Show Posts

This section allows you to view all posts made by this member. Note that you can only see posts made in areas you currently have access to.

Messages - qbguy

Pages: [1]

Programs / Sudoku solver

« on: April 17, 2019, 07:15:16 pm »

Code: QB64: [Select]

DECLARE SUB UPDATEBOARD ()
DEFINT A-Z
CONST RANK = 3
CONST RANK2 = 9
CONST EDITOR = "notepad"
CONST FILE = "steps.txt"
CONST NUMBERS = "123456789"
 
DIM SHARED BLOCK(1 TO RANK2, 1 TO RANK2, 1 TO RANK2)
DIM SHARED PART(1 TO RANK2, 1 TO RANK2)
OPEN FILE FOR OUTPUT AS #1
CLS
 
DO
  PRINT "Which character would you like to use to represent blank (empty squares)? ";
  LINE INPUT BLANK$
  BLANK$ = LEFT$(LTRIM$(RTRIM$(BLANK$)), 1)
  IF BLANK$ = "" THEN BLANK$ = " "
LOOP UNTIL INSTR(NUMBERS, BLANK$) = 0
PRINT
PRINT "Enter your puzzle in plain text form.  Only numbers (1-9) and blanks have"
PRINT "significance. All other characters are ignored.  This means that the puzzle"
PRINT "may be input all on one line or with line breaks, spaces, and ASCII art to"
PRINT "mark block boundaries or beautify your input."
PRINT
NUMLEFT = 81
I = 1
J = 0
DO
  LINE INPUT LINE$
  FOR N = 1 TO LEN(LINE$)
    X$ = MID$(LINE$, N, 1)
    IF X$ = BLANK$ OR INSTR(NUMBERS, X$) THEN
      J = J + 1
      IF J > 9 THEN J = 1: I = I + 1
      PART(I, J) = INSTR(NUMBERS, X$)
      NUMLEFT = NUMLEFT - 1
    END IF
  NEXT
LOOP UNTIL NUMLEFT = 0
FOR ROW = 1 TO RANK2
  FOR COL = 1 TO RANK2
    FOR I = 1 TO RANK2
      IF PART(ROW, COL) = 0 THEN
        BLOCK(ROW, COL, I) = I
      END IF
    NEXT
  NEXT
NEXT
 
CALL UPDATEBOARD
DO
FOR ROW = 1 TO RANK2
    FOR VALL = 1 TO RANK2
      COUNT = 0
      FOR I = 1 TO RANK2
        IF BLOCK(ROW, I, VALL) = VALL THEN COUNT = COUNT + 1
      NEXT
      IF COUNT = 1 THEN
        FOR COL = 1 TO RANK2
          IF PART(ROW, COL) <> 0 THEN GOTO 2
          IF BLOCK(ROW, COL, VALL) = VALL THEN
              PART(ROW, COL) = VALL
              PRINT #1, "Only one instance of"; VALL; "in row"; ROW; "-- inserting at column"; COL
              FOR I = 1 TO RANK2
                BLOCK(ROW, COL, I) = 0
              NEXT
              CALL UPDATEBOARD
              GOTO 4
          END IF
2       NEXT
      ELSE
        BLK = -1
        FOR COL = 1 TO RANK2
          OLDBLK = BLK
          IF BLOCK(ROW, COL, VALL) = VALL THEN BLK = INT((COL - 1) / RANK)
          IF OLDBLK >= 0 AND BLK <> OLDBLK THEN GOTO 3
        NEXT
        IF BLK = -1 THEN GOTO 3
        FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
          FOR J = BLK * RANK + 1 TO BLK * RANK + RANK
            IF I <> ROW AND BLOCK(I, J, VALL) <> 0 THEN
              BLOCK(I, J, VALL) = 0
              PRINT #1, "Eliminating"; VALL; "from"; I; J; "because it must be in row"; ROW; "in same block"
            END IF
          NEXT
        NEXT
      END IF
3   NEXT
4 NEXT
FOR COL = 1 TO RANK2
    FOR VALL = 1 TO RANK2
      COUNT = 0
      FOR I = 1 TO RANK2
        IF BLOCK(I, COL, VALL) = VALL THEN COUNT = COUNT + 1
      NEXT
      IF COUNT = 1 THEN
        FOR ROW = 1 TO RANK2
          IF PART(ROW, COL) <> 0 THEN GOTO 5
          IF BLOCK(ROW, COL, VALL) = VALL THEN
            PART(ROW, COL) = VALL
            PRINT #1, "Only one instance of"; VALL; "in column"; COL; "-- inserting at row"; ROW
            FOR I = 1 TO RANK2
              BLOCK(ROW, COL, I) = 0
            NEXT
            CALL UPDATEBOARD
            GOTO 7
          END IF
5       NEXT
      ELSE
        BLK = -1
        FOR ROW = 1 TO RANK2
          OLDBLK = BLK
          IF BLOCK(ROW, COL, VALL) = VALL THEN BLK = INT((ROW - 1) / RANK)
          IF OLDBLK >= 0 AND BLK <> OLDBLK THEN GOTO 6
        NEXT
        IF BLK = -1 THEN GOTO 6
        FOR I = BLK * RANK + 1 TO BLK * RANK + RANK
          FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
            IF J <> COL AND BLOCK(I, J, VALL) <> 0 THEN
              BLOCK(I, J, VALL) = 0
              PRINT #1, "Eliminating"; VALL; "from"; I; J; "because is must be in col"; COL; "in same block"
            END IF
          NEXT
        NEXT
      END IF
6    NEXT
7 NEXT
FOR I = 0 TO RANK - 1
  FOR J = 0 TO RANK - 1
    FOR VALL = 1 TO RANK2
      COUNT = 0
      FOR K = I * RANK + 1 TO I * RANK + RANK
        FOR L = J * RANK + 1 TO J * RANK + RANK
          IF BLOCK(K, L, VALL) = VALL THEN COUNT = COUNT + 1
        NEXT
      NEXT
      IF COUNT <> 1 THEN GOTO 9
      FOR K = I * RANK + 1 TO I * RANK + RANK
        FOR L = J * RANK + 1 TO J * RANK + RANK
          IF PART(K, L) <> 0 THEN GOTO 8
          IF BLOCK(K, L, VALL) = VALL THEN
            PART(K, L) = VALL
            PRINT #1, "Only one instance of"; VALL; "in box -- inserting at row"; K; "column"; L
            FOR M = 1 TO RANK2
              BLOCK(K, L, M) = 0
            NEXT
            CALL UPDATEBOARD
            GOTO 9
          END IF
8       NEXT
      NEXT
9   NEXT
10  NEXT
NEXT
FOR ROW = 1 TO RANK2
  FOR COL = 1 TO RANK2
    IF PART(ROW, COL) <> 0 THEN GOTO 11
    COUNT = 0
    FOR VALL = 1 TO RANK2
      IF BLOCK(ROW, COL, VALL) = VALL THEN COUNT = COUNT + 1
    NEXT
    IF COUNT = 1 THEN
      FOR VALL = 1 TO RANK2
        IF BLOCK(ROW, COL, VALL) = VALL THEN
          PRINT #1, "Only"; VALL; "may be legally inserted at"; ROW; "column"; COL
          PART(ROW, COL) = VALL
          FOR I = 1 TO RANK2
            BLOCK(ROW, COL, I) = 0
          NEXT
          CALL UPDATEBOARD
          EXIT FOR
        END IF
      NEXT
    ELSEIF COUNT = 2 THEN
      FOR COL2 = 1 TO RANK2
        EXACT = -1
        FOR J = 1 TO RANK2
          IF BLOCK(ROW, COL2, J) <> BLOCK(ROW, COL, J) OR COL2 = COL THEN EXACT = 0: EXIT FOR
        NEXT
        IF EXACT THEN
          FOR I = 1 TO RANK2
            IF (I <> COL) AND (I <> COL2) THEN
              FOR J = 1 TO RANK2
                IF BLOCK(ROW, I, J) = BLOCK(ROW, COL, J) AND BLOCK(ROW, I, J) <> 0 THEN
                  PRINT #1, "Eliminating "; J; "from"; ROW; I; "b/c naked pair at"; ROW; COL; "and"; ROW; COL2
                  BLOCK(ROW, I, J) = 0
                END IF
              NEXT
            END IF
          NEXT
          EXIT FOR
        END IF
      NEXT
      FOR ROW2 = 1 TO RANK2
        EXACT = -1
        FOR J = 1 TO RANK2
          IF BLOCK(ROW2, COL, J) <> BLOCK(ROW, COL, J) OR ROW2 = ROW THEN EXACT = 0: EXIT FOR
        NEXT
        IF EXACT THEN
          FOR I = 1 TO RANK2
            IF (I <> ROW) AND (I <> ROW2) THEN
              FOR J = 1 TO RANK2
                IF BLOCK(I, COL, J) = BLOCK(ROW, COL, J) AND BLOCK(I, COL, J) <> 0 THEN
                  BLOCK(I, COL, J) = 0
                  PRINT #1, "Eliminating "; J; "from"; I; COL; "b/c naked pair at"; ROW; COL; "and"; ROW2; COL
                END IF
              NEXT
            END IF
          NEXT
          EXIT FOR
        END IF
      NEXT
      FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
        FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
          EXACT = -1
          FOR K = 1 TO RANK2
            IF (BLOCK(I, J, K) <> BLOCK(ROW, COL, K)) OR (I = ROW AND J = COL) THEN EXACT = 0: EXIT FOR
          NEXT
          IF EXACT THEN
            FOR M = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
              FOR N = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
                IF ((M <> ROW OR N <> COL) AND (M <> I OR N <> J)) THEN
                  FOR K = 1 TO RANK2
                    IF BLOCK(ROW, COL, K) = BLOCK(M, N, K) AND BLOCK(M, N, K) <> 0 THEN
                      BLOCK(M, N, K) = 0
                      PRINT #1, "Eliminating "; K; "from"; M; N; "b/c naked pair at"; ROW; COL; "and"; I; J
                    END IF
                  NEXT
                END IF
              NEXT
            NEXT
          GOTO 11
          END IF
        NEXT
      NEXT
    ELSE
      GOTO 11
    END IF
11 NEXT
NEXT
OLDSUM = SUM
SUM = 0
SOLVED = -1
FOR I = 1 TO RANK2
  FOR J = 1 TO RANK2
    FOR K = 1 TO RANK2
      IF PART(I, J) = 0 THEN SOLVED = 0
      SUM = SUM + BLOCK(I, J, K)
    NEXT
  NEXT
NEXT
IF SOLVED THEN
  PRINT "Solution Found!"
  PRINT #1, "Solution Found!"
  EXIT DO
ELSEIF SUM = OLDSUM THEN
  PRINT "I seem to be stuck. Work so far:"
  EXIT DO
END IF
LOOP
FOR I = 1 TO RANK2
  FOR J = 1 TO RANK2
    PRINT PART(I, J);
    PRINT #1, PART(I, J);
  NEXT
  PRINT
  PRINT #1, ""
NEXT
CLOSE #1
PRINT
PRINT "Press ESCAPE to quit or any other key to see the steps"
PRINT "used to reach this point."
NULL$ = INPUT$(1)
IF NULL$ = CHR$(27) THEN
  SYSTEM
ELSE
  SHELL EDITOR + CHR$(32) + FILE
END IF
 
SUB UPDATEBOARD
FOR ROW = 1 TO RANK2
  FOR COL = 1 TO RANK2
    IF PART(ROW, COL) = 0 THEN GOTO 1
    FOR I = 1 TO RANK2
      IF BLOCK(ROW, I, PART(ROW, COL)) = PART(ROW, COL) THEN
        BLOCK(ROW, I, PART(ROW, COL)) = 0
      END IF
      IF BLOCK(I, COL, PART(ROW, COL)) = PART(ROW, COL) THEN
        BLOCK(I, COL, PART(ROW, COL)) = 0
      END IF
    NEXT
    FOR I = INT((ROW - 1) / RANK) * RANK + 1 TO INT((ROW - 1) / RANK) * RANK + RANK
      FOR J = INT((COL - 1) / RANK) * RANK + 1 TO INT((COL - 1) / RANK) * RANK + RANK
        IF BLOCK(I, J, PART(ROW, COL)) = PART(ROW, COL) THEN
          BLOCK(I, J, PART(ROW, COL)) = 0
        END IF
      NEXT
    NEXT
1 NEXT
NEXT
END SUB
 

Programs / Re: MicroSoft's version of Reversi

« on: October 29, 2018, 09:38:13 am »

My own version has a better AI than Microsoft's: https://www.qb64.org/forum/index.php?topic=677.0
The hereustics are still pretty basic though, just counting squares with some weights.

Programs / MicroSoft's version of Reversi

« on: October 29, 2018, 08:50:58 am »

Code: QB64: [Select]

REM This is a sample QBASIC program from MS-DOS 5 (June 1990)
DEFINT A-Z
OPTION BASE 1
 
DECLARE FUNCTION CheckPath% (i, IBound, IStep, j, JBound, JStep, Opponent)
DECLARE FUNCTION ValidMove% (Opponent)
DECLARE SUB ComputerMove ()
DECLARE SUB DisplayHelp ()
DECLARE SUB DisplayMsg (a$)
DECLARE SUB DrawCursor (row, col)
DECLARE SUB DrawGamePiece (row, col, PieceColor)
DECLARE SUB GameOver ()
DECLARE SUB InitGame ()
DECLARE SUB TakeBlocks (row, col, player)
DECLARE SUB UpdateScore ()
DECLARE SUB UserMove ()
DECLARE SUB DrawGameBoard ()
 
CONST TRUE = -1
CONST FALSE = 0
CONST QUIT = 113
CONST UP = 72
CONST DOWN = 80
CONST LEFT = 75
CONST RIGHT = 77
CONST BBLOCK = 1
CONST EBLOCK = 8
CONST ENTER = 13
CONST ULEFT = 71
CONST URIGHT = 73
CONST DLEFT = 79
CONST DRIGHT = 81
CONST PASS = 112
CONST DIFF = 100
CONST START = 115
CONST HELP = 104
CONST FMOVE = 99
CONST SPACE = 32
 
TYPE GameGrid
    player AS INTEGER
    nTake  AS INTEGER
    cx     AS INTEGER
    cy     AS INTEGER
END TYPE
 
TYPE GameStatus
    curRow   AS INTEGER
    curCol   AS INTEGER
    stat     AS INTEGER
    rScore   AS INTEGER
    bScore   AS INTEGER
    mDisplay AS INTEGER
    dLevel   AS STRING * 6
    GColor   AS INTEGER
END TYPE
 
DIM SHARED GS AS GameStatus, smode AS INTEGER
DIM SHARED GG(8, 8) AS GameGrid, GBoard AS INTEGER
DIM SHARED COMP AS INTEGER, HUMAN AS INTEGER, BG AS INTEGER
DIM SHARED GP(8, 8, 8) AS INTEGER, GW(8, 8) AS INTEGER
 
ON ERROR GOTO BadMode
 
DO
  READ smode
  vmode = TRUE
  SCREEN smode
LOOP UNTIL vmode = TRUE
 
IF smode = 0 THEN
  CLS
  LOCATE 10, 15: PRINT "No graphics screen mode available; cannot run REVERSI.BAS"
ELSE
  GS.stat = START
  GS.dLevel = "Novice"
  WHILE GS.stat <> QUIT
    IF GS.stat = START THEN
      InitGame
      DrawGameBoard
    END IF
    IF GS.stat <> COMP THEN
      IF ValidMove(COMP) THEN
        UserMove
      ELSEIF ValidMove(HUMAN) THEN
        DO
          DisplayMsg "You have no valid moves.  Select pass."
          DO
            a$ = INKEY$
          LOOP UNTIL a$ <> ""
        LOOP UNTIL ASC(RIGHT$(a$, 1)) = PASS
        LINE (0, 420)-(640, 447), 3, BF
        GS.mDisplay = FALSE
        GS.stat = COMP
        ComputerMove
      ELSE
        GameOver
      END IF
    ELSE
      IF ValidMove(HUMAN) THEN
        ComputerMove
      ELSEIF ValidMove(COMP) THEN
        DisplayMsg "Computer has no valid moves.  Your Turn."
        GS.stat = HUMAN
        UserMove
      ELSE
        GameOver
      END IF
    END IF
  WEND
  DisplayMsg "Game Over"
END IF
 
DATA 9, 10, 2, 3, 0
 
BadMode:
  vmode = FALSE
RESUME NEXT
 
END
 
FUNCTION CheckPath (i, IBound, IStep, j, JBound, JStep, Opponent)
 
  done = FALSE
  WHILE (i <> IBound OR j <> JBound) AND NOT done
    IF GG(i, j).player = GBoard THEN
      count = 0
      done = TRUE
    ELSEIF GG(i, j).player = Opponent THEN
      count = count + 1
      i = i + IStep
      j = j + JStep
      IF (i < 1 OR i > 8) OR (j < 1 OR j > 8) THEN
        count = 0
        done = TRUE
      END IF
    ELSE
      done = TRUE
    END IF
  WEND
  CheckPath = count
    
END FUNCTION
 
SUB ComputerMove
  BestMove = -99
  FOR row = 1 TO 8
    FOR col = 1 TO 8
      IF GG(row, col).nTake > 0 THEN
        IF GS.dLevel = "Novice" THEN
          value = GG(row, col).nTake + GW(row, col)
        ELSE
          value = GG(row, col).nTake + GW(row, col)
          SELECT CASE row
            CASE 1
              IF col < 5 THEN value = value + ABS(10 * GG(1, 1).player = COMP)
              IF col > 4 THEN value = value + ABS(10 * GG(1, 8).player = COMP)
            CASE 2
              IF GG(1, col).player <> COMP THEN value = value + 5 * (GG(1, col).player = HUMAN)
              IF col > 1 AND GG(1, col - 1).player <> COMP THEN value = value + 5 * (GG(1, col - 1).player = HUMAN)
              IF col < 8 AND GG(1, col + 1).player <> COMP THEN value = value + 5 * (GG(1, col + 1).player = HUMAN)
            CASE 7
              IF GG(8, col).player <> COMP THEN value = value + 5 * (GG(8, col).player = HUMAN)
              IF col > 1 AND GG(8, col - 1).player <> COMP THEN value = value + 5 * (GG(8, col - 1).player = HUMAN)
              IF col < 8 AND GG(8, col + 1).player <> COMP THEN value = value + 5 * (GG(8, col + 1).player = HUMAN)
            CASE 8
              IF col < 5 THEN value = value + ABS(10 * GG(8, 1).player = COMP)
              IF col > 4 THEN value = value + ABS(10 * GG(8, 8).player = COMP)
          END SELECT
          SELECT CASE col
            CASE 1
              IF row < 5 THEN value = value + ABS(10 * GG(1, 1).player = COMP)
              IF row > 4 THEN value = value + ABS(10 * GG(8, 1).player = COMP)
            CASE 2
              IF GG(row, 1).player <> COMP THEN value = value + 5 * (GG(row, 1).player = HUMAN)
              IF row > 1 AND GG(row - 1, 1).player <> COMP THEN value = value + 5 * (GG(row - 1, 1).player = HUMAN)
              IF row < 8 AND GG(row + 1, 1).player <> COMP THEN value = value + 5 * (GG(row + 1, 1).player = HUMAN)
            CASE 7
              IF GG(row, 8).player <> COMP THEN value = value + 5 * (GG(row, 8).player = HUMAN)
              IF row > 1 AND GG(row - 1, 8).player <> COMP THEN value = value + 5 * (GG(row - 1, 8).player = HUMAN)
              IF row < 8 AND GG(row + 1, 8).player <> COMP THEN value = value + 5 * (GG(row + 1, 8).player = HUMAN)
            CASE 8
              IF row < 5 THEN value = value + ABS(10 * GG(1, 8).player = COMP)
              IF row > 4 THEN value = value + ABS(10 * GG(8, 8).player = COMP)
          END SELECT
        END IF
        IF value > BestMove THEN
          BestMove = value
          bestrow = row
          bestcol = col
        END IF
      END IF
    NEXT col
  NEXT row
 
  TakeBlocks bestrow, bestcol, COMP
  GS.stat = HUMAN
 
END SUB
 
SUB DisplayHelp
 
  DIM a$(1 TO 18)
 
  a$(1) = "The object of Reversi is to finish the game with more of your red"
  a$(2) = "circles on the board than the computer has of blue (Monochrome"
  a$(3) = "monitors will show red as white and blue as black)."
  a$(4) = ""
  a$(5) = "1) You and the computer play by the same rules."
  a$(6) = "2) To make a legal move, at least one of the computer's circles"
  a$(7) = "   must lie in a horizontal, vertical, or diagonal line between"
  a$(8) = "   one of your existing circles and the square where you want to"
  a$(9) = "   move.  Use the arrow keys to position the cursor on the square"
  a$(10) = "   and hit Enter or the Space Bar."
  a$(11) = "3) You can choose Pass from the game controls menu on your first"
  a$(12) = "   move to force the computer to play first."
  a$(13) = "4) After your first move, you cannot pass if you can make a legal"
  a$(14) = "   move."
  a$(15) = "5) If you cannot make a legal move, you must choose Pass"
  a$(16) = "6) When neither you nor the computer can make a legal move, the"
  a$(17) = "   game is over."
  a$(18) = "7) The one with the most circles wins."
 
  LINE (0, 0)-(640, 480), BG, BF
  LINE (39, 15)-(590, 450), 0, B
  IF GBoard = 85 THEN
    PAINT (200, 200), CHR$(85), 0
  ELSE
    PAINT (200, 200), GBoard, 0
  END IF
  LINE (590, 25)-(600, 460), 0, BF
  LINE (50, 450)-(600, 460), 0, BF
 
  LOCATE 2, 35: PRINT "REVERSI HELP"
  FOR i = 1 TO 18
    LOCATE 3 + i, 7
    PRINT a$(i)
  NEXT i
  LOCATE 23, 25: PRINT "- Press any key to continue -"
  SLEEP: a$ = INKEY$
  DrawGameBoard
  DrawCursor GS.curRow, GS.curCol
 
END SUB
 
SUB DisplayMsg (a$)
 
  slen = LEN(a$)
  LX = (640 - 8 * (slen + 8)) / 2
  LINE (LX - 1, 420)-(640 - LX, 447), 0, B
  IF GBoard = 85 THEN
    PAINT (LX + 10, 430), CHR$(85), 0
  ELSE
    PAINT (LX + 10, 430), GBoard, 0
  END IF
  LOCATE 23, (80 - slen) / 2
  PRINT a$;
  GS.mDisplay = TRUE
 
END SUB
 
SUB DrawCursor (row, col)
  IF GG(row, col).nTake > 0 THEN
    CIRCLE (GG(row, col).cx, GG(row, col).cy), 15, HUMAN
    CIRCLE (GG(row, col).cx, GG(row, col).cy), 14, HUMAN
  ELSE
    lc = 0
    IF GG(row, col).player = 0 THEN lc = 7
    LINE (GG(row, col).cx, GG(row, col).cy - 15)-(GG(row, col).cx, GG(row, col).cy + 15), lc
    LINE (GG(row, col).cx - 1, GG(row, col).cy - 15)-(GG(row, col).cx - 1, GG(row, col).cy + 15), lc
    LINE (GG(row, col).cx + 15, GG(row, col).cy)-(GG(row, col).cx - 15, GG(row, col).cy), lc
  END IF
END SUB
 
SUB DrawGameBoard
 
  LINE (0, 0)-(640, 480), BG, BF
  LINE (239, 15)-(400, 40), 0, B
  LINE (39, 260)-(231, 390), 0, B
  LINE (39, 70)-(231, 220), 0, B
  LINE (269, 70)-(591, 390), 0, B
 
  IF GBoard = 85 THEN                  'If b&w
    PAINT (300, 25), CHR$(85), 0
    PAINT (150, 350), CHR$(85), 0
    PAINT (150, 124), CHR$(85), 0
    PAINT (450, 225), CHR$(85), 0
  ELSE
    PAINT (300, 25), GBoard, 0
    PAINT (150, 350), GBoard, 0
    PAINT (150, 124), GBoard, 0
    PAINT (450, 225), GBoard, 0
  END IF
  LINE (400, 25)-(410, 50), 0, BF
  LINE (250, 40)-(410, 50), 0, BF
  LINE (231, 80)-(240, 230), 0, BF
  LINE (50, 220)-(240, 230), 0, BF
  LINE (590, 80)-(600, 400), 0, BF
  LINE (280, 390)-(600, 400), 0, BF
  LINE (231, 270)-(240, 400), 0, BF
  LINE (50, 390)-(240, 400), 0, BF
 
  FOR i = 0 TO 8
    LINE (270, 70 + i * 40)-(590, 70 + i * 40), 0
    LINE (270 + i * 40, 70)-(270 + i * 40, 390), 0
    LINE (269 + i * 40, 70)-(269 + i * 40, 390), 0
  NEXT i
  
  LOCATE 2, 35: PRINT "R E V E R S I"
 
  LOCATE 5, 11: PRINT "Game Controls"
  LOCATE 7, 7: PRINT "S = Start New Game"
  LOCATE 8, 7: PRINT "P = Pass Turn"
  LOCATE 9, 7: PRINT "D = Set Difficulty"
  LOCATE 10, 7: PRINT "H = Display Help"
  LOCATE 11, 7: PRINT "Q = Quit"
  LOCATE 15, 12: PRINT "Game Status"
  LOCATE 17, 7: PRINT "Your Score:      "; GS.rScore; ""
  LOCATE 18, 7: PRINT "Computer Score:  "; GS.bScore
  LOCATE 20, 7: PRINT "Difficulty:   "; GS.dLevel
 
  FOR row = 1 TO 8
    FOR col = 1 TO 8
      IF GG(row, col).player <> GBoard THEN
        DrawGamePiece row, col, GG(row, col).player
      END IF
    NEXT col
  NEXT row
 
END SUB
 
SUB DrawGamePiece (row, col, GpColor)
 
  IF GBoard = 85 THEN
    LINE (232 + col * 40, 33 + row * 40)-(267 + col * 40, 67 + row * 40), 7, BF
    IF GpColor <> GBoard THEN
      CIRCLE (GG(row, col).cx, GG(row, col).cy), 15, 0
      PAINT (GG(row, col).cx, GG(row, col).cy), GpColor, 0
    END IF
    PAINT (235 + col * 40, 35 + row * 40), CHR$(85), 0
  ELSE
    CIRCLE (GG(row, col).cx, GG(row, col).cy), 15, GpColor
    CIRCLE (GG(row, col).cx, GG(row, col).cy), 14, GpColor
    PAINT (GG(row, col).cx, GG(row, col).cy), GpColor, GpColor
  END IF
 
END SUB
 
SUB GameOver
  Scorediff = GS.rScore - GS.bScore
  IF Scorediff = 0 THEN
    DisplayMsg "Tie Game"
  ELSEIF Scorediff < 0 THEN
    DisplayMsg "You lost by"
    PRINT ABS(Scorediff)
  ELSE
    DisplayMsg "You won by"
    PRINT Scorediff
  END IF
  DO
    GS.stat = ASC(RIGHT$(INKEY$, 1))
  LOOP UNTIL GS.stat = QUIT OR GS.stat = START
  LINE (0, 420)-(640, 447), BG, BF
END SUB
 
SUB InitGame
  SELECT CASE smode
    CASE 9:
      HUMAN = 4
      COMP = 1
      BG = 3
      GBoard = 8
    CASE ELSE:
      HUMAN = 7
      COMP = 0
      BG = 7
      IF smode = 10 THEN
        GBoard = 1
      ELSE
        GBoard = 85
      END IF
  END SELECT
 
  WINDOW SCREEN (640, 480)-(0, 0)
  GS.curCol = 5
  GS.curRow = 3
  GS.stat = FMOVE
  GS.bScore = 2
  GS.rScore = 2
  GS.mDisplay = FALSE
 
  FOR row = 1 TO 8
    FOR col = 1 TO 8
      GG(row, col).player = GBoard
      GG(row, col).nTake = 0
      GG(row, col).cx = 270 + (col - .5) * 40
      GG(row, col).cy = 70 + (row - .5) * 40
      GW(row, col) = 2
    NEXT col
  NEXT row
  GW(1, 1) = 99
  GW(1, 8) = 99
  GW(8, 1) = 99
  GW(8, 8) = 99
  FOR i = 3 TO 6
    FOR j = 1 TO 8 STEP 7
      GW(i, j) = 5
      GW(j, i) = 5
    NEXT j
  NEXT i
  GG(4, 4).player = HUMAN
  GG(5, 4).player = COMP
  GG(4, 5).player = COMP
  GG(5, 5).player = HUMAN
END SUB
 
SUB TakeBlocks (row, col, player)
 
  GG(row, col).player = player
  DrawGamePiece row, col, player
 
  FOR i = 1 TO GP(row, col, 1)
    GG(row, col - i).player = player
    DrawGamePiece row, col - i, player
  NEXT i
  FOR i = 1 TO GP(row, col, 2)
    GG(row, col + i).player = player
    DrawGamePiece row, col + i, player
  NEXT i
  FOR i = 1 TO GP(row, col, 3)
    GG(row - i, col).player = player
    DrawGamePiece row - i, col, player
  NEXT i
  FOR i = 1 TO GP(row, col, 4)
    GG(row + i, col).player = player
    DrawGamePiece row + i, col, player
  NEXT i
  FOR i = 1 TO GP(row, col, 5)
    GG(row - i, col - i).player = player
    DrawGamePiece row - i, col - i, player
  NEXT i
  FOR i = 1 TO GP(row, col, 6)
    GG(row + i, col + i).player = player
    DrawGamePiece row + i, col + i, player
  NEXT i
  FOR i = 1 TO GP(row, col, 7)
    GG(row - i, col + i).player = player
    DrawGamePiece row - i, col + i, player
  NEXT i
  FOR i = 1 TO GP(row, col, 8)
    GG(row + i, col - i).player = player
    DrawGamePiece row + i, col - i, player
  NEXT i
 
  IF player = HUMAN THEN
    GS.rScore = GS.rScore + GG(row, col).nTake + 1
    GS.bScore = GS.bScore - GG(row, col).nTake
  ELSE
    GS.bScore = GS.bScore + GG(row, col).nTake + 1
    GS.rScore = GS.rScore - GG(row, col).nTake
  END IF
 
  LOCATE 17, 7: PRINT "Your Score:      "; GS.rScore
  LOCATE 18, 7: PRINT "Computer Score:  "; GS.bScore
 
END SUB
 
SUB UserMove
 
  DrawCursor GS.curRow, GS.curCol
  DO
    DO
      a$ = INKEY$
    LOOP UNTIL a$ <> ""
    move = ASC(RIGHT$(a$, 1))
    IF GS.mDisplay THEN
      LINE (0, 420)-(640, 447), BG, BF
      GS.mDisplay = FALSE
    END IF
    SELECT CASE move
      CASE 71 TO 81:
        DrawGamePiece GS.curRow, GS.curCol, GG(GS.curRow, GS.curCol).player
        IF move < 74 THEN
          IF GS.curRow = BBLOCK THEN
            GS.curRow = EBLOCK
          ELSE
            GS.curRow = GS.curRow - 1
          END IF
        ELSEIF move > 78 THEN
          IF GS.curRow = EBLOCK THEN
            GS.curRow = BBLOCK
          ELSE
            GS.curRow = GS.curRow + 1
          END IF
        END IF
        IF move = 71 OR move = 75 OR move = 79 THEN
          IF GS.curCol = BBLOCK THEN
            GS.curCol = EBLOCK
          ELSE
            GS.curCol = GS.curCol - 1
          END IF
        ELSEIF move = 73 OR move = 77 OR move = 81 THEN
          IF GS.curCol = EBLOCK THEN
            GS.curCol = BBLOCK
          ELSE
            GS.curCol = GS.curCol + 1
          END IF
        END IF
        DrawCursor GS.curRow, GS.curCol
      CASE START:
        GS.stat = START
      CASE PASS:
        IF GS.stat = FMOVE THEN
          DisplayMsg "You passed.  Computer will make first move."
          GS.stat = COMP
        ELSE
          DisplayMsg "You can only pass on your first turn."
        END IF
      CASE HELP:
        DisplayHelp
      CASE DIFF:
        IF GS.dLevel = "Novice" THEN
          GS.dLevel = "Expert"
        ELSE
          GS.dLevel = "Novice"
        END IF
        LOCATE 20, 7
        PRINT "Difficulty:   "; GS.dLevel;
      CASE ENTER, SPACE:
        IF GG(GS.curRow, GS.curCol).nTake > 0 THEN
          TakeBlocks GS.curRow, GS.curCol, HUMAN
          GS.stat = COMP
        ELSE
          DisplayMsg "Invalid move.  Move to a space where the cursor is a circle."
        END IF
      CASE QUIT:
        GS.stat = QUIT
    END SELECT
  LOOP UNTIL GS.stat <> HUMAN AND GS.stat <> FMOVE
 
END SUB
 
FUNCTION ValidMove (Opponent)
 
  ValidMove = FALSE
  ERASE GP
  FOR row = 1 TO 8
    FOR col = 1 TO 8
      GG(row, col).nTake = 0
 
      IF GG(row, col).player = GBoard THEN
        IF col > 2 THEN
          GP(row, col, 1) = CheckPath(row, row, 0, col - 1, 0, -1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 1)
        END IF
        IF col < 7 THEN
          GP(row, col, 2) = CheckPath(row, row, 0, col + 1, 9, 1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 2)
        END IF
        IF row > 2 THEN
          GP(row, col, 3) = CheckPath(row - 1, 0, -1, col, col, 0, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 3)
        END IF
        IF row < 7 THEN
          GP(row, col, 4) = CheckPath(row + 1, 9, 1, col, col, 0, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 4)
        END IF
        IF col > 2 AND row > 2 THEN
          GP(row, col, 5) = CheckPath(row - 1, 0, -1, col - 1, 0, -1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 5)
        END IF
        IF col < 7 AND row < 7 THEN
          GP(row, col, 6) = CheckPath(row + 1, 9, 1, col + 1, 9, 1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 6)
        END IF
        IF col < 7 AND row > 2 THEN
          GP(row, col, 7) = CheckPath(row - 1, 0, -1, col + 1, 9, 1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 7)
        END IF
        IF col > 2 AND row < 7 THEN
          GP(row, col, 8) = CheckPath(row + 1, 9, 1, col - 1, 0, -1, Opponent)
          GG(row, col).nTake = GG(row, col).nTake + GP(row, col, 8)
        END IF
        IF GG(row, col).nTake > 0 THEN ValidMove = TRUE
      END IF
    NEXT col
  NEXT row
 
END FUNCTION
 
 

QB64 Discussion / Re: [fixed] QB64 does not interpret 0-place recursive function correctly

« on: October 15, 2018, 10:48:54 pm »

I know you can just avoid 0-argument functions but the above code works in QBASIC.

Programs / Re: Scheme (LISP) interpreter

« on: October 15, 2018, 10:31:50 pm »

Looks like QB64 still interprets 0-placed recursive functions incorrectly. The version I posted triggers the recursion bug but it is easy to change the code so as not to use zero-place functions (e.g. make depth a parameter or add a dummy parameter). STxAxTIC's modified version has this modification already but has the read code modified so it reads from a line of input so you can't split your expressions across lines.

QB64 Discussion / [fixed] QB64 does not interpret 0-place recursive function correctly

« on: October 15, 2018, 10:26:36 pm »

Code: QB64: [Select]

DIM SHARED X
X = 5
PRINT F
 
FUNCTION F
IF X = 0 THEN F = 1 ELSE PRINT "*": X = X - 1: F = F
END FUNCTIOn
 

Expected behavior: prints five stars, then 1.
Actual behaviour: prints a single star, then a 0.

QB64 Discussion / Re: CD Access

« on: October 15, 2018, 09:38:48 pm »

Quote from: Petr on October 15, 2018, 06:59:11 am

Hi. The following sentences are my estimation. If there really is a better way, of course I would also be very interested in how.

This is probably only possible with use an some external library because the audio CD format uses its own data format. They are basically WAV files but are not readable because CD-DA has one BYTE size of 14 bits, which is not compatible with the standard (8 bites per byte). With such a structure, the OPEN statement is computed, so CD-DA without special software is directly not accessible to QB64.

CDDA is 16-bit Linear PCM sampled at 44,100 Hz. (source: Wikipedia) (but there is no WAV header). However, you still can't read it with ordinary file OPEN . https://superuser.com/questions/1302319/why-you-cant-just-dd-cd-audio-like-an-ordinary-data-cd

QB64 Discussion / Re: Really got to implement source code printing

« on: October 07, 2018, 03:32:20 am »

For dot matrix printers, just save as LPT1 and it should print your text directly to the printer (assuming the printer is actually connected directly to the parallel port). The editors Notepad++ and Emacs let you print out a syntax-highlighted version of your source code. For Emacs this is PostScript format (which can be passed directly to a PostScript laser printer or to CUPS), for Notepad++ this uses the Windows printer driver.

Looks like the EPSON dot matrix printers had bold but only in draft mode, but in NLQ mode there is underline and italics. I remember WordPad (write.exe) could also print using the printer's text fonts on Windows if you select the appropriate font. LPRINT also worked for text mode even in Win 2000 NTVDM on the Epson EX800.

https://files.support.epson.com/pdf/ex800_/ex800_u1.pdf

We already have LPRINT on Windows in QB64, which seems to print to the default Windows Printer. Not sure if it's there on Linux and Mac.

Programs / Blackjack game (unfortunately variable names compressed)

« on: October 06, 2018, 09:21:08 pm »

Code: QB64: [Select]

DECLARE SUB M ()
DECLARE SUB N (Y!)
DECLARE SUB O ()
DECLARE FUNCTION P! (W!)
DECLARE FUNCTION Q% ()
DECLARE FUNCTION R$ (W!)
RANDOMIZE TIMER
DIM SHARED A(1 TO 52), B(0 TO 16, 1 TO 16), C(0 TO 16)
DIM SHARED D(0 TO 16), E(1 TO 16)
DIM SHARED G
F = 1000
G = 0
CALL M
CLS
DO
FOR I = 0 TO 16
C(I) = 0
FOR J = 1 TO 16
B(I, J) = 0
E(J) = 0
NEXT
NEXT
PRINT "Your money: "; F
E(1) = -1
WHILE E(1) < 0 AND E(1) <= 1000
INPUT "Wager"; E(1)
IF E(1) < 0 THEN PRINT "Bet must be nonnegative."
IF E(1) > 1000 THEN PRINT "Max bet $1000."
WEND
H = 1
K = 1
N 0
N 0
N 1
N 1
O
PRINT "Dealer Upcard: "; R$(B(0, 1))
PRINT "Your hand:"; R(B(1, 1)); R(B(1, 2))
PRINT
 
IF B(0, 1) = 11 THEN
1 INPUT "Would you like insurance"; X$
X$ = UCASE$(LTRIM$(RTRIM$(X$)))
SELECT CASE X$
CASE "Y", "YES", "AYE", "YUP", "YEAH", "OUI", "JA", "SI"
L = .5 * E(1)
CASE "N", "NAY", "NOPE", "NO", "NEIN", "NYET", "NON"
L = 0
CASE ELSE
GOTO 1
END SELECT
END IF
IF D(0) = 21 THEN
PRINT "Dealer Blackjack."
IF D(1) <> 21 THEN F = F - E(1)
IF L > 0 THEN
PRINT "You get "; L * 2; "from insurance"
F = F + L * 2
L = 0
END IF
GOTO 4
ELSEIF D(1) = 21 THEN
IF L > 0 THEN
PRINT "You lose the insurance bet"
F = F - L
L = 0
END IF
PRINT "Blackjack!"
F = F + E(1) * 1.5
GOTO 4
ELSEIF L > 0 THEN
PRINT "You lose the insurance bet"
F = F - L
L = 0
END IF
DO WHILE H <= K
2 LINE INPUT "Your move:"; X$
X$ = LTRIM$(RTRIM$(UCASE$(X$)))
SELECT CASE X$
CASE "HIT", "H"
N H
O
IF D(H) >= 21 THEN H = H + 1
CASE "STAND", "S"
H = H + 1
CASE "DOUBLE", "D"
E(H) = E(H) * 2
N H
O
H = H + 1
CASE "SPLIT", "P"
IF (P(B(H, 1)) <> P(B(H, 2))) OR (C(H) <> 2) THEN
PRINT "You cannot split."
GOTO 2
ELSE
B(K + 1, 1) = B(H, 2)
C(K + 1) = 1
N K + 1
B(H, 2) = 0
C(H) = 1
N H
K = K + 1
E(K) = E(H)
O
END IF
CASE "QUIT", "Q", "BYE", "ADIOS"
SYSTEM
CASE ELSE
PRINT "Invalid Selection"
GOTO 2
END SELECT
PRINT "Dealer Upcard: "; R$(B(0, 1))
FOR I = 1 TO K
PRINT "Hand"; I; ": ";
FOR J = 1 TO C(I)
PRINT R(B(I, J));
NEXT
IF H = I THEN PRINT "<- Current hand ";
PRINT "(Sum ="; D(I); ")"
NEXT
PRINT
LOOP
PRINT "Dealer's hand:"; R$(B(0, 1)); R$(B(0, 2));
3 O
IF D(0) < 17 THEN
T = TIMER + .5
WHILE T < TIMER
WEND
N 0
PRINT R$(B(0, C(0)));
GOTO 3
END IF
FOR I = 1 TO K
IF D(I) > 21 THEN
PRINT "Bust on Y"; I
F = F - E(I)
ELSEIF D(0) > 21 THEN
PRINT "Dealer bust: win on Y"; I
F = F + E(I)
ELSEIF D(I) > D(0) THEN
PRINT "Win on Y"; I
F = F + E(I)
ELSEIF D(I) < D(0) THEN
PRINT "Lose on Y"; I
F = F - E(I)
ELSE
PRINT "Push on Y"; I
END IF
NEXT
4 LOOP
 
SUB M
FOR I = 1 TO 52
A(I) = I
NEXT
J = 52
DO
K = INT(J * RND(1)) + 1
SWAP A(K), A(J)
J = J - 1
LOOP WHILE J > 1
END SUB
 
SUB N (Y)
C(Y) = C(Y) + 1
B(Y, C(Y)) = Q
END SUB
 
SUB O
FOR I = 0 TO K + 1
T = 0
S = 0
FOR J = 1 TO C(I)
X = P(B(I, J))
S = S + X
IF X = 11 THEN T = T + 1
NEXT
DO WHILE (S > 21 AND T > 0)
S = S - 10
T = T - 1
LOOP
D(I) = S
NEXT
END SUB
 
FUNCTION P (W)
V = (W MOD 13) + 1
SELECT CASE V
CASE 1
P = 11
CASE 2 TO 10
P = V
CASE 11 TO 13
P = 10
END SELECT
END FUNCTION
 
FUNCTION Q%
IF G = 52 THEN M: G = 0
G = G + 1
Q = A(G)
END FUNCTION
 
FUNCTION R$ (W)
DIM SUIT AS STRING
SUIT = CHR$(((W - 1) \ 13) + 3)
V = 1 + (W MOD 13)
SELECT CASE V
CASE 1
R$ = "A" + SUIT + " "
CASE 2 TO 10
R$ = LTRIM$(STR$(V)) + SUIT + " "
CASE 11
R$ = "J" + SUIT + " "
CASE 12
R$ = "Q" + SUIT + " "
CASE 13
R$ = "K" + SUIT + " "
END SELECT
END FUNCTION
 
 

Programs / Reversi / Othello Game (play against computer AI)

« on: October 06, 2018, 09:18:20 pm »

Mouse code is for QBASIC and uses CALL ABSOLUTE to call interrupt 33 and put the results in global variables named AX, BX, CX, DX. Should still work in QB64; otherwise alter it to use CALL ITERRUPT or QB64 mouse codes. When this was on the [abandoned, outdated and now likely malicious qb64 dot net website - don’t go there] forum there was a bug in QB64 that caused it not to compile the constants. I think I had already put alternative mouse routines for QB64 or FreeBASIC.

Code: QB64: [Select]

DECLARE FUNCTION AlphaBeta% (player%, board%(), achievable%, cutoff%, ply%)
DECLARE FUNCTION FinalValue% (player%, board%())
DECLARE FUNCTION WeightedSquares% (player%, board%())
DECLARE FUNCTION MaximizeDifference% (player%, board%())
DECLARE FUNCTION CountDifference% (player%, board%())
DECLARE SUB MakeMove (move%, player%, board%())
DECLARE SUB InitBoard ()
DECLARE FUNCTION LegalP% (move%, player%, board%())
DECLARE FUNCTION WouldFlip% (move%, player%, board%(), dir%)
DECLARE FUNCTION FindBracketingPiece% (square%, player%, board%(), dir%)
DECLARE FUNCTION NextToPlay% (board%(), PreviousPlayer%)
DECLARE FUNCTION AnyLegalMove% (player%, board%())
DECLARE FUNCTION Opponent% (player%)
DECLARE SUB MakeFlips (move%, player%, board%(), dir%)
DEFINT A-Z
DECLARE SUB Mouse (ax AS INTEGER)
DECLARE FUNCTION GetMove% ()
DECLARE FUNCTION Colour (i)
DECLARE SUB ShowBd ()
DIM SHARED board(100) AS INTEGER
DIM SHARED AllDirections(8) AS INTEGER
DIM SHARED weights(100) AS INTEGER
CLEAR , , 9999
FOR i = 1 TO 8
  READ AllDirections(i)
NEXT
DATA -11, -10, -9, -1, 1, 9, 10, 11
 
FOR i = 0 TO 99
  READ weights(i)
NEXT
DATA 0,0,0,0,0,0,0,0,0,0
DATA 0,120,-20,20,5,5,20,-20,120,0
DATA 0,-20,-0,-5,-5,-5,-5,-40,-20,0
DATA 0,20,-5,15,3,3,15,-5,20,0
DATA 0,5,-5,3,3,3,3,-5,5,0
DATA 0,5,-5,3,3,3,3,-5,5,0
DATA 0,20,-5,15,3,3,15,-5,20,0
DATA 0,-20,-0,-5,-5,-5,-5,-40,-20,0
DATA 0,120,-20,20,5,5,20,-20,120,0
DATA 0,0,0,0,0,0,0,0,0,0
 
CONST ScreenWidth = 640
CONST ScreenHeight = 480
CONST SquareWidth = ScreenHeight / 8
CONST tlx = (ScreenWidth - ScreenHeight) / 2
CONST tly = 0
CONST brx = ScreenWidth - (ScreenWidth - ScreenHeight) / 2
CONST bry = ScreenHeight
CONST PieceRadius = SquareWidth / 2 - 5
CONST EMPTY = 0
CONST BLACK = 1
CONST WHITE = 2
CONST OUTER = 3
CONST WinningValue = 32767
CONST LosingValue = -32767
CONST nply = 5
 
DIM SHARED bestm(nply) AS INTEGER
DIM SHARED ax AS INTEGER
ax = 0
DIM SHARED bx AS INTEGER
bx = 0
DIM SHARED cx AS INTEGER
cx = 0
DIM SHARED dx AS INTEGER
dx = 0
 
 
 
SCREEN 12
CALL InitBoard
CALL Mouse(0)
CALL Mouse(1)
player = BLACK
human = BLACK
computer = Opponent(human)
DO
  CALL ShowBd
  IF player = human THEN
    n = GetMove
    IF LegalP(n, player, board()) THEN
      CALL MakeMove(n, player, board())
      player = NextToPlay(board(), player)
    END IF
  END IF
  CALL ShowBd
  IF player = computer THEN
    n = AlphaBeta(player, board(), LosingValue, WinningValue, nply)
    move = bestm(nply)
    CALL MakeMove(move, player, board())
    player = NextToPlay(board(), player)
  END IF
LOOP UNTIL player = 0
 
FUNCTION AlphaBeta (player, board(), achievable, cutoff, ply)
  DIM board2(100)
  FOR i = 0 TO 99
    board2(i) = board(i)
  NEXT
  IF ply = 0 THEN
    AlphaBeta = WeightedSquares(player, board())
    EXIT FUNCTION
  END IF
  nlegal = 0
  FOR move = 0 TO 99
    IF LegalP(move, player, board()) THEN
      nlegal = nlegal + 1
      CALL MakeMove(move, player, board2())
      value = -AlphaBeta(Opponent(player), board2(), -cutoff, -achievable, ply - 1)
      IF value > achievable THEN
        achievable = value
        bestmove = move
      END IF
    END IF
  NEXT
  IF nlegal = 0 THEN
    IF AnyLegalMove(Opponent(player), board()) THEN
      AlphaBeta = -AlphaBeta(Opponent(player), board(), -cutoff, -achievable, ply - 1)
    ELSE
      AlphaBeta = FinalValue(player, board())
    END IF
  END IF
  bestm(ply) = bestmove
END FUNCTION
 
FUNCTION AnyLegalMove (player, board())
  FOR i = 0 TO 99
    IF LegalP(i, player, board()) THEN AnyLegalMove = -1: EXIT FUNCTION
  NEXT
END FUNCTION
 
FUNCTION Colour (i)
  IF i = BLACK THEN
    Colour = 0
  ELSE
    Colour = 15
  END IF
END FUNCTION
 
FUNCTION CountDifference (player, board())
  c = 0
  FOR y = 1 TO 8
    FOR x = 1 TO 8
      IF board(10 * y + x) = player THEN c = c + 1
      IF board(10 * y + x) = Opponent(player) THEN c = c - 1
    NEXT
  NEXT
  CountDifference = c
END FUNCTION
 
FUNCTION FinalValue (player, board())
  SELECT CASE SGN(CountDifference(player, board()))
    CASE -1
      FinalValue = LosingValue
    CASE 0
      FinalValue = 0
    CASE 1
      FinalValue = WinningValue
  END SELECT
END FUNCTION
 
FUNCTION FindBracketingPiece (square, player, board(), dir)
  IF board(square) = player THEN
    FindBracketingPiece = square
  ELSEIF board(square) = Opponent(player) THEN
    FindBracketingPiece = FindBracketingPiece(square + dir, player, board(), dir)
  END IF
END FUNCTION
 
FUNCTION GetMove
  DO
    CALL Mouse(3)
    IF bx AND 1 THEN
      y = (dx - tly) \ SquareWidth + 1
      x = (cx - tlx) \ SquareWidth + 1
    END IF
    IF 1 <= y AND y <= 8 AND 1 <= x AND x <= 8 THEN EXIT DO
  LOOP
  GetMove = 10 * y + x
END FUNCTION
 
SUB InitBoard
  FOR i = 0 TO 9
    board(i) = OUTER
    board(90 + i) = OUTER
    board(i * 10) = OUTER
    board(i * 10 + 9) = OUTER
  NEXT
  board(44) = 1
  board(45) = 2
  board(54) = 2
  board(55) = 1
END SUB
 
FUNCTION LegalP (move, player, board())
  IF board(move) <> EMPTY THEN LegalP = 0: EXIT FUNCTION
  FOR i = 1 TO 8
    x = WouldFlip(move, player, board(), AllDirections(i))
    IF x THEN LegalP = -1: EXIT FUNCTION
  NEXT
END FUNCTION
 
SUB MakeFlips (move, player, board(), dir)
  bracketer = WouldFlip(move, player, board(), dir)
  IF bracketer THEN
    FOR c = move + dir TO bracketer STEP dir
      board(c) = player
    NEXT
  END IF
END SUB
 
SUB MakeMove (move, player, board())
  board(move) = player
  FOR i = 1 TO 8
    CALL MakeFlips(move, player, board(), AllDirections(i))
  NEXT
END SUB
 
FUNCTION MaximizeDifference (player, board())
  DIM board2(100)
  best = -9999
  FOR y = 1 TO 8
    FOR x = 1 TO 8
      move = 10 * y + x
      IF LegalP(move, player, board()) THEN
        FOR i = 0 TO 99
          board2(i) = board(i)
        NEXT
        CALL MakeMove(move, player, board2())
        score = WeightedSquares(player, board2())
        IF score > best THEN best = score: bestmove = move
      END IF
    NEXT
  NEXT
  MaximizeDifference = bestmove
END FUNCTION
 
SUB Mouse (ax AS INTEGER)
  
  ml$ = "" ' -=<( Mouse Code )>=-
  ml$ = ml$ + CHR$(&H55) ' push bp               ; preserve BP register
  ml$ = ml$ + CHR$(&H89) + CHR$(&HE5) ' mov  bp, sp           ; copy SP to BP
  ml$ = ml$ + CHR$(&HB8) + CHR$(ax) + CHR$(&H0) '   mov  ax, #          ;   copy SUBFUNCTION to AX
  ml$ = ml$ + CHR$(&HCD) + CHR$(&H33) '   int  33             ;   call mouse interrupt
  ml$ = ml$ + CHR$(&H53) '   push bx             ;   preserve BX (again)
  ml$ = ml$ + CHR$(&H8B) + CHR$(&H5E) + CHR$(&H6) '   mov  bx, [bp+6]     ;   copy location of dx (last variable) to BX
  ml$ = ml$ + CHR$(&H89) + CHR$(&H17) '   mov  [bx], dx       ;   copy DX to dx location in BX
  ml$ = ml$ + CHR$(&H8B) + CHR$(&H5E) + CHR$(&H8) '   mov  bx, [bp+8]     ;   copy location of cx to BX
  ml$ = ml$ + CHR$(&H89) + CHR$(&HF) '   mov  [bx], cx       ;   copy CX to cx location in BX
  ml$ = ml$ + CHR$(&H8B) + CHR$(&H5E) + CHR$(&HC) '   mov  bx, [bp+C]     ;   copy location of ax to BX
  ml$ = ml$ + CHR$(&H89) + CHR$(&HF7) '   mov  [bx], ax       ;   copy AX to ax location in BX
  ml$ = ml$ + CHR$(&H8B) + CHR$(&H5E) + CHR$(&HA) '   mov  bx, [bp+A]     ;   copy location of bx to BX
  ml$ = ml$ + CHR$(&H58) '   pop  ax             ;   restore int 33's BX value to AX
  ml$ = ml$ + CHR$(&H89) + CHR$(&H7) '   mov  [bx], ax       ;   copy AX to bx location in BX
  ml$ = ml$ + CHR$(&H5D) ' pop  bp               ; restore BP
  ml$ = ml$ + CHR$(&HCA) + CHR$(&H8) + CHR$(&H0) ' retf 8                ; Return Far and skip 8 bytes of variables
  DEF SEG = SSEG(ml$) ' Set current segment this machine code segment
  offset% = SADD(ml$) ' Set offset to this machine code location
  CALL absolute(ax, bx, cx, dx, offset%) ' The actual call to this machine code
  DEF SEG ' Restore the default segment
  
END SUB
 
FUNCTION NextToPlay (board(), PreviousPlayer)
  opp = Opponent(PreviousPlayer)
  IF AnyLegalMove(opp, board()) THEN NextToPlay = opp: EXIT FUNCTION
  IF AnyLegalMove(PreviousPlayer, board()) THEN NextToPlay = PreviousPlayer
END FUNCTION
 
FUNCTION Opponent (player)
  IF player = WHITE THEN Opponent = BLACK
  IF player = BLACK THEN Opponent = WHITE
END FUNCTION
 
SUB ShowBd
  LINE (tlx, tly)-(brx, bry), 8, BF
  FOR i = 0 TO 8
    LINE (tlx + SquareWidth * i, tly)-(tlx + SquareWidth * i, bry)
    LINE (tlx, tly + SquareWidth * i)-(brx, tly + SquareWidth * i)
  NEXT
  FOR y = 1 TO 8
    FOR x = 1 TO 8
      IF board(10 * y + x) <> EMPTY THEN
        CIRCLE (tlx + SquareWidth * x - SquareWidth / 2, tly + SquareWidth * y - SquareWidth / 2), PieceRadius, Colour(board(10 * y + x))
        PAINT (tlx + SquareWidth * x - SquareWidth / 2, tly + SquareWidth * y - SquareWidth / 2), Colour(board(10 * y + x))
      END IF
    NEXT
  NEXT
END SUB
 
FUNCTION WeightedSquares (player, board())
  opp = Opponent(player)
  sum = 0
  FOR i = 0 TO 99
    IF board(i) = player THEN sum = sum + weights(i)
    IF board(i) = opp THEN sum = sum - weights(i)
  NEXT
  WeightedSquares = sum
END FUNCTION
 
FUNCTION WouldFlip (move, player, board(), dir)
  c = move + dir
  IF board(c) <> Opponent(player) THEN WouldFlip = 0: EXIT FUNCTION
  WouldFlip = FindBracketingPiece(c + dir, player, board(), dir)
END FUNCTION
 
 

Programs / Scheme (LISP) interpreter

« on: October 06, 2018, 09:14:42 pm »

Code: QB64: [Select]

DEFINT A-Z
declare function readobj()
declare function readtoken()
declare function strtoatom(s$)
declare function cons(car,cdr)
declare function readlist()
declare function alloc()
declare sub printobj(id)
declare function evalobj(id, env)
declare function apply(f, args)
declare function lookup(anum, env)
declare function lvals(id,env)
declare sub defvar(var,val,env)
declare sub setvar(id,val,env)
declare function mkprimop(id)
 
DIM SHARED depth AS INTEGER,bufpos AS INTEGER, state AS INTEGER
DIM SHARED buf AS STRING
DIM SHARED anext, hptr
DIM SHARED atom$(1024),heap(2048, 2)
RANDOMIZE TIMER
 
CONST TRUE = -1
CONST FALSE = 0
CONST TNIL = 0
CONST TCONS = 2
CONST TNUM = 3
CONST TSYM = 4
CONST TPROC = 5
CONST TPPROC = 6
CONST TOKNIL = 0
CONST TOKERR = 1
CONST TOKOPEN = 2
CONST TOKCLOSE = 3
CONST TOKQUOTE = 4
CONST TOKDOT = 5
 
 
CONST PPLUS = 1
CONST PTIMES = 3
CONST PCONS = 4
CONST PCAR = 5
CONST PCDR = 6
CONST PEQUAL = 7
CONST PNOT = 8
CONST PEQ = 9
CONST PSETCAR = 10
CONST PSETCDR = 11
CONST PAPPLY = 12
CONST PLIST = 13
CONST PREAD = 14
 
hptr = 10: bufpos = 1
vars = TNIL
vals = TNIL
frame = CONS(vars,vals)
env = CONS(frame,TNIL)
 
CALL DEFVAR(STRTOATOM("+"),mkprimop(PPLUS), env)
CALL DEFVAR(STRTOATOM("*"),mkprimop(PTIMES), env )
CALL DEFVAR(STRTOATOM("CONS"),mkprimop(PCONS), env)
CALL DEFVAR(STRTOATOM("CAR"),mkprimop(PCAR), env )
CALL DEFVAR(STRTOATOM("CDR"),mkprimop(PCDR), env)
CALL DEFVAR(STRTOATOM("="),mkprimop(PEQUAL),env)
CALL DEFVAR(STRTOATOM("NOT"),mkprimop(PNOT),env)
CALL DEFVAR(STRTOATOM("EQ?"),mkprimop(PEQ),env)
CALL DEFVAR(STRTOATOM("EQV?"),mkprimop(PEQ),env)
CALL DEFVAR(STRTOATOM("T"),STRTOATOM("T"),env) ' true
CALL DEFVAR(STRTOATOM("SET-CAR!"),mkprimop(PSETCAR),env)
CALL DEFVAR(STRTOATOM("SET-CDR!"),mkprimop(PSETCDR),env)
CALL DEFVAR(STRTOATOM("APPLY"),mkprimop(PAPPLY),env)
CALL DEFVAR(STRTOATOM("LIST"),mkprimop(PLIST),env)
CALL DEFVAR(STRTOATOM("READ"),mkprimop(PREAD), env)
 
DO
    s = READOBJ()
    SELECT CASE s
    CASE TOKCLOSE
    ' unmatched closed parenthesis
    CASE TOKDOT
    PRINT  "dot used outside list"
    CASE TOKERR
    PRINT "[Error]"
    CASE ELSE
    CALL PRINTOBJ(EVALOBJ(s,env))
    END SELECT
    PRINT
LOOP
 
 
SUB PRINTOBJ(id)
 
    IF id = TOKERR THEN PRINT "[Error]" : EXIT SUB
    SELECT CASE heap(id,0)
    CASE TNIL
        PRINT "()";
    CASE TCONS
        PRINT "(";
1       CALL PRINTOBJ(heap(id,1))
        PRINT " ";
        cdr = heap(id,2)
        IF heap(cdr,0) = TCONS THEN 
            id = cdr: GOTO 1 
        ELSEIF heap(cdr,0) = TNIL THEN
            PRINT ")";
        ELSE
            PRINT ".";  
            CALL PRINTOBJ(cdr)
            PRINT ")";
        END IF
    CASE TNUM
        PRINT heap(id,1);
    CASE TSYM
        PRINT atom$(heap(id,1));
    CASE TPROC, TPPROC
        PRINT "[Procedure]"
    END SELECT
END SUB
 
FUNCTION READTOKEN()
    
1    bufend = LEN(buf)
    WHILE bufpos < bufend AND INSTR(" "+CHR$(9),MID$(buf,bufpos,1))
        bufpos = bufpos + 1
    WEND
    c$ = MID$(buf,bufpos,1)
    IF INSTR(":;",c$) THEN
        IF c$ = ":" THEN
            bufpos = bufpos + 1
            IF bufpos <= bufend THEN
                SELECT CASE MID$(buf,bufpos,1)
                CASE "q" ' quit
                    SYSTEM
                CASE ELSE
                        READTOKEN = TOKERR
                        EXIT FUNCTION
                END SELECT
            END IF 
        END IF
        bufpos = bufend + 1
    END IF
    IF bufpos > bufend THEN
        IF depth = 0 THEN PRINT "]=> "; 
        LINE INPUT buf
        bufend = LEN(buf)
        bufpos = 1
        GOTO 1
    END IF
    SELECT CASE c$
    CASE "("
        bufpos = bufpos + 1
        READTOKEN = TOKOPEN
    CASE ")"
        bufpos = bufpos + 1
        READTOKEN = TOKCLOSE
    CASE "'"
        bufpos = bufpos+1
        READTOKEN = TOKQUOTE
    CASE "."
        bufpos = bufpos + 1
        READTOKEN = TOKDOT
    CASE ELSE
        strbeg = bufpos
        bufpos = bufpos +1
        DO WHILE bufpos <= bufend
            c$ = MID$(buf,bufpos,1)
            IF c$ = " " OR c$ = "." OR c$ = "(" OR c$ = ")" THEN EXIT DO
            bufpos = bufpos + 1
        LOOP
        READTOKEN = STRTOATOM(MID$(buf,strbeg,bufpos - strbeg))
    END SELECT 
END FUNCTION
 
FUNCTION STRTOATOM(s$)
    l = LEN(s$)
    c$ = LEFT$(s$,1)
    IF (c$ = "-" AND l >= 2) OR (c$ >= "0" AND c$ <= "9") THEN
        v = 0
        IF c$ = "-" THEN neg = 1: idx = 2 ELSE neg = 0: idx = 1
        FOR idx = idx TO l
            c$ = MID$(s$,idx,1)
            IF (c$ >= "0" AND c$ <= "9") THEN 
                v = v*10 + (ASC(c$)-ASC("0")) 
            ELSE 
                EXIT FOR
            END IF
        NEXT
        IF idx = l + 1 THEN
            IF neg THEN v = -v
            p = ALLOC()
            HEAP(p,0) = TNUM
            HEAP(p,1) = v
            STRTOATOM = p: EXIT FUNCTION
        END IF
    END IF
    IF UCASE$(s$) = "NIL" THEN STRTOATOM=TOKNIL: EXIT FUNCTION
    FOR i = 0 TO anext-1
        IF ATOM$(i) = UCASE$(s$) THEN found = TRUE : exit for
    NEXT
    IF not found then ATOM$(anext) = UCASE$(s$) : anext = anext + 1
    p = ALLOC(): HEAP(p,0) = TSYM: HEAP(p,1) = i
    STRTOATOM = p
END FUNCTION
 
FUNCTION READOBJ()
    tok = READTOKEN()
    SELECT CASE tok
    CASE TOKOPEN
    depth = depth + 1
    s = READLIST()
    depth = depth - 1
    READOBJ = s
    CASE TOKQUOTE
    depth = depth + 1
    tok = READOBJ()
    depth = depth - 1
    SELECT CASE tok
    CASE TOKCLOSE
    PRINT "warning: quote before close parenthesis"
    READOBJ = TOK
    CASE TOKDOT
    PRINT "warning: quote before dot"
    READOBJ = TOK
    CASE ELSE
    s = CONS(STRTOATOM("QUOTE"),CONS(tok,0))
    READOBJ = s
    END SELECT
    CASE ELSE
    READOBJ = tok
    END SELECT
END FUNCTION
 
FUNCTION CONS(car,cdr)
    p = ALLOC()
    heap(p,0) = TCONS
    heap(p,1) = car
    heap(p,2) = cdr
    cons = p
END FUNCTION
 
FUNCTION ALLOC()
    ALLOC = hptr
    hptr = hptr + 1 
END FUNCTION
 
FUNCTION READLIST()
    SH = READOBJ()
    SELECT CASE SH
    CASE TOKERR
        READLIST = TOKERR
    CASE TOKCLOSE
        READLIST = 0
    CASE TOKDOT
        SH = READOBJ()
        SELECT CASE SH
        CASE TOKERR, TOKDOT, TOKCLOSE
            READLIST = TOKERR
        CASE ELSE
            ST = READLIST()
            IF ST THEN READLIST = TOKERR ELSE READLIST = SH
        END SELECT
    CASE ELSE
        ST = READLIST()
        IF ST = TOKERR THEN READLIST = TOKERR ELSE READLIST = CONS(SH,ST)
    END SELECT
END FUNCTION
 
FUNCTION EVALOBJ(id, env)
1   SELECT CASE heap(id,0)
    CASE TNIL, TNUM ' self-evaluating
        EVALOBJ = id
    CASE TSYM
        EVALOBJ = LOOKUP(heap(id,1),env)
    CASE TCONS
        o = heap(id,1)
        t = heap(o,0)
        IF t = TSYM THEN
        a$ = atom$(heap(o,1)) ' symbol name of car(id)
        SELECT CASE a$
        CASE "QUOTE"
            EVALOBJ = heap(heap(id,2),1)
        CASE "SET!"
            vid = heap(heap(id,2),1) 'cadr
            aval = heap(heap(heap(id,2),2),1) 'caddr
            CALL setvar(vid, evalobj(aval, env),env)
        CASE "DEFINE"
            vid = heap(heap(id,2),1)
            aval = heap(heap(heap(id,2),2),1)
            CALL setvar(vid, evalobj(aval,env),env)
        CASE "IF"
            ' (if pred ic ia)
            pred = heap(heap(id,2),1) 'predicate = cadr
            ic = heap(heap(heap(id,2),2),1) ' caddr 
            ia = heap(heap(heap(heap(id,2),2),2),1) ' cadddr 
            IF EVALOBJ(pred,env) THEN
                ' return EVALOBJ(ic,env)
                id = ic: GOTO 1 
            ELSE 
                ' return EVALOBJ(ia,env)
                id = ia : GOTO 1 
            END IF
        CASE "LAMBDA"
            p = ALLOC()
            heap(p,0) = TPROC
            heap(p,1) = heap(heap(id,2),1) ' cadr = args
            heap(p,2) = CONS(heap(heap(id,2),2),env) 'caddr = body 
            EVALOBJ = p
        CASE "BEGIN"
        seq = heap(id,2)
        DO WHILE heap(seq,2)
        t = heap(seq,1)
        t = evalobj(t,env) 'ignore result
        seq = heap(seq,2)
        LOOP 
        id = heap(seq,1): GOTO 1
        CASE "AND"
        seq = heap(id,2)
        DO WHILE heap(seq,2)
        t = heap(seq,1)
        t = evalobj(t,env)
        IF t = 0 THEN evalobj = 0: EXIT FUNCTION
        seq = heap(seq,2)
        LOOP 
        id = heap(seq,1): GOTO 1
        CASE "OR"
        seq = heap(id,2)
        DO WHILE heap(seq,2)
        t = heap(seq,1)
        t = evalobj(t,env)
        IF t THEN evalobj = t: EXIT FUNCTION
        seq = heap(seq,2)
        LOOP 
        id = heap(seq,1): GOTO 1
        CASE "COND"
        clauses = heap(id,2)
        WHILE clauses
        clause = heap(clauses, 1)
        pred = heap(clause, 1)
        IF EVALOBJ(pred,env) THEN
           seq = heap(clause, 2)
           DO WHILE heap(seq,2)
            t = heap(seq,1)
            t = evalobj(t,env) 'ignore result
            seq = heap(seq,2)
           LOOP 
           id = heap(seq,1): GOTO 1
        END IF
        clauses = heap(clauses,2)
        WEND
        CASE ELSE
            args = heap(id,2)
            proc = EVALOBJ(o,env)
            EVALOBJ = apply(proc,lvals(args,env))
        END SELECT
        ELSE
            args = heap(id,2)
            proc = EVALOBJ(o, env)
            EVALOBJ = apply(proc,lvals(args,env))
        END IF
    CASE ELSE
        PRINT "Unhandled expression type: "; a$
        EVALOBJ = id
    END SELECT
END FUNCTION
 
FUNCTION lvals(id,env)
   IF heap(id,0) = TCONS THEN
     car = heap(id,1)
     ecar = EVALOBJ(car,env)
     head = CONS(ecar,0)
     l = heap(id,2) : prev = head
     WHILE l
         car = heap(l,1)
         ecar = EVALOBJ(car,env)
         new = CONS(ecar,0)
         heap(prev,2) = new
         prev = new
         l = heap(l,2)
     WEND
     lvals = head
   ELSE
     lvals = 0
   END IF
END FUNCTION
 
FUNCTION apply(id,args)
    IF heap(id,0) = TPROC THEN
    params = heap(id,1)
    body = heap(heap(id,2),1)
    procenv = heap(heap(id,2),2)
    env = CONS(CONS(params,args),procenv)
    DO WHILE heap(body,2)
    t = heap(body,1)
    t = evalobj(t,env) 'ignore result
    body = heap(body,2)
    LOOP
    t = heap(body,1)
    apply = evalobj(t,env)
    ELSEIF heap(id,0) = TPPROC THEN
    SELECT CASE heap(id,1)
    CASE PPLUS
        sum = 0
        a = args
        WHILE a
            sum = sum + heap(heap(a,1),1)
            a = heap(a,2)
        WEND
        p = ALLOC()
        heap(p,0) = TNUM
        heap(p,1) = sum
        apply = p
    CASE PTIMES
        prod = 1
        a = args
        WHILE a
            prod = prod * heap(heap(a,1),1)
            a = heap(a,2)
        WEND
        p = ALLOC()
        heap(p,0) = TNUM
        heap(p,1) = prod
        apply = p
    CASE PCONS
        apply = CONS(heap(args,1), heap(heap(args,2),1))
    CASE PCAR
        apply = heap(heap(args,1),1)
    CASE PCDR
        apply = heap(heap(args,1),2)
    CASE PEQUAL
        IF args = TNIL THEN apply = STRTOATOM("T"): EXIT FUNCTION
        f = heap(heap(args,1),1)
        a = heap(args,2)
        DO WHILE a
            IF heap(heap(a,1),1) <> f THEN apply = TNIL : EXIT FUNCTION
            a = heap(a,2)
        LOOP
        apply = STRTOATOM("T"): EXIT FUNCTION
    CASE PNOT
        IF heap(args,1) THEN apply = TNIL ELSE apply = STRTOATOM("T")
    CASE PEQ
        arg1 = heap(args,1)
        arg2 = heap(heap(args,2),1)
        IF heap(arg1,0) <> heap(arg2,0) THEN apply = TNIL: EXIT FUNCTION
        SELECT CASE heap(arg1,0)
        CASE TNUM, TPROC, TPPROC, TSYM
            IF heap(arg1,1) = heap(arg2,1) THEN apply = STRTOATOM("T") 
        CASE TCONS, TNIL
            IF arg1 = arg2 THEN apply = STRTOATOM("T")
        END SELECT
    CASE PSETCAR
        arg1 = heap(args,1)
        arg2 = heap(heap(args,2),1)
        heap(arg1,1) = arg2
    CASE PSETCDR
        arg1 = heap(args,1)
        arg2 = heap(heap(args,2),1)
        heap(arg2,2) = arg2
    CASE PAPPLY
        arg1 = heap(args,1)
        arg2 = heap(heap(args,2),1)
        apply = apply(arg1,arg2)
    CASE PLIST
        apply = args
    CASE PREAD
        apply = readobj()
    END SELECT
    ELSE
    PRINT "Bad application -- not a function"
    apply = TOKERR
    END IF
END FUNCTION
 
FUNCTION lookup(anum,env)
    ' env is a list of (vars . vals) frames
    ' where: vars is a list of symbols
    '        vals is a list of their values 
    e = env
    DO
    frame = heap(e,1) ' get the first frame
 
    vars = heap(frame,1) ' vars is car
 
    vals = heap(frame,2) ' vals is cdr
 
    WHILE vars ' while vars left to check
        IF heap(heap(vars, 1),1) = anum THEN 'atom number of car(vars) = anum
            lookup = heap(vals,1) ' car(vals)
            EXIT FUNCTION
        END IF
        vars = heap(vars,2) 'cdr(vars)
        vals = heap(vals,2) 'cdr(vals)
    WEND
    e = heap(e,2) ' cdr(e)
    LOOP WHILE e
    PRINT "Unbound variable: "; ATOM$(anum): lookup = TOKERR
END FUNCTION
 
SUB setvar(id, value, env)
    anum = heap(id,1)
    e = env
    DO
        frame = heap(e,1)
        vars = heap(frame,1)
        vals = heap(frame,2)
        WHILE vars
            IF heap(heap(vars,1),1) = anum THEN 
                heap(vals,1) = value : EXIT SUB
            END IF
            vars = heap(vars,2): vals = heap(vals,2)
        WEND
        e = heap(e,2)
    LOOP WHILE e
    CALL defvar(id, value, env)
END SUB
 
SUB defvar(id, value, env)
    anum = heap(id,1)
    frame = heap(env,1)
    vars = heap(frame,1)
    vals = heap(frame,2)
    WHILE vars
        IF heap(heap(vars,1),1) = anum THEN
            heap(vals,1) = value: EXIT SUB
        END IF
        vars = heap(vars,2): vals = heap(vals,2)
    WEND
    vars = heap(frame,1)
    vals = heap(frame,2)
    heap(frame,1) = CONS(id, vars)
    heap(frame,2) = CONS(value, vals)
END SUB
 
FUNCTION mkprimop(id)
 p = alloc()
 heap(p,0) = TPPROC
 heap(p,1) = id
 mkprimop = p
END FUNCTION
 

Pages: [1]

News:

Show Posts

Messages - qbguy

Programs / Sudoku solver

Programs / Re: MicroSoft's version of Reversi

Programs / MicroSoft's version of Reversi

QB64 Discussion / Re: [fixed] QB64 does not interpret 0-place recursive function correctly

Programs / Re: Scheme (LISP) interpreter

QB64 Discussion / [fixed] QB64 does not interpret 0-place recursive function correctly

QB64 Discussion / Re: CD Access

QB64 Discussion / Re: Really got to implement source code printing

Programs / Blackjack game (unfortunately variable names compressed)

Programs / Reversi / Othello Game (play against computer AI)

Programs / Scheme (LISP) interpreter