-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathgame.lisp
261 lines (236 loc) · 11 KB
/
game.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
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
(in-package :lambda-lifter)
(defun make-script (script)
(lambda (world objects path metadata)
(iter (for action in script)
(multiple-value-setq (world objects path metadata)
(funcall action world objects path metadata))
(finally (return (values world objects path metadata))))))
(defun make-game-turn (move)
(let ((go-script
(ecase move
(:L #'robot-go-left-script)
(:R #'robot-go-right-script)
(:D #'robot-go-down-script)
(:U #'robot-go-up-script)
(:W #'robot-go-wait-script)
(:S #'robot-go-razor-script))))
(lambda (world objects path metadata)
;; (declare (optimize (debug 3)))
(when go-script
(let ((robot-actions (funcall go-script world objects path metadata)))
(when robot-actions
(flet ((objects-collected (objects)
(+ (length (funcall objects :collected-lambda))
(length (funcall objects :collected-lifts)))))
(let ((game-turn-script (make-script (append robot-actions
(list (lambda (world objects path metadata)
(multiple-value-bind (world~ objects~ path~ metadata~)
(rocks-move world objects path metadata)
(funcall (beards-growth world objects) world~ objects~ path~ metadata~)))
#'water-update))))
(before-objects-collected (objects-collected objects)))
(multiple-value-bind (world objects path metadata)
(funcall game-turn-script world objects path metadata)
(if (> (objects-collected objects) before-objects-collected)
(path-set-cleared world objects path metadata)
(values world objects path metadata)))))))))))
(defun make-player (world objects path metadata)
(lambda (replay-path turn-callback)
(funcall turn-callback world objects path metadata)
(multiple-value-bind (turn-world turn-objects turn-path turn-metadata)
(values world objects path metadata)
(iter (with existing-moves = (reverse (funcall path)))
(for move in (reverse (funcall replay-path)))
(for existing-move = (car existing-moves))
(setf existing-moves (cdr existing-moves))
(when (eq move existing-move) ;; skip already done moves
(next-iteration))
(assert (not existing-moves))
(when (eq move :A)
(return (values turn-world turn-objects turn-path turn-metadata)))
(for turn-proc = (make-game-turn move))
(multiple-value-bind (new-world new-objects new-path new-metadata)
(funcall turn-proc turn-world turn-objects turn-path turn-metadata)
(multiple-value-setq (turn-world turn-objects turn-path turn-metadata)
(if (and new-world new-objects new-path new-metadata)
(values new-world new-objects new-path new-metadata)
(funcall (make-game-turn :W) turn-world turn-objects turn-path turn-metadata)))
(funcall turn-callback turn-world turn-objects turn-path turn-metadata))
(finally (return (values turn-world turn-objects turn-path turn-metadata)))))))
(defun visited-p (action sample-dx sample-dy path player)
(funcall player
path
(lambda (world objects path metadata)
(declare (ignore world metadata))
(with-robot-coords (rx ry) objects
(when (and (= rx sample-dx)
(= ry sample-dy)
(case action
((:W :S) (eq (first (funcall path)) action))
(t t)))
(return-from visited-p t)))))
nil)
(defun useless-action-p (move world objects path metadata turn-world turn-objects turn-path turn-metadata player)
(declare (ignore world metadata turn-world turn-path turn-metadata))
(with-robot-coords (rx ry) turn-objects
(ecase move
(:W (or (equal (funcall objects :rock) (funcall turn-objects :rock))
(visited-p move rx ry path player)))
((:L :R :U :D) (visited-p move rx ry path player))
(:S t))))
(defun robot-ai (world objects path metadata tries)
;; (declare (optimize (debug 3)))
(let ((current-target (choose-target world objects path metadata))
(player (apply #'make-player (funcall objects :route-start)))
(lambdas-eaten (length (funcall objects :collected-lambda))))
(unless current-target
(return-from robot-ai nil))
(iter (for available-move in '(:L :R :D :U :W :S))
(for turn-proc = (make-game-turn available-move))
(multiple-value-bind (turn-world turn-objects turn-path turn-metadata)
(funcall turn-proc world objects path metadata)
(when (and turn-world turn-objects turn-path turn-metadata
(not (useless-action-p available-move world objects path metadata turn-world turn-objects turn-path turn-metadata player)))
(let ((turn-score (score turn-world turn-objects turn-path turn-metadata))
(move available-move))
(when turn-score
(collect (list move turn-score turn-world turn-objects turn-path turn-metadata) into turns)))))
(finally
(let ((ordered-turns (sort turns (make-positions-comparator current-target))))
(iter (for counter from 1)
(for (move turn-score turn-world turn-objects turn-path turn-metadata) in ordered-turns)
(for turn-lambda-eaten = (length (funcall turn-objects :collected-lambda)))
(for next-tries = (if (> turn-lambda-eaten lambdas-eaten) 0 (+ tries counter)))
(game-loop turn-score turn-world turn-objects turn-path turn-metadata next-tries)))))))
(defun update-hiscore (current-score objects path metadata)
(flet ((maybe-abort-path (path)
(if (or (funcall objects :collected-lifts)
(eq (car (funcall path)) :A))
path
(lambda () (cons :A (funcall path))))))
(let* ((best (assoc :best metadata))
(best-path (or (third best) (lambda () nil)))
(best-score (or (second best) 0))
(current-best-path (maybe-abort-path best-path))
(current-best-score best-score))
(when (> current-score best-score)
(setf (second best) current-score
(third best) (maybe-abort-path path))
(when *force-dump-results-p*
(format t ";; New best score: ~a as ~a" current-score (dump-path nil (maybe-abort-path path)))))
(when *force-shutdown-p*
(setf (second best) current-best-score
(third best) current-best-path))))
current-score)
(defun max-ineffective-moves (metadata)
(with-meta-bind (metadata width height)
(truncate (* width height) 4)))
;; (truncate (sqrt (+ (* width width) (* height height))))))
(defun game-loop (current-score world objects path metadata tries)
;; (declare (optimize (debug 3)))
;; (dump-world world objects path metadata)
;; (format t "Try: ~a/~a; target: ~a; score: ~a; underwater: ~a; path: ~a"
;; tries
;; (max-ineffective-moves metadata)
;; (choose-target world objects path metadata)
;; (score world objects path metadata)
;; (funcall objects :underwater)
;; (dump-path nil path))
;; ;;(sleep 0.1)
;; (break)
(update-hiscore current-score objects path metadata)
;; check for extremal or winning condition
(when (or *force-shutdown-p*
(funcall objects :collected-lifts)
(>= tries (max-ineffective-moves metadata)))
;; (>= tries *max-ineffective-tries*))
;; (break)
(return-from game-loop))
;; run robot ai and perform the game turn
(robot-ai world objects path metadata tries))
(defun solve-world (world objects path metadata)
(game-loop 0
world
(lambda (type)
(if (eq type :route-start)
(list world objects path metadata)
(funcall objects type)))
path
metadata
0)
(let ((best-solve (third (assoc :best metadata))))
(dump-path t best-solve)))
;; Debugging stuff
(defun dump-world (world objects path metadata)
(declare (ignorable world objects path metadata))
(with-meta-bind (metadata width height water flooding)
;; (format t ";; growth: ~a~%" (funcall objects :growth))
;; (format t ";; path: ~a~%" (funcall path))
(iter
(with water-level = (+ (if water water 0) (if (and flooding (/= flooding 0)) (floor (path-length path) flooding) 0)))
(for y from height downto 1)
(format t "~a" (if (<= y water-level) "W" " "))
(iter (for x from 1 to width)
(format t "~a" (case (funcall world x y)
(:lambda #\\)
(:robot #\R)
(:rock #\*)
(:wall #\#)
(:earth #\.)
(:open-lambda-lift #\O)
(:closed-lambda-lift #\L)
(:portal-a #\A)
(:portal-b #\B)
(:portal-c #\C)
(:portal-d #\D)
(:portal-e #\E)
(:portal-f #\F)
(:portal-g #\G)
(:portal-h #\H)
(:portal-i #\I)
(:target-1 #\1)
(:target-2 #\2)
(:target-3 #\3)
(:target-4 #\4)
(:target-5 #\5)
(:target-6 #\6)
(:target-7 #\7)
(:target-8 #\8)
(:target-9 #\9)
(:beard #\W)
(:razor #\!)
(:horock #\@)
(t #\Space))))
(format t "~%")))
(values world objects path metadata))
(defun dump-injury (world objects path metadata)
(format t ";; robot injury: ~a~%" (funcall objects :injury))
(values world objects path metadata))
(defun dump-robot (world objects path metadata)
(format t ";; robot: ~{~a ~}, injury: ~a, underwater: ~a, score: ~a, razors: ~a~%"
(funcall objects :robot) (funcall objects :injury) (funcall objects :underwater)
(score world objects path metadata) (funcall objects :razors))
(values world objects path metadata))
(defun dump-rocks (world objects path metadata)
(format t ";; rocks: ~{~a~^, ~}~%"
(sort (copy-list (funcall objects :rock) )
#'<
:key (lambda (coord)
(with-coords (x y) coord
(with-meta-bind (metadata height)
(+ (* y height) x))))))
(values world objects path metadata))
(defun break-script (world objects path metadata)
(declare (optimize (speed 0) (safety 3) (debug 3)))
(break)
(values world objects path metadata))
(defun debug-script (file path)
(with-open-file (s file)
(funcall (multiple-value-call #'make-player (make-mine s))
(lambda ()
(reverse (iter (for reaction in-sequence path)
(collect (form-keyword reaction)))))
(lambda (world objects path metadata)
(dump-robot world objects path metadata)
(dump-world world objects path metadata)
(break)))))