Recent Posts

Pages: [1] 2 3 ... 10
1
Code and examples / Sliding Blocks Puzzle
« Last post by B+ on 22. January 2019, 18:23:14 »
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
2
Offtopic / Re: Whatever happened to...?
« Last post by Richey on 21. January 2019, 22:35:10 »
Whatever happened to.....Herman

 :o
4
Offtopic / Re: Naalaa forum?
« Last post by Tomaaz on 19. January 2019, 21:41:25 »
Oh, that's very easy to explain. :) Paid hostings are sometimes offline for technical reasons, not because the term and conditions give the hosting provider right to suspend/delete your account at any time and for no reason. As soon as your free hosting provider can see that you have no intention to become a paying customer, it is game over.
5
Offtopic / Re: Naalaa forum?
« Last post by Aurel on 19. January 2019, 21:19:30 »
y
6
Offtopic / Re: freebasic.net off
« Last post by Tomaaz on 19. January 2019, 15:48:39 »
It's back. No need to panic. They are not using free hosting. ;D
7
SmallBASIC / 0.12.15?
« Last post by Tomaaz on 19. January 2019, 15:45:09 »
Has version 0.12.15 been released? I just build 64 bit versions from source and that's what it says.
8
Offtopic / Re: Naalaa forum?
« Last post by Tomaaz on 19. January 2019, 15:02:53 »
Quote
this is something i go freaking out
it is so called suspended damn
so i will publish it here....

No problems with mipropia hosting at all? Ha ha ha!  ;D ;D ;D
9
Offtopic / Re: mini Linux distros
« Last post by Tomaaz on 19. January 2019, 14:49:45 »
This looks even better - http://www.ubuntuce.com/   ;D
10
Offtopic / Re: mini Linux distros
« Last post by Aurel on 19. January 2019, 14:30:17 »
Oh Tomek..tomek

I understand that you probably hate Hanna because you are G(Y)Y (backSideBoy)  ;D
but i don't get it why you hate Justin (niceBisexual) boy ...  ;D ;D ;D

Anubis is up(oIIo) and running....cool distro  ;D
Pages: [1] 2 3 ... 10