2000-04-22 01:12

'' Here's a quick hack of the good 'ol columns game.
'' It's not quite playable, yet. It will only check for vertical matches.

     DECLARE SUB Paint
     DECLARE SUB PaintNextGem

     CONST False = 0
     CONST True = 1
     CONST NumFieldX = 6
     CONST NumFieldY = 13

     TYPE GemType
      Color1 AS INTEGER
      Color2 AS INTEGER
      Color3 AS INTEGER
     END TYPE

     DIM Form AS QFORM
     DIM Field AS QCANVAS, NextField AS QCANVAS
     DIM Timer1 AS QTIMER
     DIM X AS INTEGER, Y AS INTEGER
     DIM Interval AS INTEGER
     DIM Grid(-2 TO NumFieldY+1, 1 TO NumFieldX) AS INTEGER
     DIM Colours(1 TO 7) AS INTEGER
     DIM Gem AS GemType, NextGem AS GemType

'' NOTE: If you're using 256 colors as your default Windows display,
''       Try modifying these values, they may not display correctly.

     Colours(1) = &HFF0000  '' Blue
     Colours(2) = &H00FF00  '' Green
     Colours(3) = &H0000FF  '' Red
     Colours(4) = &HFF00FF  '' Purple
     Colours(5) = &H30FFFF  '' Yellow
     Colours(6) = &HFFFF30  '' Cyan
     Colours(7) = &H2099FF  '' Orange

     SUB ChooseNextGem
      NextGem.Color1 = Colours(RND(7) + 1)
      NextGem.Color2 = Colours(RND(7) + 1)
      NextGem.Color3 = Colours(RND(7) + 1)
     END SUB

     SUB ChooseGem
      Gem.Color1 = NextGem.Color1
      Gem.Color2 = NextGem.Color2
      Gem.Color3 = NextGem.Color3
      ChooseNextGem
      PaintNextGem
     END SUB

     SUB InitGrid
      FOR I = -2 TO NumFieldY+1
       FOR J = 1 TO NumFieldX
        Grid(I, J) = 0
       NEXT
      NEXT
     END SUB

     FUNCTION MatchVertical (GridX AS INTEGER) AS INTEGER
'' Checks for vertical matches relative to GridX

      MatchVertical = False
      Correct = Grid(-2, GridX)
      IF Correct = 0 THEN
       Correct = -1
      END IF
      Match = 0
      StartMatch = 0

      FOR Y1 = -2 TO NumFieldY              '' Simple up/down search
       IF Grid(Y1, GridX) = Correct THEN
        IF Match = 0 THEN
         StartMatch = Y1
        END IF
        Match = Match + 1
       ELSE                                '' Not correctly matching
        IF Match < 3 THEN
         Match = 1
         StartMatch = Y1
         Correct = Grid(Y1, GridX)
         IF Correct = 0 THEN
          Correct = -1
         END IF
        ELSE
         GOSUB VertMatched
         EXIT FUNCTION
'        Match = 1
'        StartMatch = Y1
'        Correct = Grid(Y1, GridX)
'        IF Correct = 0 THEN
'          Correct = -1
'        END IF
        END IF
       END IF
      NEXT
      IF Match > 2 THEN
       GOSUB VertMatched
      END IF
      EXIT FUNCTION

VertMatched:
      FOR I = StartMatch TO StartMatch + Match - 1
       Grid(I, GridX) = -1
       Field.Paint((GridX-1)*20+5,(I-1)*20+18, 0, &HFFFFFF)
      NEXT
      FOR I = StartMatch+Match-1 TO -2+Match STEP -1
       Grid(I, GridX) = Grid(I-Match, GridX)
      NEXT
      FOR I = -2+Match TO -2 STEP -1
       Grid(I, GridX) = 0
      NEXT
      Paint
      MatchVertical = True
      RETURN
     END FUNCTION

     FUNCTION MatchHorizontal (GridY AS INTEGER) AS INTEGER
'' Checks for horizontal matches relative to GridY

      MatchHorizontal = False
      Correct = Grid(GridY, 1)
      IF Correct = 0 THEN
       Correct = -1
      END IF
      Match = 0
      StartMatch = 0

      FOR X1 = 1 TO NumFieldX              '' Simple up/down search
       IF Grid(GridY, X1) = Correct THEN
        IF Match = 0 THEN
         StartMatch = X1
        END IF
        Match = Match + 1
       ELSE                                '' Not correctly matching
        IF Match < 3 THEN
         Match = 1
         StartMatch = X1
         Correct = Grid(GridY, X1)
         IF Correct = 0 THEN
          Correct = -1
         END IF
        ELSE
         GOSUB HorzMatched
         EXIT FUNCTION
'        Match = 1
'        StartMatch = Y1
'        Correct = Grid(Y1, GridX)
'        IF Correct = 0 THEN
'          Correct = -1
'        END IF
        END IF
       END IF
      NEXT
      IF Match > 2 THEN
       GOSUB HorzMatched
      END IF
      EXIT FUNCTION

HorzMatched:
      FOR I = StartMatch TO StartMatch + Match-1
       Grid(GridY, I) = 0
       Field.Paint((I-1)*20+5,(GridY-1)*20+18, 0, &HFFFFFF)
      NEXT
      FOR I = GridY TO -1 STEP -1
       FOR J = StartMatch TO Match+StartMatch -1
        SWAP Grid(I, J), Grid(I-1, J)
       NEXT
      NEXT
'    FOR I = -2+Match TO -2 STEP -1
'      Grid(GridY, I) = 0
'    NEXT
      Paint
      MatchHorizontal = True
      RETURN
     END FUNCTION

     SUB DrawGem
      Field.Rectangle(X,Y,X+20,Y+20,&HFFFFFF)
      Field.Paint(X+5,Y+18, Gem.Color1, &HFFFFFF)
      Field.Rectangle(X,Y+20,X+20,Y+40,&HFFFFFF)
      Field.Paint(X+5,Y+38, Gem.Color2, &HFFFFFF)
      Field.Rectangle(X,Y+40,X+20,Y+60,&HFFFFFF)
      Field.Paint(X+5,Y+58, Gem.Color3, &HFFFFFF)
     END SUB

     SUB Timer1Over
      IF (Y MOD 20 = 0) AND Grid(Y/20+4, X/20+1) <> 0 THEN
       Grid(Y / 20+3, X / 20+1) = Gem.Color3
       Grid(Y / 20+2, X / 20+1) = Gem.Color2
       Grid(Y / 20+1, X / 20+1) = Gem.Color1
       MatchVertical(X/20+1)
       MatchHorizontal(Y/20+3)
       MatchHorizontal(Y/20+2)
       MatchHorizontal(Y/20+1)
       IF Grid(0, X/20+1) <> 0 THEN
        Timer1.Enabled = False
        SHOWMESSAGE("Game Over")
       ELSE
        Y = -50
        X = 40
        ChooseGem
       END IF
      ELSE
       IF Y < 20*(NumFieldY-3) THEN
        Field.Rectangle(X,Y,X+20,Y+60, 0)
        Field.Paint(X+5,Y+55, 0, 0)
        Y = Y + 10
       ELSE
        Grid(Y / 20+3, X / 20+1) = Gem.Color3
        Grid(Y / 20+2, X / 20+1) = Gem.Color2
        Grid(Y / 20+1, X / 20+1) = Gem.Color1
        MatchVertical(X/20+1)
        MatchHorizontal(Y/20+3)
        MatchHorizontal(Y/20+2)
        MatchHorizontal(Y/20+1)
        Y = -50
        X = 40
        ChooseGem
       END IF
      END IF

      Timer1.Interval = Interval
      DrawGem
     END SUB

     SUB KeyDown (Key AS BYTE, Shift AS INTEGER)
      SELECT CASE Key
      CASE 27    '' ESC
       Form.CLOSE
      CASE IS = 37 AND X > 0   '' Left
       IF Grid(INT((Y-10)/20)+4, X/20) = 0 THEN
        Field.Rectangle(X,Y,X+20,Y+60, 0)
        Field.Paint(X+5,Y+55, 0, 0)
        X=X-20
        DrawGem
       END IF
      CASE 38    '' Up
       Field.Rectangle(X,Y,X+20,Y+60, 0)
       Field.Paint(X+5,Y+55, 0, 0)
       C = Gem.Color1
       Gem.Color1 = Gem.Color3
       Gem.Color3 = Gem.Color2
       Gem.Color2 = C
       DrawGem
      CASE IS = 39 AND X < 20*(NumFieldX-1)   '' Right
       IF Grid(INT((Y-10)/20)+4, X/20+2) = 0 THEN
        Field.Rectangle(X,Y,X+20,Y+60, 0)
        Field.Paint(X+5,Y+55, 0, 0)
        X=X+20
        DrawGem
       END IF
      CASE IS = 40 AND Y < 20*(NumFieldY-3)   '' Down
       Timer1Over
'      Field.Get(0,0,100,100)
'      Field.Put(0,0,100,100,2)
      END SELECT
     END SUB

     SUB Paint
  '' Whenever the form gets hidden, we have to repaint the form once
  '' it's visible again.

'  Field.Rectangle(0,0,NumFieldX*20,NumFieldY*20,3)
'  Field.Paint (10,10,0,0)
      FOR I = 0 TO NumFieldY * 20 STEP 20
       FOR J = 0 TO NumFieldX*20 STEP 20
        IF Grid(I/20+1,J/20+1) <> 0 THEN
         Field.Rectangle(J,I,J+20,I+20,&HFFFFFF)
         Field.Paint(J+5,I+18, Grid(I/20+1,J/20+1), &HFFFFFF)
        ELSE
         Field.Rectangle(J,I,J+20,I+20,0)
         Field.Paint(J+5,I+18, 0, 0)
        END IF
       NEXT
      NEXT
     END SUB

     SUB PaintNextGem
      NextField.Paint (1,1,0,0)
      NextField.Rectangle(5,5,25,25,&HFFFFFF)
      NextField.Paint(10,10, NextGem.Color1, &HFFFFFF)
      NextField.Rectangle(5,25,25,45,&HFFFFFF)
      NextField.Paint(10,30, NextGem.Color2, &HFFFFFF)
      NextField.Rectangle(5,45,25,65,&HFFFFFF)
      NextField.Paint(10,50, NextGem.Color3, &HFFFFFF)
     END SUB

     Form.Center
     Form.ClientWidth = NumFieldX * 20 + 100
     Form.ClientHeight = NumFieldY * 20

     Interval = 300
     Y = -50
     X = 40
     InitGrid

     Field.PARENT = Form
     Field.COLOR = 0
     Field.Width = NumFieldX * 20
     Field.Height = NumFieldY * 20
     Field.OnPaint = Paint

     NextField.PARENT = Form
     NextField.COLOR = 0
     NextField.Left = Field.Width + 20
     NExtField.Top = 20
     NextField.Width = 30
     NextField.Height = 20*4-10
     NextField.OnPaint = PaintNextGem

     RANDOMIZE

     ChooseNextGem
     ChooseGem

     Timer1.Interval = Interval
     Timer1.OnTimer = Timer1Over

     Form.CAPTION = "Columns Game"
     Form.OnKeyDown = KeyDown
     Form.SHOWMODAL

2000-04-22 01:12