'http://justbasic.conforums.com/index.cgi?board=shared&action=display&num=1293772964
'*** Blockola.Jb - Blockola in JustBasic ***

NOMAINWIN
 
GLOBAL kXmax, kYmax, kUndoMax  '* Maximum block grid size *
kUndoMax = 10  '* 10 Undo levels *

'* Setup for 10 x 10 field *
'kXmax = 10 : kYmax = 10
'WindowWidth = 280 : WindowHeight = 380
'GRAPHICBOX #bo.Fld, 10, 10, 250, 250
'STATICTEXT #bo.st, "", 100, 270, 100, 30
'BUTTON #bo.bQuit, "Quit", [Done], UL, 10, 300, 40, 30
'BUTTON #bo.bNew, "New", [Redo], UL, 80, 300, 40, 30
'BUTTON #bo.bUndo, "Undo", [Undo], UL, 160, 300, 40, 30
'BUTTON #bo.bHelp, "Help", [Help], UL, 230, 300, 40, 30
  '* Add "Over" button *

'* Setup for 15 x 15 field *
kXmax = 15 : kYmax = 15
WindowWidth = 400 : WindowHeight = 510
GRAPHICBOX #bo.Fld, 10, 10, 375, 375
STATICTEXT #bo.st, "", 160, 400, 100, 30
BUTTON #bo.bQuit, "Quit", [Done], UL, 10, 430, 40, 30
BUTTON #bo.bNew, "New", [Redo], UL, 120, 430, 40, 30
BUTTON #bo.bUndo, "Undo", [Undo], UL, 230, 430, 40, 30
BUTTON #bo.bHelp, "Help", [Help], UL, 340, 430, 40, 30
 
dim Blk(kXmax+1, kYmax+1), Undo(kXmax*(kUndoMax+1), kYmax)
dim Org(kXmax, kYmax), UnScore(kUndoMax), Tmp(kXmax, kYmax)
dim C$(5)  '* Color names *

C$(0)="BLACK" : C$(1)="BLUE" : C$(2)="GREEN"
C$(3)="CYAN" : C$(4)="RED" : C$(5)="YELLOW"
 
randomize time$("seconds")/86402
 
UpperLeftX = (DisplayWidth - WindowWidth) / 2
UpperLeftY = (DisplayHeight - WindowHeight) / 2
 
open "Blockola!!" for window as #bo
#bo "trapclose [Done]"
#bo.Fld "when leftButtonUp [Play]"
#bo.Fld "fill ";C$(0)
 
[Redo]
UndoCnt = 0 : UnScore(0) = 0 : Score = 0
#bo.Fld "cls"
for x = 1 to kXmax  '* Load Block array *
  for y = 1 to kYmax
    Blk(x,y) = val(using("#",int(rnd(0)*5))) + 1
    Org(x,y) = Blk(x,y)
  next y
next x
call ReDrawBlocks
#bo.st, "Score: ";Score
wait
 
[Play]
  x = int(MouseX / 25) + 1  '* Get Block array coords from Mouse *
  y = kYmax - int(MouseY / 25)
  Tmp = Blk(x,y)  '* Save color of original block *
  if Tmp > 0 then  '* If not "empty" block *
    for a = 1 to kXmax  '* Save Block array state *
      for b = 1 to kYmax : Tmp(a,b) = Blk(a,b) : next b
    next a
    Cnt = 0
    call CheckBlocks x, y, Blk(x,y), Cnt  '* Count connected blocks *
    if Cnt > 1 then  '* Clicked a pair or more of connected blocks *
      call CompactBlocks
      if UndoCnt = kUndoMax then  '* Shift down saved blocks *
        UndoCnt = kUndoMax - 1
        for a = 0 to UndoCnt*kXmax
          for b = 1 to kYmax : Undo(a,b) = Undo(a+kXmax,b) : next b
        next a
        for a = 0 to UndoCnt : UnScore(a) = UnScore(a+1) : next
      end if
      UndoPtr = UndoCnt*kXmax
      for a = 1 to kXmax  '* Save Undo array *
        for b = 1 to kYmax : Undo(UndoPtr+a,b) = Tmp(a,b) : next b
      next a
      UnScore(UndoCnt) = Score
      UndoCnt = UndoCnt + 1
 
      for a = 2 to Cnt : Score = Score + a : next  '* Calc Score *
      #bo.st, "Score: ";Score  '* And update screen *
      if Blk(1,1) = 0 then  '* Removed all blocks *
        playwave "blk_win.wav"
        NOTICE "Congratulations!"
      else
        Rtn = ScanForPlay()
        if Rtn = 0 then  '* No moves remaining *
          Cnt = 0 : Penalty = 0
          for x = 1 to kXmax
            for y = 1 to kYmax
              if Blk(x,y) > 0 then Cnt = Cnt + 1
            next y
          next x
          for a = 2 to Cnt : Penalty = Penalty + a : next
          #bo.st, "Final Score: ";Score - Penalty
          NOTICE "Blockola!"+chr$(13)+"Too bad - No plays left"+_
            chr$(13)+"  Raw Score: "; Score;_
            chr$(13)+"    Penalty: "; Penalty;_
            chr$(13)+"Final Score: "; Score - Penalty
        else  '* Update Undo stack *
        end if
      end if
    else
      Blk(x,y) = Tmp  '* Restore color to single clicked block *
    end if
  end if
  wait
 
[Undo]
  if UndoCnt > 0 then
    UndoCnt = UndoCnt - 1
    UndoPtr = UndoCnt * kXmax
    for a = 1 to kXmax  '* Restore array *
      for b = 1 to kYmax : Blk(a,b) = Undo(UndoPtr+a,b) : next b
    next a
    Score = UnScore(UndoCnt)
    call ReDrawBlocks
    #bo.st, "Score: ";Score
    playwave "blk_undo.wav"
  end if
  wait
 
[Help]
  NOTICE "How to Play"+chr$(13)+_
    "Click a block with the same colored block next to it to remove"+chr$(13)+_
    "the block from the playing field.  The more blocks removed in"+chr$(13)+_
    "a play, the higher your score."+chr$(13)+chr$(13)+_
    "Code is placed in the public domain."
  wait
 
[Done]
#bo.Fld "when leftButtonUp"
#bo.Fld, "cls"
CLOSE #bo
 
END
 
'======================================================================
'*** See if there is a Play left ***
'======================================================================
FUNCTION ScanForPlay()
  for x = 1 to kXmax
    for y = 1 to kYmax
      if Blk(x,y) > 0 then
        if (Blk(x,y) = Blk(x+1,y) or Blk(x,y) = Blk(x,y+1)) then
          Tmp = 1 : exit for  '* Can still play *
        end if
      else
        exit for  '* Blk()=0 is no more blocks in column *
      end if
    next y
    if Tmp = 1 then exit for
  next x
  ScanForPlay = Tmp
END FUNCTION
 
'======================================================================
'*** Remove/Compress TempCode Blocks, Y first, then X ***
'======================================================================
SUB CompactBlocks
  for x = 1 to kXmax  '* Clear flagged blocks *
    Tmp = 0
    for y = 1 to kYmax
      if Blk(x,y) = 255 then
        Blk(x,y) = 0 : Tmp = 1
      else
        if Blk(x,y) > 0 and Tmp = 1 then VPop = 1
      end if
    next y
  next x
  call ReDrawBlocks  '* Draw blocks before compressing *
  for x = 1 to kXmax  '* Compress columns *
    y = 1
    DO
      if Blk(x,y) = 0 then
        Sum = 0
        for z = y to kYmax
          Blk(x,z) = Blk(x,z+1)  '* And shift in extra blank row *
          Sum = Sum + Blk(x,z)
        next z
        if Sum = 0 then exit do  '* Only moved empty blocks *
      else
        y = y + 1
      end if
    LOOP until y > kYmax
  next x
  call ReDrawBlocks
  if VPop then playwave "blk_clk.wav" else playwave "blk_whsh.wav"
  x = 1
  DO
    if Blk(x,1) = 0 then  '* Empty column - Shift columns left *
      if Blk(x+1,1) > 0 then HPop = 1
      Tmp = 1  '* Flag to re-draw field *
      Sum = 0
      for z = x to kXmax  '* And shift in extra blank column *
        for y = 1 to kYmax
          Blk(z,y) = Blk(z+1,y) : Sum = Sum + Blk(z,y)
        next y
      next z
      if Sum = 0 then exit do  '* Only moved empty columns *
    else
      x = x + 1
    end if
  LOOP until x > kXmax
  if Tmp = 1 then
    if HPop then playwave "blk_clk.wav"
    call ReDrawBlocks
  end if
 
END SUB
 
'======================================================================
'*** Draw the Playing Field ***
'======================================================================
SUB ReDrawBlocks
  #bo.Fld "down"
  Ytmp = (kYmax*25) - 25  '** 225
  for y = 1 to kYmax  '* 1 is bottom Row, kYmax is top *
    Xtmp = 0
    for x = 1 to kXmax
      if Blk(x,y) > 0 then  '* Draw a beveled block *
        #bo.Fld "color white"
        #bo.Fld "line ";Xtmp;" ";Ytmp;" ";Xtmp;" ";Ytmp+24  '* Left *
        #bo.Fld "line ";Xtmp+1;" ";Ytmp+1;" ";Xtmp+1;" ";Ytmp+23
        #bo.Fld "line ";Xtmp;" ";Ytmp;" ";Xtmp+24;" ";Ytmp  '* Top *
        #bo.Fld "line ";Xtmp+1;" ";Ytmp+1;" ";Xtmp+23;" ";Ytmp+1
        #bo.Fld "color darkgray"
        #bo.Fld "line ";Xtmp+24;" ";Ytmp;" ";Xtmp+24;" ";Ytmp+24  '* Right *
        #bo.Fld "line ";Xtmp+23;" ";Ytmp+1;" ";Xtmp+23;" ";Ytmp+23
        #bo.Fld "line ";Xtmp;" ";Ytmp+23;" ";Xtmp+24;" ";Ytmp+23  '* Bottom *
        #bo.Fld "line ";Xtmp+1;" ";Ytmp+24;" ";Xtmp+23;" ";Ytmp+24
        #bo.Fld "color ";C$(Blk(x,y));" ; backcolor ";C$(Blk(x,y))
        #bo.Fld "place ";Xtmp+2;" ";Ytmp+2;" ; boxfilled ";Xtmp+22;" ";Ytmp+22
      else  '* Draw a black square *
        #bo.Fld "color ";C$(Blk(x,y));" ; backcolor ";C$(Blk(x,y))
        #bo.Fld "place ";Xtmp;" ";Ytmp;" ; boxfilled ";Xtmp+25;" ";Ytmp+25
      end if
      Xtmp = Xtmp + 25
    next x
    Ytmp = Ytmp - 25
  next y
  #bo.Fld "up"
  #bo.Fld "flush BlkSeg"
  #bo.Fld "delsegment "; BlkSeg-1
END SUB
 
'======================================================================
'*** Recursive Scan for Neighbor Blocks of Same Color ***
'======================================================================
SUB CheckBlocks X, Y, Hue, BYREF Cnt
  if Blk(X,Y) = Hue then
    Blk(X,Y) = 255  '* Set to "matched" color *
    Cnt = Cnt + 1
    if X > 1 then call CheckBlocks X-1, Y, Hue, Cnt
    if X < kXmax then call CheckBlocks X+1, Y, Hue, Cnt
    if Y > 1 then call CheckBlocks X, Y-1, Hue, Cnt
    if Y < kYmax then call CheckBlocks X, Y+1, Hue, Cnt
  end if
END SUB