User:MagistraMundi/sandbox

rem Program for creating fractals by imposing
rem restrictions on the chaos game
mode12
*FONT Lucida Console,11
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

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);
    ifl<hi print;", ";elseprint;" \x"
  nextl
  forl=1tohi
    print;test(l);
    ifl<hi print;", ";elseprint;" zX"
    iftest(l)=1tsti(l)=1elsetsti(l)=-1
  nextl
  casefunc of
    when1print;"match = ";m;
  endcase
  print;" (d/f)"
  rr=r
else
  rr=r*1.3
endif
th=pi2/v
ifv<>4thi=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<2000andy>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"ifhi<himx hi+=1
  when"3"ifm>0m-=1
  when"4"m+=1
  when"5"ifinc>0inc-=1
  when"6"inc+=1
  when"d"iffunc>1func-=1
  when"f"iffunc<funcmx func+=1
  when"g"ifa>1a-=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)ifvi<vimx vi+=1
  whenchr$(138)ifv>3v-=1
  whenchr$(139)ifv<vmx v+=1
  when"q"quit
  otherwisenew=false
endcase
endproc