(ns ^:no-doc onyx.messaging.aeron
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout close! sliding-buffer]]
            [com.stuartsierra.component :as component]
            [taoensso.timbre :refer [fatal] :as timbre]
            [onyx.messaging.protocol-aeron :as protocol]
            [onyx.messaging.acking-daemon :as acker]
            [onyx.messaging.common :as common]
            [onyx.extensions :as extensions]
            [onyx.compression.nippy :refer [compress decompress]]
            [onyx.static.default-vals :refer [defaults]])
  (:import [uk.co.real_logic.aeron Aeron FragmentAssemblyAdapter]
           [uk.co.real_logic.aeron Aeron$Context]
           [uk.co.real_logic.aeron.driver MediaDriver MediaDriver$Context ThreadingMode]
           [uk.co.real_logic.aeron.logbuffer FragmentHandler]
           [uk.co.real_logic.agrona.concurrent UnsafeBuffer]
           [uk.co.real_logic.agrona CloseHelper]
           [uk.co.real_logic.agrona ErrorHandler]
           [uk.co.real_logic.agrona.concurrent IdleStrategy BackoffIdleStrategy BusySpinIdleStrategy]
           [java.util.function Consumer]
           [java.util.concurrent TimeUnit]))

(defrecord AeronPeerGroup [opts]
  component/Lifecycle
  (start [component]
    (taoensso.timbre/info "Starting Aeron Peer Group")
    (let [embedded-driver? (if-not (nil? (:onyx.messaging.aeron/embedded-driver? opts))
                             (:onyx.messaging.aeron/embedded-driver? opts)
                             (:onyx.messaging.aeron/embedded-driver? defaults))]
      (if embedded-driver?
        (let [ctx (doto (MediaDriver$Context.)
                    (.threadingMode ThreadingMode/DEDICATED)
                    (.dirsDeleteOnExit true))
              media-driver (MediaDriver/launch ctx)]
          (assoc component :media-driver media-driver))
        component)))

  (stop [{:keys [media-driver] :as component}]
    (taoensso.timbre/info "Stopping Aeron Peer Group")
    (when media-driver (.close ^MediaDriver media-driver))
    (assoc component :media-driver nil)))

(defn aeron-peer-group [opts]
  (map->AeronPeerGroup {:opts opts}))

(defmethod extensions/assign-site-resources :aeron
  [config peer-site peer-sites]
  (let [used-ports (->> (vals peer-sites)
                        (filter
                          (fn [s]
                            (= (:aeron/external-addr peer-site)
                               (:aeron/external-addr s))))
                        (map :aeron/port)
                        set)
        port (first (sort (remove used-ports (:aeron/ports peer-site))))]
    (assert port "Couldn't assign port - ran out of available ports.")
    {:aeron/port port}))

(defmethod extensions/get-peer-site :aeron
  [replica peer]
  (get-in replica [:peer-sites peer :aeron/external-addr]))

(defn handle-sent-message [inbound-ch decompress-f ^UnsafeBuffer buffer offset length header]
  (let [messages (protocol/read-messages-buf decompress-f buffer offset length)]
    (doseq [message messages]
      (>!! inbound-ch message))))

(defn handle-aux-message [daemon release-ch retry-ch buffer offset length header]
  (let [msg-type (protocol/read-message-type buffer offset)
        offset-rest (long (inc offset))]
    (cond (= msg-type protocol/ack-msg-id)
          (let [ack (protocol/read-acker-message buffer offset-rest)]
            (acker/ack-message daemon (:id ack) (:completion-id ack) (:ack-val ack)))

          (= msg-type protocol/completion-msg-id)
          (let [completion-id (protocol/read-completion buffer offset-rest)]
            (>!! release-ch completion-id))

          (= msg-type protocol/retry-msg-id)
          (let [retry-id (protocol/read-retry buffer offset)]
            (>!! retry-ch retry-id)))))

(defn data-handler [f]
  (FragmentAssemblyAdapter.
    (proxy [FragmentHandler] []
      (onFragment [buffer offset length header]
        (f buffer offset length header)))))

(defn backoff-strategy [strategy]
  (case strategy
    :busy-spin (BusySpinIdleStrategy.)
    :low-restart-latency (BackoffIdleStrategy. 1
                                               10
                                               (.toNanos TimeUnit/MICROSECONDS 1)
                                               (.toNanos TimeUnit/MICROSECONDS 100))
    :high-restart-latency (BackoffIdleStrategy. 10
                                                100
                                                (.toNanos TimeUnit/MICROSECONDS 100)
                                                (.toNanos TimeUnit/MICROSECONDS 10000))))

(defn consumer [handler ^IdleStrategy idle-strategy limit]
  (proxy [Consumer] []
    (accept [subscription]
      (while (not (Thread/interrupted))
        (let [fragments-read (.poll ^uk.co.real_logic.aeron.Subscription subscription ^FragmentHandler handler ^int limit)]
          (.idle idle-strategy fragments-read))))))

(def no-op-error-handler
  (proxy [ErrorHandler] []
    (onError [x] (taoensso.timbre/warn x))))

(defrecord AeronConnection [peer-group bind-addr external-addr
                            inbound-ch send-idle-strategy receive-idle-strategy ports resources
                            release-ch retry-ch decompress-f compress-f]
  component/Lifecycle
  (start [component]
    (taoensso.timbre/info "Starting Aeron" (:messenger-buffer component))
    (let [config (:config peer-group)
          inbound-ch (:inbound-ch (:messenger-buffer component))
          release-ch (chan (sliding-buffer (:onyx.messaging/release-ch-buffer-size defaults)))
          retry-ch (chan (sliding-buffer (:onyx.messaging/retry-ch-buffer-size defaults)))
          bind-addr (common/bind-addr config)
          external-addr (common/external-addr config)
          ports (common/allowable-ports config)
          idle-strategy-config (or (:onyx.messaging.aeron/idle-strategy config)
                                   (:onyx.messaging.aeron/idle-strategy defaults))
          send-idle-strategy (backoff-strategy idle-strategy-config)
          receive-idle-strategy (backoff-strategy idle-strategy-config)]
      (assoc component
             :bind-addr bind-addr
             :external-addr external-addr
             :inbound-ch inbound-ch
             :send-idle-strategy send-idle-strategy
             :receive-idle-strategy receive-idle-strategy
             :ports ports
             :resources (atom nil)
             :release-ch release-ch
             :retry-ch retry-ch
             :decompress-f (or (:onyx.messaging/decompress-fn (:config peer-group)) decompress)
             :compress-f (or (:onyx.messaging/compress-fn (:config peer-group)) compress))))

  (stop [{:keys [aeron resources release-ch] :as component}]
    (taoensso.timbre/info "Stopping Aeron")
    (try
      (when-let [rs @resources]
        (let [{:keys [conn
                      send-subscriber
                      aux-subscriber
                      accept-send-fut
                      accept-aux-fut]} rs]
          (future-cancel accept-send-fut)
          (future-cancel accept-aux-fut)
         (when send-subscriber (.close ^uk.co.real_logic.aeron.Subscription send-subscriber))
         (when aux-subscriber (.close ^uk.co.real_logic.aeron.Subscription aux-subscriber))
         (when conn (.close ^uk.co.real_logic.aeron.Aeron conn)))
        (reset! resources nil))
      (close! (:release-ch component))
      (close! (:retry-ch component))
      (catch Throwable e (fatal e)))

    (assoc component
           :bind-addr nil :external-addr nil :inbound-ch nil :send-idle-strategy nil
           :receive-idle-strategy nil :ports nil :resources nil
           :release-ch nil :retry-ch nil :decompress-f nil :compress-f nil)))

(defn aeron [peer-group]
  (map->AeronConnection {:peer-group peer-group}))

(defmethod extensions/peer-site AeronConnection
  [messenger]
  {:aeron/ports (:ports messenger)
   :aeron/external-addr (:external-addr messenger)})

(def send-stream-id 1)
(def aux-stream-id 2)

(defn aeron-channel [addr port]
  (format "udp://%s:%s" addr port))

(defrecord AeronResources [conn accept-send-fut accept-aux-fut send-subscriber aux-subscriber])

(defmethod extensions/open-peer-site AeronConnection
  [messenger assigned]
  (let [inbound-ch (:inbound-ch (:messenger-buffer messenger))
        {:keys [release-ch retry-ch acking-daemon bind-addr]} messenger
        ctx (.errorHandler (Aeron$Context.) no-op-error-handler)
        aeron (Aeron/connect ctx)
        channel (aeron-channel bind-addr (:aeron/port assigned))
        decompress-f (:decompress-f messenger)
        send-handler (data-handler (fn [buffer offset length header]
                                     (handle-sent-message inbound-ch decompress-f buffer offset length header)))
        aux-handler (data-handler (fn [buffer offset length header]
                                    (handle-aux-message acking-daemon release-ch retry-ch buffer offset length header)))

        send-subscriber (.addSubscription aeron channel send-stream-id)
        aux-subscriber (.addSubscription aeron channel aux-stream-id)

        receive-idle-strategy (:receive-idle-strategy messenger)

        ;; pass in handler to consumer constructor
        accept-send-fut (future (try (.accept ^Consumer (consumer send-handler receive-idle-strategy 10) send-subscriber)
                                     (catch Throwable e (fatal e))))
        accept-aux-fut (future (try (.accept ^Consumer (consumer aux-handler receive-idle-strategy 10) aux-subscriber)
                                      (catch Throwable e (fatal e))))]
    (reset! (:resources messenger)
            (->AeronResources aeron accept-send-fut accept-aux-fut send-subscriber aux-subscriber))))

(defrecord AeronPeerConnection [conn send-pub-f-create send-pub aux-pub-f-create aux-pub])

(defmethod extensions/connect-to-peer AeronConnection
  [messenger event {:keys [aeron/external-addr aeron/port]}]
  (let [ctx (.errorHandler (Aeron$Context.) no-op-error-handler)
        aeron (Aeron/connect ctx)
        channel (aeron-channel external-addr port)
        f-send-pub #(.addPublication aeron channel send-stream-id)
        f-aux-pub #(.addPublication aeron channel aux-stream-id)]
    (->AeronPeerConnection aeron f-send-pub (atom nil) f-aux-pub (atom nil))))

(defmethod extensions/receive-messages AeronConnection
  [messenger {:keys [onyx.core/task-map] :as event}]
  (let [ch (:inbound-ch messenger)
        batch-size (:onyx/batch-size task-map)
        ms (or (:onyx/batch-timeout task-map) (:onyx/batch-timeout defaults))
        timeout-ch (timeout ms)]
    (loop [segments [] i 0]
      (if (< i batch-size)
        (if-let [v (first (alts!! [ch timeout-ch]))]
          (recur (conj segments v) (inc i))
          segments)
        segments))))

(defn get-peer-link-pub [peer-link link-key create-key]
  (if-let [pub @(get peer-link link-key)]
    pub
    (reset! (get peer-link link-key) ((get peer-link create-key)))))

(defmethod extensions/send-messages AeronConnection
  [messenger event peer-link batch]
  (let [[len unsafe-buffer] (protocol/build-messages-msg-buf (:compress-f messenger) batch)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :send-pub :send-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 len))
        idle-strategy (:send-idle-strategy messenger)]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/internal-ack-messages AeronConnection
  [messenger event peer-link acks]
  ; TODO: Might want to batch in a single buffer as in netty
  (let [pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        idle-strategy (:send-idle-strategy messenger)]
    (doseq [{:keys [id completion-id ack-val]} acks]
      (let [unsafe-buffer (protocol/build-acker-message id completion-id ack-val)
            offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/ack-msg-length))]
        (while (not (offer-f))
          (.idle ^IdleStrategy idle-strategy 0))))))

(defmethod extensions/internal-complete-message AeronConnection
  [messenger event id peer-link]
  (let [idle-strategy (:send-idle-strategy messenger)
        unsafe-buffer (protocol/build-completion-msg-buf id)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/completion-msg-length))]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/internal-retry-message AeronConnection
  [messenger event id peer-link]
  (let [idle-strategy (:send-idle-strategy messenger)
        unsafe-buffer (protocol/build-retry-msg-buf id)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/retry-msg-length))]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/close-peer-connection AeronConnection
  [messenger event peer-link]
  (when-let [pub (get peer-link :send-pub)]
    (when @pub (.close ^uk.co.real_logic.aeron.Publication @pub))
    (reset! pub nil))
  (when-let [pub (get peer-link :aux-pub)]
    (when @pub (.close ^uk.co.real_logic.aeron.Publication @pub))
    (reset! pub nil))
  (.close ^uk.co.real_logic.aeron.Aeron (:conn peer-link))
  {})

(ns ^:no-doc onyx.messaging.aeron
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout close! sliding-buffer]]
            [com.stuartsierra.component :as component]
            [taoensso.timbre :refer [fatal] :as timbre]
            [onyx.messaging.protocol-aeron :as protocol]
            [onyx.messaging.acking-daemon :as acker]
            [onyx.messaging.common :as common]
            [onyx.extensions :as extensions]
            [onyx.compression.nippy :refer [compress decompress]]
            [onyx.static.default-vals :refer [defaults]])
  (:import [uk.co.real_logic.aeron Aeron FragmentAssemblyAdapter]
           [uk.co.real_logic.aeron Aeron$Context]
           [uk.co.real_logic.aeron.driver MediaDriver MediaDriver$Context ThreadingMode]
           [uk.co.real_logic.aeron.logbuffer FragmentHandler]
           [uk.co.real_logic.agrona.concurrent UnsafeBuffer]
           [uk.co.real_logic.agrona CloseHelper]
           [uk.co.real_logic.agrona ErrorHandler]
           [uk.co.real_logic.agrona.concurrent IdleStrategy BackoffIdleStrategy BusySpinIdleStrategy]
           [java.util.function Consumer]
           [java.util.concurrent TimeUnit]))

(defrecord AeronPeerGroup [opts]
  component/Lifecycle
  (start [component]
    (taoensso.timbre/info "Starting Aeron Peer Group")
    (let [embedded-driver? (if-not (nil? (:onyx.messaging.aeron/embedded-driver? opts))
                             (:onyx.messaging.aeron/embedded-driver? opts)
                             (:onyx.messaging.aeron/embedded-driver? defaults))]
      (if embedded-driver?
        (let [ctx (doto (MediaDriver$Context.)
                    (.threadingMode ThreadingMode/DEDICATED)
                    (.dirsDeleteOnExit true))
              media-driver (MediaDriver/launch ctx)]
          (assoc component :media-driver media-driver))
        component)))

  (stop [{:keys [media-driver] :as component}]
    (taoensso.timbre/info "Stopping Aeron Peer Group")
    (when media-driver (.close ^MediaDriver media-driver))
    (assoc component :media-driver nil)))

(defn aeron-peer-group [opts]
  (map->AeronPeerGroup {:opts opts}))

(defmethod extensions/assign-site-resources :aeron
  [config peer-site peer-sites]
  (let [used-ports (->> (vals peer-sites)
                        (filter
                          (fn [s]
                            (= (:aeron/external-addr peer-site)
                               (:aeron/external-addr s))))
                        (map :aeron/port)
                        set)
        port (first (sort (remove used-ports (:aeron/ports peer-site))))]
    (assert port "Couldn't assign port - ran out of available ports.")
    {:aeron/port port}))

(defmethod extensions/get-peer-site :aeron
  [replica peer]
  (get-in replica [:peer-sites peer :aeron/external-addr]))

(defn handle-sent-message [inbound-ch decompress-f ^UnsafeBuffer buffer offset length header]
  (let [messages (protocol/read-messages-buf decompress-f buffer offset length)]
    (doseq [message messages]
      (>!! inbound-ch message))))

(defn handle-aux-message [daemon release-ch retry-ch buffer offset length header]
  (let [msg-type (protocol/read-message-type buffer offset)
        offset-rest (long (inc offset))]
    (cond (= msg-type protocol/ack-msg-id)
          (let [ack (protocol/read-acker-message buffer offset-rest)]
            (acker/ack-message daemon (:id ack) (:completion-id ack) (:ack-val ack)))

          (= msg-type protocol/completion-msg-id)
          (let [completion-id (protocol/read-completion buffer offset-rest)]
            (>!! release-ch completion-id))

          (= msg-type protocol/retry-msg-id)
          (let [retry-id (protocol/read-retry buffer offset-rest)]
            (>!! retry-ch retry-id)))))

(defn data-handler [f]
  (FragmentAssemblyAdapter.
    (proxy [FragmentHandler] []
      (onFragment [buffer offset length header]
        (f buffer offset length header)))))

(defn backoff-strategy [strategy]
  (case strategy
    :busy-spin (BusySpinIdleStrategy.)
    :low-restart-latency (BackoffIdleStrategy. 1
                                               10
                                               (.toNanos TimeUnit/MICROSECONDS 1)
                                               (.toNanos TimeUnit/MICROSECONDS 100))
    :high-restart-latency (BackoffIdleStrategy. 10
                                                100
                                                (.toNanos TimeUnit/MICROSECONDS 100)
                                                (.toNanos TimeUnit/MICROSECONDS 10000))))

(defn consumer [handler ^IdleStrategy idle-strategy limit]
  (proxy [Consumer] []
    (accept [subscription]
      (while (not (Thread/interrupted))
        (let [fragments-read (.poll ^uk.co.real_logic.aeron.Subscription subscription ^FragmentHandler handler ^int limit)]
          (.idle idle-strategy fragments-read))))))

(def no-op-error-handler
  (proxy [ErrorHandler] []
    (onError [x] (taoensso.timbre/warn x))))

(defrecord AeronConnection [peer-group bind-addr external-addr
                            inbound-ch send-idle-strategy receive-idle-strategy ports resources
                            release-ch retry-ch decompress-f compress-f]
  component/Lifecycle
  (start [component]
    (taoensso.timbre/info "Starting Aeron" (:messenger-buffer component))
    (let [config (:config peer-group)
          inbound-ch (:inbound-ch (:messenger-buffer component))
          release-ch (chan (sliding-buffer (:onyx.messaging/release-ch-buffer-size defaults)))
          retry-ch (chan (sliding-buffer (:onyx.messaging/retry-ch-buffer-size defaults)))
          bind-addr (common/bind-addr config)
          external-addr (common/external-addr config)
          ports (common/allowable-ports config)
          idle-strategy-config (or (:onyx.messaging.aeron/idle-strategy config)
                                   (:onyx.messaging.aeron/idle-strategy defaults))
          send-idle-strategy (backoff-strategy idle-strategy-config)
          receive-idle-strategy (backoff-strategy idle-strategy-config)]
      (assoc component
             :bind-addr bind-addr
             :external-addr external-addr
             :inbound-ch inbound-ch
             :send-idle-strategy send-idle-strategy
             :receive-idle-strategy receive-idle-strategy
             :ports ports
             :resources (atom nil)
             :release-ch release-ch
             :retry-ch retry-ch
             :decompress-f (or (:onyx.messaging/decompress-fn (:config peer-group)) decompress)
             :compress-f (or (:onyx.messaging/compress-fn (:config peer-group)) compress))))

  (stop [{:keys [aeron resources release-ch] :as component}]
    (taoensso.timbre/info "Stopping Aeron")
    (try
      (when-let [rs @resources]
        (let [{:keys [conn
                      send-subscriber
                      aux-subscriber
                      accept-send-fut
                      accept-aux-fut]} rs]
          (future-cancel accept-send-fut)
          (future-cancel accept-aux-fut)
         (when send-subscriber (.close ^uk.co.real_logic.aeron.Subscription send-subscriber))
         (when aux-subscriber (.close ^uk.co.real_logic.aeron.Subscription aux-subscriber))
         (when conn (.close ^uk.co.real_logic.aeron.Aeron conn)))
        (reset! resources nil))
      (close! (:release-ch component))
      (close! (:retry-ch component))
      (catch Throwable e (fatal e)))

    (assoc component
           :bind-addr nil :external-addr nil :inbound-ch nil :send-idle-strategy nil
           :receive-idle-strategy nil :ports nil :resources nil
           :release-ch nil :retry-ch nil :decompress-f nil :compress-f nil)))

(defn aeron [peer-group]
  (map->AeronConnection {:peer-group peer-group}))

(defmethod extensions/peer-site AeronConnection
  [messenger]
  {:aeron/ports (:ports messenger)
   :aeron/external-addr (:external-addr messenger)})

(def send-stream-id 1)
(def aux-stream-id 2)

(defn aeron-channel [addr port]
  (format "udp://%s:%s" addr port))

(defrecord AeronResources [conn accept-send-fut accept-aux-fut send-subscriber aux-subscriber])

(defmethod extensions/open-peer-site AeronConnection
  [messenger assigned]
  (let [inbound-ch (:inbound-ch (:messenger-buffer messenger))
        {:keys [release-ch retry-ch acking-daemon bind-addr]} messenger
        ctx (.errorHandler (Aeron$Context.) no-op-error-handler)
        aeron (Aeron/connect ctx)
        channel (aeron-channel bind-addr (:aeron/port assigned))
        decompress-f (:decompress-f messenger)
        send-handler (data-handler (fn [buffer offset length header]
                                     (handle-sent-message inbound-ch decompress-f buffer offset length header)))
        aux-handler (data-handler (fn [buffer offset length header]
                                    (handle-aux-message acking-daemon release-ch retry-ch buffer offset length header)))

        send-subscriber (.addSubscription aeron channel send-stream-id)
        aux-subscriber (.addSubscription aeron channel aux-stream-id)

        receive-idle-strategy (:receive-idle-strategy messenger)

        ;; pass in handler to consumer constructor
        ;;;;; FIXME: 10 is not the right fragment limit to use here
        ;;;;; should at least be configurable
        accept-send-fut (future (try (.accept ^Consumer (consumer send-handler receive-idle-strategy 10) send-subscriber)
                                     (catch Throwable e (fatal e))))
        accept-aux-fut (future (try (.accept ^Consumer (consumer aux-handler receive-idle-strategy 10) aux-subscriber)
                                      (catch Throwable e (fatal e))))]
    (reset! (:resources messenger)
            (->AeronResources aeron accept-send-fut accept-aux-fut send-subscriber aux-subscriber))))

(defrecord AeronPeerConnection [conn send-pub-f-create send-pub aux-pub-f-create aux-pub])

(defmethod extensions/connect-to-peer AeronConnection
  [messenger event {:keys [aeron/external-addr aeron/port]}]
  (let [ctx (.errorHandler (Aeron$Context.) no-op-error-handler)
        aeron (Aeron/connect ctx)
        channel (aeron-channel external-addr port)
        f-send-pub #(.addPublication aeron channel send-stream-id)
        f-aux-pub #(.addPublication aeron channel aux-stream-id)]
    (->AeronPeerConnection aeron f-send-pub (atom nil) f-aux-pub (atom nil))))

(defmethod extensions/receive-messages AeronConnection
  [messenger {:keys [onyx.core/task-map] :as event}]
  (let [ch (:inbound-ch messenger)
        batch-size (:onyx/batch-size task-map)
        ms (or (:onyx/batch-timeout task-map) (:onyx/batch-timeout defaults))
        timeout-ch (timeout ms)]
    (loop [segments [] i 0]
      (if (< i batch-size)
        (if-let [v (first (alts!! [ch timeout-ch]))]
          (recur (conj segments v) (inc i))
          segments)
        segments))))

(defn get-peer-link-pub [peer-link link-key create-key]
  (if-let [pub @(get peer-link link-key)]
    pub
    (reset! (get peer-link link-key) ((get peer-link create-key)))))

(defmethod extensions/send-messages AeronConnection
  [messenger event peer-link batch]
  (let [[len unsafe-buffer] (protocol/build-messages-msg-buf (:compress-f messenger) batch)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :send-pub :send-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 len))
        idle-strategy (:send-idle-strategy messenger)]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/internal-ack-messages AeronConnection
  [messenger event peer-link acks]
  ; TODO: Might want to batch in a single buffer as in netty
  (let [pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        idle-strategy (:send-idle-strategy messenger)]
    (doseq [{:keys [id completion-id ack-val]} acks]
      (let [unsafe-buffer (protocol/build-acker-message id completion-id ack-val)
            offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/ack-msg-length))]
        (while (not (offer-f))
          (.idle ^IdleStrategy idle-strategy 0))))))

(defmethod extensions/internal-complete-message AeronConnection
  [messenger event id peer-link]
  (let [idle-strategy (:send-idle-strategy messenger)
        unsafe-buffer (protocol/build-completion-msg-buf id)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/completion-msg-length))]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/internal-retry-message AeronConnection
  [messenger event id peer-link]
  (let [idle-strategy (:send-idle-strategy messenger)
        unsafe-buffer (protocol/build-retry-msg-buf id)
        pub ^uk.co.real_logic.aeron.Publication (get-peer-link-pub peer-link :aux-pub :aux-pub-f-create)
        offer-f (fn [] (.offer pub unsafe-buffer 0 protocol/retry-msg-length))]
    (while (not (offer-f))
      (.idle ^IdleStrategy idle-strategy 0))))

(defmethod extensions/close-peer-connection AeronConnection
  [messenger event peer-link]
  (when-let [pub (get peer-link :send-pub)]
    (when @pub (.close ^uk.co.real_logic.aeron.Publication @pub))
    (reset! pub nil))
  (when-let [pub (get peer-link :aux-pub)]
    (when @pub (.close ^uk.co.real_logic.aeron.Publication @pub))
    (reset! pub nil))
  (.close ^uk.co.real_logic.aeron.Aeron (:conn peer-link))
  {})

Fix bug in completion reads.

Fix bug in completion reads.


(ns onyx.static.planning
  (:require [com.stuartsierra.dependency :as dep]
            [taoensso.timbre :as timbre :refer [debug info]])
  (:import [java.util UUID]))

(defmulti create-io-task
  (fn [task-ids element parents children]
    (:onyx/type element)))

(defn only [coll]
  (when (next coll)
    (throw (ex-info "More than one element in collection, expected count of 1" {:coll coll})))
  (if-let [result (first coll)]
    result
    (throw (ex-info "Zero elements in collection, expected exactly one" {:coll coll}))))

(defn find-task [catalog task-name]
  (let [matches (filter #(= task-name (:onyx/name %)) catalog)]
    (only matches)))

(defn egress-ids-from-children [task-ids elements]
  (into {}
        (map (juxt identity task-ids)
             (map :onyx/name elements))))

(defn grouping-task? [task-map]
  (boolean (or (:onyx/group-by-fn task-map)
               (:onyx/group-by-key task-map))))

(defmulti create-task
  (fn [task-ids catalog task-name parents children-names]
    (:onyx/type (find-task catalog task-name))))

(defmethod create-task :default
  [task-ids catalog task-name parents children-names]
  (let [element (find-task catalog task-name)
        children (map (partial find-task catalog) children-names)]
    (create-io-task task-ids element parents children)))

(defn onyx-function-task [task-ids catalog task-name parents children-names]
  (let [element (find-task catalog task-name)
        children (map (partial find-task catalog) children-names)
        element-name (:onyx/name element)
        task-id (task-ids element-name)]
    {:id task-id
     :name element-name
     :ingress-ids (or (map :id parents) [])
     :egress-ids (egress-ids-from-children task-ids children)}))

(defmethod create-task :function
  [task-ids catalog task-name parents children-names]
  (onyx-function-task task-ids catalog task-name parents children-names))

(defmethod create-io-task :input
  [task-ids element parent children]
  {:id (task-ids (:onyx/name element))
   :name (:onyx/name element)
   :ingress-ids []
   :egress-ids (egress-ids-from-children task-ids children)})

(defmethod create-io-task :output
  [task-ids element parents children]
  (let [task-name (:onyx/name element)]
    {:id (task-ids task-name)
     :name task-name
     :ingress-ids (or (map :id parents) [])}))

(defn to-dependency-graph [workflow]
  (reduce (fn [g edge]
            (apply dep/depend g (reverse edge)))
          (dep/graph) workflow))

(defn remove-dupes [coll]
  (map last (vals (group-by :name coll))))

(defn gen-task-ids [nodes]
  (into {}
        (map (juxt identity (fn [_] (java.util.UUID/randomUUID)))
             nodes)))

(defn discover-tasks [catalog workflow]
  (let [dag (to-dependency-graph workflow)
        sorted-dag (dep/topo-sort dag)
        task-ids (gen-task-ids sorted-dag)]
    (remove-dupes
     (reduce
      (fn [tasks element]
        (let [parents (dep/immediate-dependencies dag element)
              children (dep/immediate-dependents dag element)
              parent-entries (filter #(some #{(:name %)} parents) tasks)]
          (conj tasks (create-task task-ids catalog element parent-entries children))))
      []
      sorted-dag))))

(ns onyx.static.planning
  (:require [com.stuartsierra.dependency :as dep]
            [taoensso.timbre :as timbre :refer [debug info]])
  (:import [java.util UUID]))

(defmulti create-io-task
  (fn [task-ids element parents children]
    (:onyx/type element)))

(defn only [coll]
  (when (next coll)
    (throw (ex-info "More than one element in collection, expected count of 1" {:coll coll})))
  (if-let [result (first coll)]
    result
    (throw (ex-info "Zero elements in collection, expected exactly one" {:coll coll}))))

(defn find-task [catalog task-name]
  (let [matches (filter #(= task-name (:onyx/name %)) catalog)]
    (only matches)))

(defn egress-ids-from-children [task-ids elements]
  (into {}
        (map (juxt identity task-ids)
             (map :onyx/name elements))))

(defn grouping-task? [task-map]
  (boolean (or (:onyx/group-by-fn task-map)
               (:onyx/group-by-key task-map))))

(defmulti create-task
  (fn [task-ids catalog task-name parents children-names]
    (:onyx/type (find-task catalog task-name))))

(defmethod create-task :default
  [task-ids catalog task-name parents children-names]
  (let [element (find-task catalog task-name)
        children (map (partial find-task catalog) children-names)]
    (create-io-task task-ids element parents children)))

(defn onyx-function-task [task-ids catalog task-name parents children-names]
  (let [element (find-task catalog task-name)
        children (map (partial find-task catalog) children-names)
        element-name (:onyx/name element)
        task-id (task-ids element-name)]
    {:id task-id
     :name element-name
     :ingress-ids (or (into {} (map (juxt :name :id) parents)) [])
     :egress-ids (egress-ids-from-children task-ids children)}))

(defmethod create-task :function
  [task-ids catalog task-name parents children-names]
  (onyx-function-task task-ids catalog task-name parents children-names))

(defmethod create-io-task :input
  [task-ids element parent children]
  {:id (task-ids (:onyx/name element))
   :name (:onyx/name element)
   :ingress-ids []
   :egress-ids (egress-ids-from-children task-ids children)})

(defmethod create-io-task :output
  [task-ids element parents children]
  (let [task-name (:onyx/name element)]
    {:id (task-ids task-name)
     :name task-name
     :ingress-ids (into {} (map (juxt :name :id) parents))
     :egress-ids []}))

(defn to-dependency-graph [workflow]
  (reduce (fn [g edge]
            (apply dep/depend g (reverse edge)))
          (dep/graph) workflow))

(defn remove-dupes [coll]
  (map last (vals (group-by :name coll))))

(defn gen-task-ids [nodes]
  (into {}
        (map (juxt identity (fn [_] (java.util.UUID/randomUUID)))
             nodes)))

(defn discover-tasks [catalog workflow]
  (let [dag (to-dependency-graph workflow)
        sorted-dag (dep/topo-sort dag)
        task-ids (gen-task-ids sorted-dag)]
    (remove-dupes
     (reduce
      (fn [tasks element]
        (let [parents (dep/immediate-dependencies dag element)
              children (dep/immediate-dependents dag element)
              parent-entries (filter #(some #{(:name %)} parents) tasks)]
          (conj tasks (create-task task-ids catalog element parent-entries children))))
      []
      sorted-dag))))

Make ingress-ids in serialized task look like egress-ids


(ns ^{:doc "Library of general purpose utility functions for Overtone
            internals."
      :author "Jeff Rose and Sam Aaron"}
  overtone.helpers.lib
  (:import [java.util ArrayList Collections]
           [java.util.concurrent TimeUnit TimeoutException]
           [java.io File])
  (:use [clojure.stacktrace]
        [clojure.pprint]
        [overtone.helpers doc]
        [overtone.helpers.system :only [windows-os?]]))

(defn to-str
  "If val is a keyword, return its name sans :, otherwise return val"
  [val]
  (if (keyword? val) (name val) val))

(defn to-float
  "If val is a number or bool, return its float equivalent otherwise
   return val"
  [val]
  (cond
    (number? val) (float val)
    (true? val)   (float 1)
    (false? val)  (float 0)
    :else val))

(defn to-keyword
  [val]
  (if (string? val)
    (keyword val)
    val))

(defn floatify-truth
  "Convert truth values to 0 or 1 using most of the standard Clojure
   truth semantics: everything that's not nil or false is 1 otherwise
   0. The exception to this allows for the preservation of number truth
   values, so an input of 0 maps to 0, and an input of 1 maps to 1."
  [obj]
  (let [obj (if (number? obj) (float obj) obj)
        truthy (float 1)
        falsey (float 0)]
    (cond
      (= truthy obj) truthy
      (= falsey obj) falsey
      obj truthy
      :else falsey)))

(defn stringify
  "Convert all keywords in col to strings without ':' prefixed."
  [col]
  (map to-str col))

(defn floatify
  "Convert all numbers in col to floats."
  [col]
  (map to-float col))

(defn keywordify
  "Convert all strings to keywords."
  [col]
  (map to-keyword col))

;; Now available in recent Clojure versions as of Nov. 29, 2009...
;;(defn byte-array [len]
;;  (make-array (. Byte TYPE) len))
(def BYTE-ARRAY (byte-array 1))

(defn byte-array? [obj]
  (= (type BYTE-ARRAY) (type obj)))

(defn type-checker [t]
  (fn [obj] (and (map? obj) (= (:type obj) t))))

(defn uuid
  "Creates a random, immutable UUID object that is comparable using the
  '=' function."
  [] (. java.util.UUID randomUUID))

(defn cpu-count
  "Get the number of CPUs on this machine."
  []
  (.availableProcessors (Runtime/getRuntime)))

(defn map-vals
  "Takes a map m and returns a new map with all of m's values mapped
   through f"
  [f m]
  (zipmap (keys m)
          (map f (vals m))))

(defn- map-entry [k v]
  (proxy [clojure.lang.IMapEntry] []
    (key [] k)
    (getKey [] k)
    (val [] v)
    (getValue [] v)))

(defn callable-map
  "Create a map-like datastructure which overrides it's behaviour when
   called as a fn from lookup to an arbitrary fn you specify at creation
   time."
  ([m fun] (callable-map m fun {}))
  ([m fun metadata]
     (proxy [clojure.lang.Associative
             clojure.lang.IFn
             clojure.lang.IObj
             clojure.lang.IMeta]
         []
       (count       [] (count m))
       (seq         [] (seq m))
       (cons        [[k v]] (callable-map (assoc m k v) fun metadata))
       (empty       [] {})
       (equiv       [o] (= o m))
       (containsKey [k] (contains? m k))
       (entryAt     [k] (map-entry k (get m k)))
       (assoc       [k v] (callable-map (assoc m k v) fun metadata))
       (valAt
         ([k] (get m k))
         ([k d] (get m k d)))
       (invoke      [& args] (apply fun args))
       (applyTo    ([args] (apply fun args)))
       (toString   [] (if-let [ts (::to-string metadata)]
                        (ts this)
                        "Callable Map"))
       (withMeta   [new-metadata] (callable-map m fun new-metadata))
       (meta       [] metadata))))

(defmacro defrecord-ifn
  "A helper macro for creating callable records with a var-args
   function.  It generates all arities of invoke, calling the function.
   Besides generating the clojure.lang.IFn implementation, you can
   declare any other implementations as you would normally with
   defrecord."
  [rec-name fields invoke_fn & body]
  `(defrecord ~rec-name ~fields
     ~@body
     clojure.lang.IFn
     ~@(map (fn [n]
              (let [args (for [i (range n)] (symbol (str "arg" i)))]
                (if (empty? args)
                  `(~'invoke [this#]
                             (~invoke_fn this#))
                  `(~'invoke [this# ~@args]
                             (~invoke_fn this# ~@args))))) (range 21))
     (~'applyTo [this# args#]
       (apply ~invoke_fn this# args#))))

(defn- syms-to-keywords [coll]
  (map #(if (symbol? %)
          (keyword %)
          %)
       coll))

(defn- keywords-to-syms [coll]
  (map #(if (keyword? %)
          (symbol (name %))
          %)
       coll))

(defn arg-mapper
  "Takes a list of args, expected arg names and map of defaults.
   Creates a map of arg names to args using the defaults as the starting
   point.

   The args should be passed in the order 'ordered params', 'keyword
   params' such as the following: [1 2 3 :d 4 :f 5] where 1 2 and 3 are
   ordered params and 4 and 5 are named params (associated with :d
   and :f respectively).

   If the expected args is the list [:a :b :c :d :f] then the resulting
   map will look as follows: {:a 1 :b 2 :c 3 :d 5 :f 5}. If the defaults
   contains extra keys, these will be merged in with any clashes being
   overridden with the result map, so if the default map is {:a 99 :h 2}
   the final output will be {:a 1 :b 2 :c 3 :d 4 :f 5 :h 2}.

   It is assumed that the values passed in as the args are *not*
   keywords."
  [args arg-names default-map]
  (loop [args args
         names arg-names
         arg-map default-map]
    (if (not (empty? args))
      (if (and
           (keyword? (first args))
           (even? (count args)))
        (merge arg-map (apply hash-map args))
        (recur (next args)
               (next names)
               (assoc arg-map
                 (first names)
                 (first args))))
      arg-map)))

(defmacro defunk [name docstring args & body]
  (let [arg-names (map first (partition 2 args))
        arg-keys (vec (map keyword arg-names))
        default-map (apply hash-map (syms-to-keywords args))]
    (let [arg-pairs (map #(str (first %) " " (second %)) (partition 2 args))
          arg-pairs-str (apply str (interpose ", " arg-pairs))
          arg-string (str "[" arg-pairs-str "]")
          indented-doc   (indented-str-block docstring 55 2)
          full-docstring (str arg-string "\n\n  " indented-doc)]
      `(defn ~name
         ~full-docstring
         [& args#]
         (let [{:keys [~@arg-names]}
               (arg-mapper args# ~arg-keys ~default-map)]
           ~@body)))))

(defn invert-map
  "Takes a map m and returns a new map that's keys are the m's vals and
   that's vals are m's keys. Assumes that m's keys and vals are both
   sets (i.e. don't contain any duplicates). If there are duplicate
   values in the map they will result in key collisions and a smaller
   result map.

   (invert-map {:a 1, :b 2, :c 3}) ;=> {1 :a, 2 :b, 3 :c}"
  [m]
  (apply hash-map (interleave (vals m) (keys m))))

(defn update-all
  "Update a value retrieved with the key k in each element of a seq of
   maps by applying f to the current value.

   (update-all [{:a 1} {:a 2}] :a inc) ;=> ({:a 2} {:a 3})
  "
  [maps k f]
  (map (fn [elem]
         (assoc elem k (f (get elem k))))
       maps))

(defn update-every-n
  "Update every nth element in a seq of maps, optionally offset from the
   start, by applying f to the current value.

   (update-every-n [{:a 1} {:a 2} {:a 3} {:a 4} {:a 5}] 2 1 :a #(* 10 %))

   ;=> ({:a 1} {:a 20} {:a 3} {:a 40} {:a 5})
  "
  ([maps n k f]
     (update-every-n maps n 0 k f))
  ([maps n offset k f]
     (concat
      (take offset maps)
      (map-indexed
       (fn [i elem]
         (if (zero? (mod i n))
           (assoc elem k (f (get elem k)))
           elem))
       maps))))

(def DEFAULT-PROMISE-TIMEOUT 5000)

(defn deref!
  "Read a future or promise waiting for timeout ms for it to be
   successfully dereferenced. Raises an exception if a timeout
   occurs. You may optionally pass a message explaining what you're
   currently doing whilst defef!ing which will be used to construct the
   TimeoutException."
  ([ref] (deref! ref DEFAULT-PROMISE-TIMEOUT ""))
  ([ref timeout-or-msg] (if (string? timeout-or-msg)
                          (deref! ref DEFAULT-PROMISE-TIMEOUT timeout-or-msg)
                          (deref! ref timeout-or-msg "")))
  ([ref timeout msg]
     (let [timeout-indicator (gensym "deref-timeout")
           res               (deref ref timeout timeout-indicator)]
       (if (= timeout-indicator res)
         (throw (TimeoutException. (str "deref! timeout error. Dereference took longer than " timeout " ms" (when-not (empty? msg) (str " whilst " msg)))))
         res))))

(defn stringify-map-vals
  "converts a map by running all its vals through str
  (or name if val is a keyword"
  [m]
  (into {} (map (fn [[k v]] [k (if (keyword? v) (name v) (str v))]) m)))

(defn- welcome-message
  [user-name]
  (let [opts [(str "Hello " user-name ", may this be the start of a beautiful music hacking session...")
              (str "Cometh the hour, cometh " user-name ", the overtone hacker.")
              (str "Hello " user-name ", may algorithmic beauty pour forth from your fingertips today.")
              (str "Hey " user-name ", I feel something magical is only just beyond the horizon...")
              (str "Hello " user-name ", just take a moment to pause and focus your creative powers...")
              (str "Hello " user-name ". Do you feel it? I do. Creativity is rushing through your veins today!")]]
    (rand-nth opts)))

(defn print-ascii-art-overtone-logo
  [user-name version-str]
  (println (str "
    _____                 __
   / __  /_  _____  _____/ /_____  ____  ___
  / / / / | / / _ \\/ ___/ __/ __ \\/ __ \\/ _ \\
 / /_/ /| |/ /  __/ /  / /_/ /_/ / / / /  __/
 \\____/ |___/\\___/_/   \\__/\\____/_/ /_/\\___/

   Collaborative Programmable Music. "version-str "

" (welcome-message user-name) "
")))

(defn normalize-ugen-name
  "Normalizes both SuperCollider and overtone-style names to squeezed
   lower-case.

  This produces strings that may be used to represent unique ugen keys
  that can be generated from both SC and Overtone names.

  (normalize-ugen-name \"SinOsc\")  ;=> \"sinosc\"
  (normalize-ugen-name \"sin-osc\") ;=> \"sinosc\""
  [n]
  (.replaceAll (.toLowerCase (str n)) "[-|_]" ""))

(defn overtone-ugen-name
  "A basic camelCase to with-dash name converter tuned to convert
   SuperCollider names to Overtone names. Most likely needs improvement.

  (overtone-ugen-name \"SinOsc\") ;=> \"sin-osc\""
  [n]
  (when-not (string? n)
    (throw (IllegalArgumentException. (str "Cannot convert non-string obj " (with-out-str (pr n)) " to an overtone ugen name"))))

  (let [n (.replaceAll n "([a-z])([A-Z])" "$1-$2")
        n (.replaceAll n "([a-z-])([0-9])([A-Z])" "$1$2-$3")
        n (.replaceAll n "([A-Z])([A-Z][a-z])" "$1-$2")
        n (.replaceAll n "_" "-")
        n (.toLowerCase n)]
    n))

(defn resolve-gen-name
  "If the gen is a cgen or ugen returns the :name otherwise returns name
   unchanged assuming it's a keyword."
  [gen]
  (if (and (associative? gen)
           (or (= :overtone.sc.machinery.ugen.fn-gen/ugen (:type gen))
               (= :overtone.sc.defcgen/cgen (:type gen))))
    (keyword (:name gen))
        gen))

(defn windows-sc-path
  "Returns a string representing the path for SuperCollider on Windows,
   or nil if not on Windows."
  []
  (when (windows-os?)
    (let [p-files-dir (System/getenv "PROGRAMFILES(X86)")
          p-files-dir (or p-files-dir (System/getenv "PROGRAMFILES"))
          p-files-dir (File. p-files-dir)
          p-files     (map str (.listFiles p-files-dir))
          sc-files    (filter #(.contains % "SuperCollider") p-files)
          recent-sc   (last (sort (seq sc-files)))]
      recent-sc)))

(defmacro branch
  "Expansion time branching. Takes a test-expression and a set of
  clauses of the following form:

  clauses => clause1 ... clauseN, default-clause*
  clause => test-constant result-expr
  default-clause* => result-expr

  Evaluates the test-expression 'e' and looks for a matching
  test-constant in the clauses. Expands to the result-expression of the
  matching clause or nil if no match is found and no default-expression
  is provided."
  [e & clauses]
  (let [default (when (odd? (count clauses))
                  (last clauses))
        clauses (if (odd? (count clauses))
                  (butlast clauses)
                  clauses)]
    (get (apply hash-map clauses)
         (eval e)
         default)))

(ns ^{:doc "Library of general purpose utility functions for Overtone
            internals."
      :author "Jeff Rose and Sam Aaron"}
  overtone.helpers.lib
  (:import [java.util ArrayList Collections]
           [java.util.concurrent TimeUnit TimeoutException]
           [java.io File])
  (:use [clojure.stacktrace]
        [clojure.pprint]
        [overtone.helpers doc]
        [overtone.helpers.system :only [windows-os?]]))

(defn to-str
  "If val is a keyword, return its name sans :, otherwise return val"
  [val]
  (if (keyword? val) (name val) val))

(defn to-float
  "If val is a number or bool, return its float equivalent otherwise
   return val"
  [val]
  (cond
    (number? val) (float val)
    (true? val)   (float 1)
    (false? val)  (float 0)
    :else val))

(defn to-keyword
  [val]
  (if (string? val)
    (keyword val)
    val))

(defn floatify-truth
  "Convert truth values to 0 or 1 using most of the standard Clojure
   truth semantics: everything that's not nil or false is 1 otherwise
   0. The exception to this allows for the preservation of number truth
   values, so an input of 0 maps to 0, and an input of 1 maps to 1."
  [obj]
  (let [obj (if (number? obj) (float obj) obj)
        truthy (float 1)
        falsey (float 0)]
    (cond
      (= truthy obj) truthy
      (= falsey obj) falsey
      obj truthy
      :else falsey)))

(defn stringify
  "Convert all keywords in col to strings without ':' prefixed."
  [col]
  (map to-str col))

(defn floatify
  "Convert all numbers in col to floats."
  [col]
  (map to-float col))

(defn keywordify
  "Convert all strings to keywords."
  [col]
  (map to-keyword col))

;; Now available in recent Clojure versions as of Nov. 29, 2009...
;;(defn byte-array [len]
;;  (make-array (. Byte TYPE) len))
(def BYTE-ARRAY (byte-array 1))

(defn byte-array? [obj]
  (= (type BYTE-ARRAY) (type obj)))

(defn type-checker [t]
  (fn [obj] (and (map? obj) (= (:type obj) t))))

(defn uuid
  "Creates a random, immutable UUID object that is comparable using the
  '=' function."
  [] (. java.util.UUID randomUUID))

(defn cpu-count
  "Get the number of CPUs on this machine."
  []
  (.availableProcessors (Runtime/getRuntime)))

(defn map-vals
  "Takes a map m and returns a new map with all of m's values mapped
   through f"
  [f m]
  (zipmap (keys m)
          (map f (vals m))))

(defn- map-entry [k v]
  (proxy [clojure.lang.IMapEntry] []
    (key [] k)
    (getKey [] k)
    (val [] v)
    (getValue [] v)))

(defn callable-map
  "Create a map-like datastructure which overrides it's behaviour when
   called as a fn from lookup to an arbitrary fn you specify at creation
   time."
  ([m fun] (callable-map m fun {}))
  ([m fun metadata]
     (proxy [clojure.lang.Associative
             clojure.lang.IFn
             clojure.lang.IObj
             clojure.lang.IMeta]
         []
       (count       [] (count m))
       (seq         [] (seq m))
       (cons        [[k v]] (callable-map (assoc m k v) fun metadata))
       (empty       [] {})
       (equiv       [o] (= o m))
       (containsKey [k] (contains? m k))
       (entryAt     [k] (map-entry k (get m k)))
       (assoc       [k v] (callable-map (assoc m k v) fun metadata))
       (valAt
         ([k] (get m k))
         ([k d] (get m k d)))
       (invoke      [& args] (apply fun args))
       (applyTo    ([args] (apply fun args)))
       (toString   [] (if-let [ts (::to-string metadata)]
                        (ts this)
                        "Callable Map"))
       (withMeta   [new-metadata] (callable-map m fun new-metadata))
       (meta       [] metadata))))

(defmacro defrecord-ifn
  "A helper macro for creating callable records with a var-args
   function.  It generates all arities of invoke, calling the function.
   Besides generating the clojure.lang.IFn implementation, you can
   declare any other implementations as you would normally with
   defrecord."
  [rec-name fields invoke_fn & body]
  `(defrecord ~rec-name ~fields
     ~@body
     clojure.lang.IFn
     ~@(map (fn [n]
              (let [args (for [i (range n)] (symbol (str "arg" i)))]
                (if (empty? args)
                  `(~'invoke [this#]
                             (~invoke_fn this#))
                  `(~'invoke [this# ~@args]
                             (~invoke_fn this# ~@args))))) (range 21))
     (~'applyTo [this# args#]
       (apply ~invoke_fn this# args#))))

(defn- syms-to-keywords [coll]
  (map #(if (symbol? %)
          (keyword %)
          %)
       coll))

(defn- keywords-to-syms [coll]
  (map #(if (keyword? %)
          (symbol (name %))
          %)
       coll))

(defn arg-mapper
  "Takes a list of args, expected arg names and map of defaults.
   Creates a map of arg names to args using the defaults as the starting
   point.

   The args should be passed in the order 'ordered params', 'keyword
   params' such as the following: [1 2 3 :d 4 :f 5] where 1 2 and 3 are
   ordered params and 4 and 5 are named params (associated with :d
   and :f respectively).

   If the expected args is the list [:a :b :c :d :f] then the resulting
   map will look as follows: {:a 1 :b 2 :c 3 :d 5 :f 5}. If the defaults
   contains extra keys, these will be merged in with any clashes being
   overridden with the result map, so if the default map is {:a 99 :h 2}
   the final output will be {:a 1 :b 2 :c 3 :d 4 :f 5 :h 2}.

   It is assumed that the values passed in as the args are *not*
   keywords."
  [args arg-names default-map]
  (loop [args args
         names arg-names
         arg-map default-map]
    (if (not (empty? args))
      (if (and
           (keyword? (first args))
           (even? (count args)))
        (merge arg-map (apply hash-map args))
        (recur (next args)
               (next names)
               (assoc arg-map
                 (first names)
                 (first args))))
      arg-map)))

(defmacro defunk [name docstring args & body]
  (let [arg-names      (map first (partition 2 args))
        arg-keys       (vec (map keyword arg-names))
        default-map    (apply hash-map (syms-to-keywords args))
        arg-pairs      (map #(str (first %) " " (second %)) (partition 2 args))
        arg-pairs-str  (apply str (interpose ", " arg-pairs))
        arg-string     (str "[" arg-pairs-str "]")
        indented-doc   (indented-str-block docstring 55 2)
        full-docstring (str arg-string "\n\n  " indented-doc)]
    `(defn ~name
       ~full-docstring
       [& args#]
       (let [{:keys [~@arg-names]}
             (arg-mapper args# ~arg-keys ~default-map)]
         ~@body))))

(defn invert-map
  "Takes a map m and returns a new map that's keys are the m's vals and
   that's vals are m's keys. Assumes that m's keys and vals are both
   sets (i.e. don't contain any duplicates). If there are duplicate
   values in the map they will result in key collisions and a smaller
   result map.

   (invert-map {:a 1, :b 2, :c 3}) ;=> {1 :a, 2 :b, 3 :c}"
  [m]
  (apply hash-map (interleave (vals m) (keys m))))

(defn update-all
  "Update a value retrieved with the key k in each element of a seq of
   maps by applying f to the current value.

   (update-all [{:a 1} {:a 2}] :a inc) ;=> ({:a 2} {:a 3})
  "
  [maps k f]
  (map (fn [elem]
         (assoc elem k (f (get elem k))))
       maps))

(defn update-every-n
  "Update every nth element in a seq of maps, optionally offset from the
   start, by applying f to the current value.

   (update-every-n [{:a 1} {:a 2} {:a 3} {:a 4} {:a 5}] 2 1 :a #(* 10 %))

   ;=> ({:a 1} {:a 20} {:a 3} {:a 40} {:a 5})
  "
  ([maps n k f]
     (update-every-n maps n 0 k f))
  ([maps n offset k f]
     (concat
      (take offset maps)
      (map-indexed
       (fn [i elem]
         (if (zero? (mod i n))
           (assoc elem k (f (get elem k)))
           elem))
       maps))))

(def DEFAULT-PROMISE-TIMEOUT 5000)

(defn deref!
  "Read a future or promise waiting for timeout ms for it to be
   successfully dereferenced. Raises an exception if a timeout
   occurs. You may optionally pass a message explaining what you're
   currently doing whilst defef!ing which will be used to construct the
   TimeoutException."
  ([ref] (deref! ref DEFAULT-PROMISE-TIMEOUT ""))
  ([ref timeout-or-msg] (if (string? timeout-or-msg)
                          (deref! ref DEFAULT-PROMISE-TIMEOUT timeout-or-msg)
                          (deref! ref timeout-or-msg "")))
  ([ref timeout msg]
     (let [timeout-indicator (gensym "deref-timeout")
           res               (deref ref timeout timeout-indicator)]
       (if (= timeout-indicator res)
         (throw (TimeoutException. (str "deref! timeout error. Dereference took longer than " timeout " ms" (when-not (empty? msg) (str " whilst " msg)))))
         res))))

(defn stringify-map-vals
  "converts a map by running all its vals through str
  (or name if val is a keyword"
  [m]
  (into {} (map (fn [[k v]] [k (if (keyword? v) (name v) (str v))]) m)))

(defn- welcome-message
  [user-name]
  (let [opts [(str "Hello " user-name ", may this be the start of a beautiful music hacking session...")
              (str "Cometh the hour, cometh " user-name ", the overtone hacker.")
              (str "Hello " user-name ", may algorithmic beauty pour forth from your fingertips today.")
              (str "Hey " user-name ", I feel something magical is only just beyond the horizon...")
              (str "Hello " user-name ", just take a moment to pause and focus your creative powers...")
              (str "Hello " user-name ". Do you feel it? I do. Creativity is rushing through your veins today!")]]
    (rand-nth opts)))

(defn print-ascii-art-overtone-logo
  [user-name version-str]
  (println (str "
    _____                 __
   / __  /_  _____  _____/ /_____  ____  ___
  / / / / | / / _ \\/ ___/ __/ __ \\/ __ \\/ _ \\
 / /_/ /| |/ /  __/ /  / /_/ /_/ / / / /  __/
 \\____/ |___/\\___/_/   \\__/\\____/_/ /_/\\___/

   Collaborative Programmable Music. "version-str "

" (welcome-message user-name) "
")))

(defn normalize-ugen-name
  "Normalizes both SuperCollider and overtone-style names to squeezed
   lower-case.

  This produces strings that may be used to represent unique ugen keys
  that can be generated from both SC and Overtone names.

  (normalize-ugen-name \"SinOsc\")  ;=> \"sinosc\"
  (normalize-ugen-name \"sin-osc\") ;=> \"sinosc\""
  [n]
  (.replaceAll (.toLowerCase (str n)) "[-|_]" ""))

(defn overtone-ugen-name
  "A basic camelCase to with-dash name converter tuned to convert
   SuperCollider names to Overtone names. Most likely needs improvement.

  (overtone-ugen-name \"SinOsc\") ;=> \"sin-osc\""
  [n]
  (when-not (string? n)
    (throw (IllegalArgumentException. (str "Cannot convert non-string obj " (with-out-str (pr n)) " to an overtone ugen name"))))

  (let [n (.replaceAll n "([a-z])([A-Z])" "$1-$2")
        n (.replaceAll n "([a-z-])([0-9])([A-Z])" "$1$2-$3")
        n (.replaceAll n "([A-Z])([A-Z][a-z])" "$1-$2")
        n (.replaceAll n "_" "-")
        n (.toLowerCase n)]
    n))

(defn resolve-gen-name
  "If the gen is a cgen or ugen returns the :name otherwise returns name
   unchanged assuming it's a keyword."
  [gen]
  (if (and (associative? gen)
           (or (= :overtone.sc.machinery.ugen.fn-gen/ugen (:type gen))
               (= :overtone.sc.defcgen/cgen (:type gen))))
    (keyword (:name gen))
        gen))

(defn windows-sc-path
  "Returns a string representing the path for SuperCollider on Windows,
   or nil if not on Windows."
  []
  (when (windows-os?)
    (let [p-files-dir (System/getenv "PROGRAMFILES(X86)")
          p-files-dir (or p-files-dir (System/getenv "PROGRAMFILES"))
          p-files-dir (File. p-files-dir)
          p-files     (map str (.listFiles p-files-dir))
          sc-files    (filter #(.contains % "SuperCollider") p-files)
          recent-sc   (last (sort (seq sc-files)))]
      recent-sc)))

(defmacro branch
  "Expansion time branching. Takes a test-expression and a set of
  clauses of the following form:

  clauses => clause1 ... clauseN, default-clause*
  clause => test-constant result-expr
  default-clause* => result-expr

  Evaluates the test-expression 'e' and looks for a matching
  test-constant in the clauses. Expands to the result-expression of the
  matching clause or nil if no match is found and no default-expression
  is provided."
  [e & clauses]
  (let [default (when (odd? (count clauses))
                  (last clauses))
        clauses (if (odd? (count clauses))
                  (butlast clauses)
                  clauses)]
    (get (apply hash-map clauses)
         (eval e)
         default)))

Fix formatting

Fix formatting


(ns aurora.compiler
  (:require [aurora.jsth :as jsth]
            [aurora.ast :as ast]
            [aurora.interpreter :as i]
            [aurora.util :refer [map!]])
  (:require-macros [aurora.macros :refer [for! check deftraced]]))

;; compiler

(let [next (atom 0)]
  (defn new-id []
    (if js/window.uuid
      (.replace (js/uuid) (js/RegExp. "-" "gi") "_")
      (swap! next inc))))

(deftraced id->value [id] [id]
  (check id)
  (symbol (str "value_" id)))

(deftraced id->cursor [id] [id]
  (check id)
  (symbol (str "cursor_" id)))

(deftraced id->temp [id] [id]
  (check id)
  (symbol (str "temp_" id)))

(deftraced ref->jsth [index x] [x]
  (case (:type x)
    :ref/id (id->value (:id x))
    :ref/js (symbol (:js x))
    (check false)))

(deftraced tag->jsth [index x] [x]
  `(cljs.core.keyword ~(:id x) ~(:name x)))

(deftraced data->value-jsth [index x] [x]
  (cond
   (= :tag (:type x)) (tag->jsth index x)
   (#{:ref/id :ref/js} (:type x)) (ref->jsth index x)
   (number? x) x
   (string? x) x
   (vector? x) `(cljs.core.PersistentVector.fromArray
                 ~(vec (map! #(data->value-jsth index %) x)))
   (map? x) `(cljs.core.PersistentHashMap.fromArrays
              ~(vec (map! #(data->value-jsth index %) (keys x)))
              ~(vec (map! #(data->value-jsth index %) (vals x))))
   :else (check false)))

(deftraced data->cursor-jsth [index x] [x]
  (if (= :ref/id (:type x))
    (id->cursor (:id x))
    nil))

(deftraced constant->jsth [index x id] [x id]
  (check (= :constant (:type x)))
  (let [data (:data x)]
    `(do
       (let! ~(id->value id) ~(data->value-jsth index data))
       (let! ~(id->cursor id) ~(data->cursor-jsth index data)))))

(deftraced js-data->jsth [index x] [x]
  (cond
   (nil? x) nil
   :else (data->value-jsth index x)))

(deftraced call->jsth [index x id] [x id]
  (case (:type (:ref x))
    :ref/id (let [temp (id->temp (new-id))]
              `(do
                 (let! ~temp (~(ref->jsth index (:ref x)) ~@(interleave (map! #(data->value-jsth index %) (:args x)) (map! #(data->cursor-jsth index %) (:args x)))))
                 (let! ~(id->value id) (get! ~temp 0))
                 (let! ~(id->cursor id) (get! ~temp 1))))
    :ref/js `(do
               (let! ~(id->value id) (~(ref->jsth index (:ref x)) ~@(map! #(js-data->jsth index %) (:args x))))
               (let! ~(id->cursor id) nil))
    (check false)))

(deftraced test->jsth [pred] [pred]
  `(if (not ~pred) (throw failure)))

(deftraced pattern->jsth [index x input] [x input]
  (cond
   (= :match/any (:type x)) `(do)
   (= :match/bind (:type x)) `(do
                                (let! ~(id->value (:id x)) ~(id->value input))
                                (let! ~(id->cursor (:id x)) ~(id->cursor input))
                                ~(pattern->jsth index (:pattern x) input))
   (= :tag (:type x)) (test->jsth `(= ~(tag->jsth index x) ~(id->value input)))
   (= :ref/id (:type x)) (test->jsth `(= ~(ref->jsth index x) ~(id->value input)))
   (number? x) (test->jsth `(= ~x ~(id->value input)))
   (string? x) (test->jsth `(= ~x ~(id->value input)))
   (vector? x) `(do
                  ~(test->jsth `(cljs.core.vector_QMARK_.call nil ~(id->value input)))
                  ~(test->jsth `(= ~(count x) (cljs.core.count.call nil ~(id->value input))))
                  ~@(for! [i (range (count x))]
                          (let [new-input (new-id)]
                            `(do
                               (let! ~(id->value new-input) (cljs.core.nth.call nil ~(id->value input) ~i))
                               (let! ~(id->cursor new-input) (? ~(id->cursor input) (cljs.core.conj.call nil ~(id->cursor input) i) nil))
                               ~(pattern->jsth index (nth x i) new-input)))))
   (map? x) `(do
               ~(test->jsth `(cljs.core.map_QMARK_.call nil ~(id->value input)))
               ~@(for! [k (keys x)]
                       (let [k-id (new-id)
                             new-input (new-id)]
                         `(do
                            (let! ~(id->temp k-id) ~(data->value-jsth index k))
                            ~(test->jsth `(cljs.core.contains_QMARK_.call nil ~(id->value input) ~(id->temp k-id)))
                            (let! ~(id->value new-input) (cljs.core.get.call nil ~(id->value input) ~(id->temp k-id)))
                            (let! ~(id->cursor new-input) (? ~(id->cursor input) (cljs.core.conj.call nil ~(id->cursor input) ~(id->temp k-id)) nil))
                            ~(pattern->jsth index (get x k) new-input)))))
   :else (check false)))

(deftraced action->jsth [index x id] [x id]
  (case (:type x)
    :call (call->jsth index x id)
    :constant (constant->jsth index x id)
    (check false)))

(deftraced guard->jsth [index x] [x]
  (check (= :call (:type x)))
  (let [temp (new-id)]
    `(do
       ~(call->jsth index x temp)
       ~(test->jsth (id->value temp)))))

(deftraced match->jsth [index x id] [x id]
  (check (= :match (:type x)))
  (let [input (new-id)]
    `(do
       ~(constant->jsth index {:type :constant :data (:arg x)} input)
       ~(reduce
         (fn [tail branch]
           (let [exception (new-id)]
             `(try
                (do
                  ~(pattern->jsth index (:pattern branch) input)
                  ~@(for! [guard (:guards branch)]
                          (guard->jsth index guard))
                  ~(action->jsth index (:action branch) id))
                (catch ~(id->temp exception)
                  (if (== ~(id->temp exception) failure)
                    ~tail
                    (throw ~(id->temp exception)))))))
         `(throw failure)
         (reverse (:branches x))))))

(deftraced step->jsth [index x id] [x id]
  (case (:type x)
    :call (call->jsth index x id)
    :constant (constant->jsth index x id)
    :match (match->jsth index x id)
    (check false)))

(deftraced page->jsth [index x id] [x id]
  (check (= :page (:type x)))
  `(fn ~(id->value id) ~(vec (interleave (map! id->value (:args x)) (map! id->cursor (:args x))))
     (do
       (let! stack notebook.stack)
       (let! frame {})
       (set! frame.id ~id)
       (set! frame.calls [])
       (set! frame.vars {})
       (stack.push frame)
       (set! notebook.stack frame.calls)
       ~@(for! [step-id (:steps x)]
               `(do
                  ~(step->jsth index (get index step-id) step-id)
                  (set! (.. frame.vars ~(id->value step-id)) ~(id->value step-id))
                  (set! (.. frame.vars ~(id->cursor step-id)) ~(id->cursor step-id))))
       (set! notebook.stack stack))
     ~(if (-> x :steps seq)
        `[~(-> x :steps last id->value) ~(-> x :steps last id->cursor)]
        [nil nil])
     ))

(deftraced notebook->jsth [index x] [x]
  (check (= :notebook (:type x)))
  `(fn nil []
     (do
       (let! notebook {})
       (let! failure "MatchFailure!")
       ~@(for! [page-id (:pages x)]
               `(do
                  ~(page->jsth index (get index page-id) page-id)
                  (set! (.. notebook ~(id->value page-id)) ~(id->value page-id)))))
     notebook))

;; runtime

(defn run-index [index id state]
  (let [jsth (notebook->jsth index (get index id))
        source (jsth/expression->string jsth)
        _ (println "###################")
        _ (println jsth)
        _ (println source)
        notebook (js/eval (str "(" source "());"))
        stack #js []]
    (aset notebook "next_state" state)
    (aset notebook "stack" stack)
    (try
      [(.value_root notebook state []) (.-next_state notebook) (aget stack 0)]
      (catch :default e
        [e (.-next_state notebook) (aget stack 0)]))))

(defn tick-example [index id state]
  (second (run-index index id state)))

(notebook->jsth ast/example-b (get ast/example-b "example_b"))

(run-index ast/example-b "example_b" {"a" 1 "b" 2})
(run-index ast/example-b "example_b" {"a" 1 "c" 2})
(run-index ast/example-b "example_b" {"a" 1 "b" "foo"})
(run-index ast/example-b "example_b" [1 "foo"])
(run-index ast/example-b "example_b" [1 2])

;; (run-index ast/example-c 0)
;; (run-index ast/example-c 1)
;; (run-index ast/example-c 7)
;; (run-index ast/example-c 10)

;; (run-index ast/example-d {"counter" 0})

;; (run-index ast/example-e {"counter" 0 "started_" "false"})

(ns aurora.compiler
  (:require [aurora.jsth :as jsth]
            [aurora.ast :as ast]
            [aurora.interpreter :as i]
            [aurora.util :refer [map!]])
  (:require-macros [aurora.macros :refer [for! check deftraced]]))

;; compiler

(let [next (atom 0)]
  (defn new-id []
    (if js/window.uuid
      (.replace (js/uuid) (js/RegExp. "-" "gi") "_")
      (swap! next inc))))

(deftraced id->value [id] [id]
  (check id)
  (symbol (str "value_" id)))

(deftraced id->cursor [id] [id]
  (check id)
  (symbol (str "cursor_" id)))

(deftraced id->temp [id] [id]
  (check id)
  (symbol (str "temp_" id)))

(deftraced ref->jsth [index x] [x]
  (case (:type x)
    :ref/id (id->value (:id x))
    :ref/js (symbol (:js x))
    (check false)))

(deftraced tag->jsth [index x] [x]
  `(cljs.core.keyword ~(:id x) ~(:name x)))

(deftraced data->value-jsth [index x] [x]
  (cond
   (= :tag (:type x)) (tag->jsth index x)
   (#{:ref/id :ref/js} (:type x)) (ref->jsth index x)
   (number? x) x
   (string? x) x
   (vector? x) `(cljs.core.PersistentVector.fromArray
                 ~(vec (map! #(data->value-jsth index %) x)))
   (map? x) `(cljs.core.PersistentHashMap.fromArrays
              ~(vec (map! #(data->value-jsth index %) (keys x)))
              ~(vec (map! #(data->value-jsth index %) (vals x))))
   :else (check false)))

(deftraced data->cursor-jsth [index x] [x]
  (if (= :ref/id (:type x))
    (id->cursor (:id x))
    nil))

(deftraced constant->jsth [index x id] [x id]
  (check (= :constant (:type x)))
  (let [data (:data x)]
    `(do
       (let! ~(id->value id) ~(data->value-jsth index data))
       (let! ~(id->cursor id) ~(data->cursor-jsth index data)))))

(deftraced js-data->jsth [index x] [x]
  (cond
   (nil? x) nil
   :else (data->value-jsth index x)))

(deftraced call->jsth [index x id] [x id]
  (case (:type (:ref x))
    :ref/id (let [temp (id->temp (new-id))]
              `(do
                 (let! ~temp (~(ref->jsth index (:ref x)) ~@(interleave (map! #(data->value-jsth index %) (:args x)) (map! #(data->cursor-jsth index %) (:args x)))))
                 (let! ~(id->value id) (get! ~temp 0))
                 (let! ~(id->cursor id) (get! ~temp 1))))
    :ref/js `(do
               (let! ~(id->value id) (~(ref->jsth index (:ref x)) ~@(map! #(js-data->jsth index %) (:args x))))
               (let! ~(id->cursor id) nil))
    (check false)))

(deftraced test->jsth [pred] [pred]
  `(if (not ~pred) (throw failure)))

(deftraced pattern->jsth [index x input] [x input]
  (cond
   (= :match/any (:type x)) `(do)
   (= :match/bind (:type x)) `(do
                                (let! ~(id->value (:id x)) ~(id->value input))
                                (let! ~(id->cursor (:id x)) ~(id->cursor input))
                                ~(pattern->jsth index (:pattern x) input))
   (= :tag (:type x)) (test->jsth `(= ~(tag->jsth index x) ~(id->value input)))
   (= :ref/id (:type x)) (test->jsth `(= ~(ref->jsth index x) ~(id->value input)))
   (number? x) (test->jsth `(= ~x ~(id->value input)))
   (string? x) (test->jsth `(= ~x ~(id->value input)))
   (vector? x) `(do
                  ~(test->jsth `(cljs.core.vector_QMARK_.call nil ~(id->value input)))
                  ~(test->jsth `(= ~(count x) (cljs.core.count.call nil ~(id->value input))))
                  ~@(for! [i (range (count x))]
                          (let [new-input (new-id)]
                            `(do
                               (let! ~(id->value new-input) (cljs.core.nth.call nil ~(id->value input) ~i))
                               (let! ~(id->cursor new-input) (? ~(id->cursor input) (cljs.core.conj.call nil ~(id->cursor input) i) nil))
                               ~(pattern->jsth index (nth x i) new-input)))))
   (map? x) `(do
               ~(test->jsth `(cljs.core.map_QMARK_.call nil ~(id->value input)))
               ~@(for! [k (keys x)]
                       (let [k-id (new-id)
                             new-input (new-id)]
                         `(do
                            (let! ~(id->temp k-id) ~(data->value-jsth index k))
                            ~(test->jsth `(cljs.core.contains_QMARK_.call nil ~(id->value input) ~(id->temp k-id)))
                            (let! ~(id->value new-input) (cljs.core.get.call nil ~(id->value input) ~(id->temp k-id)))
                            (let! ~(id->cursor new-input) (? ~(id->cursor input) (cljs.core.conj.call nil ~(id->cursor input) ~(id->temp k-id)) nil))
                            ~(pattern->jsth index (get x k) new-input)))))
   :else (check false)))

(deftraced action->jsth [index x id] [x id]
  (case (:type x)
    :call (call->jsth index x id)
    :constant (constant->jsth index x id)
    (check false)))

(deftraced guard->jsth [index x] [x]
  (check (= :call (:type x)))
  (let [temp (new-id)]
    `(do
       ~(call->jsth index x temp)
       ~(test->jsth (id->value temp)))))

(deftraced match->jsth [index x id] [x id]
  (check (= :match (:type x)))
  (let [input (new-id)]
    `(do
       ~(constant->jsth index {:type :constant :data (:arg x)} input)
       ~(reduce
         (fn [tail branch]
           (let [exception (new-id)]
             `(try
                (do
                  ~(pattern->jsth index (:pattern branch) input)
                  ~@(for! [guard (:guards branch)]
                          (guard->jsth index guard))
                  ~(action->jsth index (:action branch) id))
                (catch ~(id->temp exception)
                  (if (== ~(id->temp exception) failure)
                    ~tail
                    (throw ~(id->temp exception)))))))
         `(throw failure)
         (reverse (:branches x))))))

(deftraced step->jsth [index x id] [x id]
  (case (:type x)
    :call (call->jsth index x id)
    :constant (constant->jsth index x id)
    :match (match->jsth index x id)
    (check false)))

(deftraced page->jsth [index x id] [x id]
  (check (= :page (:type x)))
  `(fn ~(id->value id) ~(vec (interleave (map! id->value (:args x)) (map! id->cursor (:args x))))
     (do
       (let! stack notebook.stack)
       (let! frame {})
       (set! frame.id ~id)
       (set! frame.calls [])
       (set! frame.vars {})
       (stack.push frame)
       (set! notebook.stack frame.calls)
       ~@(for! [step-id (:steps x)]
               `(do
                  ~(step->jsth index (get index step-id) step-id)
                  (set! (.. frame.vars ~(id->value step-id)) ~(id->value step-id))
                  (set! (.. frame.vars ~(id->cursor step-id)) ~(id->cursor step-id))))
       (set! notebook.stack stack))
     ~(if (-> x :steps seq)
        `[~(-> x :steps last id->value) ~(-> x :steps last id->cursor)]
        [nil nil])
     ))

(deftraced notebook->jsth [index x] [x]
  (check (= :notebook (:type x)))
  `(fn nil []
     (do
       (let! notebook {})
       (let! failure "MatchFailure!")
       ;; TODO handle nil cursors in replace and append
       (fn value_replace [value_old cursor_old value_new cursor_new]
         (cljs.core.assoc_in.call nil notebook.next_state cursor_old value_new)
         ["ok" nil])
       (fn value_append [value_old cursor_old value_new cursor_new]
         (cljs.core.update_in.call nil notebook.next_state cursor_old cljs.core.conj value_new)
         ["ok" nil])
       ~@(for! [page-id (:pages x)]
               `(do
                  ~(page->jsth index (get index page-id) page-id)
                  (set! (.. notebook ~(id->value page-id)) ~(id->value page-id)))))
     notebook))

;; runtime

(defn run-index [index id state]
  (let [jsth (notebook->jsth index (get index id))
        source (jsth/expression->string jsth)
        _ (println "###################")
        _ (println jsth)
        _ (println source)
        notebook (js/eval (str "(" source "());"))
        stack #js []]
    (aset notebook "next_state" state)
    (aset notebook "stack" stack)
    (try
      [(.value_root notebook state []) (.-next_state notebook) (aget stack 0)]
      (catch :default e
        [e (.-next_state notebook) (aget stack 0)]))))

(defn tick-example [index id state]
  (second (run-index index id state)))

(notebook->jsth ast/example-b (get ast/example-b "example_b"))

(run-index ast/example-b "example_b" {"a" 1 "b" 2})
(run-index ast/example-b "example_b" {"a" 1 "c" 2})
(run-index ast/example-b "example_b" {"a" 1 "b" "foo"})
(run-index ast/example-b "example_b" [1 "foo"])
(run-index ast/example-b "example_b" [1 2])

;; (run-index ast/example-c 0)
;; (run-index ast/example-c 1)
;; (run-index ast/example-c 7)
;; (run-index ast/example-c 10)

;; (run-index ast/example-d {"counter" 0})

;; (run-index ast/example-e {"counter" 0 "started_" "false"})

Add replace and append

Add replace and append


(ns omnom.core
  (:require [om.core :as om :include-macros true]
            [om-tools.dom :as dom :include-macros true]
            [om-tools.core :refer-macros [defcomponent]]))

(def app-state
  (atom
   {:notes [{:x 100
             :y 50
             :w 200
             :h 150
             :content "# This is cool\nTite *tite* __tite__\n```js\nfunction add(a, b) {\n  return a + b;\n}\n```"}
            {:x 200
             :y 300
             :w 400
             :h 200
             :content "[Gooooogle](http://google.com)"}
            {:x 500
             :y 20
             :w 200
             :h 150
             :content "# Head\n## lines\n### are cool"}]}))

(defcomponent note-view
  [note owner]

  (init-state
   [_]
   {:mounted false})

  (render
   [_]
   (let [{:keys [x y w h content]} note]
     (when (om/get-state owner :mounted)
       (js/setTimeout #(.highlightBlock js/hljs (om/get-node owner)) 0))
     (dom/div {:class "note"

               :style
               {:left x :top y
                :width w :height h}

               :dangerouslySetInnerHTML {:__html (js/marked content)}})))

  (did-mount
   [_]
   (om/set-state! owner :mounted true)))

(defcomponent root-view
  [app owner]

  (render
   [_]
   (dom/div
    (om/build-all note-view (:notes app)))))

(defn main []
  (om/root
    root-view
    app-state
    {:target (. js/document (getElementById "app"))}))

(ns omnom.core
  (:require [om.core :as om :include-macros true]
            [om-tools.dom :as dom :include-macros true]
            [om-tools.core :refer-macros [defcomponent]]
            [goog.dom :as gdom]))

(def app-state
  (atom
   {:notes [{:x 100
             :y 50
             :w 200
             :content "# This is cool\nTite *tite* __tite__\n```js\nfunction add(a, b) {\n  return a + b;\n}\n```"}
            {:x 200
             :y 300
             :w 400
             :content "[Gooooogle](http://google.com)"}
            {:x 500
             :y 20
             :w 200
             :content "# Head\n## lines\n### are cool"}]}))

(defn on-next-tick
  [fn]
  (js/setTimeout fn 0)
  fn)

(defn highlight!
  [node]
  (on-next-tick
   #(let [pre-blocks (array-seq (gdom/getElementsByTagNameAndClass "pre" nil node))]
     (doall
      (map (fn [pre-block]
             (.highlightBlock js/hljs pre-block))
           pre-blocks)))))

(defcomponent note-view
  [note owner]

  (init-state
   [_]
   {:mounted false})

  (did-mount
   [_]
   (om/set-state! owner :mounted true))

  (render
   [_]
   (let [{:keys [x y w h content]} note]
     (when (om/get-state owner :mounted)
       (highlight! (om/get-node owner)))
     (dom/div {:class "note"
               :style {:left x :top y :width w}
               :dangerouslySetInnerHTML {:__html (js/marked content)}
               :on-click (fn []
                           (om/transact! note :content
                                         #(str % "\n```javascript\nfunction meta-random() {\n  return " (rand-int 2048) ";\n}\n```")))}))))

(defcomponent root-view
  [app owner]

  (render
   [_]
   (dom/div
    (om/build-all note-view (:notes app)))))

(defn main []
  (om/root
    root-view
    app-state
    {:target (. js/document (getElementById "app"))}))

Fix highlighting fn. Don't set a fixed note height


(set! *warn-on-reflection* true)

(ns ui-gallery.core
  (:require [play-clj.core :refer :all]
            [play-clj.ui :refer :all]))

(defscreen main-screen
  :on-show
  (fn [screen entities]
    (update! screen :camera (orthographic) :renderer (stage))
    (let [ui-skin (skin "uiskin.json")]
      (table [(dialog "I'm a dialog" ui-skin :text "This is my content")
              :row
              [(image "clojure.png")
               :width 100
               :height 100
               :space-top 20
               :space-bottom 20]
              :row
              (select-box ["I'm a select box"
                           "I am too"
                           "So am I"]
                          ui-skin)
              :row
              (check-box "I'm a check box" ui-skin)
              :row
              (label "I'm a label" ui-skin)
              :row
              (slider {:min 1 :max 10 :step 1} ui-skin)
              :row
              (text-button "I'm a button" ui-skin)
              :row
              (text-field "I'm a text field" ui-skin)]
             :align (align :center)
             :set-fill-parent true)))
  :on-render
  (fn [screen entities]
    (clear!)
    (render! screen entities))
  :on-resize
  (fn [screen entities]
    (height! screen 400)
    nil)
  :on-ui-changed
  (fn [screen entities]
    (println (:actor screen))))

(defgame ui-gallery
  :on-create
  (fn [this]
    (set-screen! this main-screen)))

(set! *warn-on-reflection* true)

(ns ui-gallery.core
  (:require [play-clj.core :refer :all]
            [play-clj.ui :refer :all]))

(defscreen main-screen
  :on-show
  (fn [screen entities]
    (update! screen :camera (orthographic) :renderer (stage))
    (let [ui-skin (skin "uiskin.json")]
      (table [[(image "clojure.png")
               :width 100
               :height 100
               :space-top 20
               :space-bottom 20]
              :row
              (select-box ["I'm a select box"
                           "I am too"
                           "So am I"]
                          ui-skin)
              :row
              (check-box "I'm a check box" ui-skin)
              :row
              (label "I'm a label" ui-skin)
              :row
              (slider {:min 1 :max 10 :step 1} ui-skin)
              :row
              (text-button "I'm a button" ui-skin)
              :row
              (text-field "I'm a text field" ui-skin)]
             :align (align :center)
             :set-fill-parent true)))
  :on-render
  (fn [screen entities]
    (clear!)
    (render! screen entities))
  :on-resize
  (fn [screen entities]
    (height! screen 400)
    nil)
  :on-ui-changed
  (fn [screen entities]
    (println (:actor screen))))

(defgame ui-gallery
  :on-create
  (fn [this]
    (set-screen! this main-screen)))

Remove dialog

Remove dialog