(ns open-company.api.companies
  (:require [defun :refer (defun)]
            [compojure.core :refer (defroutes ANY OPTIONS GET POST)]
            [liberator.core :refer (defresource by-method)]
            [clojure.set :as cset]
            [schema.core :as s]
            [open-company.config :as config]
            [open-company.api.common :as common]
            [open-company.resources.common :as common-res]
            [open-company.resources.company :as company]
            [open-company.resources.section :as section]
            [open-company.representations.company :as company-rep]
            [cheshire.core :as json]))

;; Round-trip it through Cheshire to ensure the embedded HTML gets encodedod or the client has issues parsing it
(defonce sections (json/generate-string config/sections {:pretty true}))

(defn add-slug
  "Add the slug to the company properties if it's missing."
  [slug company]
  (update company :slug (fnil identity slug)))

;; ----- Responses -----

(defn- company-location-response [company]
  (common/location-response ["companies" (:symbol company)]
    (company-rep/render-company company) company-rep/media-type))

(defn- unprocessable-reason [reason]
  (case reason
    :invalid-slug-format (common/unprocessable-entity-response "Invalid slug format.")
    :slug-taken (common/unprocessable-entity-response "Slug already taken.")
    :name (common/unprocessable-entity-response "Company name is required.")
    :slug (common/unprocessable-entity-response "Invalid or missing slug.")
    (common/unprocessable-entity-response "Not processable.")))

(defn- options-for-company [slug ctx]
  (if-let [company (company/get-company slug)]
    (if (common/authorized-to-company? (assoc ctx :company company))
      (common/options-response [:options :get :put :patch :delete])
      (common/options-response [:options :get]))
    (common/missing-response)))

;; ----- Actions -----

(defn- get-company [slug]
  (if-let [company (company/get-company slug)]
    {:company company}))

(defn- put-company [slug company user]
  (let [full-company (assoc company :slug slug)]
    {:updated-company (company/put-company slug full-company user)}))

(defn- patch-company [slug company-updates user]
  (let [original-company (company/get-company slug)
        section-names (clojure.set/intersection (set (keys company-updates)) common-res/section-names)
        updated-sections (->> section-names
          (map #(section/put-section slug % (company-updates %) user)) ; put each section that's in the patch
          (map #(dissoc % :id :section-name))) ; not needed for sections in company
        patch-updates (merge company-updates (zipmap section-names updated-sections))] ; updated sections & anythig else
    ;; update the company
    {:updated-company (company/put-company slug (merge original-company patch-updates) user)}))

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

(defn malformed-post-req?
  "If the request contains valid JSON POST data to create
   companies, return the parsed JSON, otherwise return nil."
  [ctx]
  (let [[invalid-json? parsed] (common/malformed-json? ctx)
        with-reason (fn [r] (assoc parsed :malformed-reason r))]
    (cond invalid-json?
      [true (with-reason :malformed-json)]
      ;; Ensure all required keys are present and valid
      ;; s/check returns nil if data complies
      (->> (keys common-res/CompanyMinimum)
           (select-keys (:data parsed))
           (s/check common-res/CompanyMinimum))
      [true (with-reason :missing-fields)]
      ;; Ensure all extra fields match with our sections
      ;; if superset? returns true no superfluous fields are found
      (not (->> (into (set (keys common-res/CompanyMinimum))
                      (set (keys common-res/CompanyOptional)))
                (cset/difference (-> parsed :data keys set))
                (cset/superset? common-res/section-names)))
      [true (with-reason :unexpected-fields)]
      :else [false parsed])))

(defn slug-processable [slug]
  (cond
    (nil? slug) true
    (s/check common-res/Slug slug) [false {:reason :invalid-slug-format}]
    (not (company/slug-available? slug)) [false {:reason :slug-taken}]))

(defn company-processable [company]
  (->> (add-slug slug company)
       (s/check {:slug common-res/Slug, :name s/Str, s/Keyword s/Any})
       (common/check->liberator true)))

;; ----- Resources - see: http://clojure-liberator.github.io/liberator/assets/img/decision-graph.svg

;; A resource for a specific company.
(defresource company
  [slug]
  common/open-company-anonymous-resource ; verify validity of JWToken if it's provided, but it's not required

  :available-media-types [company-rep/media-type]
  :exists? (fn [_] (get-company slug))
  :known-content-type? (fn [ctx] (common/known-content-type? ctx company-rep/media-type))

  :allowed? (by-method {
    :options (fn [ctx] (common/allow-anonymous ctx))
    :get (fn [ctx] (common/allow-anonymous ctx))
    :put (fn [ctx] (common/allow-org-members slug ctx))
    :patch (fn [ctx] (common/allow-org-members slug ctx))
    :delete (fn [ctx] (common/allow-org-members slug ctx))})

  :processable? (by-method {
    :options true
    :get true
    :put (fn [ctx] (company-processable (:data ctx)))
    :patch (fn [ctx] true)}) ;; TODO validate for subset of company properties

  ;; Handlers
  :handle-ok (by-method {
    :get (fn [ctx] (company-rep/render-company (:company ctx) (common/authorized-to-company? ctx)))
    :put (fn [ctx] (company-rep/render-company (:updated-company ctx)))
    :patch (fn [ctx] (company-rep/render-company (:updated-company ctx)))})
  :handle-not-acceptable (fn [_] (common/only-accept 406 company-rep/media-type))
  :handle-unsupported-media-type (fn [_] (common/only-accept 415 company-rep/media-type))
  :handle-unprocessable-entity (fn [ctx] (unprocessable-reason (:reason ctx)))
  :handle-options (fn [ctx] (options-for-company slug ctx))

  ;; Delete a company
  :delete! (fn [_] (company/delete-company slug))

  ;; Create or update a company
  ;; TODO remove possibility to create company
  :new? (by-method {:put (not (company/get-company slug))})
  :put! (fn [ctx] (put-company slug (add-slug slug (:data ctx)) (:user ctx)))
  :patch! (fn [ctx] (patch-company slug (add-slug slug (:data ctx)) (:user ctx)))
  :handle-created (fn [ctx] (company-location-response (:updated-company ctx))))

;; A resource for a list of all the companies the user has access to.
(defresource company-list
  []
  common/open-company-anonymous-resource ; verify validity of JWToken if it's provided, but it's not required

  :available-charsets [common/UTF8]
  :available-media-types (by-method {:get [company-rep/collection-media-type]
                                     :post [company-rep/media-type]})
  :allowed-methods [:options :post :get]
  :allowed? (by-method {
    :options (fn [ctx] (common/allow-anonymous ctx))
    :get (fn [ctx] (common/allow-anonymous ctx))
    :post (fn [ctx] (common/allow-authenticated ctx))})

  :handle-not-acceptable (common/only-accept 406 company-rep/collection-media-type)

  :malformed? (by-method {
    :options false
    :get false
    :post (fn [ctx] (malformed-post-req? ctx))})

  ;; Get a list of companies
  :exists? (fn [_] {:companies (company/list-companies)})

  :processable? (by-method {
    :get true
    :options true
    :post (fn [ctx] (slug-processable (-> ctx :data :slug)))})

  :post! (fn [ctx] {:company (-> (company/->company (:data ctx) (:user ctx))
                                 (company/add-placeholder-sections)
                                 (company/create-company!))})

  :handle-ok (fn [ctx] (company-rep/render-company-list (:companies ctx)))
  :handle-created (fn [ctx] (company-location-response (:company ctx)))
  :handle-options (fn [ctx] (if (common/authenticated? ctx)
                              (common/options-response [:options :get :post])
                              (common/options-response [:options :get])))

  :handle-unprocessable-entity (fn [ctx] (unprocessable-reason (:reason ctx))))

;; A resource for the available sections for a specific company.
(defresource section-list
  [slug]
  common/authenticated-resource ; verify validity and presence of required JWToken

  :available-charsets [common/UTF8]
  :available-media-types [company-rep/section-list-media-type]
  :allowed-methods [:options :get]
  :allowed? (fn [ctx] (common/allow-org-members slug ctx))

  :handle-not-acceptable (common/only-accept 406 company-rep/section-list-media-type)
  :handle-options (if (company/get-company slug) (common/options-response [:options :get]) (common/missing-response))

  ;; Get a list of sections
  :exists? (fn [_] (get-company slug))
  :handle-ok (fn [_] sections))

;; ----- Routes -----

(defroutes company-routes
  (OPTIONS "/companies/:slug/section/new" [slug] (section-list slug))
  (OPTIONS "/companies/:slug/section/new/" [slug] (section-list slug))
  (GET "/companies/:slug/section/new" [slug] (section-list slug))
  (GET "/companies/:slug/section/new/" [slug] (section-list slug))
  (ANY "/companies/:slug" [slug] (company slug))
  (ANY "/companies/:slug/" [slug] (company slug))
  (OPTIONS "/companies/" [] (company-list))
  (OPTIONS "/companies" [] (company-list))
  (GET "/companies/" [] (company-list))
  (GET "/companies" [] (company-list))
  (POST "/companies/" [] (company-list))
  (POST "/companies" [] (company-list)))

(ns open-company.api.companies
  (:require [defun :refer (defun)]
            [compojure.core :refer (defroutes ANY OPTIONS GET POST)]
            [liberator.core :refer (defresource by-method)]
            [clojure.set :as cset]
            [schema.core :as s]
            [open-company.config :as config]
            [open-company.api.common :as common]
            [open-company.resources.common :as common-res]
            [open-company.resources.company :as company]
            [open-company.resources.section :as section]
            [open-company.representations.company :as company-rep]
            [cheshire.core :as json]))

;; Round-trip it through Cheshire to ensure the embedded HTML gets encodedod or the client has issues parsing it
(defonce sections (json/generate-string config/sections {:pretty true}))

(defn add-slug
  "Add the slug to the company properties if it's missing."
  [slug company]
  (update company :slug (fnil identity slug)))

;; ----- Responses -----

(defn- company-location-response [company]
  (common/location-response ["companies" (:symbol company)]
    (company-rep/render-company company) company-rep/media-type))

(defn- unprocessable-reason [reason]
  (case reason
    :invalid-slug-format (common/unprocessable-entity-response "Invalid slug format.")
    :slug-taken (common/unprocessable-entity-response "Slug already taken.")
    :name (common/unprocessable-entity-response "Company name is required.")
    :slug (common/unprocessable-entity-response "Invalid or missing slug.")
    (common/unprocessable-entity-response "Not processable.")))

(defn- options-for-company [slug ctx]
  (if-let [company (company/get-company slug)]
    (if (common/authorized-to-company? (assoc ctx :company company))
      (common/options-response [:options :get :put :patch :delete])
      (common/options-response [:options :get]))
    (common/missing-response)))

;; ----- Actions -----

(defn- get-company [slug]
  (if-let [company (company/get-company slug)]
    {:company company}))

(defn- put-company [slug company user]
  (let [full-company (assoc company :slug slug)]
    {:updated-company (company/put-company slug full-company user)}))

(defn- patch-company [slug company-updates user]
  (let [original-company (company/get-company slug)
        section-names (clojure.set/intersection (set (keys company-updates)) common-res/section-names)
        updated-sections (->> section-names
          (map #(section/put-section slug % (company-updates %) user)) ; put each section that's in the patch
          (map #(dissoc % :id :section-name))) ; not needed for sections in company
        patch-updates (merge company-updates (zipmap section-names updated-sections))] ; updated sections & anythig else
    ;; update the company
    {:updated-company (company/put-company slug (merge original-company patch-updates) user)}))

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

(defn malformed-post-req?
  "If the request contains valid JSON POST data to create
   companies, return the parsed JSON, otherwise return nil."
  [ctx]
  (let [[invalid-json? parsed] (common/malformed-json? ctx)
        with-reason (fn [r] (assoc parsed :malformed-reason r))]
    (cond invalid-json?
      [true (with-reason :malformed-json)]
      ;; Ensure all required keys are present and valid
      ;; s/check returns nil if data complies
      (->> (keys common-res/CompanyMinimum)
           (select-keys (:data parsed))
           (s/check common-res/CompanyMinimum))
      [true (with-reason :missing-fields)]
      ;; Ensure all extra fields match with our sections
      ;; if superset? returns true no superfluous fields are found
      (not (->> (into (set (keys common-res/CompanyMinimum))
                      (set (keys common-res/CompanyOptional)))
                (cset/difference (-> parsed :data keys set))
                (cset/superset? common-res/section-names)))
      [true (with-reason :unexpected-fields)]
      :else [false parsed])))

(defn slug-processable [slug]
  (cond
    (nil? slug) true
    (s/check common-res/Slug slug) [false {:reason :invalid-slug-format}]
    (not (company/slug-available? slug)) [false {:reason :slug-taken}]))

(defn company-processable [company]
  (->> (s/check {:slug common-res/Slug, :name s/Str, s/Keyword s/Any})
       (common/check->liberator true)))

;; ----- Resources - see: http://clojure-liberator.github.io/liberator/assets/img/decision-graph.svg

;; A resource for a specific company.
(defresource company
  [slug]
  common/open-company-anonymous-resource ; verify validity of JWToken if it's provided, but it's not required

  :available-media-types [company-rep/media-type]
  :exists? (fn [_] (get-company slug))
  :known-content-type? (fn [ctx] (common/known-content-type? ctx company-rep/media-type))

  :allowed? (by-method {
    :options (fn [ctx] (common/allow-anonymous ctx))
    :get (fn [ctx] (common/allow-anonymous ctx))
    :put (fn [ctx] (common/allow-org-members slug ctx))
    :patch (fn [ctx] (common/allow-org-members slug ctx))
    :delete (fn [ctx] (common/allow-org-members slug ctx))})

  :processable? (by-method {
    :options true
    :get true
    :put (fn [ctx] (company-processable (add-slug slug (:data ctx))))
    :patch (fn [ctx] true)}) ;; TODO validate for subset of company properties

  ;; Handlers
  :handle-ok (by-method {
    :get (fn [ctx] (company-rep/render-company (:company ctx) (common/authorized-to-company? ctx)))
    :put (fn [ctx] (company-rep/render-company (:updated-company ctx)))
    :patch (fn [ctx] (company-rep/render-company (:updated-company ctx)))})
  :handle-not-acceptable (fn [_] (common/only-accept 406 company-rep/media-type))
  :handle-unsupported-media-type (fn [_] (common/only-accept 415 company-rep/media-type))
  :handle-unprocessable-entity (fn [ctx] (unprocessable-reason (:reason ctx)))
  :handle-options (fn [ctx] (options-for-company slug ctx))

  ;; Delete a company
  :delete! (fn [_] (company/delete-company slug))

  ;; Create or update a company
  ;; TODO remove possibility to create company
  :new? (by-method {:put (not (company/get-company slug))})
  :put! (fn [ctx] (put-company slug (add-slug slug (:data ctx)) (:user ctx)))
  :patch! (fn [ctx] (patch-company slug (add-slug slug (:data ctx)) (:user ctx)))
  :handle-created (fn [ctx] (company-location-response (:updated-company ctx))))

;; A resource for a list of all the companies the user has access to.
(defresource company-list
  []
  common/open-company-anonymous-resource ; verify validity of JWToken if it's provided, but it's not required

  :available-charsets [common/UTF8]
  :available-media-types (by-method {:get [company-rep/collection-media-type]
                                     :post [company-rep/media-type]})
  :allowed-methods [:options :post :get]
  :allowed? (by-method {
    :options (fn [ctx] (common/allow-anonymous ctx))
    :get (fn [ctx] (common/allow-anonymous ctx))
    :post (fn [ctx] (common/allow-authenticated ctx))})

  :handle-not-acceptable (common/only-accept 406 company-rep/collection-media-type)

  :malformed? (by-method {
    :options false
    :get false
    :post (fn [ctx] (malformed-post-req? ctx))})

  ;; Get a list of companies
  :exists? (fn [_] {:companies (company/list-companies)})

  :processable? (by-method {
    :get true
    :options true
    :post (fn [ctx] (slug-processable (-> ctx :data :slug)))})

  :post! (fn [ctx] {:company (-> (company/->company (:data ctx) (:user ctx))
                                 (company/add-placeholder-sections)
                                 (company/create-company!))})

  :handle-ok (fn [ctx] (company-rep/render-company-list (:companies ctx)))
  :handle-created (fn [ctx] (company-location-response (:company ctx)))
  :handle-options (fn [ctx] (if (common/authenticated? ctx)
                              (common/options-response [:options :get :post])
                              (common/options-response [:options :get])))

  :handle-unprocessable-entity (fn [ctx] (unprocessable-reason (:reason ctx))))

;; A resource for the available sections for a specific company.
(defresource section-list
  [slug]
  common/authenticated-resource ; verify validity and presence of required JWToken

  :available-charsets [common/UTF8]
  :available-media-types [company-rep/section-list-media-type]
  :allowed-methods [:options :get]
  :allowed? (fn [ctx] (common/allow-org-members slug ctx))

  :handle-not-acceptable (common/only-accept 406 company-rep/section-list-media-type)
  :handle-options (if (company/get-company slug) (common/options-response [:options :get]) (common/missing-response))

  ;; Get a list of sections
  :exists? (fn [_] (get-company slug))
  :handle-ok (fn [_] sections))

;; ----- Routes -----

(defroutes company-routes
  (OPTIONS "/companies/:slug/section/new" [slug] (section-list slug))
  (OPTIONS "/companies/:slug/section/new/" [slug] (section-list slug))
  (GET "/companies/:slug/section/new" [slug] (section-list slug))
  (GET "/companies/:slug/section/new/" [slug] (section-list slug))
  (ANY "/companies/:slug" [slug] (company slug))
  (ANY "/companies/:slug/" [slug] (company slug))
  (OPTIONS "/companies/" [] (company-list))
  (OPTIONS "/companies" [] (company-list))
  (GET "/companies/" [] (company-list))
  (GET "/companies" [] (company-list))
  (POST "/companies/" [] (company-list))
  (POST "/companies" [] (company-list)))

fix build

fix build


{:user
 {:plugins [[lein-vanity "0.2.0" :exclusions [org.clojure/clojure]]
            [lein-ancient "0.6.15"]
            [lein-hiera "1.0.0"]
            [lein-kibit "0.1.6"]
            [lein-pprint "1.2.0"]
            [jonase/eastwood "0.3.1"]
            [com.billpiel/sayid "0.0.16"]
            [lein-cljfmt "0.6.1"]]
  :dependencies [[slamhound "1.5.5"]]
  :aliases {"slamhound" ["run" "-m" "slam.hound"]}}}

{:user
 {:plugins [[lein-vanity "0.2.0" :exclusions [org.clojure/clojure]]
            [lein-ancient "0.6.15"]
            [lein-hiera "1.0.0"]
            [lein-kibit "0.1.6"]
            [lein-pprint "1.2.0"]
            [jonase/eastwood "0.3.3"]
            [com.billpiel/sayid "0.0.17"]
            [lein-cljfmt "0.6.1"]]
  :dependencies [[slamhound "1.5.5"]]
  :aliases {"slamhound" ["run" "-m" "slam.hound"]}}}

use sayid 0.0.17 and eastwood 0.3.3

use sayid 0.0.17 and eastwood 0.3.3


(set-env!
 :source-paths    {{{source-paths}}}
 :resource-paths  #{"resources"}
 :dependencies '[[adzerk/boot-cljs          "1.7.228-2"  :scope "test"]
                 [adzerk/boot-cljs-repl     "0.3.3"      :scope "test"]
                 [adzerk/boot-reload        "0.4.13"      :scope "test"]
                 [pandeiro/boot-http        "0.7.6"      :scope "test"]
                 [com.cemerick/piggieback   "0.2.1"      :scope "test"]
                 [org.clojure/tools.nrepl   "0.2.12"     :scope "test"]
                 [weasel                    "0.7.0"      :scope "test"]
                 [org.clojure/clojurescript "1.9.293"]{{{deps}}}])

(require
 '[adzerk.boot-cljs      :refer [cljs]]
 '[adzerk.boot-cljs-repl :refer [cljs-repl start-repl]]
 '[adzerk.boot-reload    :refer [reload]]
 '[pandeiro.boot-http    :refer [serve]]{{{requires}}})

(deftask build []
  (comp (speak)
        {{{pre-build-steps}}}
        (cljs)
        {{{build-steps}}}))

(deftask run []
  (comp (serve)
        (watch)
        (cljs-repl)
        {{{run-steps}}}
        (reload)
        (build)))

(deftask production []
  (task-options! cljs {:optimizations :advanced}{{{production-task-opts}}})
  identity)

(deftask development []
  (task-options! cljs {:optimizations :none}
                 reload {:on-jsload '{{name}}.app/init}{{{development-task-opts}}})
  identity)

(deftask dev
  "Simple alias to run application in development mode"
  []
  (comp (development)
        (run)))

{{{tasks}}}

(set-env!
 :source-paths    {{{source-paths}}}
 :resource-paths  #{"resources"}
 :dependencies '[[adzerk/boot-cljs          "2.0.0"      :scope "test"]
                 [adzerk/boot-cljs-repl     "0.3.3"      :scope "test"]
                 [adzerk/boot-reload        "0.4.13"      :scope "test"]
                 [pandeiro/boot-http        "0.7.6"      :scope "test"]
                 [com.cemerick/piggieback   "0.2.1"      :scope "test"]
                 [org.clojure/tools.nrepl   "0.2.12"     :scope "test"]
                 [weasel                    "0.7.0"      :scope "test"]
                 [org.clojure/clojurescript "1.9.293"]{{{deps}}}])

(require
 '[adzerk.boot-cljs      :refer [cljs]]
 '[adzerk.boot-cljs-repl :refer [cljs-repl start-repl]]
 '[adzerk.boot-reload    :refer [reload]]
 '[pandeiro.boot-http    :refer [serve]]{{{requires}}})

(deftask build []
  (comp (speak)
        {{{pre-build-steps}}}
        (cljs)
        {{{build-steps}}}))

(deftask run []
  (comp (serve)
        (watch)
        (cljs-repl)
        {{{run-steps}}}
        (reload)
        (build)))

(deftask production []
  (task-options! cljs {:optimizations :advanced}{{{production-task-opts}}})
  identity)

(deftask development []
  (task-options! cljs {:optimizations :none}
                 reload {:on-jsload '{{name}}.app/init}{{{development-task-opts}}})
  identity)

(deftask dev
  "Simple alias to run application in development mode"
  []
  (comp (development)
        (run)))

{{{tasks}}}

update boot-cljs dependency -> 2.0.0

update boot-cljs dependency -> 2.0.0


(ns logic.util)

(def transform-map
  {:atom  (fn [& a] (symbol (apply str a)))
   :not   #(list 'not %)
   :and   #(list 'and %1 %2)
   :nand  #(list 'nand %1 %2)
   :or    #(list 'or %1 %2)
   :nor   #(list 'nor %1 %2)
   :impl  #(list 'impl %1 %2)
   :nimpl #(list 'nimpl %1 %2)
   :if    #(list 'cimpl %1 %2)
   :nif   #(list 'ncimpl %1 %2)
   :equiv #(list 'equiv %1 %2)
   :xor   #(list 'xor %1 %2)
   :false (fn [] false)
   :true  (fn [] true)
   })

(defn transform-ast
  "Takes an ast as produced by instaparse and transforms it into evaluatable clojure code."
  [ast]
  (insta/transform transform-map ast))

(defn- flat-filter
  [o l]
  (if (coll? l)
    (= o (first l))
    false))

(defn- flat
  [ast]
  (let [o (first ast) a (rest ast) ; operators and arguments
        flat (map #(rest %) (filter (partial flat-filter o) a))
        not-flat (filter (partial (complement flat-filter) o) a)]
      (apply concat  `((~o) ~@flat ~not-flat))))

(defn- flat-ast
  [ast]
  (if (and
        (coll? ast)
        (n-ary? (first ast)))
    (flat ast)
    ast))

(defn flatten-ast
  [ast]
  (postwalk flat-ast ast))

(defn create-ast
  "Parses a formula and transforms it to an ast."
  [formula]
  (-> formula logic-parse transform-ast))

; test flatten-ast
(def fml1 '(equiv (equiv a b) c))
(def fml2 (flatten-ast fml1))
(tt (list 'equiv fml1 fml2))

(def fml3 '(nand (nand a b) c))
(def fml4 (flatten-ast fml3))
(tt (list 'equiv fml3 fml4))

(def fml5 '(nor (nor a b) c))
(def fml6 (flatten-ast fml5))
(tt (list 'equiv fml5 fml6))
; Fazit: nur and und or sind "flat"

test flatten-ast

test flatten-ast


(ns tourbillon.main
  (:gen-class)
  (:require [tourbillon.core :refer [system]]
            [com.stuartsierra.component :as component]
            [taoensso.timbre :as log]
            [environ.core :refer [env]]))

(log/set-config! [:appenders :spit :enabled?] true)
(log/set-config! [:shared-appender-config :spit-filename] (get env :log-file))

(defn -main
  "Start application with a given number of worker processes and optionally
  a webserver for a sample client application."
  [& args]
  (let [env (or (first args) "dev")]
    (log/info (str "Starting system in " env))
    (component/start
     (system {:app-env (get env :app-env)}))))

(ns tourbillon.main
  (:gen-class)
  (:require [tourbillon.core :refer [system]]
            [com.stuartsierra.component :as component]
            [taoensso.timbre :as log]
            [environ.core :refer [env]]))

(log/set-config! [:appenders :spit :enabled?] true)
(log/set-config! [:shared-appender-config :spit-filename] (get env :log-file))

(defn -main
  "Start application with a given number of worker processes and optionally
  a webserver for a sample client application."
  [& args]
  (log/info (str "Starting system in " (get env :app-env)))
  (component/start
    (system {:app-env (get env :app-env)})))

Fix app environment

Fix app environment


(ns overtone.sc.bus
  (:import [java.util.concurrent TimeoutException])
  (:use [overtone.sc.machinery allocator]
        [overtone.sc.machinery.server comms]
        [overtone.sc synth ugens defaults server node]
        [overtone.helpers lib]
        [overtone.sc.foundation-groups :only [foundation-monitor-group]]
        [overtone.libs.deps            :only [on-deps]])
  (:require [overtone.at-at :as at-at]))

;; ## Buses
;;
;; Synthesizers can be connected to I/O devices (e.g. sound cards) and
;; other synthesizers by using buses.  Conceptually they are like
;; plugging a cable from the output of one unit to the input of another,
;; but in SC they are implemented using a simple integer referenced
;; array of float values.

(defonce ^{:private true} bus-monitors* (atom {}))
(defonce ^{:private true} bus-monitor-pool (at-at/mk-pool))
(defonce ^{:private true} audio-bus-monitor-group* (atom nil))

(defonce ^{:private true} __PROTOCOLS__
  (do
    (defprotocol IBus
      (free-bus [this]))))

(defrecord AudioBus [id n-channels rate name]
  to-sc-id*
  (to-sc-id [this] (:id this))

  IBus
  (free-bus [this] (free-id :audio-bus (:id this) (:n-channels this))))

(defrecord ControlBus [id n-channels rate name]
  to-sc-id*
  (to-sc-id [this] (:id this))

  IBus
  (free-bus [this] (free-id :control-bus (:id this) (:n-channels this))))

(defmethod print-method AudioBus [b w]
  (.write w (format "#<audio-bus: %s, %s, id %d>"
                    (if (empty? (:name b))
                      "No Name"
                      (:name b))
                    (cond
                     (= 1 (:n-channels b)) "mono"
                     (= 2 (:n-channels b)) "stereo"
                     :else (str (:n-channels b) " channels"))
                    (:id b))))

(defmethod print-method ControlBus [b w]
  (.write w (format "#<control-bus: %s, %s, id %d>"
                    (if (empty? (:name b))
                      "No Name"
                      (:name b))
                    (cond
                     (= 1 (:n-channels b)) "1 channel"
                     :else (str (:n-channels b) " channels"))
                    (:id b))))

(derive AudioBus ::bus)
(derive ControlBus ::bus)

(defn bus?
  "Returns true if the specified bus is a map representing a bus (either control
  or audio) "
  [bus]
  (isa? (type bus) ::bus))

(defn control-bus?
  "Returns true if the specified bus is a map representing a control bus."
  [bus]
  (isa? (type bus) ControlBus))

(defn audio-bus?
  "Returns true if the specified bus is a map representing a control bus."
  [bus]
  (isa? (type bus) AudioBus))

(defn control-bus
  "Allocate one or more successive control buses. By default, just one
   bus is allocated. However, if you specify a number of channels, a
   successive range of that length will be allocated.

   You may also specify a name for the bus for labelling purposes."
  ([] (control-bus 1 ""))
  ([n-channels-or-name]  (if (string? n-channels-or-name)
                          (control-bus 1 n-channels-or-name)
                          (control-bus n-channels-or-name "")))
  ([n-channels name]
     (let [id (alloc-id :control-bus n-channels)]
       (ControlBus. id n-channels :control name))))

(defn audio-bus
  "Allocate one or more successive audio buses. By default, just one
   bus is allocated. However, if you specify a number of channels, a
   successive range of that length will be allocated.

   For example, to allocate a stereo bus: (audio-bus 2)

   You may also specify a name for the bus for labelling purposes."
  ([] (audio-bus 1 ""))
  ([n-channels-or-name] (if (string? n-channels-or-name)
                          (audio-bus 1 n-channels-or-name)
                          (audio-bus n-channels-or-name "")))
  ([n-channels name]
     (let [id (alloc-id :audio-bus n-channels)]
       (AudioBus. id n-channels :audio name))))

;; Reserve busses for overtone
(defonce ___reserve-overtone-busses____
  (dotimes [i AUDIO-BUS-RESERVE-COUNT]
    (audio-bus)))

(defn reset-buses
  [event-info]
  nil)

;(on-sync-event :reset reset-buses ::reset-buses)

(defn control-bus-set!
  "Updates bus to new val. Modification takes place on the server asynchronously.

  (control-bus-set! my-bus 3) ;=> Sets my-bus to the value 3"
  [bus val]
  (let [id  (to-sc-id bus)
        val (double val)]
    (snd "/c_set" id val)))

(defn control-bus-get
  "Get the current value of a control bus."
  [bus]
  (let [id (to-sc-id bus)
        p  (server-recv "/c_set" (fn [info] (= id (first (:args info)))))]
    (snd "/c_get" id)
    (second (:args (deref! p (str "attempting to read the current value of bus " (with-out-str (pr bus))))))))

(defn control-bus-set-range!
  "Set a range of consecutive control buses to the supplied values."
  [bus start len vals]
  (let [id   (to-sc-id bus)
        vals (floatify vals)]
      (apply snd "/c_setn" id start len vals)))

(defn control-bus-get-range
  "Get a range of consecutive control bus values."
  [bus len]
  (let [id (to-sc-id bus)
        p  (server-recv "/c_setn" (fn [info] (and (= id (first (:args info)))
                                                 (= len (second (:args info))))))]
    (snd "/c_getn" id len)
    (drop 2 (:args (deref! p (str "attempting to get a range of consecutive control bus values of length " len " from bus " (with-out-str (pr bus))))))))

(defn- create-monitor-group
  "Creates a group for the audio bus monitor synths. Designed to be
   called in a dependency callback after :foundation-groups-created."
  []
  (ensure-connected!)
  (assert (foundation-monitor-group) "Couldn't find monitor group")
  (let [g (with-server-sync
            #(group "Audio Bus Monitors" :tail (foundation-monitor-group))
            "whilst creating the audio bus monitor group")]
    (reset! audio-bus-monitor-group* g)))

(on-deps :foundation-groups-created ::create-monitor-group create-monitor-group)

(defonce __BUS-MONITOR-SYNTH__
  (defsynth mono-audio-bus-level [in-a-bus 0 out-c-bus 0]
    (let [sig   (in:ar in-a-bus 1)
          level (amplitude sig)
          level (lag-ud level 0.1 0.3)]
      (out:kr out-c-bus [(a2k level)]))))

(defn audio-bus-monitor
  "Mono bus amplitude monitor. Returns an atom containing the current
   amplitude of the monitor. For multi-channel buses, an offset may be
   specified. Current amplitude is updated within the returned atom
   every 50 ms.

   Note - only creates one monitor per audio bus - subsequent calls for
   the same audio bus idx will return a cached monitor."
  ([audio-bus] (audio-bus-monitor audio-bus 0))
  ([audio-bus chan-offset]
     (ensure-connected!)
     (assert @audio-bus-monitor-group* "Couldn't find audio bus monitor group")
     (let [bus-idx (to-sc-id audio-bus)
           bus-idx (+ chan-offset bus-idx)]
       (if-let [[monitor _] (get @bus-monitors* bus-idx)]
         monitor
         (let [monitor (atom 0)
               cb      (control-bus (str "audio-bus-level [" bus-idx "]"))
               m-synth (mono-audio-bus-level [:tail @audio-bus-monitor-group*]
                                             bus-idx
                                             cb)]

           (at-at/every 50
                        #(reset! monitor (control-bus-get bus-idx))
                        bus-monitor-pool
                        :initial-delay 0
                        :desc (str "bus-monitor [" bus-idx "]"))
           (swap! bus-monitors* assoc bus-idx [monitor m-synth])
           monitor)))))

(ns overtone.sc.bus
  (:import [java.util.concurrent TimeoutException])
  (:use [overtone.sc.machinery allocator]
        [overtone.sc.machinery.server comms]
        [overtone.sc synth ugens defaults server node]
        [overtone.helpers lib]
        [overtone.sc.foundation-groups :only [foundation-monitor-group]]
        [overtone.libs.deps            :only [on-deps]])
  (:require [overtone.at-at :as at-at]))

;; ## Buses
;;
;; Synthesizers can be connected to I/O devices (e.g. sound cards) and
;; other synthesizers by using buses.  Conceptually they are like
;; plugging a cable from the output of one unit to the input of another,
;; but in SC they are implemented using a simple integer referenced
;; array of float values.

(defonce ^{:private true} bus-monitors* (atom {}))
(defonce ^{:private true} bus-monitor-pool (at-at/mk-pool))
(defonce ^{:private true} audio-bus-monitor-group* (atom nil))

(defonce ^{:private true} __PROTOCOLS__
  (do
    (defprotocol IBus
      (free-bus [bus] "Free this control or audio bus - enabling the resource to be re-allocated"))))

(defrecord AudioBus [id n-channels rate name]
  to-sc-id*
  (to-sc-id [this] (:id this))

  IBus
  (free-bus [this] (free-id :audio-bus (:id this) (:n-channels this))))

(defrecord ControlBus [id n-channels rate name]
  to-sc-id*
  (to-sc-id [this] (:id this))

  IBus
  (free-bus [this] (free-id :control-bus (:id this) (:n-channels this))))

(defmethod print-method AudioBus [b w]
  (.write w (format "#<audio-bus: %s, %s, id %d>"
                    (if (empty? (:name b))
                      "No Name"
                      (:name b))
                    (cond
                     (= 1 (:n-channels b)) "mono"
                     (= 2 (:n-channels b)) "stereo"
                     :else (str (:n-channels b) " channels"))
                    (:id b))))

(defmethod print-method ControlBus [b w]
  (.write w (format "#<control-bus: %s, %s, id %d>"
                    (if (empty? (:name b))
                      "No Name"
                      (:name b))
                    (cond
                     (= 1 (:n-channels b)) "1 channel"
                     :else (str (:n-channels b) " channels"))
                    (:id b))))

(derive AudioBus ::bus)
(derive ControlBus ::bus)

(defn bus?
  "Returns true if the specified bus is a map representing a bus (either control
  or audio) "
  [bus]
  (isa? (type bus) ::bus))

(defn control-bus?
  "Returns true if the specified bus is a map representing a control bus."
  [bus]
  (isa? (type bus) ControlBus))

(defn audio-bus?
  "Returns true if the specified bus is a map representing a control bus."
  [bus]
  (isa? (type bus) AudioBus))

(defn control-bus
  "Allocate one or more successive control buses. By default, just one
   bus is allocated. However, if you specify a number of channels, a
   successive range of that length will be allocated.

   You may also specify a name for the bus for labelling purposes."
  ([] (control-bus 1 ""))
  ([n-channels-or-name]  (if (string? n-channels-or-name)
                          (control-bus 1 n-channels-or-name)
                          (control-bus n-channels-or-name "")))
  ([n-channels name]
     (let [id (alloc-id :control-bus n-channels)]
       (ControlBus. id n-channels :control name))))

(defn audio-bus
  "Allocate one or more successive audio buses. By default, just one
   bus is allocated. However, if you specify a number of channels, a
   successive range of that length will be allocated.

   For example, to allocate a stereo bus: (audio-bus 2)

   You may also specify a name for the bus for labelling purposes."
  ([] (audio-bus 1 ""))
  ([n-channels-or-name] (if (string? n-channels-or-name)
                          (audio-bus 1 n-channels-or-name)
                          (audio-bus n-channels-or-name "")))
  ([n-channels name]
     (let [id (alloc-id :audio-bus n-channels)]
       (AudioBus. id n-channels :audio name))))

;; Reserve busses for overtone
(defonce ___reserve-overtone-busses____
  (dotimes [i AUDIO-BUS-RESERVE-COUNT]
    (audio-bus)))

(defn reset-buses
  [event-info]
  nil)

;(on-sync-event :reset reset-buses ::reset-buses)

(defn control-bus-set!
  "Updates bus to new val. Modification takes place on the server asynchronously.

  (control-bus-set! my-bus 3) ;=> Sets my-bus to the value 3"
  [bus val]
  (let [id  (to-sc-id bus)
        val (double val)]
    (snd "/c_set" id val)))

(defn control-bus-get
  "Get the current value of a control bus."
  [bus]
  (let [id (to-sc-id bus)
        p  (server-recv "/c_set" (fn [info] (= id (first (:args info)))))]
    (snd "/c_get" id)
    (second (:args (deref! p (str "attempting to read the current value of bus " (with-out-str (pr bus))))))))

(defn control-bus-set-range!
  "Set a range of consecutive control buses to the supplied values."
  [bus start len vals]
  (let [id   (to-sc-id bus)
        vals (floatify vals)]
      (apply snd "/c_setn" id start len vals)))

(defn control-bus-get-range
  "Get a range of consecutive control bus values."
  [bus len]
  (let [id (to-sc-id bus)
        p  (server-recv "/c_setn" (fn [info] (and (= id (first (:args info)))
                                                 (= len (second (:args info))))))]
    (snd "/c_getn" id len)
    (drop 2 (:args (deref! p (str "attempting to get a range of consecutive control bus values of length " len " from bus " (with-out-str (pr bus))))))))

(defn- create-monitor-group
  "Creates a group for the audio bus monitor synths. Designed to be
   called in a dependency callback after :foundation-groups-created."
  []
  (ensure-connected!)
  (assert (foundation-monitor-group) "Couldn't find monitor group")
  (let [g (with-server-sync
            #(group "Audio Bus Monitors" :tail (foundation-monitor-group))
            "whilst creating the audio bus monitor group")]
    (reset! audio-bus-monitor-group* g)))

(on-deps :foundation-groups-created ::create-monitor-group create-monitor-group)

(defonce __BUS-MONITOR-SYNTH__
  (defsynth mono-audio-bus-level [in-a-bus 0 out-c-bus 0]
    (let [sig   (in:ar in-a-bus 1)
          level (amplitude sig)
          level (lag-ud level 0.1 0.3)]
      (out:kr out-c-bus [(a2k level)]))))

(defn audio-bus-monitor
  "Mono bus amplitude monitor. Returns an atom containing the current
   amplitude of the monitor. For multi-channel buses, an offset may be
   specified. Current amplitude is updated within the returned atom
   every 50 ms.

   Note - only creates one monitor per audio bus - subsequent calls for
   the same audio bus idx will return a cached monitor."
  ([audio-bus] (audio-bus-monitor audio-bus 0))
  ([audio-bus chan-offset]
     (ensure-connected!)
     (assert @audio-bus-monitor-group* "Couldn't find audio bus monitor group")
     (let [bus-idx (to-sc-id audio-bus)
           bus-idx (+ chan-offset bus-idx)]
       (if-let [[monitor _] (get @bus-monitors* bus-idx)]
         monitor
         (let [monitor (atom 0)
               cb      (control-bus (str "audio-bus-level [" bus-idx "]"))
               m-synth (mono-audio-bus-level [:tail @audio-bus-monitor-group*]
                                             bus-idx
                                             cb)]

           (at-at/every 50
                        #(reset! monitor (control-bus-get bus-idx))
                        bus-monitor-pool
                        :initial-delay 0
                        :desc (str "bus-monitor [" bus-idx "]"))
           (swap! bus-monitors* assoc bus-idx [monitor m-synth])
           monitor)))))

add docstring for free-bus

add docstring for free-bus


(ns panpan.liliruca
  (:require
    [jubot.adapter    :as ja]
    [jubot.handler    :as jh]
    [jubot.scheduler  :as js]
    [panpan.jubot.doc :refer :all]))

(def ^:const NAME "リリ")
(def ^:const ICON "https://dl.dropboxusercontent.com/u/14918307/slack_icon/liliruca.png")
(def ^:private out #(do (ja/out (apply str %&) :as NAME :icon-url ICON) nil))
(def ^:const MESSAGES
  {:jubot-document
   ["jubot のドキュメントが古いようですよ"
    "あっ、jubot のドキュメント古くないですか？"
    ]
   :response
   ["どういたしまして！"
    "滅相もないです"
    "サポーターですから！"
    ]
   })

(defn liliruca-handler
  "リリ.*jubot.+テスト - jubot ドキュメントバージョンチェックのテスト
  "
  [{:keys [user] :as arg}]
  (jh/regexp arg
    #"リリ.+jubot.+テスト"
    (fn [& _] (out "@" user " 了解です\n"
                   " * document: " (get-jubot-document-version)
                   "\n"
                   " * core    : " (get-jubot-core-version)
                   "\n"))
    #"リリ.*ありがと"
    (fn [& _] (->> MESSAGES :response rand-nth (out "@" user " ")))))

(def liliruca-schedule
  (js/schedules
    ;; jubot document
    "0 0 20,21,22 * * * *"
    #(when-not (is-document-latest?)
       (out (-> MESSAGES :jubot-document rand-nth)))))

(ns panpan.liliruca
  (:require
    [jubot.adapter    :as ja]
    [jubot.handler    :as jh]
    [jubot.scheduler  :as js]
    [panpan.jubot.doc :refer :all]))

(def ^:const NAME "リリ")
(def ^:const ICON "https://dl.dropboxusercontent.com/u/14918307/slack_icon/liliruca.png")
(def ^:private out #(do (ja/out (apply str %&) :as NAME :icon-url ICON) nil))
(def ^:const MESSAGES
  {:jubot-document
   ["jubot のドキュメントが古いようですよ"
    "あっ、jubot のドキュメント古くないですか？"
    ]
   :response
   ["どういたしまして！"
    "滅相もないです"
    "サポーターですから！"
    ]
   })

(defn liliruca-handler
  "リリ.*jubot.+テスト - jubot ドキュメントバージョンチェックのテスト
  "
  [{:keys [user] :as arg}]
  (jh/regexp arg
    #"リリ.*jubot.+テスト"
    (fn [& _]
      (out "@" user " 了解です")
      (out "```\n"
           "document: " (get-jubot-document-version) "\n"
           "core    : " (get-jubot-core-version) "\n```"))
    #"リリ.*ありがと"
    (fn [& _] (->> MESSAGES :response rand-nth (out "@" user " ")))))

(def liliruca-schedule
  (js/schedules
    ;; jubot document
    "0 0 20,21,22 * * * *"
    #(when-not (is-document-latest?)
       (out (-> MESSAGES :jubot-document rand-nth)))))

update liliruca message

update liliruca message


(ns singularity.db
  (:refer-clojure :exclude [get get-in update-in assoc-in])
  (:require [reagent.core :refer [atom]]
            [schema.core :as s :include-macros true]))

(def schema
  "Defines the expected shape (i.e. data model) for `state`."
  (let [piece-colors (s/enum :white :black)
        piece-types (s/enum :rook :knight :bishop :pawn :queen :king)]
    {:board-width s/Num
     :selected-space (s/maybe [s/Num])
     :me piece-colors
     :them (s/enum :ai :player :me)
     :turn piece-colors
     :board (s/both
       (s/pred #(= 64 (count %)))
       {[s/Num] {:piece (s/maybe {
        :color piece-colors
        :type piece-types})}})}))

; Use schema as validator for state atom. Ensures that an exception
; is thrown if `state` is modified in a way that breaks the schema.
(def state
  "Central application state atom. Automatically validated to match
   the `schema`. Easily get/set data in here using the `singularity.db`
   versions of `get-in`, `update-in`, and `assoc-in`."
  (atom {} {:validator #(s/validate schema %)}))

; These functions wrap the `clojure.core` versions, preventing the user
; from having to think about derefs, swap!, etc.
(defn get [key] (clojure.core/get @state key))
(defn get-in [path] (clojure.core/get-in @state path))
(defn update-in [path fn] (swap! state clojure.core/update-in path fn))
(defn assoc-in [path fn] (swap! state clojure.core/assoc-in path fn))
(defn define [& args] (swap! state conj (->> args (partition 2) (map vec))))

(ns ^{:doc "Contains central persistent db atom and helper get/set functions."}
  singularity.db
  (:refer-clojure :exclude [get get-in update-in assoc-in])
  (:require [reagent.core :refer [atom]]
            [reagent.ratom :refer [cursor]]))

; Use schema as validator for state atom. Ensures that an exception
; is thrown if `state` is modified in a way that breaks the schema.
(def state
  "Central application state atom. Automatically validated to match
   the `schema`. Easily get/set data in here using the `singularity.db`
   versions of `get-in`, `update-in`, `assoc-in`, etc."
  (atom {} {:validator (constantly true)}))

(defn me [] (cursor state [:me]))
(defn them [] (cursor state [:them]))
(defn turn [] (cursor state [:turn]))
(defn selected-space [] (cursor state [:selected-space]))
(defn board-width [] (cursor state [:board-width]))
(defn board [] (cursor state [:board]))
(defn square [coords] (cursor (board) [coords]))
(defn piece [coords] (cursor (square coords) [:piece]))

; These functions wrap the `clojure.core` versions, preventing the user
; from having to think about derefs, swap!, etc.
(defn get [key] (clojure.core/get @state key))
(defn get-in [path] (clojure.core/get-in @state path))
(defn update-in [path fn] (swap! state clojure.core/update-in path fn))
(defn assoc-in [path fn] (swap! state clojure.core/assoc-in path fn))

(defn define
  "Helper function for merging into state. Usage: (define k1 v1, k2 v2, ...)"
  [& args] (swap! state conj (->> args (partition 2) (map vec))))

Add cursors and temproarily remove schema validation


(ns ^{:doc "French Testing Code"}
    babel.test.fr
  (:refer-clojure :exclude [get-in])
  (:require [babel.engine :as engine]
            [babel.forest :as forest]
            [babel.francais.grammar :refer [small medium]]
            [babel.francais.lexicon :refer [lexicon]]
            [babel.francais.morphology :refer [analyze conjugate fo
                                               possible-lexemes replace-patterns]]
            [babel.francais.workbook :refer [generate lookup parse tokenize]]
            [babel.over :as over]
            [babel.parse :as parse]
            [clojure.string :as string]
            #?(:clj [clojure.test :refer [deftest is]])
            #?(:cljs [cljs.test :refer-macros [deftest is]])
            #?(:clj [clojure.tools.logging :as log])
            #?(:cljs [babel.logjs :as log])
            [dag_unify.core :refer [fail-path fail? get-in strip-refs unifyc]]))

;; TODO: these defns (lookup) are convenience functions are duplicated in
;; babel.workbook.francais: factor out to babel.francais.
;; TODO: do morphological analysis
;; do find non-infinitives (e.g. find 'parler' given 'parle')
;; and then apply conjugated parts to lexeme
;; i.e. if input is 'parle', return
;; list of lexemes; for each, [:synsem :agr :person] will be
;; 1st, 2nd, or 3rd, and for all, number will be singular.

(defn over
  ([arg1]
   (over/over (vals (:grammar-map medium)) (lookup arg1)))
  ([grammar arg1]
   (over/over grammar (lookup arg1)))
  ([grammar arg1 arg2]
   (cond (string? arg1)
         (over grammar (lookup arg1)
               arg2)

         (string? arg2)
         (over grammar arg1 (lookup arg2))

         true
         (over/over grammar arg1 arg2))))

(deftest conditional
  (let [result (engine/generate {:synsem {:subcat '()
                                          :sem {:pred :sleep
                                                :subj {:pred :I}
                                                :tense :conditional}}}
                                small)]
    (is (= "je dormirais" (fo result)))))

(deftest present-irregular
  (let [result (engine/generate {:synsem {:subcat '()
                                          :sem {:pred :be
                                                :subj {:pred :I}
                                                :tense :present}}}
                                small)]
    (is (= "je suis" (fo result)))))

(deftest imperfect-irregular-être
  (let [result (engine/generate {:synsem {:subcat '()
                                          :infl :imperfect
                                          :sem {:pred :be
                                                :subj {:pred :I}}}}

                                small)]
    (is (= "j'étais" (fo result)))))

(deftest imperfect-irregular-avoir
  (let [result (engine/generate {:synsem {:subcat '()
                                          :infl :imperfect
                                          :sem {:pred :have
                                                :subj {:pred :I}}}}
                                small)]
    (is (not (nil? result)))
    (is (= "av" (get-in result [:head :français :imperfect-stem])))
    (is (= "j'avais" (fo result)))))

(deftest être-as-aux
  (let [lexicon (:lexicon small)
        result
        (filter #(not (fail? %))
                (map (fn [rule]
                       (unifyc rule
                               {:head (last (get lexicon "être"))}))
                     (:grammar small)))]
    (is (not (empty? result)))
    (is (= (get-in (first result) [:rule]) "vp-aux"))))

(deftest vp-aux-test
  (let [rule (first (filter #(= (:rule %) "vp-aux")
                            (:grammar small)))]
    (is (not (nil? rule)))))

(def etre-test
  (is (not (nil? (first (filter #(= true (get-in % [:synsem :aux]))
                                (get (:lexicon small) "être")))))))

(deftest over-test
  (let [lexicon (:lexicon small)
        grammar (:grammar small)
        result
        (over grammar
              (get lexicon "nous")
              (over grammar
                    (get lexicon "sommes") (get lexicon "aller")))]
    (is (= 2 (count result)))
    (is (or (= (fo (nth result 0))
               "nous sommes allées")
            (= (fo (nth result 1))
               "nous sommes allées")))
    (is (or (= (fo (nth result 0))
               "nous sommes allés")
            (= (fo (nth result 1))
               "nous sommes allés")))))

(deftest passe-compose-morphology
  (let [result
        {:français
         {:a {:initial true,
              :français "nous"},
          :b {:b {:future-stem "ir",
                  :agr {:number :plur,
                        :gender :fem
                        :person :1st},
                  :present {:3plur "vont",
                            :2plur "allez",
                            :3sing "va",
                            :1sing "vais",
                            :2sing "vas",
                            :1plur "allons"},
                  :français "aller",
                  :infl :past-p,
                  :essere true,
                  :initial false},
              :initial false,
              :a {:infl :present,
                  :infinitive "être",
                  :initial true,
                  :agr {:number :plur,
                        :person :1st},
                  :essere false,
                  :passato "été",
                  :imperfect {:2sing "étais",
                              :3plur "étaient",
                              :2plur "étiez",
                              :1sing "étais",
                              :3sing "était",
                              :1plur "étions"},
                  :present {:2sing "es",
                            :3plur "sont",
                            :2plur "êtes",
                            :1sing "suis",
                            :3sing "est",
                            :1plur "sommes"},
                  :futuro {:2sing "seras",
                           :3plur "seront",
                           :2plur "serez",
                           :1sing "serai",
                           :3sing "sera",
                           :1plur "serons"},
                  :futuro-stem "ser",
                  :exception true,
                  :français "sommes"}}}}]
    (is (= (fo result) "nous sommes allées"))))

(deftest passe-compose-1
  (let [result
        (forest/generate (unifyc
                          {:synsem {:subcat '()}}
                          {:synsem {:sem {:subj {:pred :noi
                                                 :gender :fem}
                                          :pred :go
                                          :aspect :perfect
                                          :tense :past}}})
         (:grammar small)
         (:lexicon small)
         (:index small)
         (:morph small))]
    (and (is (not (nil? result)))
         (is (= (fo result) "nous sommes allées")))))

(deftest passe-compose
  (let [result (engine/generate {:synsem {:sem {:pred :go
                                                :subj {:pred :noi
                                                       :gender :fem}
                                                :aspect :perfect
                                                :tense :past}}}
                                small)]
    (is (not (nil? result)))
    (is (= (fo result) "nous sommes allées"))))

(deftest reflexive
  (let [rules {:s-present-phrasal
               (first (filter #(= (get % :rule) "s-present-phrasal")
                              (:grammar medium)))
               :vp-pronoun-nonphrasal
               (first (filter #(= (get % :rule) "vp-pronoun-nonphrasal")
                              (:grammar medium)))}

        result (over (get rules :s-present-phrasal)
                     "je"
                     (over (get rules :vp-pronoun-nonphrasal)
                           "me" "s'amuser"))]
    (is (= (fo (first result))
           "je m'amuse"))))

(deftest have-fun-sentence
  (let [result (engine/expression medium
                                  {:synsem {:sem {:pred :have-fun}}})]
    (is (= (get-in result [:synsem :sem :pred]) :have-fun))))

(deftest vp-aux-reflexive
  (let [result
        (engine/expression
         medium
         {:synsem {:subcat '() :sem {:subj {:pred :lei}
                                     :pred :have-fun :tense :past}}})]
    (is (= (fo result) "elle l'est amusée"))))

(deftest named-sentence
  (let [result (engine/expression medium
                                  {:synsem {:sem {:pred :be-called
                                                  :subj {:pred :lui}
                                                  :obj {:pred :Jean}}}})]
    (is (= (fo result) "il l'appele Jean"))))

(deftest parse-reflexive
  (let [result (first (parse "il l'amuse"))]
    (not (nil? result))
    (is (= (get-in result [:synsem :sem :pred])
           :have-fun))
    (is (= (get-in result [:synsem :sem :subj :pred])
           :lui))))

(deftest parse-reflexive
  (let [result (first (parse "tu t'amuses"))]
    (not (nil? result))
    (is (= (get-in result [:synsem :sem :pred])
           :have-fun))
    (is (= (get-in result [:synsem :sem :subj :pred])
           :tu))))

(deftest parse-past-nonreflexive
  (let [result (parse "j'ai parlé")]
    (not (nil? result))
    (is (= 4 (count result)))
    (is (or (= (get-in (first result) [:synsem :sem :pred])
               :talk)
            (= (get-in (first result) [:synsem :sem :pred])
               :speak)))
    (is (= (get-in (first result) [:synsem :sem :tense])
           :past))))

(deftest parse-reflexive-past
  (let [result (first (parse "tu t'es amusé"))]
    (is (not (nil? result)))))

(deftest conjugate1
  (let [from #"s'([aeéiou].*)er$"
        infinitive "s'amuser"
        to "$1é"]
    (is (= "amusé" (string/replace infinitive from to)))))

(deftest conjugate2
  (is (= "amusé" (conjugate "s'amuser"
                            {:synsem {:infl :past-p :subcat {:1 {:agr {:number :sing}}}}}))))
(deftest conjugate3
  (is (= (conjugate "s'amuser"
                    {:synsem {:infl :past-p :subcat {:1 {:agr {:number :plur}}}}})
         "amusés")))

(defn get-lex [exp]
  (filter #(not (nil? (:lookup %)))
          (map #(let [from (first %)
                      to (second %)
                      unify-with (nth % 2)
                      lex (string/replace exp from to)]
                  {:lex lex
                   :lookup (lookup lex)
                   :unified (map (fn [entry]
                                   (unifyc unify-with entry))
                                 (lookup lex))})
               replace-patterns)))

(defn get-lex2 [exp]
  (filter (fn [result] (not (= :fail result)))
          (mapcat #(let [from (first %)
                         to (second %)
                         unify-with (nth % 2)
                         lex (string/replace exp from to)]
                     (map (fn [entry]
                            (unifyc unify-with entry))
                          (lookup lex)))
                  replace-patterns)))

(ns ^{:doc "French Testing Code"}
    babel.test.fr
  (:refer-clojure :exclude [get-in])
  (:require [babel.engine :as engine]
            [babel.forest :as forest]
            [babel.francais.grammar :refer [small medium]]
            [babel.francais.lexicon :refer [lexicon]]
            [babel.francais.morphology :refer [analyze conjugate fo get-string
                                               possible-lexemes replace-patterns]]
            [babel.francais.workbook :refer [generate lookup parse tokenize]]
            [babel.over :as over]
            [babel.parse :as parse]
            [clojure.string :as string]
            #?(:clj [clojure.test :refer [deftest is]])
            #?(:cljs [cljs.test :refer-macros [deftest is]])
            #?(:clj [clojure.tools.logging :as log])
            #?(:cljs [babel.logjs :as log])
            [dag_unify.core :refer [fail-path fail? get-in strip-refs unifyc]]))

;; TODO: these defns (lookup) are convenience functions are duplicated in
;; babel.workbook.francais: factor out to babel.francais.
;; TODO: do morphological analysis
;; do find non-infinitives (e.g. find 'parler' given 'parle')
;; and then apply conjugated parts to lexeme
;; i.e. if input is 'parle', return
;; list of lexemes; for each, [:synsem :agr :person] will be
;; 1st, 2nd, or 3rd, and for all, number will be singular.

(defn over
  ([arg1]
   (over/over (vals (:grammar-map medium)) (lookup arg1)))
  ([grammar arg1]
   (over/over grammar (lookup arg1)))
  ([grammar arg1 arg2]
   (cond (string? arg1)
         (over grammar (lookup arg1)
               arg2)

         (string? arg2)
         (over grammar arg1 (lookup arg2))

         true
         (over/over grammar arg1 arg2))))

(deftest conditional
  (let [result (engine/generate {:synsem {:subcat '()
                                          :sem {:pred :sleep
                                                :subj {:pred :I}
                                                :tense :conditional}}}
                                small)]
    (is (= "je dormirais" (fo result)))))

(deftest present-irregular
  (let [result (engine/generate {:synsem {:subcat '()
                                          :sem {:pred :be
                                                :subj {:pred :I}
                                                :tense :present}}}
                                small)]
    (is (= "je suis" (fo result)))))

(deftest imperfect-irregular-être
  (let [result (engine/generate {:synsem {:subcat '()
                                          :infl :imperfect
                                          :sem {:pred :be
                                                :subj {:pred :I}}}}

                                small)]
    (is (= "j'étais" (fo result)))))

(deftest imperfect-irregular-avoir
  (let [result (engine/generate {:synsem {:subcat '()
                                          :infl :imperfect
                                          :sem {:pred :have
                                                :subj {:pred :I}}}}
                                small)]
    (is (not (nil? result)))
    (is (= "av" (get-in result [:head :français :imperfect-stem])))
    (is (= "j'avais" (fo result)))))

(deftest être-as-aux
  (let [lexicon (:lexicon small)
        result
        (filter #(not (fail? %))
                (map (fn [rule]
                       (unifyc rule
                               {:head (last (get lexicon "être"))}))
                     (:grammar small)))]
    (is (not (empty? result)))
    (is (= (get-in (first result) [:rule]) "vp-aux"))))

(deftest vp-aux-test
  (let [rule (first (filter #(= (:rule %) "vp-aux")
                            (:grammar small)))]
    (is (not (nil? rule)))))

(def etre-test
  (is (not (nil? (first (filter #(= true (get-in % [:synsem :aux]))
                                (get (:lexicon small) "être")))))))

(deftest over-test
  (let [lexicon (:lexicon small)
        grammar (:grammar small)
        result
        (over grammar
              (get lexicon "nous")
              (over grammar
                    (get lexicon "sommes") (get lexicon "aller")))]
    (is (= 2 (count result)))
    (is (or (= (fo (nth result 0))
               "nous sommes allées")
            (= (fo (nth result 1))
               "nous sommes allées")))
    (is (or (= (fo (nth result 0))
               "nous sommes allés")
            (= (fo (nth result 1))
               "nous sommes allés")))))

(deftest passe-compose-morphology
  (let [result
        {:français
         {:a {:initial true,
              :français "nous"},
          :b {:b {:future-stem "ir",
                  :agr {:number :plur,
                        :gender :fem
                        :person :1st},
                  :present {:3plur "vont",
                            :2plur "allez",
                            :3sing "va",
                            :1sing "vais",
                            :2sing "vas",
                            :1plur "allons"},
                  :français "aller",
                  :infl :past-p,
                  :essere true,
                  :initial false},
              :initial false,
              :a {:infl :present,
                  :infinitive "être",
                  :initial true,
                  :agr {:number :plur,
                        :person :1st},
                  :essere false,
                  :passato "été",
                  :imperfect {:2sing "étais",
                              :3plur "étaient",
                              :2plur "étiez",
                              :1sing "étais",
                              :3sing "était",
                              :1plur "étions"},
                  :present {:2sing "es",
                            :3plur "sont",
                            :2plur "êtes",
                            :1sing "suis",
                            :3sing "est",
                            :1plur "sommes"},
                  :futuro {:2sing "seras",
                           :3plur "seront",
                           :2plur "serez",
                           :1sing "serai",
                           :3sing "sera",
                           :1plur "serons"},
                  :futuro-stem "ser",
                  :exception true,
                  :français "sommes"}}}}]
    (is (= (fo result) "nous sommes allées"))))

(deftest passe-compose-1
  (let [result
        (forest/generate (unifyc
                          {:synsem {:subcat '()}}
                          {:synsem {:sem {:subj {:pred :noi
                                                 :gender :fem}
                                          :pred :go
                                          :aspect :perfect
                                          :tense :past}}})
         (:grammar small)
         (:lexicon small)
         (:index small)
         (:morph small))]
    (and (is (not (nil? result)))
         (is (= (fo result) "nous sommes allées")))))

(deftest passe-compose
  (let [result (engine/generate {:synsem {:sem {:pred :go
                                                :subj {:pred :noi
                                                       :gender :fem}
                                                :aspect :perfect
                                                :tense :past}}}
                                small)]
    (is (not (nil? result)))
    (is (= (fo result) "nous sommes allées"))))

(deftest reflexive
  (let [rules {:s-present-phrasal
               (first (filter #(= (get % :rule) "s-present-phrasal")
                              (:grammar medium)))
               :vp-pronoun-nonphrasal
               (first (filter #(= (get % :rule) "vp-pronoun-nonphrasal")
                              (:grammar medium)))}

        result (over (get rules :s-present-phrasal)
                     "je"
                     (over (get rules :vp-pronoun-nonphrasal)
                           "me" "s'amuser"))]
    (is (= (fo (first result))
           "je m'amuse"))))

(deftest have-fun-sentence
  (let [result (engine/expression medium
                                  {:synsem {:sem {:pred :have-fun}}})]
    (is (= (get-in result [:synsem :sem :pred]) :have-fun))))

(deftest vp-aux-reflexive
  (let [result
        (engine/expression
         medium
         {:synsem {:subcat '() :sem {:subj {:pred :lei}
                                     :pred :have-fun :tense :past}}})]
    (is (= (fo result) "elle l'est amusée"))))

(deftest named-sentence
  (let [result (engine/expression medium
                                  {:synsem {:sem {:pred :be-called
                                                  :subj {:pred :lui}
                                                  :obj {:pred :Jean}}}})]
    (is (= (fo result) "il l'appele Jean"))))

(deftest parse-reflexive
  (let [result (first (parse "il l'amuse"))]
    (not (nil? result))
    (is (= (get-in result [:synsem :sem :pred])
           :have-fun))
    (is (= (get-in result [:synsem :sem :subj :pred])
           :lui))))

(deftest parse-reflexive
  (let [result (first (parse "tu t'amuses"))]
    (not (nil? result))
    (is (= (get-in result [:synsem :sem :pred])
           :have-fun))
    (is (= (get-in result [:synsem :sem :subj :pred])
           :tu))))

(deftest parse-past-nonreflexive
  (let [result (parse "j'ai parlé")]
    (not (nil? result))
    (is (= 4 (count result)))
    (is (or (= (get-in (first result) [:synsem :sem :pred])
               :talk)
            (= (get-in (first result) [:synsem :sem :pred])
               :speak)))
    (is (= (get-in (first result) [:synsem :sem :tense])
           :past))))

(deftest parse-reflexive-past
  (let [result (first (parse "tu t'es amusé"))]
    (is (not (nil? result)))))

(deftest conjugate1
  (let [from #"s'([aeéiou].*)er$"
        infinitive "s'amuser"
        to "$1é"]
    (is (= "amusé" (string/replace infinitive from to)))))

(deftest conjugate2
  (is (= "amusé" (conjugate "s'amuser"
                            {:synsem {:infl :past-p
                                      :subcat {:1 {:agr {:number :sing}}}}}))))
(deftest conjugate3
  (is (= (conjugate "s'amuser"
                    {:synsem {:infl :past-p
                              :subcat {:1 {:agr {:number :plur}}}}})
         "amusés")))

(deftest conjugate4
  (is (= (conjugate "s'amuser"
                    {:synsem {:infl :past-p
                              :subcat {:1 {:agr {:gender :masc
                                                 :number :plur}}}}})
         "amusés")))

(deftest conjugate5
  (is (= (conjugate "s'amuser"
                    {:synsem {:infl :past-p
                              :subcat {:1 {:agr {:gender :fem
                                                 :number :plur}}}}})
         "amusées")))

(deftest conjugate6
  (is (= (conjugate "se blesser"
                    {:synsem {:infl :past-p
                              :subcat {:1 {:agr {:gender :masc
                                                 :number :sing}}}}})
         "blessé")))

(deftest conjugate7
  (is (= (conjugate "se blesser"
                    {:synsem {:infl :past-p
                              :subcat {:1 {:agr {:gender :fem
                                                 :number :plur}}}}})
         "blessées")))

(deftest conjugate7
  (is (= (conjugate "se blesser"
                    {:synsem {:infl :present
                              :subcat {:1 {:agr {:person :2nd
                                                 :number :sing}}}}})
         "blesses")))

(defn get-lex [exp]
  (filter #(not (nil? (:lookup %)))
          (map #(let [from (first %)
                      to (second %)
                      unify-with (nth % 2)
                      lex (string/replace exp from to)]
                  {:lex lex
                   :lookup (lookup lex)
                   :unified (map (fn [entry]
                                   (unifyc unify-with entry))
                                 (lookup lex))})
               replace-patterns)))

(defn get-lex2 [exp]
  (filter (fn [result] (not (= :fail result)))
          (mapcat #(let [from (first %)
                         to (second %)
                         unify-with (nth % 2)
                         lex (string/replace exp from to)]
                     (map (fn [entry]
                            (unifyc unify-with entry))
                          (lookup lex)))
                  replace-patterns)))

add more conjugate tests

add more conjugate tests


;; Copyright (c) Cognitect, Inc.
;; All rights reserved.

(ns transit.verify
  "Provides tools for testing all transit implementations at
  once. Tests each implementaion with several sources of data:
  exemplar files, problem edn data, problem transit data and generated
  data. In addition, it can capture comparative timing results.

  From the REPL, the main entry point is `verify-all` which takes an
  options map as an argument. With an empty map it will test each
  encoding for all implementations located in sibling project
  directories which have a `bin/roundtrip` script. Options can be used
  to control which project is tested, which encoding to test, turn on
  generative testing and collect timing information."
  (:require [transit.read :as r]
            [transit.write :as w]
            [clojure.java.io :as io]
            [transit.generators :as gen]
            [transit.corner-cases :as cc])
  (:import [java.io PrintStream ByteArrayOutputStream ByteArrayInputStream
            BufferedInputStream BufferedOutputStream FileInputStream]))

(def TIMEOUT
  "Timeout for roundtrip requests to native implementation"
  10000)

(defn read-bytes
  "Read the contents of the passed file into a byte array and return
  the byte array."
  [file]
  (assert (.exists file) "file must exist")
  (assert (.isFile file) "file must actually be a file")
  (let [size (.length file)
        bytes (make-array Byte/TYPE size)
        in (BufferedInputStream. (FileInputStream. file))]
    (loop [n (.read in bytes 0 size)
           total 0]
      (if (or (= n -1) (= (+ n total) size))
        bytes
        (let [offset (+ n total)
              size (- size offset)]
          (recur (.read in bytes offset size) offset))))))

(defn write-transit
  "Given an object and an encoding, return a byte array containing the
  encoded value of the object."
  [o encoding]
  (let [out (ByteArrayOutputStream.)
        w (w/writer out encoding)]
    (w/write w o)
    (.toByteArray out)))

(defn read-transit
  "Given a byte array containing an encoded value and the encoding used,
  return the decoded object."
  [bytes encoding]
  (try
    (let [in (ByteArrayInputStream. bytes)
          r (r/reader in encoding)]
      (r/read r))
    (catch Throwable e
      ::read-error)))

(defn start-process [command encoding]
  ;; TODO: what if there is exception here? need to report that we
  ;; couldn't start the process?
  ;; TODO: how do we communicate that the encoding is not supported?
  (let [p (.start (ProcessBuilder. [command (name encoding)]))
        out (BufferedOutputStream. (.getOutputStream p))
        in (BufferedInputStream. (.getInputStream p))]
    ;; r/reader does not return until data starts to flow over in
    {:out out :p p :reader (future (r/reader in encoding))}))

(defn stop-process [proc]
  (try
    (.write (:out proc) 3) ;; send Ctrl+C
    (.flush (:out proc))
    (.destroy (:p proc))
    (catch Throwable e
      (println "WARNING! Exception while stopping process.")
      (println (.toString e)))))

;; TODO: failure to write means that the process has died
;; catch and throw the way we do with read-response
(defn write-to-stream [proc transit-data]
  (.write (:out proc) transit-data 0 (count transit-data))
  (.flush (:out proc)))

(defn read-response [proc transit-out timeout-ms]
  (let [f (future (r/read @(:reader proc)))]
    (let [response (deref f timeout-ms ::timeout)]
      (if (= response ::timeout)
        (throw (ex-info "Response timeout" {:status :timeout :p proc :transit transit-out}))
        response))))

(defn roundtrip-transit [proc transit-out encoding]
  (write-to-stream proc transit-out)
  (let [data-in (read-response proc transit-out TIMEOUT)
        data-out (read-transit transit-out encoding)]
    {:transit-expected (String. transit-out)
     :data-expected data-out
     :data-actual data-in
     ;; only checks the top level type
     :status (if (and (= (type data-out) (type data-in))
                      (= data-out data-in))
               :success
               :error)}))

(defn roundtrip-edn [proc edn encoding]
  (try
    (let [transit-out (write-transit edn encoding)]
      (roundtrip-transit proc transit-out encoding))
    (catch Throwable e
      (if (= (-> e ex-data :status) :timeout)
        (throw (ex-info "Response timeout" (assoc (ex-data e) :edn edn)))
        (throw e)))))

(defn test-transit [transits proc encoding]
  (mapv #(roundtrip-transit proc % encoding) transits))

(defn test-edn [forms proc encoding]
  (mapv #(roundtrip-edn proc % encoding) forms))

(defn test-timing [transits proc encoding]
  (println "collecting timing information...")
  (dotimes [x 10000]
    (mapv #(roundtrip-transit proc % encoding) transits))
  (let [start (System/currentTimeMillis)]
    (mapv #(roundtrip-transit proc % encoding) transits)
    (- (System/currentTimeMillis) start)))

(def extension {:json ".json"
                :msgpack ".mp"})

(defn exemplar-transit [encoding]
  (map #(read-bytes %)
       (filter #(and (.isFile %) (.endsWith (.getName %) (extension encoding)))
               (file-seq (io/file "../transit/simple-examples")))))

(defn filter-tests [proc encoding opts]
  (let [transit-exemplars (exemplar-transit encoding)]
    (filter #((:pred %) proc encoding opts)
            [{:pred (constantly true)
              :path [:tests :exemplar-file]
              :test #(test-transit transit-exemplars proc encoding)}
             {:pred (constantly true)
              :path [:tests :corner-case-edn]
              :test #(test-edn cc/forms proc encoding)}
             {:pred (fn [_ e _] (= e :json))
              :path [:tests :corner-case-transit-json]
              :test #(test-transit (map (fn [s] (.getBytes s)) cc/transit-json) proc encoding)}
             {:pred (fn [_ _ o] (:gen o))
              :path [:tests :generated-edn]
              :test #(test-edn (:generated-forms opts) proc encoding)}
             {:pred (fn [_ _ o] (:time o))
              :path [:time]
              :test #(let [ms (test-timing transit-exemplars proc encoding)]
                       {:ms ms
                        :count (count transit-exemplars)
                        :encoding encoding})}])))

(defn verify-impl-encoding [command encoding opts]
  (assert (contains? extension encoding)
          (str "encoding must be on of" (keys extension)))
  (let [proc (start-process command encoding)
        results {:command command
                 :encoding encoding}]
    (try
      (let [tests (filter-tests proc encoding opts)
            results (reduce (fn [r {:keys [path test]}]
                              (assoc-in r path (test)))
                            results
                            tests)]
        (stop-process proc)
        results)
      (catch Throwable e
        (stop-process proc)
        (merge results {:exception e})))))

(declare report)

(defn- run-test [project encoding opts]
  (println "testing" project "...")
  (let [command (str "../" project "/bin/roundtrip")]
    (if (= encoding :msgpack)
      (println "msgpack tests are disabled until we have a working implementation.")
      (report (-> (verify-impl-encoding command encoding opts)
                  (assoc :project project))
              opts))))

(defn verify-impl [project {:keys [enc] :as opts}]
  (doseq [e (if enc [enc] [:json :msgpack])]
    (run-test project e opts)))

(defn verify-all [{:keys [impls] :as opts}]
  (let [root (io/file "../")
        testable-impls (keep #(let [script (io/file root (str % "/bin/roundtrip"))]
                                (when (.exists script) %))
                             (.list root))
        forms (when-let [n (:gen opts)]
                (take n (repeatedly gen/ednable)))]
    (doseq [impl testable-impls]
      (when (or (not impls)
                (contains? impls impl))
        (verify-impl impl (assoc opts :generated-forms forms))))))

(defn read-options [args]
  (reduce (fn [a [[k] v]]
            (case k
              "-impls" (assoc a :impls (set (mapv #(str "transit-" %) v)))
              "-enc" (assoc a :enc (keyword (first v)))
              "-gen" (assoc a :gen (Integer/valueOf (first v)))
              "-time" (assoc a :time true)
              a))
          {}
          (partition-all 2 (partition-by #(.startsWith % "-") args))))

(def ^:dynamic *style* false)

(defn -main [& args]
  (binding [*style* true]
    (verify-all (read-options args))
    (shutdown-agents)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reporting

(def styles {:reset "[0m"
             :red "[31m"
             :green "[32m"
             :bright "[1m"})

(defn with-style [style & strs]
  (let [s (apply str (interpose " " strs))]
    (if (and *style* (not= style :none))
      (str \u001b (style styles) s \u001b (:reset styles))
      s)))

(defn timeout-result? [results]
  (when-let [e (:exception results)]
    (= (:status (ex-data e)) :timeout)))

(defn exception-result? [results]
  (:exception results))

(defn not-implemented? [results]
  (every? #(= (:data-actual %) ::read-error) (apply concat (vals (:tests results)))))

;; TODO: when there is an exception, print out the form that was being
;; transmitted
;; TODO: would be nice if we could do the same thing we do with
;; timeouts and show the previous thing as well
(defn report [{:keys [project command encoding tests time] :as results} opts]
  (println (with-style :bright "Project: " project))
  (println "Command: " command)
  (println "Encoding:" encoding)
  (when time
    (println (with-style :bright
               (format "Time: %s ms to roundtrip %s %s exemplar files"
                       (:ms time)
                       (:count time)
                       (name (:encoding time))))))
  (cond (timeout-result? results)
        (let [timeout-form (-> results :exception ex-data :edn)
              [prev curr] (first (filter #(= (last %) timeout-form)
                                         (partition 2 1 (:generated-forms opts))))]
          (println (with-style :red "Response Timeout"))
          (println (with-style :red "Timeout while processing:"))
          (println (pr-str timeout-form))
          (println (with-style :red "Previous form was:"))
          (println (pr-str prev)))
        (exception-result? results)
        (do (println results)
            (.printStackTrace (:exception results)))
        (not-implemented? results)
        (println (with-style :red "Not Implemented"))
        :else
        ;; TODO: need to do something better for printing transit data
        ;; (when bytes)
        (doseq [[k v] tests]
          (let [errors (filter #(= (:status %) :error) v)
                ecnt (count errors)
                pcnt (- (count v) ecnt)
                style (if (pos? ecnt) :red :green)]
            (println (with-style style (format "Testing with %s %s inputs"
                                               (count v) k)))
            (println (with-style style (format "Summary: passed: %s, errors: %s"
                                               pcnt ecnt)))
            (when (pos? ecnt)
              (do (doseq [error errors]
                    (println "Sent Transit:" (pr-str (:transit-expected error)))
                    (println "Expected:    " (pr-str (:data-expected error)))
                    (println "Actual:      " (pr-str (:data-actual error))))))))))

;; Copyright (c) Cognitect, Inc.
;; All rights reserved.

(ns transit.verify
  "Provides tools for testing all transit implementations at
  once. Tests each implementaion with several sources of data:
  exemplar files, problem edn data, problem transit data and generated
  data. In addition, it can capture comparative timing results.

  From the REPL, the main entry point is `verify-all` which takes an
  options map as an argument. With an empty map it will test each
  encoding for all implementations located in sibling project
  directories which have a `bin/roundtrip` script. Options can be used
  to control which project is tested, which encoding to test, turn on
  generative testing and collect timing information."
  (:require [transit.read :as r]
            [transit.write :as w]
            [clojure.java.io :as io]
            [transit.generators :as gen]
            [transit.corner-cases :as cc])
  (:import [java.io PrintStream ByteArrayOutputStream ByteArrayInputStream
            BufferedInputStream BufferedOutputStream FileInputStream]))

(def TIMEOUT
  "Timeout for roundtrip requests to native implementation"
  10000)

(defn read-bytes
  "Read the contents of the passed file into a byte array and return
  the byte array."
  [file]
  (assert (.exists file) "file must exist")
  (assert (.isFile file) "file must actually be a file")
  (let [size (.length file)
        bytes (make-array Byte/TYPE size)
        in (BufferedInputStream. (FileInputStream. file))]
    (loop [n (.read in bytes 0 size)
           total 0]
      (if (or (= n -1) (= (+ n total) size))
        bytes
        (let [offset (+ n total)
              size (- size offset)]
          (recur (.read in bytes offset size) offset))))))

(defn write-transit
  "Given an object and an encoding, return a byte array containing the
  encoded value of the object."
  [o encoding]
  (let [out (ByteArrayOutputStream.)
        w (w/writer out encoding)]
    (w/write w o)
    (.toByteArray out)))

(defn read-transit
  "Given a byte array containing an encoded value and the encoding used,
  return the decoded object."
  [bytes encoding]
  (try
    (let [in (ByteArrayInputStream. bytes)
          r (r/reader in encoding)]
      (r/read r))
    (catch Throwable e
      ::read-error)))

(defn start-process [command encoding]
  ;; TODO: what if there is exception here? need to report that we
  ;; couldn't start the process?
  ;; TODO: how do we communicate that the encoding is not supported?
  (let [p (.start (ProcessBuilder. [command (name encoding)]))
        out (BufferedOutputStream. (.getOutputStream p))
        in (BufferedInputStream. (.getInputStream p))]
    ;; r/reader does not return until data starts to flow over in
    {:out out :p p :reader (future (r/reader in encoding))}))

(defn stop-process [proc]
  (try
    (.write (:out proc) 3) ;; send Ctrl+C
    (.flush (:out proc))
    (.destroy (:p proc))
    (catch Throwable e
      (println "WARNING! Exception while stopping process.")
      (println (.toString e)))))

;; TODO: failure to write means that the process has died
;; catch and throw the way we do with read-response
(defn write-to-stream [proc transit-data]
  (.write (:out proc) transit-data 0 (count transit-data))
  (.flush (:out proc)))

(defn read-response [proc transit-out timeout-ms]
  (let [f (future (r/read @(:reader proc)))]
    (let [response (deref f timeout-ms ::timeout)]
      (if (= response ::timeout)
        (throw (ex-info "Response timeout" {:status :timeout :p proc :transit transit-out}))
        response))))

(defn roundtrip-transit [proc transit-out encoding]
  (write-to-stream proc transit-out)
  (let [data-in (read-response proc transit-out TIMEOUT)
        data-out (read-transit transit-out encoding)]
    {:transit-expected (String. transit-out)
     :data-expected data-out
     :data-actual data-in
     ;; only checks the top level type
     :status (if (and (= (type data-out) (type data-in))
                      (= data-out data-in))
               :success
               :error)}))

(defn roundtrip-edn [proc edn encoding]
  (try
    (let [transit-out (write-transit edn encoding)]
      (roundtrip-transit proc transit-out encoding))
    (catch Throwable e
      (if (= (-> e ex-data :status) :timeout)
        (throw (ex-info "Response timeout" (assoc (ex-data e) :edn edn)))
        (throw e)))))

(defn test-transit [transits proc encoding]
  (mapv #(roundtrip-transit proc % encoding) transits))

(defn test-edn [forms proc encoding]
  (mapv #(roundtrip-edn proc % encoding) forms))

(defn test-timing [transits proc encoding]
  (println "collecting timing information...")
  (dotimes [x 100]
    (mapv #(roundtrip-transit proc % encoding) transits))
  (let [start (System/currentTimeMillis)]
    (mapv #(roundtrip-transit proc % encoding) transits)
    (- (System/currentTimeMillis) start)))

(def extension {:json ".json"
                :msgpack ".mp"})

(defn exemplar-transit [encoding]
  (map #(read-bytes %)
       (filter #(and (.isFile %) (.endsWith (.getName %) (extension encoding)))
               (file-seq (io/file "../transit/simple-examples")))))

(defn filter-tests [proc encoding opts]
  (let [transit-exemplars (exemplar-transit encoding)]
    (filter #((:pred %) proc encoding opts)
            [{:pred (constantly true)
              :path [:tests :exemplar-file]
              :test #(test-transit transit-exemplars proc encoding)}
             {:pred (constantly true)
              :path [:tests :corner-case-edn]
              :test #(test-edn cc/forms proc encoding)}
             {:pred (fn [_ e _] (= e :json))
              :path [:tests :corner-case-transit-json]
              :test #(test-transit (map (fn [s] (.getBytes s)) cc/transit-json) proc encoding)}
             {:pred (fn [_ _ o] (:gen o))
              :path [:tests :generated-edn]
              :test #(test-edn (:generated-forms opts) proc encoding)}
             {:pred (fn [_ _ o] (:time o))
              :path [:time]
              :test #(let [ms (test-timing transit-exemplars proc encoding)]
                       {:ms ms
                        :count (count transit-exemplars)
                        :encoding encoding})}])))

(defn verify-impl-encoding [command encoding opts]
  (assert (contains? extension encoding)
          (str "encoding must be on of" (keys extension)))
  (let [proc (start-process command encoding)
        results {:command command
                 :encoding encoding}]
    (try
      (let [tests (filter-tests proc encoding opts)
            results (reduce (fn [r {:keys [path test]}]
                              (assoc-in r path (test)))
                            results
                            tests)]
        (stop-process proc)
        results)
      (catch Throwable e
        (stop-process proc)
        (merge results {:exception e})))))

(declare report)

(defn- run-test [project encoding opts]
  (println "testing" project "...")
  (let [command (str "../" project "/bin/roundtrip")]
    (if (= encoding :msgpack)
      (println "msgpack tests are disabled until we have a working implementation.")
      (report (-> (verify-impl-encoding command encoding opts)
                  (assoc :project project))
              opts))))

(defn verify-impl [project {:keys [enc] :as opts}]
  (doseq [e (if enc [enc] [:json :msgpack])]
    (run-test project e opts)))

(defn verify-all [{:keys [impls] :as opts}]
  (let [root (io/file "../")
        testable-impls (keep #(let [script (io/file root (str % "/bin/roundtrip"))]
                                (when (.exists script) %))
                             (.list root))
        forms (when-let [n (:gen opts)]
                (take n (repeatedly gen/ednable)))]
    (doseq [impl testable-impls]
      (when (or (not impls)
                (contains? impls impl))
        (verify-impl impl (assoc opts :generated-forms forms))))))

(defn read-options [args]
  (reduce (fn [a [[k] v]]
            (case k
              "-impls" (assoc a :impls (set (mapv #(str "transit-" %) v)))
              "-enc" (assoc a :enc (keyword (first v)))
              "-gen" (assoc a :gen (Integer/valueOf (first v)))
              "-time" (assoc a :time true)
              a))
          {}
          (partition-all 2 (partition-by #(.startsWith % "-") args))))

(def ^:dynamic *style* false)

(defn -main [& args]
  (binding [*style* true]
    (verify-all (read-options args))
    (shutdown-agents)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reporting

(def styles {:reset "[0m"
             :red "[31m"
             :green "[32m"
             :bright "[1m"})

(defn with-style [style & strs]
  (let [s (apply str (interpose " " strs))]
    (if (and *style* (not= style :none))
      (str \u001b (style styles) s \u001b (:reset styles))
      s)))

(defn timeout-result? [results]
  (when-let [e (:exception results)]
    (= (:status (ex-data e)) :timeout)))

(defn exception-result? [results]
  (:exception results))

(defn not-implemented? [results]
  (every? #(= (:data-actual %) ::read-error) (apply concat (vals (:tests results)))))

;; TODO: when there is an exception, print out the form that was being
;; transmitted
;; TODO: would be nice if we could do the same thing we do with
;; timeouts and show the previous thing as well
(defn report [{:keys [project command encoding tests time] :as results} opts]
  (println (with-style :bright "Project: " project))
  (println "Command: " command)
  (println "Encoding:" encoding)
  (when time
    (println (with-style :bright
               (format "Time: %s ms to roundtrip %s %s exemplar files"
                       (:ms time)
                       (:count time)
                       (name (:encoding time))))))
  (cond (timeout-result? results)
        (let [timeout-form (-> results :exception ex-data :edn)
              [prev curr] (first (filter #(= (last %) timeout-form)
                                         (partition 2 1 (:generated-forms opts))))]
          (println (with-style :red "Response Timeout"))
          (println (with-style :red "Timeout while processing:"))
          (println (pr-str timeout-form))
          (println (with-style :red "Previous form was:"))
          (println (pr-str prev)))
        (exception-result? results)
        (do (println results)
            (.printStackTrace (:exception results)))
        (not-implemented? results)
        (println (with-style :red "Not Implemented"))
        :else
        ;; TODO: need to do something better for printing transit data
        ;; (when bytes)
        (doseq [[k v] tests]
          (let [errors (filter #(= (:status %) :error) v)
                ecnt (count errors)
                pcnt (- (count v) ecnt)
                style (if (pos? ecnt) :red :green)]
            (println (with-style style (format "Testing with %s %s inputs"
                                               (count v) k)))
            (println (with-style style (format "Summary: passed: %s, errors: %s"
                                               pcnt ecnt)))
            (when (pos? ecnt)
              (do (doseq [error errors]
                    (println "Sent Transit:" (pr-str (:transit-expected error)))
                    (println "Expected:    " (pr-str (:data-expected error)))
                    (println "Actual:      " (pr-str (:data-actual error))))))))))

Use 100 for the number of warm up runs before recording time