Mercurial > rlm

annotate src/rlm/light_bot.clj @ 0:78a630e650d2

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