RetroBASIC
Basicprogramming(.org) => Code and examples => Topic started by: B+ on January 22, 2019, 05:23:14 PM
-
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):
' 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:
' 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
-
Other solution in Yabasic.
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
-
Not bad! Here is translation to QB64:
_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
-
Nice work Mark. Your small basic version works fine.
-
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. :)
-
I have not done much with Small Basic at this time.
… a few small graphics examples. Maybe some day I will get inspired.
-
...
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.