CLICKOMANIA AKA SAME GAME

Caution: very addictive!

' Clickomania.bas SmallBASIC 0.12.8 [B+=MGA] 2016-12-16
' translated from JB plug-in of DE6 (QB environment setup B+=MGA)
' translated from QB code by tsh, may 2003

'mods to tsh code for DE6 plug-in
'0 800 x 600 screen aligns better with locate and print text
'1 flipped x,y array from y,x (col, row) listing
'2 no view port
'3 mouse input instead of keys for up/down/left/right
'4 scrapped stack, push and pop in favor of recursive sweep

'SB mods, mainly adapted to whatever xmax and ymax are but
'worked out on a screen wider than high (landscape).
'Works fine without splash and less columns (w)

const h = 15 'board column height
const w = 20 'board number of coulmns
const nCol = 4 'number of colors to collapse on board
const s = 40 'side of a colored square
const xo = (xmax - s * w)/2 - s 'left edge of board
const yo = (ymax - s * h)/2 - s/2 'top edge of board
const xol = xo + (s + 1) * w + s/2 'right edge of board
const yol = yo + (s + 1) * h + s/2 'bottom edge of board
xs = int(w / 2) '
ys = int(h / 2) 'selected position (move)
dim a(w, h)

splash
fillArray
showField
pen on
while aMove()
cheese = catchMouseWithCheese()
'detected click and updated xs, ys?
if cheese then
sweepZeros xs, ys
crackDown
redrawField
delay 100 'so no 2nd click
end if
wend
showResult
pause

func
catchMouseWithCheese()
local pX, pY, bX, bY
'cheese = signal 1 if xs, ys updated with neighbor else 0
if pen(3) then
pX = pen(4) : pY = pen(5) : delay 60 'avoid fast loops around and double click
'now check the board if even in the board
if xo <= pX and pX <= xol and yo <= pY and pY <= yol then 'in board
'which square?
bX = int((pX - xo)/s) 'x offset square size is s, board is base 1
bY = int((pY - yo)/s) 'y offset size still is s, board is base 1
'now that we have the board x,y we wont get foul called if we check array a(bX, bY)
if hasN(bX, bY) <> 0 then 'say cheese!
cheese = 1 : xs = bX : ys = bY 'reset xs, ys for processing
else
cheese = 0
end if
else
cheese = 0
end if ' click in board
else
cheese = 0
end if 'pen 3
catchMouseWithCheese = cheese
end

sub
crackDown 'remove 0's between blocks,
'down first, then to left if empty
local x, p, y, c
for x = 1 to w
p = h
for y = h to 1 step -1 'move cols down
if a(x, y) <> 0 then
a(x, p) = a(x, y)
p = p - 1
end if
next
'and fill "moved" place with 0's ?
for y = p to 1 step -1
a(x, y) = 0
next
next
'now compact to the left
for x = w - 1 to 1 step -1
cEmpty = 1
for y = 1 TO h
if a(x, y) <> 0 then cEmpty = 0
next
if cEmpty = 1 then ' move right stuff to the left
for c = x + 1 to w
for y = 1 to h
a(c - 1, y) = a(c, y)
next
next
for y = 1 to h 'add empty last columm
a(w, y) = 0
next
end if
next
end

sub
fillArray 'load game board of colors
local x, y
for y = 1 to h
for x = 1 to w
a(x, y) = int(rnd * nCol) + 5
next
next
end

func
hasN(x, y) 'neighbors of same color?
local c, t
c = a(x, y)
if c = 0 then hasNeighbours = 0 : exit func
if y > 1 then
if a(x, y - 1) = c then t = 1
end if
if x > 1 then
if a(x-1, y) = c then t = 1
end if
if x < w then
if a(x+1, y) = c then t = 1
end if
if y < h then
if a(x, y + 1) = c then t = 1
end if
hasN = t
end

func
aMove() 'can a move be made?
local x, y, t
t = 0
for y = 1 to h
for x = 1 to w
t = t + hasN(x, y)
next
next
if t > 0 then aMove = 1 else aMove = 0
end


sub
redrawField
local x, y
for y = 1 to h
for x = 1 to w
color a(x, y), 0
rect x*s + xo, y*s + yo, (x + 1)*s + xo, (y + 1)*s + yo filled
color 0, 0
rect x*s + xo, y*s + yo, (x + 1)*s + xo, (y + 1)*s + yo
next
next
end

sub
showField
local x, y
color 8, 0
cls
for x = 0 to xmax step 40
color rgb(x/xmax*100+80, 0, 0)
line 0, 0, x, ymax
line xmax, ymax, xmax - x, 0
next
line 0, 0, xmax, ymax
for y = 0 to ymax step 40
color rgb(y/ymax*100+80, 0, 0)
line 0, 0, xmax, y
line xmax, ymax, 0, ymax - y
next
color 9, 0
cp 2, "C L I C K O M A N I A"
color 15, 0
redrawField
end

sub
showResult ' count pieces left
local x, y, tot, mess
tot = 0
for y = 1 to h
for x = 1 to w
if a(x, y) <> 0 then tot = tot + 1
next
next
mess = "Game ending with " + str(tot) + " blocks left."
color 15, 0
cp 12, mess
end

sub
splash
color 9, 0
cp 8, " C L I C K O M A N I A "
color 12, 0
cp 11, "Translated to SmallBASIC by [B+=MGA] 2016-12-16"
cp 13, "from Just Basic DE6 (QB like environment) plug-in module"
color 7, 0
cp 15, "based on CLICKOMANIA version for QB by tsh, may 2003"
color 10, 0
cp 22, "press any..."
pause
end

sub
sweepZeros(c, r) ' recursive sweep
local colr 'a(c, r) must have neighbors coming in
colr = a(c, r)
if colr = 0 then exit sub
if hasN(c, r) then 'don't change a(c,r)=0 until check hasN
a(c, r) = 0
if c-1 > 0 then
if a(c-1, r) = colr then sweepZeros c-1, r
end if
if c+1 < w+1 then
if a(c+1, r) = colr then sweepZeros c+1, r
end if
if r-1 > 0 then
if a(c, r-1) = colr then sweepZeros c, r-1
end if
if r+1 < h+1 then
if a(c, r+1) = colr then sweepZeros c, r+1
end if
else
a(c, r) = 0 'tsh fix!
end if
end

sub
cp(row, text)
at (xmax - txtw(text))/2, (row-1)*ymax/txth(text) : ? text
end