-
Notifications
You must be signed in to change notification settings - Fork 0
/
dice_of_doom_v3.lisp
152 lines (138 loc) · 6.21 KB
/
dice_of_doom_v3.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
(load "~/Development/CLISP/LOL/DiceOfDoom_V2.lisp")
(load "~/Development/CLISP/LOL/WebServer.lisp")
(load "~/Development/CLISP/LOL/svg.lisp")
(defparameter *board-width* 900)
(defparameter *board-height* 500)
(defparameter *board-scale* 64)
(defparameter *top-offset* 3)
(defparameter *dice-scale* 40)
(defparameter *dot-size* 0.05)
(defun draw-die-svg (x y col)
(labels ((calc-pt (pt)
(cons (+ x (* *dice-scale* (first pt)))
(+ y (* *dice-scale* (rest pt)))))
(f (pol col)
(polygon (mapcar #'calc-pt pol) col)))
(f '((0 . -1) (-0.6 . -0.75) (0 . -0.5) (0.6 . -0.75))
(brightness col 40))
(f '((0 . -0.5) (-0.6 . -0.75) (-0.6 . 0) (0 . 0.25))
col)
(f '((0 . -0.5) (0.6 . -0.75) (0.6 . 0) (0 . 0.25))
(brightness col -40))
(mapc (lambda (x y)
(polygon (mapcar (lambda (xx yy)
(calc-pt (cons (+ x (* xx *dot-size*))
(+ y (* yy *dot-size*)))))
'(-1 -1 1 1)
'(-1 1 1 -1))
'(255 255 255)))
'(-0.05 0.125 0.3 -0.3 -0.125 0.05 0.2 0.2 0.45 0.45 -0.45 -0.2)
'(-0.875 -0.80 -0.725 -0.775 -0.7 -0.625
-0.35 -0.05 -0.45 -0.15 -0.45 -0.05))))
(defun draw-tile-svg (x y pos hex xx yy col chosen-tile)
(loop for z below 2
do (polygon (mapcar (lambda (pt)
(cons (+ xx (* *board-scale* (first pt)))
(+ yy (* *board-scale* (+ (rest pt) (* (- 1 z) 0.1))))))
'((-1 . -0.2) (0 . -0.5) (1 . -0.2)
(1 . 0.2) (0 . 0.5) (-1 . 0.2)))
(if (eql pos chosen-tile)
(brightness col 100)
col)))
(loop for z below (second hex)
do (draw-die-svg (+ xx
(* *dice-scale*
0.3
(if (oddp (+ x y z))
-0.3
0.3)))
(- yy (* *dice-scale* z 0.8)) col)))
(defparameter *die-colors* '((255 63 63) (63 63 255)))
(defun draw-board-svg (board chosen-tile legal-tiles)
(loop for y below *board-size*
do (loop for x below *board-size*
for pos = (+ x (* *board-size* y))
for hex = (aref board pos)
for xx = (* *board-scale* (+ (* 2 x) (- *board-size* y)))
for yy = (* *board-scale* (+ (* y 0.7) *top-offset*))
for col = (brightness (nth (first hex) *die-colors*)
(* -15 (- *board-size* y)))
do (if (or (member pos legal-tiles) (eql pos chosen-tile))
(tag g () (tag a ("xlink:href" (make-game-link pos))
(draw-tile-svg x y pos hex xx yy col chosen-tile)))
(draw-tile-svg x y pos hex xx yy col chosen-tile)))))
(defun make-game-link (pos)
(format nil "/game.html?chosen=~a" pos))
(defparameter *cur-game-tree* nil)
(defparameter *from-tile* nil)
(defun dod-request-handler (path header params)
(if (equal path "game.html")
(progn (princ "<!doctype html>")
(tag center ()
(princ "Welcome to DICE OF DOOM")
(tag br ())
(let ((chosen (assoc 'chosen params)))
(when (or (not *cur-game-tree*) (not chosen))
(setf chosen nil)
(web-initialize))
(cond ((lazy-null (caddr *cur-game-tree*))
(web-announce-winner (rest *cur-game-tree*)))
((zerop (first *cur-game-tree*))
(web-handle-human
(when chosen
(read-from-string (rest chosen)))))
(t (web-handle-computer))))
(tag br ())
(draw-dod-page *cur-game-tree* *from-tile*)))
(princ "Sorry... I don't know that page.")))
(defun web-initialize ()
(setf *from-tile* nil)
(setf *cur-game-tree* (game-tree (gen-board) 0 0 t)))
(defun web-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 (first w)))))
(tag a (href "game.html")
(princ " play again")))
(defun web-handle-human (pos)
(cond ((not pos) (princ "Please choose a hex to move from:"))
((eq pos 'pass) (setf *cur-game-tree* (second (lazy-first (third *cur-game-tree*))))
(princ "Your reinforcements have been placed.")
(tag a (href (make-game-link nil))
(princ "confinue")))
((not *from-tile*) (setf *from-tile* pos)
(princ "Now choose a destination:"))
((eq pos *from-tile*) (setf *from-tile* nil)
(princ "Move cancelled."))
(t (setf *cur-game-tree*
(pick-chance-branch
(second *cur-game-tree*)
(lazy-find-if (lambda (move)
(equal (first move)
(list *from-tile* pos)))
(third *cur-game-tree*))))
(setf *from-tile* nil)
(princ "You may now ")
(tag a (href (make-game-link 'pass))
(princ "pass"))
(princ " or make another move:"))))
(defun web-handle-computer ()
(setf *cur-game-tree* (handle-computer *cur-game-tree*))
(princ "The computer has moved. ")
(tag script ()
(princ "window.setTimeout('window.location=\"game.html?chosen=NIL\"',5000)")))
(defun draw-dod-page (tree selected-tile)
(svg 900
500
(draw-board-svg (second tree)
selected-tile
(take-all (if selected-tile
(lazy-mapcar
(lambda (move)
(when (eql (caar move)
selected-tile)
(cadar move)))
(third tree))
(lazy-mapcar #'caar (third tree)))))))