Split long lines.

Split long lines.

--- src/cbfg/world/t1.cljs
+++ src/cbfg/world/t1.cljs
@@ -2,7 +2,8 @@
   (:require-macros [cljs.core.async.macros :refer [go-loop]]
                    [cbfg.act :refer [act act-loop actx-top achan achan-buf
                                      aalts aput atake]])
-  (:require [cljs.core.async :refer [<! >! close! chan map< merge timeout dropping-buffer]]
+  (:require [cljs.core.async :refer [<! >! close! chan map< merge timeout
+                                     dropping-buffer]]
             [goog.dom :as gdom]
             [om.core :as om :include-macros true]
             [om.dom :as dom :include-macros true]
@@ -200,7 +201,8 @@
            (when-let [listen-result-ch (achan server-init)]
              (aput server-init (:net-listen-ch @prog-base)
                    [server-addr port listen-result-ch])
-             (when-let [[accept-ch close-accept-ch] (atake server-init listen-result-ch)]
+             (when-let [[accept-ch close-accept-ch]
+                        (atake server-init listen-result-ch)]
                (cbfg.world.net/server-accept-loop world accept-ch close-accept-ch)
                (prog-event world [:kv-server server-addr port]
                            #(update-in % [:servers server-addr]


Remvoed debugging printf.

Remvoed debugging printf.

--- src/cbfg/world/t2.cljs
+++ src/cbfg/world/t2.cljs
@@ -82,7 +82,6 @@
     nil))

 (defn lane-handler [lane-state m]
-  (println :LH m)
   (case (:op m)
     "realms-list"
     [lane-state (assoc m :status :invalid)]


Kate McCaffrey, Modded, Career Fair, Running Interference.

--- src/clj/game/cards.clj
+++ src/clj/game/cards.clj
@@ -259,7 +259,12 @@
    "Career Fair"
    {:prompt "Choose a Resource to install"
     :choices (req (filter #(#{"Resource"} (:type %)) (:hand runner)))
-    :effect (effect (gain :credit (min 3 (:cost target))) (runner-install target))}
+    :effect  (effect
+               (register-events {:pre-install
+                                 {:effect (effect (install-cost-bonus -3) (unregister-events card))}}
+                                (assoc card :zone '(:discard)))
+               (runner-install target))
+    :events {:pre-install nil}}

    "Celebrity Gift"
    {:choices {:max 5 :req #(and (:side % "Corp") (= (:zone %) [:hand]))}
@@ -1075,6 +1080,12 @@
     :abilities [{:cost [:click 4] :msg "give the Corp 1 bad publicity"
                  :effect (effect (gain :corp :bad-publicity 1) (trash card))}]}

+   "Kate \"Mac\" McCaffrey: Digital Tinker"
+   {:effect (effect (gain :link 1))
+    :events {:pre-install {:once :per-turn
+                           :req (req (some #(= % (:type target)) '("Hardware" "Program")))
+                           :effect (effect (install-cost-bonus -1))}}}
+
    "Kati Jones"
    {:abilities
     [{:cost [:click 1] :msg "store 3 [Credits]" :once :per-turn
@@ -1260,7 +1271,12 @@
    "Modded"
    {:prompt "Choose a card to install"
     :choices (req (filter #(#{"Hardware" "Program"} (:type %)) (:hand runner)))
-    :effect (effect (gain :credit (min 3 (:cost target))) (runner-install target))}
+    :effect (effect
+              (register-events {:pre-install
+                                {:effect (effect (install-cost-bonus -3) (unregister-events card))}}
+                               (assoc card :zone '(:discard)))
+              (runner-install target))
+    :events {:pre-install nil}}

    "Monolith"
    {:prevent [:net :brain]
@@ -1757,7 +1773,15 @@
                  :msg "do 3 net damage" :effect (effect (damage :net 3) (trash card))}]}

    "Running Interference"
-   {:prompt "Choose a server" :choices (req servers) :effect (effect (run target))}
+   {:prompt "Choose a server" :choices (req servers)
+    :effect (effect (run target)
+                    (register-events {:pre-rez
+                                      {:req (req (= (:type target) "ICE"))
+                                       :effect (effect (rez-cost-bonus (:cost target)))}
+                                      :run-ends
+                                      {:effect (effect (unregister-events card))}}
+                                     (assoc card :zone '(:discard))))
+    :events {:pre-rez nil}}

    "Ryon Knight"
    {:abilities [{:msg "do 1 brain damage" :req (req (and this-server (zero? (:click runner))))
@@ -3230,9 +3254,6 @@
                 {:effect (effect (move card :rfg)) :label "Remove Jackson Howard from the game"
                  :msg "shuffle up to 3 cards from Archives into R&D"}]}

-   "Kate \"Mac\" McCaffrey: Digital Tinker"
-   {:effect (effect (gain :link 1))}
-
    "Nasir Meidan: Cyber Explorer"
    {:effect (effect (gain :link 1))}


Reword Shi.Kyu dialog

Reword Shi.Kyu dialog

Just played a game where a person was confused about what Shi.Kyu did, thinking they couldn't "lose 1 agenda point" if they hadn't already scored an agenda, and as a result ended up unnecessarily flatlining themself. This is my proposed rewording.

--- src/clj/game/cards.clj
+++ src/clj/game/cards.clj
@@ -2348,10 +2348,10 @@
              :msg (msg "attempt to do " target " net damage")
              :effect (effect (resolve-ability
                               {:player :runner :msg (msg target)
-                               :prompt (str "Take " target " net damage or lose 1 agenda point?")
-                               :choices [(str "take " target " net damage") "lose 1 agenda point"]
+                               :prompt (str "Take " target " net damage or take Shi.Kyū as -1 agenda points?")
+                               :choices [(str "take " target " net damage") "add Shi.Kyū to score area"]
                                :effect (let [dmg target]
-                                         (req (if (= target "lose 1 agenda point")
+                                         (req (if (= target "add Shi.Kyū to score area")
                                                 (do (gain state :runner :agenda-point -1)
                                                     (move state :runner card :scored nil))
                                                 (damage state :corp :net dmg {:card card}))))}


Fix for Autoscripter.

Fix for Autoscripter.

--- src/clj/game/cards.clj
+++ src/clj/game/cards.clj
@@ -178,12 +178,14 @@
    {:events {:jack-out {:effect (effect (gain :credit 1)) :msg "gain 1 [Credits]"}}}

    "Autoscripter"
-   {:events {:runner-install {:req (req (and (= (:active-player @state) :runner)
+   {:events {:runner-install {:req (req (and (has? target :type "Program")
+                                             (= (:active-player @state) :runner)
                                              (empty? (filter #(has? % :type "Program")
-                                                             (mapcat first (turn-events state side :runner-install))))))
+                                                             (map first (turn-events state side :runner-install))))))
                               :msg "gain [Click]" :effect (effect (gain :click 1))}
              :unsuccessful-run {:effect (effect (trash card)
-                                                (system-msg "Autoscripter is trashed"))}}}
+                                                (system-msg "trashes Autoscripter"))}}}
+

    "Bank Job"
    {:data {:counter 8}


Small tweaks

Small tweaks

--- src/clj/sptcg/core.clj
+++ src/clj/sptcg/core.clj
@@ -11,12 +11,8 @@
    [clojure.tools.nrepl.server :as nrepl]
    [sptcg.util :as util]))

-(defn index [req]
-  "hello"
-  ;;(file-response "public/html/index.html" {:root "resources"})
-  )
-
-
+(defn index [{db :db}]
+  (file-response "public/html/index.html" {:root "resources"}))

 (let [{:keys [ch-recv send-fn ajax-post-fn ajax-get-or-ws-handshake-fn]}
       (sente/make-channel-socket! {})]
@@ -51,10 +47,10 @@
 (def server (atom nil))

 (defn -main [& args]
-  (println "Starting REPL")
+  (println "Starting REPL at 127.0.0.1 port 4005")
   (nrepl/start-server :port 4005 :bind "127.0.0.1")
-  (println "Starting Datomic")
+  (println "Starting Datomic at " dburi)
   (util/init-db dburi)
-  (println "Starting Http-kit")
+  (println "Starting Http-kit http://localhost:8080")
   (reset! server (hk/run-server app {:port 8080}))
   (println "Started Server."))


Implement multiple handlers and one receiver

--- src/distributed_transducers_poc/rc.clj
+++ src/distributed_transducers_poc/rc.clj
@@ -36,9 +36,6 @@

 (defmacro super-reduce [f xs]
   `(invoke-lambda (pr-str (s/fn [] (reduce ~f ~xs))) "distributed-transducers-poc" "eu-west-1"))
-
-(defn plus [a b]
-  (+ a b))

 (def sqs-client (AmazonSQSClient. aws-credentials))

@@ -90,7 +87,6 @@
   (let [handler (fn [message]
                   (when (= "process" (:type message)
                            (let [result (f (:payload message))]
-                             (println "Result " result)
                              (send-message out-queue {:index (:index message)
                                                       :payload result}))))
                     (:type message))]
@@ -103,7 +99,6 @@
 (defn send-ok-messages [c buffer]
   (if-let [result (aq/peek-head buffer)]
     (do
-      (println "Sending ok" result)
       (go (>! c result))
       (send-ok-messages c (aq/remove-one buffer)))
     buffer))
@@ -121,35 +116,34 @@

 (defn uuid [] (str (java.util.UUID/randomUUID)))

-;(create-queue (uuid))
-
-(defn queue-reduce [f xs in-queue out-queue]
-  (message-loop (fn [x] (reduce f x)) in-queue out-queue)
+(defn queue-reduce [f xs in-queues out-queue]
+  (doseq [in-queue in-queues]
+    (message-loop (fn [x] (reduce f x)) in-queue out-queue))
   (let [{:keys [results stop-fn]} (handler-loop out-queue)
-        batches (map (fn [a b] [a b]) (partition-all 1024 xs) (range))]
+        batches (map (fn [a b] [a b]) (partition-all 4096 xs) (range))]
     (thread
       (doseq [[batch index] batches]
-        (send-message in-queue {:type "process" :index index :payload batch})))
+        (send-message (nth in-queues (mod index (count in-queues)))
+                      {:type "process" :index index :payload batch})))
     (let [response (reduce (fn [acc _]
                              (f acc (:payload (<!! results))))
                            0
                            batches)]
-      (send-message in-queue {:type "stop"})
+      (doseq [in-queue in-queues]
+        (send-message in-queue {:type "stop"}))
       (stop-fn)
       response)))

-;(comment
-(defn do-reduce []
-  (let [in (create-queue (uuid))
+(defn uber-reduce [f xs node-count]
+  (let [in-queues  (map (fn [_] (create-queue (uuid)))
+                        (range node-count))
         out (create-queue (uuid))]
-    (let [response (queue-reduce + (range 10000) in out)]
+    (let [response (queue-reduce f xs in-queues out)]
       (Thread/sleep 200)
-      (delete-queue in)
+      (doseq [in-queue in-queues]
+        (delete-queue in-queue))
       (delete-queue out)
       response)))
-  ;(super-reduce plus (range 100000))
-
-

 ;(invoke-lambda (pr-str (s/fn [] (map #(* 2 %) [3 4 5]))) "distributed-transducers-poc" "eu-west-1")


Generate shorter URLs

Generate shorter URLs

--- clojure/src/me/perdomo/cofre/http.clj
+++ clojure/src/me/perdomo/cofre/http.clj
@@ -5,12 +5,10 @@
             [ring.adapter.jetty :refer (run-jetty)]
             [ring.util.response :refer (response content-type not-found file-response)]
             [compojure.core :refer (defroutes GET POST)])
-  (:import java.util.UUID)
   (:gen-class))

 (defn- get-file-name []
-  (let [name (str (UUID/randomUUID))]
-    (.replaceAll name "-" "")))
+  (Long/toString (System/nanoTime) 36))

 (defn- copy-file [tempfile]
   (let [fname (get-file-name)


fix spacing

fix spacing

--- etc/synthdefs/synth-designs.clj
+++ etc/synthdefs/synth-designs.clj
@@ -335,7 +335,7 @@
           sustain       (select:kr (= -1 sustain) [sustain (- play-time attack release)])
           env           (env-gen (envelope [0 1 1 0] [attack sustain release]) :level-scale amp :action FREE)
           [snd-l snd-r] (buf-rd 2 buf phase)
-          snd (balance2 snd-l snd-r pan)]
+          snd           (balance2 snd-l snd-r pan)]
       (out out-bus snd)))

    ;; (save-to-pi mono-player)


cjl - Add precondition to clear-rows

cjl - Add precondition to clear-rows

--- src/icfp2015/board.clj
+++ src/icfp2015/board.clj
@@ -41,7 +41,8 @@

 (defn- clear-rows
   "Clears full rows. Moves cells above cleared row downward"
-  [{:keys [width height filled] :as board}]
+  [{:keys [width height filled current-unit] :as board}]
+  {:pre [(nil? current-unit)]}
   (let [row-is-filled (fn [i] (->> (range width)
                                    (map (fn [j] [i j]))
                                    (every? (partial contains? filled))))


GitHub Issue #11 - improve the way tooltips work; allowing the mouse to hover over the tooltip while active. this should also (hopefully) fix the IE bug

--- cljs-cheatsheet/cljs_cheatsheet/tooltips.cljs
+++ cljs-cheatsheet/cljs_cheatsheet/tooltips.cljs
@@ -1,18 +1,23 @@
 (ns cljs-cheatsheet.tooltips
   (:require
     [clojure.set :refer [difference]]
+    [clojure.string :refer [replace]]
     [cljs-cheatsheet.dom :refer [by-id set-html! show-el! hide-el!]]
     [cljs-cheatsheet.util :refer [js-log log uuid]]))

 (def $ js/jQuery)
-
 (def has-touch-events? (aget js/window "hasTouchEvents"))
+(def tooltip-icon-sel ".tooltip-link-0e91b")
+(def tooltip-sel ".tooltip-53dde")
+(def left-arrow-class "left-arr-42ea1")
+(def right-arrow-class "right-arr-d3345")
+(def arrow-classes (str left-arrow-class " " right-arrow-class))

 ;;------------------------------------------------------------------------------
 ;; Helper
 ;;------------------------------------------------------------------------------

-(defn- evt->tt-num
+(defn- js-evt->tooltip-id
   "Returns a tooltip-id from a JS event or nil if the tooltip was not found."
   [js-evt]
   (let [current-target (aget js-evt "currentTarget")
@@ -22,26 +27,59 @@
     (if tooltip-el
       tooltip-id)))

-(defn- pinned?
-  "Returns whether or not a tooltip is pinned."
-  [tt-el]
-  (= "true" (.attr ($ tt-el) "data-pinned")))
+; (defn- pinned?
+;   "Returns whether or not a tooltip is pinned."
+;   [tt-el]
+;   (= "true" (.attr ($ tt-el) "data-pinned")))

-(defn- pin-down! [tooltip-id]
-  ;; TODO: write me
-  )
+; (defn- pin-down! [tooltip-id]
+;   )

-(defn- remove-pin! [tooltip-id]
-  ;; TODO: write me
-  )
+; (defn- remove-pin! [tooltip-id]
+;   )
+
+(defn- within-bounds? [m-pos el-coords]
+  (let [x (:x m-pos)
+        y (:y m-pos)]
+    (and (>= x (:x1 el-coords))
+         (<= x (:x2 el-coords))
+         (>= y (:y1 el-coords))
+         (<= y (:y2 el-coords)))))
+
+(defn- mouse-inside-tooltip? [m-pos tooltip-coords]
+  (or (within-bounds? m-pos (:icon-bounds tooltip-coords))
+      (within-bounds? m-pos (:tooltip-bounds tooltip-coords))))
+
+;; create a box around the icon
+(def icon-mouseout-padding 20)
+
+(defn- icon-bounds [icon-el]
+  (let [$icon-el ($ icon-el)
+        icon-height (.height $icon-el)
+        icon-width (.width $icon-el)
+        icon-coords (.offset $icon-el)
+        icon-x (+ (aget icon-coords "left") (/ icon-width 2))
+        icon-y (+ (aget icon-coords "top") (/ icon-height 2))]
+    {:x1 (- icon-x icon-mouseout-padding)
+     :x2 (+ icon-x icon-mouseout-padding)
+     :y1 (- icon-y icon-mouseout-padding)
+     :y2 (+ icon-y icon-mouseout-padding 10) ;; be a little more generous around
+                                             ;; the bottom of the tooltip arrow
+     }))
+
+(defn- tooltip-bounds [tooltip-id]
+  (let [$tooltip-el ($ (str "#" tooltip-id))
+        coords (.offset $tooltip-el)
+        height (-> (.css $tooltip-el "height") (replace "px" "") int)
+        width (-> (.css $tooltip-el "width") (replace "px" "") int)]
+    {:x1 (aget coords "left")
+     :x2 (+ (aget coords "left") width)
+     :y1 (aget coords "top")
+     :y2 (+ (aget coords "top") height)}))

 ;;------------------------------------------------------------------------------
 ;; Show / Hide Tooltips
 ;;------------------------------------------------------------------------------
-
-(def left-arrow-class "left-arr-42ea1")
-(def right-arrow-class "right-arr-d3345")
-(def arrow-classes (str left-arrow-class " " right-arrow-class))

 (defn- show-tooltip! [icon-el tooltip-id]
   (let [$icon-el ($ icon-el)
@@ -53,70 +91,88 @@
         browser-width (.width ($ js/window))
         $tooltip-el ($ (str "#" tooltip-id))
         tooltip-width (.width $tooltip-el)
-        flip? (> (+ icon-x tooltip-width 50) browser-width)]
+        flip? (> (+ icon-x tooltip-width 50) browser-width)
+        left (if flip? (- icon-x tooltip-width 30)
+                       (+ icon-x 18))
+        top (- icon-y 22)]
     (.removeClass $tooltip-el arrow-classes)
     (if flip?
       (.addClass $tooltip-el right-arrow-class)
       (.addClass $tooltip-el left-arrow-class))
     (.css $tooltip-el (js-obj
-      "display" ""
-      "left" icon-x
-      "marginLeft" (if flip? (- 0 tooltip-width 30) 18)
-      "top" (- icon-y 22)))))
-
-(def tooltip-sel ".tooltip-53dde")
+      "left" left
+      "top" top))
+    (.fadeIn $tooltip-el "fast")))

 (defn- hide-all-tooltips! []
-  (.hide ($ tooltip-sel)))
+  (.fadeOut ($ tooltip-sel) "fast"))
+
+;;------------------------------------------------------------------------------
+;; Hovered Tooltip Coordinates
+;;------------------------------------------------------------------------------
+
+(def hovered-tooltip-coords (atom nil))
+
+;;------------------------------------------------------------------------------
+;; Mouse Position
+;;------------------------------------------------------------------------------
+
+(def mouse (atom nil))
+
+(defn- on-change-mouse [_ _ _ m-pos]
+  (when (and @hovered-tooltip-coords
+             (not (mouse-inside-tooltip? m-pos @hovered-tooltip-coords)))
+    (hide-all-tooltips!)
+    (reset! hovered-tooltip-coords nil)))
+
+(add-watch mouse :change on-change-mouse)

 ;;------------------------------------------------------------------------------
 ;; Events
 ;;------------------------------------------------------------------------------

-(defn- on-click [js-evt]
-  (if-let [tooltip-id (evt->tt-num js-evt)]
-    (if (pinned? (by-id tooltip-id))
-      (remove-pin! tooltip-id)
-      (pin-down! tooltip-id))))
+; (defn- on-click [js-evt]
+;   (if-let [tooltip-id (js-evt->tooltip-id js-evt)]
+;     (if (pinned? (by-id tooltip-id))
+;       (remove-pin! tooltip-id)
+;       (pin-down! tooltip-id))))

-(defn- on-mouseenter [js-evt]
-  (when-let [tooltip-id (evt->tt-num js-evt)]
-    (show-tooltip! (aget js-evt "currentTarget") tooltip-id)))
+(defn- mousemove-body [js-evt]
+  (reset! mouse {
+    :x (aget js-evt "pageX")
+    :y (aget js-evt "pageY")}))

-;; TODO: IE fires the mouseleave event while the mouse cursor is still inside
-;; the tooltip icon, causing a very distracting flicker effect.
-;; Need to find a fix. Maybe capture the x/y of everything on mouseenter and
-;; add a "listenOnce" event on the body for the exit?
-;; https://github.com/oakmac/clojurescript.info/issues/11
-(defn- on-mouseleave [js-evt]
-  (if-let [tooltip-id (evt->tt-num js-evt)]
-    (hide-el! tooltip-id)))
+(defn- on-mouseenter-icon [js-evt]
+  (when-let [tooltip-id (js-evt->tooltip-id js-evt)]
+    (let [icon-el (aget js-evt "currentTarget")]
+      (show-tooltip! icon-el tooltip-id)
+      (reset! hovered-tooltip-coords {
+        :tooltip-bounds (tooltip-bounds tooltip-id)
+        :icon-bounds (icon-bounds icon-el)}))))

 (defn- on-touchend-body [js-evt]
   (hide-all-tooltips!))

 (defn- on-touchend-icon [js-evt]
   (.stopPropagation js-evt)
-  (if-let [tooltip-id (evt->tt-num js-evt)]
+  (if-let [tooltip-id (js-evt->tooltip-id js-evt)]
     (show-tooltip! (aget js-evt "currentTarget") tooltip-id)))

 ;;------------------------------------------------------------------------------
 ;; Init and Events
 ;;------------------------------------------------------------------------------

-(def tt-link-sel ".tooltip-link-0e91b")
-
+;; TODO: touch events are not really polished yet
 (defn- add-touch-events! []
-  (doto ($ "body")
+  (-> ($ "body")
     (.on "touchend" on-touchend-body)
-    (.on "touchend" tt-link-sel on-touchend-icon)))
+    (.on "touchend" tooltip-icon-sel on-touchend-icon)))

 (defn init!
   "Initialize tooltip events."
   []
-  (doto ($ "body")
-    (.on "click" tt-link-sel on-click)
-    (.on "mouseenter" tt-link-sel on-mouseenter)
-    (.on "mouseleave" tt-link-sel on-mouseleave))
+  (-> ($ "body")
+    (.on "mousemove" mousemove-body)
+    (.on "mouseenter" tooltip-icon-sel on-mouseenter-icon))
   (when has-touch-events?
     (add-touch-events!)))


Rename variable to indicate true type (asset path is distinct from resource path)

--- src/io/aviso/twixt.clj
+++ src/io/aviso/twixt.clj
@@ -149,9 +149,9 @@
     (when (match? path-prefix path)
       (tracker/trace
         #(format "Handling asset request `%s'." path)
-        (let [resource-path (.substring path (.length path-prefix))
+        (let [asset-path (.substring path (.length path-prefix))
               asset-pipeline (-> request :twixt :asset-pipeline)]
-          (if-let [asset-map (asset-pipeline resource-path)]
+          (if-let [asset-map (asset-pipeline asset-path)]
             (-> asset-map
                 :content
                 io/input-stream


Bump Figwheel and Environ to the latest versions

--- src/leiningen/new/chestnut/project.clj
+++ src/leiningen/new/chestnut/project.clj
@@ -12,7 +12,7 @@
                  [ring.middleware.logger "0.5.0"]
                  [compojure "1.4.0"]
                  [org.omcljs/om "1.0.0-alpha28"]
-                 [environ "1.0.1"]{{{project-clj-deps}}}]
+                 [environ "1.0.2"]{{{project-clj-deps}}}]

   :plugins [[lein-cljsbuild "1.1.1"]
             [lein-environ "1.0.1"]{{{project-plugins}}}]
@@ -94,12 +94,12 @@
   :auto {"sassc" {:file-pattern  #"\.(scss)$"}}{{/sass?}}

   :profiles {:dev
-             {:dependencies [[figwheel "0.5.0-4"]
-                             [figwheel-sidecar "0.5.0-4"]
+             {:dependencies [[figwheel "0.5.0-6"]
+                             [figwheel-sidecar "0.5.0-6"]
                              [com.cemerick/piggieback "0.2.1"]
                              [org.clojure/tools.nrepl "0.2.12"]]

-              :plugins [[lein-figwheel "0.5.0-2"]
+              :plugins [[lein-figwheel "0.5.0-6"]
                         [lein-doo "0.1.6"]]

               :cljsbuild {:builds


Adding UI elements

Adding UI elements

--- src/pianola/webui.cljs
+++ src/pianola/webui.cljs
@@ -50,10 +50,34 @@

 (defonce app-state
   (r/atom {:tempo 50
-           :scale (comp scale/C scale/major)}))
+           :scale (comp scale/C scale/major)
+           :playing false
+           :automaton [[0.25 0.125 0.5 0.25 0.125 0.5 0.5]
+                       [1 2 0 4 5 6 3]]
+           :seed [[0.25 0.125 0.25 0.125 0.5 0.25 0.25 0.25]
+                  [2 1 2 1 2 3 4 5]]}))
+
+(defn slider [param value min max]
+  [:input {:type "range" :value value :min min :max max
+           :style {:width "100%"}
+           :on-change (fn [e]
+                        (swap! app-state assoc param (.-target.value e)))}])
+
+(defn toggle-playback []
+  (let [playing (:playing @app-state)]
+    [:button {:on-click (fn [e]
+                          (swap! app-state assoc :playing (not playing)))}
+     (if playing
+       "Stop"
+       "Start")]))

 (defn app []
-  [:div "Hello"])
+  (let [{:keys [tempo scale]} @app-state]
+    [:div
+     [:h1 "Pianola"]
+     [slider :tempo tempo 20 160]
+     [:p (str tempo " BPM")]
+     [toggle-playback]]))

 (defn reload []
   (println "reloading")


Revert "Convert the subscription cache from an atom to a ratom"

This reverts commit afb773dd52276e3d2bdcde9a07511df7c7f34095.

--- src/re_frame/subs.cljc
+++ src/re_frame/subs.cljc
@@ -15,7 +15,7 @@
 ;; De-duplicate subscriptions. If two or more equal subscriptions
 ;; are concurrently active, we want only one handler running.
 ;; Two subscriptions are "equal" if their query vectors test "=".
-(def query->reaction (re-frame.interop/ratom {}))
+(def query->reaction (atom {}))

 (defn clear-subscription-cache!
   "Causes all subscriptions to be removed from the cache.


A little cleanup

A little cleanup

--- src/reagent/ratom.cljs
+++ src/reagent/ratom.cljs
@@ -112,6 +112,7 @@

 (set! batch/ratom-flush flush!)

+
 ;;; Atom

 (defprotocol IReactiveAtom)
@@ -164,7 +165,6 @@
   ([x & {:keys [meta validator]}] (RAtom. x meta validator nil)))

-
 ;;; track

 (declare make-reaction)
@@ -174,27 +174,26 @@
 (defn- cached-reaction [f o k obj destroy]
   (let [m (aget o cache-key)
         m (if (nil? m) {} m)
-        r (get m k)]
-    (if-not (nil? r)
-      (-deref r)
-      (if (nil? *ratom-context*)
-        (f)
-        (let [r (make-reaction
-                 f :on-dispose (fn [x]
-                                 (when debug (swap! -running dec))
-                                 (as-> (aget o cache-key) _
-                                   (dissoc _ k)
-                                   (aset o cache-key _))
-                                 (when (some? obj)
-                                   (set! (.-reaction obj) nil))
-                                 (when (some? destroy)
-                                   (destroy x))))
-              v (-deref r)]
-          (aset o cache-key (assoc m k r))
-          (when debug (swap! -running inc))
-          (when (some? obj)
-            (set! (.-reaction obj) r))
-          v)))))
+        r (m k nil)]
+    (cond
+      (some? r) (-deref r)
+      (nil? *ratom-context*) (f)
+      :else (let [r (make-reaction
+                     f :on-dispose (fn [x]
+                                     (when debug (swap! -running dec))
+                                     (as-> (aget o cache-key) _
+                                       (dissoc _ k)
+                                       (aset o cache-key _))
+                                     (when (some? obj)
+                                       (set! (.-reaction obj) nil))
+                                     (when (some? destroy)
+                                       (destroy x))))
+                  v (-deref r)]
+              (aset o cache-key (assoc m k r))
+              (when debug (swap! -running inc))
+              (when (some? obj)
+                (set! (.-reaction obj) r))
+              v))))

 (deftype Track [f args ^:mutable reaction]
   IReactiveAtom
@@ -309,7 +308,6 @@
   (RCursor. src path nil nil nil))

-
 ;;; with-let support

 (defn with-let-destroy [v]
@@ -429,19 +427,19 @@

   IDeref
   (-deref [this]
-    (when (nil? *ratom-context*)
-      (flush!))
-    (if (and (nil? auto-run) (nil? *ratom-context*))
-      (do
+    (let [non-reactive (nil? *ratom-context*)]
+      (when non-reactive
+        (flush!))
+      (if (and non-reactive (nil? auto-run))
         (when dirty?
           (let [oldstate state]
             (set! state (f))
             (when-not (or (nil? watches) (= oldstate state))
-              (notify-w this oldstate state)))))
-      (do
-        (notify-deref-watcher! this)
-        (when dirty?
-          (._run this))))
+              (notify-w this oldstate state))))
+        (do
+          (notify-deref-watcher! this)
+          (when dirty?
+            (._run this)))))
     state)

   IDisposable
@@ -478,14 +476,14 @@
 (def temp-reaction (make-reaction nil))

 (defn run-in-reaction [f obj key run opts]
-  (let [rea temp-reaction
-        res (deref-capture f rea)]
-    (when-not (nil? (.-watching rea))
+  (let [r temp-reaction
+        res (deref-capture f r)]
+    (when-not (nil? (.-watching r))
       (set! temp-reaction (make-reaction nil))
-      (set! (.-f rea) f)
-      (._set-opts rea opts)
-      (set! (.-auto-run rea) #(run obj))
-      (aset obj key rea))
+      (._set-opts r opts)
+      (set! (.-f r) f)
+      (set! (.-auto-run r) #(run obj))
+      (aset obj key r))
     res))

 (defn check-derefs [f]


clean(e4): removed printlns, etc.

clean(e4): removed printlns, etc.

--- ccw.core.e4/src/clj/ccw/e4/model.clj
+++ ccw.core.e4/src/clj/ccw/e4/model.clj
@@ -598,11 +598,9 @@

 (defn find-binding-table
   [app context]
-  (println "find-binding-table:" context)
   (let [context (if (string? context)
                   (find-app-binding-context app context)
                   context)]
-    (println "context: " context)
     (first (filter #(= context (binding-context %)) (binding-tables app)))))

 (defn key-binding=spec?
@@ -615,7 +613,6 @@
 (defn find-key-binding
   "Find Model Key binding based on its fields"
   [app spec]
-  (println "find-key-binding spec:" spec)
   (when-let [b-table (find-binding-table app (:context spec))]
     (first (filter #(key-binding=spec? % spec) (bindings b-table)))))

@@ -648,8 +645,6 @@
   "Add the handler to the Application Model. Return the application"
   [application handler]
   (let [hdls (handlers application)]
-    (println "hdl(0):" (type (first hdls)))
-    (println "type(handler):" (type handler))
     (.add hdls 0 handler)
     application))

@@ -733,10 +728,7 @@
    data of e"
   [e spec]
   (let [td (transient-data e)]
-    (println "td:" td)
-    (println "(type td):" (type td))
     (doseq [[k v] (:transient-data spec)]
-      (println "[k v]:" k v)
       (.put td k v))))

 (def default-cmd-spec
@@ -814,7 +806,6 @@

 (defn find-or-create-binding-table
   [app context]
-  (println "-=-=-=-=-=-=-= context:" context)
   (if-let [bt (find-binding-table app context)]
     bt
     (let [bt (create-binding-table)]
@@ -828,9 +819,8 @@
   (let [bt (find-or-create-binding-table app context)]
     (.add (bindings bt) 0 kb)))

-;; TODO how/where to use :scheme ?
+;; how/where to use :scheme ?
 (defn merge-key-binding!
-  "TODO"
   [app spec]
   (let [cmd (if (string? (:command spec))
               (find-command app (:command spec))


Complete lists koans test

Complete lists koans test

--- clojure/koans/src/koans/02_lists.clj
+++ clojure/koans/src/koans/02_lists.clj
@@ -1,34 +1,34 @@
 (meditations
   "Lists can be expressed by function or a quoted form"
-  (= '(__ __ __ __ __) (list 1 2 3 4 5))
+  (= '(1 2 3 4 5) (list 1 2 3 4 5))

   "They are Clojure seqs (sequences), so they allow access to the first"
-  (= __ (first '(1 2 3 4 5)))
+  (= 1 (first '(1 2 3 4 5)))

   "As well as the rest"
-  (= __ (rest '(1 2 3 4 5)))
+  (= '(2 3 4 5) (rest '(1 2 3 4 5)))

   "The rest when nothing is left is empty"
-  (= __ (rest '(100)))
+  (= '() (rest '(100)))

   "And construction by adding an element to the front is simple"
-  (= __ (cons :a '(:b :c :d :e)))
+  (= '(:a :b :c :d :e) (cons :a '(:b :c :d :e)))

   "Conjoining an element to a list can be done in the reverse order"
-  (= __ (conj '(:a :b :c :d :e) 0))
+  (= '(0 :a :b :c :d :e) (conj '(:a :b :c :d :e) 0))

   "You can use a list like a stack to get the first element"
-  (= __ (peek '(:a :b :c :d :e)))
+  (= :a (peek '(:a :b :c :d :e)))

   "Or the others"
-  (= __ (pop '(:a :b :c :d :e)))
+  (= '(:b :c :d :e) (pop '(:a :b :c :d :e)))

   "But watch out if you try to pop nothing"
-  (= __ (try
+  (= "No dice!" (try
           (pop '())
           (catch IllegalStateException e "No dice!")))

   "The rest of nothing isn't so strict"
-  (= __ (try
+  (= '() (try
           (rest '())
           (catch IllegalStateException e "No dice!"))))


Update org.clojure/java.jdbc to "0.7.9"

Update org.clojure/java.jdbc to "0.7.9"

--- backend/project.clj
+++ backend/project.clj
@@ -36,7 +36,7 @@
                  [org.clojure/clojure "1.9.0"]
                  [org.clojure/data.csv "0.1.4"]
                  [org.clojure/core.match "0.3.0"]
-                 [org.clojure/java.jdbc "0.7.7"]
+                 [org.clojure/java.jdbc "0.7.9"]
                  [org.immutant/web "2.1.10" :exclusions [ch.qos.logback/logback-classic]]
                  [org.postgresql/postgresql "42.2.2"]
                  [ragtime/ragtime.jdbc "0.6.4"]


Clarify

Clarify

--- src/tick/interval.cljc
+++ src/tick/interval.cljc
@@ -247,7 +247,7 @@
   ;; TODO: Rename? Not always narrow, sometimes widen, or generally modify - perhaps 'derive'
   (narrow [_ beginning end] "Narrow the interval to the new given bounds")
   (splice [ival1 ival2] "Splice two intervals together")
-  (split [ival t] "Split ival into 2 intervals at t, returned as a vector"))
+  (split [ival t] "Split ival into 2 intervals at t, returned as a 2-element vector"))

 (defn split-with-assert [ival t]
   (assert


handle /thq redirect

handle /thq redirect

--- src/tweetiment/web.clj
+++ src/tweetiment/web.clj
@@ -139,11 +139,13 @@
       (redirect "/thq"))))

 (defpage [:get "/thq"] {}
-  (let [atoken (session/get :atoken)
-        sname (:screen_name atoken)
-        sent (trim-decimals (user-sentiment sname))]
-    (db/save-score sname sent)
-    (layout :result (result sname sent))))
+  (if-let [atoken (session/get :atoken)]
+    (let [sname (:screen_name atoken)
+          sent (trim-decimals (user-sentiment sname))]
+      (db/save-score sname sent)
+      (layout :result (result sname sent)))
+    ;else
+    (redirect "/")))

 (defpage [:get "/scores"] {}
   (layout :highscore (scores (db/get-top-scores 10))))


Add low-level accessor to multipart parts

--- src/yada/multipart.clj
+++ src/yada/multipart.clj
@@ -257,7 +257,7 @@
         (let [at-boundary?
               (= (seq (:dash-boundary m))
                  (seq (copy-bytes (:window m) 0 (:dash-boundary-size m))))]
-
+
           (s/put! (:stream m) [(if at-boundary?
                                  {:type :part
                                   :bytes (copy-bytes-after-dash-boundary m 0 (:pos m))
@@ -646,8 +646,13 @@
                                ((rsc/coercer :json) schema))))
                    params (coercer fields)]
                (if-not (schema.utils/error? params)
-                 (assoc-in ctx [:parameters (if (:form schemas) :form :body)] params)
+                 (-> ctx
+                     (assoc-in [:parameters (if (:form schemas) :form :body)] params)
+                     (assoc :yada.multipart/parts parts))
                  (d/error-deferred (ex-info "Bad form fields"
                                             {:status 400 :error (schema.utils/error-val params)}))))

-             :otherwise (assoc ctx :body fields))))))))
+             ;; We add a low-level access to the actual parts (via
+             ;; :yada.multipart/parts) for users with more
+             ;; sophisticated requirements.
+             :otherwise (assoc ctx :body fields :yada.multipart/parts parts))))))))


Remove unused fn

Remove unused fn

--- src/vip/data_processor/db/postgres.clj
+++ src/vip/data_processor/db/postgres.clj
@@ -452,40 +452,3 @@
                   (log/error "Lazy failure case: " (.getMessage e))
                   chunked-rows)))]
         (trampoline chunked-rows)))))
-
-(defn lazy-select-fn [chunk-size query-fn]
-  (fn [& args]
-    (let [cursor-name (str (gensym "lazy_select_cursor"))
-          done? (atom false)
-          close-attempts (atom 0)
-          query (apply query-fn args)]
-      (korma/exec-raw
-       [(str "DECLARE " cursor-name " NO SCROLL CURSOR "
-             "WITH HOLD FOR "
-             query)])
-      (letfn [(chunked-rows []
-                (when @done?
-                  (swap! close-attempts inc))
-                (try
-                  (do
-                    (let [this-chunk (korma/exec-raw
-                                      [(str "FETCH " chunk-size
-                                            " FROM " cursor-name)]
-                                      :results)]
-                      (if (seq this-chunk)
-                        (do
-                          (lazy-cat
-                           this-chunk
-                           (trampoline chunked-rows)))
-                        (do
-                          (reset! done? true)
-                          (korma/exec-raw
-                           [(str "CLOSE " cursor-name)])
-                          nil))))
-                  (catch java.sql.SQLException e
-                    (if (> @close-attempts 30)
-                      (do
-                        (log/error "Tried to close cursor" cursor-name "too many times")
-                        nil)
-                      chunked-rows))))]
-        (trampoline chunked-rows)))))


Get the real ID back when we create a record

We have to do this as the node ID and the real ID are different

--- src/webapp/framework/client/neo4j.cljs
+++ src/webapp/framework/client/neo4j.cljs
@@ -54,23 +54,17 @@
 )

-(comment defn neo-id [x]
-  (comment  go
-      (get (first (<! (neo4j "START x = node(1) RETURN ID(x)" {} ) "x")) "ID(x)")
-  )
-)

-(comment go
-    (.log js/console (str  (first (<! (neo-id nil)))))

- )
+
+

 (defn create-neo4j-record [properties]
   (go
       (log
           (let [
-                 rr (<! (neo4j "CREATE (n {values}) return n" {:values properties}  ) )
+                 rr (<! (neo4j "CREATE (n {values}) return n, ID(n)" {:values properties}  ) )
                 ]
                (str
                    (merge
@@ -78,7 +72,7 @@
                          rr
                          "n")
                        {
-                            :id (neo-id (:self (get (first rr) "n")))
+                            :id (js/parseInt (get (first rr) "ID(n)"))
                         }
                      )

@@ -100,6 +94,19 @@
 )

+(defn count-all-neo4j-records-with-field [ field-name ]
+  (go
+     (get (first (<!
+             (neo4j "START x = node(*) WHERE has(x.age) RETURN count(x)" {} )
+     )) "count(x)")
+  )
+)
+
+
+(go
+    (log (<! (count-all-neo4j-records-with-field 1)))
+)
+

 (go


Restore a test case

Restore a test case

--- test/app/core_test.clj
+++ test/app/core_test.clj
@@ -9,7 +9,7 @@
 (deftest core-test
   (testing "detect-environment"
     (let [[cp sp unit] (detect-environment foo-java)]
-      ;; (is (.endsWith (first sp) "test/app/src/"))
+      (is (.endsWith (first sp) "test/app/src/"))
       (is (not-empty cp))
       ))


Fix core test on cljs

Fix core test on cljs

--- test/com/wsscode/pathom/core_test.cljc
+++ test/com/wsscode/pathom/core_test.cljc
@@ -968,7 +968,8 @@
       (is (= (parser {::p/entity {:foo {:bar "baz"}}} [{:foo [:bar]}
                                                        :off
                                                        :err])
-             {:com.wsscode.pathom.core/errors {[:err] "class clojure.lang.ExceptionInfo: Error - {}"}
+             {:com.wsscode.pathom.core/errors {[:err] #?(:clj  "class clojure.lang.ExceptionInfo: Error - {}"
+                                                         :cljs "Error - {}")}
               :foo                            {:bar "baz"}})))))

 (deftest test-find-closest-non-placeholder-parent-join-key


Add test for problem with defdispatch

Add test for problem with defdispatch

--- test/flatland/useful/dispatch_test.clj
+++ test/flatland/useful/dispatch_test.clj
@@ -1,10 +1,19 @@
 (ns flatland.useful.dispatch-test
   (:use clojure.test flatland.useful.dispatch
-        [clojure.walk :only [stringify-keys]]))
+        [clojure.walk :only [stringify-keys]])
+
+  ;; not used directly, but added to verify that imported functions aren't exposed via dispatcher
+  (:require [clojure.set :refer [rename-keys]]))

 (deftest test-dispatcher-fn
   (let [dispatch (dispatcher (fn [f & args] (symbol "clojure.core" f)))]
     (is (= "str5" (dispatch "str" 5)))))
+
+(deftest test-imported-functions
+  (let [fn-name 'flatland.useful.dispatch-test/rename-keys
+        dispatch (dispatcher (constantly fn-name))]
+    (prn (dispatch {:a 1} {:a :b}))
+    (is (thrown? Exception (dispatch {:a 1} {:a :b})))))

 (deftest test-dispatch
   (testing "simple dispatch"


Include the examples used in the wiki.

Include the examples used in the wiki.

--- test/midje/t_sweet.clj
+++ test/midje/t_sweet.clj
@@ -218,18 +218,38 @@
  3       2      2)

-(tabular
- (fact "only two numbers have the same sum and square"
-   (* ?n ?n) ?arrow (+ ?n ?n))
- ?n     ?arrow
- 0      =>
- 2      =>
- ;; Failure cases
- 1      =not=>
- 1000   =not=>
- ;; and so on
- )
-
+     (tabular
+      (fact "only two numbers have the same sum and square"
+        (* ?n ?n) ?arrow (+ ?n ?n))
+      ?n        ?arrow
+      0         =>
+      2         =>
+      ;; Failure cases
+      1         =not=>
+      (* 10 10) =not=>
+      ;; and so on
+      )
+
+(defn alive? [cell-status neighbor-count]
+  (cond (= cell-status :dead)
+        (= 3 neighbor-count)
+
+        :else
+        (some #{neighbor-count} #{2 3})))
+
+     (tabular
+      (fact "The rules of Conway's life"
+        (alive? ?cell-status ?neighbor-count) => ?expected)
+      ?cell-status   ?neighbor-count   ?expected
+      :alive         1                 falsey        ; underpopulation
+      :alive         2                 truthy
+      :alive         3                 truthy
+      :alive         4                 falsey        ; overpopulation
+
+      ;; A newborn cell has three parents
+      :dead          2                 falsey
+      :dead          3                 truthy
+      :dead          4                 falsey)

 (tabular
  (fact "nice fact properties are retained"
@@ -240,3 +260,7 @@
  ?result ?n ?intermediate
  (+ a 1)       1      1)

+     (tabular
+      (future-fact (inc ?int) => ?int)
+      ?int
+      1)


Small style changes in problem64.clj

Small style changes in problem64.clj

--- euler_clojure/src/euler/problem64.clj
+++ euler_clojure/src/euler/problem64.clj
@@ -16,26 +16,26 @@

   Exactly four continued fractions, for N <= 13, have an odd period. How many
   continued fractions for N <= 10000 have an odd period?"
-  (:require [clojure.math.numeric-tower :as math]))
+  (:require [clojure.math.numeric-tower :refer [expt floor sqrt]]))

 (defn continued-fraction-sqrt [S]
   ;; https://en.wikipedia.org/wiki/Methods_of_computing_square_roots#Continued_fraction_expansion
   ;; Using variables S, m, d, a as in the URL above.
-  (let [root (math/sqrt S)]
-    (if (= root (math/floor root))
+  (let [root (sqrt S)]
+    (if (= root (floor root))
       [root]
       (loop [seen []
              m 0
              d 1
-             a (math/floor (math/sqrt S))]
+             a (floor (sqrt S))]
         (let [next-seen (conj seen {:m m, :d d, :a a})
               next-m (- (* d a) m)
-              next-d (/ (- S (math/expt next-m 2)) d)
-              next-a (math/floor (/ (+ (math/floor (math/sqrt S)) next-m) next-d))]
+              next-d (/ (- S (expt next-m 2)) d)
+              next-a (floor (/ (+ (floor (sqrt S)) next-m) next-d))]
           ;; If the pattern repeats, return all the 'a' variables collected in order.
           ;; Otherwise, continue the recursion.
           (if (some #(= % {:m next-m, :d next-d, :a next-a}) next-seen)
-            (vec (for [x next-seen] (get x :a)))
+            (map :a next-seen)
             (recur next-seen
                    next-m
                    next-d


CMR-2482: Modified search-app to create tag-associations as its own concept.

--- search-app/src/cmr/search/services/tagging_service.clj
+++ search-app/src/cmr/search/services/tagging_service.clj
@@ -4,6 +4,7 @@
             [cmr.common.mime-types :as mt]
             [cmr.transmit.echo.tokens :as tokens]
             [cmr.common.services.errors :as errors]
+            [cmr.common.services.messages :as cmsg]
             [cmr.common.validations.core :as v]
             [cmr.common.concepts :as concepts]
             [cmr.search.services.tagging.tagging-service-messages :as msg]
@@ -138,41 +139,64 @@
           (dissoc :revision-date)
           (update-in [:revision-id] inc)))))

+(defn- delete-tag-association
+  "Delete the tag association with the given native-id"
+  [context native-id]
+  (let [existing-concept (first (mdb/find-concepts context
+                                                   {:native-id native-id
+                                                    :exclude-metadata true
+                                                    :latest true}
+                                                   :tag-association))
+        concept-id (:concept-id existing-concept)]
+    (when-not concept-id
+      (errors/throw-service-error
+        :not-found (cmsg/invalid-native-id-msg :tag-association "CMR" native-id)))
+    (when (:deleted existing-concept)
+      (errors/throw-service-error
+        :not-found (format "Concept with native-id [%s] and concept-id [%s] is already deleted."
+                           native-id concept-id)))
+    (let [concept {:concept-type :tag-association
+                   :concept-id concept-id
+                   :deleted true}
+          {:keys [revision-id]} (mdb/save-concept context concept)]
+      {:concept-id concept-id, :revision-id revision-id})))
+
 (defn- update-tag-associations-with-query
-  "Modifies a tags associations. Finds collections using the query and then passes the existing
-  associated collection ids and the ones found from the query to the function. Sets the collection
-  ids as the result of the function."
-  [context concept-id json-query update-fn]
+  "Based on the input operation type (:insert or :delete), insert or delete tag associations
+  identified by the json query."
+  [context concept-id json-query operation]
   (let [query (-> (jp/parse-json-query :collection {} json-query)
                   (assoc :page-size :unlimited
                          :result-format :query-specified
                          :fields [:concept-id]
                          :skip-acls? false))
-        concept-id-set (->> (qe/execute-query context query)
-                            :items
-                            (map :concept-id)
-                            set)
+        coll-concept-ids (->> (qe/execute-query context query)
+                              :items
+                              (map :concept-id))
         existing-concept (fetch-tag-concept context concept-id)
-        existing-tag (edn/read-string (:metadata existing-concept))
-        updated-tag (update-in existing-tag [:associated-concept-ids]
-                               #(update-fn % concept-id-set))]
-    (mdb/save-concept
-      context
-      (-> existing-concept
-          (assoc :metadata (pr-str updated-tag)
-                 :user-id (context->user-id context))
-          (dissoc :revision-date)
-          (update-in [:revision-id] inc)))))
+        tag-key (:native-id existing-concept)]
+    ;; save tag-association for each collection concept-id
+    (for [coll-concept-id coll-concept-ids
+          :let [native-id (str tag-key native-id-separator-character coll-concept-id)]]
+      (if (= :insert operation)
+        (mdb/save-concept context {:concept-type :tag-association
+                                   :native-id native-id
+                                   :user-id (context->user-id context)
+                                   :format (mt/format->mime-type :edn)
+                                   :metadata (pr-str {:tag-key tag-key
+                                                      :associated-concept-id coll-concept-id})
+                                   :extra-fields {:associated-concept-id coll-concept-id}})
+        (delete-tag-association context native-id)))))

 (defn associate-tag-by-query
   "Associates a tag with collections that are the result of a JSON query"
   [context concept-id json-query]
-  (update-tag-associations-with-query context concept-id json-query set/union))
+  (update-tag-associations-with-query context concept-id json-query :insert))

 (defn disassociate-tag-by-query
   "Disassociates a tag with collections that are the result of a JSON query"
   [context concept-id json-query]
-  (update-tag-associations-with-query context concept-id json-query set/difference))
+  (update-tag-associations-with-query context concept-id json-query :delete))

 (defn search-for-tags
   "Searches for tags with the given result formats. Returns the results as a string."


Enable pretty hooks for logging

Enable pretty hooks for logging

--- dev-resources/user.clj
+++ dev-resources/user.clj
@@ -2,8 +2,11 @@
   (:use
     clojure.repl
     io.aviso.repl
+    io.aviso.logging
     speclj.config))

 (install-pretty-exceptions)
+(install-pretty-logging)
+(install-uncaught-exception-handler)

 (alter-var-root #'default-config assoc :color true :reporters ["documentation"])


Print full ac-entry, debugging for #183

Print full ac-entry, debugging for #183

--- src/cljs/clojuredocs/mods/search.cljs
+++ src/cljs/clojuredocs/mods/search.cljs
@@ -86,7 +86,7 @@
     (= "namespace" type) ($ac-entry-ns ac-entry)

     (= "page" type) ($ac-entry-page ac-entry)
-    :else (.log js/console (str "Couldn't render ac entry:" type))))
+    :else (.log js/console (str "Couldn't render ac entry:" (pr-str ac-entry)))))

 (defn focused? [$el]
   (= $el (.-activeElement js/document)))


Pass completion context as string

Pass completion context as string

--- src/clojure/nightcode/completions.clj
+++ src/clojure/nightcode/completions.clj
@@ -34,7 +34,6 @@
         (static-analysis/top-level-code-form caretpos)
         first
         loc-utils/node-text
-        read-string
         (try (catch Exception _)))))

 (defn get-clojure-completions


Set filter freq to zero, because without that, the default value was interfering with the connected value.

--- src/klangmeister/sound/synthesis.cljs
+++ src/klangmeister/sound/synthesis.cljs
@@ -29,7 +29,7 @@
   [& corners]
   (fn [context at duration]
     (let [audio-node (.createGain context)]
-      (-> audio-node .-gain (.setValueAtTime 0.0 at))
+      (-> audio-node .-gain (.setValueAtTime 0 at))
       (reduce
         (fn [x [dx y]]
           (-> audio-node .-gain (.linearRampToValueAtTime y (+ x dx)))
@@ -121,6 +121,7 @@
   ([type freq]
    (fn [context at duration]
      (doto (.createBiquadFilter context)
+       (-> .-frequency .-value (set! 0))
        (-> .-frequency (plug freq context at duration))
        (-> .-type (set! type))))))


fixed formatting

fixed formatting

--- src/leiningen/new/reagent/project.clj
+++ src/leiningen/new/reagent/project.clj
@@ -84,7 +84,7 @@
                                     :rules :cljs}]}
                    {{/cljx-build?}}
                    :cljsbuild {:builds {:app {:source-paths ["env/dev/cljs"]
-                                              :compiler {   :main "{{name}}.dev"
+                                              :compiler {:main "{{name}}.dev"
                                                          :source-map true}}
                                         {{#test-hook?}}
                                         :test {:source-paths ["src/cljs" {{{cljx-cljsbuild-spath}}} "test/cljs"]


Add some type hints to the new emit event code

--- src/main/clojure/clojure/data/xml.clj
+++ src/main/clojure/clojure/data/xml.clj
@@ -35,13 +35,13 @@
 (defrecord CData [content])
 (defrecord Comment [content])

-(defn emit-start-tag [event writer]
+(defn emit-start-tag [event ^javax.xml.stream.XMLStreamWriter writer]
   (let [nspace (namespace (:name event))
         qname (name (:name event))]
     (.writeStartElement writer "" qname (or nspace ""))
     (write-attributes (:attrs event) writer)))

-(defn emit-event [event writer]
+(defn emit-event [event ^javax.xml.stream.XMLStreamWriter writer]
   (case (:type event)
     :start-element (emit-start-tag event writer)
     :end-element (.writeEndElement writer)


serves images from cdn

serves images from cdn

--- frontend/components/integrations.cljs
+++ frontend/components/integrations.cljs
@@ -122,19 +122,20 @@
                    [:div.docker-features
                     [:div.feature-container
                      [:div.feature
-                      [:img {:src "/icons/cloud-circle.png"}]
+                      [:img {:src (utils/cdn-path "/icons/cloud-circle.png")}]
                       [:h3 "Continous Deployment of your Docker images"]
                       [:p
                        "CircleCI makes it easy to deploy images to Docker Hub as well as to continuously deploy applications to AWS Elastic Beanstalk, Google Compute Engine, and others."]
                       [:a {:href "/docs/docker"} "docs"]]
                      [:div.feature
-                      [:img {:src "/icons/scale-circle.png"}]
+                      [:img {:src (utils/cdn-path "/icons/scale-circle.png")}]
+
                       [:h3 "Dev-production parity"]
                       [:p
                        "Docker containers let you remove almost all of the variables that differ between your test and production environments. You can specify everything from your Linux distro to what executables run at startup in a Dockerfile, build all of that information into a Docker image, test it, and deploy the exact same image byte-for-byte to production. You can now run this entire process on CircleCI."]
                       [:a {:href "/docs/docker"} "docs"]]
                      [:div.feature
-                      [:img {:src "/icons/wrench-circle.png"}]
+                      [:img {:src (utils/cdn-path "/icons/wrench-circle.png")}]
                       [:h3 "Full Docker functionality"]
                       [:p
                        "You can now use all Docker functionality within the CircleCI build environment. All of the usual Docker command-line commands work as expected, so you can build and run Docker containers to your heart's content."]


enable-console-print!

enable-console-print!

--- labs/architecture-examples/om/src/todomvc/app.cljs
+++ labs/architecture-examples/om/src/todomvc/app.cljs
@@ -5,6 +5,8 @@
             [om.dom :as dom :include-macros true]
             [todomvc.utils :refer [pluralize now guid]]
             [todomvc.item :as todo-item]))
+
+(enable-console-print!)

 (def ENTER_KEY 13)


Handle not_running job status

Handle not_running job status

--- src-cljs/frontend/send.cljs
+++ src-cljs/frontend/send.cljs
@@ -27,14 +27,16 @@
           (recur))))
     ch))

+(defn- job-run-status [job-status-str]
+  (case job-status-str
+    ("fixed" "success") :job-run-status/succeeded
+    "failed" :job-run-status/failed
+    ("canceled" "not_running") :job-run-status/canceled
+    "running" :job-run-status/running
+    ("waiting" "queued") :job-run-status/waiting))
+
 (defn adapt-to-job [job-response]
-  (let [status->job-run-status {"fixed" :job-run-status/succeeded
-                                "success" :job-run-status/succeeded
-                                "failed" :job-run-status/failed
-                                "canceled" :job-run-status/canceled
-                                "running" :job-run-status/running
-                                "waiting" :job-run-status/waiting}]
-    (update job-response :job/status status->job-run-status)))
+  (update job-response :job/status job-run-status))

 (defn- compute-run-stop-time [jobs]
   (some->> jobs
@@ -43,24 +45,26 @@
            time/latest
            time-coerce/to-date))

-(def ^:private status->run-status {"success" :run-status/succeeded
-                                   "failed" :run-status/failed
-                                   "running" :run-status/running
-                                   "not_run" :run-status/not-run
-                                   "canceled" :run-status/canceled})
+(defn- run-status [run-status-str]
+  (case run-status-str
+    "success" :run-status/succeeded
+    "failed" :run-status/failed
+    "running" :run-status/running
+    "not_run" :run-status/not-run
+    "canceled" :run-status/canceled))

 (defn adapt-to-run
   [response]
-  (let [run-status (-> response :workflow/status status->run-status)
+  (let [status (-> response :workflow/status run-status)
         jobs (mapv adapt-to-job (:workflow/jobs response))]
     {:run/id (:workflow/id response)
      :run/name (:workflow/name response)
      :run/project {:project/name (get-in response [:workflow/trigger-resource :data :reponame])
                    :project/organization {:organization/name (get-in response [:workflow/trigger-resource :data :username])
                                           :organization/vcs-type "github"}}
-     :run/status run-status
+     :run/status status
      :run/started-at (:workflow/created-at response)
-     :run/stopped-at (if (#{:run-status/running :run-status/not-run} run-status)
+     :run/stopped-at (if (#{:run-status/running :run-status/not-run} status)
                        nil
                        (compute-run-stop-time jobs))
      :run/branch-name (get-in response [:workflow/trigger-resource :data :branch])


init commit

init commit

--- env/prod/clj/todomvc/prod_server.clj
+++ env/prod/clj/todomvc/prod_server.clj
@@ -6,6 +6,7 @@
    :web-port (or (System/getenv "PORT") 8081)})

 (defn -main [& args]
+  (println "Starting on port " (:web-port config))
   (todomvc/dev-start config)
   (println (str "Started server on port " (:web-port config)))
   (.addShutdownHook (Runtime/getRuntime)


Type-hint array-eq

Type-hint array-eq

--- src/caesium/crypto/util.clj
+++ src/caesium/crypto/util.clj
@@ -1,7 +1,9 @@
 (ns caesium.crypto.util
   (:import (java.util Arrays)))

-(defn array-eq [a b] (Arrays/equals a b))
+(defn array-eq [^bytes a ^bytes b]
+  "Compares two byte arrays for equality."
+  (Arrays/equals a b))

 (defn unhexify [s]
   (let [encoded-bytes (partition 2 s)


fixing resolve fn logging

fixing resolve fn logging

--- src/celestial/workflows.clj
+++ src/celestial/workflows.clj
@@ -43,7 +43,7 @@
   "Runs hooks"
   [args workflow event]
   (doseq [[f conf] (get! :hooks)]
-    (debug "running hook"  f (resolve f))
+    (debug "running hook" f (resolve- f))
     (try
       ((resolve- f) (merge args conf {:workflow workflow :event event}))
       (catch Throwable t (error t))


Toast on taking a tag.

Toast on taking a tag.

--- src/clj/game/core-rules.clj
+++ src/clj/game/core-rules.clj
@@ -150,6 +150,7 @@
 (defn resolve-tag [state side n args]
   (when (pos? n)
     (gain state :runner :tag n)
+    (toast state side (str "Took " n " tag" (when (> n 1) "s") "!") "info")
     (trigger-event state side :runner-gain-tag n)))

 (defn tag-runner


Execute SPARQL queries

Execute SPARQL queries

--- src/clj/sparqlab/sparql.clj
+++ src/clj/sparqlab/sparql.clj
@@ -1,13 +1,57 @@
 (ns sparqlab.sparql
+  (:require [sparqlab.config :refer [env]]
+            [clj-http.client :as client])
   (:import [org.apache.jena.query Query QueryFactory]))

-(defn equal-parsed-query?
-  "Test if queries `q1` and `q2` are equal when parsed."
-  [q1 q2]
-  (= (QueryFactory/create q1) (QueryFactory/create q2)))
+(derive ::describe ::construct)
+
+(defn get-query-type
+  [^Query query]
+  (let [query-type (.getQueryType query)]
+    (condp = query-type
+      Query/QueryTypeAsk ::ask
+      Query/QueryTypeSelect ::select
+      Query/QueryTypeDescribe ::describe)))
+
+(defn get-results-type
+  [query-type]
+  (cond (or (= query-type ::ask) (= query-type ::select)) "application/json"
+        (isa? query-type ::construct) "text/turtle"))
+
+(defmulti normalize-query-results (fn [query-type _] query-type))
+
+(defmethod normalize-query-results ::ask
+  [_ query-results])
+
+(defmethod normalize-query-results ::construct
+  [_ query-results])
+
+(defmethod normalize-query-results ::select
+  [_ query-results])
+
+(defn sparql-query
+  [endpoint query-type query]
+  (let [accept (cond (or (= query-type ::select) (= query-type ::ask)) "application/sparql-results+json,*/*;q=0.9"
+                     (isa? query-type ::construct) "text/turtle,*/*;q=0.9")]
+    (:body (client/get endpoint {:headers {:accept accept}
+                                 :query-params {"query" query}}))))

 (defn equal-query?
-  "Test if queries `q1` and `q2` are equal."
-  [q1 q2]
-  (or (= q1 q2)
-      (equal-parsed-query? q1 q2)))
+  "Test if `query` is equal to the `canonical-query`."
+  [canonical-query query]
+  (let [canonical-query' (QueryFactory/create canonical-query)
+        query' (QueryFactory/create query)
+        endpoint (:sparql-endpoint env)
+        canonical-query-type (get-query-type canonical-query')
+        canonical-results (sparql-query endpoint canonical-query-type canonical-query)
+        query-type (get-query-type query')
+        query-results (sparql-query endpoint query-type query)]
+    {:canonical-query {:query (.serialize canonical-query')
+                       :results canonical-results
+                       :results-type (get-results-type canonical-query-type)}
+     :query {:query (.serialize query')
+             :results query-results
+             :results-type (get-results-type query-type)}
+     :equal? (or (= canonical-query query)
+                 (= canonical-query' query')
+                 (= canonical-results query-results))}))


fix rollcage

fix rollcage

--- src/clj/tictag/rollcage.clj
+++ src/clj/tictag/rollcage.clj
@@ -5,9 +5,10 @@
 (defrecord RollcageClient [token environment]
   component/Lifecycle
   (start [component]
-    (let [client (rollcage/client token {:environment environment})]
-      (rollcage/setup-uncaught-exception-handler client)
-      (assoc component :client client)))
+    (when (and environment token)
+      (let [client (rollcage/client token {:environment environment})]
+        (rollcage/setup-uncaught-exception-handler client)
+        (assoc component :client client))))
   (stop [component]
-    (dissoc component :client)))
+    {}))


Move db below system

Move db below system

--- src/clj/traveler/system.clj
+++ src/clj/traveler/system.clj
@@ -10,11 +10,11 @@
 (defn conf []
   (t-conf/load-config))

+(def system
+  {:web (atom nil) :db (atom nil)})
+
 (def db
   (d/db @(:db system)))
-
-(def system
-  {:web (atom nil) :db (atom nil)})

 (defn start-http []
    (reset! (:web system) (run-server t-core/app {:port (get-in (conf) [:web :port])})))


fixed require

fixed require

#215

--- src/cljs/swarmpit/view.cljs
+++ src/cljs/swarmpit/view.cljs
@@ -4,7 +4,7 @@
             [swarmpit.component.page-404 :as page-404]
             [swarmpit.component.page-error :as page-error]
             [swarmpit.component.password :as password]
-            [swarmpit.component.api_access :as api-access]
+            [swarmpit.component.api-access :as api-access]
             [swarmpit.component.stack.edit :as stack-edit]
             [swarmpit.component.stack.compose :as stack-compose]
             [swarmpit.component.stack.create :as stack-create]


make suggestion a reaction

make suggestion a reaction

--- src/cljs/triboard/core.cljs
+++ src/cljs/triboard/core.cljs
@@ -28,21 +28,26 @@
 ;; APP STATE
 ;; -----------------------------------------

+(def is-ai? #{:red :green})
+(def ai-move-delay 1000)
+
 (defonce app-state
   (atom {:game (game/new-game)
          :help false}))

 (def current-turn (reaction (game/current-turn (:game @app-state))))
 (def current-player (reaction (turn/get-player @current-turn)))
-(def help-toggled? (reaction (:help @app-state)))
+
+(def suggestions
+  (reaction
+    (if (and (:help @app-state) (not (is-ai? @current-player)))
+      (turn/get-moves-of @current-turn @current-player)
+      {})))

 ;; -----------------------------------------
 ;; GAME LOOP
 ;; -----------------------------------------
-
-(def is-ai? #{:red :green})
-(def ai-move-delay 1000)

 (defn play-game-turn! [move]
   (swap! app-state update-in [:game] game/play-move move))
@@ -90,14 +95,8 @@
 ;; PLUGGING THE BLOCKS
 ;; -----------------------------------------

-(defn get-suggestions
-  []
-  (if (and @help-toggled? (not (is-ai? @current-player)))
-    (turn/get-moves-of @current-turn @current-player)
-    {}))
-
 (defn run-game []
-  (frame/main-frame @current-turn (get-suggestions)
+  (frame/main-frame @current-turn @suggestions
     (reify view/CallBacks
       (on-new-game [_] (send-game-event! :new-game))
       (on-toogle-help [_] (toogle-help!))


make note to help change derivative keys without re-parsing

--- src/cljs_api_gen/result.clj
+++ src/cljs_api_gen/result.clj
@@ -111,6 +111,9 @@
       (mapv #(signature->usage % item) signature))
     item))

+;; FIXME:
+;; Make this a pre-transform step when merging manual docs onto final result
+;; so we can update the way this is calculated without running a full re-parse.
 (defn transform-item
   [x]
   (-> x


Rename descriptor instead of deleting it on deactivate

--- src/containium/deployer.clj
+++ src/containium/deployer.clj
@@ -73,14 +73,26 @@
                  (swap! descriptors assoc name (update-in descriptor [:file] str)))

                :deactivate
-               (.delete (file dir name))
+               (loop [postfix nil]
+                 (when (.exists (file dir name))
+                   (when-not (.renameTo (file dir name)
+                                        (file dir (str name
+                                                       (when postfix (str "-" postfix))
+                                                       ".deactivated")))
+                     (recur (inc (or postfix 0))))))

                :status
                (spit (file dir (str name ".status"))
                      (clojure.core/name (:data msg)))

                :kill
-               (.delete (file dir name))
+               (loop [postfix nil]
+                 (when (.exists (file dir name))
+                   (when-not (.renameTo (file dir name)
+                                        (file dir (str name
+                                                       (when postfix (str "-" postfix))
+                                                       ".deactivated")))
+                     (recur (inc (or postfix 0))))))

                :finished
                (let [response (:data msg)]


Replace load with simple require directives.

--- src/continuo/postgresql.clj
+++ src/continuo/postgresql.clj
@@ -13,7 +13,6 @@
 ;; limitations under the License.

 (ns continuo.postgresql
-  "A postgresql transactor main namespace.")
-
-(load "postgresql/connection")
-(load "postgresql/bootstrap")
+  "A postgresql transactor main namespace."
+  (:require [continuo.postgresql.connection]
+            [continuo.postgresql.bootstrap]))


add method for load fontset

add method for load fontset

Signed-off-by: Yen-Chin Lee <082d453d72dce940e12089a4ad48b97cfe1f3ec4@gmail.com>

--- src/emulator_chip8/cpu.cljc
+++ src/emulator_chip8/cpu.cljc
@@ -53,8 +53,8 @@
 (defn reset-cpu
   "Reset the full cpu state."
   []
-  (make-cpu))
-
+  (-> (make-cpu)
+      load-fontset))

 ;; Default fontsets, it will be add to memory
 (def fontset
@@ -75,3 +75,10 @@
    0xF0 0x80 0xF0 0x80 0xF0 ; E
    0xF0 0x80 0xF0 0x80 0x80 ; F
    ])
+
+(defn load-fontset
+  "load fonts to chip8's memory."
+  [state]
+  (let [memory (:memory state)
+        c (count memory)]
+    (merge state {:memory (vec (take c (into fontset memory)))})))


Disable AnimateProps

Disable AnimateProps

--- src/examples/components.clj
+++ src/examples/components.clj
@@ -96,7 +96,7 @@
                                                      :left 0
                                                      :position :absolute}} [
                                        [zcui/Image {:src "/home/santos/src/zaffre/earthmap.jpg"}]]]]]
-                                     [zcui/AnimateProps {:gen (fn [state-chan open-chan]
+                                     #_[zcui/AnimateProps {:gen (fn [state-chan open-chan]
                                                                  (let [x-min 4
                                                                        y-min 4
                                                                        x-max 16


First descriptions compile.

First descriptions compile.

--- src/exp/2d_manipulation.clj
+++ src/exp/2d_manipulation.clj
@@ -15,7 +15,7 @@
 ; Seems we need all the angelic machinery we had before, in general case.

 ;; State variables are (all keyworded, note!):
-; :const {[size] [freespace] [legal-go] [goal o] [base-offsets] [n-base-samples] [map]...}
+; :const {[size] [freespace] [legal-go] [max-go] [goal o] [base-offsets] [n-base-samples] [map]...}
 ;    freespace is set of free [x y] pairs (for base).
 ;    legal-go is set of allowed [gxo gyo] pairs
 ;    goal is now set of allowed positions. Previously: [[minx miny] [maxx maxy]] range -- inclusive.
@@ -170,6 +170,7 @@
         legal-go       (set (spiral-to g-rad))]
     (env/SimpleFactoredEnv
      (into {:const (into {[:size] size [:freespace] freespace [:legal-go] legal-go [:objects] objects
+                          [:max-go] g-rad
                           [:base-offsets] (pseudo-shuffle random (spiral-to (inc g-rad)) )
                           [:n-base-samples] n-base-samples
 ;                          [:nav-slack] 1 ; Intentional error in nav/reach descs. >= 1.
@@ -255,10 +256,10 @@

 (defn reach-context
-  ([s] (reach-context s (env/get-var s [:base])))
-  ([s base]
+  ([s] (reach-context (env/get-var s :const) (env/get-var s [:base])))
+  ([const base]
     (into #{[:base] [:gripper-offset]}
-      (for [go (util/safe-get (env/get-var s :const) [:legal-go])]
+      (for [go (util/safe-get const [:legal-go])]
         [:object-at (add-pos base go)]))))

 (defn manhattan-distance [[x1 y1] [x2 y2]]
@@ -274,12 +275,15 @@
       (and (can-directly-nav-dir? free-fn l1 [x2 y1] [-1 0])
            (can-directly-nav-dir? free-fn [x2 y1] l2 [0 (util/signum (- y2 y1))]))))

-(defn can-reach-from? [s base dst-go]
-  (let [const (env/get-var s :const)]
-    (and (contains? (const [:legal-go]) dst-go)
-         (contains? (const [:freespace]) (add-pos dst-go base)))))
-
-(defn can-reach? [s dst-go] (can-reach-from? s (env/get-var s [:base]) dst-go))
+(defn can-reach-from? [const base dst-go]
+  (and (contains? (const [:legal-go]) dst-go)
+       (contains? (const [:freespace]) (add-pos dst-go base))))
+
+(defn can-reach? [s dst-go] (can-reach-from? (env/get-var s :const) (env/get-var s [:base]) dst-go))
+
+(defn can-span? [const l1 l2]
+  (<= (manhattan-distance l1 l2)
+      (+ 2 (* 2 (get const [:max-go])))))

 (defn move-gripper-reward [src dst] (* move-gripper-step-reward (manhattan-distance src dst)))

@@ -308,10 +312,10 @@
                                      (move-gripper-reward go dst-go)}
                                     {}))))))

-(defn possible-grasp-gos [s base pos]
+(defn possible-grasp-gos [const base pos]
   (for [[dirname dir] dirs
         :let [go (sub-pos (sub-pos pos dir) base)]
-        :when (can-reach-from? s base go)]
+        :when (can-reach-from? const base go)]
       go))

 ;; TODO: slack? pess?
@@ -334,7 +338,7 @@
   env/AngelicAction         (optimistic-map [s]
                               (let [opos (env/get-var s [:pos o])]
                                 (into {}
-                                 (for [go (possible-grasp-gos s (env/get-var s [:base]) opos)]
+                                 (for [go (possible-grasp-gos (env/get-var s :const) (env/get-var s [:base]) opos)]
                                    [(env/set-vars s [[[:gripper-offset] go]
                                                      [[:pos o] nil] [[:holding] o]
                                                      [[:object-at opos] nil]])
@@ -342,6 +346,14 @@
                                        (move-gripper-reward (env/get-var s [:gripper-offset]) go))]))))
                             (pessimistic-map [s] {})))

+(defn drop-reward [base init-go o-dst]
+  (let [rel-o-dst (sub-pos o-dst base)]
+    (+ putdown-reward
+       (min (move-gripper-reward init-go [0 0])
+            (+ (move-gripper-reward init-go rel-o-dst)
+               (move-gripper-reward rel-o-dst [0 0])
+               (* -2 move-gripper-step-reward))))))
+
 ;; TODO: slack, pess ?
 (defn make-drop-at-hla [env o dst]
  (reify :as this
@@ -356,17 +368,24 @@
                                            go   (sub-pos gpos base)
                                            a    (make-reach-hla env go)]
                                      :when a]
-                                 [a (make-putdown dirname base go o dst)])))
+                                 [a (make-putdown dirname base go o dst) (make-reach-hla env [0 0])])))
                             (cycle-level- [s] nil)
   env/AngelicAction         (optimistic-map [s]
-                                (into {}
-                                 (for [go (possible-grasp-gos s (env/get-var s [:base]) dst)]
-                                   [(env/set-vars s [[[:gripper-offset] go]
-                                                     [[:pos o] dst] [[:holding] nil]
-                                                     [[:object-at dst] o] [[:at-goal? o] true]])
-                                    (+ putdown-reward
-                                       (move-gripper-reward (env/get-var s [:gripper-offset]) go))])))
+                              {(env/set-vars s [[[:gripper-offset] [0 0]]
+                                                [[:pos o] dst] [[:holding] nil]
+                                                [[:object-at dst] o] [[:at-goal? o] true]])
+                               (drop-reward (env/get-var s [:base])
+                                            (env/get-var s [:gripper-offset]) dst )})
                             (pessimistic-map [s] {})))
+
+; Old version -- not forced back to origin.
+;                                (into {}
+;                                 (for [go (possible-grasp-gos (env/get-var s :const) (env/get-var s [:base]) dst)]
+;                                   [(env/set-vars s [[[:gripper-offset] go]
+;                                                     [[:pos o] dst] [[:holding] nil]
+;                                                     [[:object-at dst] o] [[:at-goal? o] true]])
+;                                    (+ putdown-reward
+;                                       (move-gripper-reward (env/get-var s [:gripper-offset]) go))]))
 ;manhattan
 ;pess: SLD?

@@ -421,7 +440,7 @@
                             (cycle-level- [s] nil)
   env/AngelicAction         (optimistic-map [s]
                                {(env/set-vars s [[[:base] dst] [[:gripper-offest] [0 0]]])
-                                (move-base-reward (env/get-var s [:base]) dst)})
+                                (move-base-reward (env/get-var s [:base]) dst (env/get-var s [:gripper-offset]))})
                             (pessimistic-map [s] {})))

 ;                              (let [base (env/get-var s [:base])
@@ -432,23 +451,34 @@
 ;                                  {}))

-(defn move-to-front [x s]
-  (if (some #{x} s)
-      (cons x (remove #{x} s))
-    s))

 ;; TODO: check out state abstraction here
 ;; Note: since we may not sample current position, have to special case.

-(defn possible-grasp-base-pos [s grasp-pos]
-  (let [const (env/get-var s :const)
-        base  (env/get-var s [:base])
-        free  (get const [:freespace])]
-    (->> (get const [:base-offsets])
-         (map #(add-pos % grasp-pos))
-         (filter free)
-         (move-to-front base)
-         (take (get const [:n-base-samples])))))
+(defn possible-grasp-base-pos
+  ([s grasp-pos]
+     (possible-grasp-base-pos (env/get-var s :const) (env/get-var s [:base]) grasp-pos))
+  ([const base grasp-pos]
+     (let [free  (get const [:freespace])
+           candidates (->> (get const [:base-offsets])
+                           (map #(add-pos % grasp-pos))
+                           (filter free))]
+       (if (some #{base} candidates)
+         (cons base (remove #{base} (take (get const [:n-base-samples]) candidates)))
+         (take (get const [:n-base-samples]) candidates)))))
+
+;(defn possible-putdown-base-pos [const init-base init-loc drop-loc]
+;  (let [free  (get const [:freespace])
+;        pickup-candidates (--> (get const [:base-offsets])
+;                               (map #(add-pos % init-loc))
+;                               (filter free))
+;        selected-pickups (util/cons-when (when (some #{init-base} pickup-candidates) init-base)
+;                                         (take (get const [:n-base-samples]) candidates))
+;        candidates (->> (get const [:base-offsets])
+;                        (map #(add-pos % grasp-pos))
+;                        (filter free))
+;        candidate-set (set candidates)]
+;    (distinct (concat (filter candidate-set selected-pickups) (take (get const [:n-base-samples]) candidates)))))

 ;; TODO: pess
@@ -457,7 +487,7 @@
   env/Action                (action-name [] [:go-grasp o])
                             (primitive? [] false)
   env/ContextualAction      (precondition-context [s]
-                              (conj (reach-context s (env/get-var s [:pos o]))
+                              (conj (reach-context (env/get-var s :const) (env/get-var s [:pos o]))
                                     [:pos o] [:at-goal? o] [:holding]))
   hierarchy/HighLevelAction (immediate-refinements- [s]
                              (for [dst (possible-grasp-base-pos s (env/get-var s [:pos o]))]
@@ -468,32 +498,48 @@
                                     opos (env/get-var s [:pos o])]
                                (into {}
                                 (for [dst (possible-grasp-base-pos s opos),
-                                      go  (possible-grasp-gos s dst opos)]
+                                      go  (possible-grasp-gos (env/get-var s :const) dst opos)]
                                   [(env/set-vars s [[[:base] dst]
                                                     [[:gripper-offset] go]
                                                     [[:pos o] nil] [[:holding] o]
                                                     [[:object-at opos] nil]])
-                                   (+ (move-base-reward base dst)
+                                   (+ (move-base-reward base dst go)
                                       (move-gripper-reward
                                        (if (= base dst) (env/get-var s [:gripper-offset]) [0 0])
                                        go)
                                       pickup-reward)]))))
                             (pessimistic-map [s] {})))

+; old version -- not forced back to origin after drop.
+;(defn go-drop-at-opt [s o o-dst]
+;  (let [base (env/get-var s [:base])]
+;    (into {}
+;          (for [dst (possible-grasp-base-pos s o-dst),
+;                go  (possible-grasp-gos (env/get-var s :const) dst o-dst)]
+;            [(env/set-vars s [[[:base] dst]
+;                              [[:gripper-offset] go]
+;                              [[:pos o] o-dst] [[:holding] nil]
+;                              [[:object-at o-dst] o] [[:at-goal? o] true]])
+;             (+ (move-base-reward base dst)
+;                (move-gripper-reward
+;                 (if (= base dst) (env/get-var s [:gripper-offset]) [0 0])
+;                 go)
+;                putdown-reward)]))))
+
 (defn go-drop-at-opt [s o o-dst]
-  (let [base (env/get-var s [:base])]
+  (let [base (env/get-var s [:base])
+        go   (env/get-var s [:gripper-offset])]
     (into {}
-          (for [dst (possible-grasp-base-pos s o-dst),
-                go  (possible-grasp-gos s dst o-dst)]
-            [(env/set-vars s [[[:base] dst]
-                              [[:gripper-offset] go]
-                              [[:pos o] o-dst] [[:holding] nil]
-                              [[:object-at o-dst] o] [[:at-goal? o] true]])
-             (+ (move-base-reward base dst)
-                (move-gripper-reward
-                 (if (= base dst) (env/get-var s [:gripper-offset]) [0 0])
-                 go)
-                putdown-reward)]))))
+        (for [dst (possible-grasp-base-pos s o-dst)]
+          [(env/set-vars s [[[:base] dst]
+                            [[:gripper-offset] [0 0]]
+                            [[:pos o] o-dst] [[:holding] nil]
+                            [[:object-at o-dst] o] [[:at-goal? o] true]])
+             (+ (move-base-reward base dst go)
+                (if (= base dst)
+                   (drop-reward dst go o-dst)
+                   (+ (move-gripper-reward go [0 0])
+                      (drop-reward dst [0 0] o-dst))))]))))

 ;; Note: since we may not sample current position, have to special case.
 (defn make-go-drop-at-hla [env o o-dst]
@@ -501,7 +547,7 @@
   env/Action                (action-name [] [:go-drop-at o o-dst])
                             (primitive? [] false)
   env/ContextualAction      (precondition-context [s]
-                              (conj (reach-context s o-dst) [:holding]))
+                              (conj (reach-context (env/get-var s :const) o-dst) [:holding]))
   hierarchy/HighLevelAction (immediate-refinements- [s]
                               (for [dst (possible-grasp-base-pos s o-dst)]
                                 [(make-move-base-hla env dst) (make-drop-at-hla env o o-dst)]))
@@ -516,7 +562,7 @@
                             (primitive? [] false)
   env/ContextualAction      (precondition-context [s]
                               (conj (apply clojure.set/union
-                                     (map #(reach-context s %)
+                                     (map #(reach-context (env/get-var s :const) %)
                                           (get (env/get-var s :const) [:goal o])))
                                     [:holding]))
   hierarchy/HighLevelAction (immediate-refinements- [s]
@@ -524,42 +570,117 @@
                                [(make-go-drop-at-hla env o o-dst)]))
                             (cycle-level- [s] nil)
   env/AngelicAction         (optimistic-map [s]
-                              (apply merge-with max (map #(go-drop-at-opt s o %)
-                                                         (get (env/get-var s :const) [:goal o]))))
+                              (reduce util/merge-disjoint
+                                     (map #(go-drop-at-opt s o %)
+                                          (get (env/get-var s :const) [:goal o]))))
                             (pessimistic-map [s] {})))

+
+(defn move-to-goal-context [s o]
+  (conj (apply clojure.set/union
+               (map #(reach-context (env/get-var s :const) %)
+                    (cons (env/get-var s [:pos o])
+                          (get (env/get-var s :const) [:goal o]))))
+        [:holding]))
+
+(defn move-to-goal-opt [s o]
+  (assert (= (env/get-var s [:gripper-offest]) [0 0]))
+  (let [const (env/get-var s :const)
+        base (env/get-var s [:base])
+        o-pos (env/get-var s [:pos o])]
+    (reduce util/merge-disjoint
+            (for [o-dst (get const [:goal o])]
+              (merge-with max
+                          (into {}
+                                (for [b-med (possible-grasp-base-pos const base o-pos)
+                                      b-dst (possible-grasp-base-pos const b-med o-dst)]
+                                  [(env/set-vars s [[[:base] b-dst] [[:pos o] o-dst]
+                                                    [[:object-at o-pos] nil] [[:object-at o-dst] o]
+                                                    [[:at-goal? o] true]])
+                                   (+ (move-base-reward base b-med [0 0])
+                                      (move-base-reward b-med b-dst [0 0])
+                                      pickup-reward putdown-reward
+                                      (if (= b-med b-dst)
+                                        (max 0 (+ (move-gripper-reward [0 0] o-pos)
+                                                  (move-gripper-reward o-pos o-dst)
+                                                  (move-gripper-reward o-dst [0 0])
+                                                  (* -4 move-gripper-step-reward)))
+                                        (+ (max 0 (+ (move-gripper-reward [0 0] o-pos)
+                                                     (* -2 move-gripper-step-reward)))
+                                           (max 0 (+ (move-gripper-reward [0 0] o-dst)
+                                                     (* -2 move-gripper-step-reward))))))])))))))
+
+;; TODO: cache as much as this as we can ?
 (defn make-move-to-goal-hla [env o]
  (reify :as this
   env/Action                (action-name [] [:go-drop o])
                             (primitive? [] false)
-  env/ContextualAction      (precondition-context [s]
-                              (conj (apply clojure.set/union
-                                     (map #(reach-context s %)
-                                          (cons (env/get-var s [:pos o])
-                                                (get (env/get-var s :const) [:goal o]))))
-                                    [:holding]))
+  env/ContextualAction      (precondition-context [s] (move-to-goal-context s o))
   hierarchy/HighLevelAction (immediate-refinements- [s]
                               [[(make-go-grasp-hla env o) (make-go-drop-hla env o)]])
                             (cycle-level- [s] nil)
-  env/AngelicAction         (optimistic-map [s]
-                               ????????)
-                            (pessimistic-map [s] {})
-                            ))
+  env/AngelicAction         (optimistic-map [s] (move-to-goal-opt s o))
+                            (pessimistic-map [s] {})))

 (defn remaining-objects [s]
   (remove #(env/get-var s [:at-goal? %])
           (map first (get (env/get-var s :const) [:objects]))))

-;; TODO: shore these up a bit.
-;
-(defn object-reward [s o])
-(defn start-reward [s o])
-(defn finish-reward [s o] 0)
-(defn linkage-reward [s o1 o2])
+; reward to get from current base position to gripper-in-grasp-position
+(defn start-reward [s o]
+  (let [const (env/get-var s :const)
+        max-go (util/safe-get const [:max-go])
+        base (env/get-var s [:base])
+        o-pos (env/get-var s [:pos o])
+        dist   (dec (manhattan-distance base o-pos))]
+    (if (<= dist max-go)
+        (* move-gripper-step-reward dist)
+      (+ unpark-reward park-reward (* (- dist max-go) move-base-step-reward)
+         (* move-gripper-step-reward max-go)))))
+
+; reward to get from some dropoff base position of o1 to gripper-in-grasp-position for o2.
+(defn linkage-reward [s o1 o2]
+  (let [const    (env/get-var s :const)
+        max-go   (util/safe-get const [:max-go])
+        o1-goals (util/safe-get const [:goal o1])
+        o2-pos   (env/get-var s [:pos o2])
+        dist     (apply min (map #(manhattan-distance % o2-pos) o1-goals))]
+    (if (<= dist (+ 2 (* 2 max-go)))
+        (* move-gripper-step-reward (max 0 (- dist 2)))
+      (+ unpark-reward park-reward (* (- dist (+ 2 (* 2 max-go))) move-base-step-reward)
+         (* move-gripper-step-reward (* 2 max-go))))))
+
+; reward for gripper-in-grasp-position to object at goal, gripper at home.
+;; TODO: tighten this up?  right now, missing to-home part.
+(defn object-reward [s o]
+  (let [const   (env/get-var s :const)
+        max-go  (util/safe-get const [:max-go])
+        o-pos   (env/get-var s [:pos o])
+        goals   (util/safe-get const [:goal o])
+        dist    (apply min (map #(manhattan-distance % o-pos) goals))]
+    (+ pickup-reward putdown-reward
+     (if (<= dist (+ 2 (* 2 max-go)))
+       (* move-gripper-step-reward (max 0 (- dist 2)))
+       (+ unpark-reward park-reward (* (- dist (+ 2 (* 2 max-go))) move-base-step-reward)
+          (* move-gripper-step-reward (* 2 max-go)))))))
+
+
+(defn compute-match-edges
+  "Compute edges, except for start, for matching.  Each edge represents a bound on the reward to deliver the
+   second object, starting from a state just after the first object has been delivered.  :end represents
+   the reward to get to the final configuration, with the gripper home."
+  [s]
+  (let [objects (remaining-objects s)
+        object-rewards (for [o objects] [o (object-reward s o)])]
+    (concat
+     (for [o1 objects, [o2 or] object-rewards]
+       [o1 o2 (+ or (linkage-reward s o1 o2))])
+     (for [o objects] [o :finish 0]))))

 ;; TODO: can do better on context -- but probably rarely matters?
 (defn- make-tla [env]
- (let [context (util/keyset (dissoc (env/initial-state env) :const))]
+ (let [context (util/keyset (dissoc (env/initial-state env) :const))
+       match-edges (compute-match-edges (env/initial-state env))]
  (reify :as this
   env/Action                (action-name [] [:act])
                             (primitive? [] false)
@@ -572,15 +693,12 @@
                             (cycle-level- [s] 2)
  env/AngelicAction         (optimistic-map [s]
                              {(env/set-vars s (env/make-finish-goal-state env))
-                              (let [objects (remaining-objects s)
-                                    object-rewards (for [o objects] [o (object-reward s o)])]
-                                (util/maximum-matching (cons :start nodes) (cons :end nodes)
-                                  (concat
-                                   (for [[o or] object-rewards]
-                                     [:start o (+ or (start-reward s o))])
-                                   (for [o1 objects, [o2 or] object-rewards]
-                                     [n1 n2 (+ or (linkage-reward s o1 o2))])
-                                   (for [o objects] [o :finish (finish-reward s o)]))))})
+                              (let [objects (remaining-objects s),
+                                    s1 (set (cons :start objects)),
+                                    s2 (set (cons :finish objects))]
+                                (util/maximum-matching s1 s2
+                                  (concat (for [o objects] [:start o (start-reward s o)])
+                                          (filter (fn [[n1 n2]] (and (s1 n1) (s2 n2))) match-edges))))})
                            (pessimistic-map [s] {}))))

 (defn make-2d-manipulation-hierarchy [env]


Make sure we remove any pause registrations when pausing

--- src/exploud/deployments.clj
+++ src/exploud/deployments.clj
@@ -108,6 +108,7 @@

 (defn pause
   [{:keys [application environment id region]}]
+  (redis/unregister-pause application environment region)
   (redis/pause application environment id region))

 (defn resume


Make merge-sorted as lazy as possible

Make merge-sorted as lazy as possible

--- src/flatland/useful/seq.clj
+++ src/flatland/useful/seq.clj
@@ -268,11 +268,12 @@
      xs)
   ([comparator xs ys]
      (lazy-loop [xs xs, ys ys]
-       (if-let [[x & more-xs] (seq xs)]
-         (if-let [[y & more-ys] (seq ys)]
-           (if (comparator x y)
-             (cons x (lazy-recur more-xs ys))
-             (cons y (lazy-recur xs more-ys)))
+       (if-let [xs (seq xs)]
+         (if-let [ys (seq ys)]
+           (let [x (first xs), y (first ys)]
+             (if (comparator x y)
+               (cons x (lazy-recur (rest xs) ys))
+               (cons y (lazy-recur xs (rest ys)))))
            xs)
          ys)))
   ([comparator xs ys & more]


Korjattu typo versionumerossa

Korjattu typo versionumerossa

--- clj-cas/project.clj
+++ clj-cas/project.clj
@@ -1,4 +1,4 @@
-(defproject oph/clj-cas "0.6.4-SNAPSHOT"
+(defproject oph/clj-cas "0.6.1-SNAPSHOT"
   :description "oph clojure cas utilities"
   :url "http://example.com/FIXME"
   :license {:name "EUPL"


Clean up ns in core.

Clean up ns in core.

--- clj_record/core.clj
+++ clj_record/core.clj
@@ -1,9 +1,8 @@
 (ns clj-record.core
-  (:require [clojure.contrib.sql :as sql])
-  (:use clj-record.util)
-  (:use clj-record.config)
-  (:use clojure.contrib.str-utils)
-  (:use clojure.contrib.test-is))
+  (:require
+    [clojure.contrib.sql :as sql]
+    [clojure.contrib.str-utils :as str-utils])
+  (:use (clj-record util config)))

 (defn table-name [model-name]
@@ -22,7 +21,7 @@
           [(conj parameterized-conditions (format "%s = ?" (name attribute))) (conj values value)]))
       [[] []]
       attributes)]
-    (apply vector (str-join " AND " parameterized-conditions) values)))
+    (apply vector (str-utils/str-join " AND " parameterized-conditions) values)))

 (defn find-records [model-name attributes]
   (let [[parameterized-where & values] (to-conditions attributes)
@@ -71,7 +70,7 @@
   (dosync (commute all-models-metadata assoc model-name (ref {}))))

 (defmacro init-model [& options]
-  (let [model-name (last (re-split #"\." (name (ns-name *ns*))))]
+  (let [model-name (last (str-utils/re-split #"\." (name (ns-name *ns*))))]
     (setup-model-metadata model-name)
     (let [optional-forms (defs-from-option-groups model-name options)]
     `(do


Basic functions for name collisions

Basic functions for name collisions

--- src/hphelper/shared/sql.clj
+++ src/hphelper/shared/sql.clj
@@ -7,6 +7,60 @@
          :subname "//127.0.0.1:3306/hphelper"
          :user "fc"})

+(defn query
+  "Performs the query against the defined database, and logs the query"
+  [& quer]
+  (log/trace "Performing Query: " quer)
+  (jdb/query db quer))
+
+(def namedItems
+  "A map atom with references as keys and named items as values"
+  (atom {}))
+
+(defn reset-named-items!
+  "Resets the namedItems atom"
+  []
+  (reset! namedItems {}))
+
+(defn get-name
+  "Returns the referenced name from namedItems, or nil if not existing"
+  [keyName]
+  (get @namedItems keyName))
+
+(defn named-exists?
+  "Returns true if the named item already exists in namedItems, else false"
+  [refName]
+  (if (some #{refName} (vals @namedItems))
+    true
+    false))
+
+(defn add-name
+  "Adds the reference name pair to namedItems, overwriting any previous allocation.
+  Returns the added name"
+  ([keyRef valName]
+   (swap! namedItems assoc keyRef valName)
+   valName)
+  ([[keyRef valName]]
+   (add-name keyRef valName)))
+
+(defn- create-name
+  "Creates the name and checks for collisions. After tries runs out just returns the current guess.
+  Adds the name to namedItems and returns the new name."
+  [nameGen nameRef triesRemaining]
+  (let [currentTry (nameGen)]
+    (if (and (named-exists? currentTry)
+             (> triesRemaining 0))
+      (recur nameGen nameRef (dec triesRemaining))
+      (add-name nameRef currentTry))))
+
+(defn get-or-create-name
+  "Takes a name generation function and a reference, and tries multiple times to create a non-colliding name
+  for the reference. If the reference already exists, returns the associated name. After multiple collision attempts
+  will simply add the latest try to the map."
+  ([nameGen nameRef]
+   (if (get-name nameRef)
+     (get-name nameRef) ;; It exists, return the name
+     (create-name nameGen nameRef 10)))) ;; Otherwise, let's try and make this work

 (defn get-random-item
   "Gets a random item from a collection. Returns nil if the collection is empty"
@@ -15,11 +69,14 @@
      nil
      (nth collection (int (Math/floor (* (Math/random) (count collection))))))))

-(defn query
-  "Performs the query against the defined database, and logs the query"
-  [& quer]
-  (log/trace "Performing Query: " quer)
-  (jdb/query db quer))
+(defn get-random-name
+  "Gets a random name from the database. at a specified clearance level"
+  ([]
+   (let [nameMap (get-random-item (query "SELECT * FROM `name` WHERE `name_clearance` = 'U';"))]
+     (str (nameMap :name_first) "-"
+          (nameMap :name_clearance) "-"
+          (nameMap :name_zone))))
+  )

 (defn get-sg-by-id
   "Gets service group by sg_id"
@@ -93,20 +150,3 @@
      (into [] items) ;; Is done, return a vector
      (recur (dec numb) (conj items (get-news-random-single))))))

-(defn get-random-name
-  "Gets a random name from the database.
-  If supplied with a collision set, tries up to five times to return a name not in that set."
-  ([]
-   (let [nameMap (get-random-item (query "SELECT * FROM `name` WHERE `name_clearance` = 'U';"))]
-     (str (nameMap :name_first) "-"
-          (nameMap :name_clearance) "-"
-          (nameMap :name_zone))))
-  ([collisionSet]
-   (get-random-name collisionSet 5))
-  ([collisionSet triesRemaining]
-   (let [tempName (get-random-name)]
-     (if (and (some #{tempName} collisionSet)
-              (> triesRemaining 0))
-       (recur collisionSet (dec triesRemaining))
-       tempName)))
-  )


Tweaks to Clojure day 6 solution.

Tweaks to Clojure day 6 solution.

--- clojure/src/advent2016/day6.clj
+++ clojure/src/advent2016/day6.clj
@@ -1,19 +1,16 @@
-(ns advent2016.day6
-  (:require [clojure.java.io :as io]
-            [clojure.string :as s]))
+(ns advent2016.day6)

 (def example1 ["eedadn" "drvtee" "eandsr" "raavrd" "atevrs" "tsrnev" "sdttsa"
                "rasrtv" "nssdts" "ntnada" "svetve" "tesnvt" "vntsnd" "vrdear"
                "dvrsen" "enarar"])
-(def puzzle (vec (line-seq (io/reader "../day6.data"))))
-(def transpose (partial apply map (comp (partial s/join) vector)))
+(def puzzle (vec (line-seq (clojure.java.io/reader "../day6.data"))))

-(def solution1 (s/join (map #(->> (frequencies %)
-                                  (sort-by (comp - val))
-                                  ffirst)
-                            (transpose puzzle))))
+(def solution1 (apply str (map #(->> (frequencies %)
+                                     (sort-by (comp - val))
+                                     ffirst)
+                               (apply map str puzzle))))

-(def solution2 (s/join (map #(->> (frequencies %)
-                                  (sort-by val)
-                                  ffirst)
-                            (transpose puzzle))))
+(def solution2 (apply str (map #(->> (frequencies %)
+                                     (sort-by val)
+                                     ffirst)
+                               (apply map str puzzle))))