(ns exp.sahucs-nc
  (:require [edu.berkeley.ai.util :as util] [edu.berkeley.ai.util.queues :as queues]
            [exp [env :as env] [hierarchy :as hierarchy]])
  (:import [java.util HashMap IdentityHashMap])
  )

;; This version is complete, optimal, and hopefully more efficient in the face of cycles.
;; (with some overhead).

;; Basic idea: all cycle-avoidance info should be reflected in what goes up the stack.
;; Nothig should be recorded in nodes, other than leaving well enough alone.
 ;; I.e., need to pass up failure set, temporarily treat children like they have modified
 ;; (i.e., artificially low) reward threshold in making decisions and computing upward values
 ;; but without actually changing anything.
 ;; Must also pass up real cutoff

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;   Helpers       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Unchanged from sahucs.clj

(defn make-queue [initial-elements]
  (let [q (queues/make-graph-search-pq)]
    (queues/g-pq-add! q :dummy Double/POSITIVE_INFINITY)
    (queues/pq-add-all! q initial-elements)
    q))

(defn assoc-safe [m pred k v]
  (if (contains? m k)
    (do (assert (pred (get m k) v)) m)
    (assoc m k v)))

(defn merge-safe [pred & maps]
  (apply merge-with (fn [x y] (assert (pred x y)) x) maps))

(defn extract-effect [state context opt]
  (vary-meta (env/extract-effects state context) assoc :opt opt))

(defn stitch-effect-map [effect-map state reward-to-state]
  (util/map-map1
   (fn [[effects local-reward]]
     [(vary-meta (env/apply-effects state effects) assoc
                 :opt (concat (:opt (meta state)) (:opt (meta effects)))
                 :cycle-depth (:cycle-depth (meta effects)))
      (+ reward-to-state local-reward)])
   effect-map))

(defn cutoff [queue]
  (- (nth (queues/pq-peek-min queue) 1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Data Structures ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A PartialResult stores a map from states to rewards, where a state is present
;; iff it has reward > cutoff.

;; Here, it also stores the min depth (0+) of any node participating in a cycle,
;; (or nil, if none), and in this case cutoff may be artificially low.
;; Also returns a separate bad-result-map for results that cannot be cached.

(deftype PartialResult [result-map cutoff min-cycle-depth])

(deftype SANode [context action result-map-atom queue])

;; Represents an action sequence from a state, with sanode representing the first action
; in remaining-actions. (or nil, if remaining-actions is empty.)
(deftype SANodeEntry [state sanode reward-to-state remaining-actions min-cycle-depth hash-code] :as this
  Object
  (equals [y] (or (identical? this y)
                  (and (= state (:state y)) (= remaining-actions (:remaining-actions y)))))
  (hashCode [] hash-code))

(defn make-sanode-entry [state sanode reward-to-state remaining-actions min-cycle-depth]
  (SANodeEntry state sanode reward-to-state remaining-actions min-cycle-depth
               (unchecked-add (int (hash state))
                              (unchecked-multiply (int 13) (int (hash remaining-actions))))))

;(defn change-depth [entry new-cycle-depth]
;  (SANodeEntry (:state entry) (:sanode entry) (:reward-to-state entry) (:remaining-actions entry)
;               new-cycle-depth (:hash-code entry)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Core Algorithm  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Only changes from sahucs.clj are in expand-sa-node.

(def *infinite-depth* 1000000000000)

(declare get-sa-node)
(defn get-sanode-entry [cache state reward-to-state actions min-cycle-depth]
  (make-sanode-entry state
   (when (seq actions) (get-sa-node cache state (first actions)))
   reward-to-state actions min-cycle-depth))

(defn get-sa-node [#^HashMap cache s a]
  "Create a new sa-node, or returned the cached copy if it exists."
  (let [context (env/precondition-context a s)]
    (util/cache-with cache [(env/action-name a) (env/extract-context s context)]
      (let [s     (env/get-logger s)
            prim? (env/primitive? a)
            [ss r] (when-let [x (and prim? (env/applicable? a s) (env/successor a s))] x)] ;pun
        (SANode context a
          (atom (if ss {(extract-effect ss context [a]) r} {}))
          (make-queue (for [ref (when-not prim? (hierarchy/immediate-refinements a s))]
                        [(get-sanode-entry cache s 0.0 ref *infinite-depth*) 0.0])))))))

;; Three things need to be dealt with -- bad states, bad states, entries based on bad states, bad roots.

;; Simple union priority queue is not enough, since we may get duplicate states.
;; Not the end of the world, but we would like to solve properly.
; Shadowed priority queue might be right ??
; Issue: what if bad state is better than good one ?
;;  Yikes, this could create all sorts of problems, ala inconsistent heuristic.
 ;  Note you can only get bad states back from a bad child.
 ;  Thus, in this case even the "good" state will be returned as bad.
 ; Two cases: good state added to queue in previous iteration -->

;; Also, in domain with reversible actions, everything will be bad regardless (?)

 ;  Also, what happens when we revisit a node -- we redo all local work, recreate bad states, re-return them?

;; Also, think about simple dijkstra version, and what it loses (e.g., nothing for single-action, right-recursive,
 ;; top-level search.)

;; Also, can use retroactive tie-breaking to maximize the good. (cost threshold).
;; This solves result-graphiness problem.
 ;; Still have entry-queue-issue.
   ;; Here, a better bad should temporarily hide an identical good, but good must remain next time.
   ;; OTOH, a worse bad (than identical good/bad) should just be dropped.
  ;; (the order they are found should not matter)

;; IF we assume strictly positive-cost actions: then, good/bad state divide is just a cost threshold ?
   ; No, it's an increasing mapping from reward to stack depth.
    ; (plus, individual state's stack depth must be taken into account.)

;; General rule: if any part of a computational result from a clean entry is dirty, entry must be saved.

;; State depths are recorded in :cycle-depth in metadata  - mandatory in return values.

;; TODO: watch out for zero reward ?

;; TODO::: FIX queue bs.

; three classes of states - clean, just dirty, already dirty
(defn classify-result-type [reward cycle-depth cutoff-depth-map]
  (let [[_ reward-cycle-depth] (first (subseq cutoff-depth-map > reward))
;        _ (println reward-cycle-depth cycle-depth)
        final-cycle-depth (min cycle-depth reward-cycle-depth)]
    (cond (= final-cycle-depth *infinite-depth*) :clean
          (= cycle-depth       *infinite-depth*) :dirtied
          :else                                  :still-dirty)))

(defn final-cycle-depth [reward cycle-depth cutoff-depth-map]
  (let [[_ reward-cycle-depth] (first (subseq cutoff-depth-map > reward))]
    (min cycle-depth reward-cycle-depth)))

(defn extend-cutoff-depth-map [cdm cutoff depth]
;  (println cdm cutoff depth)
  (let [[g-cutoff g-depth] (first (subseq cdm >= cutoff))]
    (if (< depth g-depth) (assoc cdm cutoff depth) cdm)))

;; May return states better than next-best, but these will be held at the parent.
(defn expand-sa-node [node #^HashMap cache next-best state reward-to-state last-cutoff
                      #^IdentityHashMap stack-node-depths depth]
  (assert (not (.containsKey stack-node-depths node)))
;  (println "Entering " (env/action-name (:action node)))
  (.put stack-node-depths node depth)
  (let [good-queue (:queue node)
        bad-queue  (queues/make-graph-stack-pq)
        both-queue (queues/make-union-pq good-queue bad-queue)
        catchup    (if (= last-cutoff (cutoff good-queue)) {}
                     (util/filter-map #(<= (val %) last-cutoff) @(:result-map-atom node)))]
    (loop [new-results      {}
           cutoff-depth-map (sorted-map Double/POSITIVE_INFINITY *infinite-depth*)
           good-roots       nil]   ; jumping off points for unsavable computations.
      (if (< (cutoff both-queue) next-best)  ; Done
        (let [cut (cutoff both-queue) ; Cutoff before fixing cycling children.
              {:keys [clean dirtied still-dirty]}
                (util/group-by (fn [[s r]] (classify-result-type r (:min-cycle-depth (:entry (meta s))) cutoff-depth-map))
                          new-results)]
          (swap! (:result-map-atom node) (partial merge-safe >=) (into {} clean))
          (doseq [entry (concat good-roots (map #(:entry (meta (key %))) dirtied))]
            (queues/g-pq-replace! good-queue entry
              (- 0 (:reward-to-state entry) (if-let [n  (:sanode entry)] (cutoff (:queue n)) 0))))
          (.remove stack-node-depths node) ;; TODO: catchup!!
          (PartialResult (stitch-effect-map
                           (into {} (map (fn [[s r]] [(vary-meta s assoc :cycle-depth
                                                        (final-cycle-depth r (or (:cycle-depth (:entry (meta s)))
                                                                                *infinite-depth*) cutoff-depth-map))
                                                      r])
                                         (concat new-results catchup)))
                           state reward-to-state)
                         cut (val (first cutoff-depth-map))))
        (let [[entry neg-reward] (queues/g-pq-remove-min-with-cost! (:queue node))
              b-s (:state entry), b-rts (:reward-to-state entry),
              b-ra (:remaining-actions entry), b-sa (:sanode entry), b-cd (:min-cycle-depth entry)
              rec-next-best (- (max next-best (cutoff both-queue)) b-rts)]
          (if (empty? b-ra)
              (recur (assoc-safe new-results >=
                       (vary-meta (extract-effect b-s (:context node) (:opt (meta b-s))) assoc :entry entry) b-rts)
                     cutoff-depth-map good-roots)
            (let [rec (if-let [stack-depth (.get stack-node-depths b-sa)]
                           (PartialResult {} Double/NEGATIVE_INFINITY stack-depth)
                         (expand-sa-node b-sa cache rec-next-best b-s b-rts (- 0 neg-reward b-rts)
                                         stack-node-depths (inc depth)))
                  cd  (min b-cd (:min-cycle-depth rec))
                  result-nodes (for [[ss sr] (:result-map rec)
                                     :let [s-cd (min (:cycle-depth (meta ss)) b-cd)]]
                                 (get-sanode-entry cache ss sr (next b-ra) (if (< s-cd depth) s-cd *infinite-depth*)))
                  [good-nodes bad-nodes] (split-with #(>= (:min-cycle-depth %) depth) result-nodes)
                  {:keys [nbn dbn sbn]}  (util/group-by
                                          (fn [node]
                                            (let [good-pri (queues/g-pq-priority good-queue node)]
                                              (cond (nil? good-pri)                          :nbn
                                                    (< (- good-pri) (:reward-to-state node)) :sbn
                                                    :else                                    :dbn)))
                                          bad-nodes)]
              (doseq [n good-nodes]       (queues/g-pq-add! good-queue n (- (:reward-to-state n))))
              (doseq [n (concat nbn sbn)] (queues/g-pq-add! bad-queue  n (- (:reward-to-state n))))
              (when (> (:cutoff rec) Double/NEGATIVE_INFINITY)
                (queues/g-pq-replace! (if (< cd depth) bad-queue good-queue) entry (- 0 b-rts (:cutoff rec))))
              (recur new-results
                     (extend-cutoff-depth-map cutoff-depth-map (:cutoff rec) cd)
                     (concat (when (and (>= b-cd depth) (< cd depth)) [entry])
                             (doall (for [n sbn] (queues/g-pq-remove! good-queue n)))
                             good-roots)))))))))

;; ALMOST: except suboptimal states may get cached at higher levels too.
;; Such bad states cannot be cached.
;;   You also have to actually use them, and keep track of all successors and mark as bad too.
;;   Same rules apply for them to "become good".

;; Two sets of things happening, with children + states + cutoffs -- easy way to unify?
  ;; e.g., second queue?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;    Top-level    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Only change from sahucs.clj: adding empty identity map, depth params to call.

(defn sahucs-nc [henv]
  (let [e     (hierarchy/env henv)
        cache (HashMap.)
        init  (env/initial-state e)
        root  (get-sa-node cache init (hierarchy/TopLevelAction e [(hierarchy/initial-plan henv)]))]
    (loop [cutoff 0 last-cutoff 0]
      (let [result (expand-sa-node root cache cutoff init 0.0 last-cutoff (IdentityHashMap.) 0)]
        (cond (not (empty? (:result-map result)))
                (let [[k v] (util/first-maximal-element val (:result-map result))]
                  [(:opt (meta k)) v])
              (> (:cutoff result) Double/NEGATIVE_INFINITY)
                (recur (:cutoff result) cutoff))))))

(ns exp.sahucs-nc
  (:require [edu.berkeley.ai.util :as util] [edu.berkeley.ai.util.queues :as queues]
            [exp [env :as env] [hierarchy :as hierarchy]])
  (:import [java.util HashMap IdentityHashMap])
  )

;; This version is complete, optimal, and hopefully more efficient in the face of cycles.
;; (with some overhead).

;; Basic idea: all cycle-avoidance info should be reflected in what goes up the stack.
;; Nothig should be recorded in nodes, other than leaving well enough alone.
 ;; I.e., need to pass up failure set, temporarily treat children like they have modified
 ;; (i.e., artificially low) reward threshold in making decisions and computing upward values
 ;; but without actually changing anything.
 ;; Must also pass up real cutoff

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;   Helpers       ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Unchanged from sahucs.clj

(defn make-queue [initial-elements]
  (let [q (queues/make-graph-search-pq)]
    (queues/g-pq-add! q :dummy Double/POSITIVE_INFINITY)
    (queues/pq-add-all! q initial-elements)
    q))

(defn assoc-safe [m pred k v]
  (if (contains? m k)
    (do (assert (pred (get m k) v)) m)
    (assoc m k v)))

(defn merge-safe [pred & maps]
  (apply merge-with (fn [x y] (assert (pred x y)) x) maps))

(defn extract-effect [state context opt]
  (vary-meta (env/extract-effects state context) assoc :opt opt))

(defn stitch-effect-map [effect-map state reward-to-state]
  (util/map-map1
   (fn [[effects local-reward]]
     [(vary-meta (env/apply-effects state effects) assoc
                 :opt (concat (:opt (meta state)) (:opt (meta effects)))
                 :cycle-depth (:cycle-depth (meta effects)))
      (+ reward-to-state local-reward)])
   effect-map))

(defn cutoff [queue]
  (- (nth (queues/pq-peek-min queue) 1)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Data Structures ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; A PartialResult stores a map from states to rewards, where a state is present
;; iff it has reward > cutoff.

;; Here, it also stores the min depth (0+) of any node participating in a cycle,
;; (or nil, if none), and in this case cutoff may be artificially low.
;; Also returns a separate bad-result-map for results that cannot be cached.

(deftype PartialResult [result-map cutoff min-cycle-depth])

(deftype SANode [context action result-map-atom queue])

;; Represents an action sequence from a state, with sanode representing the first action
; in remaining-actions. (or nil, if remaining-actions is empty.)
(deftype SANodeEntry [state sanode reward-to-state remaining-actions min-cycle-depth hash-code] :as this
  Object
  (equals [y] (or (identical? this y)
                  (and (= state (:state y)) (= remaining-actions (:remaining-actions y)))))
  (hashCode [] hash-code))

(defn make-sanode-entry [state sanode reward-to-state remaining-actions min-cycle-depth]
  (SANodeEntry state sanode reward-to-state remaining-actions min-cycle-depth
               (unchecked-add (int (hash state))
                              (unchecked-multiply (int 13) (int (hash remaining-actions))))))

;(defn change-depth [entry new-cycle-depth]
;  (SANodeEntry (:state entry) (:sanode entry) (:reward-to-state entry) (:remaining-actions entry)
;               new-cycle-depth (:hash-code entry)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Core Algorithm  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Only changes from sahucs.clj are in expand-sa-node.

(def *infinite-depth* 1000000000000)

(declare get-sa-node)
(defn get-sanode-entry [cache state reward-to-state actions min-cycle-depth]
  (make-sanode-entry state
   (when (seq actions) (get-sa-node cache state (first actions)))
   reward-to-state actions min-cycle-depth))

(defn get-sa-node [#^HashMap cache s a]
  "Create a new sa-node, or returned the cached copy if it exists."
  (let [context (env/precondition-context a s)]
    (util/cache-with cache [(env/action-name a) (env/extract-context s context)]
      (let [s     (env/get-logger s)
            prim? (env/primitive? a)
            [ss r] (when-let [x (and prim? (env/applicable? a s) (env/successor a s))] x)] ;pun
        (SANode context a
          (atom (if ss {(extract-effect ss context [a]) r} {}))
          (make-queue (for [ref (when-not prim? (hierarchy/immediate-refinements a s))]
                        [(get-sanode-entry cache s 0.0 ref *infinite-depth*) 0.0])))))))

;; Three things need to be dealt with -- bad states, bad states, entries based on bad states, bad roots.

;; Simple union priority queue is not enough, since we may get duplicate states.
;; Not the end of the world, but we would like to solve properly.
; Shadowed priority queue might be right ??
; Issue: what if bad state is better than good one ?
;;  Yikes, this could create all sorts of problems, ala inconsistent heuristic.
 ;  Note you can only get bad states back from a bad child.
 ;  Thus, in this case even the "good" state will be returned as bad.
 ; Two cases: good state added to queue in previous iteration -->

;; Also, in domain with reversible actions, everything will be bad regardless (?)

 ;  Also, what happens when we revisit a node -- we redo all local work, recreate bad states, re-return them?

;; Also, think about simple dijkstra version, and what it loses (e.g., nothing for single-action, right-recursive,
 ;; top-level search.)

;; Also, can use retroactive tie-breaking to maximize the good. (cost threshold).
;; This solves result-graphiness problem.
 ;; Still have entry-queue-issue.
   ;; Here, a better bad should temporarily hide an identical good, but good must remain next time.
   ;; OTOH, a worse bad (than identical good/bad) should just be dropped.
  ;; (the order they are found should not matter)

;; IF we assume strictly positive-cost actions: then, good/bad state divide is just a cost threshold ?
   ; No, it's an increasing mapping from reward to stack depth.
    ; (plus, individual state's stack depth must be taken into account.)

;; General rule: if any part of a computational result from a clean entry is dirty, entry must be saved.

;; State depths are recorded in :cycle-depth in metadata  - mandatory in return values.

;; TODO: watch out for zero reward ?

;; TODO::: FIX queue bs.

; three classes of states - clean, just dirty, already dirty
(defn classify-result-type [reward cycle-depth cutoff-depth-map]
  (let [[_ reward-cycle-depth] (first (subseq cutoff-depth-map > reward))
;        _ (println reward-cycle-depth cycle-depth)
        final-cycle-depth (min cycle-depth reward-cycle-depth)]
    (cond (= final-cycle-depth *infinite-depth*) :clean
          (= cycle-depth       *infinite-depth*) :dirtied
          :else                                  :still-dirty)))

(defn final-cycle-depth [reward cycle-depth cutoff-depth-map]
  (let [[_ reward-cycle-depth] (first (subseq cutoff-depth-map > reward))]
    (min cycle-depth reward-cycle-depth)))

(defn extend-cutoff-depth-map [cdm cutoff depth node-depth]
;  (println cdm cutoff depth)
  (let [[g-cutoff g-depth] (first (subseq cdm >= cutoff))]
    (if (< depth (min node-depth  g-depth)) (assoc cdm cutoff depth) cdm)))

;; May return states better than next-best, but these will be held at the parent.
(defn expand-sa-node [node #^HashMap cache next-best state reward-to-state last-cutoff
                      #^IdentityHashMap stack-node-depths depth]
  (assert (not (.containsKey stack-node-depths node)))
  (println "Entering " (env/action-name (:action node)) "at depth" depth)
  (.put stack-node-depths node depth)
  (let [good-queue (:queue node)
        bad-queue  (queues/make-graph-stack-pq)
        both-queue (queues/make-union-pq good-queue bad-queue)
        catchup    (if (= last-cutoff (cutoff good-queue)) {}
                     (util/filter-map #(<= (val %) last-cutoff) @(:result-map-atom node)))]
    (loop [new-results      {}
           cutoff-depth-map (sorted-map Double/POSITIVE_INFINITY *infinite-depth*)
           good-roots       nil]   ; jumping off points for unsavable computations.
      (if (< (cutoff both-queue) next-best)  ; Done
        (let [cut (cutoff both-queue) ; Cutoff before fixing cycling children.
              {:keys [clean dirtied still-dirty]}
                (util/group-by (fn [[s r]] (classify-result-type r (:min-cycle-depth (:entry (meta s))) cutoff-depth-map))
                          new-results)]
          (swap! (:result-map-atom node) (partial merge-safe >=) (into {} clean))
          (doseq [entry (concat good-roots (map #(:entry (meta (key %))) dirtied))]
            (queues/g-pq-replace! good-queue entry
              (- 0 (:reward-to-state entry) (if-let [n  (:sanode entry)] (cutoff (:queue n)) 0))))
          (.remove stack-node-depths node) ;; TODO: catchup!!
          (println "Returning from" (env/action-name (:action node)) "With cutoff" cut (cutoff good-queue) "and cdm" cutoff-depth-map "and states" (count new-results) (count catchup) "-" (count clean) (count dirtied) (count still-dirty) "and good roots" (count good-roots) (map :reward-to-state good-roots))
          (PartialResult (stitch-effect-map
                           (into {} (map (fn [[s r]] [(vary-meta s assoc :cycle-depth
                                                        (final-cycle-depth r (or (:cycle-depth (:entry (meta s)))
                                                                                *infinite-depth*) cutoff-depth-map))
                                                      r])
                                         (concat new-results catchup)))
                           state reward-to-state)
                         cut (val (first cutoff-depth-map))))
        (let [[entry neg-reward] (queues/pq-peek-min both-queue)
              b-s (:state entry), b-rts (:reward-to-state entry),
              b-ra (:remaining-actions entry), b-sa (:sanode entry), b-cd (:min-cycle-depth entry)
              rec-next-best (- (max next-best (cutoff both-queue)) b-rts)]
          (if (empty? b-ra)
              (do (queues/pq-remove-min-with-cost! both-queue)
               (recur (assoc-safe new-results >=
                                  (vary-meta (extract-effect b-s (:context node) (:opt (meta b-s))) assoc :entry entry) b-rts)
                      cutoff-depth-map good-roots))
            (let [rec (if-let [stack-depth (.get stack-node-depths b-sa)]
                           (PartialResult {} Double/NEGATIVE_INFINITY stack-depth)
                         (expand-sa-node b-sa cache rec-next-best b-s b-rts (- 0 neg-reward b-rts)
                                         stack-node-depths (inc depth)))
                  cd  (min b-cd (:min-cycle-depth rec))
                  result-nodes (for [[ss sr] (:result-map rec)
                                     :let [s-cd (min (:cycle-depth (meta ss)) b-cd)]]
                                 (get-sanode-entry cache ss sr (next b-ra) (if (< s-cd depth) s-cd *infinite-depth*)))
                  [good-nodes bad-nodes] (split-with #(>= (:min-cycle-depth %) depth) result-nodes)
                  {:keys [nbn dbn sbn]}  (util/group-by
                                          (fn [node]
                                            (let [good-pri (queues/g-pq-priority good-queue node)]
                                              (cond (nil? good-pri)                          :nbn
                                                    (< (- good-pri) (:reward-to-state node)) :sbn
                                                    :else                                    :dbn)))
                                          bad-nodes)]
              (doseq [n good-nodes]       (queues/g-pq-add! good-queue n (- (:reward-to-state n))))
              (doseq [n (concat nbn sbn)] (queues/g-pq-add! bad-queue  n (- (:reward-to-state n))))
              (queues/pq-remove-min-with-cost! both-queue)
              (when (> (:cutoff rec) Double/NEGATIVE_INFINITY)
                (queues/g-pq-replace! (if (< cd depth) bad-queue good-queue) entry (- 0 b-rts (:cutoff rec))))
              (recur new-results
                     (extend-cutoff-depth-map cutoff-depth-map (:cutoff rec) cd depth)
                     (concat (when (and (>= b-cd depth) (< cd depth)) [entry])
                             (doall (for [n sbn] (queues/g-pq-remove! good-queue n)))
                             good-roots)))))))))

;; Need same fix as regular since in cycles we may still check cutoff.

;; ALMOST: except suboptimal states may get cached at higher levels too.
;; Such bad states cannot be cached.
;;   You also have to actually use them, and keep track of all successors and mark as bad too.
;;   Same rules apply for them to "become good".

;; Two sets of things happening, with children + states + cutoffs -- easy way to unify?
  ;; e.g., second queue?

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;    Top-level    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Only change from sahucs.clj: adding empty identity map, depth params to call.

(defn sahucs-nc [henv]
  (let [e     (hierarchy/env henv)
        cache (HashMap.)
        init  (env/initial-state e)
        root  (get-sa-node cache init (hierarchy/TopLevelAction e [(hierarchy/initial-plan henv)]))]
    (loop [cutoff 0 last-cutoff 0]
      (let [result (expand-sa-node root cache cutoff init 0.0 last-cutoff (IdentityHashMap.) 0)]
        (cond (not (empty? (:result-map result)))
                (let [[k v] (util/first-maximal-element val (:result-map result))]
                  [(:opt (meta k)) v])
              (> (:cutoff result) Double/NEGATIVE_INFINITY)
                (recur (:cutoff result) cutoff))))))

; (first (filter #(let [h (simple-taxi-hierarchy (make-random-taxi-env 2 3 2 %)) ] (println %) (not (= (prln  (second (sahtn-dijkstra h))) (second (exp.sahucs-nc/sahucs-nc h))))) (map (fn [x y] x) (range 100) (iterate inc 0))))
; 74 causes infinite loop. ?

; (first (filter #(let [h (simple-taxi-hierarchy (make-random-taxi-env 3 2 2 %)) ] (println %) (not (= (prln  (second (sahtn-dijkstra h))) (second (exp.sahucs-nc/sahucs-nc h))))) (map (fn [x y] x) (range 100) (iterate inc 0))))
; 65 fails

;(first (filter #(let [h (simple-taxi-hierarchy (make-random-taxi-env 1 3 2 %)) ] (not (= (prln  (second (sahtn-dijkstra h))) ;(second (exp.sahucs-nc/sahucs-nc h))))) (map (fn [x y] x) (range 100) (iterate inc 0))))
; 81 fails

; a culprit
; (exp.sahucs-nc/sahucs-nc (simple-taxi-hierarchy (make-random-taxi-env 1 3 2 81)))

Fix a bug in cycle algorithm, still buggy.


(set-env!
  :source-paths #{"src"}
  :resource-paths #{"resources"}
  :dependencies '[[org.clojure/clojure "1.8.0"]
                  [alda "1.0.0-rc34"]])

(task-options!
  pom {:project '{{app-name}}
       :version "0.1.0-SNAPSHOT"
       :description "FIXME: write description"}
  aot {:namespace #{'{{namespace}}}}
  jar {:main '{{namespace}}})

(require '{{namespace}})

(deftask run []
  (comp
    (with-pre-wrap fileset
      ({{namespace}}/-main)
      fileset)))

(deftask build []
  (comp (aot) (pom) (uber) (jar) (target)))

(set-env!
  :source-paths #{"src"}
  :resource-paths #{"resources"}
  :dependencies '[[org.clojure/clojure "1.8.0"]
                  [alda "1.0.0-rc34"]])

(task-options!
  pom {:project '{{app-name}}
       :version "0.1.0-SNAPSHOT"
       :description "FIXME: write description"}
  aot {:namespace #{'{{namespace}}}}
  jar {:main '{{namespace}}})

(require '{{namespace}})

(deftask run []
  (comp
    (watch)
    (with-pre-wrap fileset
      ({{namespace}}/-main)
      fileset)))

(deftask build []
  (comp (aot) (pom) (uber) (jar) (target)))

Watch when running audio project

Watch when running audio project


add author links

add author links


(ns pc.views.team
  (:require [cemerick.url :as url]
            [hiccup.core :as h]
            [pc.http.urls :as urls]
            [pc.profile :as profile]
            [pc.views.content :as content]
            [ring.middleware.anti-forgery :as csrf]
            [ring.util.anti-forgery :refer (anti-forgery-field)]))

(defn request-domain [req]
  (h/html
   (content/layout
    {}
    [:div.page-team
     nav-head
     [:div.team-login
      [:div.team-login-content
       [:h1 "Create your team!"]
       [:h4 (str (h/h (:subdomain req)) "." (profile/hostname))]
       [:div.calls-to-action
        [:a {:href (str (url/map->URL
                         {:host (profile/hostname)
                          :protocol (if (profile/force-ssl?)
                                      "https"
                                      (name (:scheme req)))
                          :port (if (profile/force-ssl?)
                                  443
                                  (:server-port req))
                          :path "/early-access/team"
                          :query {:subdomain (h/h (:subdomain req))}}))}
         "Start a trial to create this team"]]]]
     nav-foot])))

(defn request-access [req]
  (h/html
   (content/layout
    {}
    [:div.page-team
     nav-head
     [:div.team-login
      [:div.team-login-content
       [:h1 "Join your team!"]
       [:h4 (str (h/h (:subdomain req)) "." (profile/hostname))]
       [:div.calls-to-action
        [:form {:action "/request-team-permission" :method "post"}
         (anti-forgery-field)
         [:button {:type "submit" :value ""}
          "Request permission to join this team"]]]]]
     nav-foot])))

(defn requested-access [req]
  (h/html
   (content/layout
    {}
    [:div.page-team
     nav-head
     [:div.team-login
      [:div.team-login-content
       [:h1 "Join your team!"]
       [:h4 (str (h/h (:subdomain req)) "." (profile/hostname))]
       [:p "We got your request. We'll send you an email when the owner grants your request."]
       [:p "You can also give the owner "
        [:a {:href (str (urls/doc (:db/id (:team/intro-doc (:team req)))
                                  :subdomain (h/h (:subdomain req))
                                  :query {:overlay "team-settings"}))}
         "this link"]
        " to review your request."]
       [:p ]]]
     nav-foot])))

(def logomark
  [:i {:class "icon-logomark"}
   [:svg {:class "iconpile" :viewBox "0 0 100 100"}
    [:path {:class "fill-logomark" :d "M43,100H29.5V39H43V100z M94,33.8C90.9,22,83.3,12.2,72.8,6.1C62.2,0,50-1.6,38.2,1.6 C26.5,4.7,16.6,12.3,10.6,22.8C4.5,33.3,2.9,45.6,6,57.4l1.7,6.4l12.7-3.4l-1.7-6.4c-4.6-17.2,5.6-35,22.9-39.6 c8.3-2.2,17.1-1.1,24.6,3.2c7.5,4.3,12.8,11.3,15.1,19.7c4.6,17.2-5.6,35-22.9,39.6L52,78.5l3.4,12.7l6.4-1.7 C86.1,83.1,100.5,58,94,33.8z"}]]])

(def google
  [:i {:class "icon-google"}
   [:svg {:class "iconpile" :viewBox "0 0 100 100"}
    [:path {:class "fill-google" :d "M53.8,0C35.5,0,25.6,11.6,25.6,24.5c0,9.8,7.1,21,21.6,21h3.7c0,0-1,2.4-1,4.8c0,3.5,1.2,5.4,3.9,8.4 c-25,1.5-35.1,11.6-35.1,22.5c0,9.5,9.1,18.9,28.2,18.9c22.6,0,34.4-12.6,34.4-24.9c0-8.7-4.3-13.5-15.3-21.7 c-3.2-2.5-3.9-4.1-3.9-6c0-2.7,1.6-4.5,2.2-5.1c1-1.1,2.8-2.3,3.5-2.9c3.7-3.1,8.9-7.7,8.9-17c0-6.3-2.6-11.8-8.6-16.9h7.3L80.9,0 L53.8,0L53.8,0z M48.8,4.1c3.3,0,6.1,1.2,9,3.6c3.2,2.9,8.4,10.8,8.4,20.5c0,10.5-8.2,13.4-12.6,13.4c-2.2,0-4.8-0.6-6.9-2.1 C41.8,36.4,37,28,37,17.9C37,8.9,42.4,4.1,48.8,4.1z M56,62.7c1.4,0,2.4,0.1,2.4,0.1s3.3,2.4,5.6,4.1c5.4,4.2,8.7,7.5,8.7,13.2 c0,7.9-7.4,14.1-19.3,14.1c-13.1,0-23.1-6.1-23.1-16C30.4,70,37.2,62.9,56,62.7L56,62.7z"}]]])

(def twitter
  [:i {:class "icon-twitter"}
   [:svg {:class "iconpile" :viewBox "0 0 100 100"}
    [:path {:class "fill-twitter" :d "M100,19c-3.7,1.6-7.6,2.7-11.8,3.2c4.2-2.5,7.5-6.6,9-11.4c-4,2.4-8.4,4.1-13,5c-3.7-4-9.1-6.5-15-6.5 c-11.3,0-20.5,9.2-20.5,20.5c0,1.6,0.2,3.2,0.5,4.7c-17.1-0.9-32.2-9-42.3-21.4c-1.8,3-2.8,6.6-2.8,10.3c0,7.1,3.6,13.4,9.1,17.1 c-3.4-0.1-6.5-1-9.3-2.6c0,0.1,0,0.2,0,0.3c0,9.9,7.1,18.2,16.5,20.1c-1.7,0.5-3.5,0.7-5.4,0.7c-1.3,0-2.6-0.1-3.9-0.4 c2.6,8.2,10.2,14.1,19.2,14.2c-7,5.5-15.9,8.8-25.5,8.8c-1.7,0-3.3-0.1-4.9-0.3c9.1,5.8,19.9,9.2,31.4,9.2 c37.7,0,58.4-31.3,58.4-58.4c0-0.9,0-1.8-0.1-2.7C93.8,26.7,97.2,23.1,100,19z"}]]])

(def nav-head
  [:div.nav.nav-head ; keep up to date with outer/nav-head
   [:a.nav-link.nav-logo {:href "https://precursorapp.com/home" :title "Precursor"} "Precursor"]
   [:a.nav-link.nav-app  {:href "https://precursorapp.com/new"  :title "Launch"}    "App"]])

(def nav-foot
  [:div.nav.nav-foot ; keep up to date with outer/nav-head
   [:a.nav-link.nav-logo {:href "https://precursorapp.com" :title "Precursor"} logomark]
   [:a.nav-link.nav-twitter
    {:title "@PrecursorApp"
     :href "https://twitter.com/PrecursorApp"}
    twitter]])

(defn login-interstitial [req]
  (h/html
   (content/layout
    {}
    [:div.page-team
     nav-head
     [:div.team-login
      [:div.team-login-content
       [:h1 "Join your team!"]
       [:h4 (str (h/h (:subdomain req)) "." (profile/hostname))]
       [:div.calls-to-action
        [:a.google-login {:href (str (url/map->URL
                                      {:host (profile/hostname)
                                       :protocol (if (profile/force-ssl?)
                                                   "https"
                                                   (name (:scheme req)))
                                       :port (if (profile/force-ssl?)
                                               443
                                               (:server-port req))
                                       :path "/login"
                                       :query {:redirect-subdomain (:subdomain req)
                                               :redirect-csrf-token csrf/*anti-forgery-token*}}))}
        google
        [:div.google-text "Sign in with Google"]]]]]
     nav-foot])))

fix functions used before being required


;; Copyright (c) Cognitect, Inc.
;; All rights reserved.

(ns exemplar
  (:require [transit.read :as r]
            [transit.write :as w]
            [clojure.java.io :as io]))

;; Generate a set of increasingly complex transit files.
;; Output checked into the transit repo under simple-examples.

(import [java.io File FileOutputStream ByteArrayInputStream ByteArrayOutputStream OutputStreamWriter])

(defn range-centered-on
  ([n] (range-centered-on n 5))
  ([n m] (vec (range (- n m) (+ n m 1)))))

(defn vmap [f s]
  (vec (map f s)))

(defn vector-of-keywords
  [n m]
  "Return a m length vector consisting of cycles of n keywordss"
  (vmap #(keyword (format "key%05d" %)) (take m (cycle (range n)))))

(defn map-of-size [n]
  (let [nums (range 0 n)]
    (apply
      sorted-map
      (interleave (map #(keyword (format "key%04d" %)) nums) nums))))

(defn write-description [file-name description vals]
  (println "##" description)
  (println "* Files:" (str file-name ".edn") (str file-name ".json") (str file-name ".mp"))
  (println "* Value (EDN)")
  (println)
  (doseq [item vals] (println "    " (pr-str item)))
  (println))

(defn write-transit [file-name & vals]
  (doseq [format [{:type :json, :suffix ".json"} {:type :msgpack :suffix ".mp"}]]
    (with-open [os (io/output-stream (str file-name (:suffix format)))]
      (let [jsw (w/writer os (:type format))]
        (doseq [item vals] (w/write jsw item))))))

(defn write-exemplar [file-name description & vals]
  (write-description file-name description vals)
  (with-open [w (io/writer (str file-name ".edn"))]
    (binding [*out* w] (apply pr vals)))
  (apply write-transit file-name vals))

(binding [*out* (io/writer "README.md")]
  (println "# Example transit files.\n\n")
  (println "There are three files for each value: An EDN file and two transit files,")
  (println "one encoded in JSON and one in MessagePack\n\n")
  (println "Note: The example transit files in this directory are *generated*.")
  (println "See https://github.com/cognitect/transit-clj/blob/master/test/exemplar.clj\n\n")

  (write-exemplar "nil" "The nil/null/ain't there value" nil)
  (write-exemplar "true" "True" true)
  (write-exemplar "false" "False" false)
  (write-exemplar "zero" "Zero (integer)" 0)
  (write-exemplar "one" "One (integer)" 1)
  (write-exemplar "one_string" "A single string" "hello")
  (write-exemplar "one_keyword" "A single keyword" :hello)
  (write-exemplar "one_symbol" "A single symbol" 'hello)
  (write-exemplar "one_date" "A single date" (java.util.Date. 946728000000))

  (def vector-simple  [1 2 3])
  (def vector-mixed  [0 1 2.0 true false "five" :six 'seven "~eight" nil])
  (def vector-nested [vector-simple vector-mixed])

  (write-exemplar "vector_simple" "A simple vector" vector-simple)
  (write-exemplar "vector_empty" "An empty vector" [])
  (write-exemplar "vector_mixed" "A ten element vector with mixed values" vector-mixed)
  (write-exemplar "vector_nested" "Two vectors nested inside of an outter vector" vector-nested)

  (def small-strings  ["" "a" "ab" "abc" "abcd" "abcde" "abcdef"])

  (write-exemplar "small_strings" "A vector of small strings" small-strings)

  (write-exemplar "strings_tilde" "A vector of strings starting with ~" (vmap #(str "~" %) small-strings))

  (write-exemplar "strings_hash" "A vector of strings starting with #" (vmap #(str "#" %) small-strings))

  (write-exemplar "strings_hat" "A vector of strings starting with ^" (vmap #(str "^" %) small-strings))

  (write-exemplar "small_ints" "A vector of eleven small integers" (range-centered-on 0))

  (write-exemplar "ints", "vector of ints" (vec (range 128)))

  (def powers-two
       [1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384
        32768 65536 131072 262144 524288 1048576 2097152 4194304
        8388608 16777216 33554432 67108864 134217728 268435456
        536870912 1073741824 2147483648 4294967296 8589934592
        17179869184 34359738368 68719476736 137438953472
        274877906944 549755813888 1099511627776 2199023255552
        4398046511104 8796093022208 17592186044416 35184372088832
        70368744177664 140737488355328 281474976710656
        562949953421312 1125899906842624 2251799813685248
        4503599627370496 9007199254740992 18014398509481984
        36028797018963968 72057594037927936 144115188075855872
        288230376151711744 576460752303423488 1152921504606846976
        2305843009213693952 4611686018427387904 9223372036854775808
        18446744073709551616 36893488147419103232])

  (def interesting-ints
    (vec (apply concat (map #(range-centered-on % 2) powers-two))))

  (write-exemplar
    "ints_interesting"
    "A vector of possibly interesting positive integers"
    interesting-ints)

  (write-exemplar
    "ints_interesting_neg"
    "A vector of possibly interesting negative integers"
    (vmap #(* -1 %) interesting-ints))

  (write-exemplar
    "doubles_small"
    "A vector of eleven doubles from -5.0 to 5.0"
    (vmap #(double %) (range-centered-on 0)))

  (write-exemplar
    "doubles_interesting"
    "A vector of interesting doubles"
    [-3.14159 3.14159 4E11 2.998E8 6.626E-34])

  (def uuids [#uuid "5a2cbea3-e8c6-428b-b525-21239370dd55"
              #uuid "d1dc64fa-da79-444b-9fa4-d4412f427289"
              #uuid "501a978e-3a3e-4060-b3be-1cf2bd4b1a38"
              #uuid "b3ba141a-a776-48e4-9fae-a28ea8571f58"])

  (write-exemplar "one_uuid" "A single UUID" (first uuids))

  (write-exemplar
    "uuids"
    "A vector of uuids"
    uuids)

  (def dates (vmap #(java.util.Date. %) [-6106017600000 0 946728000000 1396909037000]))

  (write-exemplar
    "dates_interesting"
    "A vector of interesting dates: 1776-07-04, 1970-01-01, 2000-01-01, 2014-04-07"
    dates)

  (def symbols ['a 'ab 'abc 'abcd 'abcde 'a1 'b2 'c3 'a_b])

  (write-exemplar "symbols" "A vector of symbols" symbols)
  (write-exemplar "keywords" "A vector of keywords" (vmap keyword symbols))

  (write-exemplar "list_simple" "A simple list" (apply list vector-simple))
  (write-exemplar "list_empty" "An empty list" '())
  (write-exemplar "list_mixed" "A ten element list with mixed values" (apply list vector-mixed))
  (write-exemplar "list_mixed" "Two lists nested inside an outter list"
    (list (apply list vector-simple) (apply list vector-mixed)))

  (write-exemplar "set_simple" "A simple set" (set vector-simple))
  (write-exemplar "set_empty" "An empty set" #{})
  (write-exemplar "set_mixed" "A ten element set with mixed values" (set vector-mixed))
  (write-exemplar "set_mixed" "Two sets nested inside an outter set"
    (set [(set vector-simple) (set vector-mixed)]))

  (def map-simple {:a 1 :b 2 :c 3})
  (def map-mixed {:a 1 :b "a string" :c true})
  (def map-nested {:simple map-simple, :mixed map-mixed})

  (write-exemplar "map_simple" "A simple map" map-simple)
  (write-exemplar "map_mixed" "A mixed map" map-mixed)
  (write-exemplar "map_nested" "A nested map" map-nested)

  (write-exemplar "map_string_keys" "A map with string keys" {"first" 1, "second" 2, "third" 3})

  (write-exemplar "map_numeric_keys" "A map with numeric keys" {1 "one", 2 "two"})

  (write-exemplar "map_vector_keys" "A map with vector keys" {[1 1] "one", [2 2] "two"})

  (write-exemplar "map_10_items" "10 item map"  (map-of-size 10))

  (doseq [i [10 90 91 92 93 94 95]]
    (write-exemplar
      (str "map_" i "_nested")
      (str "Map of two nested " i " item maps")
      {:f (map-of-size i) :s (map-of-size i)}))

  (write-exemplar
    "maps_two_char_sym_keys"
    "Vector of maps with identical two char symbol keys"
    [{:aa 1 :bb 2} {:aa 3 :bb 4} {:aa 5 :bb 6}])

  (write-exemplar
    "maps_three_char_sym_keys"
    "Vector of maps with identical three char symbol keys"
    [{:aaa 1 :bbb 2} {:aaa 3 :bbb 4} {:aaa 5 :bbb 6}])

  (write-exemplar
    "maps_four_char_sym_keys"
    "Vector of maps with identical four char symbol keys"
    [{:aaaa 1 :bbbb 2} {:aaaa 3 :bbbb 4} {:aaaa 5 :bbbb 6}])

  (write-exemplar
    "maps_two_char_string_keys"
    "Vector of maps with identical two char string keys"
    [{"aa" 1 "bb" 2} {"aa" 3 "bb" 4} {"aa" 5 "bb" 6}])

  (write-exemplar
    "maps_three_char_string_keys"
    "Vector of maps with identical three char string keys"
    [{"aaa" 1 "bbb" 2} {"aaa" 3 "bbb" 4} {"aaa" 5 "bbb" 6}])

  (write-exemplar
    "maps_four_char_string_keys"
    "Vector of maps with identical four char string keys"
    [{"aaaa" 1 "bbbb" 2} {"aaaa" 3 "bbbb" 4} {"aaaa" 5 "bbbb" 6}])

  (write-exemplar
    "maps_unrecognized_keys"
    "Vector of maps with keys with unrecognized encodings"
    [{"`~#abcde" :anything} {"`~#fghij" :anything-else}])

  (write-exemplar
    "map_unrecognized_vals"
    "Map with vals with unrecognized encodings"
    {:key "`~notrecognized"})

  (write-exemplar
    "vector_93_keywords_repeated_twice"
    "Vector of 93 keywords, repeated twice"
    (vector-of-keywords 93 186))

  (write-exemplar
    "vector_94_keywords_repeated_twice"
    "Vector of 94 keywords, repeated twice"
    (vector-of-keywords 94 188))

  (write-exemplar
    "vector_95_keywords_repeated_twice"
    "Vector of 95 keywords, repeated twice"
    (vector-of-keywords 95 190))

  (write-exemplar
    "vector_unrecognized_vals"
    "Vector with vals with unrecognized encodings"
    ["`~notrecognized"]))

;; Copyright (c) Cognitect, Inc.
;; All rights reserved.

(ns exemplar
  (:require [transit.read :as r]
            [transit.write :as w]
            [clojure.java.io :as io]))

;; Generate a set of increasingly complex transit files.
;; Output checked into the transit repo under simple-examples.

(import [java.io File FileOutputStream ByteArrayInputStream ByteArrayOutputStream OutputStreamWriter])

(defn range-centered-on
  ([n] (range-centered-on n 5))
  ([n m] (vec (range (- n m) (+ n m 1)))))

(defn vmap [f s]
  (vec (map f s)))

(defn vector-of-keywords
  [n m]
  "Return a m length vector consisting of cycles of n keywordss"
  (vmap #(keyword (format "key%05d" %)) (take m (cycle (range n)))))

(defn map-of-size [n]
  (let [nums (range 0 n)]
    (apply
      sorted-map
      (interleave (map #(keyword (format "key%04d" %)) nums) nums))))

(defn write-description [file-name description vals]
  (println "##" description)
  (println "* Files:" (str file-name ".edn") (str file-name ".json") (str file-name ".mp"))
  (println "* Value (EDN)")
  (println)
  (doseq [item vals] (println "    " (pr-str item)))
  (println))

(defn write-transit [file-name & vals]
  (doseq [format [{:type :json, :suffix ".json"} {:type :msgpack :suffix ".mp"}]]
    (with-open [os (io/output-stream (str file-name (:suffix format)))]
      (let [jsw (w/writer os (:type format))]
        (doseq [item vals] (w/write jsw item))))))

(defn write-exemplar [file-name description & vals]
  (write-description file-name description vals)
  (with-open [w (io/writer (str file-name ".edn"))]
    (binding [*out* w] (apply pr vals)))
  (apply write-transit file-name vals))

(binding [*out* (io/writer "README.md")]
  (println "# Example transit files.\n\n")
  (println "There are three files for each value: An EDN file and two transit files,")
  (println "one encoded in JSON and one in MessagePack\n\n")
  (println "Note: The example transit files in this directory are *generated*.")
  (println "See https://github.com/cognitect/transit-clj/blob/master/test/exemplar.clj\n\n")

  (write-exemplar "nil" "The nil/null/ain't there value" nil)
  (write-exemplar "true" "True" true)
  (write-exemplar "false" "False" false)
  (write-exemplar "zero" "Zero (integer)" 0)
  (write-exemplar "one" "One (integer)" 1)
  (write-exemplar "one_string" "A single string" "hello")
  (write-exemplar "one_keyword" "A single keyword" :hello)
  (write-exemplar "one_symbol" "A single symbol" 'hello)
  (write-exemplar "one_date" "A single date" (java.util.Date. 946728000000))

  (def vector-simple  [1 2 3])
  (def vector-mixed  [0 1 2.0 true false "five" :six 'seven "~eight" nil])
  (def vector-nested [vector-simple vector-mixed])

  (write-exemplar "vector_simple" "A simple vector" vector-simple)
  (write-exemplar "vector_empty" "An empty vector" [])
  (write-exemplar "vector_mixed" "A ten element vector with mixed values" vector-mixed)
  (write-exemplar "vector_nested" "Two vectors nested inside of an outter vector" vector-nested)

  (def small-strings  ["" "a" "ab" "abc" "abcd" "abcde" "abcdef"])

  (write-exemplar "small_strings" "A vector of small strings" small-strings)

  (write-exemplar "strings_tilde" "A vector of strings starting with ~" (vmap #(str "~" %) small-strings))

  (write-exemplar "strings_hash" "A vector of strings starting with #" (vmap #(str "#" %) small-strings))

  (write-exemplar "strings_hat" "A vector of strings starting with ^" (vmap #(str "^" %) small-strings))

  (write-exemplar "small_ints" "A vector of eleven small integers" (range-centered-on 0))

  (write-exemplar "ints", "vector of ints" (vec (range 128)))

  (def powers-two
       [1 2 4 8 16 32 64 128 256 512 1024 2048 4096 8192 16384
        32768 65536 131072 262144 524288 1048576 2097152 4194304
        8388608 16777216 33554432 67108864 134217728 268435456
        536870912 1073741824 2147483648 4294967296 8589934592
        17179869184 34359738368 68719476736 137438953472
        274877906944 549755813888 1099511627776 2199023255552
        4398046511104 8796093022208 17592186044416 35184372088832
        70368744177664 140737488355328 281474976710656
        562949953421312 1125899906842624 2251799813685248
        4503599627370496 9007199254740992 18014398509481984
        36028797018963968 72057594037927936 144115188075855872
        288230376151711744 576460752303423488 1152921504606846976
        2305843009213693952 4611686018427387904 9223372036854775808
        18446744073709551616 36893488147419103232])

  (def interesting-ints
    (vec (apply concat (map #(range-centered-on % 2) powers-two))))

  (write-exemplar
    "ints_interesting"
    "A vector of possibly interesting positive integers"
    interesting-ints)

  (write-exemplar
    "ints_interesting_neg"
    "A vector of possibly interesting negative integers"
    (vmap #(* -1 %) interesting-ints))

  (write-exemplar
    "doubles_small"
    "A vector of eleven doubles from -5.0 to 5.0"
    (vmap #(double %) (range-centered-on 0)))

  (write-exemplar
    "doubles_interesting"
    "A vector of interesting doubles"
    [-3.14159 3.14159 4E11 2.998E8 6.626E-34])

  (def uuids [#uuid "5a2cbea3-e8c6-428b-b525-21239370dd55"
              #uuid "d1dc64fa-da79-444b-9fa4-d4412f427289"
              #uuid "501a978e-3a3e-4060-b3be-1cf2bd4b1a38"
              #uuid "b3ba141a-a776-48e4-9fae-a28ea8571f58"])

  (write-exemplar "one_uuid" "A single UUID" (first uuids))

  (write-exemplar
    "uuids"
    "A vector of uuids"
    uuids)

  (def dates (vmap #(java.util.Date. %) [-6106017600000 0 946728000000 1396909037000]))

  (write-exemplar
    "dates_interesting"
    "A vector of interesting dates: 1776-07-04, 1970-01-01, 2000-01-01, 2014-04-07"
    dates)

  (def symbols ['a 'ab 'abc 'abcd 'abcde 'a1 'b2 'c3 'a_b])

  (write-exemplar "symbols" "A vector of symbols" symbols)
  (write-exemplar "keywords" "A vector of keywords" (vmap keyword symbols))

  (write-exemplar "list_simple" "A simple list" (apply list vector-simple))
  (write-exemplar "list_empty" "An empty list" '())
  (write-exemplar "list_mixed" "A ten element list with mixed values" (apply list vector-mixed))
  (write-exemplar "list_mixed" "Two lists nested inside an outter list"
    (list (apply list vector-simple) (apply list vector-mixed)))

  (write-exemplar "set_simple" "A simple set" (set vector-simple))
  (write-exemplar "set_empty" "An empty set" #{})
  (write-exemplar "set_mixed" "A ten element set with mixed values" (set vector-mixed))
  (write-exemplar "set_mixed" "Two sets nested inside an outter set"
    (set [(set vector-simple) (set vector-mixed)]))

  (def map-simple {:a 1 :b 2 :c 3})
  (def map-mixed {:a 1 :b "a string" :c true})
  (def map-nested {:simple map-simple, :mixed map-mixed})

  (write-exemplar "map_simple" "A simple map" map-simple)
  (write-exemplar "map_mixed" "A mixed map" map-mixed)
  (write-exemplar "map_nested" "A nested map" map-nested)

  (write-exemplar "map_string_keys" "A map with string keys" {"first" 1, "second" 2, "third" 3})

  (write-exemplar "map_numeric_keys" "A map with numeric keys" {1 "one", 2 "two"})

  (write-exemplar "map_vector_keys" "A map with vector keys" {[1 1] "one", [2 2] "two"})

  (write-exemplar "map_10_items" "10 item map"  (map-of-size 10))

  (doseq [i [10 90 91 92 93 94 95]]
    (write-exemplar
      (str "map_" i "_nested")
      (str "Map of two nested " i " item maps")
      {:f (map-of-size i) :s (map-of-size i)}))

  (write-exemplar
    "maps_two_char_sym_keys"
    "Vector of maps with identical two char symbol keys"
    [{:aa 1 :bb 2} {:aa 3 :bb 4} {:aa 5 :bb 6}])

  (write-exemplar
    "maps_three_char_sym_keys"
    "Vector of maps with identical three char symbol keys"
    [{:aaa 1 :bbb 2} {:aaa 3 :bbb 4} {:aaa 5 :bbb 6}])

  (write-exemplar
    "maps_four_char_sym_keys"
    "Vector of maps with identical four char symbol keys"
    [{:aaaa 1 :bbbb 2} {:aaaa 3 :bbbb 4} {:aaaa 5 :bbbb 6}])

  (write-exemplar
    "maps_two_char_string_keys"
    "Vector of maps with identical two char string keys"
    [{"aa" 1 "bb" 2} {"aa" 3 "bb" 4} {"aa" 5 "bb" 6}])

  (write-exemplar
    "maps_three_char_string_keys"
    "Vector of maps with identical three char string keys"
    [{"aaa" 1 "bbb" 2} {"aaa" 3 "bbb" 4} {"aaa" 5 "bbb" 6}])

  (write-exemplar
    "maps_four_char_string_keys"
    "Vector of maps with identical four char string keys"
    [{"aaaa" 1 "bbbb" 2} {"aaaa" 3 "bbbb" 4} {"aaaa" 5 "bbbb" 6}])

  (write-exemplar
    "maps_unrecognized_keys"
    "Vector of maps with keys with unrecognized encodings"
    [(w/tagged-value "abcde" :anything)
     (w/tagged-value "fghij" :anything-else)])

  (write-exemplar
    "map_unrecognized_vals"
    "Map with vals with unrecognized encodings"
    {:key "`~notrecognized"})

  (write-exemplar
    "vector_93_keywords_repeated_twice"
    "Vector of 93 keywords, repeated twice"
    (vector-of-keywords 93 186))

  (write-exemplar
    "vector_94_keywords_repeated_twice"
    "Vector of 94 keywords, repeated twice"
    (vector-of-keywords 94 188))

  (write-exemplar
    "vector_95_keywords_repeated_twice"
    "Vector of 95 keywords, repeated twice"
    (vector-of-keywords 95 190))

  (write-exemplar
    "vector_unrecognized_vals"
    "Vector with vals with unrecognized encodings"
    ["`~notrecognized"]))

Use tagged value to gen map with keys with unrecognized encodings


(ns freestuffly.gumtree.result-parser
  (:require [hickory.core :as h])
  (:require [clojure.set :as cset])
  (:require [clojure.string :as string])
  (:require [clj-yaml.core :as yaml])
  (:require [hickory.select :as s]))

(def ^:private config (yaml/parse-string (slurp "config/gumtree.yml")))

(defn- interesting-keywords [] (:keywords config))

(defn- interesting-keywords-regex [] (re-pattern (str "(?i)" (string/join "\b|" (interesting-keywords)))))

(defn- interesting-finds
  [results]
  (cset/select
    (fn [result]
      (re-find
        (re-matcher (interesting-keywords-regex)
                    (first (:content (into {} result))))))
    (set results)))

(defn- site-tree
  [scraped-html]
  (h/as-hickory (h/parse scraped-html)))

(defn- parsed-html
  [html]
  (-> (s/select
        (s/descendant
          (s/id "group_posts_table")
          (s/and (s/tag :tr))
          (s/and (s/tag :td) (s/nth-child 2))
          (s/and (s/tag :a) (s/nth-child 1)))
      html)))

(defn- interesting-value?
  [content-values]
  (not= (content-values :content) ["See details"]))

(defn- content-for
  [html-vector]
  (filter interesting-value? (map #(select-keys % [:attrs :content]) html-vector)))

(defn- presentable
  [results]
  (str "FOUND\n\n\n\n"
       (string/join "\n\n\n"
                    (map vals results))))

(defn parsed
  [scraped-html]
  (presentable
    (interesting-finds
      (content-for
        (parsed-html
          (site-tree scraped-html))))))

(ns freestuffly.gumtree.result-parser
  (:require [hickory.core :as h])
  (:require [clojure.set :as cset])
  (:require [clojure.string :as string])
  (:require [clj-yaml.core :as yaml])
  (:require [hickory.select :as s]))

(def ^:private config (yaml/parse-string (slurp "config/gumtree.yml")))

(defn- interesting-keywords [] (:keywords config))

(defn- interesting-keywords-regex [] (re-pattern (str "(?i)" (string/join "\\b|" (interesting-keywords)))))

(defn- interesting-finds
  [results]
  (cset/select
    (fn [result]
      (re-find
        (re-matcher (interesting-keywords-regex)
                    (first (:content (into {} result))))))
    (set results)))

(defn- site-tree
  [scraped-html]
  (h/as-hickory (h/parse scraped-html)))

(defn- parsed-html
  [html]
  (-> (s/select
        (s/descendant
          (s/id "group_posts_table")
          (s/and (s/tag :tr))
          (s/and (s/tag :td) (s/nth-child 2))
          (s/and (s/tag :a) (s/nth-child 1)))
      html)))

(defn- interesting-value?
  [content-values]
  (not= (content-values :content) ["See details"]))

(defn- content-for
  [html-vector]
  (filter interesting-value? (map #(select-keys % [:attrs :content]) html-vector)))

(defn- presentable
  [results]
  (str "FOUND\n\n\n\n"
       (string/join "\n\n\n"
                    (map vals results))))

(defn parsed
  [scraped-html]
  (presentable
    (interesting-finds
      (content-for
        (parsed-html
          (site-tree scraped-html))))))

Fix regex

Fix regex


(ns playasophy.wonderdome.display.processing
  (:require
    [clojure.core.async :as async :refer [>!!]]
    [com.stuartsierra.component :as component]
    [playasophy.wonderdome.display.core :as display]
    (playasophy.wonderdome.geometry
      [geodesic :as geodesic])
    [playasophy.wonderdome.util.quil :refer [*scale-factor* scale-point draw-axes]]
    (quil
      [applet :as applet]
      [core :as quil])))

;;;;; RENDERING FUNCTIONS ;;;;;

(defn- setup-sketch
  []
  (quil/background 0)
  (quil/stroke 0))

(defn- draw-dome
  [edges]
  (quil/stroke (quil/color 96 128))
  (quil/stroke-weight 3)
  (doseq [[a b] edges]
    (quil/line
      (scale-point a)
      (scale-point b))))

(defn- draw-strip
  "Draws a line representing the path of a pixel strip. Strip should be a vector
  of spherical coordinate maps."
  [strip]
  (quil/stroke-weight 1)
  (quil/stroke 0 64 196)
  (doseq [[a b] (partition 2 1 strip)]
    (quil/line
      (-> a :coord scale-point)
      (-> b :coord scale-point))))

(defn- draw-pixel
  "Draws a single pixel with the given color. The pixel should be a spherical
  coordinate map."
  [coordinate color]
  (quil/stroke-weight 3)
  (when-not (zero? (quil/brightness color))
    (quil/stroke color)
    (->> coordinate
         :coord
         scale-point
         (apply quil/point))))

(defn- draw-pixel-strips
  [layout colors]
  (dorun (map draw-strip layout))
  (dorun (map #(dorun (map draw-pixel %1 %2)) layout colors)))

(defn- render
  [display]
  (quil/background 0)
  (quil/translate (* 1/2 (quil/width)) (* 3/4 (quil/height)) 0)
  (quil/rotate-x 2.3)
  (quil/rotate-z (* (quil/frame-count) 0.003))
  (binding [*scale-factor* 1.5]
    (draw-axes 0.5)
    ;(draw-ground 4.0)
    (draw-dome (:dome display))
    (draw-pixel-strips
      (:layout display)
      @(:colors display))))

;;;;; INPUT FUNCTIONS ;;;;;

(def ^:private key-codes
  "Maps integer key codes to keywords."
  {10 :start    ; enter
   32 :select   ; space
   37 :left
   38 :up
   39 :right
   40 :down
   65 :A
   66 :B
   76 :L
   82 :R
   88 :X
   89 :Y})

(def ^:private axis-keys
  #{:up :down :left :right})

(defn- key->event
  "Generates button press and repeat events for appropriate key actions."
  [old-key new-key dt]
  (when new-key
    (if (= new-key old-key)
      (if (< dt 80)
        ; Repeated key-press events
        (case new-key
          :left  {:type :axis/direction, :input :x-axis, :value -1.0, :elapsed dt}
          :right {:type :axis/direction, :input :x-axis, :value  1.0, :elapsed dt}
          :down  {:type :axis/direction, :input :y-axis, :value -1.0, :elapsed dt}
          :up    {:type :axis/direction, :input :y-axis, :value  1.0, :elapsed dt}
          nil)
        ; New press of same key
        (when-not (axis-keys new-key)
          {:type :button/press, :input new-key}))
      ; New key pressed
      (when-not (axis-keys new-key)
        {:type :button/press, :input new-key}))))

(defn- key-handler
  "Builds a handler function which will store the current key state in an atom
  and report gamepad-compatible events to the given channel."
  [channel]
  (let [state (atom {})]
    (fn []
      (when (quil/key-pressed?)
        (let [code (quil/key-code)
              new-key (key-codes code)
              now (System/currentTimeMillis)
              {:keys [old-key last-press]} @state
              dt (if last-press (- now last-press) 0)]
          (when-let [event (key->event old-key new-key dt)]
            (>!! channel event))
          ; TODO: need timers to handle button/release events
          (swap! state assoc :old-key new-key :last-press now))))))

;;;;; PROCESSING DISPLAY ;;;;;

(defrecord ProcessingDisplay
  [size dome layout colors event-channel]

  component/Lifecycle

  (start
    [this]
    (assoc this :sketch
      (quil/sketch
        :title "Playasophy Wonderdome"
        :features [:keep-on-top :resizable]
        :setup setup-sketch
        :draw #(render this)
        :size (:size this)
        :key-pressed (key-handler event-channel)
        :renderer :opengl)))

  (stop
    [this]
    (when-let [sketch (:sketch this)]
      (applet/applet-close sketch))
    (dissoc this :sketch))

  display/Display

  (set-colors!
    [this colors]
    (swap! (:colors this) (constantly colors))
    nil))

(defn display
  "Creates a new simulation display using Processing. Takes a vector giving the
  width and height in pixels, and a radius of geometric dome to draw. The pixel
  layout must be injected at runtime before starting the display."
  [size radius]
  (let [dome (-> radius (+ 0.05) (geodesic/edges 3) geodesic/ground-slice set)]
    (ProcessingDisplay. size dome nil (atom []) nil)))

(ns playasophy.wonderdome.display.processing
  (:require
    [clojure.core.async :as async :refer [>!!]]
    [com.stuartsierra.component :as component]
    [playasophy.wonderdome.display.core :as display]
    (playasophy.wonderdome.geometry
      [geodesic :as geodesic])
    [playasophy.wonderdome.util.quil :refer [*scale-factor* scale-point draw-axes]]
    (quil
      [applet :as applet]
      [core :as quil])))

;;;;; RENDERING FUNCTIONS ;;;;;

(defn- setup-sketch
  []
  (quil/background 0)
  (quil/stroke 0))

(defn- draw-dome
  [edges]
  (quil/stroke (quil/color 96 128))
  (quil/stroke-weight 3)
  (doseq [[a b] edges]
    (quil/line
      (scale-point a)
      (scale-point b))))

(defn- draw-strip
  "Draws a line representing the path of a pixel strip. Strip should be a vector
  of spherical coordinate maps."
  [strip]
  (quil/stroke-weight 1)
  (quil/stroke 0 64 196)
  (doseq [[a b] (partition 2 1 strip)]
    (quil/line
      (-> a :coord scale-point)
      (-> b :coord scale-point))))

(defn- draw-pixel
  "Draws a single pixel with the given color. The pixel should be a spherical
  coordinate map."
  [coordinate color]
  (quil/stroke-weight 3)
  (when-not (zero? (quil/brightness color))
    (quil/stroke color)
    (->> coordinate
         :coord
         scale-point
         (apply quil/point))))

(defn- draw-pixel-strips
  [layout colors]
  (dorun (map draw-strip layout))
  (dorun (map #(dorun (map draw-pixel %1 %2)) layout colors)))

(defn- render
  [display]
  (quil/background 0)
  (quil/translate (* 1/2 (quil/width)) (* 0.98 (quil/height)) (* 0.61 (quil/height)))
  (quil/rotate-x 1.3)
  (quil/rotate-z (* (quil/frame-count) 0.003))
  (binding [*scale-factor* 1.5]
    (draw-axes 0.5)
    ;(draw-ground 4.0)
    (draw-dome (:dome display))
    (draw-pixel-strips
      (:layout display)
      @(:colors display))))

;;;;; INPUT FUNCTIONS ;;;;;

(def ^:private key-codes
  "Maps integer key codes to keywords."
  {10 :start    ; enter
   32 :select   ; space
   37 :left
   38 :up
   39 :right
   40 :down
   65 :A
   66 :B
   76 :L
   82 :R
   88 :X
   89 :Y})

(def ^:private axis-keys
  #{:up :down :left :right})

(defn- key->event
  "Generates button press and repeat events for appropriate key actions."
  [old-key new-key dt]
  (when new-key
    (if (= new-key old-key)
      (if (< dt 80)
        ; Repeated key-press events
        (case new-key
          :left  {:type :axis/direction, :input :x-axis, :value -1.0, :elapsed dt}
          :right {:type :axis/direction, :input :x-axis, :value  1.0, :elapsed dt}
          :down  {:type :axis/direction, :input :y-axis, :value -1.0, :elapsed dt}
          :up    {:type :axis/direction, :input :y-axis, :value  1.0, :elapsed dt}
          nil)
        ; New press of same key
        (when-not (axis-keys new-key)
          {:type :button/press, :input new-key}))
      ; New key pressed
      (when-not (axis-keys new-key)
        {:type :button/press, :input new-key}))))

(defn- key-handler
  "Builds a handler function which will store the current key state in an atom
  and report gamepad-compatible events to the given channel."
  [channel]
  (let [state (atom {})]
    (fn []
      (when (quil/key-pressed?)
        (let [code (quil/key-code)
              new-key (key-codes code)
              now (System/currentTimeMillis)
              {:keys [old-key last-press]} @state
              dt (if last-press (- now last-press) 0)]
          (when-let [event (key->event old-key new-key dt)]
            (>!! channel event))
          ; TODO: need timers to handle button/release events
          (swap! state assoc :old-key new-key :last-press now))))))

;;;;; PROCESSING DISPLAY ;;;;;

(defrecord ProcessingDisplay
  [size dome layout colors event-channel]

  component/Lifecycle

  (start
    [this]
    (assoc this :sketch
      (quil/sketch
        :title "Playasophy Wonderdome"
        :features [:keep-on-top :resizable]
        :setup setup-sketch
        :draw #(render this)
        :size (:size this)
        :key-pressed (key-handler event-channel)
        :renderer :opengl)))

  (stop
    [this]
    (when-let [sketch (:sketch this)]
      (applet/applet-close sketch))
    (dissoc this :sketch))

  display/Display

  (set-colors!
    [this colors]
    (swap! (:colors this) (constantly colors))
    nil))

(defn display
  "Creates a new simulation display using Processing. Takes a vector giving the
  width and height in pixels, and a radius of geometric dome to draw. The pixel
  layout must be injected at runtime before starting the display."
  [size radius]
  (let [dome (-> radius (+ 0.05) (geodesic/edges 3) geodesic/ground-slice set)]
    (ProcessingDisplay. size dome nil (atom []) nil)))

Adjust view in dev simulator to focus on lantern


(ns re-demo.core
  (:require-macros [cljs.core.async.macros :refer [go]]
                   [secretary.core         :refer [defroute]])
  (:require [goog.events                   :as    events]
            [reagent.core                  :as    reagent]
            [alandipert.storage-atom       :refer [local-storage]]
            [secretary.core                :as    secretary]
            [re-com.core                   :refer [h-box v-box box gap line scroller border label title alert-box] :refer-macros [handler-fn]]
            [re-com.util                   :refer [get-element-by-id item-for-id]]
            [re-demo.utils                 :refer [panel-title]]
            [re-demo.welcome               :as    welcome]
            [re-demo.radio-button          :as    radio-button]
            [re-demo.checkbox              :as    checkbox]
            [re-demo.input-text            :as    input-text]
            [re-demo.slider                :as    slider]
            [re-demo.label                 :as    label]
            [re-demo.title                 :as    title]
            [re-demo.progress-bar          :as    progress-bar]
            [re-demo.throbber               :as   throbber]
            [re-demo.button                :as    button]
            [re-demo.md-circle-icon-button :as    md-circle-icon-button]
            [re-demo.md-icon-button        :as    md-icon-button]
            [re-demo.info-button           :as    info-button]
            [re-demo.row-button            :as    row-button]
            [re-demo.hyperlink             :as    hyperlink]
            [re-demo.hyperlink-href        :as    hyperlink-href]
            [re-demo.dropdowns             :as    dropdowns]
            [re-demo.alert-box             :as    alert-box]
            [re-demo.alert-list            :as    alert-list]
            [re-demo.tabs                  :as    tabs]
            [re-demo.popovers              :as    popovers]
            [re-demo.datepicker            :as    datepicker]
            [re-demo.selection-list        :as    selection-list]
            [re-demo.input-time            :as    input-time]
            [re-demo.layout                :as    layout]
            [re-demo.layouts               :as    layouts]
            [re-demo.tour                  :as    tour]
            [re-demo.modal-panel           :as    modal-panel]
            [re-demo.h-box                 :as    h-box]
            [re-demo.v-box                 :as    v-box]
            [re-demo.box                   :as    box]
            [re-demo.gap                   :as    gap]
            [re-demo.line                  :as    line]
            [re-demo.scroller              :as    scroller]
            [re-demo.border                :as    border]
            [goog.history.EventType        :as    EventType])
  (:import [goog History]))

(enable-console-print!)

(def tabs-definition
  [{:id :welcome                :level :major :label "Welcome"            :panel welcome/panel}

   {:id :layout                 :level :major :label "Layout"             :panel layout/panel}
   {:id :h-box                  :level :minor :label "H-box"              :panel h-box/panel}
   {:id :v-box                  :level :minor :label "V-box"              :panel v-box/panel}
   {:id :box                    :level :minor :label "Box"                :panel box/panel}
   {:id :gap                    :level :minor :label "Gap"                :panel gap/panel}
   {:id :line                   :level :minor :label "Line"               :panel line/panel}
   {:id :scroller               :level :minor :label "Scroller"           :panel scroller/panel}
   {:id :border                 :level :minor :label "Border"             :panel border/panel}
   {:id :layouts                :level :minor :label "Layouts"            :panel layouts/panel}

   {:id :buttons                :level :major :label "Buttons"}
   {:id :button                 :level :minor :label "Basic Button"       :panel button/panel}
   {:id :row-button             :level :minor :label "Row Button"         :panel row-button/panel}
   {:id :md-circle-icon-button  :level :minor :label "Circle Icon Button" :panel md-circle-icon-button/panel}
   {:id :md-icon-button         :level :minor :label "Icon Button"        :panel md-icon-button/panel}
   {:id :info-button            :level :minor :label "Info Button"        :panel info-button/panel}
   {:id :hyperlink              :level :minor :label "Hyperlink"          :panel hyperlink/panel}
   {:id :hyperlink-href         :level :minor :label "Hyperlink (href)"   :panel hyperlink-href/panel}

   {:id :basics                 :level :major :label "Basics"}
   {:id :checkbox               :level :minor :label "Checkbox"           :panel checkbox/panel}
   {:id :radio-button           :level :minor :label "Radio Button"       :panel radio-button/panel}
   {:id :input-text             :level :minor :label "Input Text"         :panel input-text/panel}
   {:id :slider                 :level :minor :label "Slider"             :panel slider/panel}
   {:id :progress-bar           :level :minor :label "Progress Bar"       :panel progress-bar/panel}
   {:id :throbber               :level :minor :label "Throbber"           :panel throbber/panel}
   {:id :date                   :level :minor :label "Date Picker"        :panel datepicker/panel}
   {:id :time                   :level :minor :label "Input Time"         :panel input-time/panel}

   {:id :selection              :level :major :label "Selection"}
   {:id :dropdown               :level :minor :label "Dropdowns"          :panel dropdowns/panel}
   {:id :lists                  :level :minor :label "Selection List"     :panel selection-list/panel}
   {:id :tabs                   :level :minor :label "Tabs"               :panel tabs/panel}

   {:id :layers                 :level :major :label "Layers"}
   {:id :modal-panel            :level :minor :label "Modal Panel"        :panel modal-panel/panel}
   {:id :popover-args           :level :minor :label "Popover Args"       :panel popovers/arg-lists}
   {:id :popovers               :level :minor :label "Popover Demos"      :panel popovers/panel}
   {:id :tour                   :level :minor :label "Tour"               :panel tour/panel}

   {:id :typography             :level :major :label "Typography"}
   {:id :label                  :level :minor :label "Label"              :panel label/panel}
   {:id :title                  :level :minor :label "Title"              :panel title/panel} ;; TODO: field-label?
   {:id :alert-box              :level :minor :label "Alert Box"          :panel alert-box/panel}
   {:id :alert-list             :level :minor :label "Alert List"         :panel alert-list/panel}
   ])

(defn nav-item
  []
  (let [mouse-over? (reagent/atom false)]
    (fn [tab selected-tab-id on-select-tab]
      (let [selected?   (= @selected-tab-id (:id tab))
            is-major?  (= (:level tab) :major)
            has-panel? (some? (:panel tab))]
      [:div
       {:style {:width            "150px"
                :line-height      "1.3em"
                :padding-left     (if is-major? "24px" "32px")
                :padding-top      (when is-major? "6px")
                :font-size        (when is-major? "15px")
                :font-weight      (when is-major? "bold")
                :color            (when selected? "#111")
                :border-right     (when selected? "4px #d0d0d0 solid")
                :background-color (if (or
                                        (= @selected-tab-id (:id tab))
                                        @mouse-over?) "#eaeaea")}

        :on-mouse-over (handler-fn (when has-panel? (reset! mouse-over? true)))
        :on-mouse-out  (handler-fn (reset! mouse-over? false))
        :on-click      (handler-fn (when has-panel? (on-select-tab (:id tab))))}
       [:span
        {:style {:cursor "default"}}    ;; removes the I-beam over the label
        (:label tab)]]))))

(defn left-side-nav-bar
  [selected-tab-id on-select-tab]
    [v-box
     :class    "noselect"
     :children (for [tab tabs-definition]
                 [nav-item tab selected-tab-id on-select-tab])])

(defn re-com-title-box
  []
  [h-box
   :justify :center
   :align   :center
   :height  "63px"
   :style   {:background-color "#888"}
   :children [[title
               :label "Re-com"
               :style {:font-family "Roboto, sans-serif"
                       :font-size   "36px"
                       :font-weight 300
                       :color       "#fefefe"}]]])

(defn browser-alert
  []
  [box
   :padding "10px"
   :child   [alert-box
             :alert-type :danger
             :heading    "Works Best in Chrome"
             :body       "re-com has been verified in Google Chrome. Much of it will run in other browsers but there will be dragons!"]])

;; -- Routes, Local Storage and History ------------------------------------------------------

(def id-store        (local-storage (atom nil) ::id-store))
(def selected-tab-id (reagent/atom (if (or (nil? @id-store) (nil? (item-for-id @id-store tabs-definition)))
                                     (:id (first tabs-definition))
                                     @id-store)))  ;; id of the selected tab from local storage

(defroute demo-page "/:tab" [tab] (let [id (keyword tab)]
                                    (reset! selected-tab-id id)
                                    (reset! id-store id)))

(def history (History.))
(events/listen history EventType/NAVIGATE (fn [event] (secretary/dispatch! (.-token event))))
(.setEnabled history true)

(defn main
  []
  (let [on-select-tab #(.setToken history (demo-page {:tab (name %1)}))] ;; or can use (str "/" (name %1))
    (fn
      []
      [h-box
       ;; Outer-most box height must be 100% to fill the entrie client height.
       ;; (height is 100% of body, which must have already had it's height set to 100%)
       ;; width doesn't need to be initially set
       :height   "100%"
       :gap      "60px"
       :children [[scroller
                   :size  "none"
                   :v-scroll :auto
                   :h-scroll :off
                   :child [v-box
                           :children [[re-com-title-box]
                                      [left-side-nav-bar selected-tab-id on-select-tab]]]]
                  [scroller
                   :child [v-box
                           :size  "auto"
                           :children [(when-not (>= (.indexOf (.-userAgent (.-navigator js/window)) "Chrome") 0) [browser-alert])
                                      [(:panel (item-for-id @selected-tab-id tabs-definition))]]]]]])))    ;; the tab panel to show, for the selected tab

(defn ^:export mount-demo
  []
  (reagent/render [main] (get-element-by-id "app"))
  ;(reagent/render [display-green-messages] (util/get-element-by-id "app")) ;; TODO: EXPERIMENT - REMOVE
  )

(ns re-demo.core
  (:require-macros [cljs.core.async.macros :refer [go]]
                   [secretary.core         :refer [defroute]])
  (:require [goog.events                   :as    events]
            [reagent.core                  :as    reagent]
            [alandipert.storage-atom       :refer [local-storage]]
            [secretary.core                :as    secretary]
            [re-com.core                   :refer [h-box v-box box gap line scroller border label title alert-box] :refer-macros [handler-fn]]
            [re-com.util                   :refer [get-element-by-id item-for-id]]
            [re-demo.utils                 :refer [panel-title]]
            [re-demo.welcome               :as    welcome]
            [re-demo.radio-button          :as    radio-button]
            [re-demo.checkbox              :as    checkbox]
            [re-demo.input-text            :as    input-text]
            [re-demo.slider                :as    slider]
            [re-demo.label                 :as    label]
            [re-demo.title                 :as    title]
            [re-demo.progress-bar          :as    progress-bar]
            [re-demo.throbber               :as   throbber]
            [re-demo.button                :as    button]
            [re-demo.md-circle-icon-button :as    md-circle-icon-button]
            [re-demo.md-icon-button        :as    md-icon-button]
            [re-demo.info-button           :as    info-button]
            [re-demo.row-button            :as    row-button]
            [re-demo.hyperlink             :as    hyperlink]
            [re-demo.hyperlink-href        :as    hyperlink-href]
            [re-demo.dropdowns             :as    dropdowns]
            [re-demo.alert-box             :as    alert-box]
            [re-demo.alert-list            :as    alert-list]
            [re-demo.tabs                  :as    tabs]
            [re-demo.popovers              :as    popovers]
            [re-demo.datepicker            :as    datepicker]
            [re-demo.selection-list        :as    selection-list]
            [re-demo.input-time            :as    input-time]
            [re-demo.layout                :as    layout]
            [re-demo.layouts               :as    layouts]
            [re-demo.tour                  :as    tour]
            [re-demo.modal-panel           :as    modal-panel]
            [re-demo.h-box                 :as    h-box]
            [re-demo.v-box                 :as    v-box]
            [re-demo.box                   :as    box]
            [re-demo.gap                   :as    gap]
            [re-demo.line                  :as    line]
            [re-demo.scroller              :as    scroller]
            [re-demo.border                :as    border]
            [goog.history.EventType        :as    EventType])
  (:import [goog History]))

(enable-console-print!)

(def tabs-definition
  [{:id :welcome                :level :major :label "Welcome"            :panel welcome/panel}

   {:id :layout                 :level :major :label "Layout"             :panel layout/panel}
   {:id :h-box                  :level :minor :label "H-box"              :panel h-box/panel}
   {:id :v-box                  :level :minor :label "V-box"              :panel v-box/panel}
   {:id :box                    :level :minor :label "Box"                :panel box/panel}
   {:id :gap                    :level :minor :label "Gap"                :panel gap/panel}
   {:id :line                   :level :minor :label "Line"               :panel line/panel}
   {:id :scroller               :level :minor :label "Scroller"           :panel scroller/panel}
   {:id :border                 :level :minor :label "Border"             :panel border/panel}
   {:id :layouts                :level :minor :label "Layouts"            :panel layouts/panel}

   {:id :buttons                :level :major :label "Buttons"}
   {:id :button                 :level :minor :label "Basic Button"       :panel button/panel}
   {:id :row-button             :level :minor :label "Row Button"         :panel row-button/panel}
   {:id :md-circle-icon-button  :level :minor :label "Circle Icon Button" :panel md-circle-icon-button/panel}
   {:id :md-icon-button         :level :minor :label "Icon Button"        :panel md-icon-button/panel}
   {:id :info-button            :level :minor :label "Info Button"        :panel info-button/panel}
   {:id :hyperlink              :level :minor :label "Hyperlink"          :panel hyperlink/panel}
   {:id :hyperlink-href         :level :minor :label "Hyperlink (href)"   :panel hyperlink-href/panel}

   {:id :basics                 :level :major :label "Basics"}
   {:id :checkbox               :level :minor :label "Checkbox"           :panel checkbox/panel}
   {:id :radio-button           :level :minor :label "Radio Button"       :panel radio-button/panel}
   {:id :input-text             :level :minor :label "Input Text"         :panel input-text/panel}
   {:id :slider                 :level :minor :label "Slider"             :panel slider/panel}
   {:id :progress-bar           :level :minor :label "Progress Bar"       :panel progress-bar/panel}
   {:id :throbber               :level :minor :label "Throbber"           :panel throbber/panel}
   {:id :date                   :level :minor :label "Date Picker"        :panel datepicker/panel}
   {:id :time                   :level :minor :label "Input Time"         :panel input-time/panel}

   {:id :selection              :level :major :label "Selection"}
   {:id :dropdown               :level :minor :label "Dropdowns"          :panel dropdowns/panel}
   {:id :lists                  :level :minor :label "Selection List"     :panel selection-list/panel}
   {:id :tabs                   :level :minor :label "Tabs"               :panel tabs/panel}

   {:id :layers                 :level :major :label "Layers"}
   {:id :modal-panel            :level :minor :label "Modal Panel"        :panel modal-panel/panel}
   {:id :popover-args           :level :minor :label "Popover Args"       :panel popovers/arg-lists}
   {:id :popovers               :level :minor :label "Popover Demos"      :panel popovers/panel}
   {:id :tour                   :level :minor :label "Tour"               :panel tour/panel}

   {:id :typography             :level :major :label "Typography"}
   {:id :label                  :level :minor :label "Label"              :panel label/panel}
   {:id :title                  :level :minor :label "Title"              :panel title/panel} ;; TODO: field-label?
   {:id :alert-box              :level :minor :label "Alert Box"          :panel alert-box/panel}
   {:id :alert-list             :level :minor :label "Alert List"         :panel alert-list/panel}
   ])

(defn nav-item
  []
  (let [mouse-over? (reagent/atom false)]
    (fn [tab selected-tab-id on-select-tab]
      (let [selected?   (= @selected-tab-id (:id tab))
            is-major?  (= (:level tab) :major)
            has-panel? (some? (:panel tab))]
      [:div
       {:style {:width            "150px"
                :line-height      "1.3em"
                :padding-left     (if is-major? "24px" "32px")
                :padding-top      (when is-major? "6px")
                :font-size        (when is-major? "15px")
                :font-weight      (when is-major? "bold")
                :color            (when selected? "#111")
                :border-right     (when selected? "4px #d0d0d0 solid")
                :background-color (if (or
                                        (= @selected-tab-id (:id tab))
                                        @mouse-over?) "#eaeaea")}

        :on-mouse-over (handler-fn (when has-panel? (reset! mouse-over? true)))
        :on-mouse-out  (handler-fn (reset! mouse-over? false))
        :on-click      (handler-fn (when has-panel? (on-select-tab (:id tab))))}
       [:span
        {:style {:cursor "default"}}    ;; removes the I-beam over the label
        (:label tab)]]))))

(defn left-side-nav-bar
  [selected-tab-id on-select-tab]
    [v-box
     :class    "noselect"
     :children (for [tab tabs-definition]
                 [nav-item tab selected-tab-id on-select-tab])])

(defn re-com-title-box
  []
  [h-box
   :justify :center
   :align   :center
   :height  "63px"
   :style   {:background-color "#888"}
   :children [[title
               :label "Re-com"
               :style {:font-family "Roboto, sans-serif"
                       :font-size   "36px"
                       :font-weight 300
                       :color       "#fefefe"}]]])

(defn browser-alert
  []
  [box
   :padding "10px 0px 10px 10px"
   :child   [alert-box
             :alert-type :danger
             :heading    "Use Chrome Instead?"
             :body       "re-com should work on all modern browsers, but there might be dragons!"]])

;; -- Routes, Local Storage and History ------------------------------------------------------

(def id-store        (local-storage (atom nil) ::id-store))
(def selected-tab-id (reagent/atom (if (or (nil? @id-store) (nil? (item-for-id @id-store tabs-definition)))
                                     (:id (first tabs-definition))
                                     @id-store)))  ;; id of the selected tab from local storage

(defroute demo-page "/:tab" [tab] (let [id (keyword tab)]
                                    (reset! selected-tab-id id)
                                    (reset! id-store id)))

(def history (History.))
(events/listen history EventType/NAVIGATE (fn [event] (secretary/dispatch! (.-token event))))
(.setEnabled history true)

(defn main
  []
  (let [on-select-tab #(.setToken history (demo-page {:tab (name %1)}))] ;; or can use (str "/" (name %1))
    (fn
      []
      [h-box
       ;; Outer-most box height must be 100% to fill the entrie client height.
       ;; (height is 100% of body, which must have already had it's height set to 100%)
       ;; width doesn't need to be initially set
       :height   "100%"
       :gap      "60px"
       :children [[scroller
                   :size  "none"
                   :v-scroll :auto
                   :h-scroll :off
                   :child [v-box
                           :children [[re-com-title-box]
                                      [left-side-nav-bar selected-tab-id on-select-tab]]]]
                  [scroller
                   :child [v-box
                           :size  "auto"
                           :children [(when-not (>= (.indexOf (.-userAgent (.-navigator js/window)) "Chrome") 0) [browser-alert])
                                      [(:panel (item-for-id @selected-tab-id tabs-definition))]]]]]])))    ;; the tab panel to show, for the selected tab

(defn ^:export mount-demo
  []
  (reagent/render [main] (get-element-by-id "app"))
  ;(reagent/render [display-green-messages] (util/get-element-by-id "app")) ;; TODO: EXPERIMENT - REMOVE
  )

Tweak warning for non Chrome browsers

Tweak warning for non Chrome browsers


(ns robinson.main
  (:use    clojure.pprint
           robinson.common
           [robinson.worldgen :exclude [-main]]
           robinson.dialog
           robinson.npc
           robinson.update
           [robinson.monstergen :exclude [-main]]
           robinson.render)
  (:require
            [robinson.swingterminal :as swingterminal]
            clojure.edn
            ;[lanterna.screen :as s]
            [taoensso.timbre :as timbre]
            [clojure.core.async :as async]))

(timbre/refer-timbre)

(timbre/set-config! [] (read-string (slurp "config/timbre.clj")))

(defn tick
  "The game loop.

   Take the current state, render it, wait for player input, then update
   the state using the player's input and return the new state. Save the
   world too, in case the  game is interrupted. Then we can load it next
   time we start up."
  ([state]
   (let [keyin (swingterminal/wait-for-key (state :screen))]
     (if keyin
       (tick state keyin)
       state)))
  ([state keyin]
    (do
      (info "got " (str keyin) " type " (type keyin))
      (log-time "tick"
        (let [new-state (log-time "update-state" (update-state state keyin))]
          (log-time "render" (render new-state))
          (async/thread (spit "save/world.edn" (prn-str (new-state :world))))
          ;(async/thread (spit "save/world.edn" (with-out-str (pprint (new-state :world)))))
          new-state)))))

;; Example setup and tick fns
(defn setup
  "Create the intial `state` value.

   `state` contains

   * a `:world` that contains places, npcs, a player

   * a `:screen` to render the world

   * `quests` that are loaded dynamically on startup."
  []
  (let [terminal  (swingterminal/make-terminal 80 24)
        world (if (.exists (clojure.java.io/file "save/world.edn"))
                (->> (slurp "save/world.edn")
                     (clojure.edn/read-string {:readers {'dungeon_crusade.monstergen.Monster map->Monster}}))
                (init-world))
         ;; load quests
         _ (doall (map #(load-file (.getPath %))
                        (filter (fn [file] (.endsWith (.getPath file) ".clj"))
                                (.listFiles (clojure.java.io/file "src/dungeon_crusade/quests")))))

         ;; get a list of all the quests that have been loaded
         quests (map deref (flatten (map #(-> % ns-publics vals)
                                          (filter #(.contains (-> % ns-name str)
                                                              "robinson.quests")
                                                   (all-ns)))))
        quest-map (apply hash-map (mapcat (fn [i] [(i :id) i]) quests))
        _ (doall (map #(info "Loaded quest" (% :name)) quests))
        _ (info "dialogs" (apply merge (map :dialog quests)))
        dialog (apply merge (map (fn [[k v]]
                                   {k (dialog->fsm v)})
                                 (apply merge (map :dialog quests))))
        state {:world world :screen terminal :quests quest-map :dialog dialog}
        state (reduce (fn [state _] (add-npcs state 1)) state (range 5))]

    ;; tick once using the rest (.) command to update visibility
    (tick state \.)))

(ns robinson.main
  (:use    clojure.pprint
           robinson.common
           [robinson.worldgen :exclude [-main]]
           robinson.dialog
           robinson.npc
           robinson.update
           [robinson.monstergen :exclude [-main]]
           robinson.render)
  (:require
            [robinson.swingterminal :as swingterminal]
            clojure.edn
            ;[lanterna.screen :as s]
            [taoensso.timbre :as timbre]
            [clojure.core.async :as async]))

(timbre/refer-timbre)

(timbre/set-config! [] (read-string (slurp "config/timbre.clj")))

(defn tick
  "The game loop.

   Take the current state, render it, wait for player input, then update
   the state using the player's input and return the new state. Save the
   world too, in case the  game is interrupted. Then we can load it next
   time we start up."
  ([state]
   (let [keyin (swingterminal/wait-for-key (state :screen))]
     (if keyin
       (tick state keyin)
       state)))
  ([state keyin]
    (do
      (info "got " (str keyin) " type " (type keyin))
      (log-time "tick"
        (let [new-state (log-time "update-state" (update-state state keyin))]
          (log-time "render" (render new-state))
          (async/thread (spit "save/world.edn" (prn-str (new-state :world))))
          ;(async/thread (spit "save/world.edn" (with-out-str (pprint (new-state :world)))))
          new-state)))))

;; Example setup and tick fns
(defn setup
  "Create the intial `state` value.

   `state` contains

   * a `:world` that contains places, npcs, a player

   * a `:screen` to render the world

   * `quests` that are loaded dynamically on startup."
  []
  (let [terminal  (swingterminal/make-terminal 80 24)
        world (if (.exists (clojure.java.io/file "save/world.edn"))
                (->> (slurp "save/world.edn")
                     (clojure.edn/read-string {:readers {'robinson.monstergen.Monster map->Monster}}))
                (init-world))
         ;; load quests
         _ (doall (map #(load-file (.getPath %))
                        (filter (fn [file] (.endsWith (.getPath file) ".clj"))
                                (.listFiles (clojure.java.io/file "src/robinson/quests")))))

         ;; get a list of all the quests that have been loaded
         quests (map deref (flatten (map #(-> % ns-publics vals)
                                          (filter #(.contains (-> % ns-name str)
                                                              "robinson.quests")
                                                   (all-ns)))))
        quest-map (apply hash-map (mapcat (fn [i] [(i :id) i]) quests))
        _ (doall (map #(info "Loaded quest" (% :name)) quests))
        _ (info "dialogs" (apply merge (map :dialog quests)))
        dialog (apply merge (map (fn [[k v]]
                                   {k (dialog->fsm v)})
                                 (apply merge (map :dialog quests))))
        state {:world world :screen terminal :quests quest-map :dialog dialog}
        state (reduce (fn [state _] (add-npcs state 1)) state (range 5))]

    ;; tick once using the rest (.) command to update visibility
    (tick state \.)))

Fix save loading

Fix save loading