# Fingering the Frigit

Program in BBC Basic for Fingering the Frigit.

rem Fractal using incremented array
rem Program in BBC Basic
mode12
xc=900
yc=800
colour1,255,0,0
colour7,255,255,255
vmx=10
vimx=3
dimx(vmx*vimx)
dimy(vmx*vimx)
nmx=100
dimn(nmx)
dimn1(nmx)
v=4
vi=0
rmx=500
r=rmx
a=1
b=2
bs=3
lr=true
col=true
ctr=false
sh=true
ps=false
funcmx=5
func=1
incmx=5
inc=1
ii=0
vix=1
new=true
repeat
ifnew procsetup
procfractal
until false

defprocsetup
cls
ifsh then
print;"v=";v;" (up/down/v) vi=";vi;" () a=";a;" (1/2) b=";b;" (3/4) ii=";ii;" (5/6) ";
print;"bs=";bs;" (g/h) lr=";lr;" (l) vix=";vix;" (7/8) ps=";ps;" (p) ctr=";ctr;" (.) col=";col;" (c)"
casefunc of
when1print;"Move towards points in full number";
when2print;"Move towards one digit";
when3print;"cumulative digitsum";
when4print;"digit-by-digit digitsum";
when5print;"Sum all points";
endcase
print;" (d/f)"
endif
th=pi*2/v
gcol7
vv=0
forl=1tov
x1=xc+sin(th*l)*r
y1=yc+cos(th*l)*r
xj=(xc+sin(th*(l+1))*r-x1)/(vi+1)
yj=(yc+cos(th*(l+1))*r-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
forl=1tonmx
n(l)=0
nextl
n(1)=0
ni=1
procincnum
iflr then
i=ni
ix=-1
else
i=1
ix=1
endif
x=xc
y=yc
ab=a/b
xyi=1
s=0
new=false
k=-1
endproc

defprocfractal
repeat
casefunc of
when1
forl=1toni
x+=(x(xyi)-x)*ab
y+=(y(xyi)-y)*ab
nextl
procincnum
when2
x+=(x(xyi)-x)*ab
y+=(y(xyi)-y)*ab
when3
s=0
forl=1toni
s+=n(l)
x+=(x(xyi)-x)*ab
y+=(y(xyi)-y)*ab
nextl
procincnum
when4
s+=n(i)
x+=(x(xyi)-x)*ab
y+=(y(xyi)-y)*ab
when5
xx=0
yy=0
forl=1toni
xx+=x(xyi)
yy+=y(xyi)
nextl
xx/=ni
yy/=ni
x+=(xx-x)*ab
y+=(yy-y)*ab
procincnum
endcase
ifx>0andx0andy-1ornew
endproc

xyi+=ai+ii
whilexyi>vv
xyi-=vv
endwhile
whilexyini ni=i
endproc

i+=ix
ifi=0ori>ni then
procincnum
iflr then
i=ni
ix=-1
else
i=1
ix=1
endif
endif
endproc

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

ifk>-1k\$=chr\$(k)elsek\$=get\$
new=true
casek\$of
when"1"ifa>1a-=1
when"2"a+=1
when"3"ifb>1b-=1
when"4"b+=1
when"5"ii-=1
when"6"ii+=1
when"7"ifvix>1vix-=1
when"8"vix+=1
when"d"iffunc>1func-=1
when"f"iffunc2bs-=1
when"h"bs+=1
when"0"r=rmx
when"r"r/=2
when"t"r*=2
when"a"all=notall
when"c"col=notcol
when"-"ll=notll
when"l"lr=notlr
when"s"sh=notsh
when"p"
repeat
untilget\$""
new=false
when"u"nubase=notnubase
when"."ctr=notctr
whenchr\$(136)ifvi>0vi-=1
whenchr\$(137)ifvi3v-=1
whenchr\$(139)ifv<vmx v+=1
when"q"quit
otherwisenew=false
endcase
endproc