-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathdice-of-doom-v1.lisp
230 lines (199 loc) · 8.45 KB
/
dice-of-doom-v1.lisp
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
(defparameter *number-of-players* 2)
(defparameter *maximum-dice-per-space* 3)
(defparameter *board-length* 3)
(defparameter *board-hex-count* (* *board-length* *board-length*))
(defun board-array (list)
(make-array *board-hex-count* :initial-contents list))
(defun generate-board ()
(board-array (loop for n below *board-hex-count*
collect (list (random *number-of-players*)
(1+ (random *maximum-dice-per-space*))))))
(defun player-letter (number)
(code-char (+ 97 number)))
(defun draw-board (board)
(loop for y-position below *board-length*
do (progn (fresh-line)
(loop repeat (- *board-length* y-position)
do (princ " "))
(loop for x-position below *board-length*
for hex = (aref board (+ x-position
(* *board-length* y-position)))
do (format t "~a-~a " (player-letter (first hex))
(second hex))))))
(defun game-tree (board player spare-dice first-move)
(list player
board
(add-passing-move board
player
spare-dice
first-move
(attacking-moves board player spare-dice))))
(compile 'game-tree)
(let ((old-game-tree (symbol-function 'game-tree))
(previous (make-hash-table :test #'equalp)))
(defun game-tree (&rest rest)
(or (gethash rest previous)
(setf (gethash rest previous) (apply old-game-tree rest)))))
(compile 'game-tree)
(defun add-passing-move (board player spare-dice first-move moves)
(if first-move
moves
(cons (list nil
(game-tree (add-new-dice board player
(1- spare-dice))
(mod (1+ player) *number-of-players*)
0
t))
moves)))
(defun attacking-moves (board current-player spare-dice)
(labels ((player (position)
(car (aref board position)))
(dice (position)
(cadr (aref board position))))
(mapcan
(lambda (source)
(when (eq (player source) current-player)
(mapcan
(lambda (destination)
(when (and (not (eq (player destination)
current-player))
(> (dice source) (dice destination)))
(list (list (list source destination)
(game-tree
(board-attack board
current-player
source
destination
(dice source))
current-player
(+ spare-dice (dice destination))
nil)))))
(neighbors source))))
(loop for n below *board-hex-count*
collect n))))
(defun neighbors (position)
(let ((up (- position *board-length*))
(down (+ position *board-length*)))
(loop for p in (append (list up down)
(unless (zerop (mod position *board-length*))
(list (1- up) (1- position)))
(unless (zerop (mod (1+ position) *board-length*))
(list (1+ position) (1+ down))))
when (and (>= p 0) (< p *board-hex-count*))
collect p)))
(compile 'neighbors)
(let ((old-neighbors (symbol-function 'neighbors))
(previous (make-hash-table)))
(defun neighbors (position)
(or (gethash position previous)
(setf (gethash position previous) (funcall old-neighbors position)))))
(compile 'neighbors)
(defun board-attack (board player source destination dice)
(board-array (loop for position from 0
for hex across board
collect (cond ((eq position source) (list player 1))
((eq position destination) (list player (1- dice)))
(t hex)))))
;; Old non-tail call recursion version.
;; (defun add-new-dice (board player spare-dice)
;; (labels ((f (board-subset dice-available)
;; (cond ((null board-subset) nil)
;; ((zerop dice-available) board-subset)
;; (t (let ((current-player (caar board-subset))
;; (current-dice (cadar board-subset)))
;; (if (and (eq current-player player)
;; (< current-dice *maximum-dice-per-space*))
;; (cons (list current-player (1+ current-dice))
;; (f (cdr board-subset) (1- dice-available)))
;; (cons (car board-subset)
;; (f (cdr board-subset) dice-available))))))))
;; (board-array (f (coerce board 'list) spare-dice))))
(defun add-new-dice (board player spare-dice)
(labels ((f (list n accumulator)
(cond ((zerop n) (append (reverse accumulator) list))
((null list) (reverse accumulator))
(t (let ((current-player (caar list))
(curent-dice (cadar list)))
(if (and (eq current-player player)
(< curent-dice *maximum-dice-per-space*))
(f (cdr list)
(1- n)
(cons (list current-player (1+ curent-dice)) accumulator))
(f (cdr list) n (cons (car list) accumulator))))))))
(board-array (f (coerce board 'list) spare-dice ()))))
(compile 'add-new-dice)
(defun play-versus-human (tree)
(print-info tree)
(if (caddr tree)
(play-versus-human (handle-human tree))
(announce-winner (cadr tree))))
(defun print-info (tree)
(fresh-line)
(format t "current player = ~a" (player-letter (car tree)))
(draw-board (cadr tree)))
(defun handle-human (tree)
(fresh-line)
(princ "Choose your move: ")
(let ((moves (caddr tree)))
(loop for move in moves
for n from 1
do (let ((action (car move)))
(fresh-line)
(format t "~a. " n)
(if action
(format t "~a -> ~a" (car action) (cadr action))
(princ "end turn"))))
(fresh-line)
(cadr (nth (1- (read)) moves))))
(defun winners (board)
(let* ((tally (loop for hex across board
collect (car hex)))
(totals (mapcar (lambda (player)
(cons player (count player tally)))
(remove-duplicates tally)))
(best (apply #'max (mapcar #'cdr totals))))
(mapcar #'car
(remove-if (lambda (x)
(not (eq (cdr x) best)))
totals))))
(defun announce-winner (board)
(fresh-line)
(let ((w (winners board)))
(if (> (length w) 1)
(format t "The game is a tie between ~a" (mapcar #'player-letter w))
(format t "The winner is ~a" (player-letter (car w))))))
(defun rate-position (tree player)
(let ((moves (caddr tree)))
(if moves
(apply (if (eq (car tree) player)
#'max
#'min)
(get-ratings tree player))
(let ((w (winners (cadr tree))))
(if (member player w)
(/ 1 (length w))
0)))))
(compile 'rate-position)
(let ((old-rate-position (symbol-function 'rate-position))
(previous (make-hash-table)))
(defun rate-position (tree player)
(let ((table (gethash player previous)))
(unless table
(setf table (setf (gethash player previous) (make-hash-table))))
(or (gethash tree table)
(setf (gethash tree table)
(funcall old-rate-position tree player))))))
(compile 'rate-position)
(defun get-ratings (tree player)
(mapcar (lambda (move)
(rate-position (cadr move) player))
(caddr tree)))
(defun handle-computer (tree)
(let ((ratings (get-ratings tree (car tree))))
(cadr (nth (position (apply #'max ratings) ratings) (caddr tree)))))
(defun play-versus-computer (tree)
(print-info tree)
(cond ((null (caddr tree)) (announce-winner (cadr tree)))
((zerop (car tree)) (play-versus-computer (handle-human tree)))
(t (play-versus-computer (handle-computer tree)))))
;; (play-versus-computer (game-tree (generate-board) 0 0 t))