add lens support for morphs

add lens support for morphs

--- src/cljs/cljs_morphic/morph.cljs
+++ src/cljs/cljs_morphic/morph.cljs
@@ -1,26 +1,26 @@
 (ns cljs-morphic.morph
-  (:require-macros [cljs.core.async.macros :refer [go go-loop]])
-  (:require [goog.events :as events]
-            [goog.events.EventType :as EventType]
-            [cljs.core.async :as async :refer [>! <! put! chan timeout onto-chan]]
-            [cljs.contrib.pprint :refer [pprint]]
-            [clojure.walk :refer [walk]]
+  (:require-macros [cljs.core.async.macros :refer [go go-loop]]
+                   [fresnel.lenses :refer [deflens]])
+  (:require [cljs.core.async :as async :refer [>! <! put! chan timeout onto-chan]]
+            ; [fipp.edn :refer [pprint]]
+            [cljs.pprint :refer [pprint]]
             [om.core :as om :include-macros true]
             [om.dom :as dom :include-macros true]
-            [goog.style :as gstyle]
-            [goog.dom :as gdom]
             [cljs.reader :refer [read-string]]
+            [cljs.js]
             [cljs-morphic.event :as event :refer [signals]]
             [cljs-morphic.helper :refer [applicative add-points bottom-right apply-to-morph contains-rect?
-                                         bounds some-morph eucl-distance morph? expanded-expression?]
+                                         bounds some-morph eucl-distance morph? expanded-expression?
+                                         add-changes diff-submorphs]
              :refer-macros [morph-fn]]
             [cljs.core.match :refer-macros [match]]
-            [clojure.zip :as zip :refer [zipper node down right up children root replace path rights end?]]
             [clojure.string :refer [replace-first]]
             [clojure.data :refer [diff]]
             [rksm.cloxp-com.messenger :as m]
-            [rksm.cloxp-com.cloxp-client :as cloxp])
-  (:import [goog.events EventType]))
+            [rksm.cloxp-com.cloxp-client :as cloxp]
+            [fresnel.lenses :refer [fetch putback create-lens create-lens dissoc-trigger]])
+  (:import [goog.net XhrIo]
+           [goog.events EventType]))

 (enable-console-print!)

@@ -29,147 +29,332 @@

 (def redefinitions (chan))

-(declare world-state)
-
-(declare rectangle ellipse image text polygon ace-editor without)
-
-(declare rerender redefine on-drag read-morph)
-
-(defn merge-changes [cha chb]
-  {:removed (concat (:removed cha) (:removed chb))
-   :added (concat (:added cha) (:added chb))
-   :set-props (merge (:set-props cha) (:set-props chb))})
-
-(defn diff-morph [old-morph new-morph]
-  "Returns a dictionary containing all the changes between ma and mb.
-   This includes all changes in the props and also all changes within
-   the submorphs."
-  ; determine changes in submorphs
-  (let [submorph-changes (merge-changes (-> old-morph meta :changes) (-> new-morph meta :changes))
-        [_ old-props _] old-morph
-        [_ new-props _] new-morph
-        [removed-props changed-props _] (diff old-props new-props)]
-    (if changed-props
-      (assoc-in submorph-changes  [:set-props (:id new-props)] changed-props)
-      changed-props)))
-
-(defn diff-submorphs [old-submorphs new-submorphs]
-  (let [old-ids (map (fn [expr]
-                       (if (expanded-expression? expr)
-                         (-> expr meta :abstraction-id)
-                         (-> expr second :id))) old-submorphs)
-        new-ids (map (fn [expr]
-                       (if (expanded-expression? expr)
-                         (-> expr meta :abstraction-id)
-                         (-> expr second :id))) new-submorphs)
-        [removed-morphs added-morphs _] (diff old-ids new-ids)
-        changed-props (:set-props (reduce merge-changes (map diff-morph old-submorphs new-submorphs)))]
-    {:removed removed-morphs
-     :added added-morphs
-     :set-props changed-props}))
+(declare world-state current-namespace)
+
+(declare rectangle ellipse image text polygon without)
+
+(declare rerender redefine on-drag read-morph find-morph)
+
+; LENSES

 (defn ast-type [x]
   (cond
-    (and (list? x) (morph? x)) :morph
+    (morph? x) :morph
     (expanded-expression? x) :expr
-    (vector? x) :vector))
-
-(defn apply-changes-to [expr changes]
-  (list '-> expr
-        '(set-prop :id :prop :value)
-        '(without :id)
-        '(add-morphs-to :id :morphs)))
-
-(defmulti makenode ast-type)
-
-(defmulti get-children ast-type)
-
-(defmethod get-children :morph [morph]
-  (let [[self props & submorphs] morph]
-                    submorphs))
-
-(defmethod get-children :expr [expr]
-  (:expanded-expression (meta expr)))
-
-(defmethod get-children :vector [morph-col]
-  morph-col)
-
-(defmethod makenode :morph [morph new-submorphs]
-  (let [[self props & old-submorphs] morph
-        old-changes (-> morph meta :changes)
-        _ (prn old-changes)
-        new-changes (when-not (empty? old-submorphs)
-                      (merge-changes old-changes (diff-submorphs old-submorphs new-submorphs)))]
-    (with-meta
-      (apply list self props (filter not-empty new-submorphs))
-      (assoc (meta morph) :changes new-changes))))
-
-(defmethod makenode :expr [expr new-expansion]
-  (let [expansion (:expanded-expression (meta expr))]
-    (if (morph? expansion)
-      (let [changes (diff-morph expansion new-expansion)]
-        (with-meta expr
-          (assoc (meta (apply-changes-to expr changes))
-                 :expanded-expression new-expansion
-                 :changes changes)))
-      (let [new-morph-col (apply vector (filter not-empty new-expansion))
-            changes (map diff-morph expansion new-morph-col)]
-        (with-meta expr
-          (assoc (meta (apply-changes-to expr changes))
-                 :expanded-expression new-morph-col
-                 :changes changes))))))
-
-(defmethod makenode :vector [morph-col new-morph-col]
-  (apply vector (filter not-empty new-morph-col)))
-
-(defn world-zipper [world]
-  (zipper ast-type
-          get-children
-          makenode
-          world))
-
-(defn find-morph-loc
-  [ast id]
-  (let [expr (node ast)
-        node-id (if (morph? expr)
-                  (-> expr second :id)
-                  (-> expr meta :abstraction-id))]
-    (if (= node-id id)
-      ast
-      (when-not (end? ast)
-        (find-morph-loc (zip/next ast) id)))))
-
-(defn find-morph [root-ast id]
-  (let [ast (world-zipper root-ast)
-        loc (find-morph-loc ast id)]
-    (when loc
-      (let [m (node loc)
-            [self props & submorphs] m]
-        (with-meta (list (applicative m) props submorphs) (meta m))))))
-
-(defn owner [root-ast id]
-   (when-let [loc (find-morph-loc root-ast id)]
-     (up loc)))
+    (vector? x) :vector
+    :else x))
+
+(defmulti morphic-read
+  "Traverses the given expression, scanning for non morphic expressions
+  which are then expanded such that they integrate into the morphic tree"
+  (fn [expr ns]
+    (ast-type expr)))
+
+(defmethod morphic-read :vector
+  ([morphs ns]
+   (mapv morphic-read morphs)))
+
+(def morph-libs
+    {'cljs-morphic.morph :cljs
+     'cljs-morphic.morph.window :cljs
+     'cljs-morphic.morph.editor :cljs
+     'cljs-morphic.test :cljs})
+
+(defn get-file [url]
+  (let [c (chan)]
+    (.send XhrIo url
+      (fn [e]
+        (put! c (.. e -target getResponseText))))
+    c))
+
+(defn browser-load [{:keys [name macros]} cb]
+  (if (contains? morph-libs name)
+    (go
+     (let [path (str "cloxp-cljs-build/out/" (cljs.js/ns->relpath name)
+                     "." (cljs.core/name (get morph-libs name)))
+           file (<! (get-file path))]
+       (cb {:lang :cljs :source file})))
+    (cb nil)))
+
+(def st (cljs.js/empty-state))
+
+(cljs.js/eval
+   st
+   '(ns cljs.user (:require [cljs-morphic.morph :refer [ellipse rectangle image text set-prop add-morph add-morph-before without $morph]]
+                            [cljs-morphic.playground :refer [tree cenery
+                                                             create-clock create-labels
+                                                             create-hour-pointer
+                                                             create-minute-pointer
+                                                             create-second-pointer
+                                                             point-from-polar
+                                                             PI get-current-time angle-for-hour]]
+                            [cljs-morphic.test :refer [japanese-kitchen]]))
+   {:eval cljs.js/js-eval
+    :load browser-load}
+   (fn [c] c))
+
+(defn morph-eval [m]
+  (cljs.js/eval
+   st
+   m
+   {:eval cljs.js/js-eval}
+   (fn [c] c)))
+
+(defn compile-props [morph props ns]
+  (let [compiled-props (morph-eval (select-keys props (-> morph meta :requires-compile)))]
+    (vary-meta morph assoc :compiled-props compiled-props)))
+
+(defmethod morphic-read :morph
+  ([morph ns]
+   (let [[self props & submorphs] morph
+         morph (compile-props morph props ns)]
+     (with-meta
+       (apply list self props (map morphic-read submorphs))
+       (meta morph)))))
+
+(defmethod morphic-read :expr
+  ([expression ns]
+   (vary-meta expression update :expanded-expression morphic-read)))
+
+(defmethod morphic-read :default
+  ([new-expr ns]
+   (let [expansion (morph-eval new-expr)
+         expansion (if (morph? expansion)
+                     expansion
+                     (apply vector (remove nil? expansion)))]
+     (when new-expr
+       (vary-meta new-expr
+                  assoc :expanded-expression
+                  (morphic-read expansion))))))
+
+(deflens it [x y] ; maybe 'self' is a better name than 'it'
+  :fetch x
+  :putback (cond
+             (vector? y) (apply vector (remove nil? y))
+             :else y))
+
+(defn redefine
+  ([expression redefinition]
+   (redefine expression it redefinition))
+  ([world-state lens redefinition]
+   (let [expr (fetch world-state lens)
+         [_ _ & submorphs] expr]
+     (if (morph? expr)
+                    (do
+                      (go (>! redefinitions {:type :redefined :target-props (fetch expr properties)}))
+                      (let [new-morph (apply-to-morph redefinition expr)
+                            [_ _ & new-submorphs] new-morph
+                            new-morph (if (-> new-morph meta :changes :recompile?)
+                                        (morphic-read new-morph)
+                                        new-morph
+                                        ; TODO: Also check for props that need to be compiled
+                                        )]
+                        (putback world-state lens new-morph)))
+       (putback world-state lens (morphic-read (redefinition expr)))))))
+
+(defn update-changes [expr new-changes]
+  "Updates the expressions change meta-data without applying the changes"
+  (vary-meta expr assoc :changes new-changes))
+
+(declare add-morph add-morph-before without set-prop)
+
+(defmulti changes->form (fn [expr changes] (first expr)))
+
+(defmethod changes->form '->
+  ([[_ expr _] changes]
+   (changes->form expr changes)))
+
+(defmethod changes->form 'map
+  ([mapping-expr {struct-changes :structure
+                  id->prop-changes :properties}]
+   (let [map-fn (second mapping-expr)
+         ; try to extract the prototype morph that is being mapped
+         [_ args prototype-morph] map-fn])
+   (apply list '-> mapping-expr
+     (concat struct-changes
+             (for [[morph prop-changes] id->prop-changes]
+               (apply concat (for [[prop value] prop-changes]
+                               (list 'set-prop morph prop value))))))))
+
+(defmethod changes->form 'for
+  ([for-expr {struct-changes :structure
+              id->prop-changes :properties}]
+   (apply list '-> for-expr
+     (concat struct-changes
+             (for [[morph prop-changes] id->prop-changes]
+               (apply concat (for [[prop value] prop-changes]
+                               (list 'set-prop morph prop value))))))))
+
+(defmethod changes->form :default
+  ([expr {struct-changes :structure
+          id->prop-changes :properties}]
+   (apply list '-> expr
+     (concat struct-changes
+             (for [[morph prop-changes] id->prop-changes]
+               (apply concat (for [[prop value] prop-changes]
+                               (list 'set-prop morph prop value))))))))
+
+(defmulti apply-changes
+  "Applies the changes to the expression and also updates the change meta-data accordingly"
+  (fn [expr changes] (ast-type expr)))
+
+(defmethod apply-changes :morph [morph changes]
+  (morph-eval (changes->form morph changes)))
+
+(defmethod apply-changes :expr [expr changes]
+  (let [new-expansion (apply-changes (-> expr meta :expanded-expression) changes)]
+    (vary-meta expr assoc :expanded-expression new-expansion)))
+
+; SUBMORPH LENS
+
+(defmulti putback-submorphs (fn [expr new-submorphs] (ast-type expr)))
+
+(defmethod putback-submorphs :morph [morph new-submorphs]
+  (redefine morph (fn [self props submorphs]
+                    (go (>! redefinitions {:type :redefined :target-props props}))
+                    (self props (remove nil? new-submorphs)))))
+
+(defn update-expression [expr]
+  "match the expression to the changes that affect the expression"
+  (let [changes (fetch expr changes)
+        new-expr (changes->form expr changes)]
+    (with-meta new-expr (meta expr))))
+
+(defmethod putback-submorphs :expr [expr new-submorphs]
+  (let [old-submorphs (fetch expr submorphs)
+        new-submorphs (apply vector (remove nil? new-submorphs))
+        new-changes (diff-submorphs 'it new-submorphs old-submorphs)
+        old-changes (-> expr meta :changes)]
+    (-> expr
+    (vary-meta assoc :expanded-expression new-submorphs
+               :changes (add-changes old-changes new-changes))
+           update-expression)))
+
+; this will never happen, since (fetch [ vector ] [submorphs idx] == [idx])
+(defmethod putback-submorphs :vector [morphs new-submorphs]
+  (apply vector (remove nil? new-submorphs)))
+
+(defmethod putback-submorphs :default [expr compiled-expression]
+  compiled-expression)
+
+(deflens submorphs [expr new-submorphs]
+ :fetch
+  (cond
+    (morph? expr)
+    (let [[self props & submorphs] expr] (apply vector submorphs))
+
+    (expanded-expression? expr)
+    (let [expanded (-> expr meta :expanded-expression)]
+      (if (morph? expanded)
+        [expanded]
+        (apply vector (remove nil? expanded))))
+
+    (vector? expr)
+    expr
+    :default
+    (fetch (morphic-read expr) submorphs))
+  :putback (putback-submorphs expr new-submorphs))
+
+; PROPERTIES LENS
+
+(deflens properties [morph new-properties]
+  :fetch (if (morph? morph)
+           (second morph)
+           (throw "Can not access properties of " morph))
+  :putback (redefine morph (fn [self old-properties submorphs]
+                              (self new-properties submorphs))))
+
+; DESCRIPTION LENS
+
+(deflens description [expr new-description]
+  :fetch
+  (-> expr pprint with-out-str) ; TODO: Use cached description and changes to be faster
+  :putback
+  (cljs.reader/read-string new-description))
+
+; CHANGES LENS
+
+(deflens changes [expr new-changes]
+  :fetch (reduce add-changes
+                 (merge {:structure [] :properties {}} (-> expr meta :changes))
+                 (map #(fetch % changes) (fetch expr submorphs)))
+  :putback (let [old-changes (-> expr meta :changes)]
+             (if (= old-changes new-changes)
+               expr
+               (apply-changes expr new-changes))))
+
+(defn enum [xs]
+  (map vector (range) xs))
+
+(defmulti morph-lens (fn [expr id lens]
+                       (ast-type expr)))
+
+(defmethod morph-lens :vector
+  ([morphs id lens]
+   (some (fn [[idx m]]
+           (morph-lens m id (conj lens idx))) (enum morphs))))
+
+(defmethod morph-lens :expr
+  ([expression id lens]
+   (if (= (-> expression meta :abstraction-id) id)
+     lens
+     (when-let [morphs (fetch expression submorphs)]
+       (morph-lens morphs id (conj lens submorphs))))))
+
+(defmethod morph-lens :morph
+  ([morph id lens]
+   (if (= (fetch morph [properties :id]) id)
+       lens
+     (when-let [morphs (fetch morph submorphs)]
+         (morph-lens morphs id (conj lens submorphs))))))
+
+(defmethod morph-lens
+  :default
+  ([morphs id lens]
+   (if (every? #(or (morph? %) (expanded-expression? %)) (remove nil? morphs))
+       (some (fn [[idx m]]
+           (morph-lens m id (conj lens idx))) (enum morphs))
+     (do
+       (prn "PERF DEGREGATION! ")
+       (morph-lens (morphic-read morphs) id lens)))))
+
+(defn $morph
+  ([id]
+   (create-lens
+    (fn [_ world-state]
+      (fetch world-state (morph-lens world-state id [it])))
+    (fn [_ world-state new-morph]
+      (putback world-state (morph-lens world-state id [it]) new-morph))))
+  ([world-state id]
+   (morph-lens world-state id [it])))
+
+; WORLD OPERATIONS
+
+(defn owner [world-state id]
+  (let [lens-path ($morph world-state id)]
+    (match (take-last 2 lens-path)
+           [submorphs (true :<< number?)] (fetch world-state (drop-last 2 lens-path))
+           :default nil)))

 (defn position-in-world
   ([world-state id]
-   (position-in-world (find-morph-loc (world-zipper world-state) id)))
-  ([ast-loc]
-  "return the global position of the morph with id"
-  (if ast-loc
-    (let [[_ {pos :position} _] (node ast-loc)]
-      (add-points (position-in-world (up ast-loc)) pos))
-    {:x 0 :y 0})))
+   (position-in-world world-state ($morph world-state id) {:x 0 :y 0}))
+  ([parent lens-path pos]
+   (if (empty? lens-path)
+     pos
+     (let [next-morph (fetch parent (first lens-path))]
+       (if (morph? next-morph)
+         (position-in-world next-morph (rest lens-path) (add-points pos (fetch next-morph [properties :position])))
+         (position-in-world next-morph (rest lens-path) pos))))))

 (defn global-bounds [world-state morph-id]
-  (let [[_ {extent :extent} _] (find-morph world-state morph-id)]
+  (let [[_ {extent :extent} _] (fetch world-state ($morph morph-id))]
     [(position-in-world world-state morph-id) extent]))

 (defn contains-morph? [world-state morph other]
   (let [bounds-a (global-bounds world-state morph)
         bounds-b (global-bounds world-state other)
         contains (contains-rect? bounds-a bounds-b)]
-    (when contains (prn bounds-a " contains " bounds-b))
     contains))

 (defn move-morph [world-state id new-parent-id]
@@ -177,22 +362,15 @@
    with the new-parent-id. Additionally the relative position of
    the newly added morph is being adopted, so that it does not
    change position. This is a semantic expectation from a morphic move."
-  (prn "moving " id " to ->" new-parent-id)
   (if (not= id new-parent-id)
-    (let [[self props submorphs] (find-morph world-state id)
+    (let [moved-morph (fetch world-state ($morph id))
           {gpx :x gpy :y} (position-in-world world-state new-parent-id)
           global-pos (position-in-world world-state id)
-          relative-pos (add-points global-pos {:x (- gpx) :y (- gpy)})]
-      (prn "relative-pos " relative-pos)
-      (prn "global-pos " global-pos)
+          relative-pos (add-points global-pos {:x (- gpx) :y (- gpy)})]
       (-> world-state
         (without id)
-        (redefine new-parent-id (fn [new-owner now-props now-submorphs]
-                                  (new-owner now-props
-                                             now-submorphs
-                                             ; we also need to adapt the position
-                                             ; which is now relative to the new owner
-                                             (self (assoc props :position relative-pos) submorphs))))))
+        (add-morph new-parent-id moved-morph)
+        (set-prop id :position relative-pos)))
     world-state))

 (defn morph-under-me
@@ -201,7 +379,7 @@
    ; We traverse the morph hierarchy just like a scenegraph
    (morph-under-me world-state "world" id))
   ([world-state container-id id]
-   (let [[_ _ submorphs] (find-morph world-state container-id)
+   (let [[_ _ & submorphs] (fetch world-state ($morph container-id))
          sub-container-id (some-morph (reverse submorphs) ; first match is the topmost morph
                               (fn [_ props _]
                                 (when (and
@@ -212,97 +390,68 @@
                                   (morph-under-me world-state (props :id) id))))]
      (or sub-container-id container-id))))

-(defn handle-morph-redefine [loc new-morph]
-  (let [new-ast (read-morph (zip/replace loc new-morph))
-        new-morph (node new-ast)
-        [_ new-props _] new-morph
-        redef-args {:id (:id new-props)
-                    :new-props new-props
-                    :restructured? (not= @(:hash (meta new-morph)) (hash new-morph))}]
-    (reset! (:hash (meta new-morph)) (hash new-morph))
-    (go
-     (onto-chan redefinitions
-                (map (fn [[_ props _]]
-                       {:type :redefined :target-props props :args redef-args}) (path loc)) false)
-     (>! redefinitions {:type :redefined :target-props new-props :args redef-args}))
-    new-ast))
-
-(defn handle-morph-remove [loc old-morph]
-  (let [[_ old-props _] old-morph
-        redef-args {:id (:id old-props)
-                    :restructured? true}]
-    (go
-     (onto-chan redefinitions
-                (map (fn [[_ props _]]
-                       {:type :redefined :target-props props :args redef-args}) (path loc)) false))
-    (go (>! redefinitions {:type :removed :target-props old-props}))
-    (zip/remove loc)))
-
-(defn redefine
-  ([world-state redefinition]
-   ; if no explicit ref is given, we will apply the transformation to all morphs in the current level
-   (let [ast (world-zipper world-state)]
-     (map (fn [m] (apply-to-morph redefinition m)) ast (children ast))))
-  ([world-state id redefinition]
-   (let [ast (world-zipper world-state)
-         ast-loc (find-morph-loc ast id)]
-     (if ast-loc
-       (let [old-morph (node ast-loc)
-             redefined-structure (apply-to-morph redefinition old-morph)
-             new-ast (if redefined-structure
-                       (handle-morph-redefine ast-loc redefined-structure)
-                       (handle-morph-remove ast-loc old-morph))]
-         (root new-ast))
-       world-state))))
-
 ; MORPH FUNCTIONS

 (defn set-prop [world id prop-name prop-value]
   "Set the property prop-name of morph with id in world to prop-value"
-  (-> world (redefine id (fn [self props submorphs]
-                           (self (assoc props prop-name prop-value)
-                                 submorphs)))))
+  (putback world [($morph id) properties prop-name] prop-value))

 (defn add-morphs-to [world id morphs]
   "Add collection of morphs to the morph with id in world"
-  (-> world (redefine id (fn [self props submorphs]
+  (-> world (redefine ($morph id) (fn [self props submorphs]
                            (self props
                                  morphs
                                  submorphs)))))

+(defn add-morph [world id morph]
+  "Add single morph to the morph with id"
+  (-> world (redefine ($morph id) (fn [self props submorphs]
+                           (self props
+                                 submorphs
+                                 morph)))))
+
+(defn add-morph-before [world id before-id morph]
+  "Just as add-morph, but adds morph in front of the morph with before-id"
+  (-> world (redefine ($morph id) (fn [self props submorphs]
+                                    (let [[before after] (split-with (fn [[_ {:id id} & _]]
+                                                                     (not= id before-id))
+                                                                     submorphs)]
+                                      (self props
+                                            before
+                                            morph
+                                            after))))))
+
 (defn without [world id]
   "Return a world without the morph with the given id."
-  (-> world (redefine id (fn [self props submorphs]))))
+  (redefine world ($morph id) (fn [self props submorphs])))

 (defn get-description
   ([world-state id]
    "In this case we just return a plain old new description. This is kind of expensive though."
-   (let [morph (find-morph world-state id)
-         [self props submorphs] morph]
-     (reset! (get (meta morph) :cached-code) (-> (self props submorphs)
-                                                 pprint
-                                                 with-out-str))))
+   (fetch world-state [($morph id) description]))
+
   ([world-state id change]
    "If we supply a change {:id :prop :value} with our request, we return a description
     based on the previously cached one and just replace the changed information
     with regexp magic."
-   (let [morph (find-morph world-state id)
+   (let [morph (fetch world-state ($morph id))
          [self props submorphs] morph
+         ; THIS SHOULD BE HANDLED BY THE LENS. META DATA MAY NOT BE TOUCHED BY THE USER
          cached-code (:cached-code (meta morph))
          morph-re (str "\\{[^\\(]*\\:id\\s\\\"" (:id change) "\\\"[^\\(]*\\}(\n?)")
          new-props (:new-props change)]
      (if (or (:restructured? change) (nil? @cached-code))
-       (do
+      (do
          ; we have not cached or the morph got moved, so the change is not helpful at all
          (reset! cached-code (-> (self props submorphs)
                                  pprint
                                  with-out-str)))
-       (do
+      (do
          ; we have cached the value previously, so we can now just apply a regexp substitute
          ; or just return the cached value
          (if (nil? new-props)
-           @cached-code
-           (swap! cached-code #(replace-first % (re-pattern morph-re)
+          @cached-code
+          (swap! cached-code #(replace-first % (re-pattern morph-re)
                                               (-> new-props
                                                 pprint
                                                 with-out-str)))))))))
@@ -349,7 +498,7 @@
 (defn get-plain-css [value]
   value)

-(defn get-transform-css [{rotation :Rotation, scale :Scale, pivot :PivotPoint,
+(defn get-transform-css [{rotation :rotation, scale :scale, pivot :pivot-point,
                           :or {rotation 0, scale 1, pivot {:x 0, :y 0}}}]
   {html5TransformProperty (str "rotate(" (mod (/ (* rotation 180) js/Math.PI) 360) "deg) scale(" scale "," scale ")")
    html5TransformOriginProperty (str (:x pivot) "px " (:y pivot) "px")})
@@ -378,6 +527,43 @@
                  ;; more to come...
                  nil)) props)))

+; TEXT
+
+(defn get-font-family-css [family-name]
+  {"fontFamily" family-name})
+
+(defn get-font-size-css [size]
+  {"fontSize" (str size "pt")})
+
+(defn get-max-text-height-css [height]
+  {"maxHeight" (str height "px")})
+
+(defn get-max-text-width-css [width])
+
+(defn get-min-text-height-css [height])
+
+(defn get-min-text-width-css [height])
+
+(defn get-text-color-css [color]
+  {"textColor" color})
+
+(defn get-prevent-selection-css [value]
+  (when (false? value) {"WebkitUserSelect" "none"}))
+
+(defn extract-text-css [props]
+     (apply merge
+       (map (fn [[prop value]]
+          (case prop
+               :font-family (get-font-family-css value)
+               :font-size (get-font-size-css value)
+               :max-text-height (get-max-text-height-css value)
+               :max-text-width (get-max-text-width-css value)
+               :min-text-height (get-min-text-height-css value)
+               :min-text-width (get-min-text-width-css value)
+               :text-color (get-text-color-css value)
+               :allow-input (get-prevent-selection-css value)
+               nil)) props)))
+
 (defn extract-morph-css [props]
   (dict->js
     (apply merge
@@ -409,150 +595,20 @@
               (concat morphs morph)
               (concat morphs [morph]))) [] morphs))

-; COMPILATION
-
-(def current-namespace (atom "cljs-morphic.morph"))
-
-(def cljs-compile-handler
-  '(do
-     (require '[rksm.cloxp-cljs.ns.internals]
-              '[cljs.repl :as repl]
-              '[rksm.cloxp-com.cljs-repl :as cljs-repl]
-              '[clojure.tools.reader :refer [read-string]]
-              '[rksm.cloxp-com.messenger :as m]
-              '[rksm.cloxp-com.server :as s])
-     (fn [con msg]
-
-       ; the clopx cljs passive repl env
-       (defrecord CloxpCljsPassiveReplEnv [server client-id]
-         repl/IJavaScriptEnv
-         (-setup [this opts] {:status :success :value nil})
-         (-evaluate [this filename line js] {:status :success :value js})
-         (-tear-down [_]))
-
-       (let [client-id (-> msg :data :cloxp-client)
-             {:keys [server] :as connection} (s/find-connection client-id)
-             compiled-js (cljs.env/with-compiler-env (:compiler-env (rksm.cloxp-cljs.ns.internals/ensure-default-cljs-env))
-                           (cljs-repl/eval-cljs
-                            (read-string (get-in msg [:data :exp]))
-                            (->CloxpCljsPassiveReplEnv server client-id)
-                            {:ns-sym (symbol (-> msg :data :required-namespace))}))]
-         (m/send con (m/prep-answer-msg con msg compiled-js false))))))
-
-(defn start-cljs-compile-service [con]
-  (go
-   (let [register-msg {:action "register"
-                       :data {:id (:id con)
-                              :cloxp-client? true
-                              :services (-> con :services deref keys)
-                              :document-url (. js/document -URL)}}
-         add-service-msg {:action "add-service"
-                          :data {:name "cljs-compile-service" :handler (str cljs-compile-handler)}}
-         client-id (:id con)
-         register-answer (<! (m/send con register-msg))
-         add-service-answer (<! (m/send con add-service-msg))]
-     (prn "Registering CLJS compilation for client: " client-id)
-     (if (= "OK" (-> add-service-answer :message :data))
-       (prn "Added CLJS compilation service!")
-       (prn (str "CLJS compilation failed to initialize! Response: " add-service-answer))))))
-
-(defn compile-cljs [con exp]
-  (go
-   (let [eval-cljs-msg {:action "cljs-compile-service"
-                        :data {:exp (str exp)
-                               :cloxp-client (:id con)
-                               :required-namespace @current-namespace}}
-         compile-cljs-result (<! (m/send con eval-cljs-msg))
-         code (-> compile-cljs-result :message :data)
-         res (js/eval code)]
-     res)))
-
-(defn compile-morph [morph-id morph-description]
-  (go (>! signals {:type :compile-morph-request :target-props {:id morph-id} :args {:form morph-description}})))
-
-(defn compile-props [morph]
-  (let [[self props & submorphs] morph
-        meta-data (meta morph)]
-    (go (>! signals {:type :compile-props-request
-                     :target-props {:id (:id props)}
-                     :args {:form (select-keys props @(meta-data :requires-compile))}}))))
-
-(defn compile-expr [expression expr-ref]
-  (go (>! signals {:type :compile-expression-request
-                   :target-props {:ref expr-ref}
-                   :args {:form expression}})))
-
-(defn hot-swapping [world-state {evt-type :type
-                                 {morph-id :id
-                                  expr-ref :ref} :target-props
-                                 {compiled-cljs :compiled-cljs
-                                  expression :form} :args}]
-  (match [evt-type compiled-cljs]
-         [(:or :compile-morph-request
-               :compile-props-request
-               :compile-expression-request) nil]
-         (do
-           (when expression
-             (cloxp/with-con
-               (fn [con]
-                 (go (let [compiled-cljs (<! (compile-cljs con expression))]
-                       (>! signals {:type evt-type
-                                    :target-props {:id morph-id :ref expr-ref}
-                                    :args {:compiled-cljs compiled-cljs
-                                           :form expression}}))))))
-           :zero)
-         ; If the compiled-cljs is NOT nil, the request has been served
-         ; and we can plug the compiled cljs into the world
-         [:compile-morph-request cljs] [(redefine world-state morph-id
-                                                  (fn [_ _ _]
-                                                    compiled-cljs)) hot-swapping]
-         [:compile-props-request cljs] [(redefine world-state morph-id
-                                                  (fn [self props submorphs]
-                                                    (let [m (self props submorphs)
-                                                          meta-data (meta m)]
-                                                      (swap! (meta-data :compiled-props)
-                                                             merge cljs)
-                                                      m))) hot-swapping]
-         [:compile-expression-request cljs] [(let [ast (world-zipper world-state)
-                                                   ast-loc (find-morph-loc ast expr-ref)
-                                                   new-ast (root (zip/replace ast-loc
-                                                                  (with-meta expression
-                                                                    {:abstraction-id expr-ref
-                                                                     :expanded-expression cljs})))]
-                                               (go
-                                                (onto-chan redefinitions
-                                                           (map (fn [[_ props _]]
-                                                                  {:type :redefined :target-props props :args {:restructured? true}}) (path ast-loc)) false))
-                                               new-ast) hot-swapping]
-         :else :zero))
-
 (defn default-meta [morph]
   (let [[self props & submorphs] morph]
     {:cached-code (atom nil) ; holds the stringified ast pretty printed to prevent unnessecary re-pprints
-     :compiled-props (atom {}) ; dictionary of all props that need to be compiled and the compiled values
-     :hash (atom (hash morph)) ; hash used to determine wether the strucutre of the morph hierarchy has changed
-     ; TODO: Find a better way to determine if we have functions in our props
+     :compiled-props {} ; dictionary of all props that need to be compiled and the compiled values
      :requires-compile (->> props
                          (filter #(when
                                     (seq? (val %))
                                     (-> % val first (= 'fn))))
-                         keys
-                         atom)}))
-
-(defn not-yet-compiled? [morph]
-  (let [meta-data (meta morph)]
-    (and meta-data
-         (-> meta-data :requires-compile deref not-empty)
-         (not=
-          @(:requires-compile meta-data)
-          (keys @(:compiled-props meta-data))))))
+                         keys)}))

 (defn ensure-meta [morph]
   (let [morph (if (meta morph)
                 morph
                 (with-meta morph (default-meta morph)))]
-    (when (not-yet-compiled? morph)
-        (compile-props morph))
     morph))

 (defn generate-expr-token [expr]
@@ -560,30 +616,6 @@

 (defn scheduled-for-compile? [expr]
   (and (meta expr) (-> expr meta :abstraction-id)))
-
-(defn read-morph [ast-loc]
-  (let [expr (node ast-loc)]
-    (if (vector? expr)
-      (zip/prev (read-morph (zip/next ast-loc)))
-      (if (morph? expr)
-        (let [ast-loc (if (end? (zip/next ast-loc))
-                        ast-loc
-                        (zip/prev (read-morph (zip/next ast-loc))))
-              morph (ensure-meta (node ast-loc))]
-          (zip/replace ast-loc morph))
-        (if (expanded-expression? expr)
-          (if (end? (zip/next ast-loc))
-                        ast-loc
-                        (zip/prev (read-morph (zip/next ast-loc))))
-          (let [ast-loc (if (zip/right ast-loc)
-                          (zip/left (read-morph (zip/right ast-loc)))
-                          ast-loc)
-                expr-token (generate-expr-token expr)]
-            (if (scheduled-for-compile? expr)
-              ast-loc
-              (do
-                (compile-expr expr expr-token)
-                (zip/replace ast-loc (with-meta (list '-> expr) {:abstraction-id expr-token}))))))))))

 (defn rectangle [props & submorphs]
   (ensure-meta (apply list 'rectangle props (even-out submorphs))))
@@ -635,19 +667,22 @@
 (defn render-placeholder [morph]
   nil) ; render nothing. Its fine.

-(defn render [expr]
-  (if-not (morph? expr)
-    (when (expanded-expression? expr)
-      (let [morph (:expanded-expression (meta expr))]
-        (if (morph? morph)
-          (render morph)
-          (apply dom/div nil (map render morph)))))
-    (if (not-yet-compiled? expr)
-      ; we encountered an expression that is not yet ready for rendering
-      (render-placeholder expr)
-      ; we have to branch into the expressions meta-data to continue rendering
-      (let [[self props & args] expr
-            props (merge props @(:compiled-props (meta expr)))]
+(defmulti render
+  "render function, that traverses a morph tree and derives
+  a tree of om-components"
+  (fn [expr ns]
+    (ast-type expr)))
+
+(defmethod render :expr [expr]
+  (let [morph (-> expr meta :expanded-expression)]
+    (render morph)))
+
+(defmethod render :vector [morphs]
+  (apply dom/div nil (map render morphs)))
+
+(defmethod render :morph [morph]
+  (let [[self props & args] morph
+            props (merge props (-> morph meta :compiled-props))]
           (match [self props args]
                ['rectangle {:id id} submorphs] (om/build render-rectangle [props submorphs] {:react-key id})
                ['ellipse {:id id} submorphs] (om/build render-ellipse [props submorphs] {:react-key id})
@@ -655,7 +690,7 @@
                ['image {:id id} submorphs] (om/build render-image [props submorphs] {:react-key id})
                ['polygon {:id id} submorphs] (om/build render-polygon [props submorphs] {:react-key id})
                ['io {:id id} submorphs] (om/build render-io-morph [props submorphs] {:react-key id})
-               :else (prn "Can not render: " expr))))))
+               :else (prn "Can not render: " morph))))

 (defn render-rectangle [[props submorphs]]
   (reify
@@ -689,6 +724,24 @@
                                                   :marginLeft "-2px"}}
                     (map render submorphs))))))))

+(defn create-text-node [text-props]
+  (dom/span #js {:className "visible Selection"
+                 :contentEditable (or (not (contains? text-props :allow-input))
+                                      (:allow-input text-props))
+                 :style (clj->js (extract-text-css text-props))
+                 :ref "myInput"} (:text-string text-props)))
+
+(defn render-text [[props _]] ; text morphs do not render submorphs
+  (reify
+    om/IRender
+    (render [self]
+            ; morph
+            (dom/div (extract-html-attributes props)
+              ;shape
+              (dom/div (clj->js {:style (assoc (extract-morph-shape-css props) "cursor" "default")
+                                 :className "Morph Text"})
+                (create-text-node props))))))
+
 (defn render-image [[props submorphs]]
   (reify
     om/IRender
@@ -697,7 +750,7 @@
             (apply dom/div (extract-html-attributes props)
               ;shape
               (dom/img (clj->js {:style (extract-morph-shape-css props)
-                                 :draggable false
+                                 ; :draggable false
                                  :src (props :url)}))
               (map render submorphs)))))

@@ -764,7 +817,6 @@
     (cloxp/with-con
       (fn [con]
         (go
-         (<! (start-cljs-compile-service con))
          (loop [world init-world
                 transitions init-transitions
                 current-signal {:type nil ; the type of signal, i.e. mouse-move, redefine, step...
@@ -786,7 +838,7 @@
     new-worlds))

 (om/root
- render-root
- world-state
- {:target (. js/document (getElementById "app"))
+  render-root
+  world-state
+  {:target (. js/document (getElementById "app"))
   :tx-listen (fn [tx-data world-state])})


lowercase the input

lowercase the input

--- src/cljs/hyphen_keeper/core.cljs
+++ src/cljs/hyphen_keeper/core.cljs
@@ -91,7 +91,7 @@
      :placeholder "Word"
      :value @word
      :on-change (fn [e]
-                  (reset! word (-> e .-target .-value))
+                  (reset! word (-> e .-target .-value string/lower-case))
                   (load-hyphenation-patterns! @spelling @word))
      :on-blur #(lookup-hyphenation-pattern! @spelling @word)}]])

@@ -110,7 +110,7 @@
       {:type "text"
        :placeholder label
        :value @hyphenation
-       :on-change #(reset! hyphenation (-> % .-target .-value))}]]))
+       :on-change #(reset! hyphenation (-> % .-target .-value string/lower-case))}]]))

 (defn- hyphenation-add-button []
   [:button.btn.btn-default


Allow initialization to be performed only once

--- src/clojure/neko/application.clj
+++ src/clojure/neko/application.clj
@@ -24,14 +24,18 @@
   Application class from Java. Default `:on-create` moved to
   `init-application`.")))

+(def ^{:doc "Represents if initialization was already performed."
+       :private true}
+  initialized? (atom false))
+
 (defn init-application
   "Performs necessary preparations for Neko and REPL development."
   [context & {:keys [extends prefix on-create nrepl-port]
               :or {extends android.app.Application
                    prefix (str (simple-name name) "-")}}]
-  (alter-var-root #'neko.context/context (constantly context))
-  (alter-var-root #'package-name (constantly (.getPackageName context)))
-  (neko.init/init context :port (or nrepl-port 9999))
-  (init-threading))
-
-
+  (when-not @initialized?
+    (alter-var-root #'neko.context/context (constantly context))
+    (alter-var-root #'package-name (constantly (.getPackageName context)))
+    (neko.init/init context :port (or nrepl-port 9999))
+    (init-threading)
+    (reset! initialized? true)))


Fix tab displaying when they shouldn't

Fix tab displaying when they shouldn't

--- src/clojure/nightcode/window.clj
+++ src/clojure/nightcode/window.clj
@@ -60,8 +60,11 @@
   (.addWindowListener window
     (proxy [WindowAdapter] []
       (windowActivated [e]
+        ; force hints to hide
+        (reset! shortcuts/is-down? false)
         (shortcuts/toggle-hint! @editors/tabs false)
         (shortcuts/toggle-hints! @ui/root false)
+        ; update the tree to reflect any changes in the filesystem
         (ui/update-project-tree!))
       (windowClosing [e]
         (confirm-exit-app!)))))


Remove newline

Remove newline

--- src/clojure/nightmod/screens.clj
+++ src/clojure/nightmod/screens.clj
@@ -151,8 +151,7 @@
   ; save in tree-projects so the up button is hidden correctly
   (swap! ui/tree-projects conj path)
   ; save in tree-selection so the file grid is displayed
-  (s/invoke-later
-    (reset! ui/tree-selection path)))
+  (s/invoke-later (reset! ui/tree-selection path)))

 (defn new-project!
   [template]


Added support for normalizing lat/lon dimensions.

--- src/cmr/opendap/ous/variable.clj
+++ src/cmr/opendap/ous/variable.clj
@@ -62,6 +62,7 @@

 (def default-dim-stride 1)
 (def default-lat-lon-stride 1)
+(def default-lat-lon-resolution 1)

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;   Records   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -131,6 +132,7 @@

 (defn lon-lo-phase-shift
   [lon-max lon-lo]
+  (log/debug "Got lon-max:" lon-max)
   (-> (/ (* (dec lon-max)
             (- lon-lo default-lon-lo))
          (- default-lon-hi default-lon-lo))
@@ -139,6 +141,7 @@

 (defn lon-hi-phase-shift
   [lon-max lon-hi]
+  (log/debug "Got lon-max:" lon-max)
   (-> (/ (* (dec lon-max)
             (- lon-hi default-lon-lo))
          (- default-lon-hi default-lon-lo))
@@ -188,6 +191,7 @@

 (defn lat-lo-phase-shift
   [lat-max lat-lo]
+  (log/debug "Got lat-max:" lat-max)
   (int
     (- lat-max
        1
@@ -197,12 +201,22 @@

 (defn lat-hi-phase-shift
   [lat-max lat-hi]
+  (log/debug "Got lat-max:" lat-max)
   (int
     (- lat-max
        1
        (Math/ceil (/ (* (dec lat-max)
                         (- lat-hi default-lat-lo))
                      (- default-lat-hi default-lat-lo))))))
+
+(defn normalize-lat-lon
+  [dim]
+  (-> dim
+      (assoc :Latitude (or (:Latitude dim
+                           (:lat dim)))
+             :Longitude (or (:Longitude dim)
+                            (:lon dim)))
+      (dissoc :lat :lon)))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;   Core Functions   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -270,7 +284,8 @@
   [entry]
   (->> (get-in entry [:umm :Dimensions])
        (map #(vector (keyword (:Name %)) (:Size %)))
-       (into (array-map))))
+       (into (array-map))
+       normalize-lat-lon))

 (defn parse-annotated-bounds
   "Parse bounds that are annotated with Lat and Lon, returning values
@@ -306,8 +321,9 @@
   ([bounding-box]
    (create-opendap-bounds {:Longitude default-lon-abs-hi
                            :Latitude default-lat-abs-hi} bounding-box))
-  ([{lon-max :Longitude lat-max :Latitude :as _dimensions}
+  ([{lon-max :Longitude lat-max :Latitude :as dimensions}
     [lon-lo lat-lo lon-hi lat-hi :as bounding-box]]
+   (log/debug "Got dimensions:" dimensions)
    (when bounding-box
      (let [lon-lo (lon-lo-phase-shift lon-max lon-lo)
            lon-hi (lon-hi-phase-shift lon-max lon-hi)


history tweaks

history tweaks

--- src/common/deathrow/history.cljs
+++ src/common/deathrow/history.cljs
@@ -16,11 +16,13 @@
   (let [key (events/listen hist goog.history.EventType.NAVIGATE callback-fn)]
     (set! *event-keys* (conj *event-keys* key))))

-(defn get-token [history]
-  (.getToken history))
+(defn get-token
+  ([] (get-token *history*))
+  ([history] (.getToken history)))

-(defn set-token! [history token]
-  (.setToken history token))
+(defn set-token!
+  ([token] (set-token! *history* token))
+  ([history token] (.setToken history token)))

 (defn replace-token!
   ([token] (replace-token! *history* token))
@@ -43,7 +45,7 @@
         curr-host (.. js/window -location -hostname)]
     (when (and (= tag-name "A") (= curr-host target-host))
       (.preventDefault e)
-      (replace-token! token))))
+      (set-token! *history* token))))

 (defn setup-link-dispatcher! [history]
   (let [key (events/listen js/document "click" handle-click)]


allow `Field.special_type` to be unset via API :unamused:

--- src/metabase/api/meta/field.clj
+++ src/metabase/api/meta/field.clj
@@ -39,7 +39,7 @@
   {field_type FieldType
    special_type FieldSpecialType}
   (write-check Field id)
-  (check-500 (upd-non-nil-keys Field id
+  (check-500 (upd Field id
                :field_type      field_type
                :special_type    special_type
                :preview_display preview_display


working on 'be-called' still

working on 'be-called' still

--- src/babel/english/lexicon.clj
+++ src/babel/english/lexicon.clj
@@ -94,9 +94,7 @@
                                        :3plur "were"}}}]
           [(merge common
                   {:synsem {:sem {:pred :be}}})
-           (let [subject-semantics (ref {:spec {:def :possessive}
-                                         :pred :name})
-                 object-semantics (ref :top)]
+           (let [agr (ref :top)]
              (merge common
                     {:intransitivize false
                      :synsem {:sem {:pred :be-called
@@ -152,7 +150,7 @@
                                     :1plur "are called"
                                     :2plur "are called"
                                     :3plur "are called"}}}
-
+
    "be missed" {:synsem {:cat :verb
                          :sem {:pred :mancare}}
                 :english {:future "be missed"
@@ -217,7 +215,6 @@

    "boil" {:synsem {:cat :verb
                 :sem {:pred :boil}}}
-
    "book"
    (unify agreement-noun
           common-noun


added cerrar stem ch.

added cerrar stem ch.

--- src/babel/espanol/lexicon.clj
+++ src/babel/espanol/lexicon.clj
@@ -48,6 +48,11 @@

    "cambiar" {:synsem {:cat :verb
                        :sem {:pred :cambiare}}}
+
+   "cerrar" {:italiano {:boot-stem1 "cierr"
+                        :boot-stem2 "cerr"}
+             :synsem {:cat :verb
+                      :sem {:pred :close}}}

    "comentar" {:synsem {:cat :verb
                         :sem {:pred :comment}}}


weighted-choose in the house

weighted-choose in the house

--- src/overtone/helpers/chance.clj
+++ src/overtone/helpers/chance.clj
@@ -8,6 +8,51 @@
   "Choose a random element from a collection."
   [col]
   (nth col (rand-int (count col))))
+
+(defn weighted-choose
+  "Returns an element from list vals based on the corresponding probabilities
+  list. The length of vals and probabilities should be similar and the sum
+  of all the probabilities should be 1. It is also possible to pass a map of
+  val -> prob pairs as a param.
+
+  The following will return one of the following vals with the corresponding
+  probabilities:
+  1 -> 50%
+  2 -> 30%
+  3 -> 12.5%
+  4 -> 7.5%
+  (weighted-choose [1 2 3 4] [0.5 0.3 0.125 0.075])
+  (weighted-choose {1 0.5, 2 0.3, 3 0.125, 4 0.075"
+  ([val-prob-map] (weighted-choose (keys val-prob-map) (vals (val-prob-map))))
+  ([vals probabilities]
+     (when-not (= (count vals) (count probabilities))
+       (throw (Exception. (str "Size of vals and probabilities don't match. Got "
+                               (count vals)
+                               " and "
+                               (count probabilities)))))
+     (when-not (= (reduce + probabilities) 1)
+       (throw (Exception. (str "The sum of your probabilities is not 1.0"))))
+
+     (let [paired (map vector probabilities vals)
+           sorted (sort #(< (first %1) (first %2)) paired)
+           summed (loop [todo sorted
+                         done []
+                         cumulative 0]
+                    (if (empty? todo)
+                      done
+                      (let [f-prob (ffirst todo)
+                            f-val  (second (first todo))
+                            cumulative (+ cumulative f-prob)]
+                        (recur (rest todo)
+                               (conj done [cumulative f-val])
+                               cumulative))))
+           rand-num (rand)]
+       (loop [summed summed]
+         (when (empty? summed)
+           (throw (Exception. (str "Error, Reached end of weighed choice options"))))
+         (if (< rand-num (ffirst summed))
+           (second (first summed))
+           (recur (rest summed)))))))

 (defn weighted-coin
   "Returns true or false. Probability of true is weighted by n which should be


bug fix with ordering of replacements

bug fix with ordering of replacements


Canvas animations

Canvas animations


added comments

added comments

--- src/lcmap/clownfish/system.clj
+++ src/lcmap/clownfish/system.clj
@@ -25,6 +25,8 @@
      (do (log/info "Stopping mount components")
          (mount/stop)
          (log/info "Starting mount components...")
+         ;; insulation to make sure these states do not get accidentally
+         ;; started
          (mount/start-without #'lcmap.clownfish.setup.db/setup
                               #'lcmap.clownfish.setup.db/teardown
                               #'lcmap.clownfish.setup.event/setup


Update Typescript (1.6.2)

Update Typescript (1.6.2)

--- src/lein_typescript/plugin.clj
+++ src/lein_typescript/plugin.clj
@@ -9,7 +9,7 @@
 ; Internal API: Configuration

 (def ^:private DEF_TYPESCRIPT_DEP "typescript")
-(def ^:private DEF_TYPESCRIPT_VER ">=1.5.4")
+(def ^:private DEF_TYPESCRIPT_VER ">=1.6.2")

 ; Internal API: Middlewares


Adds a `utils` fn to stringify JSON prettily


Night tint harvestable cells

Night tint harvestable cells

--- src/cljc/robinson/render.cljc
+++ src/cljc/robinson/render.cljc
@@ -90,6 +90,10 @@
   (let [avg (bit-shift-right (+ (max r g b) (min r g b)) 1)]
    [avg avg avg]))

+(defn color->rgb
+  [color]
+  (get color-to-rgb-map color color))
+
 (defn darken-rgb
   ([rgb]
   (mapv #(int (/ % 10)) rgb))
@@ -102,9 +106,9 @@
     [r g b]
     [(/ r 4) (/ g 3) (/ (max r g b) 2)]))

-(defn color->rgb
-  [color]
-  (get color-to-rgb-map color color))
+(defn night-tint-npc
+  [[s fg bg] d]
+   [s (night-tint (color->rgb (or fg :white)) d) (color->rgb (or bg :black))])

 (defn move-cursor
   ([^robinson.aterminal.ATerminal screen x y]
@@ -836,7 +840,7 @@
                                                                (update-in out-char [1] (comp rgb->mono darken-rgb))
                                                              (contains? cell :harvestable)
                                                                (let [[chr fg bg] out-char]
-                                                                 [chr bg fg])
+                                                                 [chr bg (night-tint (color->rgb fg) d)])
                                                              (contains? (set (map :id cell-items)) :raft)
                                                                (let [[chr fg bg] out-char]
                                                                  (log/info "raft-cell" out-char cell-items)
@@ -908,46 +912,47 @@
                         (apply put-string screen
                                             vx
                                             vy
-                                            (case (get npc :race)
-                                              :rat             ["r"]
-                                              :spider          ["S"]
-                                              :scorpion        ["\u03C2"] ;;ς
-                                              :snake           ["\u00A7"] ;;§
-                                              :bat             ["B"]
-                                              :boar            ["b" :brown :black]
-                                              :gecko           ["g" :green :black]
-                                              :monkey          ["y" :orange :black]
-                                              :bird            ["a" :red :black]
-                                              :centipede       ["c" :red :black]
-                                              :turtle          ["t" :green :black]
-                                              :red-frog        ["\u03B1" :red :black] ;;α
-                                              :orange-frog     ["\u03B1" :orange :black] ;;α
-                                              :yellow-frog     ["\u03B1" :yellow :black] ;;α
-                                              :green-frog      ["\u03B1" :green :black] ;;α
-                                              :blue-frog       ["\u03B1" :blue :black] ;;α
-                                              :purple-frog     ["\u03B1" :purple :black] ;;α
-                                              :parrot          ["p" :red :black]
-                                              :shark           ["\u039B"] ;;Λ
-                                              :fish            ["f"]
-                                              :octopus         ["#" :orange :black]
-                                              :sea-snake       ["\u00A7"]
-                                              :clam            ["c"]
-                                              :urchin          ["u" :purple :black]
-                                              :squid           ["q" :orange :black]
-                                              :crocodile       ["l" :green :black]
-                                              :mosquito        ["m"]
-                                              :mongoose        ["r" :brown :black]
-                                              :tarantula       ["s" :brown :black]
-                                              :monitor-lizard  ["l" :gray :black]
-                                              :komodo-dragon   ["l" :dark-green :black]
-                                              :cobra           ["\u00A7"] ;;§
-                                              :puffer-fish     ["f" :yellow :black]
-                                              :crab            ["c" :orange :black]
-                                              :hermit-crab     ["c" :yellow :black]
-                                              :electric-eel    ["e" :brown :black]
-                                              :jellyfish       ["j"]
-                                              :human           ["@" (class->rgb (get npc :class)) :black]
-                                              ["@"])))))
+                                            (night-tint-npc
+                                              (case (get npc :race)
+                                                :rat             ["r"]
+                                                :spider          ["S"]
+                                                :scorpion        ["\u03C2"] ;;ς
+                                                :snake           ["\u00A7"] ;;§
+                                                :bat             ["B"]
+                                                :boar            ["b" :brown :black]
+                                                :gecko           ["g" :green :black]
+                                                :monkey          ["y" :orange :black]
+                                                :bird            ["a" :red :black]
+                                                :centipede       ["c" :red :black]
+                                                :turtle          ["t" :green :black]
+                                                :red-frog        ["\u03B1" :red :black] ;;α
+                                                :orange-frog     ["\u03B1" :orange :black] ;;α
+                                                :yellow-frog     ["\u03B1" :yellow :black] ;;α
+                                                :green-frog      ["\u03B1" :green :black] ;;α
+                                                :blue-frog       ["\u03B1" :blue :black] ;;α
+                                                :purple-frog     ["\u03B1" :purple :black] ;;α
+                                                :parrot          ["p" :red :black]
+                                                :shark           ["\u039B"] ;;Λ
+                                                :fish            ["f"]
+                                                :octopus         ["#" :orange :black]
+                                                :sea-snake       ["\u00A7"]
+                                                :clam            ["c"]
+                                                :urchin          ["u" :purple :black]
+                                                :squid           ["q" :orange :black]
+                                                :crocodile       ["l" :green :black]
+                                                :mosquito        ["m"]
+                                                :mongoose        ["r" :brown :black]
+                                                :tarantula       ["s" :brown :black]
+                                                :monitor-lizard  ["l" :gray :black]
+                                                :komodo-dragon   ["l" :dark-green :black]
+                                                :cobra           ["\u00A7"] ;;§
+                                                :puffer-fish     ["f" :yellow :black]
+                                                :crab            ["c" :orange :black]
+                                                :hermit-crab     ["c" :yellow :black]
+                                                :electric-eel    ["e" :brown :black]
+                                                :jellyfish       ["j"]
+                                                :human           ["@" (class->rgb (get npc :class)) :black]
+                                                ["@"]) d)))))
                    place-npcs)))
     (render-hud state)
     (log/info "current-state" (current-state state))


Roids are respawned after the last one is hit. Ship is respawned after it is hit.

--- src/cljs/clojuroids/core.cljs
+++ src/cljs/clojuroids/core.cljs
@@ -12,12 +12,12 @@
   (:require-macros
    [cljs.core.async.macros :refer [alt! go-loop]]))

+(def init-roid-count 4)
+
 (defn timestamp [] (.getTime (js/Date.)))

 (defn update-ship [{:keys [ship flames input]}]
-  (let [ship (->> ship
-                  (map (ship/control input))
-                 (ship/update))
+  (let [ship (-> (map (ship/control input) ship) (ship/update))
         flames (concat flames (ship/flames ship))]
     {:ship ship :flames flames}))

@@ -27,9 +27,36 @@
 (defn animate-frame [objs]
   (render/animate-frame (reduce concat (vals objs))))

+(defn level-check [objs game]
+  (let [roid-count (count (:roids objs))
+        timer (:level-timer game)
+        [o g] (cond
+               (and (= 0 roid-count) (= nil timer))
+               [nil {:level-timer 100}]
+
+               (and (= 0 roid-count) (= 0 timer))
+               [{:roids (roid/create-roids init-roid-count)} {:level-timer nil}]
+
+               (and (= 0 roid-count) (> timer 0))
+               [nil {:level-timer (dec timer)}]
+
+               :else
+               [nil nil])]
+    [(merge objs o) (merge game g)]))
+
+(defn ship-check [objs game]
+  (let [ship-count (count (:ship objs))
+        timer (:ship-timer game)
+        [o g] (cond
+               (and (= 0 ship-count) (= nil timer)) [nil {:ship-timer 100}]
+               (and (= 0 ship-count) (= 0 timer)) [{:ship (ship/create)} {:ship-timer nil}]
+               (and (= 0 ship-count) (> timer 0)) [nil {:ship-timer (dec timer)}]
+               :else [nil nil])]
+    [(merge objs o) (merge game g)]))
+
 (defn game-loop [init-objs]
   (let [input-chan (input/user-input)]
-    (go-loop [objs init-objs start (timestamp)]
+    (go-loop [objs init-objs game nil start (timestamp)]
       (let [objs (merge objs
                         {:input (alt! [input-chan] ([v] v) :default [])}
                         (update-ship objs)
@@ -39,13 +66,15 @@
             objs (merge objs (collisions/shot-roid objs))
             objs (merge objs (collisions/ship-roid objs))
             objs (merge objs {:explosions (explode/update (:explosions objs))})
+            [objs game] (level-check objs game)
+            [objs game] (ship-check objs game)
             end (- (timestamp) start)]
         (animate-frame objs)
         (<! (timeout (- 33 end)))
-        (recur objs (timestamp))))))
+        (recur objs game (timestamp))))))

 ; create some asteroids, the ship, and enter the game loop
-(game-loop {:roids (roid/create-roids 4)
+(game-loop {:roids (roid/create-roids init-roid-count)
             :ship (ship/create)})


remove example scraper, not needed anymore

--- src/cljs_api_gen/examples.clj
+++ src/cljs_api_gen/examples.clj
@@ -1,83 +0,0 @@
-(ns cljs-api-gen.examples
-  (:refer-clojure :exclude [replace])
-  (:require
-    [net.cgrand.enlive-html :as html]
-    [clojure.string :refer [split join replace]]
-    ))
-
-
-;;------------------------------------------------------------
-;; Examples Scraping from clojuredocs.org
-;;------------------------------------------------------------
-
-;; for each symbol
-;;  - transform symbol name to url
-;;  - pull examples
-;;  - write to file
-
-(defn split-ns-symbol
-  [s]
-  (let [[ns- s] (split s #"/")
-        s (if s s "/")] ;; if we are missing a symbol, the split expression threw out the symbol, which has to be "/".
-    [ns- s]))
-
-;; from clojuredocs:
-;; https://github.com/zk/clojuredocs/blob/813caf018bc2f0681553581761c222f3f9b78d7f/src/cljx/clojuredocs/util.cljx#L58-L66
-(defn cd-encode [s]
-  (when s
-    (cond
-      (= "." s) "_."
-      (= ".." s) "_.."
-      :else (-> s
-                (replace #"/" "_fs")
-                (replace #"\\" "_bs")
-                (replace #"\?" "_q")))))
-
-(defn symbol->clojuredocs-url
-  [ns- s]
-  (let [ns- (-> ns-
-                (replace "cljs.core" "clojure.core")
-                (replace "cljs.test" "clojure.test"))
-        s (cd-encode s)]
-    (str "http://clojuredocs.org/" ns- "/" s)))
-
-(defn fetch-url [url]
-  (html/html-resource (java.net.URL. url)))
-
-(defn format-example
-  [example]
-  (join "\n"
-        ["===== Example"
-         ""
-         "```"
-         example
-         "```"
-         ""]))
-
-(defn clojuredocs-examples [url]
-  (let [script-text (-> (fetch-url url) (html/select [:script]) first html/text)
-        [_ m] (re-find #"window\.PAGE_DATA=(.*)" script-text)]
-    (if m
-      (let [data (read-string (read-string m))
-            examples (map :body (:examples data))
-            content (join "\n" (map format-example examples))]
-        content)
-      nil)))
-
-(defn scrape-examples!
-  []
-  (git-docs-repo! "checkout" examples-branch)
-  (let [[_latest history] (get-symbol-history)]
-    (doseq [ns-and-s (sort (:symbols @history))]
-      (let [[ns- s] (split-ns-symbol ns-and-s)
-            filename (str docs-repo-dir "/" ns- "_" (symbol->filename s) ".cljsdoc")
-            url (symbol->clojuredocs-url ns- s)
-            example-content (try (clojuredocs-examples url) (catch Exception e nil))]
-        (if example-content
-          (do
-            (println "scraping" url "... OK")
-            (println "  writing to" filename)
-            (spit filename example-content))
-          (do
-            (println "scraping" url "... FAILED")))))))
-


Adjust duration calculation for polyphony.

--- src/klangmeister/processing.cljs
+++ src/klangmeister/processing.cljs
@@ -29,6 +29,9 @@
   (process [this handle! {notes :music :as state}]
     (when (:looping? state)
       (music/play-on! instrument/beep! notes)
-      (let [duration (->> notes (map :duration) (reduce +) (* 1000))]
+      (let [duration (->> notes
+                          (map (fn [{:keys [time duration]}] (+ time duration)))
+                          (apply max)
+                          (* 1000))]
         (js/setTimeout #(handle! this) duration)))
     state))


Use JavaScript data structures for communication with audio workers

--- src/main/audio_utils/worker.cljs
+++ src/main/audio_utils/worker.cljs
@@ -31,8 +31,9 @@
                     (let [sample (aget input-data n)]
                       (aset output-data n sample)
                       (.push (aget worker-data channel) sample)))))
-              (.postMessage worker (clj->js {:name :worker-process-audio
-                                             :data worker-data})))))))
+              (.postMessage worker (doto #js []
+                                     (aset "name" "worker-process-audio")
+                                     (aset "data" worker-data))))))))

 (defn worker-entry-node
   "Creates an IWorkerAudioNode in a worker that receives its audio
@@ -51,11 +52,11 @@
                    (process-audio @next data))))]
     (set! (.-onmessage js/self)
           (fn [msg]
-            (let [clj-msg (js->clj (.-data msg))
-                  name    (keyword (clj-msg "name"))
-                  data    (clj-msg "data")]
-              (when (= name :worker-process-audio)
-                (process-audio node data)))))
+            (let [name     (aget (.-data msg) "name")
+                  data     (aget (.-data msg) "data")
+                  clj-data (js->clj data)]
+              (when (= name "worker-process-audio")
+                (process-audio node clj-data)))))
     node))

 (defn worker-exit-node
@@ -67,16 +68,16 @@
     (connect [this destination])
     (disconnect [this])
     (process-audio [this data]
-      (.postMessage js/self (clj->js {:name :main-process-audio
-                                      :data data})))))
+      (.postMessage js/self (doto #js {}
+                              (aset "name" "main-process-audio")
+                              (aset "data" data))))))

 (defn main-exit-node
   [worker data-fn]
   (set! (.-onmessage worker)
         (fn [msg]
-          (let [clj-msg (js->clj (.-data msg))
-                name    (keyword (clj-msg "name"))
-                data    (clj-msg "data")]
-            (when (= name :main-process-audio)
+          (let [name    (aget (.-data msg) "name")
+                data    (aget (.-data msg) "data")]
+            (when (= name "main-process-audio")
               (when data-fn
                 (data-fn data)))))))


Exclude older CLJS versions from test

Exclude older CLJS versions from test

--- test/expound/problems_test.cljc
+++ test/expound/problems_test.cljc
@@ -234,13 +234,13 @@
              first
              (select-keys [:expound/in :val :reason])))))

-;; 1.9.562 doesn't implement map-entry?
-(when-not #?(:clj false :cljs (= *clojurescript-version* "1.9.562"))
+;; map-entry? introduced in CLJS 1.10.238
+(when-not #?(:clj false :cljs (contains? #{"1.9.562" "1.9.946"} *clojurescript-version* ))
   (defn nth-value [form i]
     (let [seq (remove map-entry? (tree-seq coll? seq form))]
       (nth seq (mod i (count seq))))))

-(when-not #?(:clj false :cljs (= *clojurescript-version* "1.9.562"))
+(when-not #?(:clj false :cljs (contains? #{"1.9.562" "1.9.946"} *clojurescript-version* ))
   ;; TODO - move to paths
   (deftest paths-to-value-test
     (checking


more test debugging

more test debugging

--- test/integration/test/slice.clj
+++ test/integration/test/slice.clj
@@ -27,6 +27,7 @@
 (deftest ^:integration test-json
   (testing "it returns a content-type of application/json"
     (let [resp (GET "/data/integration_test/slice/incomes.json")]
+      (print "RESPONSE" resp)
       (does= (:status resp) 200)
       (does-contain (:headers resp)
                     {"Content-Type" "application/json;charset=UTF-8"}))))
@@ -34,6 +35,7 @@
 (deftest ^:integration test-jsonp
   (testing "it uses the callback we supply"
     (let [resp (GET "/data/integration_test/slice/incomes.jsonp?$callback=foo")]
+      (print "RESPONSE" resp)
       (does= (:status resp) 200)
       (does-contain (:headers resp)
                     {"Content-Type" "text/javascript;charset=UTF-8"})
@@ -41,6 +43,7 @@

   (testing "it uses 'callback' by default"
     (let [resp (GET "/data/integration_test/slice/incomes.jsonp")]
+      (print "RESPONSE" resp)
       (does= (:status resp) 200)
       (does-contain (:headers resp)
                     {"Content-Type" "text/javascript;charset=UTF-8"})


First semblance of time travel

First semblance of time travel

--- src/divergence/component.cljs
+++ src/divergence/component.cljs
@@ -74,7 +74,7 @@
   (component :fps-counter true))

 (def collidable
-  (component :collidable :true))
+  (component :collidable true))

 (def accelerates
   (component :acceleration [0 0 0]))
@@ -88,4 +88,12 @@
 (def climbing
   (component :climbing 0))

+(def time-based-state
+  "Anything whose state (e.g. position, velocity...) changes based of time"
+  (component :time-base-state true))

+(defn gravity
+  "Gravity settings should be:
+   [x-acceleration y-acceleration rot-acceleration]"
+  [gravity-settings]
+  (component :gravity gravity-settings))


Wait a bit longer in tests

Wait a bit longer in tests

--- test/muon_clojure/core_test.clj
+++ test/muon_clojure/core_test.clj
@@ -61,7 +61,7 @@
           (with-muon c (subscribe!
                          (str "stream://" uuid "/stream-test")))
           _ (println "After stream-channel-order")
-          _ (Thread/sleep 10000)
+          _ (Thread/sleep 20000)
           not-ordered-0 (<!! (clojure.core.async/reduce
                               (fn [prev n] (concat prev `(~n)))
                               '() stream-channel-0))


4Clojure - problem 86

4Clojure - problem 86

--- src/fourclojure/4_clojure.clj
+++ src/fourclojure/4_clojure.clj
@@ -25,10 +25,11 @@

 ;problem 86
 ((fn [x]
-   (letfn [(square [y] (* y y))]
-     (loop [s (str x)]
-       (let [s2 (reduce + (map #(square (Integer/parseInt (str %))) s))]
+   (letfn [(square-ch [y] (let [n (Integer/parseInt (str y))] (* n n)))]
+     (loop [s (str x) ctrl #{}]
+       (let [s2 (reduce + (map #(square-ch %) s))]
+         (println s2)
          (cond
            (= s2 1) true
-           (= s2 x) false
-           :else (recur (str s2))))))) 2)+           (ctrl s2) false
+           :else (recur (str s2) (conj ctrl s2))))))) 7)


Use keep instead of map + remove

Use keep instead of map + remove

Co-Authored-By: Szabó Krisztián <509c28f63eb4b0a9fa210ded0c2640ef2f75a9c4@gmail.com>

--- src/github_changelog/core.clj
+++ src/github_changelog/core.clj
@@ -42,8 +42,7 @@

 (defn ^:no-gen assoc-pulls [pulls {:keys [commits] :as tag}]
   (->> commits
-       (map (partial find-pull pulls))
-       (remove nil?)
+       (keep (partial find-pull pulls))
        (assoc tag :pulls)))

 (s/fdef assoc-pulls


support re-using a custom executor, remove redefs for now

--- src/main/shadow/cljs/build.clj
+++ src/main/shadow/cljs/build.clj
@@ -23,13 +23,14 @@
            [com.google.javascript.jscomp JSModule SourceFile JSModuleGraph CustomPassExecutionTime]
            (java.util.jar JarFile JarEntry)
            (com.google.javascript.jscomp.deps JsFileParser)
-           [java.util.concurrent Executors Future]
+           [java.util.concurrent Executors Future ExecutorService]
            (com.google.javascript.jscomp ReplaceCLJSConstants CompilerOptions CommandLineRunner JSError ErrorFormat CheckLevel LightweightMessageFormatter SourceMapInput BasicErrorManager CompilerOptions$LanguageMode CompilerInput ProcessEs6Modules SourceMap SourceMap$LocationMapping VariableMap)
            (java.security MessageDigest)
            (javax.xml.bind DatatypeConverter)
            (cljs.tagged_literals JSValue)))

 ;; (set! *warn-on-reflection* true)
+(defonce stdout-lock (Object.))

 (def SHADOW-TIMESTAMP
   (-> (io/resource "shadow/cljs/build.clj")
@@ -746,47 +747,56 @@
       (rewrite-ns-aliases compiler-state)
       (assoc :env env :form form :op :ns)))

-(def default-parse ana/parse)
-
-(defn shadow-parse [op env form name opts]
-  (condp = op
-    ;; the default ana/parse 'ns has way too many side effects we don't need or want
-    ;; don't want analyze-deps -> never needed
-    ;; don't want require or macro ns -> post-analyze
-    ;; don't want check-uses -> doesn't recognize macros
-    ;; don't want check-use-macros -> doesnt handle (:require [some-ns :refer (a-macro)])
-    ;; don't want swap into compiler env -> post-analyze
-    'ns (hijacked-parse-ns env form name opts)
-    (default-parse op env form name opts)))
-
-(def default-analyze-form ana/analyze-form)
-
-;; FIXME: doing this so I can access the form that caused a warning
-;; some warnings do not include it, should really provide patches to add them
-;; but this is simpler and an experiment anyways
-(defn shadow-analyze-form
-  [env form name opts]
-  (let [warnings-before
-        @*cljs-warnings-ref*
-
-        result
-        (default-analyze-form env form name opts)
-
-        warnings-after
-        @*cljs-warnings-ref*]
-
-    (when-not (identical? warnings-before warnings-after)
-      (swap! *cljs-warnings-ref*
-        (fn [warnings]
-          (->> warnings
-               (map (fn [x]
-                      (if (contains? x :form)
-                        x
-                        (assoc x :form form))))
-               (into [])
-               ))))
-    result
-    ))
+;; FIXME: this hijacks unconditionally which may break other CLJS tools
+;; with-redefs is probably safer
+(defmethod ana/parse 'ns
+  [op env form name opts]
+  (hijacked-parse-ns env form name opts))
+
+(comment
+  ;; FIXME: these rely on with-redefs which isn't threadsafe
+
+  (def default-parse ana/parse)
+
+  (defn shadow-parse [op env form name opts]
+    (condp = op
+      ;; the default ana/parse 'ns has way too many side effects we don't need or want
+      ;; don't want analyze-deps -> never needed
+      ;; don't want require or macro ns -> post-analyze
+      ;; don't want check-uses -> doesn't recognize macros
+      ;; don't want check-use-macros -> doesnt handle (:require [some-ns :refer (a-macro)])
+      ;; don't want swap into compiler env -> post-analyze
+      'ns (hijacked-parse-ns env form name opts)
+      (default-parse op env form name opts)))
+
+  (def default-analyze-form ana/analyze-form)
+
+  ;; FIXME: doing this so I can access the form that caused a warning
+  ;; some warnings do not include it, should really provide patches to add them
+  ;; but this is simpler and an experiment anyways
+  (defn shadow-analyze-form
+    [env form name opts]
+    (let [warnings-before
+          @*cljs-warnings-ref*
+
+          result
+          (default-analyze-form env form name opts)
+
+          warnings-after
+          @*cljs-warnings-ref*]
+
+      (when-not (identical? warnings-before warnings-after)
+        (swap! *cljs-warnings-ref*
+          (fn [warnings]
+            (->> warnings
+                 (map (fn [x]
+                        (if (contains? x :form)
+                          x
+                          (assoc x :form form))))
+                 (into [])
+                 ))))
+      result
+      )))

 (defn analyze
   ([state compile-state form]
@@ -1888,7 +1898,8 @@
   (assoc src :output @input))

 (defn generate-output-for-source [state {:keys [name type output warnings] :as src}]
-  {:pre [(valid-resource? src)]}
+  {:pre [(valid-resource? src)]
+   :post [(string? (:output %))]}
   (when (= name "goog/base.js")
     (throw (ex-info "trying to compile goog/base.js" {})))

@@ -1912,11 +1923,15 @@
 (defn load-core-noop [])

 (defmacro shadow-redefs [& body]
-  `(locking REDEF-LOCK
-     (with-redefs [ana/parse shadow-parse
-                   ana/load-core load-core-noop
-                   ana/analyze-form shadow-analyze-form]
-       ~@body)))
+  ;; FIXME: can't redef without the lock
+  ;; but the lock prevents multiple builds from running in parallel
+  #_(locking REDEF-LOCK
+      (with-redefs [ana/parse shadow-parse
+                    ana/load-core load-core-noop
+                    ana/analyze-form shadow-analyze-form]
+        ~@body))
+
+  `(do ~@body))

 (defn do-compile-sources
   "compiles with just the main thread, can do partial compiles assuming deps are compiled"
@@ -1985,7 +2000,7 @@
 (defn par-compile-sources
   "compile files in parallel, files MUST be in dependency order and ALL dependencies must be present
    this cannot do a partial incremental compile"
-  [{:keys [n-compile-threads] :as state} source-names]
+  [state source-names]
   (with-compiler-env state
     (ana/load-core)
     (shadow-redefs
@@ -1998,18 +2013,22 @@
             (atom {})

             exec
-            (Executors/newFixedThreadPool n-compile-threads)
+            (or (:executor state)
+                (Executors/newFixedThreadPool (:n-compile-threads state)))

             tasks
             (->> (for [source-name source-names]
                    ;; bound-fn for with-compiler-state
                    (let [task-fn (bound-fn [] (par-compile-one state ready errors source-name))]
-                     (.submit exec ^Callable task-fn)))
+                     ;; things go WTF without the type tags, tasks will return nil
+                     (.submit ^ExecutorService exec ^Callable task-fn)))
                  (doall) ;; force submit all, then deref
                  (into [] (map deref)))]

-        ;; FIXME: might deadlock here if any of the derefs fail
-        (.shutdown exec)
+        ;; only shutdown executor if we werent given one
+        (when-not (contains? state :executor)
+          ;; FIXME: might deadlock here if any of the derefs fail
+          (.shutdown exec))

         ;; unlikely to encounter 2 concurrent errors
         ;; so unpack for a single error for better stacktrace
@@ -2024,6 +2043,8 @@
             (update :sources (fn [sources]
                                (reduce
                                  (fn [sources {:keys [name] :as src}]
+                                   (when (nil? src)
+                                     (throw (ex-info "a compile task returned nil?" {})))
                                    (assoc sources name src))
                                  sources
                                  tasks)))
@@ -3112,8 +3133,6 @@
 (defn get-closure-compiler [state]
   (::cc state))

-(defonce stdout-lock (Object.))
-
 (def stdout-log
   (reify log/BuildLog
     (log* [_ state evt]


Make sure an entry patch can't change a poll's votes data but only add/remove/update polls and replies.

--- src/oc/storage/api/entries.clj
+++ src/oc/storage/api/entries.clj
@@ -60,6 +60,31 @@
         [false, {:reason (.getMessage e)}])) ; Not a valid new entry
     [false, {:reason "Invalid board."}])) ; couldn't find the specified board

+(defn- clean-polls-for-patch
+  "Given the new"
+  [existing-entry entry]
+  (update entry :polls (fn [polls]
+   (mapv (fn [poll]
+    (if-let [existing-poll (some #(when (= (:poll-uuid %) (:poll-uid poll)) %) (:polls existing-entry))]
+      ;; Make sure we keep the votes that are currently saved, client can't update votes with an entry patch
+      ;; but can add/delete/update replies.
+      (let [updated-replies (mapv (fn [reply]
+                             (let [existing-reply (some #(when (= (:reply-id %) (:reply-id reply)) %)
+                                                   (:replies existing-poll))
+                                   reply-votes (or (:votes existing-reply) (:votes reply) 0)]
+                               (-> reply
+                                (assoc :votes reply-votes)
+                                (assoc :votes-count (count reply-votes)))))
+                              (:replies poll))
+            sorted-replies (sort-by (juxt :votes-count :created-at) updated-replies)]
+        (-> poll
+         ;; Replace replies with new sorted ones
+         (assoc :replies sorted-replies)
+         ;; Update the total count
+         (assoc :total-votes-count (reduce + (map :votes-count updated-replies)))))
+      poll))
+    polls))))
+
 (defn- valid-entry-update? [conn entry-uuid entry-props user entry-publish?]
   (if-let [existing-entry (entry-res/get-entry conn entry-uuid)]
     ;; Merge the existing entry with the new updates
@@ -77,7 +102,8 @@
                   (assoc with-status-props :board-uuid new-board-uuid)
                   (dissoc with-status-props :board-uuid))
           merged-entry (merge existing-entry (entry-res/ignore-props props))
-          updated-entry (update merged-entry :attachments #(entry-res/timestamp-attachments %))
+          with-attachments (update merged-entry :attachments #(entry-res/timestamp-attachments %))
+          updated-entry (clean-polls-for-patch existing-entry with-attachments)
           ts (db-common/current-timestamp)]
       (if (lib-schema/valid? common-res/Entry updated-entry)
         {:existing-entry (api-common/rep existing-entry)
@@ -421,7 +447,7 @@
   (let [user-has-voted? (some #(when (= % (:user-id user)) %) (:replies poll))

         updated-poll-replies (mapv (partial update-reply (:user-id user) reply-id add?) (:replies poll))
-        sorted-replies (reverse (sort-by :votes-count updated-poll-replies))
+        sorted-replies (reverse (sort-by (juxt :votes-count :created-at) updated-poll-replies))
         updated-poll (merge poll {:replies sorted-replies :total-votes-count (reduce + (map :votes-count sorted-replies))})
         filtered-polls (filterv #(not= (:poll-uuid %) (:poll-uuid poll)) (:polls entry))
         final-entry (assoc entry :polls (vec (conj filtered-polls updated-poll)))


Fix board passed in when selecting posts for a single board.

--- src/oc/storage/api/entries.clj
+++ src/oc/storage/api/entries.clj
@@ -383,7 +383,7 @@
     (let [old-board (:moving-board ctx)]
       ;; If we are moving the entry from a draft board, check if we need to remove the board itself.
       (when old-board
-        (let [remaining-entries (entry-res/list-all-entries-by-board conn (:uuid old-board))]
+        (let [remaining-entries (entry-res/list-all-entries-by-board conn old-board)]
           (board-res/maybe-delete-draft-board conn org old-board remaining-entries user)))
       (timbre/info "Updated entry for:" entry-for)
       (notification/send-trigger! (notification/->trigger :update org board {:old entry :new updated-result} user nil (api-common/get-change-client-id ctx)))
@@ -444,7 +444,7 @@
       (undraft-board conn user org board)
       ;; If we are moving the entry from a draft board, check if we need to remove the board itself.
       (when old-board
-        (let [remaining-entries (entry-res/list-all-entries-by-board conn (:uuid old-board))]
+        (let [remaining-entries (entry-res/list-all-entries-by-board conn old-board)]
           (board-res/maybe-delete-draft-board conn org old-board remaining-entries user)))
       (entry-res/delete-versions conn final-entry)
       (auto-share-on-publish conn ctx final-entry)
@@ -462,7 +462,7 @@
     (do
       ;; If deleting a draft on a draft board
       (when (= (keyword (:status entry)) :draft)
-        (let [remaining-entries (entry-res/list-all-entries-by-board conn (:uuid board))]
+        (let [remaining-entries (entry-res/list-all-entries-by-board conn board)]
           (board-res/maybe-delete-draft-board conn org board remaining-entries (:user ctx))))
       (when (not= (keyword (:status entry)) :published)
         (entry-res/delete-versions conn (assoc entry :delete-entry true)))


Revert "Make alpha/beta/etc versions incompatible with each other."

This reverts commit ae9cd69e738069965b2a97784bb7b7fd833be8b6.

--- src/onyx/peer/log_version.cljc
+++ src/onyx/peer/log_version.cljc
@@ -3,7 +3,7 @@
 (def version "0.10.0-SNAPSHOT")

 (defn check-compatible-log-versions! [cluster-version]
-  (when-not (or (re-find #"-SNAPSHOT" version)
+  (when-not (or (re-find #"-" version)
                  (= version cluster-version))
     (throw (ex-info "Incompatible versions of the Onyx cluster coordination log.
                      A new, distinct, :onyx/tenancy-id should be supplied when upgrading or downgrading Onyx."


Whitespace

Whitespace

--- src/oxcart/passes/warnings.clj
+++ src/oxcart/passes/warnings.clj
@@ -216,7 +216,7 @@
   -----------
   This pass takes no options."
   [whole-ast options]
-  (let [error?   (atom false)]
+  (let [error? (atom false)]
     (doseq [ast (whole-ast->forms whole-ast)]
       (when-not (pattern/def? ast)
         (reset! error? true)


Corrected ommision in votes-base rewrite in conv-update

--- src/polismath/conversation.clj
+++ src/polismath/conversation.clj
@@ -223,7 +223,8 @@
                              {:tid tid
                               :A (agg-bucket-votes-for-tid bid-to-pid rating-mat agree? tid)
                               :D (agg-bucket-votes-for-tid bid-to-pid rating-mat disagree? tid)}))
-                          (reduce (fn [o entry] (assoc o (:tid entry) (dissoc entry :tid)))))))
+                          (reduce (fn [o entry] (assoc o (:tid entry) (dissoc entry :tid)))
+                                  {}))))

      ; End of large-update
      }))


Adding exception handling to mod-update

Adding exception handling to mod-update

--- src/polismath/conversation.clj
+++ src/polismath/conversation.clj
@@ -394,15 +394,22 @@
 (defn mod-update
   "Take a conversation record and a seq of moderation data and updates the conversation's mod-out attr"
   [conv mods]
-  (let [mod-sep (fn [mod] (->> mods (filter (comp #{mod} :mod)) (map :tid)))
-        mod-out (mod-sep -1)
-        mod-in  (mod-sep 1)]
-    (update-in conv
-               [:mod-out]
-               (plmb/fn->
-                 (set)
-                 (into mod-out)
-                 (clojure.set/difference mod-in)))))
+  (try
+    (let [mod-sep (fn [mod] (->> mods
+                                 (filter (comp #{mod} :mod))
+                                 (map :tid)))
+          mod-out (mod-sep -1)
+          mod-in  (mod-sep 1)]
+      (update-in conv
+                 [:mod-out]
+                 (plmb/fn->
+                   (set)
+                   (into mod-out)
+                   (clojure.set/difference mod-in))))
+    (catch Exception e
+      (log/error "Problem running mod-update with mod-out:" (:mod-out conv) "and mods:" mods ":" e)
+      (.printStackTrace e)
+      conv)))

 ;; Creating some overrides for how core.matrix instances are printed, so that we can read them back via our


CMR-3195: Changed the name of the new assert-invalid-* function.

--- system-int-test/test/cmr/system_int_test/ingest/collection_validation_test.clj
+++ system-int-test/test/cmr/system_int_test/ingest/collection_validation_test.clj
@@ -83,7 +83,7 @@
                        :errors errors}]}
             (select-keys response [:status :errors]))))))

-(defn assert-invalid-with-valid-schema
+(defn assert-invalid-dif10
   ([coll-attributes field-path errors]
    (assert-invalid coll-attributes field-path errors nil))
   ([coll-attributes field-path errors options]
@@ -369,8 +369,8 @@
     (assert-valid {:product-specific-attributes [(dc/psa {:name "bool1" :data-type :boolean :value true})
                                                  (dc/psa {:name "bool2" :data-type :boolean :value true})]}))
   (testing "Enabling UMM-Spec validation through Cmr-Validate-Umm-C header"
-    ;; create a dif10 collection valid against schema, but invalid against umm-spec validation
-    (assert-invalid-with-valid-schema
+    ;; create an old umm collection using dif10, valid against schema, but invalid against umm-spec validation
+    (assert-invalid-dif10
       {:processing-level-id
        "1"
        :product-specific-attributes


cleanup

cleanup

--- src/selmer/template_parser.clj
+++ src/selmer/template_parser.clj
@@ -5,27 +5,10 @@
             [clojure.string :refer [split trim]])
   (:import java.io.StringReader))

-(declare find-template-dependencies)
+(declare find-template-dependencies insert-includes preprocess-template)

 (defn get-tag-name [tag-id block-str]
   (-> block-str (split tag-id) second (split #"%") first trim))
-
-(defn handle-includes
-  "parse any included templates and splice them in replacing the include tags"
-  [template]
-  (let [buf (StringBuilder.)]
-    (with-open [rdr (reader (StringReader. template))]
-    (loop [ch (read-char rdr)]
-      (when ch
-        (if (= *tag-open* ch)
-          (let [tag-str (read-tag-content rdr)]
-            (.append buf
-              (if (re-matches #"\{\%\s*include.*" tag-str)
-                (preprocess-template (.replaceAll (get-tag-name #"include" tag-str) "\"" ""))
-              tag-str)))
-          (.append buf ch))
-        (recur (read-char rdr))))
-    (.toString buf))))

 (defn handle-extends [template templates path]
   (find-template-dependencies path (assoc-in templates [template :extends] path)))
@@ -47,6 +30,18 @@
       (handle-block template templates (first args))

       templates)))
+
+(defn find-template-dependencies [filename & [templates]]
+  (with-open [rdr (reader (str (resource-path) filename))]
+    (loop [templates (assoc (or templates {}) filename {})
+           ch       (read-char rdr)]
+      (if ch
+        (recur
+          (if (= *tag-open* ch)
+            (handle-tag filename templates rdr)
+            templates)
+          (read-char rdr))
+        templates))))

 (defn consume-block [rdr]
   (loop [ch (read-char rdr)
@@ -106,17 +101,22 @@
     (recur parent templates)
     template))

-(defn find-template-dependencies [filename & [templates]]
-  (with-open [rdr (reader (str (resource-path) filename))]
-    (loop [templates (assoc (or templates {}) filename {})
-           ch       (read-char rdr)]
-      (if ch
-        (recur
-          (if (= *tag-open* ch)
-            (handle-tag filename templates rdr)
-            templates)
-          (read-char rdr))
-        templates))))
+(defn insert-includes
+  "parse any included templates and splice them in replacing the include tags"
+  [template]
+  (let [buf (StringBuilder.)]
+    (with-open [rdr (reader (StringReader. template))]
+    (loop [ch (read-char rdr)]
+      (when ch
+        (if (= *tag-open* ch)
+          (let [tag-str (read-tag-content rdr)]
+            (.append buf
+              (if (re-matches #"\{\%\s*include.*" tag-str)
+                (preprocess-template (.replaceAll (get-tag-name #"include" tag-str) "\"" ""))
+              tag-str)))
+          (.append buf ch))
+        (recur (read-char rdr))))
+    (.toString buf))))

 (defn preprocess-template [filename]
   (let [templates (find-template-dependencies filename)
@@ -124,7 +124,9 @@
     (-> filename
         (find-root templates)
         (fill-blocks blocks)
-        handle-includes)))
+        insert-includes)))
+
+

 #_(preprocess-template "templates/inheritance/inherit-c.html")


Ignoring files and directories that start with @

--- src/video_server/directory.clj
+++ src/video_server/directory.clj
@@ -25,10 +25,10 @@

 (defn hidden?
   "Returns whether the file or directory is hidden using common file
-  nameing conventions."
+  naming conventions."
   [^File file]
   (or (.isHidden file)
-      (some #(.startsWith (.getName file) %) ["." "$"])))
+      (some #(.startsWith (.getName file) %) ["." "$" "@"])))

 (defn- register
   "Recursively registers a directory, calling the dir-fn with a


SER-532 Changes image-review status ednpoint to match actual implementation

--- src/vignette/util/services.clj
+++ src/vignette/util/services.clj
@@ -17,4 +17,4 @@
     (str
      (consul/->uri
       (consul/find-service
-        consul/create-consul "image-review" consul/service-query-tag)) "/image-review/image/" oid "?" statuses-params)))
+        consul/create-consul "image-review" consul/service-query-tag)) "/image-review/image/" oid "/status?" statuses-params)))


Replacing routes

Replacing routes

--- src/wishlistd/views/routes.clj
+++ src/wishlistd/views/routes.clj
@@ -2,5 +2,8 @@
   (:require [wishlistd.views.wishlist :as wishlist])
   (:use noir.core))

-(defpage "/" [] (wishlist/main-page))
-(defpage "/create-wishlist" [] (wishlist/create-wishlist))
+(defpage "/" []
+  (wishlist/main-page))
+
+(defpage "/create-wishlist" []
+  (wishlist/create-wishlist-json))


Add a :main clause to the sample's project.clj file.

--- sample/project.clj
+++ sample/project.clj
@@ -2,4 +2,4 @@
   :dependencies [[org.clojure/clojure "1.1.0-master-SNAPSHOT"]
                  [rome/rome "0.9"]
                  [org.ccil.cowan.tagsoup/tagsoup "1.2"]]
-  :namespaces [nom.nom.nom])
+  :main nom.nom.nom)


:zap: Improve performance of `concat` operation.

--- common/uxbox/common/data.cljc
+++ common/uxbox/common/data.cljc
@@ -28,12 +28,12 @@

 (defn concat
   [& colls]
-  (loop [result (first colls)
+  (loop [result (transient (first colls))
          colls (rest colls)]
     (if (seq colls)
-      (recur (reduce conj result (first colls))
+      (recur (reduce conj! result (first colls))
              (rest colls))
-      result)))
+      (persistent! result))))

 (defn enumerate
   ([items] (enumerate items 0))


Strip trailing slashes from paths.

Strip trailing slashes from paths.

Fixes #1151 client-side.

--- frontend/routes.cljs
+++ frontend/routes.cljs
@@ -170,6 +170,8 @@
       (open-to-outer! nav-ch :landing params))))

 (defn define-spec-routes! [nav-ch]
+  (defroute trailing-slash #"(.+)/$" [path]
+    (put! nav-ch [:navigate! {:path path :replace-token? true}]))
   (defroute v1-not-found "*" []
     (open-to-outer! nav-ch :error {:status 404})))


Use idiomatic functions in lib

Use idiomatic functions in lib

--- src/discuss/utils/common.cljs
+++ src/discuss/utils/common.cljs
@@ -169,7 +169,7 @@
 (defn error?
   "Return boolean indicating if there are errors or not."
   []
-  (not (empty? (load-from-app-state :layout/error))))
+  (seq (load-from-app-state :layout/error)))

 (defn error!
   "Set error message."
@@ -236,7 +236,7 @@
   "Keep last-api call. Useful to login and then re-request the url to jump to the
   same position in the discussion, but this time as a logged in user."
   [url]
-  (when-not (empty? url)
+  (when (seq url)
     (store-to-app-state! 'api/last-call url)))

 (defn get-last-api


remove forgotten print

remove forgotten print

--- src/district0x/ui/events.cljs
+++ src/district0x/ui/events.cljs
@@ -131,7 +131,7 @@
   :district0x/set-current-location-as-active-page
   interceptors
   (fn [_ args]
-    {:dispatch [:district0x/set-active-page (apply d0x-ui-utils/match-current-location (print.foo/look args))]}))
+    {:dispatch [:district0x/set-active-page (apply d0x-ui-utils/match-current-location args)]}))

 (reg-event-fx
   :district0x/set-active-page


Load tags from db.

Load tags from db.

--- web/src/twitter_hashtags_visualizer/handler.clj
+++ web/src/twitter_hashtags_visualizer/handler.clj
@@ -32,8 +32,9 @@
 (def tags (atom {}))

 (defn query-top-tags []
-  (let [tags ["monkey" "cat" "horse" "pig" "football" "hockey" "skating" "golf"]]
-    (map #(hash-map :tag % :count (rand-int 10)) tags)))
+  (take 10 (jdbc/query pooled-db-spec
+                       ["select * from tag_count where valid_to > current_timestamp"]
+                       :row-fn #(select-keys % [:tag :count]))))

 (defn update-tags []
   (swap! tags (fn [_] (query-top-tags))))


Include separator between date and time, pefix sha with "g" (following git-describe).

--- src/leiningen/git_version.clj
+++ src/leiningen/git_version.clj
@@ -4,7 +4,7 @@
             [leiningen.core.main :as lmain])
   (:import [java.util Date]))

-(def timestamp-fmt "yyyyMMddhhmmss")
+(def timestamp-fmt "yyyyMMdd_hhmmss")

 (defn formatted-timestamp
   [fmt t]
@@ -25,16 +25,19 @@
 (defn format-git-ver
   [gver fmt]
   (let [{:keys [ctime sha]} gver]
-    (str "-" (formatted-timestamp fmt ctime) "-" sha)))
+    (str "-" (formatted-timestamp fmt ctime) "-g" sha)))

 (defn ver-parse
   "Parses jar-path-like-string or artifact-version-string to find ctime and sha.
    Can handle cases in the range of:
      1.2.3-20120219223112-abc123f
-     foo-1.2.3-20120219223112-abc123f
-     /path/to/foo-1.2.3-20120219223112-abc123f19ea8d29b13.jar"
+     1.2.3-20120219_223112-gabc123f
+     foo-1.2.3-20120219223112-gabc123f
+     foo-1.2.3-20120219_223112-abc123f
+     /path/to/foo-1.2.3-20120219_223112-gabc123f19ea8d29b13.jar"
   [ver-str]
-  (let [[_ ctime sha] (re-matches #".*-?([0-9]{14})-([a-f0-9]{5,40})(?:\.jar)?$" ver-str)]
+  (let [[_ ctime sha] (re-matches #".*-?([0-9]{8}_?[0-9]{6})-g?([a-f0-9]{4,40})(?:\.jar)?$" ver-str)
+        ctime (s/replace ctime #"_" "")]
     (when (and ctime sha)
       {:ctime ctime :sha sha})))


[#2812] Fix failing update logic flow

[#2812] Fix failing update logic flow