rlm@0: (ns rlm.light-bot
rlm@0:   (:refer-clojure :only [])
rlm@0:   (:require rlm.ns-rlm mobius.base))
rlm@0: (rlm.ns-rlm/ns-clone mobius.base)
rlm@0: ;(use 'clojure.contrib.combinatorics)
rlm@0: (use 'sunil.curry)
rlm@0: 
rlm@0: 
rlm@0: {:loc '[x y]
rlm@0:  :rot '[c]}
rlm@0: 
rlm@0: (defrecord tile [height lit?])
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 	      
rlm@0: 
rlm@0: ;;; Robot Actions
rlm@0: (def cycle-right 
rlm@0:      {:N :E
rlm@0:       :E :S
rlm@0:       :S :W
rlm@0:       :W :N})
rlm@0: (def  cycle-left 
rlm@0:       {:N :W
rlm@0:        :W :S
rlm@0:        :S :E
rlm@0:        :E :N})
rlm@0: 
rlm@0: (defn turn-left [game]
rlm@0:   (update-in game [:pos :rot] cycle-left))
rlm@0: 
rlm@0: (defn turn-right [game]
rlm@0:     (update-in game [:pos :rot] cycle-right))
rlm@0: 	
rlm@0: (def light* {nil nil
rlm@0: 	     true false
rlm@0: 	     false true})
rlm@0:   
rlm@0: (defn light [{:keys [map pos] :as game}]
rlm@0:   (update-in game [:map (:loc pos) :lit?] light*))
rlm@0: 
rlm@0: (def move
rlm@0:   {:N [0,1]
rlm@0:    :E [1,0]
rlm@0:    :S [0,-1]
rlm@0:    :W [-1,0]})
rlm@0: 
rlm@0: (defn-decorated
rlm@0:   advance
rlm@0:   [(curry 2)]
rlm@0:   [action {:keys [pos] :as game}]
rlm@0:   (let [proposed (vec (map + (move (:rot pos)) (:loc pos)))]
rlm@0:     (if (get (:map game) proposed false)
rlm@0:       (assoc-in game [:pos :loc] (action proposed game))
rlm@0:       game)))
rlm@0: 
rlm@0: (defn jump-gaurd [proposed {:keys [pos] :as game}]
rlm@0:   (if (= (.height ((:map game) proposed)) (inc (.height ((:map game) (:loc pos)))))
rlm@0:     proposed
rlm@0:     (:loc pos)))
rlm@0: (def jump (advance jump-gaurd))
rlm@0: 
rlm@0: (defn forward-gaurd [proposed {:keys [map pos] :as game}]
rlm@0:   (if (= (.height ((:map game) proposed)) (.height ((:map game) (:loc pos))))
rlm@0:     proposed
rlm@0:     (:loc pos)))
rlm@0: (def forward (advance forward-gaurd));;heehee :)
rlm@0: 
rlm@0:   
rlm@0: (declare commands)
rlm@0: 
rlm@0: (defn expand [game moves]
rlm@0:   (reduce (fn [game move] ((commands move) game)) game moves))
rlm@0: 
rlm@0: (defn function-1 [{{f1 :f1} :stragety :as game}]
rlm@0:   (expand game f1))
rlm@0: 
rlm@0: (defn function-2 [{{f2 :f2} :stragety :as game}]
rlm@0:   (expand game f2))
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: (defn all-lit? [game]
rlm@0:   (not (some false? (map #(.lit? %) (vals (:map game))))))
rlm@0: 
rlm@0: 
rlm@0: (defn solves? [game]
rlm@0:   (all-lit? (expand game (:main (:stragety game)))))
rlm@0: 
rlm@0: 
rlm@0:   
rlm@0: (def commands
rlm@0:      {:jump jump
rlm@0:       :light light
rlm@0:       :turn-left turn-left
rlm@0:       :turn-right turn-right
rlm@0:       :function-1 function-1
rlm@0:       :function-2 function-2
rlm@0:       :forward forward})
rlm@0: 
rlm@0: 
rlm@0: ;;; End game implementation
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: ;;; Find linear solutions
rlm@0: 
rlm@0: (def naturals (iterate inc 1))
rlm@0: 
rlm@0: (defvar linear-commands
rlm@0:   (remove #(or (= % :function-2) (= % :function-1)) (keys commands))
rlm@0:   "all the commands ignoring function calls. Branching factor 5.")
rlm@0: 
rlm@0: (decorate selections (curry 2))
rlm@0: (defn breadth-first
rlm@0:   "iterate through the search space in breadth-first-order"
rlm@0:   [coll]
rlm@0:   (mapcat (selections coll) naturals))
rlm@0: 
rlm@0: (defn solutions
rlm@0:   "find solutions via breadth first search and returns as a lazy seq"
rlm@0:   [{level-map :map init-pos :pos :as level}]
rlm@0:   (filter #(solves? (assoc-in level [:stragety :main] %)) (breadth-first linear-commands)))
rlm@0: 
rlm@0: ;;(decorate selections [(curry 2) memoize])
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: ;;;
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: ;;;Level One
rlm@0: (defn level-one-gen [[x y]]
rlm@0:   (cond (= x 0) (tile. 2 nil)
rlm@0: 	(= x 7) (tile. 2 nil)
rlm@0: 	(= [x y] [3 4]) (tile. 0 false)
rlm@0: 	true (tile. 0 nil)))
rlm@0: 
rlm@0: (def level-one-map
rlm@0:      (let [domain (selections (range 8) 2)]
rlm@0:        (zipmap (map vec domain) (map level-one-gen domain))))
rlm@0: 
rlm@0: (def level-one-solution
rlm@0:      {:main [:forward :forward :light]
rlm@0:       :f1 []
rlm@0:       :f2 []})
rlm@0: 
rlm@0: (def level-one-init-pos {:loc [3 2] :rot :N})
rlm@0: (def game-1
rlm@0:      {:map level-one-map
rlm@0:       :stragety level-one-solution
rlm@0:       :pos level-one-init-pos})
rlm@0: 
rlm@0: (def level-1 {:map level-one-map
rlm@0: 	      :pos level-one-init-pos})
rlm@0: 
rlm@0: