User:MagistraMundi/sandbox

rem Program for creating fractals by imposing rem restrictions on the chaos game mode12 xc=900 yc=830 colour7,255,255,255 colour8,0,0,0 vmx=10 vimx=3 vmx*=vimx dimx(vmx) dimy(vmx) himx=10 dimhist(himx) dimvi(himx) dimtest(himx) dimtsti(himx) forl=1tohimx vi(l)=0 test(l)=1 nextl v=4 hi=1 a=1 b=2 vi=0 m=0 inc=0 rmx=700 r=rmx col=false ctr=false sh=true norm=false funcmx=1 func=1 pi2=pi*2 repeat procsetup procfractal ifnotnew procmenu until false
 * FONT Lucida Console,11

defprocsetup cls ifnorm gcol0elsegcol8 fillxc,yc ifsh then print;"v=";v;" (up/down/v) vi=";vi;" (<->) hi=";hi;" (1/2) m=";m;" (3/4) inc=";inc;" (5/6) "; print;"a=";a;" (g/h) b=";b;" (j/k) ctr=";ctr;" (.) col=";col;" (c) norm=";norm;" (N)" forl=1tohi print;vi(l); ifl4thi=0elsethi=pi/4 gcol7 vv=0 forl=1tov x1=xc+sin(th*l+thi)*rr y1=yc+cos(th*l+thi)*rr xj=(xc+sin(th*(l+1)+thi)*rr-x1)/(vi+1) yj=(yc+cos(th*(l+1)+thi)*rr-y1)/(vi+1) forl1=0tovi vv+=1 x(vv)=x1+xj*l1 y(vv)=y1+yj*l1 nextl1 nextl forl=1tovv l1=l+1 ifl1>vv l1=1 linefnxy(xc,x(l)),fnxy(yc,y(l)),fnxy(xc,x(l1)),fnxy(yc,y(l1)) circlefillfnxy(xc,x(l)),fnxy(yc,y(l)),10 nextl ifctr then vv+=1 x(vv)=xc y(vv)=yc circlefillxc,yc,10 endif x=xc y=yc ab=a/b forl=1tohimx hist(l)=0 nextl hi1=hi-1 new=false k=-1 endproc

defprocfractal repeat procgetxy ifx>0andx 0andy<2000then ifcol then ifpoint(x,y)<>7gcolpoint(x,y)+1 endif linex,y,x,y endif untilk>-1 endproc

defprocgetxy repeat v2=rnd(vv) k=inkey(0) untilfnok ork>-1 x+=(x(v2)-x)*ab y+=(y(v2)-y)*ab ifhi>0then ifhi1>0then forl=1tohi1 hist(l)=hist(l+1) nextl endif hist(hi)=v2 endif endproc

deffnok ifhi=0then=true mm=0 forl=1tohi iftest(l)>0then v3=v2+vi(l) ifv3>vv v3-=vv ifhist(l)=v3 mm+=tsti(l) endif nextl =mm<=m end

defprocvinc i=hi whiletest(i)=0 i-=1 endwhile vi(i)+=1 whilevi(i)>=vv andi>0 vi(i)=0 i-=1 whiletest(i)=0andi>0 i-=1 endwhile vi(i)+=1 endwhile endproc

defproctestinc test(hi)+=1 i=hi whiletest(i)>2 andi>0 test(i)=0 i-=1 test(i)+=1 endwhile endproc

deffnxy(p1,p2) =p1+(p2-p1)*1.01 end

defprocmenu ifk>-1k$=chr$(k)elsek$=get$ new=true casek$of when"1"ifhi>0hi-=1 when"2"ifhi0m-=1 when"4"m+=1 when"5"ifinc>0inc-=1 when"6"inc+=1 when"d"iffunc>1func-=1 when"f"iffunc1a-=1 when"h"a+=1 when"j"ifb>1b-=1 when"k"b+=1 when"0"r=rmx when"r"r/=1.1 when"t"r*=1.1 when"c"col=notcol when"N"norm=notnorm when"S"sh=notsh when"."ctr=notctr when"x"forl=1tohimx:vi(l)=0:nextl when"X"forl=1tohimx:test(l)=0:nextl when"\"procvinc when"z"proctestinc whenchr$(136)ifvi>0vi-=1 whenchr$(137)ifvi3v-=1 whenchr$(139)ifv<vmx v+=1 when"q"quit otherwisenew=false endcase endproc