(ns com.sixsq.slipstream.ssclj.usage.summary-test
  (:require
    [com.sixsq.slipstream.ssclj.usage.summary :refer :all]
    [com.sixsq.slipstream.ssclj.usage.record-keeper :as rc]
    [com.sixsq.slipstream.ssclj.usage.utils :as u]
    [clojure.test :refer :all]
    [clojure.tools.logging :as log]
    [korma.core :refer :all]
    [clj-time.format :as f]
    [clj-time.core :as t]))

(defn timestamp
  [& args]
  (f/unparse (:date-time f/formatters) (apply t/date-time args)))

(def past-1 (timestamp 2015 04 12))
(def past-2 (timestamp 2015 04 13))
(def after-day (timestamp 2015 04 17 3))

(def start-day  (timestamp 2015 04 16))
(def in-day-1  (timestamp 2015 04 16 9 33))
(def in-day-2  (timestamp 2015 04 16 15 10))

(def end-day    (timestamp 2015 04 17))

(def future-1 (timestamp 2015 04 20))
(def future-2 (timestamp 2015 04 22))

(defn delete-all [f]
  (rc/-init)
  (defentity usage-records)
  (defentity usage-summaries)
  (delete usage-records)
  ; (delete usage-summaries)
  (log/debug "All usage-records deleted")
  (log/debug "usage records " (select usage-records))
  (log/debug "usage summaries " (select usage-summaries))
  (f))
(use-fixtures :each delete-all)

(deftest truncate-filters-outside-records
  (let [urs [{:start_timestamp in-day-1 :end_timestamp in-day-2}]]
    (is (= urs (truncate start-day end-day urs )))
    (is (= urs (truncate past-1 future-1 urs)))
    (is (= [] (truncate past-1 past-2 urs))
    (is (= [] (truncate future-1 future-2 urs))
      ))))

(deftest truncate-checks-args
  (truncate past-1 past-2 [])
  (is (thrown? IllegalArgumentException (truncate past-2 past-1 []))))

(deftest truncate-move-start
  (let [urs [{:start_timestamp past-1 :end_timestamp in-day-2}]]
    (is (= [{:start_timestamp start-day :end_timestamp in-day-2}]
        (truncate start-day end-day urs)))))

(deftest truncate-move-end
  (let [urs [{:start_timestamp in-day-1 :end_timestamp future-1}]]
    (is (= [{:start_timestamp in-day-1 :end_timestamp end-day}]
        (truncate start-day end-day urs)))))

(deftest test-contribution
  (is (= 11692.8 (contribution {:start_timestamp start-day :end_timestamp end-day :metric_value 8.12}))))

(def record-1
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     in-day-1
    :end_timestamp       in-day-2
    :metric_name        "nb-cpu"
    :metric_value       4 })

(def record-2
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       in-day-2
    :metric_name         "nb-cpu"
    :metric_value        6 })

(def record-3
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     in-day-1
    :end_timestamp       end-day
    :metric_name         "RAM"
    :metric_value        16 })

(def record-4
  { :cloud_vm_instanceid "aws:445623"
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     past-1
    :end_timestamp       future-2
    :metric_name         "Disk"
    :metric_value        100 })

(def record-5
  { :cloud_vm_instanceid "aws:445623"
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     past-1
    :end_timestamp       nil
    :metric_name         "Disk"
    :metric_value        100 })

(deftest test-summarize-records
  (is (=
    [{
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "nb-cpu"
          {
            :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
            ;; 337 minutes between in-day-1 and in-day-1, 910 minutes from start day to in-
            ; :aggregated_duration_mn   (+ (* 6 910) (* 4 337))
            :aggregated_duration_mn   (+ (* 6 910) (* 4 337))
          }
       "RAM"
        { :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   13872
        }
      }
     }]
    (summarize-records [record-1 record-2 record-3] start-day end-day)))

  (is (=
    [{
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "Disk"
          {
            :cloud_vm_instanceid      "aws:445623"
            :aggregated_duration_mn   144000
          }
      }
     }]
     (summarize-records [record-4] start-day end-day)))

  (is (=
    [{
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "Disk"
          {
            :cloud_vm_instanceid      "aws:445623"
            :aggregated_duration_mn   144000
          }
      }
     }]
     (summarize-records [record-5] start-day end-day)))
  )

(defn insert-record
  []
  (rc/-insertStart
    { :cloud_vm_instanceid   "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
      :user                "sixsq_dev"
      :cloud               "exoscale-ch-gva"
      :start_timestamp     in-day-1
      :metrics [{   :name  "nb-cpu"
                    :value 4 }
                  { :name  "RAM-GB"
                    :value 8 }
                  { :name  "disk-GB"
                    :value 100.5 }]})
  (rc/-insertEnd
    { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
      :end_timestamp       in-day-2}))

(deftest test-summarize
  (insert-record)
  (is (=
    [{
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "nb-cpu"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 4.0 337)
        }
        "RAM-GB"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 8.0 337)
        }
        "disk-GB"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 100.5 337)
        }
      }
     }]
    (summarize start-day end-day)))
  )

(deftest test-summarize-and-store
  (insert-record)
  (summarize-and-store start-day end-day)
  (let [summaries-from-db (select usage-summaries)]
    (is (= 1 (count summaries-from-db)))
    (is (= "{\"disk-GB\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":33868.5},\n \"RAM-GB\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":2696.0},\n \"nb-cpu\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":1348.0}}\n"
       (:usage (first summaries-from-db))))))

(ns com.sixsq.slipstream.ssclj.usage.summary-test
  (:require
    [com.sixsq.slipstream.ssclj.usage.summary :refer :all]
    [com.sixsq.slipstream.ssclj.usage.record-keeper :as rc]
    [com.sixsq.slipstream.ssclj.usage.utils :as u]
    [clojure.test :refer :all]
    [clojure.tools.logging :as log]
    [korma.core :refer :all]
    [clj-time.format :as f]
    [clj-time.core :as t]))

(defn timestamp
  [& args]
  (f/unparse (:date-time f/formatters) (apply t/date-time args)))

(def past-1 (timestamp 2015 04 12))
(def past-2 (timestamp 2015 04 13))
(def after-day (timestamp 2015 04 17 3))

(def start-day  (timestamp 2015 04 16))
(def in-day-1  (timestamp 2015 04 16 9 33))
(def in-day-2  (timestamp 2015 04 16 15 10))

(def end-day    (timestamp 2015 04 17))

(def future-1 (timestamp 2015 04 20))
(def future-2 (timestamp 2015 04 22))

(defn delete-all [f]
  (rc/-init)
  (defentity usage-records)
  (defentity usage-summaries)
  (delete usage-records)
  (delete usage-summaries)
  (log/debug "All usage-records deleted")
  (log/debug "usage records " (select usage-records))
  (log/debug "usage summaries " (select usage-summaries))
  (f))
(use-fixtures :each delete-all)

(deftest truncate-filters-outside-records
  (let [urs [{:start_timestamp in-day-1 :end_timestamp in-day-2}]]
    (is (= urs (truncate start-day end-day urs )))
    (is (= urs (truncate past-1 future-1 urs)))
    (is (= [] (truncate past-1 past-2 urs))
    (is (= [] (truncate future-1 future-2 urs))
      ))))

(deftest truncate-checks-args
  (truncate past-1 past-2 [])
  (is (thrown? IllegalArgumentException (truncate past-2 past-1 []))))

(deftest truncate-move-start
  (let [urs [{:start_timestamp past-1 :end_timestamp in-day-2}]]
    (is (= [{:start_timestamp start-day :end_timestamp in-day-2}]
        (truncate start-day end-day urs)))))

(deftest truncate-move-end
  (let [urs [{:start_timestamp in-day-1 :end_timestamp future-1}]]
    (is (= [{:start_timestamp in-day-1 :end_timestamp end-day}]
        (truncate start-day end-day urs)))))

(deftest test-contribution
  (is (= 11692.8 (contribution {:start_timestamp start-day :end_timestamp end-day :metric_value 8.12}))))

(def record-1
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     in-day-1
    :end_timestamp       in-day-2
    :metric_name        "nb-cpu"
    :metric_value       4 })

(def record-2
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       in-day-2
    :metric_name         "nb-cpu"
    :metric_value        6 })

(def record-3
  { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     in-day-1
    :end_timestamp       end-day
    :metric_name         "RAM"
    :metric_value        16 })

(def record-4
  { :cloud_vm_instanceid "aws:445623"
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     past-1
    :end_timestamp       future-2
    :metric_name         "Disk"
    :metric_value        100 })

(def record-5
  { :cloud_vm_instanceid "aws:445623"
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     past-1
    :end_timestamp       nil
    :metric_name         "Disk"
    :metric_value        100 })

(deftest test-summarize-records
  (is (=
    [{
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "nb-cpu"
          {
            :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
            ;; 337 minutes between in-day-1 and in-day-1, 910 minutes from start day to in-
            ; :aggregated_duration_mn   (+ (* 6 910) (* 4 337))
            :aggregated_duration_mn   (+ (* 6 910) (* 4 337))
          }
       "RAM"
        { :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   13872
        }
      }
     }]
    (summarize-records [record-1 record-2 record-3] start-day end-day)))

  (is (=
    [{
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "Disk"
          {
            :cloud_vm_instanceid      "aws:445623"
            :aggregated_duration_mn   144000
          }
      }
     }]
     (summarize-records [record-4] start-day end-day)))

  (is (=
    [{
    :user                "joe"
    :cloud               "aws"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "Disk"
          {
            :cloud_vm_instanceid      "aws:445623"
            :aggregated_duration_mn   144000
          }
      }
     }]
     (summarize-records [record-5] start-day end-day)))
  )

(defn insert-record
  []
  (rc/-insertStart
    { :cloud_vm_instanceid   "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
      :user                "sixsq_dev"
      :cloud               "exoscale-ch-gva"
      :start_timestamp     in-day-1
      :metrics [{   :name  "nb-cpu"
                    :value 4 }
                  { :name  "RAM-GB"
                    :value 8 }
                  { :name  "disk-GB"
                    :value 100.5 }]})
  (rc/-insertEnd
    { :cloud_vm_instanceid "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
      :end_timestamp       in-day-2}))

(deftest test-summarize
  (insert-record)
  (is (=
    [{
    :user                "sixsq_dev"
    :cloud               "exoscale-ch-gva"
    :start_timestamp     start-day
    :end_timestamp       end-day
    :usage
      {
        "nb-cpu"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 4.0 337)
        }
        "RAM-GB"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 8.0 337)
        }
        "disk-GB"
        {
          :cloud_vm_instanceid      "exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592"
          :aggregated_duration_mn   (* 100.5 337)
        }
      }
     }]
    (summarize start-day end-day)))
  )

(deftest test-summarize-and-store
  (insert-record)
  (summarize-and-store start-day end-day)
  (let [summaries-from-db (select usage-summaries)]
    (is (= 1 (count summaries-from-db)))
    (is (= "{\"disk-GB\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":33868.5},\n \"RAM-GB\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":2696.0},\n \"nb-cpu\":\n {\"cloud_vm_instanceid\":\n  \"exoscale-ch-gva:7142f7bc-f3b1-4c1c-b0f6-d770779b1592\",\n  \"aggregated_duration_mn\":1348.0}}\n"
       (:usage (first summaries-from-db))))))

fix unit tests

minor: fix unit tests


(ns playmary.one
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :as async :refer [<! put! chan timeout sliding-buffer close!]]
            [playmary.util :as util]
            [playmary.scales :as scales]))

(def timbre js/T)

(def colors [{:note "#676767" :light "#6DA0CB" :dark "#000000"}
             {:note "#929292" :light "#A76AB9" :dark "#1E1E1E"}
             {:note "#B9B9B9" :light "#BB67A2" :dark "#3D3D3D"}
             {:note "#DCDCDC" :light "#C55D83" :dark "#5C5C5C"}
             {:note "#FFFFFF" :light "#D35E4C" :dark "#7A7A7A"}
             {:note "#000000" :light "#E18C43" :dark "#999999"}
             {:note "#393939" :light "#E1B040" :dark "#B9B9B9"}])

(defn prevent-scrolling
  []
  (set! (.-ontouchmove js/document) (fn [e] (.preventDefault e))))

(defn set-up-web-audio-on-first-touch
  []
  (set! (.-ontouchstart js/document)
        (fn []
          (-> "sin" timbre .play .pause)
          (set! (.-ontouchstart js/document) nil))))

(defn piano-key-width
  [{piano-keys :piano-keys w :w}]
  (.round js/Math (/ w (count piano-keys))))

(defn t->px
  [{start :start px-per-ms :px-per-ms} t]
  (* px-per-ms (- t start)))

(defn note-rect
  [{on :on off :off freq :freq :as note}
   {px-per-ms :px-per-ms playhead :playhead :as instrument}]
  (let [piano-key-w (piano-key-width instrument)]
    {:x (* piano-key-w (get-in instrument [:piano-keys freq :n]))
     :y (+ (t->px instrument on)
           (/ (-> instrument :h) 2))
     :w piano-key-w
     :h (- (t->px instrument (or off playhead))
           (t->px instrument on))}))

(defn screen-rect
  [{w :w h :h playhead :playhead :as instrument}]
  {:x 0 :y (t->px instrument playhead) :w w :h h})

(defn draw-note
  [draw-ctx instrument note]
  (let [{x :x y :y w :w h :h} (note-rect note instrument)]
    (set! (.-fillStyle draw-ctx) "white")
    (.fillRect draw-ctx x y w h)))

(defn colliding?
  [r1 r2]
  (not (or (< (+ (:x r1) (:w r1)) (:x r2))
           (< (+ (:y r1) (:h r1)) (:y r2))
           (> (:x r1) (+ (:x r2) (:w r2)))
           (> (:y r1) (+ (:y r2) (:h r2))))))

(defn on-screen?
  [instrument note]
  (colliding? (note-rect note instrument)
              (screen-rect instrument)))

(defn draw-notes
  [draw-ctx instrument]
  (doseq [note (filter (partial on-screen? instrument)
                       (-> instrument :notes))]
    (draw-note draw-ctx instrument note)))

(defn draw-piano-keys
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (let [piano-keys (-> instrument :piano-keys)
        piano-key-w (piano-key-width instrument)]
    (doseq [[n [freq piano-key]] (map-indexed vector piano-keys)]
      (set! (.-fillStyle draw-ctx)
            ((if (piano-key :on?) :light :dark) (nth colors (mod n (count colors)))))
      (.fillRect draw-ctx
                 (* n piano-key-w)
                 (t->px instrument playhead)
                 piano-key-w h))))

(defn draw-instrument
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (.save draw-ctx)
  (.translate draw-ctx 0 (-> (t->px instrument playhead) -))
  (.clearRect draw-ctx 0 0 w h)
  (draw-piano-keys draw-ctx instrument)
  (draw-notes draw-ctx instrument)
  (.restore draw-ctx))

(defn touch->note
  [x instrument]
  (let [note-index (.floor js/Math (/ x (piano-key-width instrument)))]
    (nth (-> instrument :piano-keys keys) note-index)))

(defn create-note-synth
  [freq]
  (timbre "adsr"
          (js-obj "a" 5 "d" 10000 "s" 0 "r" 500)
          (timbre "fami" (js-obj "freq" freq "mul" 0.1))))

(defn create-instrument
  [scale]
  (let [start (.getTime (js/Date.))]
    {:piano-keys (into (sorted-map) (map-indexed (fn [i freq] [freq {:n i :on? false}])
                                                 scale))
     :notes ()
     :w 0 :h 0 :sound-ready false
     :px-per-ms 0.1
     :cur-touches {}
     :scrolling? false
     :start start
     :playhead start}))

(defn add-synths-to-instrument
  [instrument]
  (assoc (reduce (fn [a x] (assoc-in a [:piano-keys x :synth] (create-note-synth x)))
                 instrument
                 (-> instrument :piano-keys keys))
    :sound-ready true))

(defn play-piano-key
  [instrument freq]
  (println "play")
  (.play (.bang (get-in instrument [:piano-keys freq :synth])))
  (assoc-in instrument [:piano-keys freq :on?] true))

(defn stop-piano-key
  [instrument freq]
  (if (get-in instrument [:piano-keys freq :on?])
    (do
      (println "stop")
      (.release (get-in instrument [:piano-keys freq :synth]))
      (assoc-in instrument [:piano-keys freq :on?] false))
    instrument))

(defn touch-data->touches [touch-data]
  (let [event (.-event_ touch-data)
        touches (js->clj (.-changedTouches event) :keywordize-keys true)]
    (map (fn [x] {:type (.-type event)
                  :touch-id (:identifier x)
                  :position {:x (:clientX x) :y (:clientY x)}
                  :time (.-timeStamp event)})
         (for [x (range (:length touches))] ((keyword (str x)) touches)))))

(defn touch->freq
  [instrument touch]
  (touch->note (get-in touch [:position :x])
               instrument))

(defn maybe-init-synths
  [instrument]
  (if (:sound-ready instrument)
    instrument
    (add-synths-to-instrument instrument)))

(defn filter-type
  [type touches]
  (filter (fn [t] (= (t :type) type)) touches))

(defn reduce-val->>
  [f coll val]
  (reduce f val coll))

(defn touches->notes
  [{playhead :playhead :as instrument} touches]
  (->> touches
       (map (fn [t] (assoc t :freq (touch->freq instrument t))))
       (remove (fn [t] (get-in instrument [:piano-keys (t :freq) :on?])))
       (map (fn [t] {:freq (t :freq)
                     :on playhead
                     :off nil
                     :touch-id (t :touch-id)}))))

(defn start-notes
  [touches {notes :notes :as instrument}]
  (let [new-notes (touches->notes instrument (filter-type "touchstart" touches))]
    (reduce play-piano-key
            (assoc instrument :notes (concat new-notes notes))
            (map :freq new-notes))))

(defn end-notes
  [touches {notes :notes playhead :playhead :as instrument}]
  (let [off-touch-ids (->> (filter-type "touchend" touches)
                           (map :touch-id)
                           set)
        note-off? (fn [n] (contains? off-touch-ids (n :touch-id)))]
    (-> instrument
        (assoc :notes (map (fn [n] (if (note-off? n) (assoc n :off playhead) n)) notes))
        (->> (reduce-val->> stop-piano-key (->> notes (filter note-off?) (map :freq)))))))

(defn distance
  [t instrument]
  (- (get-in instrument [:cur-touches (t :touch-id) :position :y])
     (-> t :position :y)))

(defn filter-scroll-touches
  [touches instrument]
  (filter (fn [t] (> (.abs js/Math (distance t instrument)) 10))
          (filter-type "touchmove" touches)))

(defn record-touches
  [touches instrument]
  (let [starts (filter-type "touchstart" touches)
        moves (filter-type "touchmove" touches)
        ends (filter-type "touchend" touches)]
    (-> instrument
        (update-in [:cur-touches] into (map vector (map :touch-id starts) starts))
        (update-in [:cur-touches] into (map vector (map :touch-id moves) moves))
        (update-in [:cur-touches] (fn [c] (apply dissoc c (map :touch-id ends)))))))

(defn scroll
  [scroll-touches {playhead :playhead px-per-ms :px-per-ms :as instrument}]
  (if-let [scroll-touch (first (sort (fn [a b] (max (.abs js/Math (distance a instrument))
                                                    (.abs js/Math (distance b instrument))))
                                     scroll-touches))]
    (-> instrument
        (assoc :scrolling? true)
        (assoc :playhead (+ playhead (/ (distance scroll-touch instrument) px-per-ms))))
    (assoc instrument :scrolling? false)))

(defn delete-scrolled-notes
  [scroll-touches {notes :notes :as instrument}]
  (let [scroll-touch-ids (set (map :touch-id scroll-touches))
        delete-notes (group-by (fn [t] (and (nil? (t :off))
                                            (contains? scroll-touch-ids (t :touch-id))))
                               notes)]
    (-> instrument
        (assoc :notes (get delete-notes false))
        (->> (reduce-val->> stop-piano-key (map :freq (get delete-notes true)))))))

(defn handle-scrolling
  [touches instrument]
  (let [scroll-touches (filter-scroll-touches touches instrument)]
    (->> instrument
         (scroll scroll-touches)
         (delete-scrolled-notes scroll-touches)
         (record-touches touches))))

(defn fire-touch-data-on-instrument
  [instrument data]
  (let [touches (touch-data->touches data)]
    (->> instrument
         maybe-init-synths
         (start-notes touches)
         (end-notes touches)
         (handle-scrolling touches))))

(defn update-size [instrument canvas-id]
  (let [{w :w h :h :as window-size} (util/get-window-size)]
    (do (util/set-canvas-size! canvas-id window-size)
        (.scrollTo js/window 0 0) ;; Safari leaves window part scrolled down after turn
        (assoc (assoc instrument :h h) :w w))))

(defn create-touch-input-channel
  [canvas-id]
  (async/merge [(util/listen (dom/getElement canvas-id) :touchstart)
                (util/listen (dom/getElement canvas-id) :touchend)
                (util/listen (dom/getElement canvas-id) :touchmove)]))

(defn step-time
  [instrument delta]
  (if (not (instrument :scrolling?))
    (assoc instrument :playhead (+ (instrument :playhead) delta))
    instrument))

(prevent-scrolling)
(set-up-web-audio-on-first-touch)

(let [canvas-id "canvas"
      c-instrument (chan (sliding-buffer 1))
      c-orientation-change (util/listen js/window :orientation-change)
      c-touch (create-touch-input-channel canvas-id)
      frame-delay 16]

  (go
   (let [draw-ctx (util/get-ctx canvas-id)]
     (util/set-canvas-size! canvas-id (util/get-window-size))
     (loop [instrument (<! c-instrument)
            timer (timeout frame-delay)]
       (let [[data c] (alts! [c-instrument timer])]
         (condp = c
           c-instrument (recur data timer)
           (do (draw-instrument draw-ctx instrument)
               (recur instrument (timeout frame-delay))))))))

  (go
   (loop [instrument (update-size (create-instrument (scales/c-minor)) canvas-id)]
     (>! c-instrument instrument)
     (let [[data c] (alts! [c-touch c-orientation-change (timeout frame-delay)])]
       (condp = c
         c-orientation-change (recur (update-size instrument canvas-id))
         c-touch (recur (fire-touch-data-on-instrument instrument data))
         (recur (step-time instrument frame-delay)))))))

(ns playmary.one
  (:require-macros [cljs.core.async.macros :refer [go]])
  (:require [goog.dom :as dom]
            [goog.events :as events]
            [cljs.core.async :as async :refer [<! put! chan timeout sliding-buffer close!]]
            [playmary.util :as util]
            [playmary.scales :as scales]))

(def timbre js/T)

(def colors [{:note "#676767" :light "#6DA0CB" :dark "#000000"}
             {:note "#929292" :light "#A76AB9" :dark "#1E1E1E"}
             {:note "#B9B9B9" :light "#BB67A2" :dark "#3D3D3D"}
             {:note "#DCDCDC" :light "#C55D83" :dark "#5C5C5C"}
             {:note "#FFFFFF" :light "#D35E4C" :dark "#7A7A7A"}
             {:note "#000000" :light "#E18C43" :dark "#999999"}
             {:note "#393939" :light "#E1B040" :dark "#B9B9B9"}])

(defn prevent-scrolling
  []
  (set! (.-ontouchmove js/document) (fn [e] (.preventDefault e))))

(defn set-up-web-audio-on-first-touch
  []
  (set! (.-ontouchstart js/document)
        (fn []
          (-> "sin" timbre .play .pause)
          (set! (.-ontouchstart js/document) nil))))

(defn piano-key-width
  [{piano-keys :piano-keys w :w}]
  (.round js/Math (/ w (count piano-keys))))

(defn t->px
  [{start :start px-per-ms :px-per-ms} t]
  (* px-per-ms (- t start)))

(defn note-rect
  [{on :on off :off freq :freq :as note}
   {px-per-ms :px-per-ms playhead :playhead :as instrument}]
  (let [piano-key-w (piano-key-width instrument)]
    {:x (* piano-key-w (get-in instrument [:piano-keys freq :n]))
     :y (+ (t->px instrument on)
           (/ (-> instrument :h) 2))
     :w piano-key-w
     :h (- (t->px instrument (or off playhead))
           (t->px instrument on))}))

(defn screen-rect
  [{w :w h :h playhead :playhead :as instrument}]
  {:x 0 :y (t->px instrument playhead) :w w :h h})

(defn draw-note
  [draw-ctx instrument note]
  (let [{x :x y :y w :w h :h} (note-rect note instrument)]
    (set! (.-fillStyle draw-ctx) "white")
    (.fillRect draw-ctx x y w h)))

(defn colliding?
  [r1 r2]
  (not (or (< (+ (:x r1) (:w r1)) (:x r2))
           (< (+ (:y r1) (:h r1)) (:y r2))
           (> (:x r1) (+ (:x r2) (:w r2)))
           (> (:y r1) (+ (:y r2) (:h r2))))))

(defn on-screen?
  [instrument note]
  (colliding? (note-rect note instrument)
              (screen-rect instrument)))

(defn draw-notes
  [draw-ctx instrument]
  (doseq [note (filter (partial on-screen? instrument)
                       (-> instrument :notes))]
    (draw-note draw-ctx instrument note)))

(defn draw-piano-keys
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (let [piano-keys (-> instrument :piano-keys)
        piano-key-w (piano-key-width instrument)]
    (doseq [[n [freq piano-key]] (map-indexed vector piano-keys)]
      (set! (.-fillStyle draw-ctx)
            ((if (piano-key :on?) :light :dark) (nth colors (mod n (count colors)))))
      (.fillRect draw-ctx
                 (* n piano-key-w)
                 (t->px instrument playhead)
                 piano-key-w h))))

(defn draw-instrument
  [draw-ctx {w :w h :h playhead :playhead :as instrument}]
  (.save draw-ctx)
  (.translate draw-ctx 0 (-> (t->px instrument playhead) -))
  (.clearRect draw-ctx 0 0 w h)
  (draw-piano-keys draw-ctx instrument)
  (draw-notes draw-ctx instrument)
  (.restore draw-ctx))

(defn touch->note
  [x instrument]
  (let [note-index (.floor js/Math (/ x (piano-key-width instrument)))]
    (nth (-> instrument :piano-keys keys) note-index)))

(defn create-note-synth
  [freq]
  (timbre "adsr"
          (js-obj "a" 5 "d" 10000 "s" 0 "r" 500)
          (timbre "fami" (js-obj "freq" freq "mul" 0.1))))

(defn create-instrument
  [scale]
  (let [start (.getTime (js/Date.))]
    {:piano-keys (into (sorted-map) (map-indexed (fn [i freq] [freq {:n i :on? false}])
                                                 scale))
     :notes ()
     :w 0 :h 0 :sound-ready false
     :px-per-ms 0.1
     :cur-touches {}
     :scrolling? false
     :start start
     :playhead start}))

(defn add-synths-to-instrument
  [instrument]
  (assoc (reduce (fn [a x] (assoc-in a [:piano-keys x :synth] (create-note-synth x)))
                 instrument
                 (-> instrument :piano-keys keys))
    :sound-ready true))

(defn play-piano-key
  [instrument freq]
  (println "play")
  (.play (.bang (get-in instrument [:piano-keys freq :synth])))
  (assoc-in instrument [:piano-keys freq :on?] true))

(defn stop-piano-key
  [instrument freq]
  (if (get-in instrument [:piano-keys freq :on?])
    (do
      (println "stop")
      (.release (get-in instrument [:piano-keys freq :synth]))
      (assoc-in instrument [:piano-keys freq :on?] false))
    instrument))

(defn touch-data->touches [touch-data]
  (let [event (.-event_ touch-data)
        touches (js->clj (.-changedTouches event) :keywordize-keys true)]
    (map (fn [x] {:type (.-type event)
                  :touch-id (:identifier x)
                  :position {:x (:clientX x) :y (:clientY x)}
                  :time (.-timeStamp event)})
         (for [x (range (:length touches))] ((keyword (str x)) touches)))))

(defn touch->freq
  [instrument touch]
  (touch->note (get-in touch [:position :x])
               instrument))

(defn maybe-init-synths
  [instrument]
  (if (:sound-ready instrument)
    instrument
    (add-synths-to-instrument instrument)))

(defn filter-type
  [type touches]
  (filter (fn [t] (= (t :type) type)) touches))

(defn reduce-val->>
  [f coll val]
  (reduce f val coll))

(defn touches->notes
  [{playhead :playhead :as instrument} touches]
  (->> touches
       (map (fn [t] (assoc t :freq (touch->freq instrument t))))
       (remove (fn [t] (get-in instrument [:piano-keys (t :freq) :on?])))
       (map (fn [t] {:freq (t :freq)
                     :on playhead
                     :off nil
                     :touch-id (t :touch-id)}))))

(defn start-notes
  [touches {notes :notes :as instrument}]
  (let [new-notes (touches->notes instrument (filter-type "touchstart" touches))]
    (reduce play-piano-key
            (assoc instrument :notes (concat new-notes notes))
            (map :freq new-notes))))

(defn end-notes
  [touches {notes :notes playhead :playhead :as instrument}]
  (let [off-touch-ids (->> (filter-type "touchend" touches)
                           (map :touch-id)
                           set)
        note-off? (fn [n] (contains? off-touch-ids (n :touch-id)))]
    (-> instrument
        (assoc :notes (map (fn [n] (if (note-off? n) (assoc n :off playhead) n)) notes))
        (->> (reduce-val->> stop-piano-key (->> notes (filter note-off?) (map :freq)))))))
(defn x-distance
  [{{end-x :x} :position :as t} instrument]
  (- (get-in instrument [:cur-touches (t :touch-id) :position :x]) end-x))

(defn y-distance
  [{{end-y :y} :position :as t} instrument]
  (- (get-in instrument [:cur-touches (t :touch-id) :position :y]) end-y))

(defn distance
  [t instrument]
  (.sqrt js/Math (+ (.pow js/Math (x-distance t instrument) 2)
                    (.pow js/Math (y-distance t instrument) 2))))

(defn filter-scroll-touches
  [touches instrument]
  (filter (fn [t] (> (.abs js/Math (distance t instrument)) 10))
          (filter-type "touchmove" touches)))

(defn record-touches
  [touches instrument]
  (let [starts (filter-type "touchstart" touches)
        moves (filter-type "touchmove" touches)
        ends (filter-type "touchend" touches)]
    (-> instrument
        (update-in [:cur-touches] into (map vector (map :touch-id starts) starts))
        (update-in [:cur-touches] into (map vector (map :touch-id moves) moves))
        (update-in [:cur-touches] (fn [c] (apply dissoc c (map :touch-id ends)))))))

(defn scroll
  [scroll-touches {playhead :playhead px-per-ms :px-per-ms :as instrument}]
  (if-let [scroll-touch (first (sort (fn [a b] (max (.abs js/Math (y-distance a instrument))
                                                    (.abs js/Math (y-distance b instrument))))
                                     scroll-touches))]
    (-> instrument
        (assoc :scrolling? true)
        (assoc :playhead (+ playhead (/ (y-distance scroll-touch instrument) px-per-ms))))
    (assoc instrument :scrolling? false)))

(defn delete-scrolled-notes
  [scroll-touches {notes :notes :as instrument}]
  (let [scroll-touch-ids (set (map :touch-id scroll-touches))
        delete-notes (group-by (fn [t] (and (nil? (t :off))
                                            (contains? scroll-touch-ids (t :touch-id))))
                               notes)]
    (-> instrument
        (assoc :notes (get delete-notes false))
        (->> (reduce-val->> stop-piano-key (map :freq (get delete-notes true)))))))

(defn handle-scrolling
  [touches instrument]
  (let [scroll-touches (filter-scroll-touches touches instrument)]
    (->> instrument
         (scroll scroll-touches)
         (delete-scrolled-notes scroll-touches)
         (record-touches touches))))

(defn fire-touch-data-on-instrument
  [instrument data]
  (let [touches (touch-data->touches data)]
    (->> instrument
         maybe-init-synths
         (start-notes touches)
         (end-notes touches)
         (handle-scrolling touches))))

(defn update-size [instrument canvas-id]
  (let [{w :w h :h :as window-size} (util/get-window-size)]
    (do (util/set-canvas-size! canvas-id window-size)
        (.scrollTo js/window 0 0) ;; Safari leaves window part scrolled down after turn
        (assoc (assoc instrument :h h) :w w))))

(defn create-touch-input-channel
  [canvas-id]
  (async/merge [(util/listen (dom/getElement canvas-id) :touchstart)
                (util/listen (dom/getElement canvas-id) :touchend)
                (util/listen (dom/getElement canvas-id) :touchmove)]))

(defn step-time
  [instrument delta]
  (if (not (instrument :scrolling?))
    (assoc instrument :playhead (+ (instrument :playhead) delta))
    instrument))

(prevent-scrolling)
(set-up-web-audio-on-first-touch)

(let [canvas-id "canvas"
      c-instrument (chan (sliding-buffer 1))
      c-orientation-change (util/listen js/window :orientation-change)
      c-touch (create-touch-input-channel canvas-id)
      frame-delay 16]

  (go
   (let [draw-ctx (util/get-ctx canvas-id)]
     (util/set-canvas-size! canvas-id (util/get-window-size))
     (loop [instrument (<! c-instrument)
            timer (timeout frame-delay)]
       (let [[data c] (alts! [c-instrument timer])]
         (condp = c
           c-instrument (recur data timer)
           (do (draw-instrument draw-ctx instrument)
               (recur instrument (timeout frame-delay))))))))

  (go
   (loop [instrument (update-size (create-instrument (scales/c-minor)) canvas-id)]
     (>! c-instrument instrument)
     (let [[data c] (alts! [c-touch c-orientation-change (timeout frame-delay)])]
       (condp = c
         c-orientation-change (recur (update-size instrument canvas-id))
         c-touch (recur (fire-touch-data-on-instrument instrument data))
         (recur (step-time instrument frame-delay)))))))

Make scroll detection bi-lateral

Make scroll detection bi-lateral

* Before, would only detect scroll if touch moved fast enough in y axis.  Now, uses  Pythagorean distance for detection.  But still only looks at y distance to decide actual scroll distance.


(ns pubhouse.core
  (:require [pubhouse.files :refer [with-parent-dir map-directory! do-directory!]]
            [clojure.java.io :refer [as-file]]
            [clojure.string :refer [join]]
            [markdown.core :refer [md-to-html-string]]
            [hiccup.core :as hiccup]
            [me.raynes.fs :as fs]))

(def ^:dynamic *site-map*
  "This contain the hash created by recursively reading metadata from content files
  in the build directory."

  nil)

(def ^:dynamic site nil)

(def ^:dynamic *meta-sep*
  "The separator that splits each content file into meta and content sections."

  "===")

(def ^:dynamic *block-sep*
  "Separator used in content files to denote line-oriented preprocessing
  blocks."

  "$$$")

(defn mk-file-record
  [file lines]
  (merge (->> lines (take-while #(not= % *meta-sep*)) (join " ") (read-string))
         {:path (.getPath file) :mod-time (fs/mod-time file)}))

(defn content-section
  [lines]
  (->> lines (drop-while #(not= % *meta-sep*)) (drop 1)))

(defn file-record? [x] (and (coll? x) (contains? x :mod-time)))

(defn build-file!
  "Merge the hash from the meta-information lines of `file` with useful
  file-system information, such as the path and url relative to the root."

  [file lines]
  [(mk-file-record file lines)
   (content-section lines)])

(defn build-files!
  [root-dir]
  (map-directory! build-file! (complement fs/directory?) root-dir))

;; A site is our primary way of keeping track of content files as they
;; change.

(defn conj-site-map
  [site-map file-record]
  (assoc-in site-map
            (map keyword (fs/split (:path file-record)))
            file-record))

(defn build-site-map!
  "Creates a nested persistent map where the keys are filenames and directory
  names, and entries are maps of the same type, or file records."

  [root-dir]
  (reset! *site-map*
          (let [root-part (first (fs/split root-dir))]
            (get (reduce #(conj-site-map %1 (first %2))
                         {}
                         (build-files! root-dir))
                 (keyword root-part)))))

(defn strip-extension
  [s]
  (if-let [e (fs/extension s)] (clojure.string/replace s e "") s))

(defn strip-file-info
  [file-record]
  (dissoc file-record :path :mod-time))

(defn get-site-map
  []
  (deref *site-map*))

(defn humane-site-map
  []
  (clojure.walk/postwalk (fn [form]
                           (cond (file-record? form)
                                 (strip-file-info form)

                                 (keyword? form)
                                 (-> form name strip-extension keyword)

                                 :default form))
                         (get-site-map)))

(defmulti render-file
  "Takes as its first argument a map of the type returned by `build-file!`,
  and as its second argument a lazy sequence of the lines of the corresponding
  file. Should return a string which will be written to the output file."

  (comp fs/extension :path))

(defmethod render-file ".md"
  [file-record content-lines]
  (hiccup/html
   [:html
    [:head [:title (:title file-record)]]
    [:body (md-to-html-string (join "\n" content-lines))]]))

(defn mk-output
  [root path]
  (clojure.java.io/as-file
   (str (join "/" (cons root (drop 2 (fs/split (strip-extension path)))))
        ".html")))

(defn compile-file!
  [build-path [file-record lines]]
  (let [output (mk-output build-path (:path file-record))]
    (with-parent-dir output
      (fn []
        (with-open [writer (clojure.java.io/writer output)]
          (binding [site (assoc (humane-site-map)
                                :current-page
                                (strip-file-info file-record))]
            (.write writer (render-file file-record lines))))))))

(defn compile-content!
  [content-root build-path]
  (do-directory! (comp (partial compile-file! build-path)
                       build-file!)
                 (complement fs/directory?)
                 content-root))

(defn compile-site!
  [root-dir build-root]
  (binding [*site-map* (atom {})]
    (let [content-root (clojure.java.io/as-file
                        (join "/" (concat (fs/split root-dir)
                                          (list "content"))))]
      (build-site-map! content-root)
      (compile-content! content-root build-root))))

(ns pubhouse.core
  (:require [pubhouse.files :refer [with-parent-dir map-directory! do-directory!]]
            [clojure.java.io :refer [as-file]]
            [clojure.string :refer [join]]
            [markdown.core :refer [md-to-html-string]]
            [hiccup.core :as hiccup]
            [me.raynes.fs :as fs]))

(def ^:dynamic *site-map*
  "This contain the hash created by recursively reading metadata from content files
  in the build directory."

  nil)

(def ^:dynamic site nil)

(def ^:dynamic *meta-sep*
  "The separator that splits each content file into meta and content sections."
  "===")

(def ^:dynamic *block-sep*
  "Separator used in content files to denote line-oriented preprocessing
  blocks."
  "$$$")

(defn mk-page-record
  [file lines]
  (merge (->> lines (take-while #(not= % *meta-sep*)) (join " ") (read-string))
         {:path (.getPath file) :mod-time (fs/mod-time file)}))

(defn content-section
  [lines]
  (->> lines (drop-while #(not= % *meta-sep*)) (drop 1)))

(defn page-record? [x] (and (coll? x) (contains? x :mod-time)))

(defn build-file!
  "Merge the hash from the meta-information lines of `file` with useful
  file-system information, such as the path and url relative to the root."
  [file lines]
  [(mk-page-record file lines)
   (content-section lines)])

(defn build-files!
  [root-dir]
  (map-directory! build-file! (complement fs/directory?) root-dir))

;; A site is our primary way of keeping track of content files as they
;; change.

(defn conj-site-map
  [site-map page-record]
  (assoc-in site-map
            (map keyword (fs/split (:path page-record)))
            page-record))

(defn build-site-map!
  "Creates a nested persistent map where the keys are filenames and directory
  names, and entries are maps of the same type, or file records."
  [root-dir]
  (reset! *site-map*
          (let [root-part (first (fs/split root-dir))]
            (get (reduce #(conj-site-map %1 (first %2))
                         {}
                         (build-files! root-dir))
                 (keyword root-part)))))

(defn strip-extension
  [s]
  (if-let [e (fs/extension s)] (clojure.string/replace s e "") s))

(defn strip-file-info
  [page-record]
  (dissoc page-record :path :mod-time))

(defn humane-site-map
  [site-map]
  (clojure.walk/postwalk (fn [form]
                           (cond (page-record? form)
                                 (strip-file-info form)

                                 (keyword? form)
                                 (-> form name strip-extension keyword)

                                 :default form))
                         site-map))

(defmulti render-file
  "Takes as its first argument a map of the type returned by `build-file!`,
  and as its second argument a lazy sequence of the lines of the corresponding
  file. Should return a string which will be written to the output file."
  (comp fs/extension :path))

(defmethod render-file ".md"
  [page-record content-lines]
  (hiccup/html
   [:html
    [:head [:title (:title page-record)]]
    [:body (md-to-html-string (join "\n" content-lines))]]))

(defn mk-output
  [root path]
  (clojure.java.io/as-file
   (str (join "/" (cons root (drop 2 (fs/split (strip-extension path)))))
        ".html")))

(defn navigate-site-map
  [site-map page-record]
  (assoc (humane-site-map site-map)
         :current-page
         (strip-file-info page-record)))

(defn compile-file!
  [site-map build-path [page-record lines]]
  (let [output (mk-output build-path (:path page-record))]
    (with-parent-dir output
      (fn []
        (with-open [writer (clojure.java.io/writer output)]
          (binding [site (navigate-site-map site-map page-record)]
            (.write writer (render-file page-record lines))))))))

(defn compile-content!
  [site-map content-root build-path]
  (do-directory! (comp (partial compile-file! site-map build-path)
                       build-file!)
                 (complement fs/directory?)
                 content-root))

(defn compile-site!
  [root-dir build-root]
  (binding [*site-map* (atom {})]
    (let [content-root (clojure.java.io/as-file
                        (join "/" (concat (fs/split root-dir)
                                          (list "content"))))]
      (build-site-map! content-root)
      (compile-content! @*site-map* content-root build-root))))

Make more functions which depend on the site-map accept it as an argument.

This allows us to constrain state to a very small area. In this case, the current
site map value is determine in 'compile-content!'.


(in-ns 'play-clj.core)

; global

(defn ^:private input-processor
  [{:keys [on-key-down on-key-typed on-key-up on-mouse-moved
           on-scrolled on-touch-down on-touch-dragged on-touch-up]}
   execute-fn!]
  (reify InputProcessor
    (keyDown [this k]
      (execute-fn! on-key-down :keycode k)
      false)
    (keyTyped [this c]
      (execute-fn! on-key-typed :character c)
      false)
    (keyUp [this k]
      (execute-fn! on-key-up :keycode k)
      false)
    (mouseMoved [this sx sy]
      (execute-fn! on-mouse-moved :input-x sx :input-y sy)
      false)
    (scrolled [this a]
      (execute-fn! on-scrolled :amount a)
      false)
    (touchDown [this sx sy p b]
      (execute-fn! on-touch-down :input-x sx :input-y sy :pointer p :button b)
      false)
    (touchDragged [this sx sy p]
      (execute-fn! on-touch-dragged :input-x sx :input-y sy :pointer p)
      false)
    (touchUp [this sx sy p b]
      (execute-fn! on-touch-up :input-x sx :input-y sy :pointer p :button b)
      false)))

(defn ^:private gesture-listener
  [{:keys [on-fling on-long-press on-pan on-pan-stop on-pinch on-tap on-zoom]}
   execute-fn!]
  (reify GestureDetector$GestureListener
    (fling [this vx vy b]
      (execute-fn! on-fling :velocity-x vx :velocity-y vy :button b)
      false)
    (longPress [this x y]
      (execute-fn! on-long-press :input-x x :input-y y)
      false)
    (pan [this x y dx dy]
      (execute-fn! on-pan :input-x x :input-y y :delta-x dx :delta-y dy)
      false)
    (panStop [this x y p b]
      (execute-fn! on-pan-stop :input-x x :input-y y :pointer p :button b)
      false)
    (pinch [this ip1 ip2 p1 p2]
      (execute-fn! on-pinch
                   :initial-pointer-1 ip1 :initial-pointer-2 ip2
                   :pointer1 p1 :pointer2 p2)
      false)
    (tap [this x y c b]
      (execute-fn! on-tap :input-x x :input-y y :count c :button b)
      false)
    (touchDown [this x y p b]
      false)
    (zoom [this id d]
      (execute-fn! on-zoom :initial-distance id :distance d)
      false)))

(defn ^:private gesture-detector
  [options execute-fn!]
  (proxy [GestureDetector] [(gesture-listener options execute-fn!)]))

(defn ^:private global-listeners
  [options execute-fn!]
  [(input-processor options execute-fn!)
   (gesture-detector options execute-fn!)])

; ui

(defn ^:private actor-gesture-listener
  [{:keys [on-ui-fling on-ui-long-press on-ui-pan on-ui-pinch
           on-ui-tap on-ui-touch-down on-ui-touch-up on-ui-zoom]}
   execute-fn!]
  (proxy [ActorGestureListener] []
    (fling [e vx vy b]
      (execute-fn! on-ui-fling
                   :event e :velocity-x vx :velocity-y vy :button b))
    (longPress [a x y]
      (execute-fn! on-ui-long-press :actor a :input-x x :input-y y)
      false)
    (pan [e x y dx dy]
      (execute-fn! on-ui-pan
                   :event e :input-x x :input-y y :delta-x dx :delta-y dy))
    (pinch [e ip1 ip2 p1 p2]
      (execute-fn! on-ui-pinch
                   :event e :initial-pointer-1 ip1 :initial-pointer-2 ip2
                   :pointer1 p1 :pointer2 p2))
    (tap [e x y p b]
      (execute-fn! on-ui-tap
                   :event e :input-x x :input-y y :pointer p :button b))
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))
    (zoom [e id d]
      (execute-fn! on-ui-zoom :event e :initial-distance id :distance d))))

(defn ^:private change-listener
  [{:keys [on-ui-changed]} execute-fn!]
  (proxy [ChangeListener] []
    (changed [e a]
      (execute-fn! on-ui-changed :event e :actor a))))

(defn ^:private click-listener
  [{:keys [on-ui-clicked on-ui-enter on-ui-exit
           on-ui-touch-down on-ui-touch-dragged on-ui-touch-up]}
   execute-fn!]
  (proxy [ClickListener] []
    (clicked [e x y]
      (execute-fn! on-ui-clicked :event e :input-x x :input-y y))
    (enter [e x y p a]
      (execute-fn! on-ui-enter
                   :event e :input-x x :input-y y :pointer p :from-actor a))
    (exit [e x y p a]
      (execute-fn! on-ui-exit
                   :event e :input-x x :input-y y :pointer p :to-actor a))
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b)
      false)
    (touchDragged [e x y p]
      (execute-fn! on-ui-touch-dragged
                   :event e :input-x x :input-y y :pointer p))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))))

(defn ^:private drag-listener
  [{:keys [on-ui-drag on-ui-drag-start on-ui-drag-stop
           on-ui-touch-down on-ui-touch-dragged on-ui-touch-up]}
   execute-fn!]
  (proxy [DragListener] []
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b)
      false)
    (touchDragged [e x y p]
      (execute-fn! on-ui-touch-dragged
                   :event e :input-x x :input-y y :pointer p))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))
    (drag [e x y p]
      (execute-fn! on-ui-drag :event e :input-x x :input-y y :pointer p))
    (dragStart [e x y p]
      (execute-fn! on-ui-drag-start :event e :input-x x :input-y y :pointer p))
    (dragStop [e x y p]
      (execute-fn! on-ui-drag-stop :event e :input-x x :input-y y :pointer p))))

(defn ^:private focus-listener
  [{:keys [on-ui-keyboard-focus-changed on-ui-scroll-focus-changed]}
   execute-fn!]
  (proxy [FocusListener] []
    (keyboardFocusChanged [e a f]
      (execute-fn! on-ui-keyboard-focus-changed :event e :actor a :focused? f))
    (scrollFocusChanged [e a f]
      (execute-fn! on-ui-scroll-focus-changed :event e :actor a :focused? f))))

(defn ^:private ui-listeners
  [options execute-fn!]
  [(actor-gesture-listener options execute-fn!)
   (change-listener options execute-fn!)
   (click-listener options execute-fn!)
   (drag-listener options execute-fn!)
   (focus-listener options execute-fn!)])

(defmulti contact-listener
  (fn [screen options execute-fn!] (some-> screen :world class .getName))
  :default nil)

(defmethod contact-listener nil [_ _ _])

; update functions

(defn ^:private update-stage!
  ([{:keys [^Stage renderer ^Camera camera] :as screen}]
    (when camera
      (doto (.getViewport renderer)
        (.setCamera camera)
        (.setWorldSize (. camera viewportWidth) (. camera viewportHeight))
        (.update (game :width) (game :height) true))))
  ([{:keys [^Stage renderer ui-listeners]} entities]
    (doseq [^Actor a (.getActors renderer)]
      (.remove a))
    (doseq [{:keys [object]} entities]
      (when (isa? (type object) Actor)
        (.addActor renderer object)
        (doseq [listener ui-listeners]
          (.addListener ^Actor object listener))))
    (remove-input! renderer)
    (add-input! renderer)))

(defmulti update-physics!
  (fn [screen & [entities]] (some-> screen :world class .getName))
  :default nil)

(defmethod update-physics! nil [_ & _])

(defn ^:private update-screen!
  ([{:keys [renderer world] :as screen}]
    (when (isa? (type renderer) Stage)
      (update-stage! screen))
    (update-physics! screen))
  ([{:keys [renderer world] :as screen} entities]
    (when (isa? (type renderer) Stage)
      (update-stage! screen entities))
    (update-physics! screen entities)))

(in-ns 'play-clj.core)

; global

(defn ^:private input-processor
  [{:keys [on-key-down on-key-typed on-key-up on-mouse-moved
           on-scrolled on-touch-down on-touch-dragged on-touch-up]}
   execute-fn!]
  (reify InputProcessor
    (keyDown [this k]
      (execute-fn! on-key-down :keycode k)
      false)
    (keyTyped [this c]
      (execute-fn! on-key-typed :character c)
      false)
    (keyUp [this k]
      (execute-fn! on-key-up :keycode k)
      false)
    (mouseMoved [this sx sy]
      (execute-fn! on-mouse-moved :input-x sx :input-y sy)
      false)
    (scrolled [this a]
      (execute-fn! on-scrolled :amount a)
      false)
    (touchDown [this sx sy p b]
      (execute-fn! on-touch-down :input-x sx :input-y sy :pointer p :button b)
      false)
    (touchDragged [this sx sy p]
      (execute-fn! on-touch-dragged :input-x sx :input-y sy :pointer p)
      false)
    (touchUp [this sx sy p b]
      (execute-fn! on-touch-up :input-x sx :input-y sy :pointer p :button b)
      false)))

(defn ^:private gesture-listener
  [{:keys [on-fling on-long-press on-pan on-pan-stop on-pinch on-tap on-zoom]}
   execute-fn!]
  (reify GestureDetector$GestureListener
    (fling [this vx vy b]
      (execute-fn! on-fling :velocity-x vx :velocity-y vy :button b)
      false)
    (longPress [this x y]
      (execute-fn! on-long-press :input-x x :input-y y)
      false)
    (pan [this x y dx dy]
      (execute-fn! on-pan :input-x x :input-y y :delta-x dx :delta-y dy)
      false)
    (panStop [this x y p b]
      (execute-fn! on-pan-stop :input-x x :input-y y :pointer p :button b)
      false)
    (pinch [this ip1 ip2 p1 p2]
      (execute-fn! on-pinch
                   :initial-pointer-1 ip1 :initial-pointer-2 ip2
                   :pointer-1 p1 :pointer-2 p2)
      false)
    (tap [this x y c b]
      (execute-fn! on-tap :input-x x :input-y y :count c :button b)
      false)
    (touchDown [this x y p b]
      false)
    (zoom [this id d]
      (execute-fn! on-zoom :initial-distance id :distance d)
      false)))

(defn ^:private gesture-detector
  [options execute-fn!]
  (proxy [GestureDetector] [(gesture-listener options execute-fn!)]))

(defn ^:private global-listeners
  [options execute-fn!]
  [(input-processor options execute-fn!)
   (gesture-detector options execute-fn!)])

; ui

(defn ^:private actor-gesture-listener
  [{:keys [on-ui-fling on-ui-long-press on-ui-pan on-ui-pinch
           on-ui-tap on-ui-touch-down on-ui-touch-up on-ui-zoom]}
   execute-fn!]
  (proxy [ActorGestureListener] []
    (fling [e vx vy b]
      (execute-fn! on-ui-fling
                   :event e :velocity-x vx :velocity-y vy :button b))
    (longPress [a x y]
      (execute-fn! on-ui-long-press :actor a :input-x x :input-y y)
      false)
    (pan [e x y dx dy]
      (execute-fn! on-ui-pan
                   :event e :input-x x :input-y y :delta-x dx :delta-y dy))
    (pinch [e ip1 ip2 p1 p2]
      (execute-fn! on-ui-pinch
                   :event e :initial-pointer-1 ip1 :initial-pointer-2 ip2
                   :pointer1 p1 :pointer2 p2))
    (tap [e x y p b]
      (execute-fn! on-ui-tap
                   :event e :input-x x :input-y y :pointer p :button b))
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))
    (zoom [e id d]
      (execute-fn! on-ui-zoom :event e :initial-distance id :distance d))))

(defn ^:private change-listener
  [{:keys [on-ui-changed]} execute-fn!]
  (proxy [ChangeListener] []
    (changed [e a]
      (execute-fn! on-ui-changed :event e :actor a))))

(defn ^:private click-listener
  [{:keys [on-ui-clicked on-ui-enter on-ui-exit
           on-ui-touch-down on-ui-touch-dragged on-ui-touch-up]}
   execute-fn!]
  (proxy [ClickListener] []
    (clicked [e x y]
      (execute-fn! on-ui-clicked :event e :input-x x :input-y y))
    (enter [e x y p a]
      (execute-fn! on-ui-enter
                   :event e :input-x x :input-y y :pointer p :from-actor a))
    (exit [e x y p a]
      (execute-fn! on-ui-exit
                   :event e :input-x x :input-y y :pointer p :to-actor a))
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b)
      false)
    (touchDragged [e x y p]
      (execute-fn! on-ui-touch-dragged
                   :event e :input-x x :input-y y :pointer p))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))))

(defn ^:private drag-listener
  [{:keys [on-ui-drag on-ui-drag-start on-ui-drag-stop
           on-ui-touch-down on-ui-touch-dragged on-ui-touch-up]}
   execute-fn!]
  (proxy [DragListener] []
    (touchDown [e x y p b]
      (execute-fn! on-ui-touch-down
                   :event e :input-x x :input-y y :pointer p :button b)
      false)
    (touchDragged [e x y p]
      (execute-fn! on-ui-touch-dragged
                   :event e :input-x x :input-y y :pointer p))
    (touchUp [e x y p b]
      (execute-fn! on-ui-touch-up
                   :event e :input-x x :input-y y :pointer p :button b))
    (drag [e x y p]
      (execute-fn! on-ui-drag :event e :input-x x :input-y y :pointer p))
    (dragStart [e x y p]
      (execute-fn! on-ui-drag-start :event e :input-x x :input-y y :pointer p))
    (dragStop [e x y p]
      (execute-fn! on-ui-drag-stop :event e :input-x x :input-y y :pointer p))))

(defn ^:private focus-listener
  [{:keys [on-ui-keyboard-focus-changed on-ui-scroll-focus-changed]}
   execute-fn!]
  (proxy [FocusListener] []
    (keyboardFocusChanged [e a f]
      (execute-fn! on-ui-keyboard-focus-changed :event e :actor a :focused? f))
    (scrollFocusChanged [e a f]
      (execute-fn! on-ui-scroll-focus-changed :event e :actor a :focused? f))))

(defn ^:private ui-listeners
  [options execute-fn!]
  [(actor-gesture-listener options execute-fn!)
   (change-listener options execute-fn!)
   (click-listener options execute-fn!)
   (drag-listener options execute-fn!)
   (focus-listener options execute-fn!)])

(defmulti contact-listener
  (fn [screen options execute-fn!] (some-> screen :world class .getName))
  :default nil)

(defmethod contact-listener nil [_ _ _])

; update functions

(defn ^:private update-stage!
  ([{:keys [^Stage renderer ^Camera camera] :as screen}]
    (when camera
      (doto (.getViewport renderer)
        (.setCamera camera)
        (.setWorldSize (. camera viewportWidth) (. camera viewportHeight))
        (.update (game :width) (game :height) true))))
  ([{:keys [^Stage renderer ui-listeners]} entities]
    (doseq [^Actor a (.getActors renderer)]
      (.remove a))
    (doseq [{:keys [object]} entities]
      (when (isa? (type object) Actor)
        (.addActor renderer object)
        (doseq [listener ui-listeners]
          (.addListener ^Actor object listener))))
    (remove-input! renderer)
    (add-input! renderer)))

(defmulti update-physics!
  (fn [screen & [entities]] (some-> screen :world class .getName))
  :default nil)

(defmethod update-physics! nil [_ & _])

(defn ^:private update-screen!
  ([{:keys [renderer world] :as screen}]
    (when (isa? (type renderer) Stage)
      (update-stage! screen))
    (update-physics! screen))
  ([{:keys [renderer world] :as screen} entities]
    (when (isa? (type renderer) Stage)
      (update-stage! screen entities))
    (update-physics! screen entities)))

Make hyphenation consistent

Make hyphenation consistent


(ns cljs-api-gen.catalog
  (:require
    [fipp.edn :refer [pprint]]
    [clojure.edn :as edn]
    [clansi.core :refer [style]]
    [clojure.string :refer [join]]
    [clojure.java.shell :refer [sh]]
    [me.raynes.fs :refer [mkdir
                          exists?
                          file?
                          delete-dir
                          list-dir
                          base-name
                          copy
                          copy-dir]]
    [cljs-api-gen.cljsdoc :refer [build-cljsdoc!]]
    [cljs-api-gen.config :refer [*output-dir*
                                 cache-dir
                                 edn-parsed-file
                                 edn-cljsdoc-file]]
    [cljs-api-gen.parse :refer [parse-all]]
    [cljs-api-gen.repo-cljs :refer [get-cljs-tags-to-parse
                                    published-cljs-tags
                                    with-checkout!
                                    cljs-tag->version
                                    *cljs-tag*
                                    *cljs-date*
                                    *clj-tag*
                                    *cljs-version*
                                    *clj-version*]]
    [cljs-api-gen.result :refer [get-result
                                 add-cljsdoc-to-result]]
    [cljs-api-gen.write :refer [dump-result!]]
    ))

;;----------------------------------------------------------------------
;; Catalog Repo Operations
;;----------------------------------------------------------------------

(defn git
  [& args]
  (apply sh "git" (concat args [:dir *output-dir*])))

(defn catalog-tag->cljs
  [v]
  (let [m (re-find #"-\d+" v)
        number (subs m 1)]
    (str "r" number)))

(defn catalog-tag []
  (:out (git "describe" "--tags")))

(defn catalog-init! []
  (delete-dir (str *output-dir* "/.git"))
  (git "init"))

(defn catalog-add!
  [f]
  (git "add" f))

(defn catalog-commit! []
  (let [msg (str *cljs-version* "\n"
                 "\n"
                 "- auto-generated by:\n"
                 "  https://github.com/cljsinfo/cljs-api-docs\n"
                 "\n"
                 "- parsed from:\n"
                 "  ClojureScript " *cljs-version* "\n"
                 "  Clojure " *clj-version* "\n")]
    (git "commit" "-m" msg)
    (git "tag" *cljs-version*)))

;;----------------------------------------------------------------------
;; Catalog Creation
;;----------------------------------------------------------------------

(defn print-summary*
  [parsed]
  (let [ns-groups (group-by :ns parsed)
        pairs (sort-by first ns-groups)]
    (doseq [[ns- symbols] pairs]
      (printf "    %-24s %4s = %s\n"
        ns-
        (count symbols)
        (let [type-groups (group-by :type symbols)
              pairs (sort-by first type-groups)]
          (join " + "
            (for [[type- symbols] pairs]
              (let [total (count symbols)]
                (str total " " (cond-> type- (> total 1) (str "s")))))))))))

(defn print-summary
  [parsed]
  (println " Syntax API:")
  (print-summary* (:syntax parsed))
  (println " Library API:")
  (print-summary* (:library parsed))
  (println " Compiler API:")
  (print-summary* (:compiler parsed)))

(defn create-catalog!
  [{:as options
    :keys [version
           catalog?
           skip-pages?
           skip-parse?]
    :or {version :latest
         catalog? false
         skip-pages? true
         skip-parse? true}}]

  ;; create output directory
  (when-not (exists? *output-dir*)
    (mkdir *output-dir*))

  (let [cache (str *output-dir* "/" cache-dir)

        ;; This holds the "result" data for the most recently parsed cljs version.
        ;; Sometimes this is cached, so there is some ceremony here to prevent pulling
        ;; the value from its cache until its actually needed.  We use an expression
        ;; wrapped in a `delay` to do this.  Since not every value is cached, we just
        ;; use the `get-prev-result` to not worry about it.
        prev-result (atom nil)
        get-prev-result #(if (delay? @prev-result)
                           @@prev-result
                           @prev-result)

        tags (if (= :latest version)
               @published-cljs-tags
               (concat (take-while (partial not= version) @published-cljs-tags) [version]))
        last-tag (last tags)]

    ;; make cache directory
    (when-not (exists? cache)
      (mkdir cache))

    (println "Outputting to " (style *output-dir* :cyan))
    (println "   with cache at " (style cache :cyan))

    ;; parse symbol history
    (println "\nStarting first pass (parsing symbol history)...\n")
    (doseq [tag tags]

      ;; check if skip-parse? and if this tag's edn-parsed-file already exists
      (let [out-folder (str cache "/" tag)
            parsed-file (str out-folder "/" edn-parsed-file)
            skip? (and skip-parse?           ;; do we want to skip?
                       (exists? parsed-file) ;; can we skip?
                       )]

        ;; make output folder for this tag
        (when-not (exists? out-folder)
          (mkdir out-folder))

        (if skip?

          (do
            (println "Using cache instead of parsing" (style tag :yellow))
            (reset! prev-result (delay (edn/read-string (slurp parsed-file)))))

          ;; parse
          (with-checkout! tag

            (println "\n=========================================================")
            (println "\nChecked out ClojureScript " (style *cljs-tag* :yellow))
            (println "with Clojure:" (style *clj-tag* :yellow))
            (println "published on" (style *cljs-date* :yellow))

            (println "\nParsing...")
            (let [parsed (parse-all)]
              (print-summary parsed)

              (println "\nWriting parsed data to" (style parsed-file :cyan))
              (let [result (get-result parsed (get-prev-result))]
                (spit parsed-file (with-out-str (pprint result)))
                (reset! prev-result result)))

            (println "\nDone.")))))

    ;; compile cljsdoc files (manual docs)
    (println)
    (let [known-symbols (set (keys (:symbols (get-prev-result))))
          num-skipped (build-cljsdoc! known-symbols) ;; TODO: uncomment param when ready to address symbol errors
          ]
      (when-not (zero? num-skipped)
        (System/exit 1)))

    ;; create pages
    (println "\nStarting second pass (merge manual docs and create pages)...\n")
    (doseq [tag tags]
      (let [skip? (and skip-pages? (not= tag last-tag))
            out-folder (str cache "/" tag)]
        (if skip?
          (println "Skipping page creation for" (style tag :yellow))
          (do
            (println "\nCreating pages for " (style tag :yellow))
            (let [parsed-file (str out-folder "/" edn-parsed-file)
                  parsed (edn/read-string (slurp parsed-file))
                  result (add-cljsdoc-to-result parsed)]
              (binding [*output-dir* out-folder]
                (dump-result! result)))))))

    ;; third pass
    (println "\nStarting final pass (finalizing output directory)...\n")
    (let [dont-copy? #{edn-parsed-file}
          should-copy? (complement dont-copy?)
          files-to-copy (fn [tag]
                          (->> (list-dir (str cache "/" tag))
                               (filter #(should-copy? (base-name %)))))
          copy-to-root! (fn [tag]
                          (doseq [f (files-to-copy tag)]
                            (let [filename (base-name f)
                                  new-loc (str *output-dir* "/" filename)]
                              (if (file? f)
                                (copy f new-loc)
                                (copy-dir f new-loc)))))]

      (if catalog?

        (do
          (println "\nCreating catalog repo...")
          (catalog-init!)
          (doseq [tag tags]

            ;; FIXME: We shouldn't be checking out the repos here, but this
            ;; wrapper gives us the version bindings, which we haven't separated
            ;; into its own macro yet.
            (with-checkout! tag
              (println "\nCommitting docs at tag" tag "...")
              (copy-to-root! tag)
              (doseq [f (files-to-copy tag)]
                (catalog-add! (base-name f)))
              (catalog-commit!))))

        (copy-to-root! last-tag))))

    (println (style "Success!" :green)))

(ns cljs-api-gen.catalog
  (:require
    [fipp.edn :refer [pprint]]
    [clojure.edn :as edn]
    [clansi.core :refer [style]]
    [clojure.string :refer [join]]
    [clojure.java.shell :refer [sh]]
    [me.raynes.fs :refer [mkdir
                          exists?
                          file?
                          delete-dir
                          list-dir
                          base-name
                          copy
                          copy-dir]]
    [cljs-api-gen.cljsdoc :refer [build-cljsdoc!]]
    [cljs-api-gen.config :refer [*output-dir*
                                 cache-dir
                                 edn-parsed-file
                                 edn-cljsdoc-file]]
    [cljs-api-gen.parse :refer [parse-all]]
    [cljs-api-gen.repo-cljs :refer [get-cljs-tags-to-parse
                                    published-cljs-tags
                                    with-checkout!
                                    cljs-tag->version
                                    *cljs-tag*
                                    *cljs-date*
                                    *clj-tag*
                                    *cljs-version*
                                    *clj-version*]]
    [cljs-api-gen.result :refer [get-result
                                 add-cljsdoc-to-result]]
    [cljs-api-gen.write :refer [dump-result!]]
    ))

;;----------------------------------------------------------------------
;; Catalog Repo Operations
;;----------------------------------------------------------------------

(defn git
  [& args]
  (apply sh "git" (concat args [:dir *output-dir*])))

(defn catalog-tag->cljs
  [v]
  (let [m (re-find #"-\d+" v)
        number (subs m 1)]
    (str "r" number)))

(defn catalog-tag []
  (:out (git "describe" "--tags")))

(defn catalog-init! []
  (delete-dir (str *output-dir* "/.git"))
  (git "init"))

(defn catalog-add!
  [f]
  (git "add" f))

(defn catalog-commit! []
  (let [msg (str *cljs-version* "\n"
                 "\n"
                 "- auto-generated by:\n"
                 "  https://github.com/cljsinfo/cljs-api-docs\n"
                 "\n"
                 "- parsed from:\n"
                 "  ClojureScript " *cljs-version* "\n"
                 "  Clojure " *clj-version* "\n")]
    (git "commit" "-m" msg)
    (git "tag" *cljs-version*)))

;;----------------------------------------------------------------------
;; Catalog Creation
;;----------------------------------------------------------------------

(defn print-summary*
  [parsed]
  (let [ns-groups (group-by :ns parsed)
        pairs (sort-by first ns-groups)]
    (doseq [[ns- symbols] pairs]
      (printf "    %-24s %4s = %s\n"
        ns-
        (count symbols)
        (let [type-groups (group-by :type symbols)
              pairs (sort-by first type-groups)]
          (join " + "
            (for [[type- symbols] pairs]
              (let [total (count symbols)]
                (str total " " (cond-> type- (> total 1) (str "s")))))))))))

(defn print-summary
  [parsed]
  (println " Syntax API:")
  (print-summary* (:syntax parsed))
  (println " Library API:")
  (print-summary* (:library parsed))
  (println " Compiler API:")
  (print-summary* (:compiler parsed)))

(defn create-catalog!
  [{:as options
    :keys [version
           catalog?
           skip-pages?
           skip-parse?]
    :or {version :latest
         catalog? false
         skip-pages? true
         skip-parse? true}}]

  ;; create output directory
  (when-not (exists? *output-dir*)
    (mkdir *output-dir*))

  (let [cache (str *output-dir* "/" cache-dir)

        ;; This holds the "result" data for the most recently parsed cljs version.
        ;; Sometimes this is cached, so there is some ceremony here to prevent pulling
        ;; the value from its cache until its actually needed.  We use an expression
        ;; wrapped in a `delay` to do this.  Since not every value is cached, we just
        ;; use the `get-prev-result` to not worry about it.
        prev-result (atom nil)
        get-prev-result #(if (delay? @prev-result)
                           @@prev-result
                           @prev-result)

        tags (if (= :latest version)
               @published-cljs-tags
               (concat (take-while (partial not= version) @published-cljs-tags) [version]))
        last-tag (last tags)]

    ;; make cache directory
    (when-not (exists? cache)
      (mkdir cache))

    (println "Outputting to " (style *output-dir* :cyan))
    (println "   with cache at " (style cache :cyan))

    ;; parse symbol history
    (println "\nStarting first pass (parsing symbol history)...\n")
    (doseq [tag tags]

      ;; check if skip-parse? and if this tag's edn-parsed-file already exists
      (let [out-folder (str cache "/" tag)
            parsed-file (str out-folder "/" edn-parsed-file)
            skip? (and skip-parse?           ;; do we want to skip?
                       (exists? parsed-file) ;; can we skip?
                       )]

        ;; make output folder for this tag
        (when-not (exists? out-folder)
          (mkdir out-folder))

        (if skip?

          (do
            (println "Using cache instead of parsing" (style tag :yellow))
            (reset! prev-result (delay (edn/read-string (slurp parsed-file)))))

          ;; parse
          (with-checkout! tag

            (println "\n=========================================================")
            (println "\nChecked out ClojureScript " (style *cljs-tag* :yellow))
            (println "with Clojure:" (style *clj-tag* :yellow))
            (println "published on" (style *cljs-date* :yellow))

            (println "\nParsing...")
            (let [parsed (parse-all)]
              (print-summary parsed)

              (println "\nWriting parsed data to" (style parsed-file :cyan))
              (let [result (get-result parsed (get-prev-result))]
                (spit parsed-file (with-out-str (pprint result)))
                (reset! prev-result result)))

            (println "\nDone.")))))

    ;; compile cljsdoc files (manual docs)
    (println)
    (let [known-symbols (set (keys (:symbols (get-prev-result))))
          num-skipped (build-cljsdoc! known-symbols) ;; TODO: uncomment param when ready to address symbol errors
          ]
      (when-not (zero? num-skipped)
        (System/exit 1)))

    ;; create pages
    (println "\nStarting second pass (merge manual docs and create pages)...\n")
    (doseq [tag tags]
      (let [skip? (and skip-pages? (not= tag last-tag))
            out-folder (str cache "/" tag)]
        (if skip?
          (println "Skipping page creation for" (style tag :yellow))
          (do
            (println "\nCreating pages for " (style tag :yellow))
            (let [parsed-file (str out-folder "/" edn-parsed-file)
                  parsed (edn/read-string (slurp parsed-file))
                  result (add-cljsdoc-to-result parsed)]
              (binding [*output-dir* out-folder]
                (dump-result! result)))))))

    ;; third pass
    (println "\nStarting final pass (finalizing output directory)...\n")
    (let [dont-copy? #{edn-parsed-file}
          should-copy? (complement dont-copy?)
          files-to-copy (fn [tag]
                          (->> (list-dir (str cache "/" tag))
                               (filter #(should-copy? (base-name %)))))
          copy-to-root! (fn [tag]
                          (doseq [f (files-to-copy tag)]
                            (let [filename (base-name f)
                                  new-loc (str *output-dir* "/" filename)]
                              (if (file? f)
                                (copy f new-loc)
                                (do
                                  (delete-dir new-loc)
                                  (copy-dir f new-loc))))))]

      (if catalog?

        (do
          (println "\nCreating catalog repo...")
          (catalog-init!)
          (doseq [tag tags]

            ;; FIXME: We shouldn't be checking out the repos here, but this
            ;; wrapper gives us the version bindings, which we haven't separated
            ;; into its own macro yet.
            (with-checkout! tag
              (println "\nCommitting docs at tag" tag "...")
              (copy-to-root! tag)
              (doseq [f (files-to-copy tag)]
                (catalog-add! (base-name f)))
              (catalog-commit!))))

        (copy-to-root! last-tag))))

    (println (style "Success!" :green)))

fix directory copying for catalog commits (close #111)


(ns cavm.core
  (:require [clojure.string :as s])
  (:require [cavm.h2 :as h2])
  (:require [clojure.java.io :as io])
  (:require [ring.adapter.jetty :refer [run-jetty]])
  (:require [clojure.data.json :as json])
  (:require [me.raynes.fs :as fs])
  (:require [clojure.tools.cli :refer [parse-opts]])
  (:require [cgdata.core :as cgdata])
  (:require [ring.middleware.resource :refer [wrap-resource]])
  (:require [ring.middleware.content-type :refer [wrap-content-type]])
  (:require [ring.middleware.not-modified :refer [wrap-not-modified]])
  (:require [ring.middleware.params :refer [wrap-params]])
  (:require [cavm.views.datasets])
  (:require [ring.middleware.gzip :refer [wrap-gzip]])
  (:require [ring.middleware.stacktrace :refer [wrap-stacktrace]]) ; XXX only in dev
  (:require [liberator.dev :refer [wrap-trace]])                   ; XXX only in dev
  (:require [filevents.core :refer [watch]])
  (:require [cavm.readers :as cr])
  (:require [cavm.loader :as cl])
  (:require [cavm.fs-utils :refer [normalized-path]])
  (:require [cavm.cgdata])
  (:require [clj-http.client :as client])
  (:gen-class))

(defn- in-data-path [root path]
  (boolean (fs/child-of? (normalized-path root) (normalized-path path))))

;
; web services

; XXX change Access-Control-Allow-Origin in production.
(defn wrap-access-control [handler]
  (fn [request]
    (let [response (handler request)]
      (-> response
          (assoc-in [:headers "Access-Control-Allow-Origin"] "https://tcga1.kilokluster.ucsc.edu")
          (assoc-in [:headers "Access-Control-Allow-Headers"] "Cancer-Browser-Api")))))

(defn- attr-middleware [app k v]
  (fn [req]
    (app (assoc req k v))))

(comment (defn- del-datasets [args]
   (dorun (map del-exp args))))

(comment (defn- print-datasets []
   (dorun (map println (datasets)))))

; XXX add ring jsonp?
(defn- get-app [db loader]
  (-> cavm.views.datasets/routes
      (wrap-trace :header :ui)
      (attr-middleware :db db)
      (attr-middleware :loader loader)
      (wrap-params)
      (wrap-resource "public")
      (wrap-content-type)
      (wrap-not-modified)
      (wrap-access-control)
      (wrap-gzip)
      (wrap-stacktrace)))

(defn- serv [app host port]
  (ring.adapter.jetty/run-jetty app {:host host :port port :join? true}))

(comment (defn- load-report [load-fn root file]
   (try
     (load-fn root file)
     (catch java.lang.Exception e
       (binding [*out* *err*]
         (println "Error loading file" file)
         (println (str "message " (.getMessage e)))
         (.printStackTrace e))))))

; XXX call clean-sources somewhere?? Should be automated.
(comment (defn- loadfiles [load-fn root args]
   (when (not (> (count args) 0))
     (println "Usage\nload <filename>")
     (System/exit 0))

   ; Skip files outside the designated path
   (let [{in-path true, not-in-path false}
         (group-by #(in-data-path root %) args)]
     (when not-in-path
       (binding [*out* *err*]
         (println "These files are outside the CAVM data path and will not be served:")
         (println (s/join "\n" (in-path false)))))
     (create)
     (println "Loading " (count in-path) " file(s)")
     (dorun (map #(do (print %2 %1 "") (time (load-report load-fn root %1)))
                 in-path
                 (range (count in-path) 0 -1)))
     (clean-sources))))

(defn- loadfiles [port files]
  (client/post (str "http://localhost:" port "/update/")
               {:form-params {:file files}}))

(def detectors
  [cgdata/detect-cgdata
   cgdata/detect-tsv])

; Full reload metadata. The loader will skip
; data files with unchanged hashes.
(defn file-changed [loader docroot kind file]
  (doseq [f (rest (file-seq (io/file docroot)))] ; skip docroot (the first element)
    (try (loader f)
      (catch Exception e (println (str "caught exception: " (.getMessage e))))))) ; XXX this is unhelpful. Log it somewhere.

(def xenadir-default (str (io/file (System/getProperty  "user.home") "xena")))
(def docroot-default (str (io/file xenadir-default "files")))
(def db-default (str (io/file xenadir-default "database")))
(def tmp-dir-default
  (str (io/file (System/getProperty "java.io.tmpdir") "xena-staging")))

(def ^:private argspec
  [[nil "--no-serve" "Don't start web server" :id :serve :parse-fn not :default true]
   ["-p" "--port PORT" "Server port to listen on" :default 7222 :parse-fn #(Integer/parseInt %)]
   ["-l" "--load" "Load files into running server"]
   [nil "--no-auto" "Don't auto-load files" :id :auto :parse-fn not :default true]
   ["-h" "--help" "Show help"]
   ["-H" "--host HOST" "Set host for listening socket" :default "localhost"]
   ["-r" "--root DIR" "Set document root directory" :default docroot-default]
   ["-d" "--database FILE" "Database to use" :default db-default]
   ["-j" "--json" "Fix json"]
   ["-t" "--tmp DIR" "Set tmp dir" :default tmp-dir-default]])

(defn- mkdir [dir]
  (.mkdirs (io/file dir))
  (when (not (.exists (io/file dir)))
    (str "Unable to create directory: " dir)))

; XXX create dir for database as well?
(defn -main [& args]
  (let [{:keys [options arguments summary errors]} (parse-opts args argspec)
        docroot (:root options)
        port (:port options)
        host (:host options)
        tmp (:tmp options)]
    (if errors
      (binding [*out* *err*]
        (println (s/join "\n" errors)))
      (cond
        (:help options) (println summary)
        (:json options) (cgdata/fix-json docroot)
        (:load options) (loadfiles port arguments)
        :else (if-let [error (some mkdir [tmp docroot])]
                (binding [*out* *err*]
                  (println error))
                (do
                  (h2/set-tmp-dir! tmp)
                  (let [db (h2/create-xenadb (str (:database options) ";MVCC=TRUE")) ; XXX guard against double semicolon
                        detector (apply cr/detector docroot detectors)
                        loader (cl/loader-agent db detector docroot)]
                    (when (:auto options)
                      (watch (partial file-changed loader docroot) docroot))
                    (when (:serve options)
                      (serv (get-app db loader) host port))))))))
  (shutdown-agents))

; When logging to the repl from a future, *err* gets lost.
; This will set it to the repl terminal, for reasons I don't understand.
(comment (defn snoop [msg x]
   (.start (Thread. #(binding [*out* *err*]
                       (println msg x)
                       (flush))))
   x))

; (def testdb (create-xenadb "test;TRACE_LEVEL_FILE=3"))
; (def testdb (create-xenadb "/inside/home/craft/xena/database;TRACE_LEVEL_FILE=3"))
; (def testdetector (apply cr/detector "/inside/home/craft/xena/files" detectors))
; (def testloader (cl/loader-agent testdb testdetector "/inside/home/craft/xena/files"))
;            (watch (partial file-changed #'testloader docroot-default) docroot-default)
; (def app (get-app testdb testloader))
; (defonce server (ring.adapter.jetty/run-jetty #'app {:port 7222 :join? false}))
; (.start server)
; (.stop server)

(ns cavm.core
  (:require [clojure.string :as s])
  (:require [cavm.h2 :as h2])
  (:require [clojure.java.io :as io])
  (:require [ring.adapter.jetty :refer [run-jetty]])
  (:require [clojure.data.json :as json])
  (:require [me.raynes.fs :as fs])
  (:require [clojure.tools.cli :refer [parse-opts]])
  (:require [cgdata.core :as cgdata])
  (:require [ring.middleware.resource :refer [wrap-resource]])
  (:require [ring.middleware.content-type :refer [wrap-content-type]])
  (:require [ring.middleware.not-modified :refer [wrap-not-modified]])
  (:require [ring.middleware.params :refer [wrap-params]])
  (:require [cavm.views.datasets])
  (:require [ring.middleware.gzip :refer [wrap-gzip]])
  (:require [ring.middleware.stacktrace :refer [wrap-stacktrace]]) ; XXX only in dev
  (:require [liberator.dev :refer [wrap-trace]])                   ; XXX only in dev
  (:require [filevents.core :refer [watch]])
  (:require [cavm.readers :as cr])
  (:require [cavm.loader :as cl])
  (:require [cavm.fs-utils :refer [normalized-path]])
  (:require [cavm.cgdata])
  (:require [clj-http.client :as client])
  (:gen-class))

(defn- in-data-path [root path]
  (boolean (fs/child-of? (normalized-path root) (normalized-path path))))

;
; web services

; XXX change Access-Control-Allow-Origin in production.
(defn wrap-access-control [handler]
  (fn [request]
    (let [response (handler request)]
      (-> response
          (assoc-in [:headers "Access-Control-Allow-Origin"] "https://tcga1.kilokluster.ucsc.edu")
          (assoc-in [:headers "Access-Control-Allow-Headers"] "Cancer-Browser-Api")))))

(defn- attr-middleware [app k v]
  (fn [req]
    (app (assoc req k v))))

(comment (defn- del-datasets [args]
   (dorun (map del-exp args))))

(comment (defn- print-datasets []
   (dorun (map println (datasets)))))

; XXX add ring jsonp?
(defn- get-app [db loader]
  (-> cavm.views.datasets/routes
      (wrap-trace :header :ui)
      (attr-middleware :db db)
      (attr-middleware :loader loader)
      (wrap-params)
      (wrap-resource "public")
      (wrap-content-type)
      (wrap-not-modified)
      (wrap-access-control)
      (wrap-gzip)
      (wrap-stacktrace)))

(defn- serv [app host port]
  (ring.adapter.jetty/run-jetty app {:host host :port port :join? true}))

(comment (defn- load-report [load-fn root file]
   (try
     (load-fn root file)
     (catch java.lang.Exception e
       (binding [*out* *err*]
         (println "Error loading file" file)
         (println (str "message " (.getMessage e)))
         (.printStackTrace e))))))

; XXX call clean-sources somewhere?? Should be automated.
(comment (defn- loadfiles [load-fn root args]
   (when (not (> (count args) 0))
     (println "Usage\nload <filename>")
     (System/exit 0))

   ; Skip files outside the designated path
   (let [{in-path true, not-in-path false}
         (group-by #(in-data-path root %) args)]
     (when not-in-path
       (binding [*out* *err*]
         (println "These files are outside the CAVM data path and will not be served:")
         (println (s/join "\n" (in-path false)))))
     (create)
     (println "Loading " (count in-path) " file(s)")
     (dorun (map #(do (print %2 %1 "") (time (load-report load-fn root %1)))
                 in-path
                 (range (count in-path) 0 -1)))
     (clean-sources))))

(defn- loadfiles [port files]
  (client/post (str "http://localhost:" port "/update/")
               {:form-params {:file files}}))

(def detectors
  [cgdata/detect-cgdata
   cgdata/detect-tsv])

; Full reload metadata. The loader will skip
; data files with unchanged hashes.
(defn file-changed [loader docroot kind file]
  (doseq [f (rest (file-seq (io/file docroot)))] ; skip docroot (the first element)
    (try (loader f)
      (catch Exception e (println (str "caught exception: " (.getMessage e))))))) ; XXX this is unhelpful. Log it somewhere.

(def xenadir-default (str (io/file (System/getProperty  "user.home") "xena")))
(def docroot-default (str (io/file xenadir-default "files")))
(def db-default (str (io/file xenadir-default "database")))
(def tmp-dir-default
  (str (io/file (System/getProperty "java.io.tmpdir") "xena-staging")))

(def ^:private argspec
  [[nil "--no-serve" "Don't start web server" :id :serve :parse-fn not :default true]
   ["-p" "--port PORT" "Server port to listen on" :default 7222 :parse-fn #(Integer/parseInt %)]
   ["-l" "--load" "Load files into running server"]
   [nil "--no-auto" "Don't auto-load files" :id :auto :parse-fn not :default true]
   ["-h" "--help" "Show help"]
   ["-H" "--host HOST" "Set host for listening socket" :default "localhost"]
   ["-r" "--root DIR" "Set document root directory" :default docroot-default]
   ["-d" "--database FILE" "Database to use" :default db-default]
   ["-j" "--json" "Fix json"]
   ["-t" "--tmp DIR" "Set tmp dir" :default tmp-dir-default]])

(defn- mkdir [dir]
  (.mkdirs (io/file dir))
  (when (not (.exists (io/file dir)))
    (str "Unable to create directory: " dir)))

; XXX create dir for database as well?
(defn -main [& args]
  (let [{:keys [options arguments summary errors]} (parse-opts args argspec)
        docroot (:root options)
        port (:port options)
        host (:host options)
        tmp (:tmp options)]
    (if errors
      (binding [*out* *err*]
        (println (s/join "\n" errors)))
      (cond
        (:help options) (println summary)
        (:json options) (cgdata/fix-json docroot)
        (:load options) (loadfiles port arguments)
        :else (if-let [error (some mkdir [tmp docroot])]
                (binding [*out* *err*]
                  (println error))
                (do
                  (h2/set-tmp-dir! tmp)
                  (let [db (h2/create-xenadb (str (:database options) ";MVCC=TRUE")) ; XXX guard against double semicolon
                        detector (apply cr/detector docroot detectors)
                        loader (cl/loader-agent db detector docroot)]
                    (when (:auto options)
                      (watch (partial file-changed loader docroot) docroot))
                    (when (:serve options)
                      (serv (get-app db loader) host port))))))))
  (shutdown-agents))

; When logging to the repl from a future, *err* gets lost.
; This will set it to the repl terminal, for reasons I don't understand.
(comment (defn snoop [msg x]
   (.start (Thread. #(binding [*out* *err*]
                       (println msg x)
                       (flush))))
   x))

; (def testdb (h2/create-xenadb "test;TRACE_LEVEL_FILE=3"))
; (def testdb (h2/create-xenadb "/inside/home/craft/xena/database;TRACE_LEVEL_FILE=3"))
; (def testdetector (apply cr/detector "/inside/home/craft/xena/files" detectors))
; (def testloader (cl/loader-agent testdb testdetector "/inside/home/craft/xena/files"))
;            (watch (partial file-changed #'testloader docroot-default) docroot-default)
; (def app (get-app testdb testloader))
; (defonce server (ring.adapter.jetty/run-jetty #'app {:port 7222 :join? false}))
; (.start server)
; (.stop server)

Update repl expression comments.

Update repl expression comments.