Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Binary game

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

  • PBWin/PBCC Binary game

    The following game is similar to a game I tried in a puzzle book quite some time ago.
    The solution to the puzzle will not have more than two characters the same successively in any row or column and all rows and columns will have 5 of each character.
    Playing the game- Click on an empty box and a '0' will appear in it, a second click will remove the '0' and place a '1' in the box and a third click will empty the box so you can do it again.
    The buttons:
    NEW GAME - selects rows and columns to match the above specifications and can take a few seconds(I've waited about 7 at the longest). It places 30 of the characters in their respective slots to start the game.
    CLEAR - removes the user entered characters to restart the same game
    CHECK - checks to see that an entered character matches the character specified in the overlay array. If the character matches, it is left untouched, otherwise the box is emptied.
    SOLVE - fills all empty boxes with the appropriate character from the overlay array. Check can be used to make any corrections to the previously entered characters.

    There may be more than one solution for each layout.
    Code:
    #COMPILE EXE
    #DIM ALL
    #IF %DEF(%PB_CC32)  ' if to be compiled with PBCC6 or PBCC5, then
      #CONSOLE OFF      ' this example doesn't need the console window
    #ENDIF
    '#RESOURCE ICON, 7423, "C:\PBWin10\iconsFC\UNTITLED21.ico"
    MACRO when=IF
    MACRO just=THEN
    FUNCTION PBMAIN () AS LONG
      LOCAL gWin, fnt, fnt1, tw, th, bw, bh, ndx, clk, x, y, xx, yy, elem, inc AS LONG
      LOCAL tallycnt, longcnt, toomany, first, last, rand AS LONG
      LOCAL pic, temp, keep, t, cpic AS STRING
      LOCAL baux() AS LONG       '0 has "0";1 has "1" ; -1 is empty ""; 2- protected "0"; 3-protected "1"
      LOCAL prntpos(), cpp() AS POINT
      LOCAL posn() AS LONG
      LOCAL inbaux(), char(), src(), srcb(), grp(), ovrly() AS STRING
      DIM grp(1 TO 10), posn(1 TO 25), cpp(1 TO 100), ovrly(1 TO 100)
      DIM baux(1 TO 100), prntpos(1 TO 100), inbaux(1 TO 100), char(-1 TO 3), src(1 TO 84), srcb(1 TO 84)
      char(-1)=" " :char(0)="0" :char(1)="1" :char(2)="0" :char(3)="1"
      RANDOMIZE TIMER
      FONT NEW "Lucida Console", 16, 0 TO fnt
      FONT NEW "Lucida Console", 8, 0 TO fnt1
      GRAPHIC WINDOW NEW "", 100,100,305,300 TO gWin
    '  DIALOG SET ICON gwin,"#7423"
      GRAPHIC SET FONT fnt1
      GRAPHIC SET OVERLAP 1
      GRAPHIC CLEAR %WHITE
      GRAPHIC TEXT SIZE "A" TO tw, th
    
      GRAPHIC WIDTH 3
      GRAPHIC BOX (260,25)-(325,55),100, %BLACK, RGB(054,055,052)   ' 'New Game' button
      GRAPHIC COLOR %WHITE,-2
      GRAPHIC SET POS (273, 28)
      GRAPHIC PRINT "New"
      GRAPHIC SET POS (270,41)
      GRAPHIC PRINT "Game"
    
      GRAPHIC BOX (260,60)-(325,90),100, %BLACK, RGB(054,055,052)   ' 'Clear' button
      GRAPHIC COLOR %WHITE,-2
      GRAPHIC SET POS (266, 69)
      GRAPHIC PRINT "Clear"
    
      GRAPHIC BOX (260,95)-(325,125),100, %BLACK, RGB(054,055,052)  ' 'Check' button
      GRAPHIC COLOR %WHITE,-2
      GRAPHIC SET POS (266, 104)
      GRAPHIC PRINT "Check"
    
      GRAPHIC BOX (260,130)-(325,160),100, %BLACK, RGB(054,055,052)  ' 'Solve' button
      GRAPHIC COLOR %WHITE,-2
      GRAPHIC SET POS (266, 139)
      GRAPHIC PRINT "Solve"
      GRAPHIC WIDTH 1
      GRAPHIC SET FONT fnt
      GRAPHIC TEXT SIZE "A" TO tw, th
      GRAPHIC WIDTH 2                           ' the red x box in the top right corner
      GRAPHIC BOX (285, 0)-(304,19), 0, %RED, -2
      GRAPHIC LINE (285,0)-(304,19), %RED
      GRAPHIC LINE (285,19)-(304,0), %RED
      GRAPHIC WIDTH 1
      GRAPHIC COLOR %BLACK, -2
      bw=(tw+10)
      bh=(th+5)
      FOR ndx=23 TO 260 STEP 23
        GRAPHIC LINE (ndx,23)-(ndx,272), %GRAY
      NEXT ndx
      FOR ndx=23 TO 273 STEP 25
        GRAPHIC LINE (23,ndx)-(253,ndx), %GRAY
      NEXT ndx
      GRAPHIC GET BITS TO pic
      FOR y=25 TO 250 STEP 25      ' fill the baux() and Prntpos() arrays
        FOR x=27 TO 250 STEP 23
          GRAPHIC SET POS (x,y)
          GRAPHIC PRINT "0"
          xx=CEIL((x-23)/23)
          yy=CEIL((y-23)/25)
          elem= (yy-1)*10+xx
          baux(elem)=-1
          prntpos(elem).x=x
          prntpos(elem).y=y
        NEXT x
      NEXT y
      GRAPHIC SET BITS pic
      DO
        #IF %DEF(%PB_CC32)
          SLEEP 1
        #ELSE
          DIALOG DOEVENTS
        #ENDIF
        GRAPHIC WINDOW CLICK TO clk, x, y
        IF ISTRUE clk THEN
          IF x>284 AND y<20 THEN
            EXIT LOOP
          END IF
          IF x>22 AND x<254 AND y>22 AND y<274 THEN
            xx=CEIL((x-23)/23)
            yy=CEIL((y-23)/25)
            elem= (yy-1)*10+xx
            GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
            IF baux(elem)=-1 THEN                  'first click on empty cell 'x'   puts a '0'
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC BOX (prntpos(elem).x,prntpos(elem).y)-(prntpos(elem).x+tw,prntpos(elem).y+th), 0,%WHITE,%WHITE
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC PRINT char(0)
              baux(elem)=0
              inbaux(elem)=char(0)
            ELSEIF baux(elem)=0 THEN               'second click on cell 'x'   puts a '1'
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC BOX (prntpos(elem).x,prntpos(elem).y)-(prntpos(elem).x+tw,prntpos(elem).y+th), 0,%WHITE,%WHITE
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC PRINT char(1)
              baux(elem)=1
              inbaux(elem)=char(1)
            ELSEIF baux(elem)=1 THEN               'third click on cell 'x'    puts a ' '
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC BOX (prntpos(elem).x,prntpos(elem).y)-(prntpos(elem).x+tw,prntpos(elem).y+th), 0,%WHITE,%WHITE
              GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
              GRAPHIC PRINT char(-1)
              baux(elem)=-1
              inbaux(elem)=char(-1)
            END IF
          END IF
          SELECT CASE y
          CASE 25 TO 55
            IF x>259 THEN GOSUB new_game
          CASE 60 TO 90
            IF x>259 THEN GOSUB clear_it
          CASE 95 TO 125
            IF x>259 THEN GOSUB check_it
          CASE 130 TO 160
            IF x>259 THEN GOSUB solve_it
          END SELECT
        END IF
      LOOP
      GOTO tuktoyaktuk
    new_game:
    
      FOR ndx=1 TO 100
        baux(ndx)=-1
      NEXT ndx
       GRAPHIC SET BITS pic
      longcnt=0
      keep=""
      FOR ndx=0 TO 1023     'find all available 10 digit only 2 successive and 5 of each.
        temp=BIN$(ndx,10)
        tallycnt=TALLY(temp, "0")
        IF tallycnt<>5 THEN
          ITERATE FOR
        ELSE
          toomany=0
          toomany= INSTR(temp, "000")
          when toomany just ITERATE FOR
          toomany=0
          toomany=  INSTR(temp,"111")
          when toomany just ITERATE FOR
          keep+=temp+" "
          INCR longcnt
          src(longcnt)=temp
          IF longcnt=1 THEN       ' not required, just checking values of the selectable strings
            first=VAL("&B"+temp)   '155
          ELSEIF longcnt=84 THEN
            last =VAL("&B"+temp)   '868
          END IF
          IF longcnt/4=longcnt\4 THEN
            keep+=$CRLF
          END IF
        END IF
      NEXT ndx
      again:
      FOR ndx=1 TO 84
        srcb(ndx)=src(ndx)
      NEXT ndx
      last =84
      FOR ndx=1 TO 10      'get 10 of the 84 possibles
        rand=RND(1, last)
        grp(ndx)=srcb(rand)
        SWAP srcb(rand), srcb(last)
        DECR last
      NEXT ndx
      FOR inc=1 TO 10     ' check the vertical column for the same 2 successive 5 of each
        temp=""
        FOR ndx=1 TO 10
          temp+= MID$(grp(ndx),inc,1)
        NEXT ndx
        toomany=0
        toomany= INSTR(temp, "000")
        when toomany just EXIT FOR
        toomany=  INSTR(temp,"111")
        when toomany just EXIT FOR
      NEXT inc
      when toomany just GOTO again
      temp=""
      first=0
      FOR ndx=1 TO 10      ' load the ovrly array
        temp+=grp(ndx)+$CRLF
        FOR inc=1 TO 10
          INCR first
          ovrly(first)=MID$(grp(ndx),inc,1)
        NEXT inc
      NEXT ndx
      last=100
      FOR ndx=1 TO 30
        redo:
        rand=RND(1, last)
        IF baux(rand)=-1 THEN
          GRAPHIC SET POS (prntpos(rand).x,prntpos(rand).y)
          t=ovrly(rand)
          IF t="0" THEN
            baux(rand)=2
          ELSE
            baux(rand)=3
          END IF
          GRAPHIC PRINT t
        ELSE
          GOTO redo
        END IF
      NEXT ndx
      GRAPHIC GET BITS TO cpic
    
    RETURN
    clear_it:
    
      FOR ndx=1 TO 100
        IF baux(ndx)<2 THEN
          baux(ndx)=-1
        END IF
      NEXT ndx
      GRAPHIC SET BITS cpic
    
    RETURN
    check_it:
    
      IF inbaux(elem)<> ovrly(elem) THEN
        GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
        GRAPHIC BOX (prntpos(elem).x,prntpos(elem).y)-(prntpos(elem).x+tw,prntpos(elem).y+th), 0,%WHITE,%WHITE
        GRAPHIC SET POS (prntpos(elem).x,prntpos(elem).y)
        GRAPHIC PRINT char(-1)
        baux(elem)=-1
        inbaux(elem)=char(-1)
      END IF
    
    RETURN
    solve_it:
    
      FOR ndx=1 TO 100
        IF baux(ndx)=-1 THEN
          GRAPHIC SET POS (prntpos(ndx).x,prntpos(ndx).y)
          GRAPHIC PRINT ovrly(ndx)
        END IF
      NEXT ndx
    
    RETURN
    
    tuktoyaktuk:
      GRAPHIC WINDOW END
    END FUNCTION
    Click image for larger version

Name:	binary_game.gif
Views:	1
Size:	6.3 KB
ID:	775878
    Rod
    "To every unsung hero in the universe
    To those who roam the skies and those who roam the earth
    To all good men of reason may they never thirst " - from "Heaven Help the Devil" by G. Lightfoot
Working...
X