Knight Tour

Started by jsalai, July 20, 2021, 14:06:39

Previous topic - Next topic

jsalai

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 "Board-width(x):",x0
  if x0=0 then end
  input "Board-height(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 "x-Start[1-"+x0+"]:",x
  input "y-Start[1-"+y0+"]:",y
  x=iff(x>0,x-1,0)
  y=iff(y>0,y-1,0)
  nn=x0*y0
  n=0
  dim b(x0-1,y0-1),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=nn-1
          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=x-xx
    yd=y-yy
    v << chr(x+64)+y
    rect z*x+z\4,z*(y0-y+1)+z\4,step z\2,z\2,5 filled
    circle (x+0.5)*z,(y0-y+1.5)*z,2 filled
    if n>1
      line (x+0.5)*z,(y0-y+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

I won't belong to any organization that would have people like me as members.
[Groucho Marx]

chrisws

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

jsalai

#2
Quote from: chrisws on July 21, 2021, 11:52:23
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:

Quote'Warnsdorff's rule, 1823. For 5 - 9 square boards there are
'1,728;6637920;165575218320;19591828170979904 solutions, respective

Thanks for your kind attention!
I won't belong to any organization that would have people like me as members.
[Groucho Marx]

bplus

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

jsalai

#4
Here an adaptation of recursive c-code, 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:
a1-b3 could produce a symetry to a1-c2 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 x0-1
  for j=0 to y0-1
    dim s(x0-1,y0-1)
    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(pm-p0)=1) && (abs(qm-q0)=2)) || ((abs(pm-p0)=2) && (abs(qm-q0)=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
I won't belong to any organization that would have people like me as members.
[Groucho Marx]

jsalai

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 w-1:for j=0 to h-1
  dim s(w-1,h-1):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\h-b\h):q=abs(a%h-b%h)
    t=iff(p+q=3 && abs(p-q)=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=(xmax-z*w)\2:b=(ymax-z*h)\2:d=a+z\4:e=(h-1)*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
I won't belong to any organization that would have people like me as members.
[Groucho Marx]