(ns uxbox.shapes
  (:require [uxbox.util.matrix :as mtx]
            [uxbox.util.math :as mth]
            [uxbox.state :as st]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:static +hierarchy+
  (as-> (make-hierarchy) $
    (derive $ ::rect ::shape)
    (derive $ :builtin/icon ::rect)
    (derive $ :builtin/rect ::rect)
    (derive $ :builtin/line ::shape)
    (derive $ :builtin/circle ::shape)
    (derive $ :builtin/text ::shape)
    (derive $ :builtin/group ::rect)))

(defn shape?
  [type]
  {:pre [(keyword? type)]}
  (isa? +hierarchy+ type ::shape))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation Api
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- dispatch-by-type
  [shape & params]
  (:type shape))

(defmulti -render
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -render-svg
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -move
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -resize
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -resize'
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -rotate
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;; Used for calculate the outer rect that wraps
;; up the whole underlying shape. Mostly used
;; for calculate the shape or shapes selection
;; rectangle.

(defmulti -outer-rect
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;; Used for create the final shape data structure
;; from initial shape data structure and final
;; canvas position.

(defmulti -initialize
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Initialize

(defmethod -initialize ::shape
  [shape {:keys [x1 y1 x2 y2]}]
  (merge shape
         (when x1 {:x x1})
         (when y1 {:y y1})
         (when (and x2 x1) {:width (- x2 x1)})
         (when (and y2 y1) {:height (- y2 y1)})))

(defmethod -initialize :builtin/group
  [shape {:keys [x1 y1 x2 y2]}]
  shape)

(defmethod -initialize :builtin/line
  [shape {:keys [x1 y1 x2 y2]}]
  (merge shape
         (when x1 {:x1 x1})
         (when y1 {:y1 y1})
         (when x2 {:x2 x2})
         (when y2 {:y2 y2})))

;; Resize

(defmethod -resize :builtin/line
  [shape [x2 y2]]
  (assoc shape
         :x2 x2 :y2 y2))

(defmethod -resize :builtin/rect
  [shape [x2 y2]]
  (let [{:keys [x y]} shape]
    (assoc shape
           :width (- x2 x)
           :height (- y2 y))))

(defmethod -resize :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

(defmethod -resize' ::rect
  [shape [width height]]
  (merge shape
         (when width {:width width})
         (when height {:height height})))

(defmethod -resize' :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

;; Move

(defmethod -move ::rect
  [shape {:keys [dx dy] :as opts}]
  (assoc shape
         :x (+ (:x shape) dx)
         :y (+ (:y shape) dy)))

(defmethod -move :builtin/line
  [shape {:keys [dx dy] :as opts}]
  (assoc shape
         :x1 (+ (:x1 shape) dx)
         :y1 (+ (:y1 shape) dy)
         :x2 (+ (:x2 shape) dx)
         :y2 (+ (:y2 shape) dy)))

(defmethod -move :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

(defmethod -rotate ::shape
  [shape rotation]
  (assoc shape :rotation rotation))

(declare container-rect)

(defmethod -outer-rect ::shape
  [{:keys [group] :as shape}]
  (let [group (get-in @st/state [:shapes-by-id group])]
    (as-> shape $
      (assoc $ :x (+ (:x shape) (:dx group 0)))
      (assoc $ :y (+ (:y shape) (:dy group 0)))
      (container-rect $))))

(defmethod -outer-rect :builtin/line
  [{:keys [x1 y1 x2 y2 group] :as shape}]
  (let [group (get-in @st/state [:shapes-by-id group])
        props {:x (+ x1 (:dx group 0))
               :y (+ y1 (:dy group 0))
               :width (- x2 x1)
               :height (- y2 y1)}]
    (-> (merge shape props)
        (container-rect))))

(defmethod -outer-rect :builtin/group
  [{:keys [id group rotation dx dy] :as shape}]
  (let [shapes (->> (:items shape)
                    (map #(get-in @st/state [:shapes-by-id %]))
                    (map -outer-rect))
        x (apply min (map :x shapes))
        y (apply min (map :y shapes))
        x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
        y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
        width (- x' x)
        height (- y' y)]
    (as-> shape $
      (merge $ {:width width :height height :x x :y y})
      (container-rect $))))

(defmethod -outer-rect :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn apply-rotation
  [[x y :as v] rotation]
  (let [angle (mth/radians rotation)
        rx (- (* x (mth/cos angle))
              (* y (mth/sin angle)))
        ry (+ (* x (mth/sin angle))
              (* y (mth/cos angle)))]
    (let [r [(mth/precision rx 6)
             (mth/precision ry 6)]]
      r)))

(defn container-rect
  [{:keys [x y width height rotation] :as shape}]
  (let [center-x (+ x (/ width 2))
        center-y (+ y (/ height 2))

        angle (mth/radians (or rotation 0))
        x1 (- x center-x)
        y1 (- y center-y)

        x2 (- (+ x width) center-x)
        y2 (- y center-y)

        [rx1 ry1] (apply-rotation [x1 y1] rotation)
        [rx2 ry2] (apply-rotation [x2 y2] rotation)

        [d1 d2] (cond
                  (and (>= rotation 0)
                       (< rotation 90))
                  [(mth/abs ry1)
                   (mth/abs rx2)]

                  (and (>= rotation 90)
                       (< rotation 180))
                  [(mth/abs ry2)
                   (mth/abs rx1)]

                  (and (>= rotation 180)
                       (< rotation 270))
                  [(mth/abs ry1)
                   (mth/abs rx2)]

                  (and (>= rotation 270)
                       (<= rotation 360))
                  [(mth/abs ry2)
                   (mth/abs rx1)])
        final-x (- center-x d2)
        final-y (- center-y d1)
        final-width (* d2 2)
        final-height (* d1 2)]
    (merge shape
           {:x final-x
            :y final-y
            :width final-width
            :height final-height})))

;; (defn group-dimensions
;;   "Given a collection of shapes, calculates the
;;   dimensions of the resultant group."
;;   [shapes]
;;   {:pre [(seq shapes)]}
;;   (let [shapes (map container-rect shapes)
;;         x (apply min (map :x shapes))
;;         y (apply min (map :y shapes))
;;         x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
;;         y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
;;         width (- x' x)
;;         height (- y' y)]
;;     {:width width
;;      :height height
;;      :view-box [0 0 width height]
;;      :x x
;;      :y y}))

(defn outer-rect
  [shapes]
  {:pre [(seq shapes)]}
  (let [shapes (map -outer-rect shapes)
        x (apply min (map :x shapes))
        y (apply min (map :y shapes))
        x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
        y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
        width (- x' x)
        height (- y' y)]
    {:width width
     :height height
     :x x
     :y y}))

(defn translate-coords
  "Given a shape and initial coords, transform
  it mapping its coords to new provided initial coords."
  ([shape x y]
   (translate-coords shape x y -))
  ([shape x y op]
   (let [x' (:x shape)
         y' (:y shape)]
     (assoc shape :x (op x' x) :y (op y' y)))))

(defn resolve-parent
  "Recursively resolve the real shape parent."
  [{:keys [group] :as shape}]
  (if group
    (resolve-parent (get-in @st/state [:shapes-by-id group]))
    shape))

(defn contained-in?
  "Check if a shape is contained in the
  provided selection rect."
  [shape selrect]
  (let [sx1 (:x selrect)
        sx2 (+ sx1 (:width selrect))
        sy1 (:y selrect)
        sy2 (+ sy1 (:height selrect))
        rx1 (:x shape)
        rx2 (+ rx1 (:width shape))
        ry1 (:y shape)
        ry2 (+ ry1 (:height shape))]
    (and (neg? (- (:y selrect) (:y shape)))
         (neg? (- (:x selrect) (:x shape)))
         (pos? (- (+ (:y selrect)
                     (:height selrect))
                  (+ (:y shape)
                     (:height shape))))
         (pos? (- (+ (:x selrect)
                     (:width selrect))
                  (+ (:x shape)
                     (:width shape)))))))

(ns uxbox.shapes
  (:require [uxbox.util.matrix :as mtx]
            [uxbox.util.math :as mth]
            [uxbox.state :as st]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def ^:static +hierarchy+
  (as-> (make-hierarchy) $
    (derive $ ::rect ::shape)
    (derive $ :builtin/icon ::rect)
    (derive $ :builtin/rect ::rect)
    (derive $ :builtin/line ::shape)
    (derive $ :builtin/circle ::shape)
    (derive $ :builtin/text ::shape)
    (derive $ :builtin/group ::rect)))

(defn shape?
  [type]
  {:pre [(keyword? type)]}
  (isa? +hierarchy+ type ::shape))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation Api
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn- dispatch-by-type
  [shape & params]
  (:type shape))

(defmulti -render
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -render-svg
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -move
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -move'
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -resize
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -resize'
  dispatch-by-type
  :hierarchy #'+hierarchy+)

(defmulti -rotate
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;; Used for calculate the outer rect that wraps
;; up the whole underlying shape. Mostly used
;; for calculate the shape or shapes selection
;; rectangle.

(defmulti -outer-rect
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;; Used for create the final shape data structure
;; from initial shape data structure and final
;; canvas position.

(defmulti -initialize
  dispatch-by-type
  :hierarchy #'+hierarchy+)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Implementation
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Initialize

(defmethod -initialize ::shape
  [shape {:keys [x1 y1 x2 y2]}]
  (merge shape
         (when x1 {:x x1})
         (when y1 {:y y1})
         (when (and x2 x1) {:width (- x2 x1)})
         (when (and y2 y1) {:height (- y2 y1)})))

(defmethod -initialize :builtin/group
  [shape {:keys [x1 y1 x2 y2]}]
  shape)

(defmethod -initialize :builtin/line
  [shape {:keys [x1 y1 x2 y2]}]
  (merge shape
         (when x1 {:x1 x1})
         (when y1 {:y1 y1})
         (when x2 {:x2 x2})
         (when y2 {:y2 y2})))

;; Resize

(defmethod -resize :builtin/line
  [shape [x2 y2]]
  (assoc shape
         :x2 x2 :y2 y2))

(defmethod -resize :builtin/rect
  [shape [x2 y2]]
  (let [{:keys [x y]} shape]
    (assoc shape
           :width (- x2 x)
           :height (- y2 y))))

(defmethod -resize :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

(defmethod -resize' ::rect
  [shape [width height]]
  (merge shape
         (when width {:width width})
         (when height {:height height})))

(defmethod -resize' :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

;; Move

(defmethod -move ::rect
  [shape [dx dy]]
  (assoc shape
         :x (+ (:x shape) dx)
         :y (+ (:y shape) dy)))

(defmethod -move :builtin/line
  [shape [dx dy]]
  (assoc shape
         :x1 (+ (:x1 shape) dx)
         :y1 (+ (:y1 shape) dy)
         :x2 (+ (:x2 shape) dx)
         :y2 (+ (:y2 shape) dy)))

(defmethod -move :builtin/circle
  [shape [dx dy]]
  (assoc shape
         :cx (+ (:cx shape) dx)
         :cy (+ (:cy shape) dy)))

(defmethod -move :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

(defmethod -move' ::rect
  [shape [x y]]
  (let [dx (if x (- (:x shape) x) 0)
        dy (if y (- (:y shape) y) 0)]
    (-move shape [dx dy])))

(defmethod -move' :builtin/line
  [shape [x y]]
  (let [dx (if x (- (:x1 shape) x) 0)
        dy (if y (- (:y1 shape) y) 0)]
    (-move shape [dx dy])))

(defmethod -move' :builtin/circle
  [shape [x y]]
  (let [{:keys [cx cy rx ry]} shape
        x1 (- cx rx)
        y1 (- cy ry)
        dx (if x (- (:x1 shape) x) 0)
        dy (if y (- (:y1 shape) y) 0)]
    (-move shape [dx dy])))

(defmethod -move' :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

(defmethod -rotate ::shape
  [shape rotation]
  (assoc shape :rotation rotation))

(declare container-rect)

(defmethod -outer-rect ::shape
  [{:keys [group] :as shape}]
  (let [group (get-in @st/state [:shapes-by-id group])]
    (as-> shape $
      (assoc $ :x (+ (:x shape) (:dx group 0)))
      (assoc $ :y (+ (:y shape) (:dy group 0)))
      (container-rect $))))

(defmethod -outer-rect :builtin/line
  [{:keys [x1 y1 x2 y2 group] :as shape}]
  (let [group (get-in @st/state [:shapes-by-id group])
        props {:x (+ x1 (:dx group 0))
               :y (+ y1 (:dy group 0))
               :width (- x2 x1)
               :height (- y2 y1)}]
    (-> (merge shape props)
        (container-rect))))

(defmethod -outer-rect :builtin/group
  [{:keys [id group rotation dx dy] :as shape}]
  (let [shapes (->> (:items shape)
                    (map #(get-in @st/state [:shapes-by-id %]))
                    (map -outer-rect))
        x (apply min (map :x shapes))
        y (apply min (map :y shapes))
        x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
        y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
        width (- x' x)
        height (- y' y)]
    (as-> shape $
      (merge $ {:width width :height height :x x :y y})
      (container-rect $))))

(defmethod -outer-rect :default
  [shape _]
  (throw (ex-info "Not implemented" (select-keys shape [:type]))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helpers
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn apply-rotation
  [[x y :as v] rotation]
  (let [angle (mth/radians rotation)
        rx (- (* x (mth/cos angle))
              (* y (mth/sin angle)))
        ry (+ (* x (mth/sin angle))
              (* y (mth/cos angle)))]
    (let [r [(mth/precision rx 6)
             (mth/precision ry 6)]]
      r)))

(defn container-rect
  [{:keys [x y width height rotation] :as shape}]
  (let [center-x (+ x (/ width 2))
        center-y (+ y (/ height 2))

        angle (mth/radians (or rotation 0))
        x1 (- x center-x)
        y1 (- y center-y)

        x2 (- (+ x width) center-x)
        y2 (- y center-y)

        [rx1 ry1] (apply-rotation [x1 y1] rotation)
        [rx2 ry2] (apply-rotation [x2 y2] rotation)

        [d1 d2] (cond
                  (and (>= rotation 0)
                       (< rotation 90))
                  [(mth/abs ry1)
                   (mth/abs rx2)]

                  (and (>= rotation 90)
                       (< rotation 180))
                  [(mth/abs ry2)
                   (mth/abs rx1)]

                  (and (>= rotation 180)
                       (< rotation 270))
                  [(mth/abs ry1)
                   (mth/abs rx2)]

                  (and (>= rotation 270)
                       (<= rotation 360))
                  [(mth/abs ry2)
                   (mth/abs rx1)])
        final-x (- center-x d2)
        final-y (- center-y d1)
        final-width (* d2 2)
        final-height (* d1 2)]
    (merge shape
           {:x final-x
            :y final-y
            :width final-width
            :height final-height})))

;; (defn group-dimensions
;;   "Given a collection of shapes, calculates the
;;   dimensions of the resultant group."
;;   [shapes]
;;   {:pre [(seq shapes)]}
;;   (let [shapes (map container-rect shapes)
;;         x (apply min (map :x shapes))
;;         y (apply min (map :y shapes))
;;         x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
;;         y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
;;         width (- x' x)
;;         height (- y' y)]
;;     {:width width
;;      :height height
;;      :view-box [0 0 width height]
;;      :x x
;;      :y y}))

(defn outer-rect
  [shapes]
  {:pre [(seq shapes)]}
  (let [shapes (map -outer-rect shapes)
        x (apply min (map :x shapes))
        y (apply min (map :y shapes))
        x' (apply max (map (fn [{:keys [x width]}] (+ x width)) shapes))
        y' (apply max (map (fn [{:keys [y height]}] (+ y height)) shapes))
        width (- x' x)
        height (- y' y)]
    {:width width
     :height height
     :x x
     :y y}))

(defn translate-coords
  "Given a shape and initial coords, transform
  it mapping its coords to new provided initial coords."
  ([shape x y]
   (translate-coords shape x y -))
  ([shape x y op]
   (let [x' (:x shape)
         y' (:y shape)]
     (assoc shape :x (op x' x) :y (op y' y)))))

(defn resolve-parent
  "Recursively resolve the real shape parent."
  [{:keys [group] :as shape}]
  (if group
    (resolve-parent (get-in @st/state [:shapes-by-id group]))
    shape))

(defn contained-in?
  "Check if a shape is contained in the
  provided selection rect."
  [shape selrect]
  (let [sx1 (:x selrect)
        sx2 (+ sx1 (:width selrect))
        sy1 (:y selrect)
        sy2 (+ sy1 (:height selrect))
        rx1 (:x shape)
        rx2 (+ rx1 (:width shape))
        ry1 (:y shape)
        ry2 (+ ry1 (:height shape))]
    (and (neg? (- (:y selrect) (:y shape)))
         (neg? (- (:x selrect) (:x shape)))
         (pos? (- (+ (:y selrect)
                     (:height selrect))
                  (+ (:y shape)
                     (:height shape))))
         (pos? (- (+ (:x selrect)
                     (:width selrect))
                  (+ (:x shape)
                     (:width shape)))))))

Add absolute move abstraction.

Add absolute move abstraction.


;;   Copyright (c) 7theta. All rights reserved.
;;   The use and distribution terms for this software are covered by the
;;   Eclipse Public License 1.0 (http://www.eclipse.org/legal/epl-v10.html)
;;   which can be found in the LICENSE file at the root of this
;;   distribution.
;;
;;   By using this software in any fashion, you are agreeing to be bound by
;;   the terms of this license.
;;   You must not remove this notice, or any others, from this software.

(ns via.endpoint
  (:require [via.defaults :refer [default-via-endpoint]]
            [signum.interceptors :refer [->interceptor]]
            [haslett.client :as ws]
            [haslett.format :as fmt]
            [utilis.fn :refer [fsafe]]
            [utilis.map :refer [compact]]
            [utilis.types.string :refer [->string]]
            [cljs.core.async :as a :refer [chan close! <! >! poll! timeout go alt! put!]]
            [re-frame.core :refer [reg-sub-raw] :as re-frame]
            [reagent.ratom :refer [reaction]]
            [reagent.core :as r]
            [integrant.core :as ig]
            [cognitect.transit :as transit]
            [goog.string :refer [format]]
            [goog.string.format]
            [clojure.string :as st]))

;;; Declarations

(declare connect! disconnect! connected? send! default-via-url exponential-seq send*)

(def interceptor)

;;; Integrant

(defmethod ig/init-key :via/endpoint
  [_ {:keys [url
             auto-connect
             auto-reconnect
             max-reconnect-interval
             connect-opts]
      :or {auto-connect true
           auto-reconnect true
           max-reconnect-interval 5000
           url (default-via-url)}
      :as opts}]
  (let [endpoint {:url url
                  :outbound-ch (atom nil)
                  :control-ch (atom nil)
                  :connect-state (r/atom :initial)
                  :subscriptions (atom {})
                  :requests (atom {})}
        connect-opts (compact
                      (assoc connect-opts
                             :auto-reconnect auto-reconnect
                             :max-reconnect-interval max-reconnect-interval))]
    (reg-sub-raw
     :via.endpoint/connected
     (fn []
       (reaction (connected? (fn [] endpoint)))))
    (set!
     interceptor
     (->interceptor
      :id :via.endpoint/interceptor
      :before #(update % :coeffects merge {:endpoint endpoint :request (:request %)})
      :after (fn [context]
               (when-let [reply (get-in context [:effects :via/reply])]
                 (send! (fn [] endpoint) reply
                        :type :reply
                        :client-id (:client-id context)
                        :params {:status (get-in context [:effects :via/status])
                                 :request-id (:request-id context)}))
               context)))
    (when auto-connect (connect! (fn [] endpoint) connect-opts))
    (fn [] endpoint)))

(defmethod ig/halt-key! :via/endpoint
  [_ endpoint]
  (disconnect! endpoint))

;;; API

(declare handle-event handle-reply handle-connection-context append-query-params
         establish-connection-context)

(defn connect!
  ([endpoint] (connect! endpoint nil))
  ([endpoint {:keys [params
                     auto-reconnect
                     max-reconnect-interval
                     protocols
                     binary-type]}]
   (let [control-ch (reset! (:control-ch (endpoint)) (chan))
         connection-context (atom nil)
         handle-message (fn [message]
                          (if-not (nil? message)
                            (case (:type message)
                              :connection-context (handle-connection-context connection-context message)
                              :message (handle-event (endpoint) :message message)
                              :reply (handle-reply (endpoint) message))
                            (js/console.warn "via: nil message from server")))
         handle-close #(do (reset! (:connect-state (endpoint)) :disconnected)
                           (reset! (:outbound-ch (endpoint)) nil)
                           (handle-event (endpoint) :close (merge {:status :forced} %)))]
     (go (try
           (loop [backoff-sq (when auto-reconnect (exponential-seq 2 max-reconnect-interval))]
             (let [return (ws/connect (append-query-params (:url (endpoint)) params)
                                      {:format fmt/transit})
                   {:keys [socket source sink close-status] :as stream} (<! return)
                   recur? (= :recur
                             (if (ws/connected? stream)
                               (do (reset! (:outbound-ch (endpoint)) sink)
                                   (establish-connection-context endpoint stream connection-context)
                                   (loop []
                                     (alt!
                                       control-ch (do (ws/close stream) :exit)
                                       source ([message] (handle-message message) (recur))
                                       close-status ([status] (do (handle-close status) :recur)))))
                               :recur))]
               (when-let [interval (and recur? auto-reconnect (first backoff-sq))]
                 (js/console.log "Reconnecting in " (str interval "ms"))
                 (<! (timeout interval))
                 (recur (rest backoff-sq)))))
           (handle-event (endpoint) :shutdown {:status :final})
           (close! control-ch)
           (catch js/Error e
             (js/console.error e "Error occurred in via connection/message loop.")))
         (js/console.info "via connection loop exited.")))))

(defn disconnect!
  [endpoint]
  (when (connected? endpoint)
    (let [endpoint (endpoint)]
      (handle-event endpoint :close {:status :normal})
      (close! @(:control-ch endpoint))
      (reset! (:control-ch endpoint) nil)
      (reset! (:outbound-ch endpoint) nil))))

(defn connected?
  [endpoint]
  (= :connected @(:connect-state (endpoint))))

(defn subscribe
  [endpoint callbacks]
  (let [key (str (random-uuid))]
    (swap! (:subscriptions (endpoint)) assoc key callbacks)
    (when (connected? endpoint)
      (when-let [handler (:open callbacks)]
        (handler {:status :progress})))
    key))

(defn dispose
  [endpoint key]
  (swap! (:subscriptions (endpoint)) dissoc key))

(defn send!
  [endpoint message & {:keys [type success-fn failure-fn timeout timeout-fn]
                       :or {type :message}
                       :as options}]
  (if-not (connected? endpoint)
    ((fsafe failure-fn) {:status :disconnected})
    (send* endpoint message (assoc options :type type))))

;;; Implementation

(defn- handle-event
  [endpoint type data]
  (doseq [handler (->> @(:subscriptions endpoint) vals (map type) (remove nil?))]
    (try (handler data)
         (catch js/Error e
           (js/console.error e)))))

(defn- handle-reply
  [endpoint reply]
  (if-let [request (get @(:requests endpoint) (:request-id reply))]
    (do (js/clearTimeout (:timer request))
        ((fsafe ((if (= 200 (:status reply)) :success-fn :failure-fn) request))
         (select-keys reply [:status :payload])))
    (js/console.warn ":via/endpoint reply with invalid request-id" (pr-str reply))))

(defn- handle-connection-context
  [connection-context {:keys [payload]}]
  (let [[event-id context] payload]
    (js/console.info "Got connection context" (pr-str context))
    (condp = event-id
      :via.connection-context/updated (reset! connection-context context)
      (js/console.warn "Unknown via connection-context message" (pr-str payload)))))

(defn- default-via-url
  []
  (when-let [location (.-location js/window)]
    (str (if (= "http:" (.-protocol location)) "ws://" "wss://")
         (.-host location) default-via-endpoint)))

(defn- append-query-params
  [url query-params]
  (->> query-params
       (map (fn [[k v]]
              (format "%s=%s"
                      (->string k)
                      (->string v))))
       (st/join "&") vector
       (filter seq)
       (cons url)
       (st/join "?")
       js/encodeURI))

(defn- exponential-seq
  ([base max-value]
   (map #(min % max-value) (exponential-seq base)))
  ([base]
   (let [base (js/Math.abs base)]
     (->> {:step 1 :value base}
          (iterate
           (fn [{:keys [step]}]
             {:value (js/Math.pow base (inc step))
              :step (inc step)}))
          (map :value)))))

(defn- send*
  [endpoint message {:keys [type success-fn failure-fn timeout timeout-fn]
                     :or {type :message}
                     :as options}]
  (if message
    (let [endpoint (endpoint)
          do-send (fn [message params]
                    (if-let [outbound-ch @(:outbound-ch endpoint)]
                      (go (>! outbound-ch
                              (merge {:type type
                                      :payload message} params)))
                      (throw (js/Error. ":via/endpoint not connected"))))]
      (if-not (or success-fn failure-fn)
        (do-send message nil)
        (let [request-id (str (random-uuid))]
          (swap! (:requests endpoint)
                 assoc request-id {:success-fn success-fn
                                   :failure-fn failure-fn
                                   :message message
                                   :timer (js/setTimeout (fsafe timeout-fn) timeout)})
          (do-send message {:request-id request-id
                            :timeout timeout}))))
    (js/console.warn ":via/endpoint attempting to send nil message")))

(defn- establish-connection-context
  [endpoint {:keys [sink close-status] :as stream} connection-context]
  (let [ready-ch (chan)
        response-handler (fn [status]
                           (fn [response]
                             (go (>! ready-ch [status response])
                                 (close! ready-ch))))]
    (send* endpoint [:via.connection-context/replace @connection-context]
           {:success-fn (response-handler :success)
            :failure-fn (response-handler :failure)
            :timeout 10000
            :timeout-fn (response-handler :timeout)})
    (go (let [[status response] (<! ready-ch)]
          (condp = status
            :success (let [control-ch @(:control-ch (endpoint))]
                       (reset! (:connect-state (endpoint)) :connected)
                       (handle-event (endpoint) :open {:status :initial}))
            :failure (js/console.warn "Unable to establish connection context" (pr-str response))
            :timeout (js/console.warn "Timed out establishing connection context" (pr-str response)))))))

;;   Copyright (c) 7theta. All rights reserved.
;;   The use and distribution terms for this software are covered by the
;;   Eclipse Public License 1.0 (http://www.eclipse.org/legal/epl-v10.html)
;;   which can be found in the LICENSE file at the root of this
;;   distribution.
;;
;;   By using this software in any fashion, you are agreeing to be bound by
;;   the terms of this license.
;;   You must not remove this notice, or any others, from this software.

(ns via.endpoint
  (:require [via.defaults :refer [default-via-endpoint]]
            [signum.interceptors :refer [->interceptor]]
            [haslett.client :as ws]
            [haslett.format :as fmt]
            [utilis.fn :refer [fsafe]]
            [utilis.map :refer [compact]]
            [utilis.types.string :refer [->string]]
            [cljs.core.async :as a :refer [chan close! <! >! poll! timeout go alt! put!]]
            [re-frame.core :refer [reg-sub-raw] :as re-frame]
            [reagent.ratom :refer [reaction]]
            [reagent.core :as r]
            [integrant.core :as ig]
            [cognitect.transit :as transit]
            [goog.string :refer [format]]
            [goog.string.format]
            [clojure.string :as st]))

;;; Declarations

(declare connect! disconnect! connected? send! default-via-url exponential-seq send*)

(def interceptor)

;;; Integrant

(defmethod ig/init-key :via/endpoint
  [_ {:keys [url
             auto-connect
             auto-reconnect
             max-reconnect-interval
             connect-opts]
      :or {auto-connect true
           auto-reconnect true
           max-reconnect-interval 5000
           url (default-via-url)}
      :as opts}]
  (let [endpoint {:url url
                  :outbound-ch (atom nil)
                  :control-ch (atom nil)
                  :connect-state (r/atom :initial)
                  :subscriptions (atom {})
                  :requests (atom {})}
        connect-opts (compact
                      (assoc connect-opts
                             :auto-reconnect auto-reconnect
                             :max-reconnect-interval max-reconnect-interval))]
    (reg-sub-raw
     :via.endpoint/connected
     (fn []
       (reaction (connected? (fn [] endpoint)))))
    (set!
     interceptor
     (->interceptor
      :id :via.endpoint/interceptor
      :before #(update % :coeffects merge {:endpoint endpoint :request (:request %)})
      :after (fn [context]
               (when-let [reply (get-in context [:effects :via/reply])]
                 (send! (fn [] endpoint) reply
                        :type :reply
                        :client-id (:client-id context)
                        :params {:status (get-in context [:effects :via/status])
                                 :request-id (:request-id context)}))
               context)))
    (when auto-connect (connect! (fn [] endpoint) connect-opts))
    (fn [] endpoint)))

(defmethod ig/halt-key! :via/endpoint
  [_ endpoint]
  (disconnect! endpoint))

;;; API

(declare handle-event handle-reply handle-connection-context append-query-params
         establish-connection-context)

(defn connect!
  ([endpoint] (connect! endpoint nil))
  ([endpoint {:keys [params
                     auto-reconnect
                     max-reconnect-interval
                     protocols
                     binary-type]}]
   (let [control-ch (reset! (:control-ch (endpoint)) (chan))
         connection-context (atom nil)
         handle-message (fn [message]
                          (if-not (nil? message)
                            (case (:type message)
                              :connection-context (handle-connection-context connection-context message)
                              :message (handle-event (endpoint) :message message)
                              :reply (handle-reply (endpoint) message))
                            (js/console.warn "via: nil message from server")))
         handle-close #(do (reset! (:connect-state (endpoint)) :disconnected)
                           (reset! (:outbound-ch (endpoint)) nil)
                           (handle-event (endpoint) :close (merge {:status :forced} %)))]
     (go (try
           (loop [backoff-sq (when auto-reconnect (exponential-seq 2 max-reconnect-interval))]
             (let [return (ws/connect (append-query-params (:url (endpoint)) params)
                                      {:format fmt/transit})
                   {:keys [socket source sink close-status] :as stream} (<! return)
                   recur? (= :recur
                             (if (ws/connected? stream)
                               (do (reset! (:outbound-ch (endpoint)) sink)
                                   (establish-connection-context endpoint stream connection-context)
                                   (loop []
                                     (alt!
                                       control-ch (do (ws/close stream) :exit)
                                       source ([message] (handle-message message) (recur))
                                       close-status ([status] (do (handle-close status) :recur)))))
                               :recur))]
               (when-let [interval (and recur? auto-reconnect (first backoff-sq))]
                 (js/console.log "Reconnecting in " (str interval "ms"))
                 (<! (timeout interval))
                 (recur (rest backoff-sq)))))
           (handle-event (endpoint) :shutdown {:status :final})
           (close! control-ch)
           (catch js/Error e
             (js/console.error e "Error occurred in via connection/message loop.")))
         (js/console.info "via connection loop exited.")))))

(defn disconnect!
  [endpoint]
  (when (connected? endpoint)
    (let [endpoint (endpoint)]
      (handle-event endpoint :close {:status :normal})
      (close! @(:control-ch endpoint))
      (reset! (:control-ch endpoint) nil)
      (reset! (:outbound-ch endpoint) nil))))

(defn connected?
  [endpoint]
  (= :connected @(:connect-state (endpoint))))

(defn subscribe
  [endpoint callbacks]
  (let [key (str (random-uuid))]
    (swap! (:subscriptions (endpoint)) assoc key callbacks)
    (when (connected? endpoint)
      (when-let [handler (:open callbacks)]
        (handler {:status :progress})))
    key))

(defn dispose
  [endpoint key]
  (swap! (:subscriptions (endpoint)) dissoc key))

(defn send!
  [endpoint message & {:keys [type success-fn failure-fn timeout timeout-fn]
                       :or {type :message}
                       :as options}]
  (if-not (connected? endpoint)
    ((fsafe failure-fn) {:status :disconnected})
    (send* endpoint message (assoc options :type type))))

;;; Implementation

(defn- handle-event
  [endpoint type data]
  (doseq [handler (->> @(:subscriptions endpoint) vals (map type) (remove nil?))]
    (try (handler data)
         (catch js/Error e
           (js/console.error e)))))

(defn- handle-reply
  [endpoint reply]
  (if-let [request (get @(:requests endpoint) (:request-id reply))]
    (do (js/clearTimeout (:timer request))
        ((fsafe ((if (= 200 (:status reply)) :success-fn :failure-fn) request))
         (select-keys reply [:status :payload])))
    (js/console.warn ":via/endpoint reply with invalid request-id" (pr-str reply))))

(defn- handle-connection-context
  [connection-context {:keys [payload]}]
  (let [[event-id context] payload]
    (condp = event-id
      :via.connection-context/updated (reset! connection-context context)
      (js/console.warn "Unknown via connection-context message" (pr-str payload)))))

(defn- default-via-url
  []
  (when-let [location (.-location js/window)]
    (str (if (= "http:" (.-protocol location)) "ws://" "wss://")
         (.-host location) default-via-endpoint)))

(defn- append-query-params
  [url query-params]
  (->> query-params
       (map (fn [[k v]]
              (format "%s=%s"
                      (->string k)
                      (->string v))))
       (st/join "&") vector
       (filter seq)
       (cons url)
       (st/join "?")
       js/encodeURI))

(defn- exponential-seq
  ([base max-value]
   (map #(min % max-value) (exponential-seq base)))
  ([base]
   (let [base (js/Math.abs base)]
     (->> {:step 1 :value base}
          (iterate
           (fn [{:keys [step]}]
             {:value (js/Math.pow base (inc step))
              :step (inc step)}))
          (map :value)))))

(defn- send*
  [endpoint message {:keys [type success-fn failure-fn timeout timeout-fn]
                     :or {type :message}
                     :as options}]
  (if message
    (let [endpoint (endpoint)
          do-send (fn [message params]
                    (if-let [outbound-ch @(:outbound-ch endpoint)]
                      (go (>! outbound-ch
                              (merge {:type type
                                      :payload message} params)))
                      (throw (js/Error. ":via/endpoint not connected"))))]
      (if-not (or success-fn failure-fn)
        (do-send message nil)
        (let [request-id (str (random-uuid))]
          (swap! (:requests endpoint)
                 assoc request-id {:success-fn success-fn
                                   :failure-fn failure-fn
                                   :message message
                                   :timer (js/setTimeout (fsafe timeout-fn) timeout)})
          (do-send message {:request-id request-id
                            :timeout timeout}))))
    (js/console.warn ":via/endpoint attempting to send nil message")))

(defn- establish-connection-context
  [endpoint {:keys [sink close-status] :as stream} connection-context]
  (let [ready-ch (chan)
        response-handler (fn [status]
                           (fn [response]
                             (go (>! ready-ch [status response])
                                 (close! ready-ch))))]
    (send* endpoint [:via.connection-context/replace @connection-context]
           {:success-fn (response-handler :success)
            :failure-fn (response-handler :failure)
            :timeout 10000
            :timeout-fn (response-handler :timeout)})
    (go (let [[status response] (<! ready-ch)]
          (condp = status
            :success (let [control-ch @(:control-ch (endpoint))]
                       (reset! (:connect-state (endpoint)) :connected)
                       (handle-event (endpoint) :open {:status :initial}))
            :failure (js/console.warn "Unable to establish connection context" (pr-str response))
            :timeout (js/console.warn "Timed out establishing connection context" (pr-str response)))))))

Remove connection context console log.

Remove connection context console log.


(ns pepa.bus
  (:require [com.stuartsierra.component :as component]
            [clojure.core.async :as async :refer [>!!]]))

;;; pepa.bus is a simple application-wide notification bus. Clients
;;; can subscribe for any topic they want and will receive a value for
;;; any call of `notify!' for that topic.

(defn subscribe
  "Returns a channel with that will receive a value when `notify!' is
  called for that topic."
  ([bus topic buf]
   (let [chan (async/chan buf)]
     (async/sub (:output bus) topic chan)
     chan))
  ([bus topic]
   (subscribe bus topic nil)))

(defn notify!
  ([bus topic data]
   (println "notify!" topic data)
   (>!! (:input bus) (assoc data ::topic topic)))
  ([bus topic]
   (notify! bus topic {})))

(defn subscribe-all
  "Returns a channel receiving all messages sent over the bus."
  ([bus buf]
   (let [ch (async/chan buf)]
     (async/tap (:mult bus) ch)))
  ([bus]
   (subscribe-all bus nil)))

(defn topic [message]
  (::topic message))

(defrecord Bus [input mult output]
  component/Lifecycle
  (start [component]
    (println ";; Starting bus")
    (let [input (async/chan)
          mult (async/mult input)
          output-tap (async/chan)
          output (async/pub output-tap ::topic)]
      (async/tap mult output-tap)
      (assoc component
             :input input
             :mult mult
             :output output)))

  (stop [component]
    (println ";; Stopping bus")
    (async/close! (:input component))
    (assoc component
           :input nil
           :mult nil
           :output nil)))

(defn make-component []
  (map->Bus {}))

(ns pepa.bus
  (:require [com.stuartsierra.component :as component]
            [clojure.core.async :as async :refer [>!!]]))

;;; pepa.bus is a simple application-wide notification bus. Clients
;;; can subscribe for any topic they want and will receive a value for
;;; any call of `notify!' for that topic.

(defn subscribe
  "Returns a channel with that will receive a value when `notify!' is
  called for that topic."
  ([bus topic buf]
   (let [chan (async/chan buf)]
     (async/sub (:output bus) topic chan)
     chan))
  ([bus topic]
   (subscribe bus topic nil)))

(defn notify!
  ([bus topic data]
   (println "notify!" topic data)
   (>!! (:input bus) (assoc data ::topic topic)))
  ([bus topic]
   (notify! bus topic {})))

(defn subscribe-all
  "Returns a channel receiving all messages sent over the bus."
  ([bus buf]
   (let [ch (async/chan buf)]
     (async/tap (:mult bus) ch)))
  ([bus]
   (subscribe-all bus nil)))

(defn topic [message]
  (::topic message))

(defrecord Bus [input mult output]
  component/Lifecycle
  (start [component]
    (println ";; Starting bus")
    (let [input (async/chan)
          mult (async/mult input)
          output-tap (async/chan)
          output (async/pub output-tap ::topic)]
      (async/tap mult output-tap)
      (assoc component
             :input input
             :mult mult
             :output output)))

  (stop [component]
    (println ";; Stopping bus")
    (when-let [input (:input component)]
      (async/close! input))
    (assoc component
           :input nil
           :mult nil
           :output nil)))

(defn make-component []
  (map->Bus {}))

make pepa.bus/Bus double-`stop'-safe.

make pepa.bus/Bus double-`stop'-safe.


(ns buildviz.junit-xml
  (:require [clojure.xml :as xml]))

(defn is-ok? [{status :status}]
  (contains? #{:pass :skipped} status))

;; Parsing is following schema documented in http://llg.cubic.org/docs/junit/

(defn- is-failure? [testcase-elem]
  (some #(= :failure (:tag %))
        (:content testcase-elem)))

(defn- is-error? [testcase-elem]
  (some #(= :error (:tag %))
        (:content testcase-elem)))

(defn- is-skipped? [testcase-elem]
  (some #(= :skipped (:tag %))
        (:content testcase-elem)))

(defn- item-name [elem]
  (:name (:attrs elem)))

(defn- parse-runtime [testcase-elem]
  (if-let [time (:time (:attrs testcase-elem))]
    (Math/round (* 1000 (Float/parseFloat time)))))

(defn- parse-status [testcase-elem]
  (if (is-failure? testcase-elem)
    :fail
    (if (is-error? testcase-elem)
      :error
      (if (is-skipped? testcase-elem)
        :skipped
        :pass))))

(defn- add-runtime [testcase testcase-elem]
  (if-let [runtime (parse-runtime testcase-elem)]
    (assoc testcase :runtime runtime)
    testcase))

(defn- add-class [testcase testcase-elem]
  (if-let [classname (:classname (:attrs testcase-elem))]
    (assoc testcase :classname classname)
    testcase))

(defn- testcase [testcase-elem]
  (-> {:name (item-name testcase-elem)
       :status (parse-status testcase-elem)}
      (add-runtime testcase-elem)
      (add-class testcase-elem)))

(declare parse-testsuite)

(defn- properties? [elem]
  (= :properties (:tag elem)))

(defn- testsuite? [elem]
  (= :testsuite (:tag elem)))

(defn- ignore-properties [children]
  (filter (complement properties?) children))

(defn- testsuite [testsuite-elem]
  {:name (item-name testsuite-elem)
   :children (map parse-testsuite
                  (ignore-properties (:content testsuite-elem)))})

(defn- parse-testsuite [elem]
  (if (testsuite? elem)
    (testsuite elem)
    (testcase elem)))

(defn parse-testsuites [junit-xml-result]
  (let [root (xml/parse (java.io.ByteArrayInputStream. (.getBytes junit-xml-result)))]
    (if (= :testsuites (:tag root))
      (map parse-testsuite
           (:content root))
      (list (parse-testsuite root)))))

(ns buildviz.junit-xml
  (:require [clojure.xml :as xml]))

(defn is-ok? [{status :status}]
  (contains? #{:pass :skipped} status))

;; Parsing is following schema documented in http://llg.cubic.org/docs/junit/

(defn- is-failure? [testcase-elem]
  (some #(= :failure (:tag %))
        (:content testcase-elem)))

(defn- is-error? [testcase-elem]
  (some #(= :error (:tag %))
        (:content testcase-elem)))

(defn- is-skipped? [testcase-elem]
  (some #(= :skipped (:tag %))
        (:content testcase-elem)))

(defn- item-name [elem]
  (:name (:attrs elem)))

(defn- parse-runtime [testcase-elem]
  (if-let [time (:time (:attrs testcase-elem))]
    (Math/round (* 1000 (Float/parseFloat time)))))

(defn- parse-status [testcase-elem]
  (cond
    (is-failure? testcase-elem) :fail
    (is-error? testcase-elem) :error
    (is-skipped? testcase-elem) :skipped
    :else :pass))

(defn- add-runtime [testcase testcase-elem]
  (if-let [runtime (parse-runtime testcase-elem)]
    (assoc testcase :runtime runtime)
    testcase))

(defn- add-class [testcase testcase-elem]
  (if-let [classname (:classname (:attrs testcase-elem))]
    (assoc testcase :classname classname)
    testcase))

(defn- testcase [testcase-elem]
  (-> {:name (item-name testcase-elem)
       :status (parse-status testcase-elem)}
      (add-runtime testcase-elem)
      (add-class testcase-elem)))

(declare parse-testsuite)

(defn- properties? [elem]
  (= :properties (:tag elem)))

(defn- testsuite? [elem]
  (= :testsuite (:tag elem)))

(defn- ignore-properties [children]
  (filter (complement properties?) children))

(defn- testsuite [testsuite-elem]
  {:name (item-name testsuite-elem)
   :children (map parse-testsuite
                  (ignore-properties (:content testsuite-elem)))})

(defn- parse-testsuite [elem]
  (if (testsuite? elem)
    (testsuite elem)
    (testcase elem)))

(defn parse-testsuites [junit-xml-result]
  (let [root (xml/parse (java.io.ByteArrayInputStream. (.getBytes junit-xml-result)))]
    (if (= :testsuites (:tag root))
      (map parse-testsuite
           (:content root))
      (list (parse-testsuite root)))))

Refactor to use cond

Refactor to use cond


(ns analyze-data.tf-idf.core
  (:require [analyze-data.tf-idf.term-frequency
             :refer [normalized-term-frequency]]
            [analyze-data.tf-idf.inverse-document-frequency
             :refer [inverse-document-frequency]]
            [analyze-data.tf-idf.words
             :refer [n-grams remove-stopwords to-words]]))

(defn to-terms
  "Given a string representing a document, return a sequence of words,
  bigrams, and trigrams found in the document."
  [document]
  (let [words (remove-stopwords (to-words document))]
    (concat words (n-grams 2 words) (n-grams 3 words))))

(defn- tf-idf-document
  "Calculate a sequence of (term frequency * inverse document frequency) values
  for a single document.

  idf: map from term to its inverse document frequency in the corpus
  all-terms: sorted sequence of all terms found in the corpus
  tf-document: map from term to its frequency in a single document

  Return a sequence of calculated tf-idf values for the given tf-document,
  matching the order of all-terms."
  [idf all-terms tf-document]
  (let [calc-tf-idf (fn [term] (* (get tf-document term 0) (get idf term 0)))]
    (map calc-tf-idf all-terms)))

(defn tf-idf
  "Calculates (term frequency * inverse document frequency) values for a corpus
  of documents.

  term-corpus: a sequence of term sequences. A term is a word, or bigram, or
               trigram, etc. Each term sequence should represent a single
               document in the corpus.

  Return a sequence of the form:
  [[\"a\" ...] [0.3 ...] [0.2 ...] ...]

  The first sequence is a sorted sequence of all terms found in the
  corpus. The rest are sequences of tf-idf values of those terms, for each
  document in term-corpus."
  [term-corpus]
  (let [all-terms (sort (distinct (reduce into term-corpus)))
        tf-corpus (map normalized-term-frequency term-corpus)
        idf (inverse-document-frequency tf-corpus)
        tf-idf-values (map (partial tf-idf-document idf all-terms) tf-corpus)]
    (cons all-terms tf-idf-values)))

(ns analyze-data.tf-idf.core
  (:require [analyze-data.tf-idf.term-frequency
             :refer [normalized-term-frequency]]
            [analyze-data.tf-idf.inverse-document-frequency
             :refer [inverse-document-frequency]]
            [analyze-data.tf-idf.words
             :refer [n-grams remove-stopwords to-words]]))

(defn to-terms
  "Given a string representing a document, return a sequence of words,
  bigrams, and trigrams found in the document."
  [document]
  (let [words (remove-stopwords (to-words document))]
    (concat words (n-grams 2 words) (n-grams 3 words))))

(defn- tf-idf-document
  "Calculate a sequence of (term frequency * inverse document frequency) values
  for a single document.

  idf: map from term to its inverse document frequency in the corpus
  all-terms: sorted sequence of all terms found in the corpus
  tf-document: map from term to its frequency in a single document

  Return a sequence of calculated tf-idf values for the given tf-document,
  matching the order of all-terms."
  [idf all-terms tf-document]
  (let [calc-tf-idf (fn [term] (* (get tf-document term 0) (get idf term 0)))]
    (map calc-tf-idf all-terms)))

(defn tf-idf
  "Calculates (term frequency * inverse document frequency) values for a corpus
  of documents.

  term-corpus: a sequence of term sequences. A term is a word, or bigram, or
               trigram, etc. Each term sequence should represent a single
               document in the corpus.

  Return a sequence of the form:
  [[\"a\" ...] [0.3 ...] [0.2 ...] ...]

  The first sequence is a sorted sequence of all terms found in the
  corpus. The rest are sequences of tf-idf values of those terms, for each
  document in term-corpus."
  [term-corpus]
  (let [all-terms (sort (distinct (apply concat term-corpus)))
        tf-corpus (map normalized-term-frequency term-corpus)
        idf (inverse-document-frequency tf-corpus)
        tf-idf-values (map (partial tf-idf-document idf all-terms) tf-corpus)]
    (cons all-terms tf-idf-values)))

Use apply concat so sort can lazily realize the collection and not build intermediate ones.


(ns chat.client.views
  (:require [om.core :as om]
            [om.dom :as dom]
            [cljs-uuid-utils.core :as uuid]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.store :as store]
            [chat.client.views.new-message :refer [new-message-view]]
            [chat.client.views.group-invite :refer [group-invite-view]]
            [chat.client.views.helpers :as helpers])
  (:import [goog.events KeyCodes]))

(defn message-view [message owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "message"}
        (dom/img #js {:className "avatar" :src (get-in @store/app-state [:users (message :user-id) :avatar])})
        (apply dom/div #js {:className "content"}
          (helpers/format-message (message :content)))))))

(defn thread-tags-view [thread owner]
  (reify
    om/IRender
    (render [_]
      (let [tags (->> (thread :tag-ids)
                      (map #(get-in @store/app-state [:tags %])))]
        (apply dom/div #js {:className "tags"}
          (map (fn [tag]
                 (dom/div #js {:className "tag"
                               :style #js {:background-color (helpers/tag->color tag)}}
                   (tag :name))) tags))))))

(defn thread-view [thread owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "thread"}
        (when-not (thread :new?)
          (dom/div #js {:className "close"
                        :onClick (fn [_]
                                   (dispatch! :hide-thread {:thread-id (thread :id)}))} "×"))
        (om/build thread-tags-view thread)
        (when-not (thread :new?)
          (apply dom/div #js {:className "messages"}
            (om/build-all message-view (->> (thread :messages)
                                            (sort-by :created-at))
                          {:key :id})))
        (om/build new-message-view {:thread-id (thread :id)
                                    :placeholder (if (thread :new?)
                                                   "Start a conversation..."
                                                   "Reply...")}
                  {:react-key "message"})))))

(defn tag-view [tag owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "tag"
                    :onClick (fn [_]
                               (if (tag :subscribed?)
                                 (dispatch! :unsubscribe-from-tag (tag :id))
                                 (dispatch! :subscribe-to-tag (tag :id))))}
        (dom/div #js {:className "color-block"
                      :style #js {:backgroundColor (helpers/tag->color tag)}}
          (when (tag :subscribed?)
            "✔"))
        (dom/span #js {:className "name"}
          (tag :name))))))

(defn new-tag-view [data owner]
  (reify
    om/IRender
    (render [_]
      (dom/input #js {:className "new-tag"
                      :onKeyDown
                      (fn [e]
                        (when (= 13 e.keyCode)
                          (let [text (.. e -target -value)]
                            (dispatch! :create-tag [text (data :group-id)]))
                          (.preventDefault e)
                          (aset (.. e -target) "value" "")))
                      :placeholder "New Tag"}))))

(defn group-tags-view [[group-id tags] owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "group"}
        (dom/h2 #js {:className "name"}
          (:name (store/id->group group-id)))
        (om/build group-invite-view group-id)
        (apply dom/div #js {:className "tags"}
          (om/build-all tag-view tags))
        (om/build new-tag-view {:group-id group-id})))))

(defn groups-view [grouped-tags owner]
  (reify
    om/IRender
    (render [_]
      (apply dom/div #js {:className "tag-groups"}
        (om/build-all group-tags-view grouped-tags)))))

(defn invitations-view
  [invites owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "pending-invites"}
        (dom/h2 nil "Invites")
        (apply dom/ul #js {:className "invites"}
          (map (fn [invite]
                 (dom/li #js {:className "invite"}
                   "Group "
                   (dom/strong nil (invite :group-name))
                   " from "
                   (dom/strong nil (invite :inviter-email))
                   (dom/br nil)
                   (dom/button #js {:onClick
                                    (fn [_]
                                      (dispatch! :accept-invite invite))}
                     "Accept")
                   (dom/button #js {:onClick
                                    (fn [_]
                                      (dispatch! :decline-invite invite))}
                     "Decline")))
               invites))))))

(defn chat-view [data owner]
  (reify
    om/IRender
    (render [_]
      (let [groups-map (into {} (map (juxt identity (constantly nil))) (keys (data :groups)))
            ; groups-map is just map of group-ids to nil, to be merged with
            ; tags, so there is still an entry for groups without any tags
            grouped-tags (->> (data :tags)
                              vals
                              (map (fn [tag]
                                     (assoc tag :subscribed?
                                       (store/is-subscribed-to-tag? (tag :id)))))
                              (group-by :group-id)
                              (merge groups-map))]
        (dom/div nil
          (when-let [err (data :error-msg)]
            (dom/div #js {:className "error-banner"}
              err
              (dom/span #js {:className "close"
                            :onClick (fn [_] (store/clear-error!))}
                "×")))
          (dom/div #js {:className "meta"}
            (dom/img #js {:className "avatar"
                          :src (let [user-id (get-in @store/app-state [:session :user-id])]
                                 (get-in @store/app-state [:users user-id :avatar]))})
            (dom/div #js {:className "extras"}
              (om/build groups-view grouped-tags)
              (when (seq (data :invitations))
                (om/build invitations-view (data :invitations)))
              (dom/div #js {:className "new-group"}
                (dom/label nil "New Group"
                  (dom/input #js {:placeholder "Group Name"
                                  :onKeyDown
                                  (fn [e]
                                    (when (= KeyCodes.ENTER e.keyCode)
                                      (.preventDefault e)
                                      (let [group-name (.. e -target -value)]
                                        (dispatch! :create-group {:name group-name})
                                        (set! (.. e -target -value) "")))) })))
              (dom/div #js {:className "logout"
                            :onClick (fn [_] (dispatch! :logout nil))} "Log Out")))
          (apply dom/div #js {:className "threads"}
            (concat (om/build-all thread-view
                                  (->> (vals (data :threads))
                                       (sort-by
                                         (comp (partial apply min) (partial map :created-at) :messages)))
                                  {:key :id})
                    [(om/build thread-view
                               {:id (uuid/make-random-squuid)
                                :new? true
                                :tag-ids []
                                :messages []}
                               {:react-key "new-thread"})])))))))

(defn login-view [data owner]
  (reify
    om/IInitState
    (init-state [_]
      {:email ""
       :password ""
       :error false})
    om/IRenderState
    (render-state [_ state]
      (dom/div #js {:className "login"}
        (when (state :error)
          (dom/div #js {:className "error"}
            "Bad credentials, please try again"))
        (dom/input
          #js {:placeholder "Email"
               :type "text"
               :value (state :email)
               :onChange (fn [e] (om/set-state! owner :email (.. e -target -value)))})
        (dom/input
          #js {:placeholder "Password"
               :type "password"
               :value (state :password)
               :onChange (fn [e] (om/set-state! owner :password (.. e -target -value)))})
        (dom/button
          #js {:onClick (fn [e]
                          (dispatch! :auth
                                     {:email (state :email)
                                      :password (state :password)
                                      :on-error
                                      (fn []
                                        (om/set-state! owner :error true))}))}
          "Let's do this!")))))

(defn app-view [data owner]
  (reify
    om/IRender
    (render [_]
      (dom/div nil
        (if (data :session)
          (om/build chat-view data)
          (om/build login-view data))))))

(ns chat.client.views
  (:require [om.core :as om]
            [om.dom :as dom]
            [cljs-uuid-utils.core :as uuid]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.store :as store]
            [chat.client.views.new-message :refer [new-message-view]]
            [chat.client.views.group-invite :refer [group-invite-view]]
            [chat.client.views.helpers :as helpers])
  (:import [goog.events KeyCodes]))

(defn message-view [message owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "message"}
        (dom/img #js {:className "avatar" :src (get-in @store/app-state [:users (message :user-id) :avatar])})
        (apply dom/div #js {:className "content"}
          (helpers/format-message (message :content)))))))

(defn thread-tags-view [thread owner]
  (reify
    om/IRender
    (render [_]
      (let [tags (->> (thread :tag-ids)
                      (map #(get-in @store/app-state [:tags %])))]
        (apply dom/div #js {:className "tags"}
          (map (fn [tag]
                 (dom/div #js {:className "tag"
                               :style #js {:backgroundColor (helpers/tag->color tag)}}
                   (tag :name))) tags))))))

(defn thread-view [thread owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "thread"}
        (when-not (thread :new?)
          (dom/div #js {:className "close"
                        :onClick (fn [_]
                                   (dispatch! :hide-thread {:thread-id (thread :id)}))} "×"))
        (om/build thread-tags-view thread)
        (when-not (thread :new?)
          (apply dom/div #js {:className "messages"}
            (om/build-all message-view (->> (thread :messages)
                                            (sort-by :created-at))
                          {:key :id})))
        (om/build new-message-view {:thread-id (thread :id)
                                    :placeholder (if (thread :new?)
                                                   "Start a conversation..."
                                                   "Reply...")}
                  {:react-key "message"})))))

(defn tag-view [tag owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "tag"
                    :onClick (fn [_]
                               (if (tag :subscribed?)
                                 (dispatch! :unsubscribe-from-tag (tag :id))
                                 (dispatch! :subscribe-to-tag (tag :id))))}
        (dom/div #js {:className "color-block"
                      :style #js {:backgroundColor (helpers/tag->color tag)}}
          (when (tag :subscribed?)
            "✔"))
        (dom/span #js {:className "name"}
          (tag :name))))))

(defn new-tag-view [data owner]
  (reify
    om/IRender
    (render [_]
      (dom/input #js {:className "new-tag"
                      :onKeyDown
                      (fn [e]
                        (when (= 13 e.keyCode)
                          (let [text (.. e -target -value)]
                            (dispatch! :create-tag [text (data :group-id)]))
                          (.preventDefault e)
                          (aset (.. e -target) "value" "")))
                      :placeholder "New Tag"}))))

(defn group-tags-view [[group-id tags] owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "group"}
        (dom/h2 #js {:className "name"}
          (:name (store/id->group group-id)))
        (om/build group-invite-view group-id)
        (apply dom/div #js {:className "tags"}
          (om/build-all tag-view tags))
        (om/build new-tag-view {:group-id group-id})))))

(defn groups-view [grouped-tags owner]
  (reify
    om/IRender
    (render [_]
      (apply dom/div #js {:className "tag-groups"}
        (om/build-all group-tags-view grouped-tags)))))

(defn invitations-view
  [invites owner]
  (reify
    om/IRender
    (render [_]
      (dom/div #js {:className "pending-invites"}
        (dom/h2 nil "Invites")
        (apply dom/ul #js {:className "invites"}
          (map (fn [invite]
                 (dom/li #js {:className "invite"}
                   "Group "
                   (dom/strong nil (invite :group-name))
                   " from "
                   (dom/strong nil (invite :inviter-email))
                   (dom/br nil)
                   (dom/button #js {:onClick
                                    (fn [_]
                                      (dispatch! :accept-invite invite))}
                     "Accept")
                   (dom/button #js {:onClick
                                    (fn [_]
                                      (dispatch! :decline-invite invite))}
                     "Decline")))
               invites))))))

(defn chat-view [data owner]
  (reify
    om/IRender
    (render [_]
      (let [groups-map (into {} (map (juxt identity (constantly nil))) (keys (data :groups)))
            ; groups-map is just map of group-ids to nil, to be merged with
            ; tags, so there is still an entry for groups without any tags
            grouped-tags (->> (data :tags)
                              vals
                              (map (fn [tag]
                                     (assoc tag :subscribed?
                                       (store/is-subscribed-to-tag? (tag :id)))))
                              (group-by :group-id)
                              (merge groups-map))]
        (dom/div nil
          (when-let [err (data :error-msg)]
            (dom/div #js {:className "error-banner"}
              err
              (dom/span #js {:className "close"
                            :onClick (fn [_] (store/clear-error!))}
                "×")))
          (dom/div #js {:className "meta"}
            (dom/img #js {:className "avatar"
                          :src (let [user-id (get-in @store/app-state [:session :user-id])]
                                 (get-in @store/app-state [:users user-id :avatar]))})
            (dom/div #js {:className "extras"}
              (om/build groups-view grouped-tags)
              (when (seq (data :invitations))
                (om/build invitations-view (data :invitations)))
              (dom/div #js {:className "new-group"}
                (dom/label nil "New Group"
                  (dom/input #js {:placeholder "Group Name"
                                  :onKeyDown
                                  (fn [e]
                                    (when (= KeyCodes.ENTER e.keyCode)
                                      (.preventDefault e)
                                      (let [group-name (.. e -target -value)]
                                        (dispatch! :create-group {:name group-name})
                                        (set! (.. e -target -value) "")))) })))
              (dom/div #js {:className "logout"
                            :onClick (fn [_] (dispatch! :logout nil))} "Log Out")))
          (apply dom/div #js {:className "threads"}
            (concat (om/build-all thread-view
                                  (->> (vals (data :threads))
                                       (sort-by
                                         (comp (partial apply min) (partial map :created-at) :messages)))
                                  {:key :id})
                    [(om/build thread-view
                               {:id (uuid/make-random-squuid)
                                :new? true
                                :tag-ids []
                                :messages []}
                               {:react-key "new-thread"})])))))))

(defn login-view [data owner]
  (reify
    om/IInitState
    (init-state [_]
      {:email ""
       :password ""
       :error false})
    om/IRenderState
    (render-state [_ state]
      (dom/div #js {:className "login"}
        (when (state :error)
          (dom/div #js {:className "error"}
            "Bad credentials, please try again"))
        (dom/input
          #js {:placeholder "Email"
               :type "text"
               :value (state :email)
               :onChange (fn [e] (om/set-state! owner :email (.. e -target -value)))})
        (dom/input
          #js {:placeholder "Password"
               :type "password"
               :value (state :password)
               :onChange (fn [e] (om/set-state! owner :password (.. e -target -value)))})
        (dom/button
          #js {:onClick (fn [e]
                          (dispatch! :auth
                                     {:email (state :email)
                                      :password (state :password)
                                      :on-error
                                      (fn []
                                        (om/set-state! owner :error true))}))}
          "Let's do this!")))))

(defn app-view [data owner]
  (reify
    om/IRender
    (render [_]
      (dom/div nil
        (if (data :session)
          (om/build chat-view data)
          (om/build login-view data))))))

set bg colour the way react wants

set bg colour the way react wants


(ns braid.ui.views.message
  (:require [reagent.core :as r]
            [clojure.string :as string]
            [chat.client.store :as store]
            [chat.client.views.helpers :refer [id->color]]
            [chat.client.reagent-adapter :refer [subscribe]]
            [braid.ui.views.embed :refer [embed-view]]
            [braid.ui.views.pills :refer [tag-pill-view user-pill-view]]
            [chat.client.emoji :as emoji]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.views.helpers :as helpers :refer [starts-with? ends-with?]]
            [chat.client.routes :as routes]))

(def url-re #"(http(?:s)?://\S+(?:\w|\d|/))")

(defn abridged-url
  "Given a full url, returns 'domain.com/*.png' where"
  [url]
  (let [char-limit 30
        [domain path] (rest (re-find #"http(?:s)?://([^/]+)(.*)" url))]
    (let [url-and-path (str domain path)]
      (if (> char-limit (count url-and-path))
        url-and-path
        (let [gap "/..."
              path-char-limit (- char-limit (count domain) (count gap))
              abridged-path (apply str (take-last path-char-limit path))]
          (str domain gap abridged-path))))))

(def replacements
  {:urls
   {:pattern url-re
    :replace (fn [match]
               [:a.external {:href match
                             :title match
                             :target "_blank"
                             :tabIndex -1}
                 (abridged-url match)])}
   :users
   {:pattern #"@([-0-9a-z]+)"
    :replace (fn [match]
               ;TODO: Subscribe to valid user id
               (if (store/valid-user-id? (uuid match))
                 [user-pill-view (uuid match)]
                 [:span "@" match]))}
   :tags
   {:pattern #"#([-0-9a-z]+)"
    :replace (fn [match]
               (if (store/get-tag (uuid match))
                 [tag-pill-view (uuid match)]
                 [:span "#" match]))}
   :emoji-shortcodes
   {:pattern #"(:\S*:)"
    :replace (fn [match]
               (if (emoji/unicode match)
                 (emoji/shortcode->html match)
                 match))}
   :emoji-ascii
   {:replace (fn [match]
               (if-let [shortcode (emoji/ascii match)]
                 (emoji/shortcode->html shortcode)
                 match))}
   })

(defn re-replace
  [re s replace-fn]
  (if-let [match (second (re-find re s))]
    ; TODO: recurse, incease the rest has more matches?
    ; using Javascript split beacuse we don't want the match to be in the last
    ; component
    (let [[pre _ post] (seq (.split s re 3))]
      (if (or (string/blank? pre) (re-matches #".*\s$" pre))
      ; XXX: find a way to use return a seq & use mapcat instead of this hack
      [:span.dummy pre (replace-fn match) post]
      s))
    s))

(defn make-text-replacer
  "Make a new function to perform a simple stateless replacement of a single element"
  [match-type]
  (fn [text-or-node]
    (if (string? text-or-node)
      (let [text text-or-node
            type-info (get replacements match-type)]
        (re-replace (type-info :pattern) text (type-info :replace)))
      text-or-node)))

(defn make-delimited-processor
  "Make a new transducer to process the stream of words"
  [{:keys [delimiter result-fn]}]
  (fn [xf]
    (let [state (volatile! ::start)
          in-code (volatile! [])]
      (fn
        ([] (xf))
        ([result] (if (= @state ::in-code)
                    (reduce xf result (update-in @in-code [0] (partial str delimiter)))
                    (xf result)))
        ([result input]
         (if (string? input)
           (cond
             ; TODO: handle starting code block with delimiter not at beginning of word
             ; start
             (and (= @state ::start) (starts-with? input delimiter))
             (cond
               (and (not= input delimiter) (ends-with? input delimiter))
               (xf result (result-fn (.slice input (count delimiter) (- (.-length input) (count delimiter)))))

               (and (not= input delimiter) (not= 0 (.lastIndexOf input delimiter)))
               (let [idx (.lastIndexOf input delimiter)
                     code (.slice input (count delimiter) idx)
                     after (.slice input (inc idx) (.-length input))]
                 (reduce xf result [(result-fn code) after]))

               :else
               (do (vreset! state ::in-code)
                   (vswap! in-code conj (.slice input (count delimiter)))
                   result))

             ; end
             (and (= @state ::in-code) (ends-with? input delimiter))
             (let [code (conj @in-code (.slice input 0 (- (.-length input) (count delimiter))))]
               (vreset! state ::start)
               (vreset! in-code [])
               (xf result (result-fn (string/join " " code))))

             (and (= @state ::in-code) (not= -1 (.indexOf input delimiter)))
             (let [idx (.indexOf input delimiter)
                   code (conj @in-code (.slice input 0 idx))
                   after (.slice input (inc idx) (.-length input))]
               (vreset! state ::start)
               (vreset! in-code [])
               (reduce xf result [(result-fn (string/join " " code)) after]))

             (= @state ::in-code) (do (vswap! in-code conj input) result)

             :else (xf result input))
           (xf result input)))))))

(def url-replace (make-text-replacer :urls))
(def user-replace (make-text-replacer :users))
(def tag-replace (make-text-replacer :tags))
(def emoji-shortcodes-replace (make-text-replacer :emoji-shortcodes))

(defn emoji-ascii-replace [text-or-node]
  (if (string? text-or-node)
    (let [text text-or-node]
      (if (contains? emoji/ascii-set text)
        ((get-in replacements [:emoji-ascii :replace]) text)
        text))
    text-or-node))

(def extract-code-blocks
  (make-delimited-processor {:delimiter "```"
                             :result-fn (partial [:code.prettyprint.multiline-code.lang-clj])}))
(def extract-code-inline
  (make-delimited-processor {:delimiter "`"
                             :result-fn (partial [:code.prettyprint.inline-code.lang-clj])}))

(def extract-emphasized
  (make-delimited-processor {:delimiter "*"
                             :result-fn (partial [:strong.starred])}))

(defn extract-urls
  "Given some text, returns a sequence of URLs contained in the text"
  [text]
  (map first (re-seq url-re text)))

(defn format-message
  "Given the text of a message body, turn it into dom nodes, making urls into
  links"
  [text]
  (let [; Caution: order of transforms is important! url-replace should come before
        ; user/tag replace at least so urls with octothorpes or at-signs don't get
        ; wrecked
        stateless-transform (map (comp emoji-ascii-replace
                                       emoji-shortcodes-replace
                                       tag-replace
                                       user-replace
                                       url-replace))
        statefull-transform (comp extract-code-blocks extract-code-inline extract-emphasized)]
    (->> (into [] (comp statefull-transform stateless-transform) (string/split text #" "))
         (interleave (repeat " "))
         rest)))

(defn message-view [message]
  ; TODO: closing over value!
  (let [sender (subscribe [:user (message :user-id)])]
    (r/create-class
      {:component-did-mount
       (fn []
         ; TODO: use prettyPrintOne to only do the content of this node
         ; TODO: also call on IDidUpdate?
         ; TODO: don't call if don't have code?
         (when-let [PR (aget js/window "PR")]
           ((aget PR "prettyPrint"))))
       :reagent-render
       (fn [message]
         (let [sender-path (routes/user-page-path {:group-id (routes/current-group)
                                                   :user-id (@sender :id)})]
           [:div.message {:class (str " " (when (:collapse? message) "collapse")
                                      " " (if (:unseen? message) "unseen" "seen")
                                      " " (when (:first-unseen? message) "first-unseen")
                                      " " (when (:failed? message) "failed-to-send"))}
            (when (:failed? message)
              [:div.error
               [:span "Message failed to send"]
               [:button {:on-click
                         (fn [_] (dispatch! :resend-message message))}
                "Resend"]])
            [:a.avatar {:href sender-path
                        :tabIndex -1}
             [:img {:src (@sender :avatar)
                    :style {:backgroundColor (id->color (@sender :id))}}]]
            [:div.info
             [:a.nickname {:tabIndex -1
                           :href sender-path}
              (@sender :nickname)]
             [:span.time {:title (message :created-at)} (helpers/format-date (message :created-at))]]

            (into [:div.content] (format-message (message :content)))

            (when-let [url (first (extract-urls (message :content)))]
              [embed-view url])]))})))

(ns braid.ui.views.message
  (:require [reagent.core :as r]
            [clojure.string :as string]
            [chat.client.store :as store]
            [chat.client.views.helpers :refer [id->color]]
            [chat.client.reagent-adapter :refer [subscribe]]
            [braid.ui.views.embed :refer [embed-view]]
            [braid.ui.views.pills :refer [tag-pill-view user-pill-view]]
            [chat.client.emoji :as emoji]
            [chat.client.dispatcher :refer [dispatch!]]
            [chat.client.views.helpers :as helpers :refer [starts-with? ends-with?]]
            [chat.client.routes :as routes]))

(def url-re #"(http(?:s)?://\S+(?:\w|\d|/))")

(defn abridged-url
  "Given a full url, returns 'domain.com/*.png' where"
  [url]
  (let [char-limit 30
        [domain path] (rest (re-find #"http(?:s)?://([^/]+)(.*)" url))]
    (let [url-and-path (str domain path)]
      (if (> char-limit (count url-and-path))
        url-and-path
        (let [gap "/..."
              path-char-limit (- char-limit (count domain) (count gap))
              abridged-path (apply str (take-last path-char-limit path))]
          (str domain gap abridged-path))))))

(def replacements
  {:urls
   {:pattern url-re
    :replace (fn [match]
               [:a.external {:href match
                             :title match
                             :target "_blank"
                             :tabIndex -1}
                 (abridged-url match)])}
   :users
   {:pattern #"@([-0-9a-z]+)"
    :replace (fn [match]
               ;TODO: Subscribe to valid user id
               (if (store/valid-user-id? (uuid match))
                 [user-pill-view (uuid match)]
                 [:span "@" match]))}
   :tags
   {:pattern #"#([-0-9a-z]+)"
    :replace (fn [match]
               (if (store/get-tag (uuid match))
                 [tag-pill-view (uuid match)]
                 [:span "#" match]))}
   :emoji-shortcodes
   {:pattern #"(:\S*:)"
    :replace (fn [match]
               (if (emoji/unicode match)
                 (emoji/shortcode->html match)
                 match))}
   :emoji-ascii
   {:replace (fn [match]
               (if-let [shortcode (emoji/ascii match)]
                 (emoji/shortcode->html shortcode)
                 match))}
   })

(defn re-replace
  [re s replace-fn]
  (if-let [match (second (re-find re s))]
    ; TODO: recurse, incease the rest has more matches?
    ; using Javascript split beacuse we don't want the match to be in the last
    ; component
    (let [[pre _ post] (seq (.split s re 3))]
      (if (or (string/blank? pre) (re-matches #".*\s$" pre))
      ; XXX: find a way to use return a seq & use mapcat instead of this hack
      [:span.dummy pre (replace-fn match) post]
      s))
    s))

(defn make-text-replacer
  "Make a new function to perform a simple stateless replacement of a single element"
  [match-type]
  (fn [text-or-node]
    (if (string? text-or-node)
      (let [text text-or-node
            type-info (get replacements match-type)]
        (re-replace (type-info :pattern) text (type-info :replace)))
      text-or-node)))

(defn make-delimited-processor
  "Make a new transducer to process the stream of words"
  [{:keys [delimiter result-fn]}]
  (fn [xf]
    (let [state (volatile! ::start)
          in-code (volatile! [])]
      (fn
        ([] (xf))
        ([result] (if (= @state ::in-code)
                    (reduce xf result (update-in @in-code [0] (partial str delimiter)))
                    (xf result)))
        ([result input]
         (if (string? input)
           (cond
             ; TODO: handle starting code block with delimiter not at beginning of word
             ; start
             (and (= @state ::start) (starts-with? input delimiter))
             (cond
               (and (not= input delimiter) (ends-with? input delimiter))
               (xf result (result-fn (.slice input (count delimiter) (- (.-length input) (count delimiter)))))

               (and (not= input delimiter) (not= 0 (.lastIndexOf input delimiter)))
               (let [idx (.lastIndexOf input delimiter)
                     code (.slice input (count delimiter) idx)
                     after (.slice input (inc idx) (.-length input))]
                 (reduce xf result [(result-fn code) after]))

               :else
               (do (vreset! state ::in-code)
                   (vswap! in-code conj (.slice input (count delimiter)))
                   result))

             ; end
             (and (= @state ::in-code) (ends-with? input delimiter))
             (let [code (conj @in-code (.slice input 0 (- (.-length input) (count delimiter))))]
               (vreset! state ::start)
               (vreset! in-code [])
               (xf result (result-fn (string/join " " code))))

             (and (= @state ::in-code) (not= -1 (.indexOf input delimiter)))
             (let [idx (.indexOf input delimiter)
                   code (conj @in-code (.slice input 0 idx))
                   after (.slice input (inc idx) (.-length input))]
               (vreset! state ::start)
               (vreset! in-code [])
               (reduce xf result [(result-fn (string/join " " code)) after]))

             (= @state ::in-code) (do (vswap! in-code conj input) result)

             :else (xf result input))
           (xf result input)))))))

(def url-replace (make-text-replacer :urls))
(def user-replace (make-text-replacer :users))
(def tag-replace (make-text-replacer :tags))
(def emoji-shortcodes-replace (make-text-replacer :emoji-shortcodes))

(defn emoji-ascii-replace [text-or-node]
  (if (string? text-or-node)
    (let [text text-or-node]
      (if (contains? emoji/ascii-set text)
        ((get-in replacements [:emoji-ascii :replace]) text)
        text))
    text-or-node))

(def extract-code-blocks
  (make-delimited-processor {:delimiter "```"
                             :result-fn (fn [body]
                                          [:code.prettyprint.multiline-code.lang-clj body])}))
(def extract-code-inline
  (make-delimited-processor {:delimiter "`"
                             :result-fn (fn [body]
                                          [:code.prettyprint.inline-code.lang-clj body])}))

(def extract-emphasized
  (make-delimited-processor {:delimiter "*"
                             :result-fn (fn [body] [:strong.starred body])}))

(defn extract-urls
  "Given some text, returns a sequence of URLs contained in the text"
  [text]
  (map first (re-seq url-re text)))

(defn format-message
  "Given the text of a message body, turn it into dom nodes, making urls into
  links"
  [text]
  (let [; Caution: order of transforms is important! url-replace should come before
        ; user/tag replace at least so urls with octothorpes or at-signs don't get
        ; wrecked
        stateless-transform (map (comp emoji-ascii-replace
                                       emoji-shortcodes-replace
                                       tag-replace
                                       user-replace
                                       url-replace))
        statefull-transform (comp extract-code-blocks extract-code-inline extract-emphasized)]
    (->> (into [] (comp statefull-transform stateless-transform) (string/split text #" "))
         (interleave (repeat " "))
         rest)))

(defn message-view [message]
  ; TODO: closing over value!
  (let [sender (subscribe [:user (message :user-id)])]
    (r/create-class
      {:component-did-mount
       (fn []
         ; TODO: use prettyPrintOne to only do the content of this node
         ; TODO: also call on IDidUpdate?
         ; TODO: don't call if don't have code?
         (when-let [PR (aget js/window "PR")]
           ((aget PR "prettyPrint"))))
       :reagent-render
       (fn [message]
         (let [sender-path (routes/user-page-path {:group-id (routes/current-group)
                                                   :user-id (@sender :id)})]
           [:div.message {:class (str " " (when (:collapse? message) "collapse")
                                      " " (if (:unseen? message) "unseen" "seen")
                                      " " (when (:first-unseen? message) "first-unseen")
                                      " " (when (:failed? message) "failed-to-send"))}
            (when (:failed? message)
              [:div.error
               [:span "Message failed to send"]
               [:button {:on-click
                         (fn [_] (dispatch! :resend-message message))}
                "Resend"]])
            [:a.avatar {:href sender-path
                        :tabIndex -1}
             [:img {:src (@sender :avatar)
                    :style {:backgroundColor (id->color (@sender :id))}}]]
            [:div.info
             [:a.nickname {:tabIndex -1
                           :href sender-path}
              (@sender :nickname)]
             [:span.time {:title (message :created-at)} (helpers/format-date (message :created-at))]]

            (into [:div.content] (format-message (message :content)))

            (when-let [url (first (extract-urls (message :content)))]
              [embed-view url])]))})))

fix message transform fns

fix message transform fns


(ns cglossa.server
  (:require [clojure.java.io :as io]
            [cglossa.dev :refer [is-dev? inject-devmode-html]]
            [compojure.core :refer [GET defroutes routes context]]
            [compojure.route :refer [resources]]
            [compojure.handler :as handler]
            [net.cgrand.enlive-html :refer [deftemplate]]
            [ring.middleware.reload :as reload]
            [ring.middleware.params :refer [wrap-params]]
            [ring.middleware.keyword-params :refer [wrap-keyword-params]]
            [ring.middleware.format :refer [wrap-restful-format]]
            [ring.handler.dump :refer [handle-dump]]
            [prone.middleware :refer [wrap-exceptions]]
            [environ.core :refer [env]]
            [org.httpkit.server :refer [run-server]]))

(deftemplate page
  (io/resource "index.html") [] [:body] (if is-dev? inject-devmode-html identity))

(defroutes api-routes
           )

(defroutes app-routes
  (resources "/")
  (GET "/request" [] handle-dump)
  (GET "/" req (page)))

(defroutes db-routes
           (GET "/db" []
                {:status  200
                 :headers {}
                 :body    "dummy"}))

(def http-handler
  (let [r (routes (wrap-restful-format #'db-routes :formats [:transit-json :json])
                  #'app-routes)
        r (if is-dev? (-> r reload/wrap-reload wrap-exceptions) r)]
    (-> r
        wrap-keyword-params
        wrap-params)))

(defn run [& [port]]
  (defonce ^:private server
    (do
      (let [port (Integer. (or port (env :port) 10555))]
        (print "Starting web server on port" port ".\n")
        (run-server http-handler {:port port
                                  :join? false}))))
  server)

(defn -main [& [port]]
  (run port))

(ns cglossa.server
  (:require [clojure.java.io :as io]
            [cglossa.dev :refer [is-dev? inject-devmode-html]]
            [compojure.core :refer [GET defroutes routes context]]
            [compojure.route :refer [resources]]
            [compojure.handler :as handler]
            [net.cgrand.enlive-html :refer [deftemplate]]
            [ring.middleware.reload :as reload]
            [ring.middleware.params :refer [wrap-params]]
            [ring.middleware.keyword-params :refer [wrap-keyword-params]]
            [ring.middleware.format :refer [wrap-restful-format]]
            [ring.handler.dump :refer [handle-dump]]
            [prone.middleware :refer [wrap-exceptions]]
            [environ.core :refer [env]]
            [org.httpkit.server :refer [run-server]])
  (:gen-class))

(deftemplate page
  (io/resource "index.html") [] [:body] (if is-dev? inject-devmode-html identity))

(defroutes api-routes
           )

(defroutes app-routes
  (resources "/")
  (GET "/request" [] handle-dump)
  (GET "/" req (page)))

(defroutes db-routes
           (GET "/db" []
                {:status  200
                 :headers {}
                 :body    "dummy"}))

(def http-handler
  (let [r (routes (wrap-restful-format #'db-routes :formats [:transit-json :json])
                  #'app-routes)
        r (if is-dev? (-> r reload/wrap-reload wrap-exceptions) r)]
    (-> r
        wrap-keyword-params
        wrap-params)))

(defn run [& [port]]
  (defonce ^:private server
    (do
      (let [port (Integer. (or port (env :port) 10555))]
        (print "Starting web server on port" port ".\n")
        (run-server http-handler {:port port
                                  :join? false}))))
  server)

(defn -main [& [port]]
  (run port))

Add missing gen-class directive

Add missing gen-class directive