Continue to implementing macros

Continue to implementing macros

--- src/beehive/guard_rail.clj
+++ src/beehive/guard_rail.clj
@@ -78,13 +78,25 @@
     {:cpath cpath
      :key->enum-string key->enum-string}))

-(defmacro create-types [result->success?]
-  (let [{:keys [key->enum-string cpath]} (gen-type result->success?)]
-    `(do
-       (-> {}
-           ~@(map (fn [[k es]]
-                    (list assoc k `(. ~cpath ~es)))
-                  key->enum-string)))))
+(defmacro create-type-map [{:keys [key->enum-string cpath] :as l}]
+  (println key->enum-string)
+  `(do
+     (-> {}
+         ~@(map (fn [[k es]]
+                  (list assoc k `(. ~cpath ~es)))
+                key->enum-string))))
+
+(def default-rejected-type
+  {:cpath net.uncontended.precipice.rejected.Rejected
+   :key->enum-string {:max-concurrency 'MAX_CONCURRENCY_LEVEL_EXCEEDED
+                      :circuit-open 'CIRCUIT_OPEN
+                      :rate-limit 'RATE_LIMIT_EXCEEDED}})
+
+(def default-result-type
+  {:cpath net.uncontended.precipice.result.TimeoutableResult
+   :key->enum-string {:success 'SUCCESS
+                      :error 'ERROR
+                      :timeout 'TIMEOUT}})

 (defmacro guard-rail
   [name result-metrics rejected-metrics &
@@ -93,20 +105,23 @@
         rj-fn (first rejected-metrics)
         rm-args (rest result-metrics)
         rj-args (rest rejected-metrics)
-        result-type TimeoutableResult                       ;; Use correct type
-        rejected-type Rejected                              ;; Use correct type
+        result-type (if result->success?
+                      (gen-type result->success?)
+                      default-result-type)
+        rejected-type default-rejected-type
         l-fn (first latency-metrics)
         l-args (rest latency-metrics)]
-    {:pr `(-> (GuardRailBuilder.)
-             (.name ~name)
-             (.resultMetrics (~rm-fn ~result-type ~@rm-args))
-             (.rejectedMetrics (~rj-fn ~rejected-type ~@rj-args))
-             (cond->
-               ~latency-metrics
-               (.resultLatency (~l-fn ~result-type ~@l-args))
-               ~backpressure
-               (new-bp ~backpressure)))
-     :pl `(create-types ~result->success?)}))
+    {:guard-rail `(-> (GuardRailBuilder.)
+                      (.name ~name)
+                      (.resultMetrics (~rm-fn ~(:cpath result-type) ~@rm-args))
+                      (.rejectedMetrics (~rj-fn ~(:cpath rejected-type) ~@rj-args))
+                      (cond->
+                        ~latency-metrics
+                        (.resultLatency (~l-fn ~(:cpath result-type) ~@l-args))
+                        ~backpressure
+                        (new-bp ~backpressure)))
+     :results `(create-type-map ~result-type)
+     :rejected `(create-type-map ~rejected-type)}))


Add a clickable link to the online download

--- src/catalog/latex.clj
+++ src/catalog/latex.clj
@@ -108,6 +108,11 @@
 %% \\pagestyle{plain}
 \\tableofcontents")

+(defn to-url
+  "Return an url given a `record-id`"
+  [record-id]
+  (format "http://online.sbs.ch/iguana/www.main.cls?sUrl=search#anchor_Record_%s" record-id))
+
 (defmulti catalog-entry (fn [{fmt :format}] fmt))

 (defmethod catalog-entry :hörfilm
@@ -136,12 +141,12 @@
                 price])))

 (defmethod catalog-entry :default
-  [{:keys [title creator description source_publisher source_date genre]}]
+  [{:keys [record-id title creator description source_publisher source_date genre]}]
   (apply
    format "\\begin{description}
-\\item[%s] %s %s %s %s \\\\ %s
+\\item[%s] \\href{%s}{%s} %s %s %s \\\\ %s
 \\end{description}"
-   (map escape [creator title source_publisher source_date (translations genre) description])))
+   (map escape [creator (to-url record-id) title source_publisher source_date (translations genre) description])))

 (defn catalog-entries [items]
   (for [item items] (catalog-entry item)))


initial docstring for cljs.repl/repl

initial docstring for cljs.repl/repl

--- src/clj/cljs/repl.clj
+++ src/clj/cljs/repl.clj
@@ -667,7 +667,71 @@
          (-tear-down repl-env)))))

 (defn repl
-  "Note - repl will reload core.cljs every time, even if supplied old repl-env"
+  "Generic, reusable, read-eval-print loop. By default, reads from *in* using
+  a c.t.r.reader-types/source-logging-push-back-reader,
+  writes to *out*, and prints exception summaries to *err*. If you use the
+  default :read hook, *in* must either be an instance of
+  c.t.r.reader-types/PushbackReader or duplicate its behavior of both supporting
+  unread and collapsing CR, LF, and CRLF into a single \\newline. Options
+  are sequential keyword-value pairs. The first argument is the JavaScript
+  evaluation environment, the second argument is an extended version of the
+  standard ClojureScript compiler options. In addition to ClojureScript compiler
+  build options it also take a set of options similar to clojure.main/repl with
+  adjustments for ClojureScript evalution and compilation model:
+
+  Available clojure.main/repl style options and their defaults:
+
+     - :init, function of no arguments, initialization hook called with
+       bindings for set!-able vars in place.
+       default: #()
+
+     - :need-prompt, function of no arguments, called before each
+       read-eval-print except the first, the user will be prompted if it
+       returns true.
+       default: #(if (c.t.r.readers-types/indexing-reader? *in*)
+                   (== (c.t.r.reader-types/get-column-number *in*) 1)
+                   (identity true))
+
+     - :prompt, function of no arguments, prompts for more input.
+       default: repl-prompt
+
+     - :flush, function of no arguments, flushes output
+       default: flush
+
+     - :read, function of two arguments, reads from *in*:
+         - returns its first argument to request a fresh prompt
+           - depending on need-prompt, this may cause the repl to prompt
+             before reading again
+         - returns its second argument to request an exit from the repl
+         - else returns the next object read from the input stream
+       default: repl-read
+
+     - :eval, function of one argument, returns the evaluation of its
+       argument. The eval function must take repl-env, the JavaScript evaluation
+       envrionment, env, the ClojureScript analysis environemnt, the form
+       and opts, the standard ClojureScript REPL/compiler options.
+       default: eval
+
+     - :print, function of one argument, prints its argument to the output
+       default: println
+
+     - :caught, function of two arguments, a throwable, called when
+       read, eval, or print throws an exception or error
+       default. The second argument is opts, the standard ClojureScript
+       REPL/compiler options. In the case of errors or exception in the
+       JavaScript target, these will be thrown as clojure.lang.IExceptionInfo
+       instances.
+       default: repl-caught
+
+     - :reader, the c.t.r reader to use.
+       default: c.t.r.read-types/source-logging-push-back-reader
+
+     - :print-no-newline, print without a newline.
+       deafult: print
+
+     - :source-map-inline, whether inline source maps should be enabled. Most
+       useful in browser context. Implies using a fresh reader for each form.
+       default: true"
   [repl-env & {:as opts}]
   (repl* repl-env opts))


Fix :access event not firing when additional costs to steal an agenda are declined. (Fetal AI)

--- src/clj/game/core.clj
+++ src/clj/game/core.clj
@@ -21,7 +21,7 @@
     (say state side {:user "__system__" :text (str username " " text ".")})))

 (declare prompt! forfeit trigger-event handle-end-run trash update-advancement-cost update-all-advancement-costs
-         update-all-ice update-ice-strength update-breaker-strength all-installed)
+         update-all-ice update-ice-strength update-breaker-strength all-installed resolve-steal-events)

 (defn can-pay? [state side & args]
   (let [costs (merge-costs (remove #(or (nil? %) (= % [:forfeit])) args))
@@ -252,8 +252,8 @@
 (defn optional-ability [state side card msg ability targets]
   (show-prompt state side card msg ["Yes" "No"] #(if (= % "Yes")
                                                    (resolve-ability state side ability card targets)
-                                                   (when-let [no-msg (:no-msg ability)]
-                                                     (system-msg state side (:no-msg ability))))))
+                                                   (when-let [no-ability (:no-effect ability)]
+                                                     (resolve-ability state side no-ability card targets)))))

 (defn resolve-trace [state side boost]
   (let [runner (:runner @state)
@@ -402,9 +402,7 @@
 (defn trash-no-cost [state side]
   (when-let [card (:card (first (get-in @state [side :prompt])))]
     (when (= (:type card) "Agenda") ; trashing before the :access events actually fire; fire them manually
-      (when-let [access-effect (:access (card-def card))]
-        (resolve-ability state (to-keyword (:side card)) access-effect card nil))
-      (trigger-event state side :access card))
+      (resolve-steal-events state side card))
     (trash state side card)
     (swap! state update-in [side :prompt] rest)
     (when-let [run (:run @state)]
@@ -806,11 +804,15 @@
       (concat (get-in @state [:bonus :steal-cost]))
       merge-costs flatten vec))

-(defn resolve-steal [state side c]
+(defn resolve-steal-events [state side c]
   (let [cdef (card-def c)]
     (when-let [access-effect (:access cdef)]
       (resolve-ability state (to-keyword (:side c)) access-effect c nil))
-    (trigger-event state side :access c)
+    (trigger-event state side :access c)))
+
+(defn resolve-steal [state side c]
+  (let [cdef (card-def c)]
+    (resolve-steal-events state side c)
     (when (or (not (:steal-req cdef)) ((:steal-req cdef) state :runner c nil))
       (steal state :runner c))))

@@ -831,13 +833,12 @@
                                       {:cost cost
                                        :effect (effect (system-msg (str "pays " (costs-to-symbol cost)
                                                                         " to steal " (:title c)))
-                                                       (resolve-steal c))} nil)
+                                                       (resolve-steal c))
+                                       :no-effect {:effect (effect (resolve-steal-events c))}} nil)
                     (resolve-ability state :runner
                                      {:prompt (str "You access " (:title c)) :choices ["Steal"]
                                       :effect (req (resolve-steal state :runner c))} c nil)))
-                (do (when-let [access-effect (:access cdef)]
-                      (resolve-ability state (to-keyword (:side c)) access-effect c nil))
-                    (trigger-event state side :access c)
+                (do (resolve-steal-events state side c)
                     (prompt! state :runner c (str "You accessed but cannot steal " (:title c)) ["OK"] {}))))
         (do (when-let [access-effect (:access cdef)]
               (resolve-ability state (to-keyword (:side c)) access-effect c nil))


Added event for card de-rezing, :derez. Used by Mother Goddess.

--- src/clj/game/core.clj
+++ src/clj/game/core.clj
@@ -762,7 +762,8 @@

 (defn derez [state side card]
   (system-msg state side (str "derez " (:title card)))
-  (update! state :corp (desactivate state :corp card true)))
+  (update! state :corp (desactivate state :corp card true))
+  (trigger-event state side :derez card))

 (defn advance [state side {:keys [card]}]
   (when (pay state side card :click 1 :credit 1)


Update :zone of nested :host.

Update :zone of nested :host.

--- src/clj/game/core.clj
+++ src/clj/game/core.clj
@@ -1283,6 +1283,13 @@
                (get-in @state [:runner :rig (to-keyword (:type card))]))]
     (some #(= (:title %) (:title card)) dest)))

+(defn assoc-host-zones [card]
+  (let [card (update-in card [:zone] #(map to-keyword %))]
+    (if (:host card)
+      (assoc card :host (assoc-host-zones (:host card)))
+      card)))
+
+
 (defn host
   ([state side card target] (host state side card target nil))
   ([state side card {:keys [zone cid host installed] :as target} {:keys [facedown] :as options}]
@@ -1297,9 +1304,8 @@
        (swap! state update-in (cons s (vec zone))
               (fn [coll] (remove-once #(not= (:cid %) cid) coll)))))
    (swap! state update-in (cons side (vec zone)) (fn [coll] (remove-once #(not= (:cid %) cid) coll)))
-   (let [c (assoc target :host (-> card
-                                   (update-in [:zone] #(map to-keyword %))
-                                   (dissoc :hosted))
+   (let [card (assoc-host-zones card)
+         c (assoc target :host (dissoc card :hosted)
                          :facedown facedown
                          :zone '(:onhost) ;; hosted cards should not be in :discard or :hand etc
                          :previous-zone (:zone target))]


Comment indentation fix

Comment indentation fix

--- src/clj_http/core.clj
+++ src/clj_http/core.clj
@@ -122,7 +122,7 @@
 (defn http-client [{:keys [redirect-strategy retry-handler uri
                            response-interceptor proxy-host proxy-port]}
                    conn-mgr http-url proxy-ignore-host]
-  ; have to let first, otherwise we get a reflection warning on (.build)
+  ;; have to let first, otherwise we get a reflection warning on (.build)
   (let [^HttpClientBuilder builder (-> (HttpClients/custom)
                                        (.setConnectionManager conn-mgr)
                                        (.setRedirectStrategy


Stub for server_test

Stub for server_test

--- test/zg/server_test.clj
+++ test/zg/server_test.clj
@@ -23,3 +23,11 @@
     [function-name]
     (clojure.test/function? function-name))

+;
+; Tests for various functions existence
+;
+
+;
+; Test for function behaviours
+;
+


add invalidators

add invalidators

--- src/domshot/core.cljs
+++ src/domshot/core.cljs
@@ -2,6 +2,21 @@
   (:require [goog.dom]))

 (enable-console-print!)
+
+;; ---- Node validators ---- ;;
+
+(def invalidators
+  "An atom of a list of predicates. Each takes the current node as its only arg.
+  Predicates should return `true` if you want `snapshot` to ignore the node."
+  (atom ()))
+
+(defn include-node? [node]
+  (not-any? false? (map #(% node) @invalidators)))
+
+(defn add-invalidator [fn]
+  (swap! invalidators conj fn))
+
+;; ---- Serializing the dom ---- ;;

 (defn get-attrs [node]
   (if (.-attributes node)
@@ -37,7 +52,14 @@
        :children (if (not (.hasChildNodes node))
                    []
                    (vec (for [index (range (-> node .-childNodes .-length))
-                              :let [child (aget (.-childNodes node) index)]]
+                              :let [child (aget (.-childNodes node) index)]
+                              :when (include-node? child)]
                           (snapshot child))))))))

+
+
+;; ---- Testing the api... TODO: delete these and test like a pro, not a noob D: ---- ;;
+
+(add-invalidator #(not= "SCRIPT" (.-nodeName %)))
+
 (.log js/console "snapshot result" (clj->js (snapshot)))


server/home-route refactored and docstring added

--- src/elliot/server.clj
+++ src/elliot/server.clj
@@ -14,8 +14,9 @@
   [query]
   (search-template/render (search/go query)))

-(defn home-route [{{terms "terms"} :params}]
-  (println terms)
+(defn home-route
+  "Returns the full html page with search results included"
+  [{{terms "terms"} :params}]
   {:status 200
    :body  (home/render (search {:q terms}))})


helper function select-fields to return a map of the fields with their associated values

--- src/ez_form/core.cljc
+++ src/ez_form/core.cljc
@@ -117,6 +117,13 @@
           (:fields form))
      (decorate form tail))))

+(defn select-fields [form]
+  (reduce (fn [out field]
+            (assoc out
+                   (or (:id field) (:name field))
+                   (or (:value-added field) (:value field))))
+          {} (:fields form)))
+
 (defmacro defform [-name options fields]
   (let [form-name (name -name)]
     `(defn ~-name


Some query comments.

Some query comments.

--- src/fcms/db/views.clj
+++ src/fcms/db/views.clj
@@ -7,6 +7,7 @@

 ;; http://localhost:5984/falklandcms/_design/collection/_view/all
 ;; http://localhost:5984/falklandcms/_design/collection/_view/all?include_docs=true
+;; http://localhost:5984/falklandcms/_design/collection/_view/all?key="slug"
 (clutch/with-db (base/db)
   (clutch/save-view "collection"
     (clutch/view-server-fns :cljs {:all
@@ -16,6 +17,7 @@

 ;; http://localhost:5984/falklandcms/_design/item/_view/all
 ;; http://localhost:5984/falklandcms/_design/collection/_view/all?include_docs=true
+;; http://localhost:5984/falklandcms/_design/collection/_view/all?key="slug"
 (clutch/with-db (base/db)
   (clutch/save-view "item"
     (clutch/view-server-fns :cljs {:all {:map (fn [doc]
@@ -24,6 +26,7 @@

 ;; http://localhost:5984/falklandcms/_design/taxonomy/_view/all
 ;; http://localhost:5984/falklandcms/_design/collection/_view/all?include_docs=true
+;; http://localhost:5984/falklandcms/_design/collection/_view/all?key="slug"
 (clutch/with-db (base/db)
   (clutch/save-view "taxonomy"
     (clutch/view-server-fns :cljs {:all {:map (fn [doc]


Some short-circuiting on interval union

Some short-circuiting on interval union

--- src/ha/intervals.cljc
+++ src/ha/intervals.cljc
@@ -136,32 +136,35 @@
     (simple? i1) (union i2 i1)
     ; union many one
     (simple? i2)
-    (loop [is []
-           i1s i1
-           i i2]
-      (if (seq i1s)
-        (let [i1 (first i1s)
-              i1min (.-start i1)
-              i1max (.-end i1)
-              i2min (.-start i)
-              i2max (.-end i)]
-          (cond
-            ;i1 ends before i2 begins -- pass i1 on and continue
-            (<= i1max i2min) (recur (conj is i1) (rest i1s) i)
-            ;i2 ends before i1 starts -- conj in (the possibly extended) i2 and then finish up
-            (<= i2max i1min) (into (conj is i) i1s)
-            ;i1 contains i2 -- drop i2 completely and finish up
-            (<= i1min i2min i2max i1max) (into is i1s)
-            ;i2 contains i1 -- drop i1 and continue
-            (<= i2min i1min i1max i2max) (recur is (rest i1s) i)
-            ;i2 overlaps i1 -- extend i2 by i1, drop i1, and continue
-            (or (<= i1min i2min i1max)
-                (<= i2min i1min i2max)) (recur is (rest i1s) (interval (min i1min i2min)
-                                                                       (max i1max i2max)))
-            ; that should be all the cases!
-            :else (assert false)))
-        ;got to the end without bailing early, which means i ought to be included
-        (conj is i)))
+    (cond
+      (< (.-end i2) (start i1)) (vec (concat [i2] i1))
+      (< (end i1) (.-start i2)) (conj i1 i2)
+      :else (loop [is []
+                   i1s i1
+                   i i2]
+              (if (seq i1s)
+                (let [i1 (first i1s)
+                      i1min (.-start i1)
+                      i1max (.-end i1)
+                      i2min (.-start i)
+                      i2max (.-end i)]
+                  (cond
+                    ;i1 ends before i2 begins -- pass i1 on and continue
+                    (<= i1max i2min) (recur (conj is i1) (rest i1s) i)
+                    ;i2 ends before i1 starts -- conj in (the possibly extended) i2 and then finish up
+                    (<= i2max i1min) (into (conj is i) i1s)
+                    ;i1 contains i2 -- drop i2 completely and finish up
+                    (<= i1min i2min i2max i1max) (into is i1s)
+                    ;i2 contains i1 -- drop i1 and continue
+                    (<= i2min i1min i1max i2max) (recur is (rest i1s) i)
+                    ;i2 overlaps i1 -- extend i2 by i1, drop i1, and continue
+                    (or (<= i1min i2min i1max)
+                        (<= i2min i1min i2max)) (recur is (rest i1s) (interval (min i1min i2min)
+                                                                               (max i1max i2max)))
+                    ; that should be all the cases!
+                    :else (assert false)))
+                ;got to the end without bailing early, which means i ought to be included
+                (conj is i))))
     ; union many many
     ; reduce union-with-i1 over elements of i2
     :else (reduce union i1 i2)))
@@ -177,7 +180,7 @@
                                   intvl
                                   (do
                                     #_(assert (and (>= (.-start new-i) (.-start i))
-                                                 (<= (.-end new-i) (.-end i))))
+                                                   (<= (.-end new-i) (.-end i))))
                                     (conj intvl new-i)))))
                             []
                             intvl)]


Keep track of config file in config ns.

Keep track of config file in config ns.

Also add serving? function which checks to see the current method is serving.

--- src/incise/config.clj
+++ src/incise/config.clj
@@ -7,12 +7,28 @@

 (defonce config (atom {}))

-(defn load []
-  (when-let [config-file (file (resource "incise.edn"))]
-    (reset! config (edn/read (PushbackReader. (reader config-file))))))
+(defn get [& more]
+  (if (empty? more)
+    @config
+    (apply @config more)))
+
+(defn merge [& more]
+  (apply swap! config
+         clojure.core/merge more))

 (defn assoc [& more]
   (apply swap! config clojure.core/assoc more))
+
+(defonce config-path (atom nil))
+
+(defn serving? [] (= (get :method) :serve))
+
+(defn load
+  "Load the config from "
+  [& [path-to-config]]
+  (when path-to-config (reset! config-path path-to-config))
+  (when-let [config-file (file (or @config-path (resource "incise.edn")))]
+    (reset! config (edn/read (PushbackReader. (reader config-file))))))

 (defmannerisms config
   [:in-dir "must have an in-dir"]
@@ -21,12 +37,3 @@
   [(comp string? :out-dir) "out-dir must be a string (like a path)"])

 (defn avow! [] (avow-config! @config))
-
-(defn get [& more]
-  (if (empty? more)
-    @config
-    (apply @config more)))
-
-(defn merge [& more]
-  (apply swap! config
-         clojure.core/merge more))


Add comments about :new and :edit

Add comments about :new and :edit

--- src/io/aviso/rook.clj
+++ src/io/aviso/rook.clj
@@ -13,11 +13,11 @@
   If a public method whose name matches a default mapping exists, then it will be added using the
   default mapping; for example, a method named \"index\" will automatically be matched against \"GET /\".
   This can be overriden by providing meta-data on the functions."
-  [[[:get "/new"] :new]
+  [[[:get "/new"] :new] ; :new is used to present an HTML form to a user, to create the entity, not needed in a pure web service
    [[:get "/:id"] :show]
    [[:put "/:id"] :update]
    [[:patch "/:id"] :update]
-   [[:get "/:id/edit"] :edit]
+   [[:get "/:id/edit"] :edit] ; :edit parallels :new, a user-centric HTML form, not needed in a pure web service
    [[:delete "/:id"] :destroy]
    [[:get "/"] :index]
    [[:post "/"] :create]])


simplifying pipeline

simplifying pipeline

--- src/babel/generate.cljc
+++ src/babel/generate.cljc
@@ -42,6 +42,7 @@
 (declare log-unification-result)
 (declare lightning-bolts)
 (declare not-fail?)
+(declare unify-and-log)

 ;; TODO: demote 'depth' and 'max-depth' down to lower level functions
 (defn generate-all [spec model & [depth max-depth]]
@@ -84,12 +85,7 @@

      (map (fn [tree-parts]
             (reduce (fn [a b]
-                      (let [result
-                            (cond (or (= :fail a)
-                                      (= :fail b)) :fail
-                                  true (unify a b))]
-                        (log-unification-result a b result model)
-                        result))
+                      (unify-and-log a b model))
                     tree-parts)))

      (map #(do-defaults % model)) ;; for each tree, run model defaults.
@@ -99,6 +95,9 @@
              %))

      (remove #(= :fail %)))))
+
+(defn unify-and-log [a b model]
+  (log-unification-result a b (unify a b) model))

 (defn comp-path-to-complements
   "return a lazy sequence of bolts for all possible complements that can be added to the end of the _path_ within _bolt_."


more on 'take'

more on 'take'

--- src/babel/generate.cljc
+++ src/babel/generate.cljc
@@ -174,10 +174,11 @@
 (defn generate2
   "Return all expressions matching spec _spec_ given the model _model_."
   [spec model
-   & {:keys [max-total-depth truncate-children lexicon]
+   & {:keys [max-total-depth truncate-children lexicon take]
       :or {max-total-depth max-total-depth
            lexicon nil
-           truncate-children true}}]
+           truncate-children true
+           take false}}]
   (log/debug (str "generate2: spec: " spec))
   (let [depth 0
         spec (if (fail? (unify spec {:synsem {:subcat []}}))
@@ -187,7 +188,7 @@
      (flatten
       (mapfn #(do
                 (log/debug (str "top-level add-bolt-at: " ((:morph-ps model) %)))
-                (add-bolt-at % % [] % model depth max-depth truncate-children))
+                (add-bolt-at % % [] % model depth max-depth truncate-children take))
              (lightning-bolts model spec 0 max-total-depth)))))

 (defn generate-n


experiment with removing one lazy-sea

experiment with removing one lazy-sea

--- src/babel/generate.cljc
+++ src/babel/generate.cljc
@@ -23,7 +23,7 @@
 ;;(def ^:const shufflefn (fn [x] x))

 ;; nondeterministic generation
-(def ^:const shufflefn (fn [x] (and x (lazy-seq (shuffle x)))))
+(def ^:const shufflefn (fn [x] (shuffle x)))

 (def ^:const randomize-lexemes-before-phrases
 ;;  false)


possible performance improvement to (defn lightning-bolt)

--- src/babel/generate.cljc
+++ src/babel/generate.cljc
@@ -176,8 +176,8 @@
                                 (get-in % [:head :phrasal] true))
                             parents)))]
       (if (lexemes-before-phrases total-depth max-total-depth)
-        (concat lexical phrasal)
-        (concat phrasal lexical)))))
+        (lazy-cat lexical phrasal)
+        (lazy-cat phrasal lexical)))))

 (defn do-defaults [tree language-model]
   (log/trace (str "calling do-defaults on tree:" ((:morph language-model) tree)))


add comments in (map-function-on-map-vals) about handling typos involving non-uniformly-typed keys

--- src/babel/lexiconfn.clj
+++ src/babel/lexiconfn.clj
@@ -439,9 +439,18 @@
 (defn map-function-on-map-vals [m f]
   (if (not (map? m))
     (throw (Exception. "Expected map as first input to map-function-on-map-vals, but got an input of type: " (type m))))
+  ;; TODO: add check for uniformity of type of keys
+  ;; i.e. check that they are either all strings, or all keywords, or all integers, etc.
+  ;; this is to avoid the need to log/debug below.
   (into {}
         (for [[k v]
-              (sort m)]
+              ;; if you need to trace this, probably your input data
+              ;; is non-uniform: i.e. the map keys are not all one type
+              ;; (e.g. a mixture of strings and keywords rather than
+              ;;  purely one or the other)
+              ;; your keys or values
+              (do (log/debug (str "sorting array: " m))
+                  (sort m))]
           ;; for each <k,v> pair, return a <k,v'>, where v' = f(v).
           [k (f k v)])))


drop read-config from root inducers

drop read-config from root inducers

--- src/bract/core/main.clj
+++ src/bract/core/main.clj
@@ -21,7 +21,6 @@
   [core-inducer/set-verbosity        ; set default verbosity
    core-inducer/read-context         ; read context file if present
    core-inducer/set-verbosity        ; set user-preferred verbosity
-   core-inducer/read-config          ; read config file(s) if specified
    core-inducer/run-context-inducers ; run context inducers
    ])


Read job properties from official API /properties, instead from internal, undocumented one

--- src/buildviz/gosync.clj
+++ src/buildviz/gosync.clj
@@ -54,35 +54,48 @@
         response (client/get (absolute-url-for relative-url))]
     (j/parse-string (:body response) true)))

-
-;; /jobStatus.json
+(defn get-plain [relative-url-template & url-params]
+  (let [relative-url (apply format relative-url-template url-params)
+        response (client/get (absolute-url-for relative-url))]
+    (:body response)))
+
+;; /properties/%pipeline/%pipeline_run/%stage/%stage_run/%job

 (defn handle-missing-start-time-when-cancelled [build-start-time build-end-time]
   (if (nil? build-start-time)
     build-end-time
     build-start-time))

-(defn build-times [info start-time end-time]
+(defn build-times [start-time end-time]
   (if-not (nil? end-time)
-    (assoc info
-           :start (handle-missing-start-time-when-cancelled start-time end-time)
-           :end end-time)
-    info))
-
-(defn parse-build-info [json-response]
-  (let [build-info (:building_info (first json-response))
-        result (:result build-info)]
+    {:start (handle-missing-start-time-when-cancelled start-time end-time)
+     :end end-time}
+    {}))
+
+(defn- parse-datetime [property-map key]
+  (tc/to-long (tf/parse (get property-map key))))
+
+(defn parse-build-properties [properties]
+  (let [lines (string/split properties #"\n")
+        keys (string/split (first lines) #",")
+        values (string/split (second lines) #",")
+        property-map (zipmap keys values)
+        result (get property-map "cruise_job_result")]
     (when-not (= "Unknown" result)
-      (let [start-time (tc/to-long (tf/parse (:build_building_date build-info)))
-            end-time (tc/to-long (tf/parse (:build_completed_date build-info)))
+      (let [start-time (parse-datetime property-map "cruise_timestamp_04_building")
+            end-time (parse-datetime property-map "cruise_timestamp_06_completed")
             outcome (if (= "Passed" result) "pass" "fail")]
-        (-> {}
-            (build-times start-time end-time)
-            (assoc :outcome outcome))))))
-
-(defn build-for [{jobId :jobId}]
-  (let [build (get-json "/jobStatus.json?pipelineName=&stageName=&jobId=%s" jobId)]
-    (parse-build-info build)))
+        (assoc (build-times start-time end-time)
+               :outcome outcome)))))
+
+(defn build-for [{pipeline-name :pipelineName
+                  pipeline-run :pipelineRun
+                  stage-name :stageName
+                  stage-run :stageRun
+                  job-name :jobName}]
+  (let [build-properties (get-plain "/properties/%s/%s/%s/%s/%s"
+                                    pipeline-name pipeline-run stage-name stage-run job-name)]
+    (parse-build-properties build-properties)))

 (defn accumulate-build-times [builds]
   (let [start-times (map :start builds)


Get rid of the dynamic var *show-genre*

Get rid of the dynamic var *show-genre*

There are just too many problems with dynamic vars and lazy seqs.
Replace it with an opts parameter that is passed down the call chain.
This incidentally also simplifies the api of many functions, e.g. the
title to number mapping can also be passed via this opts map.

--- src/catalog/layout/fop.clj
+++ src/catalog/layout/fop.clj
@@ -16,8 +16,6 @@

 (def ^:private region-body-margin-top 15)

-(def ^:dynamic *show-genre* true)
-
 (defn- to-mm [n]
   (format "%smm" n))

@@ -52,15 +50,12 @@
     (str (string/join "." numbers) ". ")))

 (defn heading
-  ([level path]
-   (heading level path []))
-  ([level path path-to-numbers]
-   [:fo:block (style level
-                     {:id (hash path)})
-    (when-let [numbers (get path-to-numbers path)]
-      (section-numbers numbers))
-    (let [title (last path)]
-      (if (keyword? title) (layout/translations title) title))]))
+  [level path {:keys [path-to-numbers]}]
+  [:fo:block (style level {:id (hash path)})
+   (when-let [numbers (get path-to-numbers path)]
+     (section-numbers numbers))
+   (let [title (last path)]
+     (if (keyword? title) (layout/translations title) title))])

 (def ^:private running-header-class-name "running-header")

@@ -125,12 +120,12 @@
   (if (not-empty content)
     (apply #(external-link href %) content)
     (external-link href href)))
-(defmethod to-fop :h1 [{content :content} path path-to-numbers]
-  (heading :h1 (conj path (string/join content)) path-to-numbers))
-(defmethod to-fop :h2 [{content :content} path path-to-numbers]
-  (heading :h2 (conj path (string/join content)) path-to-numbers))
-(defmethod to-fop :h3 [{content :content} path path-to-numbers]
-  (heading :h3 (conj path (string/join content)) path-to-numbers))
+(defmethod to-fop :h1 [{content :content} path opts]
+  (heading :h1 (conj path (string/join content)) opts))
+(defmethod to-fop :h2 [{content :content} path opts]
+  (heading :h2 (conj path (string/join content)) opts))
+(defmethod to-fop :h3 [{content :content} path opts]
+  (heading :h3 (conj path (string/join content)) opts))
 (defmethod to-fop :ul [{content :content} _ _] [:fo:list-block content])
 (defmethod to-fop :li [{content :content} _ _] (bullet-list content))
 (defmethod to-fop :em [{content :content} _ _] (inline {:font-style "italic"} content))
@@ -141,17 +136,17 @@
 (defn- node? [node]
   (and (map? node) (or (set/subset? #{:tag :content} (set (keys node))) (= (:tag node) :br))))

-(defn- visitor [node path path-to-numbers]
+(defn- visitor [node path opts]
   (if (node? node)
-    (to-fop node path path-to-numbers)
+    (to-fop node path opts)
     node))

-(defn md-to-fop [markdown path path-to-numbers]
+(defn md-to-fop [markdown path opts]
   (->>
    markdown
    endophile/mp
    endophile/to-clj
-   (walk/postwalk #(visitor % path path-to-numbers))))
+   (walk/postwalk #(visitor % path opts))))

 (defn- md-extract-headings [markdown]
   (->>
@@ -162,37 +157,35 @@
    (map (comp string/join :content))))

 (defn- toc-entry
-  ([items path path-to-numbers depth]
-   (toc-entry items path path-to-numbers depth 1))
-  ([items path path-to-numbers depth current-depth]
-   [:fo:block {:text-align-last "justify" :role "TOCI"
-               :start-indent (str (- current-depth 1) "em")}
-    [:fo:basic-link {:internal-destination (hash path)}
-     (inline {:role "Reference"}
-             (when-let [numbers (get path-to-numbers path)] (section-numbers numbers))
-             (let [title (last path)]
-               (if (keyword? title) (layout/translations title) title)))
-     " " [:fo:leader {:leader-pattern "dots" :role "NonStruct"}] " "
-     [:fo:page-number-citation {:ref-id (hash path) :role "Reference"}]]
-    (cond
-      (and (map? items) (< current-depth depth))
-      (map #(toc-entry (get items %) (conj path %) path-to-numbers depth (inc current-depth))
-           (keys items))
-      ;; check for headings in markdown
-      (and (string? items)
-           ;; only show in the toc if there are multiple headings (I
-           ;; guess this is a weird way of saying we don't want any
-           ;; subheadings in the toc for :grossdruck)
-           (< 1 (count (md-extract-headings items))))
-      (map #(toc-entry % (conj path %) path-to-numbers depth (inc current-depth))
-           (md-extract-headings items)))]))
-
-(defn toc [items path depth path-to-numbers & {:keys [heading?]}]
+  [items path depth current-depth {:keys [path-to-numbers] :as opts}]
+  [:fo:block {:text-align-last "justify" :role "TOCI"
+              :start-indent (str (- current-depth 1) "em")}
+   [:fo:basic-link {:internal-destination (hash path)}
+    (inline {:role "Reference"}
+            (when-let [numbers (get path-to-numbers path)] (section-numbers numbers))
+            (let [title (last path)]
+              (if (keyword? title) (layout/translations title) title)))
+    " " [:fo:leader {:leader-pattern "dots" :role "NonStruct"}] " "
+    [:fo:page-number-citation {:ref-id (hash path) :role "Reference"}]]
+   (cond
+     (and (map? items) (< current-depth depth))
+     (map #(toc-entry (get items %) (conj path %) depth (inc current-depth) opts)
+          (keys items))
+     ;; check for headings in markdown
+     (and (string? items)
+          ;; only show in the toc if there are multiple headings (I
+          ;; guess this is a weird way of saying we don't want any
+          ;; subheadings in the toc for :grossdruck)
+          (< 1 (count (md-extract-headings items))))
+     (map #(toc-entry % (conj path %) depth (inc current-depth) opts)
+          (md-extract-headings items)))])
+
+(defn toc [items path depth {:keys [heading?] :as opts}]
   (when (map? items)
     [:fo:block {:line-height "150%"
                 :role "TOC"}
-     (when heading? (heading :h1 [:inhalt]))
-     (map #(toc-entry (get items %) (conj path %) path-to-numbers depth) (keys items))]))
+     (when heading? (heading :h1 [:inhalt] opts))
+     (map #(toc-entry (get items %) (conj path %) depth 1 opts) (keys items))]))

 (defn- narrators-sexp [narrators]
   (let [narrator (first narrators)]
@@ -235,14 +228,15 @@
     (block {:keep-with-previous "always"}
            (bold "Verkauf:") " " price ". " (layout/braille-signatures product-number))))

-(defmulti entry-sexp (fn [{fmt :format}] fmt))
+(defmulti entry-sexp (fn [{fmt :format} opts] fmt))

 (defmethod entry-sexp :hörbuch
   [{:keys [genre-text description duration narrators producer-brief
-           produced-commercially? library-signature product-number price] :as item}]
-  (list-item
-   (entry-heading-sexp item)
-   (when *show-genre*
+           produced-commercially? library-signature product-number price] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
+  (list-item
+   (entry-heading-sexp item)
+   (when show-genre?
      (block (wrap genre-text "Genre: ")))
    (block (wrap description))
    (block (wrap duration "" " Min., " false) (narrators-sexp narrators))
@@ -253,10 +247,11 @@

 (defmethod entry-sexp :braille
   [{:keys [genre-text description producer-brief rucksackbuch? rucksackbuch-number
-           library-signature product-number price] :as item}]
-  (list-item
-   (entry-heading-sexp item)
-   (when *show-genre*
+           library-signature product-number price] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
+  (list-item
+   (entry-heading-sexp item)
+   (when show-genre?
      (block (wrap genre-text "Genre: ")))
    (block (wrap description))
    (block (wrap producer-brief "" (if rucksackbuch?
@@ -266,10 +261,11 @@
    (verkauf product-number price)))

 (defmethod entry-sexp :grossdruck
-  [{:keys [genre-text description library-signature volumes product-number price] :as item}]
-  (list-item
-   (entry-heading-sexp item)
-   (when *show-genre*
+  [{:keys [genre-text description library-signature volumes product-number price] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
+  (list-item
+   (entry-heading-sexp item)
+   (when show-genre?
      (block (wrap genre-text "Genre: ")))
    (block (wrap description))
    (when library-signature
@@ -279,22 +275,24 @@
      (block {:keep-with-previous "always"} (bold "Verkauf:") " " price))))

 (defmethod entry-sexp :e-book
-  [{:keys [genre-text description library-signature] :as item}]
-  (list-item
-   (entry-heading-sexp item)
-   (when *show-genre*
+  [{:keys [genre-text description library-signature] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
+  (list-item
+   (entry-heading-sexp item)
+   (when show-genre?
      (block (wrap genre-text "Genre: ")))
    (block (wrap description))
    (ausleihe library-signature)))

 (defmethod entry-sexp :hörfilm
   [{:keys [personel-text movie_country genre-text
-           description producer library-signature] :as item}]
+           description producer library-signature] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
   (list-item
    (entry-heading-sexp item)
    (block (wrap personel-text))
    (block (wrap movie_country))
-   (when *show-genre*
+   (when show-genre?
      (block (wrap genre-text)))
    (block (wrap description))
    (block (wrap producer))
@@ -302,18 +300,19 @@

 (defmethod entry-sexp :ludo
   [{:keys [source-publisher genre-text description
-           game-description accompanying-material library-signature] :as item}]
+           game-description accompanying-material library-signature] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
   (list-item
    (entry-heading-sexp item)
    (block (wrap source-publisher))
-   (when *show-genre*
+   (when show-genre?
      (block (wrap genre-text)))
    (block (wrap description))
    (block (wrap game-description))
    (ausleihe library-signature)))

 (defmethod entry-sexp :musiknoten
-  [{:keys [description producer-brief library-signature product-number price] :as item}]
+  [{:keys [description producer-brief library-signature product-number price] :as item} opts]
   (list-item
    (entry-heading-sexp item)
    (block (wrap description))
@@ -322,61 +321,57 @@
    (verkauf product-number price)))

 (defmethod entry-sexp :taktilesbuch
-  [{:keys [genre-text description producer-brief library-signature product-number price] :as item}]
-  (list-item
-   (entry-heading-sexp item)
-   (when *show-genre*
+  [{:keys [genre-text description producer-brief library-signature product-number price] :as item}
+   {:keys [show-genre?] :or {show-genre? true}}]
+  (list-item
+   (entry-heading-sexp item)
+   (when show-genre?
      (block (wrap genre-text "Genre: ")))
    (block (wrap description))
    (block (wrap producer-brief))
    (ausleihe-multi library-signature)
    (verkauf product-number price)))

-(defn entries-sexp [items]
+(defn entries-sexp [items opts]
   [:fo:list-block
-   (map entry-sexp items)])
+   (map #(entry-sexp % opts) items)])

 (defn- level-to-h [level]
   (keyword (str "h" level)))

-(defn subgenre-sexp [items fmt genre subgenre level path-to-numbers]
-  [(heading (level-to-h level) [fmt genre subgenre] path-to-numbers)
+(defn subgenre-sexp [items fmt genre subgenre level opts]
+  [(heading (level-to-h level) [fmt genre subgenre] opts)
    (when-not (#{:kinder-und-jugendbücher} genre)
      (set-marker (layout/translations subgenre)))
-   (entries-sexp items)])
-
-(defn subgenres-sexp [items fmt genre level path-to-numbers]
-    (mapcat #(subgenre-sexp (get items %) fmt genre % level path-to-numbers) (keys items)))
+   (entries-sexp items opts)])
+
+(defn subgenres-sexp [items fmt genre level opts]
+  (mapcat #(subgenre-sexp (get items %) fmt genre % level opts) (keys items)))

 (defn genre-sexp
-  ([items fmt genre level]
-   (genre-sexp items fmt genre level nil))
-  ([items fmt genre level path-to-numbers]
-   [(heading (level-to-h level) [fmt genre] path-to-numbers)
-    (set-marker (layout/translations genre))
-    (cond
-      ;; special case where the editorial or the recommendations are passed in the tree
-      (#{:editorial :recommendations :recommendation} genre) (md-to-fop items
-                                                                        [fmt genre] path-to-numbers)
-      ;; special case when printing the whole catalog of tactile books
-      (#{:taktilesbuch} fmt) (entries-sexp items)
-      (#{:kinder-und-jugendbücher} genre) (subgenres-sexp items fmt genre (inc level) path-to-numbers)
-      (#{:hörbuch} fmt) (subgenres-sexp items fmt genre (inc level) path-to-numbers)
-      :else (entries-sexp items))]))
+  [items fmt genre level opts]
+  [(heading (level-to-h level) [fmt genre] opts)
+   (set-marker (layout/translations genre))
+   (cond
+     ;; special case where the editorial or the recommendations are passed in the tree
+     (#{:editorial :recommendations :recommendation} genre) (md-to-fop items [fmt genre] opts)
+     ;; special case when printing the whole catalog of tactile books
+     (#{:taktilesbuch} fmt) (entries-sexp items opts)
+     (#{:kinder-und-jugendbücher} genre) (subgenres-sexp items fmt genre (inc level) opts)
+     (#{:hörbuch} fmt) (subgenres-sexp items fmt genre (inc level) opts)
+     :else (entries-sexp items opts))])

 (defn format-sexp
-  ([items fmt level]
-   (format-sexp items fmt level nil true))
-  ([items fmt level path-to-numbers with-toc?]
-   [(heading (level-to-h level) [fmt] path-to-numbers)
-    (when with-toc?
-      (toc items [fmt] 2 nil))
-    (set-marker (layout/translations fmt))
-    (case fmt
-      ;; handle the special case where the editorial or the recommendations are passed in the tree
-      (:editorial :recommendations :recommendation) (md-to-fop items [fmt] path-to-numbers)
-      (:hörfilm :ludo) (entries-sexp items)
-      (mapcat #(genre-sexp (get items %) fmt % (inc level) path-to-numbers) (keys items)))]))
+  [items fmt level {:keys [with-toc?] :or {with-toc? true} :as opts}]
+  [(heading (level-to-h level) [fmt] opts)
+   (when with-toc?
+     (toc items [fmt] 2 {}))
+   (set-marker (layout/translations fmt))
+   (case fmt
+     ;; handle the special case where the editorial or the recommendations are passed in the tree
+     (:editorial :recommendations :recommendation) (md-to-fop items [fmt] opts)
+     (:hörfilm :ludo) (entries-sexp items opts)
+     (mapcat #(genre-sexp (get items %) fmt % (inc level) opts) (keys items)))])

 (defn- page-number []
   [:fo:inline
@@ -513,9 +508,9 @@
                          (assoc :editorial editorial
                                 :recommendation recommendations))]
         [:fo:flow {:flow-name "xsl-region-body"}
-         (toc subitems [fmt] 2 nil :heading? true)
+         (toc subitems [fmt] 2 {:heading? true})
          (realize-lazy-seqs
-          (mapcat #(genre-sexp (get subitems %) fmt % 1) (keys subitems)))])]]))
+          (mapcat #(genre-sexp (get subitems %) fmt % 1 {}) (keys subitems)))])]]))

 (defmethod document-sexp :hörbuch
   [items fmt editorial recommendations {:keys [description date]}]
@@ -543,9 +538,9 @@
        ;; Cover page
        [:fo:block (style :h1) (format "Neu als Hörbuch Nr. %s" date)]
        (block {:break-before "odd-page"}) ;; toc should start on recto
-       (toc subitems [] 3 path-to-numbers :heading? true)
+       (toc subitems [] 3 {:path-to-numbers path-to-numbers :heading? true})
        (block {:break-before "odd-page"}) ;; the very first format should start on recto
-       (mapcat #(format-sexp (get subitems %) % 1 path-to-numbers false) (keys subitems))])]])
+       (mapcat #(format-sexp (get subitems %) % 1 {:path-to-numbers path-to-numbers :with-toc? false}) (keys subitems))])]])

 (defn- logo []
   [:fo:block {:space-before "100mm" :text-align "right"}
@@ -600,11 +595,9 @@
                     "Filme mit Audiodeskription"]
                    date)
        (block {:break-before "odd-page"}) ;; toc should start on recto
-       (toc subitems [fmt] 1 nil :heading? true)
+       (toc subitems [fmt] 1 {:heading? true})
        (block {:break-before "odd-page"}) ;; the very first format should start on recto
-       (binding [*show-genre* false]
-         (realize-lazy-seqs
-          (mapcat #(genre-sexp (get subitems %) fmt % 1) (keys subitems))))])]])
+       (mapcat #(genre-sexp (get subitems %) fmt % 1 {:show-genre? false}) (keys subitems))])]])

 (defmethod document-sexp :ludo
   [items fmt _ _ {:keys [description date]
@@ -626,11 +619,9 @@
        (cover-page ["Spiele in der SBS"]
                    date)
        (block {:break-before "odd-page"}) ;; toc should start on recto
-       (toc subitems [fmt] 1 nil :heading? true)
+       (toc subitems [fmt] 1 {:heading? true})
        (block {:break-before "odd-page"}) ;; the very first format should start on recto
-       (binding [*show-genre* false]
-         (realize-lazy-seqs
-          (mapcat #(genre-sexp (get subitems %) fmt % 1) (keys subitems))))])]])
+       (mapcat #(genre-sexp (get subitems %) fmt % 1 {:show-genre? false}) (keys subitems))])]])

 (defmethod document-sexp :taktilesbuch
   [items fmt _ _ {:keys [description date]
@@ -652,9 +643,9 @@
        (cover-page ["Taktile Kinderbücher in der SBS"]
                    date)
        (block {:break-before "odd-page"}) ;; toc should start on recto
-       (toc subitems [fmt] 1 nil :heading? true)
+       (toc subitems [fmt] 1 {:heading? true})
        (block {:break-before "odd-page"}) ;; the very first format should start on recto
-       (mapcat #(genre-sexp (get subitems %) fmt % 1) (keys subitems))])]])
+       (mapcat #(genre-sexp (get subitems %) fmt % 1 {}) (keys subitems))])]])

 (defmethod document-sexp :all-formats
   [items _ _ _ {:keys [description date]}]
@@ -671,9 +662,9 @@
     (header :verso)

     [:fo:flow {:flow-name "xsl-region-body"}
-     (toc items [] 1 nil :heading? true)
+     (toc items [] 1 {:heading? true})
      (block {:break-before "odd-page"}) ;; the very first format should start on recto
-     (mapcat #(format-sexp (get items %) % 1) (keys items))]]])
+     (mapcat #(format-sexp (get items %) % 1 {}) (keys items))]]])

 (defn document [items fmt editorial recommendations & args]
   (-> items


I love reduce, but it's not appropriate here.

--- src/leiningen/jar.clj
+++ src/leiningen/jar.clj
@@ -104,7 +104,7 @@
   (or (.isDirectory file)
       (re-find #"^\.?#" (.getName file))
       (re-find #"~$" (.getName file))
-      (reduce #(or %1 (re-find %2 relative-path)) false patterns)))
+      (some #(re-find % relative-path) patterns)))

 (defmulti copy-to-jar (fn [project jar-os spec] (:type spec)))


Add support for sentiment analysis from cmd line.

--- src/lexemic/core.cljs
+++ src/lexemic/core.cljs
@@ -1,5 +1,22 @@
-(ns lexemic.core)
+(ns lexemic.core
+  (:require [lexemic.sentiment.simple :as sentiment]))

-(defn -main [& command])
+(def ^:private usage-banner "Usage: lexemic [command] [target]")
+(def ^:private supported-commands #{"help" "sentiment"})
+
+(defn- show-help []
+  (do
+    (println usage-banner)))
+
+(defn- run [cmd text]
+  (condp = cmd
+    "sentiment" (println (sentiment/analyse text))))
+
+(defn -main [& args]
+  (let [command (first args)
+        input (second args)]
+    (if-let [cmd (supported-commands command)]
+      (run cmd input)
+      (show-help))))

 (set! *main-cli-fn* -main)


CLJS-1203: official way to supply multiple files/directories to cljs.closure/build and cljs.closure/watch

Add cljs.build.api/inputs which returns cljs.closure/Compilable instance

Add cljs.build.api/build, will eventually become the only public entry point for building

--- src/clj/cljs/build/api.clj
+++ src/clj/cljs/build/api.clj
@@ -20,6 +20,9 @@
             [cljs.js-deps :as js-deps]
             [clojure.java.io :as io])
   (:import java.io.File))
+
+;; =============================================================================
+;; Useful Utilities

 (defn ^File target-file-for-cljs-ns
   "Given an output directory and a clojurescript namespace return the
@@ -90,6 +93,30 @@
   ([src options]
     (closure/src-file->goog-require src options)))

+;; =============================================================================
+;; Main API
+
+(defn inputs
+  "Given a list of directories and files, return a compilable object that may
+  be passed to build or watch."
+  [& xs]
+  (reify
+    closure/Compilable
+    (-compile [_ opts]
+      (letfn [(compile-input [x]
+                (let [compiled (closure/-compile x opts)]
+                  (if (sequential? compiled)
+                    compiled
+                    [compiled])))]
+        (mapcat compile-input xs)))))
+
+(defn build
+  "Given a source which can be compiled, produce runnable JavaScript."
+  ([source opts]
+   (closure/build source opts))
+  ([source opts compiler-env]
+   (closure/build source opts compiler-env)))
+
 (comment

   (def test-cenv (atom {}))


Sketch server update.

Sketch server update.

--- src/clj/fleetdb/server.clj
+++ src/clj/fleetdb/server.clj
@@ -1,128 +1,54 @@
 (ns fleetdb.server
   (:use     (fleetdb util))
-  (:require (fleetdb [embedded :as embedded] [io :as io] [file :as file]
-                     [thread-pool :as thread-pool])
+  (:require (fleetdb [embedded :as embedded] [io :as io]
+                     [file :as file] [thread-pool :as thread-pool])
             (clj-stacktrace [repl :as stacktrace])
             (clojure.contrib [str-utils :as str-utils]))
   (:import  (java.net ServerSocket Socket InetAddress)
-            (java.io PushbackReader BufferedReader InputStreamReader
-                     PrintWriter    BufferedWriter OutputStreamWriter
-                     DataInputStream  BufferedInputStream  InputStream
-                     DataOutputStream BufferedOutputStream OutputStream)
             (joptsimple OptionParser OptionSet OptionException))
   (:gen-class))

 (defn- server-query [dba q]
   (let [[q-type q-opt] q]
     (condp = q-type
-      :ping     "pong"
-      :compact  (embedded/compact dba)
-      :snapshot (embedded/snapshot dba q-opt)
+      "ping"     "pong"
+      "compact"  (embedded/compact dba)
+      "snapshot" (embedded/snapshot dba q-opt)
       nil)))

 (defn- process-query [dba q]
   (or (server-query dba q)
       (embedded/query dba q)))

-(defn generic-handler [init-out init-in read-query write-response write-error]
-  (fn [dba #^Socket socket]
-    (try
-      (with-open [socket socket
-                  out    (init-out (.getOutputStream socket))
-                  in     (init-in  (.getInputStream socket))]
-        (.setKeepAlive socket true)
-        (loop []
-          (if (try
-                (let [query (read-query in io/eof)]
-                  (if (= query io/eof)
-                    false
-                    (let [result (process-query dba query)]
-                      (write-response out result)
-                      true)))
-                (catch Exception e
-                  (write-error out e)
-                  true))
-              (recur))))
-      (catch Exception e
-        (stacktrace/pst-on System/err false e)
-        (.println System/err)))))
+(defn handler [dba #^Socket socket]
+  (try
+    (with-open [socket    socket
+                generator (io/os->generator (.getOutputStream socket))
+                parser    (io/in->parser    (.getInputStream socket))]
+      (.setKeepAlive socket true)
+      (loop []
+        (if (try
+              (let [query (io/parse parser io/eof)]
+                (if (= query io/eof)
+                  false
+                  (let [result (process-query dba query)]
+                    (io/generate generator [0 result])
+                    true)))
+              (catch Exception e
+                (io/generate out
+                  (if (raised? e)
+                    [1 (str e)]
+                    [2 (pst-str e)]))
+                true))
+            (recur))))
+    (catch Exception e
+      (stacktrace/pst-on System/err false e)
+      (.println System/err))))

-(def- text-handler
-  (generic-handler
-    (fn [#^OutputStream os]
-      (PrintWriter. (BufferedWriter. (OutputStreamWriter. os))))
-    (fn [#^InputStream is]
-      (PushbackReader. (BufferedReader. (InputStreamReader. is))))
-    (fn [#^PushbackReader in eof-val]
-      (read in false eof-val))
-    (fn [#^PrintWriter out val]
-      (.println out (pr-str val))
-      (.println out)
-      (.flush out))
-    (fn [#^PrintWriter out e]
-      (let [msg (if (raised? e) (str e) (stacktrace/pst-str e))]
-        (.println out msg)
-        (.println out)
-        (.flush out)))))
-
-(def- binary-handler
-  (generic-handler
-    (fn [#^OutputStream os]
-      (DataOutputStream. (BufferedOutputStream. os)))
-    (fn [#^InputStream is]
-      (DataInputStream.  (BufferedInputStream. is)))
-    (fn [#^DataInputStream in eof-val]
-      (io/dis-deserialize in io/eof))
-    (fn [#^DataOutputStream out val]
-      (io/dos-serialize out [0 val]))
-    (fn [#^DataOutputStream out e]
-      (let [msg (if (raised? e) (str e) (stacktrace/pst-str e))]
-        (io/dos-serialize out [1 msg])))))
-
-(def- bert-handler
-  (generic-handler
-    (fn [#^OutputStream os]
-      (DataOutputStream. (BufferedOutputStream. os)))
-    (fn [#^InputStream is]
-      (DataInputStream.  (BufferedInputStream.  is)))
-    (fn [#^DataInputStream in eof-val]
-      (io/dis-berp-decode in io/eof))
-    (fn [#^DataOutputStream out val]
-      (io/dos-berp-encode out [0 val]))
-    (fn [#^DataOutputStream out e]
-      (let [msg (if (raised? e) (str e) (stacktrace/pst-str e))]
-        (io/dos-berp-encode out [1 msg])))))
-
-(def- bert-rpc-handler
-  (generic-handler
-    (fn [os]
-      (DataOutputStream. (BufferedOutputStream. os)))
-    (fn [is]
-      (DataInputStream. (BufferedInputStream. is)))
-    (fn [in eof-val]
-      (let [d (io/dis-berp-decode in io/eof)]
-        (if (= d io/eof)
-          d
-          (let [[call server query [q]] d]
-            q))))
-    (fn [out val]
-      (io/dos-berp-encode out [:reply val]))
-    (fn [out e]
-      (let [bert (if (raised? e)
-                   [:error [:user   0 "Exception"          (str e) (list)]]
-                   [:error [:server 0 (.getName (class e)) (str e)
-                     (next (str-utils/re-split #"\n" (stacktrace/pst-str e)))]])]
-        (io/dos-berp-encode out bert)))))
-
-(def- protocol-handlers
-  {:text text-handler :binary binary-handler
-   :bert bert-handler :bert-rpc bert-rpc-handler})
-
-(defn run [db-path ephemeral port addr threads protocol]
+(defn run [db-path ephemeral port addr threads]
   (let [inet          (InetAddress/getByName addr)
         server-socket (ServerSocket. port 10000 inet)
         pool          (thread-pool/init threads)
-        handler       (protocol-handlers protocol)
         loading       (and db-path (file/exist? db-path))
         dba           (if ephemeral
                         (if loading
@@ -131,7 +57,7 @@
                         (if loading
                           (embedded/load-persistent db-path)
                           (embedded/init-persistent db-path)))]
-    (printf "FleetDB serving '%s' protocol on port %d\n" (name protocol) port)
+    (printf "FleetDB is ready on port %d\n" port)
     (flush)
     (loop []
       (let [socket (doto (.accept server-socket))]
@@ -139,24 +65,23 @@
       (recur))))

 (defn- print-help []
-  (println "FleetDB Server                                                               ")
-  (println "-f <path>   Path to database log file                                        ")
-  (println "-e          Ephemeral: do not log changes to disk                            ")
-  (println "-p <port>   TCP port to listen on (default: 3400)                            ")
-  (println "-a <addr>   Local address to listen on (default: 127.0.0.1)                  ")
-  (println "-t <num>    Maximum number of worker threads (default: 100)                  ")
-  (println "-i <name>   Client/server protocol: one of {text,binary,bert,bert-rpc} (default: bert)")
-  (println "-h          Print this help and exit.                                        "))
+  (println "FleetDB Server                                             ")
+  (println "-f <path>   Path to database log file                      ")
+  (println "-e          Ephemeral: do not log changes to disk          ")
+  (println "-p <port>   TCP port to listen on (default: 3400)          ")
+  (println "-a <addr>   Local address to listen on (default: localhost)")
+  (println "-t <num>    Maximum number of worker threads (default: 100)")
+  (println "-h          Print this help and exit.                      "))

 (defn- parse-int [s]
   (and s (Integer/decode s)))

 (defn -main [& args]
-  (let [args-array  (into-array String args)
-        opt-parser (OptionParser. "f:ep:a:t:i:h")
+  (let [args-array (into-array String args)
+        opt-parser (OptionParser. "f:ep:a:t:h")
         opt-set    (.parse opt-parser args-array)]
     (cond
-      (not-any? #(.has opt-set #^String %) ["f" "e" "p" "a" "t" "i" "h"])
+      (not-any? #(.has opt-set #^String %) ["f" "e" "p" "a" "t" "h"])
         (print-help)
       (.has opt-set "h")
         (print-help)
@@ -171,7 +96,6 @@
         (let [db-path   (.valueOf opt-set "f")
               ephemeral (.has opt-set "e")
               port      (or (parse-int (.valueOf opt-set "p")) 3400)
-              addr      (or (.valueOf opt-set "a") "127.0.0.1")
-              threads   (or (parse-int (.valueOf opt-set "t")) 100)
-              protocol  (or (keyword (or (.valueOf opt-set "i") "bert")))]
-          (run db-path ephemeral port addr threads protocol)))))
+              addr      (or (.valueOf opt-set "a") "localhost")
+              threads   (or (parse-int (.valueOf opt-set "t")) 100)]
+          (run db-path ephemeral port addr threads)))))


Performance: converting markdown to html on retrieval

It seems like md->html was a bit expensive when running it on a few
hundred items. It wasn't a dealbreaker, but it bugged me enough to
profile and fix it.

This wasn't an issue before endless scrolling since we always rendered
a limited set of items the moment we queried them.

--- src/cljs/memento/core.cljs
+++ src/cljs/memento/core.cljs
@@ -237,10 +237,12 @@
 (register-handler
   :memories-load-success
   (fn [app-state [_ memories]]
-    (-> app-state
-        (assoc-in [:search-state :list] (concat (get-in app-state [:search-state :list]) (:results memories)))
-        (assoc-in [:search-state :last-result] memories)
-        (assoc-in [:ui-state :is-searching?] false))
+    (let [transformed (map #(assoc % :html (md->html (:thought %) :replacement-transformers md-transformers))
+                           (:results memories))]
+      (-> app-state
+          (assoc-in [:search-state :list] (concat (get-in app-state [:search-state :list]) transformed))
+          (assoc-in [:search-state :last-result] memories)
+          (assoc-in [:ui-state :is-searching?] false)))
     ))

 (register-handler
@@ -289,7 +291,7 @@
           (assoc-in [:note :edit-note] "")
           (assoc-in [:note :focus] nil)
           (assoc :search-state nil)
-          #_ (assoc-in [:search-state :force?] true)
+          #_(assoc-in [:search-state :force?] true)
           ))))

 (register-handler
@@ -321,7 +323,7 @@
         (assoc-in [:note :thread] nil)
         (assoc-in [:ui-state :show-thread?] false)
         (assoc-in [:note :focus] nil)
-        #_ (assoc-in [:search-state :force?] true)
+        #_(assoc-in [:search-state :force?] true)
         (assoc :search-state nil)
         )))

@@ -491,7 +493,7 @@
         [:div {:class "panel-heading"} "Refining... " [:i [:small "(from " (:created @focus) ")"]]
          [:button {:type "button" :class "close" :aria-hidden "true" :on-click #(dispatch [:refine nil])} "×"]]
         [:div {:class "panel-body"}
-         [:p {:dangerouslySetInnerHTML {:__html (md->html (:thought @focus) :replacement-transformers md-transformers)}}]
+         [:p {:dangerouslySetInnerHTML {:__html (:html @focus)}}]
          ]]])
     ))

@@ -582,7 +584,7 @@
     ^{:key (:id memory)}
     [:div {:class "col-sm-12 thought"}
      [:div {:class "memory col-sm-12"}
-      [:span {:dangerouslySetInnerHTML {:__html (md->html (:thought memory) :replacement-transformers md-transformers)}}]
+      [:span {:dangerouslySetInnerHTML {:__html (:html memory)}}]
       ]
      [:div
       [:div {:class "col-sm-6"}


Use vectors for x y coords

Use vectors for x y coords

Who needs a map?

--- src/cljs/pizarra/core.cljs
+++ src/cljs/pizarra/core.cljs
@@ -26,10 +26,10 @@
     (doseq [[k val] props]
       (aset context (name k) val))
     (.beginPath context)
-    (let [point (first points)]
-      (.moveTo context (:x point) (:y point)))
-    (doseq [point points]
-      (.lineTo context (:x point) (:y point)))
+    (let [[x y] (first points)]
+      (.moveTo context x y))
+    (doseq [[x y] points]
+      (.lineTo context x y))
     (.stroke context)
     (.restore context)))

@@ -44,7 +44,7 @@
     (-start [_ actions]
       (conj actions (new-line-action)))
     (-move [_ action x y]
-      (update-in action [:points] conj {:x x :y y}))
+      (update-in action [:points] conj [x y]))
     (-end [_ action]
       action)))


Added some utility functions for layouts

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

--- src/conexp/layout/util.clj
+++ src/conexp/layout/util.clj
@@ -1,3 +1,24 @@
 (ns conexp.layout.util
-  (:use conexp.graphics.base))
+  (:use conexp.graphics.base
+	conexp.fca.lattices
+	clojure.contrib.graph))

+(defn lattice->graph [lattice]
+  (remove-loops
+   (struct-map directed-graph
+     :nodes (base-set lattice)
+     :neighbors (memoize
+		 (fn [x]
+		   (let [order (order lattice)]
+		     (filter #(order [x %]) (base-set lattice))))))))
+
+(defn layers [lattice]
+  (dependency-list (lattice->graph lattice)))
+
+(defn scale-points-to-rectangle
+  "Scales the collection of points such that they fit int the
+  rectangle given by [x1 y1] and [x2 y2]."
+  [[x1 y1] [x2 y2] points]
+  'to-be-done)
+
+nil


another tseitin performance enhancement

another tseitin performance enhancement

--- src/logic/tseitin.clj
+++ src/logic/tseitin.clj
@@ -76,21 +76,19 @@
 (defn- gen-tseit-rec
   "Recursive helper function for generate-tseitin-symbols."
   [f z t]
-  (if (literal? f)
-    (swap! t #(conj %
-                {(symbol (str tseitin-prefix (swap! z inc)))
-                 f}))
-    (let [rec-syms (doall (for [f' (rest f)]
-                            (gen-tseit-rec f' z t)))]
-      (swap! t #(conj %
-                  {(symbol (str tseitin-prefix (swap! z inc)))
-                   f})))))
+  (do
+    (when (not (literal? f))
+      (doall (for [f' (rest f)]
+               (gen-tseit-rec f' z t))))
+    (swap! t #(assoc
+                %
+                (symbol (str tseitin-prefix (swap! z inc)))
+                f))))

 (defn- generate-tseitin-symbols
   "Generate tseitin symbols for all subformulas and literals."
   [formula z]
-  (let [lits (find-variables formula)
-        tmap (atom (hash-map))
+  (let [tmap (atom (hash-map))
         _ (gen-tseit-rec formula z tmap)
         rev-tmap (zipmap (vals @tmap) (keys @tmap))
         ]


critter bearing

critter bearing

--- src/critter_cljs/core.cljs
+++ src/critter_cljs/core.cljs
@@ -228,23 +228,23 @@
                                 :transform (translate x y)}}
       [:g.critter-inner {:style {:transition "transform 100ms"
                                  :transform (str "rotate(" b "rad)")}}
-        [:circle {:r 5 :cx 5  :style {:fill butt}}]
-        [:circle {:r 5 :cx -5 :style {:fill head}}]
+        [:circle {:r 5 :cy 5  :style {:fill butt}}]
+        [:circle {:r 5 :cy -5 :style {:fill head}}]
         [:rect {:x -5 :y -5 :width 10 :height 10 :style {:fill torso}}]]]))

-(defn module-critter-pen []
-    (let [{:keys [width height critters]} @app-state]
-        [:svg.module-critter-pen
-            {:width width
-             :height height
-             :on-mouse-move on-mouse-move}
-            [:rect {:width width :height height
-                :style {:fill "gray"}}]
-            [:g.critters (wrap-map module-critter critters)]]))
+(defn module-critter-pen [env]
+  (let [{:keys [width height critters]} env]
+    [:svg.module-critter-pen {:width width
+                              :height height
+                              :on-mouse-move on-mouse-move}
+      [:rect {:width width
+              :height height
+              :style {:fill "gray"}}]
+      [:g.critters (wrap-map module-critter critters)]]))

 (defn module-app-root []
-    [:section.module-app-root
-        [module-critter-pen]])
+  [:section.module-app-root
+    [module-critter-pen @app-state]])

 (reagent/render-component [module-app-root]
                           (. js/document (getElementById "app")))


update cli language and formatting

update cli language and formatting

--- src/mirthsync/cli.clj
+++ src/mirthsync/cli.clj
@@ -41,20 +41,21 @@
    ["-i" "--ignore-cert-warnings" "Ignore certificate warnings"
     :default false]

-   ["-f" "--force" (str "Overwrite existing local files during pull "
-                        "and always overwrite remote items without "
-                        "regard for revisions during push")]
+   ["-f" "--force" "
+        Overwrite existing local files during a pull and overwrite remote items
+        without regard for revisions during a push."]

    ["-t" "--target TARGET_DIR" "Base directory used for pushing or pulling files"
     :missing "--target is required"
     :parse-fn strip-trailing-slashes]

-   ["-r" "--resource-path TARGET_RESOURCE_PATH" "A path within the target
-   directory to limit the scope of the push/pull. This path may refer to a
-   filename specifically or a directory. In the case of a pull - only resources
-   that would end up within that path are saved to the filesystem. In the case
-   of a push - only resources within that path are pushed to the specified
-   server. *This path needs to be relative to the target directory.*"
+   ["-r" "--resource-path TARGET_RESOURCE_PATH" "
+        A path within the target directory to limit the scope of the push/pull.
+        This path may refer to a filename specifically or a directory. In the
+        case of a pull - only resources that would end up within that path are
+        saved to the filesystem. In the case of a push - only resources within
+        that path are pushed to the specified server. The TARGET_RESOURCE_PATH
+        must be specified relative to the target directory."
     :default ""
     :parse-fn strip-trailing-slashes]


Bring back long notes

Bring back long notes

--- src/musicbox/one.cljs
+++ src/musicbox/one.cljs
@@ -42,7 +42,7 @@
 (defn create-note-synth
   [freq]
   (timbre "adsr"
-          (js-obj "a" 5 "d" 100 "s" 0 "r" 5)
+          (js-obj "a" 5 "d" 10000 "s" 0 "r" 500)
           (timbre "fami" (js-obj "freq" freq "mul" 0.1))))

 (defn create-instrument


don't handle team transactions, we don't send any and it could cause a security bug

--- src/pc/http/sente.clj
+++ src/pc/http/sente.clj
@@ -415,26 +415,6 @@
                          :client-id client-id
                          :cust-uuid cust-uuid
                          :frontend-id-seed (get-in @document-subs [document-id client-id :frontend-id-seed])
-                         :session-uuid (UUID/fromString (get-in req [:ring-req :session :sente-id]))
-                         :timestamp (:receive-instant req)})))
-
-(defmethod ws-handler :team/transaction [{:keys [client-id ?data] :as req}]
-  (check-team-access (-> ?data :team/uuid) req :admin)
-  (let [team (team-model/find-by-uuid (:db req) (:team/uuid ?data))
-        datoms (->> ?data
-                 :datoms
-                 (remove (comp nil? :v))
-                 ;; Don't let people sneak into other teams
-                 (map (fn [d]
-                        (if (= "team" (name (:a d)))
-                          (assoc d :v (:db/id team))
-                          d))))
-        cust-uuid (-> req :ring-req :auth :cust :cust/uuid)]
-    (log/infof "transacting %s datoms on %s for %s" (count datoms) (:team/uuid team) client-id)
-    (datomic2/transact! datoms
-                        {:team-id (:db/id team)
-                         :client-id client-id
-                         :cust-uuid cust-uuid
                          :session-uuid (UUID/fromString (get-in req [:ring-req :session :sente-id]))
                          :timestamp (:receive-instant req)})))


turn off blog post for a minute

turn off blog post for a minute

--- src/pc/views/blog.clj
+++ src/pc/views/blog.clj
@@ -43,7 +43,7 @@
   [
    {:slug "we-made-precursor-for-teams"
     :unique-id "we-made-precursor-for-teams"
-    :display-in-overview true}
+    :display-in-overview false}
    {:slug "id-wear-that"
     :unique-id "id-wear-that"
     :display-in-overview false}


fix publish date and display for clips post

--- src/pc/views/blog.clj
+++ src/pc/views/blog.clj
@@ -43,8 +43,8 @@
   [
    {:slug "dont-let-your-tools-distract-you"
     :unique-id "dont-let-your-tools-distract-you"
-    :pub-date (clj-time.format/parse "Tue, 23 June 2015 06:00:00 -0800")
-    :display-in-overview false}
+    :pub-date (clj-time.format/parse "Fri, 26 June 2015 06:00:00 -0700")
+    :display-in-overview true}
    {:slug "slack-integration"
     :unique-id "slack-integration"
     :pub-date (clj-time.format/parse "Thurs, 18 June 2015 10:59:00 -0800")


Way more succinct touch triage code

Way more succinct touch triage code

--- src/playmary/one.cljs
+++ src/playmary/one.cljs
@@ -147,6 +147,7 @@
         touches (js->clj (.-changedTouches event) :keywordize-keys true)]
     (map (fn [x] {:type (.-type event)
                   :touch-id (:identifier x)
+                  :age 0 ;; ticks
                   :position {:x (:clientX x) :y (:clientY x)}
                   :time (.-timeStamp event)})
          (for [x (range (:length touches))] ((keyword (str x)) touches)))))
@@ -227,67 +228,47 @@
   (mapcat< touch-data->touches (util/listen (dom/getElement canvas-id) type)))

 (defn scroll?
-  [scroll-state cur-t]
-  (let [prev-t (get scroll-state (cur-t :touch-id))]
+  [scroll-states cur-t]
+  (let [prev-t (get scroll-states (cur-t :touch-id))]
     (and prev-t
          (= (cur-t :type) "touchmove")
          (or (= (prev-t :type) "touchmove")
              (and (= (prev-t :type) "touchstart")
-                  (> (distance (cur-t :position) (prev-t :position)) 3))))))
-
-(defn emit-hold?
-  [t]
-  (> (t :age) 0))
-
-(def emit-scroll? (constantly true))
-
-(def emit-end? emit-hold?)
-
-(defmulti handle-touch (fn [t touch-state] (:type t)))
+                  (= (prev-t :age) 0)
+                  (> (distance (cur-t :position) (prev-t :position)) 5))))))
+
+(defmulti handle-touch (fn [t touch-state out-c] (:type t)))

 (defmethod handle-touch "touchstart"
-  [{touch-id :touch-id :as t} {holds :holds scroll-states :scroll-states :as touch-state}]
-  (-> touch-state
-      (assoc :holds (assoc holds touch-id (assoc t :age 0)))
-      (assoc :scroll-states (assoc scroll-states touch-id t))))
+  [{touch-id :touch-id :as t} state out-c]
+  (assoc state touch-id t))

 (defmethod handle-touch "touchmove"
-  [{touch-id :touch-id :as t}
-   {holds :holds scrolls :scrolls ends :ends scroll-states :scroll-states :as touch-state}]
-  (-> touch-state
-      (assoc :holds (if (scroll? scroll-states t) (dissoc holds touch-id) holds))
-      (assoc :scrolls (if (scroll? scroll-states t)
-                        (let [{{x1 :x y1 :y} :position} (get scroll-states touch-id)
-                              {{x2 :x y2 :y} :position} t]
-                          (assoc scrolls touch-id (-> t (assoc :x-distance (- x1 x2))
-                                                        (assoc :y-distance (- y1 y2)))))
-                        scrolls))
-      (assoc :scroll-states (if (scroll? scroll-states t)
-                              (assoc scroll-states touch-id t)
-                              (dissoc scroll-states touch-id)))))
+  [{touch-id :touch-id :as t} state out-c]
+  (if (scroll? state t)
+    (let [{{x1 :x y1 :y} :position} (get state touch-id)
+          {{x2 :x y2 :y} :position} t]
+      (assoc state touch-id
+             (-> t (assoc :x-distance (- x1 x2)) (assoc :y-distance (- y1 y2)))))
+    (dissoc state touch-id)))

 (defmethod handle-touch "touchend"
-  [{touch-id :touch-id :as t} {ends :ends scroll-states :scroll-states :as touch-state}]
-  (-> touch-state
-      (assoc :ends (assoc ends touch-id (assoc t :age 0)))
-      (assoc :scroll-states (dissoc scroll-states touch-id))))
-
-(defn emit-or-return
-  [hash-map emit? c]
-  (let [{emit true keep false} (group-by emit? (vals hash-map))]
-    (onto-chan c (or (vals (select-keys hash-map (map :touch-id emit))) '()) false)
-    (select-keys hash-map (map :touch-id keep))))
-
-(defn age
-  [touch-map]
-  (reduce (fn [m k] (update-in m [k :age] inc)) touch-map (keys touch-map)))
-
-(defn emit-events
-  [out-c {holds :holds scrolls :scrolls ends :ends :as touch-state}]
-  (-> touch-state
-      (assoc :holds (age (emit-or-return holds emit-hold? out-c)))
-      (assoc :scrolls (emit-or-return scrolls emit-scroll? out-c))
-      (assoc :ends (age (emit-or-return ends emit-end? out-c)))))
+  [{touch-id :touch-id :as t} state out-c]
+  (assoc state touch-id t))
+
+(defn emit-touch?
+  [{t-type :type t-age :age} state]
+  (or (and (or (= t-type "touchstart") (= t-type "touchend"))
+           (> t-age 0))
+      (= t-type "touchmove")))
+
+(defn touch-tick
+  [state out-c]
+  (let [{emit true keep false} (group-by emit-touch? (vals state))]
+    (onto-chan out-c (or (vals (select-keys state (map :touch-id emit))) '()) false)
+    (reduce (fn [m k] (update-in m [k :age] inc))
+            (select-keys state (map :touch-id keep))
+            (map :touch-id keep))))

 (defn touch-chan
   [canvas-id wait]
@@ -295,12 +276,11 @@
         c-touchstart (touches canvas-id :touchstart)
         c-touchmove (touches canvas-id :touchmove)
         c-touchend (touches canvas-id :touchend)]
-    (go (loop [touch-state {:holds (sorted-map) :scrolls (sorted-map) :ends (sorted-map)
-                            :scroll-states {}}]
+    (go (loop [state {}]
           (let [[v _] (alts! [c-touchstart c-touchmove c-touchend (timeout wait)])]
             (if (nil? v)
-              (recur (emit-events out-c touch-state))
-              (recur (handle-touch v touch-state))))))
+              (recur (touch-tick state out-c))
+              (recur (handle-touch v state out-c))))))
     out-c))

 (defn step-time


Add some doc strings

Add some doc strings

--- src/reagent/core.cljs
+++ src/reagent/core.cljs
@@ -13,8 +13,7 @@

 (defn render-component
   "Render a Reagent component into the DOM. The first argument may be either a
-vector (using Reagent's Hiccup syntax), or a React component. The second argument
-should be a DOM node.
+vector (using Reagent's Hiccup syntax), or a React component. The second argument should be a DOM node.

 Optionally takes a callback that is called when the component is in place.

@@ -108,7 +107,12 @@
   [defaults props]
   (util/merge-props defaults props))

-(defn flush []
+(defn flush
+  "Render dirty components immediately to the DOM.
+
+Note that this may not work in event handlers, since React.js does
+batching of updates there."
+  []
   (comp/flush))

@@ -125,7 +129,9 @@

 ;; Utilities

-(defn next-tick [f]
+(defn next-tick
+  "Run f using requestAnimationFrame or equivalent."
+  [f]
   (comp/next-tick f))

 (defn partial


All folds take the first element.

All folds take the first element.

Thought about it for a while; first is significantly faster than last,
and in cases where we accrete events over time it'll actually be faster
to accrete them in *reverse* order.

--- src/riemann/folds.clj
+++ src/riemann/folds.clj
@@ -30,9 +30,9 @@
        (sorted-sample-extract s points)))

 (defn sum
-  "Adds events together. Sums metric, merges into last of events."
+  "Adds events together. Sums metric, merges into first of events."
   [events]
-  (assoc (last events)
+  (assoc (first events)
          :metric
          (reduce + (map :metric events))))

@@ -61,9 +61,9 @@
          (reduce / (map :metric events))))

 (defn mean
-  "Averages events together. Mean metric, merged into last of events."
+  "Averages events together. Mean metric, merged into first of events."
   [events]
-  (assoc (last events)
+  (assoc (first events)
          :metric
          (/ (reduce + (map :metric events)) (count events))))


removed unused function

removed unused function

--- src/server/rooms.cljs
+++ src/server/rooms.cljs
@@ -93,13 +93,6 @@
       (if-not (nil? reply)
         (delete-user socket-id #(callback reply))
         callback))))
-
-(defn image-tags-to-base64 [tags]
-  (let [image-tag (get (get tags "v2") "image")
-        image-data (get image-tag "data")]
-    (if-not (nil? image-tag)
-      (merge tags {"v2" (merge image-tag {"data" (.encode base64-arraybuffer image-data)})})
-      tags)))

 (defn does-room-exist? [room callback]
   (.get redis-client (str "room:" room ":current-track")
@@ -230,7 +223,7 @@
             (fn [username]
               (get-num-of-tracks room
                 (fn [track-num]
-                  (let [tags (image-tags-to-base64 (js->clj tags))
+                  (let [tags (js->clj tags)
                         writer (transit/writer :json)
                         music-info {:tags tags
                                     :username username


tuning...

tuning...

--- src/sormilla/core.clj
+++ src/sormilla/core.clj
@@ -62,8 +62,8 @@
   (with-trans g
     (.translate g (double (/ w 4)) (double (/ (- h th) 2)))
     (.translate g
-      (double (math/lin-scale yaw -0.6 +0.6 (/ w -4) (/ w 4)))
-      (double (math/lin-scale pitch -1.5 +1.5 (/ w 4) (/ w -4))))
+      (double (-> yaw math/clip-to-zero (math/lin-scale -0.6 +0.6 (/ w -4) (/ w 4))))
+      (double (-> pitch math/clip-to-zero (math/lin-scale -1.5 +1.5 (/ w 4) (/ w -4)))))
     (.rotate g (- roll))
     (.setColor g lo)
     (.fillOval g -150 -20 300 40)
@@ -106,16 +106,18 @@

 (defn dummy-source []

-  #_(leap/frame)
-
   [{:quality    3
     :pitch      0.2
     :yaw        0.2
     :roll       0.2}
-   {:quality   1
+   {:quality   0
     :pitch     0.0
     :yaw       0.0
-    :roll     -0.2}])
+    :roll     -0.2}]
+
+  (leap/frame)
+
+  )

 (comment


add possibility to pass extra params to get request

--- src/t2000/twitlib.clj
+++ src/t2000/twitlib.clj
@@ -62,7 +62,9 @@
 (defn http-get
   "Send http GET including twitter authentication.
   Return json converted into clojure data structure."
-  [url]
-  @(http/get url {:oauth-token @token} parse-json-body))
+  ([url]
+   (http-get url {}))
+  ([url options]
+   @(http/get url (merge options {:oauth-token @token}) parse-json-body)))


Attempt to speedup bundle export (#1311)

`map` -> `pmap` should be enough to boost performance of `export-bundle` function.

> **Epic** https://github.com/advthreat/iroh/issues/7107
> Related https://github.com/advthreat/iroh/issues/4958

[§](#qa) QA
============================

No QA is needed.

[§](#squashed-commits) Squashed Commits
======================================================================

--- src/ctia/bundle/core.clj
+++ src/ctia/bundle/core.clj
@@ -491,9 +491,9 @@
                    :metric (count ids)})
       (let [start (System/currentTimeMillis)
             identity-map (auth/ident->map identity)
-            res (->> (map #(export-entities % identity-map identity params services) ids)
-                       (reduce #(deep-merge-with coll/add-colls %1 %2))
-                       (into empty-bundle))]
+            res (->> (pmap #(export-entities % identity-map identity params services) ids)
+                     (reduce #(deep-merge-with coll/add-colls %1 %2))
+                     (into empty-bundle))]
         (send-event {:service "Export bundle end"
                      :correlation-id correlation-id
                      :time (get-epoch-second)


Fix indentation

Fix indentation

--- src/discuss/tooltip.cljs
+++ src/discuss/tooltip.cljs
@@ -63,7 +63,7 @@
                (vlib/logo)
                (vlib/safe-space) " | " (vlib/safe-space)
                (dom/span #js {:className "pointer"
-                              :onClick clipboard/add-selection}
+                              :onClick   clipboard/add-selection}
                          (vlib/fa-icon "fa-bookmark-o")
                          " Save")
                (vlib/safe-space) "  " (vlib/safe-space)


Added tracing data.

Added tracing data.

--- src/dragon/blog/core.clj
+++ src/dragon/blog/core.clj
@@ -25,10 +25,12 @@

 (defn legal-content-file?
   [^java.io.File post]
+  (log/trace "Checking legality of file:" post)
   (->> legal-post-file-extensions
        (map #(string/ends-with? (.getCanonicalPath post) %))
        (remove false?)
-       (not-empty)))
+       (not-empty)
+       ((fn [x] (log/tracef "Found file: %s" x) x))))

 (defn post-url
   [uri-base post]


can catch those using eval, thanks Tim

can catch those using eval, thanks Tim

--- src/util/funxions.clj
+++ src/util/funxions.clj
@@ -48,23 +48,6 @@
 (get_fxn *fxn_defBlock_symbol* defBlock) ;(defmacro get_fxn_defBlock ...)
 (get_fxn *fxn_defBlockRaw_symbol* defBlockRaw) ;(defmacro get_fxn_defBlockRaw ...)
 (get_fxn *fxn_defBlock_Aliases* defBlock_Aliases);(defmacro get_fxn_defBlock_Aliases ...)
-;(defmacro get_fxn_defBlock2
-;  []
-;  ;like get the value of <the symbol returned by *fxn_defBlock_symbol*>
-;  `~*fxn_defBlock_symbol*
-;  )
-;=> (macroexpand-1 '(get_fxn_defBlock))
-;fxn_defBlock3
-;=> (macroexpand-1 '(get_fxn_defBlock2))
-;fxn_defBlock3
-;=> (clojure.tools.macro/mexpand-all '(defmacro get_fxn_defBlock2
-;     []
-;     ;like get the value of the symbol returned by *fxn_defBlock_symbol*
-;     `~*fxn_defBlock_symbol*
-;     ))
-;(do (def get_fxn_defBlock2 (fn* ([&form &env] *fxn_defBlock_symbol*))) (. (var get_fxn_defBlock2) (setMacro)) (var get_fxn_defBlock2))
-;=> (clojure.tools.macro/mexpand-all '(get_fxn *fxn_defBlock_symbol* defBlock))
-;(do (def get_fxn_defBlock (fn* ([&form &env] *fxn_defBlock_symbol*))) (. (var get_fxn_defBlock) (setMacro)) (var get_fxn_defBlock))

 (q/deftest test_second
   (q/is (= nil (second nil)))
@@ -262,8 +245,10 @@
   (foo)
   )

-#_(q/deftest test_defxn1
-  (q/isAssumptionFailed (defxn 1 2)) ;XXX: all these happen at compiletime so we can't catch that
+(q/deftest test_defxn1
+  (q/isAssumptionFailed (eval '(defxn 1 2)))
+  (q/isAssumptionFailed (eval '(defxn ~'a 1)))
+  ;XXX: all these happen at compiletime so we can't catch that, we can using eval - thanks Tim Reinke on the ML
   )
 ;)


get rid of one let

get rid of one let

--- src/util/funxions.clj
+++ src/util/funxions.clj
@@ -89,25 +89,32 @@
    passedDefBlock; a map
    & codeblocks ;multiple forms as code
    ]
-  (let [
+  (let [
         readyforeval_fname (list 'backtick/template fname)
-        evaluated_fname (eval readyforeval_fname) ;the fname after ~ are evaluated
-        ;fn_name
-        _ (q/assumedTrue [(symbol? evaluated_fname) "fname must be a symbol, you passed `"
-                          fname "` which resolved to `" evaluated_fname "` of type `" (type evaluated_fname) "` . Maybe you want to use ~ to cause a resolve."])
+        evaluated_fname (eval readyforeval_fname) ;the fname after ~ are evaluated
+        ;fn_name
+        _ (q/assumedTrue [
+                          (symbol? evaluated_fname)
+                          "fname must be a symbol, you passed `"
+                          fname
+                          "` which resolved to `"
+                          evaluated_fname
+                          "` of type `"
+                          (type evaluated_fname)
+                          "` . Maybe you want to use ~ to cause a resolve."]
+            )
+
+        lstBackTicked_passedDefBlock (list 'backtick/template passedDefBlock)
+        evaDefBlock (eval lstBackTicked_passedDefBlock) ;the defblock after ~ are evaluated
+        ;e (eval evaDefBlock)
+        ;_ (q/assumedTrue (symbol? fname))
+        _ (q/assumedTrue [(map? evaDefBlock) "the defBlock must be a map"])
+        aliases (second (find evaDefBlock :aliases)) ;can be nil
         ]
-    (let [
-          lstBackTicked_passedDefBlock (list 'backtick/template passedDefBlock)
-          evaDefBlock (eval lstBackTicked_passedDefBlock) ;the defblock after ~ are evaluated
-          ;e (eval evaDefBlock)
-          ;_ (q/assumedTrue (symbol? fname))
-          _ (q/assumedTrue [(map? evaDefBlock) "the defBlock must be a map"])
-          aliases (second (find evaDefBlock :aliases)) ;can be nil
-          ]
-      ;(q/when-debug (clojure.pprint/pprint (list ":aliases=" aliases)))
-      ;(q/when-debug (clojure.pprint/pprint (list "evaDefBlock=" evaDefBlock)))
-      (q/when-debug (q/show-lexical-env))
-      ; evaDefBlock == `'~evaDefBlock = `~*fxn_defBlock_symbol*
+    ;(q/when-debug (clojure.pprint/pprint (list ":aliases=" aliases)))
+    ;(q/when-debug (clojure.pprint/pprint (list "evaDefBlock=" evaDefBlock)))
+    (q/when-debug (q/show-lexical-env))
+    ; evaDefBlock == `'~evaDefBlock = `~*fxn_defBlock_symbol*
     `(defn ~evaluated_fname
 "
 this function takes only one parameter: a map with the parameters;
@@ -144,7 +151,6 @@
          )
        )
     )
-  )
   )

 #_(try ;can't catch it


Concurrency and other fixes.

Concurrency and other fixes.

Metronome was using atoms, when it needed to preserve mutual
integrity between its various elements (a problem inherited from its
Overtone origins). Changed to use refs and dosync, so Clojure's software
transactional memory can manage coordinated changes as transactions.
Also eliminated strange use of floating point numbers (perhaps because
Overtone developers were confused by ratios?)

Implemented forgotten metro-bpp implementations (oops!), and enhanced
metro-bpb and metro-bpp to preserve smaller beat (and bar, for bpp)
phases when making changes.

--- src/afterglow/rhythm.clj
+++ src/afterglow/rhythm.clj
@@ -110,7 +110,7 @@

 (defn beat-ms
   "Convert 'b' beats to milliseconds at the given 'bpm'."
-  [b bpm] (* (/ 60000.0 bpm) b))
+  [b bpm] (* (/ 60000 bpm) b))

 (defn- marker-number
   "Helper function to calculate the beat, bar, or phrase number in
@@ -171,79 +171,171 @@
   IMetronome
   (metro-start [metro] @start)
   (metro-start [metro start-beat]
-    (let [new-start (round (- (now) (* (dec start-beat) (metro-tick metro))))]
-      (reset! start new-start)))
+    (dosync
+     (ensure bpm)
+     (let [new-start (round (- (now) (* (dec start-beat) (metro-tick metro))))]
+       (ref-set start new-start))))
   (metro-bar-start [metro start-bar]
-    (let [phase (metro-beat-phase metro)
-          shift (* (metro-tick metro) (if (> phase 0.5) (dec phase) phase))
-          new-bar-start (round (- (now) shift (* (dec start-bar) (metro-tock metro))))]
-      (reset! start new-bar-start)))
+    (dosync
+     (ensure bpm)
+     (ensure bpb)
+     (let [phase (metro-beat-phase metro)
+           shift (* (metro-tick metro) (if (> phase 0.5) (dec phase) phase))
+           new-bar-start (round (- (now) shift (* (dec start-bar) (metro-tock metro))))]
+       (ref-set start new-bar-start))))
   (metro-phrase-start [metro start-phrase]
-    (let [phase (metro-beat-phase metro)
-          shift (* (metro-tick metro) (if (> phase 0.5) (dec phase) phase))
-          new-phrase-start (round (- (now) shift (* (dec start-phrase) (metro-ding metro))))]
-      (reset! start new-phrase-start)))
+    (dosync
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (let [phase (metro-beat-phase metro)
+           shift (* (metro-tick metro) (if (> phase 0.5) (dec phase) phase))
+           new-phrase-start (round (- (now) shift (* (dec start-phrase) (metro-ding metro))))]
+       (ref-set start new-phrase-start))))
   (metro-adjust [metro ms]
-    (swap! start + ms))
+    (dosync
+     (alter start + ms)))

   (metro-tick [metro] (beat-ms 1 @bpm))
-  (metro-tock [metro] (beat-ms @bpb @bpm))
-  (metro-ding [metro] (beat-ms (* @bpb @bpp) @bpm))
-
-  (metro-beat [metro] (marker-number (now) @start (metro-tick metro)))
-  (metro-beat [metro b] (+ (* b (metro-tick metro)) @start))
+  (metro-tock [metro] (dosync
+                       (ensure bpm)
+                       (ensure bpb)
+                       (beat-ms @bpb @bpm)))
+  (metro-ding [metro] (dosync
+                       (ensure bpm)
+                       (ensure bpb)
+                       (ensure bpp)
+                       (beat-ms (* @bpb @bpp) @bpm)))
+
+  (metro-beat [metro] (dosync
+                       (ensure start)
+                       (ensure bpm)
+                       (marker-number (now) @start (metro-tick metro))))
+  (metro-beat [metro b] (dosync
+                         (ensure start)
+                         (ensure bpm)
+                         (+ (* b (metro-tick metro)) @start)))
   (metro-beat-phase [metro]
-    (marker-phase (now) @start (metro-tick metro)))
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (marker-phase (now) @start (metro-tick metro))))
   (metro-beat-phase [metro phase]
-    (let [delta (- phase (metro-beat-phase metro))
-          shift (round (* (metro-tick metro) (if (> delta 0.5) (dec delta)
-                                                 (if (< delta -0.5) (inc delta) delta))))]
-      (swap! start - shift)))
+    (dosync
+     (ensure bpm)
+     (let [delta (- phase (metro-beat-phase metro))
+           shift (round (* (metro-tick metro) (if (> delta 0.5) (dec delta)
+                                                  (if (< delta -0.5) (inc delta) delta))))]
+       (alter start - shift))))

-  (metro-bar [metro] (marker-number (now) @start (metro-tock metro)))
-  (metro-bar [metro b] (+ (* b (metro-tock metro)) @start))
+  (metro-bar [metro]
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (marker-number (now) @start (metro-tock metro))))
+  (metro-bar [metro b]
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (+ (* b (metro-tock metro)) @start)))
   (metro-bar-phase [metro]
-    (marker-phase (now) @start (metro-tock metro)))
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (marker-phase (now) @start (metro-tock metro))))
   (metro-bar-phase [metro phase]
-    (let [delta (- phase (metro-bar-phase metro))
-          shift (round (* (metro-tock metro) (if (> delta 0.5) (dec delta)
-                                                 (if (< delta -0.5) (inc delta) delta))))]
-      (swap! start - shift)))
+    (dosync
+     (ensure bpm)
+     (ensure bpb)
+     (let [delta (- phase (metro-bar-phase metro))
+           shift (round (* (metro-tock metro) (if (> delta 0.5) (dec delta)
+                                                  (if (< delta -0.5) (inc delta) delta))))]
+       (alter start - shift))))

-  (metro-phrase [metro] (marker-number (now) @start (metro-ding metro)))
-  (metro-phrase [metro b] (+ (* b (metro-ding metro)) @start))
+  (metro-phrase [metro]
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (marker-number (now) @start (metro-ding metro))))
+  (metro-phrase [metro p]
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (+ (* p (metro-ding metro)) @start)))
   (metro-phrase-phase [metro]
-    (marker-phase (now) @start (metro-ding metro)))
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (marker-phase (now) @start (metro-ding metro))))
   (metro-phrase-phase [metro phase]
-    (let [delta (- phase (metro-phrase-phase metro))
-          shift (round (* (metro-ding metro) (if (> delta 0.5) (dec delta)
-                                                 (if (< delta -0.5) (inc delta) delta))))]
-      (swap! start - shift)))
+    (dosync
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (let [delta (- phase (metro-phrase-phase metro))
+           shift (round (* (metro-ding metro) (if (> delta 0.5) (dec delta)
+                                                  (if (< delta -0.5) (inc delta) delta))))]
+       (alter start - shift))))

   (metro-bpm [metro] @bpm)
   (metro-bpm [metro new-bpm]
-    (let [cur-beat (metro-beat metro)
-          new-tick (beat-ms 1 new-bpm)
-          new-start (round (- (metro-beat metro cur-beat) (* new-tick cur-beat)))]
-      (reset! start new-start)
-      (reset! bpm new-bpm))
+    (dosync
+     (let [cur-beat (metro-beat metro)
+           new-tick (beat-ms 1 new-bpm)
+           new-start (round (- (metro-beat metro cur-beat) (* new-tick cur-beat)))]
+       (ref-set start new-start)
+       (ref-set bpm new-bpm)))
     [:bpm new-bpm])
+
   (metro-bpb [metro] @bpb)
   (metro-bpb [metro new-bpb]
-    (let [cur-bar (metro-bar metro)
-          new-tock (beat-ms new-bpb @bpm)
-          new-start (- (metro-bar metro cur-bar) (* new-tock cur-bar))]
-      (reset! start new-start)
-      (reset! bpb new-bpb)))
+    (dosync
+     (ensure bpm)
+     (let [cur-bar (metro-bar metro)
+           new-tock (beat-ms new-bpb @bpm)
+           new-start (- (now) (* new-tock (dec cur-bar)))
+           phase (metro-beat-phase metro)  ; Preserve beat phase
+           shift (* (metro-tick metro) phase)]
+       (ref-set start (round (- new-start shift)))
+       (ref-set bpb new-bpb))))
+
+  (metro-bpp [metro] @bpp)
+  (metro-bpp [metro new-bpp]
+    (dosync
+     (ensure bpm)
+     (ensure bpb)
+     (let [cur-phrase (metro-phrase metro)
+           new-ding (beat-ms (* @bpb new-bpp) @bpm)
+           new-start (- (now) (* new-ding (dec cur-phrase)))
+           phase (metro-bar-phase metro)  ; Preserve beat & bar phase
+           shift (* (metro-tock metro) phase)]
+       (ref-set start (round (- new-start shift)))
+       (ref-set bpp new-bpp))))
+
   (metro-snapshot [metro]
-    (let [instant (now)
-          beat (marker-number instant @start (metro-tick metro))
-          bar (marker-number instant @start (metro-tock metro))
-          phrase (marker-number instant @start (metro-ding metro))
-          beat-phase (marker-phase instant @start (metro-tick metro))
-          bar-phase (marker-phase instant @start (metro-tock metro))
-          phrase-phase (marker-phase instant @start (metro-ding metro))]
-      (MetronomeSnapshot. @start @bpm @bpb @bpp instant beat bar phrase beat-phase bar-phase phrase-phase)))
+    (dosync
+     (ensure start)
+     (ensure bpm)
+     (ensure bpb)
+     (ensure bpp)
+     (let [instant (now)
+           beat (marker-number instant @start (metro-tick metro))
+           bar (marker-number instant @start (metro-tock metro))
+           phrase (marker-number instant @start (metro-ding metro))
+           beat-phase (marker-phase instant @start (metro-tick metro))
+           bar-phase (marker-phase instant @start (metro-tock metro))
+           phrase-phase (marker-phase instant @start (metro-ding metro))]
+       (MetronomeSnapshot. @start @bpm @bpb @bpp instant beat bar phrase beat-phase bar-phase phrase-phase))))
+
   (metro-marker [metro]
     (let [snap (metro-snapshot metro)]
       (str (:phrase snap) "." (snapshot-bar-within-phrase snap) "." (snapshot-beat-within-bar snap)))))
@@ -253,9 +345,9 @@
   and it will compute beat, bar, and phrase timestamps accordingly.
   See the IMetronome interface for full details."
   [bpm & {:keys [bpb bpp] :or {bpb 4 bpp 8}}]
-  (let [start (atom (now))
-        bpm (atom bpm)
-        bpb (atom bpb)
-        bpp (atom bpp)]
+  (let [start (ref (now))
+        bpm (ref bpm)
+        bpb (ref bpb)
+        bpp (ref bpp)]
     (Metronome. start bpm bpb bpp)))