gistfile1.scm

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;CONNECT 4 - By Ben Kolera
 ;;
 ;;Last Revised, 6/7/05
 ;;N.B - "Best Moves" functionality still not implemented.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;Interact with the game object, "g" defined in the last line of these defns.
 ;;You could create other games in the interactions window on the fly, or just
 ;;Alter the defintion of g to change players, board size and etc... 
 ;;
 ;;To play this game, execute the code and type,  (g 'play) into the 
 ;;interactions window. 
 ;;
 ;;when a game is over, type (g 'exit) to cleanly exit the game or 
 ;;send the game the play symbol again to replay.
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (require (lib "graphics.ss" "graphics"))
 
 ;;a connect-gui is an object that is responsible for creating and maintaining 
 ;;the graphical representation of a game board. 
 (define make-connect-gui
   (lambda (height width)
     (let ((game-board '()))
       
       ;;colour constants
       (define BACK_COL (make-rgb 0 0.25 0.5))
       (define TOKEN_OFF_COL (make-rgb 1 1 1))
       (define TOKEN_P1_COL (make-rgb 0 0 1))
       (define TOKEN_P2_COL (make-rgb 1 0 0))
       (define FRAME_BACK_COL (make-rgb 0 .5 1))
       (define FRAME_FORE_COL (make-rgb 0 .75 1))
       (define HILIGHT_COL (make-rgb .5 .5 .5))
       
       ;constants for graphic dimentions
       
       (define FRAME_PAD 5)
       (define FRAME_THICK 10)
       (define TOKEN_PAD 5)
       (define TOKEN_RADIUS 50)
       (define FRAME_WIDTH  
         (+ (* FRAME_THICK 2) (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) width)))
       (define FRAME_HEIGHT 
         (+ (* FRAME_THICK 2) (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) height)))
       (define FRAME_POS 
         (make-posn FRAME_PAD 
                    (+ (* 2 TOKEN_PAD) TOKEN_RADIUS)))
       (define FRAME_INNER_POS 
         (make-posn (+ FRAME_PAD FRAME_THICK) 
                    (+ (* 2 TOKEN_PAD) TOKEN_RADIUS FRAME_THICK)))
       (define FRAME_INNER_WIDTH  (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) width))
       (define FRAME_INNER_HEIGHT (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) height))
       (define VIEW_HEIGHT (+ (* 2 TOKEN_PAD) TOKEN_RADIUS FRAME_HEIGHT))
       (define VIEW_WIDTH (+ (* 2 FRAME_PAD) FRAME_WIDTH))
       
       ;;draws the frame onto the canvas.      
       (define draw-frame
         (lambda ()
           ((draw-solid-rectangle canvas) 
            FRAME_POS FRAME_WIDTH FRAME_HEIGHT FRAME_BACK_COL)
           ((draw-solid-rectangle canvas) 
            FRAME_INNER_POS FRAME_INNER_WIDTH FRAME_INNER_HEIGHT FRAME_FORE_COL)
           ))  
       
       ;;draws the tokens onto the frame
       (define draw-tokens 
         (lambda (b i)
           (if (= i (- width 1))
               (draw-row (car b) i 0)
               (begin 
                 (draw-row (car b) i 0)
                 (draw-tokens (cdr b) (+ i 1)))
               )))
       
       (define draw-row
         (lambda (row i j)
           (if (= j (- height 1))
               (draw-point (car row) i j)
               (begin
                 (draw-point (car row) i j)
                 (draw-row (cdr row) i (+ j 1)))
               )))
       
       (define draw-point
         (lambda (point i j)
           ((draw-solid-ellipse canvas) 
            (abstract->absolute (cons i j)) 
            TOKEN_RADIUS 
            TOKEN_RADIUS
            (cond ((eq? (point 'get-state) 'off) TOKEN_OFF_COL)
                  ((eq? (point 'get-state) 'p1) TOKEN_P1_COL)
                  ((eq? (point 'get-state) 'p2) TOKEN_P2_COL)))))
       
       ;;repaints the canvas
       (define repaint
         (lambda ()
           (draw-frame)
           (draw-tokens (game-board 'get-board) 0)
           ))
       
       ;;gets the human move as a column number
       (define get-human-move
         (lambda (player)
           (let ((move-pt #f))
             
             ;;a procedure to highlight/colour blank every mouseover icon from 
             ;column i to width-1. the column "on-col" will be highlighted and 
             ;;the rest painted blank. 
             (define highlighter
               (lambda (on-col i)
                 (if (< i width)
                     (begin 
                       ((draw-solid-ellipse canvas)
                        (make-posn 
                         (+ FRAME_PAD FRAME_THICK 
                            (* i (+ (* 2 TOKEN_PAD) TOKEN_RADIUS))) 
                         TOKEN_PAD)
                        TOKEN_RADIUS
                        TOKEN_RADIUS
                        (if (= i on-col) 
                            (if (= player 0) TOKEN_P1_COL TOKEN_P2_COL) 
                            BACK_COL)
                        )
                       (highlighter on-col (+ i 1))
                       )))) 
             
             ;;a function to highlight the current column the user mouse is 
             ;;hovering over.
             (define highlight-col
               (lambda ()
                 (let ((mouse-pos (query-mouse-posn canvas)))
                   (if (and (posn? mouse-pos) 
                            (not (null? (absolute->abstract mouse-pos))))
                       (highlighter (car (absolute->abstract mouse-pos)) 0) 
                       (highlighter -1 0)))))
             
             
             ;;repeatedly check the mouse click buffer, highlighting the current
             ;;column the user is hovering over on each non-successful call. set
             ;;move-pt to the appropriate abstract position when a click has 
             ;;been registered.
             (define wait-for-human-move
               (lambda ()
                 (set! move-pt (ready-mouse-click canvas))
                 (if (boolean? move-pt)
                     (begin 
                       (highlight-col) 
                       (wait-for-human-move)
                       )
                     (begin
                       ;;turn off any column that may have been higlighted.
                       (highlighter -1 0)
                       (set! move-pt (mouse-click-posn move-pt))))))
             
             ;;flush any clicks out of the buffer that may have happened before 
             ;;we wanted to deal with them
             (viewport-flush-input canvas) 
             (wait-for-human-move) ;; move-pt will be set after here.
             (if (pair? (absolute->abstract move-pt))
                 (car (absolute->abstract move-pt))
                 (get-human-move)
                 ))))
       
       ;;Conversion methods between an abstract position (matrix index) and an 
       ;;absolute position (posn obj on canvas) where an abstract posn is just a
       ;;pair with the x as the car and y as the cdr and the absolute posn 
       ;;returned points to the top left corner of the token.
       (define abstract->absolute
         (lambda (posn)
           (make-posn 
            (+ FRAME_PAD FRAME_THICK TOKEN_PAD 
               (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) (car posn)))
            (+ FRAME_THICK TOKEN_PAD 
               (* (+ (* 2 TOKEN_PAD) TOKEN_RADIUS) (+ (cdr posn) 1))))))
       
       ;;Conversion from an absolute to an abstract by checking whether the 
       ;; point is within the range of an abstract
       ;; returns null if out of the abstract bounds 
       ;; the -1 height is when the point is in the selection zone (note the
       ;;annoying special case) the if boolean part is so that the false from 
       ;;ready-mouse-click passes through without problems
       (define absolute->abstract
         (lambda (posn)
           (if (not (boolean? posn))
               (let ((reduced-y 
                      (- (posn-y posn) (* 2 TOKEN_PAD) TOKEN_RADIUS FRAME_THICK))
                     (reduced-x (- (posn-x posn) FRAME_PAD FRAME_THICK)))
                 (let ((x (quotient reduced-x (+ (* 2 TOKEN_PAD) TOKEN_RADIUS)))
                       (y (if (< (posn-y posn) (posn-y FRAME_POS))  
                              -1
                              (quotient reduced-y 
                                        (+ (* 2 TOKEN_PAD) TOKEN_RADIUS)))))
                   (if (and (< x width) (< y height)) (cons x y) '())))
               posn)))
       
       ;;play a little animation when the player, "player" wins.
       (define win-display
         (lambda (player)           
           (map 
            (lambda (x) (map (lambda (y) ((y 'set-state) 'off)) x)) 
            (game-board 'get-board))
           (map 
            (lambda (x) 
              (map (lambda (y) ((y 'set-state) (if (= player 0) 'p1 'p2))) x)
              (sleep 0.05)(repaint)) 
            (game-board 'get-board))
           (map 
            (lambda (x)
              (map (lambda (y) ((y 'set-state) 'off))  x)
              (sleep 0.05)(repaint)) 
            (reverse (game-board 'get-board)))
           (map 
            (lambda (x) 
              (map (lambda (y) ((y 'set-state) (if (= player 0) 'p1 'p2))) x)
              (sleep 0.05)(repaint))
            (game-board 'get-board))))
       
       (define canvas (open-viewport "Connect 4" VIEW_WIDTH VIEW_HEIGHT))
       (set! game-board (make-connect-board height width))
       
       (repaint)
       (lambda (msg)
         (case msg
           ((reset) (game-board 'reset) (repaint))
           ((move) 
            (lambda (move player) 
              (let ((result ((game-board 'move) move player))) 
                (repaint) 
                (if (eq? result 'win) 
                    (win-display player)) 
                result)))
           ((get-move) (lambda (player) (get-human-move player)))
           ((repaint-board) (repaint))
           ((get-board) game-board)
           ((get-copy) (game-board 'get-copy))
           ((get-width) width)
           ((get-height) height)
           ((exit) (close-viewport canvas)))
         ))))
 
 ;;a connect board object contains a matrix of points.
 ;;it's methods deal with adding pieces and checking for a winner.
 ;;the "get-copy" message returns a deep copy of the object so that a
 ;;copy of the game's state can be used and manipulated by an ai function
 ;;without affecting the game itself.
 (define make-connect-board
   (lambda (height width)
     (let ((board '()))
       
       ;Point: 0 = off, 1 = player 1 and 2 = player 2
       (define make-point
         (lambda ()
           (let ((state 'off))
             (lambda (msg)
               (case msg
                 ((get-state) state)
                 ((set-state) (lambda (new-state) (set! state new-state) state))
                 (else (error "point: incorrect message passed to me")))))))
       
       ;;these just populate the matrix of points according to height and width.
       (define new-board
         (lambda ()
           (init-cols width)))
       
       (define init-cols
         (lambda (i)
           (if (= i 0)
               null
               (cons (init-col height) (init-cols (- i 1))))))
       
       (define init-col
         (lambda (i)
           (if (= i 0)
               null
               (cons (make-point) (init-col (- i 1))))))
       
       
       ;;Inserts a token into the specified colummn for the specified player.
       (define insert
         (lambda (col-inserted player)
           
           ;horizontal add (to abstract point)
           ;eg  where x > 0
           ; x1 x2 x3
           (define x+
             (lambda (move x)
               (cons (+ (car move) x) (cdr move))))
           
           ;vertical add (to abstract point)
           ;eg  where x > 0
           ;  x3
           ;  x2
           ;  x1
           (define y+
             (lambda (move y)
               (cons (car move) (+ (cdr move) y))))
           
           ;;ascending diagonal (to abstract point)
           ;eg  where x > 0
           ;           x3
           ;       x2
           ;   x1
           (define dasc+ 
             (lambda (move d)
               (cons (+ (car move) d) (+ (cdr move) d))))
           
           ;;descending diagonal (to abstract point)
           ;eg  where x > 0
           ; x1
           ;    x2
           ;        x3
           (define ddesc+
             (lambda (move d)
               (cons (+ (car move) d) (- (cdr move) d))))
           
           ;;for any given start and end, check all points between start and end
           ;;to see if the state of the game board at that point is the current
           ;;players. If they all are return true. The inc (incrementer) is a 
           ;;function that takes a point and returns the next point needed to be
           ;;checked...
           (define win-hlpr?
             (lambda (start end inc)
               (if (equal? start end)
                   (eq? 
                    ((list-ref (list-ref board (car start)) 
                               (- height 1 (cdr start))) 'get-state) 
                    (if (= player 0) 'p1 'p2)) 
                   (and (eq? ((list-ref (list-ref board (car start))
                                        (- height 1 (cdr start))) 'get-state)
                             (if (= player 0) 'p1 'p2))  
                        (win-hlpr? (inc start 1) end inc)))))
           
           (define win?
             (lambda (start end inc)
               (and (>= (car start) 0)        ;;Make sure that all of the
                    (>= (cdr start) 0)        ;;endpoints are within the
                    (< (car start) width)     ;;bounds of the board before
                    (< (cdr start) height)    ;;checking for a win.
                    (< (car end) width)
                    (< (cdr end) height)
                    (>= (cdr end) 0)
                    (>= (car end) 0)
                    (win-hlpr? start end inc)
                    )))
           
           (define horz-win? 
             (lambda (start end)
               (win? start end x+)))
           
           (define vert-win?
             (lambda (start end)
               (win? start end y+)))
           
           (define diag-asc-win? 
             (lambda (start end)
               (win? start end dasc+)))
           
           (define diag-desc-win?
             (lambda (start end)
               (win? start end ddesc+)))
           
           ;;These checks work by passing start and end points to the horz-win
           ;;(etc.) functions. these start and end points are then given to 
           ;;win with specific incrementers.
           (define check-winner
             (lambda (move offset)
               (or
                ;;checks to the left
                (horz-win? (x+ move (- 0 offset)) (x+ move (- 3 offset))) 
                ;;checks to the right
                (horz-win? (x+ move (- 0 (- 3 offset)))  (x+ move offset))
                ;;checks vertically up
                (vert-win? (y+ move (- 0 offset)) (y+ move (- 3 offset))) 
                ;;checks vertically down
                (vert-win? (y+ move (- 0 (- 3 offset))) (y+ move offset)) 
                ;;checks diagonally up and left
                (diag-asc-win? (dasc+ move (- 0 offset)) 
                               (dasc+ move (- 3 offset))) 
                ;;checks diagonally down and right
                (diag-asc-win? (dasc+ move (- 0 (- 3 offset))) 
                               (dasc+ move offset)) 
                ;; checks diagonally down and left
                (diag-desc-win? (ddesc+ move (- 0 offset)) 
                                (ddesc+ move (- 3 offset))) 
                ;; checks diagonally up and right
                (diag-desc-win? (ddesc+ move (- 0 (- 3 offset))) 
                                (ddesc+ move offset)) 
                ))) 
           
           (define winner?
             (lambda (mv)
               ;;hmm, note for later on. These functions could easily be 
               ;;generalised to work for X-in-a-row...
               (or (check-winner mv 2) (check-winner mv 3))
               ))            
           
           (define inserter
             (lambda (c p i)
               (cond ((null? c) (cons 'invalid -1)) ;;end -> return invalid
                     ((eq? ((car c) 'get-state) 'off) ;;free -> add new token
                      (begin 
                        (((car c) 'set-state)
                         (if (= player 0)
                             'p1
                             'p2))
                        (cons 'done i)))
                     (else (inserter (cdr c) player (+ i 1))) ;; else next point
                     )                 
               ))           
           
           (define no-moves-left?
             (lambda (b) 
               (if (null? b)
                   #t
                   (and (not (eq? ((caar b) 'get-state) 'off)) 
                        (no-moves-left? (cdr b)))))) 
           
           (let ((result 
                  (inserter (reverse (list-ref board col-inserted)) player 0)))
             (case (car result)
               ((done) (if (winner? (cons col-inserted (cdr result))) 
                           'win
                           (begin
                             (if (no-moves-left? board) 'drawn 'neutral))))
               ((invalid) 'invalid))            
             )))
       
       
       (set! board (new-board))      
       
       (lambda (msg)
         (case msg
           ((reset) 
            (set! board 
                  (map (lambda (x) (map (lambda (y) (make-point)) x)) board)))
           ((set-board) 
            (lambda (board-matrix) 
              (map 
               (lambda (x y) 
                 (map (lambda (a b) ((a 'set-state) (b 'get-state))) x y))
               board board-matrix))) 
           ((get-copy) 
            (let ((b (make-connect-board height width))) 
              ((b 'set-board) board) b))
           ((move) 
            (lambda (move player) 
              (let ((result (insert move player)))  result)))
           ((get-move) (lambda (player) (get-human-move player)))
           ((get-width) width )
           ((get-height) height)
           ((get-board) board)
           )))))
 
 ;;the game is the entry point to the program. It keeps track of scores and 
 ;;alternates player control between player 1 and player 2, resetting the board
 ;;after a win.
 ;;player1 and player two are player objects and the width and height are the
 ;;desired dimentions of the game board.
 (define game
   (lambda (player1 player2 width height)
     (open-graphics)
     (let ((gui (make-connect-gui width height))
           (scoreBoard (open-viewport "Score Board" 250 50))
           (p1-score 0)
           (p2-score 0))
       
       (define PLAYER1_COL (make-rgb 0 0 1))
       (define PLAYER2_COL (make-rgb 1 0 0))
       (define SCORE_BACK_COL (make-rgb .25 1 .25))
       
       (define paint-scores
         (lambda ()
           ((draw-viewport scoreBoard) SCORE_BACK_COL)
           ((draw-string scoreBoard) 
            (make-posn 5 20) 
            (player1 'get-name) 
            PLAYER1_COL)
           ((draw-string scoreBoard) 
            (make-posn 5 40) 
            (player2 'get-name) 
            PLAYER2_COL)
           ((draw-string scoreBoard) 
            (make-posn (+ 10 (car ((get-string-size scoreBoard) 
                                   (player1 'get-name)))) 20) 
            (number->string p1-score)
            PLAYER1_COL)
           ((draw-string scoreBoard)  
            (make-posn (+ 10 (car ((get-string-size scoreBoard) 
                                   (player2 'get-name)))) 40) 
            (number->string p2-score) 
            PLAYER2_COL)
           ))
       
       (define play-loop
         (lambda (player)
           (paint-scores)
           ;; (sleep 1)
           (case ((gui 'move) 
                  (((if (= player 0) player1 player2) 'get-move) gui)
                  player)
             ((neutral) (play-loop (modulo (+ player 1) 2)))
             ((invalid) (display "move invalid") (newline) (play-loop player))
             ((drawn) 
              (display "drawn - play symbol to play again or exit to quit") 
              (newline))
             ((win) 
              (display "finished -play symbol to play again or exit to quit") 
              (if (eq? player 0) 
                  (set! p1-score (+ p1-score 1))
                  (set! p2-score (+ p2-score 1)))
              (paint-scores)
              (gui 'reset)
              ))))
       
       (set! player1 (player1 0))
       (set! player2 (player2 1))
       
       (lambda (msg)
         (case msg
           ((play) (play-loop 0))
           ((get-width) width ) 
           ((reset) (gui 'reset) (set! p1-score 0) (set! p2-score 0))
           ((board-reset) (gui 'reset))
           ((repaint) (gui 'repaint-board))
           ((exit) 
            (gui 'exit) 
            (close-viewport scoreBoard) 
            (close-graphics) 
            "...game exited."))))))
 
 
 ;;constants for the difficulty rating of players.
 (define HUMAN -2)
 (define STUPID -1)
 (define EASY 0)
 (define MEDIUM 1)
 (define HARD 2)
 
 ;;a player object is a function that takes a skill rating and name. This is all
 ;;the user needs to know as the parameter "num" is taken care of by the game 
 ;;itself and is merely just to keep track of whether the player is the second 
 ;;or first player.
 (define make-player
   (lambda (skill name)
     (lambda (num)
       (lambda (msg)
         (case msg
           ((get-move)
            (lambda (gui)
                    ;;if human, find out which column the user clicks
              (cond ((= skill HUMAN) ((gui 'get-move) num))
                    ;;if a stupid automatic player, pick a random number. 
                    ((= skill STUPID)(random 8)) 
                    (else 
                     (let ((best-move 
                            (get-best-move 0 skill (gui 'get-copy) num)))
                       ;;if best move can't find a best move->pick random move.
                       (if (= (car best-move) -1)
                           (random 8) 
                           (car best-move)))))))
           ((get-name) name)))))) 
 
 ;;gets the best move from the board for the player, p (looking ahead 
 ;;(maxDepth - depthSoFar) times) note that this function assumes that at least
 ;;one move is possible on the board. also not that if two or more of the 
 ;;opponent's moves will result in a loss, then it is probbable that this
 ;;function will return no move (ie. the pair, (-1 -1))
 
 (define get-best-move
   (lambda (depthSoFar maxDepth board p)
     
     (define opp-win?
       (lambda (b i)
         (and (not (= i (b 'get-width))) 
              (or (eq? (((b 'get-copy) 'move) i (modulo (+ p 1) 2)) 'win) 
                  (opp-win? b (+ i 1))))))    
     
     ;;where x and y are move lists
     ;;(it is possible that they could be a move list from best-moves, and 
     ;;also have a third, weight-sum element.)
     (define max-weight
       (lambda (x y)
         (if (> (cdr x) (cadr y))
             x
             y
             )))
     
     (define simple-check
       (lambda (move)       
         
         (let ((this-copy (board 'get-copy)))
           
           (case ((this-copy 'move) move p)
             ((win) 1)
             ((drawn) 0)
             ((invalid) 'invalid)
             (else
              (begin
                (if (opp-win? this-copy 0) -1 0)))))))
     
     (define simple-checks
       (lambda (best i)
         (if (= i (board 'get-width))
             best
             (simple-checks
              (let ((tempWeight (simple-check i)))
                (if (and (not (eq? tempWeight 'invalid))
                         (> tempWeight (cadr best)))
                    (list i tempWeight)
                    best))
              (+ i 1)))))       
     
     ;;note. I haven't yet implemented best-moves. it was planned that best
     ;;moves would recursively look at each move and each possible move after
     ;;that (to a certain depthand weigh up the best option according to whether
     ;;the player won or lost down the different choice paths. simple-checks 
     ;;does enough though to demonstrate it working.
     (define best-moves
       (lambda (best i)
         (simple-checks best i)))
     
     (if (= depthSoFar maxDepth)
         (simple-checks (list -1 -1) 0)
         (best-moves (list -1 -1) 0))))
 
 (define g 
   (game (make-player HUMAN "Dr Jekyll") 
         (make-player EASY "Mr Hyde")
                 6 8))