(ns akvo.lumen.lib.update
  (:require [akvo.lumen.protocols :as p]
            [akvo.lumen.lib.import.common :as import]
            [akvo.lumen.postgres :as postgres]
            [akvo.lumen.lib :as lib]
            [akvo.lumen.lib.env :as env]
            [akvo.lumen.lib.transformation.engine :as engine]
            [akvo.lumen.util :as util]
            [clojure.java.jdbc :as jdbc]
            [clojure.set :as set]
            [clojure.string :as string]
            [clojure.data :as d]
            [akvo.lumen.db.dataset-version :as db.dataset-version]
            [clojure.tools.logging :as log]
            [akvo.lumen.db.transformation :as db.transformation]
            [akvo.lumen.db.job-execution :as db.job-execution]
            [clojure.walk :as walk]))

(defn- undif-columns [tx columns]
  (let [columns (reduce #(assoc % (:columnName %2) %2) {} columns)
        cc (->> tx :changedColumns vals)
        res (reduce (fn [c {:keys [before after]}]
                      (if after
                        (assoc c (:columnName after) after)
                        (dissoc c (:columnName before))))
                    columns cc)]
    (vals res)))

(defn- columns-used-in-txs [importer-type initial-dataset-version latest-dataset-version]
  (if (contains? #{"LINK" "CSV"} importer-type)
    (set (-> initial-dataset-version :columns))
    (loop [columns (-> initial-dataset-version :columns walk/keywordize-keys)
           txs (-> latest-dataset-version :transformations walk/keywordize-keys)
           counter 1
           cols0 #{}]
      (let [tx (first txs)
            cols1 (apply conj cols0 (try
                                      (when-not (engine/avoidable-if-missing? tx)
                                        (flatten (engine/columns-used tx columns)))
                                      (catch Throwable e
                                        (if-let [ex-d (ex-data e)]
                                          (throw (ex-info (format "Transformation '%s' failed. %s" counter (.getMessage e))
                                                          ex-d))
                                          (throw e)))))]
        (if-let [txs (seq (next txs))]
          (recur (undif-columns tx columns) txs (inc counter) cols1)
          cols1)))))

(defn- successful-update
  "On a successful update we need to create a new dataset-version that
  is similar to the previous one, except with an updated :version and
  pointing to the new table-name, imported-table-name and columns. We
  also delete the previous table-name and imported-table-name so we
  don't accumulate unused datasets on each update."
  [tenant-conn job-execution-id dataset-id table-name imported-table-name old-dataset-version columns transformations]
  (jdbc/with-db-transaction [conn tenant-conn]
    (db.dataset-version/new-dataset-version conn {:id                  (str (util/squuid))
                                                  :dataset-id          dataset-id
                                                  :job-execution-id    job-execution-id
                                                  :table-name          table-name
                                                  :imported-table-name imported-table-name
                                                  :version             (inc (:version old-dataset-version))
                                                  :columns             columns
                                                  :transformations     transformations})
    (db.transformation/touch-dataset conn {:id dataset-id})
    (db.job-execution/update-successful-job-execution conn {:id job-execution-id})
    (db.transformation/drop-table tenant-conn {:table-name (:imported-table-name old-dataset-version)})
    (db.transformation/drop-table tenant-conn {:table-name (:table-name old-dataset-version)})))

(defn- failed-update [conn job-execution-id reason]
  (db.job-execution/update-failed-job-execution conn {:id job-execution-id
                                                      :reason [reason]}))

(defn compatible-columns-errors [dict imported-columns columns]
  (let [diff (d/diff imported-columns columns)
        diff-indexed (map (partial conj []) (range) (first diff))

        f0 (vec (filter (comp some? :id last)  diff-indexed))

        columns-id-problems (mapv (fn [[idx _]]
                                    (let [c (nth imported-columns idx nil)]
                                      {:title (get dict (:id c))
                                       :id (:id c)})) f0)
        idxs (set (map first f0))
        f1 (vec (->> diff-indexed
                     (filter (comp some? :type last))
                     (filter #((complement contains?) idxs (first %)))))

        column-types-problems (mapv (fn [[idx _]]
                                      (let [c (nth imported-columns idx nil)]
                                        {:title (get dict (:id c))
                                         :id (:id c)
                                         :imported-type (:type (nth (first diff) idx nil))
                                         :updated-type (:type (nth (second diff) idx nil))})) f1)]
    {:wrong-types column-types-problems :missed-columns columns-id-problems}))

(defn compatible-columns-error? [imported-columns* columns]
  (let [imported-columns (->> imported-columns*
                              (map (fn [column]
                                     (cond-> {:id (get column "columnName")
                                              :type (get column "type")}
                                       (contains? column "key") (assoc :key (boolean (get column "key")))))
                                   )
                              (mapv #(select-keys % [:id :type])))
        columns (->> columns
                     (mapv #(select-keys % [:id :type])
                           ;; https://github.com/akvo/akvo-lumen/issues/1923
                           ;; https://github.com/akvo/akvo-lumen/issues/1926
                           ;; remove this map conversion logic once #1926 is finished
                           ))
        columns-dict (reduce (fn [c x] (assoc c (:id x) x)) {} columns)
        imported-columns (map (fn [{:keys [id type] :as x}]
                                (cond
                                  (and (= type "text")
                                       (= "geoshape" (-> (get columns-dict id) :type))) (assoc x :type "geoshape")
                                  (and (= type "text")
                                       (= "option" (-> (get columns-dict id) :type))) (assoc x :type "option")
                                  :else x)) imported-columns)
        compatible? (set/subset? (set imported-columns) (set columns))]
    (if-not compatible?
      (do
        (log/warn :compatible-columns-errors :imported-columns imported-columns  :columns columns (d/diff imported-columns columns))
        (compatible-columns-errors (reduce (fn [c e] (assoc c (get e "columnName")
                                                            (get e "title") )) {} imported-columns*)
                                   imported-columns
                                   columns))
      nil)))

(defn- import-data-to-table [tenant-conn import-config dataset-id job-execution-id data-source-spec]
  (jdbc/with-db-transaction [conn tenant-conn]
    (let [environment (env/all conn)]
      (with-open [importer (import/dataset-importer (get data-source-spec "source")
                                                    (assoc import-config :environment environment))]
        (let [initial-dataset-version  (db.transformation/initial-dataset-version-to-update-by-dataset-id conn {:dataset-id dataset-id})
              latest-dataset-version (db.transformation/latest-dataset-version-by-dataset-id conn {:dataset-id dataset-id})
              imported-dataset-columns (vec (:columns initial-dataset-version))
              importer-columns         (p/columns importer)

              columns-used (columns-used-in-txs
                            (import/importer-type (get data-source-spec "source"))
                            initial-dataset-version
                            latest-dataset-version)
              imported-dataset-columns-checked (reduce (fn [c co]
                                                         (if (contains? columns-used (get co "columnName"))
                                                           (conj c co)
                                                           c)) [] imported-dataset-columns)]
          (if-let [compatible-errors (compatible-columns-error? imported-dataset-columns-checked
                                                                importer-columns)]
            (do
              (failed-update conn job-execution-id
                             (cond-> "Column mismatch"
                               (seq (:missed-columns compatible-errors))
                               (str ".\n Following columns are missed in new data version: " (:missed-columns compatible-errors))
                               (seq (:wrong-types compatible-errors))
                               (str ".\n Following columns have changed the column type in new data version: " (:wrong-types compatible-errors))))
              {:success? false})
            (let [table-name          (util/gen-table-name "ds")
                  imported-table-name (util/gen-table-name "imported")]
              (postgres/create-dataset-table conn table-name importer-columns)
              (doseq [record (map (comp postgres/coerce-to-sql import/extract-first-and-merge) (p/records importer))]
                (jdbc/insert! conn table-name record))
              (db.job-execution/clone-data-table conn {:from-table table-name
                                                       :to-table   imported-table-name}
                                                 {}
                                                 {:transaction? false})
              (let [coerce-column-fn (fn [{:keys [title id type key multipleId multipleType groupName groupId] :as column}]
                                       (cond-> {"type" type
                                                "title" title
                                                "columnName" id
                                                "groupName" groupName
                                                "groupId" groupId
                                                "sort" nil
                                                "direction" nil
                                                "hidden" false}
                                         key           (assoc "key" (boolean key))
                                         multipleType (assoc "multipleType" multipleType)
                                         multipleId   (assoc "multipleId" multipleId)))]
                {:success? true
                 :table-name table-name :imported-table-name imported-table-name
                 :importer-columns (mapv coerce-column-fn importer-columns) :imported-dataset-columns imported-dataset-columns
                 :latest-dataset-version latest-dataset-version}))))))))

(defn update-dataset [tenant-conn caddisfly import-config error-tracker dataset-id data-source-id data-source-spec]
  (if-let [current-tx-job (db.transformation/pending-transformation-job-execution tenant-conn {:dataset-id dataset-id})]
    (lib/bad-request {:message "A running transformation still exists, please wait to update this dataset ..."})
    (let [job-execution-id (str (util/squuid))]
     (db.job-execution/insert-dataset-update-job-execution tenant-conn {:id job-execution-id
                                                                        :data-source-id data-source-id
                                                                        :dataset-id dataset-id})
     (future
       (try
         (let [{:keys [table-name imported-table-name
                       importer-columns imported-dataset-columns
                       latest-dataset-version success?]}  (import-data-to-table tenant-conn
                                                                                import-config
                                                                                dataset-id
                                                                                job-execution-id
                                                                                data-source-spec)]
           (when success?
             (let [{:keys [columns transformations]} (engine/apply-dataset-transformations-on-table tenant-conn
                                                                                caddisfly
                                                                                dataset-id
                                                                                (:transformations latest-dataset-version)
                                                                                table-name
                                                                                importer-columns
                                                                                imported-dataset-columns)]
               (successful-update tenant-conn job-execution-id dataset-id table-name imported-table-name latest-dataset-version columns transformations))))
         (catch Exception e
           (failed-update tenant-conn job-execution-id (.getMessage e))
           (p/track error-tracker e)
           (log/error e))))
     (lib/ok {"updateId" job-execution-id}))))

(ns akvo.lumen.lib.update
  (:require [akvo.lumen.protocols :as p]
            [akvo.lumen.lib.import.common :as import]
            [akvo.lumen.postgres :as postgres]
            [akvo.lumen.lib :as lib]
            [akvo.lumen.lib.env :as env]
            [akvo.lumen.lib.transformation.engine :as engine]
            [akvo.lumen.lib.import.data-groups :as import.data-groups]
            [akvo.lumen.util :as util]
            [clojure.java.jdbc :as jdbc]
            [clojure.set :as set]
            [clojure.string :as string]
            [clojure.data :as d]
            [akvo.lumen.db.dataset-version :as db.dataset-version]
            [clojure.tools.logging :as log]
            [akvo.lumen.db.data-group :as db.data-group]
            [akvo.lumen.db.transformation :as db.transformation]
            [akvo.lumen.db.job-execution :as db.job-execution]
            [clojure.walk :as walk]))

(defn- undif-columns [tx columns]
  (let [columns (reduce #(assoc % (:columnName %2) %2) {} columns)
        cc (->> tx :changedColumns vals)
        res (reduce (fn [c {:keys [before after]}]
                      (if after
                        (assoc c (:columnName after) after)
                        (dissoc c (:columnName before))))
                    columns cc)]
    (vals res)))

(defn- columns-used-in-txs [importer-type initial-dataset-version latest-dataset-version]
  (if (contains? #{"LINK" "CSV"} importer-type)
    (set (-> initial-dataset-version :columns))
    (loop [columns (-> initial-dataset-version :columns walk/keywordize-keys)
           txs (-> latest-dataset-version :transformations walk/keywordize-keys)
           counter 1
           cols0 #{}]
      (let [tx (first txs)
            cols1 (apply conj cols0 (try
                                      (when-not (engine/avoidable-if-missing? tx)
                                        (flatten (engine/columns-used tx columns)))
                                      (catch Throwable e
                                        (if-let [ex-d (ex-data e)]
                                          (throw (ex-info (format "Transformation '%s' failed. %s" counter (.getMessage e))
                                                          ex-d))
                                          (throw e)))))]
        (if-let [txs (seq (next txs))]
          (recur (undif-columns tx columns) txs (inc counter) cols1)
          cols1)))))

(defn- successful-update
  "On a successful update we need to create a new dataset-version that
  is similar to the previous one, except with an updated :version and
  pointing to the new table-name, imported-table-name and columns. We
  also delete the previous table-name and imported-table-name so we
  don't accumulate unused datasets on each update."
  [tenant-conn job-execution-id dataset-id table-name imported-table-name old-dataset-version columns transformations]
  (jdbc/with-db-transaction [conn tenant-conn]
    (db.dataset-version/new-dataset-version conn {:id                  (str (util/squuid))
                                                  :dataset-id          dataset-id
                                                  :job-execution-id    job-execution-id
                                                  :table-name          table-name
                                                  :imported-table-name imported-table-name
                                                  :version             (inc (:version old-dataset-version))
                                                  :columns             columns
                                                  :transformations     transformations})
    (db.transformation/touch-dataset conn {:id dataset-id})
    (db.job-execution/update-successful-job-execution conn {:id job-execution-id})
    (db.transformation/drop-table tenant-conn {:table-name (:imported-table-name old-dataset-version)})
    (db.transformation/drop-table tenant-conn {:table-name (:table-name old-dataset-version)})))

(defn- failed-update [conn job-execution-id reason]
  (db.job-execution/update-failed-job-execution conn {:id job-execution-id
                                                      :reason [reason]}))

(defn compatible-columns-errors [dict imported-columns columns]
  (let [diff (d/diff imported-columns columns)
        diff-indexed (map (partial conj []) (range) (first diff))

        f0 (vec (filter (comp some? :id last)  diff-indexed))

        columns-id-problems (mapv (fn [[idx _]]
                                    (let [c (nth imported-columns idx nil)]
                                      {:title (get dict (:id c))
                                       :id (:id c)})) f0)
        idxs (set (map first f0))
        f1 (vec (->> diff-indexed
                     (filter (comp some? :type last))
                     (filter #((complement contains?) idxs (first %)))))

        column-types-problems (mapv (fn [[idx _]]
                                      (let [c (nth imported-columns idx nil)]
                                        {:title (get dict (:id c))
                                         :id (:id c)
                                         :imported-type (:type (nth (first diff) idx nil))
                                         :updated-type (:type (nth (second diff) idx nil))})) f1)]
    {:wrong-types column-types-problems :missed-columns columns-id-problems}))

(defn compatible-columns-error? [imported-columns* columns]
  (let [imported-columns (->> imported-columns*
                              (map (fn [column]
                                     (cond-> {:id (get column "columnName")
                                              :type (get column "type")}
                                       (contains? column "key") (assoc :key (boolean (get column "key")))))
                                   )
                              (mapv #(select-keys % [:id :type])))
        columns (->> columns
                     (mapv #(select-keys % [:id :type])
                           ;; https://github.com/akvo/akvo-lumen/issues/1923
                           ;; https://github.com/akvo/akvo-lumen/issues/1926
                           ;; remove this map conversion logic once #1926 is finished
                           ))
        columns-dict (reduce (fn [c x] (assoc c (:id x) x)) {} columns)
        imported-columns (map (fn [{:keys [id type] :as x}]
                                (cond
                                  (and (= type "text")
                                       (= "geoshape" (-> (get columns-dict id) :type))) (assoc x :type "geoshape")
                                  (and (= type "text")
                                       (= "option" (-> (get columns-dict id) :type))) (assoc x :type "option")
                                  :else x)) imported-columns)
        compatible? (set/subset? (set imported-columns) (set columns))]
    (if-not compatible?
      (do
        (log/warn :compatible-columns-errors :imported-columns imported-columns  :columns columns (d/diff imported-columns columns))
        (compatible-columns-errors (reduce (fn [c e] (assoc c (get e "columnName")
                                                            (get e "title") )) {} imported-columns*)
                                   imported-columns
                                   columns))
      nil)))

(defn- import-data-to-table [tenant-conn import-config dataset-id job-execution-id data-source-spec]
  (jdbc/with-db-transaction [conn tenant-conn]
    (let [environment (env/all conn)]
      (with-open [importer (import/dataset-importer (get data-source-spec "source")
                                                    (assoc import-config :environment environment))]
        (let [initial-dataset-version  (db.transformation/initial-dataset-version-to-update-by-dataset-id conn {:dataset-id dataset-id})
              latest-dataset-version (db.transformation/latest-dataset-version-by-dataset-id conn {:dataset-id dataset-id})
              imported-dataset-columns (vec (:columns initial-dataset-version))
              importer-columns         (p/columns importer)

              columns-used (columns-used-in-txs
                            (import/importer-type (get data-source-spec "source"))
                            initial-dataset-version
                            latest-dataset-version)
              imported-dataset-columns-checked (reduce (fn [c co]
                                                         (if (contains? columns-used (get co "columnName"))
                                                           (conj c co)
                                                           c)) [] imported-dataset-columns)]
          (if-let [compatible-errors (compatible-columns-error? imported-dataset-columns-checked
                                                                importer-columns)]
            (do
              (failed-update conn job-execution-id
                             (cond-> "Column mismatch"
                               (seq (:missed-columns compatible-errors))
                               (str ".\n Following columns are missed in new data version: " (:missed-columns compatible-errors))
                               (seq (:wrong-types compatible-errors))
                               (str ".\n Following columns have changed the column type in new data version: " (:wrong-types compatible-errors))))
              {:success? false})
            (let [table-name          (util/gen-table-name "ds")
                  imported-table-name (util/gen-table-name "imported")]
              (postgres/create-dataset-table conn table-name importer-columns)
              (doseq [record (map (comp postgres/coerce-to-sql import/extract-first-and-merge) (p/records importer))]
                (jdbc/insert! conn table-name record))
              (db.job-execution/clone-data-table conn {:from-table table-name
                                                       :to-table   imported-table-name}
                                                 {}
                                                 {:transaction? false})
              (let [coerce-column-fn (fn [{:keys [title id type key multipleId multipleType groupName groupId] :as column}]
                                       (cond-> {"type" type
                                                "title" title
                                                "columnName" id
                                                "groupName" groupName
                                                "groupId" groupId
                                                "sort" nil
                                                "direction" nil
                                                "hidden" false}
                                         key           (assoc "key" (boolean key))
                                         multipleType (assoc "multipleType" multipleType)
                                         multipleId   (assoc "multipleId" multipleId)))]
                {:success? true
                 :table-name table-name :imported-table-name imported-table-name
                 :importer-columns (mapv coerce-column-fn importer-columns) :imported-dataset-columns imported-dataset-columns
                 :latest-dataset-version latest-dataset-version}))))))))

(defn- import-data-to-table-2 [tenant-conn import-config dataset-id job-execution-id data-source-spec]
  (jdbc/with-db-transaction [conn tenant-conn]
    (let [environment (env/all conn)]
      (with-open [importer (import/datagroups-importer (get data-source-spec "source")
                                                       (assoc import-config :environment environment))]
        (let [initial-dataset-version  (let [dsv (db.transformation/initial-dataset-version-2-to-update-by-dataset-id conn {:dataset-id dataset-id})]
                                         (assoc dsv :columns (db.data-group/get-all-columns conn {:dataset-version-id (:id dsv)})))
              latest-dataset-version (let [dsv (db.transformation/latest-dataset-version-2-by-dataset-id conn {:dataset-id dataset-id})]
                                       (assoc dsv :columns (db.data-group/get-all-columns conn {:dataset-version-id (:id dsv)})))
              imported-dataset-columns (vec (:columns initial-dataset-version))
              importer-columns         (p/columns importer)
              columns-used (columns-used-in-txs
                            (import/importer-type (get data-source-spec "source"))
                            initial-dataset-version
                            latest-dataset-version)
              imported-dataset-columns-checked (reduce (fn [c co]
                                                         (if (contains? columns-used (get co "columnName"))
                                                           (conj c co)
                                                           c)) [] imported-dataset-columns)]
          (if-let [compatible-errors (compatible-columns-error? imported-dataset-columns-checked
                                                                importer-columns)]
            (do
              (failed-update conn job-execution-id
                             (cond-> "Column mismatch"
                               (seq (:missed-columns compatible-errors))
                               (str ".\n Following columns are missed in new data version: " (:missed-columns compatible-errors))
                               (seq (:wrong-types compatible-errors))
                               (str ".\n Following columns have changed the column type in new data version: " (:wrong-types compatible-errors))))
              {:success? false})
            (let [{:keys [columns group-table-names]} (import.data-groups/adapt-columns importer-columns)]
              (doseq [[groupId cols] (group-by :groupId columns)]
                (postgres/create-dataset-table conn (get group-table-names groupId) cols))
              (doseq [response (take import/rows-limit (p/records importer))]
                (doseq [[groupId iterations] response]
                  (let [table-name (get group-table-names groupId)]
                    (jdbc/insert-multi! conn table-name (mapv postgres/coerce-to-sql iterations)))))
              (doseq [[groupId cols] (group-by :groupId columns)]
                (let [table-name (get group-table-names groupId)]
                  (db.job-execution/clone-data-table conn {:from-table table-name
                                                           :to-table (util/table-name-to-imported table-name)}
                                                     {}
                                                     {:transaction? false})))
              (let [coerce-column-fn (fn [{:keys [title id type key multipleId multipleType groupName groupId] :as column}]
                                       (cond-> {"type" type
                                                "title" title
                                                "columnName" id
                                                "groupName" groupName
                                                "groupId" groupId
                                                "sort" nil
                                                "direction" nil
                                                "hidden" false}
                                         key           (assoc "key" (boolean key))
                                         multipleType (assoc "multipleType" multipleType)
                                         multipleId   (assoc "multipleId" multipleId)))]
                {:success? true
                 :group-table-names group-table-names
                 :importer-columns (mapv coerce-column-fn columns)
                 :imported-dataset-columns imported-dataset-columns
                 :latest-dataset-version latest-dataset-version}))))))))

(defn update-dataset [tenant-conn caddisfly import-config error-tracker dataset-id data-source-id data-source-spec]
  (if-let [current-tx-job (db.transformation/pending-transformation-job-execution tenant-conn {:dataset-id dataset-id})]
    (lib/bad-request {:message "A running transformation still exists, please wait to update this dataset ..."})
    (let [job-execution-id (str (util/squuid))]
     (db.job-execution/insert-dataset-update-job-execution tenant-conn {:id job-execution-id
                                                                        :data-source-id data-source-id
                                                                        :dataset-id dataset-id})
     (future
       (try
         (if (get (env/all tenant-conn) "data-groups")
           (let [{:keys [group-table-names
                         importer-columns imported-dataset-columns
                         latest-dataset-version success?] :as foo} (import-data-to-table-2 tenant-conn
                                                                                import-config
                                                                                dataset-id
                                                                                job-execution-id
                                                                                data-source-spec)]
             (throw  (ex-info "foo" foo))
             #_(when success?
               (let [{:keys [columns transformations]}
                     (engine/apply-dataset-transformations-on-table-2 tenant-conn
                                                                      caddisfly
                                                                      dataset-id
                                                                      (:transformations latest-dataset-version)
                                                                      table-name
                                                                      importer-columns
                                                                      imported-dataset-columns)]
                 (successful-update-2 tenant-conn job-execution-id dataset-id table-name imported-table-name latest-dataset-version columns transformations))))
           (let [{:keys [table-name imported-table-name
                         importer-columns imported-dataset-columns
                         latest-dataset-version success?]}  (import-data-to-table tenant-conn
                                                                                import-config
                                                                                dataset-id
                                                                                job-execution-id
                                                                                data-source-spec)]
             (when success?
               (let [{:keys [columns transformations]} (engine/apply-dataset-transformations-on-table tenant-conn
                                                                                caddisfly
                                                                                dataset-id
                                                                                (:transformations latest-dataset-version)
                                                                                table-name
                                                                                importer-columns
                                                                                imported-dataset-columns)]
                 (successful-update tenant-conn job-execution-id dataset-id table-name imported-table-name latest-dataset-version columns transformations)))))
         (catch Exception e
           (failed-update tenant-conn job-execution-id (.getMessage e))
           (p/track error-tracker e)
           (log/error e))))
     (lib/ok {"updateId" job-execution-id}))))

[#3083] Add data-groups support for update/import-data-to-table


(ns overtone.studio.midi
  #^{:author "Sam Aaron and Jeff Rose"
     :doc "A high level MIDI API for sending and receiving messages with
           external MIDI devices and automatically hooking into
           Overtone's event system." }
  (:use [overtone.sc.dyn-vars]
        [overtone.at-at :only (mk-pool every)]
        [overtone.libs event counters]
        [overtone.sc.defaults :only [INTERNAL-POOL]]
        [overtone.helpers.system :only [mac-os?]]
        [overtone.config.store :only [config-get]]
        )
  (:require [overtone.config.log :as log]
            [overtone.midi :as midi]))

(defonce midi-control-agents* (atom {}))
(defonce poly-players* (atom {}))

(declare connected-midi-devices)
(declare connected-midi-receivers)

(defn midi-mk-full-device-key
  "Returns a unique key for the specific device. In the case of multiple
   identical devices, the final integer of the key, dev-num, will be
   different to ensure key uniqueness.

   Is able to handle either a connected MIDI device stored in this
   namespace via or a raw MIDI device map from overtone.midi. "
  [dev]
  (or (::full-device-key dev)
      (let [dev-num (or (::dev-num dev)
                        (::dev-num (get (connected-midi-devices) (:device dev)))
                        -1)]
        [:midi-device (dev :vendor) (dev :name) (dev :description) dev-num])))

(defn- midi-find-connected
  [search devs-or-recvrs]
  (let [filter-pred (fn [dev]
                      (let [key-as-str (str (midi-mk-full-device-key dev))]
                        (if (= java.util.regex.Pattern (type search))
                          (re-find search key-as-str)
                          (.contains key-as-str search))))]
    (filter filter-pred devs-or-recvrs)))

(defn midi-find-connected-devices
  "Returns a list of connected MIDI devices where the full device key
   either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (midi-find-connected search (connected-midi-devices)))

(defn midi-find-connected-receivers
  "Returns a list of connected MIDI receivers where the full device key
   either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (midi-find-connected search (connected-midi-receivers)))

(defn midi-find-connected-device
  "Returns the first connected MIDI device found where the full device
   key either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (first (midi-find-connected-devices search)))

(defn midi-find-connected-receiver
  "Returns the first connected MIDI receiver found where the full device
   key either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (first (midi-find-connected-receivers search)))

(defn midi-mk-full-device-event-key
  "Creates the device-specific part of the key used for events generated
  by incoming MIDI messages."
  [dev command]
  (concat (midi-mk-full-device-key dev) [command]))

(defn midi-mk-full-control-event-key
  "Creates the full key used for events generated by incoming MIDI
  messages. Using this key can allow you to detect events from specific
  devices rather than just general control events."
  [dev command control-id]
  (concat (midi-mk-full-device-event-key dev command) [control-id]))

(defn midi-device-keys
  "Return a list of device event keys for the available MIDI devices"
  []
  (map midi-mk-full-device-key (vals (connected-midi-devices))))

(defn- midi-control-handler
  [state-atom handler mapping msg]
  (let [[ctl-name scale-fn] (get mapping (:note msg))
        ctl-val  (scale-fn (:velocity msg))]
    (swap! state-atom assoc ctl-name ctl-val)
    (handler ctl-name ctl-val)))

(defn midi-inst-controller
  "Create a midi instrument controller for manipulating the parameters of an instrument
  using an external device.  Requires an atom to store the state of the parameters, a
  handler that will be called each time a parameter is modified, and a mapping table to
  specify how midi control messages should manipulate the parameters.

  (def ding-mapping
    {22 [:attack     #(* 0.3 (/ % 127.0))]
     23 [:decay      #(* 0.6 (/ % 127.0))]
     24 [:sustain    #(/ % 127.0)]
     25 [:release    #(/ % 127.0)]})

  (def ding-state (atom {}))

  (midi-inst-controller ding-state (partial ctl ding) ding-mapping)
  "
  [state-atom handler mapping]
  (let [ctl-key (keyword (gensym 'control-change))]
    (on-event [:midi :control-change]
              #(midi-control-handler state-atom handler mapping %)
              ctl-key)))

(defn midi-player-stop
  ([]
     (remove-event-handler [::midi-poly-player :midi :note-on])
     (remove-event-handler [::midi-poly-player :midi :note-off]))
  ([player-or-key]
     (if (keyword? player-or-key)
       (midi-player-stop (get @poly-players* player-or-key))
       (let [player player-or-key]
         (when-not (= :overtone.studio.midi-player/midi-poly-player (type player))
           (throw (IllegalArgumentException. (str "Expected a midi-poly-player. Got: " (prn-str (type player))))))
         (remove-event-handler (:on-key player))
         (remove-event-handler (:off-key player))
         (reset! (:playing? player) false)
         (swap! poly-players* dissoc (:player-key player))
         player))))

(defn midi-capture-next-control-input
  "Returns a simple map representing next modified controller. Will
  block the current thread until a new MIDI control-change event is
  received.

  Useful for detecting controller information. If the argument with-key?
  is set to true, the full event key will be associated with the
  resulting map."
  ([] (midi-capture-next-control-input false))
  ([with-key?]
     (let [p (promise)]
       (oneshot-event [:midi :control-change]
                      (fn [msg]
                        (let [{controller :data1 val :data2} msg
                              device-name                    (get-in msg [:device :name])
                              res {:controller controller :value val}
                              res (if with-key?
                                    (assoc res :key (midi-mk-full-device-event-key (:device msg) :control-change))
                                    res)]

                          (deliver p res)))
                      ::print-next-control-input)
       @p)))

(defn midi-capture-next-controller-key
  "Returns a vector representing the unique key for the next modified
  controller."
  []
  (:key (midi-capture-next-control-input true)))

(defn midi-capture-next-controller-control-key
  "Returns a vector representing the unique key for the specific control
  of the next modified controller. This is the key used for controller
  specific MIDI events."
  []
  (let [next-input (midi-capture-next-control-input true)]
    (vec (concat (:key next-input) [(:controller next-input)]))))

(defn midi-mk-control-key-keyword
  [prefix control-key]
  (keyword (str prefix control-key)))

(defn- mk-control-key-keyword-for-agent
  [control-key]
  (midi-mk-control-key-keyword "overtone.studio.midi/update-agent-for-control-" control-key))

(defn midi-agent-for-control
  "Returns an agent representing the current value of a
  controller-specific control identified by a fully-qualified MIDI event
  key such as that generated by midi-mk-full-control-event-key. If the
  agent doesn't exist, it is created and cached. Subsequent calls with
  the same control-key will return the same agent.

  Agents are used because the event to update them can be safely handled
  synchronously (with on-sync-event) without watchers being able to
  block the thread generating the MIDI events. This also means that
  incoming events are sent to the agent in the correct order whereas if
  the thread pool were used (via on-event), the incoming events may be
  arbitrarily ordered."
  [control-key]
  (let [control-agents (swap! midi-control-agents*
                              (fn [prev]
                                (if (get prev control-key)
                                  prev
                                  (let [new-control-agent (agent 0)]
                                    (on-sync-event control-key
                                                   (fn [msg]
                                                     (send new-control-agent
                                                           (fn [old-val]
                                                             (:data2 msg))))
                                                   (mk-control-key-keyword-for-agent control-key))
                                    (assoc prev control-key new-control-agent)))))]
    (get control-agents control-key)))

(defn- handle-incoming-midi-event
  "Place incoming midi-event onto the global event stream."
  [dev msg & [ts]]
  (let [command       (:command msg)
        data2-f       (float (/ (:data2 msg) 127))
        msg           (assoc msg :data2-f data2-f :velocity-f data2-f)
        dev-key       (midi-mk-full-device-key dev)
        dev-event-key (midi-mk-full-device-event-key dev command)
        msg           (assoc msg :dev-key dev-key)]
    (event [:midi command] msg)
    (event (midi-mk-full-device-key dev) msg)
    (event (midi-mk-full-control-event-key dev command (:data1 msg)) msg)
    (event dev-event-key msg)))

(defn- handle-incoming-midi-sysex
  "Place incoming midi sysex message onto the global event stream."
  [dev msg & [ts]]
  (let [dev-key (midi-mk-full-device-key dev)
        msg     (assoc msg :dev-key dev-key)]
    (event (midi-mk-full-device-key dev) :sysex msg)))

(defn- remove-duplicate-devices
  "Removes all duplicate devices, where a duplicate is defined as a
   device map with the same :device value."
  [devs]
  (vals (into {} (map (fn [dev] [(:device dev) dev]) devs))))

(defn- detect-midi-devices
  "Returns a set of MIDI device maps filtered to remove unwanted devices
   such as the Java Real Time Sequencer and duplicates"
  []
  (let [devs   (midi/midi-sources)
        devs   (remove-duplicate-devices devs)
        devs   (map #(assoc % ::dev-num (next-id
                                         (str "overtone.studio.midi - device - "
                                              (:vendor %)
                                              (:name %)
                                              (:description %))))
                    devs)
        devs   (map #(assoc % ::full-device-key (midi-mk-full-device-key %)) devs)]
    devs))

(defn- detect-midi-receivers
  []
  (let [rcvs   (midi/midi-sinks)
        rcvs   (remove-duplicate-devices rcvs)
        rcvs   (map #(assoc % ::dev-num (next-id
                                         (str "overtone.studio.midi - receiver - "
                                              (:vendor %)
                                              (:name %)
                                              (:description %))))
                    rcvs)

        rcvs   (map #(assoc % ::full-device-key (midi-mk-full-device-key %)) rcvs)]
    rcvs))

(defn- add-listener-handles!
  "Adds listener handles to send incoming messages to Overtone's event
   stream. Devices that a handler can't be added to are dropped. Returns
   a filtered and modified sequence of device maps"
  [devs]
  (doall (filter
          (fn [dev]
            (try
              (midi/midi-handle-events (midi/midi-in dev)
                                  #(handle-incoming-midi-event dev %1)
                                  #(handle-incoming-midi-sysex dev %1))
              true
              (catch Exception e
                (log/warn "Can't listen to midi device: " dev "\n" e)
                false)))
          devs)))

(defonce ^:private connected-midi-devices*
  (-> (detect-midi-devices) add-listener-handles!))

(defonce ^:private connected-midi-receivers*
  (map midi/midi-out (detect-midi-receivers)))

(defn connected-midi-devices
  "Returns a sequence of device maps for all 'connected' MIDI
   devices. By device, we mean a MIDI unit that is capable of sending
   messages (such as a MIDI piano). By connected, we mean that Overtone
   is aware of the device and has added event handlers to emit incoming
   messages from the device as unique events.

   This currently returns a list which was created and cached at boot
   time. Therefore, devices connected after boot will not be
   available. We are considering work-arounds to this issue for a future
   release."
  []
  connected-midi-devices*)

(defn connected-midi-receivers
  "Returns a sequence of device maps for all 'connected' MIDI
   receivers. By receiver, we mean a MIDI unit that is capable of
   receiving messages. By connected, we mean that Overtone is aware of
   the device.

   This currently returns a list which was created and cached at boot
   time. Therefore, devices connected after boot will not be
   available. We are considering work-arounds to this issue for a future
   release."
  []
  connected-midi-receivers*)

(defn midi-device-num
  "Returns the device number for the specified MIDI device"
  [dev]
  (::dev-num dev))

(defn midi-full-device-key
  "Returns the full device key for the specified MIDI device"
  [dev]
  (::full-device-key dev))

(defn midi-sysex
  "Send a midi System Exclusive msg made up of the bytes in byte-seq
   byte-array, sequence of integers, longs or a byte-string to the
   receiver.  If a byte string is specified, must only contain bytes
   encoded as hex values.  Commas, spaces, and other whitespace is
   ignored.

   See connected-midi-receivers for a full list of available receivers."
  [rcv byte-seq]
  (midi/midi-sysex rcv byte-seq))

(defn midi-control
  "Send a MIDI control msg to the receiver. See connected-midi-receivers
   for a full list of available receivers."
  ([rcv ctl-num val]
     (midi/midi-control rcv ctl-num val))
  ([rcv ctl-num val channel]
     (midi/midi-control rcv ctl-num val channel)))

(defn midi-note-on
  "Send a MIDI note on msg to the receiver. See connected-midi-receivers
   for a full listof available receivers."
  ([rcv note-num vel]
     (midi/midi-note-on rcv note-num vel))
  ([rcv note-num vel channel]
     (midi/midi-note-on rcv note-num vel channel)))

(defn midi-note-off
  "Send a MIDI note off msg to the receiver. See connected-midi-receivers
   for a full list of available receivers."
  ([rcv note-num]
     (midi/midi-note-off rcv note-num))
  ([rcv note-num channel]
     (midi/midi-note-off rcv note-num channel)))

(defn midi-note
  "Send a midi on/off msg pair to the receiver. The off message will be
   sent dur ms after the on message resulting in the note being 'played'
   for dur ms.

   See connected-midi-receivers for a full list of available receivers."
  ([rcv note-num vel dur]
     (midi/midi-note rcv note-num vel dur))
  ([rcv note-num vel dur channel]
     (midi/midi-note rcv note-num vel dur channel)))

(ns overtone.studio.midi
  #^{:author "Sam Aaron and Jeff Rose"
     :doc "A high level MIDI API for sending and receiving messages with
           external MIDI devices and automatically hooking into
           Overtone's event system." }
  (:use [overtone.sc.dyn-vars]
        [overtone.at-at :only (mk-pool every)]
        [overtone.libs event counters]
        [overtone.sc.defaults :only [INTERNAL-POOL]]
        [overtone.helpers.system :only [mac-os?]]
        [overtone.config.store :only [config-get]]
        )
  (:require [overtone.config.log :as log]
            [overtone.midi :as midi]))

(defonce midi-control-agents* (atom {}))
(defonce poly-players* (atom {}))

(declare connected-midi-devices)
(declare connected-midi-receivers)

(defn midi-mk-full-device-key
  "Returns a unique key for the specific device. In the case of multiple
   identical devices, the final integer of the key, dev-num, will be
   different to ensure key uniqueness.

   Is able to handle either a connected MIDI device stored in this
   namespace via or a raw MIDI device map from overtone.midi. "
  [dev]
  (or (::full-device-key dev)
      (let [dev-num (or (::dev-num dev)
                        (::dev-num (get (connected-midi-devices) (:device dev)))
                        -1)]
        [:midi-device (dev :vendor) (dev :name) (dev :description) dev-num])))

(defn- midi-find-connected
  [search devs-or-recvrs]
  (let [filter-pred (fn [dev]
                      (let [key-as-str (str (midi-mk-full-device-key dev))]
                        (if (= java.util.regex.Pattern (type search))
                          (re-find search key-as-str)
                          (.contains key-as-str search))))]
    (filter filter-pred devs-or-recvrs)))

(defn midi-find-connected-devices
  "Returns a list of connected MIDI devices where the full device key
   either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (midi-find-connected search (connected-midi-devices)))

(defn midi-find-connected-receivers
  "Returns a list of connected MIDI receivers where the full device key
   either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (midi-find-connected search (connected-midi-receivers)))

(defn midi-find-connected-device
  "Returns the first connected MIDI device found where the full device
   key either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (first (midi-find-connected-devices search)))

(defn midi-find-connected-receiver
  "Returns the first connected MIDI receiver found where the full device
   key either contains the search string or matches the search regexp
   depending on the type of parameter supplied"
  [search]
  (first (midi-find-connected-receivers search)))

(defn midi-mk-full-device-event-key
  "Creates the device-specific part of the key used for events generated
  by incoming MIDI messages."
  [dev command]
  (concat (midi-mk-full-device-key dev) [command]))

(defn midi-mk-full-control-event-key
  "Creates the full key used for events generated by incoming MIDI
  messages. Using this key can allow you to detect events from specific
  devices rather than just general control events."
  [dev command control-id]
  (concat (midi-mk-full-device-event-key dev command) [control-id]))

(defn midi-device-keys
  "Return a list of device event keys for the available MIDI devices"
  []
  (map midi-mk-full-device-key (vals (connected-midi-devices))))

(defn- midi-control-handler
  [state-atom handler mapping msg]
  (let [[ctl-name scale-fn] (get mapping (:note msg))
        ctl-val  (scale-fn (:velocity msg))]
    (swap! state-atom assoc ctl-name ctl-val)
    (handler ctl-name ctl-val)))

(defn midi-inst-controller
  "Create a midi instrument controller for manipulating the parameters of an instrument
  using an external device.  Requires an atom to store the state of the parameters, a
  handler that will be called each time a parameter is modified, and a mapping table to
  specify how midi control messages should manipulate the parameters.

  (def ding-mapping
    {22 [:attack     #(* 0.3 (/ % 127.0))]
     23 [:decay      #(* 0.6 (/ % 127.0))]
     24 [:sustain    #(/ % 127.0)]
     25 [:release    #(/ % 127.0)]})

  (def ding-state (atom {}))

  (midi-inst-controller ding-state (partial ctl ding) ding-mapping)
  "
  [state-atom handler mapping]
  (let [ctl-key (keyword (gensym 'control-change))]
    (on-event [:midi :control-change]
              #(midi-control-handler state-atom handler mapping %)
              ctl-key)))

(defn midi-player-stop
  ([]
     (remove-event-handler [::midi-poly-player :midi :note-on])
     (remove-event-handler [::midi-poly-player :midi :note-off]))
  ([player-or-key]
     (if (keyword? player-or-key)
       (midi-player-stop (get @poly-players* player-or-key))
       (let [player player-or-key]
         (when-not (= :overtone.studio.midi-player/midi-poly-player (type player))
           (throw (IllegalArgumentException. (str "Expected a midi-poly-player. Got: " (prn-str (type player))))))
         (remove-event-handler (:on-key player))
         (remove-event-handler (:off-key player))
         (reset! (:playing? player) false)
         (swap! poly-players* dissoc (:player-key player))
         player))))

(defn midi-capture-next-control-input
  "Returns a simple map representing next modified controller. Will
  block the current thread until a new MIDI control-change event is
  received.

  Useful for detecting controller information. If the argument with-key?
  is set to true, the full event key will be associated with the
  resulting map."
  ([] (midi-capture-next-control-input false))
  ([with-key?]
     (let [p (promise)]
       (oneshot-event [:midi :control-change]
                      (fn [msg]
                        (let [{controller :data1 val :data2} msg
                              device-name                    (get-in msg [:device :name])
                              res {:controller controller :value val}
                              res (if with-key?
                                    (assoc res :key (midi-mk-full-device-event-key (:device msg) :control-change))
                                    res)]

                          (deliver p res)))
                      ::print-next-control-input)
       @p)))

(defn midi-capture-next-controller-key
  "Returns a vector representing the unique key for the next modified
  controller."
  []
  (:key (midi-capture-next-control-input true)))

(defn midi-capture-next-controller-control-key
  "Returns a vector representing the unique key for the specific control
  of the next modified controller. This is the key used for controller
  specific MIDI events."
  []
  (let [next-input (midi-capture-next-control-input true)]
    (vec (concat (:key next-input) [(:controller next-input)]))))

(defn midi-mk-control-key-keyword
  [prefix control-key]
  (keyword (str prefix control-key)))

(defn- mk-control-key-keyword-for-agent
  [control-key]
  (midi-mk-control-key-keyword "overtone.studio.midi/update-agent-for-control-" control-key))

(defn midi-agent-for-control
  "Returns an agent representing the current value of a
  controller-specific control identified by a fully-qualified MIDI event
  key such as that generated by midi-mk-full-control-event-key. If the
  agent doesn't exist, it is created and cached. Subsequent calls with
  the same control-key will return the same agent.

  Agents are used because the event to update them can be safely handled
  synchronously (with on-sync-event) without watchers being able to
  block the thread generating the MIDI events. This also means that
  incoming events are sent to the agent in the correct order whereas if
  the thread pool were used (via on-event), the incoming events may be
  arbitrarily ordered."
  [control-key]
  (let [control-agents (swap! midi-control-agents*
                              (fn [prev]
                                (if (get prev control-key)
                                  prev
                                  (let [new-control-agent (agent 0)]
                                    (on-sync-event control-key
                                                   (fn [msg]
                                                     (send new-control-agent
                                                           (fn [old-val]
                                                             (:data2 msg))))
                                                   (mk-control-key-keyword-for-agent control-key))
                                    (assoc prev control-key new-control-agent)))))]
    (get control-agents control-key)))

(defn- handle-incoming-midi-event
  "Place incoming midi-event onto the global event stream."
  [dev msg & [ts]]
  (let [command       (:command msg)
        data2-f       (float (/ (:data2 msg) 127))
        msg           (assoc msg :data2-f data2-f :velocity-f data2-f)
        dev-key       (midi-mk-full-device-key dev)
        dev-event-key (midi-mk-full-device-event-key dev command)
        msg           (assoc msg :dev-key dev-key)]
    (event [:midi command] msg)
    (event (midi-mk-full-device-key dev) msg)
    (event (midi-mk-full-control-event-key dev command (:data1 msg)) msg)
    (event dev-event-key msg)))

(defn- handle-incoming-midi-sysex
  "Place incoming midi sysex message onto the global event stream."
  [dev msg & [ts]]
  (let [dev-key (midi-mk-full-device-key dev)
        msg     (assoc msg :dev-key dev-key)]
    (event (midi-mk-full-device-key dev) :sysex msg)))

(defn- remove-duplicate-devices
  "Removes all duplicate devices, where a duplicate is defined as a
   device map with the same :device value."
  [devs]
  (vals (into {} (map (fn [dev] [(:device dev) dev]) devs))))

(defn- detect-midi-devices
  "Returns a set of MIDI device maps filtered to remove unwanted devices
   such as the Java Real Time Sequencer and duplicates"
  []
  (let [devs   (midi/midi-sources)
        devs   (remove-duplicate-devices devs)
        devs   (map #(assoc % ::dev-num (next-id
                                         (str "overtone.studio.midi - device - "
                                              (:vendor %)
                                              (:name %)
                                              (:description %))))
                    devs)
        devs   (map #(assoc % ::full-device-key (midi-mk-full-device-key %)) devs)]
    devs))

(defn- detect-midi-receivers
  []
  (let [rcvs   (midi/midi-sinks)
        rcvs   (remove-duplicate-devices rcvs)
        rcvs   (map #(assoc % ::dev-num (next-id
                                         (str "overtone.studio.midi - receiver - "
                                              (:vendor %)
                                              (:name %)
                                              (:description %))))
                    rcvs)

        rcvs   (map #(assoc % ::full-device-key (midi-mk-full-device-key %)) rcvs)]
    rcvs))

(defn- add-listener-handles!
  "Adds listener handles to send incoming messages to Overtone's event
   stream. Devices that a handler can't be added to are dropped. Returns
   a filtered and modified sequence of device maps"
  [devs]
  (doall (filter
          (fn [dev]
            (try
              (midi/midi-handle-events (midi/midi-in dev)
                                  #(handle-incoming-midi-event dev %1)
                                  #(handle-incoming-midi-sysex dev %1))
              true
              (catch Exception e
                (log/warn "Can't listen to midi device: " dev "\n" e)
                false)))
          devs)))

(defonce ^:private connected-midi-devices*
  (-> (detect-midi-devices) add-listener-handles!))

(defonce ^:private connected-midi-receivers*
  (map midi/midi-out (detect-midi-receivers)))

(defn connected-midi-devices
  "Returns a sequence of device maps for all 'connected' MIDI
   devices. By device, we mean a MIDI unit that is capable of sending
   messages (such as a MIDI piano). By connected, we mean that Overtone
   is aware of the device and has added event handlers to emit incoming
   messages from the device as unique events.

   This currently returns a list which was created and cached at boot
   time. Therefore, devices connected after boot will not be
   available. We are considering work-arounds to this issue for a future
   release."
  []
  connected-midi-devices*)

(defn connected-midi-receivers
  "Returns a sequence of device maps for all 'connected' MIDI
   receivers. By receiver, we mean a MIDI unit that is capable of
   receiving messages. By connected, we mean that Overtone is aware of
   the device.

   This currently returns a list which was created and cached at boot
   time. Therefore, devices connected after boot will not be
   available. We are considering work-arounds to this issue for a future
   release."
  []
  connected-midi-receivers*)

(defn midi-device-num
  "Returns the device number for the specified MIDI device"
  [dev]
  (::dev-num dev))

(defn midi-full-device-key
  "Returns the full device key for the specified MIDI device"
  [dev]
  (::full-device-key dev))

(defn midi-sysex
  "Send a midi System Exclusive msg made up of the bytes in byte-seq
   byte-array, sequence of integers, longs or a byte-string to the
   receiver.  If a byte string is specified, must only contain bytes
   encoded as hex values.  Commas, spaces, and other whitespace is
   ignored.

   See connected-midi-receivers for a full list of available receivers."
  [rcv byte-seq]
  (midi/midi-sysex rcv byte-seq))

(defn midi-control
  "Send a MIDI control msg to the receiver. See connected-midi-receivers
   for a full list of available receivers."
  ([rcv ctl-num val]
     (midi/midi-control rcv ctl-num val))
  ([rcv ctl-num val channel]
     (midi/midi-control rcv ctl-num val channel)))

(defn midi-note-on
  "Send a MIDI note on msg to the receiver. See connected-midi-receivers
   for a full list of available receivers."
  ([rcv note-num vel]
     (midi/midi-note-on rcv note-num vel))
  ([rcv note-num vel channel]
     (midi/midi-note-on rcv note-num vel channel)))

(defn midi-note-off
  "Send a MIDI note off msg to the receiver. See connected-midi-receivers
   for a full list of available receivers."
  ([rcv note-num]
     (midi/midi-note-off rcv note-num))
  ([rcv note-num channel]
     (midi/midi-note-off rcv note-num channel)))

(defn midi-note
  "Send a midi on/off msg pair to the receiver. The off message will be
   sent dur ms after the on message resulting in the note being 'played'
   for dur ms.

   See connected-midi-receivers for a full list of available receivers."
  ([rcv note-num vel dur]
     (midi/midi-note rcv note-num vel dur))
  ([rcv note-num vel dur channel]
     (midi/midi-note rcv note-num vel dur channel)))

fix missing space

fix missing space


(ns chocolatier.engine.components.collidable
  (:require [chocolatier.utils.logging :as log]
            [chocolatier.engine.ces :as ces]))

(defn exp
  "Raise x to the exponent of n"
  [x n]
  (reduce * (repeat n x)))

(defn halve
  "Divide n by 2"
  [n]
  (/ n 2))

(defn circle-collision?
  "Basic circle collision detection. Returns true if x and y
   are colliding.

   Two circles are colliding if distance between the center
   points is less than the sum of the radii."
  [x1 y1 r1 x2 y2 r2]
  (<= (+ (exp (- x2 x1) 2) (exp (- y2 y1) 2))
      (exp (+ r1 r2) 2)))

(defn collision?
  "Compare two entities future position to see if they are colliding.
   Returns a boolean of whether the two entities are colliding."
  [e1 e2]
  (if (and (seq e1) (seq e2))
    (let [key-list [:pos-x :pos-y
                    :offset-x :offset-y
                    :height :width
                    :hit-radius]
          [x1 y1 off-x1 off-y1 h1 w1 r1] (map #(% e1) key-list)
          [x2 y2 off-x2 off-y2 h2 w2 r2] (map #(% e2) key-list)
          ;; The hit circles are drawn around the center of the entity
          ;; by halving the height and width
          [center-x1 center-y1] (map + [x1 y1] (map halve [w1 h1]))
          [center-x2 center-y2] (map + [x2 y2] (map halve [w2 h2]))
          ;; Apply offsets of where the two entities will be
          [adj-x1 adj-y1] (map + [center-x1 center-y1] [off-x1 off-y1])
          [adj-x2 adj-y2] (map + [center-x2 center-y2] [off-x2 off-y2])
          colliding? (circle-collision? adj-x1 adj-y1 r1 adj-x2 adj-y2 r2)]
      colliding?)
    false))

(defn include-collidable-entities
  "State parsing function. Returns a vector of component-state
   positions of all collidable entities and their id, component-id and this entity-id"
  [state component-id entity-id]
  (let [entity-ids (ces/entities-with-component (:entities state) component-id)
        ;; Only want the renderable component state as that has the
        ;; actual sprites with real positions
        ;; Add on the id of the entity
        entities (map #(assoc (ces/get-component-state state :renderable %) :id %)
                      entity-ids)
        component-state (ces/get-component-state state component-id entity-id)]
    [entities component-state component-id entity-id]))

(defmulti check-collisions
  "Returns updated component state and collision events when colliding"
  (fn [entities component-state component-id entity-id] entity-id))

(defmethod check-collisions :default
  [entities component-state component-id entity-id]
  component-state)

(defmethod check-collisions :player1
  [entities component-state component-id entity-id]
  (let [player (first (filter #(= (:id %) entity-id) entities))
        ;; Exclude the player from collection of collidable entities
        filtered-entities (filter #(not= (:id %) entity-id) entities)
        collisions (doall (for [e filtered-entities] (collision? player e)))
        ;; In order to have a collision the collisions seq must not be
        ;; empty and must have a falsey value
        colliding? (and (every? boolean collisions) (seq collisions))]
    (if colliding?
      (do (log/debug "Colliding!!!")
          [component-state [[:collision entity-id {:colliding? true}]]])
      component-state)))

(ns chocolatier.engine.components.collidable
  (:require [chocolatier.utils.logging :as log]
            [chocolatier.engine.ces :as ces]))

(defn exp
  "Raise x to the exponent of n"
  [x n]
  (reduce * (repeat n x)))

(defn halve
  "Divide n by 2"
  [n]
  (/ n 2))

(defn circle-collision?
  "Basic circle collision detection. Returns true if x and y
   are colliding.

   Two circles are colliding if distance between the center
   points is less than the sum of the radii."
  [x1 y1 r1 x2 y2 r2]
  (<= (+ (exp (- x2 x1) 2) (exp (- y2 y1) 2))
      (exp (+ r1 r2) 2)))

(defn collision?
  "Compare two entities future position to see if they are colliding.
   Returns a boolean of whether the two entities are colliding."
  [e1 e2]
  (if (and (seq e1) (seq e2))
    (let [key-list [:pos-x :pos-y
                    :offset-x :offset-y
                    :height :width
                    :hit-radius]
          [x1 y1 off-x1 off-y1 h1 w1 r1] (map #(% e1) key-list)
          [x2 y2 off-x2 off-y2 h2 w2 r2] (map #(% e2) key-list)
          ;; The hit circles are drawn around the center of the entity
          ;; by halving the height and width
          [center-x1 center-y1] (map + [x1 y1] (map halve [w1 h1]))
          [center-x2 center-y2] (map + [x2 y2] (map halve [w2 h2]))
          ;; Apply offsets of where the two entities will be
          [adj-x1 adj-y1] (map + [center-x1 center-y1] [off-x1 off-y1])
          [adj-x2 adj-y2] (map + [center-x2 center-y2] [off-x2 off-y2])
          colliding? (circle-collision? adj-x1 adj-y1 r1 adj-x2 adj-y2 r2)]
      colliding?)
    false))

(defn include-collidable-entities
  "State parsing function. Returns a vector of component-state
   positions of all collidable entities and their id, component-id and this entity-id"
  [state component-id entity-id]
  (let [entity-ids (ces/entities-with-component (:entities state) component-id)
        ;; Only want the renderable component state as that has the
        ;; actual sprites with real positions
        ;; Add on the id of the entity
        entities (map #(assoc (ces/get-component-state state :renderable %) :id %)
                      entity-ids)
        component-state (ces/get-component-state state component-id entity-id)]
    [entities component-state component-id entity-id]))

(defmulti check-collisions
  "Returns updated component state and collision events when colliding"
  (fn [entities component-state component-id entity-id] entity-id))

(defmethod check-collisions :default
  [entities component-state component-id entity-id]
  component-state)

(defmethod check-collisions :player1
  [entities component-state component-id entity-id]
  (let [player (first (filter #(= (:id %) entity-id) entities))
        ;; Exclude the player from collection of collidable entities
        filtered-entities (filter #(not= (:id %) entity-id) entities)
        collisions (doall (for [e filtered-entities] (collision? player e)))
        ;; In order to have a collision the collisions seq must not be
        ;; empty and must have a falsey value
        colliding? (and (every? boolean collisions) (seq collisions))]
    (if colliding?
      [component-state [[:collision entity-id {:colliding? true}]]]
      component-state)))

Remove debug messages

Remove debug messages


;; TODO:
;; Have a :plugins vector.
;; Add [lein-outdated "1.0.0"] to it
;; Q: Does that make any sense at all?
;; Hasn't it been superseded by lein-ancient?
{:user {:aliases {"slamhound" ["run" "-m" "slam.hound"]}  ; Q: Will I ever find occasion to actually use this?
        :dependencies [[alembic "0.3.2"]   ; Q: what's this for?
                       #_[clj-ns-browser "1.3.1" :exclusions [hiccup]]
                       ;; We inherit this next through vinyasa.
                       ;; Shouldn't need to declare it
                       ;; Actually, this doesn't make sense in here. Its entire purpose
                       ;; in life is to split away from vinyasa. It's a general purpose
                       ;; library, such as useful.
                       ;; TODO: Verify that nothing else in here depends on it.
                       ;; (that seems to be done)
                       ;; (I'm pretty sure it doesn't, because my general profiles.clj
                       ;; doesn't have this)
                       #_[im.chit/hara "2.1.11"]
                       ;; TODO: Replace this with whatever replaced it
                       [im.chit/vinyasa "0.3.4" :exclusions [org.codehaus.plexus/plexus-utils]]
                       [io.aviso/pretty "0.1.20"]
                       [leiningen #= (leiningen.core.main/leiningen-version)  :exclusions [cheshire
                                                                                com.fasterxml.jackson.core/jackson-core
                                                                                com.fasterxml.jackson.dataformat/jackson-dataformat-smile
                                                                                common-logging
                                                                                commons-codec
                                                                                org.apache.httpcomponents/httpclient
                                                                                org.apache.httpcomponents/httpcore
                                                                                org.apache.maven.wagon/wagon-http
                                                                                org.apache.maven.wagon/wagon-http-shared4
                                                                                org.apache.maven.wagon/wagon-provider-api
                                                                                org.clojure/tools.cli
                                                                                org.clojure/tools.reader
                                                                                ;;org.codehaus.plexus/plexus-utils
                                                                                org.jsoup/jsoup
                                                                                potemkin]]
                       ;; How many of any of the rest of these do I actually use?
                       [nrepl-inspect "0.3.0"]
                       [org.codehaus.plexus/plexus-utils "3.0"]
                       [org.clojure/java.classpath "0.2.2"]
                       [org.clojure/tools.namespace "0.2.10"]
                       ;; I know I have a lot of projects that transitively rely on this, but they really shouldn't
                       [org.clojure/tools.nrepl "0.2.12" :exclusions [org.clojure/clojure]]
                       [pjstadig/humane-test-output "0.7.0"]
                       ;; Q: Is there any point to this next one?
                       [ritz/ritz-nrepl-middleware "0.7.0"]
                       [slamhound "1.5.5"]
                       [spyscope "0.1.5" :exclusions [clj-time]]]
        :injections [(require 'spyscope.core)
                     (require '[vinyasa.inject :as inject])
                     ;; TODO: call install-pretty-exception
                     (require 'io.aviso.repl)
                     (inject/in
                      ;; Default injection ns is .
                      [vinyasa.inject :refer [inject [in inject-in]]]
                      #_[vinyasa.lein :exclude [*project*]]
                      #_[vinyasa.pull :all]
                      [alembic.still [distill pull]]  ; Q: what is/was this?
                      ;; Actually, I think I want to keep something along these lines
                      [cemerick.pomegranate add-classpath add-dependencies get-classpath resources]

                      ;;; At least 90% certain that I don't want any of the rest of this
                      ;; Inject into clojure.core
                      clojure.core
                      [vinyasa.reflection .> .? .* .% .%> .& .>ns .>var]

                      ;; Inject into clojure.core, with prefix
                      clojure.core >
                      [clojure.pprint pprint]
                      [clojure.java.shell sh])
                     ;;; Well, this doesn't seem awful; I think I do want something like this.
                     ;;; But it doesn't seem worth including here...really ought to be decided on
                     ;;; a case-by-case basis, oughtn't it?
                     (require 'pjstadig.humane-test-output)
                     (pjstadig.humane-test-output/activate!)]
        ;;:local-repo "repo"
        :plugins [[cider/cider-nrepl "0.10.1" :exclusions [org.clojure/java.classpath]]
                  [com.jakemccrary/lein-test-refresh "0.9.0"]
                  [jonase/eastwood "0.2.2" :exclusions [org.clojure/clojure]]
                  [lein-ancient "0.6.8" :exclusions [cheshire common-codec commons-codec org.clojure/clojure org.clojure/tools.reader slingshot]]
                  ;; This next one's super useful, but its dependencies are out of date
                  ;; TODO: Update!
                  #_[lein-kibit "0.0.8"]
                  [lein-pprint "1.1.1"]
                  [mvxcvi/whidbey "0.6.0"]]
        :repl-options {:nrepl-middleware
                       [inspector.middleware/wrap-inspect
                        ;;ritz.nrepl.middleware.apropos/wrap-apropos
                        ;;ritz.nrepl.middleware.javadoc/wrap-javadoc
                        ;;ritz.nrepl.middleware.simple-complete/wrap-simple-complete
                        ]}
        :whidbey {:width 180
                  :map-delimiter ""
                  :extend-notation true
                  :print-meta true
                  :color-scheme {}
                  :print-color true}}}

;; TODO:
;; Have a :plugins vector.
;; Add [lein-outdated "1.0.0"] to it
{:user {:aliases {"slamhound" ["run" "-m" "slam.hound"]}  ; Q: Will I ever find occasion to actually use this?
        :dependencies [[alembic "0.3.2"]   ; Q: what's this really for?
                       ;; We inherit this next through vinyasa.
                       ;; Shouldn't need to declare it
                       ;; Actually, this doesn't make sense in here. Its entire purpose
                       ;; in life is to split away from vinyasa. It's a general purpose
                       ;; library, such as useful.
                       ;; TODO: Verify that nothing else in here depends on it.
                       ;; (that seems to be done)
                       ;; (I'm pretty sure it doesn't, because my general profiles.clj
                       ;; doesn't have this)
                       #_[im.chit/hara "2.1.11"]
                       ;; This should probably go away
                       ;; Q: Did hara replace this too?
                       [im.chit/vinyasa "0.3.4" :exclusions [org.codehaus.plexus/plexus-utils]]
                       [io.aviso/pretty "0.1.20"]
                       [leiningen #= (leiningen.core.main/leiningen-version)  :exclusions [cheshire
                                                                                com.fasterxml.jackson.core/jackson-core
                                                                                com.fasterxml.jackson.dataformat/jackson-dataformat-smile
                                                                                common-logging
                                                                                commons-codec
                                                                                org.apache.httpcomponents/httpclient
                                                                                org.apache.httpcomponents/httpcore
                                                                                org.apache.maven.wagon/wagon-http
                                                                                org.apache.maven.wagon/wagon-http-shared4
                                                                                org.apache.maven.wagon/wagon-provider-api
                                                                                org.clojure/tools.cli
                                                                                org.clojure/tools.reader
                                                                                org.jsoup/jsoup
                                                                                potemkin]]
                       ;; How many of any of the rest of these do I actually use?
                       [nrepl-inspect "0.3.0"]
                       [org.codehaus.plexus/plexus-utils "3.0.17"]
                       [org.clojure/tools.namespace "0.2.10"]
                       ;; I know I have a lot of projects that transitively rely on this, but they really shouldn't
                       [org.clojure/tools.nrepl "0.2.12" :exclusions [org.clojure/clojure]]
                       [pjstadig/humane-test-output "0.7.0"]
                       ;; Q: Is there any point to this next one?
                       [ritz/ritz-nrepl-middleware "0.7.0"]
                       [slamhound "1.5.5"]]
        :injections [(require '[vinyasa.inject :as inject])
                     ;; TODO: call install-pretty-exception
                     (require 'io.aviso.repl)
                     (inject/in
                      ;; Default injection ns is .
                      [vinyasa.inject :refer [inject [in inject-in]]]
                      #_[vinyasa.lein :exclude [*project*]]
                      #_[vinyasa.pull :all]
                      [alembic.still [distill pull]]  ; Q: what is/was this?
                      ;; Actually, I think I want to keep something along these lines
                      [cemerick.pomegranate add-classpath add-dependencies get-classpath resources]

                      ;;; At least 90% certain that I don't want any of the rest of this
                      ;; Inject into clojure.core
                      clojure.core
                      [vinyasa.reflection .> .? .* .% .%> .& .>ns .>var]

                      ;; Inject into clojure.core, with prefix
                      clojure.core >
                      [clojure.pprint pprint]
                      [clojure.java.shell sh])
                     ;;; Well, this doesn't seem awful; I think I do want something like this.
                     ;;; But it doesn't seem worth including here...really ought to be decided on
                     ;;; a case-by-case basis, oughtn't it?
                     (require 'pjstadig.humane-test-output)
                     (pjstadig.humane-test-output/activate!)]
        ;;:local-repo "repo"
        :plugins [[cider/cider-nrepl "0.10.2" :exclusions [org.clojure/java.classpath]]
                  [com.jakemccrary/lein-test-refresh "0.13.0"]
                  [jonase/eastwood "0.2.2" :exclusions [org.clojure/clojure]]
                  [lein-ancient "0.6.8" :exclusions [cheshire
                                                     common-codec
                                                     commons-codec
                                                     org.clojure/clojure
                                                     org.clojure/tools.reader
                                                     slingshot]]
                  ;; This next one's super useful, but its dependencies are out of date
                  ;; TODO: Update!
                  [lein-kibit "0.1.2"]
                  [lein-pprint "1.1.1"]
                  [mvxcvi/whidbey "0.6.0"]]
        :repl-options {:nrepl-middleware
                       [inspector.middleware/wrap-inspect
                        ;;ritz.nrepl.middleware.apropos/wrap-apropos
                        ;;ritz.nrepl.middleware.javadoc/wrap-javadoc
                        ;;ritz.nrepl.middleware.simple-complete/wrap-simple-complete
                        ]}
        :whidbey {:width 180
                  :map-delimiter ""
                  :extend-notation true
                  :print-meta true
                  :color-scheme {}
                  :print-color true}}
  :repl {:plugins [[cider/cider-nrepl "0.10.1" :exclusions [org.clojure/java.classpath]]]}}

Clean up some dependency issues

Clean up some dependency issues


(ns cats.types
  "Monadic types definition."
  (:require [cats.protocols :as proto]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Either
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype Either [v type]
  Object
  (equals [self other]
    (if (instance? Either other)
      (and (= v (.v other))
           (= type (.type other)))
      false))

  (toString [self]
    (with-out-str (print [v type])))

  proto/Monad
  (bind [s f]
    (case type
      :right (f v)
      s))

  proto/Functor
  (fmap [s f]
    (case type
      :right (Either. (f v) :right)
      s))

  proto/Applicative
  (pure [_ v]
    (Either. v type))
  (fapply [s av]
    (case type
      :right (proto/fmap av v)
      s)))

(defn left
  "Left constructor for Either type."
  [^Object v]
  (Either. v :left))

(defn right
  "Right constructor for Either type."
  [^Object v]
  (Either. v :right))

(defn left?
  [mv]
  (= (.type mv) :left))

(defn right?
  [mv]
  (= (.type mv) :right))

(defn from-either
  "Return inner value of either monad."
  [mv]
  (.v mv))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Maybe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype Nothing []
  Object
  (equals [_ other]
    (instance? Nothing other))

  (toString [_]
    (with-out-str (print "")))

  proto/Monad
  (bind [s f] s)

  proto/MonadPlus
  (mzero [_] (Nothing.))
  (mplus [_ mv] mv)

  proto/Functor
  (fmap [s f] s)

  proto/Applicative
  (pure [s v] s)
  (fapply [s av] s))

(deftype Just [v]
  Object
  (equals [self other]
    (if (instance? Just other)
      (= v (.v other))
      false))

  (toString [self]
    (with-out-str (print [v])))

  proto/Monad
  (bind [self f]
    (f v))

  proto/MonadPlus
  (mzero [_]
    (Nothing.))
  (mplus [mv _] mv)

  proto/Functor
  (fmap [s f]
    (Just. (f v)))

  proto/Applicative
  (pure [_ v]
    (Just. v))
  (fapply [_ av]
    (proto/fmap av v)))

(defn just
  [v]
  (Just. v))

(defn nothing
  []
  (Nothing.))

(defn maybe?
  [v]
  (or (instance? Just v)
     (instance? Nothing v)))

(defn just?
  [v]
  (instance? Just v))

(defn nothing?
  [v]
  (instance? Nothing v))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Clojure types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+clj
(extend-type clojure.lang.PersistentVector
  proto/Monad
  (bind [self f]
    (vec (flatten (map f self))))

  proto/MonadPlus
  (mzero [_] [])
  (mplus [mv mv'] (vec (concat mv mv')))

  proto/Functor
  (fmap [self f] (vec (map f self)))

  proto/Applicative
  (pure [_ v] [v])
  (fapply [self av]
    (vec (for [f self
               v av]
           (f v)))))

(ns cats.types
  "Monadic types definition."
  (:require [cats.protocols :as proto]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Either
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype Either [v type]
  Object
  (equals [self other]
    (if (instance? Either other)
      (and (= v (.v other))
           (= type (.type other)))
      false))

  (toString [self]
    (with-out-str (print [v type])))

  proto/Monad
  (bind [s f]
    (case type
      :right (f v)
      s))

  proto/Functor
  (fmap [s f]
    (case type
      :right (Either. (f v) :right)
      s))

  proto/Applicative
  (pure [_ v]
    (Either. v type))
  (fapply [s av]
    (case type
      :right (proto/fmap av v)
      s)))

(defn left
  "Left constructor for Either type."
  [^Object v]
  (Either. v :left))

(defn right
  "Right constructor for Either type."
  [^Object v]
  (Either. v :right))

(defn left?
  [mv]
  (= (.type mv) :left))

(defn right?
  [mv]
  (= (.type mv) :right))

(defn from-either
  "Return inner value of either monad."
  [mv]
  (.v mv))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Maybe
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftype Nothing []
  Object
  (equals [_ other]
    (instance? Nothing other))

  (toString [_]
    (with-out-str (print "")))

  proto/Monad
  (bind [s f] s)

  proto/MonadPlus
  (mzero [_] (Nothing.))
  (mplus [_ mv] mv)

  proto/Functor
  (fmap [s f] s)

  proto/Applicative
  (pure [s v] s)
  (fapply [s av] s))

(deftype Just [v]
  Object
  (equals [self other]
    (if (instance? Just other)
      (= v (.v other))
      false))

  (toString [self]
    (with-out-str (print [v])))

  proto/Monad
  (bind [self f]
    (f v))

  proto/MonadPlus
  (mzero [_]
    (Nothing.))
  (mplus [mv _] mv)

  proto/Functor
  (fmap [s f]
    (Just. (f v)))

  proto/Applicative
  (pure [_ v]
    (Just. v))
  (fapply [_ av]
    (proto/fmap av v)))

(defn just
  [v]
  (Just. v))

(defn nothing
  []
  (Nothing.))

(defn maybe?
  [v]
  (or (instance? Just v)
     (instance? Nothing v)))

(defn just?
  [v]
  (instance? Just v))

(defn nothing?
  [v]
  (instance? Nothing v))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Clojure types
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#+clj
(extend-type clojure.lang.PersistentVector
  proto/Monad
  (bind [self f]
    (vec (flatten (map f self))))

  proto/MonadPlus
  (mzero [_] [])
  (mplus [mv mv'] (into mv mv'))

  proto/Functor
  (fmap [self f] (vec (map f self)))

  proto/Applicative
  (pure [_ v] [v])
  (fapply [self av]
    (vec (for [f self
               v av]
           (f v)))))

Use into instead of vec and concat

Use into instead of vec and concat


Trim whitespace from pgp key if a pgp key is present


(ns examples.handleinputinmain
  (:require [zaffre.aterminal :as zat]
            [zaffre.glterminal :as zgl]
            [zaffre.font :as zfont]
            [zaffre.util :as zutil]
            [clojure.core.async :as async :refer [go-loop]]
            [taoensso.timbre :as log])
  (:import (zaffre.aterminal ATerminal)
           (zaffre.font CP437Font TTFFont)))

(defn hsv->rgb [h s v]
  (let [c (* v s)
        x (* c (- 1.0 (Math/abs (double (dec (mod (/ h 60.0) 2.0))))))]
    (mapv (comp int (partial * 255))
      (cond
        (< h  60) [c x 0]
        (< h 120) [x c 0]
        (< h 180) [0 c x]
        (< h 240) [0 x c]
        (< h 300) [x 0 c]
        (< h 360) [c 0 x]))))

(defn -main [& _]
  ;; render in background thread
   (let [colorShift    (atom 0.0001)
         brightness    (atom 0.68)
         contrast      (atom 2.46)
         scanlineDepth (atom 0.94)
         time          (atom 0.0)
         noise         (atom 0.0016)
         terminal   (zgl/make-terminal [:text :rainbow]
                                       {:title "Zaffre demo"
                                        :columns 80 :rows 24
                                        :default-fg-color [250 250 250]
                                        :default-bg-color [5 5 8]
                                        :windows-font (TTFFont. "Consolas" 12)
                                        ;:else-font "/home/santos/Downloads/cour.ttf"
                                        ;:else-font (TTFFont. "/home/santos/Downloads/cour.ttf" 12)
                                        ;:else-font (TTFFont. "Monospaced" 12)
                                        ;:else-font (TTFFont. "/home/santos/src/robinson/fonts/Boxy/Boxy.ttf" 12)
                                        ;:else-font (CP437Font. "http://dwarffortresswiki.org/images/2/29/Potash_8x8.png" :green 2)
                                        ;:else-font (CP437Font. "http://dwarffortresswiki.org/images/2/29/Potash_8x8.png" :green 2)
                                        ;:else-font (CP437Font. "http://dwarffortresswiki.org/images/b/b7/Kein_400x125.png" :green 2)
                                        ;:else-font (CP437Font. "http://dwarffortresswiki.org/images/0/03/Alloy_curses_12x12.png" :green 2)
                                        :else-font (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 1)
                                        ;:else-font (CP437Font. "/home/santos/Pictures/LN_EGA8x8.png" :green 2)
                                        :antialias true
                                        ;:fullscreen true
                                        :icon-paths ["images/icon-16x16.png"
                                                     "images/icon-32x32.png"
                                                     "images/icon-128x128.png"]
                                        :fx-shader {:name     "retro.fs"
                                                    :uniforms [["time" @time]
                                                               ["noise" @noise]
                                                               ["colorShift" @colorShift]
                                                               ["scanlineDepth" @scanlineDepth]
                                                               ["brightness" @brightness]
                                                               ["contrast" @contrast]]}})
        fullscreen-sizes (zat/fullscreen-sizes terminal)
        last-key    (atom nil)
        ;; Every 10ms, set the "Rainbow" text to have a random fg color
        fx-chan     (go-loop []
                      (dosync
                        (doseq [x (range (count "Rainbow"))
                                :let [rgb (hsv->rgb (double (rand 360)) 1.0 1.0)]]
                            (zat/set-fx-fg! terminal :rainbow (inc x) 1 rgb)))
                        (zat/assoc-fx-uniform! terminal "time" (swap! time inc))
                        (zat/refresh! terminal)
                      (Thread/sleep 10)
                      (recur))
        ;; Every 33ms, draw a full frame
        render-chan (go-loop []
                      (dosync
                        (let [key-in (or @last-key \?)]
                          (zat/clear! terminal)
                          (zutil/put-string terminal :text 0 0 "Hello world")
                          (doseq [[i c] (take 23 (map-indexed (fn [i c] [i (char c)]) (range (int \a) (int \z))))]
                            (zutil/put-string terminal :text 0 (inc i) (str c) [128 (* 10 i) 0] [0 0 50]))
                          (zutil/put-string terminal :text 12 0 (str key-in))
                          (zutil/put-string terminal :rainbow 1 1 "Rainbow")
                          (zat/refresh! terminal)))
                          ;; ~30fps
                        (Thread/sleep 33)
                        (recur))]
    (log/info "Fullscreen sizes" fullscreen-sizes)
    ;; get key presses in fg thread
    (loop []
      (let [new-key (async/<!! (zat/get-key-chan terminal))]
        (reset! last-key new-key)
        (log/info "got key" (or (str @last-key) "nil"))
        ;; change font size on s/m/l keypress
        (case new-key
          \s (zat/apply-font! terminal
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 1)
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 1))
          \m (zat/apply-font! terminal
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 2)
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 2))
          \l (zat/apply-font! terminal
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 3)
               (CP437Font. "http://dwarffortresswiki.org/images/b/be/Pastiche_8x8.png" :green 3))
          \f (zat/fullscreen! terminal (first fullscreen-sizes))
          \w (zat/fullscreen! terminal false)
          \0 (zat/assoc-fx-uniform! terminal "brightness" (swap! brightness #(- % 0.02)))
          \1 (zat/assoc-fx-uniform! terminal "brightness" (swap! brightness #(+ % 0.02)))
          \2 (do (swap! contrast #(- % 0.02))
                 (log/info "contrast" @contrast)
                 (zat/assoc-fx-uniform! terminal "contrast" @contrast))
          \3 (zat/assoc-fx-uniform! terminal "contrast" (swap! contrast #(+ % 0.02)))
          \4 (zat/assoc-fx-uniform! terminal "scanlineDepth" (swap! scanlineDepth #(- % 0.02)))
          \5 (zat/assoc-fx-uniform! terminal "scanlineDepth" (swap! scanlineDepth #(+ % 0.02)))
          \6 (zat/assoc-fx-uniform! terminal "colorShift" (swap! colorShift #(- % 0.0001)))
          \7 (zat/assoc-fx-uniform! terminal "colorShift" (swap! colorShift #(+ % 0.0001)))
          \8 (zat/assoc-fx-uniform! terminal "noise" (swap! noise #(- % 0.0001)))
          \9 (zat/assoc-fx-uniform! terminal "noise" (swap! noise #(+ % 0.0001)))
          \p (log/info "brightness" @brightness
                       "contrast" @contrast
                       "scanlineDepth" @scanlineDepth
                       "colorShift" @colorShift
                       "noise" @noise
                       "time" @time)
          \q (zat/destroy! terminal)
          nil)
        (if (= new-key :exit)
          (do
            (async/close! fx-chan)
            (async/close! render-chan)
            (System/exit 0))
          (recur))))))

(ns examples.handleinputinmain
  (:require [zaffre.aterminal :as zat]
            [zaffre.glterminal :as zgl]
            [zaffre.font :as zfont]
            [zaffre.util :as zutil]
            [clojure.core.async :as async :refer [go-loop]]
            [taoensso.timbre :as log])
  (:import (zaffre.aterminal ATerminal)
           (zaffre.font CP437Font TTFFont)))

(defn hsv->rgb [h s v]
  (let [c (* v s)
        x (* c (- 1.0 (Math/abs (double (dec (mod (/ h 60.0) 2.0))))))]
    (mapv (comp int (partial * 255))
      (cond
        (< h  60) [c x 0]
        (< h 120) [x c 0]
        (< h 180) [0 c x]
        (< h 240) [0 x c]
        (< h 300) [x 0 c]
        (< h 360) [c 0 x]))))

(defn -main [& _]
  ;; render in background thread
   (let [terminal   (zgl/make-terminal [:text :rainbow]
                                       {:title "Zaffre demo"
                                        :columns 80 :rows 24
                                        :default-fg-color [250 250 250]
                                        :default-bg-color [5 5 8]
                                        :windows-font (TTFFont. "Consolas" 12)
                                        :else-font (TTFFont. "Monospaced" 12)
                                        :icon-paths ["images/icon-16x16.png"
                                                     "images/icon-32x32.png"
                                                     "images/icon-128x128.png"]})
        last-key    (atom nil)
        ;; Every 10ms, set the "Rainbow" text to have a random fg color
        fx-chan     (go-loop []
                      (dosync
                        (doseq [x (range (count "Rainbow"))
                                :let [rgb (hsv->rgb (double (rand 360)) 1.0 1.0)]]
                            (zat/set-fx-fg! terminal :rainbow (inc x) 1 rgb)))
                        (zat/refresh! terminal)
                      (Thread/sleep 10)
                      (recur))
        ;; Every 33ms, draw a full frame
        render-chan (go-loop []
                      (dosync
                        (let [key-in (or @last-key \?)]
                          (zat/clear! terminal)
                          (zutil/put-string terminal :text 0 0 "Hello world")
                          (doseq [[i c] (take 23 (map-indexed (fn [i c] [i (char c)]) (range (int \a) (int \z))))]
                            (zutil/put-string terminal :text 0 (inc i) (str c) [128 (* 10 i) 0] [0 0 50]))
                          (zutil/put-string terminal :text 12 0 (str key-in))
                          (zutil/put-string terminal :rainbow 1 1 "Rainbow")
                          (zat/refresh! terminal)))
                          ;; ~30fps
                        (Thread/sleep 33)
                        (recur))]
    ;; get key presses in fg thread
    (loop []
      (let [new-key (async/<!! (zat/get-key-chan terminal))]
        (reset! last-key new-key)
        (log/info "got key" (or (str @last-key) "nil"))
        ;; change font size on s/m/l keypress
        (case new-key
          \q (zat/destroy! terminal)
          nil)
        (if (= new-key :exit)
          (do
            (async/close! fx-chan)
            (async/close! render-chan)
            (System/exit 0))
          (recur))))))

Update simplify example

Update simplify example