1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/rlm/light_bot.clj	Tue Oct 18 00:57:08 2011 -0700
     1.3 @@ -0,0 +1,175 @@
     1.4 +(ns rlm.light-bot
     1.5 +  (:refer-clojure :only [])
     1.6 +  (:require rlm.ns-rlm mobius.base))
     1.7 +(rlm.ns-rlm/ns-clone mobius.base)
     1.8 +;(use 'clojure.contrib.combinatorics)
     1.9 +(use 'sunil.curry)
    1.10 +
    1.11 +
    1.12 +{:loc '[x y]
    1.13 + :rot '[c]}
    1.14 +
    1.15 +(defrecord tile [height lit?])
    1.16 +
    1.17 +
    1.18 +
    1.19 +	      
    1.20 +
    1.21 +;;; Robot Actions
    1.22 +(def cycle-right 
    1.23 +     {:N :E
    1.24 +      :E :S
    1.25 +      :S :W
    1.26 +      :W :N})
    1.27 +(def  cycle-left 
    1.28 +      {:N :W
    1.29 +       :W :S
    1.30 +       :S :E
    1.31 +       :E :N})
    1.32 +
    1.33 +(defn turn-left [game]
    1.34 +  (update-in game [:pos :rot] cycle-left))
    1.35 +
    1.36 +(defn turn-right [game]
    1.37 +    (update-in game [:pos :rot] cycle-right))
    1.38 +	
    1.39 +(def light* {nil nil
    1.40 +	     true false
    1.41 +	     false true})
    1.42 +  
    1.43 +(defn light [{:keys [map pos] :as game}]
    1.44 +  (update-in game [:map (:loc pos) :lit?] light*))
    1.45 +
    1.46 +(def move
    1.47 +  {:N [0,1]
    1.48 +   :E [1,0]
    1.49 +   :S [0,-1]
    1.50 +   :W [-1,0]})
    1.51 +
    1.52 +(defn-decorated
    1.53 +  advance
    1.54 +  [(curry 2)]
    1.55 +  [action {:keys [pos] :as game}]
    1.56 +  (let [proposed (vec (map + (move (:rot pos)) (:loc pos)))]
    1.57 +    (if (get (:map game) proposed false)
    1.58 +      (assoc-in game [:pos :loc] (action proposed game))
    1.59 +      game)))
    1.60 +
    1.61 +(defn jump-gaurd [proposed {:keys [pos] :as game}]
    1.62 +  (if (= (.height ((:map game) proposed)) (inc (.height ((:map game) (:loc pos)))))
    1.63 +    proposed
    1.64 +    (:loc pos)))
    1.65 +(def jump (advance jump-gaurd))
    1.66 +
    1.67 +(defn forward-gaurd [proposed {:keys [map pos] :as game}]
    1.68 +  (if (= (.height ((:map game) proposed)) (.height ((:map game) (:loc pos))))
    1.69 +    proposed
    1.70 +    (:loc pos)))
    1.71 +(def forward (advance forward-gaurd));;heehee :)
    1.72 +
    1.73 +  
    1.74 +(declare commands)
    1.75 +
    1.76 +(defn expand [game moves]
    1.77 +  (reduce (fn [game move] ((commands move) game)) game moves))
    1.78 +
    1.79 +(defn function-1 [{{f1 :f1} :stragety :as game}]
    1.80 +  (expand game f1))
    1.81 +
    1.82 +(defn function-2 [{{f2 :f2} :stragety :as game}]
    1.83 +  (expand game f2))
    1.84 +
    1.85 +
    1.86 +
    1.87 +(defn all-lit? [game]
    1.88 +  (not (some false? (map #(.lit? %) (vals (:map game))))))
    1.89 +
    1.90 +
    1.91 +(defn solves? [game]
    1.92 +  (all-lit? (expand game (:main (:stragety game)))))
    1.93 +
    1.94 +
    1.95 +  
    1.96 +(def commands
    1.97 +     {:jump jump
    1.98 +      :light light
    1.99 +      :turn-left turn-left
   1.100 +      :turn-right turn-right
   1.101 +      :function-1 function-1
   1.102 +      :function-2 function-2
   1.103 +      :forward forward})
   1.104 +
   1.105 +
   1.106 +;;; End game implementation
   1.107 +
   1.108 +
   1.109 +
   1.110 +
   1.111 +;;; Find linear solutions
   1.112 +
   1.113 +(def naturals (iterate inc 1))
   1.114 +
   1.115 +(defvar linear-commands
   1.116 +  (remove #(or (= % :function-2) (= % :function-1)) (keys commands))
   1.117 +  "all the commands ignoring function calls. Branching factor 5.")
   1.118 +
   1.119 +(decorate selections (curry 2))
   1.120 +(defn breadth-first
   1.121 +  "iterate through the search space in breadth-first-order"
   1.122 +  [coll]
   1.123 +  (mapcat (selections coll) naturals))
   1.124 +
   1.125 +(defn solutions
   1.126 +  "find solutions via breadth first search and returns as a lazy seq"
   1.127 +  [{level-map :map init-pos :pos :as level}]
   1.128 +  (filter #(solves? (assoc-in level [:stragety :main] %)) (breadth-first linear-commands)))
   1.129 +
   1.130 +;;(decorate selections [(curry 2) memoize])
   1.131 +
   1.132 +
   1.133 +
   1.134 +
   1.135 +
   1.136 +
   1.137 +
   1.138 +
   1.139 +
   1.140 +
   1.141 +
   1.142 +;;;
   1.143 +
   1.144 +
   1.145 +
   1.146 +
   1.147 +
   1.148 +
   1.149 +
   1.150 +
   1.151 +
   1.152 +
   1.153 +;;;Level One
   1.154 +(defn level-one-gen [[x y]]
   1.155 +  (cond (= x 0) (tile. 2 nil)
   1.156 +	(= x 7) (tile. 2 nil)
   1.157 +	(= [x y] [3 4]) (tile. 0 false)
   1.158 +	true (tile. 0 nil)))
   1.159 +
   1.160 +(def level-one-map
   1.161 +     (let [domain (selections (range 8) 2)]
   1.162 +       (zipmap (map vec domain) (map level-one-gen domain))))
   1.163 +
   1.164 +(def level-one-solution
   1.165 +     {:main [:forward :forward :light]
   1.166 +      :f1 []
   1.167 +      :f2 []})
   1.168 +
   1.169 +(def level-one-init-pos {:loc [3 2] :rot :N})
   1.170 +(def game-1
   1.171 +     {:map level-one-map
   1.172 +      :stragety level-one-solution
   1.173 +      :pos level-one-init-pos})
   1.174 +
   1.175 +(def level-1 {:map level-one-map
   1.176 +	      :pos level-one-init-pos})
   1.177 +
   1.178 +