Updated autoencoder to test an MRT network (both decode and classify layers)

--- examples/dropout/src/dropout/autoencoder.clj
+++ examples/dropout/src/dropout/autoencoder.clj
@@ -26,12 +26,19 @@
   (gpu-desc/build-and-create-network description))

+(defn single-target-network
+  [network-desc]
+  {:network-desc network-desc
+   :loss-fn (opt/mse-loss)
+   :labels {:training @training-data :test @test-data}})
+
+
 (defn create-linear
   []
   (let [network-desc [(desc/input 28 28 1)
                       (desc/linear->relu 144)
                       (desc/linear 784)]]
-    (build-and-create-network network-desc)))
+    (single-target-network network-desc)))

 (defn create-logistic
@@ -39,7 +46,7 @@
   (let [network-desc [(desc/input 28 28 1)
                       (desc/linear->logistic 144)
                       (desc/linear 784)]]
-    (build-and-create-network network-desc)))
+    (single-target-network network-desc)))

@@ -50,7 +57,7 @@
                       (desc/linear->relu 144 :l2-max-constraint 2.0)
                       (desc/dropout 0.5)
                       (desc/linear 784)]]
-    (build-and-create-network network-desc)))
+    (single-target-network network-desc)))

 (defn create-dropout-logistic-full
@@ -60,35 +67,50 @@
                       (desc/linear->logistic 144 :l2-max-constraint 2.0)
                       (desc/dropout 0.5)
                       (desc/linear 784)]]
-    (build-and-create-network network-desc)))
+    (single-target-network network-desc)))
+
+(defn create-multi-target-dropout
+  []
+  (let [network-desc [(desc/input 28 28 1)
+                      (desc/dropout 0.8)
+                      (desc/linear->logistic 144 :l2-max-constraint 2.0)
+                      (desc/dropout 0.5)
+                      ;;Note carefully the order of the leaves of the network.  There
+                      ;;is currently an implicit dependency here on that order, the order
+                      ;;of the loss functions and the order of the training and test
+                      ;;labels which is probably an argument to specify all of that
+                      ;;in the network description
+                      (desc/split [[(desc/linear 784)] [(desc/linear->softmax 10)]])]
+        labels {:training [@training-data @training-labels]
+                :test [@test-data @test-labels]}
+        loss-fn [(opt/mse-loss) (opt/softmax-loss)]]
+    {:network-desc network-desc
+     :labels labels
+     :loss-fn loss-fn}))

 (defn train-and-evaluate
-  [network optimiser {:keys [dataset cv-dataset] :as train-config}]
-  (let [n-epochs 20
-        batch-size 10
-        loss-fn (opt/mse-loss)
-        full-train-config
-        (merge train-config (gpu-train/make-training-config network optimiser loss-fn
-                                                            batch-size n-epochs
-                                                            dataset cv-dataset))
-
-        train-config (dissoc full-train-config :gpu-cv-dataset)
-        train-config (gpu-train/train-uploaded-train-config train-config)
-        train-config (assoc train-config :gpu-cv-dataset (:gpu-cv-dataset full-train-config))
-        loss (gpu-train/evaluate-training-network train-config)]
-    {:network (vec (flatten (desc/network->description network)))
-     :score loss}))
+  [network-params optimiser]
+  (resource/with-resource-context
+   (let [n-epochs 20
+         batch-size 10
+         {:keys [network-desc loss-fn labels]} network-params
+         network (build-and-create-network network-desc)
+         training-labels (get labels :training)
+         network (gpu-train/train network optimiser loss-fn @training-data training-labels
+                                  batch-size n-epochs)]
+     {:network (vec (flatten (desc/network->description network)))})))

 (defonce networks (atom nil))

 (defn train-network
-  [[network-entry opt-entry] train-config]
+  [[network-entry opt-entry]]
   (let [[net-name network-fn] network-entry
         [opt-name opt-fn] opt-entry
-        network-and-score (train-and-evaluate (network-fn) (opt-fn) train-config)]
+        _ (println "training" net-name)
+        network-and-score (train-and-evaluate (network-fn) (opt-fn))]
     (swap! networks assoc [net-name opt-name]
            network-and-score)))

@@ -96,25 +118,20 @@
 (defn train-networks
   []
   (let [opt-fns {:adam opt/adam}
-        network-fns {:linear create-linear
-                     :logistic create-logistic
-                     :linear-dropout-full create-dropout-full
-                     :logistic-dropout-full create-dropout-logistic-full
+        network-fns {
+                     ;; :logistic create-logistic
+                     ;; :logistic-dropout-full create-dropout-logistic-full
+                     :multiple-target-dropout create-multi-target-dropout
                      }
         network-opts (for [opt-fn opt-fns network network-fns]
                        [network opt-fn])]
-    (resource/with-resource-context
-      (try
-       (with-bindings {#'cudnn/*cudnn-datatype* (float 0.0)}
-         (let [train-config (gpu-train/upload-datasets
-                             {:dataset [@training-data @training-data]
-                              :cv-dataset [@test-data @test-data]})]
-           ;;Until we start to make sense of cuda streams, there is no benefit
-           ;;of a pmap here and I was getting crashes.
-           (doall (map #(train-network % train-config) network-opts))))
-       (catch Exception e (do (println "caught error: ") (println  e) (throw e)))))
-    (map (fn [[key val]]
-           [key (:score val)]) @networks)))
+    (try
+      (with-bindings {#'cudnn/*cudnn-datatype* (float 0.0)}
+        ;;Until we start to make sense of cuda streams, there is no benefit
+        ;;of a pmap here and I was getting crashes.
+        (doall (map #(train-network %) network-opts)))
+      (catch Exception e (do (println "caught error: ") (println  e) (throw e))))
+    (keys @networks)))

 (defn check-l2-constraint
@@ -238,7 +255,7 @@

 (defn plot-network-tsne
   [net-key & {:keys [sample-count iterations]
-              :or {sample-count 2500
+              :or {sample-count 10000
                    iterations 1000}}]
   (let [_ (println "running network" net-key)
         samples (run-network net-key)


remove unnecessary requires

remove unnecessary requires

--- examples/src/worksheets/captcha_facebook.clj
+++ examples/src/worksheets/captcha_facebook.clj
@@ -17,11 +17,8 @@
             [helpers.captcha :refer [levenshtein-normalized]]
             [helpers.captcha-facebook :refer [render render-to-file abc-dist abc-sigma letter-dict oxCaptcha]]
             [helpers.general :refer [empirical-MAP]]
-            [anglican.stat :refer [collect-results]]
-            [clojure.core.matrix :as m]
-            [gorilla-repl.image :as image])
-  (:use [anglican emit runtime]
-        [gorilla-plot core])
+            [anglican.stat :refer [collect-results]])
+  (:use [anglican emit runtime])
   (:import [robots.OxCaptcha OxCaptcha]
            [javax.imageio ImageIO]
            [java.io File]))


working on improving performance and content of english/sentences

--- src/babel/english.cljc
+++ src/babel/english.cljc
@@ -107,33 +107,60 @@
   ([input model truncate?]
    (parse/parse (preprocess input) model truncate?)))

+(def tree-variants
+  [
+   {:head {:phrasal true}}
+
+   {:comp {:phrasal true}}
+
+   {:head {:phrasal true}
+    :comp {:phrasal true}}
+
+   {:head {:phrasal true}
+    :comp {:phrasal true
+           :head {:phrasal true}}}
+
+   {:comp {:phrasal true
+           :head {:phrasal true}}
+    :head {:phrasal true}}
+
+   ;; failsafe
+   {:comp {:phrasal :top
+           :head :top}}])
+
 (defn sentences [ & [count as-numbered-list spec model]]
   (let [as-numbered-list (or (nil? as-numbered-list)
                              (= as-numbered-list "true"))
         count (or (Integer. count) 100)
         model (or model (medium))
-        spec-fn (or (and spec (fn [] spec))
+        spec-fn (or (and spec (fn [] [spec]))
                     (fn []
                       (let [preds
                             (vec (set (filter #(not (= :top %))
                                               (map #(get-in % [:synsem :sem :pred] :top)
                                                    (filter #(= (get-in % [:synsem :cat]) :verb)
                                                            (flatten (vals (:lexicon (medium)))))))))]
-                        {:synsem {:sem {:pred (first (take 1 (shuffle preds)))}
-                                  :cat :verb}
-                         :head {:phrasal true
-                                :comp {:phrasal true}}
-                         :comp {:phrasal true}})))]
+                        (map (fn [variant]
+                               (merge {:synsem {:sem {:pred (first (take 1 (shuffle preds)))}
+                                                :cat :verb}}
+                                      variant))
+                             (shuffle tree-variants)))))]
     (println (str "count: " count))
-    (doall (pmap
+    (doall (map
             (fn [num]
-              (let [spec (spec-fn)
-                    expr (generate (spec-fn)
-                                   :model model)
+              (let [specs (spec-fn)
+                    expr (-> (->> (lazy-seq specs)
+                                  (map (fn [spec]
+                                         (println (str "trying spec: " spec))
+                                         (generate spec :model model)))
+                                  (remove #(= :fail %))
+                                  (take 1))
+                             first)
                     fo (morph expr :show-notes false)]
                 (let [to-print
                       (cond
-                        (empty? fo) (str "(failed: spec=" spec ")")
+                        (nil? expr) (str " expr: specs=" (string/join "," specs))
+                        (empty? fo) (str " failed: specs=" (string/join "," specs))
                         true
                         (str (string/capitalize (nth fo 0))
                              (string/join "" (rest (vec fo)))


Use site-id in ComicRepository protocol method arguments

--- src/clj/comic_reader/comic_repository.clj
+++ src/clj/comic_reader/comic_repository.clj
@@ -2,10 +2,10 @@

 (defprotocol ComicRepository
   (list-sites         [this] "List all the comic sites available from this repository.")
-  (list-comics        [this site] "List all the comics available on this site.")
-  (previous-locations [this site comic-id location n] "Get up-to n locations that precede `location' in a comic.")
-  (next-locations     [this site comic-id location n] "Get up-to n locations that follow `location' in a comic.")
-  (image-tag          [this site location] "Get the hiccup image tag for this comic location."))
+  (list-comics        [this site-id] "List all the comics available on this site.")
+  (previous-locations [this site-id comic-id location n] "Get up-to n locations that precede `location' in a comic.")
+  (next-locations     [this site-id comic-id location n] "Get up-to n locations that follow `location' in a comic.")
+  (image-tag          [this site-id location] "Get the hiccup image tag for this comic location."))

 (defprotocol WritableComicRepository
   (store-sites [this sites] "Store a seq of site records.")


Make zoom more correct (take desired aspect ratio into account and center) - TODO: make less confusing and document

--- src/cljs/fractals_clojurescript/core.cljs
+++ src/cljs/fractals_clojurescript/core.cljs
@@ -23,8 +23,8 @@
 (defn render-mandelbrot!
   [{:keys [scale x0 y0 escape-radius] :as render-state}]

+  (println render-state)

-  (println render-state)

   (aset canvas "width"(.-innerWidth js/window))
   (aset canvas "height"(.-innerHeight js/window))
@@ -93,30 +93,54 @@
                                                             (- (aget e "pageY") (aget mousedown "pageY"))))))

 (set! (.-onmouseup overlay-canvas) (fn [e]
-                             (when-let [mousedown (get @app-state :mousedown)]
-                               (let [scale     (get-in @app-state [:render-data :scale])
+                                     (when-let [mousedown (get @app-state :mousedown)]
+                                       ; TODO: Make this much less confusing
+                                       (let [scale          (get-in @app-state [:render-data :scale])

-                                     old-x0    (get-in @app-state [:render-data :x0])
-                                     old-y0    (get-in @app-state [:render-data :y0])
-                                     start-x   (aget mousedown "pageX")
-                                     start-y   (aget mousedown "pageY")
-                                     finish-x  (aget e "pageX")
-                                     finish-y  (aget e "pageY")
+                                             old-x0         (get-in @app-state [:render-data :x0])
+                                             old-y0         (get-in @app-state [:render-data :y0])
+                                             start-x        (aget mousedown "pageX")
+                                             start-y        (aget mousedown "pageY")
+                                             finish-x       (aget e "pageX")
+                                             finish-y       (aget e "pageY")

-                                     width     (aget canvas "width")
-                                     height    (aget canvas "height")
+                                             width          (aget canvas "width")
+                                             height         (aget canvas "height")
+                                             aspect-ratio   (/ width height)

-                                     new-scale (/ width (/ (- finish-x start-x) scale))
-                                     new-x0    (+ old-x0 (/ start-x scale))
-                                     new-y0    (- old-y0 (/ start-y scale))]
+                                             portrait?      (< (- finish-x start-x) (- finish-y start-y))

-                                 (swap! app-state
-                                        (fn [x]
-                                          (-> x
-                                              (assoc-in [:render-data :x0] new-x0)
-                                              (assoc-in [:render-data :y0] new-y0)
-                                              (assoc-in [:render-data :scale] new-scale)
-                                              (dissoc :mousedown))))))))
+                                             new-scale      (if portrait?
+                                                              (/ height (/ (- finish-y start-y) scale))
+                                                              (/ width (/ (- finish-x start-x) scale)))
+
+                                             desired-aspect (/ (- finish-x start-x)
+                                                               (- finish-y start-y))
+
+                                             padding        (* 0.5
+                                                               (if portrait?
+                                                                 (- width (* height desired-aspect))
+                                                                 (- height (/ width desired-aspect))))
+
+                                             new-x0         (if portrait?
+                                                              (- (+ old-x0 (/ start-x scale))
+                                                                 (/ padding new-scale))
+
+                                                              (+ old-x0 (/ start-x scale)))
+
+                                             new-y0         (if portrait?
+                                                              (- old-y0 (/ start-y scale))
+
+                                                              (+ (- old-y0 (/ start-y scale))
+                                                                 (/ padding new-scale)))]
+
+                                         (swap! app-state
+                                                (fn [x]
+                                                  (-> x
+                                                      (assoc-in [:render-data :x0] new-x0)
+                                                      (assoc-in [:render-data :y0] new-y0)
+                                                      (assoc-in [:render-data :scale] new-scale)
+                                                      (dissoc :mousedown))))))))

 (defn on-js-reload []
   ;; optionally touch your app-state to force rerendering depending on


bugfix: update banner to use :formatted-version

--- src/clojupyter/kernel/middleware/base.clj
+++ src/clojupyter/kernel/middleware/base.clj
@@ -9,9 +9,8 @@
                                                                 response-mapping-transport
                                                                 parent-msgtype-pred]]
    [clojupyter.kernel.util		:as u]
+   [clojupyter.kernel.version		:as ver]
    ))
-
-(def BANNER "clojupyter-0.1.1-SNAPSHOT")

 (defn jupyter-message
   [{:keys [parent-message signer] :as ctx} resp-socket resp-msgtype response]
@@ -90,7 +89,7 @@
                         :version (clojure-version)
                         :mimetype "text/x-clojure"
                         :file_extension ".clj"}
-        :banner BANNER
+        :banner (or (:formatted-version (ver/version)) "clojupyter-v0.0.0")
         :help_links []}))))

 (def wrap-shutdown-request


Increase the default spacing between orbit samples to reduce the number of polygons needed for long orbits

--- src/cmr/spatial/orbits/swath_geometry.clj
+++ src/cmr/spatial/orbits/swath_geometry.clj
@@ -164,7 +164,7 @@
      interval-separation-s: the maximum desired time sparation in seconds
        between two edge points"
   ([orbit-parameters granule-orbit ocsds temporal]
-     (to-swath orbit-parameters granule-orbit ocsds temporal 60.0))
+     (to-swath orbit-parameters granule-orbit ocsds temporal 300.0))
   ([orbit-parameters granule-orbit ocsds temporal interval-separation-s]
      (let [ascending-crossing-time (ascending-crossing-time orbit-parameters granule-orbit ocsds)
            [start-time-s end-time-s] (temporal-offset-range temporal ascending-crossing-time)


117 query refactored

117 query refactored

--- src/etaoin/api.clj
+++ src/etaoin/api.clj
@@ -530,25 +530,21 @@
   ([driver q]
    (cond

-     (el/el? q) q
-
      (= q :active)
-     (el/el (get-active-element* driver))
+     (get-active-element* driver)

      (vector? q)
      (apply query driver q)

      :else
      (let [[loc term] (q-expand q)]
-       (el/el (find-element* driver loc term)))))
+       (find-element* driver loc term))))

   ([driver q & more]
    (letfn [(folder [el q]
              (let [[loc term] (q-expand q)]
-               (if el
-                 (el/el (find-element-from* driver el loc term))
-                 (query driver q))))]
-     (reduce folder nil (cons q more)))))
+               (find-element-from* driver el loc term)))]
+     (reduce folder (query driver q) more))))

 (defn query-all
   "Finds multiple elements on a page.
@@ -563,12 +559,12 @@

      :else
      (let [[loc term] (q-expand q)]
-       (el/els (find-elements* driver loc term)))))
+       (find-elements* driver loc term))))

   ([driver q & more]
    (let [[loc term] (q-expand (last more))
          el (apply query driver q (butlast more))]
-     (el/els (find-elements-from* driver el loc term)))))
+     (find-elements-from* driver el loc term))))

 ;;
 ;; mouse


Close test channels for less garbage.

Close test channels for less garbage.

--- src/cbfg/npr-test.cljs
+++ src/cbfg/npr-test.cljs
@@ -87,7 +87,9 @@
                                                     stream-request
                                                     server-to-client-ch)
                         cresult (atake tn cs)
-                        sresult (atake tn ss)]
+                        sresult (atake tn ss)
+                        _ (aclose tn client-to-server-ch)
+                        _ (aclose tn server-to-client-ch)]
                     (and (e n nil sresult nil)
                          (e n (:status cresult) :ok nil)
                          (e n (:items @client-atom) [2 4 6] nil)
@@ -115,7 +117,9 @@
                                                     stream-request
                                                     server-to-client-ch)
                         cresult (atake tn cs)
-                        sresult (atake tn ss)]
+                        sresult (atake tn ss)
+                        _ (aclose tn client-to-server-ch)
+                        _ (aclose tn server-to-client-ch)]
                     (and (e n nil sresult nil)
                          (e n (:status cresult) :ok nil)
                          (e n (:items @client-atom) [2 4 6 8] nil)
@@ -139,7 +143,9 @@
                                                     stream-request
                                                     server-to-client-ch)
                         cresult (atake tn cs)
-                        sresult (atake tn ss)]
+                        sresult (atake tn ss)
+                        _ (aclose tn client-to-server-ch)
+                        _ (aclose tn server-to-client-ch)]
                     (and (e n nil sresult nil)
                          (e n (:status cresult) :ok nil)
                          (e n (:items @client-atom) [2 4 6] nil)


Check coll-create name arg against regex.

--- src/cbfg/world/t2.cljs
+++ src/cbfg/world/t2.cljs
@@ -114,26 +114,27 @@

     "coll-create"
     ; TODO: Needs auth check.
-    ; TODO: Missing/bad arg check.
-    (if-let [colls (get-in server-state [:realms (:cur-realm m)
-                                         :collsets (:cur-realm-collset m)
-                                         :colls])]
-      (if (not (get (:key m) colls))
-        (let [nrev (inc (:rev server-state))
-              coll (make-coll actx nrev m)]
-          [(-> server-state
-               (assoc-in [:realms (:cur-realm m)
-                          :collsets (:cur-realm-collset m)
-                          :colls (:key m)] coll)
-               (assoc-in [:realms (:cur-realm m)
-                          :collsets (:cur-realm-collset m)
-                          :rev] nrev)
-               (assoc-in [:realms (:cur-realm m)
-                          :rev] nrev)
-               (assoc :rev nrev))
-           (assoc m :status :ok :rev nrev)])
-        [server-state (assoc m :status :exists)])
-      [server-state (assoc m :status :not-found)])
+    (if (and (:key m) (re-matches #"^[a-zA-Z][a-zA-Z0-9_-]+" (:key m)))
+      (if-let [colls (get-in server-state [:realms (:cur-realm m)
+                                           :collsets (:cur-realm-collset m)
+                                           :colls])]
+        (if (not (get (:key m) colls))
+          (let [nrev (inc (:rev server-state))
+                coll (make-coll actx nrev m)]
+            [(-> server-state
+                 (assoc-in [:realms (:cur-realm m)
+                            :collsets (:cur-realm-collset m)
+                            :colls (:key m)] coll)
+                 (assoc-in [:realms (:cur-realm m)
+                            :collsets (:cur-realm-collset m)
+                            :rev] nrev)
+                 (assoc-in [:realms (:cur-realm m)
+                            :rev] nrev)
+                 (assoc :rev nrev))
+             (assoc m :status :ok :rev nrev)])
+          [server-state (assoc m :status :exists)])
+        [server-state (assoc m :status :not-found)])
+      [server-state (assoc m :status :invalid)])

     nil))


desktop: Add styles a little to tree view

--- apps/desktop/src_front/souptitle_desktop/manager/views/tree.cljs
+++ apps/desktop/src_front/souptitle_desktop/manager/views/tree.cljs
@@ -9,14 +9,14 @@
     (fn [{:keys [content] :as node} node-comp tree]
       [:div
        [:div
-        (when (not (nil? content))
-          [:div
-           {:on-click #(swap! toggled? not)}
-           [icon :angle-right
-            {:rotate (and @toggled? 90)
-             :style {:float "left"
-                     :padding "0 5px"}}]])
-        (node-comp node)]
+        (node-comp
+         node
+         (when (not (nil? content))
+           [:div
+            {:on-click #(swap! toggled? not)
+             :style {:padding-right "5px"}}
+            [icon :angle-right
+             {:rotate (and @toggled? 90)}]]))]
        (when (not (nil? content))
          [tree content node-comp @toggled?])])))

@@ -27,36 +27,46 @@
              (map #(identity [tree-node % node-comp tree-comp])))))

 (defn tree [{:keys [content label-comp]}]
-  [tree-comp content label-comp true])
+  [:div {:style {:background-color "#303945"
+                 :height "100%"}}
+   [tree-comp content label-comp true]])

 (defstyle style
   [".node" {:font-size "14px"
             :font-family "Roboto"
             :padding "8px"
             :cursor "pointer"
-            :transition "all 450ms cubic-bezier(0.23, 1, 0.32, 1) 0ms"}
-   ["&:hover" {:background-color "#ccc"}]]
-  [".active" {:background-color "#eee"}]
+            :transition "all 450ms cubic-bezier(0.23, 1, 0.32, 1) 0ms"
+            :display "flex"
+            :flex-direction "row"
+            :align-items "center"
+            :color "#aabac7"}
+   ["&:hover" {:background-color "#1c232d"}]]
+  [".active" {:background-color "#242d3a"
+              :color "#fff"}]
   [".season" {:padding-left "18px"}]
-  [".chapter" {:padding-left "28px"}])
+  [".chapter" {:padding-left "38px"}])

 (defmulti node (fn [el] (-> el :meta :type)))

-(defmethod node :serial [{{:keys [title]} :meta id :id active? :active?}]
+(defmethod node :serial [{{:keys [title]} :meta id :id active? :active?} shevron]
   [:div
    {:on-click #(dispatch [:set-active-serial id])
     :class (str (:node style) " " (when active? (:active style)))}
-   [icon :television]
+   shevron
+   ;; [icon :television {:style {:padding-right "5px"}}]
    title])

-(defmethod node :season [{{:keys [title]} :meta id :id active? :active?}]
+(defmethod node :season [{{:keys [title]} :meta id :id active? :active?} shevron]
   [:div
    {:on-click #(dispatch [:set-active-season id])
     :class (str (:node style) " " (:season style) " " (when active? (:active style)))}
+   shevron
    title])

-(defmethod node :chapter [{{:keys [title]} :meta id :id active? :active?}]
+(defmethod node :chapter [{{:keys [title]} :meta id :id active? :active?} shevron]
   [:div
    {:on-click #(dispatch [:set-active-chapter id])
     :class (str (:node style) " " (:chapter style) " " (when active? (:active style)))}
+   shevron
    title])


Made TITANIC's implementation functional

Yeah!

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

--- src/conexp/contrib/algorithms/titanic.clj
+++ src/conexp/contrib/algorithms/titanic.clj
@@ -38,11 +38,6 @@

 ;;; TITANIC Implementation

-(defvar- closure nil
-  "Holds the closures of sets. To be rebound.")
-(defvar- set-weight nil
-  "Holds the weights of sets. To be rebound.")
-
 (defn- titanic-closure
   "Computes the closure of X by the weights of its subsets. The
   following restrictions apply:
@@ -51,9 +46,8 @@
       together with their weights, ordered by their weights,
     - X is a member of keys.

-  Also note that the variables «closure» and «set-weight» have to be
-  rebound."
-  [X X-weight base-set keys]
+  "
+  [X X-weight base-set keys set-weight closure]
   (let [keys (map first (take-while #(not= (second %) X-weight) keys))]
     (loop [Y        (apply union X (map #(closure (disj X %)) X)),
            elements (difference base-set Y)]
@@ -71,8 +65,7 @@
         Y))))

 (defn- titanic-generate
-  "Computes the next candidate set. Note that the variables «closure»
-  and «set-weight» have to be rebound."
+  "Computes the next candidate set."
   [base-set key-set]
   (set-of next [A key-set,
                 m (difference base-set A),
@@ -87,26 +80,29 @@
   the order on the weights. Note that this order has to be linear for
   this implementation to work."
   [base-set weigh max-weight weight-order]
-  (binding [closure    {},
-            set-weight (weigh [#{}])]
-    (loop [key-set #{[#{}, (set-weight #{})]}, ;keys are pairs of sets and weights
-           keys    key-set]
-      (let [candidates (titanic-generate base-set (set (map first key-set)))]
-        (set! set-weight (into set-weight (weigh candidates)))
-        (doseq [[X, X-weight] key-set]
-          (set-val! closure X (titanic-closure X X-weight base-set keys)))
-        (let [next-key-set (set-of [X w] [X candidates,
-                                          :let [w (set-weight X)]
-                                          :when (not= w
-                                                      ;;(subset-weight X)
-                                                      (minimum weight-order max-weight
-                                                               (map #(set-weight (disj X %)) X)))])]
-          (if-not (empty? next-key-set)
-            (recur next-key-set
-                   (sort (fn [X Y]
-                           (weight-order (second X) (second Y)))
-                         (concat next-key-set keys)))
-            (distinct (vals closure))))))))
+  (loop [closure    {},
+         set-weight (weigh [#{}]),
+         key-set    #{[#{}, (set-weight #{})]}, ;keys are pairs of sets and weights here
+         keys       key-set]
+    (let [candidates   (titanic-generate base-set (set (map first key-set))),
+          set-weight   (into set-weight (weigh candidates)),
+          closure      (into closure (map (fn [[X, X-weight]]
+                                            [X (titanic-closure X X-weight base-set keys set-weight closure)])
+                                          key-set)),
+          next-key-set (set-of [X w] [X candidates,
+                                      :let [w (set-weight X)]
+                                      :when (not= w
+                                                  ;;(subset-weight X)
+                                                  (minimum weight-order max-weight
+                                                           (map #(set-weight (disj X %)) X)))])]
+      (if-not (empty? next-key-set)
+        (recur closure,
+               set-weight,
+               next-key-set
+               (sort (fn [X Y]
+                       (weight-order (second X) (second Y)))
+                     (concat next-key-set keys)))
+        (distinct (vals closure))))))

 (defn titanic-keys
   "Nearly the same as titanic, but returns the key sets only."
@@ -127,7 +123,7 @@
                (concat next-key-set keys))
         keys))))

-;;;
+;;; Common use cases

 (defn supports
   "Returns a function of one argument being a collection of sets of attributes,


Bumped Clojure version.

Bumped Clojure version.

--- app/project.clj
+++ app/project.clj
@@ -3,7 +3,7 @@
   :url "http://example.com/FIXME"
   :license {:name "Eclipse Public License"
             :url "http://www.eclipse.org/legal/epl-v10.html"}
-  :dependencies [[org.clojure/clojure "1.6.0"]
+  :dependencies [[org.clojure/clojure "1.7.0-beta3"]
                  [org.clojure/tools.logging "0.3.1"]
                  [ch.qos.logback/logback-classic "1.1.3"]
                  [com.stuartsierra/component "0.2.3"]


formatting

formatting

--- src/chat/server/db.clj
+++ src/chat/server/db.clj
@@ -545,11 +545,12 @@
               user-id
               thread-pull-pattern)
          (into ()
-               (map (comp (fn [t]
-                            (update-in t [:tag-ids] (partial into #{} (filter visible-tags))))
-                          (fn [t] (thread-add-last-open-at t user-id))
-                          db->thread
-                          first))))))
+               (map (comp
+                      #(update-in % [:tag-ids]
+                                  (partial into #{} (filter visible-tags)))
+                      #(thread-add-last-open-at % user-id)
+                      db->thread
+                      first))))))

 (defn get-thread
   [conn thread-id]
@@ -748,7 +749,8 @@
          (into #{}))))

 (defn threads-with-tag
-  "Find threads with a given tag that the user is allowed to see, ordered by most recent message.
+  "Find threads with a given tag that the user is allowed to see, ordered by
+  most recent message.
   Paginates results, dropping `skip` threads and returning `limit`.
   Returns the threads and a count of how many threads remain."
   [conn user-id tag-id skip limit]
@@ -765,15 +767,16 @@
                          (map first)
                          (drop skip)
                          (take limit))]
-    {:threads (->> (d/pull-many (d/db conn) thread-pull-pattern thread-eids)
-                   (map db->thread)
-                   (filter (fn [thread] (user-can-see-thread? user-id (thread :id)))))
+    {:threads (into ()
+                    (comp (map db->thread)
+                          (filter #(user-can-see-thread? user-id (% :id))))
+                    (d/pull-many (d/db conn) thread-pull-pattern thread-eids))
      :remaining (- (count all-thread-eids) (+ skip (count thread-eids)))}))

 (defn tag-set-description!
   [conn tag-id description]
   (d/transact conn [[:db/add [:tag/id tag-id]
-                       :tag/description description]]))
+                     :tag/description description]]))

 (defn create-extension!
   [conn {:keys [id type group-id user-id config]}]
@@ -869,4 +872,3 @@
                        db->group)]
     (when (:public? (group-settings (group :id)))
       group)))
-


Fixed typo in core.

Fixed typo in core.

--- src/clj/forma/core.clj
+++ src/clj/forma/core.clj
@@ -48,7 +48,7 @@
   "Like chunk-test, but works for NOAA PRECL data files."
   [m-res ll-res c-size tile-seq dir]
   (let [source (all-files dir)
-        chunks (r/rain-chunks m-res ll-res c-size tile-seq dir)]
+        chunks (r/rain-chunks m-res ll-res c-size tile-seq source)]
     (?<- (stdout) [?dataset ?res ?period]
          (chunks ?dataset ?res ?mod-h ?mod-v ?period ?chunkid ?chunk)
          (c/count ?count))))


Select one subroutine to fire at a time.

--- src/clj/game/cards.clj
+++ src/clj/game/cards.clj
@@ -2902,8 +2902,8 @@
                  :msg (msg "reveal "
                            (join ", " (map #(str (:title %) " ("
                                                  (:label (first (:abilities (card-def %)))) ")") targets)))}
-                {:label "Resolve up to 2 Grail ICE subroutines from HQ"
-                 :choices {:max 2 :req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
+                {:label "Resolve a Grail ICE subroutine from HQ"
+                 :choices {:req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
                  :effect (req (doseq [ice targets]
                                 (resolve-ability state side (first (:abilities (card-def ice))) card nil)))}]}

@@ -3017,8 +3017,8 @@
                  :msg (msg "reveal "
                            (join ", " (map #(str (:title %) " ("
                                                  (:label (first (:abilities (card-def %)))) ")") targets)))}
-                {:label "Resolve up to 2 Grail ICE subroutines from HQ"
-                 :choices {:max 2 :req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
+                {:label "Resolve a Grail ICE subroutine from HQ"
+                 :choices {:req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
                  :effect (req (doseq [ice targets]
                                 (resolve-ability state side (first (:abilities (card-def ice))) card nil)))}]}

@@ -3062,8 +3062,8 @@
                  :msg (msg "reveal "
                            (join ", " (map #(str (:title %) " ("
                                                  (:label (first (:abilities (card-def %)))) ")") targets)))}
-                {:label "Resolve up to 2 Grail ICE subroutines from HQ"
-                 :choices {:max 2 :req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
+                {:label "Resolve a Grail ICE subroutine from HQ"
+                 :choices {:req #(and (:side % "Corp") (= (:zone %) [:hand]) (has? % :subtype "Grail"))}
                  :effect (req (doseq [ice targets]
                                 (resolve-ability state side (first (:abilities (card-def ice))) card nil)))}]}


Fix documentation.

Fix documentation.

--- src/clojure/beckon.clj
+++ src/clojure/beckon.clj
@@ -8,18 +8,16 @@
   same (identical) atom.

   A beckon atom is an atom containing a Seqable Clojure collection, where all
-  the elements in the Seqable collection must be Callable. Clojure functions are
-  by default Callable if they take zero arguments. By default would a beckon
-  atom be a Clojure List with the default signal handler wrapped within a
-  Callable.
+  the elements in the Seqable collection must be Runnable. Clojure functions are
+  by default Runnable if they can take zero arguments. By default would a beckon
+  atom be a Clojure Set with the default signal handler wrapped within a
+  Runnable. Note that with sets, the ordering of the Runnable is arbitrary; If
+  you need ordered calling, convert the set to a vector or list first.

-  The signal handling of a (modified) beckon atom is as follows: The first
-  element in the sequence is called. If the element returns a truthy value, the
-  next element will be called in the same fashion. If the element returns a
-  falsey value or throws an Exception, the handling will stop and no more
-  elements will be called. A default signal handler will always return true
-  unless it throws an Exception. If the signal handler throws an Error, that
-  Error will not be caught.
+  The signal handling of a (modified) beckon atom is done by simply calling all
+  the functions in order. If the Runnable throws an Exception, the handling will
+  stop and no more elements will be called. If the signal handler throws an
+  Error, that Error will not be caught.

   signal-name must be a legal POSIX signal, where SIG is omitted from the first
   part of the name."
@@ -45,17 +43,3 @@
   "Reintializes all signal handlers handled by beckon to their default values."
   []
   (SignalRegisterer/resetAllHandlers))
-
-(defn always-true
-  "Takes a function of no arguments, and returns a function taking no arguments
-  which calls f and returns true. f has presumably side effects. Will not handle
-  throwables."
-  [f]
-  (fn [] (f) true))
-
-(defn always-false
-  "Takes a function of no arguments, and returns a function taking no arguments
-  which calls f and returns false. f has presumably side effects. Will not
-  handle throwables."
-  [f]
-  (fn [] (f) false))


Fix the cost calculator

Fix the cost calculator

--- src/baustellen.clj
+++ src/baustellen.clj
@@ -52,19 +52,18 @@
        (total-cost coalition sites agents skill-costs))
     0))

-(defn indiv-alloc-cost [{:keys [site-k site-alloc]} static-data]
+(defn indiv-alloc-cost [[site-k site-alloc] static-data]
   (let [site-loc (get-in static-data [:sites site-k :location])]
     (apply +
            (mapcat
-             (fn [{:keys [skill bundles]}]
-               (map (fn [{:keys [agent-k cnt]}]
+             (fn [[skill bundles]]
+               (map (fn [[agent-k cnt]]
                       (let [agent-loc (get-in static-data
                                               [:agents agent-k :location])
                             dist (distance agent-loc site-loc)]
-                        (cost dist cnt
-                              (get-in static-data [:skill-costs skill]))))
-                    bundles)
-               site-alloc)))))
+                        (cost dist skill cnt (:skill-cost static-data))))
+                    bundles))
+             site-alloc))))

 (defn netto-payoff [allocation static-data]
   (- (apply + (map #(get-in static-data [:sites % :payoff]) (keys allocation)))


Export to JSON and EDN

Export to JSON and EDN

--- src/emender_jenkins/metadata_exporter.clj
+++ src/emender_jenkins/metadata_exporter.clj
@@ -38,11 +38,19 @@
     [columns data]
     (data->csv (cons columns data)))

+(defn export2json
+    [columns data]
+    (data->json data))
+
+(defn export2edn
+    [columns data]
+    (data->edn data))
+
 (defn export
     [columns data output-format]
     (case output-format
-        :json  nil
-        :edn   nil
+        :json  (export2json columns data)
+        :edn   (export2edn columns data)
         :csv   (export2csv columns data)
         :txt   nil
         :xml   nil))


gender of subject must be specified for tests to pass

--- test/babel/test/fr.clj
+++ test/babel/test/fr.clj
@@ -123,11 +123,12 @@

 (deftest passe-compose-1
   (let [result
-        (forest/generate
-         {:synsem {:subcat '()
-                   :sem {:tense :passe-compose
-                         :subj {:pred :noi}
-                         :pred :andare}}}
+        (forest/generate (unifyc
+                          {:synsem {:subcat '()}}
+                          {:synsem {:sem {:subj {:pred :noi
+                                                 :gender :fem}
+                                          :pred :andare
+                                          :tense :passe-compose}}})
          (:grammar @fr/small)
          (:lexicon @fr/small)
          (:index @fr/small)
@@ -137,9 +138,9 @@

 (deftest passe-compose
   (let [result (engine/generate {:synsem {:sem {:pred :andare
-                                                :tense :passe-compose
                                                 :subj {:pred :noi
-                                                       :gender :fem}}}}
+                                                       :gender :fem}
+                                                :tense :passe-compose}}}
                                 fr/small)]
     (and (is (not (nil? result)))
          (is (= (fo result) "nous sommes allées")))))


Be more lenient for missing build time stamps

--- scripts/gosync.clj
+++ scripts/gosync.clj
@@ -36,15 +36,22 @@
     build-end-time
     build-start-time))

+(defn build-times [info start-time end-time]
+  (if-not (nil? end-time)
+    (assoc info
+           :start (handle-missing-start-time-when-cancelled start-time end-time)
+           :end end-time)
+    info))
+
 (defn parse-build-info [json-response]
-  (let [buildInfo (:building_info (first json-response))
-        buildStartTime (tc/to-long (tf/parse (:build_building_date buildInfo)))
-        buildEndTime (tc/to-long (tf/parse (:build_completed_date buildInfo)))
-        result (:result buildInfo)
+  (let [build-info (:building_info (first json-response))
+        start-time (tc/to-long (tf/parse (:build_building_date build-info)))
+        end-time (tc/to-long (tf/parse (:build_completed_date build-info)))
+        result (:result build-info)
         outcome (if (= "Passed" result) "pass" "fail")]
-    {:start (handle-missing-start-time-when-cancelled buildStartTime buildEndTime)
-     :end buildEndTime
-     :outcome outcome}))
+    (-> {}
+        (build-times start-time end-time)
+        (assoc :outcome outcome))))

 (defn build-for [{jobId :jobId}]
   (let [build (get-json "/jobStatus.json?pipelineName=&stageName=&jobId=%s" jobId)]


Remove closed result-ch in aalts after as prep for take-ghosts.

--- src/cbfg/core.cljs
+++ src/cbfg/core.cljs
@@ -126,7 +126,9 @@
                  (swap! vis #(dissoc-in % [:actxs actx :wait-chs ch])))
                (swap! vis #(dissoc-in % [:chs result-ch :msgs result-msg]))
                (when (nil? result-msg) ; The ch is closed.
-                 (swap! vis #(dissoc-in % [:chs result-ch])))
+                 (swap! vis #(-> %
+                                 (dissoc-in [:actxs actx :wait-chs result-ch])
+                                 (dissoc-in [:chs result-ch]))))
                (when (some #(= % result-ch) ch-bindings)
                  [{:delta :take :msg result-msg :ch result-ch :actx actx}])))}})


Fix Failing Build

Fix Failing Build

--- test/lens/api_test.clj
+++ test/lens/api_test.clj
@@ -5,7 +5,8 @@
             [datomic.api :as d]
             [clojure.core.reducers :as r]
             [clj-time.core :as t]
-            [clj-time.coerce :as tc]))
+            [clj-time.coerce :as tc]
+            [lens.api :as api]))

 (def date (tc/to-date (t/date-time 2015)))

@@ -120,12 +121,12 @@
                       (r/map :study/id)
                       (into #{})))))
     (testing "with one study"
-      @(d/transact conn [[:study.fn/create (d/tempid :part/meta-data) "id-144922" {}]])
+      (api/create-study conn "id-144922" "name-225358")
       (is (= #{"id-144922"} (->> (all-studies (d/db conn))
                                  (r/map :study/id)
                                  (into #{})))))
     (testing "with two studies"
-      @(d/transact conn [[:study.fn/create (d/tempid :part/meta-data) "id-150211" {}]])
+      (api/create-study conn "id-150211" "name-225425")
       (is (= #{"id-144922"
                "id-150211"} (->> (all-studies (d/db conn))
                                  (r/map :study/id)


[cassandra] Upgrade to Cassaforte 2.0.0

[cassandra] Upgrade to Cassaforte 2.0.0

--- joplin.cassandra/project.clj
+++ joplin.cassandra/project.clj
@@ -6,5 +6,5 @@
   :license {:name "Eclipse Public License"
             :url "http://www.eclipse.org/legal/epl-v10.html"}
   :dependencies [[org.clojure/clojure "1.6.0"]
-                 [clojurewerkz/cassaforte "2.0.0-rc4"]
+                 [clojurewerkz/cassaforte "2.0.0"]
                  [joplin.core "0.2.5-SNAPSHOT"]])


Adds multisubst

Adds multisubst

--- src/the_little_clojurian/chapter3.clj
+++ src/the_little_clojurian/chapter3.clj
@@ -135,3 +135,18 @@
          '()))
   (is (= (multiinsertL 'new 'old '(old socks old beer))
          '(new old socks new old beer))))
+
+(with-test
+  (def multisubst
+    (fn [new old lat]
+      (cond (null? lat) '()
+            (eq? (car lat) old) (cons new (multisubst new old (cdr lat)))
+            :else (cons (car lat) (multisubst new old (cdr lat))))))
+  (is (= (multisubst 'new 'old '())
+         '()))
+  (is (= (multisubst 'new 'old '(frog))
+         '(frog)))
+  (is (= (multisubst 'new 'old '(old))
+         '(new)))
+  (is (= (multisubst 'new 'old '(old old old))
+         '(new new new))))


Fix cljam.util/upper-case

Fix cljam.util/upper-case

--- src/cljam/util.clj
+++ src/cljam/util.clj
@@ -9,12 +9,12 @@

 ;;; string utils

-(def ^:private upper-case-offset (- (byte \A) (byte \a)))
+(def ^:private upper-case-offset (byte (- (byte \A) (byte \a))))

 (defn upper-case
   "Converts a lower case letter to upper case."
   [b]
-  (if (or (< b \a) (> b \z))
+  (if (or (< b (byte \a)) (> b (byte \z)))
     b
     (byte (+ b upper-case-offset))))


Add some extra fields to lucene document field.

This will add following options to document meta map:
:analyzed - disable/eneble Analyzer for field
:norms - disable/enable storing norms for field

--- src/clucy/core.clj
+++ src/clucy/core.clj
@@ -62,19 +62,28 @@
     index))

 (defn- add-field
-  "Add a Field to a Document."
+  "Add a Field to a Document.
+  Following options are allowed for meta-map:
+  :stored - when false, then do not store the field value in the index.
+  :indexed - when false, then do not index the field.
+  :analyzed - when :indexed is enabled use this option to disable/eneble Analyzer for current field.
+  :norms - when :indexed is enabled user this option to disable/enable the storing of norms."
   ([document key value]
      (add-field document key value {}))

   ([document key value meta-map]
      (.add document
            (Field. (as-str key) (as-str value)
-                   (if (and meta-map (= false (:stored meta-map)))
+                   (if (false? (:stored meta-map))
                      Field$Store/NO
                      Field$Store/YES)
-                   (if (and meta-map (= false (:indexed meta-map)))
+                   (if (false? (:indexed meta-map))
                      Field$Index/NO
-                     Field$Index/ANALYZED)))))
+                     (case [(false? (:analyzed meta-map)) (false? (:norms meta-map))]
+                       [false false] Field$Index/ANALYZED
+                       [true false] Field$Index/NOT_ANALYZED
+                       [false true] Field$Index/ANALYZED_NO_NORMS
+                       [true true] Field$Index/NOT_ANALYZED_NO_NORMS))))))

 (defn- map-stored
   "Returns a hash-map containing all of the values in the map that


Remove broken import.

Remove broken import.

--- clojure/src/advent2017/day8.clj
+++ clojure/src/advent2017/day8.clj
@@ -3,7 +3,7 @@
   the condition and alters the registers. Part 1 is just a matter of reducing
   over the input and checking the result. Part 2 is a matter of tracking the
   all-time-high at each iteration."
-  (:require [advent2017.core :refer [read-puzzle ->lines max*]]))
+  (:require [advent2017.core :refer [read-puzzle ->lines]]))

 (def instructions
   {"inc" +


update game of main buffer on click on move

--- src/main/cljs/chessdojo/views/editor.cljs
+++ src/main/cljs/chessdojo/views/editor.cljs
@@ -3,7 +3,7 @@
             [chessdojo.notation :as cn]
             [chessdojo.state :as cst]
             [clojure.zip :as zip]
-            ))
+            [chessdojo.fen :as cf]))

 (defn buttons []
   [:div
@@ -47,15 +47,16 @@
   (cond
     (odd? ply) (str (inc (quot ply 2)) ".")
     (and is-first (even? ply)) (str (quot ply 2) "...")))
-;
-;(defn update-board [path]
-;  (let [game @current-game new-game (cg/jump game path) new-fen (cf/position->fen (:position (node new-game)))]
-;    (reset! current-game new-game)
-;    (js/updateBoard new-fen)))
+
+
+; new-fen (cf/position->fen (:position (zip/node new-game)))
+; (js/updateBoard new-fen)

 (defn update-board [path]
-
-  )
+  (println path)
+  (let [game (:game @cst/main-buffer)
+        new-game (cg/jump game path)]
+    (swap! cst/main-buffer assoc :game new-game)))

 (defn move-view [move path focus is-first]
   [:span {:className (str "move" (when focus " focus")) :on-click #(update-board path)}


GR - remove ununsed atom from storage namespace

--- src/d_cent/storage.clj
+++ src/d_cent/storage.clj
@@ -1,8 +1,6 @@
 (ns d-cent.storage)

 (defn gen-uuid [] (str (java.util.UUID/randomUUID)))
-
-(def the-store (atom {}))

 (defn retrieve
   "Retrieves a record from the in memory database"


Logout processing

Logout processing

--- src/cylon/core.clj
+++ src/cylon/core.clj
@@ -260,7 +260,8 @@

 (defprotocol HttpSessionStore
   (start-session! [_ username]) ; return cookie map compatible with wrap-cookies
-  (get-session [_ request]))
+  (get-session [_ request])
+  (end-session! [_ value]))

 (def sessions-atom (atom {}))

@@ -276,12 +277,16 @@
              {:username username
               :expiry (+ (.getTime (java.util.Date.)) (* expiry-seconds 1000))})
       ;; TODO: Make this cookie name configurable
-      {"session" {:value uuid
-                  :max-age expiry-seconds}}))
+      ;; TODO: Use, or remain compatible with, session stores from ring-session
+      {:value uuid
+       :max-age expiry-seconds}))
   (get-session [this cookies]
     (when-let [{:keys [expiry] :as session} (->> (get cookies "session") :value (get @(:sessions this)))]
       (when (< (.getTime (java.util.Date.)) expiry)
-        session))))
+        session)))
+  (end-session! [this value]
+    (swap! (:sessions this)
+           dissoc value)))

 (defn new-atom-backed-session-store [expiry-seconds]
   (->AtomBackedSessionStore expiry-seconds))
@@ -336,12 +341,12 @@
 ;; Since this module is dependent on bidi, let's provide some sample
 ;; bidi routes that can be used as-is or to demonstrate.

-(defn new-login-get-handler [handlers-p post-handler-key {:keys [boilerplate] :as opts}]
+(defn new-login-get-handler [handlers-p & {:keys [boilerplate] :as opts}]
   (fn [{{{requested-uri :value} "requested-uri"} :cookies
         routes :modular.bidi/routes}]
     (let [form
           [:form {:method "POST" :style "border: 1px dotted #555"
-                  :action (bidi/path-for routes (get @handlers-p post-handler-key))}
+                  :action (bidi/path-for routes (get @handlers-p :process-login))}
            (when requested-uri
              [:input {:type "hidden" :name :requested-uri :value requested-uri}])
            [:div
@@ -355,7 +360,7 @@
       {:status 200
        :body (if boilerplate (boilerplate (html form)) (html [:body form]))})))

-(defn new-login-post-handler [handlers-p get-handler-key {:keys [user-authenticator http-session-store] :as opts}]
+(defn new-login-post-handler [handlers-p & {:keys [user-authenticator http-session-store] :as opts}]
   (s/validate {:user-authenticator (s/protocol UserAuthenticator)
                :http-session-store (s/protocol HttpSessionStore)}
               opts)
@@ -367,28 +372,42 @@
              (allowed-user? user-authenticator (.trim username) password))

       {:status 302
-       :headers {"Location" requested-uri}
-       :cookies (start-session! http-session-store username)}
+       :headers {"Location" (or requested-uri "/")} ; "/" can be parameterized (TODO)
+       :cookies {"session" (start-session! http-session-store username)}}

       ;; Return back to login form
       {:status 302
-       :headers {"Location" (path-for routes (get @handlers-p get-handler-key))}})))
-
-(defn- make-login-handlers [opts]
+       :headers {"Location" (path-for routes (get @handlers-p :login))}})))
+
+(defn new-logout-handler [http-session-store]
+  (fn [{:keys [cookies]}]
+    (end-session!
+     http-session-store
+     (:value (get cookies "session")))
+    {:status 302 :headers {"Location" "/"}}))
+
+(defn make-login-handlers [opts]
   (let [p (promise)]
-    @(deliver p {:get-handler (new-login-get-handler p :post-handler (select-keys opts [:boilerplate]))
-                 :post-handler (wrap-params (new-login-post-handler p :get-handler (select-keys opts [:user-authenticator :http-session-store])))})))
-
-(defrecord LoginForm [path context boilerplate]
+    @(deliver p
+              {:login (apply new-login-get-handler p (apply concat (seq (select-keys opts [:boilerplate]))))
+               :process-login (->
+                               (apply new-login-post-handler
+                                      p (apply concat (seq (select-keys opts [:user-authenticator :http-session-store]))))
+                               wrap-params)
+               :logout (new-logout-handler (:http-session-store opts))})))
+
+(defrecord LoginForm [context boilerplate]
   component/Lifecycle
   (start [this]
     (let [handlers (make-login-handlers (select-keys this [:user-authenticator :http-session-store :boilerplate]))]
       (assoc this
         :handlers handlers
-        :routes [path (->WrapMiddleware
-                       {:get (:get-handler handlers)
-                        :post (:post-handler handlers)}
-                       wrap-cookies)])))
+        :routes
+        ["" (->WrapMiddleware
+             [["/login" {:get (:login handlers)
+                     :post (:process-login handlers)}]
+              ["/logout" {:get (:logout handlers)}]]
+             wrap-cookies)])))
   (stop [this] this)

   BidiRoutesProvider
@@ -396,18 +415,16 @@
   (context [this] context))

 (def new-login-form-schema
-  {(s/optional-key :path) s/Str
-   (s/optional-key :context) s/Str
+  {(s/optional-key :context) s/Str
    (s/optional-key :boilerplate) (s/=> 1)})

 (defn new-login-form [& {:as opts}]
-  (let [{:keys [path context boilerplate]}
+  (let [{:keys [context boilerplate]}
         (->> opts
              (merge {:context ""
-                     :path "/login"
                      :boilerplate #(html [:body %])})
              (s/validate new-login-form-schema))]
-    (component/using (->LoginForm path context boilerplate) [:user-authenticator :http-session-store])))
+    (component/using (->LoginForm context boilerplate) [:user-authenticator :http-session-store])))

 ;; Now we can build a protection system, composed of a login form, user
 ;; authenticator and session store. Different constructors can build this
@@ -433,7 +450,7 @@
     (add-bidi-protection-wrapper
      routes
      :http-request-authenticator (new-session-based-request-authenticator :http-session-store (:http-session-store this) :user-roles user-roles)
-     :failed-authentication-handler (->BidiFailedAuthenticationRedirect (get-in (:login-form this) [:handlers :get-handler]))))
+     :failed-authentication-handler (->BidiFailedAuthenticationRedirect (get-in (:login-form this) [:handlers :login]))))

   NewUserCreator
   (add-user! [_ uid pw]


Simplify arb->* methods

Simplify arb->* methods

--- src/datemo/arb.clj
+++ src/datemo/arb.clj
@@ -10,6 +10,30 @@

 (defn get-in-metadata [k metadata]
   (k (first (filter #(k %) metadata))))
+
+(defn walk-arb-fn [wrap-node process-node]
+  (fn walk [arb]
+    (let [[_ metadata & nodes] arb]
+      (wrap-node
+       metadata
+       (apply vector (for [node nodes]
+                       (if (or (string? node) (nil? node))
+                         (process-node node)
+                         (walk node))))))))
+
+(defn arb->tx [arb]
+  (let [process-node #(hash-map :content/text %)
+        wrap-node #(hash-map
+                    :arb/metadata [{:metadata/html-tag (:original-tag %1)}]
+                    :arb/value %2)
+        convert (walk-arb-fn wrap-node process-node)]
+    (convert arb)))
+
+(defn arb->hiccup [arb]
+  (let [proccess-node #(identity %)
+        wrap-node #(vec (concat [(:original-tag %1) {}] %2))
+        convert (walk-arb-fn wrap-node proccess-node)]
+    (convert arb)))

 (defn html->hiccup
   ([html] (as-hiccup (parse html)))
@@ -39,27 +63,6 @@
     (hiccup->arb (html->hiccup html)))
     (hiccup->arb (html->hiccup html as-fragment))))

-(defn arb->tx [arb]
-  (let [[arb-tag metadata & value] arb]
-    (if (and
-          (= 1 (count value))
-          (or (string? (first value)) (nil? (first value))))
-      {:arb/metadata [{:metadata/html-tag (metadata :original-tag)}]
-       :arb/value [{:content/text (first value)}]}
-      (loop [values []
-             items value]
-        (def new-val (if (string? (first items))
-                       {:content/text (first items)}
-                       (arb->tx (first items))))
-        (if (= 1 (count items))
-          {:arb/metadata [{:metadata/html-tag (metadata :original-tag)}]
-           :arb/value (conj values new-val)}
-          (recur (conj values new-val) (next items)))))))
-
-(defn html->tx [html & metadata]
-  (let [tx (-> html (html->arb) (arb->tx))]
-    (assoc tx :arb/metadata (into (:arb/metadata tx) metadata))))
-
 (defn tx->arb [tx]
   (let [{metadata :arb/metadata value :arb/value} tx]
     (if (and (= 1 (count value)) (not (nil? (:content/text (first value)))))
@@ -76,18 +79,9 @@
                          (:content/text (first items)) ;; If it's not an arb it must be a :content/text
                          (tx->arb (first items)))) (next items)))))))

-(defn arb->hiccup [arb]
-  (let [[arb-tag metadata & value] arb]
-    (if (and (string? (first value)) (= 1 (count value)))
-      [(:original-tag metadata) {} (first value)]
-      (loop [hiccups [], items value]
-        (if (= 0 (count items))
-          (into [(:original-tag metadata) {}] hiccups)
-          (if (string? (first items))
-            (recur (conj hiccups (first items)) (next items))
-            (recur
-              (conj hiccups (arb->hiccup (first items)))
-              (next items))))))))
+(defn html->tx [html & metadata]
+  (let [tx (-> html (html->arb) (arb->tx))]
+    (assoc tx :arb/metadata (into (:arb/metadata tx) metadata))))

 (defn tx->html [tx]
   (-> tx (tx->arb) (arb->hiccup) (html)))


Renames specs and adds trailing period to sentences

--- src/expound/alpha.cljc
+++ src/expound/alpha.cljc
@@ -18,12 +18,11 @@
 ;;;;;; internal specs ;;;;;;

 (s/def ::singleton (s/coll-of any? :count 1))
-;; TODO - rename within expound namespace, I can't take top-level spec namespace
-;; (s/def :spec/spec keyword?)
-;; (s/def :spec/specs (s/coll-of :spec/spec))
-;; (s/def :spec.problem/via (s/coll-of :spec/spec :kind vector?))
-;; (s/def :spec/problem (s/keys :req-un [:spec.problem/via]))
-;; (s/def :spec/problems (s/coll-of :spec/problem))
+(s/def :expound.spec/spec keyword?)
+(s/def :expound.spec/specs (s/coll-of :expound.spec/spec))
+(s/def :expound.spec.problem/via (s/coll-of :expound.spec/spec :kind vector?))
+(s/def :expound.spec/problem (s/keys :req-un [:expound.spec.problem/via]))
+(s/def :expound.spec/problems (s/coll-of :expound.spec/problem))

 (s/def :expound.printer/show-valid-values? boolean?)
 (s/def :expound.printer/value-str-fn ifn?)
@@ -111,8 +110,8 @@
       via)))

 (s/fdef specs
-        :args (s/cat :problems :spec/problems)
-        :ret :spec/specs)
+        :args (s/cat :problems :expound.spec/problems)
+        :ret :expound.spec/specs)
 (defn ^:private specs
   "Given a collection of problems, returns the specs for those problems, with duplicates removed"
   [problems]
@@ -806,7 +805,7 @@
         :args (s/cat :explain-data map?)
         :ret nil?)
 (defn printer
-  "Prints `explain-data` in a human-readable format"
+  "Prints `explain-data` in a human-readable format."
   [explain-data]
   ((custom-printer {}) explain-data))

@@ -833,7 +832,7 @@
                      :form any?)
         :ret nil?)
 (defn expound
-  "Given a `spec` and a `form`, either prints a success message or prints a human-readable explanation"
+  "Given a `spec` and a `form`, either prints a success message or prints a human-readable explanation."
   [spec form]
   (print (expound-str spec form)))

@@ -851,7 +850,7 @@
    (defmacro def
      "Define a spec with an optional error message.

-This is a replacement for `clojure.spec.alpha/def` but optionally takes a human-readable `error-message` (will only be used for predicates) e.g. 'should be a string'"
+This is a replacement for `clojure.spec.alpha/def` but optionally takes a human-readable `error-message` (will only be used for predicates) e.g. 'should be a string'."
      ([k spec-form]
       `(s/def ~k ~spec-form))
      ([k spec-form error-message]


Added experimental diffing support because it was pretty easy to implement, but it doesn't improve much... oh well just an experiment.

--- src/freactive/dom.cljs
+++ src/freactive/dom.cljs
@@ -271,8 +271,7 @@
     (when handler
       (unlisten! node event-name handler)))
   (dispose [this]
-    (.unlisten this)
-    (set! (.-disposed this) true)))
+    (.unlisten this)))

 (defn- bind-event! [node event-name handler]
   ((EventBinding. node (name event-name) nil) handler))
@@ -376,6 +375,25 @@

 (def ^:private bind-attrs! (wrap-attr-map-binder bind-attr!))

+(def ^:private enable-diffing false)
+
+(defn enable-diffing!
+  "Enables experimental diffing support."
+  ([] (enable-diffing! true))
+  ([enable] (set! enable-diffing enable)))
+
+(def ^:private ^:dynamic *diff-head* nil)
+
+(defn- get-diff-head* []
+  (when-let [head *diff-head*]
+    (set! *diff-head* (.-nextSibling head))
+    head))
+
+(defn- get-diff-head []
+  (when-let [head (get-diff-head*)]
+    (or (get-element-state head)
+        (UnmanagedDOMNode. head nil nil))))
+
 (deftype DOMElement [ns-uri tag ^:mutable attrs children ^:mutable node
                      ^:mutable parent ^:mutable attr-binder]
   IHash
@@ -383,11 +401,8 @@

   Object
   (dispose [this]
-    (r/dispose attr-binder)
-    ;; (dispose-states attr-states)
-    ;; (dispose-states events)
-    ;; (dispose-states styles)
-    (doseq [i (range (.-length children))]
+    (when attr-binder (r/dispose attr-binder))
+    (dotimes [i (.-length children)]
       (r/dispose (aget children i))))
   (ensureNode [this]
     (when-not node
@@ -403,14 +418,32 @@
     (when-let [on-attached (get attrs :node/on-attached)]
       (on-attached node)))
   (updateAttrs [this new-attrs]
-    ;; (let [{new-events :events new-style :style :as new-attrs} new-attrs]
-    ;;   (set! events (bind-events! node events new-events))
-    ;;   (set! styles (bind-styles! node styles new-style))
-    ;;   (set! attr-states (attr-diff* node attr-states (dissoc new-attrs :events :style) bind-attr!))
-    ;;   (set! attrs new-attrs))
-    ;; (set! attr-states (attr-diff* node attr-states new-addts bind-attr!))
     (set! attr-binder (attr-binder node new-attrs))
     (set! attrs new-attrs))
+  (diffReplace [this old]
+    (when (and
+           enable-diffing
+           (not node)
+           (instance? DOMElement old)
+           (identical? (.-ns-uri old) ns-uri)
+           (identical? (.-tag old) tag))
+      (set! node (.-node old))
+      (if-let [binder (.-attr-binder old)]
+        (do
+          (set! attr-binder binder)
+          (set! (.-attr-binder old) nil)
+          (when (.-clean binder) (.clean binder))
+          (binder attrs))
+        (set! attr-binder (bind-attrs! node attrs)))
+      (binding [*diff-head* (.-firstChild node)]
+        (doseq [child children]
+          (ui/velem-insert child this nil))
+        (loop []
+          (when-let [head (get-diff-head*)]
+            (dom-remove head)
+            (recur))))
+      (r/dispose old)
+      true))

   ui/IVirtualElement
   (-velem-parent [this] parent)
@@ -421,19 +454,24 @@
   (-velem-simple-element [this] this)
   (-velem-insert [this vparent vnext-sibling]
     (set! parent vparent)
-    (.ensureNode this)
-    (dom-insert parent node vnext-sibling)
-    (.onAttached this)
+    (if-let [diff-head (get-diff-head)]
+      (ui/velem-replace this diff-head)
+      (do
+        (.ensureNode this)
+        (dom-insert parent node vnext-sibling)
+        (.onAttached this)))
     this)
   (-velem-take [this]
     (dom-remove node))
   (-velem-replace [this old-velem]
-    (.ensureNode this)
-    (if-let [old-node (ui/velem-native-element old-velem)]
-      (do
-        (dom-simple-replace node old-node)
+    (if-let [old-simple (ui/velem-simple-element old-velem)]
+      (when-not (.diffReplace this old-simple)
+        (.ensureNode this)
+        (dom-simple-replace node (ui/velem-native-element old-simple))
         (r/dispose old-velem))
-      (dom-remove-replace node old-velem))
+      (do
+        (.ensureNode this)
+        (dom-remove-replace node old-velem)))
     (.onAttached this)
     this)
   (-velem-lifecycle-callback [this cb-name]
@@ -456,9 +494,12 @@
     node)
   (-velem-simple-element [this] this)
   (-velem-insert [this vparent vnext-sibling]
-    (.ensureNode this)
-    (set! parent vparent)
-    (dom-insert parent node vnext-sibling)
+    (if-let [diff-head (get-diff-head)]
+      (ui/velem-replace this diff-head)
+      (do
+        (.ensureNode this)
+        (set! parent vparent)
+        (dom-insert parent node vnext-sibling)))
     this)
   (-velem-take [this]
     (dom-remove node))


cjl - Unicode output

cjl - Unicode output

--- src/icfp2015/board.clj
+++ src/icfp2015/board.clj
@@ -61,8 +61,8 @@
 (defn board->str [{:keys [width height filled current-unit]}]
   (let [print-cell (fn [cell]
                      (cond
-                       (contains? (:members current-unit) cell) "o"
-                       (contains? filled cell) "x"
+                       (contains? (:members current-unit) cell) "⬡"
+                       (contains? filled cell) "⬢"
                        :else "."))
         print-row (fn [i] (str (if (odd? i) " " "") (join " " (map print-cell (map (fn [j] [i j]) (range width))))))]
     (join "\n" (map print-row (range height)))))


could just compare the last thing in each vector

--- clojure/src/dnd/showScreen.cljs
+++ clojure/src/dnd/showScreen.cljs
@@ -32,7 +32,7 @@
                      current-block (get-in level [x y])]
                  (not (current-block :solid))
                  ) line))
-  (if (apply not= (map count [shortened-line line]))
+  (if (apply not= (map last [shortened-line line]))
     (concat shortened-line (list (nth line (count shortened-line))))
     line))


onyl clear the screen if you need to

onyl clear the screen if you need to

--- clojure/src/dnd/showScreen.cljs
+++ clojure/src/dnd/showScreen.cljs
@@ -106,11 +106,11 @@

 (defn show-map-direct [term level character]
   (let [get-in-level (partial get-in level)]
+    (.clear term)
     (->> level
          (viewable-coords character)
          (map get-in-level)
-         (run! #(draw-block term %))
-         )))
+         (run! #(draw-block term %)))))

 (defn show-map-with-buffer [term level character]
   (let [
@@ -134,13 +134,10 @@

 (defn show-screen [term level character]
-  (.clear term)

   (if (-> (.-support term) (aget "trueColor"))
     (show-map-with-buffer term level character)
     (show-map-direct term level character))
-
-  (show-map-direct term level character)

   (doto term
     (.color256    7)


pro <= release, pack <= package

pro <= release, pack <= package

--- ext/chrome/project.clj
+++ ext/chrome/project.clj
@@ -53,14 +53,14 @@
              :server-logfile ".figwheel.log"
              }

-  :aliases {"release"     ["with-profile" "pro"
-                           "do"
-                           ["clean"]
-                           ["cljsbuild" "once"]]
-            "package"     ["with-profile" "pro"
-                           "do"
-                           ["clean"]
-                           ["cljsbuild" "once"]
-                           ["packer" "once"]]}
+  :aliases {"pro"     ["with-profile" "pro"
+                       "do"
+                       ["clean"]
+                       ["cljsbuild" "once"]]
+            "pack"     ["with-profile" "pro"
+                        "do"
+                        ["clean"]
+                        ["cljsbuild" "once"]
+                        ["packer" "once"]]}
   )


switch to keywords for state/action types

--- src/leftover/core.cljs
+++ src/leftover/core.cljs
@@ -10,7 +10,7 @@
 (enable-console-print!)

 (def app-state (atom {
-                      :state "enter-payment"
+                      :state :enter-payment
                       :start-amount 524.15
                       :previous-payments [
                                           {:when "yesterday"
@@ -53,7 +53,7 @@
                    (obi/input {:type "text" :placeholder "Location"})
                    (obi/input {:type "text" :placeholder "Amount"})
                    (obb/button-group {:justified? true}
-                                     (obb/button-group {} (obb/button { :bs-style "success" :on-click (fn [] (put! actions {:type "add-payment"})) } "Add")))))))))
+                                     (obb/button-group {} (obb/button { :bs-style "success" :on-click (fn [] (put! actions {:type :add-payment})) } "Add")))))))))

 (defn button-bar [app owner]
   (reify om/IRender
@@ -61,8 +61,8 @@
       (let [actions (om/get-shared owner :actions)]
         (dom/div {:class "col-sm-6 component"}
                  (obb/button-group {:justified? true}
-                                   (obb/button-group {} (obb/button { :bs-style "primary" :on-click (fn [] (put! actions {:type "enter-payment"})) } "Enter Payment"))
-                                   (obb/button-group {} (obb/button { :bs-style "primary" :on-click (fn [] (put! actions {:type "view-history"})) } "View History"))))))))
+                                   (obb/button-group {} (obb/button { :bs-style "primary" :on-click (fn [] (put! actions {:type :enter-payment})) } "Enter Payment"))
+                                   (obb/button-group {} (obb/button { :bs-style "primary" :on-click (fn [] (put! actions {:type :view-history})) } "View History"))))))))

 (defn running-total [app owner]
   (reify om/IRender
@@ -77,17 +77,17 @@
         (om/build running-total app)
         (om/build button-bar app)
         (case (:state app)
-          "enter-payment" (om/build enter-payment app)
-          "view-history" (om/build view-history app))))))
+          :enter-payment (om/build enter-payment app)
+          :view-history (om/build view-history app))))))

 (def actions (chan))

 (go (loop []
       (let [action (<! actions)]
         (case (:type action)
-          "enter-payment" (swap! app-state assoc :state "enter-payment")
-          "view-history" (swap! app-state assoc :state "view-history")
-          "add-payment" (.log js/console "add"))
+          :enter-payment (swap! app-state assoc :state :enter-payment)
+          :view-history (swap! app-state assoc :state :view-history)
+          :add-payment (.log js/console "add"))
         (recur))))

 (om/root


Remove extraneous debug in 'contains-sha?.

--- src/leiningen/voom.clj
+++ src/leiningen/voom.clj
@@ -116,7 +116,6 @@
     (map #(str (.getParent d) "/" %) lines)))

 (defn contains-sha? [d sha]
-  (prn "contains-sha?" d sha)
   (->>
    (git {:gitdir d :ok-statuses #{0 1}} "rev-parse" "--verify" "--quiet" sha)
    :exit


Add fns for finding all old project version shas

--- src/leiningen/voom.clj
+++ src/leiningen/voom.clj
@@ -236,6 +236,124 @@
     (println "Checking out latest:" (.getPath d))
     (git {:gitdir d} "fetch")
     (git {:gitdir d} "checkout" "origin/HEAD")))
+
+(defn read-project [gitdir sha prj-path]
+  (let [tmp-file (File/createTempFile ".project-" ".clj")
+        _ (spit tmp-file
+                (:out (git {:gitdir gitdir} "show" (str sha ":" prj-path))))
+        prj (try (project/read (str tmp-file))
+                 (catch Throwable t
+                   (throw (ex-info "Error reading project file"
+                                   {:project-file prj-path
+                                    :git-sha sha
+                                    :git-dir gitdir}
+                                   t))))]
+    (.delete tmp-file)
+    prj))
+
+
+(defn patch-fn
+  [f default-val]
+  (fn [filename & args]
+    (if (re-find #"\.lein|project[^/]*\.clj$" filename)
+      (apply f filename args)
+      default-val)))
+
+(defn robust-read-project
+  [gitdir sha prj-path]
+  (try
+    ;; Hack to work around our crazy project.clj files
+    (with-redefs [slurp (patch-fn slurp "{}")
+                  load-file (patch-fn load-file {})]
+      (read-project gitdir sha prj-path))
+    (catch Exception e
+      ;; 128 means git complained about
+      ;; something. Probably a non-existant
+      ;; project.clj at this sha.
+      (when-not (= 128 (:exit (ex-data e)))
+        (println "Skipping error:" (pr-str e)))
+      nil)))
+
+(defn re-quote [s]
+  (s/replace s #"\." "\\\\."))
+
+;; This is not right, at least when asking for the latest version
+(defn find-ver-part-projs
+  [gitdir prj-name ver-part]
+  (let [ver-ptn (re-pattern (str (re-quote ver-part) #"[-.].*"))
+        qprj (re-quote prj-name)
+        prj-ptn (if (= (name prj-name) (namespace prj-name))
+                  (str "(" (re-quote (name prj-name)) "|" qprj ")")
+                  qprj)
+        git-ptn (str #"\(defproject\s+" prj-ptn #"\s+\"" ver-ptn \")
+        _ (prn :git-ptn git-ptn)
+        r (git {:gitdir gitdir} "log" "--name-only" "--all" "--pretty=format:%H"
+                 "-G" git-ptn "--" "project.clj" "**/project.clj")
+        lines (s/split-lines (:out r))]
+    (->> lines
+         (reductions (fn [[sha v] line]
+                       (cond
+                        (empty? line) [nil nil]
+                        sha [sha {:sha sha :file line}]
+                        :else [line nil]))
+                     [nil nil])
+         (keep second)
+         (keep
+          (fn [{:keys [sha file]}]
+            (let [{:keys [group name version]} (read-project gitdir sha file)]
+              (prn group name version)
+              (when (and (re-matches ver-ptn version)
+                         (= prj-name (symbol group name)))
+                {:sha sha
+                 :v version}))))
+         first)))
+
+(defn likely-project-shas
+  "Return lazy seq of maps with :sha and :file keys, each representing
+  a sha of the given gitdir that has a change to the project.clj named
+  in the map. Ordered by newest to oldest."
+  [gitdir]
+  (let [r (git {:gitdir gitdir} "log" "--name-only" "--all"
+               "--pretty=format:%H" "--" "project.clj" "**/project.clj")]
+    (->> (s/split-lines (:out r))
+         (reductions (fn [[sha v] line]
+                       (cond
+                        (empty? line) [nil nil]
+                        sha [sha {:sha sha :file line}]
+                        :else [line nil]))
+                     [nil nil])
+         (keep second))))
+
+(defn report-progress
+  "Eagerly consume xs, but return a lazy seq that reports progress
+  every half second as the returned seq is consumed."
+  [msg xs]
+  (concat
+   (let [last-report (clojure.lang.Box. 0)
+         c (count xs)
+         digits (inc (long (quot (Math/log c) (Math/log 10))))]
+     (map-indexed
+      (fn [i x]
+        (let [now (System/currentTimeMillis)]
+          (when (< 500 (- now (.val last-report)))
+            (set! (.val last-report) now)
+            (printf (str "\r%s %" digits "d/%d ...") msg i c)
+            (flush)))
+        x)
+      xs))
+   (lazy-seq (println "done"))))
+
+(defn update-ver-cache
+  [gitdir]
+  (let [prj-changes (likely-project-shas gitdir)
+        sha-info (map
+                  (fn [{:keys [sha file]}]
+                    (when-let [p (robust-read-project gitdir sha file)]
+                      {:proj (symbol (:group p) (:name p))
+                       :v (:version p)
+                       :sha sha}))
+                  (report-progress gitdir prj-changes))]
+    (remove nil? sha-info)))

 ;; Add metadata pinning (how big to bump? all? minor? sha?) -- warn about not updating
 ;; Opt-in autobump  -- default to no major auto


sparkles

sparkles

--- src/lights/my_show.clj
+++ src/lights/my_show.clj
@@ -386,13 +386,21 @@
   []

   (ct/set-cue! (:cue-grid *show*) 0 7
-      (cues/cue :sparkle (fn [_] (afterglow.effects/scene
-        "Sparkle all"
-        (fun/sparkle (show/all-fixtures)
-        :chance :sparkle-chance
-        :fade-time :sparkle-fade))
-          :held true
-          :priority 100)))
+    (cues/cue :sparkle (fn [_] (fun/sparkle (show/all-fixtures)
+      :chance :sparkle-chance
+      :fade-time :sparkle-fade))
+        :held true
+        :priority 100
+        ))
+
+  (ct/set-cue! (:cue-grid *show*) 1 7
+    (cues/cue :sparkle (fn [_] (fun/sparkle (show/fixtures-named "scene")
+      ;2DO find good values here
+      :chance 0.3
+      :fade-time 400))
+        :held true
+        :priority 100
+        ))

   (ct/set-cue! (:cue-grid *show*) 0 2
     (cues/cue :color  (fn [_] (afterglow.effects/scene


Update example.clj

Update example.clj

Woah --> Whoa

--- bob/example.clj
+++ bob/example.clj
@@ -14,6 +14,6 @@
 (defn response-for [input]
   (cond
     (silence?  input) "Fine. Be that way!"
-    (shouting? input) "Woah, chill out!"
+    (shouting? input) "Whoa, chill out!"
     (question? input) "Sure."
     :else             "Whatever."))


(TK-16) Removed some unnecessary future usages from tests

This commit removes unnecessary future wrappers around code in some of
the shutdown unit tests.

--- test/puppetlabs/trapperkeeper/shutdown_test.clj
+++ test/puppetlabs/trapperkeeper/shutdown_test.clj
@@ -69,11 +69,10 @@
                                            (reset! shutdown-called? true)
                                            context))
           app               (bootstrap-services-with-empty-config [test-service])
-          shutdown-svc      (get-service app :ShutdownService)
-          main-thread       (future (tk/run-app app))]
+          shutdown-svc      (get-service app :ShutdownService)]
       (is (false? @shutdown-called?))
       (internal/request-shutdown shutdown-svc)
-      (deref main-thread)
+      (tk/run-app app)
       (is (true? @shutdown-called?))))

   (testing (str "`shutdown-on-error` in custom function causes services to be "
@@ -91,23 +90,22 @@
                                                           (Throwable.
                                                             "oops"))))))
           app               (tk/boot-services-with-config [test-service] {})
-          test-svc          (get-service app :ShutdownTestServiceWithFn)
-          main-thread       (future (tk/run-app app))]
+          test-svc          (get-service app :ShutdownTestServiceWithFn)]
       (is (false? @shutdown-called?))
       (test-fn test-svc)
       (is (thrown-with-msg?
-            java.util.concurrent.ExecutionException #"java.lang.Throwable: oops"
-            (deref main-thread)))
+            Throwable
+            #"oops"
+            (tk/run-app app)))
       (is (true? @shutdown-called?))))

   (defn bootstrap-and-validate-shutdown
     [services shutdown-called? expected-exception-message]
-    (let [app         (tk/boot-services-with-config services {})
-          main-thread (future (tk/run-app app))]
+    (let [app         (tk/boot-services-with-config services {})]
         (is (thrown-with-msg?
-              ExecutionException
+              Throwable
               expected-exception-message
-              (deref main-thread))
+              (tk/run-app app))
             "tk run-app did not die with expected exception.")
         (is (true? @shutdown-called?)
             "Service shutdown was not called.")))
@@ -127,7 +125,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"Error during service init!!!" :error)
             "Error message for service init not logged."))))

@@ -146,7 +144,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"Error during service start!!!" :error)
             "Error message for service start not logged."))))

@@ -167,7 +165,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"shutdown-on-error triggered because of exception!"
                      :error)
             "Error message for shutdown-on-error not logged."))))
@@ -190,7 +188,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"shutdown-on-error triggered because of exception!"
                      :error)
             "Error message for shutdown-on-error not logged."))))
@@ -212,7 +210,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"shutdown-on-error triggered because of exception!"
                      :error)
             "Error message for shutdown-on-error not logged."))))
@@ -235,7 +233,7 @@
         (bootstrap-and-validate-shutdown
           [test-service]
           shutdown-called?
-          #"java.lang.Throwable")
+          #"oops")
         (is (logged? #"shutdown-on-error triggered because of exception!"
                      :error)
             "Error message for shutdown-on-error not logged."))))
@@ -253,14 +251,14 @@
                                                                    #(throw (RuntimeException. "uh oh"))
                                                                    (fn [ctxt] (reset! on-error-fn-called? true)))))
           app                 (bootstrap-services-with-empty-config [broken-service])
-          test-svc            (get-service app :ShutdownTestServiceWithFn)
-          main-thread         (future (tk/run-app app))]
+          test-svc            (get-service app :ShutdownTestServiceWithFn)]
       (is (false? @shutdown-called?))
       (is (false? @on-error-fn-called?))
       (test-fn test-svc)
       (is (thrown-with-msg?
-            java.util.concurrent.ExecutionException #"java.lang.RuntimeException: uh oh"
-            (deref main-thread)))
+            RuntimeException
+            #"uh oh"
+            (tk/run-app app)))
       (is (true? @shutdown-called?))
       (is (true? @on-error-fn-called?))))

@@ -274,12 +272,12 @@
           app             (bootstrap-services-with-empty-config [broken-service])
           test-svc        (get-service app :ShutdownTestServiceWithFn)]
       (logging/with-test-logging
-        (let [main-thread (future (tk/run-app app))]
-          (test-fn test-svc)
-          (is (thrown-with-msg?
-                java.util.concurrent.ExecutionException #"java.lang.Throwable: foo"
-                (deref main-thread)))
-          (is (logged? #"Error occurred during shutdown" :error)))))))
+        (test-fn test-svc)
+        (is (thrown-with-msg?
+              Throwable
+              #"foo"
+              (tk/run-app app)))
+        (is (logged? #"Error occurred during shutdown" :error))))))

 (deftest shutdown-on-error-error-handling
   (testing "Shutdown-on-error should never throw an exception."


fix a dumb mistake fetching chats

fix a dumb mistake fetching chats

--- src/pc/models/chat.clj
+++ src/pc/models/chat.clj
@@ -7,12 +7,6 @@
   (pcd/touch-all '{:find [?t]
                    :where [[?t :chat/body]]}
                  db))
-
-(defn find-by-document [db document]
-  (pcd/touch-all '{:find [?t] :in [$ ?document-id]
-                   :where [[?t :document/id ?document-id]
-                           [?t :chat/body]]}
-                 db (:db/id document)))

 (defn find-chat-name [db cust-uuid]
   (ffirst (d/q '{:find [?name] :in [$ ?uuid]
@@ -29,7 +23,8 @@
          (assoc e :chat/cust-name (when-let [uuid (:cust/uuid e)]
                                     (memo-find-name db uuid)))))
      (d/q '{:find [?t] :in [$ ?document-id]
-            :where [[?t :document/id ?document-id]]}
+            :where [[?t :document/id ?document-id]
+                    [?t :chat/body]]}
           db (:db/id document)))))

 (comment


save changes in make-jmessage

save changes in make-jmessage

--- src/postal/message.clj
+++ src/postal/message.clj
@@ -167,7 +167,8 @@
          (.setSentDate (or (:date msg) (make-date)))
          (.addHeader "User-Agent" (:user-agent msg (user-agent)))
          (add-extra! (drop-keys msg standard))
-         (add-body! (:body msg))))))
+         (add-body! (:body msg))
+         (.saveChanges)))))

 (defn make-fixture [from to & {:keys [tag]}]
   (let [uuid (str (UUID/randomUUID))


Increment version to 0.6.0 (to be consistent with the latest CHANGELOG).

--- src/pamela/cli.clj
+++ src/pamela/cli.clj
@@ -233,7 +233,7 @@
 (defn pamela
   "PAMELA command line processor. (see usage for help)."
   {:added "0.2.0"
-   :version "0.5.0"}
+   :version "0.6.0"}
   [& args]
   (when (and (:pamela-version env)
           (not= (:pamela-version env) (:version (meta #'pamela))))


Restore Results and other testimonial.

Restore Results and other testimonial.

--- src-cljs/frontend/components/stories.cljs
+++ src-cljs/frontend/components/stories.cljs
@@ -87,9 +87,9 @@
            [:div.col-xs-6.col-xs-offset-3
             (features/testimonial {:company-name "Shopify"
                                    :company-short "shopify"
-                                   :customer-quote "CircleCI lets us be more agile and ship product faster. We can focus on delivering value to our customer, not maintaining CI infrasturcture."
-                                   :employee-name "John Duff"
-                                   :employee-title "Director of Engineering"})]]]]
+                                   :customer-quote "One of my favorite things about CircleCI is that their team really cares about making sure their customers get maximum value out of their product."
+                                   :employee-name "Arthur Neves"
+                                   :employee-title "Developer"})]]]]

         [:div.outer-section
          [:section.container
@@ -97,7 +97,25 @@
           [:p "CircleCI integrates natively with GitHub, which Shopify was already using, so set up time was minimal; it only took a few minutes to follow the rest of their repos on CircleCI and to invite the rest of their team members. Once their tests were running, they started optimizing their containers and parallelization from within the CircleCI app so that their test suite would run as quickly as possible. Once they had the tests running for all their projects, the next step was setting up Continuous Deployment."]
           [:p "CD has always been a core part of the engineering culture at Shopify, so getting deployment set up with CircleCI was essential. To streamline their CD process, Shopify used the CircleCI API to build a custom 'Ship It' tool that allows any developer to deploy with the press of a button, as long as they have a green build on CircleCI. All they had to do to build this was verify that the pull request in question returned \"outcome\" : \"success\" from the CircleCI API after merging with master, and then allow the developer to deploy."]
           [:p "This same functionality can also be accomplished without using the API by putting the deployment script directly into the circle.yml file."]
-          shared/stories-procedure]]
+
+          shared/stories-procedure
+
+          [:h2 "Results"]
+          [:p "Today, 1 year after initially switching to CircleCI, Shopify has scaled their engineering team to 130 team members who on average merge 300 pull requests and deploy 100 times per week. Thanks to CircleCI, they've managed to maintain their agile and efficient development process, with new projects being added effortlessly and everyone working off of a master branch (rather than having to maintain production and development branches). Their test suite runs faster than it ever did with their previous solution, and now that developers don't have to run tests on their local machine they can work on other projects while CircleCI runs their tests in the background. Shopify also uses CircleCI along with Capistrano to continuously deploy their application for anything from a small bug fix, to a package upgrade, to a new feature."]]]
+
+        [:div.outer-section.outer-section-condensed
+         [:section.container
+          [:div.row
+           [:div.col-xs-6.col-xs-offset-3
+            (features/testimonial {:company-name "Shopify"
+                                   :company-short "shopify"
+                                   :customer-quote "CircleCI lets us be more agile and ship product faster. We can focus on delivering value to our customer, not maintaining CI infrasturcture."
+                                   :employee-name "John Duff"
+                                   :employee-title "Director of Engineering"})]]]]
+
+        [:div.outer-section
+         [:section.container
+          [:p "The Shopify team no longer has to worry about scaling their testing infrastructure, maintaining their test stack, or monitoring their deployments. They focus on building products that bring value to their customers while relying on CircleCI to ensure that they are able to get those products to market quickly and reliably."]]]

         [:div.outer-section.outer-section-condensed.bottom-cta-section
          common/language-background


Increase perf test threshold

Increase perf test threshold

--- pigpen-cascading/src/test/clojure/pigpen/cascading/core_test.clj
+++ pigpen-cascading/src/test/clojure/pigpen/cascading/core_test.clj
@@ -194,4 +194,4 @@
         udf (PigPenFunction. nil out-fields)
         results (criterium/benchmark (.operate udf nil call) {})]
     (criterium/report-result results)
-    (is (< (first (:mean results)) 1.6E-5))))
+    (is (< (first (:mean results)) 1.8E-5))))


Removed some globals

Removed some globals

--- src/re_demo/h_box.cljs
+++ src/re_demo/h_box.cljs
@@ -17,16 +17,11 @@
 (def h-box-style {:border-right  "dashed 1px blue" :overflow "hidden"})
 (def v-box-style {:border-bottom "dashed 1px blue" :overflow "hidden"})

-(def size-options
-  [{:id :inital :label "initial"}
-   {:id :auto   :label "auto"}
-   {:id :none   :label "none"}
-   {:id :px     :label "px"}
-   {:id :%      :label "%"}])
-
-(def box1-db (reagent/atom {:size :%  :px 100 :% 60 :show? true}))
-(def box2-db (reagent/atom {:size :px :px 100 :% 50 :show? true}))
-(def box3-db (reagent/atom {:size :%  :px 100 :% 40 :show? true}))
+(def size-options [{:id :inital :label "initial"}
+                   {:id :auto   :label "auto"}
+                   {:id :none   :label "none"}
+                   {:id :px     :label "px"}
+                   {:id :%      :label "%"}])

 (defn box-controls
   [box-name control]
@@ -75,7 +70,10 @@
   (defn panel
   []
   (let [container-size (reagent/atom 500)
-        gap-size       (reagent/atom 0)]
+        gap-size       (reagent/atom 0)
+        box1-db        (reagent/atom {:size :%  :px 100 :% 60 :show? true})
+        box2-db        (reagent/atom {:size :px :px 100 :% 50 :show? true})
+        box3-db        (reagent/atom {:size :%  :px 100 :% 40 :show? true})]
     (fn
       []
       [v-box


Clearer derefing of signals

Clearer derefing of signals

--- src/re_frame/subs.cljc
+++ src/re_frame/subs.cljc
@@ -1,6 +1,6 @@
 (ns re-frame.subs
  (:require
-   [re-frame.db    :refer [app-db]]
+   [re-frame.db      :refer [app-db]]
    [re-frame.interop :refer [add-on-dispose! debug-enabled? make-reaction ratom? deref?]]
    [re-frame.loggers :refer [console]]
    [re-frame.utils   :refer [first-in-vector]]
@@ -94,12 +94,12 @@

 (defn- deref-input-signals
-  [sigs query-id]
+  [signals query-id]
   (cond
-    (sequential? sigs)       (map deref sigs)
-    (map? sigs)              (map-vals deref sigs)
-    (deref? sigs)      @sigs
-    :else (console :error "re-frame: in reg-sub for " query-id ", input signal function returns a non-reactive input. Got: " sigs)))
+    (sequential? signals) (map deref signals)
+    (map? signals)        (map-vals deref signals)
+    (deref? signals)      @signals
+    :else (console :error "re-frame: the reg-sub for " query-id ", must be wrong. Return value from input-signals function is: " signals)))

 (defn reg-sub


(maint) jsonify benchmark submission objects

This is necessary for catalog and report submission to work with benchmark.clj.

--- src/puppetlabs/puppetdb/cli/benchmark.clj
+++ src/puppetlabs/puppetdb/cli/benchmark.clj
@@ -207,14 +207,14 @@
       (when catalog
         (future
           (try
-            (client/submit-catalog puppetdb-host puppetdb-port 5 catalog)
+            (client/submit-catalog puppetdb-host puppetdb-port 5 (json/generate-string catalog))
             (log/info (format "[%s] submitted catalog" host))
             (catch Exception e
               (log/error (format "[%s] failed to submit catalog: %s" host e))))))
       (when report
         (future
           (try
-            (client/submit-report puppetdb-host puppetdb-port 3 report)
+            (client/submit-report puppetdb-host puppetdb-port 3 (json/generate-string report))
             (log/info (format "[%s] submitted report" host))
             (catch Exception e
               (log/error (format "[%s] failed to submit report: %s" host e))))))
@@ -240,9 +240,9 @@
         report (and report (update-report-run-fields report))
         factset (and factset (update-factset rand-percentage factset))]
     (when catalog
-      (client/submit-catalog puppetdb-host puppetdb-port 5 catalog))
+      (client/submit-catalog puppetdb-host puppetdb-port 5 (json/generate-string catalog)))
     (when report
-      (client/submit-report puppetdb-host puppetdb-port 3 report))
+      (client/submit-report puppetdb-host puppetdb-port 3 (json/generate-string report)))
     (when factset
       (client/submit-facts puppetdb-host puppetdb-port 3 (json/generate-string factset)))
     (assoc state :catalog catalog)))