pygments-bind9 / tests / examplefiles / reversi.lsp

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
#!/usr/bin/env newlisp
;; @module reversi.lsp
;; @description a simple version of Reversi: you as white against newLISP as black
;; @version 0.1 alpha August 2007
;; @author cormullion
;;
;; 2008-10-08 21:46:54
;; updated for newLISP version 10. (changed nth-set to setf)
;; this now does not work with newLISP version 9!
;;
;; This is my first attempt at writing a simple application using newLISP-GS.
;; The game algorithms are basically by 
;; Peter Norvig http://norvig.com/paip/othello.lisp
;; and all I've done is translate to newLISP and add the interface...
;;
;; To-Do: work out how to handle the end of the game properly...
;; To-Do: complete newlispdoc for the functions

(constant 'empty 0) 
(constant 'black 1) 
(constant 'white 2)
(constant 'outer 3) ; squares outside the 8x8 board

(set '*board* '()) ; the master board is a 100 element list
(set '*moves* '()) ; list of moves made

; these are the 8 different directions from a square on the board

(set 'all-directions '(-11 -10 -9 -1 1 9 10 11))

; return a list of all the playable squares (the 8 by 8 grid inside the 10by10

(define (all-squares)
  (local (result)
     (for (square 11 88)
        (if (<= 1 (mod square 10) 8)
           (push square result -1)))
result))

; make a board

(define (make-board)
  (set '*board* (dup outer 100))
  (dolist (s (all-squares))
     (setf (*board* s) empty)))

; for testing and working at a terminal

(define (print-board)
  (print { })
  (for (c 1 8)
     (print c))
  (set 'c 0)
  (for (i 0 99)
     (cond
        ((= (*board* i) 0) (print {.}))
        ((= (*board* i) 1) (print {b}))
        ((= (*board* i) 2) (print {w})))
     (if (and (<= i 88) (= (mod (+ i 1) 10) 0)) ; newline
        (print "\n" (inc c))))
  (println "\n"))

; the initial starting pattern

(define (initial-board)
  (make-board)
  (setf (*board* 44) white)
  (setf (*board* 55) white)
  (setf (*board* 45) black)
  (setf (*board* 54) black))

(define (opponent player)
  (if (= player black) white black))

(define (player-name player)
  (if (= player white) "white" "black"))
  
(define (valid-move? move)
  (and 
     (integer? move)
     (<= 11 move 88)
     (<= 1 (mod move 10) 8)))

(define (empty-square? square)
  (and
     (valid-move? square)
     (= (*board* square) empty)))
     
; test whether a move is legal. The square must be empty
; and it must flip at least one of the opponent's piece

(define (legal-move? move player)
  (and 
     (empty-square? move)
     (exists (fn (dir) (would-flip? move player dir)) all-directions)))

; would this move by player result in any flips in the given direction?
; if so, return the number of the 'opposite' (bracketing) piece's square

(define (would-flip? move player dir) 
  (let 
     ((c (+ move dir)))
     (and 
        (= (*board* c) (opponent player))
        (find-bracketing-piece (+ c dir) player dir))))
  
(define (find-bracketing-piece square player dir)
  ; return the square of the bracketing piece, if any
  (cond
     ((= (*board* square) player) square)
     ((= (*board* square) (opponent player))
        (find-bracketing-piece (+ square dir) player dir))
     (true nil)))

(define (make-flips move player dir)
  (let 
     ((bracketer (would-flip? move player dir))
      (c (+ move dir)))
  (if bracketer
     (do-until (= c bracketer)
        (setf (*board* c) player)
        (push c *flips* -1)
        (inc c dir)))))

; make the move on the master game board, not yet visually

(define (make-move move player)
  (setf (*board* move) player)
  (push move *moves* -1)
  (set '*flips* '()) ; we're going to keep a record of the flips made
  (dolist (dir all-directions)
     (make-flips move player dir)))

(define (next-to-play previous-player)
  (let ((opp (opponent previous-player)))
     (cond
        ((any-legal-move? opp) opp)
        ((any-legal-move? previous-player)
           (println (player-name opp) " has no moves")
           previous-player)
        (true nil))))
        
; are there any legal moves (returns first) for this player?
(define (any-legal-move? player)
  (exists (fn (move) (legal-move? move player)) 
     (all-squares)))

; a list of all legal moves might be useful
(define (legal-moves player)
  (let ((result '()))
     (dolist (move (all-squares))
        (if (legal-move? move player)
           (push move result)))
  (unique result)))

; define any number of strategies that can be called on to calculate
; the next computer move. This is the only one I've done... - make 
; any legal move at random!

(define (random-strategy player)
  (seed (date-value))
  (apply amb (legal-moves player)))

; get the next move using a particular strategy

(define (get-move strategy player)
 (let ((move (apply strategy (list player))))
  (cond
     ((and
        (valid-move? move)
        (legal-move? move player))
            (make-move move player))
     (true  
        (println "no valid or legal move for " (player-name player) )
        nil))
  move))

; that's about all the game algorithms for now
; now for the interface

(if (= ostype "Win32")
   (load (string (env "PROGRAMFILES") "/newlisp/guiserver.lsp"))
   (load "/usr/share/newlisp/guiserver.lsp")
)

(gs:init)
(map set '(screen-width screen-height) (gs:get-screen))
(set 'board-width 540)
; center on screen
(gs:frame 'Reversi (- (/ screen-width 2) (/ board-width 2)) 60 board-width 660 "Reversi")
(gs:set-border-layout 'Reversi)

(gs:canvas 'MyCanvas 'Reversi)
  (gs:set-background 'MyCanvas '(.8 .9 .7 .8))
  (gs:mouse-released 'MyCanvas 'mouse-released-action true)

(gs:panel 'Controls)
  (gs:button 'Start 'start-game "Start")

(gs:panel 'Lower)
  (gs:label 'WhiteScore "")
  (gs:label 'BlackScore "")

(gs:add-to 'Controls 'Start )
(gs:add-to 'Lower 'WhiteScore 'BlackScore)
(gs:add-to 'Reversi 'MyCanvas "center" 'Controls "north" 'Lower "south")

(gs:set-anti-aliasing true)
(gs:set-visible 'Reversi true)

; size of board square, and radius/width of counter
(set 'size 60 'width 30)

; initialize the master board

(define (initial-board)
  (make-board)
  (setf (*board* 44) white)
  (setf (*board* 55) white)
  (setf (*board* 45) black)
  (setf (*board* 54) black)  
)

; draw a graphical repesentation of the board

(define (draw-board)
  (local (x y)
     (dolist (i (all-squares))
        (map set '(x y) (square-to-xy i))
        (gs:draw-rect 
           (string x y) 
           (- (* y size) width ) ; !!!!!!
           (- (* x size) width )
           (* width 2)
           (* width 2)
           gs:white))))

(define (draw-first-four-pieces)
  (draw-piece 44 "white")
  (draw-piece 55 "white")
  (draw-piece 45 "black")
  (draw-piece 54 "black"))

; this next function can mark the legal moves available to a player

(define (show-legal-moves player)
  (local (legal-move-list x y)
     (set 'legal-move-list (legal-moves player))
     (dolist (m (all-squares))
        (map set '(x y) (square-to-xy m))
        (gs:draw-rect 
           (string x y) 
           (- (* y size) width ) ; !!!!!!
           (- (* x size) width )
           (* width 2)
           (* width 2)
           (if (find m legal-move-list) gs:blue gs:white)
        )
     )
  )
)

; convert the number of a square on the master board to coordinates

(define (square-to-xy square) 
  (list (/ square 10) (mod square 10)))

; draw one of the pieces

(define (draw-piece square colour)
  (local (x y)
  (map set '(x y) (square-to-xy square))
  (cond 
     ((= colour "white") 
        (gs:fill-circle 
           (string x y) 
           (* y size)  ; !!!!!!! y first, cos y is x ;-)
           (* x size) 
           width
           gs:white))
     
     ((= colour "black") 
        (gs:fill-circle 
           (string x y) 
           (* y size) 
           (* x size) 
           width
           gs:black))
     
     ((= colour "empty") 
        (gs:draw-rect 
           (string x y) 
           (- (* y size) width ) 
           (- (* x size) width )
           (* width 2)
           (* width 2)
           gs:white))
  )))

; animate the pieces flipping

(define (flip-piece square player)
; flip by drawing thinner and fatter ellipses 
; go from full disk in opposite colour to invisible
; then from invisible to full disk in true colour
  (local (x y colour)
     (map set '(x y) (square-to-xy square))
     ; delete original piece
     (gs:delete-tag (string x y))
     (set 'colour (if (= player 2) gs:black gs:white )) 
     (for (i width  1 -3)
        (gs:fill-ellipse 
           (string x y {flip} i) 
           (* y size) ; y first :-) !!! 
           (* x size) 
           i 
           width
           colour)
        (sleep 20)  ; this might need adjusting...
        (gs:delete-tag (string x y {flip} i))
     )
     (set 'colour (if (= player 2) gs:white gs:black))
     (for (i 1 width 3)
        (gs:fill-ellipse 
           (string x y {flip} i) 
           (* y size) ; :-) !!! 
           (* x size) 
           i 
           width
           colour)
        (sleep 20)  
        (gs:delete-tag (string x y {flip} i))
     )
     ; draw the piece again
     (gs:fill-circle 
           (string x y) 
           (* y size)
           (* x size) 
           width
           colour)
  )
)

(define (do-move move player)
  (cond 
     ; check if the move is good ...
     ((and (!= player nil)
           (valid-move? move)
           (legal-move? move player))
           
           ; ... play it
              ; make move on board
              (make-move move player)
              ; and on screen
              (draw-piece move (player-name player))
              (gs:update)
              ; do flipping stuff
              
              ; wait for a while
              (sleep 1000)
  
              ; then do flipping
              (dolist (f *flips*)
                 (flip-piece f player))
              
              (inc *move-number*)
              (draw-piece move (player-name player))
              (gs:update)

              ; update scores
              (gs:set-text 'WhiteScore 
                 (string "White: " (first (count (list white) *board*))))
              (gs:set-text 'BlackScore
                 (string "Black: " (first (count (list black) *board*))))
              )
     ; or return nil
     (true 
           nil)))

; the game is driven by the mouse clicks of the user
; in reply, the computer plays a black piece
; premature clicking is possible and possibly a bad thing...

(define (mouse-released-action x y button modifiers tags)
  ; extract the tag of the clicked square
  (set 'move (int (string (first tags)) 0 10))
  (if (do-move move player)
     (begin
        (set 'player (next-to-play player))
        ; there is a training mode - legal squares are highlighted
        ; you can uncomment the next line...
        ; (show-legal-moves player)
        (gs:update)
        
        ; wait for black's reply
        (gs:set-cursor 'Reversi "wait")
        (gs:set-text 'Start "black's move - thinking...")
        ; give the illusion of Deep Thought...
        (sleep 2000)
        ; black's reply
        ; currently only the random strategy has been defined...
        (set 'strategy random-strategy)
        (set 'move (apply strategy (list player)))
        (do-move move player)
        (set 'player (next-to-play player))
        ; (show-legal-moves player) ; to see black's moves
        (gs:set-text 'Start "your move")
        (gs:set-cursor 'Reversi "default")
        (gs:update))))

(define (start-game)
  (gs:set-text 'Start "Click a square to place a piece!")
  (gs:disable 'Start)
  (set 'player white))

(define (start)
  (gs:set-text 'Start "Start")
  (gs:enable 'Start)
  (set  '*move-number* 1
        '*flips* '())
  (initial-board)
  (draw-board)
  (draw-first-four-pieces))

(start)

(gs:listen)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.