SyntaxBomb  Indie Coders
Languages & Coding => SmallBASIC => Topic started by: jsalai on July 20, 2021, 14:06:39

A completely useless program. Today is the International Chess Day, 20th of July.
in fact a program written about 2017... and because I never comment my programs, please, don't ask me how it works.
It heavily use both static, dynamic and nested arrays.
' Knight tour  hibrid algo  jsalai  thanks to all who may think
' there are parts of their work(s)!
' Initially the problem of the Chess Knight on Chess Board 8x8,1,1
'Warnsdorff's rule, 1823. For 5  9 square boards there are
'1,728;6637920;165575218320;19591828170979904 solutions, respective
'This program finds only one  a hybrid algorithm thanks for many  and me...
'I could use recursion, but that would significantly slow down the work
'for bigger boards.
'the minimal are 3x7(7x3) or 4x5(5x4)  not for all starting points
'but you may try boards up to 50x50,1,1 (if your display supports it
' worked fine on my android phone). On a PC it may go up to 150x90 or even more
'depending on memory size and/display.
'If the program stucks, it try to undo the moves until it finds a solution
'using dynamic nested arrays...
'Sometimes it get stuck near to end then it may take a long tine to get back
'In such cases you may try with <Esc> and another starting point (eg 60x60,3,3)
'
'Note: when it starts to display, all the work is already done!
'
sub quit
cls
?"Interrupted! Press Enter"
pause
goto start
end
definekey 27, quit
label start
color 15,0
while 1
cls
input "Boardwidth(x):",x0
if x0=0 then end
input "Boardheight(y):",y0
if y0=0 then y0=x0
z1=xmax\(x0+1)
z2=ymax\(y0+1)
z=iff(min(z1,z2)<50,min(z1,z2),50)
input "xStart[1"+x0+"]:",x
input "yStart[1"+y0+"]:",y
x=iff(x>0,x1,0)
y=iff(y>0,y1,0)
nn=x0*y0
n=0
dim b(x01,y01),u
dx=[1,2,1,2,2,1,1,2]
dy=[2,1,2,1,1,2,2,1]
dim w
while n<nn
n++
b(x,y)=n
dim u
for q=0 to 7
xc=x+dx(q)
yc=y+dy(q)
if xc>=0 && yc>=0 && xc<x0 && yc<y0 && !b(xc,yc)
if n=nn1
b(xc,yc)=n+1
displ
exit loop
else
nm=0
for r=0 to 7
xt=xc+dx(r)
yt=yc+dy(r)
b(xc,yc)=1
if xt>=0 && yt>=0 && xt<x0 && yt<y0 && !b(xt,yt) then nm++
b(xc,yc)=0
next
if nm
u << [n+1,nm,xc,yc]
fi
fi
fi
next
if len(u)
sort u
for i=ubound(u) to 0 step 1
if u(i)(1)>u(0)(1) then delete u,i
next
x=u(0)(2)
y=u(0)(3)
delete u,0
if len(u)
w << u
fi
else
if len(w)
u=w(ubound(w))
delete w,ubound(w)
while n>=u(0)(0)
c=(n in b)1
x=c\y0
y=c%y0
b(x,y)=0
n
wend
x=u(0)(2)
y=u(0)(3)
delete u,0
if len(u)
w << u
fi
else
?"No solution!"
exit loop
fi
fi
wend
wend
stop
sub displ
cls
dim v
for i=0 to y0
line z,i*z+z,x0*z+z,i*z+z
next
for i=0 to x0
line i*z+z,z,i*z+z,y0*z+z
next
for n=1 to nn
c=(n in b)1
x=c\y0+1
y=c%y0+1
if n=1
xx=x
yy=y
fi
xd=xxx
yd=yyy
v << chr(x+64)+y
rect z*x+z\4,z*(y0y+1)+z\4,step z\2,z\2,5 filled
circle (x+0.5)*z,(y0y+1.5)*z,2 filled
if n>1
line (x+0.5)*z,(y0y+1.5)*z,step xd*z,yd*z
fi
delay 30
xx=x
yy=y
next
pause
locate ((y0+2)*z)\txth("A"),0
?v
pause
?b
pause
end

Ha  that's pretty cool. With a few changes to make it run in a loop, it looks like some weird machine.

Ha  that's pretty cool. With a few changes to make it run in a loop, it looks like some weird machine.
Thanks!
If you find it worth, you may include it to repository...
About the loop... It was my intention, but as for some starting poits it may be a pain to wait for a solution.
eg: 60x60,1,1 stucks around 2760/3600 (if I remember well), but with 60x60,3,3 it start practically instant.
so I left it to the user to interrupt the process and choose some other starting point.
I have some variants of the program which find ALL solutions but, as you may see, it may work ONLY for small boards (not necessary square), because of enormous number of solutions:
'Warnsdorff's rule, 1823. For 5  9 square boards there are
'1,728;6637920;165575218320;19591828170979904 solutions, respective
Thanks for your kind attention!

I think this one even nicer than one I saw recently in QB64 that blew my version away! :)

Here an adaptation of recursive ccode, that finds ALL solutions for specified boards.
In this example shown the 3x10 board with 6096 solutions, and 960 "closed" solutions.
Closed means that the knight may close the cycle jumping to the initial field.
It finds all soutions of any board, but beware, for some boards (eg normal 8x8) it takes a kind of an eternity.
Of course, the numbers are not exact, as there are lots of solutions which are symmetrical transformations of some previous. I don't want to perform such analyses.
I could make loops for only half of hor and vert, but for square boards it would not suffice, bcs eg:
a1b3 could produce a symetry to a1c2 so I left them all shown...
As the task is anyway useless, I don't expect anyone to try to make an improvement...
x0=3:y0=10:mm=x0*y0:zz=0:color 15,0
xm=[2,1,1,2,2,1,1,2]:ym=[1,2,2,1,1,2,2,1]
open x0+"x"+y0+".txt" for output as #1
for i=0 to x01
for j=0 to y01
dim s(x01,y01)
sol(i,j,1,s)
next
next
?"Done":close #1:pause
end
sub sol(x,y,m,@s)
local k,xn,yn
s(x,y)=m
if m=mm
c0=(1 in s)1:cm=(mm in s)1:p0=c0\y0:q0=c0%y0:pm=cm\y0:qm=cm%y0
ss=iff(((abs(pmp0)=1) && (abs(qmq0)=2))  ((abs(pmp0)=2) && (abs(qmq0)=1)),"closed","")
zz++:?zz;s;ss:?#1,zz;s;ss
s(x,y)=0
exit sub
fi
for k=0 to 7
xn=x+xm(k):yn=y+ym(k)
if xn>=0 && xn<x0 && yn>=0 && yn<y0 && !s(xn,yn)
sol(xn,yn,m+1,s)
fi
next
s(x,y)=0
end sub

Same as above, except it shows all CLOSED solutions graphically.
The display.bas is easy to adapt to show ALL solutions from the saved file
knight_rec.bas
w=10:h=3:n=w*h:z=0:color 15,0
u=[2,1,1,2,2,1,1,2]:v=[1,2,2,1,1,2,2,1]
open w+"x"+h+".txt" for output as #1
for i=0 to w1:for j=0 to h1
dim s(w1,h1):sol(i,j,1)
next:next
?"Done":close #1:pause
end
include display.bas
sub sol(x,y,m)
local k,xn,yn
s(x,y)=m
if m=n
a=(1 in s)1:b=(n in s)1
p=abs(a\hb\h):q=abs(a%hb%h)
t=iff(p+q=3 && abs(pq)=1,"closed","")
if len(t) then displ(w,h,s):pause 3
z++:?#1,z;s;t
s(x,y)=0
exit sub
fi
for k=0 to 7
xn=x+u(k):yn=y+v(k)
if xn>=0 && xn<w && yn>=0 && yn<h && !s(xn,yn)
sol(xn,yn,m+1)
fi
next
s(x,y)=0
end sub
display.bas
sub displ(w,h,@s)
local a,b,c,d,e,f,g,i,n,p,q,x,y,z
cls:a=xmax\(w+1):b=ymax\(h+1):z=min(a,b):n=w*h
a=(xmaxz*w)\2:b=(ymaxz*h)\2:d=a+z\4:e=(h1)*z+b+z\4
for i=0 to h:line a,i*z+b,w*z+a,i*z+b:next
for i=0 to w:line i*z+a,b,i*z+a,h*z+b:next
for i=1 to n
c=(i in s)1
x=d+(c\h)*z:f=x+z\4:y=e(c%h)*z:g=y+z\4
if i=1 then p=x:q=y
rect x,y,step z\2,z\2,4+(i=n)(i=1) filled
circle f,g,z\8 filled
if i>1 then line f,g,step x+p,y+q
delay 30:p=x:q=y
next
end sub
Unfortunately, another NEW BUG emerged:
when
include display.bas
is at the end, ie. AFTER the sol(...) subroutine
we got an error message:
Undefined SUB/FUNC CODE: SOL
On the beginning, or at the place where it is, all works well