HW2 Solutions Page

Return to homework page.

There were twenty programs submitted for HW2. I went through each of these to see if minimax with alpha-beta pruning was being used and could each program play itself without crashing. Many people did not follow the spec and so the cs156-checkers-move function was not of the correct prototype. Nine programs passed this preliminary check. I divided these nine progams into four leagues each of size two except for League #3 which had three programs in it. To have programs compete against each other I had to first alter the programs slightly to make sure they did not have different functions with the same name. For instance, it was common that different people had a function max-value, but had defined it differently. I also added a check to my code for testing that is not on the web-page to prevent people from issuing a move for Player 2 when it was Player 1's turn and vice-versa. Here is the result of the matches played.

League1
=======
Player 1a vs. Player 1b

Player 1a won both matches by getting the other player to repeat himself too much.

League2
=======
Player 2a vs Player 2b

Player 2b won both matches. Player 2a made an illegal move where moving in the second game.

League3
=======
Player 3a vs. Player 3b
Player 3b won both these matches because of repeat moves by 3a.

Player 3b vs. Player 3c
Each program one one of the two matches. However, 3b crashed where he player as player2. So
I rated 3b the weaker program.

Player 3a vs. Player 3c
Player 3c won both these matches.


League4
=======
Player 4a vs. Player 4b
Player 4b won both matches as Player 4a crashed in each match.


Semi-Final1
===========
Player 1a vs. Player 2b
Each program won one match, but 1a crashed in the first game. So 2b was judged the stronger program.


Semi-Final2
===========
Player 3c vs. Player 4b
Each won one match, but 4b beat 3c by getting all his pieces to the other side -- the first prorgam to
successfully do this. So 4b was judged stronger.


Final
=====
Player2b vs. Player 4b
Player 4b won both these matches. 4b declared tournament victor and receives two bonus points.


Runner-up Match
===============
Player 1a vs. Player 3c
Each won one match. So I gave each of 1a, 2b, 3c a bonus point.

If your program competed in the tournament, I have indicated on your homework grade which program you were in the standings above. Below is the winning program:

;;;; cs156-checkers-move.scm
;;;;
;;;; Author: Winning Programmer
;;;;
;;;; Description: HW2 - CS 156 Checkers game using minimax with
;;;;  alpha-beta pruning
;;;;
;;;; Version: 03/9/2004

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;Author: Chris Pollett
;;;;
;;;;Code to play two agents against each other at cs156-checkers
;;;;
;;;;The main function below is play-game. This takes two agents and plays
;;;; a game of cs156-checkers between them.
;;;;
;;;;The function human-agent is defined so people can play the game as
well as computers.
;;;;
;;;;The function human-game can be invoke so two humans can play each
other
;;;;
;;;;To test this out, at the the prompt type (human-game)


;;;
;;;function to set the n element of a list
;;;
(define set-ref!
  (lambda (list n new)
    (if (= n 0)
        (set-car! list new)
        (set-ref! (cdr list) (- n 1) new))))

;;;
;;;function to shallow copy a list
;;;
(define copy-list
  (lambda (list)
    (if (null? list)
        ()
        (cons (car list) (copy-list (cdr list))))))

;;;
;;;function to get a list of the first number elements from a lsit
;;;
(define list-head
  (lambda (list number)
    (if (= number 0)
        '()
        (cons (car list) (list-head (cdr list) (- number 1))))))

;;;
;;;function to copy a cs156-checker board
;;;
(define copy-board
  (lambda (board)
    (let ((row1 (copy-list (car board)))
          (row2 (copy-list (cadr board)))
          (row3 (copy-list (caddr board))))
      (list row1 row2 row3))))

;;;
;;;function to set the x y location of a board to a given value
;;;
(define update-square-board!
  (lambda (board x y value)
    (let* ((row (car (list-tail board x)))
           (col (list-tail row y)))
      (set-car! col value))))

;;;
;;;function to get what piece, if any, is on the (x, y) square on the
;;; board
;;;
(define get-square-board
  (lambda (board x y)
    (let* ((row (car (list-tail board x))))
      (list-ref row y))))

;;;function to produce the board that results from a given move
;;;
;;;Parameters
;;;
;;; move - a list consisting of steps of move
;;;
;;; board - to do move on
;;;
;;; returns - resulting board
(define apply-move
  (lambda (move board)
    (let* ((next-board (copy-board board))
          (start-x (car move))
          (start-y (cadr move))
          (l (length move))
          (end-x (list-ref move (- l 2)))
          (end-y (list-ref move (- l 1)))
          (piece (get-square-board board start-x start-y)))
      (update-square-board! next-board start-x start-y 0)
      (update-square-board! next-board end-x end-y piece)
      next-board)))

;;;
;;;functions used to draw all or parts of a board
;;;
(define draw-row
  (lambda (x)
    (display " ")
    (if (null? x)
        (newline)
        (begin
          (display (car x))
          (draw-row (cdr x))))))

(define draw-board
  (lambda (board)
    (draw-row (car board))
    (draw-row (cadr board))
    (draw-row (caddr board))))

;;;
;;;Next functions all used to check if a move is valid
;;; tried to make sure valid-move-board? will give a #t or #f answer
;;; rather than through an error
;;;
(define on-board-coord?
  (lambda (x y)
    (and (integer? x) (integer? y)
        (>= x 0) (< x 3)
        (>= y 0) (< y 9))))

(define valid-step-move?
  (lambda (board move)
    (if (not (= (length move) 4))
        #f
        (let* ((start-x (car move))
              (start-y (cadr move))
              (end-x (caddr move))
              (end-y (cadddr move))
              (piece (get-square-board board start-x start-y)))

          (if (or (not (on-board-coord? start-x start-y))
                  (not (on-board-coord? end-x end-y))
                  (= piece 0) )
              #f
              (and (or (and (= start-x end-x) (= end-y (+ start-y 1)) (=
piece 1))
                       (and (= start-x end-x) (= end-y (- start-y 1)) (=
piece 2))
                       (and (= start-y end-y) (= (abs (- end-x start-x))
1)))
                  (= (get-square-board board end-x end-y) 0)))))))

(define valid-jump-move?
  (lambda (board move)
    (let* ((start-x (car move))
          (start-y (cadr move))
          (end-x (caddr move))
          (end-y (cadddr move))
          (mid-x (/ (+ start-x end-x) 2))
          (mid-y (/ (+ start-y end-y) 2))
          (piece (get-square-board board start-x start-y)))
      (if (or (not (on-board-coord? start-x start-y))
              (not (on-board-coord? end-x end-y))
              (= piece 0) )
          #f
          (let ((hop-ok-boolean
                (and (or (and (= start-x end-x) (= end-y (+ start-y 2)) (=
piece 1))
                         (and (= start-x end-x) (= end-y (- start-y 2)) (=
piece 2))
                         (and (= start-y end-y) (not (= end-x start-x))
(not (= start-x 1))))
                     (= (get-square-board board end-x end-y) 0)
                     (> (get-square-board board mid-x mid-y) 0))))
            (if (or (= (length move) 4) (not hop-ok-boolean))
                hop-ok-boolean
                (valid-jump-move? (apply-move (list start-x start-y end-x
end-y) board) (cddr move))))))))

(define valid-move?
  (lambda (board move)
    (if (or (not (list? move)) (not (>= (length move) 4))
            (not (even? (length move))))
        #f
        (or (valid-step-move? board move)
            (valid-jump-move? board move)))))

(define valid-squares-count?
  (lambda (list count)
    (if (null? list)
        (= count 999)
        (let ((f (car list))
              (next-count count))
          (if (not (integer? f))
              #f
              (begin
                (cond ((= f 0) (set! next-count (+ next-count 1)))
                      ((= f 1) (set! next-count (+ next-count 10)))
                      ((= f 2) (set! next-count (+ next-count 100))))
                (valid-squares-count? (cdr list) next-count)))))))

(define valid-board?
  (lambda (board)
    (if (or (not (list? board)) (not (= (length board) 3)))
        #f
        (let ((row1 (car board))
              (row2 (cadr board))
              (row3 (caddr board)))
          (if (or (not (= (length row1) 9)) (not (= (length row2) 9))
                  (not (= (length row3) 9)))
              #f
              (valid-squares-count? (append row1 row2 row3) 0))))))

(define valid-move-board?
  (lambda (board move-board)
    (if (or (not (list? move-board)) (not (= (length move-board) 2)))
         #f
         (let ((next-board (cadr move-board))
               (move (car move-board)))
           (and (valid-move? board move) (valid-board? next-board)
                (equal? next-board (apply-move move board)))))))

;;;
;;; function to compute half of a round in the game less checking for a
win
;;;
(define get-check-and-apply-move
  (lambda (agent-move turn board)
   (let ((move-board (agent-move (list turn board))))
      (if (valid-move-board? board move-board)
          (cadr move-board)
          (error 'get-check-and-apply-move "player ~s loses because made
illegal move. " turn)))))

;;;
;;; functions to check for a win
;;;
(define player2-win-board?
  (lambda (board)
    (let* ((row1 (list-head (car board) 3))
          (row2 (list-head (cadr board) 3))
          (row3 (list-head (caddr board) 3))
          (single-list (cons 2 (append row1 row2 row3))))
          (apply = single-list))))

(define player1-win-board?
  (lambda (board)
    (let* ((row1 (list-tail (car board) 6))
          (row2 (list-tail(cadr board) 6))
          (row3 (list-tail (caddr board) 6))
          (single-list (cons 1 (append row1 row2 row3))))
          (apply = single-list))))

(define game-over?
  (lambda (board)
    (or (player1-win-board? board) (player2-win-board? board))))

(define display-win
  (lambda (winner)
    (begin
      (display "\n\nPlayer ")
      (display winner)
      (display " wins!!\n\n"))))

;;;
;;; constant for initial board
;;;
(define initial-board
  (list
   (list 1 1 1 0 0 0 2 2 2)
   (list 1 1 1 0 0 0 2 2 2)
   (list 1 1 1 0 0 0 2 2 2)))

;;;
;;;function to get a move from a human player and make it into the format
;;; expected of an agent
;;;
;;;Parameters
;;;
;;; state - expected to be in the form (turn board) where turn is which
;;;         player's turn and board is the board player gets to move on
;;;
;;; returns - a list consisting of (move resulting-board)
(define human-agent
  (lambda (state)
      (display "You are player ")
      (display (car state))
      (display ".\n\nHere is the current board:\n")
      (draw-board (cadr state))
      (let* ((move (read))
             (next-board (apply-move move (cadr state))))
        (list move next-board))))

;;;
;;;functions to play game
;;;

(define play-game-turn
  (lambda (cur-agent-move other-agent-move turn board)
    (display "Player ")(display turn)(display ":\nHere is the current
board:\n")(draw-board board)
    (let* ((t (current-seconds))
          (next-board (get-check-and-apply-move cur-agent-move turn
board))
          (next-turn (if (= turn 1) 2 1)))
      (display "Time: ")(display (- (current-seconds)
t))(newline)(newline)
      (if (game-over? next-board)
          (display-win turn)
          (play-game-turn other-agent-move cur-agent-move next-turn
next-board)))))


(define play-game
  (lambda (agent1-move agent2-move)
    (play-game-turn agent1-move agent2-move 1 initial-board)))

(define human-game
  (lambda ()
    (play-game human-agent human-agent)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Author: 
;;;
;;; Minimax with alpha-beta pruning
;;;

;;;
;;;Function to decide next move using minimax with alpha-
;;; beta pruning.
;;; Parameters
;;; turn-board - list of player turn and the current board
;;;
;;; returns - (move resulting-board) 
(define cs156-checkers-move
  (lambda (turn-board)
    (let ((turn (car turn-board))
          (board (cadr turn-board))
          (depth-limit 4))    
      (cond
        ((= turn 1)
         (cadr (max-value board -inf.0 +inf.0 evaluate3 depth-limit)))
        ((= turn 2)
         (cadr (min-value board -inf.0 +inf.0 evaluate3 depth-limit)))
        (else (error 'cs156-checkers-move "invalid turn ~s" turn))))))

;;;
;;;Testing opponent
;;;
(define cs156-checkers-move1
  (lambda (turn-board)
    (let ((turn (car turn-board))
          (board (cadr turn-board))
          (depth-limit 4))    
      (cond
        ((= turn 1)
         (cadr (max-value board -inf.0 +inf.0 evaluate2 depth-limit)))
        ((= turn 2)
         (cadr (min-value board -inf.0 +inf.0 evaluate2 depth-limit)))
        (else (error 'cs156-checkers-move "invalid turn ~s" turn))))))

;;;
;;;Function to decide next move by maximizing minimax value with alpha-
;;; beta pruning.
;;; Parameters
;;; board - current board
;;; alpha - current alpha value
;;; beta - current beta value
;;; evaluation - board evaluation function
;;; depth - depth limit of search
;;;
;;; returns - (backed-up-value move resulting-board)
(define max-value
  (lambda (board alpha beta evaluation depth)
    (if (or (= depth 0) (game-over? board))
;reach depth limit or terminal
        (list (evaluation board) (list '() board))
        (let loop ((value -inf.0)
;search through successor boards
                   (value-move-board (list -inf.0 (list '() board)))
                   (a alpha)
                   (moves (successors board 1)))
          (if (null? moves) value-move-board
              (let* ((next-move (car moves))
                     (next-board (apply-move next-move board))
                     (min-value-move-board (min-value next-board
                                                      a beta 
                                                      evaluation
                                                      (- depth 1))))
                (if (< value (car min-value-move-board))
;check if new value is larger
                    (begin
                      (set! value (car min-value-move-board))
                      (set! value-move-board
                            (list value (list next-move next-board)))))
                (if (>= value beta) value-move-board
;alpha prune
                    (loop value value-move-board (max a value) (cdr
moves)))))))))

;;;
;;;Function to decide next move by minimizing minimax value with alpha-
;;; beta pruning.
;;; Parameters
;;; board - current board
;;; alpha - current alpha value
;;; beta - current beta value
;;; evaluation - board evaluation function
;;; depth - depth limit of search
;;;
;;; returns - (backed-up-value move resulting-board)
(define min-value
  (lambda (board alpha beta evaluation depth)
    (if (or (= depth 0) (game-over? board))
;reach depth limit or terminal
        (list (evaluation board) (list '() board))
        (let loop ((value +inf.0)
;search through successor boards
                   (value-move-board (list +inf.0 (list '() board)))
                   (b beta)
                   (moves (successors board 2)))
          (if (null? moves) value-move-board
              (let* ((next-move (car moves)) 
                     (next-board (apply-move next-move board))
                     (max-value-move-board (max-value next-board
                                                      alpha b
                                                      evaluation
                                                      (- depth 1))))
                (if (> value (car max-value-move-board))
;check if new value is smaller
                    (begin
                      (set! value (car max-value-move-board))
                      (set! value-move-board
                            (list value (list next-move next-board)))))
                (if (<= value alpha) value-move-board
;beta prune
                    (loop value value-move-board (min b value) (cdr
moves)))))))))


;;;
;;;Functions to calculate a value for the game board
;;; Parameters
;;; board - game board to evaluate
;;;
;;; returns - value for the board

(define evaluate2
  (lambda (board)
    (piece-position-bottom board)))

(define evaluate3
  (lambda (board)
    (piece-position3 board)))

;;;
;;;Stupid evaluation for testing
;;;
(define piece-position-bottom
  (lambda (board)
    (let out-loop((x 0)
                  (score 0))
      (if (= x 3) score
          (let in-loop ((y 0))
            (if (= y 9)
                (out-loop (+ x 1) score)
                (begin
                  (cond
                    ((= 1 (get-square-board board x y))
                     (set! score (+ score (* y y)))
                     (if (= x 2) (set! score (+ score 25))))
                    ((= 2 (get-square-board board x y))
                     (set! score (- score (* (- 8 y) (- 8 y))))
                     (if (= x 2) (set! score (- score 25)))))
                  (in-loop (+ y 1)))))))))

;;;
;;;Basic positional score evaluation
;;;
(define piece-position2
  (lambda (board)
    (let out-loop((x 0)
                  (score 0))
      (if (= x 3) score
          (let in-loop ((y 0))
            (if (= y 9)
                (out-loop (+ x 1) score)
                (begin
                  (cond
                    ((= 1 (get-square-board board x y))
                     (set! score (+ score (* y y))))
                    ((= 2 (get-square-board board x y))
                     (set! score (- score (* (- 8 y) (- 8 y))))))
                  (in-loop (+ y 1)))))))))
;;;
;;;Basic positional score evaluation plus lagging pieces consideration
;;; plus a little randomness when there are only a few moves left
;;;
(define piece-position3
  (lambda (board)
    (let out-loop((x 0)
                  (score 0)
                  (one-lagger 8)
                  (two-lagger 0))
      (if (= x 3) (+ (- (+ score (* 2 one-lagger)) (* 2 two-lagger))
(random 4))
          (let in-loop ((y 0))
            (if (= y 9)
                (out-loop (+ x 1) score one-lagger two-lagger)
                (begin
                  (cond
                    ((= 1 (get-square-board board x y))
                     (set! score (+ score  y))
                     (if (< y one-lagger)
                         (set! one-lagger y)))
                    ((= 2 (get-square-board board x y))
                     (set! score (- score (- 8 y)))
                     (if (> y two-lagger)
                         (set! two-lagger y))))
                  (in-loop (+ y 1)))))))))
  
;;;
;;;function to find a list of next moves
;;;
;;;Parameters
;;;
;;; board - current board
;;; turn -  current player
;;;
;;; returns - a list consisting of legal next moves
(define successors
  (lambda (board turn)
    (cond
      ((= turn 1) (player1-next-moves board))
      ((= turn 2) (player2-next-moves board))
      (else (error 'successors "invalid turn ~s" turn)))))

;;;
;;;function to find a list of next moves for player 1
;;;
;;;Parameters
;;;
;;; board - current board
;;;
;;; returns - a list consisting of legal next moves
(define player1-next-moves
  (lambda (board)
    (let out-loop((x 0)
                  (moves '()))
      (if (= x 3) moves
          (let in-loop ((y 0))
            (if (= y 9)
                (out-loop (+ x 1) moves)
                (begin
                  (if (= 1 (get-square-board board x y))
                      (set! moves (append moves (find-moves board x y
1))))
                  (in-loop (+ y 1)))))))))

;;;
;;;function to find a list of next moves for player 2
;;;
;;;Parameters
;;;
;;; board - current board
;;;
;;; returns - a list consisting of legal next moves
(define player2-next-moves
  (lambda (board)
    (let out-loop((x 0)
                  (moves '()))
      (if (= x 3) moves
          (let in-loop ((y 8))
            (if (= y -1)
                (out-loop (+ x 1) moves)
                (begin
                  (if (= 2 (get-square-board board x y))
                      (set! moves (append moves (find-moves board x y
2))))
                  (in-loop (- y 1)))))))))

;;;
;;;function to find a list of next moves for a player
;;; from position (x, y). attemps to give the hop moves
;;; first.
;;;
;;;Parameters
;;;
;;; board - current board
;;; x - row # for position
;;; y - column # for position
;;; turn -  current player
;;;
;;; returns - a list consisting of legal next moves
(define find-moves
  (lambda (board x y turn)
    (append (hop '() board x y turn)
            (step board x y turn))))

;;;
;;;function to create a step move in the valid format
;;;
;;;Parameters
;;;
;;; x-start - starting row
;;; y-start - starting column
;;; x-end - resulting row
;;; y-end - resulting column
;;;
;;; returns - a move
(define make-move
  (lambda (x-start y-start x-end y-end)
    (list x-start y-start x-end y-end)))

;;;
;;;function to find a list of step moves for a player
;;; from position (x, y)
;;;
;;;Parameters
;;;
;;; board - current board
;;; x - row # for position
;;; y - column # for position
;;; turn -  current player
;;;
;;; returns - a list consisting of legal next moves
(define step
  (lambda (board x y turn)
    (let ((moves '())
          (up (make-move x y (- x 1) y))
          (down (make-move x y (+ x 1) y))
          (right (make-move x y x (+ y 1)))
          (left (make-move x y x (- y 1))))
      (cond
        ((= turn 1)
         (begin
           (if (valid-step-move? board right)           ;step right
               (set! moves (append moves (list right))))           
           (if (valid-step-move? board up)              ;step up
               (set! moves (append moves (list up))))
           (if (valid-step-move? board down)            ;step down
               (set! moves (append moves (list down))))
           moves))
        ((= turn 2)
         (begin
           (if (valid-step-move? board left)            ;step left
               (set! moves (append moves (list left))))           
           (if (valid-step-move? board up)              ;step up
               (set! moves (append moves (list up))))
           (if (valid-step-move? board down)            ;step down
               (set! moves (append moves (list down))))
           moves))
        (else (error 'step "invalid turn ~s" turn))))))

;;;
;;;function to find a list of hop moves for a player
;;; from position (x, y)
;;;
;;;Parameters
;;;
;;; board - current board
;;; x - row # for position
;;; y - column # for position
;;; turn -  current player
;;;
;;; returns - a list consisting of legal next moves
(define hop
  (lambda (prev-move board x y turn)
    (let ((moves '())
          (down (make-move x y (+ x 2) y))
          (up (make-move x y (- x 2) y))
          (right (make-move x y x (+ y 2)))
          (left (make-move x y x (- y 2))))
      (cond
        ((= turn 1)
         (if (and (not-backtrack? prev-move down)
                  (valid-jump-move? board down))                    ;hop
down
             (begin
               (set! moves (append moves
                                   (list (hopping prev-move down)) 
                                   (hop (hopping prev-move down)    ;look
for multi
                                        (apply-move down board)     ; hops
                                        (+ x 2) y turn)))
               moves)
             (if (and (not-backtrack? prev-move up)
                      (valid-jump-move? board up))                  ;else
if hop up
                 (begin
                   (set! moves (append moves
                                       (list (hopping prev-move up))
                                       (hop (hopping prev-move up)
                                            (apply-move up board)
                                            (- x 2) y turn)))
                   moves)
                 (if (and (not-backtrack? prev-move right)
                          (valid-jump-move? board right))           ;else
if hop right
                     (begin
                       (set! moves
                             (append moves
                                     (list (hopping prev-move right))
                                     (hop (hopping prev-move right)
                                          (apply-move right board)
                                          x (+ y 2) turn)))
                       moves)
                     moves))))                                      ;else
no moves
        
        ((= turn 2)
         (if (and (not-backtrack? prev-move down)
                  (valid-jump-move? board down))                    ;hop
down
             (begin
               (set! moves (append moves
                                   (list (hopping prev-move down)) 
                                   (hop (hopping prev-move down)    ;look
for multi
                                        (apply-move down board)     ; hops
                                        (+ x 2) y turn)))
               moves)
             (if (and (not-backtrack? prev-move up)
                      (valid-jump-move? board up))                  ;else
if hop up
                 (begin
                   (set! moves (append moves
                                       (list (hopping prev-move up))
                                       (hop (hopping prev-move up)
                                            (apply-move up board)
                                            (- x 2) y turn)))
                   moves)
                 (if (and (not-backtrack? prev-move left)
                          (valid-jump-move? board left))            ;else
if hop left
                     (begin
                       (set! moves
                             (append moves
                                     (list (hopping prev-move left))
                                     (hop (hopping prev-move left)
                                          (apply-move left board)
                                          x (- y 2) turn)))
                       moves)
                       moves))))                                     ;else
no moves
        (else (error 'hop "invalid turn ~s" turn))))))

;;;
;;;function to create a multi hop move in the valid
;;; format
;;;
;;;Parameters
;;;
;;; prev-move - hop moves made before
;;; next-move - the hop move from the last position of the previous hops
;;;
;;; returns - a multi hop move
(define hopping
  (lambda (prev-move next-move)
    (if (null? prev-move)
        next-move
        (append prev-move (list-tail next-move 2)))))

;;;
;;;function to check if a move isn't a backtracking move of
;;; the move previously made to get to the current position
;;;
;;;Parameters
;;;
;;; prev-move - move made before
;;; move - move to check
;;;
;;; returns - #t if not backtrack, #f otherwise
(define not-backtrack?
  (lambda (prev-move move)
    (if (null? prev-move)
        #t
        (let ((move1 (list-tail prev-move (- (length prev-move) 4)))
              (move2 (append (list-tail move 2) (list-head move 2))))
          
          (not (equal? move1 move2)))))) 

Return to homework page.