Fixed multiple HA behavior

Fixed multiple HA behavior

--- src/player/core.cljs
+++ src/player/core.cljs
@@ -43,35 +43,66 @@
 (defn current-state [ha]
   (get ha (:state ha)))

+(defn extrapolate [ha now]
+  (let [;req (:next-required-transition ha)
+        ;_ (assert (or (nil? req) (<= now (first (:interval req)))) "Extrapolating beyond next transition of HA")
+        s (:state ha)
+        flows (:flows (get ha s))
+        delta (- now (:entry-time ha))
+        new-vals (map (fn [[variable flow]]
+                        [variable (+ (get ha variable) (* flow delta))])
+                      flows)]
+    (merge ha (into {} new-vals))))
+
 (defn get-var-and-flow [has ha k]
+  (assert has "Must provide has")
   (cond
     (nil? k) [0 0]
     (keyword? k) [(quantize (get ha k) precision) (get-in ha [(:state ha) :flows k] 0)]
-    (vector? k) (get-var-and-flow has (get-in has [:objects (first k)]) (second k))
+    (vector? k) (let [other-ha (get has (first k))
+                      other-state (:state other-ha)
+                      et (:entry-time ha)
+                      other-et (:entry-time other-ha)
+                      ex-other-ha (extrapolate other-ha et)
+                      [v _f] (get-var-and-flow has other-ha (second k))
+                      [exv f] (get-var-and-flow has ex-other-ha (second k))
+                      ]
+                  #_(println "remote var and flow" k "from" (keys has) "in state" other-state "=" [v f]
+                             "extrapolated from" other-et "to" et "=" [exv f])
+                  [exv f])
     :else (assert (or (nil? k) (keyword? k) (vector? k)) "Unrecognized variable lookup type")))

 (defn constant-from-expr [has ha c]
   (cond
     (number? c) c
-    (and (vector? c) (= (first c) :d)) (second (apply get-var-and-flow has ha (rest c)))
+    (and (vector? c) (= (first c) :d)) (* frame-length (second (apply get-var-and-flow has ha (rest c))))
     (vector? c) (first (get-var-and-flow has ha c))
-    (seq? c) (apply ({'+ + '- - '* * '/ /} (first c))
-                    (map #(constant-from-expr has ha %) (rest c)))))
+    (seqable? c) (apply ({'+ + '- - '* * '/ /} (first c))
+                        (map #(constant-from-expr has ha %) (rest c)))))
+
+(defn guard-satisfied? [rel v10 v20 c]
+  (let [diff (- v10 v20)]
+    (case rel
+      :gt (> diff c)
+      :geq (>= diff c)
+      :leq (<= diff c)
+      :lt (< diff c))))

 (defn simple-interval [has ha simple-guard]
   (let [rel (first simple-guard)
         c (constant-from-expr has ha (last simple-guard))
-        _ (println "Constant" (last simple-guard) "is" c)
-        _ (println ":d :x is" (constant-from-expr has ha [:d :x]))
+        ;_ (println "Constant" (last simple-guard) "is" c)
+        ;_ (println ":d :x is" (constant-from-expr has ha [:d :x]))
         v1k (second simple-guard)
         v2k (if (= (count simple-guard) 4) (third simple-guard) nil)
         [v10 v1f] (get-var-and-flow has ha v1k)
         [v20 v2f] (get-var-and-flow has ha v2k)
+        ; _ (println (str "(" v10 " + " v1f "t) - (" v20 " + " v2f "t) " (case rel :gt ">" :geq ">=" :leq "<=" :lt "<") " " c))
         ; by algebra: A0+fA*dt-B0-fB*dt-C~0 --> (fA-fB)*dt ~ (-A0 + B0 + C) --> dt ~ (-A0 + B0 + C)/(fA-fB)
         denom (- v1f v2f)
         rhs (/ (+ (- v10) v20 c)
                denom)
-        ; flip rel if denom (a constant) < 0
+        ; since we are dividing by denom, flip rel if denom (a constant) < 0
         rel (if (< denom 0)
               (case rel
                 :gt :lt
@@ -81,48 +112,41 @@
               rel)
         ; t REL rhs
         entry-time (:entry-time ha)
+        ; _ (println (:id ha) simple-guard "et" entry-time "push up" time-unit rhs "to" (+ entry-time time-unit) (+ entry-time rhs))
         min-t (+ entry-time time-unit)
         rhs (+ entry-time rhs)]
     (assert (not (nil? v10))
             "V1 must be a valid variable reference")
     (assert (not (nil? v20))
             "V2 must be a valid variable reference")
-    (assert (and (not= rhs -Infinity)
-                 (not= rhs Infinity)
-                 (not (js/Number.isNaN rhs)))
-            "RHS was not a valid number. How?")
-    ; if t is bounded from above by a number less than time-unit...
-    (if (and (< rhs min-t)
-             (#{:lt :leq} rel))
-      ;return an interval which will become empty during intersection
-      [-Infinity rhs]
-      ; being bounded from above by a number less than time-unit is no problem. all intervals are open.
-      (case rel
-        ;  < : t  < rhs --> guard is true until t exceeds rhs
-        :lt [min-t (- rhs (/ time-unit 16))]
-        ; <= : t <= rhs --> guard is true until t exceeds or equals rhs
-        :leq [min-t rhs]
-        ; >= : t >= rhs --> guard becomes true once t exceeds or equals rhs
-        :geq [(.max js/Math rhs min-t) Infinity]
-        ;  > : t  > rhs --> guard becomes true once t exceeds rhs
-        :gt [(.max js/Math (+ rhs (/ time-unit 16)) min-t) Infinity]))))
+    (cond
+      ;if RHS is +-infinity, then the guard will never flip truth value
+      (or (= rhs Infinity) (= rhs -Infinity)) (if (guard-satisfied? rel v10 v20 c)
+                                                [-Infinity Infinity]
+                                                [Infinity Infinity])
+      ; if t is bounded from above by a number less than time-unit, return an interval which will become empty during intersection
+      (and (< rhs min-t) (#{:lt :leq} rel)) [-Infinity rhs]
+      ; being bounded from below by a number less than time-unit is no problem. all intervals are open.
+      :else (case rel
+              ;  < : t  < rhs --> guard is true until t exceeds rhs
+              :lt [min-t (- rhs (/ time-unit 16))]
+              ; <= : t <= rhs --> guard is true until t exceeds or equals rhs
+              :leq [min-t rhs]
+              ; >= : t >= rhs --> guard becomes true once t exceeds or equals rhs
+              :geq [(.max js/Math rhs min-t) Infinity]
+              ;  > : t  > rhs --> guard becomes true once t exceeds rhs
+              :gt [(.max js/Math (+ rhs (/ time-unit 16)) min-t) Infinity])
+      )))

 (defn transition-interval [has ha transition]
-  ; TODO: handle cases where transition is also guarded on states
-  {:interval   (intersect-all (map #(simple-interval has ha %) (:guard transition)))
-   :id         (:id ha)
-   :transition transition})
-
-(defn extrapolate [ha now]
-  (let [req (:next-required-transition ha)
-        ;_ (assert (or (nil? req) (<= now (first (:interval req)))) "Extrapolating beyond next transition of HA")
-        s (:state ha)
-        flows (:flows (get ha s))
-        delta (- now (:entry-time ha))
-        new-vals (map (fn [[variable flow]]
-                        [variable (+ (get ha variable) (* flow delta))])
-                      flows)]
-    (merge ha (into {} new-vals))))
+  ;(println "Transition" (:id ha) (:x ha) (:target transition) (:guard transition))
+  (let [intervals (map #(simple-interval has ha %) (:guard transition))
+        interval (intersect-all intervals)]
+    ; (println "interval:" intervals "->" interval)
+    ; TODO: handle cases where transition is also guarded on states
+    {:interval   interval
+     :id         (:id ha)
+     :transition transition}))

 (defn required-transitions [ha]
   (filter #(:required (:label %)) (:edges (current-state ha))))
@@ -141,7 +165,9 @@
                      transitions))))

 (defn enter-state [has ha state now]
+  (println "enter state" (keys has) (:id ha) state now)
   (let [now (floor-time now time-unit)
+        _ (assert (>= now (:entry-time ha)) "Time must be monotonic")
         ; set the current state to this state
         ; set ha's entry-time to the current moment
         ha (assoc (extrapolate ha now) :entry-time now
@@ -150,6 +176,10 @@
                                          ha
                                          Infinity
                                          (required-transitions ha)))
+        #_(println "New required transitions" (transition-intervals has
+                                                                    ha
+                                                                    Infinity
+                                                                    (required-transitions ha)))
         ; calculate intervals when optional guards will be satisfied up to and including the upcoming required guard, if any
         opts (transition-intervals has
                                    ha
@@ -188,9 +218,10 @@
   ;todo
   false)

-(defn next-transition [ha then inputs]
+(defn next-transition [has ha then inputs]
   (let [; by definition req is after then, so it doesn't need to be filtered or checked
-        req (:next-required-transition ha)
+        ;req (:next-required-transition ha)
+        req (first (transition-intervals has ha then (required-transitions ha)))
         req-t (first (:interval req))
         ; opts on the other hand must be filtered and sliced into range
         [min-opt-t opts] (reduce (fn [[min-t trs] {[start end] :interval :as trans}]
@@ -220,13 +251,32 @@
       ; we prioritize the first-defined optional transition. this policy could change later, e.g. to be an error.
       (first opts))))

-(defn ha-dependencies [_ha] #{})
-
+(defn term-dependencies [guard-term]
+  (cond
+    ; catch [:d ID v]
+    (and (vector? guard-term) (= (first guard-term) :d) (= 3 (count guard-term))) [(second guard-term)]
+    ; catch [ID v]
+    (and (vector? guard-term) (not= (first guard-term) :d) (= 2 (count guard-term))) [(first guard-term)]
+    ; must be (+-*/ ...)
+    (and (not (vector? guard-term)) (seqable? guard-term)) (mapcat term-dependencies (rest guard-term))
+    :else []))
+
+(defn ha-dependencies [ha]
+  (let [all-guards (mapcat :guard (:edges (current-state ha)))
+        all-ha-refs (mapcat (fn [g] (mapcat term-dependencies (rest g)))
+                            all-guards)
+        ;_ (println all-ha-refs)
+        ]
+    (into #{} all-ha-refs)))
+
+(declare scene-a)
 (defn follow-transitions [has transitions]
   (let [t (first (:interval (first transitions)))
         _ (assert (every? #(= t (first (:interval %))) transitions) "All transitions must have same start time")
+        ;_ (println "Transitioning" transitions)
         ; simultaneously transition all the HAs that can transition.
         transitioned-has (map (fn [{id :id {target :target update :update} :transition}]
+                                ;(println "transitioning state-change" id (:entry-time (get has id)) "->" t)
                                 (enter-state has (update (get has id)) target t))
                               transitions)
         transitioned-ids (into #{} (map :id transitioned-has))
@@ -241,6 +291,10 @@
         reenter-has (map #(let [ha (get has %)]
                            (enter-state has ha (:state ha) t))
                          deps)]
+    #_(println "next transitions" #_reenter-has (transition-intervals has
+                                                                  (second reenter-has)
+                                                                  Infinity
+                                                                  (required-transitions (second reenter-has))))
     (merge has (zipmap (map :id reenter-has) reenter-has))))

 (defn update-scene [scene now inputs]
@@ -249,19 +303,20 @@
         has (:objects scene)
         [min-t transitions] (reduce (fn [[min-t transitions] {[start _] :interval :as trans}]
                                       (cond
+                                        (nil? trans) [min-t transitions]
                                         (< start min-t) [start [trans]]
                                         (= start min-t) [min-t (conj transitions trans)]
                                         :else [min-t transitions]))
                                     [Infinity []]
-                                    (map #(next-transition % qthen inputs) (vals has)))]
+                                    (map #(next-transition has % qthen inputs) (vals has)))]
     (cond
       (> min-t qnow) (assoc scene :now now)
-      (= min-t qnow) (assoc scene :now now
-                                  :objects (follow-transitions has transitions))
-      :else (update-scene (assoc scene :now min-t
-                                       :objects (follow-transitions has transitions))
-                          now
-                          inputs)
+      (= min-t qnow) (do #_(println "clean border") (assoc scene :now now
+                                   :objects (follow-transitions has transitions)))
+      :else (do #_(println "messy border overflow" (- now min-t)) (update-scene (assoc scene :now min-t
+                                        :objects (follow-transitions has transitions))
+                           now
+                           inputs))
       )))

 (defonce scene-a (atom {}))
@@ -276,11 +331,11 @@
              :right                                         ;name
              {:x speed}                                     ;flows
              ;edges
-             ; x < 16 && x + dx*frame >= 16 --> x >= 16 - dx*frame
-             (make-edge :left [[:lt :x 64] [:geq :x '(- 64 [:d :x])]] #{:required})
-             ; x + 16 < x2 + dx2*frame && x + dx*frame + 16 >= x2 + dx2*frame
-             ; x - x2 < -16 + dx2*frame && x - x2 >= dx2*frame - dx*frame - 16
-             (map #(make-edge :left [[:lt :x [% :x] (list '+ -16 [:d % :x])]
+             ; x + 16 < 64 --> x < 64 - 16 && x + 16 + dx*frame >= 64 --> x >= 48 - dx*frame
+             (make-edge :left [[:lt :x 48] [:geq :x '(- 48 [:d :x])]] #{:required})
+             ; x + 16 < x2 && x + dx*frame + 16 >= x2 + dx2*frame
+             ; x - x2 < -16 && x - x2 >= dx2*frame - dx*frame - 16
+             (map #(make-edge :left [[:lt :x [% :x] -16]
                                      [:geq :x [% :x] (list '- [:d % :x] [:d :x] 16)]]
                               #{:required}) others))
            (make-state
@@ -289,13 +344,13 @@
              ;edges
              ; x > 8 && x + dx*frame <= 8 --> x <= 8 - dx*frame
              (make-edge :right [[:gt :x 8] [:leq :x '(- 8 [:d :x])]] #{:required})
-             ; x > x2 + 16 + dx2 && x + dx*frame <= x2 + dx2*frame + 16 --> x - x2 > 16 + dx2 && x - x2 <= dx2*frame + 16 - dx*frame
-             ; x - x2 > 16 + dx2
-             (map #(make-edge :right [[:gt :x [% :x] (list '+ 16 [:d % :x])]
+             ; x > x2 + 16 && x + dx*frame <= x2 + dx2*frame + 16 --> x - x2 > 16 + dx2 && x - x2 <= dx2*frame + 16 - dx*frame
+             ; x - x2 > 16
+             (map #(make-edge :right [[:gt :x [% :x] 16]
                                       [:leq :x [% :x] (list '+ [:d % :x] 16 (list '- [:d :x]))]]
                               #{:required}) others))))

-(defn make-scene-a [x] (let [objects [(goomba :a x 8 8 :right #{:b}) (goomba :b (* x 4) 8 8 :left #{:a})]
+(defn make-scene-a [x] (let [objects [(goomba :a x 8 8 :right #{:b}) (goomba :b (+ x 18) 8 8 :left #{:a})]
                              obj-ids (map :id objects)
                              obj-dict (zipmap obj-ids objects)
                              ; got to let every HA enter its current (initial) state to set up state invariants like
@@ -304,38 +359,47 @@
                          {:now     0
                           :then    0
                           :playing false
+                          :pause-on-play false
                           :objects obj-dict}))
 (defn reset-scene-a! []
   (swap! scene-a (fn [_]
                    (make-scene-a 8))))

+(defn ha-states [scene]
+  (let [has (sort-by :id (vals (:objects scene)))]
+    (map (fn [ha] [(:id ha) (:state ha)]) has)))
+
 (defn tick-frame [t]
   (when-not last-time (set! last-time t))
   (when (:playing @scene-a)
     (swap! scene-a
-           (fn [s] (update-scene s
-                                 (+ (:now s) (/ (- t last-time) 1000))
-                                 #{[(floor-time (:now s) time-unit) #{}]}))))
+           (fn [s] (let [new-s (update-scene s
+                                             (+ (:now s) (/ (- t last-time) 1000))
+                                             #{[(floor-time (:now s) time-unit) #{}]})]
+                     (if (and (:pause-on-play new-s)
+                              (not= (ha-states s) (ha-states new-s)))
+                       (assoc new-s :playing false)
+                       new-s)))))
   (set! last-time t)
   (.requestAnimationFrame js/window tick-frame))
 (when (= @scene-a {})
   (.requestAnimationFrame js/window tick-frame)
   (reset-scene-a!))

-(defcard ha-data
-         (fn [scene _owner]
-           (let [a (get-in @scene [:objects :a])
-                 b (get-in @scene [:objects :b])
-                 desc (fn [ha]
-                        [[:div "Required transitions:" (str (required-transitions ha))]
-                         [:div "Next required transition:" (str (:next-required-transition ha))]
-                         [:div "Optional transitions:" (str (optional-transitions ha))]
-                         [:div "Intervals:" (str (:optional-transitions ha))]])]
-             (sab/html [:div
-                        (concat
-                          (desc a)
-                          (desc b))])))
-         scene-a)
+#_(defcard ha-data
+           (fn [scene _owner]
+             (let [a (get-in @scene [:objects :a])
+                   b (get-in @scene [:objects :b])
+                   desc (fn [ha]
+                          [[:div "Required transitions:" (str (required-transitions ha))]
+                           [:div "Next required transition:" (str (:next-required-transition ha))]
+                           [:div "Optional transitions:" (str (optional-transitions ha))]
+                           [:div "Intervals:" (str (:optional-transitions ha))]])]
+               (sab/html [:div
+                          (concat
+                            (desc a)
+                            (desc b))])))
+           scene-a)

 #_(defcard sample-time
            "What are the current values of the variables of object a?"
@@ -344,34 +408,57 @@
               (extrapolate (get-in @scene [:objects :a]) (get-in @scene [:now]))])
            scene-a)

+#_(defcard ha-deps
+         (fn [scene _owner]
+           [(ha-dependencies (get-in @scene [:objects :a])) (ha-dependencies (get-in @scene [:objects :b]))])
+         scene-a)
+
+(defcard ha-states-card
+         (fn [scene _owner]
+           (ha-states @scene))
+         scene-a)
+
 (defcard draw-scene
          (fn [scene _owner]
            (let [scale 2
-                 view-h (str (* scale 240) "px")]
+                 view-h (str (* scale 240) "px")
+                 ct (count (:objects @scene))
+                 line-h (/ (* scale 240) ct)]
              (sab/html [:div {:style {:backgroundColor "blue" :width (str (* scale 320) "px") :height view-h :position "relative"}}
-                        (map (fn [{x :x y :y w :w h :h :as ha}]
-                               [:div
-                                (map (fn [trans]
-                                       (println trans (:target trans))
-                                       (let [[s e] (:interval trans)
-                                             sx (* scale (:x (extrapolate ha s)))
-                                             ex (* scale (:x (extrapolate ha e)))]
-                                         [:div {:style {:height view-h :width (.abs js/Math (- sx ex)) :position :absolute :left (.min js/Math sx ex) :backgroundColor "grey"}}
-                                          [:div {:style {:position :absolute :top "64px" :width "200px"}} (str (:id ha) "-" (:target (:transition trans)))]
-                                          [:div {:style {:height view-h :width (* scale 2) :backgroundColor "red"}}]
-                                          [:div {:style {:height view-h :width (* scale 2) :backgroundColor "green"}}]]))
-                                     (vector (first (transition-intervals (:objects scene)
-                                                                 ha
-                                                                 Infinity
-                                                                 (required-transitions ha)))))])
-                             (map #(extrapolate % (:now @scene)) (vals (:objects @scene))))
+                        (map (fn [{x :x y :y w :w h :h :as ha} i]
+                               (let [trans-count (count (required-transitions ha))
+                                     trans-h (/ line-h trans-count)]
+                                 [:div
+                                  (map (fn [trans j]
+                                         (let [[s e] (:interval trans)
+                                               sx (* scale (:x (extrapolate ha s)))
+                                               ex (* scale (:x (extrapolate ha e)))
+                                               line-top (+ (* i line-h) (* j trans-h))]
+                                           [:div {:style {:height   trans-h :width (.abs js/Math (- sx ex))
+                                                          :top      line-top :left (.min js/Math sx ex)
+                                                          :position :absolute :backgroundColor "grey"}}
+                                            [:div {:style {:position :absolute :top "64px" :width "200px"}} (str (:id ha) "-" (:target (:transition trans)))]
+                                            [:div {:style {:height "100%" :width (* scale 2) :position :absolute :left (if (< sx ex) "0%" "100%") :backgroundColor "green"}}]
+                                            [:div {:style {:height "100%" :width (* scale 2) :position :absolute :left (if (< sx ex) "100%" "0%") :backgroundColor "red"}}]]))
+                                       (transition-intervals (:objects @scene)
+                                                             ha
+                                                             Infinity
+                                                             (required-transitions ha))
+                                       (range 0 trans-count))]))
+                             (map #(extrapolate % (:now @scene)) (vals (:objects @scene)))
+                             (range 0 ct))
                         (map (fn [{x :x y :y w :w h :h :as ha}]
                                [:div
                                 [:div {:style {:width           (str (* scale w) "px") :height (str (* scale h) "px") :borderRadius (str (* scale w) "px")
                                                :backgroundColor "brown"
-                                               :position        "absolute" :left (str (* scale x) "px") :bottom (str (* scale y) "px")}}]])
+                                               :position        "absolute" :left (str (* scale x) "px") :bottom (str (* scale y) "px")}}
+                                 (str (:id ha))]])
                              (map #(extrapolate % (:now @scene)) (vals (:objects @scene))))
-                        [:button {:onClick #(do (swap! scene (fn [s] (assoc s :playing (not (:playing s))))) true)} (if (:playing @scene) "PAUSE" "PLAY")]
+                        [:button {:onClick #(swap! scene (fn [s] (assoc s :playing (not (:playing s)))))} (if (:playing @scene) "PAUSE" "PLAY")]
+                        [:span {:style {:backgroundColor "lightgrey"}} "Pause on state change?"
+                         [:input {:type     "checkbox"
+                                  :checked  (:pause-on-play @scene)
+                                  :onChange #(swap! scene (fn [s] (assoc s :pause-on-play (.-checked (.-target %)))))}]]
                         [:button {:onClick #(reset-scene-a!)} "RESET"]])))
          scene-a)


Bring back "hyperspace core online" at startup.

Closes #104

--- src/riemann/core.clj
+++ src/riemann/core.clj
@@ -75,6 +75,8 @@

     ; Start merged services
     (dorun (pmap service/start! merged-services))
+
+    (info "Hyperspace core online")
     merged))

 (defn start!


Added test-app-data.

Added test-app-data.

--- test-phantomjs/ago/test-phantomjs.cljs
+++ test-phantomjs/ago/test-phantomjs.cljs
@@ -1,12 +1,15 @@
-; This ago.unit-test script is meant to run headless, not in a browser,
-; but instead in something like phantomjs.
+; This ago.unit-test script is meant to run headless in phantomjs.

 (ns ago.test-phantomjs
-  (:require [ago.core]))
+  (:require [ago.core :refer [make-ago-world]]))

 (def success 0)

+(defn test-app-data []
+  (assert (not= nil (make-ago-world nil)))
+  (assert (= (:app-data @(make-ago-world :my-app-data)) :my-app-data)))
+
 (defn ^:export run []
-  (.log js/console "ago unit test started.")
-  (.log js/console (+ 1 2))
+  (.log js/console "ago test-phantomjs started.")
+  (test-app-data)
   success)


CMR-3005: Add more thorough tests for humanizer transforms

--- indexer-app/test/cmr/indexer/test/data/concepts/humanizer.clj
+++ indexer-app/test/cmr/indexer/test/data/concepts/humanizer.clj
@@ -7,6 +7,31 @@
   [humanizers source expected]
   (is (= expected
          (humanizer/umm-collection->umm-collection+humanizers source humanizers))))
+
+(deftest to-human
+  (testing "trim_whitespace"
+    (are [a b] (= b (humanizer/to-human {:type "trim_whitespace"} a))
+      "TEST/value" "TEST/value"
+      "TEST  value" "TEST  value"
+      "TEST value  " "TEST value"
+      "   \t\r\nTEST value   \t\r\n" "TEST value"))
+
+  (testing "capitalize"
+    (are [a b] (= b (humanizer/to-human {:type "capitalize"} a))
+      "TEST" "Test"
+      "TestTest" "Testtest"
+      "Test Test" "Test Test"
+      "TEST-TEST" "Test-Test"
+      "TEST/TEST" "Test/Test"
+      "/TEST/TEST/" "/Test/Test/"))
+
+  (testing "alias"
+    (are [a b] (= b (humanizer/to-human {:type "alias" :replacement_value b} a))
+      "A" "B"))
+
+  (testing "ignore"
+    (are [a b] (= b (humanizer/to-human {:type "ignore"} a))
+      "A" nil)))

 (deftest humanize-collection
   (testing "humanize platform"


(SERVER-1310) Use standard errors

(SERVER-1310) Use standard errors

--- test/puppetlabs/trapperkeeper/authorization/ring_middleware_test.clj
+++ test/puppetlabs/trapperkeeper/authorization/ring_middleware_test.clj
@@ -127,27 +127,27 @@
                 (cert-from-request (testutils/url-encoded-cert
                                     testutils/test-domain-cert))))))
       (testing "fails as expected when cert not properly URL encoded"
-        (is (thrown+? [:type :bad-request
-                       :message (str "Unable to URL decode the x-client-cert header: "
+        (is (thrown+? [:kind :bad-request
+                       :msg (str "Unable to URL decode the x-client-cert header: "
                                      "For input string: \"1%\"")]
                       (cert-from-request "%1%2"))))
       (testing "fails as expected when URL encoded properly but base64 content malformed"
-        (is (thrown+? [:type :bad-request
-                       :message (str "Unable to parse x-client-cert into "
+        (is (thrown+? [:kind :bad-request
+                       :msg (str "Unable to parse x-client-cert into "
                                      "certificate: -----END CERTIFICATE not found")]
                       (cert-from-request
                        "-----BEGIN%20CERTIFICATE-----%0AM"))))
       (testing "fails when cert not in the payload"
-        (is (thrown+? [:type :bad-request
-                       :message "No certs found in PEM read from x-client-cert"]
+        (is (thrown+? [:kind :bad-request
+                       :msg "No certs found in PEM read from x-client-cert"]
                       (cert-from-request "NOCERTSHERE"))))
       (testing "fails when more than one cert is in the payload"
         (let [cert-writer (StringWriter.)
               _ (ssl-utils/cert->pem! testutils/test-domain-cert cert-writer)
               _ (ssl-utils/cert->pem! testutils/test-domain-cert cert-writer)
               certs-encoded (ring-codec/url-encode cert-writer)]
-          (is (thrown+? [:type :bad-request
-                         :message (str "Only 1 PEM should be supplied for "
+          (is (thrown+? [:kind :bad-request
+                         :msg (str "Only 1 PEM should be supplied for "
                                        "x-client-cert but 2 found")]
                         (cert-from-request certs-encoded))))))))


dont run stuff outside of main

dont run stuff outside of main

--- cljs/src/immanent/app.cljs
+++ cljs/src/immanent/app.cljs
@@ -10,5 +10,3 @@
 (defn -main []
   (r/render [state-ful-with-atom]
             (.-body js/document)))
-
-(enable-console-print!)


Non-private function

Non-private function

--- src/wireframes/renderer/bitmap.clj
+++ src/wireframes/renderer/bitmap.clj
@@ -17,7 +17,7 @@
     (.moveTo ax ay)
     (.lineTo bx by)))

-(defn- draw-wireframe [^Graphics2D g2d focal-length transform shape]
+(defn draw-wireframe [^Graphics2D g2d focal-length transform shape]
   (let [path (GeneralPath.)
         points-3d (get-3d-points transform shape)
         points-2d (get-2d-points focal-length points-3d)]


DM/RS/GG - update response test to use objective-detail page

--- test/objective8/responses_test.clj
+++ test/objective8/responses_test.clj
@@ -5,24 +5,24 @@
             [objective8.utils :as utils]))

 (fact "'Sign-in to comment' link target on objective detail view refers back to current url"
-      (-> (responses/objective-view-page {:translation (constantly "---")
-                                          :objective {}
-                                          :signed-in false
-                                          :comments []
-                                          :uri "CURRENT_PAGE_URI"})
-          (html/select [:#clj-comment-sign-in :a])
+      (-> (responses/objective-detail-page {:translation (constantly "---")
+                                            :objective {}
+                                            :signed-in false
+                                            :comments []
+                                            :uri "CURRENT_PAGE_URI"})
+          (html/select [:#clj-comment-sign-in-uri])
           first)
       => (contains {:attrs (contains {:href (contains "refer=CURRENT_PAGE_URI")})}))

 (facts "Splitting text into paragraphs"
        (fact "Newlines are turned into paragraphs"
              (responses/text->p-nodes "Hello\nWorld") =>
-             [[{:tag :p :content '("Hello") :attrs {}}]
+             [[{:tag :p :content '("Hello") :attrs {}}]
               [{:tag :p :content '("World") :attrs {}}]])

        (fact "Collapses multiple newlines into single paragraphs"
              (responses/text->p-nodes "Hello\n\n\nWorld\n\r\nFoo\n   \n \n \nBar Zap\r\t\n") =>
-             [[{:tag :p :content '("Hello") :attrs {}}]
+             [[{:tag :p :content '("Hello") :attrs {}}]
               [{:tag :p :content '("World") :attrs {}}]
               [{:tag :p :content '("Foo") :attrs {}}]
               [{:tag :p :content '("Bar Zap") :attrs {}}]])


write the corrected images, not the uncorrected images!

git-svn-id: 03a8048b5ee8463be5048a3801110fb50f378627@10501 d0ab736e-dc22-4aeb-8dc9-08def0aa14fd

--- plugins/SlideExplorer2/src/slide_explorer/flatfield.clj
+++ plugins/SlideExplorer2/src/slide_explorer/flatfield.clj
@@ -33,13 +33,19 @@

 (defn flatten-image [[index image] flat-field-by-channel]
   (let [correction (flat-field-by-channel (:nc index))]
-    (image/divide-processors image correction)))
+    [index (image/divide-processors image correction)]))
+
+;; Can I continuously update the flat field correction image for each channel,
+;; create zoomed-out versions, and then apply correction on the fly as
+;; I do with channel overlays? Memoization key here.
+;; Correction image can perhaps be generated using the remedian algorithm.
+;; See http://web.ipac.caltech.edu/staff/fmasci/home/statistics_refs/Remedian.pdf

 (defn re-flatten [in-dir out-dir flat-field-by-channel]
   (let [out-cache (tile-cache/create-tile-cache 200 out-dir false)]
     (doseq [[index image] (disk/read-tiles in-dir)]
-      (let [flattened (flatten-image [index image] flat-field-by-channel)]
-        (store/add-to-memory-tiles out-cache index image 1/256)))))
+      (let [[index2 image2] (flatten-image [index image] flat-field-by-channel)]
+        (store/add-to-memory-tiles out-cache index2 image2 1/256)))))

 ;; testing


Use node REPL instead of Nashorn

Use node REPL instead of Nashorn

Nashorn doesn't provide a suitable async scheduler for Bluebird out of
the box and Node does.

See https://github.com/petkaantonov/bluebird/wiki/Error:-No-async-scheduler-available

--- scripts/repl.clj
+++ scripts/repl.clj
@@ -1,8 +1,8 @@
 (require
   '[cljs.repl :as repl]
-  '[cljs.repl.nashorn :as nashorn])
+  '[cljs.repl.node :as node])

 (cljs.repl/repl
- (cljs.repl.nashorn/repl-env)
+ (node/repl-env)
  :output-dir "out"
  :cache-analysis true)


fix factory for processor

fix factory for processor

--- core/src/samsara_core/kernel.clj
+++ core/src/samsara_core/kernel.clj
@@ -147,10 +147,16 @@
      :track-pipeline-time track-pipeline-time}))

-(defn create-core-processor [stream config]
-  (let [factory (or (-> stream :processor-factory)
+(defmulti create-core-processor
+  (fn [{:keys [processor-type] :as stream} config] processor-type))
+
+
+(defmethod create-core-processor :samsara-factory
+  [{:keys [id processor] :as stream} config]
+  (let [factory (or processor
                    "samsara-core.core/make-samsara-processor")
         [fns ff] (str/split factory #"/")]
+    (log/info "Loading processor[" id "]:" factory)
     ;; requiring the namespace
     (require (symbol fns))
     (let [proc-factory (resolve (symbol fns ff))]


missed a call to flatten-exception on rarely used code path

fixes #516

--- sidecar/src/figwheel_sidecar/cljs_utils/exception_parsing.clj
+++ sidecar/src/figwheel_sidecar/cljs_utils/exception_parsing.clj
@@ -62,6 +62,7 @@
 (defn parse-failed-compile [{:keys [exception-data] :as ex}]
   (if (and
        (exception-info? exception-data)
+       (:message exception-data)
        (->> exception-data :message (re-matches #"failed compiling.*")))
     (assoc ex
              :failed-compiling true
@@ -314,7 +315,7 @@
                 #(update-in % [:class] get-class-name)
                 (if message
                  [{:class class :message message}]
-                 (:exception-data exception)))
+                 (flatten-exception (:exception-data exception))))
      :stack-trace (when-not (or failed-compiling reader-exception analysis-exception)
                     (when-let [e (-> exception :exception-data flatten-exception last meta :orig-exception)]
                       (with-out-str (stack/print-cause-trace e))))
@@ -451,10 +452,10 @@
       warning-data->display-data
       formatted-exception-display-str))

-#_(-> (:reader example-ex)
-    parse-inspected-exception
-    exception-data->display-data
-    formatted-exception-display-str)
+#_(-> (example-ex :analysis-no-message) #_(:reader example-ex)
+      parse-inspected-exception
+      exception-data->display-data
+      formatted-exception-display-str)

 ;; this is only for development

@@ -483,6 +484,12 @@
                 :message "Invalid :refer, var var cljs.core.async/yep does not exist in file test.cljs",
                 :data {:tag :cljs/analysis-error},
                 :cause nil}}
+   :analysis-no-message {:class clojure.lang.ExceptionInfo,
+                         :data {:file "test.cljs"},
+                         :cause
+                         {:class clojure.lang.ExceptionInfo,
+                          :data {:tag :cljs/analysis-error},
+                          :cause nil}}
    :reader {:class clojure.lang.ExceptionInfo,
             :message "failed compiling file:test.cljs",
             :data {:file "test.cljs"},


[#8] Small refactorings on github api calls

--- api/src/api/core.clj
+++ api/src/api/core.clj
@@ -1,26 +1,16 @@
 (ns api.core
-  (:import [com.google.appengine.tools.remoteapi RemoteApiInstaller RemoteApiOptions]
+  (:import [com.gallatinsystems.common Constants]
+           [com.gallatinsystems.survey.dao SurveyDAO SurveyGroupDAO]
            [com.gallatinsystems.user.dao UserDao]
-           [com.gallatinsystems.survey.dao SurveyDAO]
-           [com.gallatinsystems.common Constants]
-           [org.apache.commons.codec.binary Base64]
+           [com.google.appengine.tools.remoteapi RemoteApiInstaller RemoteApiOptions]
            [com.google.apphosting.utils.config AppEngineWebXmlReader]
-           [java.io ByteArrayInputStream])
-  (:require [clojure.string :as str]
+           [java.io ByteArrayInputStream]
+           [org.apache.commons.codec.binary Base64])
+  (:require [clj-http.client :as http]
             [clojure.java.io :as io]
-            [clj-http.client :as http]))
+            [clojure.string :as str]))

-(def p12-dir (System/getProperty "java.io.tmpdir"))
-
-#_(let [auth-token ""
-        email ""
-        alias-map (get-alias-map instance-map)
-        instance-id (get alias-map "uat1")
-        host (str instance-id ".appspot.com")
-        port 443
-        iam-account (get-in instance-map [instance-id "serviceAccountId"])
-        p12-file (get-p12 instance-id auth-token)]
-    (get-filtered-surveys host iam-account (.getAbsolutePath p12-file) email))
+(def tmp-dir (System/getProperty "java.io.tmpdir"))

 (defn get-filtered-surveys
   [host iam-account p12-path email]
@@ -43,44 +33,42 @@
         (finally
           (.uninstall installer))))))

+(defn contents-url [path]
+  (format "https://api.github.com/repos/akvo/akvo-flow-server-config/contents%s" path))
+
+(defn headers [auth-token]
+  {"Authorization" (format "token %s" auth-token)
+   "Content-Type" "application/json"})
+
+(defn github-contents [auth-token path]
+  (:body (http/get (contents-url path)
+                   {:headers (headers auth-token)
+                    :as :json})))
+
 (defn get-instances [auth-token]
-  (let [folders (->> (http/get "https://api.github.com/repos/akvo/akvo-flow-server-config/contents/"
-                               {:headers {"Authorization" (format "token %s" auth-token)}
-                                :as :json})
-                     :body
-                     (filter #(= "dir" (:type %)))
-                     (map :name))]
-    folders))
+  (->> (github-contents auth-token "/")
+       (filter #(= "dir" (:type %)))
+       (map :name)))

 (defn get-instance-props [instance-id auth-token]
-  (let [temp-file (java.io.File/createTempFile "appengine" ".xml")
-        _ (spit temp-file
-                (String.
-                 (Base64/decodeBase64
-                  (-> (http/get (format "https://api.github.com/repos/akvo/akvo-flow-server-config/contents/%s/appengine-web.xml"
-                                        instance-id)
-                                {:headers {"Authorization" (format "token %s"
-                                                                   auth-token)}
-                                 :as :json})
-                      :body
-                      :content))))
-        ae-reader (AppEngineWebXmlReader. (System/getProperty "java.io.tmpdir")
-                                          (.getName temp-file))]
-    {:instance-id instance-id
-     :properties (.getSystemProperties (.readAppEngineWebXml ae-reader))}))
+  (let [tmp-file (java.io.File/createTempFile "appengine" ".xml")
+        _ (spit tmp-file
+                (-> (github-contents auth-token (format "/%s/appengine-web.xml" instance-id))
+                    :content
+                    Base64/decodeBase64
+                    String.))
+        ae-reader (AppEngineWebXmlReader. tmp-dir
+                                          (.getName tmp-file))]
+    (.getSystemProperties (.readAppEngineWebXml ae-reader))))

 (defn get-instance-map [auth-token]
   (let [instances (get-instances auth-token)]
-    (reduce (fn [m {:keys [properties instance-id]}]
-              (if (nil? instance-id)
-                m
-                (assoc m instance-id properties)))
+    (reduce (fn [m instance-id]
+              (try
+                (assoc m instance-id (get-instance-props instance-id auth-token))
+                (catch Exception e m)))
             {}
-            (map (fn [instance-id]
-                   (try
-                     (get-instance-props instance-id auth-token)
-                     (catch clojure.lang.ExceptionInfo e)))
-                 instances))))
+            instances)))

 (defn get-alias-map [instances-map]
   (reduce (fn [m [instance-id props]]
@@ -90,29 +78,31 @@
           {}
           instances-map))

-
-
 (defn fetch-p12
   "Fetch the p12 file from github. Save it and return the File.
   Returns nil if the file can't be found"
   [instance-id auth-token]
   (try
-    (let [bytes (-> (http/get (format
-                               "https://api.github.com/repos/akvo/akvo-flow-server-config/contents/%1$s/%1$s.p12"
-                               instance-id)
-                              {:headers {"Authorization" (str "token " auth-token)
-                                         "Content-Type" "application/json"}
-                               :as :json})
-                    :body
+    (let [bytes (-> (github-contents auth-token (format "/%1$s/%1$s.p12" instance-id))
                     :content
                     Base64/decodeBase64)
-          file (io/file p12-dir (str instance-id ".p12"))]
+          file (io/file tmp-dir (str instance-id ".p12"))]
       (io/copy bytes file)
       file)
     (catch clojure.lang.ExceptionInfo e)))

 (defn get-p12 [instance-id auth-token]
-  (let [file (io/file p12-dir (str instance-id ".p12"))]
+  (let [file (io/file tmp-dir (str instance-id ".p12"))]
     (if (.exists file)
       file
       (fetch-p12 instance-id auth-token))))
+
+#_(let [auth-token ""
+        email ""
+        alias-map (get-alias-map instance-map)
+        instance-id (get alias-map "uat1")
+        host (str instance-id ".appspot.com")
+        port 443
+        iam-account (get-in instance-map [instance-id "serviceAccountId"])
+        p12-file (get-p12 instance-id auth-token)]
+    (get-filtered-surveys host iam-account (.getAbsolutePath p12-file) email))


(c) header

(c) header


Refactored midi/notes, to make it smaller


Some cleanup

Some cleanup

--- src/cljs/todo_clj/core.cljs
+++ src/cljs/todo_clj/core.cljs
@@ -1,7 +1,7 @@
 (ns todo-clj.core
   (:require [om.core :as om :include-macros true]
             [om.dom :as dom :include-macros true]
-            [ajax.core :refer [GET POST ajax-request json-request-format json-response-format]]))
+            [ajax.core :refer [GET POST]]))

 (enable-console-print!)

@@ -18,9 +18,7 @@

 (defn add-todo [app owner]
   (let [title (.-value (om/get-node owner "new-todo"))]
-    (POST "/todos" {:handler #(om/transact! app :todos (fn [todos]
-                                                         (println (conj todos %))
-                                                         (conj todos %)))
+    (POST "/todos" {:handler #(om/transact! app :todos (fn [todos] (conj todos %)))
                     :error-handler trace
                     :params {:title title}
                     :format :json
@@ -36,7 +34,6 @@
                      :response-format :json}))
     om/IRender
     (render [_]
-      (println (:todos app))
       (dom/div nil
         (dom/h1 nil "Todo")
         (dom/div nil


Fix typo in css watcher log (#499)

Fix typo in css watcher log (#499)

--- sidecar/src/figwheel_sidecar/components/css_watcher.clj
+++ sidecar/src/figwheel_sidecar/components/css_watcher.clj
@@ -21,7 +21,7 @@
           sendable-files (map #(make-css-file %) changed-css-files)]
       (send-css-files figwheel-server sendable-files)
       (doseq [f sendable-files]
-        (println "Notifyng browser that CSS file changed:" (:file f))))))
+        (println "Notifying browser that CSS file changed:" (:file f))))))

 (defn css-watcher [{:keys [watch-paths] :as options}]
   (fsw/file-system-watcher


removing the dummy maps from the chunks-state

--- src-cljs/bitfondue/core.cljs
+++ src-cljs/bitfondue/core.cljs
@@ -6,8 +6,7 @@
 ;; define your app data so that it doesn't get over-written on reload

 (defonce app-state (atom {:text "Hello world!"}))
-(defonce chunks-state (atom '({:title "first title"}
-                              {:title "second title"})))
+(defonce chunks-state (atom '()))

 (defn hello-world []
   [:h1 (:text @app-state)])


gather canvas size in stats

gather canvas size in stats

--- src-cljs/frontend/stats.cljs
+++ src-cljs/frontend/stats.cljs
@@ -31,4 +31,5 @@
      :camera (select-keys (:camera app-state) [:x :y :zf])
      :mouse (:mouse app-state)
      :logged-in? (boolean (seq (:cust app-state)))
-     :performance (performance)}))
+     :performance (performance)
+     :canvas-size (utils/canvas-size)}))


Add function to get all selected pokemon

--- frontend/src/cruncher/utils/views.cljs
+++ frontend/src/cruncher/utils/views.cljs
@@ -81,6 +81,13 @@
   (dom/span #js {:dangerouslySetInnerHTML #js {:__html string}}))

+;;;; DOM Stuff
+(defn get-selected-pokemon
+  "Returns all selected Pokemon."
+  []
+  (vec (map #(.. % -value) (filter #(.. % -checked) (gdom/getElementsByClass "poketable-checkbox")))))
+
+
 ;;;; UIs
 (defui Loader
   ; "Spinning icon to indicate if there is data being transferred."


(SERVER-2550) Drop trailing slash on CRL update endpoint

--- src/clj/puppetlabs/services/ca/certificate_authority_core.clj
+++ src/clj/puppetlabs/services/ca/certificate_authority_core.clj
@@ -407,11 +407,10 @@
           (handle-put-certificate-request! subject body ca-settings))
         (DELETE [""] [subject]
           (handle-delete-certificate-request! subject ca-settings)))
-      (comidi/context ["/certificate_revocation_list/"]
-        (GET [[#"[^/]+" :ignored-node-name]] request
-          (handle-get-certificate-revocation-list request ca-settings))
-        (PUT [""] request
-          (handle-put-certificate-revocation-list! (:body request) ca-settings)))
+      (GET ["/certificate_revocation_list/" :ignored-node-name] request
+        (handle-get-certificate-revocation-list request ca-settings))
+      (PUT ["/certificate_revocation_list"] request
+        (handle-put-certificate-revocation-list! (:body request) ca-settings))
       (GET ["/expirations"] request
         (handle-get-ca-expirations ca-settings))
       (PUT ["/clean"] request


Fix bug with dissocing last element. Use gen-key instead gen/any-printable to avoid massive gc. Remove printlns.

--- src/aurora/btree.cljs
+++ src/aurora/btree.cljs
@@ -132,7 +132,6 @@
                  (.dissoc! (aget children ix) key min-keys)))
              result))
   (remove! [this ix min-keys]
-           (prn "remove")
            (.splice keys ix 1)
            (.splice vals ix 1)
            (when-not (nil? children)
@@ -145,7 +144,7 @@
            (when (< (alength keys) min-keys)
              (cond
               (instance? Node parent) (.rotate-left! this min-keys)
-              (== (alength keys) 0) (set! (.-root parent) (aget children 0)))))
+              (and (== (alength keys) 0) (not (nil? children))) (set! (.-root parent) (aget children 0)))))
   (rotate-left! [this min-keys]
                 (if (> parent-ix 0)
                   (let [left-node (aget (.-children parent) (- parent-ix 1))
@@ -153,7 +152,6 @@
                         left-vals (.-vals left-node)]
                     (if (> (alength left-keys) min-keys)
                       (do
-                        (prn "rotate-left")
                         (.unshift keys (.pop left-keys))
                         (.unshift vals (.pop left-vals))
                         (set! lower (aget keys 0))
@@ -167,7 +165,6 @@
                          right-vals (.-vals right-node)]
                      (if (> (alength right-keys) min-keys)
                        (do
-                         (prn "rotate-right")
                          (.push keys (.shift right-keys))
                          (.push vals (.shift right-vals))
                          (set! upper (aget keys (- (alength keys) 1)))
@@ -175,7 +172,6 @@
                        (.merge! this min-keys)))
                    (.merge! this min-keys)))
   (merge! [this min-keys]
-          (prn "merge")
           (let [separator-ix (if (> parent-ix 0) (- parent-ix 1) parent-ix)
                 left-node (aget (.-children parent) separator-ix)
                 right-node (aget (.-children parent) (+ separator-ix 1))
@@ -288,7 +284,7 @@
   (gen/one-of [gen/int gen/string-ascii]))

 (def gen-assoc
-  (gen/tuple (gen/return :assoc!) gen-key gen/any-printable))
+  (gen/tuple (gen/return :assoc!) gen-key gen-key))

 (def gen-dissoc
   (gen/tuple (gen/return :dissoc!) gen-key))
@@ -375,5 +371,29 @@
     (dc/quick-check 1000 total-prop)
     (dc/quick-check 100 (denotational-prop gen-assoc))
     (dc/quick-check 100 (denotational-prop gen-action)))
+
+  (defn f []
+    (time
+     (let [tree (tree 100)]
+       (dotimes [i 500000]
+         (.assoc! tree i (* 2 i))))))
+
+  (f)
+
+  (defn g []
+    (time
+     (let [tree (tree 100)]
+       (dotimes [i 500000]
+         (.assoc! tree (if (even? i) i (str i)) (* 2 i))))))
+
+  (g)
+
+  (defn h []
+    (time
+     (let [tree (tree 100)]
+       (dotimes [i 500000]
+         (.assoc! tree (js/Math.sin i) (* 2 i))))))
+
+  (h)
  )


Fixed issue #12

Fixed issue #12

--- src/alfresco_technical_validation/source_validation.clj
+++ src/alfresco_technical_validation/source_validation.clj
@@ -204,7 +204,7 @@
                          :stb08-stb09
                          "STB09"
                          "Uses of synchronized"
-                         true
+                         false
                          "The technology does not synchronize.")))

 (defn- stb19-avoid-none-transactions


LD controls loading bitbucket repos

LD controls loading bitbucket repos

--- src-cljs/frontend/controllers/navigation.cljs
+++ src-cljs/frontend/controllers/navigation.cljs
@@ -234,7 +234,8 @@
     ;; load orgs, collaborators, and repos.
     (api/get-orgs api-ch)
     (api/get-github-repos api-ch)
-    (api/get-bitbucket-repos api-ch))
+    (when (feature/enabled? :bitbucket)
+      (api/get-bitbucket-repos api-ch)))
   (set-page-title! "Add projects")
   (analytics/track-signup))


handle page type relationship and add more comments

--- corpusmaker.clj
+++ corpusmaker.clj
@@ -1,13 +1,13 @@
-;   Copyright (c) Olivier Grisel, 2009
-;   The use and distribution terms for this software are covered by the
-;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
-;   which can be found in the file epl-v10.html at the root of this distribution.
-;   By using this software in any fashion, you are agreeing to be bound by
-;   the terms of this license.
-;   You must not remove this notice, or any other, from this software.
+;;   Copyright (c) Olivier Grisel, 2009
+;;   The use and distribution terms for this software are covered by the
+;;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
+;;   which can be found in the file epl-v10.html at the root of this distribution.
+;;   By using this software in any fashion, you are agreeing to be bound by
+;;   the terms of this license.
+;;   You must not remove this notice, or any other, from this software.

-; corpusmaker - Clojure tools to build training dataset for machine learning
-; based NLP algorithms out of Wikimedia dumps
+;; corpusmaker - Clojure tools to build training dataset for machine learning
+;; based NLP algorithms out of Wikimedia dumps

 (ns corpusmaker
   (:require
@@ -18,23 +18,20 @@
   (:use
      [clojure.contrib.duck-streams :only (read-lines)]))

-;
-; Utilities to parse DBPedia N-TRIPLES dump to load them in a redis DB to
-; perform fast look up of wikilink => entity type
-;
+;;
+;; Utilities to parse DBPedia N-TRIPLES dump to load them in a redis DB to
+;; perform fast look up of wikilink => entity type
+;;

-; RE to parse a line of a N-TRIPLES RDF stream to find a type relationship
-; http://www.w3.org/TR/rdf-testcases/#ntriples
+;; RE to parse a line of a N-TRIPLES RDF stream to find a type relationship
+;; http://www.w3.org/TR/rdf-testcases/#ntriples
 (def *type-pattern*
   #"<([^<]+?)> <http://www.w3.org/1999/02/22-rdf-syntax-ns#type> <([^<]+?)> \.")
 (def *page-pattern*
   #"<([^<]+?)> <http://xmlns.com/foaf/0.1/page> <([^<]+?)> \.")

-(defn collect-page
-  "Parse a N-TRIPLES statement and store the [instance page] pair if match"
-  [store-func statement]
-  (let [[_ inst page] (re-find *page-pattern* statement)]
-    (when inst (store-func page inst))))
+(def *pages-db* "entities-pages")
+(def *types-db* "pages-types")

 (defn process-file [filename line-func]
   ; TODO: add start line and end line (max)
@@ -42,24 +39,47 @@
   ; http://lethain.com/entry/2009/nov/15/reading-file-in-clojure/
   (count (map line-func (read-lines filename))))

-(defn collect-pages-redis
-  [filename]
+(defn collect-page
+  "Parse a N-TRIPLES statement and store the [page entity] pair if match"
+  [statement]
+  (let [[_ entity page] (re-find *page-pattern* statement)]
+    (when entity
+      (redis/set entity page))))
+
+(defn collect-entities-to-pages
+  "Parse a N-TRIPLES file to extract and store entity - page relationships"
+  [filename server-params]
   (redis/with-server
-    {:host "127.0.0.1" :port 6379 :db 0}
-    (let [store-func #(redis/set %1 %2)
-          process-line #(collect-page store-func %)]
-      (process-file filename process-line))))
+    server-params
+    (redis/select *pages-db*)
+    (process-file filename collect-page)))

-;
-; Utilities to parse a complete Wikimedia XML dump to extract sentence that
-; contain token annotated with a wiki link that point to a page that matches a
-; named entity with a type among the classes of the DBPedia ontology:
-; Person, Organisation, Place, ...
-;
+(defn join-page-type
+  "Parse a N-TRIPLES statement and store the [page type] pair if match"
+  [statement]
+  (let [[_ entity type_] (re-find *type-pattern* statement)]
+    (when entity
+      (redis/select *pages-db*)
+      (when-let [page (redis/get entity)]
+        (redis/select *types-db*)
+        (redis/set page type_)))))

-; TODO: rewrite this using http://github.com/marktriggs/xml-picker-seq since
-; using a zipper keeps all the parsed elements in memory which is not suitable
-; for large XML chunks
+(defn collect-pages-to-types
+  "Parse a N-TRIPLES file to extract types to be joined with page db"
+  [filename server-params]
+  (redis/with-server
+    server-params
+    (process-file filename join-page-type)))
+;;
+;; Utilities to parse a complete Wikimedia XML dump to extract sentence that
+;; contain token annotated with a wiki link that point to a page that matches a
+;; named entity with a type among the classes of the DBPedia ontology:
+;; Person, Organisation, Place, ...
+;;
+
+;; TODO: rewrite this using http://github.com/marktriggs/xml-picker-seq since
+;; using a zipper keeps all the parsed elements in memory which is not suitable
+;; for large XML chunks

 (defn parse-xml
   "Zipable XML content from any common source"
@@ -70,6 +90,6 @@
   [xml] (zfx/xml-> xml :page :revision :text zfx/text))

-; sample timed run
-; (time (dorun (collect-text (parse-xml "chunk-0001.xml"))))
+;; sample timed run
+;; (time (dorun (collect-text (parse-xml "chunk-0001.xml"))))


Saving data immediately when imported

Saving data immediately when imported

--- src/booklet/core.cljs
+++ src/booklet/core.cljs
@@ -75,10 +75,11 @@
 (register-handler
   :data-import
   (fn [app-state [_ json-data]]
-    (let [current  (:data app-state)
-          new-data (clojure.walk/keywordize-keys (js->clj (.parse js/JSON json-data)))]
+    (let [new-data (clojure.walk/keywordize-keys (js->clj (.parse js/JSON json-data)))]
+      (doseq [[key item] new-data]
+        ;; Dispatch instead of just doing an assoc so that it's also saved
+        (dispatch [:data-set key item]))
       (-> app-state
-          (assoc :data (merge current new-data))
           (assoc-in [:ui-state :section] :groups)
           (assoc-in [:app-state :import] nil))
       )))


Pull streaming out of handler and send initial

--- src/civil_ci/http.clj
+++ src/civil_ci/http.clj
@@ -91,6 +91,17 @@
                                         :removed (if (empty? removed) nil removed)}))))
        key)))

+(defn state-stream
+  ([state-atom] (state-stream state-atom identity))
+  ([state-atom munge-fn]
+     (fn [request]
+       (with-channel request channel
+         (let [key (diff-watcher state-atom munge-fn
+                                 (fn [changed]
+                                   (send! channel (json/generate-string changed))))]
+           (on-close channel (fn [_] (remove-watch state-atom key)))
+           (send! channel (json/generate-string {:initial (munge-fn @state-atom)})))))))
+

 (defn build-routes [repo job-id job history key build-channel]
   (routes (POST "/steps" [:as request]
@@ -134,19 +145,12 @@
                  {:status 404 :body "Invalid run id"}))))

-
 (defn bind-routes [repo server-config jobs-config jobs-history build-channel build-buffer]
   (routes
    (GET "/jobs" []
         {:status 200 :body (json/generate-string (jobs-from-config @jobs-config))})

-   (GET "/jobs/stream" []
-        (fn [request]
-          (with-channel request channel
-            (let [key (diff-watcher jobs-config jobs-from-config
-                                    (fn [changed]
-                                      (send! channel (json/generate-string changed))))]
-              (on-close channel (fn [_] (remove-watch jobs-config key)))))))
+   (GET "/jobs/stream" [] (state-stream jobs-config jobs-from-config))

    (POST "/jobs" [id :as request]
          (let [body (slurp (:body request))


* src/clj/cljs/core.clj: exclude str from core.clj, str -> core/str

--- src/clj/cljs/core.clj
+++ src/clj/cljs/core.clj
@@ -15,7 +15,7 @@
                             memfn ns or proxy proxy-super pvalues refer-clojure reify sync time
                             when when-first when-let when-not while with-bindings with-in-str
                             with-loading-context with-local-vars with-open with-out-str with-precision with-redefs
-                            satisfies? identical? true? false? nil?
+                            satisfies? identical? true? false? nil? str

                             aget aset
                             + - * / < <= > >= == zero? pos? neg? inc dec max min mod
@@ -72,8 +72,8 @@
   ([a i]
      (list 'js* "(~{}[~{}])" a i))
   ([a i & idxs]
-     (let [astr (apply str (repeat (count idxs) "[~{}]"))]
-      `(~'js* ~(str "(~{}[~{}]" astr ")") ~a ~i ~@idxs))))
+     (let [astr (apply core/str (repeat (count idxs) "[~{}]"))]
+      `(~'js* ~(core/str "(~{}[~{}]" astr ")") ~a ~i ~@idxs))))

 (defmacro aset [a i v]
   (list 'js* "(~{}[~{}] = ~{})" a i v))
@@ -211,7 +211,7 @@
          h#))))

 (defn- protocol-prefix [psym]
-  (str (.replace (str psym) \. \$) "$"))
+  (core/str (.replace (core/str psym) \. \$) "$"))

 (def #^:private base-type
      {nil "null"
@@ -245,7 +245,7 @@

 (defmacro extend-type [tsym & impls]
   (let [resolve #(let [ret (:name (cljs.compiler/resolve-var (dissoc &env :locals) %))]
-                   (assert ret (str "Can't resolve: " %))
+                   (assert ret (core/str "Can't resolve: " %))
                    ret)
         impl-map (loop [ret {} s impls]
                    (if (seq s)
@@ -256,14 +256,14 @@
       (let [t (base-type tsym)
             assign-impls (fn [[p sigs]]
                            (let [psym (resolve p)
-                                 pfn-prefix (subs (str psym) 0 (clojure.core/inc (.lastIndexOf (str psym) ".")))]
+                                 pfn-prefix (subs (core/str psym) 0 (clojure.core/inc (.lastIndexOf (core/str psym) ".")))]
                              (cons `(aset ~psym ~t true)
                                    (map (fn [[f & meths]]
-                                          `(aset ~(symbol (str pfn-prefix f)) ~t (fn ~@meths)))
+                                          `(aset ~(symbol (core/str pfn-prefix f)) ~t (fn ~@meths)))
                                         sigs))))]
         `(do ~@(mapcat assign-impls impl-map)))
       (let [t (resolve tsym)
-            prototype-prefix (str t ".prototype.")
+            prototype-prefix (core/str t ".prototype.")
             assign-impls (fn [[p sigs]]
                            (let [psym (resolve p)
                                  pprefix (protocol-prefix psym)]
@@ -273,9 +273,9 @@
                                                       (list (with-meta (vec args) (meta sig))
                                                             (list* 'this-as tname body))))]
                                  (map (fn [[f & meths]]
-                                        `(set! ~(symbol (str prototype-prefix f)) (fn ~@(map adapt-params meths))))
+                                        `(set! ~(symbol (core/str prototype-prefix f)) (fn ~@(map adapt-params meths))))
                                       sigs))
-                               (cons `(set! ~(symbol (str prototype-prefix pprefix)) true)
+                               (cons `(set! ~(symbol (core/str prototype-prefix pprefix)) true)
                                      (mapcat (fn [[f & meths]]
                                                (if (= psym 'cljs.core.IFn)
                                                  (let [adapt-params (fn [[[targ & args :as sig] & body]]
@@ -287,16 +287,16 @@
                                                        meths (map adapt-params meths)
                                                        tsym (gensym "tsym")
                                                        argsym (gensym "args")]
-                                                    [`(set! ~(symbol (str prototype-prefix 'call)) (fn ~@meths))
-                                                     `(set! ~(symbol (str prototype-prefix 'apply))
+                                                    [`(set! ~(symbol (core/str prototype-prefix 'call)) (fn ~@meths))
+                                                     `(set! ~(symbol (core/str prototype-prefix 'apply))
                                                             (fn ~(with-meta [tsym argsym] (meta (first meths)))
                                                               (.apply (.-call ~tsym) ~tsym
                                                                       (.concat (array ~tsym) (aclone ~argsym)))))])
-                                                 (let [pf (str prototype-prefix pprefix f)]
+                                                 (let [pf (core/str prototype-prefix pprefix f)]
                                                    (if (vector? (first meths))
-                                                     [`(set! ~(symbol (str pf "$arity$" (count (first meths)))) (fn ~@meths))]
+                                                     [`(set! ~(symbol (core/str pf "$arity$" (count (first meths)))) (fn ~@meths))]
                                                      (map (fn [[sig & body :as meth]]
-                                                            `(set! ~(symbol (str pf "$arity$" (count sig)))
+                                                            `(set! ~(symbol (core/str pf "$arity$" (count sig)))
                                                                    (fn ~meth)))
                                                           meths)))))
                                              sigs)))))]
@@ -323,12 +323,12 @@
     (if (seq impls)
       `(do
          (deftype* ~t ~fields)
-         (set! (.-cljs$core$IPrintable$_pr_seq ~t) (fn [this#] (list ~(str r))))
+         (set! (.-cljs$core$IPrintable$_pr_seq ~t) (fn [this#] (list ~(core/str r))))
          (extend-type ~t ~@(dt->et impls))
          ~t)
       `(do
          (deftype* ~t ~fields)
-         (set! (.-cljs$core$IPrintable$_pr_seq ~t) (fn [this#] (list ~(str r))))
+         (set! (.-cljs$core$IPrintable$_pr_seq ~t) (fn [this#] (list ~(core/str r))))
          ~t))))

 (defn- emit-defrecord
@@ -407,7 +407,7 @@
 		  `(~'-pr-seq [this# opts#]
 			      (let [pr-pair# (fn [keyval#] (pr-sequential pr-seq "" " " "" opts# keyval#))]
 				(pr-sequential
-				 pr-pair# (str "#" ~(name rname) "{") ", " "}" opts#
+				 pr-pair# (core/str "#" ~(name rname) "{") ", " "}" opts#
 				 (concat [~@(map #(list `vector (keyword %) %) base-fields)]
 					 ~'__extmap))))
 		  ])]
@@ -417,14 +417,14 @@

 (defn- build-positional-factory
   [rsym rname fields]
-  (let [fn-name (symbol (str '-> rsym))]
+  (let [fn-name (symbol (core/str '-> rsym))]
     `(defn ~fn-name
        [~@fields]
        (new ~rname ~@fields))))

 (defn- build-map-factory
   [rsym rname fields]
-  (let [fn-name (symbol (str 'map-> rsym))
+  (let [fn-name (symbol (core/str 'map-> rsym))
 	ms (gensym)
 	ks (map keyword fields)
 	getters (map (fn [k] `(~k ~ms)) ks)]
@@ -436,7 +436,7 @@
   (let [r (:name (cljs.compiler/resolve-var (dissoc &env :locals) rsym))]
     `(let []
        ~(emit-defrecord rsym r fields impls)
-       (set! (.-cljs$core$IPrintable$_pr_seq ~r) (fn [this#] (list ~(str r))))
+       (set! (.-cljs$core$IPrintable$_pr_seq ~r) (fn [this#] (list ~(core/str r))))
        ~(build-positional-factory rsym r fields)
        ~(build-map-factory rsym r fields)
        ~r)))
@@ -444,25 +444,25 @@
 (defmacro defprotocol [psym & doc+methods]
   (let [p (:name (cljs.compiler/resolve-var (dissoc &env :locals) psym))
         ns-name (-> &env :ns :name)
-        fqn (fn [n] (symbol (str ns-name "." n)))
+        fqn (fn [n] (symbol (core/str ns-name "." n)))
         prefix (protocol-prefix p)
-        methods (if (string? (first doc+methods)) (next doc+methods) doc+methods)
+        methods (if (core/string? (first doc+methods)) (next doc+methods) doc+methods)
         expand-sig (fn [fname slot sig]
                      `(~sig
-                       (if (and ~(first sig) (. ~(first sig) ~(symbol (str "-" slot)))) ;; Property access needed here.
+                       (if (and ~(first sig) (. ~(first sig) ~(symbol (core/str "-" slot)))) ;; Property access needed here.
                          (. ~(first sig) ~slot ~@sig)
                          ((or
                            (aget ~(fqn fname) (goog.typeOf ~(first sig)))
                            (aget ~(fqn fname) "_")
                            (throw (missing-protocol
-                                    ~(str psym "." fname) ~(first sig))))
+                                    ~(core/str psym "." fname) ~(first sig))))
                           ~@sig))))
         method (fn [[fname & sigs]]
                  (let [sigs (take-while vector? sigs)
-                       slot (symbol (str prefix (name fname)))]
+                       slot (symbol (core/str prefix (name fname)))]
                    `(defn ~fname ~@(map (fn [sig]
                                           (expand-sig fname
-                                                      (symbol (str slot "$arity$" (count sig)))
+                                                      (symbol (core/str slot "$arity$" (count sig)))
                                                       sig))
                                         sigs))))]
     `(do
@@ -478,7 +478,7 @@
         prefix (protocol-prefix p)]
     `(let [x# ~x]
        (if (and x#
-                (. x# ~(symbol (str "-" prefix)))        ;; Need prop lookup here
+                (. x# ~(symbol (core/str "-" prefix)))        ;; Need prop lookup here
                 (not (. x# (~'hasOwnProperty ~prefix))))
 	 true
 	 (cljs.core/type_satisfies_ ~psym x#)))))
@@ -548,7 +548,7 @@
                        (split-at (if (= :>> (second args)) 3 2) args)
                        n (count clause)]
                  (cond
-                  (= 0 n) `(throw (js/Error. (str "No matching clause: " ~expr)))
+                  (= 0 n) `(throw (js/Error. (core/str "No matching clause: " ~expr)))
                   (= 1 n) a
                   (= 2 n) `(if (~pred ~a ~expr)
                              ~b
@@ -564,7 +564,7 @@
 (defmacro case [e & clauses]
   (let [default (if (odd? (count clauses))
                   (last clauses)
-                  `(throw (js/Error. (str "No matching clause: " ~e))))
+                  `(throw (js/Error. (core/str "No matching clause: " ~e))))
         pairs (partition 2 clauses)]
    `(condp = ~e
       ~@(apply concat pairs)
@@ -617,7 +617,7 @@
 (defmacro ^{:private true} assert-args [fnname & pairs]
   `(do (when-not ~(first pairs)
          (throw (IllegalArgumentException.
-                  ~(str fnname " requires " (second pairs)))))
+                  ~(core/str fnname " requires " (second pairs)))))
      ~(let [more (nnext pairs)]
         (when more
           (list* `assert-args fnname more)))))
@@ -642,7 +642,7 @@
                                 (conj (pop groups) (conj (peek groups) [k v]))
                                 (conj groups [k v])))
                             [] (partition 2 seq-exprs)))
-        err (fn [& msg] (throw (apply str msg)))
+        err (fn [& msg] (throw (apply core/str msg)))
         emit-bind (fn emit-bind [[[bind expr & mod-pairs]
                                   & [[_ next-expr] :as next-groups]]]
                     (let [giter (gensym "iter__")
@@ -712,18 +712,18 @@
   (let [xs-str (->> (repeat "~{}")
                     (take (count rest))
                     (interpose ",")
-                    (apply str))]
+                    (apply core/str))]
    (concat
-    (list 'js* (str "[" xs-str "]"))
+    (list 'js* (core/str "[" xs-str "]"))
     rest)))

 (defmacro js-obj [& rest]
   (let [kvs-str (->> (repeat "~{}:~{}")
                      (take (quot (count rest) 2))
                      (interpose ",")
-                     (apply str))]
+                     (apply core/str))]
     (concat
-     (list 'js* (str "{" kvs-str "}"))
+     (list 'js* (core/str "{" kvs-str "}"))
      rest)))

 (defmacro alength [a]
@@ -775,9 +775,9 @@
   [options & valid-keys]
   (when (seq (apply disj (apply hash-set (keys options)) valid-keys))
     (throw
-     (apply str "Only these options are valid: "
+     (apply core/str "Only these options are valid: "
 	    (first valid-keys)
-	    (map #(str ", " %) (rest valid-keys))))))
+	    (map #(core/str ", " %) (rest valid-keys))))))

 (defmacro defmulti
   "Creates a new multimethod with the associated dispatch function.
@@ -788,10 +788,10 @@
     :hierarchy  the isa? hierarchy to use for dispatching
                 defaults to the global hierarchy"
   [mm-name & options]
-  (let [docstring   (if (string? (first options))
+  (let [docstring   (if (core/string? (first options))
                       (first options)
                       nil)
-        options     (if (string? (first options))
+        options     (if (core/string? (first options))
                       (next options)
                       options)
         m           (if (map? (first options))
@@ -835,5 +835,5 @@
   [expr]
   `(let [start# (.getTime (js/Date.) ())
          ret# ~expr]
-     (prn (str "Elapsed time: " (- (.getTime (js/Date.) ()) start#) " msecs"))
+     (prn (core/str "Elapsed time: " (- (.getTime (js/Date.) ()) start#) " msecs"))
      ret#))


CLJS-325: copy over destructure, let, loop to cljs.core to fix destructuring

Copy & paste from clojure.core with adjustments to make things work
again and remove some metadata.

--- src/clj/cljs/core.clj
+++ src/clj/cljs/core.clj
@@ -9,7 +9,7 @@
 (ns cljs.core
   (:refer-clojure :exclude [-> ->> .. amap and areduce alength aclone assert binding bound-fn case comment cond condp
                             declare definline definterface defmethod defmulti defn defn- defonce
-                            defprotocol defrecord defstruct deftype delay doseq dosync dotimes doto
+                            defprotocol defrecord defstruct deftype delay destructure doseq dosync dotimes doto
                             extend-protocol extend-type fn for future gen-class gen-interface
                             if-let if-not import io! lazy-cat lazy-seq let letfn locking loop
                             memfn ns or proxy proxy-super pvalues refer-clojure reify sync time
@@ -39,9 +39,114 @@
   declare defn defn-
   doto
   extend-protocol fn for
-  if-let if-not let letfn loop
+  if-let if-not letfn
   memfn or
   when when-first when-let when-not while])
+
+(defmacro ^{:private true} assert-args [fnname & pairs]
+  `(do (when-not ~(first pairs)
+         (throw (IllegalArgumentException.
+                  ~(core/str fnname " requires " (second pairs)))))
+     ~(core/let [more (nnext pairs)]
+        (when more
+          (list* `assert-args fnname more)))))
+
+(defn destructure [bindings]
+  (core/let [bents (partition 2 bindings)
+         pb (fn pb [bvec b v]
+              (core/let [pvec
+                     (fn [bvec b val]
+                       (core/let [gvec (gensym "vec__")]
+                         (core/loop [ret (-> bvec (conj gvec) (conj val))
+                                     n 0
+                                     bs b
+                                     seen-rest? false]
+                           (if (seq bs)
+                             (core/let [firstb (first bs)]
+                               (cond
+                                 (= firstb '&) (recur (pb ret (second bs) (list `nthnext gvec n))
+                                                      n
+                                                      (nnext bs)
+                                                      true)
+                                 (= firstb :as) (pb ret (second bs) gvec)
+                                 :else (if seen-rest?
+                                         (throw (new Exception "Unsupported binding form, only :as can follow & parameter"))
+                                         (recur (pb ret firstb  (list `nth gvec n nil))
+                                                (core/inc n)
+                                                (next bs)
+                                                seen-rest?))))
+                             ret))))
+                     pmap
+                     (fn [bvec b v]
+                       (core/let [gmap (gensym "map__")
+                                  defaults (:or b)]
+                         (core/loop [ret (-> bvec (conj gmap) (conj v)
+                                             (conj gmap) (conj `(if (seq? ~gmap) (apply hash-map ~gmap) ~gmap))
+                                             ((fn [ret]
+                                                (if (:as b)
+                                                  (conj ret (:as b) gmap)
+                                                  ret))))
+                                     bes (reduce
+                                          (fn [bes entry]
+                                            (reduce #(assoc %1 %2 ((val entry) %2))
+                                                    (dissoc bes (key entry))
+                                                    ((key entry) bes)))
+                                          (dissoc b :as :or)
+                                          {:keys #(keyword (core/str %)), :strs core/str, :syms #(list `quote %)})]
+                           (if (seq bes)
+                             (core/let [bb (key (first bes))
+                                        bk (val (first bes))
+                                        has-default (contains? defaults bb)]
+                               (recur (pb ret bb (if has-default
+                                                   (list `get gmap bk (defaults bb))
+                                                   (list `get gmap bk)))
+                                      (next bes)))
+                             ret))))]
+                    (cond
+                      (symbol? b) (-> bvec (conj b) (conj v))
+                      (vector? b) (pvec bvec b v)
+                      (map? b) (pmap bvec b v)
+                      :else (throw (new Exception (core/str "Unsupported binding form: " b))))))
+         process-entry (fn [bvec b] (pb bvec (first b) (second b)))]
+        (if (every? symbol? (map first bents))
+          bindings
+          (reduce process-entry [] bents))))
+
+(defmacro let
+  "binding => binding-form init-expr
+
+  Evaluates the exprs in a lexical context in which the symbols in
+  the binding-forms are bound to their respective init-exprs or parts
+  therein."
+  [bindings & body]
+  (assert-args
+     (vector? bindings) "a vector for its binding"
+     (even? (count bindings)) "an even number of forms in binding vector")
+  `(let* ~(destructure bindings) ~@body))
+
+(defmacro loop
+  "Evaluates the exprs in a lexical context in which the symbols in
+  the binding-forms are bound to their respective init-exprs or parts
+  therein. Acts as a recur target."
+  [bindings & body]
+    (assert-args
+      (vector? bindings) "a vector for its binding"
+      (even? (count bindings)) "an even number of forms in binding vector")
+    (let [db (destructure bindings)]
+      (if (= db bindings)
+        `(loop* ~bindings ~@body)
+        (let [vs (take-nth 2 (drop 1 bindings))
+              bs (take-nth 2 bindings)
+              gs (map (fn [b] (if (symbol? b) b (gensym))) bs)
+              bfs (reduce (fn [ret [b v g]]
+                            (if (symbol? b)
+                              (conj ret g v)
+                              (conj ret g v b g)))
+                          [] (map vector bs vs gs))]
+          `(let ~bfs
+             (loop* ~(vec (interleave gs gs))
+               (let ~(vec (interleave bs gs))
+                 ~@body)))))))

 (def fast-path-protocols
   "protocol fqn -> [partition number, bit]"
@@ -774,14 +879,6 @@
           (throw (js/Error.
                   (cljs.core/str "Assert failed: " ~message "\n" (cljs.core/pr-str '~x))))))))

-(defmacro ^{:private true} assert-args [fnname & pairs]
-  `(do (when-not ~(first pairs)
-         (throw (IllegalArgumentException.
-                  ~(core/str fnname " requires " (second pairs)))))
-     ~(let [more (nnext pairs)]
-        (when more
-          (list* `assert-args fnname more)))))
-
 (defmacro for
   "List comprehension. Takes a vector of one or more
    binding-form/collection-expr pairs, each followed by zero or more


another crash fix attempt

another crash fix attempt

--- src/clj/game/main.clj
+++ src/clj/game/main.clj
@@ -66,9 +66,9 @@
         (catch Exception e
           (println "Error " action command (get-in args [:card :title]) e "\nStack trace:"
                    (java.util.Arrays/toString (.getStackTrace e)))
-          (when-let [state (@game-states gameid)]
+          (if (and state (#{"do" "start"} action))
             (.send socket (generate-string state))
-            (.send socket "error")))))))
+            (.send socket (generate-string "error"))))))))

 (defn dev []
   (println "[Dev] Listening on port 1043 for incoming commands...")


(list-unignored-files) now picks up globs from .gitignore

--- src/clj_git/index.clj
+++ src/clj_git/index.clj
@@ -246,18 +246,20 @@
         to-regex  (fn [s]
                     (if (= (first s) \/)
                       (re-pattern (str "\\./" (glob-to-regex-str (.substring s 1)) ".*"))
-                      (re-pattern (str "\\./.*" (glob-to-regex-str s) ".*"))))]
+                      (re-pattern (str "\\./.*" (glob-to-regex-str s) ".*"))))
+        gitignore-patterns  (-> (slurp ".gitignore") (clojure.string/split #"\n"))
+        buildin-patterns    [root-filter-str ".gitignore"]
+        patterns            (concat buildin-patterns gitignore-patterns)
+        filter-fn           (fn [pattern]
+                              (fn [strings]
+                                (filter #(not (re-matches (to-regex pattern) %)) strings)))
+        filters             (map filter-fn patterns)]
     (->>
       (clojure.java.io/file ".")
       (file-seq)
       (filter #(not (.isDirectory %)))
       (map #(.getPath %))
-      (filter #(not (re-matches (to-regex root-filter-str) %)))
-      (filter #(not (re-matches (to-regex ".gitignore") %)))
-      (filter #(not (re-matches (to-regex "/target") %))) ;TODO: Pick these up from .gitignore!
-      (filter #(not (re-matches (to-regex "*.swp") %)))
-      (filter #(not (re-matches (to-regex "/.lein-*") %)))
-      (filter #(not (re-matches (to-regex "/.nrepl-port") %)))
+      ((apply comp filters))
       (map #(.substring % 2))
   )
 ))


Don't canonicalize mapping before passing to user-supplied update-fn.

This could be a surprise to someone who is expecting to get, e.g., a hiccup vector.

--- src/cljs/c2/core.cljs
+++ src/cljs/c2/core.cljs
@@ -1,7 +1,7 @@
 (ns c2.core
   (:use-macros [c2.util :only [p pp timeout]])
   (:use [cljs.reader :only [read-string]]
-        [c2.dom :only [select select-all node-type append! remove! children build-dom-elem merge-dom! attr cannonicalize]])
+        [c2.dom :only [select select-all node-type append! remove! children build-dom-elem merge-dom!]])
   (:require [goog.dom :as gdom]
             [clojure.set :as set]
             [clojure.string :as string]))
@@ -100,7 +100,7 @@

     ;;For each datum, update existing nodes and add new ones
     (doseq [[idx d] (map-indexed vector data)]
-      (let [new-node (cannonicalize (mapping d idx))]
+      (let [new-node (mapping d idx)]
         ;;If there's an existing node
         (if-let [old (existing-nodes-by-key (key-fn d idx))]
           (do


two more test cases

two more test cases

--- src/cljsfmt/core.cljs
+++ src/cljsfmt/core.cljs
@@ -102,7 +102,7 @@
    :var "#'", :quote "'",  :syntax-quote "`", :unquote-splicing "~@"})

 (defn- prior-string [zloc]
-  (if-let [p (z/left zloc)]
+  (if-let [p (u/left zloc)]
     (str (prior-string p) (n/string (z/node p)))
     (if-let [p (z/up zloc)]
       (str (prior-string p) (start-element (n/tag (z/node p))))


Reorganize an HTTP server test

Reorganize an HTTP server test

--- test/picard/test/http/server.clj
+++ test/picard/test/http/server.clj
@@ -583,16 +583,20 @@
   (with-socket
     (write-socket "POST / HTTP/1.1\r\n"
                   "Connection: close\r\n"
-                  "Transfer-Encoding: chunked\r\n\r\n"
-                  "5\r\nHello\r\n5\r\nWorld\r\n0\r\n\r\n")
-
-    (is (next-msgs
-         ch1
-         :request [#(includes-hdrs {"transfer-encoding" "chunked"} %) :chunked]
-         :body    "Hello"
-         :body    "World"
-         :body    nil
-         :done    nil))
+                  "Transfer-Encoding: chunked\r\n\r\n")
+
+    (is (next-msgs
+         ch1
+         :request [#(includes-hdrs {"transfer-encoding" "chunked"} %) :chunked]))
+
+    (write-socket "5\r\nHello\r\n5\r\nWorld\r\n0\r\n\r\n")
+
+    (is (next-msgs
+         ch1
+         :body "Hello"
+         :body "World"
+         :body nil
+         :done nil))

     (is (receiving
          "HTTP/1.1 200 OK\r\n"


Make config function public.

Make config function public.


hide about box from search results page

hide about box from search results page

--- src/complico/core.clj
+++ src/complico/core.clj
@@ -12,7 +12,7 @@
             [hiccup.core :as hiccup]))

 ; url of the external search engine to use
-(def external-search-url "https://duckduckgo.com/?q=")
+(def external-search-url "https://duckduckgo.com/?iac=1&q=")

 (def home-page
   (selmer/render-file "templates/index.html" {}))


Improved algorithm for computing neighbours

Signed-off-by: Daniel Borchmann <25857343a15bf1edafebc2912e82ecf775c585c1@mailbox.tu-dresden.de>

--- src/conexp/graphics/nodes_and_connections.clj
+++ src/conexp/graphics/nodes_and_connections.clj
@@ -8,7 +8,7 @@

 (ns conexp.graphics.nodes-and-connections
   (:use [conexp.util :only (update-ns-meta!)]
-	[conexp.base :only (defvar-, defvar, round, union)]
+	[conexp.base :only (defvar-, defvar, round, union, difference)]
 	conexp.graphics.util
 	conexp.graphics.scenes
 	[clojure.contrib.core :only (-?>)])
@@ -270,11 +270,18 @@

 (defn- all-neighbored-nodes
   "Returns all directly and indirectly neighbored nodes of node."
-  [node neighbors]
-  (let [neighs (neighbors node)]
-    (if (empty? neighs)
-      #{}
-      (apply union (set neighs) (map #(all-neighbored-nodes % neighbors) neighs)))))
+  ([node neighbors]
+     (all-neighbored-nodes neighbors (set (neighbors node)) #{}))
+  ([neighbors to-process visited]
+     (if (empty? to-process)
+       visited
+       (let [next (first to-process)]
+	 (if (contains? visited next)
+	   (recur neighbors (rest to-process) visited)
+	   (let [neighs (neighbors next)]
+	     (recur neighbors
+		    (into (rest to-process) neighs)
+		    (conj visited next))))))))

 (defn all-nodes-above
   "Returns the set of all nodes above node."


removed paging models from the initial setting

--- src/crawler/model.clj
+++ src/crawler/model.clj
@@ -2,7 +2,8 @@
   "Contains code to read and process a
    sampled model"
   (:require [clojure.java.io :as io]
-            [crawler.dom :as dom])
+            [crawler.dom :as dom]
+            [structural-similarity.xpath-text :as similarity])
   (:import [java.io PushbackReader]))

 (defn read-model
@@ -120,3 +121,96 @@
             consecs  (map vector reversed (rest reversed))]
         (some (fn [[x y]] (= x y)) consecs)))
     a-model)))
+
+(defn find-pagination
+  [action-seq corpus]
+  (let [paths (reductions
+               (fn [acc x]
+                 (cons x acc))
+               nil
+               (reverse action-seq))]
+    (reduce
+     (fn [acc a-path]
+       (merge-with
+        clojure.set/union
+        acc
+        (let [items (map
+                     first
+                     (filter
+                      (fn [[url stuff]]
+                        (= (:src-xpath stuff) a-path))
+                      corpus))
+
+              dests (filter
+                     (fn [[u x]]
+                       (some #{(:src-url x)} (set items)))
+                     corpus)
+
+              paging-candidates (filter
+                                 (fn [[u x]]
+                                   (let [b1 (:body x)
+                                         b2 (:body
+                                             (corpus
+                                              (:src-url x)))]
+                                     (similarity/similar? b1 b2)))
+                                 dests)]
+          (reduce
+           (fn [acc [u x]]
+             (merge-with
+              clojure.set/union
+              acc
+              {:to-remove
+               (set
+                [(cons
+                  (first
+                   (:src-xpath x))
+                  a-path)])
+
+               :paging
+               (set [[a-path (first (:src-xpath x))]])}))
+           {}
+           paging-candidates))))
+     {}
+     paths)))
+
+(defn planned-model
+  "First we plan it.
+   For each plan we find a pagination and a filter module
+   and remove them from the planned setup"
+  [a-model-file a-corpus-file]
+  (let [model        (read-model a-model-file)
+        init-planned (plan model)
+        corpus       (read-corpus a-corpus-file)
+        {paging :paging
+         remove :to-remove}
+        (reduce
+         (fn [acc [action-seq n]]
+           (merge-with
+            clojure.set/union
+            acc
+            (find-pagination action-seq corpus)))
+         {}
+         init-planned)
+
+        prefix-match (fn [prefix x]
+                       (let [rx (reverse x)]
+                        (reduce
+                         #(and %1 %2)
+                         (map
+                          (fn [i]
+                            (= (nth prefix i)
+                               (nth rx i)))
+                          (range
+                           (count prefix))))))]
+    (into
+     {}
+     (filter
+      (fn [[action-seq n]]
+        (not
+         (reduce
+          #(or %1 %2)
+          (map
+           (fn [prefix]
+             (prefix-match prefix action-seq))
+           remove))))
+      init-planned))))


add select, follow naming idioms

add select, follow naming idioms

--- src/crucible/core.clj
+++ src/crucible/core.clj
@@ -16,8 +16,14 @@
   ([r att]
    [:ref r att]))

-(defn join
-  ([v]
+(defn join
+  ([vals]
    [:fn [:join {:delimiter "" :values v}]])
-  ([delimiter v]
+  ([delimiter vals]
    [:fn [:join {:delimiter delimiter :values v}]]))
+
+(defn select
+  [i vals]
+  [:fn [:select {:index i :values vals}]])
+
+


Upgrade karma-junit-reporter to 2.0.1

Upgrade karma-junit-reporter to 2.0.1

--- src/deps.cljs
+++ src/deps.cljs
@@ -2,4 +2,4 @@
                 "karma"                 "4.3.0"
                 "karma-chrome-launcher" "3.1.0"
                 "karma-cljs-test"       "0.1.0"
-                "karma-junit-reporter"  "1.2.0"}}
+                "karma-junit-reporter"  "2.0.1"}}


Focus management #38

Focus management #38

--- src/flatgui/focus.clj
+++ src/flatgui/focus.clj
@@ -343,7 +343,8 @@
                            (got-trigger))
                          ;; Just give chance further
                          :else
-                         (got-trigger))))
+                         (got-trigger)))
+        old-focus-state)

       :else ; Neither event type - ignore
       old-focus-state)))


remove comments

remove comments

--- worker/src/worker/core.cljs
+++ worker/src/worker/core.cljs
@@ -52,25 +52,6 @@
 (.then (do-some-wrk2) #(println %))
 (.then (do-some-wrk2) #(println %))
 (.then (do-some-wrk2) #(println %))
-  ; (dispatch/run #(println %))
-  ; (dispatch/run #(println %))
-  ; (dispatch/run #(println %))

-  ; (async)
-
-  ; (enable-console-print!)
-  ; (w/add-worker)
-  ; (w/add-worker)
-  ; (println (map #(.. % -onmessage) @w/worker-pool-arr))
-  ; (println (w/get-worker))
-  ; (println (map #(.. % -onmessage) @w/worker-pool-arr))
-  ; (println (w/get-worker))
-  ; (println (map #(.. % -onmessage) @w/worker-pool-arr))
-  ; (println (w/get-worker))
-  ; (println "done")
-  ; (println (js/setTimeout #() 100))
-  ; (def strt (.getTime (js/Date.)))
-  ;
-  ; (do-some-wrk)

   )


Use partition-all from clojure.core.

Use partition-all from clojure.core.

--- src/clj/fleetdb/embedded.clj
+++ src/clj/fleetdb/embedded.clj
@@ -1,6 +1,5 @@
 (ns fleetdb.embedded
-  (:use [fleetdb.util :only (def- ? spawn rassert raise)]
-        [clojure.contrib.seq-utils :only (partition-all)])
+  (:use [fleetdb.util :only (def- ? spawn rassert raise)])
   (:require (fleetdb [types :as types] [lint :as lint] [core :as core]
                      [fair-lock :as fair-lock] [file :as file])
             (clj-json [core :as json]))


acr handler #331

acr handler
#331

--- src/clj/swarmpit/handler.clj
+++ src/clj/swarmpit/handler.clj
@@ -419,7 +419,8 @@
         (->> (case registry
                :v2 (api/registries-v2 owner)
                :dockerhub (api/dockerhubs owner)
-               :ecr (api/registries-ecr owner))
+               :ecr (api/registries-ecr owner)
+               :acr (api/registries-acr owner))
              (resp-ok))
         (resp-error 400 (str "Unknown registry type [" registry "]"))))))

@@ -431,7 +432,8 @@
         (->> (case registry
                :v2 (api/registry-v2 id)
                :dockerhub (api/dockerhub id)
-               :ecr (api/registry-ecr id))
+               :ecr (api/registry-ecr id)
+               :acr (api/registry-acr id))
              (resp-ok))
         (resp-error 400 (str "Unknown registry type [" registry "]"))))))

@@ -443,7 +445,8 @@
         (do (case registry
               :v2 (api/delete-v2-registry id)
               :dockerhub (api/delete-dockerhub id)
-              :ecr (api/delete-ecr-registry id))
+              :ecr (api/delete-ecr-registry id)
+              :acr (api/delete-acr-registry id))
             (resp-ok))
         (resp-error 400 (str "Unknown registry type [" registry "]"))))))

@@ -455,7 +458,8 @@
         (->> (case registry
                :v2 (api/registry-v2-repositories id)
                :dockerhub (api/dockerhub-repositories id)
-               :ecr (api/registry-ecr-repositories id))
+               :ecr (api/registry-ecr-repositories id)
+               :acr (api/registry-acr-repositories id))
              (resp-ok))
         (resp-error 400 (str "Unknown registry type " registry))))))

@@ -495,6 +499,19 @@
     (catch Exception e
       (resp-error 400 (get-in (ex-data e) [:body :error])))))

+(defmethod registry-create :acr
+  [_ payload]
+  (try
+    (let [url (api/acr-url payload)
+          payload (assoc payload :url url)
+          info (api/registry-acr-info payload)
+          response (api/create-acr-registry payload)]
+      (if (some? response)
+        (resp-created (select-keys response [:id]))
+        (resp-error 400 "Azure ACR account with given service principals already linked")))
+    (catch Exception e
+      (resp-error 400 (get-in (ex-data e) [:body :error])))))
+
 (defmethod dispatch :registry-create [_]
   (fn [{:keys [params identity route-params]}]
     (let [owner (get-in identity [:usr :username])
@@ -535,6 +552,15 @@
     (catch Exception e
       (resp-error 400 (get-in (ex-data e) [:body :error])))))

+(defmethod registry-update :acr
+  [_ payload id]
+  (try
+    (api/registry-acr-info payload)
+    (api/update-acr-registry id payload)
+    (resp-ok)
+    (catch Exception e
+      (resp-error 400 (get-in (ex-data e) [:body :error])))))
+
 (defmethod dispatch :registry-update [_]
   (fn [{:keys [route-params params]}]
     (let [payload (keywordize-keys params)


Update SPARQL endpoint URL

Update SPARQL endpoint URL

--- src/cljs/db_quiz/config.cljs
+++ src/cljs/db_quiz/config.cljs
@@ -19,8 +19,8 @@
              :missed "#333333"
              :player-1 "#fc4349"
              :player-2 "#354d65"}
-   :data {:sparql {:endpoint-urls {:cs "https://doc.lmcloud.vse.cz:8443/sparql"
-                                   :en "https://doc.lmcloud.vse.cz:8443/sparql"}
+   :data {:sparql {:endpoint-urls {:cs "https://xtest.vse.cz/virtuoso-dbquiz/sparql"
+                                   :en "https://xtest.vse.cz/virtuoso-dbquiz/sparql"}
                    :query-files {:cs {:alphabetic "sparql/cs_dbpedia_az.mustache"
                                       :numeric "sparql/cs_dbpedia.mustache"}
                                  :en {:alphabetic ""


Corrected deprecation problem, closing issue #12

--- src/clojure_rest/handler.clj
+++ src/clojure_rest/handler.clj
@@ -10,6 +10,6 @@
 ; ------------------- APP CONFIG

 (def app
-  (-> (handler/api config-routes/app-routes)
+  (-> config-routes/app-routes
       (ring-json/wrap-json-body  {:keywords? true :bigdecimals? true})
       (ring-json/wrap-json-response)))


Define config/avow! to wrap avow-config! on @config.

--- src/incise/config.clj
+++ src/incise/config.clj
@@ -18,6 +18,8 @@
   [(comp string? :in-dir) "must have an input dir"]
   [(comp string? :out-dir) "must have an output dir"])

+(defn avow! [] (avow-config! @config))
+
 (defn get [& more]
   (if (empty? more)
     @config


Update ioframes.clj

Update ioframes.clj

--- src/iyye/ioframes.clj
+++ src/iyye/ioframes.clj
@@ -29,7 +29,12 @@
 ; list of IOs

 (defn process-input [IO input]
-  (log/info (str (:name IO) input))
+  (log/info (str "in: " (:name IO) input))
   (for [func (map :input-listeners-list IO)
         :when func] (func input))
-  (persistence/write-io-to-db IO input))
+  (persistence/write-io-to-db IO :input input))
+
+(defn process-output [IO output]
+  (log/info (str "out:" (:name IO) output))
+  ((first (:outputs-list (:outputs-list IO))) output)
+  (persistence/write-io-to-db IO :output output))


Add dev alias for vault.blob.core as blob.

--- dev/user.clj
+++ dev/user.clj
@@ -1,4 +1,8 @@
 (ns user
   (:require
     [clojure.java.io :as io]
-    [clojure.string :as str]))
+    [clojure.string :as str]
+    (puget
+      data
+      [printer :as puget])
+    [vault.blob.core :as blob]))


don't show the started system in go

don't show the started system in go

--- dev/user.clj
+++ dev/user.clj
@@ -33,7 +33,8 @@
   "Initializes the current development system and starts it running."
   []
   (init)
-  (start))
+  (start)
+  true)

 (defn reset []
   (stop)


Add better testing helpers on user ns.

Add better testing helpers on user ns.

--- dev/user.clj
+++ dev/user.clj
@@ -1,24 +1,20 @@
 (ns user
+  (:refer-clojure :exclude [test])
   (:require [clojure.tools.namespace.repl :as repl]
             [clojure.pprint :refer [pprint]]
             [clojure.test :as test]))

+(defn test
+  ([] (test #"^catacumba.tests.*"))
+  ([o]
+   (repl/refresh)
+   (cond
+     (instance? java.util.regex.Pattern o)
+     (test/run-all-tests o)

-(defonce ^:dynamic
-  *namespaces*
-  ['catacumba.core-tests
-   'catacumba.sse-tests
-   'catacumba.ring-tests
-   'catacumba.handlers-tests
-   'catacumba.websocket-tests])
+     (symbol? o)
+     (if-let [sns (namespace o)]
+       (do (require (symbol sns))
+           (test/test-vars [(resolve o)]))
+       (test/test-ns o)))))

-(defn run-tests'
-  []
-  (apply test/run-tests *namespaces*))
-
-(defn run-tests
-  [& nss]
-  (if (pos? (count nss))
-    (binding [*namespaces* nss]
-      (repl/refresh :after 'user/run-tests'))
-    (repl/refresh :after 'user/run-tests')))