1#!/usr/bin/env newlisp 2;; @module reversi.lsp 3;; @description a simple version of Reversi: you as white against newLISP as black 4;; @version 0.1 alpha August 2007 5;; @author cormullion 6;; 7;; 2008-10-08 21:46:54 8;; updated for newLISP version 10. (changed nth-set to setf) 9;; this now does not work with newLISP version 9! 10;; 11;; This is my first attempt at writing a simple application using newLISP-GS. 12;; The game algorithms are basically by 13;; Peter Norvig http://norvig.com/paip/othello.lisp 14;; and all I've done is translate to newLISP and add the interface... 15;; 16;; To-Do: work out how to handle the end of the game properly... 17;; To-Do: complete newlispdoc for the functions 18 19(constant 'empty 0) 20(constant 'black 1) 21(constant 'white 2) 22(constant 'outer 3) ; squares outside the 8x8 board 23 24(set '*board* '()) ; the master board is a 100 element list 25(set '*moves* '()) ; list of moves made 26 27; these are the 8 different directions from a square on the board 28 29(set 'all-directions '(-11 -10 -9 -1 1 9 10 11)) 30 31; return a list of all the playable squares (the 8 by 8 grid inside the 10by10 32 33(define (all-squares) 34 (local (result) 35 (for (square 11 88) 36 (if (<= 1 (mod square 10) 8) 37 (push square result -1))) 38result)) 39 40; make a board 41 42(define (make-board) 43 (set '*board* (dup outer 100)) 44 (dolist (s (all-squares)) 45 (setf (*board* s) empty))) 46 47; for testing and working at a terminal 48 49(define (print-board) 50 (print { }) 51 (for (c 1 8) 52 (print c)) 53 (set 'c 0) 54 (for (i 0 99) 55 (cond 56 ((= (*board* i) 0) (print {.})) 57 ((= (*board* i) 1) (print {b})) 58 ((= (*board* i) 2) (print {w}))) 59 (if (and (<= i 88) (= (mod (+ i 1) 10) 0)) ; newline 60 (print "\n" (inc c)))) 61 (println "\n")) 62 63; the initial starting pattern 64 65(define (initial-board) 66 (make-board) 67 (setf (*board* 44) white) 68 (setf (*board* 55) white) 69 (setf (*board* 45) black) 70 (setf (*board* 54) black)) 71 72(define (opponent player) 73 (if (= player black) white black)) 74 75(define (player-name player) 76 (if (= player white) "white" "black")) 77 78(define (valid-move? move) 79 (and 80 (integer? move) 81 (<= 11 move 88) 82 (<= 1 (mod move 10) 8))) 83 84(define (empty-square? square) 85 (and 86 (valid-move? square) 87 (= (*board* square) empty))) 88 89; test whether a move is legal. The square must be empty 90; and it must flip at least one of the opponent's piece 91 92(define (legal-move? move player) 93 (and 94 (empty-square? move) 95 (exists (fn (dir) (would-flip? move player dir)) all-directions))) 96 97; would this move by player result in any flips in the given direction? 98; if so, return the number of the 'opposite' (bracketing) piece's square 99 100(define (would-flip? move player dir) 101 (let 102 ((c (+ move dir))) 103 (and 104 (= (*board* c) (opponent player)) 105 (find-bracketing-piece (+ c dir) player dir)))) 106 107(define (find-bracketing-piece square player dir) 108 ; return the square of the bracketing piece, if any 109 (cond 110 ((= (*board* square) player) square) 111 ((= (*board* square) (opponent player)) 112 (find-bracketing-piece (+ square dir) player dir)) 113 (true nil))) 114 115(define (make-flips move player dir) 116 (let 117 ((bracketer (would-flip? move player dir)) 118 (c (+ move dir))) 119 (if bracketer 120 (do-until (= c bracketer) 121 (setf (*board* c) player) 122 (push c *flips* -1) 123 (inc c dir))))) 124 125; make the move on the master game board, not yet visually 126 127(define (make-move move player) 128 (setf (*board* move) player) 129 (push move *moves* -1) 130 (set '*flips* '()) ; we're going to keep a record of the flips made 131 (dolist (dir all-directions) 132 (make-flips move player dir))) 133 134(define (next-to-play previous-player) 135 (let ((opp (opponent previous-player))) 136 (cond 137 ((any-legal-move? opp) opp) 138 ((any-legal-move? previous-player) 139 (println (player-name opp) " has no moves") 140 previous-player) 141 (true nil)))) 142 143; are there any legal moves (returns first) for this player? 144(define (any-legal-move? player) 145 (exists (fn (move) (legal-move? move player)) 146 (all-squares))) 147 148; a list of all legal moves might be useful 149(define (legal-moves player) 150 (let ((result '())) 151 (dolist (move (all-squares)) 152 (if (legal-move? move player) 153 (push move result))) 154 (unique result))) 155 156; define any number of strategies that can be called on to calculate 157; the next computer move. This is the only one I've done... - make 158; any legal move at random! 159 160(define (random-strategy player) 161 (seed (date-value)) 162 (apply amb (legal-moves player))) 163 164; get the next move using a particular strategy 165 166(define (get-move strategy player) 167 (let ((move (apply strategy (list player)))) 168 (cond 169 ((and 170 (valid-move? move) 171 (legal-move? move player)) 172 (make-move move player)) 173 (true 174 (println "no valid or legal move for " (player-name player) ) 175 nil)) 176 move)) 177 178; that's about all the game algorithms for now 179; now for the interface 180 181(if (= ostype "Win32") 182 (load (string (env "PROGRAMFILES") "/newlisp/guiserver.lsp")) 183 (load "/usr/share/newlisp/guiserver.lsp") 184) 185 186(gs:init) 187(map set '(screen-width screen-height) (gs:get-screen)) 188(set 'board-width 540) 189; center on screen 190(gs:frame 'Reversi (- (/ screen-width 2) (/ board-width 2)) 60 board-width 660 "Reversi") 191(gs:set-border-layout 'Reversi) 192 193(gs:canvas 'MyCanvas 'Reversi) 194 (gs:set-background 'MyCanvas '(.8 .9 .7 .8)) 195 (gs:mouse-released 'MyCanvas 'mouse-released-action true) 196 197(gs:panel 'Controls) 198 (gs:button 'Start 'start-game "Start") 199 200(gs:panel 'Lower) 201 (gs:label 'WhiteScore "") 202 (gs:label 'BlackScore "") 203 204(gs:add-to 'Controls 'Start ) 205(gs:add-to 'Lower 'WhiteScore 'BlackScore) 206(gs:add-to 'Reversi 'MyCanvas "center" 'Controls "north" 'Lower "south") 207 208(gs:set-anti-aliasing true) 209(gs:set-visible 'Reversi true) 210 211; size of board square, and radius/width of counter 212(set 'size 60 'width 30) 213 214; initialize the master board 215 216(define (initial-board) 217 (make-board) 218 (setf (*board* 44) white) 219 (setf (*board* 55) white) 220 (setf (*board* 45) black) 221 (setf (*board* 54) black) 222) 223 224; draw a graphical repesentation of the board 225 226(define (draw-board) 227 (local (x y) 228 (dolist (i (all-squares)) 229 (map set '(x y) (square-to-xy i)) 230 (gs:draw-rect 231 (string x y) 232 (- (* y size) width ) ; !!!!!! 233 (- (* x size) width ) 234 (* width 2) 235 (* width 2) 236 gs:white)))) 237 238(define (draw-first-four-pieces) 239 (draw-piece 44 "white") 240 (draw-piece 55 "white") 241 (draw-piece 45 "black") 242 (draw-piece 54 "black")) 243 244; this next function can mark the legal moves available to a player 245 246(define (show-legal-moves player) 247 (local (legal-move-list x y) 248 (set 'legal-move-list (legal-moves player)) 249 (dolist (m (all-squares)) 250 (map set '(x y) (square-to-xy m)) 251 (gs:draw-rect 252 (string x y) 253 (- (* y size) width ) ; !!!!!! 254 (- (* x size) width ) 255 (* width 2) 256 (* width 2) 257 (if (find m legal-move-list) gs:blue gs:white) 258 ) 259 ) 260 ) 261) 262 263; convert the number of a square on the master board to coordinates 264 265(define (square-to-xy square) 266 (list (/ square 10) (mod square 10))) 267 268; draw one of the pieces 269 270(define (draw-piece square colour) 271 (local (x y) 272 (map set '(x y) (square-to-xy square)) 273 (cond 274 ((= colour "white") 275 (gs:fill-circle 276 (string x y) 277 (* y size) ; !!!!!!! y first, cos y is x ;-) 278 (* x size) 279 width 280 gs:white)) 281 282 ((= colour "black") 283 (gs:fill-circle 284 (string x y) 285 (* y size) 286 (* x size) 287 width 288 gs:black)) 289 290 ((= colour "empty") 291 (gs:draw-rect 292 (string x y) 293 (- (* y size) width ) 294 (- (* x size) width ) 295 (* width 2) 296 (* width 2) 297 gs:white)) 298 ))) 299 300; animate the pieces flipping 301 302(define (flip-piece square player) 303; flip by drawing thinner and fatter ellipses 304; go from full disk in opposite colour to invisible 305; then from invisible to full disk in true colour 306 (local (x y colour) 307 (map set '(x y) (square-to-xy square)) 308 ; delete original piece 309 (gs:delete-tag (string x y)) 310 (set 'colour (if (= player 2) gs:black gs:white )) 311 (for (i width 1 -3) 312 (gs:fill-ellipse 313 (string x y {flip} i) 314 (* y size) ; y first :-) !!! 315 (* x size) 316 i 317 width 318 colour) 319 (sleep 20) ; this might need adjusting... 320 (gs:delete-tag (string x y {flip} i)) 321 ) 322 (set 'colour (if (= player 2) gs:white gs:black)) 323 (for (i 1 width 3) 324 (gs:fill-ellipse 325 (string x y {flip} i) 326 (* y size) ; :-) !!! 327 (* x size) 328 i 329 width 330 colour) 331 (sleep 20) 332 (gs:delete-tag (string x y {flip} i)) 333 ) 334 ; draw the piece again 335 (gs:fill-circle 336 (string x y) 337 (* y size) 338 (* x size) 339 width 340 colour) 341 ) 342) 343 344(define (do-move move player) 345 (cond 346 ; check if the move is good ... 347 ((and (!= player nil) 348 (valid-move? move) 349 (legal-move? move player)) 350 351 ; ... play it 352 ; make move on board 353 (make-move move player) 354 ; and on screen 355 (draw-piece move (player-name player)) 356 (gs:update) 357 ; do flipping stuff 358 359 ; wait for a while 360 (sleep 1000) 361 362 ; then do flipping 363 (dolist (f *flips*) 364 (flip-piece f player)) 365 366 (inc *move-number*) 367 (draw-piece move (player-name player)) 368 (gs:update) 369 370 ; update scores 371 (gs:set-text 'WhiteScore 372 (string "White: " (first (count (list white) *board*)))) 373 (gs:set-text 'BlackScore 374 (string "Black: " (first (count (list black) *board*)))) 375 ) 376 ; or return nil 377 (true 378 nil))) 379 380; the game is driven by the mouse clicks of the user 381; in reply, the computer plays a black piece 382; premature clicking is possible and possibly a bad thing... 383 384(define (mouse-released-action x y button modifiers tags) 385 ; extract the tag of the clicked square 386 (set 'move (int (string (first tags)) 0 10)) 387 (if (do-move move player) 388 (begin 389 (set 'player (next-to-play player)) 390 ; there is a training mode - legal squares are highlighted 391 ; you can uncomment the next line... 392 ; (show-legal-moves player) 393 (gs:update) 394 395 ; wait for black's reply 396 (gs:set-cursor 'Reversi "wait") 397 (gs:set-text 'Start "black's move - thinking...") 398 ; give the illusion of Deep Thought... 399 (sleep 2000) 400 ; black's reply 401 ; currently only the random strategy has been defined... 402 (set 'strategy random-strategy) 403 (set 'move (apply strategy (list player))) 404 (do-move move player) 405 (set 'player (next-to-play player)) 406 ; (show-legal-moves player) ; to see black's moves 407 (gs:set-text 'Start "your move") 408 (gs:set-cursor 'Reversi "default") 409 (gs:update)))) 410 411(define (start-game) 412 (gs:set-text 'Start "Click a square to place a piece!") 413 (gs:disable 'Start) 414 (set 'player white)) 415 416(define (start) 417 (gs:set-text 'Start "Start") 418 (gs:enable 'Start) 419 (set '*move-number* 1 420 '*flips* '()) 421 (initial-board) 422 (draw-board) 423 (draw-first-four-pieces)) 424 425(start) 426 427(gs:listen)