2000-05-17 18:14

     DECLARE SUB MarkForDelete(col,row,carac$,subst$)
     DECLARE SUB paint
     DECLARE SUB blockclick
     DECLARE SUB deletesel(inicol)
     DECLARE SUB killcol(y)
     DECLARE SUB restart
     DECLARE SUB AppEnd
     DECLARE SUB cntrupdate
     DECLARE SUB msgabout
     CONST width =25
     CONST height=22
     CONST unit=20
     CONST vertoffs=height*unit
     CONST horoffs=width*unit
     CONST level=5   'change it
     $INCLUDE "rapidq.inc"
     REDIM a (1 TO width) AS STRING
     DIM res AS WORD
     DIM colours(8) AS LONG

     colours(0) = &h000000 '' black
     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
     colours(8) = &hffffff  '' white
     CREATE myfont AS QFONT
      name="Verdana"
      size=20
     END CREATE

     CREATE Form AS QFORM
      CAPTION = "Blocks"
      ClientWidth = unit*width+100
      ClientHeight = unit*(height+1)
      Center
      Borderstyle=bssingle
      onshow=restart
      CREATE MENU AS QMAINMENU
       CREATE mOpt AS QMENUITEM
        CAPTION="Options"
        CREATE mNew AS QMENUITEM
         CAPTION="New game"
         onclick=restart
        END CREATE
        CREATE  mExit AS QMENUITEM
         CAPTION="Exit Game"
         onclick=AppEnd
        END CREATE
       END CREATE
       CREATE mAbout AS QMENUITEM
        CAPTION="About"
        onclick=Msgabout
       END CREATE
      END CREATE
      CREATE counter AS QLABEL
       top=0
       left=unit*width+5
       width=90
       height=10
       font=myfont
       alignment=tacenter
      END CREATE
      CREATE CANVAS AS QCANVAS
       width=Form.Clientwidth
       height=form.clientheight
       COLOR=colours(7)
       OnPaint = Paint
       OnMouseup=BlockClick
      END CREATE
     END CREATE

     SUB displaycol(kol)
      canvas.fillrect((kol-1)*unit,0,kol*unit,vertoffs,clappworkspace)
      IF kol<=UBOUND(a) THEN
       FOR i=1 TO LEN(a(kol))
        CANVAS.FillRect((kol-1)*unit,vertoffs-(i-1)*unit,kol* _
         unit,vertoffs-i*unit,colours(ASC(MID$(a(kol),i,1))))
       NEXT
      END IF
     END SUB

     SUB msgabout
      MESSAGEDLG("Blocks, by Antoni Gual"+CHR$(13)+"agual@eic.ictnet.es",mtcustom,mbOK,0)
     END SUB

     SUB blockclick(but,x,y,shift)
      coordx=INT(MOUSEX\unit)+1
      coordy=INT((vertoffs-MOUSEY)\unit)+1
      TXT$=STR$(coordx)+" "+STR$(coordy)
      IF coordx<=UBOUND(a) THEN
       IF LEN(a(coordx))>=coordy THEN
        res=0:prescol$=MID$(a(coordx),coordy,1)
        markfordelete(coordx,coordy,prescol$,CHR$(8))
        IF res>1 THEN
         deletesel(coordx)
        ELSE
         markfordelete(coordx,coordy,CHR$(8),prescol$)
        END IF
       END IF
      END IF
     END SUB

     SUB paint
      FOR i=1 TO width
       displaycol(i)
      NEXT
     END SUB

     SUB initstr(lev)
      FOR i=1 TO width
       a(i)=""
       FOR j = 1 TO RND(height)+1:a(i)=a(i)+CHR$(RND(lev)+1):NEXT
        displaycol(i)
       NEXT
      END SUB

      SUB deletesel(inicol)
       Col=UBOUND(a)
       WHILE col>0
        I=0:j=LEN(a(col))
        WHILE j>0
         IF MID$(a(col),j,1)=CHR$(8) THEN
          a(col)=DELETE$(a(col),j,1):INC i
         END IF
         DEC j
        WEND
        IF i THEN
         IF LEN(a(col)) THEN
          displaycol(col)
         ELSE
          killcol(col)
         END IF
        END IF
        DEC col
       WEND
       cntrupdate
      END SUB

      SUB killcol(y)
       temp=UBOUND(a)-1
       FOR k=y TO temp :SWAP a(k),a(k+1):displaycol(k):NEXT
        displaycol(temp+1)
        REDIM a(1 TO temp)AS STRING
       END SUB

       SUB MarkForDelete(col,row,carac$,subst$)
        IF carac$=subst$ THEN
         EXIT SUB
        END IF
        a(col)=REPLACE$(a(col),subst$, row):res = res + 1
        displaycol(col)

        IF row < LEN(a(col)) THEN
         IF MID$(a(col), row + 1, 1) = carac$ THEN
          MarkForDelete col,row + 1,  carac$,subst$
         END IF
        END IF
        IF row > 1 THEN
         IF MID$(a(col), row - 1, 1) = carac$ THEN
          MarkForDelete col,row - 1,  carac$,Subst$
         END IF
        END IF
        IF col < UBOUND(a) THEN
         IF MID$(a(col+1), row, 1) = carac$ THEN
          MarkForDelete col+1,row,  carac$,subst$
         END IF
        END IF
        IF col > 1 THEN
         IF MID$(a(col-1), row, 1) = carac$ THEN
          MarkForDelete col-1,row,carac$,subst$
         END IF
        END IF
       END SUB
       SUB cntrupdate
        cnt=0
        FOR i=1 TO UBOUND(a)
         cnt=cnt+LEN(a(i))
        NEXT
        counter.CAPTION=STR$(cnt)
       END SUB
       SUB restart
        RANDOMIZE
        REDIM a (1 TO width) AS STRING
        initstr(level)
        cntrupdate
       END SUB
       SUB AppEnd
        form.CLOSE
       END SUB

       Form.SHOWMODAL

2000-05-17 18:14