Sliding Blocks Puzzle

[B+]

I remember H.M.M. Hermang, a fan of YaBasic. Here is a translation of his Sliding Blocks Puzzle code to SB (dropping the image handling and alphabet blocks parts):

Code: [Select]

' 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 <enter>  for a 3X3 Puzzle)"
PRINT "(or   press 0 <enter>    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 rtn<size+1 and rtn>0 then bx=rtn else bx=0
end

func by(my)
   rtn=int((my-tly)/sq+1)
   if rtn<size+1 and rtn>0 then by=rtn else by=0
end

Here is that code cut to 40 lines:

Code: [Select]


' Classic Sliding Blocks Puzzle.bas  SmallBASIC 0.12.8 [B+=MGA] 2016-12-28
WHILE size < 3 OR size > 9
    PRINT "Sliding Block Puzzle": INPUT "Enter your number of blocks per side 3-9"; s
  size = int(val(s)) : if size = 0 then end
wend
color 15, 9 : rect 0, 0, xmax, ymax, 0 filled 'cls but not with back color
dim board(size, size)
for r = 1 to size : for c = 1 to size : board(c, r) = c + (r - 1) * size : next : next
board(size, size) = 0 : c0 = size : r0 = size
for i = 0 to 50 * size * size                               ' mix blocks
    select case mid("lrud", int(rnd * 4) + 1, 1)
    case "l" : if c0 + 1 <= size then board(c0, r0) = board(c0+1, r0) : board(c0+1, r0) = 0 : c0 = c0+1
    case "r" : if c0 - 1 > 0     then board(c0, r0) = board(c0-1, r0) : board(c0-1, r0) = 0 : c0 = c0-1
    case "u" : if r0 + 1 <= size then board(c0, r0) = board(c0, r0+1) : board(c0, r0+1) = 0 : r0 = r0+1
    case "d" : if r0 - 1 > 0     then board(c0, r0) = board(c0, r0-1) : board(c0, r0-1) = 0 : r0 = r0-1
    end select
next
pen on
while not solved
  solved = 1
  for r = 1 to size : for c = 1 to size
    if board(c, r) then
      if board(c, r) <> (r-1)*size + (c-1) mod size + 1 then solved=0
      rect (c-1) * 60, (r - 1) * 60, c * 60, r * 60, 9 filled
      rect (c-1) * 60, (r - 1) * 60, c * 60, r * 60, 15
      at (c - 1) * 60 + 20, (r - 1) * 60 + 20 : ? board(c, r)
    else
      rect (c-1) * 60+1, (r - 1) * 60+1, c * 60-2, r * 60-1, 0 filled
    end if
  next : next
  if pen(3) and solved = 0 then
    mx = pen(4) : my = pen(5) : delay 50
    bx = int(mx / 60) + 1 : by = int(my / 60) + 1
    if bx = c0 + 1 and by = r0 then board(c0, r0) = board(c0+1, r0) : board(c0+1, r0) = 0 : c0 = c0+1
    if bx = c0 - 1 and by = r0 then board(c0, r0) = board(c0-1, r0) : board(c0-1, r0) = 0 : c0 = c0-1
    if bx = c0 and by = r0 + 1 then board(c0, r0) = board(c0, r0+1) : board(c0, r0+1) = 0 : r0 = r0+1
    if bx = c0 and by = r0 - 1 then board(c0, r0) = board(c0, r0-1) : board(c0, r0-1) = 0 : r0 = r0-1
  end if
wend
pen off : color 15, 0 : at 50, size * 60 + 40 : ? "Solved!": delay 5000


[Galileo]

Other solution in Yabasic.

Code: [Select]

board$ = "123456789ABCDEF0"
solve$ = board$
pos = 16
 
sub print_board()
    local i, n$
   
    clear screen
    for i = 1 to len(board$)
        if i = pos then
            print "   ";
        else
            n$ = str$(dec(mid$(board$, i, 1)), "###")
            print n$;
        end if
        if mod(i, 4) = 0 print
    next
    print
end sub
 
sub move(d)
    local new_pos, delta(4)
   
    delta(1) = 4 : delta(2) = 1 : delta(3) = -1 : delta(4) = -4
   
    new_pos = pos + delta(d)
    if new_pos >= 1 and new_pos <= 16 and (mod(pos, 4) = mod(new_pos, 4) or floor((pos - 1) / 4) = floor((new_pos - 1) / 4)) then
        mid$(board$, pos, 1) = mid$(board$, new_pos, 1)
        mid$(board$, new_pos, 1) = "0"
        pos = new_pos
    end if
end sub
 
for i = 1 to 100 : move(int(ran(4))+1) : next
do
    print_board()
    if board$ = solve$ print "solve!" : break
    c = ((instr("esc  up   left rightdown ", inkey$) - 1) / 5)
    if c < 1 break
    move(c)
loop

[B+]

Not bad! Here is translation to QB64:

Code: [Select]

_TITLE "Sliding Blocks B+ mod Galileo 2019-01-25 Retro post"
DIM SHARED delta(4)
delta(1) = 4: delta(2) = 1: delta(3) = -1: delta(4) = -4
DIM SHARED board$, hole
board$ = "123456789ABCDEF0": solve$ = board$: hole = 16
FOR i = 1 TO 100: move INT(RND * 4 + 1): NEXT
DO
    print_board
    IF board$ = solve$ THEN LOCATE 8, 4: PRINT "solved!": EXIT DO
    INPUT " u for up, l for left, r for right, d for down "; l$
    c = INSTR("ulrd", l$): IF c > 0 AND c < 5 THEN move (c)
LOOP
SUB print_board ()
    CLS: LOCATE 2, 1: PRINT " ";
    FOR i = 1 TO LEN(board$)
        IF i = hole THEN PRINT "    "; ELSE n$ = RIGHT$("  " + STR$(VAL("&H" + MID$(board$, i, 1))) + " ", 4): PRINT n$;
        IF i MOD 4 = 0 THEN PRINT: PRINT " ";
    NEXT
    PRINT
END SUB
SUB move (d)
    newHole = hole + delta(d)
    IF newHole >= 1 AND newHole <= 16 AND (hole MOD 4 = newHole MOD 4) OR INT((hole - 1) / 4) = INT((newHole - 1) / 4) THEN
        MID$(board$, hole, 1) = MID$(board$, newHole, 1): MID$(board$, newHole, 1) = "0": hole = newHole
    END IF
END SUB


[Rick3137]

 Nice work Mark. Your small basic version works fine.

[B+]

Hi Rick,

Did I know you've worked in SmallBASIC? Have you programmed anything with it's editor?

I have to say, Galileo's handling of Sliding Blocks had some interesting ideas specially for making the move.

[Rick3137]

 I have not done much with Small Basic at this time.
 
 … a few small graphics examples. Maybe some day I will get inspired.

[Galileo]

...
I have to say, Galileo's handling of Sliding Blocks had some interesting ideas specially for making the move.

It's not my code. It is a porting of the Phix language code published on the Rosetta Code website.