;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; NAME: mtttt.scm ;;; ;;; DESCRIPTION: The Tomorrow's-Tic-Tac-Toe Game ;;; ;;; AUTHORS: Dan Garcia - University of California at Berkeley ;;; Ported to Scheme by David, Greg, Alex and Alan. ;;; Copyright (C) Dan Garcia, 2001. All rights reserved. ;;; ;;; UPDATE HIST: ;;; ;;; 2001-11-05: (v2.0s) Release for Fall 2001 CS3 ;;; 2002-09-22: (v3.0b) Modified to work with Loopy Gamesman ;;; 2002-10-14: (v3.1b) Modified to work with game-piece driven Gamesman ;;; Still relies on stk-graphics package instead of gdraw.scm ;;; 2002-10-29: (v3.2b) ;;; 2002-11-05: (v3.2s) Graphics updated using new gdraw.scm package ;;; 2002-11-15: (v3.3s) Added GUI features to handle mouse input & motion! ;;; 2003-11-03: (v4.0) Changed to be "Tomorrow's TTT", arb rows & cols ;;; 2003-11-04: (v4.1) Corrected many DAVs, up-down flip bugs remain ;;; 2003-11-04: (v4.2) Fixed Simple and GUI up-down bugs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The comment ALL GAMES appears next to things that are common to all ;;; Gamesman games ;;;;;;;;; ;;; These tell the library a bit about the game. ALL GAMES ;;;;;;;;; (define *game-name* "Tomorrow's-Tic-Tac-Toe") (define *group-members* "The Gamesmen") (name-game-pieces "X-player" "O-player") ;;;;;;;;; ;;; GET-TURN (helper for whose-move) ;;; Input: position ;;; Output: a turn representation, x or o ;;; Example: (get-turn '(x --- -x- --o)) ==> x ;;;;;;;;; (define (get-turn position) (first position)) ;;;;;;;;; ;;; WHOSE-MOVE ALL GAMES ;;; Input: Position ;;; Output: either "X-Player" or "O-Player" ;;; (the piece whose turn it is to move) ;;; Example: (whose-move '(x --- --- ---)) ==> "X-Player" ;;;;;;;;; (define (whose-move position) (if (equal? (get-turn position) 'x) "X-player" "O-player")) ;;;;;;;;; ;;; MAKE-POSITION ALL GAMES ;;; Input: Player, Board ;;; Output: A position ;;; Example: (make-position 'x '(--- --- ---)) ==> (x --- --- ---) ;;;;;;;;; (define (make-position player board) (se player board)) ;;;;;;;;; ;;; MAKE-BOARD ALL GAMES ;;; Input: Number of rows R, number of columns C ;;; Note: Input to MAKE-BOARD is dependent on the game. ;;; It may take additional or different information ;;; (number of rows, columns, a player, pieces, etc.). ;;; Output: An empty board of size R by C (rows by columns) ;;; Example: (make-board 3 4) ==> (---- ---- ----) ;;;;;;;;; (define (make-board r c) ((repeated (lambda (board-so-far) (se board-so-far ((repeated (lambda (col-so-far) (word '- col-so-far)) c) ""))) r) '())) ;;;;;;;;; ;;; GET-BOARD ALL GAMES ;;; Input: Position ;;; Output: A board ;;; Example: (get-board '(x --- -x- --o)) ==> (--- -x- --o) ;;;;;;;;; (define (get-board position) (bf position)) ;;;;;;;;; ;;; GET-NUM-ROWS ALL GAMES ;;; Input: Position ;;; Output: The number of rows in POSITION ;;; Example: (get-num-rows '(x ---- -x-- -oxo)) ==> 3 ;;;;;;;;; (define (get-num-rows position) (count (get-board position))) ;; one row per word ;;;;;;;;; ;;; GET-NUM-COLS ALL GAMES ;;; Input: Position ;;; Output: The number of columns in POSITION ;;; Example: (get-num-cols '(x ---- -x-- -oxo)) ==> 4 ;;;;;;;;; (define (get-num-cols position) (count (first-row (get-board position)))) ;; assume all rows same size ;;;;;;;;; ;;; Abstractions for cells, single squares on a Tic-Tac-Toe board ;;;;;;;;; (define *alphabet* 'abcdefghijklmnopqrstuvwxyz) (define (blank? cell) (equal? cell '-)) (define (x? cell) (equal? cell 'x)) (define (o? cell) (equal? cell 'o)) (define (X-turn? position) (equal? (get-turn position) 'x)) ;;;;;;;;; ;;; Selectors for position, board, row, moves ;;;;;;;;; ;;; GET-CELL ;;; Input: Position POSITION, row number R-NUM, column number C-NUM ;;; Output: The piece in the cell defined by R-NUM and C-NUM (define (get-cell position r-num c-num) (item c-num (get-row r-num position))) ;;; GET-ROW ;;; Input: Integer k, position ;;; Output: kth row (define (get-row k position) (item k (get-board position))) ;;; APPEND-ROW ;;; Input: ROW row, BOARD board ;;; Output: The new board with the row appended to the front of it (define (append-row row board) (se row board)) ;;; FIRST-ROW ;;; Input: Board ;;; Output: The first row (define (first-row board) (first board)) ;;; BF-ROW ;;; Input: Board ;;; Output: The board with the first row removed (define (bf-row board) (bf board)) ;;; LAST-ROW ;;; Input: Board ;;; Output: The last row (define (last-row board) (last board)) ;;; BL-ROW ;;; Input: Board ;;; Output: The board with the last row removed (define (bl-row board) (bl board)) ;;; EMPTY-BOARD? ;;; Input: Board ;;; Output: #t if the board is empty, #f otherwise (define (empty-board? board) (empty? board)) ;;; APPEND-COL ;;; Input: PIECE piece, col (partial-column) ;;; Output: The column with piece appended to the front of it (define (append-col piece col) (word piece col)) ;;; FIRST-COL ;;; Input: Row ;;; Output: The column piece of the row (define (first-col row) (first row)) ;;; BF-COL ;;; Input: Row ;;; Output: The row with the first column piece removed (define (bf-col row) (bf row)) ;;; EMPTY-ROW? ;;; Input: Row ;;; Output: #t if the row is empty, #f otherwise (define (empty-row? row) (empty? row)) ;;; ROW-NUM ;;; Input: a move MOVE ;;; Output: row number (define (row-num move) (bf move)) ;;; COL-NUM ;;; Input: a move MOVE ;;; Output: column number (define (col-num move) (index (first move) *alphabet*)) ;;; INDEX ;;; Input: an item ITEM, word/sent to reference from REF ;;; Output: a number N such that ITEM is the Nth item in REF (define (index item ref) (cond ((empty? ref) 0) ((equal? (first ref) item) 1) (else (+ 1 (index item (bf ref)))))) ;;;;;;;;; ;;; Constructors for position, board, row, moves ;;;;;;;;; ;;; MAKE-MOVE ;;; Input: Column letter COL-LTTR, row number ROW-NUM ;;; Output: MOVE (define (make-move col-lttr row-num) (word col-lttr row-num)) ;;;;;;;;; ;;; Create the game-specific option menu ALL GAMES ;;; ;;; Menu entries are added with a call to: ;;; (ADD-MENU-ENTRY! printer changer) ;;; The PRINTER is a procedure that displays the menu entry ;;; The CHANGER is a procedure that takes user input (if applicable) ;;; and changes the menu entry. ;;;;;;;;; ;;; DISPLAY-STANDARD-MISERE gets called to display the STANDARD-GAME option (define (display-standard-misere) (if (get-rule 'standard-game) (display "Toggle from [STANDARD] to misere play") (display "Toggle from [MISERE] to standard play"))) ;;; TOGGLE-STANDARD-MISERE gets called to change the STANDARD-GAME option. (define (toggle-standard-misere) (set-rule! 'standard-game (not (get-rule 'standard-game)))) ;;; Add the menu entry (add-menu-entry! display-standard-misere toggle-standard-misere) ;;; Set the default value (set-rule! 'standard-game #t) ;;; DISPLAY-INITIAL gets called to display the INITIAL-POSITION option. (define (display-initial) (display "Change initial position. Currently set to: ") (display (get-rule 'initial-position))) ;;; CHANGE-INITIAL gets called to change the INITIAL-POSITION option. ;;; It does not currently error check the user's position. (define (change-initial) (display "Should x or o go first? ") (let ((player (read))) (if (not (or (x? player) (o? player))) (begin (display "Invalid player.")(newline) (change-initial)) (begin (display "Now enter the number of rows: ") (let ((n-rows (read))) (if (not (and (integer? n-rows) (> n-rows 0))) (begin (display "Invalid number.")(newline) (change-initial)) (begin (display "And the number of columns: ") (let ((n-cols (read))) (if (not (and (integer? n-cols) (> n-cols 0))) (begin (display "Invalid number.")(newline) (change-initial)) (add-pieces player (make-board n-rows n-cols))))))))))) ;;; ADD-PIECES ;;; A loop to receive user input about adding pieces to the current initial position. (define (add-pieces player board) (let ((pos (make-position player board))) (newline) (display "The current board is ")(newline)(print-position pos)(newline) (display "To place a piece on the board, enter the piece and position in parentheses,")(newline) (display " otherwise type 'p'.")(newline) (display " (e.g. (x a2) places a piece x at the location a2): ") (let ((ans (read))) (if (equal? ans 'p) (set-rule! 'initial-position pos) (if (or (not (= (count ans) 2)) (not (or (equal? (first ans) 'x) (equal? (first ans) 'o))) (> 0 (row-num (first (bf ans)))) (< (get-num-rows pos) (row-num (first (bf ans)))) (> 0 (col-num (first (bf ans)))) (< (get-num-cols pos) (col-num (first (bf ans))))) (begin (display "Invalid input.")(newline) (add-pieces player board)) (add-pieces player (replace-cell board (+ 1 (- (get-num-rows pos) (row-num (first (bf ans))))) (col-num (first (bf ans))) (first ans)))))))) ;;; Add to the menu (add-menu-entry! display-initial change-initial) ;;; DISPLAY-DIAG gets called to display the DIAG option (define (display-diag) (if (get-rule 'diag-wins) (display "Toggle from [DIAGONALS-ARE-3-IN-ROW] to diagonals-not-3-in-row") (display "Toggle from [DIAGONALS-NOT-3-IN-ROW] to diagonals-are-3-in-row"))) ;;; TOGGLE-DIAG gets called to change the DIAG option (define (toggle-diag) (set-rule! 'diag-wins (not (get-rule 'diag-wins)))) ;;; Add the menu entry (add-menu-entry! display-diag toggle-diag) ;;; Set the default value (set-rule! 'diag-wins #f) ;;;;;;;;; ;;; Set the starting position ;;;;;;;;; ;; copied down to below do-move [do-move needs to be defined to be able to ;; set the initial position] ;;;;;;;;; ;;; PRINT-HELP ALL GAMES ;;; Side-Effect: Prints a useful help message about the current game ;;; given the current options. ;;;;;;;;; (define (print-help) (newline) (show "ON YOUR TURN...") (newline) (show "You place one of your pieces on one of the empty board positions.") (newline) (show "THE OBJECTIVE IS...") (newline) (let ((diag-help (if (get-rule 'diag-wins) "horizontally, vertically, or diagonally" "horizontally or vertically"))) (if (get-rule 'standard-game) (begin (show "To get three of your markers (either X or O) in a row, either") (display diag-help) (show ". 3-in-a-row WINS. A tie") (show "occurs when the board fills up without either player getting") (show "three-in-a-row.")) (begin (show "To force your opponent into getting three of her markers (either X or O)") (display "in a row, either ") (display diag-help) (show ". 3-in-a-row") (show "LOSES. A tie occurs when the board fills up without either player") (show "getting three-in-a-row."))) (newline))) ;;;;;;;;; ;;; PRINT-POSITION ALL GAMES ;;; Input: Position ;;; Side-Effect: Prints the board pretty along with the column and row legends ;;;;;;;;; (define (print-position position) (pp-helper (get-board position) (get-num-rows position)) (print-col-legend (get-num-cols position) 1)) ;;; PP-HELPER ;;; Input: Board BOARD, number of rows ROWS ;;; Side-Effect: Prints the board pretty along with the row legend (define (pp-helper board rows) (if (empty-board? board) 'done (begin (if (> rows 9) (display (word " " rows " | ")) (display (word " " rows " | "))) (print-row (first board))(newline) (pp-helper (bf board) (- rows 1))))) ;;; Prints a given ROW of the game board on a newline (define (print-row row) (if (empty-row? row) 'done (begin (display (first-col row)) (display " ") (print-row (bf-col row))))) ;;; Prints a the alphabet column legend given the board size (number of columns) (define (print-col-legend cols counter) (display " ") ((repeated (lambda (counter) (display (word (item counter *alphabet*) " ")) (+ counter 1)) cols) counter) 'done) ;;;;;;;;; ;;; DO-MOVE ALL GAMES ;;; Input: Position, move ;;; Output: New position that results from the move ;;; Example: (do-move '(x --x -o- ---) 'a2) ==> (o --x xo- ---) ;;;;;;;;; (define (do-move position move) (make-position (get-other-player position) (replace-cell (get-board position) (+ 1 (- (get-num-rows position) (row-num move))) (col-num move) (get-turn position)))) ;;;;;;;;; ;;; GET-OTHER-PLAYER ;;; Input: position ;;; Output: word, the other player ;;; Example: (get-other-player '(x --- --- ---)) => 'o ;;;;;;;;; (define (get-other-player position) (if (X-turn? position) 'o 'x)) ;;; REPLACE-CELL ;;; Input: Board BOARD, row-number R, column-number C, piece PIECE ;;; Output: New board with Rth-Cth cell replaced with PIECE (define (replace-cell board r c piece) (if (= r 1) (append-row (rep-helper (first-row board) c piece) (bf-row board)) (append-row (first-row board) (replace-cell (bf-row board) (- r 1) c piece)))) ;;; REP-HELPER ;;; Input: Row ROW, column-number C, piece PIECE ;;; Output: New row with Cth cell replaced with PIECE (define (rep-helper row c piece) (if (= c 1) (append-col piece (bf-col row)) (append-col (first-col row) (rep-helper (bf-col row) (- c 1) piece)))) ;;; The default initial game position ALL GAMES (shifted down after do-move) (set-rule! 'initial-position ;; '(x ---- x--- --o-) (do-move (do-move (make-position 'x (make-board 3 4)) (make-move 'a 2)) (make-move 'c 1))) ;;;;;;;;; ;;; GENERATE-MOVES ALL GAMES ;;; Input: Position ;;; Output: LIST of all possible moves that can be made from the position ;;; Example: (generate-moves '(x oxx -o- -xo)) ==> (a2 c2 a1) ;;;;;;;;; (define (generate-moves position) (blank-cells (get-board position) (get-num-rows position) (get-num-cols position) 1)) ;;; BLANK-CELLS ;;; Input: Board BOARD, number of rows NUM-ROWS, number of columns NUM-COLS, row counter R ;;; Output: LIST of all blank cells in the position (define (blank-cells board num-rows num-cols r-counter) (if (empty-board? board) (list) ;; null list (append (map (lambda (col-lttr) (make-move col-lttr (+ 1 (- num-rows r-counter)))) (bc-helper (first-row board) num-cols 1)) (blank-cells (bf-row board) num-rows num-cols (+ 1 r-counter))))) ;;; BC-HELPER ;;; Input: Row ROW, number of columns NUM-COLS, column counter C ;;; Output: LIST of all blank cells in the row (define (bc-helper row num-cols c) (cond ((empty-row? row) '()) ((blank? (first-col row)) (cons (item c *alphabet*) (bc-helper (bf-col row) (- num-cols 1) (+ 1 c)))) (else (bc-helper (bf-col row) (- num-cols 1) (+ 1 c))))) ;;;;;;;;; ;;; PRIMITIVE-POSITION ALL GAMES ;;; Input: Position ;;; Output: ;;; 'l (for lose) if the player whose turn it is has lost ;;; 'w (for win) if the player whose turn it is has won ;;; 't (for tie) if the game is a tie ;;; #f if the game isn't over ;;; ;;; In other words, PRIMITIVE-POSITION should tell us the status of the game ;;; for the player whose turn it is. In the second example, it is O's turn, ;;; but the board has three-in-a-row, therefore this is a LOSE for O. ;;;;;;;;; (define (primitive-position position) (cond ((three-in-a-row? position 1) (if (get-rule 'standard-game) 'l 'w)) ((all-filled-in? (get-board position)) 't) (else #f))) ;;; THREE-IN-A-ROW? ;;; Input: Position, three cell numbers ;;; Output: TRUE if the three cells contain the same (non-blank) piece ;;; FALSE otherwise (define (three-in-a-row? position row-counter) (if (> row-counter (get-num-rows position)) #f (or (check-row-num position row-counter 1) (three-in-a-row? position (+ 1 row-counter))))) ;;; CHECK-ROW-NUM ;;; Input: Position POSITION, row number ROW-NUM, counter for columns COL-COUNTER ;;; Output: TRUE if a piece in ROW-NUMth row is part of a three-in-a-row winner ;;; FALSE otherwise (define (check-row-num position row-num col-counter) (cond ((> col-counter (get-num-cols position)) #f) ((not (blank? (get-cell position row-num col-counter))) (or (check-around position row-num col-counter) (check-row-num position row-num (+ 1 col-counter)))) (else (check-row-num position row-num (+ 1 col-counter))))) ;;; CHECK-AROUND ;;; Input: Position POSITION, row-number R-NUM, column number C-NUM ;;; Output: TRUE if the cell defined by R-NUM and C-NUM is the middle piece of three-in-a-row winner ;;; FALSE otherwise (define (check-around position r-num c-num) (let ((l (- c-num 1)) (r (+ c-num 1)) (u (- r-num 1)) (d (+ r-num 1)) (num-rows (get-num-rows position)) (num-cols (get-num-cols position))) (if (or ;; check horizontal (and (> l 0) (<= r num-cols) (same-three? (get-cell position r-num l) (get-cell position r-num c-num) (get-cell position r-num r))) ;; check vertical (and (> u 0) (<= d num-rows) (same-three? (get-cell position u c-num) (get-cell position r-num c-num) (get-cell position d c-num))) ;; check diagonals (and (get-rule 'diag-wins) (> l 0) (<= r num-cols) (> u 0) (<= d num-rows) (or (same-three? (get-cell position u l) (get-cell position r-num c-num) (get-cell position d r)) (same-three? (get-cell position u r) (get-cell position r-num c-num) (get-cell position d l))))) (get-cell position r-num c-num) #f))) ;;; SAME-THREE? ;;; Input: three pieces P1, P2, P3 ;;; Output: TRUE if the three pieces are the same ;;; FALSE otherwise (define (same-three? p1 p2 p3) (and (equal? p1 p2) (equal? p2 p3))) ;;; SAME-PLAYER? ;;; Input: two players P1, P2 ;;; Output: TRUE if the players are the same ;;; FALSE otherwise (define (same-player? p1 p2) (equal? p1 p2)) ;;; ALL-FILLED-IN? ;;; Input: Board ;;; Output: TRUE if all positions in BOARD are taken, FALSE otherwise (define (all-filled-in? board) (zero? (accumulate + (every (lambda (row) (count (keep blank? row))) board)))) ;;;;;;;;;;;;; ;;; SIMPLE GRAPHICS ;;;;;;;;;;;;; ;;;;;;;;;;;;; ;;; DRAW-POSITION ALL GAMES ;;; Input: position ;;; Side-Effect: Draw the position on the board with lines and pieces ;;; ;;; This is called if Gamesman is in simple-graphics mode. ;;;;;;;;;;;;; (define (draw-position pos) (let ((num-rows (get-num-rows pos)) (num-cols (get-num-cols pos))) (let ((square-height (get-square-height pos)) (square-width (get-square-width pos))) (let ((board-height (* num-rows square-height)) (board-width (* num-cols square-width))) ;;; the following functions are internal to draw-position and have access ;;; to the variables defined above: ;;; 1.draw-x, 2.draw-o, 3.draw-row, 4.draw-piece, 5.draw-all-pieces ;;; DRAW-X ;;; Input: coordinates x, y (bottom-left corner of square) ;;; Draws an X piece at the coordinates (define (draw-x x y) (draw-line (+ x (* .1 square-width)) (+ y (* .1 square-height)) (+ x (* .9 square-width)) (+ y (* .9 square-height)) ;; the two points 'width (quotient square-height 10) ;; thickness of line 'fill "red") ;; color of line ;; draws back slash (draw-line (+ x (* .1 square-width)) (+ y (* .9 square-height)) (+ x (* .9 square-width)) (+ y (* .1 square-height));; the two points 'width (quotient square-height 10) ;; thickness of line 'fill "red") ;; color of line ) ;;; DRAW-0 ;;; Input: coordinates x, y ;;; Draws an 0 piece at the coordinates (define (draw-o x y) (draw-oval (+ x (* .1 square-width)) (+ y (* .1 square-height)) (+ x (* .9 square-width)) (+ y (* .9 square-height)) ;; the two points ;; x (+ y square-height) (+ x square-width) y ;; the two points 'width (quotient square-height 10) ;; thickness of line 'outline "blue" ;; color of O 'fill "white")) ;; color inside O ;;; DRAW-ROW ;;; Input: row ;;; Side-Effect: draws all the pieces for the given row (define (draw-row row x-cor y-cor) (if (empty-row? row) #t (begin (draw-piece x-cor y-cor (first-col row)) (draw-row (bf-col row) (+ x-cor square-width) y-cor) ) ) ) ;;; DRAW-ALL-PIECES ;;; Input: board, initial y-coordinate ;;; Side-Effect: draws all the pieces on the position bottom to top, left to right (define (draw-all-pieces board y-cor) (if (empty-board? board) #t (begin (draw-row (first-row board) 0 y-cor) (draw-all-pieces (bf-row board) (+ square-height y-cor)) ) ) ) ;;; DRAW-PIECE ;;; Input: board, x and y coordinates, and the piece to draw ;;; Side-Effect: draw the pieces in the correct place (define (draw-piece x y piece) (cond ((x? piece) (draw-x x y)) ((o? piece) (draw-o x y)) (else 'okay))) ;;;; End of the function definitions internal to draw-position ;;;; Note that these functions CANNOT be called outside draw-position ;;;; Beginning of the actual DRAW-POSITION execution. (clear-graphics!) (draw-all-pieces (get-board pos) 0) (draw-frame pos))))) ;;;;;;;;; ;;; INIT-CANVAS ALL GAMES ;;; Input: None ;;; Side-Effect: Set the size of the canvas to whatever is desired. ;;; ;;; This function is called by Gamesman each time simple graphics are turned on. ;;;;;;;;; ;; these can be changed or abstracted later ;; I think the board size should be some even number of pixels per sqaure. ;; E.g. 5 x 7 (rows x cols) should be by (define *board-horizontal-max* 600) (define *board-vertical-max* 600) ;; the closest number of horizontal pixels that ;; each square can be and not exceed the max size of the canvas. (define (get-square-width pos) (quotient *board-horizontal-max* (get-num-cols pos))) ;; the closest number of vertical pixels that ;; each square can be and not exceed the max size of the canvas. (define (get-square-height pos) (quotient *board-vertical-max* (get-num-rows pos))) (define (init-canvas pos) (set-canvas-size (* (get-num-rows pos) (get-square-height pos)) (* (get-num-cols pos) (get-square-width pos)))) ;;; DRAW-FRAME ;;; Draws the Tic Tac Toe board with no pieces. (define (draw-frame pos) (let ((num-rows (get-num-rows pos)) (num-cols (get-num-cols pos))) (let ((square-height (get-square-height pos)) (square-width (get-square-width pos))) (let ((board-height (* num-rows square-height)) (board-width (* num-cols square-width ))) (define (draw-vert-lines lines-drawn-so-far) (let ((x-cor (* (+ 1 lines-drawn-so-far) square-width))) (if (= num-cols (+ 1 lines-drawn-so-far)) #t ;; done drawing (begin (draw-line x-cor 0 x-cor board-height) (draw-vert-lines (+ 1 lines-drawn-so-far)))))) (define (draw-horiz-lines lines-drawn-so-far) (let ((y-cor (* (+ 1 lines-drawn-so-far) square-height))) (if (= num-rows (+ 1 lines-drawn-so-far)) #t ;; done drawing (begin (draw-line 0 y-cor board-width y-cor) (draw-horiz-lines (+ 1 lines-drawn-so-far)))))) (set-default-fill-color! "black") (draw-vert-lines 0) (draw-horiz-lines 0) ) ) ) ) ;;;;;;;;;;;;; ;;; GUI GRAPHICS -The fun stuff!!!! ;;;;;;;;;;;;; ;;;;;;;;;;;;; ;; WARNING!!! ;; GUI code below is uncommented. See online documentation for details. ;; We hope to have the below code documented in a future release of mtttt.scm ;; ;; In General, any procedure that starts with "gui-" is one that is required for ;; full interaction with the Graphical User Interface (GUI) and will be called ;; by gamesman.scm. All the others are just helpers we use internally here. ;; ;; REFER TO THE WEB PAGE FOR REQUIRED GUI PROCEDURES! ;;;;;;;;;;;;; (define *square-size* 170) ;;; GUI-DRAW-FRAME ;;; Draws the Tic Tac Toe board with no pieces. (define (gui-draw-frame num-rows num-cols board-size) (set-default-fill-color! "black") (gui-draw-vert-lines 0 board-size num-cols) (gui-draw-horiz-lines 0 board-size num-rows)) ;;; GUI-DRAW-VERT/HORIZ-LINES ;;; Draws the verticle/horizontal lines (define (gui-draw-vert-lines num-done board-size num-cols) (let ((x-cor (* (+ 1 num-done) *square-size*))) (if (= num-cols (+ 1 num-done)) #t ;; done drawing (begin (draw-line x-cor 0 x-cor board-size) (gui-draw-vert-lines (+ 1 num-done) board-size num-cols))))) (define (gui-draw-horiz-lines num-done board-size num-rows) (let ((y-cor (* (+ 1 num-done) *square-size*))) (if (= num-rows (+ 1 num-done)) #t ;; done drawing (begin (draw-line 0 y-cor board-size y-cor) (gui-draw-horiz-lines (+ 1 num-done) board-size num-rows))))) ;;;;;;;;;;;;; ;;; GUI-INIT-BOARD ;;; Input: Initial-position ;;; Side-Effect: Prepares the GUI board ;;;;;;;;;;;;; (define (gui-init-board initial-position) (let ((num-rows (get-num-rows initial-position)) (num-cols (get-num-cols initial-position))) (set-canvas-size (* num-cols *square-size*) (* num-rows *square-size*)) (make-all-pieces initial-position 0 0 1 1) (gui-draw-frame num-rows num-cols (* (max num-rows num-cols) *square-size*)) (fill-canvas initial-position 1 1) (set-binding! 'base (lambda () (make-board-move initial-position (first (get-mouse-coords)) (first (bf (get-mouse-coords)))))))) ;;; MAKE-BOARD-MOVE ;;; Brings forward the correct player piece depending on where the mouse clicked (define (make-board-move pos x y) (let ((col (item (coord-to-slot pos x) *alphabet*)) (row (+ 1 (- (get-num-rows pos) (coord-to-slot pos y))))) (gui-return-from-human-move (make-move col row)))) ;;; COORD-TO-SLOT ;;; Converts the x- or y- coordinate value to the correct slot number based on the board (define (coord-to-slot pos coord) (if (< coord *square-size*) 1 (+ 1 (coord-to-slot pos (- coord *square-size*))))) ;;; MAKE-ALL-PIECES ;;; Makes all the pieces in POS and lowers it behind the canvas (define (make-all-pieces pos x y r-counter tag) (let* ((num-rows (get-num-rows pos)) (num-cols (get-num-cols pos)) (board-size (* (max num-rows num-cols) *square-size*))) (if (> r-counter num-rows) #t (begin (make-row (item r-counter (get-board pos)) 0 y tag pos) (make-all-pieces pos 0 (+ *square-size* y) (+ 1 r-counter) (+ num-cols tag)) ) ) )) ;;; MAKE-ROW ;;; Draws the pieces in ROW beginning at coordinate (X,Y) and lowers it behind the canvas (define (make-row row x y tag pos) (if (empty-row? row) #t (begin (draw-image x y "white-back.gif" 'anchor 'nw 'tag 'base) (make-x (+ x 85) (+ y 85) (word 'x- tag) pos) (make-o (+ x 85) (+ y 85) (word 'o- tag) pos) (lower-under-base (word 'x- tag)) (lower-under-base (word 'o- tag)) (make-row (bf-col row) (+ x *square-size*) y (+ 1 tag) pos) ) ) ) ;;; MAKE-X / MAKE-O ;;; Draws the corresponding X or O piece at coordinate (X,Y) with the given TAG number (define (make-x x y tag pos) (draw-image x y "xicon.ppm" 'anchor 'center 'tag tag) (set-binding! tag (lambda () (make-board-move pos (first (get-mouse-coords)) (first (bf (get-mouse-coords))))))) (define (make-o x y tag pos) (draw-oval (- x 60) (- y 60) (+ x 60) (+ y 60) 'fill "" 'outline "blue" 'width 20 'tag tag) (set-binding! tag (lambda () (make-board-move pos (first (get-mouse-coords)) (first (bf (get-mouse-coords))))))) ;;; FILL-CANVAS ;;; Given the initial position POS, brings up necessary pieces on the board (define (fill-canvas pos r-counter tag) (let ((num-rows (get-num-rows pos)) (num-cols (get-num-cols pos))) (if (> r-counter num-rows) #t (begin (fill-row (item r-counter (get-board pos)) tag) (fill-canvas pos (+ 1 r-counter) (+ num-cols tag)) ) ) )) ;;; FILL-ROW ;;; Given the ROW from the initial position, brings up necessary pieces on the board (define (fill-row row tag) (cond ((empty-row? row) #t) ((x? (first-col row)) (raise-over-base (word 'x- tag)) (fill-row (bf-col row) (+ 1 tag))) ((o? (first-col row)) (raise-over-base (word 'o- tag)) (fill-row (bf-col row) (+ 1 tag))) (else (fill-row (bf-col row) (+ 1 tag))))) ;;; GET-TAG-NUM ;;; Given the cell defined by MOVE, returns the corresponding tag number for the piece at the cell (define (get-tag-num move pos) (+ (* (- (+ 1 (- (get-num-rows pos) (row-num move))) 1) (get-num-cols pos)) (col-num move))) ;;;;;;;;;;;;; ;;; GUI-SHOW/HIDE-ALL-MOVES ;;; Input: POSITION, list of moves MOVELIST ;;; Side-Effect: Shows/hides all types of moves in MOVELIST ;;;;;;;;;;;;; (define (gui-show-all-moves position movelist) (moves-helper position movelist (if (X-turn? position) "xicongrey.gif" "grey") raise-over-base)) (define (gui-hide-all-moves position movelist) (moves-helper position movelist (if (X-turn? position) "xicon.ppm" "blue") lower-under-base)) ;;;;;;;;;;;;; ;;; GUI-SHOW/HIDE-VALUE-MOVES ;;; Input: POSITION, list of WIN-MOVES, list of LOSE-MOVES, list of TIE-MOVES, list of DRAW-MOVES ;;; Side-Effect: Shows/hides moves according to value ;;;;;;;;;;;;; (define (gui-show-value-moves position win-moves lose-moves tie-moves draw-moves) (moves-helper position win-moves (if (X-turn? position) "xicongreen.gif" "green") raise-over-base) (moves-helper position lose-moves (if (X-turn? position) "xiconred.gif" "red") raise-over-base) (moves-helper position (append tie-moves draw-moves) (if (X-turn? position) "xiconyellow.gif" "yellow") raise-over-base)) (define (gui-hide-value-moves position win-moves lose-moves tie-moves draw-moves) (moves-helper position (append win-moves lose-moves tie-moves draw-moves) (if (X-turn? position) "xicon.ppm" "blue") lower-under-base)) (define (get-value-pair value) (cond ((equal? value 'w) (list "xicongreen.gif" "green")) ((equal? value 'l) (list "xiconred.gif" "red")) (else (list "xiconyellow.gif" "yellow")))) ;;;;;;;;;;;;; ;;; GUI-SHOW/HIDE-SAFE-MOVES ;;; Input: POSITION, list of moves MOVELIST, VALUE ;;; Side-Effect: Shows/hides all safe moves (the highest type value move) ;;;;;;;;;;;;; (define (gui-show-safe-moves position movelist value) (let ((value-pair (get-value-pair value))) (moves-helper position movelist (if (X-turn? position) (car value-pair) (cadr value-pair)) raise-over-base))) (define (gui-hide-safe-moves position movelist value) (moves-helper position movelist (if (X-turn? position) "xicon.ppm" "blue") lower-under-base)) ;;;;;;;;;;;;; ;;; GUI-HANDLE-UNDO ;;; Input: Position CURRENT-POSITION, move MOVE-TO-UNDO, position POSITION-AFTER-UNDO ;;; Side-Effect: Undoes whatever graphical move just made ;;;;;;;;;;;;; (define (gui-handle-undo current-position move-to-undo position-after-undo) (lower-under-base (word (first position-after-undo) '- (get-tag-num move-to-undo current-position)))) ;;;;;;;;;;;;; ;;; GUI-HANDLE-MOVE ;;; Input: Position OLD-POSITION, MOVE, position NEW-POSITION ;;; Side-Effect: Graphically implements the move ;;;;;;;;;;;;; (define (gui-handle-move old-position move new-position) (let* ((posX (- (random 400) 200)) (posY (- (random 400) 200)) (tag (if (X-turn? old-position) (word 'x- (get-tag-num move old-position)) (word 'o- (get-tag-num move old-position)))) (coords (get-coords tag)) (origX (car coords)) (origY (cadr coords))) (begin (set-coords! tag (if (X-turn? old-position) (pos-mod-X coords posX posY) (pos-mod-O coords posX posY))) (raise-over-base tag) (fly-to origX origY tag 10 (if (X-turn? old-position) pos-mod-X pos-mod-O))))) ;;; POS-MOD-X/0 ;;; Helps create the flying in of pieces (define (pos-mod-X coords dx dy) (list (+ (car coords) dx) (+ (cadr coords) dy))) (define (pos-mod-O coords xInc yInc) (let ((x1 (car coords)) (y1 (cadr coords)) (x2 (caddr coords)) (y2 (cadddr coords))) (list (+ x1 xInc) (+ y1 yInc) (+ x2 xInc) (+ y2 yInc)))) ;;; MOVES-HELPER ;;; Used in showing/hiding moves in MOVELIST (define (moves-helper position movelist type raise-or-lower) (if (null? movelist) 'okay (let ((tag (word (if (X-turn? position) 'x- 'o-) (get-tag-num (car movelist) position)))) (modify-piece tag type) (raise-or-lower tag) (moves-helper position (cdr movelist) type raise-or-lower)))) ;;; MODIFY-PIECE ;;; Changes the settings of the image TAG (define (modify-piece tag type) (if (x? (first tag)) (set-image! tag type) (set-outline-color! tag type))) ;;; RAISE/LOWER-OVER-BASE ;;; Raises/lowers the given IDorTAG (define (raise-over-base idortag) (raise! idortag 'base)) (define (lower-under-base idortag) (lower! idortag 'base))