(ns leiningen.remote-test-refresh
  (:require [clojure.tools.namespace.dir :as dir]
            [clojure.tools.namespace.track :as t]
            [clojure.string :as str]
            [leiningen.core.main :as m]
            [leiningen.remote.utils.utils :as u]
            [clj-ssh.ssh :as ssh]
            [clojure.core.async :as async]
            [clojure.java.shell :as sh]
            [clojure.java.io :as io]))

;;; Transfer steps
(def verbose true)
(def local-patch-file-name "test-refresh-local.patch")
(def remote-patch-file-name "test-refresh.remote.patch")

(defn remote-patch-file-path [remote-path repo]
  (str remote-path repo "/" remote-patch-file-name))

(defn create-patch! [_ _]
  (try (->> ["git" "diff" "HEAD"]
            (apply sh/sh)
            (:out)
            (spit local-patch-file-name))
       (if (u/exists? local-patch-file-name)
         {:step :create-patch :status :success}
         {:step :create-patch :status :failed :error "could not create local patch file"})
       (catch Exception e
         {:step :create-patch :status :failed :error (.getMessage e)})))

(defn upload-patch! [{repo :repo path :remote-path} session]
  (let [_ (ssh/scp-to session local-patch-file-name (remote-patch-file-path path repo))
        result-remove (sh/sh "rm" "-f" local-patch-file-name)]
    (if (= 0 (:exit result-remove))
      {:step :upload-patch :status :success}
      {:step :upload-patch :status :failed :error (:err result-remove)})))

(defn apply-patch! [{repo :repo path :remote-path} session]
  (let [cmd (str "cd " path repo ";"
                 "git reset --hard;"
                 (str "git apply --whitespace=warn " remote-patch-file-name ";")
                 "rm -f " remote-patch-file-name ";")
        result-apply-patch (ssh/ssh session {:cmd cmd})]
    (if (= 0 (:exit result-apply-patch))
      {:step :apply-patch :status :success}
      {:step :apply-patch :status :failed :error (:err result-apply-patch)})))

;;; Transfer logic

(defn transfer-per-ssh [parameters session run-steps]
  (let [failed-steps (->> run-steps
                          (map #(% parameters session))
                          (filter #(= :failed (:status %)))
                          (reduce str))]
    (if (empty? failed-steps)
      {:status :success :msg "* Change has been transfered successfully to your remote repository"}
      {:status :failed :msg (str "* Transfer per SSH failed in: " failed-steps)})))

(defn normalize-remote-path [path]
  (let [lower-case-path (str/lower-case path)]
    (if (.endsWith lower-case-path "/")
      lower-case-path
      (str lower-case-path "/"))))

(defn start-parameters [project]
  (let [project-name (:name project)
        user (or (get-in project [:remote-test :user])
                 (u/ask-clear-text "* ==> Please enter your ssh user:"))

        password (or (get-in project [:remote-test :password])
                     (u/ask-for-password "* ==> Please enter your ssh password:"))

        host (or (get-in project [:remote-test :host])
                 (u/ask-clear-text
                  "* ==> Please enter your remote host:"))

        path (or (get-in project [:remote-test :remote-path])
                 (u/ask-clear-text
                  "* ==> Please enter parent folder path of repository on remote machine:"))

        command (or (get-in project [:remote-test :command])
                    (u/ask-clear-text
                     "* ==> Which command do you want to run on the repository of remote machine (optional):"))

        forwarding-port (or (get-in project [:remote-test :forwarding-port])
                            (u/ask-clear-text
                             "* ==> Enter port if you need a port to be forwared (optional):"))]

    (assert (not (empty? project-name)) project-name)
    (assert (not (empty? user)) user)
    (assert (not (empty? user)) password)
    (assert (not (empty? host)) host)
    (assert (not (empty? path)) path)
    {:repo            project-name
     :user            user
     :password        password
     :host            host
     :command         command
     :forwarding-port forwarding-port
     :remote-path     (normalize-remote-path path)}))

(defn find-asset-paths [project]
  (->> (concat (:source-paths project ["src"])
               (:resource-paths project ["resources"])
               (:test-paths project ["test"]))
       (vec)))

;;;; Main

(def TRANSFER-STEPS [create-patch! upload-patch! apply-patch!])
(def WAIT-TIME 500)

(defn sync-code-change
  ([console session dirs parameters]
   (sync-code-change console session dirs parameters (apply dir/scan (t/tracker) dirs)))
  ([console session dirs parameters old-tracker]
   (let [new-tracker (apply dir/scan old-tracker dirs)]
     (if (not= new-tracker old-tracker)
       (->> TRANSFER-STEPS
            (transfer-per-ssh parameters session)
            (async/>!! console))
       (Thread/sleep WAIT-TIME))
     (recur console session dirs parameters new-tracker))))

(defn run-command-remotely [{run-command :command repo :repo path :remote-path} session]
  (let [output (->> {:cmd (str "cd " path repo ";" run-command ";") :out :stream :pty true}
                    (ssh/ssh session)
                    (:out-stream))]
    (with-open [rdr (io/reader output)]
      (doseq [line (line-seq rdr)] (m/info line)))))

(defn log-console [console]
  (while true
    (let [{msg :msg} (async/<!! console)]
      (m/info "\n" msg "\n")
      (Thread/sleep WAIT-TIME))))

(defn endless-loop []
  (while true (Thread/sleep WAIT-TIME)))

(defn run-command-and-forward-port [session parameters]
  (let [{port :forwarding-port command :command} parameters]
    (cond
      (and (not (empty? port)) (not (empty? command)))
      (ssh/with-local-port-forward [session (u/parse-int port) (u/parse-int port)]
        (run-command-remotely parameters session))

      (and (empty? port) (not (empty? command)))
      (run-command-remotely parameters session)

      (not (empty? port))
      (ssh/with-local-port-forward [session (u/parse-int port) (u/parse-int port)]
        (endless-loop))

      :else (endless-loop))))

(defn start-remote-routine [session asset-paths parameters]
  (let [console (async/chan)]
    (future (sync-code-change console session asset-paths parameters))
    (future (log-console console))
    (run-command-and-forward-port session parameters)))

(defn session-option [parameters]
  {:username                 (:user parameters)
   :password                 (:password parameters)
   :strict-host-key-checking :no})

(defn remote-test-refresh [project & _]
  (m/info "* Remote-Test-Refresh version:" (u/artifact-version))
  (try
    (let [asset-paths (find-asset-paths project)
          parameters (start-parameters project)
          agent (ssh/ssh-agent {:use-system-ssh-agent false})
          session (ssh/session agent (:host parameters) (session-option parameters))]
      (m/info "* Starting with the parameters:" (assoc parameters :password "***") "\n")
      (ssh/connect session)
      (ssh/with-connection session (start-remote-routine session asset-paths parameters)))
    (catch Exception e (m/info "* [error] " (.getMessage e) (when verbose e)))))

(ns leiningen.remote-test-refresh
  (:require [clojure.tools.namespace.dir :as dir]
            [clojure.tools.namespace.track :as t]
            [clojure.string :as str]
            [leiningen.core.main :as m]
            [leiningen.remote.utils.utils :as u]
            [clj-ssh.ssh :as ssh]
            [clojure.core.async :as async]
            [clojure.java.shell :as sh]
            [clojure.java.io :as io]))

;;; Transfer steps
(def verbose true)
(def local-patch-file-name "test-refresh-local.patch")
(def remote-patch-file-name "test-refresh.remote.patch")

(defn remote-patch-file-path [remote-path repo]
  (str remote-path repo "/" remote-patch-file-name))

(defn create-patch! [_ _]
  (try (->> ["git" "diff" "HEAD"]
            (apply sh/sh)
            (:out)
            (spit local-patch-file-name))
       (if (u/exists? local-patch-file-name)
         {:step :create-patch :status :success}
         {:step :create-patch :status :failed :error "could not create local patch file"})
       (catch Exception e
         {:step :create-patch :status :failed :error (.getMessage e)})))

(defn upload-patch! [{repo :repo path :remote-path} session]
  (let [_ (ssh/scp-to session local-patch-file-name (remote-patch-file-path path repo))
        result-remove (sh/sh "rm" "-f" local-patch-file-name)]
    (if (= 0 (:exit result-remove))
      {:step :upload-patch :status :success}
      {:step :upload-patch :status :failed :error (:err result-remove)})))

(defn apply-patch! [{repo :repo path :remote-path} session]
  (let [cmd (str "cd " path repo ";"
                 "git reset --hard;"
                 (str "git apply --whitespace=warn " remote-patch-file-name ";")
                 "rm -f " remote-patch-file-name ";")
        result-apply-patch (ssh/ssh session {:cmd cmd :agent-forwarding true})]
    (if (= 0 (:exit result-apply-patch))
      {:step :apply-patch :status :success}
      {:step :apply-patch :status :failed :error (:err result-apply-patch)})))

;;; Transfer logic

(defn transfer-per-ssh [parameters session run-steps]
  (let [failed-steps (->> run-steps
                          (map #(% parameters session))
                          (filter #(= :failed (:status %)))
                          (reduce str))]
    (if (empty? failed-steps)
      {:status :success :msg "* Change has been transfered successfully to your remote repository"}
      {:status :failed :msg (str "* Transfer per SSH failed in: " failed-steps)})))

(defn normalize-remote-path [path]
  (let [lower-case-path (str/lower-case path)]
    (if (.endsWith lower-case-path "/")
      lower-case-path
      (str lower-case-path "/"))))

(defn start-parameters [project]
  (let [project-name (:name project)
        user (or (get-in project [:remote-test :user])
                 (u/ask-clear-text "* ==> Please enter your ssh user:"))

        password (or (get-in project [:remote-test :password])
                     (u/ask-for-password "* ==> Please enter your ssh password:"))

        host (or (get-in project [:remote-test :host])
                 (u/ask-clear-text
                  "* ==> Please enter your remote host:"))

        path (or (get-in project [:remote-test :remote-path])
                 (u/ask-clear-text
                  "* ==> Please enter parent folder path of repository on remote machine:"))

        command (or (get-in project [:remote-test :command])
                    (u/ask-clear-text
                     "* ==> Which command do you want to run on the repository of remote machine (optional):"))

        forwarding-port (or (get-in project [:remote-test :forwarding-port])
                            (u/ask-clear-text
                             "* ==> Enter port if you need a port to be forwared (optional):"))]

    (assert (not (empty? project-name)) project-name)
    (assert (not (empty? user)) user)
    (assert (not (empty? user)) password)
    (assert (not (empty? host)) host)
    (assert (not (empty? path)) path)
    {:repo            project-name
     :user            user
     :password        password
     :host            host
     :command         command
     :forwarding-port forwarding-port
     :remote-path     (normalize-remote-path path)}))

(defn find-asset-paths [project]
  (->> (concat (:source-paths project ["src"])
               (:resource-paths project ["resources"])
               (:test-paths project ["test"]))
       (vec)))

;;;; Main

(def TRANSFER-STEPS [create-patch! upload-patch! apply-patch!])
(def WAIT-TIME 500)

(defn sync-code-change
  ([console session dirs parameters]
   (sync-code-change console session dirs parameters (apply dir/scan (t/tracker) dirs)))
  ([console session dirs parameters old-tracker]
   (let [new-tracker (apply dir/scan old-tracker dirs)]
     (if (not= new-tracker old-tracker)
       (->> TRANSFER-STEPS
            (transfer-per-ssh parameters session)
            (async/>!! console))
       (Thread/sleep WAIT-TIME))
     (recur console session dirs parameters new-tracker))))

(defn run-command-remotely [{run-command :command repo :repo path :remote-path} session]
  (let [output (->> {:cmd (str "cd " path repo ";" run-command ";") :out :stream :pty true :agent-forwarding true}
                    (ssh/ssh session)
                    (:out-stream))]
    (with-open [rdr (io/reader output)]
      (doseq [line (line-seq rdr)] (m/info line)))))

(defn log-console [console]
  (while true
    (let [{msg :msg} (async/<!! console)]
      (m/info "\n" msg "\n")
      (Thread/sleep WAIT-TIME))))

(defn endless-loop []
  (while true (Thread/sleep WAIT-TIME)))

(defn run-command-and-forward-port [session parameters]
  (let [{port :forwarding-port command :command} parameters]
    (cond
      (and (not (empty? port)) (not (empty? command)))
      (ssh/with-local-port-forward [session (u/parse-int port) (u/parse-int port)]
        (run-command-remotely parameters session))

      (and (empty? port) (not (empty? command)))
      (run-command-remotely parameters session)

      (not (empty? port))
      (ssh/with-local-port-forward [session (u/parse-int port) (u/parse-int port)]
        (endless-loop))

      :else (endless-loop))))

(defn start-remote-routine [session asset-paths parameters]
  (let [console (async/chan)]
    (future (sync-code-change console session asset-paths parameters))
    (future (log-console console))
    (run-command-and-forward-port session parameters)))

(defn session-option [parameters]
  {:username                 (:user parameters)
   :strict-host-key-checking :no})

(defn remote-test-refresh [project & _]
  (m/info "* Remote-Test-Refresh version:" (u/artifact-version))
  (try
    (let [asset-paths (find-asset-paths project)
          parameters (start-parameters project)
          agent (ssh/ssh-agent {})
          session (ssh/session agent (:host parameters) (session-option parameters))]
      (m/info "* Starting with the parameters:" (assoc parameters :password "***") "\n")
      (ssh/connect session)
      (ssh/with-connection session (start-remote-routine session asset-paths parameters)))
    (catch Exception e (m/info "* [error] " (.getMessage e) (when verbose e)))))

use system agent

exp: use system agent


(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [environ.core :refer [env]]
            [me.raynes.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.rdf :as rdf]))

(def ^:private db (env :archive-database-url))

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(def ^:private default-job
  {:verzeichnis ""
   :archivar "NN"
   :abholer "NN"
   :aktion "save"
   :transaktions_status "pending"})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str "ds" (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn- container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [id (container-id production sektion)]
    (.getPath (file spool-dir id "produkt"))))

(defn- container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [path (container-id production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file spool-dir path rdf-name))))

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [new-job
        {:verzeichnis (container-id production sektion)
         :sektion (case sektion :master "master" :dist-master "cdimage")}
        job (merge default-job new-job)]
    (jdbc/insert! db :container job)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-path (container-path production sektion)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s already exists" archive-path)
      (case sektion
        :master
        (fs/copy-dir (path/recorded-path production) archive-path)
        :dist-master
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                iso-archive-path (.getPath (file archive-path iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        entries (case sektion :master 2 :dist-master (inc (:volumes production)))]
    (let [rdf-path (container-rdf-path production sektion)]
      (spit rdf-path rdf))))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (archive-sektion production :master)
  (archive-sektion production :dist-master))

(defmethod archive "periodical"
  [production]
  (archive-sektion production :master)
  ;; archive the periodical iso(s)
  (let [dam-number (prod/dam-number production)
        archive-path (.getPath (file periodical-spool-dir dam-number))
        multi-volume? (prod/multi-volume? production)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s for periodical already exists" archive-path)
      (do
        (fs/mkdir archive-path)
        ;; create the rdf
        (let [rdf-path (file archive-path (str dam-number ".rdf"))
              rdf (rdf/rdf production)]
          (spit rdf-path rdf))
        ;; copy all volumes
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
                iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))))))

(defmethod archive "other"
  [production]
  (archive-sektion production :master)
  ;; place the iso in a spool directory
  (let [product_number (:product_number production)
        multi-volume? (prod/multi-volume? production)]
    (doseq [volume (range 1 (inc (:volumes production)))]
      (let [iso-archive-name (str product_number (when multi-volume? (str "_" volume)) ".iso")
            iso-archive-path (.getPath (file other-spool-dir iso-archive-name))]
        (fs/copy (path/iso-name production volume) iso-archive-path)))))

(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [environ.core :refer [env]]
            [me.raynes.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.rdf :as rdf]))

(def ^:private db (env :archive-database-url))

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(def ^:private default-job
  {:verzeichnis ""
   :archivar "NN"
   :abholer "NN"
   :aktion "save"
   :transaktions_status "pending"})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str "ds" (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn- container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [id (container-id production sektion)]
    (.getPath (file spool-dir id "produkt"))))

(defn- container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [path (container-id production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file spool-dir path rdf-name))))

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [new-job
        {:verzeichnis (container-id production sektion)
         :sektion (case sektion :master "master" :dist-master "cdimage")}
        job (merge default-job new-job)]
    (jdbc/insert! db :container job)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-path (container-path production sektion)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s already exists" archive-path)
      (case sektion
        :master
        (fs/copy-dir (path/recorded-path production) archive-path)
        :dist-master
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                iso-archive-path (.getPath (file archive-path iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        entries (case sektion :master 2 :dist-master (inc (:volumes production)))]
    (let [rdf-path (container-rdf-path production sektion)]
      (spit rdf-path rdf))))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (archive-sektion production :master)
  (archive-sektion production :dist-master)
  (prod/set-state! production "archived"))

(defmethod archive "periodical"
  [production]
  (archive-sektion production :master)
  ;; archive the periodical iso(s)
  (let [dam-number (prod/dam-number production)
        archive-path (.getPath (file periodical-spool-dir dam-number))
        multi-volume? (prod/multi-volume? production)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s for periodical already exists" archive-path)
      (do
        (fs/mkdir archive-path)
        ;; create the rdf
        (let [rdf-path (file archive-path (str dam-number ".rdf"))
              rdf (rdf/rdf production)]
          (spit rdf-path rdf))
        ;; copy all volumes
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
                iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))
        (prod/set-state! production "archived")))))

(defmethod archive "other"
  [production]
  (archive-sektion production :master)
  ;; place the iso in a spool directory
  (let [product_number (:product_number production)
        multi-volume? (prod/multi-volume? production)]
    (doseq [volume (range 1 (inc (:volumes production)))]
      (let [iso-archive-name (str product_number (when multi-volume? (str "_" volume)) ".iso")
            iso-archive-path (.getPath (file other-spool-dir iso-archive-name))]
        (fs/copy (path/iso-name production volume) iso-archive-path)))
    (prod/set-state! production "archived")))

Set state when archiving

Set state when archiving


(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [environ.core :refer [env]]
            [clj-time.core :as t]
            [me.raynes.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.rdf :as rdf]))

(def ^:private db (env :archive-database-url))

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(def ^:private default-job
  {:archivar "Madras2"
   :abholer ""
   :aktion "save"
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn- container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [id (container-id production sektion)]
    (.getPath (file spool-dir id "produkt"))))

(defn- container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [path (container-id production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file spool-dir path rdf-name))))

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [new-job
        {:verzeichnis (container-id production sektion)
         :sektion (case sektion :master "master" :dist-master "cdimage")
         :datum (t/now)}
        job (merge default-job new-job)]
    (jdbc/insert! db :container job)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-path (container-path production sektion)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s already exists" archive-path)
      (case sektion
        :master
        (fs/copy-dir (path/recorded-path production) archive-path)
        :dist-master
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                iso-archive-path (.getPath (file archive-path iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        entries (case sektion :master 2 :dist-master (inc (:volumes production)))]
    (let [rdf-path (container-rdf-path production sektion)]
      (spit rdf-path rdf))))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (archive-sektion production :master)
  (archive-sektion production :dist-master)
  (prod/set-state! production "archived"))

(defmethod archive "periodical"
  [production]
  (archive-sektion production :master)
  ;; archive the periodical iso(s)
  (let [dam-number (prod/dam-number production)
        archive-path (.getPath (file periodical-spool-dir dam-number))
        multi-volume? (prod/multi-volume? production)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s for periodical already exists" archive-path)
      (do
        (fs/mkdir archive-path)
        ;; create the rdf
        (let [rdf-path (file archive-path (str dam-number ".rdf"))
              rdf (rdf/rdf production)]
          (spit rdf-path rdf))
        ;; copy all volumes
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
                iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))
        (prod/set-state! production "archived")))))

(defmethod archive "other"
  [production]
  (archive-sektion production :master)
  ;; place the iso in a spool directory
  (let [product_number (:product_number production)
        multi-volume? (prod/multi-volume? production)]
    (doseq [volume (range 1 (inc (:volumes production)))]
      (let [iso-archive-name (str product_number (when multi-volume? (str "_" volume)) ".iso")
            iso-archive-path (.getPath (file other-spool-dir iso-archive-name))]
        (fs/copy (path/iso-name production volume) iso-archive-path)))
    (prod/set-state! production "archived")))

(ns mdr2.archive
  "Main entry point into the archive

For archiving we need to interface with an existing legacy system
named agadir. It doesn't do very much in very complicated ways.
Probably best to replace it at some point. In the mean time we try to
stay away from it and not to change too much. From reading the source
it appears that in order to archive a production you need to first
archive what they call the *master*, i.e. the dtb containing the wav
files and after that you'll have to archive the so-called *distribution
master* which is basically the same thing but the audio is encoded as
mp3 and the whole thing is packed up in one or more iso files

### Archiving the *master*

1. place it in a magic spool directory
2. generate an rdf file containing some meta data about the production
3. add an entry to a table in a database. Specify the `sektion` to be `master`

### Archiving the *distribution master*

1. Encode the audio to mp3
2. Pack everything up in an iso
3. place this iso in the magic spool directory
4. generate the rdf as above
5. add an entry to a table in a database. The `sektion` should be `cdimage`
"
  ;; FIXME: Most likely this should be split off into a separate lib that
  ;; replaces all of agadir at a later point in time. For instructions on
  ;; how to do this see
  ;; https://github.com/technomancy/leiningen/blob/stable/doc/DEPLOY.md

  (:require [clojure.java.jdbc :as jdbc]
            [clojure.java.io :refer [file]]
            [clojure.tools.logging :as log]
            [environ.core :refer [env]]
            [clj-time.core :as t]
            [clj-time.coerce :refer [to-date]]
            [me.raynes.fs :as fs]
            [mdr2.production :as prod]
            [mdr2.production.path :as path]
            [mdr2.rdf :as rdf]))

(def ^:private db (env :archive-database-url))

(def spool-dir
  "Path to the archive spool directory, i.e. where to place incoming
  productions that are to be archived"
   (env :archive-spool-dir))

(def periodical-spool-dir
  "Path to the archive spool directory for periodicals"
  (env :archive-periodical-spool-dir))

(def other-spool-dir
  "Path to the archive spool directory for other productions"
  (env :archive-other-spool-dir))

(def ^:private default-job
  {:archivar "Madras2"
   :abholer ""
   :aktion "save"
   :transaktions_status "pending"
   :container_status "ok"
   :bemerkung ""})

(defn- container-id
  "Return the name of a archive spool directory for a given
  `production` and `sektion`"
  ([production sektion]
   (container-id production sektion nil))
  ([production sektion volume]
   (case sektion
     :master (prod/dam-number production)
     :dist-master (str (:library_signature production)
                       (when (and volume
                                  (prod/multi-volume? production))
                         (str "_" volume))))))

(defn- container-path
  "Return the path to the archive spool directory for a given
  `production` and `sektion`"
  [production sektion]
  (let [id (container-id production sektion)]
    (.getPath (file spool-dir id "produkt"))))

(defn- container-rdf-path
  "Return the path to the rdf file in the archive spool for a given
  `production` and `sektion`"
  [production sektion]
  (let [path (container-id production sektion)
        rdf-name (str (container-id production sektion) ".rdf")]
    (.getPath (file spool-dir path rdf-name))))

(defn- add-to-db
  "Insert a `production` into the archive db for the given `sektion`.
  This marks the files in the spool directory as ready for archiving
  and concludes the archiving process from the point of view of the
  production system."
  [production sektion]
  (let [new-job
        {:verzeichnis (container-id production sektion)
         :sektion (case sektion :master "master" :dist-master "cdimage")
         :datum (to-date (t/now))}
        job (merge default-job new-job)]
    (jdbc/insert! db :container job)))

(defn- copy-files
  "Copy a `production` to the archive spool dir for the given
  `sektion`. For a production master copy the whole DTB including wav
  files. For a production distribution master copy the isos"
  [production sektion]
  (let [archive-path (container-path production sektion)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s already exists" archive-path)
      (case sektion
        :master
        (fs/copy-dir (path/recorded-path production) archive-path)
        :dist-master
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str (container-id production sektion volume) ".iso")
                iso-archive-path (.getPath (file archive-path iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))))))

(defn- create-rdf
  "Create an rdf file and place it in the appropriate archive spool
  directory"
  [production sektion]
  (let [rdf (rdf/rdf production)
        entries (case sektion :master 2 :dist-master (inc (:volumes production)))]
    (let [rdf-path (container-rdf-path production sektion)]
      (spit rdf-path rdf))))

(defn- archive-sektion
  "Archive a `production` for given `sektion`. For the :master sektion
  copy the original DTB including the wav files. For the :dist-master
  sektion copy one or more iso files"
  [production sektion]
  ;; place all the files in the spool dir
  (copy-files production sektion)
  ;; create an rdf file
  (create-rdf production sektion)
  ;; add it to the db so that the agadir machinery will pick it up
  (add-to-db production sektion))

(defmulti archive
  "Archive a `production`"
  (fn [production] (:production_type production))
  :default "book")

(defmethod archive "book"
  [production]
  (archive-sektion production :master)
  (archive-sektion production :dist-master)
  (prod/set-state! production "archived"))

(defmethod archive "periodical"
  [production]
  (archive-sektion production :master)
  ;; archive the periodical iso(s)
  (let [dam-number (prod/dam-number production)
        archive-path (.getPath (file periodical-spool-dir dam-number))
        multi-volume? (prod/multi-volume? production)]
    (if (fs/exists? archive-path)
      (log/errorf "Archive path %s for periodical already exists" archive-path)
      (do
        (fs/mkdir archive-path)
        ;; create the rdf
        (let [rdf-path (file archive-path (str dam-number ".rdf"))
              rdf (rdf/rdf production)]
          (spit rdf-path rdf))
        ;; copy all volumes
        (doseq [volume (range 1 (inc (:volumes production)))]
          (let [iso-archive-name (str dam-number (when multi-volume? (str "_" volume)) ".iso")
                iso-archive-path (.getPath (file archive-path "produkt" iso-archive-name))]
            (fs/copy+ (path/iso-name production volume) iso-archive-path)))
        (prod/set-state! production "archived")))))

(defmethod archive "other"
  [production]
  (archive-sektion production :master)
  ;; place the iso in a spool directory
  (let [product_number (:product_number production)
        multi-volume? (prod/multi-volume? production)]
    (doseq [volume (range 1 (inc (:volumes production)))]
      (let [iso-archive-name (str product_number (when multi-volume? (str "_" volume)) ".iso")
            iso-archive-path (.getPath (file other-spool-dir iso-archive-name))]
        (fs/copy (path/iso-name production volume) iso-archive-path)))
    (prod/set-state! production "archived")))

Insert a date when a date is required

Insert a date when a date is required


(ns mdr2.handler
  "Main entry points to the application"
  (:require [compojure.core :refer [defroutes GET POST]]
            [compojure.handler :as handler]
            [hiccup.middleware :refer [wrap-base-url]]
            [compojure.route :as route]
            [cemerick.friend :as friend]
            (cemerick.friend [workflows :as workflows]
                             [credentials :as creds])
            [ring.util.response :as response]
            [ring.middleware.defaults :refer [wrap-defaults site-defaults]]
            [mdr2.db :as db]
            [mdr2.views :as views]))

(defroutes app-routes
  "Main routes for the application"
  (GET "/" request (views/home request))
  ;; bulk import of productions
  (GET "/production/upload" request
       (friend/authenticated (views/production-bulk-import-form request)))
  (POST "/production/upload-confirm" [file :as r]
        (friend/authenticated (views/production-bulk-import-confirm r file)))
  (POST "/production/upload" [productions]
        (friend/authenticated (views/production-bulk-import productions)))
  ;; repair productions
  (GET "/production/repair" request
       (friend/authenticated (views/production-repair-form request)))
  (POST "/production/repair-confirm" [identifier :as r]
        (friend/authenticated (views/production-repair-confirm r identifier)))
  (POST "/production/repair" [id]
        (friend/authenticated (views/production-repair id)))
  ;; individual productions
  (GET "/production/:id.xml" [id]
       (friend/authenticated (views/production-xml id)))
  (GET "/production/:id/upload" [id :as r]
       (friend/authenticated (views/file-upload-form r id)))
  (POST "/production/:id/upload" [id file :as r]
        (friend/authenticated (views/production-add-xml r id file)))
  (POST "/production/:id/state" [id state]
        (friend/authenticated (views/production-set-state id state)))
  (GET "/production/:id/split" [id :as r]
       (friend/authenticated (views/production-split-form r id)))
  (POST "/production/:id/split" [id volumes sample-rate bitrate]
        (friend/authenticated (views/production-split id volumes sample-rate bitrate)))
  ;; catalog
  (GET "/catalog" request
       (friend/authenticated (views/catalog request)))
  (POST "/catalog/:id" [id library_signature]
        (friend/authenticated (views/production-catalog id library_signature)))
  (GET "/production/:id" [id :as r]
       (friend/authenticated (views/production r id)))
  (GET "/production/:id/delete" [id]
       (friend/authorize #{:admin} (views/production-delete id)))
  ;; production monitoring
  (GET "/psm.csv" [] (views/production-monitoring))
  ;; auth
  (GET "/login" [] (views/login-form))
  (GET "/logout" req (friend/logout* (response/redirect "/")))
  ;; resources and 404
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  "Main handler for the application"
  (-> app-routes
      (friend/authenticate
       {:credential-fn (partial creds/bcrypt-credential-fn db/get-user)
        :workflows [(workflows/interactive-form)]
        :unauthorized-handler views/unauthorized})
      (wrap-defaults site-defaults)
      wrap-base-url))

(ns mdr2.handler
  "Main entry points to the application"
  (:require [compojure.core :refer [defroutes GET POST]]
            [compojure.handler :as handler]
            [hiccup.middleware :refer [wrap-base-url]]
            [compojure.route :as route]
            [cemerick.friend :as friend]
            (cemerick.friend [workflows :as workflows]
                             [credentials :as creds])
            [ring.util.response :as response]
            [ring.middleware.defaults :refer [wrap-defaults site-defaults]]
            [mdr2.db :as db]
            [mdr2.views :as views]))

(defroutes app-routes
  "Main routes for the application"
  (GET "/" request (views/home request))
  ;; bulk import of productions
  (GET "/production/upload" request
       (friend/authenticated (views/production-bulk-import-form request)))
  (POST "/production/upload-confirm" [file :as r]
        (friend/authenticated (views/production-bulk-import-confirm r file)))
  (POST "/production/upload" [productions]
        (friend/authenticated (views/production-bulk-import productions)))
  ;; repair productions
  (GET "/production/repair" request
       (friend/authenticated (views/production-repair-form request)))
  (POST "/production/repair-confirm" [identifier :as r]
        (friend/authenticated (views/production-repair-confirm r identifier)))
  (POST "/production/repair" [id]
        (friend/authenticated (views/production-repair id)))
  ;; individual productions
  (GET "/production/:id.xml" [id]
       (friend/authenticated (views/production-xml id)))
  (GET "/production/:id/upload" [id :as r]
       (friend/authenticated (views/file-upload-form r id)))
  (POST "/production/:id/upload" [id file :as r]
        (friend/authenticated (views/production-add-xml r id file)))
  (POST "/production/:id/state" [id state]
        (friend/authenticated (views/production-set-state id state)))
  (GET "/production/:id/split" [id :as r]
       (friend/authenticated (views/production-split-form r id)))
  (POST "/production/:id/split" [id volumes sample-rate bitrate]
        (friend/authenticated (views/production-split id volumes sample-rate bitrate)))
  ;; catalog
  (GET "/catalog" request
       (friend/authenticated (views/catalog request)))
  (POST "/catalog/:id" [id library_signature]
        (friend/authenticated (views/production-catalog id library_signature)))
  (GET "/production/:id" [id :as r]
       (friend/authenticated (views/production r id)))
  (GET "/production/:id/delete" [id]
       (friend/authorize #{:admin} (views/production-delete id)))
  ;; production monitoring
  (GET "/psm.csv" [] (views/production-monitoring))
  ;; auth
  (GET "/login" [] (views/login-form))
  (GET "/logout" req (friend/logout* (response/redirect "/")))
  ;; resources and 404
  (route/resources "/")
  (route/not-found "Not Found"))

(def app
  "Main handler for the application"
  (-> app-routes
      (friend/authenticate
       {:credential-fn (partial creds/bcrypt-credential-fn db/get-user)
        :workflows [(workflows/interactive-form)]
        :unauthorized-handler views/unauthorized})
      (wrap-defaults (assoc-in site-defaults [:static :resources] false))
      wrap-base-url))

Work around a ring bug that only occurs in-container

Thanks to tcrawley


(ns oc.storage.util.ziggeo
  "
   Make a simple GET request for video information from Ziggeo.
   Based on Ziggeo SDK at https://github.com/Ziggeo/ZiggeoPythonSdk

   TODO: Maybe in the future we can create a full clojure SDK.
  "
  (:require [org.httpkit.client :as http]
            [cheshire.core :as json]
            [clojure.walk :refer (keywordize-keys)]
            [oc.storage.config :as config]))

(defonce ziggeo-api-url "https://srvapi.ziggeo.com/v1")

(defonce auth {:username config/ziggeo-api-token
               :password config/ziggeo-api-key})

(defn auth-options [auth]
  {:headers {
             "Content-Type" "application/json"
             }
   :basic-auth [(:username auth) (:password auth)]})

(defn video
  "
    https://ziggeo.com/docs/api/resources/video The data structure returned
    from the api call.

    Info we are interested in ':state' if this is greater than 4 , then the
    video is processed.

    ':original_stream { :audio_transcription { :text "" }}' Will contain the
    transcription data for the video.
  "
  [token cb]
  (http/get (str ziggeo-api-url "/videos/" token) (auth-options auth)
    (fn [{:keys [status headers body error] :as resp}]
      (when (and (> status 199) (< status 500))
        (cb (-> body
                json/parse-string
                keywordize-keys))))))

(ns oc.storage.util.ziggeo
  "
   Make a simple GET request for video information from Ziggeo.
   Based on Ziggeo SDK at https://github.com/Ziggeo/ZiggeoPythonSdk

   TODO: Maybe in the future we can create a full clojure SDK.
  "
  (:require [org.httpkit.client :as http]
            [cheshire.core :as json]
            [clojure.walk :refer (keywordize-keys)]
            [oc.storage.config :as config]))

(defonce ziggeo-api-url "https://srvapi.ziggeo.com/v1")

(defonce auth {:username config/ziggeo-api-token
               :password config/ziggeo-api-key})

(defn auth-options [auth]
  {:headers {
             "Content-Type" "application/json"
             }
   :basic-auth [(:username auth) (:password auth)]})

(defn video
  "
  https://ziggeo.com/docs/api/resources/video The data structure returned
  from the api call.

  Info we are interested in ':state' if this is greater than 4 , then the
  video is processed.

  `:original_stream { :audio_transcription { :text '' }}` Will contain the
  transcription data for the video.
  "
  [token cb]
  (http/get (str ziggeo-api-url "/videos/" token) (auth-options auth)
    (fn [{:keys [status headers body error] :as resp}]
      (when (and (> status 199) (< status 500))
        (cb (-> body
                json/parse-string
                keywordize-keys))))))

Fix docstring.

Fix docstring.


(ns om-next-todolist.core
  (:require [goog.dom :as gdom]
            [om.next :as om :refer-macros [defui]]
            [om.dom :as dom]))

(enable-console-print!)

(println "Hello world!")

(ns om-next-todolist.core
  (:require [goog.dom :as gdom]
            [om.next :as om :refer-macros [defui]]
            [om.dom :as dom]))

(enable-console-print!)

(def app-state
  (atom {:todos [{:id 1 :title "豚肉を買ってくる"}
                 {:id 2 :title "たまねぎを買ってくる"}
                 {:id 3 :title "にんじんを買ってくる"}
                 {:id 4 :title "じゃがいもを買ってくる"}
                 {:id 5 :title "カレーを作る"}]}))

(defui TodoItem
  Object
  (render [this]
    (let [props (om/props this)
          title (:title props)]
      (dom/li nil title))))

(def todo-item (om/factory TodoItem))

(defui TodoList
  Object
  (render [this]
    (let [props (om/props this)
          todos (:todos props)]
      (apply dom/ul nil
        (map todo-item todos)))))

(def reconciler
  (om/reconciler {:state app-state}))

(om/add-root! reconciler TodoList (gdom/getElement "app"))

enable to display todo list

enable to display todo list


(ns neuseg.train
  (:use [clj-tuple]
        [clojure.core.matrix :only [dot zero-vector]]
        [neuseg.db]
        [com.guokr.nlp.seg])
  (:import (com.guokr.neuseg.util NGram
                                  Neighbors)))

(defn- mdot [vecs]
  (let [mid 4
        mid-vec (nth vecs mid)]
    (map (partial dot mid-vec) (concat (take mid vecs) (drop (inc mid) vecs)))))

(defn- zip [& colls]
  (map flatten (partition (count colls) (apply interleave colls))))

(defn- format-case [input output]
  (clojure.string/join "\n" (map (partial clojure.string/join " ") [input output])))

(defn tagging [text]
  (let [seged (seg text)]
		(loop [raw text
           sgd seged
           ret [1]]
      (if (nil? (second raw)) (conj ret 1)
        (if (= (second raw) (second sgd))
          (recur (rest raw) (rest sgd) (conj ret -1 -1))
          (recur (rest raw) (nthrest sgd 2) (conj ret 1 1)))))))

(defn gen-cases [text]
  (clojure.string/join "\n"
    (map format-case (zip (map mdot (Neighbors/slider 4 unizero  (map get-vector (iterator-seq (NGram/unigram text)))))
                          (map mdot (Neighbors/slider 4 bizero   (map get-vector (iterator-seq (NGram/bigram text)))))
                          (map mdot (Neighbors/slider 4 trizero  (map get-vector (iterator-seq (NGram/trigram text)))))
                          (map mdot (Neighbors/slider 4 quadzero (map get-vector (iterator-seq (NGram/quadgram text))))))
                          (partition 2 (tagging text)))))

(defn gen-train [file-corpus file-output]
  (with-open [wrtr (writer file-output {:encoding "utf-8"})]
    (with-open [rdr (reader file-corpus {:encoding "utf-8"})]
      (let [text (clojure.string/join "" (line-seq rdr))]
        (.write wrtr (str (count text) " 32 2\n"))
        (.write wrtr (gen-cases text))))))

(defn prepare []
  (gen-train "data/corpus/corpus" "data/trains/train"))

(ns neuseg.train
  (:use [clj-tuple]
        [clojure.java.io]
        [clojure.core.matrix :only [dot zero-vector]]
        [neuseg.db]
        [com.guokr.nlp.seg])
  (:import (com.guokr.neuseg.util NGram
                                  Neighbors)))

(defn- mdot [vecs]
  (let [mid 4
        mid-vec (nth vecs mid)]
    (map (partial dot mid-vec) (concat (take mid vecs) (drop (inc mid) vecs)))))

(defn- zip [& colls]
  (map flatten (partition (count colls) (apply interleave colls))))

(defn- format-case [input output]
  (clojure.string/join "\n" (map (partial clojure.string/join " ") [input output])))

(defn tagging [text]
  (let [seged (seg text)]
		(loop [raw text
           sgd seged
           ret [1]]
      (if (nil? (second raw)) (conj ret 1)
        (if (= (second raw) (second sgd))
          (recur (rest raw) (rest sgd) (conj ret -1 -1))
          (recur (rest raw) (nthrest sgd 2) (conj ret 1 1)))))))

(defn gen-cases [text]
  (clojure.string/join "\n"
    (map format-case (zip (map mdot (Neighbors/slider 4 unizero  (map get-vector (iterator-seq (NGram/unigram text)))))
                          (map mdot (Neighbors/slider 4 bizero   (map get-vector (iterator-seq (NGram/bigram text)))))
                          (map mdot (Neighbors/slider 4 trizero  (map get-vector (iterator-seq (NGram/trigram text)))))
                          (map mdot (Neighbors/slider 4 quadzero (map get-vector (iterator-seq (NGram/quadgram text))))))
                          (partition 2 (tagging text)))))

(defn gen-train [file-corpus file-output]
  (with-open [wrtr (writer file-output {:encoding "utf-8"})]
    (with-open [rdr (reader file-corpus {:encoding "utf-8"})]
      (let [text (clojure.string/join "" (line-seq rdr))]
        (.write wrtr (str (count text) " 32 2\n"))
        (.write wrtr (gen-cases text))))))

(defn prepare []
  (gen-train "data/corpus/corpus" "data/trains/train"))

use clojure.java.io

use clojure.java.io


(ns onyx.plugin.core-async
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout go <!]]
            [onyx.peer.task-lifecycle-extensions :as l-ext]
            [onyx.peer.pipeline-extensions :as p-ext]
            [taoensso.timbre :refer [debug] :as timbre]))

(defmethod l-ext/inject-lifecycle-resources :core.async/read-from-chan
  [_ event]
  {:core.async/pending-messages (atom {})
   :core.async/retry-ch (chan 1000)})

(defmethod p-ext/read-batch [:input :core.async]
  [{:keys [onyx.core/task-map core.async/chan core.async/retry-ch
           core.async/pending-messages] :as event}]
  (let [batch-size (:onyx/batch-size task-map)
        ms (or (:onyx/batch-timeout task-map) 50)
        batch (->> (range batch-size)
                   (map (fn [_] {:id (java.util.UUID/randomUUID)
                                :input :core.async
                                :message (first (alts!! [retry-ch chan (timeout ms)] :priority true))}))
                   (filter (comp not nil? :message)))]
    (doseq [m batch]
      (swap! pending-messages assoc (:id m) (:message m)))
    {:onyx.core/batch batch}))

(defmethod p-ext/decompress-batch [:input :core.async]
  [{:keys [onyx.core/batch]}]
  {:onyx.core/decompressed batch})

(defmethod p-ext/apply-fn [:input :core.async]
  [event segment]
  segment)

(defmethod p-ext/ack-message [:input :core.async]
  [{:keys [core.async/pending-messages]} message-id]
  (swap! pending-messages dissoc message-id))

(defmethod p-ext/retry-message [:input :core.async]
  [{:keys [core.async/pending-messages core.async/retry-ch]} message-id]
  (>!! retry-ch (get @pending-messages message-id))
  (swap! pending-messages dissoc message-id))

(defmethod p-ext/pending? [:input :core.async]
  [{:keys [core.async/pending-messages]} message-id]
  (get @pending-messages message-id))

(defmethod p-ext/drained? [:input :core.async]
  [{:keys [core.async/pending-messages]}]
  (let [x @pending-messages]
    (and (= (count (keys x)) 1)
         (= (first (vals x)) :done))))

(defmethod p-ext/apply-fn [:output :core.async]
  [event segment]
  segment)

(defmethod p-ext/compress-batch [:output :core.async]
  [{:keys [onyx.core/results]}]
  {:onyx.core/compressed results})

(defmethod p-ext/write-batch [:output :core.async]
  [{:keys [onyx.core/compressed core.async/chan]}]
  (doseq [segment compressed]
    (>!! chan (:message segment)))
  {})

(defmethod p-ext/seal-resource [:output :core.async]
  [{:keys [core.async/chan]}]
  (>!! chan :done))

(defn take-segments!
  "Takes segments off the channel until :done is found.
   Returns a seq of segments, including :done."
  [ch]
  (loop [x []]
    (let [segment (<!! ch)]
      (let [stack (conj x segment)]
        (if-not (= segment :done)
          (recur stack)
          stack)))))

(ns onyx.plugin.core-async
  (:require [clojure.core.async :refer [chan >!! <!! alts!! timeout go <!]]
            [onyx.peer.task-lifecycle-extensions :as l-ext]
            [onyx.peer.pipeline-extensions :as p-ext]
            [taoensso.timbre :refer [debug] :as timbre]))

(defmethod l-ext/inject-lifecycle-resources :core.async/read-from-chan
  [_ event]
  {:core.async/pending-messages (atom {})
   :core.async/retry-ch (chan 1000)})

(defmethod p-ext/read-batch [:input :core.async]
  [{:keys [onyx.core/task-map core.async/chan core.async/retry-ch
           core.async/pending-messages] :as event}]
  (let [pending (count (keys @pending-messages))
        max-pending (or (:onyx/max-pending task-map) 10000)
        batch-size (:onyx/batch-size task-map)
        max-segments (min (- max-pending pending) batch-size)
        ms (or (:onyx/batch-timeout task-map) 50)
        batch (->> (range max-segments)
                   (map (fn [_] {:id (java.util.UUID/randomUUID)
                                :input :core.async
                                :message (first (alts!! [retry-ch chan (timeout ms)] :priority true))}))
                   (filter (comp not nil? :message)))]
    (doseq [m batch]
      (swap! pending-messages assoc (:id m) (:message m)))
    {:onyx.core/batch batch}))

(defmethod p-ext/decompress-batch [:input :core.async]
  [{:keys [onyx.core/batch]}]
  {:onyx.core/decompressed batch})

(defmethod p-ext/apply-fn [:input :core.async]
  [event segment]
  segment)

(defmethod p-ext/ack-message [:input :core.async]
  [{:keys [core.async/pending-messages]} message-id]
  (swap! pending-messages dissoc message-id))

(defmethod p-ext/retry-message [:input :core.async]
  [{:keys [core.async/pending-messages core.async/retry-ch]} message-id]
  (>!! retry-ch (get @pending-messages message-id))
  (swap! pending-messages dissoc message-id))

(defmethod p-ext/pending? [:input :core.async]
  [{:keys [core.async/pending-messages]} message-id]
  (get @pending-messages message-id))

(defmethod p-ext/drained? [:input :core.async]
  [{:keys [core.async/pending-messages]}]
  (let [x @pending-messages]
    (and (= (count (keys x)) 1)
         (= (first (vals x)) :done))))

(defmethod p-ext/apply-fn [:output :core.async]
  [event segment]
  segment)

(defmethod p-ext/compress-batch [:output :core.async]
  [{:keys [onyx.core/results]}]
  {:onyx.core/compressed results})

(defmethod p-ext/write-batch [:output :core.async]
  [{:keys [onyx.core/compressed core.async/chan]}]
  (doseq [segment compressed]
    (>!! chan (:message segment)))
  {})

(defmethod p-ext/seal-resource [:output :core.async]
  [{:keys [core.async/chan]}]
  (>!! chan :done))

(defn take-segments!
  "Takes segments off the channel until :done is found.
   Returns a seq of segments, including :done."
  [ch]
  (loop [x []]
    (let [segment (<!! ch)]
      (let [stack (conj x segment)]
        (if-not (= segment :done)
          (recur stack)
          stack)))))

Implement max pending.

Implement max pending.


(ns open-company.resources.report
  (:require [defun :refer (defun)]
            [rethinkdb.query :as r]
            [open-company.config :as c]
            [open-company.resources.common :as common]
            [open-company.resources.company :as company]))

(def ^:private table-name :reports)
(def ^:private primary-key :symbol-year-period)

(defn- get-periods [prefix n]
  (into #{} (map #(str prefix %) (range 1 (+ n 1)))))

(def periods (into #{} (concat
                (get-periods "Q" 4)
                (get-periods "M" 12))))

(defn- key-for
  ([report] (key-for (:symbol report) (:year report) (:period report)))
  ([ticker year period] (str ticker "-" year "-" period)))

;; ----- Validations -----

(defn- not-a-number?
  "Return `true` if the string cannot be converted into an integer."
  [string]
  (try (Integer. string) false
    (catch NumberFormatException e true)))

(defun valid-year?
  "Return `true` if the specified period is valid, `false` if not."
  ([year :guard integer?] (and (> year 1900) (< year 3000)))
  ([_year :guard #(and (string? %) (not-a-number? %))] false)
  ([year :guard string?] (valid-year? (Integer. year))))

(defn valid-period?
  "Return `true` if the specified period is valid, `false` if not."
  [period]
  (if (periods period) true false))

(defun valid-report
  "Validate the ticker symbol, year and period of the report
  returning `:bad-company`, `:bad-year` and `bad-period` respectively.
  TODO: Use prismatic schema to validate report properties."
  ([ticker year period] (valid-report ticker year period {}))
  ([_ _year :guard #(not (valid-year? %)) _ _] :bad-year)
  ([_ _ _period :guard #(not (valid-period? %)) _] :bad-period)
  ([_ticker :guard #(not (company/get-company %)) _ _ _] :bad-company)
  ([_ _ _ _] true))

;; ----- Report CRUD -----

(defn get-report
  "Given the ticker symbol of the company and the year and period of the report,
  or the primary key, retrieve it from the database, or return nil if it doesn't exist."
  ([ticker year period] (get-report ticker (key-for ticker year period)))
  ([ticker report-key]
    (when (company/get-company ticker)
      (common/read-resource table-name report-key))))

(defun create-report
  "Given the report property map, create the report returning the property map for the resource or `false`.
  Return `:bad-company` if the company for the report does not exist."
  ([report :guard #(company/get-company (:symbol %))]
    (common/create-resource table-name (assoc report primary-key (key-for report))))
  ([_] :bad-company))

(defn update-report
  "Given the an updated report property map, update the report and return `true` on success."
  [report]
  (if-let [original-report (get-report (:symbol report) (:year report) (:period report))]
    (common/update-resource table-name primary-key original-report (assoc report primary-key (key-for report)))
    :bad-company))

(defun put-report
  "Given a report property map, create or update the report and return `true` on success."
  ([report :guard #(get-report (key-for %))] (update-report report))
  ([report] (create-report report)))

(defn delete-report
  "Given the ticker symbol of the company and the year and period of the report, delete the report and return `true`."
  [ticker year period]
  (common/delete-resource table-name (key-for ticker year period)))

;; ----- Collection of reports -----

(defn list-reports
  "Given the ticker symbol of a company, return a sequence of report hashes with `:year` and `:period`."
  [ticker]
  (vec (with-open [conn (apply r/connect c/db-options)]
    (-> (r/table table-name)
      (r/get-all [ticker] {:index :symbol})
      (r/with-fields ["year" "period"])
      (r/run conn)))))

(defn report-count
  "Given the ticker symbol of a company, return how many reports exist for the company."
  [ticker]
  (with-open [conn (apply r/connect c/db-options)]
    (-> (r/table table-name)
      (r/get-all [ticker] {:index :symbol})
      (r/count)
      (r/run conn))))

(defn delete-all-reports!
  "Use with caution! Failure can result in partial deletes of just some reports. Returns `true` if successful."
  []
  (common/delete-all-resources! table-name))

(ns open-company.resources.report
  (:require [clojure.string :as s]
            [defun :refer (defun)]
            [rethinkdb.query :as r]
            [open-company.config :as c]
            [open-company.resources.common :as common]
            [open-company.resources.company :as company]))

(def ^:private table-name :reports)
(def ^:private primary-key :symbol-year-period)

(defn- get-periods [prefix n]
  (into #{} (map #(str prefix %) (range 1 (+ n 1)))))

(def periods (into #{} (concat
                (get-periods "Q" 4)
                (get-periods "M" 12))))

(defn- key-for
  ([report] (key-for (:symbol report) (:year report) (:period report)))
  ([ticker year period] (str ticker "-" year "-" period)))

;; ----- Validations -----

(defn- not-a-number?
  "Return `true` if the string cannot be converted into an integer."
  [string]
  (try (Integer. string) false
    (catch NumberFormatException e true)))

(defun valid-year?
  "Return `true` if the specified period is valid, `false` if not."
  ([year :guard integer?] (and (> year 1900) (< year 3000)))
  ([_year :guard #(and (string? %) (not-a-number? %))] false)
  ([year :guard string?] (valid-year? (Integer. year))))

(defn valid-period?
  "Return `true` if the specified period is valid, `false` if not."
  [period]
  (if (periods period) true false))

(defun valid-report
  "Validate the ticker symbol, year and period of the report
  returning `:bad-company`, `:bad-year` and `bad-period` respectively.
  TODO: Use prismatic schema to validate report properties."
  ([ticker year period] (valid-report ticker year period {}))
  ([_ _year :guard #(not (valid-year? %)) _ _] :bad-year)
  ([_ _ _period :guard #(not (valid-period? %)) _] :bad-period)
  ([_ticker :guard #(not (company/get-company %)) _ _ _] :bad-company)
  ([_ _ _ _] true))

;; ----- Report CRUD -----

(defn get-report
  "Given the ticker symbol of the company and the year and period of the report,
  or the primary key, retrieve it from the database, or return nil if it doesn't exist."
  ([report-key] (get-report (first (s/split report-key #"-")) report-key))
  ([ticker report-key]
    (when (company/get-company ticker)
      (common/read-resource table-name report-key)))
  ([ticker year period] (get-report ticker (key-for ticker year period))))

(defun create-report
  "Given the report property map, create the report returning the property map for the resource or `false`.
  Return `:bad-company` if the company for the report does not exist."
  ([report :guard #(company/get-company (:symbol %))]
    (common/create-resource table-name (assoc report primary-key (key-for report))))
  ([_] :bad-company))

(defn update-report
  "Given the an updated report property map, update the report and return `true` on success."
  [report]
  (if-let [original-report (get-report (:symbol report) (:year report) (:period report))]
    (common/update-resource table-name primary-key original-report (assoc report primary-key (key-for report)))
    :bad-company))

(defun put-report
  "Given a report property map, create or update the report and return `true` on success."
  ([report :guard #(get-report (key-for %))] (update-report report))
  ([report] (create-report report)))

(defn delete-report
  "Given the ticker symbol of the company and the year and period of the report, delete the report and return `true`."
  [ticker year period]
  (common/delete-resource table-name (key-for ticker year period)))

;; ----- Collection of reports -----

(defn list-reports
  "Given the ticker symbol of a company, return a sequence of report hashes with `:year` and `:period`."
  [ticker]
  (vec (with-open [conn (apply r/connect c/db-options)]
    (-> (r/table table-name)
      (r/get-all [ticker] {:index :symbol})
      (r/with-fields ["year" "period"])
      (r/run conn)))))

(defn report-count
  "Given the ticker symbol of a company, return how many reports exist for the company."
  [ticker]
  (with-open [conn (apply r/connect c/db-options)]
    (-> (r/table table-name)
      (r/get-all [ticker] {:index :symbol})
      (r/count)
      (r/run conn))))

(defn delete-all-reports!
  "Use with caution! Failure can result in partial deletes of just some reports. Returns `true` if successful."
  []
  (common/delete-all-resources! table-name))

Allow report/get-report to still take just a report-key as an argument as that arity/1 version is used in a guard expression.


(ns twitterbuzz.showgraph
  (:require [twitterbuzz.core :as buzz]
            [twitterbuzz.anneal :as ann]
            [twitterbuzz.layout :as layout]
            [goog.dom :as dom]
            [goog.events :as events]
            [goog.fx.Animation :as anim]
            [goog.graphics.Font :as Font]
            [goog.graphics.Stroke :as Stroke]
            [goog.graphics.SolidFill :as SolidFill]
            [goog.graphics :as graphics]))

; Drawing configuration
(def avatar-size 32) ; used for both x and y dimensions of avatars
(def edge-widths [0 1 2 3 4]) ; More mentions == thicker edges
(def anneal-skipping 10)
(def cooling 1000)
; fail whale
;(def default-avatar "http://farm3.static.flickr.com/2562/4140195522_e207b97280_s.jpg")
; google+ silhouette
(def default-avatar "http://ssl.gstatic.com/s2/profiles/images/silhouette48.png")
(defn debug [_])
;(defn debug [a] (str "t: " (:t a) " score: " (:best-score a)))

; BAD HACK: don't change globals like this -- find a better way:
;(set! anim/TIMEOUT 500)

(def edge-strokes
  (vec (map #(graphics/Stroke. % "#009") edge-widths)))

(def max-stroke (peek edge-strokes))

(def g
  (doto (graphics/createGraphics "100%" "100%")
    (.render (dom/getElement "network"))))

(def font (graphics/Font. 12 "Arial"))
(def fill (graphics/SolidFill. "#f00"))

(defn unit-to-pixel [unit-arg canvas-size]
  (+ (* unit-arg (- canvas-size avatar-size)) (/ avatar-size 2)))

(defn log [& args]
  (js* "console.log(~{})" (apply pr-str args)))

(defn draw-graph [{:keys [locs mentions]} text]
  (let [canvas-size (. g (getPixelSize))]
    (. g (clear))

    ; Draw mention edges
    (doseq [[username {ux1 :x, uy1 :y}] locs
            :let [x1 (unit-to-pixel ux1 (.width canvas-size))
                  y1 (unit-to-pixel uy1 (.height canvas-size))]
            [mention-name mention-count] (:mentions (get mentions username))]
      (when-let [{ux2 :x, uy2 :y} (get locs mention-name)]
        (let [x2 (unit-to-pixel ux2 (.width canvas-size))
              y2 (unit-to-pixel uy2 (.height canvas-size))]
          (.drawPath g
                    (-> (. g (createPath)) (.moveTo x1 y1) (.lineTo x2 y2))
                    (get edge-strokes mention-count max-stroke) nil))))

    ; Draw avatar nodes
    (doseq [[username {:keys [x y] :as foo}] locs]
      ;(log (pr-str foo))
      (.drawImage g
                  (- (unit-to-pixel x (.width canvas-size))  (/ avatar-size 2))
                  (- (unit-to-pixel y (.height canvas-size)) (/ avatar-size 2))
                  avatar-size avatar-size
                  (get (get mentions username) :image-url default-avatar)))

    (let [text (if (empty? locs)
                 "No locations to graph"
                 text)]
      (when text
        (.drawTextOnLine g text 5 20 (.width canvas-size) 20
                        "left" font nil fill)))))

(buzz/register :graph-update #(draw-graph (layout/radial %) nil))

(def animation (atom nil))

;(events/listen (dom/getElement "network") events/EventType.CLICK start-anneal)
;(buzz/register :track-clicked start-anneal)
;(buzz/register :refresh-clicked start-anneal)

(ns twitterbuzz.showgraph
  (:require [twitterbuzz.core :as buzz]
            [twitterbuzz.anneal :as ann]
            [twitterbuzz.layout :as layout]
            [goog.dom :as dom]
            [goog.events :as events]
            [goog.fx.Animation :as anim]
            [goog.graphics.Font :as Font]
            [goog.graphics.Stroke :as Stroke]
            [goog.graphics.SolidFill :as SolidFill]
            [goog.graphics :as graphics]))

; Drawing configuration
(def avatar-size 32) ; used for both x and y dimensions of avatars
(def edge-widths [0 1 2 3 4]) ; More mentions == thicker edges
(def anneal-skipping 10)
(def cooling 1000)
; fail whale
;(def default-avatar "http://farm3.static.flickr.com/2562/4140195522_e207b97280_s.jpg")
; google+ silhouette
(def default-avatar "http://ssl.gstatic.com/s2/profiles/images/silhouette48.png")
(defn debug [_])
;(defn debug [a] (str "t: " (:t a) " score: " (:best-score a)))

; BAD HACK: don't change globals like this -- find a better way:
;(set! anim/TIMEOUT 500)

(def edge-strokes
  (vec (map #(graphics/Stroke. % "#009") edge-widths)))

(def max-stroke (peek edge-strokes))

(def g
  (doto (graphics/createGraphics "100%" "100%")
    (.render (dom/getElement "network"))))

(def font (graphics/Font. 12 "Arial"))
(def fill (graphics/SolidFill. "#f00"))

(defn unit-to-pixel [unit-arg canvas-size]
  (+ (* unit-arg (- canvas-size avatar-size)) (/ avatar-size 2)))

(defn log [& args]
  (js* "console.log(~{})" (apply pr-str args)))

(defn draw-graph [{:keys [locs mentions]} text]
  (let [canvas-size (. g (getPixelSize))]
    (. g (clear))

    ; Draw mention edges
    (doseq [[username {ux1 :x, uy1 :y}] locs
            :let [x1 (unit-to-pixel ux1 (.width canvas-size))
                  y1 (unit-to-pixel uy1 (.height canvas-size))]
            [mention-name mention-count] (:mentions (get mentions username))]
      (when-let [{ux2 :x, uy2 :y} (get locs mention-name)]
        (let [x2 (unit-to-pixel ux2 (.width canvas-size))
              y2 (unit-to-pixel uy2 (.height canvas-size))]
          (.drawPath g
                    (-> (. g (createPath)) (.moveTo x1 y1) (.lineTo x2 y2))
                    (get edge-strokes mention-count max-stroke) nil))))

    ; Draw avatar nodes
    (doseq [[username {:keys [x y] :as foo}] locs]
      ;(log (pr-str foo))
      (.drawImage g
                  (- (unit-to-pixel x (.width canvas-size))  (/ avatar-size 2))
                  (- (unit-to-pixel y (.height canvas-size)) (/ avatar-size 2))
                  avatar-size avatar-size
                  (get (get mentions username) :image-url default-avatar)))

    (let [text (if (empty? locs)
                 "No locations to graph"
                 text)]
      (when text
        (.drawTextOnLine g text 5 20 (.width canvas-size) 20
                        "left" font nil fill)))))

(buzz/register :graph-update #(draw-graph (layout/radial %) nil))

(def animation (atom nil))

;(events/listen (dom/getElement "network") events/EventType.CLICK start-anneal)
(buzz/register :track-clicked #(. g (clear)))
;(buzz/register :refresh-clicked start-anneal)

Clear the graph view when the Track button is pressed.


(ns babel.encyclopedia
  ^{:doc "real-world knowledge, expressed
as a map of implications"}
  (:refer-clojure)
  (:require
   [babel.exception :refer [exception]]
   #?(:cljs [babel.logjs :as log])
   #?(:clj [clojure.tools.logging :as log])
   [dag_unify.core :refer [strip-refs]]))

(def encyc
  {
   {:activity true} {:animate false
                     :artifact false
                     :consumable false
                     :part-of-human-body false}

   {:animate true} {:activity false
                    :artifact false
                    :mass false
                    :furniture false
                    :physical-object true
                    :part-of-human-body false
                    :drinkable false
                    :speakable false
                    :place false}

   {:artifact true} {:animate false
                     :activity false
                     :physical-object true}

   {:buyable true} {:human false
                    :part-of-human-body false}

   {:city true} {:artifact true
                 :legible false
                 :place true}

   {:clothing true} {:animate false
                     :place false
                     :physical-object true}

   {:consumable true} {:activity false
                       :buyable true
                       :furniture false
                       :legible false
                       :human false
                       :part-of-human-body false
                       :pet false
                       :physical-object true
                       :speakable false}

   {:consumable false} {:drinkable false
                        :edible false}

   {:drinkable true}   {:mass true}

   {:edible true}      {:consumable true}

   {:furniture true}   {:artifact true
                        :animate false
                        :buyable true
                        :consumable false
                        :legible false
                        :edible false
                        :place false
                        :speakable false}

   {:human true} {:animate true
                  :buyable false
                  :consumable false
                  :legible false
                  :pet false
                  :part-of-human-body true
                  :physical-object true
                  :place false}

   {:living false} {:animate false
                    :human false}

   {:living true} {:artifact false}

   {:part-of-human-body true} {:consumable false
                               :human false
                               :physical-object true}

   {:pet true} {:animate true
                :buyable true
                :edible false
                :human false}

   {:place true} {:activity false
                  :consumable false
                  :living false
                  :physical-object true}

   {:time true} {:activity false
                 :living false
                 :place false}

   }
  )

(def animal {:animate true
             :artifact false
             :living true})

(defn null-sem-impl [input]
  "null sem-impl: simply return input."
  (log/trace (str "null-sem-impl:" (strip-refs input)))
  input)

(defn get-encyc [input k]
  (get encyc {k (get-in input [k])} {}))

(defn impl-list [input]
  [(get-encyc input :activity)
   (get-encyc input :animate)
   (get-encyc input :artifact)
   (get-encyc input :buyable)
   (get-encyc input :city)
   (get-encyc input :clothing)
   (get-encyc input :consumable)
   (get-encyc input :drinkable)
   (get-encyc input :edible)
   (get-encyc input :furniture)
   (get-encyc input :human)
   (get-encyc input
              :part-of-human-body)
   (get-encyc input :pet)
   (get-encyc input :place)
   (get-encyc input :time)])

(defn sem-impl [input & [original-input]]
  "expand input feature structures with semantic (really cultural) implicatures, e.g., if human, then not buyable or edible"
  (let [original-input (if original-input original-input
                           (do
                             (log/debug (str "original call of sem-impl: (" (get-in input [:pred]) ")" (strip-refs input)))
                             input))]
    (cond
      (= input :top) input
      true
      (let [activity   (get-encyc input :activity)
            animate    (get-encyc input :animate)
            artifact   (get-encyc input :artifact)
            buyable    (get-encyc input :buyable)
            city       (get-encyc input :city)
            clothing   (get-encyc input :clothing)
            consumable (get-encyc input :consumable)
            drinkable  (get-encyc input :drinkable)
            edible     (get-encyc input :edible)
            furniture  (get-encyc input :furniture)
            human      (get-encyc input :human)
            part-of-human-body (get-encyc input
                                          :part-of-human-body)
            pet        (get-encyc input :pet)
            place      (get-encyc input :place)
            time       (get-encyc input :time)
            ]
        (let [merged
              (cond (= input :fail) :fail

                    true
                    (merge input
                           (reduce merge [activity animate artifact buyable city clothing consumable drinkable
                                          edible furniture human
                                          pet place time])))]
          (log/trace (str "sem-impl so far: " merged))
          (if (not (= merged input)) ;; TODO: make this check more efficient: count how many rules were hit
            ;; rather than equality-check to see if merged has changed.
            (sem-impl merged original-input) ;; we've added some new information: more implications possible from that.

            ;; else, no more implications: done.
            (do
              (log/debug (str "sem-impl:" (strip-refs original-input) " -> " (strip-refs merged)))
              merged)))))))

(ns babel.encyclopedia
  ^{:doc "real-world knowledge, expressed
as a map of implications"}
  (:refer-clojure)
  (:require
   [babel.exception :refer [exception]]
   #?(:cljs [babel.logjs :as log])
   #?(:clj [clojure.tools.logging :as log])
   [dag_unify.core :refer [strip-refs unify]]))

(def encyc
  {
   {:activity true} {:animate false
                     :artifact false
                     :consumable false
                     :part-of-human-body false}

   {:animate true} {:activity false
                    :artifact false
                    :mass false
                    :furniture false
                    :physical-object true
                    :part-of-human-body false
                    :drinkable false
                    :speakable false
                    :place false}

   {:artifact true} {:animate false
                     :activity false
                     :physical-object true}

   {:buyable true} {:human false
                    :part-of-human-body false}

   {:city true} {:artifact true
                 :legible false
                 :place true}

   {:clothing true} {:animate false
                     :place false
                     :physical-object true}

   {:consumable true} {:activity false
                       :buyable true
                       :furniture false
                       :legible false
                       :human false
                       :part-of-human-body false
                       :pet false
                       :physical-object true
                       :speakable false}

   {:consumable false} {:drinkable false
                        :edible false}

   {:drinkable true}   {:mass true}

   {:edible true}      {:consumable true}

   {:furniture true}   {:artifact true
                        :animate false
                        :buyable true
                        :consumable false
                        :legible false
                        :edible false
                        :place false
                        :speakable false}

   {:human true} {:animate true
                  :buyable false
                  :consumable false
                  :legible false
                  :pet false
                  :part-of-human-body true
                  :physical-object true
                  :place false}

   {:living false} {:animate false
                    :human false}

   {:living true} {:artifact false}

   {:part-of-human-body true} {:consumable false
                               :human false
                               :physical-object true}

   {:pet true} {:animate true
                :buyable true
                :edible false
                :human false}

   {:place true} {:activity false
                  :consumable false
                  :living false
                  :physical-object true}

   {:time true} {:activity false
                 :living false
                 :place false}

   }
  )

(defn null-sem-impl [input]
  "null sem-impl: simply return input."
  (log/trace (str "null-sem-impl:" (strip-refs input)))
  input)

(defn get-encyc [input k]
  (get encyc {k (get-in input [k])} {}))

(defn impl-list [input]
  [
   (get-encyc input :activity)
   (get-encyc input :animate)
   (get-encyc input :artifact)
   (get-encyc input :buyable)
   (get-encyc input :city)
   (get-encyc input :clothing)
   (get-encyc input :consumable)
   (get-encyc input :drinkable)
   (get-encyc input :edible)
   (get-encyc input :furniture)
   (get-encyc input :human)
   (get-encyc input
              :part-of-human-body)
   (get-encyc input :pet)
   (get-encyc input :place)
   (get-encyc input :time)
   ])

(defn sem-impl [input & [original-input]]
  "expand input feature structures with semantic (really cultural) implicatures, e.g., if human, then not buyable or edible"
  (let [original-input (if original-input original-input
                           (do
                             (log/debug (str "original call of sem-impl: (" (get-in input [:pred]) ")" (strip-refs input)))
                             input))]
    (cond
      (= input :top) input
      (= input :fail) :fail
      true
      (let [merged
            (unify input
                   (reduce unify (impl-list input)))]
        (log/debug (str "sem-impl so far: " merged))
        (if (not (= merged input)) ;; TODO: make this check more efficient: count how many rules were hit
          ;; rather than equality-check to see if merged has changed.
          (sem-impl merged original-input) ;; we've added some new information: more implications possible from that.

          ;; else, no more implications: done.
          (do
            (log/debug (str "sem-impl:" (strip-refs original-input) " -> " (strip-refs merged)))
            merged))))))

switch from (merge) to (unify) to catch contradictions sooner