(require (lib "1" "srfi")) (require (lib "25" "srfi")) (load "c4.scm") ; Connect-Four support code for HW3 ; (Connect-Four is a registered trademark of Hasbro.) ; ================================= ; nth-row extracts a single row from a board ; (and returns it as a list). ; board is a game board representation (see above) and n is ; a row number (0 is the top row). ; (define kantrn-nth-row (lambda (board n) (let g-row ((ls board)) (if (null? ls) () (cons (list-ref (car ls) n) (g-row (cdr ls))))))) ; ================================= ; getsquare extracts and returns a single board element (0, 1 or 2) ; board is a game board representation (see above) ; row and col are the row number and column number ; (define getsquare (lambda (board row col) (list-ref (list-ref board col) row))) ; ================================= ; rightdiag extracts a right diagonal from a board. ; right diags start at the bottom and move up and to the right ; board is a game board representation (see above) ; row and col are the starting coordinates of the diagonal ; (the bottom most element is the start) ; (define rightdiag (lambda (board row col) (let ((cols (length board)) (rows (length (car board))) (diag ())) (do ( (r row (- r 1)) (c col (+ c 1))) ((or (< r 0) (>= c cols)) diag) (set! diag (append diag (list (getsquare board r c)))))))) ; ================================= ; leftdiag extracts a left diagonal from a board ; left diags start at the bottom and move up and to the left ; row and col are the starting coordinates of the diagonal (define leftdiag (lambda (board row col) (let ((cols (length board)) (rows (length (car board))) (diag ())) (do ( (r row (- r 1)) (c col (- c 1))) ((or (< r 0) (< c 0)) diag) (set! diag (append diag (list (getsquare board r c)))))))) ; ================================= ; rightdiags returns a list of all the right diagonals ; that include 4 or more elements. ; (define kantrn-rightdiags (lambda (board) (let ((diags ()) (rows (length (car board))) (cols (length board))) (do ((r 3 (+ r 1))) ((= r rows) ()) (set! diags (cons (rightdiag board r 0) diags))) (do ((c 1 (+ c 1))) ((= c (- cols 3)) ()) (set! diags (cons (rightdiag board (- rows 1) c) diags))) diags))) ; ================================= ; kantrn-kantrn-leftdiags returns a list of all the left diagonals ; that include 4 or more elements. ; (define kantrn-leftdiags (lambda (board) (let ((diags ()) (rows (length (car board))) (cols (length board))) (do ((c 3 (+ c 1))) ((= c cols) ()) (set! diags (cons (leftdiag board (- rows 1) c) diags))) (do ((r (- rows 2) (- r 1))) ((< r 3) ()) (set! diags (cons (leftdiag board r (- cols 1)) diags))) diags))) ; ================================= ; kantrn-getall extracts all rows, columns and diagonals and makes a big list. ; each element of the list could contain 4 in a row. (define kantrn-getall (lambda (board) (append board ; board holds the columns (board-transpose board) ; the rows (kantrn-rightdiags board) ; the diagonals (kantrn-leftdiags board)))) ; ================================= ; convert list of columns to list of rows ; Given a board of c columns and r rows, ; the board representation is a list of c elements (one per column), ; each element is a list contains the values for each square in a ; column. This procedure returns a list of r elements (one per row), ; each element is a list containinf the values for each square in ; a row. (define board-transpose (lambda (board) (let ((bt ()) (len (length (car board)))) (do ( (i (- len 1) (- i 1))) ((< i 0) bt) (set! bt (cons (kantrn-nth-row board i) bt)))))) ; ================================= ; kantrn-four-in-a-row? is a predicate that returns true if a list contains ; 4 consecutive elements that all match a single value. ; l is the list (could be from a row, column or diaganol) and ; e is the value we are looking for (1 or 2) ; (define kantrn-four-in-a-row? (lambda (l e) (let finar ((ls l) (count 0)) ; if we don't have enough elements left to make 4 in a row - FALSE (if (< (+ count (length ls)) 4) #f (if (= e (car ls)) ; we got a match (if (= count 3) #t ; 4 in a row! (finar (cdr ls) (+ count 1))) ; no match (finar (cdr ls) 0)))))) ; Auto-memorizing functions (define-macro lambda-memo (lambda (args . body) (let ((memo (gensym)) (hashed (gensym)) (key (gensym))) `(let ((,memo (make-hash-table 'equal))) (lambda ,args (let* ((,key (list ,@args)) (,hashed (hash-table-get ,memo ,key #f))) (if ,hashed ,hashed (let ((,hashed (begin ,@body))) (hash-table-put! ,memo ,key ,hashed) ,hashed ) ) ) ) ) ))) ; Using lists instead (define kantrn-free-square (lambda (board x) (let ((col (list-ref board x))) (- (or (list-index (lambda (x) (> x 0)) col) (length col)) 1) ))) ; Make a move (define kantrn-make-move (lambda (board move mover) (let-values (((newcolhead newcoltail) (split-at (list-ref board (car move)) (cadr move))) ((newboardhead newboardtail) (split-at board (car move))) ) (let* ((newcol (append newcolhead (list mover) (cdr newcoltail))) (newboard (append newboardhead (list newcol) (cdr newboardtail))) ) newboard ) ) ) ) ; Convert a board to a 2D array ; This should not memorize because the result will be altered destructively (define kantrn-board->array (lambda (board) (apply array (shape 0 (length board) 0 (length (car board))) (apply append board)))) ; Subfunctions for kantrn-evaluate-cell ; All verturn two values: A chain length and who the chain is for (define kantrn-evaluate-cell-left (lambda (arr c r x y) (do ((x (- x 1) (- x 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (< x 0) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-right (lambda (arr c r x y) (do ((x (+ x 1) (+ x 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (= x c) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-down (lambda (arr c r x y) (do ((y (+ y 1) (+ y 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (= y r) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-downleft (lambda (arr c r x y) (do ((x (- x 1) (- x 1)) (y (+ y 1) (+ y 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (< x 0) (= y r) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-downright (lambda (arr c r x y) (do ((x (+ x 1) (+ x 1)) (y (+ y 1) (+ y 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (= x c) (= y r) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-upleft (lambda (arr c r x y) (do ((x (- x 1) (- x 1)) (y (- y 1) (- y 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (< x 0) (< y 0) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-upright (lambda (arr c r x y) (do ((x (+ x 1) (+ x 1)) (y (- y 1) (- y 1)) (chain 0 (+ chain 1)) (chain-for #f)) ((or (= x c) (< y 0) (and chain-for (not (= (array-ref arr x y) chain-for)))) (values chain chain-for)) (if (not chain-for) (set! chain-for (array-ref arr x y))) ))) (define kantrn-evaluate-cell-subfn (lambda (fn . args) (call-with-values (lambda () (apply fn args)) (lambda (chain chain-for) (cond ((not chain-for) (values 0 0)) ((= chain-for 1) (values chain 0)) ((= chain-for 2) (values 0 chain)) (else (values 0 0)) ) ) ))) ; Evaluate a square on the board for strategic value ; Returns two values: The chains for 1 and the chains for 2 (define kantrn-evaluate-cell (lambda (board x y) (let ((arr (kantrn-board->array board)) (c (length board)) (r (length (car board)))) (let-values ( ((left1 left2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-left arr c r x y)) ((right1 right2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-right arr c r x y)) ((down1 down2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-down arr c r x y)) ((downleft1 downleft2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-downleft arr c r x y)) ((downright1 downright2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-downright arr c r x y)) ((upleft1 upleft2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-upleft arr c r x y)) ((upright1 upright2) (kantrn-evaluate-cell-subfn kantrn-evaluate-cell-upright arr c r x y)) ) (list (list left1 right1 down1 downleft1 downright1 upleft1 upright1 ) (list left2 right2 down2 downleft2 downright2 upleft2 upright2 ) ))))) ; Compile the opposing chains (define kantrn-compile-chains (lambda (eval-list mover) (match-let (( (left right down downleft downright upleft upright) (list-ref eval-list (- mover 1)) )) (list (+ left right) down (+ downleft upright) (+ downright upleft) )))) ; All valid moves (list x y) for a board (define kantrn-valid-moves (lambda (board) (remove (lambda (x) (= (cadr x) -1)) (list-tabulate (length board) (lambda (x) (list x (kantrn-free-square board x))))) ) ) ; Compile board statistics ; Returns a dotted pair of (list 3s 2s 1s) for (mover . enemy) (define kantrn-evaluate-board (lambda (board mover) (letrec ((possible-moves (kantrn-valid-moves board)) (all-evals (map (lambda (move) (apply kantrn-evaluate-cell board move)) possible-moves)) (chains (map (lambda (eval-data) (list (kantrn-compile-chains eval-data mover) (kantrn-compile-chains eval-data (if (= mover 1) 2 1)))) all-evals)) (lengths (apply map (lambda x (apply append x)) chains)) (calc-stats (lambda (lst 3s 2s 1s) (if (null? lst) (list 3s 2s 1s) (let ((n (car lst))) (cond ((= n 3) (calc-stats (cdr lst) (+ 3s 1) 2s 1s)) ((= n 2) (calc-stats (cdr lst) 3s (+ 2s 1) 1s)) ((= n 1) (calc-stats (cdr lst) 3s 2s (+ 1s 1))) (else (calc-stats (cdr lst) 3s 2s 1s)) ) ) ) )) ) (list (calc-stats (car lengths) 0 0 0) (calc-stats (cadr lengths) 0 0 0)) ) ) ) ; Silly scoring stuff (define kantrn-score-board (lambda-memo (board mover) (let ((stats (kantrn-evaluate-board board mover))) (match-let (( ((me-3s me-2s me-1s) (them-3s them-2s them-1s)) stats )) (cond ((> me-3s 0) 100) ; FTW! ((= them-3s 1) 99) ; "I'll take the dying boy to block" ((> them-3s 1) -100) ; It's a trap (else (- (+ (* me-2s 10) (* me-1s 2)) (+ (* them-2s 5) them-1s))) ) ) ) ) ) ; The following pseudo-code is from http://en.wikipedia.org/wiki/Alpha-beta_pruning (Yes, I really am that lazy) ;function minimax(node, depth) ; return alphabeta(node, depth, -∞, +∞) ; ;function alphabeta(node, depth, α, β) ; if node is a terminal node or depth = 0 ; return the heuristic value of node ; if the adversary is to play at node ; foreach child of node ; β := min(β, alphabeta(child, depth-1, α, β)) ; if α≥β ; return α ; return β ; else {we are to play at node} ; foreach child of node ; α := max(α, alphabeta(child, depth-1, α, β)) ; if α≥β ; return β ; return α (define kantrn-minimax (lambda (board me mover depth) (kantrn-alphabeta board me mover depth -inf.0 +inf.0)) ) (define kantrn-alphabeta (lambda (board me mover depth a b) (let ((alllines (kantrn-getall board))) (cond ((not (null? (filter (lambda (l) (kantrn-four-in-a-row? l me)) alllines))) 1000) ; I win, yay! ((not (null? (filter (lambda (l) (kantrn-four-in-a-row? l (if (= me 1) 2 1))) alllines))) -1000) ; They win, boo hiss! ((> (apply min (map (lambda (x) (apply min x)) board)) 0) -inf.0) ; No 0s in the board (terminal) (not bloddy likely) ((= depth 0) (kantrn-score-board board mover)) ; Bottom of the tree ((= mover me) (call/cc (lambda (return) (letrec ((fn (lambda (moves a b) (if (null? moves) (return a)) (let ((newa (max a (kantrn-alphabeta (kantrn-make-move board (car moves) mover) me (if (= mover 1) 2 1) (- depth 1) a b)))) (if (> newa b) (return b)) (fn (cdr moves) newa b) ) ) )) (fn (kantrn-valid-moves board) a b) ) )) ) (else (call/cc (lambda (return) (letrec ((fn (lambda (moves a b) (if (null? moves) (return b)) (let ((newb (min b (kantrn-alphabeta (kantrn-make-move board (car moves) mover) me (if (= mover 1) 2 1) (- depth 1) a b)))) (if (> a newb) (return a)) (fn (cdr moves) a newb) ) ) )) (fn (kantrn-valid-moves board) a b) ) )) ) )))) (define kantrn-getmove (lambda (board mover) (letrec ((bestval -inf.0) (bestmove #f) (best (make-hash-table)) (allmoves (kantrn-valid-moves board)) (write-lock (make-semaphore 1)) (helper (lambda (move depth) (let ((x (car move))(v (kantrn-minimax (kantrn-make-move board move mover) mover (if (= mover 1) 2 1) depth))) (printf "~a: ~a~n" x v) (semaphore-wait write-lock) (if (> v (hash-table-get best x -inf.0)) (hash-table-put! best x v) ) (semaphore-post write-lock) ) ) ) (helper2 (lambda (depth) (if (> depth 10) (raise 'omfg)) (display "Depth: ")(display depth)(newline) (for-each (lambda (move) (helper move depth)) allmoves) (helper2 (+ depth 1)) ) ) (calc-thread (thread (lambda () (helper2 4)))) ) (sync/timeout 30 (thread-dead-evt calc-thread)) (semaphore-wait write-lock) (kill-thread calc-thread) (semaphore-post write-lock) ; Single-threaded again (car (car (sort (hash-table-map best (lambda (k v) (list k v))) (lambda (a b) (> (cadr a) (cadr b)))))) ) ) ) ;(play-connect4 3 5 kantrn-getmove getmove-human) ;(kantrn-getmove (blank-game 6 7) 1) (play-connect4 6 7 kantrn-getmove kantrn-getmove)