Mercurial > rlm
comparison src/rlm/light_bot.clj @ 0:78a630e650d2
initial import
author | Robert McIntyre <rlm@mit.edu> |
---|---|
date | Tue, 18 Oct 2011 00:57:08 -0700 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
-1:000000000000 | 0:78a630e650d2 |
---|---|
1 (ns rlm.light-bot | |
2 (:refer-clojure :only []) | |
3 (:require rlm.ns-rlm mobius.base)) | |
4 (rlm.ns-rlm/ns-clone mobius.base) | |
5 ;(use 'clojure.contrib.combinatorics) | |
6 (use 'sunil.curry) | |
7 | |
8 | |
9 {:loc '[x y] | |
10 :rot '[c]} | |
11 | |
12 (defrecord tile [height lit?]) | |
13 | |
14 | |
15 | |
16 | |
17 | |
18 ;;; Robot Actions | |
19 (def cycle-right | |
20 {:N :E | |
21 :E :S | |
22 :S :W | |
23 :W :N}) | |
24 (def cycle-left | |
25 {:N :W | |
26 :W :S | |
27 :S :E | |
28 :E :N}) | |
29 | |
30 (defn turn-left [game] | |
31 (update-in game [:pos :rot] cycle-left)) | |
32 | |
33 (defn turn-right [game] | |
34 (update-in game [:pos :rot] cycle-right)) | |
35 | |
36 (def light* {nil nil | |
37 true false | |
38 false true}) | |
39 | |
40 (defn light [{:keys [map pos] :as game}] | |
41 (update-in game [:map (:loc pos) :lit?] light*)) | |
42 | |
43 (def move | |
44 {:N [0,1] | |
45 :E [1,0] | |
46 :S [0,-1] | |
47 :W [-1,0]}) | |
48 | |
49 (defn-decorated | |
50 advance | |
51 [(curry 2)] | |
52 [action {:keys [pos] :as game}] | |
53 (let [proposed (vec (map + (move (:rot pos)) (:loc pos)))] | |
54 (if (get (:map game) proposed false) | |
55 (assoc-in game [:pos :loc] (action proposed game)) | |
56 game))) | |
57 | |
58 (defn jump-gaurd [proposed {:keys [pos] :as game}] | |
59 (if (= (.height ((:map game) proposed)) (inc (.height ((:map game) (:loc pos))))) | |
60 proposed | |
61 (:loc pos))) | |
62 (def jump (advance jump-gaurd)) | |
63 | |
64 (defn forward-gaurd [proposed {:keys [map pos] :as game}] | |
65 (if (= (.height ((:map game) proposed)) (.height ((:map game) (:loc pos)))) | |
66 proposed | |
67 (:loc pos))) | |
68 (def forward (advance forward-gaurd));;heehee :) | |
69 | |
70 | |
71 (declare commands) | |
72 | |
73 (defn expand [game moves] | |
74 (reduce (fn [game move] ((commands move) game)) game moves)) | |
75 | |
76 (defn function-1 [{{f1 :f1} :stragety :as game}] | |
77 (expand game f1)) | |
78 | |
79 (defn function-2 [{{f2 :f2} :stragety :as game}] | |
80 (expand game f2)) | |
81 | |
82 | |
83 | |
84 (defn all-lit? [game] | |
85 (not (some false? (map #(.lit? %) (vals (:map game)))))) | |
86 | |
87 | |
88 (defn solves? [game] | |
89 (all-lit? (expand game (:main (:stragety game))))) | |
90 | |
91 | |
92 | |
93 (def commands | |
94 {:jump jump | |
95 :light light | |
96 :turn-left turn-left | |
97 :turn-right turn-right | |
98 :function-1 function-1 | |
99 :function-2 function-2 | |
100 :forward forward}) | |
101 | |
102 | |
103 ;;; End game implementation | |
104 | |
105 | |
106 | |
107 | |
108 ;;; Find linear solutions | |
109 | |
110 (def naturals (iterate inc 1)) | |
111 | |
112 (defvar linear-commands | |
113 (remove #(or (= % :function-2) (= % :function-1)) (keys commands)) | |
114 "all the commands ignoring function calls. Branching factor 5.") | |
115 | |
116 (decorate selections (curry 2)) | |
117 (defn breadth-first | |
118 "iterate through the search space in breadth-first-order" | |
119 [coll] | |
120 (mapcat (selections coll) naturals)) | |
121 | |
122 (defn solutions | |
123 "find solutions via breadth first search and returns as a lazy seq" | |
124 [{level-map :map init-pos :pos :as level}] | |
125 (filter #(solves? (assoc-in level [:stragety :main] %)) (breadth-first linear-commands))) | |
126 | |
127 ;;(decorate selections [(curry 2) memoize]) | |
128 | |
129 | |
130 | |
131 | |
132 | |
133 | |
134 | |
135 | |
136 | |
137 | |
138 | |
139 ;;; | |
140 | |
141 | |
142 | |
143 | |
144 | |
145 | |
146 | |
147 | |
148 | |
149 | |
150 ;;;Level One | |
151 (defn level-one-gen [[x y]] | |
152 (cond (= x 0) (tile. 2 nil) | |
153 (= x 7) (tile. 2 nil) | |
154 (= [x y] [3 4]) (tile. 0 false) | |
155 true (tile. 0 nil))) | |
156 | |
157 (def level-one-map | |
158 (let [domain (selections (range 8) 2)] | |
159 (zipmap (map vec domain) (map level-one-gen domain)))) | |
160 | |
161 (def level-one-solution | |
162 {:main [:forward :forward :light] | |
163 :f1 [] | |
164 :f2 []}) | |
165 | |
166 (def level-one-init-pos {:loc [3 2] :rot :N}) | |
167 (def game-1 | |
168 {:map level-one-map | |
169 :stragety level-one-solution | |
170 :pos level-one-init-pos}) | |
171 | |
172 (def level-1 {:map level-one-map | |
173 :pos level-one-init-pos}) | |
174 | |
175 |