(ns cheshire.core
  "Main encoding and decoding namespace."
  (:require [cheshire.factory :as factory]
            [cheshire.generate :as gen]
            [cheshire.generate-seq :as gen-seq]
            [cheshire.parse :as parse])
  (:import (com.fasterxml.jackson.core JsonParser JsonFactory
                                       JsonGenerator
                                       JsonGenerator$Feature)
           (com.fasterxml.jackson.dataformat.smile SmileFactory)
           (java.io StringWriter StringReader BufferedReader BufferedWriter
                    ByteArrayOutputStream)))

;; Generators
(defn ^String generate-string
  "Returns a JSON-encoding String for the given Clojure object. Takes an
  optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
     (generate-string obj nil))
  ([obj opt-map]
     (let [sw (StringWriter.)
           generator (.createJsonGenerator
                      ^JsonFactory (or factory/*json-factory*
                                       factory/json-factory) sw)]
       (when (:pretty opt-map)
         (.useDefaultPrettyPrinter generator))
       (when (:escape-non-ascii opt-map)
         (.enable generator JsonGenerator$Feature/ESCAPE_NON_ASCII))
       (gen/generate generator obj
                     (or (:date-format opt-map) factory/default-date-format)
                     (:ex opt-map)
                     (:key-fn opt-map))
       (.flush generator)
       (.toString sw))))

(defn ^String generate-stream
  "Returns a BufferedWriter for the given Clojure object with the.
  JSON-encoded data written to the writer. Takes an optional date
  format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj ^BufferedWriter writer]
     (generate-stream obj writer nil))
  ([obj ^BufferedWriter writer opt-map]
     (let [generator (.createJsonGenerator
                      ^JsonFactory (or factory/*json-factory*
                                       factory/json-factory) writer)]
       (when (:pretty opt-map)
         (.useDefaultPrettyPrinter generator))
       (when (:escape-non-ascii opt-map)
         (.enable generator JsonGenerator$Feature/ESCAPE_NON_ASCII))
       (gen/generate generator obj (or (:date-format opt-map)
                                       factory/default-date-format)
                     (:ex opt-map)
                     (:key-fn opt-map))
       (.flush generator)
       writer)))

(defn create-generator [writer]
  "Returns JsonGenerator for given writer."
  (.createJsonGenerator
   ^JsonFactory (or factory/*json-factory*
                    factory/json-factory) writer))

(def ^:dynamic ^JsonGenerator *generator*)
(def ^:dynamic *opt-map*)

(defmacro with-writer [[writer opt-map] & body]
  "Start writing for series objects using the same json generator.
   Takes writer and options map as arguments.
   Expects it's body as sequence of write calls.
   Returns a given writer."
  `(let [c-wr# ~writer]
     (binding [*generator* (create-generator c-wr#)
               *opt-map* ~opt-map]
       ~@body
       (.flush *generator*)
       c-wr#)))

(defn write
  "Write given Clojure object as a piece of data within with-writer.
  List of wholeness acceptable values:
  - no value - the same as :all
  - :all - write object in a regular way with start and end borders
  - :start - write object with start border only
  - :start-inner - write object and it's inner object with start border only
  - :end - write object with end border only."
  ([obj] (write obj nil))
  ([obj wholeness]
     (gen-seq/generate *generator* obj (or (:date-format *opt-map*)
                                           factory/default-date-format)
                       (:ex *opt-map*)
                       (:key-fn *opt-map*)
                       :wholeness wholeness)))

(defn generate-smile
  "Returns a SMILE-encoded byte-array for the given Clojure object.
  Takes an optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
     (generate-smile obj nil))
  ([obj opt-map]
     (let [baos (ByteArrayOutputStream.)
           generator (.createJsonGenerator ^SmileFactory
                                           (or factory/*smile-factory*
                                               factory/smile-factory)
                                           baos)]
       (gen/generate generator obj (or (:date-format opt-map)
                                       factory/default-date-format)
                     (:ex opt-map)
                     (:key-fn opt-map))
       (.flush generator)
       (.toByteArray baos))))

(defn generate-cbor
  "Returns a CBOR-encoded byte-array for the given Clojure object.
  Takes an optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
     (generate-cbor obj nil))
  ([obj opt-map]
     (let [baos (ByteArrayOutputStream.)
           generator (.createJsonGenerator ^CBORFactory
                                           (or factory/*cbor-factory*
                                               factory/cbor-factory)
                                           baos)]
       (gen/generate generator obj (or (:date-format opt-map)
                                       factory/default-date-format)
                     (:ex opt-map)
                     (:key-fn opt-map))
       (.flush generator)
       (.toByteArray baos))))

;; Parsers
(defn parse-string
  "Returns the Clojure object corresponding to the given JSON-encoded string.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([string] (parse-string string nil nil))
  ([string key-fn] (parse-string string key-fn nil))
  ([^String string key-fn array-coerce-fn]
     (when string
       (parse/parse
        (.createJsonParser ^JsonFactory (or factory/*json-factory*
                                            factory/json-factory)
                           (StringReader. string))
        key-fn nil array-coerce-fn))))

;; Parsing strictly
(defn parse-string-strict
  "Returns the Clojure object corresponding to the given JSON-encoded string.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.

  Does not lazily parse top-level arrays."
  ([string] (parse-string-strict string nil nil))
  ([string key-fn] (parse-string-strict string key-fn nil))
  ([^String string key-fn array-coerce-fn]
     (when string
       (parse/parse-strict
        (.createJsonParser ^JsonFactory (or factory/*json-factory*
                                            factory/json-factory)
                           (StringReader. string))
        key-fn nil array-coerce-fn))))

(defn parse-stream
  "Returns the Clojure object corresponding to the given reader, reader must
  implement BufferedReader. An optional key-fn argument can be either true (to
  coerce keys to keywords),false to leave them as strings, or a function to
  provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.
  If laziness is needed, see parsed-seq."
  ([rdr] (parse-stream rdr nil nil))
  ([rdr key-fn] (parse-stream rdr key-fn nil))
  ([^BufferedReader rdr key-fn array-coerce-fn]
     (when rdr
       (parse/parse
        (.createJsonParser ^JsonFactory (or factory/*json-factory*
                                            factory/json-factory) rdr)
        key-fn nil array-coerce-fn))))

(defn parse-smile
  "Returns the Clojure object corresponding to the given SMILE-encoded bytes.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([bytes] (parse-smile bytes nil nil))
  ([bytes key-fn] (parse-smile bytes key-fn nil))
  ([^bytes bytes key-fn array-coerce-fn]
     (when bytes
       (parse/parse
        (.createJsonParser ^SmileFactory (or factory/*smile-factory*
                                             factory/smile-factory) bytes)
        key-fn nil array-coerce-fn))))

(defn parse-cbor
  "Returns the Clojure object corresponding to the given CBOR-encoded bytes.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([bytes] (parse-cbor bytes nil nil))
  ([bytes key-fn] (parse-cbor bytes key-fn nil))
  ([^bytes bytes key-fn array-coerce-fn]
     (when bytes
       (parse/parse
        (.createJsonParser ^CBORFactory (or factory/*cbor-factory*
                                            factory/cbor-factory) bytes)
        key-fn nil array-coerce-fn))))

(def ^{:doc "Object used to determine end of lazy parsing attempt."}
  eof (Object.))

;; Lazy parsers
(defn- parsed-seq*
  "Internal lazy-seq parser"
  [^JsonParser parser key-fn array-coerce-fn]
  (lazy-seq
   (let [elem (parse/parse-strict parser key-fn eof array-coerce-fn)]
     (when-not (identical? elem eof)
       (cons elem (parsed-seq* parser key-fn array-coerce-fn))))))

(defn parsed-seq
  "Returns a lazy seq of Clojure objects corresponding to the JSON read from
  the given reader. The seq continues until the end of the reader is reached.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.
  If non-laziness is needed, see parse-stream."
  ([reader] (parsed-seq reader nil nil))
  ([reader key-fn] (parsed-seq reader key-fn nil))
  ([^BufferedReader reader key-fn array-coerce-fn]
     (when reader
       (parsed-seq* (.createJsonParser ^JsonFactory
                                       (or factory/*json-factory*
                                           factory/json-factory) reader)
                    key-fn array-coerce-fn))))

(defn parsed-smile-seq
  "Returns a lazy seq of Clojure objects corresponding to the SMILE read from
  the given reader. The seq continues until the end of the reader is reached.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([reader] (parsed-smile-seq reader nil nil))
  ([reader key-fn] (parsed-smile-seq reader key-fn nil))
  ([^BufferedReader reader key-fn array-coerce-fn]
     (when reader
       (parsed-seq* (.createJsonParser ^SmileFactory
                                       (or factory/*smile-factory*
                                           factory/smile-factory) reader)
                    key-fn array-coerce-fn))))

;; aliases for clojure-json users
(def encode "Alias to generate-string for clojure-json users" generate-string)
(def encode-stream "Alias to generate-stream for clojure-json users" generate-stream)
(def encode-smile "Alias to generate-smile for clojure-json users" generate-smile)
(def decode "Alias to parse-string for clojure-json users" parse-string)
(def decode-strict "Alias to parse-string-strict for clojure-json users" parse-string-strict)
(def decode-stream "Alias to parse-stream for clojure-json users" parse-stream)
(def decode-smile "Alias to parse-smile for clojure-json users" parse-smile)

(ns cheshire.core
  "Main encoding and decoding namespace."
  (:require [cheshire.factory :as factory]
            [cheshire.generate :as gen]
            [cheshire.generate-seq :as gen-seq]
            [cheshire.parse :as parse])
  (:import (com.fasterxml.jackson.core JsonParser JsonFactory
                                       JsonGenerator
                                       JsonGenerator$Feature)
           (com.fasterxml.jackson.dataformat.smile SmileFactory)
           (java.io StringWriter StringReader BufferedReader BufferedWriter
                    ByteArrayOutputStream OutputStream Reader Writer)))

;; Generators
(defn ^String generate-string
  "Returns a JSON-encoding String for the given Clojure object. Takes an
  optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
   (generate-string obj nil))
  ([obj opt-map]
   (let [sw (StringWriter.)
         generator (.createGenerator
                    ^JsonFactory (or factory/*json-factory*
                                     factory/json-factory)
                    ^Writer sw)]
     (when (:pretty opt-map)
       (.useDefaultPrettyPrinter generator))
     (when (:escape-non-ascii opt-map)
       (.enable generator JsonGenerator$Feature/ESCAPE_NON_ASCII))
     (gen/generate generator obj
                   (or (:date-format opt-map) factory/default-date-format)
                   (:ex opt-map)
                   (:key-fn opt-map))
     (.flush generator)
     (.toString sw))))

(defn ^String generate-stream
  "Returns a BufferedWriter for the given Clojure object with the.
  JSON-encoded data written to the writer. Takes an optional date
  format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj ^BufferedWriter writer]
   (generate-stream obj writer nil))
  ([obj ^BufferedWriter writer opt-map]
   (let [generator (.createGenerator
                    ^JsonFactory (or factory/*json-factory*
                                     factory/json-factory)
                    ^Writer writer)]
     (when (:pretty opt-map)
       (.useDefaultPrettyPrinter generator))
     (when (:escape-non-ascii opt-map)
       (.enable generator JsonGenerator$Feature/ESCAPE_NON_ASCII))
     (gen/generate generator obj (or (:date-format opt-map)
                                     factory/default-date-format)
                   (:ex opt-map)
                   (:key-fn opt-map))
     (.flush generator)
     writer)))

(defn create-generator [writer]
  "Returns JsonGenerator for given writer."
  (.createGenerator
   ^JsonFactory (or factory/*json-factory*
                    factory/json-factory)
   ^Writer writer))

(def ^:dynamic ^JsonGenerator *generator*)
(def ^:dynamic *opt-map*)

(defmacro with-writer [[writer opt-map] & body]
  "Start writing for series objects using the same json generator.
   Takes writer and options map as arguments.
   Expects it's body as sequence of write calls.
   Returns a given writer."
  `(let [c-wr# ~writer]
     (binding [*generator* (create-generator c-wr#)
               *opt-map* ~opt-map]
       ~@body
       (.flush *generator*)
       c-wr#)))

(defn write
  "Write given Clojure object as a piece of data within with-writer.
  List of wholeness acceptable values:
  - no value - the same as :all
  - :all - write object in a regular way with start and end borders
  - :start - write object with start border only
  - :start-inner - write object and it's inner object with start border only
  - :end - write object with end border only."
  ([obj] (write obj nil))
  ([obj wholeness]
   (gen-seq/generate *generator* obj (or (:date-format *opt-map*)
                                         factory/default-date-format)
                     (:ex *opt-map*)
                     (:key-fn *opt-map*)
                     :wholeness wholeness)))

(defn generate-smile
  "Returns a SMILE-encoded byte-array for the given Clojure object.
  Takes an optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
   (generate-smile obj nil))
  ([obj opt-map]
   (let [baos (ByteArrayOutputStream.)
         generator (.createGenerator ^SmileFactory
                                     (or factory/*smile-factory*
                                         factory/smile-factory)
                                     ^OutputStream baos)]
     (gen/generate generator obj (or (:date-format opt-map)
                                     factory/default-date-format)
                   (:ex opt-map)
                   (:key-fn opt-map))
     (.flush generator)
     (.toByteArray baos))))

(defn generate-cbor
  "Returns a CBOR-encoded byte-array for the given Clojure object.
  Takes an optional date format string that Date objects will be encoded with.

  The default date format (in UTC) is: yyyy-MM-dd'T'HH:mm:ss'Z'"
  ([obj]
   (generate-cbor obj nil))
  ([obj opt-map]
   (let [baos (ByteArrayOutputStream.)
         generator (.createGenerator ^CBORFactory
                                     (or factory/*cbor-factory*
                                         factory/cbor-factory)
                                     ^OutputStream baos)]
     (gen/generate generator obj (or (:date-format opt-map)
                                     factory/default-date-format)
                   (:ex opt-map)
                   (:key-fn opt-map))
     (.flush generator)
     (.toByteArray baos))))

;; Parsers
(defn parse-string
  "Returns the Clojure object corresponding to the given JSON-encoded string.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([string] (parse-string string nil nil))
  ([string key-fn] (parse-string string key-fn nil))
  ([^String string key-fn array-coerce-fn]
   (when string
     (parse/parse
      (.createParser ^JsonFactory (or factory/*json-factory*
                                      factory/json-factory)
                     ^Reader (StringReader. string))
      key-fn nil array-coerce-fn))))

;; Parsing strictly
(defn parse-string-strict
  "Returns the Clojure object corresponding to the given JSON-encoded string.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.

  Does not lazily parse top-level arrays."
  ([string] (parse-string-strict string nil nil))
  ([string key-fn] (parse-string-strict string key-fn nil))
  ([^String string key-fn array-coerce-fn]
   (when string
     (parse/parse-strict
      (.createParser ^JsonFactory (or factory/*json-factory*
                                      factory/json-factory)
                     ^Writer (StringReader. string))
      key-fn nil array-coerce-fn))))

(defn parse-stream
  "Returns the Clojure object corresponding to the given reader, reader must
  implement BufferedReader. An optional key-fn argument can be either true (to
  coerce keys to keywords),false to leave them as strings, or a function to
  provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.
  If laziness is needed, see parsed-seq."
  ([rdr] (parse-stream rdr nil nil))
  ([rdr key-fn] (parse-stream rdr key-fn nil))
  ([^BufferedReader rdr key-fn array-coerce-fn]
   (when rdr
     (parse/parse
      (.createParser ^JsonFactory (or factory/*json-factory*
                                      factory/json-factory)
                     ^Reader rdr)
      key-fn nil array-coerce-fn))))

(defn parse-smile
  "Returns the Clojure object corresponding to the given SMILE-encoded bytes.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([bytes] (parse-smile bytes nil nil))
  ([bytes key-fn] (parse-smile bytes key-fn nil))
  ([^bytes bytes key-fn array-coerce-fn]
   (when bytes
     (parse/parse
      (.createParser ^SmileFactory (or factory/*smile-factory*
                                       factory/smile-factory) bytes)
      key-fn nil array-coerce-fn))))

(defn parse-cbor
  "Returns the Clojure object corresponding to the given CBOR-encoded bytes.
  An optional key-fn argument can be either true (to coerce keys to keywords),
  false to leave them as strings, or a function to provide custom coercion.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([bytes] (parse-cbor bytes nil nil))
  ([bytes key-fn] (parse-cbor bytes key-fn nil))
  ([^bytes bytes key-fn array-coerce-fn]
   (when bytes
     (parse/parse
      (.createParser ^CBORFactory (or factory/*cbor-factory*
                                      factory/cbor-factory) bytes)
      key-fn nil array-coerce-fn))))

(def ^{:doc "Object used to determine end of lazy parsing attempt."}
  eof (Object.))

;; Lazy parsers
(defn- parsed-seq*
  "Internal lazy-seq parser"
  [^JsonParser parser key-fn array-coerce-fn]
  (lazy-seq
   (let [elem (parse/parse-strict parser key-fn eof array-coerce-fn)]
     (when-not (identical? elem eof)
       (cons elem (parsed-seq* parser key-fn array-coerce-fn))))))

(defn parsed-seq
  "Returns a lazy seq of Clojure objects corresponding to the JSON read from
  the given reader. The seq continues until the end of the reader is reached.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values.
  If non-laziness is needed, see parse-stream."
  ([reader] (parsed-seq reader nil nil))
  ([reader key-fn] (parsed-seq reader key-fn nil))
  ([^BufferedReader reader key-fn array-coerce-fn]
   (when reader
     (parsed-seq* (.createParser ^JsonFactory
                                 (or factory/*json-factory*
                                     factory/json-factory)
                                 ^Reader reader)
                  key-fn array-coerce-fn))))

(defn parsed-smile-seq
  "Returns a lazy seq of Clojure objects corresponding to the SMILE read from
  the given reader. The seq continues until the end of the reader is reached.

  The array-coerce-fn is an optional function taking the name of an array field,
  and returning the collection to be used for array values."
  ([reader] (parsed-smile-seq reader nil nil))
  ([reader key-fn] (parsed-smile-seq reader key-fn nil))
  ([^BufferedReader reader key-fn array-coerce-fn]
   (when reader
     (parsed-seq* (.createParser ^SmileFactory
                                 (or factory/*smile-factory*
                                     factory/smile-factory)
                                 ^Reader reader)
                  key-fn array-coerce-fn))))

;; aliases for clojure-json users
(def encode "Alias to generate-string for clojure-json users" generate-string)
(def encode-stream "Alias to generate-stream for clojure-json users" generate-stream)
(def encode-smile "Alias to generate-smile for clojure-json users" generate-smile)
(def decode "Alias to parse-string for clojure-json users" parse-string)
(def decode-strict "Alias to parse-string-strict for clojure-json users" parse-string-strict)
(def decode-stream "Alias to parse-stream for clojure-json users" parse-stream)
(def decode-smile "Alias to parse-smile for clojure-json users" parse-smile)

Use the non-deprecated createGenerator and createParser

.createJsonGenerator and .createJsonParser are both deprecated.

This also adds more type hints for the arguments.

Fixes #72


(ns clrdlhu.core
  (:require [clojure.browser.repl :as repl]
            [monet.canvas :as canvas]
            [cljs.core.logic :as m :refer [membero]]))

;; (repl/connect "http://localhost:9000/repl")

(enable-console-print!)

(defrecord block [name
                  type
                  width
                  height
                  position
                  supported-by
                  support-for])

(defrecord hand [name
                 position
                 grasping])

(def h (-> (make-hierarchy)
          (derive ::movable-block ::basic-block)
          (derive ::load-bearing-block ::basic-block)

          (derive ::brick ::movable-block)
          (derive ::brick ::load-bearing-block)

          (derive ::wedge ::movable-block)

          (derive ::ball ::movable-block)

          (derive ::table ::load-bearing-block)))

(defn make-def [k v]
  ;;(eval `(def ~(symbol k) ~v))
  (reset! (block_map k) v))

(defn reset-world []

  (def hh (atom (hand. "hand" '(0 6) nil)))

  (def block_map {"tt" (atom (block. "tt" ::table 20 0 '(0 0) nil '()))
                  "b1" (atom (block. "b1" ::brick 2  2 '(0 0) nil nil))
                  "b2" (atom (block. "b2" ::brick 2  2 '(2 0) nil nil))
                  "b3" (atom (block. "b3" ::brick 4  4 '(4 0) nil nil))
                  "b4" (atom (block. "b4" ::brick 2  2 '(8 0) nil nil))
                  "w5" (atom (block. "w5" ::wedge 2  4 '(10 0) nil nil))
                  "b6" (atom (block. "b6" ::brick 4  2 '(12 0) nil nil))
                  "w7" (atom (block. "w7" ::wedge 2  2 '(16 0) nil nil))
                  "lq" (atom (block. "lq" ::ball  2  2 '(18 0) nil nil))})

  (doseq [[k v] block_map
          :let [tt (block_map "tt")]]
    (if (not= v tt)
      (do
        (make-def "tt" (update-in @tt [:support-for] (fn [x y] (cons y x)) v))
        (make-def k (update-in @v [:supported-by] (fn [x y] y) tt)))))

  ;; (doseq [l *blocks*]
  ;;   (let [n (:name l)]
  ;;     (make-def n l)))

  ;; (doseq [l (rest *blocks*)
  ;;         :let [tt (first *blocks*)]]

  ;;   ;; (make-def (:name tt))
  ;;   (reset! tt (update-in @tt [:support-for] (fn [x y] (cons y x)) l))
  ;;   ;; (make-def (:name l))
  ;;   (reset! l (update-in @l [:supported-by] (fn [x y] y) tt))
  ;;   )
  )
(reset-world)
;;(println (block_map "b2"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare top-location)
(declare intersections-p)
(declare find-space)
(declare get-space)
(declare grasp)
(declare ungrasp)
(declare get-ride-of)
(declare make-space)
(declare clear-top)
(declare move)
(declare remove-support)
(declare add-support)
(declare put-on)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn top-location [object]
  (let [pos (:position @object)
        posx (first pos)
        posy (fnext pos)
        w (:width @object)
        h (:height @object)]
    (list (+ posx  (/ w 2)) (+ posy h))))

(defn intersections-p [object offset base obstacles]
  ;;(println "----+++")
  ;;(println "Ip, " (:name @object) offset base);; obstacles)
  (let [hit nil]
    (loop [obstacle obstacles
           hit nil]
      ;;(println (or (empty? obstacle) (= true hit)))
      (if (or (empty? obstacle) (= true hit))
        hit
        (let [o (first obstacle)
              ls-proposed (+ offset base)
              rs-proposed (+ ls-proposed (:width @object))
              ls-obstacle (first (:position @o))
              rs-obstacle (+ ls-obstacle (:width @o))]

          ;; (println (count obstacle) "-->"
          ;;          (:name @object) ls-proposed rs-proposed
          ;;          (:name @o) ls-obstacle rs-obstacle
          ;;          (or (>= ls-proposed rs-obstacle) (<= rs-proposed ls-obstacle)))

          (if (or (>= ls-proposed rs-obstacle)
                 (<= rs-proposed ls-obstacle))
            (recur (next obstacle) hit)
            (recur (next obstacle) true)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  FIND-SPACE

(defn find-space [object support]
  (println "F-Spc, " (:name @object) " - " (:name @support))
  (loop [curr-offset 0
         max-offset (+ 1 (- (:width @support)
                            (:width @object)))
         hit nil]

    ;; (println "-->" (intersections-p object curr-offset
    ;;                                 (first (:position @support))
    ;;                                 (:support-for @support)))

    (cond (or (= curr-offset max-offset) (not= nil hit)) hit
          :else (if (not (intersections-p object curr-offset
                                        (first (:position @support))
                                        (:support-for @support)))
                  (recur (+ 1 curr-offset) max-offset (list (+ curr-offset (first (:position @support)))
                                                            (+ (second (:position @support))
                                                               (:height @support))))
                  (recur (+ 1 curr-offset) max-offset hit)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GET-SPACE

(defmulti get-space
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod get-space [::movable-block ::basic-block] [object support]
  (println "G-Spc, " (:name @object) " - " (:name @support))
  ;;(println " --- > "(find-space object support))
  (or (find-space object support)
     (make-space object support)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GRASP

(defmulti grasp
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod grasp ::movable-block [object]
  (println "TRY GRASP")
  (when-not (= (:grasping @hh) object)
    (when (:support-for @object) (clear-top object))
    (when (:grasping @hh)
      (get-ride-of (:grasping @hh)))
    (println "Move hand to pick up "
             (:name @object)
             " at location "
             (top-location object))

    (reset! hh (assoc @hh :position (top-location object)))
    (println "Grasp " (:name @object))
    (reset! hh (assoc @hh :grasping object)))
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  UNGRASP

(defmulti ungrasp
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod ungrasp ::movable-block [object]
  (println "Try Ungrasp " (:name @object))
  (when (:supported-by @object)
    (println "Ungrasp " (:name @object))
    ;;(def hh (assoc hh :grasping nil))
    (reset! hh (assoc @hh :grasping nil))
    true))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GET_RIDE-OF

(defmulti get-ride-of
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod get-ride-of ::movable-block [object]
  (println "TRY GET-RID-OF")
  (put-on object (block_map "tt")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MAKE-SPACE

(defmulti make-space
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod make-space [::movable-block ::basic-block] [object support]
  (println "TRY MAKE-SPACE")
  (loop [obstruction (:support-for support)
         hit nil]
    (cond (or (not= nil hit)(empty? obstruction)) hit
          :else (do
                  (get-ride-of (first obstruction))
                  (let [space (find-space object support)]
                    (if space
                      (recur (next obstruction) space)
                      (recur (next obstruction) hit)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  CLEAR-TOP

(defmulti clear-top
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod clear-top ::load-bearing-block [support]
  (println "TRY CLEAR-TOP" (count (:support-for @support)))
  (doseq [obstacle (:support-for @support)]
    (get-ride-of obstacle))
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MOVE

(defmulti move
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod move [::movable-block ::basic-block] [object support]
  (println "TRY MOVE" (:name @object))
  (remove-support object)
  (make-def (:name @object) (assoc @object :position '(3000 3000)))
  (let [newplace (get-space object support)]
    (println "Move" (:name @object)
             "to top of" (:name @support)
             "at location" newplace)
    (make-def (:name @object) (assoc @object :position newplace))
    (reset! hh (assoc @hh :position (top-location object))))
  (add-support object support)
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  REMOVE-SUPPORT

(defmulti remove-support
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod remove-support ::movable-block [object]
  (println "TRY REMOVE SUPPORT" (:name @object))
  (let [support (:supported-by @object)]
    (when support
      (println "remove support" (:name @object) (:name @support))
      (println  (map #(:name @%) (remove #(= % object) (:support-for @support))))
      (make-def (:name @support) (assoc @support :support-for (remove #(= % object) (:support-for @support))))
      (make-def (:name @object) (assoc @object :supported-by nil)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ADD-SUPPORT

(defmulti add-support
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod add-support[::movable-block ::basic-block] [object support]
  (println "A-Sup: basic")
  true)

(defmethod add-support [::movable-block ::load-bearing-block] [object support]
  (println "A-Sup: load bearing")
  (println "add support" (:name @object) (:name @support) (map #(:name @%) (:support-for @support)))
  (println (count (:support-for @support) ))
  (make-def (:name @support) (assoc @support :support-for (conj (:support-for @support) object)))
  (println (count (:support-for @support)))
  (make-def (:name @object) (assoc @object :supported-by support))
  true)

(prefer-method add-support [::movable-block ::load-bearing-block][::movable-block ::basic-block])

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  PUT-ON

(defmulti put-on
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod put-on [::movable-block ::basic-block] [object support]
  (print "P-O, " (:name @object) " - " (:name @support))
  (if (get-space object support)
    (and (grasp object)
       (move object support)
       (ungrasp object))
    (println "Sorry, there is no room for" (:name @object)
             "on" (:name @support))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def black "#000000")
(def yellow "#FFDB7F")
(def red "#E88E7F")
(def purple "#DA98FF")
(def blue "#88BAE8")
(def green "#7FFFA5")

(def canvas (.getElementById js/document "canvas"))
(def context (.getContext canvas "2d"))

(def width (atom 20))
(def height (atom 10))
(def cell-size 25)
(def world (atom {}))

(defn resized []
  (set! (.-width canvas) (* @width cell-size))
  (set! (.-height canvas) (* @height cell-size)))

(defn fill_sq [x y w h];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (.strokeRect context
               (* x cell-size)
               (* y cell-size)
               (* w cell-size)
               (* h cell-size)))

(defn fill_tri [x y w h];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (let [tx (* cell-size x)
        ty (* cell-size y)
        tw (* cell-size w)
        th (* cell-size h)]
    (.beginPath context)
    (.moveTo context tx ty)
    (.lineTo context (+ tx tw) ty)
    (.lineTo context (+ tx (/ tw 2)) (+ ty th))
    (.lineTo context tx ty)
    (.stroke context)))

(defn fill_circ [x y w];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (let [r (/ (* cell-size w) 2)
        tx (+ r (* cell-size x))
        ty (- (* cell-size y) r)]
    (.beginPath context)
    (.arc context tx ty r 0 (* Math/PI 2) true)
    (.stroke context)))

(defn fill_txt [x y str]
  (set! (.-fillStyle context) yellow)
  (set! (.-font context) "10px sans-serif")
  (.fillText context str (+ 15 (* cell-size x)) (- (* cell-size y) 5)))

(defn deg->rad [d]
  (* Math/PI (/ d 360)))

(set! (.-onresize js/window) resized)

(resized)

(defn blank []
  (set! (.-fillStyle context) black)
  (.fillRect context
             0
             0
             (* cell-size @width)
             (* cell-size @height)))

(defn draw []
  (blank)
  (doseq [[k v] block_map]
    (let [x (first (:position @v))
          y (- @height (last (:position @v)))
          w (:width @v)
          h (- (:height @v))]
      (cond
        (= (:type @v) ::brick)(fill_sq x y w h)
        (= (:type @v) ::wedge)(fill_tri x y w h)
        (= (:type @v) ::ball)(fill_circ x y w)
        :else
        (println "draw table")))
    (fill_txt (first (:position @v))
              (- @height (last (:position @v)))
              (:name @v))))

(draw)

(defn put [o s]
  (put-on (block_map o) (block_map s))
  (draw))

(ns clrdlhu.core
  (:require [clojure.browser.repl :as repl]
            [monet.canvas :as canvas]
            [cljs.core.logic :as m :refer [membero]]))

;; (repl/connect "http://localhost:9000/repl")

(enable-console-print!)

(defrecord block [name
                  type
                  width
                  height
                  position
                  supported-by
                  support-for])

(defrecord hand [name
                 position
                 grasping])

(def h (-> (make-hierarchy)
          (derive ::movable-block ::basic-block)
          (derive ::load-bearing-block ::basic-block)

          (derive ::brick ::movable-block)
          (derive ::brick ::load-bearing-block)

          (derive ::wedge ::movable-block)

          (derive ::ball ::movable-block)

          (derive ::table ::load-bearing-block)))

(defn make-def [k v]
  ;;(eval `(def ~(symbol k) ~v))
  (reset! (block_map k) v))

(defn reset-world []

  (def hh (atom (hand. "hand" '(0 6) nil)))

  (def block_map {"tt" (atom (block. "tt" ::table 20 0 '(0 0) nil '()))
                  "b1" (atom (block. "b1" ::brick 2  2 '(0 0) nil nil))
                  "b2" (atom (block. "b2" ::brick 2  2 '(2 0) nil nil))
                  "b3" (atom (block. "b3" ::brick 4  4 '(4 0) nil nil))
                  "b4" (atom (block. "b4" ::brick 2  2 '(8 0) nil nil))
                  "w5" (atom (block. "w5" ::wedge 2  4 '(10 0) nil nil))
                  "b6" (atom (block. "b6" ::brick 4  2 '(12 0) nil nil))
                  "w7" (atom (block. "w7" ::wedge 2  2 '(16 0) nil nil))
                  "lq" (atom (block. "lq" ::ball  2  2 '(18 0) nil nil))})

  (doseq [[k v] block_map
          :let [tt (block_map "tt")]]
    (if (not= v tt)
      (do
        (make-def "tt" (update-in @tt [:support-for] (fn [x y] (cons y x)) v))
        (make-def k (update-in @v [:supported-by] (fn [x y] y) tt))))))

(reset-world)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(declare top-location)
(declare intersections-p)
(declare find-space)
(declare get-space)
(declare grasp)
(declare ungrasp)
(declare get-ride-of)
(declare make-space)
(declare clear-top)
(declare move)
(declare remove-support)
(declare add-support)
(declare put-on)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn top-location [object]
  (let [pos (:position @object)
        posx (first pos)
        posy (fnext pos)
        w (:width @object)
        h (:height @object)]
    (list (+ posx  (/ w 2)) (+ posy h))))

(defn intersections-p [object offset base obstacles]
  (let [hit nil]
    (loop [obstacle obstacles
           hit nil]
      (if (or (empty? obstacle) (= true hit))
        hit
        (let [o (first obstacle)
              ls-proposed (+ offset base)
              rs-proposed (+ ls-proposed (:width @object))
              ls-obstacle (first (:position @o))
              rs-obstacle (+ ls-obstacle (:width @o))]
          (if (or (>= ls-proposed rs-obstacle)
                 (<= rs-proposed ls-obstacle))
            (recur (next obstacle) hit)
            (recur (next obstacle) true)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  FIND-SPACE

(defn find-space [object support]
  (println "F-Spc, " (:name @object) " - " (:name @support))
  (loop [curr-offset 0
         max-offset (+ 1 (- (:width @support)
                            (:width @object)))
         hit nil]
    (cond (or (= curr-offset max-offset) (not= nil hit)) hit
          :else (if (not (intersections-p object curr-offset
                                        (first (:position @support))
                                        (:support-for @support)))
                  (recur (+ 1 curr-offset) max-offset (list (+ curr-offset (first (:position @support)))
                                                            (+ (second (:position @support))
                                                               (:height @support))))
                  (recur (+ 1 curr-offset) max-offset hit)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GET-SPACE

(defmulti get-space
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod get-space [::movable-block ::basic-block] [object support]
  (println "G-Spc, " (:name @object) " - " (:name @support))
  ;;(println " --- > "(find-space object support))
  (or (find-space object support)
     (make-space object support)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GRASP

(defmulti grasp
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod grasp ::movable-block [object]
  (println "TRY GRASP")
  (when-not (= (:grasping @hh) object)
    (when (:support-for @object) (clear-top object))
    (when (:grasping @hh)
      (get-ride-of (:grasping @hh)))
    (println "Move hand to pick up "
             (:name @object)
             " at location "
             (top-location object))

    (reset! hh (assoc @hh :position (top-location object)))
    (println "Grasp " (:name @object))
    (reset! hh (assoc @hh :grasping object)))
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  UNGRASP

(defmulti ungrasp
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod ungrasp ::movable-block [object]
  (println "Try Ungrasp " (:name @object))
  (when (:supported-by @object)
    (println "Ungrasp " (:name @object))
    ;;(def hh (assoc hh :grasping nil))
    (reset! hh (assoc @hh :grasping nil))
    true))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  GET_RIDE-OF

(defmulti get-ride-of
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod get-ride-of ::movable-block [object]
  (println "TRY GET-RID-OF")
  (put-on object (block_map "tt")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MAKE-SPACE

(defmulti make-space
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod make-space [::movable-block ::basic-block] [object support]
  (println "TRY MAKE-SPACE")
  (loop [obstruction (:support-for support)
         hit nil]
    (cond (or (not= nil hit)(empty? obstruction)) hit
          :else (do
                  (get-ride-of (first obstruction))
                  (let [space (find-space object support)]
                    (if space
                      (recur (next obstruction) space)
                      (recur (next obstruction) hit)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  CLEAR-TOP

(defmulti clear-top
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod clear-top ::load-bearing-block [support]
  (println "TRY CLEAR-TOP" (count (:support-for @support)))
  (doseq [obstacle (:support-for @support)]
    (get-ride-of obstacle))
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  MOVE

(defmulti move
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod move [::movable-block ::basic-block] [object support]
  (println "TRY MOVE" (:name @object))
  (remove-support object)
  (make-def (:name @object) (assoc @object :position '(3000 3000)))
  (let [newplace (get-space object support)]
    (println "Move" (:name @object)
             "to top of" (:name @support)
             "at location" newplace)
    (make-def (:name @object) (assoc @object :position newplace))
    (reset! hh (assoc @hh :position (top-location object))))
  (add-support object support)
  true)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  REMOVE-SUPPORT

(defmulti remove-support
  (fn [b] (:type @b))
  :hierarchy #'h)

(defmethod remove-support ::movable-block [object]
  (println "TRY REMOVE SUPPORT" (:name @object))
  (let [support (:supported-by @object)]
    (when support
      (println "remove support" (:name @object) (:name @support))
      (println  (map #(:name @%) (remove #(= % object) (:support-for @support))))
      (make-def (:name @support) (assoc @support :support-for (remove #(= % object) (:support-for @support))))
      (make-def (:name @object) (assoc @object :supported-by nil)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  ADD-SUPPORT

(defmulti add-support
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod add-support[::movable-block ::basic-block] [object support]
  (println "A-Sup: basic")
  true)

(defmethod add-support [::movable-block ::load-bearing-block] [object support]
  (println "A-Sup: load bearing")
  (println "add support" (:name @object) (:name @support) (map #(:name @%) (:support-for @support)))
  (println (count (:support-for @support) ))
  (make-def (:name @support) (assoc @support :support-for (conj (:support-for @support) object)))
  (println (count (:support-for @support)))
  (make-def (:name @object) (assoc @object :supported-by support))
  true)

(prefer-method add-support [::movable-block ::load-bearing-block][::movable-block ::basic-block])

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;  PUT-ON

(defmulti put-on
  (fn [b1 b2] [(:type @b1) (:type @b2)])
  :hierarchy #'h)

(defmethod put-on [::movable-block ::basic-block] [object support]
  (print "P-O, " (:name @object) " - " (:name @support))
  (if (get-space object support)
    (and (grasp object)
       (move object support)
       (ungrasp object))
    (println "Sorry, there is no room for" (:name @object)
             "on" (:name @support))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(def black "#000000")
(def yellow "#FFDB7F")
(def red "#E88E7F")
(def purple "#DA98FF")
(def blue "#88BAE8")
(def green "#7FFFA5")

(def canvas (.getElementById js/document "canvas"))
(def context (.getContext canvas "2d"))

(def width (atom 20))
(def height (atom 10))
(def cell-size 25)
(def world (atom {}))

(defn resized []
  (set! (.-width canvas) (* @width cell-size))
  (set! (.-height canvas) (* @height cell-size)))

(defn fill_sq [x y w h];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (.strokeRect context
               (* x cell-size)
               (* y cell-size)
               (* w cell-size)
               (* h cell-size)))

(defn fill_tri [x y w h];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (let [tx (* cell-size x)
        ty (* cell-size y)
        tw (* cell-size w)
        th (* cell-size h)]
    (.beginPath context)
    (.moveTo context tx ty)
    (.lineTo context (+ tx tw) ty)
    (.lineTo context (+ tx (/ tw 2)) (+ ty th))
    (.lineTo context tx ty)
    (.stroke context)))

(defn fill_circ [x y w];; colour]
  (set! (.-fillStyle context) red)
  (set! (.-strokeStyle context) yellow)
  (let [r (/ (* cell-size w) 2)
        tx (+ r (* cell-size x))
        ty (- (* cell-size y) r)]
    (.beginPath context)
    (.arc context tx ty r 0 (* Math/PI 2) true)
    (.stroke context)))

(defn fill_txt [x y str]
  (set! (.-fillStyle context) yellow)
  (set! (.-font context) "10px sans-serif")
  (.fillText context str (+ 15 (* cell-size x)) (- (* cell-size y) 5)))

(defn deg->rad [d]
  (* Math/PI (/ d 360)))

(set! (.-onresize js/window) resized)

(resized)

(defn blank []
  (set! (.-fillStyle context) black)
  (.fillRect context
             0
             0
             (* cell-size @width)
             (* cell-size @height)))

(defn draw []
  (blank)
  (doseq [[k v] block_map]
    (let [x (first (:position @v))
          y (- @height (last (:position @v)))
          w (:width @v)
          h (- (:height @v))]
      (cond
        (= (:type @v) ::brick)(fill_sq x y w h)
        (= (:type @v) ::wedge)(fill_tri x y w h)
        (= (:type @v) ::ball)(fill_circ x y w)
        :else
        (println "draw table")))
    (fill_txt (first (:position @v))
              (- @height (last (:position @v)))
              (:name @v))))

(draw)

(defn put [o s]
  (put-on (block_map o) (block_map s))
  (draw))

complete remove extraneous comments

complete remove extraneous comments


;; Copyright 2014 Red Hat, Inc, and individual contributors.
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;; http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

(ns immutant.codecs
  "Common codecs used when [de]serializing data structures."
  (:require [clojure.tools.reader.edn :as edn]
            [clojure.tools.reader     :as r]
            [immutant.internal.util   :as u])
  (:import [org.projectodd.wunderboss.codecs BytesCodec Codec Codecs None StringCodec]
           java.nio.ByteBuffer))

(defmacro data-readers []
  (if (resolve 'clojure.core/*data-readers*)
    '(merge *data-readers* r/*data-readers*)
    'r/*data-readers*))

(defmacro make-codec
  "Creates a codec instance for the given settings.

   Takes the following settings, most of which are required:

   * :name - The nickname for the codec. Can be a String or Keyword.
   * :content-type - The content type for the codec as a String.
   * :type - The type of data the codec encodes to/decodes from.
     Can be either :bytes or :string, and is optional, defaulting to
     :string.
   * :encode - A single-arity function that encodes its argument to
     the expected type.
   * :encode - A single-arity function that decodes its argument from
     the expected type to clojure data."
  [{:keys [name content-type type encode decode] :or {type :string}}]
  `(proxy [~(if (= :bytes type) 'BytesCodec 'StringCodec)]
       [~(clojure.core/name name) ~content-type]
     (encode [data#]
       (~encode data#))
     (decode [data#]
       (~decode data#))))

(defonce ^:internal ^Codecs codecs
  (-> (Codecs.)
    (.add None/INSTANCE)))

(defn register-codec!
  "Registers a codec for use.

   `codec` should be the result of {{make-codec}}."
  [codec]
  (.add codecs codec))

(register-codec!
  (make-codec
    {:name :edn
     :content-type "application/edn"
     :encode pr-str
     :decode (fn [data]
               (try
                 (and data (edn/read-string {:readers (data-readers)} data))
                 (catch Throwable e
                   (throw (RuntimeException.
                            (str "Invalid edn-encoded data (type=" (class data) "): " data)
                            e)))))}))

(register-codec!
  (make-codec
    {:name :fressian
     :content-type "application/fressian"
     :type :bytes
     :encode (fn [data]
               (if-let [write (u/try-resolve 'clojure.data.fressian/write)]
                 (let [^ByteBuffer encoded (write data :footer? true)
                       bytes (byte-array (.remaining encoded))]
                   (.get encoded bytes)
                   bytes)
                 (throw (IllegalArgumentException.
                          "Can't encode fressian. Add org.clojure/data.fressian to your dependencies."))))
     :decode (fn [data]
               (if-let [read (u/try-resolve 'clojure.data.fressian/read)]
                 (try
                   (and data (read data))
                   (catch Throwable e
                     (throw (RuntimeException.
                              (str "Invalid fressian-encoded data (type=" (class data) "): " data)
                              e))))
                 (throw (IllegalArgumentException.
                          "Can't decode fressian. Add org.clojure/data.fressian to your dependencies."))))}))

(register-codec!
  (make-codec
    {:name :json
     :content-type "application/json"
     :encode (fn [data]
               (if-let [generate-string (u/try-resolve 'cheshire.core/generate-string)]
                 (generate-string data)
                 (throw (IllegalArgumentException. "Can't encode json. Add cheshire to your dependencies."))))
     :decode (fn [data]
               (if-let [parse-string (u/try-resolve 'cheshire.core/parse-string)]
                 (try
                   (and data (parse-string data true))
                   (catch Throwable e
                     (throw (RuntimeException.
                              (str "Invalid json-encoded data (type=" (class data) "): " data)
                              e))))
                 (throw (IllegalArgumentException. "Can't decode json. Add cheshire to your dependencies."))))}))

(defn codec-set
  "Returns a set of names for available codecs."
  []
  (into #{} (map #(-> % .name keyword) (.codecs codecs))))

(defn ^Codec lookup-codec
  [name-or-content-type]
  (if-let [codec (.forName codecs (name name-or-content-type))]
    codec
    (if-let [codec (.forContentType codecs (name name-or-content-type))]
      codec
      (throw (IllegalArgumentException.
               (str "Can't find codec for: " name-or-content-type))))))

(defn encode
  "Encodes `data` using the codec for `encoding`.

   `encoding` can be the name of the encoding or its
   content-type. `encoding` defaults to :edn."
  ([data]
     (encode data :edn))
  ([data encoding]
     (.encode (lookup-codec encoding) data)))

(defn decode
  "Decodes `data` using the codec for `encoding`.

   `encoding` can be the name of the encoding or its
   content-type. `encoding` defaults to :edn."
  ([data]
     (decode data :edn))
  ([data encoding]
     (.decode (lookup-codec encoding) data)))

;; Copyright 2014 Red Hat, Inc, and individual contributors.
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;; http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

(ns immutant.codecs
  "Common codecs used when [de]serializing data structures."
  (:require [clojure.tools.reader.edn :as edn]
            [clojure.tools.reader     :as r]
            [immutant.internal.util   :as u])
  (:import [org.projectodd.wunderboss.codecs BytesCodec Codec Codecs None StringCodec]
           java.nio.ByteBuffer))

(defmacro ^:internal ^:no-doc data-readers []
  (if (resolve 'clojure.core/*data-readers*)
    '(merge *data-readers* r/*data-readers*)
    'r/*data-readers*))

(defmacro make-codec
  "Creates a codec instance for the given settings.

   Takes the following settings, most of which are required:

   * :name - The nickname for the codec. Can be a String or Keyword.
   * :content-type - The content type for the codec as a String.
   * :type - The type of data the codec encodes to/decodes from.
     Can be either :bytes or :string, and is optional, defaulting to
     :string.
   * :encode - A single-arity function that encodes its argument to
     the expected type.
   * :encode - A single-arity function that decodes its argument from
     the expected type to clojure data."
  [{:keys [name content-type type encode decode] :or {type :string}}]
  `(proxy [~(if (= :bytes type) 'BytesCodec 'StringCodec)]
       [~(clojure.core/name name) ~content-type]
     (encode [data#]
       (~encode data#))
     (decode [data#]
       (~decode data#))))

(defonce ^:internal ^:no-doc ^Codecs codecs
  (-> (Codecs.)
    (.add None/INSTANCE)))

(defn register-codec!
  "Registers a codec for use.

   `codec` should be the result of {{make-codec}}."
  [codec]
  (.add codecs codec))

(register-codec!
  (make-codec
    {:name :edn
     :content-type "application/edn"
     :encode pr-str
     :decode (fn [data]
               (try
                 (and data (edn/read-string {:readers (data-readers)} data))
                 (catch Throwable e
                   (throw (RuntimeException.
                            (str "Invalid edn-encoded data (type=" (class data) "): " data)
                            e)))))}))

(register-codec!
  (make-codec
    {:name :fressian
     :content-type "application/fressian"
     :type :bytes
     :encode (fn [data]
               (if-let [write (u/try-resolve 'clojure.data.fressian/write)]
                 (let [^ByteBuffer encoded (write data :footer? true)
                       bytes (byte-array (.remaining encoded))]
                   (.get encoded bytes)
                   bytes)
                 (throw (IllegalArgumentException.
                          "Can't encode fressian. Add org.clojure/data.fressian to your dependencies."))))
     :decode (fn [data]
               (if-let [read (u/try-resolve 'clojure.data.fressian/read)]
                 (try
                   (and data (read data))
                   (catch Throwable e
                     (throw (RuntimeException.
                              (str "Invalid fressian-encoded data (type=" (class data) "): " data)
                              e))))
                 (throw (IllegalArgumentException.
                          "Can't decode fressian. Add org.clojure/data.fressian to your dependencies."))))}))

(register-codec!
  (make-codec
    {:name :json
     :content-type "application/json"
     :encode (fn [data]
               (if-let [generate-string (u/try-resolve 'cheshire.core/generate-string)]
                 (generate-string data)
                 (throw (IllegalArgumentException. "Can't encode json. Add cheshire to your dependencies."))))
     :decode (fn [data]
               (if-let [parse-string (u/try-resolve 'cheshire.core/parse-string)]
                 (try
                   (and data (parse-string data true))
                   (catch Throwable e
                     (throw (RuntimeException.
                              (str "Invalid json-encoded data (type=" (class data) "): " data)
                              e))))
                 (throw (IllegalArgumentException. "Can't decode json. Add cheshire to your dependencies."))))}))

(defn codec-set
  "Returns a set of names for available codecs."
  []
  (into #{} (map #(-> % .name keyword) (.codecs codecs))))

(defn ^:internal ^:no-doc ^Codec lookup-codec
  [name-or-content-type]
  (if-let [codec (.forName codecs (name name-or-content-type))]
    codec
    (if-let [codec (.forContentType codecs (name name-or-content-type))]
      codec
      (throw (IllegalArgumentException.
               (str "Can't find codec for: " name-or-content-type))))))

(defn encode
  "Encodes `data` using the codec for `encoding`.

   `encoding` can be the name of the encoding or its
   content-type. `encoding` defaults to :edn."
  ([data]
     (encode data :edn))
  ([data encoding]
     (.encode (lookup-codec encoding) data)))

(defn decode
  "Decodes `data` using the codec for `encoding`.

   `encoding` can be the name of the encoding or its
   content-type. `encoding` defaults to :edn."
  ([data]
     (decode data :edn))
  ([data encoding]
     (.decode (lookup-codec encoding) data)))

Hide internal codec functions from apidocs.


(defproject uxbox "0.1.0-SNAPSHOT"
  :description "UXBox UI"
  :url "http://uxbox.github.io"
  :license {:name "MPL 2.0" :url "https://www.mozilla.org/en-US/MPL/2.0/"}
  :jvm-opts ["-Dclojure.compiler.direct-linking=true"]

  :source-paths ["src" "vendor"]
  :test-paths ["test"]

  :profiles {:dev {:source-paths ["dev"]}}

  :dependencies [[org.clojure/clojure "1.9.0-alpha14" :scope "provided"]
                 [org.clojure/clojurescript "1.9.293" :scope "provided"]

                 ;; Build
                 [figwheel-sidecar "0.5.8" :scope "test"]

                 ;; runtime
                 [com.cognitect/transit-cljs "0.8.239"]
                 [rum "0.10.7"]
                 [cljsjs/react "15.4.0-0"]
                 [cljsjs/react-dom "15.4.0-0"]
                 [cljsjs/react-dom-server "15.4.0-0"]
                 [cljsjs/moment "2.15.2-3"]
                 [funcool/potok "1.1.0"]
                 [funcool/struct "1.0.0"]
                 [funcool/lentes "1.2.0"]
                 [funcool/beicon "2.8.0"]
                 [funcool/cuerdas "2.0.1"]
                 [funcool/bide "1.2.1"]]
  :plugins [[lein-ancient "0.6.10"]]
  :clean-targets ^{:protect false} ["resources/public/js" "target"]
  )

(defproject uxbox "0.1.0-SNAPSHOT"
  :description "UXBox UI"
  :url "http://uxbox.github.io"
  :license {:name "MPL 2.0" :url "https://www.mozilla.org/en-US/MPL/2.0/"}
  :jvm-opts ["-Dclojure.compiler.direct-linking=true"]

  :source-paths ["src" "vendor"]
  :test-paths ["test"]

  :profiles {:dev {:source-paths ["dev"]}}

  :dependencies [[org.clojure/clojure "1.9.0-alpha14" :scope "provided"]
                 [org.clojure/clojurescript "1.9.293" :scope "provided"]

                 ;; Build
                 [figwheel-sidecar "0.5.8" :scope "test"]

                 ;; runtime
                 [com.cognitect/transit-cljs "0.8.239"]
                 [rum "0.10.7"]
                 [cljsjs/react "15.4.0-0"]
                 [cljsjs/react-dom "15.4.0-0"]
                 [cljsjs/react-dom-server "15.4.0-0"]
                 [cljsjs/moment "2.15.2-3"]
                 [funcool/potok "1.1.0"]
                 [funcool/struct "1.0.0"]
                 [funcool/lentes "1.2.0"]
                 [funcool/beicon "2.8.0"]
                 [funcool/cuerdas "2.0.2"]
                 [funcool/bide "1.2.2"]]
  :plugins [[lein-ancient "0.6.10"]]
  :clean-targets ^{:protect false} ["resources/public/js" "target"]
  )

Update dependencies.

Update dependencies.


(ns s7p.slave.core-test
  (:require [clojure.test :refer :all]
            [s7p.slave.core :refer :all]))

(def dsp1 {:id        "1"
          :url       "http://example.com/api"
          :winnotice "http://example.com/winnotice"})

(def dsp2 {:id        "2"
          :url       "http://example.com/api"
           :winnotice "http://example.com/winnotice"})

(def dsp3 {:id        "3"
          :url       "http://example.com/api"
          :winnotice "http://example.com/winnotice"})

(deftest validate-test
  (let [req1 {:id "1" :floorPrice 3.0 :site "http://test.org/" :device "Ubuntu Touch" :user "user1" :test 0}
        req2 {:id "1" :floorPrice nil :site "http://test.org/" :device "Ubuntu Touch" :user "user1" :test 0}]
   (testing "`validate`"
     (testing "204 no bid"
       (let [ret (validate req1 {:dsp dsp1 :status 204 :body ""})]
         (is (= :no-bid (:status ret)))))

     (testing "invalid response status"
       (let [ret (validate req1 {:dsp dsp1 :status 201 :body ""})]
         (is (= :invalid (:status ret)))))

     (testing "empty response"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body ""})]
         (is (= :invalid (:status ret)))))

     (testing "invalid json string"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{"})]
         (is (= :invalid (:status ret)))))

     (testing "valid response"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :valid (:status ret)))))

     (testing "valid response2"
       (let [ret (validate req2 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :valid (:status ret)))))

     (testing "no id"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "under floor"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 1000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "no bidPrice"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "no advertiserId"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0}"})]
         (is (= :invalid (:status ret)))))

     (testing "non maching id"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"2\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret))))))))

(deftest auction-test
  (testing "`auction`"
    (testing "no valid response"
      (let [fp 4.0
            arg []
            ret (auction fp arg)]
       (is (nil? ret))))

    (testing "one valid response with fp, and bidPrice is over the fp"
      (let [fp 4.0
            bid-price 4100.0
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price :advertiserId "2"}}]
            ret (auction fp arg)]
       (is ret)
       (is (= dsp1 (:dsp ret)))
       (is (= fp   (:win-price ret)))))

    (testing "one valid response without fp"
      (let [fp nil
            bid-price 4000.0
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price :advertiserId "2"}}]
            ret (auction fp arg)]
       (is ret)
       (is (= dsp1 (:dsp ret)))
       (is (= (/ bid-price 1000) (:win-price ret)))))

    (testing "more than 1 valid response"
      (let [fp 4.0
            bid-price1 4100
            bid-price2 4200
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}
                 {:dsp dsp2 :response {:id "1", :bidPrice bid-price2 :advertiserId "2"}}]
            ret (auction fp arg)]
        (is ret)
        (is (= dsp2 (:dsp ret)))
        (is (= (float (/ bid-price1 1000)) (:win-price ret)))))

    (testing "more than 1 valid response with same bid price"
      (let [fp 4.0
            bid-price1 4100
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}
                 {:dsp dsp2 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}]
            ret (auction fp arg)]
        (is ret)
        (is (= (float (/ bid-price1 1000)) (:win-price ret)))))))

(ns s7p.slave.core-test
  (:require [clojure.test :refer :all]
            [s7p.slave.core :refer :all]))

(def dsp1 {:id        "1"
          :url       "http://example.com/api"
          :winnotice "http://example.com/winnotice"})

(def dsp2 {:id        "2"
          :url       "http://example.com/api"
           :winnotice "http://example.com/winnotice"})

(def dsp3 {:id        "3"
          :url       "http://example.com/api"
          :winnotice "http://example.com/winnotice"})

(deftest validate-test
  (let [req1 {:id "1" :floorPrice 3000.0 :site "http://test.org/" :device "Ubuntu Touch" :user "user1" :test 0}
        req2 {:id "1" :floorPrice nil :site "http://test.org/" :device "Ubuntu Touch" :user "user1" :test 0}]
   (testing "`validate`"
     (testing "204 no bid"
       (let [ret (validate req1 {:dsp dsp1 :status 204 :body ""})]
         (is (= :no-bid (:status ret)))))

     (testing "invalid response status"
       (let [ret (validate req1 {:dsp dsp1 :status 201 :body ""})]
         (is (= :invalid (:status ret)))))

     (testing "empty response"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body ""})]
         (is (= :invalid (:status ret)))))

     (testing "invalid json string"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{"})]
         (is (= :invalid (:status ret)))))

     (testing "valid response"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :valid (:status ret)))))

     (testing "valid response2"
       (let [ret (validate req2 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :valid (:status ret)))))

     (testing "no id"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "under floor"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 1000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "no bidPrice"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret)))))

     (testing "no advertiserId"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"1\", \"bidPrice\": 4000.0}"})]
         (is (= :invalid (:status ret)))))

     (testing "non maching id"
       (let [ret (validate req1 {:dsp dsp1 :status 200 :body "{\"id\": \"2\", \"bidPrice\": 4000.0, \"advertiserId\": \"1\"}"})]
         (is (= :invalid (:status ret))))))))

(deftest auction-test
  (testing "`auction`"
    (testing "no valid response"
      (let [fp 4000.0
            arg []
            ret (auction fp arg)]
       (is (nil? ret))))

    (testing "one valid response with fp, and bidPrice is over the fp"
      (let [fp 4000.0
            bid-price 4100.0
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price :advertiserId "2"}}]
            ret (auction fp arg)]
       (is ret)
       (is (= dsp1 (:dsp ret)))
       (is (= (float (/ fp 1000))   (:win-price ret)))))

    (testing "one valid response without fp"
      (let [fp nil
            bid-price 4000.0
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price :advertiserId "2"}}]
            ret (auction fp arg)]
       (is ret)
       (is (= dsp1 (:dsp ret)))
       (is (= (/ bid-price 1000) (:win-price ret)))))

    (testing "more than 1 valid response"
      (let [fp 4000.0
            bid-price1 4100
            bid-price2 4200
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}
                 {:dsp dsp2 :response {:id "1", :bidPrice bid-price2 :advertiserId "2"}}]
            ret (auction fp arg)]
        (is ret)
        (is (= dsp2 (:dsp ret)))
        (is (= (float (/ bid-price1 1000)) (:win-price ret)))))

    (testing "more than 1 valid response with same bid price"
      (let [fp 4000.0
            bid-price1 4100
            arg [{:dsp dsp1 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}
                 {:dsp dsp2 :response {:id "1", :bidPrice bid-price1 :advertiserId "2"}}]
            ret (auction fp arg)]
        (is ret)
        (is (= (float (/ bid-price1 1000)) (:win-price ret)))))))

fix tests according to specification

fix tests according to specification


(ns obb-demo.views.player
  (:require [obb-demo.state :as state]
            [obb-rules.game :as game]
            [obb-rules.element :as element]
            [obb-rules.actions.move :as move]
            [obb-rules.stash :as stash]
            [obb-rules.host-dependent :as host]
            [obb-demo.processor :as processor]
            [obb-demo.views.power-bar :as power-bar]
            [obb-rules.ai.firingsquad :as firingsquad]
            [obb-rules.math :as math]
            [obb-rules.game-mode :as game-mode]
            [obb-rules.laws :as laws]
            [obb-rules.evaluator :as evaluator]
            [obb-rules.turn :as turn]
            [obb-rules.result :as result]
            [obb-demo.boardground :as boardground]))

(defn- get-game-data
  "Gets the current game or creates a new one"
  [state]
  (if-let [game (:player state)]
    game
    (let [game (-> (processor/deployed-game)
                   (game/state :p1))
          game-data {:game game
                     :original-game game
                     :action-points 0
                     :turn-num 0}]
      (state/set-page-data! game-data)
      game-data)))

(defn- restart-game
  "Generates and restarts a new game"
  []
  (state/set-page-data! nil))

(defn- selected-player
  "Shows the player"
  [current-player expected]

  (if (= current-player expected)
    (if (= :p1 current-player)
      :span.label.label-success
      :span.label.label-info)
  :span.label.label-primary))

(defn- players
  "Displays the players and the current to play"
  [game]
  (let [player (game/state game)]
    [:div
      [(selected-player player :p2) "Firingsquad"]
      " vs "
      [(selected-player player :p1) "Player 1"]]))

(defn- game-turn
  "Displays the current turn"
  [game-data]
  [:ul.nav.nav-pills {:style {:margin-bottom "10px"}}
   [:li
    [:a "Turn "
     [:span.badge (:turn-num game-data)]]]])

(defn- action-points
  "Displays the current turn"
  [game-data]
  [:ul.nav.nav-pills {:style {:margin-bottom "10px"}}
   [:li
    [:a "Action Points "
     [:span.badge (- laws/max-action-points (:action-points game-data))]]]])

(defn- rotate-selected
  "Rotates the selected element"
  [game-data direction]
  (let [game (:game game-data)
        selected-coord (:selected-coord game-data)
        player (element/element-player (:selected-element game-data))
        action [:rotate selected-coord direction]]
    (boardground/register-action game-data game player action selected-coord)))

(defn- reset-turn
  "Resets the actions on the current turn"
  [game-data]
  (state/set-page-data! {:game (dissoc (:original-game game-data) :action-results)
                         :original-game (:original-game game-data)
                         :previous-game (:original-game game-data)
                         :previous-player :p2
                         :action-points 0
                         :turn-num 0}))

(defn- play-turn
  "Resets the actions on the current turn"
  [game-data]
  (let [player :p1
        game (-> (:game game-data)
                 (game-mode/process)
                 (dissoc :action-results))
        turn-num (:turn-num game-data)
        actions (firingsquad/actions game :p2)
        result (turn/process-actions game :p2 actions)]
    (println actions)
    (if (result/succeeded? result)
      (let [new-game (result/result-board result)
            clean-game (dissoc new-game :action-results)]
        (state/set-page-data! {:game clean-game
                               :original-game new-game
                               :previous-game new-game
                               :previous-player :p2
                               :action-points 0
                               :turn-num (+ 1 turn-num)}))
        (println result))))

(defn- rotate-button
  "Rotate button display"
  [game-data direction]
  [:button.btn.btn-default {:disabled (not (:selected-element game-data))
                            :on-click (partial rotate-selected game-data direction)}
   (str "Rotate " direction)])

(defn- selected-element-quantity
  "Gets the quantity of the selected element, or 0 it no element is
  selected"
  [game-data]
  (if-let [element (:selected-element game-data)]
    (element/element-quantity element)
    0))

(defn- parse-ev-quantity
  "Parses the quantity on the given event"
  [ev]
  (let [raw-quantity (-> ev .-target .-value)]
    (if (empty? raw-quantity)
      "0"
      raw-quantity)))

(defn- quantity-changed
  "Runs when the quantity changes"
  [game-data ev]
  (let [total-quantity (element/element-quantity (:selected-element game-data))
        quantity (parse-ev-quantity ev)]
    (if (move/invalid-move-percentage? total-quantity quantity)
      (state/set-page-data! (-> (assoc game-data :selected-quantity-error true)
                                (assoc :selected-quantity quantity)))
      (state/set-page-data! (-> (assoc game-data :selected-quantity quantity)
                                (dissoc :selected-quantity-error))))))

(defn- unit-quantity-picker
  "Specifies the units to move"
  [game-data]
  (let [quantity (:selected-quantity game-data)
        invalid-quantity? (:selected-quantity-error game-data)]
     [:div.panel.panel-default
      [:div.panel-heading
       [:h3.panel-title "Move quantity"]]
      [:div.panel-body
       [(keyword (str "div.form-group" (if invalid-quantity? ".has-error" ".has-success")))
         [:input.form-control {:on-change (partial quantity-changed game-data)
                               :disabled (nil? quantity)
                               :type "text"
                               :value quantity}]
         (when invalid-quantity?
           (let [total-quantity (element/element-quantity (:selected-element game-data))
                 min-quantity (math/ceil (* total-quantity laws/min-move-percentage))
                 max-quantity (math/floor (* total-quantity laws/max-move-percentage))]
            [:p (str "Move must be " min-quantity " to " max-quantity " or " total-quantity)]))]
       ]]
    ))

(defn render
  [state]
  (let [game-data (get-game-data state)
        game (:game game-data)]
    [:div.row
      [:div.col-lg-2
       (game-turn game-data)
       (players game)
       (power-bar/render game)
       (action-points game-data)
       [:button.btn.btn-primary {:on-click (partial play-turn game-data)} "Play turn"]
       (unit-quantity-picker game-data)
       (rotate-button game-data :west)
       (rotate-button game-data :east)
       (rotate-button game-data :north)
       (rotate-button game-data :south)
       [:button.btn.btn-default {:on-click (partial reset-turn game-data)} "Reset turn"]]
      [:div.col-lg-5
        [boardground/render {} game-data]]]))

(ns obb-demo.views.player
  (:require [obb-demo.state :as state]
            [obb-rules.game :as game]
            [obb-rules.element :as element]
            [obb-rules.actions.move :as move]
            [obb-rules.stash :as stash]
            [obb-rules.host-dependent :as host]
            [obb-demo.processor :as processor]
            [obb-demo.views.power-bar :as power-bar]
            [obb-rules.ai.firingsquad :as firingsquad]
            [obb-rules.math :as math]
            [obb-rules.game-mode :as game-mode]
            [obb-rules.laws :as laws]
            [obb-rules.evaluator :as evaluator]
            [obb-rules.turn :as turn]
            [obb-rules.result :as result]
            [obb-demo.boardground :as boardground]))

(defn- get-game-data
  "Gets the current game or creates a new one"
  [state]
  (if-let [game (:player state)]
    game
    (let [game (-> (processor/deployed-game)
                   (game/state :p1))
          game-data {:game game
                     :original-game game
                     :action-points 0
                     :turn-num 0}]
      (state/set-page-data! game-data)
      game-data)))

(defn- restart-game
  "Generates and restarts a new game"
  []
  (state/set-page-data! nil))

(defn- selected-player
  "Shows the player"
  [current-player expected]

  (if (= current-player expected)
    (if (= :p1 current-player)
      :span.label.label-success
      :span.label.label-info)
  :span.label.label-primary))

(defn- players
  "Displays the players and the current to play"
  [game]
  (let [player (game/state game)]
    [:div
      [(selected-player player :p2) "Firingsquad"]
      " vs "
      [(selected-player player :p1) "Player 1"]]))

(defn- game-turn
  "Displays the current turn"
  [game-data]
  [:ul.nav.nav-pills {:style {:margin-bottom "10px"}}
   [:li
    [:a "Turn "
     [:span.badge (:turn-num game-data)]]]])

(defn- action-points
  "Displays the current turn"
  [game-data]
  [:ul.nav.nav-pills {:style {:margin-bottom "10px"}}
   [:li
    [:a "Action Points "
     [:span.badge (- laws/max-action-points (:action-points game-data))]]]])

(defn- rotate-selected
  "Rotates the selected element"
  [game-data direction]
  (let [game (:game game-data)
        selected-coord (:selected-coord game-data)
        player (element/element-player (:selected-element game-data))
        action [:rotate selected-coord direction]]
    (boardground/register-action game-data game player action selected-coord)))

(defn- reset-turn
  "Resets the actions on the current turn"
  [game-data]
  (state/set-page-data! {:game (dissoc (:original-game game-data) :action-results)
                         :original-game (:original-game game-data)
                         :previous-game (:original-game game-data)
                         :previous-player :p2
                         :action-points 0
                         :turn-num 0}))

(defn- play-turn
  "Resets the actions on the current turn"
  [game-data]
  (let [player :p1
        game (-> (:game game-data)
                 (game-mode/process)
                 (dissoc :action-results))
        turn-num (:turn-num game-data)
        actions (firingsquad/actions game :p2)
        result (turn/process-actions game :p2 actions)]
    (println actions)
    (if (result/succeeded? result)
      (let [new-game (result/result-board result)
            clean-game (dissoc new-game :action-results)]
        (state/set-page-data! {:game clean-game
                               :original-game new-game
                               :previous-game new-game
                               :previous-player :p2
                               :action-points 0
                               :turn-num (+ 1 turn-num)}))
        (println result))))

(defn- rotate-button
  "Rotate button display"
  [game-data direction]
  [:button.btn.btn-default {:disabled (not (:selected-element game-data))
                            :on-click (partial rotate-selected game-data direction)}
   (nth (name direction) 0)])

(defn- selected-element-quantity
  "Gets the quantity of the selected element, or 0 it no element is
  selected"
  [game-data]
  (if-let [element (:selected-element game-data)]
    (element/element-quantity element)
    0))

(defn- parse-ev-quantity
  "Parses the quantity on the given event"
  [ev]
  (let [raw-quantity (-> ev .-target .-value)]
    (if (empty? raw-quantity)
      "0"
      raw-quantity)))

(defn- quantity-changed
  "Runs when the quantity changes"
  [game-data ev]
  (let [total-quantity (element/element-quantity (:selected-element game-data))
        quantity (parse-ev-quantity ev)]
    (if (move/invalid-move-percentage? total-quantity quantity)
      (state/set-page-data! (-> (assoc game-data :selected-quantity-error true)
                                (assoc :selected-quantity quantity)))
      (state/set-page-data! (-> (assoc game-data :selected-quantity quantity)
                                (dissoc :selected-quantity-error))))))

(defn- rotate-panel
  "Rotate options"
  [game-data]
     [:div.panel.panel-default
      [:div.panel-heading
       [:h3.panel-title "Rotate"]]
      [:div.panel-body
       (rotate-button game-data :west)
       (rotate-button game-data :east)
       (rotate-button game-data :north)
       (rotate-button game-data :south)
       ]]
  )

(defn- unit-quantity-picker
  "Specifies the units to move"
  [game-data]
  (let [quantity (:selected-quantity game-data)
        invalid-quantity? (:selected-quantity-error game-data)]
     [:div.panel.panel-default
      [:div.panel-heading
       [:h3.panel-title "Move quantity"]]
      [:div.panel-body
       [(keyword (str "div.form-group" (if invalid-quantity? ".has-error" ".has-success")))
         [:input.form-control {:on-change (partial quantity-changed game-data)
                               :disabled (nil? quantity)
                               :type "text"
                               :value quantity}]
         (when invalid-quantity?
           (let [total-quantity (element/element-quantity (:selected-element game-data))
                 min-quantity (math/ceil (* total-quantity laws/min-move-percentage))
                 max-quantity (math/floor (* total-quantity laws/max-move-percentage))]
            [:p (str "Move must be " min-quantity " to " max-quantity " or " total-quantity)]))]
       ]]
    ))

(defn render
  [state]
  (let [game-data (get-game-data state)
        game (:game game-data)]
    [:div.row
      [:div.col-lg-2
       (game-turn game-data)
       (players game)
       (power-bar/render game)
       (action-points game-data)
       [:button.btn.btn-primary {:on-click (partial play-turn game-data)} "Play turn"]
       (unit-quantity-picker game-data)
       (rotate-panel game-data)
       [:button.btn.btn-default {:on-click (partial reset-turn game-data)} "Reset turn"]]
      [:div.col-lg-5
        [boardground/render {} game-data]]]))

Rearrange rotate panel

Rearrange rotate panel


(ns onyx.coordinator.async
  (:require [clojure.core.async :refer [chan thread mult tap timeout >!! <!!]]
            [onyx.coordinator.extensions :as extensions]
            [onyx.coordinator.log.datomic]
            [onyx.coordinator.sync.zookeeper]))

(def eviction-delay 5000)

(def ch-capacity 1000)

(def planning-ch-head (chan ch-capacity))

(def born-peer-ch-head (chan ch-capacity))

(def dead-peer-ch-head (chan ch-capacity))

(def evict-ch-head (chan ch-capacity))

(def offer-ch-head (chan ch-capacity))

(def ack-ch-head (chan ch-capacity))

(def completion-ch-head (chan ch-capacity))

(def planning-ch-tail (chan ch-capacity))

(def born-peer-ch-tail (chan ch-capacity))

(def dead-peer-ch-tail (chan ch-capacity))

(def evict-ch-tail (chan ch-capacity))

(def offer-ch-tail (chan ch-capacity))

(def ack-ch-tail (chan ch-capacity))

(def completion-ch-tail (chan ch-capacity))

(def planning-mult (mult planning-ch-head))

(def born-peer-mult (mult born-peer-ch-head))

(def dead-peer-mult (mult dead-peer-ch-head))

(def evict-mult (mult evict-ch-head))

(def offer-mult (mult offer-ch-head))

(def ack-mult (mult ack-ch-head))

(def completion-mult (mult completion-ch-head))

(defn mark-peer-birth [log sync place death-cb]
  (extensions/on-change sync place death-cb)
  (extensions/mark-peer-born log place))

(defn mark-peer-death [log peer]
  (extensions/mark-peer-dead log peer))

(defn plan-job [log job]
  (comment "Planning here.")
  (extensions/plan-job log job))

(defn acknowledge-task [log task]
  (extensions/ack log task))

(defn evict-task [log sync task]
  (extensions/delete sync task)
  (extensions/evict log task))

(defn offer-task [log sync ack-cb complete-cb]
  (when (extensions/next-task log)
    (extensions/create sync)
    (extensions/create sync)
    (extensions/on-change sync ack-cb)
    (extensions/on-change sync complete-cb)
    (extensions/mark-offered log)
    (extensions/write-place sync)))

(defn complete-task [log sync queue task]
  (extensions/delete sync task)
  (extensions/complete log task)
  (extensions/cap-queue queue task))

(defn born-peer-ch-loop [log sync]
  (loop []
    (let [place (<!! born-peer-ch-tail)]
      (mark-peer-birth log sync place #(>!! dead-peer-ch-head %))
      (>!! offer-ch-head place)
      (recur))))

(defn dead-peer-ch-loop [log]
  (loop []
    (let [peer (<!! dead-peer-ch-tail)]
      (mark-peer-death log peer)
      (>!! evict-ch-head peer)
      (recur))))

(defn planning-ch-loop [log]
  (loop []
    (let [job (<!! planning-ch-tail)]
      (plan-job log job)
      (>!! offer-ch-head job)
      (recur))))

(defn ack-ch-loop [log]
  (loop []
    (let [task (<!! ack-ch-tail)]
      (acknowledge-task log task)
      (recur))))

(defn evict-ch-loop [log sync]
  (loop []
    (let [task (<!! evict-ch-tail)]
      (evict-task log sync task)
      (>!! offer-ch-head task)
      (recur))))

(defn offer-ch-loop [log sync]
  (loop []
    (let [event (<!! offer-ch-tail)]
      (when (offer-task log sync
                        #(>!! ack-ch-head %)
                        #(>!! completion-ch-head %))
        (thread (<!! (timeout eviction-delay))
                (>!! evict-ch-head nil)))
      (recur))))

(defn completion-ch-loop [log sync queue]
  (loop []
    (let [task (<!! completion-ch-tail)]
      (complete-task log sync queue task)
      (>!! offer-ch-head task)
      (recur))))

(defn start-async! [log sync queue]
  (tap planning-mult planning-ch-tail)
  (tap born-peer-mult born-peer-ch-tail)
  (tap dead-peer-mult dead-peer-ch-tail)
  (tap evict-mult evict-ch-tail)
  (tap offer-mult offer-ch-tail)
  (tap ack-mult ack-ch-tail)
  (tap completion-mult completion-ch-tail)

  (thread (try (born-peer-ch-loop log sync) (catch Exception e (prn e) (.printStackTrace e))))
  (thread (dead-peer-ch-loop log))
  (thread (planning-ch-loop))
  (thread (ack-ch-loop log))
  (thread (evict-ch-loop log sync))
  (thread (offer-ch-loop log sync))
  (thread (completion-ch-loop log sync queue)))

(start-async! :datomic :zookeeper :hornetq)

(ns onyx.coordinator.async
  (:require [clojure.core.async :refer [chan thread mult tap timeout >!! <!!]]
            [onyx.coordinator.extensions :as extensions]
            [onyx.coordinator.log.datomic]
            [onyx.coordinator.sync.zookeeper]))

(def eviction-delay 5000)

(def ch-capacity 1000)

(def planning-ch-head (chan ch-capacity))

(def born-peer-ch-head (chan ch-capacity))

(def dead-peer-ch-head (chan ch-capacity))

(def evict-ch-head (chan ch-capacity))

(def offer-ch-head (chan ch-capacity))

(def ack-ch-head (chan ch-capacity))

(def completion-ch-head (chan ch-capacity))

(def planning-ch-tail (chan ch-capacity))

(def born-peer-ch-tail (chan ch-capacity))

(def dead-peer-ch-tail (chan ch-capacity))

(def evict-ch-tail (chan ch-capacity))

(def offer-ch-tail (chan ch-capacity))

(def ack-ch-tail (chan ch-capacity))

(def completion-ch-tail (chan ch-capacity))

(def planning-mult (mult planning-ch-head))

(def born-peer-mult (mult born-peer-ch-head))

(def dead-peer-mult (mult dead-peer-ch-head))

(def evict-mult (mult evict-ch-head))

(def offer-mult (mult offer-ch-head))

(def ack-mult (mult ack-ch-head))

(def completion-mult (mult completion-ch-head))

(defn mark-peer-birth [log sync place death-cb]
  (extensions/on-change sync place death-cb)
  (extensions/mark-peer-born log place))

(defn mark-peer-death [log peer]
  (extensions/mark-peer-dead log peer))

(defn plan-job [log job]
  (comment "Planning here.")
  (extensions/plan-job log job))

(defn acknowledge-task [log task]
  (extensions/ack log task))

(defn evict-task [log sync task]
  (extensions/delete sync task)
  (extensions/evict log task))

(defn offer-task [log sync ack-cb complete-cb]
  (when (extensions/next-task log)
    (extensions/create sync)
    (extensions/create sync)
    (extensions/on-change sync ack-cb)
    (extensions/on-change sync complete-cb)
    (extensions/mark-offered log)
    (extensions/write-place sync)))

(defn complete-task [log sync queue task]
  (extensions/delete sync task)
  (extensions/complete log task)
  (extensions/cap-queue queue task))

(defn born-peer-ch-loop [log sync]
  (loop []
    (let [place (<!! born-peer-ch-tail)]
      (mark-peer-birth log sync place #(>!! dead-peer-ch-head %))
      (>!! offer-ch-head place)
      (recur))))

(defn dead-peer-ch-loop [log]
  (loop []
    (let [peer (<!! dead-peer-ch-tail)]
      (mark-peer-death log peer)
      (>!! evict-ch-head peer)
      (recur))))

(defn planning-ch-loop [log]
  (loop []
    (let [job (<!! planning-ch-tail)]
      (plan-job log job)
      (>!! offer-ch-head job)
      (recur))))

(defn ack-ch-loop [log]
  (loop []
    (let [task (<!! ack-ch-tail)]
      (acknowledge-task log task)
      (recur))))

(defn evict-ch-loop [log sync]
  (loop []
    (let [task (<!! evict-ch-tail)]
      (evict-task log sync task)
      (>!! offer-ch-head task)
      (recur))))

(defn offer-ch-loop [log sync]
  (loop []
    (let [event (<!! offer-ch-tail)]
      (when (offer-task log sync
                        #(>!! ack-ch-head %)
                        #(>!! completion-ch-head %))
        (thread (<!! (timeout eviction-delay))
                (>!! evict-ch-head nil)))
      (recur))))

(defn completion-ch-loop [log sync queue]
  (loop []
    (let [task (<!! completion-ch-tail)]
      (complete-task log sync queue task)
      (>!! offer-ch-head task)
      (recur))))

(defn start-async! [log sync queue]
  (tap planning-mult planning-ch-tail)
  (tap born-peer-mult born-peer-ch-tail)
  (tap dead-peer-mult dead-peer-ch-tail)
  (tap evict-mult evict-ch-tail)
  (tap offer-mult offer-ch-tail)
  (tap ack-mult ack-ch-tail)
  (tap completion-mult completion-ch-tail)

  (thread (born-peer-ch-loop log sync))
  (thread (dead-peer-ch-loop log))
  (thread (planning-ch-loop))
  (thread (ack-ch-loop log))
  (thread (evict-ch-loop log sync))
  (thread (offer-ch-loop log sync))
  (thread (completion-ch-loop log sync queue)))

(start-async! :datomic :zookeeper :hornetq)

Remove t/c

Remove t/c