-
Notifications
You must be signed in to change notification settings - Fork 0
/
strategy.lisp
172 lines (151 loc) · 8.08 KB
/
strategy.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
(in-package :lambda-lifter)
(defun object-sq-dist (rx ry ox oy)
(let ((x-diff (- rx ox))
(y-diff (- ry oy)))
(+ (* x-diff x-diff) (* y-diff y-diff))))
(defun will-free-a-rock (ox oy world objects path metadata)
(let ((object-type (funcall world ox oy))
(game-turn (make-game-turn :W)))
(with-robot-coords (rx ry) objects
(multiple-value-bind (world-orig objects-orig path-orig metadata-orig)
(funcall game-turn world objects path metadata)
(declare (ignore world-orig path-orig metadata-orig))
(multiple-value-bind (world-free objects-free path-free metadata-free)
(funcall (make-game-turn :W)
(lambda (x y)
(cond ((and (= x ox) (= y oy)) nil)
((and (= x rx) (= y ry)) nil)
(t (funcall world x y))))
(lambda (type)
(cond ((eq type object-type) (remove (complex ox oy) (funcall objects type)))
(t (funcall objects type))))
path
metadata)
(declare (ignore world-free path-free metadata-free))
(not (equal (funcall objects-orig :rock)
(funcall objects-free :rock))))))))
(defun make-targets-importancy-comparator (world objects path metadata)
(with-robot-coords (rx ry) objects
(let ((portal-coords (first (append (funcall objects :closed-lambda-lift)
(funcall objects :open-lambda-lift))))
(has-flooding-p (map-has-flooding-p world objects metadata)))
(with-coords (px py) portal-coords
(lambda (target-a target-b)
(with-coords (tax tay) (car target-a)
(with-coords (tbx tby) (car target-b)
(let ((will-free-rock-a (will-free-a-rock tax tay world objects path metadata))
(will-free-rock-b (will-free-a-rock tbx tby world objects path metadata))
(robot-dist-a (object-sq-dist rx ry tax tay))
(robot-dist-b (object-sq-dist rx ry tbx tby))
(portal-dist-a (object-sq-dist px py tax tay))
(portal-dist-b (object-sq-dist px py tbx tby))
(direct-access-a (cdr target-a))
(direct-access-b (cdr target-b)))
(cond ((and direct-access-a (not direct-access-b)) t)
((and direct-access-b (not direct-access-a)) nil)
((and has-flooding-p (< tay tby)) t)
((and has-flooding-p (> tay tby)) nil)
((and will-free-rock-b (not will-free-rock-a)) t)
((and will-free-rock-a (not will-free-rock-b)) nil)
((and has-flooding-p (> portal-dist-a portal-dist-b)) t)
((and has-flooding-p (> portal-dist-b portal-dist-a)) nil)
(t (< robot-dist-a robot-dist-b)))))))))))
(defun find-most-important-object (world objects path metadata)
(with-robot-coords (rx ry) objects
(iter outer
(for type in '(:lambda :open-lambda-lift :portal-a :portal-b :portal-c :portal-d :portal-e :portal-f :portal-g :portal-h :portal-i :razor))
(iter (for coords in (funcall objects type))
;; (for direct-access-p = (a*-search/accessible (realpart coords)
;; (imagpart coords)
;; rx
;; ry
;; (lambda (x y)
;; (and (in-range-p metadata x y)
;; (member (funcall world x y) '(:earth nil))))))
(in outer (collect coords into targets-facts)))
(finally
(let* ((directs-accesses (a*-search/accessible-group rx
ry
(mapcar (lambda (v) (list (realpart v) (imagpart v))) targets-facts)
(lambda (x y)
(and (in-range-p metadata x y)
(member (funcall world x y) '(:earth nil))))))
(targets-facts (mapcar #'cons targets-facts directs-accesses)))
(when targets-facts
(return-from find-most-important-object
(caar (sort targets-facts (make-targets-importancy-comparator world objects path metadata))))))))))
(defun choose-target (world objects path metadata)
(let ((nearest-object (find-most-important-object world objects path metadata)))
(when nearest-object
(return-from choose-target nearest-object))))
(defun make-estimator (target move score world objects path metadata)
(with-coords (target-x target-y) target
(lambda (proc) (funcall proc target-x target-y move score world objects path metadata))))
;; world position estimating
(defmacro deffact (name &body body)
`(defun ,(form-symbol 'fact- name) (estimator)
(funcall estimator
(lambda (target-x target-y move score world objects path metadata)
(declare (ignorable target-x target-y move score world objects path metadata))
,@body))))
(deffact sq-dist
(with-robot-coords (rx ry) objects
(let ((x-diff (- target-x rx))
(y-diff (- target-y ry)))
(+ (* x-diff x-diff) (* y-diff y-diff)))))
(deffact lambdas-eaten
(length (funcall objects :collected-lambda)))
(deffact target-reached
(with-robot-coords (rx ry) objects
(and (= rx target-x) (= ry target-y))))
(deffact moving-action
(when (member move '(:L :R :U :D)) t))
(deffact score score)
(deffact not-sinking-yet
(when (map-has-flooding-p world objects metadata)
(with-meta-bind (metadata water flooding waterproof)
(let ((underwater (or (funcall objects :underwater) 0))
(level (water-level water flooding path)))
(and (under-water-p objects level)
(< underwater (truncate waterproof 2)))))))
(defmacro defmaybe (name fact check-type)
`(defun ,(form-symbol 'maybe- name) (estimator-a estimator-b k)
(let ((fact-a (,fact estimator-a))
(fact-b (,fact estimator-b)))
(cond ,@(ecase check-type
(:less
`(((< fact-a fact-b) t)
((> fact-a fact-b) nil)
(t (funcall k))))
(:more
`(((> fact-a fact-b) t)
((< fact-a fact-b) nil)
(t (funcall k))))
(:predicate
`(((and fact-a (not fact-b)) t)
((and fact-b (not fact-a)) nil)
(t (funcall k)))))))))
(defmaybe target-nearer fact-sq-dist :less)
(defmaybe target-reached fact-target-reached :predicate)
(defmaybe less-lambdas-eaten fact-lambdas-eaten :less)
(defmaybe moving-action fact-moving-action :predicate)
(defmaybe score-better fact-score :more)
(defmaybe not-sinking-yet fact-not-sinking-yet :predicate)
(defmacro check-facts ((target position-a position-b) &rest clauses)
(with-gensyms (ea eb)
(labels ((builder (maybes)
(if maybes
`(,(car maybes) ,ea ,eb (lambda () ,(builder (cdr maybes))))
'nil)))
`(let ((,ea (apply #'make-estimator ,target ,position-a))
(,eb (apply #'make-estimator ,target ,position-b)))
,(builder clauses)))))
(defun make-positions-comparator (target)
(lambda (position-a position-b)
(check-facts (target position-a position-b)
maybe-target-reached
maybe-not-sinking-yet
maybe-less-lambdas-eaten
maybe-moving-action
maybe-target-nearer
maybe-score-better)))