flow.cljs

(ns fp.flow
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require
    [om.core :as om :include-macros true]
    [cljs.pprint :as pprint]
    [pdfn.core :refer [and* or* not* is*] :refer-macros [defpdfn pdfn inspect]]
    [fp.cache :as cache]
    [fp.canvas :as c]
    [css.units :as u]
    [cljs.core.async :as async :refer [>! <! put! chan dropping-buffer]]
    [fp.selection]
    [fp.insertion]
    [fast.core :as fast :refer [-o -uid -native -styles -cached -purge -store -add -compute]]
    [commands.core]
    [fast.util]
    [skin.data]
    [sync.core][sync.space][sync.mouse]
    [sync.convert]
    [sync.matrix :as x]
    [fp.refs :refer [doc-ref root-ref ui-color]])
  (:use
    [sync.animation :only [->f dirty]]
    [sync.convert :only [convert]]
    [sync.mouse :only [drag-fns! ->click ->drag-start ->drag ->drag-end ->change-uid ->nodrag-doc-xy]]))

(defn get-resize-points [bounds]
  (let [[[l t] [r b]] bounds
        [hm vm] [(+ l (* (- r l) 0.5)) (+ t (* (- b t) 0.5))]]
    #js[#js [l t]                                           ;:nw-resize
        #js [hm t]                                          ;:n-resize
        #js [r t]                                           ;:ne-resize
        #js [l vm]                                          ;:w-resize
        #js [r vm]                                          ;:e-resize
        #js [l b]                                           ;:sw-resize
        #js [hm b]                                          ;:s-resize
        #js [r b]                                           ;:se-resize
        ]))

(def Bounds (atom [[0 0][0 0]]))
(def Resizers (atom (get-resize-points [[10 10] [10 10]])))


(defn set-cursor
  ([cursor] (set-cursor :body cursor))
  ([target cursor]
   (cond (= target :workspace) 
         (sync.core/inject-css "_workspace_cursor" (str "body, body *{cursor: " cursor " !important;}"))
         (= target :body) 
         (reset! skin.data/cursor cursor))))

(defn cache-colors []
  (let [options (doc-ref :options)
        rulers (:rulers options)
        workspace-opts (:workspace options)]
    (cache/push "options:show-rulers"  (:value (:show rulers)))
    (cache/push "options:show-lines"  (:value (:show-lines workspace-opts)))
    (cache/push "options:show-measures"  (:value (:show-measure workspace-opts))))
    (cache/push ":workspace :selection :info :text" (fp.util/vec->colorstr (ui-color :workspace :selection :info :text)))
    (cache/push "workspace :selection :info :background" (fp.util/vec->colorstr (ui-color :workspace :selection :info :background)))
    (cache/push ":workspace :guides" (fp.util/vec->colorstr (ui-color :workspace :guides)))
    (cache/push ":workspace :selection :boxes :outline" (fp.util/vec->colorstr (ui-color :workspace :selection :boxes :outline)))
    (cache/push ":workspace :selection :boxes :fill" (fp.util/vec->colorstr (ui-color :workspace :selection :boxes :fill)))
    (cache/push ":workspace :selection :info :lines" (fp.util/vec->colorstr (ui-color :workspace :selection :info :lines)))
    (cache/push ":workspace :selection :handles :outline" (fp.util/vec->colorstr (ui-color :workspace :selection :handles :outline)))
    (cache/push ":workspace :selection :handles :fill" (fp.util/vec->colorstr (ui-color :workspace :selection :handles :fill))))


(defn draw-rulers []
  (c/clear-canvas)
  (c/font! "9px Courier")
  (.draw_rulers  (.-tracking (.-_t js/window))))


(defn draw-selection-box [handles]
  (c/stroke-style! (cache/pull ":workspace :selection :handles :outline"))
  (c/fill-style! (cache/pull ":workspace :selection :handles :fill"))
  (.map handles (fn [[a b]]
          (c/fill-rect #js [(- a 5) (- b 5)] #js [10 10])
          (c/stroke-rect #js [(- a 5) (- b 5)] #js [10 10]))))


(defn compute-selection-bounds
  ([] (cache/purge "selection-bounds")
      (compute-selection-bounds (cache/pull "selected-roots")))
  ([_ removed] (compute-selection-bounds (fast.util/selection-roots)))
  ([added]
   (let [rects (map #(-cached % "boundingRect") added)
         selection-bounds (x/rectangle 99999999999 9999999999 -99999999999 -9999999999)
        bounds (reduce
                 (fn [j k]
                  (x/rectangle 
                    (.min js/vec2 (.create js/vec2) (x/A j) (x/A k))
                    (.max js/vec2 (.create js/vec2) (x/B j) (x/B k))))
                selection-bounds rects)]

      (cache/push "selection-bounds" (js->clj bounds)))))




(defn draw-textbox [s x y opts]
  (let [{:keys [padding font align-h align-v bg-color color stroke]} opts
        width (* (count s) (/ font 1.7))
        height (* font 0.7)
        px (int (case align-h :right (- x width (* padding 2)) :middle (- x (* width 0.5) padding) x))
        py (int (case align-v :bottom (- y height (* padding 2)) :middle (- y (* height 0.5) padding) y))]
  (when bg-color
    (c/fill-style! bg-color)
    (c/fill-rect #js [px py] #js [(int (+ width (* padding 2))) (int (+ height (* padding 2)))]))
  (when font (c/font! (str  font "px " " Courier")))
  (when color (c/fill-style! color))
  (c/text [(+ px padding) (+ py height padding)] s) ))





(defn- -draw-tracking []
  (let [space (sync.space/get-space)
        [doc-w doc-h] (x/v2+ (.-dimensions space) (x/v2 (:resizer-size @skin.data/app) 0))
        show-rulers? (cache/pull "options:show-rulers")
        show-lines? (cache/pull "options:show-lines")
        show-measures? (cache/pull "options:show-measures")
        info-text-col (cache/pull ":workspace :selection :info :text")
        info-bg-col (cache/pull "workspace :selection :info :background")
        selection (or (cache/pull "selected-roots") (clj->js (fast.util/selection-roots)))
        rects  (.map selection #(-cached % "boundingRect"))
        [SA SB] (or (cache/pull "selection-bounds") (compute-selection-bounds))
        bounds (x/rectangle 
                  (sync.convert/doc->canvas SA)
                  (sync.convert/doc->canvas SB))
        [[-bl -bt][-br -bb]] bounds
        resizers (get-resize-points bounds)]

  (reset! Resizers resizers)

  (if show-rulers?
      (c/clear-except-rulers)
      (c/clear-canvas))
  (c/clip-canvas 16 16 doc-w doc-h)
  (c/line-width! 1)

  ;draw selection boxes
  (c/stroke-style! (cache/pull ":workspace :selection :boxes :outline"))
  (c/fill-style! (cache/pull ":workspace :selection :boxes :fill"))
  (.map rects
    (fn [rect]
      (let [sxy (sync.convert/doc->canvas (x/A rect))
            swh (sync.convert/doc->canvas (x/B rect))
            dims (x/v2- swh sxy)]
        (c/fill-rect sxy dims)
        (c/stroke-rect sxy dims))))
 
  (when show-lines?
    (c/stroke-style! (cache/pull ":workspace :selection :info :lines"))
    (c/line [-bl 16] [-bl -bb])
    (c/line [-br 16] [-br -bb])
    (c/line [16 -bt] [-br -bt])
    (c/line [16 -bb] [-br -bb]))

  (when show-measures?
    (draw-textbox (str (int (aget SA 0))) -bl 18 {:align-h :middle :font 12 :bg-color info-bg-col :color info-text-col :padding 2})
    (draw-textbox (str (int (aget SB 0))) -br 18 {:align-h :middle :font 12 :bg-color info-bg-col :color info-text-col :padding 2})
    (draw-textbox (str (int (aget SA 1))) 18 -bt {:align-v :middle :font 12 :bg-color info-bg-col :color info-text-col :padding 2})
    (draw-textbox (str (int (aget SB 1))) 18 -bb {:align-v :middle :font 12 :bg-color info-bg-col :color info-text-col :padding 2}))

  (draw-selection-box resizers)
  (c/restore-canvas)))






(defn draw-tracking []
  (if (not (aget dirty "tracking"))
      (aset dirty "tracking" -draw-tracking)))

(defn uncache-tracking []
  (cache/purge "selection-bounds"))

(defn uncache-selection []
  (cache/purge "selected-roots")
  (.map (cache/push "selected-roots" (clj->js (fast.util/selection-roots)))
    #(-purge % "boundingRect")))


(def get-handle-ints
  (fn [m] (case m
    :nw-resize #js [-1 -1] :n-resize #js [nil 1]
    :ne-resize #js [1 -1] :w-resize #js [-1 nil]
    :e-resize #js [1 nil] :sw-resize #js [-1 1]
    :s-resize #js [nil 1] :se-resize #js [1 1] #js [nil nil])))

(defn mutate [uid k n op]
  (fast.core/-update (-styles uid) k #(op % n)))


(defn handle-under [pos]
  (case (sync.convert/source pos)
    :app (let [[x y] (sync.convert/doc->canvas pos)]
           (cond (< -1 y 13) [:row-resize]
                 (< -1 x 13) [:col-resize]
            :else []))
    :doc
  (filter #(not (nil? %))
   (mapv (fn [k [hx hy]]
           (let [xy (sync.convert/doc->canvas pos)]
             (if (x/inside? xy (x/rectangle (- hx 12) (- hy 12) (+ hx 12) (+ hy 12)))
              k)))
     #js [:nw-resize :n-resize :ne-resize :w-resize :e-resize :sw-resize :s-resize :se-resize] @Resizers))))

(defn change-handle [v]
  (if v (do
          (set-cursor :workspace (apply str (rest (str v)))))
    (set-cursor :workspace "default")) {})






(defn force-relative [uid]
  (let [pos (-cached uid "position")]
    (when (or (= pos nil) (#{"" "static"} (.valueOf pos)))
      (-add uid "position" "relative"))))
 
(defn cache-subbound [uid]
  (let [
    SB              @Bounds
    scrollv2        (x/v2 16 16)
    DIMS            (x/v2- (x/B SB) (x/A SB))
    rect            (-cached uid "boundingRect")
    rect-dims       (x/v2- (x/B SB) (x/A SB))
    dim-ratio       (x/v2div rect-dims DIMS)
    offset          (x/v2- (x/A rect) (x/A SB))
    offset-ratio    (x/v2div offset DIMS)]
    (prn "*" dim-ratio offset-ratio)
    (-store uid "subbounds" [dim-ratio offset-ratio])))



(def idx-rect-ks {0 "left" 1 "top" 2 "right" 3 "bottom"})
 
(defn -resize-fn [v selection op u-op kw idx]
  (when (number? idx)
    (x/-update! 
      (cache/pull "selection-bounds") 
      (get idx-rect-ks idx) 
      #(op % v)))

  (.map selection
    (fn [uid]
      (when (number? idx) 
        (let [br (-cached uid "boundingRect")]  
          (x/-update! br kw #(op % v))))      
      (mutate uid kw v u-op))))


(defpdfn ^:inline resize-sel)

(pdfn resize-sel [axis ^pos? side v sel] {axis (is* :h)}
  (-resize-fn v sel + u/+ "width" 2))
(pdfn resize-sel [axis ^neg? side v sel] {axis (is* :h)}
  (-resize-fn v sel - u/- "width" nil)
  (-resize-fn v sel + u/+ "left" 0))
(pdfn resize-sel [axis ^pos? side v sel] {axis (is* :v)}
  (-resize-fn v sel + u/+ "height" 3))
(pdfn resize-sel [axis ^neg? side v sel] {axis (is* :v)}
  (-resize-fn v sel - u/- "height" nil)
  (-resize-fn v sel + u/+ "margin-top" 1))


(defn resize [{:keys [handle xy start delta]}]
  (let [selection (cache/pull "selected-roots")
        [horizontal vertical] (get-handle-ints handle)
        [dx dy] delta]
    (when vertical (resize-sel :v vertical dy selection))
    (when horizontal (resize-sel :h horizontal dx selection)) ))



(defn start-drag [{:keys [mode value]}]
  (let [selection (cache/push "selected-roots" (clj->js (fast.util/selection-roots)))]
    (case mode
      :selection
      (.map selection
        (fn [uid]
              (if (not (fast.util/measured-style? (-cached uid "left")))  (-add uid "left" "0px"))
              (if (not (fast.util/measured-style? (-cached uid "top")))  (-add uid "top" "0px"))
              (force-relative uid)))
      :resize
      (let []
        (.map selection
          (fn [uid]
                (if (not (fast.util/measured-style? (-cached uid "left")))  (-add uid "left" "0px"))
                (if (not (fast.util/measured-style? (-cached uid "top")))  (-add uid "top" "0px"))
                ;(cache-subbound uid)
                (force-relative uid))))
      :guide
      (prn "guide-drag-start")
      nil)))



(defn route-drag [{:keys [mode delta] :as state}]
  (case mode
    :selection
    (let [selection (cache/pull "selected-roots")
          [dx dy] delta
          SB (or (cache/pull "selection-bounds") (compute-selection-bounds))]
      (assert (x/rectangle? SB))
      (x/v2+! (x/A SB) (x/v2 dx dy))
      (x/v2+! (x/B SB) (x/v2 dx dy))
      (.map selection
          (fn [uid]
            (let [br (-cached uid "boundingRect")
                  dv (x/v2 dx dy)]
              (x/v2+! (x/A br) dv)
              (x/v2+! (x/B br) dv)
              (mutate uid "left" dx u/+)
              (mutate uid "top" dy u/+))))
      (draw-tracking))
    :resize
    (do (resize state)
        (draw-tracking))
    :guide
    (prn "guide-drag")
    nil))

(def last-mouse (atom nil))

(defn change-target [{:keys [mode target] :as m}]
  (let [selection (fp.refs/doc :selection/uids)
        last-target @last-mouse
        ]
    (when (not= @last-mouse target)
      (reset! last-mouse target)
      (when (-o last-target)
        (.remove (.-classList (-native (-o last-target))) "__targeted"))
      (when (-o target)
        (.add (.-classList (-native (-o target))) "__targeted")))
    (cond 
      ;(= :pan mode)
      #_(do (reset! skin.data/cursor "-webkit-grab")
          (reset! skin.data/canvas-events true)
          (sync.mouse/drag-fns! {
          :start #(do (reset! skin.data/canvas-events true) (start-drag m))
          ;TODO updating matrix causes wierd drag deltas
          :drag #(mapv swap! ((juxt :x :y) (sync.space/get-document)) [+ +] (:delta %))
          :end #(reset! skin.data/canvas-events false)})
        m)
      (selection target) 
      (do (set-cursor :workspace "move")
          (draw-tracking)
          (let [m (assoc m :mode :selection)]
            (sync.mouse/drag-fns! {
              :start #(start-drag m)
              :drag #(route-drag (conj m %))
              :end #(prn "end!")})
            m))
      (= :resize mode) m
      (= :guide mode) m
      :else              
      (do (set-cursor :workspace "pointer")
          (draw-tracking)
          (sync.mouse/clear-drag-fns)
          (assoc m :mode nil)))))


(defn check-handle [v mode]
  (if (commands.core/key-modifier? :pan) 
    {:mode :pan}
    (let [hk (first (handle-under v))
          old-hk (:handle mode)
          check (mapv keyword? [old-hk hk])
          nmode (assoc mode :handle hk)]
      (case check
        [false true] (do (change-handle hk)
                       (if (#{:col-resize :row-resize} hk)
                         (assoc nmode :mode :guide)
                         (let [m (assoc nmode :mode :resize)] 
                          (drag-fns! {:start #(start-drag m) :end #() :drag #(route-drag (conj m %))})
                         (assoc nmode :mode :resize))))
        [true false] (change-target (assoc nmode :mode nil))
        nmode))))
 


 



(defn route-click [{:keys [mode target] :as m}]
  (when target
    (fp.selection/click target)
    ;(uncache-tracking)
    ;(draw-tracking)
    (change-target m)))

(defn drag-cycle [m]
  (go 
    (loop [mode m]
      (let [[v c] (alts! [->drag ->drag-end])]
        (cond
          (= c ->drag) (recur mode)
          (= c ->drag-end) nil))))
  {:target nil :mode nil :drag nil})

(defn move-insertion [[x y] {:keys [target] :as mode}]
  (when-let [el (-native target)]
      (let [insertion (.find_insertion (.-arrange js/_t) 
                        (clj->js {:target el :clientX x :clientY y}))]
        (set-cursor :workspace "crosshair")
        (c/clear-except-rulers)
        (c/clip-canvas 16 16)
        (conj mode {:insertion insertion 
                    :insertion-point (.. js/_t -tracking -arrange_cursor)}))))

(defn insertion-drag-cycle [m]
  (when-let [inserted (fp.insertion/insert m)]
    ;(fast.util/expand-to inserted )
    (om/update! (doc-ref :selection) :uids #{inserted})
    (om/update! (doc-ref :mode) :active "edit"))
    m)




(defn run-async []
  (.log js/console "%c[go block] fp.flow/run-async" "color:purple;background:silver;")
  (go
    (loop [mode {:target nil :mode nil :drag nil}]
      (let [[v c] (alts! [->drag-start ->change-uid ->click ->nodrag-doc-xy])]
        (if (= "edit" (:active (fp.refs/doc :mode)) )
          (cond
            (= c ->change-uid)(recur (change-target (assoc mode :target v)))
            (= c ->nodrag-doc-xy)(recur (check-handle v mode))
            (= c ->click)(recur (route-click mode))
            (= c ->drag-start) (recur (drag-cycle (assoc mode :start v))))
          (cond
            (= c ->change-uid) (do (prn '->change-uid v)(recur (assoc mode :target v)))
            (= c ->nodrag-doc-xy)(recur (move-insertion v mode))
            (= c ->click)(recur mode)
            (= c ->drag-start) 
            (let [mode (conj mode {:mode :resize :start v :drag nil :handle :se-resize})]
                         (insertion-drag-cycle mode)
                           (recur (drag-cycle mode))))
        (recur mode))))))

mouse.cljs

(ns sync.mouse
  (:require-macros [cljs.core.async.macros :refer [go]]
    [sync.macros :refer [defmachine machine inspect]])
  (:require
    [om.core :as om :include-macros true]
    [sync.animation :as animation]
    [fp.util]
    [fp.data]
    [fast.util]
    [sync.matrix :as x][sync.core]
    [cljs.pprint :as pprint]
    [sync.convert :as convert]
    [cljs.core.async :as async :refer [close! >! <! put! chan dropping-buffer split ]]))

(defn abs [n] (.abs js/Math n))

(def drag-fns #js {})

(defn drag-fns! [m]
  (set! (.-start drag-fns) (or (:start m) nil))
  (set! (.-drag drag-fns) (or (:drag m) nil))
  (set! (.-end drag-fns) (or (:end m) nil)))

(defn clear-drag-fns []
  (set! (.-start drag-fns) nil)
  (set! (.-drag drag-fns) nil)
  (set! (.-end drag-fns) nil))


(defonce ->uid (chan (async/sliding-buffer 1)))
(defonce ->change-uid (async/unique ->uid))


(defn e->uid [e]
  (put! ->uid 
    (if (.-origin e)
      (let [
        target (.-target e)
        uid (or (.-uid target) false)
        expanded-uid 
        (if uid
          (if (@fp.data/KEYS-DOWN 18)
            uid
            (fast.util/expanded-ancestor uid))
         false)]
      expanded-uid)
      false)))
 


(defonce ->e (chan (async/sliding-buffer 1))) ;(map mouse-loc->vec)
(defonce ->xy (chan (async/sliding-buffer 1)))
(defonce ->nodrag-doc-xy (chan (async/sliding-buffer 1)))

(defonce ->up (chan (async/sliding-buffer 1)))
(defonce ->down (chan (async/sliding-buffer 1)))


(defonce ->drag-start (chan (async/sliding-buffer 1)))
(defonce ->drag (chan (async/sliding-buffer 1)))
(defonce ->drag-end (chan (async/sliding-buffer 1)))

(defonce ->click (chan (async/sliding-buffer 1)))

  
(defn route-move [mode xy]
  (if (.-drag mode)
      (do 
        (animation/->xy xy)
        (put! ->drag xy)
        (when (.-drag drag-fns) 
          (animation/->f (.-drag drag-fns))) 
        mode)
      (if (> (.dist js/vec2 (or (.-start mode) xy) xy) 1)
        (do
          (put! ->drag-start (.-start mode))
          (animation/->xy xy)
          (sync.core/inject-css true "dragstyle" "input, text-area{cursor:inherit !important; pointer-events:none !important; -webkit-user-select: none !important;}")
          (when (.-start drag-fns) 
            ((.-start drag-fns) {:start (.-start mode)}))
          (put! ->drag xy)
          (set! (.-drag mode) true) 
          mode)
        mode)))

(defn format-mouse [mode e]
  (let [v (x/v2 (.-clientX e) (.-clientY e))]
    (if (= "doc" (.-source mode))
      (if (.-origin e)
        (put! ->xy v)
        (put! ->xy (convert/app->doc v)))
      (if (.-origin e)
        (put! ->xy (convert/doc->app v))
        (put! ->xy v)))))

(defn event-position [e]
  (x/v2 (.-clientX e) (.-clientY e)))

(defn format-event [mode v]
  (if (.-down mode) 
    (format-mouse mode v)
    (do (e->uid v)
      (if (.-origin v) 
        (put! ->nodrag-doc-xy 
          (event-position v))))))

(defn register-down [e]
  #js {
    :down true 
    :source (if (.-origin e) "doc" "app")
    :start (x/v2 (.-clientX e) (.-clientY e))})

(defn run-async []
  (.log js/console "%c[go block] sync.mouse go loop" "color:purple;background:silver;")
  (go 
    (loop [mode #js {}]
      (let [[v c] (alts! [->e ->down ->up ->xy])]
        (cond
          (= c ->e) (format-event mode v)
          (= c ->xy) (recur (route-move mode v))
          (= c ->down) (recur (register-down v))
          (= c ->up) 
          (do 
            (or (.. v -target -uid) false)
            (if (.-drag mode) 
              (do 
                ;(put! ->uid false)
                (e->uid v)
                (sync.core/inject-css true "dragstyle" "")
                (when (.-end drag-fns) 
                  ((.-end drag-fns) v))
                (clear-drag-fns)
                (animation/->f nil))
              (put! ->click v))
            (recur #js {})))
        (recur mode)))))