Classic Sliding Blocks Puzzle

I don't think the code library has a version of this yet.

' slide sq w mouse.bas (SmallBASIC) MGA/B+ 2015-07-28

rem from Sliding Blocks Puzzle Game programmed by Hermang H. M. M.
rem copied from BP.org 2015-07-26, his last changes on July 5, 2015 in YABasic.
rem 2015-07-26 simplified for SmallBASIC with Picture and Alphabet Modes removed.
rem 2015-07-27 adding TFsolved checker routine and mouse/graphics in YABasic.
rem 2015-07-28 translated again to SmallBASIC for further improvement in SmallBASIC.

MaxSize = 15
print "SLIDING BLOCKS PUZZLE"
print : print "Select Board size from 3 up to "; MaxSize
print "(ie. press 3 for a 3X3 Puzzle)
print "(or press 0 to quit)
repeat
input size
if size=0 then print"goodbye!":end
until(size>=3 and size<=MaxSize)
dim board(size+1,size+1)
th=40 'text height, max expansion in SB 11.8
tlx=40 'top left x for board
tly=2*th 'top left y for board
sq=int((ymax-4*th)/size) 'board sq size
plx=3*tlx+sq*size 'for title and text right of board
color 0,11:cls 'sets all print fore and back color, squares have to match
rect 0,0,2*tlx+sq*size,ymax,9 filled 'set board on blue left side
for i=0 to 3
rect 0,0,2*tlx+sq*size-i,ymax-i,0
next
initBoard()
mixBlocks()
showBoard()
at plx,3*th:print "SLIDING BLOCKS PUZZLE:"
at plx,4*th:print "click block or press arrow key to move block into space,"
at plx,5*th:print "press Q to quit, escape key to remix blocks"
pen on
repeat
if pen(3) then
mx=bx(pen(4))
my=by(pen(5))
if emptyRow+1=mx and emptyCol=my then doleft
if emptyRow-1=mx and emptyCol=my then doright
if emptyRow=mx and emptyCol+1=my then doup
if emptyRow=mx and emptyCol-1=my then dodown
endif
k=inkey
if len(k)=2 then
ak=asc(right(k,1))
if ak=4 then:doleft
elseif ak=5:doright
elseif ak=9:doup
elseif ak=10:dodown:endif
elseif len(k)=1
if asc(k)=27 then mixBlocks
endif
if update=1 then showBoard
if TFsolved then k="q"
until(k="q")
pen off
if
TFsolved then s="Congratulations, Puzzle Solved!" else s="Goodbye!"
at plx,10*th:print s
end

'==========procedures

sub
initBoard()
count=0
for j=0 to size+1
for i=0 to size+1
if i=0 or j=0 or i=(size+1) or j=(size+1) then
board(i,j)=-1
else
count=count+1
board(i,j)=count
endif
next
next
board(size,size)=0
emptyRow=size
emptyCol=size
end

sub
showBoard()
local x,y,c
rect tlx-1,tly-1,tlx+sq*size+2,tly+sq*size+2,0 filled
for y=1 to size
for x=1 to size
if board(x,y) then c=11 else c=0
rect tlx+sq*(x-1),tly+sq*(y-1),tlx+sq*(x-1)+sq-2,tly+sq*(y-1)+sq-2,c filled
if board(x,y) then
s=str$(board(x,y))
at tlx+sq*(x-1)+sq/2-txtw(s)/2,tly+sq*(y-1)+sq/2-txth(s)/2
print s;
endif
next
next
update=0
end

sub
mixBlocks()
repeat
for i=1 to 7*size*size
dir=1+int(rnd*4)
if dir=1 then:doleft
elseif dir=2:doright
elseif dir=3:doup
else:dodown:endif
next
until TFsolved=0
update=1
end

sub
swapp()
board(emptyRow,emptyCol)=tag
board(tr,tc)=0
emptyRow=tr
emptyCol=tc
update=1
end

sub
doleft()
tr=emptyRow+1
tc=emptyCol
tag=board(tr,tc)
if tag=-1 then exit
swapp
end

sub
doright()
tr=emptyRow-1
tc=emptyCol
tag=board(tr,tc)
if tag=-1 then exit
swapp
end

sub
dodown()
tr = emptyRow
tc = emptyCol-1
tag = board(tr,tc)
if tag=-1 then exit
swapp
end

sub
doup()
tr=emptyRow
tc=emptyCol+1
tag=board(tr,tc)
if tag=-1 then exit
swapp
end

func
TFsolved()
TFsolved=0:test=1
for j=1 to size
for i=1 to size
if board(i,j)<>0 then
if test=board(i,j) then test=test+1 else exit sub
endif
next
next
TFsolved=1
end

func
bx(mx)
rtn=int((mx-tlx)/sq+1)
if rtn0 then bx=rtn else bx=0
end

func
by(my)
rtn=int((my-tly)/sq+1)
if rtn0 then by=rtn else by=0
end