'===========================================================================
' Subject: BLOCKS (PUZZLE GAME) W/MOUSE      Date: 02-07-99 (20:59)       
' Author:  Antoni Gual                       Code: QB, PDS                
' Origin:  agual@eic.ictnet.es             Packet: GAMES.ABC
'===========================================================================
DECLARE SUB CopyStatus (fm%, too%)
DECLARE SUB InfoScreen ()
DECLARE FUNCTION MovesLeft% ()
DECLARE SUB Undo ()
DECLARE SUB BlockClicked (row AS INTEGER, col AS INTEGER)
DECLARE SUB RedrawScreen ()
DECLARE SUB NewLandscape (nivel%)
DECLARE SUB MoveCursWKbd (fil%, col%, mov$)
DECLARE SUB MarkForDelete (fil%, col%, res%, carac$)
DECLARE SUB Delay (i%)
DECLARE SUB DeleteBlocks (fil%, col%)

DEFINT A-Z
OPTION BASE 1


' Define the type needed for INTERUPTX
'
TYPE regtypex
	  ax    AS INTEGER
	  bx    AS INTEGER
	  cx    AS INTEGER
	  dx    AS INTEGER
	  bp    AS INTEGER
	  si    AS INTEGER
	  di    AS INTEGER
	  flags AS INTEGER
	  ds    AS INTEGER
	  es    AS INTEGER
END TYPE
DECLARE SUB INTERRUPTX (intnum AS INTEGER, inreg AS regtypex, outreg AS regtypex)
DECLARE SUB mouse (subfnct AS INTEGER, reg AS regtypex)
'
' Call a routine at an absolute address.
' NOTE: If the routine called takes parameters, then they will have to
'       be added to this declare statement before the parameter given.
'



CONST mouinit = 0
CONST moushow = 1
CONST mouhide = 2
CONST mougetpos = 3
CONST mousetpos = 4
CONST moubtnprs = 5
CONST moubtnrls = 6
CONST mouxlim = 7
CONST mouylim = 8
CONST mougrcurs = 9
CONST moutxcurs = 10

CONST LastCol = 39                          'dimensions of the playground
CONST MaxRow = 22

CONST BaseCar = 64
CLEAR , , 10000                             'as there's a recursive routine
											'save space for stack

DIM SHARED maxcol, Score AS INTEGER

CONST CharToDelete = "*"
DIM SHARED block(LastCol + 1, 3) AS STRING
DIM SHARED regis AS regtypex
InfoScreen

SCREEN 13

DO
   RANDOMIZE TIMER
   COLOR 7: CLS
   maxcol = LastCol
  
   nivel = 1                                 'level
   DO
	INPUT "Level 0-11 (1)"; nivel
   LOOP UNTIL nivel >= 0 AND nivel <= 11
   CLS
   mouse mouini, regis
   IF regis.ax = 0 THEN PRINT "No mouse: no game": END
  
   NewLandscape (nivel)                      'init landscape
   row = 1: col = maxcol / 2                 'init mouse
   mouse moushow, regis
   DO                                        'game loop
		RedrawScreen
					
		DO
		   mouse moubtnprs, regis
		LOOP UNTIL (regis.ax AND 1)          'wait for a mouse click
					  
		row = 23 - (regis.dx - 3) / 8        'convert mouse coord to block coord
		col = (regis.cx - 4) / 16 + 1
				
		IF row = -1 THEN                     'keyword clicked
		   IF col < 18 AND col > 9 THEN
			   EXIT DO
		   ELSEIF col > 19 AND col < 28 THEN
			   Undo
		   END IF
		ELSE
		   BlockClicked row, col              'process block clicked
		END IF
		moremoves = MovesLeft%
		
   LOOP UNTIL Score = 0 OR moremoves = 0
   RedrawScreen
   mouse mouhide, regis
   IF moremoves = 0 THEN LOCATE 24, 1: PRINT "No more moves available"; : a$ = INPUT$(1)
   CLS
   COLOR 15
   INPUT "Another Game? Y/N"; a$
   IF UCASE$(a$) = "N" THEN EXIT DO
LOOP

SUB BlockClicked (row AS INTEGER, col AS INTEGER)
   
	IF col > maxcol THEN EXIT SUB
	IF row > LEN(block(col, 1)) THEN EXIT SUB
	IF row < 1 THEN EXIT SUB
	CopyStatus 1, 2
   
	carac$ = MID$(block(col, 1), row, 1): res = 0
	MarkForDelete row, col, res, carac$
	
	IF res = 1 THEN
	   'if only a block found, invalid move, reset block   
	   res = 0: MID$(block(col, 1), row, 1) = carac$
	ELSE
	   'valid move, proceed
	   RedrawScreen
		  Delay 1
	   DeleteBlocks row, col
	END IF

END SUB

SUB CopyStatus (fm, too)
	i = 1
	DO WHILE i <= LastCol
		block(i, too) = block(i, fm)
		i = i + 1
	LOOP

END SUB

SUB Delay (i)
tmp! = TIMER
DO
LOOP UNTIL TIMER > tmp! + i
END SUB

SUB DeleteBlocks (row, col)
	 FOR i = 1 TO maxcol
		 j = 1
		 DO
			IF MID$(block(i, 1), j, 1) = CharToDelete THEN
			   block(i, 1) = LEFT$(block(i, 1), j - 1) + MID$(block(i, 1), j + 1)
			   
			ELSE
			   j = j + 1
			END IF
		 LOOP UNTIL j > LEN(block(i, 1))
	 
	 NEXT
	 FOR i = maxcol TO 1 STEP -1
	  IF LEN(block(i, 1)) = 0 THEN
			   FOR j = i TO LastCol
				  block(j, 1) = block(j + 1, 1)
			   NEXT
			   maxcol = maxcol - 1
			   
		END IF
		 
	NEXT
END SUB

SUB InfoScreen
screen12: CLS
COLOR 14
PRINT " ---------------------- B L O C K S ---------------------------"
COLOR 7
PRINT "Well, I called it blocks but it has another name I don't remember"
PRINT "I found this game in a Cover CD for MacIntosh. Don't remember the author"
PRINT "I simply figured out how was it coded and did it in Quick Basic"
PRINT
PRINT "The original game had beautiful bitmap graphics and a lot of options,"
PRINT "My use of characters instead of bitmaps is only a proof of my laziness."
PRINT
PRINT "You must simply delete blocks by clicking on them until there's no one left."
PRINT "You can only delete a block if it's contiguous to another of the same color."
PRINT "Not so silly...."
PRINT
PRINT "agual@eic.ictnet.es"
PRINT

PRINT "Press any key To continue"
a$ = INPUT$(1)
DO
LOOP UNTIL INKEY$ = ""
END SUB

SUB MarkForDelete (row, col, res, carac$) 'marks blocks to delete, recursive
   'STOP
   res = res + 1
   MID$(block(col, 1), row, 1) = CharToDelete
   IF row > 1 THEN
	  IF MID$(block(col, 1), row - 1, 1) = carac$ THEN MarkForDelete row - 1, col, res, carac$
   END IF
   IF row < MaxRow THEN
	  IF MID$(block(col, 1), row + 1, 1) = carac$ THEN MarkForDelete row + 1, col, res, carac$
   END IF
   IF col > 1 THEN
	 IF MID$(block(col - 1, 1), row, 1) = carac$ THEN MarkForDelete row, col - 1, res, carac$
   END IF
   IF col < maxcol THEN
	  IF MID$(block(col + 1, 1), row, 1) = carac$ THEN MarkForDelete row, col + 1, res, carac$
   END IF
	 
END SUB

DEFSNG A-Z
SUB mouse (subfnct AS INTEGER, reg AS regtypex)
reg.ax = subfnct
CALL INTERRUPTX(&H33, reg, reg)
END SUB

DEFINT A-Z
SUB MoveCursWKbd (row, col, mov$)
   SELECT CASE mov$
   CASE "R"
	  IF row < MaxRow THEN row = row + 1
   CASE "B"
	  IF row > 1 THEN row = row - 1
   CASE "I"
	  IF col > 1 THEN col = col - 1
   CASE "D"
	  IF col < maxcol THEN col = col + 1
   END SELECT
   LOCATE 26 - row, col, 1
END SUB

FUNCTION MovesLeft%
 CopyStatus 1, 3
 FOR i = 1 TO maxcol
	FOR j = 1 TO LEN(block(i, 1))
		carac$ = MID$(block(i, 1), j, 1): res = 0
		MarkForDelete j, i, res, carac$
		IF res > 1 THEN GOTO LoopOut
		res = 0: MID$(block(i, 1), j, 1) = carac$
	NEXT
 NEXT

LoopOut:
CopyStatus 3, 1
MovesLeft% = res
END FUNCTION

SUB NewLandscape (nivel)
   FOR i = 1 TO maxcol
	  block(i, 1) = ""
	  alto = RND * (MaxRow - 1) + 1
	  FOR j = 1 TO alto
		   block(i, 1) = block(i, 1) + CHR$(BaseCar + RND * (3 + nivel))
	  NEXT
   NEXT
   CopyStatus 1, 2
END SUB

SUB RedrawScreen
   CONST posy = 24
   'hide mouse
   mouse mouhide, regis
  
   FOR i = 1 TO maxcol
	  FOR j = 1 TO LEN(block(i, 1))
		 c$ = MID$(block(i, 1), j, 1)
		 LOCATE posy - j, i, 0:
		 IF c$ = CharToDelete THEN COLOR 15 ELSE COLOR ASC(c$) - BaseCar + 1
		 PRINT c$;
	  NEXT
	  'empty the rest of the col to the top of screen
	  FOR j = LEN(block(i, 1)) + 1 TO MaxRow
		 LOCATE posy - j, i, 0: COLOR 7: PRINT " ";
	  NEXT
   NEXT
   'make sure the empty cols at right are really empty
   FOR i = maxcol + 1 TO LastCol
	  FOR j = 1 TO 23
		 LOCATE posy - j, i, 0: COLOR 7: PRINT " ";
	  NEXT
   NEXT
  
   'recalc and display score
   Score = 0
   FOR i = 1 TO maxcol
	Score = Score + LEN(block(i, 1))
   NEXT
   LOCATE 25, 1: COLOR 15: PRINT Score;
   COLOR 15: LOCATE 25, 10: PRINT "quit       redo   ";
   'show mouse
   mouse moushow, regis
   
END SUB

SUB Undo
	  CopyStatus 2, 1
	  RedrawScreen
END SUB