Tidy up some tests

Tidy up some tests

--- test/exploud/messages/health_test.clj
+++ test/exploud/messages/health_test.clj
@@ -16,20 +16,24 @@
                            :deployment-params {:min 2}}}})

 (fact "that healthchecks are skipped if told to"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :application-properties :service.healthcheck.skip] true)}) => (contains {:status :success}))
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :application-properties :service.healthcheck.skip] true)})
+      => (contains {:status :success}))

 (fact "that checking the health when min is zero skips the process"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :deployment-params :min] 0)}) => (contains {:status :success}))
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :deployment-params :min] 0)})
+      => (contains {:status :success}))

 (fact "that getting no instances back when min is greater than zero retries"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params}) => {:status :retry
-                                                                                :backoff-ms 10000}
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params})
+      => {:status :retry
+          :backoff-ms 10000}
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => []))

 (fact "that getting one healthy instance when the minimum is two retries"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params}) => {:status :retry
-                                                                                :backoff-ms 10000}
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params})
+      => {:status :retry
+          :backoff-ms 10000}
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "i-1"}
                                                                            {:instance-id "i-2"}]
@@ -41,7 +45,8 @@
        (http/simple-get "http://ip2:9090/the/healthcheck" {:socket-timeout 2000}) => {:status 200}))

 (fact "that getting two healthy instances when the minimum is two succeeds"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params}) => (contains {:status :success})
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params})
+      => (contains {:status :success})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "i-1"}
                                                                            {:instance-id "i-2"}]
@@ -53,8 +58,9 @@
        (http/simple-get "http://ip2:9090/the/healthcheck" {:socket-timeout 2000}) => {:status 200}))

 (fact "that getting an exception while attempting the healthcheck counts as a failed check"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params}) => {:status :retry
-                                                                                :backoff-ms 10000}
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params})
+      => {:status :retry
+          :backoff-ms 10000}
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "i-1"}
                                                                            {:instance-id "i-2"}]
@@ -66,17 +72,20 @@
        (http/simple-get "http://ip2:9090/the/healthcheck" {:socket-timeout 2000}) =throws=> (ex-info "Busted" {})))

 (fact "that getting an exception while attempting to retrieve the instance details is an error"
-      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params}) => (contains {:status :error})
+      (wait-for-instances-to-be-healthy {:attempt 1 :parameters wait-for-instances-to-be-healthy-params})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") =throws=> (ex-info "Busted" {})))

 (fact "that after the default maximum number of attempts we give up checking health and getting no instances"
-      (wait-for-instances-to-be-healthy {:attempt 50 :parameters wait-for-instances-to-be-healthy-params}) => (contains {:status :error})
+      (wait-for-instances-to-be-healthy {:attempt 50 :parameters wait-for-instances-to-be-healthy-params})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => []))

 (fact "that after the default maximum number of attempts we give up checking health and get an unsuccessful responses"
-      (wait-for-instances-to-be-healthy {:attempt 50 :parameters wait-for-instances-to-be-healthy-params}) => (contains {:status :error})
+      (wait-for-instances-to-be-healthy {:attempt 50 :parameters wait-for-instances-to-be-healthy-params})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "i-1"}
                                                                            {:instance-id "i-2"}]
@@ -88,7 +97,8 @@
        (http/simple-get "http://ip2:9090/the/healthcheck" {:socket-timeout 2000}) => {:status 200}))

 (fact "that after the given maximum number of attempts we give up checking health and getting no instances"
-      (wait-for-instances-to-be-healthy {:attempt 12 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :deployment-params :instance-healthy-attempts] 12)}) => (contains {:status :error})
+      (wait-for-instances-to-be-healthy {:attempt 12 :parameters (assoc-in wait-for-instances-to-be-healthy-params [:new-state :tyranitar :deployment-params :instance-healthy-attempts] 12)})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => []))

@@ -100,7 +110,8 @@
   {:environment "environment"
    :region "region"
    :new-state {:auto-scaling-group-name "asg"
-               :tyranitar {:deployment-params {:selected-load-balancers ["lb-1" "lb-2"]}}}})
+               :tyranitar {:deployment-params {:min 2
+                                               :selected-load-balancers ["lb-1" "lb-2"]}}}})

 (fact "that waiting for load balancer health of an undo with no previous state skips it"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
@@ -109,18 +120,21 @@

 (fact "that waiting for load balancer health of no load balancers skips it"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters (assoc-in wait-for-load-balancers-to-be-healthy-params [:new-state :tyranitar :deployment-params :selected-load-balancers] [])}) => (contains {:status :success}))
+                                              :parameters (assoc-in wait-for-load-balancers-to-be-healthy-params [:new-state :tyranitar :deployment-params :selected-load-balancers] [])})
+      => (contains {:status :success}))

 (fact "that waiting for load balancer health of auto scaling group with no instances is successful"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => (contains {:status :success})
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => (contains {:status :success})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => []))

 (fact "that waiting for load balancer health of auto scaling group with no healthy instances retries"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => {:status :retry
-                      :backoff-ms 10000}
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => {:status :retry
+          :backoff-ms 10000}
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "id-1"}]
        (aws/load-balancer-health "environment" "region" "lb-1") => [{:instance-id "id-1" :state "NotInService"}]
@@ -128,8 +142,9 @@

 (fact "that waiting for load balancer health of auto scaling group with not enough healthy instances retries"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => {:status :retry
-                                                                                :backoff-ms 10000}
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => {:status :retry
+          :backoff-ms 10000}
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "id-1"} {:instance-id "id-2"}]
        (aws/load-balancer-health "environment" "region" "lb-1") => [{:instance-id "id-1" :state "NotInService"}
@@ -139,7 +154,8 @@

 (fact "that waiting for load balancer health of auto scaling group with unknown unhealthy instances succeeds"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => (contains {:status :success})
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => (contains {:status :success})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "id-1"}]
        (aws/load-balancer-health "environment" "region" "lb-1") => [{:instance-id "id-1" :state "InService"}
@@ -149,13 +165,15 @@

 (fact "that an exception while waiting for load balancer health is an error"
       (wait-for-load-balancers-to-be-healthy {:attempt 1
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => (contains {:status :error})
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") =throws=> (ex-info "Busted" {})))

 (fact "that waiting for load balancer health errors if too many unsuccessful attempts have been made"
       (wait-for-load-balancers-to-be-healthy {:attempt 50
-                                              :parameters wait-for-load-balancers-to-be-healthy-params}) => (contains {:status :error})
+                                              :parameters wait-for-load-balancers-to-be-healthy-params})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "id-1"} {:instance-id "id-2"}]
        (aws/load-balancer-health "environment" "region" "lb-1") => [{:instance-id "id-1" :state "NotInService"}
@@ -165,7 +183,8 @@

 (fact "that waiting for load balancer health uses given maximum attempts"
       (wait-for-load-balancers-to-be-healthy {:attempt 12
-                                              :parameters (assoc-in wait-for-load-balancers-to-be-healthy-params [:new-state :tyranitar :deployment-params :load-balancer-healthy-attempts] 12)}) => (contains {:status :error})
+                                              :parameters (assoc-in wait-for-load-balancers-to-be-healthy-params [:new-state :tyranitar :deployment-params :load-balancer-healthy-attempts] 12)})
+      => (contains {:status :error})
       (provided
        (aws/auto-scaling-group-instances "asg" "environment" "region") => [{:instance-id "id-1"} {:instance-id "id-2"}]
        (aws/load-balancer-health "environment" "region" "lb-1") => [{:instance-id "id-1" :state "NotInService"}


Separate templates out into FOSS/PE directories

--- src/puppetlabs/ezbake/stage.clj
+++ src/puppetlabs/ezbake/stage.clj
@@ -8,7 +8,7 @@
             [cemerick.pomegranate.aether :as aether]
             [clj-time.local :as local-time]))

-(def template-dir "./template")
+(def template-dir-prefix "./template")
 (def staging-dir "./target/staging")
 (def shared-config-prefix "ext/config/shared/")

@@ -65,7 +65,7 @@
   (fs/delete-dir staging-dir))

 (defn cp-template-files
-  []
+  [template-dir]
   (println "copying template files from" template-dir "to" staging-dir)
   (fs/copy-dir template-dir staging-dir))

@@ -199,20 +199,21 @@

 (defn -main
   [& args]
-  (try
-    (clean)
-    (cp-template-files)
-    ;; TODO: this will be configurable and allow us to build other projects besides
-    ;; just jvm-puppet.
-    (let [project-file "./configs/jvm-puppet.clj"
-          lein-project (project/read project-file)
-          config-files (cp-shared-config-files lein-project)]
-      (cp-project-file project-file)
-      (rename-redhat-spec-file lein-project)
-      (generate-ezbake-config-file lein-project config-files)
-      (generate-project-data-yaml lein-project)
-      (create-git-repo lein-project))
-    (finally
-      ;; this is required in order to make the threads started by sh/sh terminate,
-      ;; and thus allow the jvm to exit
-      (shutdown-agents))))+  ;; TODO: these will be configurable and allow us to build other projects besides
+  ;; just jvm-puppet, and choose between foss and pe templates
+  (let [template-dir (fs/file template-dir-prefix "foss")
+        project-file "./configs/jvm-puppet.clj"]
+    (try
+      (clean)
+      (cp-template-files template-dir)
+      (let [lein-project (project/read project-file)
+            config-files (cp-shared-config-files lein-project)]
+        (cp-project-file project-file)
+        (rename-redhat-spec-file lein-project)
+        (generate-ezbake-config-file lein-project config-files)
+        (generate-project-data-yaml lein-project)
+        (create-git-repo lein-project))
+      (finally
+        ;; this is required in order to make the threads started by sh/sh terminate,
+        ;; and thus allow the jvm to exit
+        (shutdown-agents)))))


Finer grained changed tracking and dynamic change watching

--- src/aurora/btree.cljs
+++ src/aurora/btree.cljs
@@ -404,8 +404,7 @@
   Object
   (reset [this key]
          (set! node (.-root tree))
-         (set! ix 0)
-         (set! end? (> (alength (.-keys node)) 0)))
+         (set! ix 0))
   (seek-gt [this key]
            (loop []
              (if (and (instance? Node (.-parent node))
@@ -456,74 +455,89 @@

 ;; los and his are inclusive

-;; propagate updates the current lo/hi for each var and returns one of:
-;;   failed (no possible solutions)
-;;   changed (possible solutions, los/his changed)
-;;   unchanged (possible solutions, los/his unchanged)
+;; propagate updates the current lo/hi for each var and set the solver to failed
 ;; split-left either:
 ;;   breaks the solutions into two branches, sets the left branch, returns true
 ;;   has only one possible solution, does nothing, returns false
 ;; split-right:
 ;;   breaks the solutions into two branches, sets the right branch

-;; solver remembers ixes, handles copying los/his
-;; solver push los/his when splitting and remembers who split
-;; solver checks changed/failed, sets dirty
-
-(deftype Contains [iterator right-los failed-los]
+(deftype Contains [iterator vars scratch-key]
   Object
-  (reset [this]
+  (reset [this solver]
          (.reset iterator))
-  (propagate [this los his]
-             ;; widen los/his to just the bounds we can use here
-             (loop [i 0]
-               (when (< i (alength los))
-                 (if (identical? (aget los i) (aget his i))
-                   (recur (+ i 1))
-                   (loop [i (+ i 1)]
-                     (when (< i (alength los))
-                       (aset los i least)
-                       (aset his i greatest)
-                       (recur (+ i 1)))))))
-             ;; update los
-             (let [new-los (or (.seek-gte iterator los) failed-los)]
+  (propagate [this solver constraint]
+             (let [los (.-los solver)
+                   his (.-his solver)]
+               ;; derive a lower bound for the iterator
                (loop [i 0]
-                 (when (< i (alength los))
-                   (aset los i (aget new-los i))
-                   (if (identical? (aget new-los i) (aget his i))
-                     (recur (+ i 1)))))))
-  (split-left [this los his]
+                 (when (< i (alength vars))
+                   (let [var (aget vars i)]
+                     (aset scratch-key i (aget los var))
+                     (if (identical? (aget los var) (aget his var))
+                       (recur (+ i 1))
+                       (loop [i (+ i 1)]
+                         (when (< i (alength vars))
+                           (aset scratch-key i least)
+                           (recur (+ i 1))))))))
+               ;; find a new lower bound
+               (let [new-los (.seek-gte iterator scratch-key)]
+                 (if (nil? new-los)
+                   (set! (.-failed? solver) true)
+                   (loop [i 0]
+                     (when (< i (alength vars))
+                       (let [var (aget vars i)]
+                         (.set-lo solver var (aget new-los i))
+                         (if (identical? (aget new-los i) (aget his var))
+                           (recur (+ i 1))
+                           (.set-watch solver constraint var true)))))))))
+  (split-left [this solver constraint]
               ;; fix the value of the first non-fixed var
-              (loop [i 0]
-                (when (< i (alength los))
-                  (if (identical? (aget los i) (aget his i))
-                    (recur (+ i 1))
-                    (aset his i (aget los i))))))
-  (split-right [this los his]
-               ;; copy the los
-               (dotimes [i (alength los)]
-                 (aset right-los i (aget los i)))
-               ;; find the his for the left branch...
+             (let [los (.-los solver)
+                   his (.-his solver)]
                (loop [i 0]
-                 (when (< i (alength right-los))
-                   (if (identical? (aget right-los i) (aget his i))
-                     (recur (+ i 1))
-                     (loop [i (+ i 1)]
-                       (when (< i (alength right-los))
-                         (aset right-los i greatest)
-                         (recur (+ i 1)))))))
-               (debug :right-los right-los)
-               ;; ...and then seek past it
-               (let [new-los (or (.seek-gt iterator right-los) failed-los)]
+                 (if (< i (alength vars))
+                   (let [var (aget vars i)]
+                     (if (identical? (aget los var) (aget his var))
+                       (recur (+ i 1))
+                       (do
+                         (.set-hi solver var (aget los var))
+                         (when (< (+ i 1) (alength vars))
+                           (.set-watch solver constraint (aget vars (+ i 1)) true))
+                         true)))
+                   false))))
+  (split-right [this solver constraint]
+               (let [los (.-los solver)
+                     his (.-his solver)]
+                 ;; copy the los
+                 (dotimes [i (alength vars)]
+                   (let [var (aget vars i)]
+                     (aset scratch-key i (aget los var))))
+                 ;; find the upper bound for the left branch...
                  (loop [i 0]
-                   (when (< i (alength los))
-                     (aset los i (aget new-los i))
-                     (if (identical? (aget new-los i) (aget his i))
-                       (recur (+ i 1))))))))
-
-(defn contains [iterator]
+                   (when (< i (alength vars))
+                     (let [var (aget vars i)]
+                       (if (identical? (aget scratch-key i) (aget his var))
+                         (recur (+ i 1))
+                         (loop [i (+ i 1)]
+                           (when (< i (alength vars))
+                             (aset scratch-key i greatest)
+                             (recur (+ i 1))))))))
+                 ;; ...and then seek past it
+                 (let [new-los (.seek-gt iterator scratch-key)]
+                   (debug :seeking-past scratch-key new-los)
+                   (if (nil? new-los)
+                     (set! (.-failed? solver) true)
+                     (loop [i 0]
+                       (when (< i (alength vars))
+                         (let [var (aget vars i)]
+                           (aset los var (aget new-los i))
+                           (if (identical? (aget new-los i) (aget his var))
+                             (recur (+ i 1)))))))))))
+
+(defn contains [iterator vars]
   (let [key-len (.-key-len (.-tree iterator))]
-    (Contains. iterator (make-array key-len) (greatest-key key-len))))
+    (Contains. iterator vars (make-array key-len))))

 ;; TODO for these constraints would be useful to be able to disable the constraints once they run succesfully

@@ -577,102 +591,110 @@

 ;; los and his are inclusive

-;; TODO replace last-changed with dirty tracking
-(deftype Solver [constraints constraint->ixes constraint->los constraint->his ^:mutable los ^:mutable his ^:mutable depth pushed-los pushed-his pushed-splitters ^:mutable failed?]
+(deftype Solver [constraints ^:mutable failed? ^:mutable depth
+                 ^:mutable los ^:mutable his ^:mutable var->constraint->watching? ^:mutable constraint->dirty?
+                 pushed-los pushed-his pushed-var->constraint->watching? pushed-constraint->dirty? pushed-splitters]
   Object
   (reset [this]
          (dotimes [i (alength constraints)]
            (.reset (aget constraints i)))
+         (set! depth 0)
+         (set! failed? false)
          (dotimes [i (alength los)]
            (aset los i least)
            (aset his i greatest))
-         (set! depth 0)
+         (dotimes [i (alength var->constraint->watching?)]
+           (aset var->constraint->watching? i false))
+         (dotimes [i (alength constraint->dirty?)]
+           (aset constraint->dirty? i true))
          (aclear pushed-los)
          (aclear pushed-his)
-         (aclear pushed-splitters)
-         (set! failed? false))
-  (write-bounds [this current]
-                (let [current-ixes (aget constraint->ixes current)
-                      current-los (aget constraint->los current)
-                      current-his (aget constraint->his current)]
-                 (dotimes [i (alength current-ixes)]
-                   (let [ix (aget current-ixes i)]
-                     (aset current-los i (aget los ix))
-                     (aset current-his i (aget his ix))))))
-  (read-bounds [this current]
-               (let [current-ixes (aget constraint->ixes current)
-                     current-los (aget constraint->los current)
-                     current-his (aget constraint->his current)
-                     changed? false]
-                 (dotimes [i (alength current-ixes)]
-                   (let [ix (aget current-ixes i)
-                         new-lo (aget current-los i)
-                         new-hi (aget current-his i)]
-                     (when (val-lt (aget los ix) new-lo)
-                       (set!! changed? true)
-                       (aset los ix new-lo))
-                     (when (val-lt new-hi (aget his ix))
-                       (set!! changed? true)
-                       (aset his ix new-hi))
-                     ;; TODO need a better way to indicate failure
-                     (when (or (identical? greatest (aget los ix))
-                               (identical? least (aget his ix))
-                               (val-lt (aget his ix) (aget los ix)))
-                       (set! failed? true))))
-                 changed?))
+         (aclear pushed-var->constraint->watching?)
+         (aclear pushed-constraint->dirty?)
+         (aclear pushed-splitters))
+  (set-lo [this var new-lo]
+          (when-not (identical? (aget los var) new-lo)
+            (if (val-lt (aget his var) new-lo)
+              (set! failed? true)
+              (do
+                (aset los var new-lo)
+                (.set-dirty this var)))))
+  (set-hi [this var new-hi]
+          (when-not (identical? (aget his var) new-hi)
+            (if (val-lt new-hi (aget los var))
+              (set! failed? true)
+              (do
+                (aset his var new-hi)
+                (.set-dirty this var)))))
+  (set-eq [this var new-val]
+          (let [old-lo (aget los var)
+                old-hi (aget his var)]
+            (when-not (and (identical? old-lo new-val) (identical? old-hi new-val))
+              (if (or (val-lt new-val old-hi) (val-lt old-hi new-val))
+                (set! failed? true)
+                (do
+                  (aset los var new-val))
+                  (aset his var new-val)
+                  (.set-dirty this var)))))
+  (set-watch [this constraint var value]
+             (aset var->constraint->watching? (+ (* (alength constraints) var) constraint) value))
+  (set-dirty [this var]
+             (let [start (* (alength constraints) var)]
+               (dotimes [constraint (alength constraints)]
+                 (when (true? (aget var->constraint->watching? (+ start constraint)))
+                   (aset constraint->dirty? constraint true)))))
   (split [this]
          (debug :splitting-left los his)
+         (set! depth (+ depth 1))
          (apush pushed-los (aclone los))
          (apush pushed-his (aclone his))
-         (set! depth (+ depth 1))
+         (apush pushed-var->constraint->watching? (aclone var->constraint->watching?))
+         (apush pushed-constraint->dirty? (aclone constraint->dirty?))
          (loop [splitter 0]
            (if (< splitter (alength constraints))
-             (do
-               (.write-bounds this splitter)
-               (.split-left (aget constraints splitter) (aget constraint->los splitter) (aget constraint->his splitter))
-               (if (true? (.read-bounds this splitter))
-                 (do
-                   (apush pushed-splitters splitter)
-                   (debug :split-left los his splitter))
-                 (recur (+ splitter 1))))
+             (if (.split-left (aget constraints splitter) this splitter)
+               (do
+                 (apush pushed-splitters splitter)
+                 (debug :split-left los his splitter))
+               (recur (+ splitter 1)))
              (assert false "Can't split anything!"))))
   (backtrack [this]
+             (set! failed? false)
+             (set! depth (- depth 1))
              (set! los (.pop pushed-los))
              (set! his (.pop pushed-his))
-             (set! depth (- depth 1))
-             (set! failed? false)
+             (set! var->constraint->watching? (.pop pushed-var->constraint->watching?))
+             (set! constraint->dirty? (.pop pushed-constraint->dirty?))
              (let [splitter (.pop pushed-splitters)]
-               (debug :backtracked los his splitter)
-               (.write-bounds this splitter)
                (debug :splitting-right los his splitter)
-               (.split-right (aget constraints splitter) (aget constraint->los splitter) (aget constraint->his splitter))
-               (.read-bounds this splitter)
+               (.split-right (aget constraints splitter) this splitter)
                (debug :split-right los his splitter failed?)))
   (next [this]
         (debug :next los his pushed-los pushed-his)
-        (loop [current 0
-               last-changed (- (alength constraints) 1)]
-          (debug :next-loop los his current last-changed failed?)
+        (loop [constraint 0]
           (if (true? failed?)
-            (when (> depth 0)
-              (.backtrack this)
-              (recur current (- (alength constraints) 1)))
             (do
-              (.write-bounds this current)
-              (debug :propagating current (aget constraint->los current) (aget constraint->his current))
-              (.propagate (aget constraints current) (aget constraint->los current) (aget constraint->his current))
-              (debug :propagated current (aget constraint->los current) (aget constraint->his current))
-              (if (true? (.read-bounds this current))
-                (recur (mod (+ current 1) (alength constraints)) current)
-                (if (== current last-changed)
-                  (if (key= los his)
-                    (do
-                      (set! failed? true) ;; force solver to backtrack next time
-                      (aclone los))
-                    (do
-                      (.split this current)
-                      (recur 0 (- (alength constraints) 1))))
-                  (recur (mod (+ current 1) (alength constraints)) last-changed)))))))
+              (debug :failed)
+              (when (> depth 0)
+                (.backtrack this)
+                (recur 0)))
+            (if (< constraint (alength constraints))
+              (if (false? (aget constraint->dirty? constraint))
+                (recur (+ constraint 1))
+                (do
+                  (debug :propagating constraint los his)
+                  (aset constraint->dirty? constraint false)
+                  (.propagate (aget constraints constraint) this constraint)
+                  (debug :propagated constraint los his)
+                  (recur 0)))
+              (if (key= los his)
+                (do
+                  (set! failed? true) ;; force solver to backtrack next time
+                  (debug :done los)
+                  (aclone los))
+                (do
+                  (.split this)
+                  (recur 0)))))))
   (keys [this]
        (let [results #js []]
          (loop []
@@ -685,14 +707,14 @@
   (-seq [this]
         (seq (.keys this))))

-(defn solver [num-vars constraints constraint->ixes]
-  (let [constraint->los (amake [i (alength constraint->ixes)]
-                               (make-array (alength (aget constraint->ixes i))))
-        constraint->his (amake [i (alength constraint->ixes)]
-                               (make-array (alength (aget constraint->ixes i))))
-        los (least-key num-vars)
-        his (greatest-key num-vars)]
-    (Solver. constraints constraint->ixes constraint->los constraint->his los his 0 #js [] #js [] #js [] false)))
+(defn solver [num-vars constraints]
+  (let [los (least-key num-vars)
+        his (greatest-key num-vars)
+        var->constraint->watching? (amake [_ (* num-vars (alength constraints))] false)
+        constraint->dirty? (amake [_ (alength constraints)] true)]
+    (Solver. constraints false 0
+             los his var->constraint->watching? constraint->dirty?
+             #js [] #js [] #js [] #js [] #js [])))

 ;; TESTS

@@ -1072,10 +1094,8 @@
       _ (.assoc! tree2 #js ["d" "c"] 0)
       _ (.assoc! tree2 #js ["b" "d"] 0)
       s (solver 3
-                #js [(contains (iterator tree1))
-                     (contains (iterator tree2))]
-                #js [#js [0 2]
-                     #js [1 2]])
+                #js [(contains (iterator tree1) #js [0 2])
+                     (contains (iterator tree2)) #js [1 2]])
       ]
   [(.next s) (.next s) (.next s) (.next s) (.next s)]
   )


Simple optimisations for .assoc

Simple optimisations for .assoc

--- src/aurora/btree.cljs
+++ src/aurora/btree.cljs
@@ -47,8 +47,8 @@
                   (recur (+ mid 1) hi)
                   mid))))))
   (assoc! [this key val max-keys]
-          (set! lower (min lower key))
-          (set! upper (max upper key))
+          (set! lower (if (< lower key) lower key))
+          (set! upper (if (< upper key) key upper))
           (let [ix (.seek this key 0)]
             (if (nil? children)
               (if (== key (aget keys ix))


Fix up parent-ixes in merge

Fix up parent-ixes in merge

--- src/aurora/btree.cljs
+++ src/aurora/btree.cljs
@@ -192,6 +192,8 @@
             (apush* (.-keys left-node) (.-keys right-node))
             (apush* (.-vals left-node) (.-vals right-node))
             (when-not (nil? children)
+              (dotimes [ix (alength (.-children right-node))]
+                (set! (.-parent-ix (aget (.-children right-node) ix)) (+ ix (alength children))))
               (apush* (.-children left-node) (.-children right-node)))
             (set! (.-upper left-node) (.-upper right-node))
             (.remove! parent separator-ix min-keys)))
@@ -217,6 +219,8 @@
                 #_(assert (= lower (aget keys 0)) (pr-str lower keys))
                 #_(assert (= upper (aget keys (- (alength keys) 1))) (pr-str upper keys)))
               (do
+                (dotimes [ix (count children)]
+                  (assert (= ix (.-parent-ix (aget children ix)))))
                 (assert (= (count keys) (count vals) (dec (count children))) (pr-str keys vals children))
                 #_(assert (= lower (.-lower (aget children 0))) (pr-str lower (.-lower (aget children 0))))
                 #_(assert (= upper (.-upper (aget children (- (alength children) 1)))) (pr-str upper (.-upper (aget children (- (alength children) 1)))))
@@ -344,13 +348,14 @@

 (defn apply-to-tree [tree actions]
   (doseq [action actions]
-    (prn action)
     (case (nth action 0)
       :assoc! (.assoc! tree (nth action 1) (nth action 2))
       :dissoc! (.dissoc! tree (nth action 1)))
-    (.pretty-print tree)
-    (prn tree)
-    (.valid! tree))
+    (do
+      (prn action)
+      (.pretty-print tree)
+      (prn tree)
+      (.valid! tree)))
   tree)

 (defn apply-to-sorted-map [map actions]
@@ -373,6 +378,8 @@
                 (run-denotational-prop min-keys actions)))

 ;; TODO iterator tests
+
+(apply run-denotational-prop [1 [[:assoc! 0 0] [:assoc! 1 0] [:assoc! 4 0] [:assoc! 2 0] [:assoc! -1 0] [:assoc! 3 0] [:assoc! -2 0] [:dissoc! 0] [:assoc! 0 0]]])

 (comment
   (do


Add missing license header con core.clj file.

--- src/potok/core.clj
+++ src/potok/core.clj
@@ -1,26 +1,8 @@
-;; Copyright (c) 2019 Andrey Antukh <niwi@niwi.nz>
-;; All rights reserved.
+;; This Source Code Form is subject to the terms of the Mozilla Public
+;; 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/.
 ;;
-;; Redistribution and use in source and binary forms, with or without
-;; modification, are permitted provided that the following conditions are met:
-;;
-;; * Redistributions of source code must retain the above copyright notice, this
-;;   list of conditions and the following disclaimer.
-;;
-;; * Redistributions in binary form must reproduce the above copyright notice,
-;;   this list of conditions and the following disclaimer in the documentation
-;;   and/or other materials provided with the distribution.
-;;
-;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
-;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
-;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
-;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
-;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
-;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; Copyright (c) Andrey Antukh <niwi@niwi.nz>

 (ns potok.core
   "Stream & Events based state management toolkit for ClojureScript."


blosum-metric added

blosum-metric added

--- src/pscan/core.clj
+++ src/pscan/core.clj
@@ -1,9 +1,8 @@
 (ns pscan.core
   (:require [clojure.core.reducers :as r]
             [clojure.set :as s]
-            [clojure.string :refer [split]]))
-
-(def pts [[0 0] [0 1] [0 2] [1 0] [1 1] [1 2] [2 0] [2 1] [2 2]])
+            [clojure.string :refer [split]])
+  (:import match.Match2))

 (defn r2-dist
   "Euclidian distance for points in R^2 (for testing)
@@ -80,9 +79,15 @@
   [s]
   (Float/parseFloat s))

-
+(defn blosum-metric
+  "BLOSUM pseudo-metric; returns negative of the similarity score
+   BLOSUM62 matrix, gap penalty 11, extension penalty 1 (BLAST defaults)"
+  [a b]
+  (match.Match2/blosum62 a b))

 (comment
+
+(def pts [[0 0] [0 1] [0 2] [1 0] [1 1] [1 2] [2 0] [2 1] [2 2]])

 (def star [[0 0] [0 1] [1 0] [-1 0] [0 -1]])


Push Mini mapping is working.

Push Mini mapping is working.

Still need to decide about startup animation, and support for assigning
virtual pressure to the whole grid and individual cues.

--- src/afterglow/controllers/launchpad_mini.clj
+++ src/afterglow/controllers/launchpad_mini.clj
@@ -61,28 +61,45 @@
   0x0d)

 (def stop-active-color
-  "The color of the stop button when active."
+  "The color of the Stop button when active."
   0x0f)

-(def click-unsynced-beat-color
+(def shift-available-color
+  "The color of the Shift button when not active."
+  0x2d)
+
+(def shift-active-color
+  "The color of the Shift button when active."
+  0x3e)
+
+(def tempo-unsynced-beat-color
   "The color of the tap tempo button when synchronization is off and a
   beat is taking place."
   0x3e)

-(def click-unsynced-off-beat-color
+(def tempo-unsynced-off-beat-color
   "The color of the tap tempo button when synchronization is off and a
   beat is not taking place."
   0x1d)

-(def click-synced-beat-color
+(def tempo-synced-beat-color
   "The color of the tap tempo button when the metronome is
   synchronzied and a beat is taking place."
   0x3c)

-(def click-synced-off-beat-color
+(def tempo-synced-off-beat-color
   "The color of the tap tempo button when the metronome is
   synchronized and a beat is not taking place."
   0x1c)
+
+(def cue-held-color
+  "The color to light up a pad when a cue runs only as long as it is
+  held."
+  0x3f)
+
+(def cue-running-color
+  "The color to light up a pad when it is running a cue."
+  0x3c)

 (defn set-pad-color
   "Set one of the 64 grid pads to one of the color values specified
@@ -104,8 +121,6 @@
     (reset! (:origin controller) origin)
     (doseq [f @(:move-listeners controller)] (f @(:grid-controller-impl controller) :moved))))

-
-
 (defn clear-interface
   "Clears all illuminated buttons and pads."
   [controller]
@@ -114,15 +129,332 @@
   (reset! (:last-grid-pads controller) nil)
   (reset! (:last-control-buttons controller) {}))

-
-
+(defn- update-control-buttons
+  "Sees if any top row buttons have changed state since the last time
+  the interface was updated, and if so, sends the necessary MIDI
+  commands to update them on the Launchpad Mini."
+  [controller]
+  ;; First turn off any which were on before but no longer are
+  (doseq [[button old-color] @(:last-control-buttons controller)]
+    (when-not (get @(:next-control-buttons controller) button)
+      (midi/midi-control (:port-out controller) button button-off-color)))
+
+  ;; Then, light any currently active buttons
+  (doseq [[button color] @(:next-control-buttons controller)]
+    (when-not (= (get @(:last-control-buttons controller) button) color)
+      (midi/midi-control (:port-out controller) button color)))
+
+  ;; And record the new state for next time
+  (reset! (:last-control-buttons controller) @(:next-control-buttons controller)))
+
+(defn- render-cue-grid
+  "Figure out how the cue grid pads should be illuminated, based on
+  the currently active cues and a metronome snapshot identifying the
+  point in musical time at which the interface is being rendered.
+  Returns a vector of the rows, from bottom to top. Each row is a
+  vector of the colors in that row, from left to right."
+  [controller snapshot]
+  (let [[origin-x origin-y] @(:origin controller)
+        active-keys (show/active-effect-keys (:show controller))]
+    (vec (for [y (range 8)]
+           (vec (for [x (range 8)]
+                  (let [[cue active] (show/find-cue-grid-active-effect (:show controller) (+ x origin-x) (+ y origin-y))
+                        ending (and active (:ending active))
+                        color (when cue (if active
+                                          (if ending
+                                            (if (> (rhythm/snapshot-beat-phase snapshot) 0.4)
+                                              stop-available-color
+                                              stop-active-color)
+                                            cue-running-color)
+                                          (if (or (active-keys (:key cue))
+                                                  (seq (clojure.set/intersection active-keys (set (:end-keys cue)))))
+                                            button-dimmed-color button-available-color)))]
+                    (or color button-off-color))))))))
+
+(defn- update-cue-grid
+  "Set the colors of all the cue grid pads, based on the currently
+  active cues and overlays."
+  [controller]
+  (doseq [x (range 8)  ; Send the changes only, individually
+              y (range 8)]
+        (let [color (get-in @(:next-grid-pads controller) [y x])]
+          (when-not (= (get-in @(:last-grid-pads controller) [y x]) color)
+            (set-pad-color controller x y color)))))
+
+(defn- update-scroll-arrows
+  "Activate the arrow buttons for directions in which scrolling is
+  possible."
+  [controller]
+  (let [[origin-x origin-y] @(:origin controller)]
+    (when (pos? origin-x)
+      (swap! (:next-control-buttons controller) assoc (:left-arrow control-buttons) button-available-color))
+    (when (pos? origin-y)
+      (swap! (:next-control-buttons controller) assoc (:down-arrow control-buttons) button-available-color))
+    (when (> (- (controllers/grid-width (:cue-grid (:show controller))) origin-x) 7)
+      (swap! (:next-control-buttons controller) assoc (:right-arrow control-buttons) button-available-color))
+    (when (> (- (controllers/grid-height (:cue-grid (:show controller))) origin-y) 7)
+      (swap! (:next-control-buttons controller) assoc (:up-arrow control-buttons) button-available-color))))
+
+(defn add-button-held-feedback-overlay
+  "Adds a simple overlay which keeps a control button bright as long
+  as the user is holding it down."
+  ([controller button]
+   (add-button-held-feedback-overlay controller button button-active-color))
+  ([controller button color]
+   (controllers/add-control-held-feedback-overlay (:overlays controller) button
+                                                  (fn [_] (swap! (:next-control-buttons controller)
+                                                                 assoc button color)))))
+
+(defn- enter-stop-mode
+  "The user has asked to stop the show. Suspend its update task
+  and black it out until the stop button is pressed again."
+  [controller & {:keys [already-stopped]}]
+
+  (reset! (:stop-mode controller) true)
+  (when-not already-stopped
+    (with-show (:show controller)
+      (show/stop!)
+      (Thread/sleep (:refresh-interval (:show controller)))
+      (show/blackout-show)))
+
+  (controllers/add-overlay (:overlays controller)
+                           (reify controllers/IOverlay
+                             (captured-controls [this] #{(:stop control-buttons)})
+                             (captured-notes [this] #{})
+                             (adjust-interface [this _]
+                               (swap! (:next-control-buttons controller)
+                                      assoc (:stop control-buttons) stop-active-color)
+                               (with-show (:show controller)
+                                 (when (show/running?)
+                                   (reset! (:stop-mode controller) false))
+                                 @(:stop-mode controller)))
+                             (handle-control-change [this message]
+                               (when (pos? (:velocity message))
+                                 ;; End stop mode
+                                 (with-show (:show controller)
+                                   (show/start!))
+                                 (reset! (:stop-mode controller) false)
+                                 :done))
+                             (handle-note-on [this message])
+                             (handle-note-off [this message])
+                             (handle-aftertouch [this message]))))
+
+(defn- new-beat?
+  "Returns true if the metronome is reporting a different marker
+  position than the last time this function was called."
+  [controller marker]
+  (when (not= marker @(:last-marker controller))
+    (reset! (:last-marker controller) marker)))
+
+(defn- metronome-sync-colors
+  "Determine the colors to light the tap tempo button. Returns a tuple
+  of the off-beat and on-beat colors based on the current sync
+  status."
+  [controller]
+  (with-show (:show controller)
+    (if (= (:type (show/sync-status)) :manual)
+      [tempo-unsynced-off-beat-color tempo-unsynced-beat-color]
+      (if (:current (show/sync-status))
+        [tempo-synced-off-beat-color tempo-synced-beat-color]
+        [stop-available-color stop-active-color]))))
+
+(defn- update-interface
+  "Determine the desired current state of the interface, and send any
+  changes needed to get it to that state."
+  [controller]
+  (try
+    ;; Assume we are starting out with a blank interface.
+    (reset! (:next-control-buttons controller) {})
+
+    ;; If the show has stopped without us noticing, enter stop mode
+    (with-show (:show controller)
+      (when-not (or (show/running?) @(:stop-mode controller))
+        (enter-stop-mode controller :already-stopped true)))
+
+    ;; Reflect the shift button state
+    (swap! (:next-control-buttons controller)
+           assoc (:shift control-buttons)
+           (if @(:shift-mode controller) shift-active-color shift-available-color))
+
+    (update-scroll-arrows controller)
+
+    ;; Flash the tap tempo button on beats
+    (let [snapshot (rhythm/metro-snapshot (get-in controller [:show :metronome]))
+          marker (rhythm/snapshot-marker snapshot)
+          colors (metronome-sync-colors controller)]
+      (swap! (:next-control-buttons controller)
+             assoc (:tap-tempo control-buttons)
+             (if (or (new-beat? controller marker) (< (rhythm/snapshot-beat-phase snapshot) 0.15))
+               (second colors) (first colors)))
+
+      ;; Make the User button bright, since we live in User mode
+      (swap! (:next-control-buttons controller)
+             assoc (:device-mode control-buttons) button-active-color)
+
+      ;; Make the stop button visible, since we support it
+      (swap! (:next-control-buttons controller)
+             assoc (:stop control-buttons)
+             stop-available-color)
+
+      (reset! (:next-grid-pads controller) (render-cue-grid controller snapshot))
+
+      ;; Add any contributions from interface overlays, removing them
+      ;; if they report being finished.
+      (controllers/run-overlays (:overlays controller) snapshot))
+
+    (update-cue-grid controller)
+    (update-control-buttons controller)
+
+    (catch Throwable t
+      (warn t "Problem updating Launchpad Mini/S Interface"))))
+
+
+(defn- leave-user-mode
+  "The user has asked to exit user mode, so suspend our display
+  updates, and prepare to restore our state when user mode is pressed
+  again."
+  [controller]
+  (swap! (:task controller) (fn [task]
+                              (when task (at-at/kill task))
+                              nil))
+  (clear-interface controller)
+  ;; In case Live isn't running, leave the User Mode button dimly lit, to help the user return.
+  (midi/midi-control (:port-out controller) (:device-mode control-buttons) button-available-color)
+  (controllers/add-overlay (:overlays controller)
+                           (reify controllers/IOverlay
+                             (captured-controls [this] #{(:device-mode control-buttons)})
+                             (captured-notes [this] #{})
+                             (adjust-interface [this _]
+                               true)
+                             (handle-control-change [this message]
+                               (when (pos? (:velocity message))
+                                 ;; We are returning to user mode, restore display
+                                 (clear-interface controller)
+                                 (reset! (:task controller) (at-at/every (:refresh-interval controller)
+                                                                         #(update-interface controller)
+                                                                         controllers/pool
+                                                                         :initial-delay 250
+                                                                         :desc "Launchpad Mini/S interface update"))
+                                 :done))
+                             (handle-note-on [this message])
+                             (handle-note-off [this message])
+                             (handle-aftertouch [this message]))))
+
+(defn- control-change-received
+  "Process a control change message which was not handled by an
+  interface overlay."
+  [controller message]
+  (case (:note message)
+    108  ; Tap tempo button
+    (when (pos? (:velocity message))
+      ((:tempo-tap-handler controller)))
+
+    111  ; Stop button
+    (when (pos? (:velocity message))
+      (enter-stop-mode controller))
+
+    109 ; Shift button
+    (swap! (:shift-mode controller) (fn [_] (pos? (:velocity message))))
+
+    106 ; Left arrow
+    (when (pos? (:velocity message))
+      (let [[x y] @(:origin controller)]
+        (when (pos? x)
+          (move-origin controller [(max 0 (- x 8)) y])
+          (add-button-held-feedback-overlay controller (:left-arrow control-buttons)))))
+
+    107 ; Right arrow
+    (when (pos? (:velocity message))
+      (let [[x y] @(:origin controller)]
+        (when (> (- (controllers/grid-width (:cue-grid (:show controller))) x) 7)
+          (move-origin controller [(+ x 8) y])
+          (add-button-held-feedback-overlay controller (:right-arrow control-buttons)))))
+
+    104 ; Up arrow
+    (when (pos? (:velocity message))
+      (let [[x y] @(:origin controller)]
+        (when (> (- (controllers/grid-height (:cue-grid (:show controller))) y) 7)
+          (move-origin controller [x (+ y 8)])
+          (add-button-held-feedback-overlay controller (:up-arrow control-buttons)))))
+
+    105 ; Down arrow
+    (when (pos? (:velocity message))
+      (let [[x y] @(:origin controller)]
+        (when (pos? y)
+          (move-origin controller [x (max 0 (- y 8))])
+          (add-button-held-feedback-overlay controller (:down-arrow control-buttons)))))
+
+    110 ; Device mode button
+    (when (pos? (:velocity message))
+      (leave-user-mode controller))
+
+    ;; Something we don't care about
+    nil))
+
+(defn- note-to-cue-coordinates
+  "Translate the MIDI note associated with an incoming message to its
+  coordinates in the show cue grid."
+  [controller note]
+  (let [[origin-x origin-y] @(:origin controller)
+        pad-x (rem note 16)
+        pad-y (- 7 (quot note 16))
+        cue-x (+ origin-x pad-x)
+        cue-y (+ origin-y pad-y)]
+    [cue-x cue-y pad-x pad-y]))
+
+;; TODO: Add a way for user to configure default virtual velocity for whole grid and individual cells.
+(defn- cue-grid-pressed
+  "One of the pads in the 8x8 cue grid was pressed."
+  [controller note]
+  (let [[cue-x cue-y pad-x pad-y] (note-to-cue-coordinates controller note)
+        [cue active] (show/find-cue-grid-active-effect (:show controller) cue-x cue-y)]
+          (when cue
+            (with-show (:show controller)
+              (if (and active (not (:held cue)))
+                (show/end-effect! (:key cue))
+                (let [id (show/add-effect-from-cue-grid! cue-x cue-y)
+                      holding (and (:held cue) (not @(:shift-mode controller)))]
+                  (controllers/add-overlay
+                   (:overlays controller)
+                   (reify controllers/IOverlay
+                     (captured-controls [this] #{})
+                     (captured-notes [this] #{note})
+                     (adjust-interface [this snapshot]
+                       (when holding
+                         (swap! (:next-grid-pads controller) assoc-in [cue-y cue-x] cue-held-color))
+                       true)
+                     (handle-control-change [this message])
+                     (handle-note-on [this message])
+                     (handle-note-off [this message]
+                       (when holding
+                         (with-show (:show controller)
+                           (show/end-effect! (:key cue) :when-id id)))
+                       :done)
+                     (handle-aftertouch [this message])))))))))
+
+(defn- note-on-received
+  "Process a note-on message which was not handled by an interface
+  overlay."
+  [controller message]
+  (let [note (:note message)]
+    (when (and (<= (rem note 16) 7) (<= 0 (quot note 16) 7))
+      (cue-grid-pressed controller note))))
+
+(defn- note-off-received
+  "Process a note-off message which was not handled by an interface
+  overlay."
+  [controller message]
+  (case (:note message)
+
+    ;; Something we don't care about
+    nil))

 (defn- midi-received
   "Called whenever a MIDI message is received while the controller is
   active; checks if it came in on the right port, and if so, decides
   what should be done."
   [controller message]
-  #_(when (amidi/same-device? (:device message) (:port-in controller))
+  (when (amidi/same-device? (:device message) (:port-in controller))
     ;;(timbre/info message)
     (when-not (controllers/overlay-handled? (:overlays controller) message)
       (when (= (:command message) :control-change)
@@ -132,9 +464,86 @@
       (when (= (:command message) :note-off)
         (note-off-received controller message)))))

-
-
-
+(defn- start-interface
+  "Set up the thread which keeps the user interface up to date."
+  [controller]
+  (clear-interface controller)
+  (amidi/add-global-handler! @(:midi-handler controller))
+  (reset! (:task controller) (at-at/every (:refresh-interval controller)
+                                          #(update-interface controller)
+                                          controllers/pool
+                                          :initial-delay 10
+                                          :desc "Launchpad Mini/S interface update")))
+
+(defn- welcome-frame
+  "Render a frame of the welcome animation, or if it is done, start
+  the main interface update thread, and terminate the task running the
+  animation."
+  [controller counter task]
+  (try
+    (cond
+      true  ; TODO: For now we have no animation; remove this entry once the below is finished.
+      (do
+        (start-interface controller)
+        (at-at/kill @task))
+
+      (< @counter 8)
+      (doseq [y (range 0 (inc @counter))]
+        (let [color (colors/create-color
+                     :h 0 :s 0 :l (max 10 (- 75 (/ (* 50 (- @counter y)) 6))))]
+          (set-pad-color controller 3 y color)
+          (set-pad-color controller 4 y color)))
+
+      (< @counter 12)
+      (doseq [x (range 0 (- @counter 7))
+              y (range 0 8)]
+        (let [color (colors/create-color
+                     :h 340 :s 100 :l (- 75 (* (- @counter 8 x) 20)))]
+          (set-pad-color controller (- 3 x) y color)
+          (set-pad-color controller (+ 4 x) y color)))
+
+      (< @counter 15)
+      (doseq [y (range 0 8)]
+        (let [color (colors/create-color
+                     :h (* 13 (- @counter 11)) :s 100 :l 50)]
+          (set-pad-color controller (- @counter 7) y color)
+          (set-pad-color controller (- 14 @counter) y color)))
+
+      #_(= @counter 15)
+      #_(show-labels controller (colors/create-color :cyan))
+
+      (< @counter 24)
+      (doseq [x (range 0 8)]
+        (let [lightness-index (if (> x 3) (- 7 x) x)
+              lightness ([10 30 50 70] lightness-index)
+              color (colors/create-color
+                     :h (+ 60 (* 40 (- @counter 18))) :s 100 :l lightness)]
+          (set-pad-color controller x (- 23 @counter) color)))
+
+      #_(= @counter 24)
+      #_(show-labels controller (colors/create-color :blue))
+
+      (< @counter 33)
+      (doseq [x (range 0 8)]
+        (set-pad-color controller x (- 32 @counter) button-off-color))
+
+      :else
+      (do
+        (start-interface controller)
+        (at-at/kill @task)))
+    (catch Throwable t
+      (warn t "Animation frame failed")))
+
+  (swap! counter inc))
+
+(defn- welcome-animation
+  "Provide a fun animation to make it clear the Launchpad Mini/S is
+  online."
+  [controller]
+  (let [counter (atom 0)
+        task (atom nil)]
+    (reset! task (at-at/every 50 #(welcome-frame controller counter task)
+                              controllers/pool))))

 (defn deactivate
   "Deactivates a controller interface, killing its update thread and
@@ -167,7 +576,7 @@
         (clear-interface controller)
         ;; Leave the User button bright, in case the user has Live
         ;; running and wants to be able to see how to return to it.
-        (set-control-button-color controller (:user-mode control-buttons) button-available-color))
+        (set-control-button-color controller (:device-mode control-buttons) button-available-color))

       ;; Cancel any UI overlays which were in effect
       (reset! (:overlays controller) (controllers/create-overlay-state))
@@ -282,7 +691,7 @@
                   (add-move-listener [this f] (swap! (:move-listeners controller) conj f))
                   (remove-move-listener [this f] (swap! (:move-listeners controller) disj f))))
         (clear-interface controller)
-        #_(if skip-animation
+        (if skip-animation
           (start-interface controller)
           (welcome-animation controller))
         (swap! active-bindings assoc (:id controller) controller)


Fix rebalance test.

Fix rebalance test.

--- test/onyx/log/peer_rebalance_test.clj
+++ test/onyx/log/peer_rebalance_test.clj
@@ -61,12 +61,17 @@

 (zk/close conn)

-#_(def replica-2
+(def replica-2
   (loop [replica replica-1]
     (let [position (<!! ch)
           entry (extensions/read-log-entry (:log env) position)
           new-replica (extensions/apply-log-entry entry replica)]
-      (recur new-replica))))
+      (if-not (and (= (count (:a (get (:allocations new-replica) j1))) 3)
+                   (= (count (:b (get (:allocations new-replica) j1))) 3)
+                   (= (count (:c (get (:allocations new-replica) j2))) 3)
+                   (= (count (:d (get (:allocations new-replica) j2))) 2))
+        (recur new-replica)
+        new-replica))))

 (doseq [v-peer v-peers]
   (try


formatting

formatting

--- src/clj/backtype/storm/daemon/supervisor.clj
+++ src/clj/backtype/storm/daemon/supervisor.clj
@@ -465,7 +465,7 @@
               curr-id (if-let [id (.get state LS-ID)]
                         id
                         (generate-supervisor-id))]
-          (.put state LS-ID curr-id)
+          (.put state LS-ID curr-id)
           (reset! id-atom curr-id))
         )
       (confirmAssigned [this port]


Bulk insert plots

Bulk insert plots

--- src/clj/collect_earth_online/db/projects.clj
+++ src/clj/collect_earth_online/db/projects.clj
@@ -547,14 +547,17 @@
                              "none"    1.0)
                            200.0
                            50000.0)
-        ;; TODO use bulk insert, or use postGIS to generate points.
-        (doseq [plot-center (if (= "gridded" plot-distribution)
-                              (create-gridded-points-in-bounds left bottom right top plot-spacing)
-                              (create-random-points-in-bounds left bottom right top num-plots))]
-          (call-sql "create_project_plot"
-                    {:log? false}
-                    project-id
-                    (make-geo-json-point (first plot-center) (second plot-center))))
+        (let [plot-centers (if (= "gridded" plot-distribution)
+                             (create-gridded-points-in-bounds left bottom right top plot-spacing)
+                             (create-random-points-in-bounds left bottom right top num-plots))]
+          (as-> plot-centers pc
+            (map (fn [[lon lat]]
+                   {:project_rid project-id
+                    :center      (format "POINT(%s %s)" lon lat)})
+                 pc)
+            (p-insert-rows! "plots"
+                            pc
+                            :custom-row "(?, ST_GeomFromText(?, 4326))")))
         (create-project-samples! project-id
                                  sample-distribution
                                  plot-shape
@@ -816,9 +819,9 @@
               (if (#{"csv" "shp"} plot-distribution)
                 plot-file-base64
                 (or (not (same-polygon-boundary? (tc/jsonb->clj boundary) (tc/jsonb->clj (:boundary original-project))))
-                    (not= num-plots (:num_plots original-project))
-                    (not= plot-shape (:plot_shape original-project))
-                    (not= plot-size (:plot_size original-project))
+                    (not= num-plots    (:num_plots original-project))
+                    (not= plot-shape   (:plot_shape original-project))
+                    (not= plot-size    (:plot_size original-project))
                     (not= plot-spacing (:plot_spacing original-project)))))
           (do
             (call-sql "delete_plots_by_project" project-id)


execute.clj: remove :code (not allowed)

execute.clj: remove :code (not allowed)

--- src/clojupyter/kernel/middleware/execute.clj
+++ src/clojupyter/kernel/middleware/execute.clj
@@ -49,7 +49,6 @@
           (and (not silent?) (not (code-hushed? code)))
           ,, (tp/send-iopub transport jup/EXECUTE-RESULT
                {:execution_count (state/execute-count)
-                :code code
                 :data (when-not (nil? result) (u/parse-json-str result true))
                 :metadata {}}))
         (when store-history?


Moved handling of race conditions to the handler

--- src/clojure/staircase/resources/services.clj
+++ src/clojure/staircase/resources/services.clj
@@ -61,10 +61,8 @@
   (create [_ doc]
     (let [id (new-id)
           owner (:user staircase.resources/context)
-          service (-> (dissoc doc :id "id") (assoc "id" id "owner" owner))]
-      (sql/with-db-transaction [trs (:connection db)]
-        (sql/delete! trs :services ["root=? and owner=?" (:root service) owner]) ;; Preserve invariant.
-        (sql/insert! trs :services service))
+          service (-> doc (dissoc :id "id" :owner) (assoc "id" id "owner" owner))]
+      (sql/insert! (:connection db) :services service)
       id))

   Searchable


Some tests take to long, made them smaller

but we have to think about why this is so slow...

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

--- src/conexp/tests/fca/lattices.clj
+++ src/conexp/tests/fca/lattices.clj
@@ -58,9 +58,9 @@
    (make-lattice #{0 1 2 3 4} #{[0 1] [0 2] [0 3] [0 4]
                                 [2 1] [3 1] [4 1] [0 0]
                                 [1 1] [2 2] [3 3] [4 4]}),
-   (concept-lattice (rand-context (set-of-range 10) 0.4)),
-   (concept-lattice (rand-context (set-of-range 10) 0.1)),
-   (concept-lattice (rand-context (set-of-range 10) 0.9))])
+   (concept-lattice (rand-context (set-of-range 7) 0.4)),
+   (concept-lattice (rand-context (set-of-range 7) 0.1)),
+   (concept-lattice (rand-context (set-of-range 7) 0.9))])

 (deftest test-has-lattice-order?
   (with-testing-data [lattice *testing-data*]


rest task crud

rest task crud

--- src/celestial/api.clj
+++ src/celestial/api.clj
@@ -116,9 +116,16 @@
    (update-in user [:password] (fn [v] (creds/hash-bcrypt v))))

 (defroutes- tasks {:path "/tasks" :description "Tasks managment"}
-    (POST- "/task" [^:task script] {:nickname "addTask" :summary "adds a new task"}
-         (debug (slurp (:tempfile script)))
-         (success {:msg "added task"})))
+  (POST- "/task" [& ^:task task] {:nickname "addTask" :summary "Adds a new task"}
+         (let [id (p/add-task task)]
+           (success {:msg "added new task" :id id})))
+
+  (PUT- "/task/:id" [^:int id & ^:task task] {:nickname "updateTask" :summary "Update a task"}
+        (p/update-task task)
+        (success {:msg "updated task" :task task}))
+
+  (GET- "/task" [^:int id] {:nickname "getTask" :summary "Get a task"}
+        (success {:task (p/get-task id)})))

 (defroutes- users {:path "/user" :description "User managment"}
   (GET- "/user/:name" [^:string name] {:nickname "getUser" :summary "Get User"}


leanup

leanup

--- src/clojure/clojurewerkz/cassaforte/new_query_api.clj
+++ src/clojure/clojurewerkz/cassaforte/new_query_api.clj
@@ -6,6 +6,10 @@
             BindMarker
             Clause]
            [com.datastax.driver.core.querybuilder ]))
+
+;;
+;; Static QB Methods
+;;

 (defn ?
   ([]
@@ -182,8 +186,7 @@
 ;; Truncate truncate(String keyspace, String table)
 ;; Truncate truncate(TableMetadata table)
 ;; String quote(String columnName)
-;; String token(String columnName)
-;; String token(String... columnNames)
+
 ;; Using timestamp(long timestamp)
 ;; Using timestamp(BindMarker marker)
 ;; Using ttl(int ttl)


CLJS-1175: CLJS defmulti doesn't exhibit same defonce behavior as Clojure's defmulti, suggesting an even better reloading behavior

defmulti now expands to defonce not def

add ns-unmap macro to support interactions with defonce

--- src/clj/cljs/core.clj
+++ src/clj/cljs/core.clj
@@ -34,7 +34,7 @@

                             cond-> cond->> as-> some-> some->>

-                            if-some when-some test ns-interns var vswap! macroexpand-1 macroexpand])
+                            if-some when-some test ns-interns ns-unmap var vswap! macroexpand-1 macroexpand])
   (:require clojure.walk
             clojure.set
             cljs.compiler
@@ -1855,7 +1855,7 @@
     (let [options   (apply core/hash-map options)
           default   (core/get options :default :default)]
       (check-valid-options options :default :hierarchy)
-      `(def ~(with-meta mm-name m)
+      `(defonce ~(with-meta mm-name m)
          (let [method-table# (atom {})
                prefer-table# (atom {})
                method-cache# (atom {})
@@ -1962,6 +1962,15 @@
             `[(symbol ~(name sym)) (var ~(symbol (name ns) (name sym)))])
           (get-in @env/*compiler* [:cljs.analyzer/namespaces ns :defs]))]))

+(defmacro ns-unmap
+  "Removes the mappings for the symbol from the namespace."
+  [[quote0 ns] [quote1 sym]]
+  (core/assert (core/and (= quote0 'quote) (core/symbol? ns)
+                         (= quote1 'quote) (core/symbol? sym))
+    "Arguments to ns-unmap must be quoted symbols")
+  (swap! env/*compiler* update-in [::ana/namespaces ns :defs] dissoc sym)
+  `(js-delete ~(cljs.compiler/munge ns) ~(cljs.compiler/munge (core/str sym))))
+
 (defmacro vswap!
   "Non-atomically swaps the value of the volatile as if:
    (apply f current-value-of-vol args). Returns the value that


the fact if a server should be keeped alive must be passed as a parameter to resolve-trash from corp install.

--- src/clj/game/core.clj
+++ src/clj/game/core.clj
@@ -619,9 +619,9 @@
   (when (>= (get-in @state [side :agenda-point]) (get-in @state [side :agenda-point-req]))
     (system-msg state side "wins the game")))

-(defn resolve-trash [state side {:keys [zone type] :as card} {:keys [unpreventable cause] :as args} & targets]
+(defn resolve-trash [state side {:keys [zone type] :as card} {:keys [unpreventable cause keep-server-alive] :as args} & targets]
   (let [cdef (card-def card)
-        moved-card (move state (to-keyword (:side card)) card :discard {:keep-server-alive true})]
+        moved-card (move state (to-keyword (:side card)) card :discard {:keep-server-alive keep-server-alive})]
     (when-let [trash-effect (:trash-effect cdef)]
       (resolve-ability state side trash-effect moved-card (cons cause targets)))))

@@ -1058,7 +1058,7 @@
                  (when-let [prev-card (some #(when (#{"Asset" "Agenda"} (:type %)) %) dest-zone)]
                    (system-msg state side (str "trashes " (if (:rezzed prev-card)
                                                             (:title prev-card) "a card") " in " server))
-                   (trash state side prev-card)))
+                   (trash state side prev-card {:keep-server-alive true})))
                (let [card-name (if (or rezzed (:rezzed c) (= (:install-state cdef) :face-up)) (:title card) "a card")]
                  (if (> install-cost 0)
                    (system-msg state side (str "pays " install-cost " [Credits] to install "


Playing around with LinClosure

Playing around with LinClosure

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

--- src/conexp/contrib/algorithms/linclosure.clj
+++ src/conexp/contrib/algorithms/linclosure.clj
@@ -41,6 +41,48 @@
               (.add update x))))))
     (set newdep)))

+(defn close-under-implications*  ;; this is LinClosure
+  "Computes smallest superset of start being closed under given implications."
+  [implications start]
+  (let [[counts list newdep] (loop [implications implications,
+                                    counts       {},
+                                    list         {},
+                                    newdep       (set start)]
+                               (if-let [impl (first implications)]
+                                 (let [impl-count (count (premise impl))]
+                                   (recur (rest implications)
+                                          (if (zero? impl-count)
+                                            counts
+                                            (assoc counts impl impl-count))
+                                          (if (zero? impl-count)
+                                            list
+                                            (reduce (fn [list a]
+                                                      (assoc list a (conj (get list a) impl)))
+                                                    list
+                                                    (premise impl)))
+                                          (if (zero? impl-count)
+                                            (into newdep (conclusion impl))
+                                            newdep)))
+                                 [counts list newdep]))]
+    (loop [counts counts,
+           update (seq newdep),
+           newdep newdep]
+      (if (empty? update)
+        newdep
+        (let [a      (first update),
+              update (rest update),
+              counts (reduce (fn [counts impl]
+                               (assoc counts impl (dec (get counts impl))))
+                             counts
+                             (get list a)),
+              newdep (reduce (fn [newdep impl]
+                               (if (zero? (counts impl))
+                                 (into newdep (conclusion impl))
+                                 newdep))
+                             newdep
+                             (get list a))]
+          (recur counts update newdep))))))
+
 ;;;

 (comment
@@ -48,11 +90,13 @@
   (use '[clojure.contrib.def :only (defvar-)])
   (require '[conexp.main :as cm])

-  (defvar- impls (cm/set-of (cm/make-implication A B)
-                            [A (cm/subsets #{1 2 3 4 5 6 7 8 9 10}),
-                             B (cm/subsets #{1 2 3 4 5 6 7 8 9 10})]))
+  (let [subsets-10 (cm/subsets #{1 2 3 4 5 6 7 8 9 10})]
+    (defvar- impls (cm/set-of (cm/make-implication A B)
+                              [A subsets-10
+                               B subsets-10])))

   (time (close-under-implications impls #{}))
+  (time (close-under-implications* impls #{}))
   (time (cm/close-under-implications impls #{}))

   nil)


This appears to be more stable performance-wise.

--- src/dsbdp/local_data_processing_pipeline.clj
+++ src/dsbdp/local_data_processing_pipeline.clj
@@ -28,9 +28,10 @@
 ;  `(ArrayBlockingQueue. *queue-size*))

 (defmacro enqueue
-;  [^TransferQueue queue data]
-  [^BlockingQueue queue data]
-  `(.put ~queue ~data))
+  [^TransferQueue queue data]
+;  [^BlockingQueue queue data]
+;  `(.put ~queue ~data))
+  `(.transfer ~queue ~data))
 ;  `(.tryTransfer ~queue ~data))

 (defmacro take-from-queue


More experiments with the way data is enqueued.

--- src/dsbdp/local_data_processing_pipeline.clj
+++ src/dsbdp/local_data_processing_pipeline.clj
@@ -29,11 +29,13 @@
                 (do
                   (println file-name "not found. Using default.")
 ;                  "ArrayBlockingQueue_put"))]
-                  "ArrayBlockingQueue_put-counted"))]
+;                  "ArrayBlockingQueue_put-counted"))]
 ;                  "ArrayBlockingQueue_put-counted-yield"))]
 ;                  "ArrayBlockingQueue_add-counted-yield"))]
 ;                  "ArrayBlockingQueue_add-counted-yield_remove-yield"))]
 ;                  "OneToOneConcurrentArrayQueue3_add-counted-yield_remove-yield"))]
+;                  "OneToOneConcurrentArrayQueue3_add-counted_remove-yield"))]
+                  "OneToOneConcurrentArrayQueue3_add-counted_remove"))]
 ;                  "ArrayBlockingQueue_offer-counted"))]
 ;                  "ArrayBlockingQueue_offer-counted-yield"))]
 ;                  "LinkedTransferQueue_transfer"))]
@@ -66,6 +68,11 @@
                                       (do
                                         (.inc ~dropped-counter)
                                         (Thread/yield)))
+               "add-counted" `(if (< (.size ~queue) queue-size)
+                                (do
+                                  (.add ~queue ~data)
+                                  (.inc ~enqueued-counter))
+                                (.inc ~dropped-counter))
                "put-counted-yield" `(if (< (.size ~queue) queue-size)
                                       (do
                                         (.put ~queue ~data)
@@ -74,10 +81,10 @@
                                         (.inc ~dropped-counter)
                                         (Thread/yield)))
                "put-counted" `(if (< (.size ~queue) queue-size)
-                                      (do
-                                        (.put ~queue ~data)
-                                        (.inc ~enqueued-counter))
-                                      (.inc ~dropped-counter))
+                                (do
+                                  (.put ~queue ~data)
+                                  (.inc ~enqueued-counter))
+                                (.inc ~dropped-counter))
                "put" `(.put ~queue ~data)
                "offer-counted-yield" `(if (< (.size ~queue) queue-size)
                                         (do
@@ -136,6 +143,10 @@
                                    (do
                                      (Thread/yield)
                                      (recur))))
+               "remove" `(loop []
+                           (if (not (.isEmpty ~queue))
+                             (.remove ~queue)
+                             (recur)))
                `(.take ~queue))]
     (println expr)
     expr))


more matchers

more matchers

--- src/matcha.clj
+++ src/matcha.clj
@@ -3,6 +3,7 @@
     :exclude
     [empty? every?
      = some not <= >= < >
+     re-matches
      instance? string? map? seq? char? vector? nil? keyword? symbol? ratio? decimal? float? isa? rational? coll? set? list? fn?])
   (:require [clojure.string :as string]
             [clojure.core :as core]))
@@ -22,8 +23,12 @@
 ;;  if pass? if false
 ;;
 ;;  TODO: matchers list
-;;  - all the matchers using `on` should have good error messages with bad types
-;;  - re-matches
+;;  - containsString
+;;  - startsWith
+;;  - endsWith
+;;  - equalIgnoringCase
+;;  - equalIgnoringWhiteSpace
+;;  - stringContainsInOrder
 (defn describe-list [call xs]
   (str "(" call " " (clojure.string/join " " xs) ")"))

@@ -55,7 +60,11 @@
             (and (pred x)
                  ((:match m) x)))
    :description (:description m)
-   :describe-mismatch #(str "not a " type-name ", " (describe-class-mismatch %))})
+   :describe-mismatch
+   (fn [x]
+     (if (pred x)
+       ((:describe-mismatch m describe-class-mismatch) x)
+       (str "not a " type-name ", " (describe-class-mismatch x))))})

 (defn =
   "matches based on equality of the value given
@@ -198,6 +207,39 @@
    :describe-mismatch
    standard-describe-mismatch})

+(defn is-in?
+  "passes if the value is included in the given collection
+
+  (matcha/run-match (matcha/is-in? [1]) 1) ; => passes
+  (matcha/run-match (matcha/is-in? [5]) 1) ; => fails"
+  [xs]
+  {:match #(core/some #{%} xs)
+   :description (str "one of " (pr-str xs))})
+
+(defn re-matches
+  "passes if the string matches the regex given
+
+  (matcha/run-match (matcha/is-in? #\"\\d+\") \"1\") ; => passes
+  (matcha/run-match (matcha/is-in? #\"\\d+\") \"a\") ; => fails"
+  [re]
+  (type-matcher
+    core/string?
+    "string"
+    {:match #(core/re-matches re %)
+     :description (str "a string matching " (pr-str re))}))
+
+(defn contains-string
+  "passes if the string includes the given string
+
+  (matcha/run-match (matcha/contains-string \"a\") \"a\") ; => passes
+  (matcha/run-match (matcha/contains-string \"a\") \"b\") ; => fails"
+  [s]
+  (type-matcher
+    core/string?
+    "string"
+    {:match #(.contains ^String % s)
+     :description (str "a string including " (pr-str s))}))
+
 (defn not
   "passes if the given matcher fails
   (matcha/run-match (matcha/not (matcha/= 1)) 1) ; => passes


Change formatting

Change formatting

--- src/github_changelog/formatters/markdown.clj
+++ src/github_changelog/formatters/markdown.clj
@@ -7,14 +7,14 @@

 (defmulti translate-type identity)

-(doseq [[k v] {"feat" "Features"
-               "fix" "Bug Fixes"
-               "perf" "Performance Improvements"
-               "docs" "Documentations"
-               "chore" "Chores"
-               "style" "Style Changes"
+(doseq [[k v] {"feat"     "Features"
+               "fix"      "Bug Fixes"
+               "perf"     "Performance Improvements"
+               "docs"     "Documentations"
+               "chore"    "Chores"
+               "style"    "Style Changes"
                "refactor" "Refactorings"
-               "test" "Tests"}]
+               "test"     "Tests"}]
   (defmethod translate-type k [_] v))

 (defmethod translate-type :default [x] x)


Decrease visibility

Decrease visibility

--- src/github_changelog/formatters/markdown.clj
+++ src/github_changelog/formatters/markdown.clj
@@ -23,10 +23,10 @@
   (when (not-empty scope)
     (markdown/emphasis (str scope ":"))))

-(defn format-pull-request [{:keys [number html_url]}]
+(defn- format-pull-request [{:keys [number html_url]}]
   (str " " (markdown/link (str "#" number) html_url)))

-(defn format-change [{:keys [subject pull-request issues]}]
+(defn- format-change [{:keys [subject pull-request issues]}]
   (str
    subject
    (format-pull-request pull-request)


Format scope only once

Format scope only once

--- src/github_changelog/formatters/markdown.clj
+++ src/github_changelog/formatters/markdown.clj
@@ -19,8 +19,9 @@

 (defmethod translate-type :default [x] x)

-(defn format-scope [scope]
-  (markdown/emphasis (str scope ":")))
+(defn- format-scope [scope]
+  (when (not-empty scope)
+    (markdown/emphasis (str scope ":"))))

 (defn format-pull-request [{:keys [number html_url]}]
   (str " " (markdown/link (str "#" number) html_url)))
@@ -40,15 +41,15 @@
 (defmethod format-grouped-changes 1 [[scope [change]]]
   (if (empty? scope)
     change
-    (str (format-scope scope) " " change)))
+    (str scope " " change)))

 (defmethod format-grouped-changes :default [[scope changes]]
   (if (empty? scope)
     changes
-    (str (format-scope scope) (format-entries changes))))
+    (str scope (format-entries changes))))

 (defn- map-formatted [[scope changes]]
-  [scope (map format-change changes)])
+  [(format-scope scope) (map format-change changes)])

 (defn format-changes [[type changes]]
   (str (markdown/h6 (translate-type type))


Convert DateTime to Date

Convert DateTime to Date

Currently I have not implemented encoding of DateTime in Transit. As I
need Date anyway in the Transaction Processor, I just convert it here.

--- src/lens/import_clinical_data.clj
+++ src/lens/import_clinical_data.clj
@@ -1,6 +1,7 @@
 (ns lens.import-clinical-data
   (:use plumbing.core)
-  (:require [clj-uuid :as uuid]
+  (:require [clj-time.coerce :as tc]
+            [clj-uuid :as uuid]
             [clojure.core.async :as async :refer [<!! <! >! chan go go-loop]]
             [clojure.data.xml :as xml]
             [lens.broker :as b :refer [handle-command send-event]]
@@ -11,7 +12,8 @@
                                                 ClinicalData
                                                 ODMFile]]
             [schema.core :as s :refer [Uuid Str Int Any Num]])
-  (:import [clojure.lang Keyword]))
+  (:import [clojure.lang Keyword]
+           [org.joda.time DateTime]))

 ;; ---- Commands --------------------------------------------------------------

@@ -49,11 +51,19 @@
 (s/defn remove-item-group [form-id :- Uuid item-group-oid :- OID]
   [:odm-import/remove-item-group {:form-id form-id :item-group-oid item-group-oid}])

-(s/defn insert-item [item-group-id :- Uuid item-oid :- OID data-type :- DataType value]
-  [:odm-import/insert-item {:item-group-id item-group-id :item-oid item-oid :data-type data-type :value value}])
+(defn- coerce [value]
+  (if (instance? DateTime value)
+    (tc/to-date value)
+    value))
+
+(s/defn insert-item
+  [item-group-id :- Uuid item-oid :- OID data-type :- DataType value]
+  [:odm-import/insert-item {:item-group-id item-group-id :item-oid item-oid
+                            :data-type data-type :value (coerce value)}])

 (s/defn update-item [item-id :- Uuid data-type :- DataType value]
-  [:odm-import/update-item {:item-id item-id :data-type data-type :value value}])
+  [:odm-import/update-item {:item-id item-id :data-type data-type
+                            :value (coerce value)}])

 (s/defn remove-item [item-group-id :- Uuid item-oid :- OID]
   [:odm-import/remove-item {:item-group-id item-group-id :item-oid item-oid}])


Cleaned up demo code

Cleaned up demo code

Just with easier to understand SPACING

--- src/webapp/framework/client/components/main_view.cljs
+++ src/webapp/framework/client/components/main_view.cljs
@@ -23,64 +23,65 @@

 (defn-ui-component     main-to-do-component   [app]
   {}
-
-  (section {:className "todoapp"}
-
-           (header {} (h2 nil "Todo app"))
+  (section
+   {:className "todoapp"}
+     (header {} (h2 nil "Todo app"))
+     (div {:className "main_div"}

-           (div {:className "main_div"}
+       (input-field {:placeholder  "Enter a new todo here"} app
+         (fn [new-todo-item-text] (go
+            (sql "insert into coils_todo_items
+                            (item, item_status)
+                  values
+                            (?,                  ?)"
+                            [new-todo-item-text  "ACTIVE"]  ))))

-                (input-field {}
-                 app
-                 (fn [new-value]
-                   (go
-                    (sql "insert into  coils_todo_items   (item, item_status) values (?,?)"
-                        [new-value  "ACTIVE"]  ))))
+
+       (div {:className "smallGap"})

-                (div {:className "smallGap"})

-                (div {:className "todo-list"}
-                     (realtime select
-                               id, item, item_status
-                               from
-                               coils_todo_items
-                               where
-                               item_status = ?
-                               OR
-                               item_status = ?
-                               order
-                               by id desc

-                               {:params [(if (read-ui app [:show]) (read-ui app [:show]) "ACTIVE")
-                                         (if (read-ui app [:show]) (read-ui app [:show]) "COMPLETED")
-                                         ]}
-                               (form {}
-                                     (div {:className "view" }

-                                          (div {:className  "checkbox"  :style { :width "20%" :display "inline-block;"} }
-                                               (input {:type  "checkbox"
-                                                       :checked   (if (= (<-- :item_status) "COMPLETED") "T" "")
-                                                       :onChange  (fn [event]
-                                                                    (let [newtext   (.. event -target -checked  )
-                                                                          item-id   (<-- :id)]
-                                                                      (if newtext
-                                                                        (go (sql "update  coils_todo_items   set item_status = 'COMPLETED' where id = ?" [item-id]  ))
-                                                                        (go (sql "update  coils_todo_items   set item_status = 'ACTIVE' where id = ?" [item-id]  ))
-                                                                        )))}))
+       (realtime select
+                      id, item, item_status
+                 from
+                      coils_todo_items
+                 where
+                      item_status = ? OR item_status = ?
+                 order
+                      by id desc

-                                          (label {:style {:width   "50%"} :className (if (= (<-- :item_status) "COMPLETED") "completed" "item")} (str (<-- :item)))
-                                          (button {:className   "destroy"
-                                                   :style {:width   "10%"}
-                                                   :onClick
-                                                   (fn [e]
-                                                     (go
-                                                       (sql "delete from  coils_todo_items  where id = ?"
-                                                            [(<-- :id)]  ))
-                                                     false)})
-                                          ))))
+                 {:params [(if (read-ui app [:show]) (read-ui app [:show]) "ACTIVE")
+                           (if (read-ui app [:show]) (read-ui app [:show]) "COMPLETED")]}
+
+                 (container
+
+                  (div {:className  "checkbox"  :style { :width "20%" :display "inline-block;"} }
+                       (input {:type  "checkbox"
+                               :checked   (if (= (<-- :item_status) "COMPLETED") "T" "")
+                               :onChange  (fn [event]
+                                            (let [newtext   (.. event -target -checked  )
+                                                  item-id   (<-- :id)]
+                                              (if newtext
+                                                (go (sql "update  coils_todo_items   set item_status = 'COMPLETED' where id = ?" [item-id]  ))
+                                                (go (sql "update  coils_todo_items   set item_status = 'ACTIVE' where id = ?" [item-id]  ))
+                                                )))}))
+
+                  (label {:style {:width   "50%"}
+                          :className (if (= (<-- :item_status) "COMPLETED") "completed" "item")}
+                                (str (<-- :item)))
+
+                  (button {:className   "destroy"
+                           :style {:width   "10%"}
+                           :onClick
+                           (fn [e]
+                             (go
+                              (sql "delete from  coils_todo_items  where id = ?"
+                                   [(<-- :id)]  ))
+                                          false)})))


Handle unpriced service-offers

Handle unpriced service-offers

--- jar-placement-lib/src/sixsq/slipstream/placement/core.clj
+++ jar-placement-lib/src/sixsq/slipstream/placement/core.clj
@@ -7,6 +7,7 @@
     [sixsq.slipstream.client.api.cimi :as cimi]))

 (def service-offer-currency-key :schema-org:priceCurrency)
+(def no-price -1)

 (defn string-or-nil?
   [s]
@@ -30,10 +31,15 @@
                       #(get-in % [:schema-org:descriptionVector :schema-org:disk])))
        first))

-(defn- entity-to-price-with
+(defn- EUR-or-unpriced?
+  [service-offer]
+  (let [price-currency (service-offer-currency-key service-offer)]
+    (or (nil? price-currency) (= "EUR" price-currency))))
+
+(defn- service-offer-for-connector
   [service-offers connector-name]
   (->> service-offers
-       (filter #(and (= (service-offer-currency-key %) "EUR")
+       (filter #(and (EUR-or-unpriced? %)
                      (= (get-in % [:connector :href]) connector-name)))
        smallest-service-offer))

@@ -56,20 +62,30 @@
     (into {} (map (fn [[k v]] [(denamespace k) (denamespace-keys v)]) m))
     m))

+(defn- priceable?
+  [service-offer]
+  (every? (set (keys service-offer))
+          [:schema-org:billingTimeCode
+           :schema-org:price
+           :schema-org:priceCurrency
+           :schema-org:unitCode]))
+
 (defn- compute-price
-  [entity timecode]
-  (pr/compute-cost (denamespace-keys entity)
-                   [{:timeCode timecode
-                     :sample   1
-                     :values   [1]}]))
+  [service-offer timecode]
+  (if (priceable? service-offer)
+    (pr/compute-cost (denamespace-keys service-offer)
+                     [{:timeCode timecode
+                       :sample   1
+                       :values   [1]}])
+    no-price))

 (defn- price-connector
   [service-offers connector-name]
-  (if-let [entity (entity-to-price-with service-offers connector-name)]
+  (if-let [service-offer (service-offer-for-connector service-offers connector-name)]
     (do
-      (log/info "Entity to price with " (display-service-offer entity))
+      (log/info "Entity to price with " (display-service-offer service-offer))
       {:name     connector-name
-       :price    (compute-price entity "HUR")               ;; TODO hard-coded timecode
+       :price    (compute-price service-offer "HUR")               ;; TODO hard-coded timecode
        :currency "EUR"})))                                  ;; TODO hard-coded currency to EUR

 (defn order-by-price
@@ -114,12 +130,11 @@
         connectors-clause   (str/join " or " connectors-clauses)
         cimi-filter         (cimi-and policy connectors-clause)
         cimi-filter         (cimi-and cimi-filter (clause-cpu-ram-disk component))]
-    (log/info "the cimi-filter = " cimi-filter)
+    (log/debug "the cimi-filter = " cimi-filter)
     cimi-filter))

 (defn- service-offers-by-component-policy
   [user-connectors component]
-  (log/info "Fetching service offers by component policy")
   (fetch-service-offers (cimi-filter-policy user-connectors component)))

 (defn- place-rank-component


Makes more sense to use .equals with type hints

--- src/main/clj/clojure/core/matrix/complex.clj
+++ src/main/clj/clojure/core/matrix/complex.clj
@@ -212,7 +212,7 @@
     (every?
       identity
       (mapv (fn [alpha beta]
-                (Complex/equalsWithRelativeTolerance alpha beta eps))
+                (Complex/equals ^Complex alpha ^Complex beta ^double eps))
             (m/eseq a)
             (m/eseq b)))))


Parse processor-batch-size environment variable as integer

--- src/main/clojure/pdok/featured/processor.clj
+++ src/main/clojure/pdok/featured/processor.clj
@@ -302,7 +302,10 @@
          tx (:tx initialized-persistence)
          initialized-projectors (doall (map #(proj/init % tx dataset (pers/collections initialized-persistence))
                                             (clojure.core/flatten projectors)))
-         batch-size (or (config/env :processor-batch-size) 10000)]
+         batch-size (or
+                      (when-let [processor-batch-size (config/env :processor-batch-size)]
+                        (Integer/parseInt processor-batch-size))
+                      10000)]
      (merge {:dataset dataset
              :check-validity-on-delete true
              :check-existence-on-delete true


fix: only new-validation for nested features (changes and closes)

--- src/main/clojure/pdok/featured/processor.clj
+++ src/main/clojure/pdok/featured/processor.clj
@@ -70,19 +70,20 @@
   )

 (defn- validate [{:keys [persistence]} feature]
+  "Validates features. Nested actions are validated against new checks, because we always close the old nested features."
   (condp contains? (:action feature)
-    #{:new :nested-new}
+    #{:new :nested-new :nested-change :nested-close}
     (let [validated  (->> feature
                           (apply-all-features-validation persistence)
                           (apply-new-feature-requires-non-existing-stream-validation persistence))]
       validated)
-    #{:change :nested-change}
+    #{:change}
     (->> feature
          (apply-all-features-validation persistence)
          (apply-non-new-feature-requires-existing-stream-validation persistence)
          (apply-closed-feature-cannot-be-changed-validation persistence)
          (apply-non-new-feature-current-validity-validation persistence))
-    #{:close :nested-close}
+    #{:close}
     (->> feature
          (apply-all-features-validation persistence)
          (apply-closed-feature-cannot-be-changed-validation persistence)


[UI] fix Runtimes tab not highlighting

[UI] fix Runtimes tab not highlighting

--- src/main/shadow/cljs/ui/main.cljs
+++ src/main/shadow/cljs/ui/main.cljs
@@ -51,7 +51,7 @@
    nav-items
    [{:pages #{:dashboard} :label "Dashboard" :path "/dashboard"}
     {:pages #{:builds :build} :label "Builds" :path "/builds"}
-    {:pages #{:repl} :label "Runtimes" :path "/runtimes"}
+    {:pages #{:runtimes} :label "Runtimes" :path "/runtimes"}
     {:pages #{:inspect} :label "Inspect" :path "/inspect"}]

    nav-selected


Fix: timezone offset for today was missing

--- src/status_im/utils/datetime.cljs
+++ src/status_im/utils/datetime.cljs
@@ -25,16 +25,13 @@
   ([ms]
    (to-short-str ms #(unparse (formatters :hour-minute) %)))
   ([ms today-format-fn]
-   (let [date       (from-long ms)
-         local      (plus date time-zone-offset)
-         today-date (t/today)
-         today      (date-time (t/year today-date)
-                               (t/month today-date)
-                               (t/day today-date))
-         yesterday  (plus today (days -1))]
+   (let [date      (from-long ms)
+         local     (plus date time-zone-offset)
+         today     (t/today-at-midnight)
+         yesterday (plus today (days -1))]
      (cond
-       (before? local yesterday) (unparse (formatter "dd MMM hh:mm") local)
-       (before? local today) (label :t/datetime-yesterday)
+       (before? date yesterday) (unparse (formatter "dd MMM hh:mm") local)
+       (before? date today) (label :t/datetime-yesterday)
        :else (today-format-fn local)))))

 (defn day-relative [ms]


procfile

procfile

--- src/redchat/core.clj
+++ src/redchat/core.clj
@@ -13,7 +13,9 @@
   (s/run-dmc h/app))

 (defn -main
-  [& [port]]
-  (info "port is " (env :port))
-  (let [port (Integer. (or port (env :port) 5000))]
-    (s/run h/heroku {:port port})))
+  [& {:as args}]
+  ;;  (info "port is " (env :port))
+  (let [host (args "host")
+        port (Integer. (or (args "port") (env :port) 5000))]
+    (s/run h/heroku {:port port
+                     :host host})))


Fast path matching with .equals

Fast path matching with .equals

--- src/reitit/impl.cljc
+++ src/reitit/impl.cljc
@@ -104,22 +104,24 @@
 (defrecord Route [path matcher parts params meta result])

 (defn create [[path meta result]]
-  (if (contains-wilds? path)
-    (as-> (parse-path path) $
-          (assoc $ :path-re (path-regex $))
-          (merge $ {:path path
-                    :matcher (path-matcher $)
-                    :result result
-                    :meta meta})
-          (dissoc $ :path-re :path-constraints)
-          (update $ :path-params set)
-          (set/rename-keys $ {:path-parts :parts
-                              :path-params :params})
-          (map->Route $))
-    (map->Route {:path path
-                 :meta meta
-                 :matcher #(if (= path %) {})
-                 :result result})))
+  (let [path #?(:clj (.intern ^String path) :cljs path)]
+    (if (contains-wilds? path)
+      (as-> (parse-path path) $
+            (assoc $ :path-re (path-regex $))
+            (merge $ {:path path
+                      :matcher (path-matcher $)
+                      :result result
+                      :meta meta})
+            (dissoc $ :path-re :path-constraints)
+            (update $ :path-params set)
+            (set/rename-keys $ {:path-parts :parts
+                                :path-params :params})
+            (map->Route $))
+      (map->Route {:path path
+                   :meta meta
+                   :matcher #?(:clj #(if (.equals path %) {})
+                               :cljs #(if (= path %)))
+                   :result result}))))

 (defn segments [path]
   (let [ss (-> (str/split path #"/") rest vec)]


Remove debugging class

Remove debugging class

--- src/ankha/core.cljs
+++ src/ankha/core.cljs
@@ -150,7 +150,7 @@

 (defn- editor [owner {:keys [value save-editor cancel-editor error-message]}]
   (dom/div #js {:style #js {:display "inline"}}
-           (dom/textarea #js {:className "bacon"
+           (dom/textarea #js {:className "editor"
                               :ref "editor"
                               :style #js {:display "inline-block"}
                               :value value