XProfan

Window Title "Figuren through Superformel erzeugen"
Window Style 24:Cls rgb(0,0,0):ShowMax
var xh&=width(%hwnd)\2:var yh&=height(%hwnd)\2:randomize:font 2

Proc Superformel'supply radius(phi!,...)

    parameters phi!,Symmetrie!,shape1!,shape2!,shape3!,xHalbachse!,yHalbachse!
    casenot xHalbachse!*yHalbachse!:return 0
    var Winkel!=Symmetrie!*phi!*0.25
    'r! = (abs(cos(Winkel!)/xHalbachse!)^Form2!+abs(sin(Winkel!)/yHalbachse!)^Form3!)^(-1/shape1!)
    var co!=cos(Winkel!):var si!=sin(Winkel!)
    var r!=0:case co!<>0:r!=abs(co!/xHalbachse!)^Form2!
    case si!<>0:r!=r!+abs(sin(Winkel!)/yHalbachse!)^Form3!
    :if r!>0:r! = r!^(-1/shape1!):else r!=0:endif
    return r!

ENDPROC

Proc To_xy :parameters r!,phi!:x!=r!*cos(phi!):y!=r!*sin(phi!):endproc

    Proc rPhi :parameters x!,y!:r!=sqrt(sqr(x!)+sqr(y!)):phi!=ArcTan4(x!,y!):endproc

        Proc ArcTan4 :parameters x!,y!:var pi!=3.1415926535897932:var w!=0

            if x!=0:if y!>0:w!=pi!*0.5:elseif y!<0:w!=pi!*1.5:else :w!=0:endif :return w!:elseif x!>0

                if y!=0:w!=0:return w!:elseif y!>0:if x!>y!:w!=arctan(y!/x!):else :w!=pi!/2-arctan(x!/y!):endif

                    return w!:else :if x!<-y!:w!=pi!*1.5+arctan(x!/-y!):else :w!=2*pi!-arctan(-y!/x!):endif :return w!
                    endif :else :if y!>0:if x!>-y!:w!=pi!/2+arctan(-x!/y!):return w!:else :w!=pi!-arctan(y!/-x!)
                    return w!:endif :elseif y!<0:if x!<y!:w!=pi!+arctan(-y!/-x!):else :w!=pi!*1.5-arctan(-x!/-y!)
                    endif :return w!:else :w!=pi!:return w!:endif :endif :Print " ArcTan4 ERROR":waitinput 1e5

                endproc

                MAIN:
                var s!=100' Size
                var f!=pi()/180
                Declare x!,y!,r!,phi!,w!,n&,\
                \
                Symmetrie!,shape1!,shape2!,shape3!,xHalbachse!,yHalbachse! :var Data$=\
                "3 5 18 18 1 1 "+"6 20 7 18 1 1 "+"4 2 4 13 1 1 "+"7 2 4 17 1 1 " +\
                "7 3 6 6 1 1 "+"3 3 14 2 1 1 "+"19 9 14 11 1 1 "+"12 15 20 3 1 1 "+\
                "8 1 1 8 1 1 "+"8 1 5 8 1 1 "+"8 3 4 3 1 1 "+"8 7 8 2 1 1 "+\
                "5 2 6 6 1 1 "+"6 1 1 6 1 1 "+"6 1 7 8 1 1 "+"7 2 8 4 1 1 "+\
                "3 2 8 3 1 1 "+"3 6 6 6 1 1 "+"4 1 7 8 1 1 "+"4 4 7 7 1 1 "+\
                "2 2 2 2 1 1 "+"2 1 1 1 1 1 "+"2 1 4 8 1 1 "+"3 2 5 7 1 1"
                Declare LSymmetrie!,LForm1!,LForm2!,LForm3!,LxHalbachse!,LyHalbachse!
                Declare p!,q!,  p1!,p2!,p3!,p4!,p5!,p6!
                Nochmal:

                Whileloop 0,23:n&=&Loop

                    Symmetrie!=val(substr$(Data$,6*n&+1," "))
                    shape1!=val(substr$(Data$,6*n&+2," "))
                    shape2!=val(substr$(Data$,6*n&+3," "))
                    shape3!=val(substr$(Data$,6*n&+4," "))
                    xHalbachse!=val(substr$(Data$,6*n&+5," "))
                    yHalbachse!=val(substr$(Data$,6*n&+6," "))

                    Whileloop 200,0,-2

                        p!=&Loop/200:q!=1-p!
                        p1!=LSymmetrie!*p!+Symmetrie!*q!
                        p2!=LForm1!*p!+shape1!*q!
                        p3!=LForm2!*p!+shape2!*q!
                        p4!=LForm3!*p!+shape3!*q!
                        p5!=LxHalbachse!*p!+xHalbachse!*q!
                        p6!=LyHalbachse!*p!+yHalbachse!*q!
                        phi!=0
                        r!=Superformel(phi!,p1!,p2!,p3!,p4!,p5!,p6!)
                        To_xy(r!,phi!)
                        'cls 0:locate 1,1:print "  ";n&;" - ";&Loop;"  "
                        MCLS %maxx, %maxy, 0'$FFFFFF
                        StartPaint -1
                        Usepen 0,12,rgb(0,255,0)
                        moveto xh&+s!*x!,yh&-s!*y!

                        whileloop 0,360,3 :phi!=f!*&Loop

                            r!=Superformel(phi!,p1!,p2!,p3!,p4!,p5!,p6!)
                            To_xy(r!,phi!):Lineto xh&+s!*x!,yh&-s!*y!

                        endwhile

                        EndPaint
                        MCopyBMP 0, 0 - %maxx,%maxy > 0, 0; 0
                        '  waitinput 42

                    Endwhile

                    LSymmetrie!=Symmetrie!
                    LForm1!=shape1!
                    LForm2!=shape2!
                    LForm3!=shape3!
                    LxHalbachse!=xHalbachse!
                    LyHalbachse!=yHalbachse!
                    waitinput 1000
                    'cls 0

                Endwhile

                beep
                n&=0
                goto "Nochmal"