Enhancements to the project model

Enhancements to the project model

--- src/circle/model/project.clj
+++ src/circle/model/project.clj
@@ -1,23 +1,38 @@
 (ns circle.model.project
   (:use [circle.util.validation :only (validate defn-v)])
   (:use [circle.util.model-validation :only (validate!)])
-  (:use [circle.util.model-validation-helpers :only (require-keys key-types)])
+  (:require [circle.backend.github-url :as github])
+  (:use [circle.util.model-validation-helpers :only (require-keys key-types col-predicate)])
   (:require [somnium.congomongo :as mongo]))

-(def project-validation [(require-keys [:name :vcs-type :vcs-url :aws-credentials :actions :node-id])])
+(def project-validation [(require-keys [:name
+                                        :vcs-type
+                                        :vcs-url
+                                        :aws-credentials])
+                         (col-predicate :vcs-url #(= :top (github/url-type %)) "github url must be https://github.com/foo/bar")])

 (defmethod validate ::Project [tag obj]
   (validate! project-validation obj))

 (defn project [& {:keys [name
                          vcs-type
-                         vcs-url
+                         vcs-url ;; the url that github will call us on the post-commit hook
                          aws-credentials
-                         node-id
+                         github-ssh-key ;; an SSH private key authorized to checkout code
+                         ami-id
                          actions]
                   :as args}]
   (validate! project-validation args)
   args)

 (defn-v insert! [^::Project p]
-  (mongo/insert! :projects p))+  (mongo/insert! :projects p))
+
+(defn-v get-by-name [name]
+  (mongo/fetch-one :projects :where {:name name}))
+
+(defn-v get-by-url [url]
+  (mongo/fetch-one :projects :where {:vcs-url url}))
+
+(defn github-ssh-key-for-url [url]
+  (-> url (get-by-url) :githb-ssh-key))


(MAINT) Fix concurrent command proc test issue

The intention of the tests is to verify that if we receive two factsets
for the same certname and process them at the same time, that we get
correct results (i.e. one wins, the other is retried). These tests were
failing in Jenkins due to a timing issue. Switching from the
SynchronousQueue to a CountDownLatch should fix this issue and avoid
having timeouts like the code did previously.

--- test/puppetlabs/puppetdb/command_test.clj
+++ test/puppetlabs/puppetdb/command_test.clj
@@ -974,7 +974,7 @@
                        :version 4
                        :payload facts}

-            hand-off-queue (java.util.concurrent.SynchronousQueue.)
+            latch (java.util.concurrent.CountDownLatch. 2)
             storage-replace-facts! scf-store/update-facts!]

         (jdbc/with-db-transaction []
@@ -991,16 +991,13 @@
                       command-delay-ms 10000
                       scf-store/update-facts!
                       (fn [fact-data]
-                        (.put hand-off-queue "got the lock")
-                        (.poll hand-off-queue 5 TimeUnit/SECONDS)
+                        (.countDown latch)
                         (storage-replace-facts! fact-data))]
           (let [first-message? (atom false)
                 second-message? (atom false)
                 fut (future
                       (handle-message (store-command' q command))
                       (reset! first-message? true))
-
-                _ (.poll hand-off-queue 5 TimeUnit/SECONDS)

                 new-facts (update-in facts [:values]
                                      (fn [values]
@@ -1013,6 +1010,9 @@

             (handle-message (store-command' q new-facts-cmd))
             (reset! second-message? true)
+
+            @fut
+
             (let [failed-cmdref (take-with-timeout!! command-chan default-timeout-ms)]
               (is (= 1 (count (:attempts failed-cmdref))))
               (is (re-matches
@@ -1024,7 +1024,6 @@
                        .getNextException
                        .getMessage))))

-            @fut
             (is (true? @first-message?))
             (is (true? @second-message?))))))))

@@ -1200,8 +1199,8 @@
                      :version 6
                      :payload wire-catalog}

-            hand-off-queue (java.util.concurrent.SynchronousQueue.)
-            storage-replace-catalog! scf-store/replace-catalog!]
+            latch (java.util.concurrent.CountDownLatch. 2)
+            orig-replace-existing-catalog scf-store/replace-existing-catalog]

         (jdbc/with-db-transaction []
           (scf-store/add-certname! certname)
@@ -1209,18 +1208,15 @@

         (with-redefs [quick-retry-count 0
                       command-delay-ms 1
-                      scf-store/replace-catalog!
-                      (fn [catalog timestamp]
-                        (.put hand-off-queue "got the lock")
-                        (.poll hand-off-queue 5 TimeUnit/SECONDS)
-                        (storage-replace-catalog! catalog timestamp))]
+                      scf-store/replace-existing-catalog
+                      (fn [& args]
+                        (.countDown latch)
+                        (apply orig-replace-existing-catalog args))]
           (let [first-message? (atom false)
                 second-message? (atom false)
                 fut (future
                       (handle-message (store-command' q command))
                       (reset! first-message? true))
-
-                _ (.poll hand-off-queue 5 TimeUnit/SECONDS)

                 new-wire-catalog (assoc-in wire-catalog [:edges]
                                            #{{:relationship "contains"
@@ -1233,6 +1229,8 @@
             (handle-message (store-command' q new-catalog-cmd))
             (reset! second-message? true)
             (is (empty? (fs/list-dir (:path dlo))))
+
+            @fut

             (let [failed-cmdref (take-with-timeout!! command-chan default-timeout-ms)]
               (is (= 1 (count (:attempts failed-cmdref))))
@@ -1244,7 +1242,7 @@
                        :exception
                        .getNextException
                        .getMessage))))
-            @fut
+
             (is (true? @first-message?))
             (is (true? @second-message?))))))))

@@ -1258,8 +1256,8 @@
                      :version 6
                      :payload wire-catalog}

-            hand-off-queue (java.util.concurrent.SynchronousQueue.)
-            storage-replace-catalog! scf-store/replace-catalog!]
+            latch (java.util.concurrent.CountDownLatch. 2)
+            orig-replace-existing-catalog scf-store/replace-existing-catalog]

         (jdbc/with-db-transaction []
           (scf-store/add-certname! certname)
@@ -1267,18 +1265,15 @@

         (with-redefs [quick-retry-count 0
                       command-delay-ms 1
-                      scf-store/replace-catalog!
-                      (fn [catalog timestamp]
-                        (.put hand-off-queue "got the lock")
-                        (.poll hand-off-queue 5 TimeUnit/SECONDS)
-                        (storage-replace-catalog! catalog timestamp))]
+                      scf-store/replace-existing-catalog
+                      (fn [& args]
+                        (.countDown latch)
+                        (apply orig-replace-existing-catalog args))]
           (let [first-message? (atom false)
                 second-message? (atom false)
                 fut (future
                       (handle-message (store-command' q command))
                       (reset! first-message? true))
-
-                _ (.poll hand-off-queue 5 TimeUnit/SECONDS)

                 new-wire-catalog (update wire-catalog :resources
                                          conj
@@ -1298,6 +1293,8 @@
             (handle-message (store-command' q new-catalog-cmd))
             (reset! second-message? true)

+            @fut
+
             (is (empty? (fs/list-dir (:path dlo))))
             (let [failed-cmdref (take-with-timeout!! command-chan default-timeout-ms)]
               (is (= 1 (count (:attempts failed-cmdref))))
@@ -1310,7 +1307,6 @@
                        .getNextException
                        .getMessage))))

-            @fut
             (is (true? @first-message?))
             (is (true? @second-message?))))))))


Add missing copyright notice on core.nonce ns.

--- src/buddy/core/nonce.clj
+++ src/buddy/core/nonce.clj
@@ -1,3 +1,17 @@
+;; Copyright 2013-2015 Andrey Antukh <niwi@niwi.nz>
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License")
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+
 (ns buddy.core.nonce
   "Namespace dedicated to provide an abstraction
   for generate a valid secure nonce values.


change dynamic navs to return single navigator instead of sequence of one nav, helps inline compiler when a nav takes a parameterized navs as input

--- src/clj/com/rpl/specter.cljc
+++ src/clj/com/rpl/specter.cljc
@@ -32,10 +32,15 @@
 (defn wrap-dynamic-nav [f]
   (fn [& args]
     (let [ret (apply f args)]
-      (if (and (sequential? ret) (static-path? ret))
-        (i/comp-paths* ret)
-        ret
-        ))))
+      (cond (and (sequential? ret) (static-path? ret))
+            (i/comp-paths* ret)
+
+            (and (sequential? ret) (= 1 (count ret)))
+            (first ret)
+
+            :else
+            ret
+            ))))

 #?(:clj
    (do


implementing get-events in db

implementing get-events in db

--- src/clj/eventsourcing/db.clj
+++ src/clj/eventsourcing/db.clj
@@ -1,4 +1,6 @@
 (ns eventsourcing.db
+  (:refer-clojure :rename {update update-clj
+                           == ==-clj})
   (:require [korma.db :as db]
             [korma.core :refer :all]
             [heroku-database-url-to-jdbc.core :as h]
@@ -14,7 +16,20 @@
     db))

 (defn select-lazy
-  ([q l o] (when-let [res (seq (select (-> (q) (limit l) (offset o))))]
+  "q is a korma select object, produced via select*"
+  ([q l o] (when-let [res (seq (select (-> q (limit l) (offset o))))]
              (println "did another select from" o "to" (+ o l))
              (cons res (lazy-seq (select-lazy q l (+ o l))))))
   ([q] (select-lazy q 1 0)))
+
+
+
+(defentity es_events)
+
+(defn get-events []
+  (select-lazy (-> (select* es_events)
+                   (order :tx :desc))))
+
+
+#_(open)
+#_(get-events)


Ints work, as well as floats. Big successes today!

--- src/clj/forma/playground.clj
+++ src/clj/forma/playground.clj
@@ -13,22 +13,24 @@
      (files ?file)
      (c/count ?count))))

-(defn add-bytes [file]
-  (float-array 10 3.2))
-
-
+(defn add-floats
+  "Returns a float array, for the purpose of stacking on to the end of
+  a tuple. If the returned field works as a subquery result, we're in
+  business."
+  [file]
+  (float-array 10 12))

 (defn get-floats
-  "Test of byte array serialization."
+  "Subquery to test float array serialization."
   [dir]
   (let [files (files-with-names dir)]
     (<- [?filename ?floats]
         (files ?filename ?file)
-        (add-bytes ?file :> ?floats)
+        (add-floats ?file :> ?floats)
         (:distinct false))))

 (defn files-with-bytes
-  "Test of byte array serialization."
+  "Test of float array serialization."
   [dir]
   (let [stuff (get-floats dir)]
       (?<- (stdout) [?filename ?floats ?num]


Fix for file from data URL

Fix for file from data URL

--- src/clj/salava/core/util.clj
+++ src/clj/salava/core/util.clj
@@ -164,6 +164,16 @@
           path (public-path-from-content content-str ext)]
       (save-file-data ctx content path))))

+(defn save-file-from-data-url-fix
+  [ctx data-str comma-pos]
+  (if (> comma-pos -1)
+    (let [base64-data (subs data-str (inc comma-pos))
+          content (.decode (Base64/getMimeDecoder) base64-data)
+          content-str (String. (.decode (Base64/getMimeDecoder) base64-data) "UTF-8")
+          ext (if (re-find #"^data:image/svg" data-str) ".svg" ".png")
+          path (public-path-from-content content-str ext)]
+      (save-file-data ctx content path))))
+
 (defn file-from-url
   [ctx url]
   (cond
@@ -171,6 +181,13 @@
     (re-find #"^https?"  (str url)) (save-file-from-http-url ctx url)
     (re-find #"^data"    (str url)) (save-file-from-data-url ctx url (.lastIndexOf url ","))
     :else (throw (Exception. (str "Error in file url: " url)))))
+
+(defn file-from-url-fix [ctx url]
+   (cond
+      (string/blank? url) (throw (Exception. "file-from-url: url parameter missing"))
+      (re-find #"^https?"  (str url)) (save-file-from-http-url ctx url)
+      (re-find #"^data"    (str url)) (save-file-from-data-url-fix ctx url (.lastIndexOf url ","))
+      :else (throw (Exception. (str "Error in file url: " url)))))

 (defn str->qr-base64 [text]
   (try
@@ -238,4 +255,3 @@
 (defn event [ctx subject verb object type]
   ;TODO VALIDATE DATA
   (publish ctx :event {:subject subject :verb verb :object object :type type}))
-


bugfix beeminder

bugfix beeminder

--- src/clj/tictag/beeminder.clj
+++ src/clj/tictag/beeminder.clj
@@ -56,7 +56,7 @@

 (defn sync! [{{:keys [auth-token user goals disable?]} :config tagtime-config :tagtime} rows]
   (when (and (not disable?) auth-token user (seq goals))
-    (doseq [[goal tag] goals]
+    (doseq [[tag goal] goals]
       (let [days                (days-matching-tag tag rows)
             existing-datapoints (datapoints auth-token user goal)
             existing-map        (group-by :daystamp existing-datapoints)


minor counting fix

minor counting fix

--- src/clj_naive_bayes/core.clj
+++ src/clj_naive_bayes/core.clj
@@ -14,7 +14,7 @@
   "Compute word frequencies in document list restricted to dictionary entries"
   [doc-list]
   (->> doc-list
-       (pmap #(split % #" "))
+       (pmap #(into #{} (split % #" ")))
        (apply concat)
        frequencies
        (pmap (fn [[k v]] [k (/ v (count doc-list))]))
@@ -35,8 +35,7 @@
                         (sort-by second >)
                         (take 2500)
                         keys)
-        model {:spam-vs-ham (/ (count raw-spam)
-                             (count raw-ham))
+        model {:spam-vs-ham (/ (count raw-spam) (count raw-ham))
              :spam-probs (select-keys (word-probs raw-spam) dictionary)
              :ham-probs (select-keys (word-probs raw-ham) dictionary)
              :dictionary dictionary}]
@@ -85,3 +84,13 @@
        (test-mails "data/spam-test")
        (test-mails "data/nonspam-test"))
   (System/exit 0))
+
+
+(comment
+
+  (->> (train "data/spam-train" "data/nonspam-train")
+       (test-mails "data/spam-test")
+       (test-mails "data/nonspam-test")
+       :done)
+
+  )


Change feedback to player only.

Change feedback to player only.

--- src/cljs-blackjack/core.cljs
+++ src/cljs-blackjack/core.cljs
@@ -15,7 +15,7 @@
                      :current-bet 10
                      :playing false
                      :player-feedback ""
-                     :dealer-feedback ""}))
+                     :feedback-color :black}))

 (defn deal
   "Deal one card from the deck to a hand in the given
@@ -89,9 +89,9 @@
     (swap! game assoc :player-money new-money :current-bet (max 0 (min current-bet new-money)))))

 (defn feedback
-  "Given feedback for the dealer and player, update the reactive fields."
-  [dealer player]
-  (swap! game assoc :dealer-feedback dealer :player-feedback player))
+  "Given feedback for the player; update the reactive field."
+  [message color]
+  (swap! game assoc :player-feedback (str "\u00a0" message) :feedback-color (name color)))

 (defn end-game
   "Evaluate the dealer's and player's hands when the
@@ -102,14 +102,14 @@
 ;;    (println "Player:" player ptotal pstatus)
 ;;    (println "Dealer:" dealer dtotal dstatus)
     (cond
-      (> ptotal 21) (feedback "Dealer wins." "Sorry, you busted.")
-      (> dtotal 21) (feedback "Dealer goes bust." "You win!")
-      (= ptotal dtotal) (feedback "" "Tie.")
-      (= pstatus :blackjack) (feedback "" "You win with blackjack!")
-      (= dstatus :blackjack) (feedback "Dealer has blackjack." "")
-      (< ptotal dtotal) (feedback "Dealer wins." "")
-      (> ptotal dtotal) (feedback "" "You win!")
-      :else (feedback "" "Unknown result (Shouldn't happen.)"))
+      (> ptotal 21) (feedback "Sorry, you busted." :red)
+      (> dtotal 21) (feedback "Dealer goes bust. You win!" :green)
+      (= ptotal dtotal) (feedback "Tie game." :black)
+      (= pstatus :blackjack) (feedback "You win with blackjack!" :green)
+      (= dstatus :blackjack) (feedback "Dealer has blackjack." :red)
+      (< ptotal dtotal) (feedback "Dealer wins." :red)
+      (> ptotal dtotal) (feedback "You win!" :green)
+      :else (feedback "Unknown result (Shouldn't happen.)" :gray))
     (update-money dtotal dstatus ptotal pstatus)
     (swap! game assoc :playing false)))

@@ -120,15 +120,15 @@
   [event]
   (let [{:keys [deck discard-pile dealer-hand player-hand current-bet]} @game
         [player1 disc0] (discard [player-hand discard-pile])
-        [dealer1 disc1] (discard [dealer-hand disc0])]
-    (let [[deck2 dealer2 disc2] (deal (deal [deck dealer1 disc1] :up) :down)
-          [deck3 player2 disc3] (deal (deal [deck2 player1 disc2] :up) :up)]
-      (swap! game assoc :playing true :discard-pile disc3 :player-hand player2
-             :dealer-hand dealer2 :deck deck3 :dealer-feedback "" :player-feedback "")
-      (if (immediate-win dealer2 player2)
-        (do
-          (swap! game assoc :dealer-hand (reveal dealer2))
-          (end-game dealer2 player2))))))
+        [dealer1 disc1] (discard [dealer-hand disc0])
+        [deck2 dealer2 disc2] (deal (deal [deck dealer1 disc1] :up) :down)
+        [deck3 player2 disc3] (deal (deal [deck2 player1 disc2] :up) :up)]
+    (swap! game assoc :playing true :discard-pile disc3 :player-hand player2
+           :dealer-hand dealer2 :deck deck3 :player-feedback "" :feedback-color :black)
+    (if (immediate-win dealer2 player2)
+      (do
+        (swap! game assoc :dealer-hand (reveal dealer2))
+        (end-game dealer2 player2)))))

 (defn hit-me
   "Deal a card face up to the player, and evaluate the hand.
@@ -210,13 +210,13 @@
 (defn tableau
   "Display the playing area (the tableau)."
   []
-  (let [{:keys [dealer-hand player-hand playing dealer-feedback player-feedback
+  (let [{:keys [dealer-hand player-hand playing player-feedback feedback-color
                 player-money current-bet]} @game]
   [:div
-   [:h2 "Dealer’s Cards " [:span {:class "dealerFeedback"} dealer-feedback]]
+   [:h2 "Dealer’s Cards"]
    [show-cards dealer-hand]
    [:hr]
-   [:h2 "Your Cards " [:span {:class "playerFeedback"} player-feedback]]
+   [:h2 "Your Cards" [:span {:style {:color feedback-color}} player-feedback]]
    [show-cards player-hand]
    [:p
     [:input {:type "button"


Minor reconfiguration

Minor reconfiguration

--- src/cljs/db_quiz/config.cljs
+++ src/cljs/db_quiz/config.cljs
@@ -3,7 +3,7 @@
 (defonce config
   {; Number of hexagons on one side of the triangle
    :board-size 7
-   :colours {:active "#fafafa"
+   :colours {:active "#eeeeee"
              :default "#bcbcbc"
              :hover "#dedede"
              :missed "#333333"
@@ -16,7 +16,7 @@
    :layout {; Width of hexagon's border (in pixels)
             :border-width 1
             ; Radius of 1 hexagon composing the triangle (in pixels)
-            :hex-radius 30
+            :hex-radius 35
             ; Amount of hexagon's shading (in %)
             :hex-shade 20
             ; Hexagons will be embossed by offset (in %).


fix name

fix name

--- src/cljs/scrabble/views.cljs
+++ src/cljs/scrabble/views.cljs
@@ -2,7 +2,7 @@
   (:require [re-frame.core :as re-frame :refer [dispatch subscribe]]
             [scrabble.constants :as const]
             [goog.string :as gstring]
-            [cljs.spec :as spec]))
+            [cljs.spec.alpha :as spec]))

 ;; the page is composed of
 ;; - a tile editor: to be able to enter the current situation


The simulation uses the rules.

The simulation uses the rules.

--- src/cljs/smarthome/core.cljs
+++ src/cljs/smarthome/core.cljs
@@ -21,42 +21,48 @@

 ;; -------------------------
 ;; Rules
-(defn rules []
-  ; Fire-alarm
+(defn fire-alarm []
   (when (= :activated! (:fire-alarm (:diagnostics @state)))
-    (swap! state assoc :view :diagnostics))
-  ; Stove still on
+    (swap! state assoc :view :diagnostics)))
+
+(defn stove-on []
   (when (and (:active? (:stove (:kitchen (:rooms @state))))
              (= :out (:current-location (:user @state))))
-    (swap! state assoc :view :kitchen))
-  ; Out -> shopping
+    (swap! state assoc :view :kitchen)))
+
+(defn shopping []
   (when (= :out (:current-location (:user @state)))
-    (swap! state assoc :view :food))
-  ; laundry
+    (swap! state assoc :view :food)))
+
+(defn laundry []
   (when (and (= 100 (or (:whites (:laundry (:bathroom (:rooms @state))))
                         (:colors (:laundry (:bathroom (:rooms @state))))))
              (not (:at-work? (:user @state))))
-    (swap! state assoc :view :bathroom))
-  ; burglary alarm
+    (swap! state assoc :view :bathroom)))
+
+(defn burglary-alarm []
   (when (= :activated! (:burglary-alarm (:diagnostics @state)))
-    (swap! state assoc :view :diagnostics))
-  ; unlocked door
+    (swap! state assoc :view :diagnostics)))
+
+(defn unlocked-door []
   (when (and (= :out (:current-location (:user @state)))
              (not (:front-door-locked? (:hall (:rooms @state)))))
-    (swap! state assoc :view :hall))
-  ; dishwasher finished
+    (swap! state assoc :view :hall)))
+
+(defn dishwasher-finished []
   (when (and (:active? (:dish-washer (:kitchen (:rooms @state))))
              (= 0 (:time-remaining (:dish-washer (:kitchen (:rooms @state))))))
-    (swap! state assoc :view :kitchen))
-  ; weather in the morning
+    (swap! state assoc :view :kitchen)))
+
+(defn morning-weather []
   (when (= :morning (:time-of-day @state))
-    (swap! state assoc :view :weather))
-  ; door and garage port locked at night
+    (swap! state assoc :view :weather)))
+
+(defn lock-doors-at-night []
   (when (= "22:00" (:time @state))
-    (do
-      (swap! state assoc-in [:rooms :garage :port-closed?] true)
-      (swap! state assoc-in [:rooms :garage :lights-off?] true)
-      (swap! state assoc-in [:rooms :hall :front-door-locked?] true))))
+    (swap! state assoc-in [:rooms :garage :port-closed?] true)
+    (swap! state assoc-in [:rooms :garage :lights-off?] true)
+    (swap! state assoc-in [:rooms :hall :front-door-locked?] true)))

 ;; -------------------------
 ;; Scenario simulations
@@ -64,11 +70,11 @@
   (go-loop []
            ; fire alarm
            (reset! state initial-state)
-           (swap! state assoc :scenario "Scenario 1: A fire has broken out and the fire alarm goes off!")
+           (swap! state assoc :scenario "Scenario 1a: A fire has broken out and the fire alarm goes off!")
            (<! (timeout 4000))
            (swap! state assoc-in [:diagnostics :fire-alarm] :activated!)
-           (swap! state assoc :view :diagnostics)
-           (swap! state assoc :scenario "Scenario 1: The graphics show that the fire alarm has been activated.")
+           (fire-alarm)
+           (swap! state assoc :scenario "Scenario 1b: The graphics show that the fire alarm has been activated.")
            (<! (timeout 8000))

            ; stove still on
@@ -79,7 +85,7 @@
            (swap! state assoc-in [:rooms :bathroom :door-open?] true)
            (swap! state assoc-in [:rooms :bedroom :door-open?] true)
            (swap! state assoc :scenario
-                  "Scenario 2: The inhabitant has cooked and eaten breakfast, and is about to leave the house..")
+                  "Scenario 2a: The inhabitant has cooked and eaten breakfast, and is about to leave the house..")
            (<! (timeout 4000))
            (swap! state assoc-in [:rooms :livingroom :lights-off?] true)
            (swap! state assoc-in [:rooms :garage :lights-off?] true)
@@ -88,10 +94,10 @@
            (swap! state assoc-in [:rooms :hall :front-door-locked?] true)
            (swap! state assoc-in [:rooms :livingroom :radio-on?] false)
            (swap! state assoc-in [:rooms :garage :car-in?] false)
-           (swap! state assoc :scenario "Scenario 2: But she forgot to turn off the stove!")
-           (<! (timeout 4000))
-           (swap! state assoc :view :kitchen)
-           (swap! state assoc :scenario "Scenario 2: The still hot stove is shown to the user.")
+           (swap! state assoc :scenario "Scenario 2b: But she forgot to turn off the stove!")
+           (<! (timeout 4000))
+           (stove-on)
+           (swap! state assoc :scenario "Scenario 2c: The still hot stove is shown to the user.")
            (<! (timeout 8000))

            ; out shopping
@@ -101,15 +107,17 @@
            (swap! state assoc-in [:rooms :bedroom :lights-off?] true)
            (swap! state assoc-in [:rooms :bathroom :lights-off?] true)
            (swap! state assoc-in [:rooms :garage :car-in?] false)
-           (swap! state assoc :scenario "Scenario 3: The user is not at home.")
-           (<! (timeout 4000))
-           (swap! state assoc :view :food)
-           (swap! state assoc :scenario "Scenario 3: The shopping list of food items is shown.")
+           (swap! state assoc :scenario "Scenario 3a: The inhabitant is not at home.")
+           (<! (timeout 4000))
+           (shopping)
+           (swap! state assoc :scenario
+                  "Scenario 3b: When she visits the website, the shopping list is shown.")
            (<! (timeout 8000))

            ; laundry
            (reset! state initial-state)
-           (swap! state assoc :scenario "Scenario 4: The user has the day off and the laundry is filling up.")
+           (swap! state assoc :scenario
+                  "Scenario 4a: The inhabitatnt has the day off and the white clothes laundry is about to be full.")
            (swap! state assoc-in [:rooms :bathroom :laundry :whites] 54)
            (swap! state assoc-in [:rooms :bathroom :laundry :colors] 63)
            (<! (timeout 2000))
@@ -120,8 +128,8 @@
            (<! (timeout 2000))
            (swap! state assoc-in [:rooms :bathroom :laundry :whites] 100)
            (<! (timeout 2000))
-           (swap! state assoc :view :bathroom)
-           (swap! state assoc :scenario "Scenario 4: The laundry is full and the bathroom view is presented.")
+           (laundry)
+           (swap! state assoc :scenario "Scenario 4b: The bathroom view is presented.")
            (<! (timeout 8000))

            ; burglary alarm
@@ -130,18 +138,18 @@
            (swap! state assoc-in [:rooms :garage :lights-off?] true)
            (swap! state assoc-in [:rooms :bedroom :lights-off?] true)
            (swap! state assoc-in [:rooms :bathroom :lights-off?] true)
-           (swap! state assoc :scenario "Scenario 5: At nighttime, the motion detector has detected an intruder!")
+           (swap! state assoc :scenario "Scenario 5a: At nighttime, the motion detector has detected an intruder!")
            (<! (timeout 4000))
            (swap! state assoc-in [:diagnostics :burglary-alarm] :activated!)
-           (swap! state assoc :view :diagnostics)
-           (swap! state assoc :scenario "Scenario 5: The graphics shows that the burglary alarm has been activated.")
+           (burglary-alarm)
+           (swap! state assoc :scenario "Scenario 5b: The graphics shows that the burglary alarm has been activated.")
            (<! (timeout 8000))

            ; unlocked door
            (reset! state initial-state)
            (swap! state assoc-in [:rooms :hall :front-door-locked?] true)
            (swap! state assoc-in [:rooms :livingroom :tv-on?] true)
-           (swap! state assoc :scenario "Scenario 6: The inhabitant is about to leave the house..")
+           (swap! state assoc :scenario "Scenario 6a: The inhabitant is about to leave the house..")
            (<! (timeout 4000))
            (swap! state assoc-in [:rooms :livingroom :lights-off?] true)
            (swap! state assoc-in [:rooms :garage :lights-off?] true)
@@ -150,26 +158,30 @@
            (swap! state assoc-in [:rooms :hall :front-door-locked?] false)
            (swap! state assoc-in [:rooms :livingroom :tv-on?] false)
            (swap! state assoc-in [:rooms :garage :car-in?] false)
-           (swap! state assoc :scenario "Scenario 6: He forgot to lock the front door!")
-           (<! (timeout 4000))
-           (swap! state assoc :view :hall)
-           (swap! state assoc :scenario "Scenario 6: The hall view with the front door is presented.")
+           (swap! state assoc :scenario "Scenario 6b: He forgot to lock the front door!")
+           (<! (timeout 4000))
+           (unlocked-door)
+           (swap! state assoc :scenario "Scenario 6c: The hall view with the unlocked front door is shown.")
            (<! (timeout 8000))

            ; dishwasher finished
            (reset! state initial-state)
-           (swap! state assoc :scenario "Scenario 7: The dishwasher is almost done..")
+           (swap! state assoc :scenario "Scenario 7a: The dishwasher is almost done..")
            (swap! state assoc-in [:rooms :kitchen :dish-washer :active?] true)
-           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 9)
-           (<! (timeout 2000))
-           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 6)
-           (<! (timeout 2000))
+           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 5)
+           (<! (timeout 1000))
+           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 4)
+           (<! (timeout 1000))
            (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 3)
-           (<! (timeout 2000))
+           (<! (timeout 1000))
+           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 2)
+           (<! (timeout 1000))
+           (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 1)
+           (<! (timeout 1000))
            (swap! state assoc-in [:rooms :kitchen :dish-washer :time-remaining] 0)
-           (<! (timeout 2000))
-           (swap! state assoc :view :kitchen)
-           (swap! state assoc :scenario "Scenario 7: The dishwasher is done and the kitchen view is presented.")
+           (<! (timeout 500))
+           (dishwasher-finished)
+           (swap! state assoc :scenario "Scenario 7b: The dishwasher is done and the kitchen view is presented.")
            (<! (timeout 8000))

            ; weather in the morning
@@ -179,27 +191,26 @@
            (swap! state assoc-in [:rooms :bedroom :lights-off?] true)
            (swap! state assoc-in [:rooms :bathroom :lights-off?] true)
            (swap! state assoc-in [:rooms :garage :car-in?] false)
-           (swap! state assoc :scenario "Scenario 8: The user prefers to see the weather in the morning.")
+           (swap! state assoc :scenario "Scenario 8a: The inhabitant prefers to see the weather in the morning.")
            (<! (timeout 2000))
            (swap! state assoc-in [:rooms :bedroom :lights-off?] false)
            (<! (timeout 2000))
-           (swap! state assoc :view :weather)
-           (swap! state assoc :scenario "Scenario 8: The weather view is presented.")
+           (morning-weather)
+           (swap! state assoc :scenario "Scenario 8b: The weather view is presented.")
            (<! (timeout 8000))

            ; door and garage port locked at night
            (reset! state initial-state)
-           (swap! state assoc-in [:rooms :garage-port :port-closed?] false)
+           (swap! state assoc-in [:rooms :garage :port-closed?] false)
            (swap! state assoc-in [:rooms :hall :front-door-locked?] false)
+           (swap! state assoc :time "22:00")
            (swap! state assoc :scenario
-                  "Scenario 9: The user has created a rule,
+                  "Scenario 9a: The inhabitant has created a rule,
                   stating that the front door and the garage port shall be automatically locked at 22:00.")
            (<! (timeout 3000))
-           (swap! state assoc-in [:rooms :garage :port-closed?] true)
-           (swap! state assoc-in [:rooms :garage :lights-off?] true)
-           (swap! state assoc-in [:rooms :hall :front-door-locked?] true)
-           (<! (timeout 2000))
-           (swap! state assoc :scenario "Scenario 9: At 22:00, the front door and garage port are locked.")
+           (lock-doors-at-night)
+           (<! (timeout 2000))
+           (swap! state assoc :scenario "Scenario 9b: At 22:00, the front door and garage port are locked.")
            (<! (timeout 8000))

            (recur)))


Improve tests for corn yield data sets

Improve tests for corn yield data sets

--- cortex/test/cljc/cortex/nn/network_test.cljc
+++ cortex/test/cljc/cortex/nn/network_test.cljc
@@ -1,12 +1,12 @@
 (ns cortex.nn.network-test
   (:require
-    [cortex.nn.core :refer [calc output forward backward input-gradient parameters gradient parameter-count]]
+    [cortex.nn.core :refer [calc output calc-output forward backward input-gradient parameters gradient parameter-count]]
     #?(:cljs
         [cljs.test :refer-macros [deftest is are testing]]
         :clj
         [clojure.test :refer [deftest is are testing]])
     [cortex.optimise :as opt]
-    [clojure.core.matrix :as mat]
+    [clojure.core.matrix :as m]
     [clojure.core.matrix.random :as randm]
     #?(:cljs [thi.ng.ndarray.core :as nd])
     [cortex.util :as util]
@@ -14,7 +14,7 @@
     [cortex.nn.core :as core]
     [cortex.nn.layers :as layers]))

-(mat/set-current-implementation #?(:clj :vectorz :cljs :thing-ndarray))
+(m/set-current-implementation #?(:clj :vectorz :cljs :thing-ndarray))

 ; a	b	| a XOR b
 ; 1	1	     0
@@ -48,8 +48,8 @@
   "Define a random dataset and create the labels from some fixed parameters so we know exactly
   what the linear model should learn."
   []
-  (let [x-data (into [] (mat/rows (randm/sample-uniform [100 2])))
-        y-data (into [] (map vector (mat/array (mat/transpose (mat/add (mat/mmul [0.1 0.2] (mat/transpose x-data)) 0.3)))))
+  (let [x-data (into [] (m/rows (randm/sample-uniform [100 2])))
+        y-data (into [] (map vector (m/array (m/transpose (m/add (m/mmul [0.1 0.2] (m/transpose x-data)) 0.3)))))
         model (layers/linear-layer 2 1)
         loss (opt/mse-loss)
         optimizer (opt/sgd-optimiser 0.01 0.9)
@@ -82,15 +82,23 @@
 (def CORN-RESULTS
   [40.32, 42.92, 45.33, 48.85, 52.37, 57.0, 61.82, 69.78, 72.19, 79.42])

-(deftest core-test
+
+(defn corn-test-fn [o]
   (let [net (layers/linear-layer 2 1)
-        n-epochs 5000
+        n-epochs 1500
         batch-size 1
         loss (opt/mse-loss)
-        optimizer (opt/adadelta-optimiser)
+        optimizer o
         data CORN-DATA
         labels CORN-LABELS
         results CORN-RESULTS
         net (net/train net optimizer loss data labels batch-size n-epochs)
-        mse (net/evaluate-mse net data labels)]
+        mse (net/evaluate-mse net data results)]
+    ;; (println (str (class o) ": mse = " mse " predicted = " (mapv (fn [v] (m/coerce [] (calc-output net v))) CORN-DATA)))
     (is (< mse 25))))
+
+(deftest corn-test
+  (testing "ADADELTA" (corn-test-fn (opt/adadelta-optimiser)))
+  (testing "Newton" (corn-test-fn (opt/newton-optimiser)))
+  ;; (testing "SGD" (corn-test-fn (opt/sgd-optimiser))) ;; seems to fail?
+  )


Add aggregations

Add aggregations

--- src/cyanite_fetcher/core.clj
+++ src/cyanite_fetcher/core.clj
@@ -8,6 +8,66 @@
             [clojurewerkz.elastisch.rest.document :as esrd]
             [qbits.alia :as alia])
   (:gen-class))
+
+;;------------------------------------------------------------------------------
+;; Aggregation
+;;------------------------------------------------------------------------------
+
+(defmulti aggregate-with
+  "This transforms a raw list of points according to the provided aggregation
+   method. Each point is stored as a list of data points, so multiple
+   methods make sense (max, min, mean). Additionally, a raw method is
+   provided"
+  (comp first list))
+
+(defmethod aggregate-with :mean
+  [_ {:keys [data] :as metric}]
+  (if (seq data)
+    (-> metric
+        (dissoc :data)
+        (assoc :metric (/ (reduce + 0.0 data) (count data))))
+    metric))
+
+(defmethod aggregate-with :sum
+  [_ {:keys [data] :as metric}]
+  (-> metric
+      (dissoc :data)
+      (assoc :metric (reduce + 0.0 data))))
+
+(defmethod aggregate-with :max
+  [_ {:keys [data] :as metric}]
+  (-> metric
+      (dissoc :data)
+      (assoc :metric (apply max data))))
+
+(defmethod aggregate-with :min
+  [_ {:keys [data] :as metric}]
+  (-> metric
+      (dissoc :data)
+      (assoc :metric (apply min data))))
+
+(defmethod aggregate-with :raw
+  [_ {:keys [data] :as metric}]
+  (-> metric
+      (dissoc :data)
+      (assoc :metric data)))
+
+(defmethod aggregate-with :avg
+           [_ {:keys [data] :as metric}]
+  (if (seq data)
+    (-> metric
+        (dissoc :data)
+        (assoc :metric (/ (reduce + 0.0 data) (count data))))
+    metric))
+
+;;
+;; if no method given parse metric name and select aggregation function
+;;
+(defn detect-aggregate
+  [{:keys [path] :as metric}]
+  (if-let [[_ m] (re-find #"^(sum|avg|mean|min|max|raw)\..*" path)]
+    (aggregate-with (keyword m) metric)
+    (aggregate-with :mean metric)))

 ;;------------------------------------------------------------------------------
 ;; Cassandra
@@ -43,7 +103,7 @@
                                        (int period)
                                        from to]
                               :fetch-size Integer/MAX_VALUE})
-                            ;;(map detect-aggregate)
+                            (map detect-aggregate)
                             (seq)))
                     paths))]
     (map deref futures)))


excessive nesting

excessive nesting

--- examples/ring-swagger/src/example/server.clj
+++ examples/ring-swagger/src/example/server.clj
@@ -13,37 +13,37 @@
 (def app
   (ring/ring-handler
     (ring/router
-      [["/api"
-        {:swagger {:id ::math}}
+      ["/api"
+       {:swagger {:id ::math}}

-        ["/swagger.json"
-         {:get {:no-doc true
-                :swagger {:info {:title "my-api"}}
-                :handler (swagger/create-swagger-handler)}}]
+       ["/swagger.json"
+        {:get {:no-doc true
+               :swagger {:info {:title "my-api"}}
+               :handler (swagger/create-swagger-handler)}}]

-        ["/spec"
-         {:coercion spec/coercion
-          :swagger {:tags ["spec"]}}
+       ["/spec"
+        {:coercion spec/coercion
+         :swagger {:tags ["spec"]}}

-         ["/plus"
-          {:get {:summary "plus with spec"
-                 :parameters {:query {:x int?, :y int?}}
-                 :responses {200 {:body {:total int?}}}
-                 :handler (fn [{{{:keys [x y]} :query} :parameters}]
-                            {:status 200
-                             :body {:total (+ x y)}})}}]]
+        ["/plus"
+         {:get {:summary "plus with spec"
+                :parameters {:query {:x int?, :y int?}}
+                :responses {200 {:body {:total int?}}}
+                :handler (fn [{{{:keys [x y]} :query} :parameters}]
+                           {:status 200
+                            :body {:total (+ x y)}})}}]]

-        ["/schema"
-         {:coercion schema/coercion
-          :swagger {:tags ["schema"]}}
+       ["/schema"
+        {:coercion schema/coercion
+         :swagger {:tags ["schema"]}}

-         ["/plus"
-          {:get {:summary "plus with schema"
-                 :parameters {:query {:x Int, :y Int}}
-                 :responses {200 {:body {:total Int}}}
-                 :handler (fn [{{{:keys [x y]} :query} :parameters}]
-                            {:status 200
-                             :body {:total (+ x y)}})}}]]]]
+        ["/plus"
+         {:get {:summary "plus with schema"
+                :parameters {:query {:x Int, :y Int}}
+                :responses {200 {:body {:total Int}}}
+                :handler (fn [{{{:keys [x y]} :query} :parameters}]
+                           {:status 200
+                            :body {:total (+ x y)}})}}]]]

       {:data {:middleware [ring.middleware.params/wrap-params
                            muuntaja.middleware/wrap-format


adjust lot criteria validation

adjust lot criteria validation

--- src/clj_money/models/storage/sql_storage.clj
+++ src/clj_money/models/storage/sql_storage.clj
@@ -73,9 +73,9 @@

 (defmulti lot-criteria #(contains? % :account-id))
 (defmethod lot-criteria true [_]
-  (s/keys :req-un [::account-id] :opt-un[::commodity-id ::entity-id]))
+  (s/keys :req-un [::account-id] :opt-un[::commodity-id]))
 (defmethod lot-criteria false [_]
-  (s/keys :req-un [::entity-id] :opt-un[::account-id ::commodity-id]))
+  (s/keys :req-un [::commodity-id] :opt-un[::account-id]))
 (s/def ::lot-criteria (s/multi-spec lot-criteria #(contains? % :account-id)))
 (s/def ::lot-transaction-criteria
   (fn [c] (integer? (some #(% c) [:id :lot-id :transaction-id]))))


use partitioning to select transaction records

--- src/clj_money/models/storage/sql_storage.clj
+++ src/clj_money/models/storage/sql_storage.clj
@@ -683,14 +683,16 @@

   ; Transactions
   (select-transactions
-    [_ criteria options]
+    [this criteria options]
     (validate-criteria criteria ::transaction-criteria)
-    (let [sql (-> (h/select :t.*)
-                  (h/from [:transactions :t])
-                  (adjust-select options)
-                  (append-paging options)
-                  (append-transaction-lot-filter criteria))
-          result (query db-spec sql)]
+    (let [d-range (date-range this (:trade-date criteria))
+          result
+          (with-partitioning db-spec :prices d-range options [table]
+            (-> (h/select :t.*)
+                (h/from [:transactions :t])
+                (adjust-select options)
+                #_(append-paging options)
+                (append-transaction-lot-filter criteria)))]
       (if (:count options) ; TODO remove this duplication with select-transaction-items
         (-> result first vals first)
         result)))


Fix a problem checking for block to send (WIP)

Had a misplaced if. I was trying to send a block before I'd checked to
see whether there was one to send.

This fixes that, but the "big send" test goes into a fast infinite loop
near the end, spinning with nothing to send. Haven't had a chance to dig
into that angle yet.

--- src/clojure/frereth_cp/message/to_parent.clj
+++ src/clojure/frereth_cp/message/to_parent.clj
@@ -223,15 +223,20 @@
      current-message-id ::specs/next-message-id
      :as outgoing} ::specs/outgoing
     :as state}]
-  ;; Really just for timing info
-  (log/debug (str message-loop-name ": top of pre-calculate after-send"))
-  (assert next-block-queue
-          (str message-loop-name
-               ": No next-block-queue to tell us what to send\nAvailable:\n"
-               (keys outgoing)))
-  ;; Starts with line 380 sendblock:
-  ;; Resending old block will goto this
-  ;; It's in the middle of a do {} while(0) loop
+  (let [pre-log (utils/pre-log message-loop-name)]
+    ;; Really just for timing info
+    (log/debug pre-log
+               "top of pre-calculate after-send")
+    (assert next-block-queue
+            (str pre-log
+                 "No next-block-queue to tell us what to send\nAvailable:\n"
+                 (keys outgoing)
+                 "\nHopeful: \""
+                 next-block-queue
+                 "\""))
+    ;; Starts with line 380 sendblock:
+    ;; Resending old block will goto this
+    ;; It's in the middle of a do {} while(0) loop

 ;;;      382-404:  Build the message packet
 ;;;                N.B.: Ignores most of the ACK bits
@@ -243,89 +248,91 @@
 ;;;                the write to FD9 at offset +7, which is the
 ;;;                len/16 byte.
 ;;;                So everything else is shifted right by 8 bytes
-  (let [q (get-in state [::specs/outgoing next-block-queue])
-        current-message (first q)]
-    (log/debug (str message-loop-name
-                    ": Next message should come from "
-                    (count q)
-                    " block(s) in\n"
-                    next-block-queue
-                    "\ninside\n"
-                    (::specs/outgoing state)))
-    (let [transmission-count (::specs/transmissions current-message)]
-      (assert transmission-count
-              (str message-loop-name
-                   ": Missing ::transmissions under "
-                   next-block-queue)))
-    ;; Q: How much time could I save right here and now by making
-    ;; state transient?
-    ;; (possibly using something like proteus)
-    (let [next-message-id (let [n' (inc current-message-id)]
-                            ;; Stupid unsigned math
-                            ;; Actually, this seems even more problematic
-                            ;; than it looks at first glance.
-                            ;; Really shouldn't be reusing IDs.
-                            ;; Q: Does that matter?
-                            (if (> n' shared-K/max-32-uint)
-                              ;; TODO: Just roll with the negative IDs. The only
-                              ;; one that's special is 0
-                              1 n'))]
-      ;; It's tempting to pop that message off of whichever queue is its current home.
-      ;; That doesn't make sense here/yet.
-      ;; Either we're resending a previous message that never got ACK'd (in which
-      ;; case it must stay exactly where it is until we *do* get an ACK), or we're
-      ;; sending a new message.
-      ;; If it's the latter, it *does* need to move from the un-sent queue to the
-      ;; un-ackd queue.
-      ;; But that's an operation to handle elsewhere.
-      (assert current-message)
-      ;; It's tempting to try to re-use a previously sent message ID for a re-send.
-      ;; After all, if I send message 39, then resend it as message 50, then get
-      ;; an ACK for message 39, the only way I have to correlate that to message
-      ;; 50 is the stream address.
-      ;; Which should be good enough.
-      ;; And this seems like a better way to debug messages on the wire.
-      ;; And this is the way the reference implementation works.
-      (let [state' (assoc-in state [::specs/outgoing ::specs/next-message-id] next-message-id)
-            updated-message (-> current-message
-                                (update ::specs/transmissions inc)
-                                (assoc ::specs/time recent)
-                                (assoc ::specs/message-id current-message-id))]
-        (log/debug (str message-loop-name
-                    ": Getting ready to build message block for message "
-                        current-message-id
-                        "\nbased on:\n")
-                   (utils/pretty current-message))
-        (let [buf (build-message-block-description message-loop-name
-                                                   current-message-id
-                                                   updated-message)
-              ;; Reference implementation waits until after the actual write before setting any of
-              ;; the next pieces. But it's a single-threaded process that's going to block at the write,
-              ;; and this part's purely functional anyway. So it should be safe enough to set up
-              ;; this transition here
-              result (update state'
-                             ::specs/outgoing
-                             (fn [cur]
-                               (assoc cur
-                                      ;; Q: Is it really worth tracking this separately?
-                                      ;; A: Yes, absolutely.
-                                      ;; It *is* readily available in un-ackd-blocks,
-                                      ;; until the last block gets ACK'd.
-                                      ::specs/last-block-time recent
-                                      ;; Q: How wise is it to inject send-buf here?
-                                      ::specs/send-buf buf
-                                      ::specs/want-ping false)))]
-          (log/debug (utils/pre-log message-loop-name)
-                     "Next block built and control state updated to"
-                     result)
-          ;; It's tempting to split this part up to avoid the conditional.
-          ;; Maybe turn the call into a multimethod.
-          ;; The latter would be a mistake, since there are
-          ;; really only 2 possibilities (I'm sending a new block or
-          ;; resending one that had its ACK timeout)
-          (if (= ::specs/un-sent-blocks next-block-queue)
-            (mark-block-sent result updated-message)
-            (mark-block-resent result current-message updated-message)))))))
+    (let [q (get-in state [::specs/outgoing next-block-queue])
+          current-message (first q)]
+      (log/debug (str message-loop-name
+                      ": Next message should come from "
+                      (count q)
+                      " block(s) in\n"
+                      next-block-queue
+                      "\ninside\n"
+                      (::specs/outgoing state)))
+      (let [transmission-count (::specs/transmissions current-message)]
+        (assert transmission-count
+                (str message-loop-name
+                     ": Missing ::transmissions under "
+                     next-block-queue
+                     " for "
+                     current-message)))
+      ;; Q: How much time could I save right here and now by making
+      ;; state transient?
+      ;; (possibly using something like proteus)
+      (let [next-message-id (let [n' (inc current-message-id)]
+                              ;; Stupid unsigned math
+                              ;; Actually, this seems even more problematic
+                              ;; than it looks at first glance.
+                              ;; Really shouldn't be reusing IDs.
+                              ;; Q: Does that matter?
+                              (if (> n' shared-K/max-32-uint)
+                                ;; TODO: Just roll with the negative IDs. The only
+                                ;; one that's special is 0
+                                1 n'))]
+        ;; It's tempting to pop that message off of whichever queue is its current home.
+        ;; That doesn't make sense here/yet.
+        ;; Either we're resending a previous message that never got ACK'd (in which
+        ;; case it must stay exactly where it is until we *do* get an ACK), or we're
+        ;; sending a new message.
+        ;; If it's the latter, it *does* need to move from the un-sent queue to the
+        ;; un-ackd queue.
+        ;; But that's an operation to handle elsewhere.
+        (assert current-message)
+        ;; It's tempting to try to re-use a previously sent message ID for a re-send.
+        ;; After all, if I send message 39, then resend it as message 50, then get
+        ;; an ACK for message 39, the only way I have to correlate that to message
+        ;; 50 is the stream address.
+        ;; Which should be good enough.
+        ;; And this seems like a better way to debug messages on the wire.
+        ;; And this is the way the reference implementation works.
+        (let [state' (assoc-in state [::specs/outgoing ::specs/next-message-id] next-message-id)
+              updated-message (-> current-message
+                                  (update ::specs/transmissions inc)
+                                  (assoc ::specs/time recent)
+                                  (assoc ::specs/message-id current-message-id))]
+          (log/debug pre-log
+                     (str "Getting ready to build message block for message "
+                          current-message-id
+                          "\nbased on:\n")
+                     (utils/pretty current-message))
+          (let [buf (build-message-block-description message-loop-name
+                                                     current-message-id
+                                                     updated-message)
+                ;; Reference implementation waits until after the actual write before setting any of
+                ;; the next pieces. But it's a single-threaded process that's going to block at the write,
+                ;; and this part's purely functional anyway. So it should be safe enough to set up
+                ;; this transition here
+                result (update state'
+                               ::specs/outgoing
+                               (fn [cur]
+                                 (assoc cur
+                                        ;; Q: Is it really worth tracking this separately?
+                                        ;; A: Yes, absolutely.
+                                        ;; It *is* readily available in un-ackd-blocks,
+                                        ;; until the last block gets ACK'd.
+                                        ::specs/last-block-time recent
+                                        ;; Q: How wise is it to inject send-buf here?
+                                        ::specs/send-buf buf
+                                        ::specs/want-ping false)))]
+            (log/debug pre-log
+                       "Next block built and control state updated to"
+                       result)
+            ;; It's tempting to split this part up to avoid the conditional.
+            ;; Maybe turn the call into a multimethod.
+            ;; The latter would be a mistake, since there are
+            ;; really only 2 possibilities (I'm sending a new block or
+            ;; resending one that had its ACK timeout)
+            (if (= ::specs/un-sent-blocks next-block-queue)
+              (mark-block-sent result updated-message)
+              (mark-block-resent result current-message updated-message))))))))

 (s/fdef check-for-previous-block-to-resend
         :args ::specs/state
@@ -579,23 +586,23 @@
   ;; of having it return nil like this.
   ;; That seems like a better API.
   ;; TODO: Make that so.
-  (let [state' (pick-next-block-to-send state)
-        {{:keys [::specs/->parent
-                 ::specs/next-block-queue
-                 ::specs/send-buf
-                 ::specs/un-ackd-blocks]} ::specs/outgoing
-         :as state''} (pre-calculate-state-after-send state')]
+  (let [{{:keys [::specs/next-block-queue]} ::specs/outgoing
+         :as state'} (pick-next-block-to-send state)
+        pre-log (utils/pre-log message-loop-name)]
     (if next-block-queue
-      (do
-        (log/debug (str message-loop-name
-                        ": Sending "
-                        (count send-buf)
-                        " bytes to parent"))
+      (let [{{:keys [::specs/->parent
+                     ::specs/send-buf
+                     ::specs/un-ackd-blocks]} ::specs/outgoing
+             :as state''} (pre-calculate-state-after-send state')]
+        (log/debug pre-log
+                   "Sending"
+                   (count send-buf)
+                   "bytes to parent")
         ;; Note that this winds up doing a send to the message
         ;; loop's agent.

         (block->parent! ->parent send-buf)
-        (log/debug (utils/pre-log message-loop-name)
+        (log/debug pre-log
                    (str "Calculating earliest time among "
                         (count un-ackd-blocks)
                         " blocks\nthat have not been ACK'd in a "
@@ -609,4 +616,7 @@
             (assoc-in [::specs/outgoing ::specs/earliest-time]
                       (help/earliest-block-time message-loop-name un-ackd-blocks))
             (update ::specs/outgoing dissoc ::specs/next-block-queue)))
-      state)))
+      (do
+        (log/debug pre-log
+                   "Nothing to send")
+        state))))


More boolean instructions; back to addition/combination-deletion operators.

--- src/clojush/problems/classification/penn.clj
+++ src/clojush/problems/classification/penn.clj
@@ -132,13 +132,17 @@
                             (list (tag-instruction-erc [:exec :integer :boolean :string] 1000)
                                   (tagged-instruction-erc 1000)
                                   (fn [] (lrand-int 1000))))
-                    (for [n (map inc
+                    (for [n (map inc ;; inputs
                                  (range (count (:inputs (first (:train @penn-fitness-cases))))))]
                       (symbol (str "in" n)))
                     (concat (registered-for-stacks [:exec :integer :boolean :parentheses])
-                            '(string_pop string_dup string_dup_times string_dup_items
+                            '(string_pop string_dup string_dup_times string_dup_items ;; just stack ops for strings, for outputs
                                          string_swap string_rot string_flush string_eq string_stackdepth
-                                         string_yank string_yankdup string_shove string_empty))))
+                                         string_yank string_yankdup string_shove string_empty))
+                    (map first ;; more of anything that usese booleans
+                         (filter (fn [[instr instr-fn]]
+                                   (some #{boolean} (:stack-types (meta instr-fn))))
+                                 @instruction-table))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Main call
@@ -152,17 +156,17 @@
    :population-size 1000
    :max-generations 300
    :parent-selection :lexicase
-   :genetic-operator-probabilities {:alternation 0.2
-                                    :uniform-mutation 0.2
-                                    :uniform-close-mutation 0.1
-                                    [:alternation :uniform-mutation] 0.5
-                                    ;:genesis 0.1 ;***
-                                    }
+   ;:genetic-operator-probabilities {:alternation 0.2
+   ;                                 :uniform-mutation 0.2
+   ;                                 :uniform-close-mutation 0.1
+   ;                                 [:alternation :uniform-mutation] 0.5
+   ;                                 ;:genesis 0.1 ;***
+   ;                                 }
    ;:genetic-operator-probabilities {:uniform-addition-and-deletion 0.45
    ;                                 :uniform-combination-and-deletion 0.45
    ;                                 :genesis 0.1}
-   ;:genetic-operator-probabilities {:uniform-addition-and-deletion 0.9
-   ;                                 :uniform-combination-and-deletion 0.1}
+   :genetic-operator-probabilities {:uniform-addition-and-deletion 0.9
+                                    :uniform-combination-and-deletion 0.1}
    :uniform-addition-and-deletion-rate [0.1 0.01] ;[1/16 1/32 1/64 1/128]
    :uniform-combination-and-deletion-rate 1 ;[1 1/2 1/4 1/8]
    :alternation-rate 0.01


Added guards to domain and subdomain event insert

--- src/chronograph/data.clj
+++ src/chronograph/data.clj
@@ -55,18 +55,20 @@
     (catch Exception e (prn "EXCEPTION" e))))

 (defn insert-domain-event [domain type-id source-id date cnt]
-  (try
-    (k/exec-raw ["INSERT INTO referrer_domain_events (domain, type, source, event, inserted, count) VALUES (?, ?, ?, ?, ?, ?) ON DUPLICATE KEY UPDATE event = ?, count = ?"
-                 [domain type-id source-id (coerce/to-sql-time date) (coerce/to-sql-time (t/now)) (or cnt 1)
-                  (coerce/to-sql-time date) (or cnt 1)]])
-    (catch Exception e (prn "EXCEPTION" e))))
+  (when (and (< (.length domain) 128))
+    (try
+      (k/exec-raw ["INSERT INTO referrer_domain_events (domain, type, source, event, inserted, count) VALUES (?, ?, ?, ?, ?, ?) ON DUPLICATE KEY UPDATE event = ?, count = ?"
+                   [domain type-id source-id (coerce/to-sql-time date) (coerce/to-sql-time (t/now)) (or cnt 1)
+                    (coerce/to-sql-time date) (or cnt 1)]])
+      (catch Exception e (prn "EXCEPTION" e)))))

 (defn insert-subdomain-event [host domain type-id source-id date cnt]
-  (try
-    (k/exec-raw ["INSERT INTO referrer_subdomain_events (subdomain, domain, type, source, event, inserted, count) VALUES (?, ?, ?, ?, ?, ?, ?) ON DUPLICATE KEY UPDATE event = ?, count = ?"
-                 [host domain type-id source-id (coerce/to-sql-time date) (coerce/to-sql-time (t/now)) (or cnt 1)
-                  (coerce/to-sql-time date) (or cnt 1)]])
-    (catch Exception e (prn "EXCEPTION" e))))
+  (when (and (< (.length domain) 128) (< (.length host) 128))
+    (try
+      (k/exec-raw ["INSERT INTO referrer_subdomain_events (subdomain, domain, type, source, event, inserted, count) VALUES (?, ?, ?, ?, ?, ?, ?) ON DUPLICATE KEY UPDATE event = ?, count = ?"
+                   [host domain type-id source-id (coerce/to-sql-time date) (coerce/to-sql-time (t/now)) (or cnt 1)
+                    (coerce/to-sql-time date) (or cnt 1)]])
+      (catch Exception e (prn "EXCEPTION" e)))))

 (defn insert-events-chunk
   "Insert chunk of inputs to insert-event"


perf tweaks (and, unrolling, nonconforming in nilable)

--- src/clj/clojure/spec.clj
+++ src/clj/clojure/spec.clj
@@ -952,17 +952,39 @@
   [keys forms preds gfn]
   (let [id (java.util.UUID/randomUUID)
         kps (zipmap keys preds)
-        cform (let [specs (delay (mapv specize preds))]
-                (fn [x]
-                  (let [specs @specs]
-                    (loop [i 0]
-                      (if (< i (count specs))
-                        (let [spec (specs i)]
-                          (let [ret (conform* spec x)]
-                            (if (= ::invalid ret)
-                              (recur (inc i))
-                              (tagged-ret (keys i) ret))))
-                        ::invalid)))))]
+        specs (delay (mapv specize preds))
+        cform (case (count preds)
+                    2 (fn [x]
+                        (let [specs @specs
+                              ret (conform* (specs 0) x)]
+                          (if (= ::invalid ret)
+                            (let [ret (conform* (specs 1) x)]
+                              (if (= ::invalid ret)
+                                ::invalid
+                                (tagged-ret (keys 1) ret)))
+                            (tagged-ret (keys 0) ret))))
+                    3 (fn [x]
+                        (let [specs @specs
+                              ret (conform* (specs 0) x)]
+                          (if (= ::invalid ret)
+                            (let [ret (conform* (specs 1) x)]
+                              (if (= ::invalid ret)
+                                (let [ret (conform* (specs 2) x)]
+                                  (if (= ::invalid ret)
+                                    ::invalid
+                                    (tagged-ret (keys 2) ret)))
+                                (tagged-ret (keys 1) ret)))
+                            (tagged-ret (keys 0) ret))))
+                    (fn [x]
+                      (let [specs @specs]
+                        (loop [i 0]
+                          (if (< i (count specs))
+                            (let [spec (specs i)]
+                              (let [ret (conform* spec x)]
+                                (if (= ::invalid ret)
+                                  (recur (inc i))
+                                  (tagged-ret (keys i) ret))))
+                            ::invalid)))))]
     (reify
      Spec
      (conform* [_ x] (cform x))
@@ -1014,14 +1036,42 @@
 (defn ^:skip-wiki and-spec-impl
   "Do not call this directly, use 'and'"
   [forms preds gfn]
-  (reify
-   Spec
-   (conform* [_ x] (and-preds x preds forms))
-   (unform* [_ x] (reduce #(unform %2 %1) x (reverse preds)))
-   (explain* [_ path via in x] (explain-pred-list forms preds path via in x))
-   (gen* [_ overrides path rmap] (if gfn (gfn) (gensub (first preds) overrides path rmap (first forms))))
-   (with-gen* [_ gfn] (and-spec-impl forms preds gfn))
-   (describe* [_] `(and ~@forms))))
+  (let [specs (delay (mapv specize preds))
+        cform
+        (case (count preds)
+              2 (fn [x]
+                  (let [specs @specs
+                        ret (conform* (specs 0) x)]
+                    (if (= ::invalid ret)
+                      ::invalid
+                      (conform* (specs 1) ret))))
+              3 (fn [x]
+                  (let [specs @specs
+                        ret (conform* (specs 0) x)]
+                    (if (= ::invalid ret)
+                      ::invalid
+                      (let [ret (conform* (specs 1) ret)]
+                        (if (= ::invalid ret)
+                          ::invalid
+                          (conform* (specs 2) ret))))))
+              (fn [x]
+                (let [specs @specs]
+                  (loop [ret x i 0]
+                    (if (< i (count specs))
+                      (let [nret (conform* (specs i) ret)]
+                        (if (= ::invalid nret)
+                          ::invalid
+                          ;;propagate conformed values
+                          (recur nret (inc i))))
+                      ret)))))]
+    (reify
+     Spec
+     (conform* [_ x] (cform x))
+     (unform* [_ x] (reduce #(unform %2 %1) x (reverse preds)))
+     (explain* [_ path via in x] (explain-pred-list forms preds path via in x))
+     (gen* [_ overrides path rmap] (if gfn (gfn) (gensub (first preds) overrides path rmap (first forms))))
+     (with-gen* [_ gfn] (and-spec-impl forms preds gfn))
+     (describe* [_] `(and ~@forms)))))

 (defn ^:skip-wiki merge-spec-impl
   "Do not call this directly, use 'merge'"
@@ -1609,10 +1659,27 @@
      (with-gen (clojure.spec/& (* (cat ::k keyword? ::v any?)) ::kvs->map mspec#)
        (fn [] (gen/fmap (fn [m#] (apply concat m#)) (gen mspec#))))))

+(defn nonconforming
+  "takes a spec and returns a spec that has the same properties except
+  'conform' returns the original (not the conformed) value. Note, will specize regex ops."
+  [spec]
+  (let [spec (specize spec)]
+    (reify
+     Spec
+     (conform* [_ x] (let [ret (conform* spec x)]
+                       (if (= ::invalid ret)
+                         ::invalid
+                         x)))
+     (unform* [_ x] (unform* spec x))
+     (explain* [_ path via in x] (explain* spec path via in x))
+     (gen* [_ overrides path rmap] (gen* spec overrides path rmap))
+     (with-gen* [_ gfn] (nonconforming (with-gen* spec gfn)))
+     (describe* [_] `(nonconforming ~(describe* spec))))))
+
 (defmacro nilable
-  "returns a spec that accepts nil and values satisfiying pred"
+  "returns a spec that accepts nil and values satisfying pred"
   [pred]
-  `(and (or ::nil nil? ::pred ~pred) (conformer second #(if (nil? %) [::nil nil] [::pred %]))))
+  `(nonconforming (or ::nil nil? ::pred ~pred)))

 (defn exercise
   "generates a number (default 10) of values compatible with spec and maps conform over them,


Removed parser.clj -- now exists in geocoder project.

--- src/clj/forma/parser.clj
+++ src/clj/forma/parser.clj
@@ -1,42 +0,0 @@
-;; For a little more about the zipper data structure, take a look:
-;; http://en.wikibooks.org/wiki/Clojure_Programming/Examples/API_Examples/Advanced_Data_Structures#zipper
-
-(ns forma.parser
-  (:use cascalog.api)
-  (:require (clojure.contrib.http [agent :as h])
-            (clojure [xml :as x] [zip :as z])
-            (clojure.contrib.zip-filter [xml :as zf])))
-
-(defn coord-piece
-  "Generates a function that extracts either lat or lng from a
-  supplied xml zipper."
-  [lat-or-lng]
-  (fn [zipper]
-    (first (zf/xml-> zipper :result :geometry :location lat-or-lng zf/text))))
-
-(def lat (coord-piece :lat))
-(def lng (coord-piece :lng))
-
-(defn parse
-  "Parses the xml at a given address into zipper format, and returns a
-  [lat lng] vector. For bad addresses, we'll get [nil, nil]."
-  [addr]
-  (let [xml-zipper (z/xml-zip (x/parse addr))]
-    [(lat xml-zipper) (lng xml-zipper)]))
-
-(defn geocode
-  "Returns the lat and long for a given address line."
-  [line]
-  (parse (str "http://maps.google.com/maps/api/geocode/xml?address="
-              line
-              "&sensor=false")))
-
-(defn process-addresses
-  "Cascalog query to parse all files in a given directory, and print
-  (lat, lng, address) to stdout. All bad addresses are stacked up at
-  the beginning."
-  [dir]
-  (let [source (hfs-textline dir)]
-    (?<- (stdout) [!!lat !!lng ?line]
-         (source ?line)
-         (geocode ?line :> !!lat !!lng))))


finished the monster build windows function.

--- src/clj/forma/trends.clj
+++ src/clj/forma/trends.clj
@@ -234,36 +234,7 @@
                                [row-aggr (in-syms 1) int-sym :> (out-syms 1) (out-syms 2)]])]
     win-source))

-
-;; ALSO WORKING
-(defn build-windows
-  "Accepts a cascalog generator, and a vector of keys corresponding to the "
-  [gen in-syms edge splits empty-val]
-  (let [split-width (/ edge splits)
-        mk-empty #(matrix-of empty-val % split-width)
-        dim-aggr (partial p/vals->sparsevec edge splits)
-
-        [in-pos [val]] (split-at (dec (count in-syms)) in-syms)
-        pos-syms (v/gen-non-nullable-vars 2)
-        val-syms (v/gen-non-nullable-vars 2) ; equal to dimensions?
-
-        ;; Swap out vars.
-        src-vars (get-out-fields gen)
-        swap #(replace (zipmap in-syms %) src-vars)
-
-        ;;1st dimensional change
-        row-source (construct (swap [(nth in-pos 1) (pos-syms 0) (val-syms 0)])
-                              [(into [gen] src-vars)
-                               [(dim-aggr (mk-empty 0))
-                                (nth in-pos 0) val :> (pos-syms 0) (val-syms 0)]])
-
-        ;; second dimensional change
-        win-source (construct (swap [(pos-syms 0) (pos-syms 1) (val-syms 1)])
-                              [(into [row-source] (swap [(nth in-pos 1) (pos-syms 0) (val-syms 0)]))
-                               [(dim-aggr (mk-empty 1))
-                                (nth in-pos 1) (val-syms 0) :> (pos-syms 1) (val-syms 1)]])]
-    win-source))
-
+;; WORKING
 (defn build-windows
   "Accepts a cascalog generator, and a vector of keys corresponding to the "
   [gen in-syms edge splits empty-val]
@@ -271,36 +242,19 @@
         split-width (/ edge splits)
         mk-empty #(matrix-of empty-val % split-width)
         dim-aggr (partial p/vals->sparsevec edge splits)
-        [in-pos [val]] (split-at dimensions in-syms)
-        pos-syms (v/gen-non-nullable-vars dimensions)
-        val-syms (cons val (v/gen-non-nullable-vars dimensions)) ; equal to dimensions?
-
-        ;; Swap out vars.
-        src-vars (get-out-fields gen)
-        swap #(replace (zipmap in-syms %) src-vars)
+        [pos-syms val-syms] (map #(into (vec %)
+                                        (v/gen-non-nullable-vars dimensions))
+                                 (split-at dimensions in-syms))
+        swap #(replace (zipmap in-syms %)
+                       (get-out-fields gen))

-        ;;1st dimensional change
-        row-source (construct (swap [(nth in-pos 1) (nth pos-syms 0) (nth val-syms 1)])
-                              [(into [gen] (swap [(nth in-pos 0) (nth in-pos 1) (nth val-syms 0)]))
-                               [(dim-aggr (mk-empty 0))
-                                (nth in-pos 0) (nth val-syms 0) :> (nth pos-syms 0) (nth val-syms 1)]])
-
-        ;; second dimensional change
-        win-source (construct (swap [(nth pos-syms 0) (nth pos-syms 1) (nth val-syms 2)])
-                              [(into [row-source] (swap [(nth in-pos 1) (nth pos-syms 0) (nth val-syms 1)]))
-                               [(dim-aggr (mk-empty 1))
-                                (nth in-pos 1) (nth val-syms 1) :> (nth pos-syms 1) (nth val-syms 2)]])]
-    win-source))
-
-(defn const-dim
-  "NOTE THAT WE AGGREGATE DIMENSIONS FROM LEFT TO RIGHT. First
-  dimension is going to be the width, then height is the second
-  dimension. I think that reversing this, and counting down from dim
-  on the in-pos var at the end would fix this."
-  [dim src]
-  (let [dims 2
-        ()])
-  (construct (swap [(nth pos-syms 0) (nth pos-syms 1) (nth val-syms 2)])
-             [(into [src] (swap [(nth in-pos 1) (nth pos-syms 0) (nth val-syms 1)]))
-              [(dim-aggr (mk-empty dim))
-               (nth in-pos dim) (nth val-syms dim) :> (nth pos-syms dim) (nth val-syms (inc dim))]]))
+        const-dim (fn [dim src]
+                    (let [[inpos nextpos outpos] (map #(nth pos-syms %) [dim (inc dim) (+ dim dimensions)])
+                          [inval outval] (map #(nth val-syms %) [dim (inc dim)])]
+                      (construct (swap [nextpos outpos outval])
+                                 [(into [src] (swap [inpos nextpos inval]))
+                                  [(dim-aggr (mk-empty dim)) inpos inval :> outpos outval]])))]
+    (reduce #(%2 %1)
+            gen
+            (for [d (range dimensions)]
+              (partial const-dim d)))))


:tada: Add hooks and memoization to group components.

--- frontend/src/uxbox/main/ui/shapes/group.cljs
+++ frontend/src/uxbox/main/ui/shapes/group.cljs
@@ -2,7 +2,10 @@
 ;; License, v. 2.0. If a copy of the MPL was not distributed with this
 ;; file, You can obtain one at http://mozilla.org/MPL/2.0/.
 ;;
-;; Copyright (c) 2016-2019 Andrey Antukh <niwi@niwi.nz>
+;; This Source Code Form is "Incompatible With Secondary Licenses", as
+;; defined by the Mozilla Public License, v. 2.0.
+;;
+;; Copyright (c) 2020 UXBOX Labs SL

 (ns uxbox.main.ui.shapes.group
   (:require
@@ -20,36 +23,62 @@

 (defonce ^:dynamic *debug* (atom false))

+(defn- equals?
+  [np op]
+  (let [n-shape (unchecked-get np "shape")
+        o-shape (unchecked-get op "shape")
+        n-frame (unchecked-get np "frame")
+        o-frame (unchecked-get op "frame")]
+    (and (= n-frame o-frame)
+         (= n-shape o-shape))))
+
 (declare translate-to-frame)
 (declare group-shape)

-(defn group-wrapper [shape-wrapper]
-  (mf/fnc group-wrapper
-   {::mf/wrap-props false}
-   [props]
-   (let [shape (unchecked-get props "shape")
-         frame (unchecked-get props "frame")
-         on-mouse-down #(common/on-mouse-down % shape)
-         on-context-menu #(common/on-context-menu % shape)
-         children (-> (refs/objects-by-id (:shapes shape)) mf/deref)
-         is-child-selected? (-> (refs/is-child-selected? (:id shape)) mf/deref)
-         on-double-click
-         (fn [event]
-           (dom/stop-propagation event)
-           (dom/prevent-default event)
-           (st/emit! (dw/select-inside-group
-                      (:id shape)
-                      @ms/mouse-position)))]
+(defn group-wrapper
+  [shape-wrapper]
+  (let [group-shape (group-shape shape-wrapper)]
+    (mf/fnc group-wrapper
+      {::mf/wrap [#(mf/memo' % equals?)]
+       ::mf/wrap-props false}
+      [props]
+      (let [shape (unchecked-get props "shape")
+            frame (unchecked-get props "frame")
+            on-mouse-down   (mf/use-callback (mf/deps shape)
+                                             #(common/on-mouse-down % shape))
+            on-context-menu (mf/use-callback (mf/deps shape)
+                                             #(common/on-context-menu % shape))

-     [:g.shape {:on-mouse-down on-mouse-down
-                :on-context-menu on-context-menu
-                :on-double-click on-double-click}
-      [:& (group-shape shape-wrapper) {:frame frame
-                                       :shape (geom/transform-shape frame shape)
-                                       :children children
-                                       :is-child-selected? is-child-selected?}]])))
+            children-ref   (mf/use-memo (mf/deps shape)
+                                        #(refs/objects-by-id (:shapes shape)))
+            children       (mf/deref children-ref)

-(defn group-shape [shape-wrapper]
+
+            is-child-selected-ref (mf/use-memo (mf/deps (:id shape))
+                                               #(refs/is-child-selected? (:id shape)))
+            is-child-selected?    (mf/deref is-child-selected-ref)
+
+            on-double-click
+            (mf/use-callback
+             (mf/deps (:id shape))
+             (fn [event]
+               (dom/stop-propagation event)
+               (dom/prevent-default event)
+               (st/emit! (dw/select-inside-group (:id shape) @ms/mouse-position))))]
+
+        [:g.shape
+         {:on-mouse-down on-mouse-down
+          :on-context-menu on-context-menu
+          :on-double-click on-double-click}
+
+         [:& group-shape
+          {:frame frame
+           :shape (geom/transform-shape frame shape)
+           :children children
+           :is-child-selected? is-child-selected?}]]))))
+
+(defn group-shape
+  [shape-wrapper]
   (mf/fnc group-shape
     {::mf/wrap-props false}
     [props]
@@ -68,12 +97,13 @@
                                   (+ y (/ height 2))))]
       [:g {:transform transform}
        (for [item children]
-         [:& shape-wrapper {:frame frame
-                            :shape (cond-> item
-                                       displacement-modifier (assoc :displacement-modifier displacement-modifier)
-                                       resize-modifier (assoc :resize-modifier resize-modifier))
-                            :key (:id item)}])
-
+         [:& shape-wrapper
+          {:frame frame
+           :shape (cond-> item
+                    displacement-modifier (assoc :displacement-modifier displacement-modifier)
+                    resize-modifier (assoc :resize-modifier resize-modifier))
+           :key (:id item)}])
+
        (when (not is-child-selected?)
          [:rect {:x x
                  :y y


hacky prod pepl

hacky prod pepl

--- src/clj/unfolds/core.clj
+++ src/clj/unfolds/core.clj
@@ -32,10 +32,15 @@

 (comment

+   ;; HACKY PROD REPL
+
+  ;; sudo lein repl
+  (use 'unfolds.core)
+  (use 'ring.adapter.jetty)
   (start)
-  (service {:port "8081"})
-  ;; what is req?
+  (def jetty (run-jetty service {:port 80 :join? false}))

-  @servlet-system
-
-  )
+  ;; then to stop it
+  (.stop jetty)
+
+)


abstract on interval

abstract on interval

--- src/cljs/bardo/core.cljs
+++ src/cljs/bardo/core.cljs
@@ -20,6 +20,34 @@
     (.call now (.-performance js/window))
     (.now js/Date)))

+(defn on-interval
+  "runs a function intended to produce side effects at a target speed while the function returns truthy"
+  ([step] (on-interval step {}))
+  ([step {:keys [target tolerance step]
+          :or {target 16
+               tolerance 1
+               step 0.5}}]
+     (go-loop [last-time (t/now)
+               wait target]
+
+              (let [time (now)]
+
+                (when (step time)
+
+                  ;; converge wait time on 60fps and recur
+                  (let [last (- time last-time)
+                        new (if (< (- target tolerance)
+                                         last
+                                         (+ target tolerance))
+                                    wait
+                                    ((if (< target last) - +) wait step))]
+
+                    (when (< 0 wait)
+                      (<! (timeout wait)))
+
+                    (recur time
+                           new)))))))
+
 (defn on-raf
   [step]
   (if-let [native (let [vendors ["" "ms" "moz" "webkit" "o"]]
@@ -34,30 +62,7 @@
                (let [time (<! frame)]
                  (when (step time)
                    (recur)))))
-    (let [speed-target 16
-          speed-tolerance 1
-          speed-step 0.5]
-
-      (go-loop [last-time (t/now)
-                wait speed-target]
-
-               (let [time (now)]
-
-                 (when (step time)
-
-                   ;; converge wait time on 60fps and recur
-                   (let [speed-last (- time last-time)
-                         speed-new (if (< (- speed-target speed-tolerance)
-                                          speed-last
-                                          (+ speed-target speed-tolerance))
-                                     wait
-                                     ((if (< speed-target speed-last) - +) wait speed-step))]
-
-                     (when (< 0 wait)
-                       (<! (timeout wait)))
-
-                     (recur time
-                            speed-new))))))))
+    (on-interval step {:target 16})))

 (defn transition
   ([state target] (transition state target 500))


Map difference util

Map difference util

Will use on keys

--- src/cljs/cloj/utils.cljs
+++ src/cljs/cloj/utils.cljs
@@ -1,5 +1,6 @@
 (ns cloj.utils
   (:require
+    [clojure.set :refer [difference]]
     [goog.string :as gstring]
     [goog.string.format :as gformat])
   )
@@ -8,3 +9,18 @@

 (defn format [ arg & args] (apply gstring/format arg args) )

+(defn map-difference
+  [orig other]
+  (let [changed (difference (set orig) (set other))
+        added (difference (set (keys other)) (set (keys orig))) ]
+
+    {:changed (->
+                (fn [r [k v] ]
+                  (assoc r k {:old v :new (k other)}))
+                (reduce {} changed))
+     :added (->>
+              (map (fn [k] [k (k other)]) added)
+              (into {}))
+     }))
+
+


Minor change in docs

Minor change in docs

--- src/clojure/neko/log.clj
+++ src/clojure/neko/log.clj
@@ -18,9 +18,9 @@

     (require '[neko.log :as log])

-    (neko.log/d \"Some log string\" {:foo 1, :bar 2})
-    (neko.log/i \"Logging to custom tag\" [1 2 3] :tag \"custom\")
-    (neko.log/e \"Something went wrong\" [1 2 3] :exception ex)"
+    (log/d \"Some log string\" {:foo 1, :bar 2})
+    (log/i \"Logging to custom tag\" [1 2 3] :tag \"custom\")
+    (log/e \"Something went wrong\" [1 2 3] :exception ex)"
   {:author "Adam Clements"}
   (:import android.util.Log))


max-key added to the restricted list

max-key added to the restricted list

--- src/foreclojure/data_set.clj
+++ src/foreclojure/data_set.clj
@@ -375,7 +375,7 @@
            {:_id 38
             :title "Maximum value"
             :times-solved 0
-	    :restricted ["max"]
+	    :restricted ["max" "max-key"]
             :description "Write a function which takes a variable number of parameters and returns the maximum value."
             :tags ["easy" "core-functions"]
             :tests ["(= (__ 1 8 3 4) 8)"


Use new :text, not :body, and also add a newline since it's a text email

--- src/foreclojure/problems.clj
+++ src/foreclojure/problems.clj
@@ -438,8 +438,9 @@
        {:from "team@4clojure.com"
         :to [email]
         :subject "Problem rejected"
-        :body
-        (str "A problem you've submitted has been rejected, but don't get discouraged!  Check out the reason below, and try again.\n\n"
+        :text
+        (str "A problem you've submitted has been rejected, but don't get discouraged!\n"
+             "Check out the reason below, and try again.\n\n"
              "Title: " title "\n"
              "Tags: " tags "\n"
              "Description: " description "\n"


fix __Schema __type query

fix __Schema __type query

--- src/graphql_clj/resolver.clj
+++ src/graphql_clj/resolver.clj
@@ -25,16 +25,11 @@
                                          :mutationType (if mutation
                                                          (introspection/type-resolver mutation))
                                          :directives []}))
-       [root-query-name "__type"] (fn [context parent & args]
-                                    {:kind nil
-                                     :type-name nil
-                                     :description nil
-                                     :fields []
-                                     :interfaces []
-                                     :possibleTypes nil
-                                     :enumValues nil
-                                     :inputFields nil
-                                     :ofType nil})
+       [root-query-name "__type"] (fn [context parent & rest]
+                                    (let [args (first rest)
+                                          type-name (get args "name")
+                                          type (type/get-type-in-schema schema type-name)]
+                                      (introspection/type-resolver type)))
        ["__Schema" "directives"] (fn [context parent & rest]
                                    [])
        ["__Type" "ofType"] (fn [context parent & rest]


Cleaning up the mess

Cleaning up the mess

--- src/grimoire/api/fs/read.clj
+++ src/grimoire/api/fs/read.clj
@@ -109,7 +109,15 @@

 ;; Read things
 ;;--------------------
-(defmethod api/read-notes :filesystem [config thing]
+(defn -read-group-notes [config thing]
+  (let [thing (ensure-thing thing)
+        h     (thing->notes-handle config thing)]
+    (if (and (.exists h)
+           (.isFile h))
+      (succeed [[nil (slurp h)]])
+      (fail "No such file"))))
+
+(defn -read-general-notes [config thing]
   (let [thing    (ensure-thing thing)
         versions (api/thing->prior-versions config thing)]
     (if (succeed? versions)
@@ -123,6 +131,11 @@

       ;; versions is a Fail, pass it down
       versions)))
+
+(defmethod api/read-notes :filesystem [config thing]
+  (if (#{:group :artifact} (:type thing))
+    (-read-group-notes config thing)
+    (-read-general-notes config thing)))

 (defmethod api/read-examples :filesystem [config thing]
   (let [thing    (ensure-thing thing)
@@ -161,16 +174,16 @@
         versions        (api/thing->prior-versions config thing)]
     (if (succeed? versions)
       (-> (for [thing (result versions)
-               :let  [v (:name (thing->version thing))
-                      h (thing->related-handle config thing)]
-               :when (.exists h)
-               :when (.isFile h)
-               line  (line-seq (io/reader h))
-               :let  [sym (read-string line)]]
-           (-> current-version
-              (->Ns  (namespace sym))
-              (->Def (name sym))))
-         succeed)
+                :let  [v (:name (thing->version thing))
+                       h (thing->related-handle config thing)]
+                :when (.exists h)
+                :when (.isFile h)
+                line  (line-seq (io/reader h))
+                :let  [sym (read-string line)]]
+            (-> current-version
+                (->Ns  (namespace sym))
+                (->Def (name sym))))
+          succeed)

       ;; versions is a Fail, pass it down
       versions)))


Micro-optimize ring handler: remove indirection.

- Partial always goes through a call to apply,
which seq-ifies all arguments.

- Vector implements invoke directly to get an item.

--- systems/ring/src/containium/systems/ring.clj
+++ systems/ring/src/containium/systems/ring.clj
@@ -84,15 +84,16 @@
                                      (or ~@(for [index (range (count sorted))
                                                  :let [app (get sorted index)]]
                                              `(when (matcher ~(:ring-conf app) ~'uri ~'host)
-                                                (let [~'app (get ~'sorted ~index)]
+                                                (let [~'app (~'sorted ~index)]
                                                   (boxure/call-in-box
                                                    (:box ~'app)
                                                    (:handler-fn ~'app)
                                                    ~(if-let [cp (-> app :ring-conf :context-path)]
                                                       `(update-in ~'request [:uri]
                                                                   #(subs % ~(count cp)))
-                                                      'request))))))))]
-                    (partial (eval fn-form) sorted))
+                                                      'request))))))))
+                        handler (eval fn-form)]
+                    (fn [request] (handler sorted request)))
                   (constantly {:status 503 :body "no apps loaded"}))]
     (wrap-try-catch handler)))


Add cljfmt to lein profiles.

Add cljfmt to lein profiles.

--- dotfiles/lein/profiles.clj
+++ dotfiles/lein/profiles.clj
@@ -1,2 +1,3 @@
 {:user {:plugins [[jonase/eastwood "0.2.1"]
+                  [cljfmt "0.1.10"]
                   [cider/cider-nrepl "0.8.2"]]}}


lein-release plugin: bumped version from 0.1.2 to 0.1.3-SNAPSHOT for next development cycle

--- re-frame-simple/project.clj
+++ re-frame-simple/project.clj
@@ -1,4 +1,4 @@
-(defproject re-view/re-frame-simple "0.1.2"
+(defproject re-view/re-frame-simple "0.1.3-SNAPSHOT"

   :description "re-view syntax for re-frame"


work arround not being able to ignore @define in npm files

can't find another way to tell GCC to ignore npm package files
containing @define annotations which don't adhere to the new
strict variant GCC expects.

fixes #765

--- src/main/shadow/build/closure.clj
+++ src/main/shadow/build/closure.clj
@@ -1756,6 +1756,15 @@
           obj)
         (json/write-str))))

+(defn hide-closure-defines [source]
+  ;; source sources like @firebase/util contain
+  ;;   @define {boolean}
+  ;; which Closure interprets as being closure-defines which they seem to be
+  ;; but somehow weren't actually replaced or set during their build
+  ;; Closure errors out when we process it so we just hide it in a way that
+  ;; Closure doesn't complain anymore
+  (str/replace source #"\* @define" "* .define"))
+
 (defn convert-sources-simple*
   "takes a list of :npm sources and rewrites in a browser compatible way, no full conversion"
   [{:keys [js-options mode] :as state} sources]
@@ -1781,7 +1790,7 @@
                               (str "module.exports=(" source ");")

                               :else
-                              source)
+                              (hide-closure-defines source))
                             "\n};"))]

                  (when file


Wrap user routes so that wrap-user-session-check is not invoked instead of 404

--- src/formlogic/routes.clj
+++ src/formlogic/routes.clj
@@ -32,7 +32,7 @@
   (POST "/login" [email password :as req] (controllers/login email password req))
   (GET "/register" [] (views/register-page))
   (POST "/register" [email] (controllers/register email))
-  (handlers/wrap-user-session-check #'user-routes)
+  (wrap-routes #'user-routes handlers/wrap-user-session-check)
   (route/not-found views/not-found-page))

 ;; Note that every time we reload this page, a new in-memory session store is


test hok

test hok

--- src/main/cawala/api/read.clj
+++ src/main/cawala/api/read.clj
@@ -6,7 +6,7 @@
                      :person/relation :friend}
                  2  {:db/id 2 :person/name "Sally" :person/age 22
                      :person/relation :friend}
-                 3  {:db/id 3 :person/name "Allie" :person/age 52
+                 3  {:db/id 3 :person/name "Allie" :person/age 51
                      :person/relation :enemy}
                  4  {:db/id 4 :person/name "Zoe" :person/age 32
                      :person/relation :friend}


Add test user to prevent midje failing in jruby code.

--- test/circle/backend/build/test_run_build.clj
+++ test/circle/backend/build/test_run_build.clj
@@ -1,6 +1,6 @@
 (ns circle.backend.build.test-run-build
   (:use midje.sweet)
-  (:use [circle.backend.build.test-utils :only (minimal-build)])
+  (:use [circle.backend.build.test-utils :only (minimal-build ensure-test-user-and-project ensure-test-project)])
   (:use [circle.backend.action :only (defaction)])
   (:use [circle.backend.build :only (build successful?)])
   (:use [circle.backend.build.run :only (run-build)])
@@ -9,6 +9,7 @@
   (:use [circle.util.predicates :only (ref?)]))

 (circle.db/init)
+(ensure-test-user-and-project)

 (defaction successful-action [act-name]
   {:name act-name}


add security check on query executions.

add security check on query executions.

--- src/metabase/api/meta/dataset.clj
+++ src/metabase/api/meta/dataset.clj
@@ -4,11 +4,13 @@
             [compojure.core :refer [GET POST]]
             [metabase.api.common :refer :all]
             [metabase.driver :as driver]
+            [metabase.models.database :refer [Database]]
             [metabase.util :as u]))

 (defendpoint POST "/"
   "Execute an MQL query and retrieve the results as JSON."
-  [:as {:keys [body]}]
+  [:as {{:keys [database] :as body} :body}]
+  (read-check Database database)
   (let [{:keys [status] :as response} (driver/dataset-query body {:executed_by *current-user-id*})]
     {:status (if (= status :completed) 200 400)
      :body response}))
@@ -17,6 +19,7 @@
   "Execute an MQL query and download the result data as a CSV file."
   [query]
   {query [Required String->Dict]}
+  (read-check Database (:database query))
   (let [{{:keys [columns rows]} :data :keys [status] :as response} (driver/dataset-query query {:executed_by *current-user-id*})]
     (if (= status :completed)
       ;; successful query, send CSV file


Rework some of sample.project.clj.

Rework some of sample.project.clj.

--- sample.project.clj
+++ sample.project.clj
@@ -1,15 +1,15 @@
 ;; This is an annotated example of the options that may be set in a
 ;; project.clj file. It is a fairly contrived example in order to
 ;; cover all options exhaustively; it shouldn't be considered a
-;; representative configuration.
+;; representative configuration. For a more detailed explanation of
+;; some of the terms run "lein help tutorial".

 ;; The project is named "sample", and its group-id is "org.example".
 (defproject org.example/sample "1.0.0-SNAPSHOT" ; version "1.0.0-SNAPSHOT"
   ;; Beyond this point you may prepend a form with unquote, or ~, to eval it.

-  ;; The descrption is used to allow searchability when uploaded to Clojars.
+  ;; The descrption text is searchable from repositories like Clojars.
   :description "A sample project"
-  ;; The URL is also metadata that Clojars uses.
   :url "http://example.org/sample-clojure-project"
   ;; The mailing list of the project. If the project has multiple mailing
   ;; lists, use the :mailing-lists key (bound to a seq of mailing list
@@ -23,10 +23,7 @@
                  :unsubscribe "list-unsubscribe@example.org"}
   ;; The project's license. :distribution should be :repo or :manual;
   ;; :repo means it is ok for public repositories to host this project's
-  ;; artifacts. :licence can be used in place of :license, and for projects
-  ;; which allow their users to choose among several licenses, :licenses
-  ;; and :licences keys are supported. NB. all licenses mentioned in
-  ;; project.clj under any of the supported keys will be put in pom.xml.
+  ;; artifacts. A seq of :licenses is also supported.
   :license {:name "Eclipse Public License - v 1.0"
             :url "http://www.eclipse.org/legal/epl-v10.html"
             :distribution :repo
@@ -46,10 +43,10 @@
   :disable-implicit-clean false
   ;; Delete .class files that do not have a correspoinding package in
   ;; the src/ directory. Workaround for Clojure bug CLJ-322. Causes problems
-  ;; with protocols in upstream libraries.
+  ;; with protocols in upstream libraries; false by default.
   :clean-non-project-classes true
-  ;; Load these namespaces on startup to pick up hooks from
-  ;; them. Hooks are generally included in plugins.
+  ;; Load these namespaces on startup to pick up hooks from them. Hooks
+  ;; generally come from plugins, but may be included in your project source.
   :hooks [leiningen.hooks.difftest]
   ;; Predicates to determine whether to run a test or not. See tutorial.
   :test-selectors {:default (fn [t] (not (or (:integration v) (:regression v))))
@@ -95,12 +92,15 @@
   :library-path "target/dependency"
   :test-path "src/test/clojure"
   :resources-path "src/main/resource" ; non-code files included in classpath/jar
-  :test-resources-path "src/test/resource" ; added to classpath but not in jar
-  :native-path "src/native"   ; where to look for native dependencies
-  :jar-dir "target/"          ; where to place the project's jar file
-  :jar-name "sample.jar"      ; name of the jar produced by 'lein jar'
+  :dev-resources-path "src/test/resource" ; added to dev classpath but not jar
+  :native-path "src/native"      ; where to look for native dependencies
+  :target-dir "target/"          ; where to place the project's jar file
+  :jar-name "sample.jar"         ; name of the jar produced by 'lein jar'
   :uberjar-name "sample-standalone.jar" ; as above for uberjar
-  :java-source-path "src/main/java" ; location of Java source.
+  ;; Options to pass to java compiler for java source
+  ;; See http://ant.apache.org/manual/Tasks/javac.html
+  :javac-options {:destdir "classes/"}
+  :java-source-path "src/main/java" ; location of Java source
   ;; Leave the contents of :source-path out of jars (for AOT projects)
   :omit-source true
   ;; Files with names matching any of these patterns will be excluded from jars


Zapped some tabs that snuck in

Zapped some tabs that snuck in

--- src/net/dishevelled/mailindex.clj
+++ src/net/dishevelled/mailindex.clj
@@ -22,10 +22,10 @@
   (:require [net.dishevelled.mailindex.fieldpool :as fieldpool]
             [net.dishevelled.mailindex.searcher-manager :as searcher-manager])
   (:use clojure.java.io
-	[clojure.string :only [join]]
+        [clojure.string :only [join]]
         clojure.contrib.seq
         clojure.contrib.def
-	clojure.contrib.command-line)
+        clojure.contrib.command-line)

   (:gen-class))

@@ -436,16 +436,16 @@

     (reset! config (read (PushbackReader. (reader config-file))))
     (let [{:keys [port indexfile]} @config
-	  connections (map (fn [b]
-			     (require (:backend b))
-			     (let [conn (@(ns-resolve (:backend b)
-						      'get-connection)
-					 b)]
-			       (swap! conn assoc :config b)
-			       conn))
-			   (:backends @config))
-	  searcher (agent nil)
-	  indexer (agent nil)]
+          connections (map (fn [b]
+                             (require (:backend b))
+                             (let [conn (@(ns-resolve (:backend b)
+                                                      'get-connection)
+                                         b)]
+                               (swap! conn assoc :config b)
+                               conn))
+                           (:backends @config))
+          searcher (agent nil)
+          indexer (agent nil)]

       (send-off searcher handle-searches indexfile (Integer. port))
       (send-off indexer start-indexing indexfile connections)