(defn -return [value tail] {:value value :tail tail})
(def -valid? boolean)
(def -value :value)
(def -tail :tail)

(defn _empty [value] (partial -return value))

(defn _char [p]
  (fn [[c & cs]]
    (if (and c (p c)) (-return c cs))))

(defn _map [f]
  (fn [result]
    (if (-valid? result)
      (-return (f (-value result)) (-tail result)))))

(defn _combine [f a b]
  (fn [str]
    (let [ar ((force a) str)]
      (if (-valid? ar)
        ((_map (partial f (-value ar)))
         ((force b) (-tail ar)))))))

(defn _either [a b]
  (fn [str]
    (let [ar ((force a) str)]
      (if (-valid? ar) ar ((force b) str)))))

(defn _parser [p]
  (fn [input]
    (-value ((_combine (fn [v _] v) p (_char #{\u0000})) (str input \u0000)))))



; Second level of abstraction
(defn +char [chars] (_char (set chars)))

(defn +char-not [chars] (_char (comp not (set chars))))

(defn +map [f parser] (comp (_map f) parser))

(def +parser _parser)

(def +ignore (partial +map (constantly 'ignore)))

(defn iconj [coll value]
  (if (= value 'ignore) coll (conj coll value)))

(defn +seq [& ps]
  (reduce (partial _combine iconj) (_empty []) ps))

(defn +seqf [f & ps] (+map (partial apply f) (apply +seq ps)))

(defn +seqn [n & ps] (apply +seqf (fn [& vs] (nth vs n)) ps))

(defn +or [p & ps]
  (reduce (partial _either) p ps))

(defn +opt [p]
  (+or p (_empty nil)))

(defn +star [p]
  (letfn [(rec [] (+or (+seqf cons p (delay (rec))) (_empty ())))] (rec)))

(defn +plus [p] (+seqf cons p (+star p)))

(defn +str [p] (+map (partial apply str) p))



; Third level of abstraction (READ-EXPRESSION FUNCTION)
(def read-expression
  (let
    [
     *all-chars (mapv char (range 0 128))

     *digit (+char "0123456789")
     *number (+map read-string (+str (+plus (+or *digit (+char "-.")))))

     *space (+char (apply str (filter #(Character/isWhitespace (char %)) *all-chars)))
     *ws (+ignore (+star *space))

     *negate (+seqf (constantly 'negate) (+char "n") (+char "e") (+char "g") (+char "a") (+char "t") (+char "e"))
     *operation (+map symbol (+str (+plus (+char "+-/*"))))

     *variable (+map symbol (+str (+plus (+char "xyzXYZ"))))
     ]

    (letfn [
            (*seq [begin p end]
              (+seqn 1 (+char begin) (+opt (+seqf cons *ws p (+star (+seqn 1 (+char " ") *ws p)))) *ws (+char end)))

            (*list [] (*seq "(" (delay (*value)) ")"))

            (*value [] (+or *negate *number *variable (*list) *operation))
            ]
      (+parser (+seqn 0 *ws (*value) *ws)))))


; Functions
(def div #(/ (double %1) %2))
(defn hyperbolic [op] #(div (op (Math/exp %) (Math/exp (- %))) 2))
(def sqrt #(Math/sqrt (Math/abs (double %))))
(def square #(* % %))
(def sinh (hyperbolic -))
(def cosh (hyperbolic +))

; Proto-methods
(defn proto-get [obj key]
  (cond
    (contains? obj key) (obj key)
    (contains? obj :prototype) (proto-get (obj :prototype) key)
    :else nil))

(defn proto-call [this key & args]
  (apply (proto-get this key) this args))

(defn field [key]
  (fn [this] (proto-get this key)))

; Достаем метод и применяем к объекту и аргументам
(defn method [key]
  (fn [this & args] (apply proto-call this key args)))

(def evaluate (method :evaluate))
(def toString (method :toString))
(def toStringSuffix (method :toStringSuffix))
(def diff (method :diff))

; Classes
(defn Constant [value]
  {
   :toString       (fn [_] (format "%.1f" value))
   :toStringSuffix (fn [_] (format "%.1f" value))
   :evaluate       (fn [_ _] value)
   :diff           (fn [_ _] (Constant 0))
   })

(def zero (Constant 0))
(def one (Constant 1))
(def two (Constant 2))

(def var-proto
  (let [name (field :name)]
    {
     :toString       (fn [this] (name this))
     :toStringSuffix (fn [this] (name this))
     :evaluate       (fn [this keymap] (keymap (clojure.string/lower-case (first (name this)))))
     :diff           (fn [this var] (if (= var (name this)) one zero))
     }))

(defn Variable [name]
  {
   :prototype var-proto
   :name      name
   })

(def operation-proto
  (let [diffFunc (field :diffFunc)
        name (field :name)
        op (field :op)
        operands (field :operands)]
    {
     :toString       (fn [this]
                       (str "(" (name this) " " (clojure.string/join " " (map toString (operands this))) ")"))

     :toStringSuffix (fn [this]
                       (str "(" (clojure.string/join " " (map toStringSuffix (operands this))) " " (name this) ")"))

     :evaluate       (fn [this values]
                       (apply (op this) (map #(evaluate % values) (operands this))))

     :diff           (fn [this var] (let [curArgs (operands this) a (first curArgs) b (last curArgs)]
                                      (if (= (count curArgs) 2)
                                        ((diffFunc this) a b (diff a var) (diff b var))
                                        ((diffFunc this) a (diff a var)))))
     }))

(defn operation-params [op name diffFunc]
  {
   :prototype operation-proto
   :op        op
   :name      name
   :diffFunc  diffFunc
   })

(defn operation [op name diffFunc]
  (let [params-proto (operation-params op name diffFunc)]
    (fn [& operands]
      {
       :prototype params-proto
       :operands  (vec operands)
       })))

(def Add (operation + "+" (fn [_ _ da db] (Add da db))))

(def Subtract (operation - "-" (fn [_ _ da db] (Subtract da db))))

(def Multiply (operation * "*" (fn [a b da db] (Add (Multiply da b) (Multiply db a)))))

(def Divide (operation
              div "/" (fn [a b da db] (Divide (Subtract (Multiply b da)
                                                        (Multiply a db))
                                              (Multiply b b)))))

(def Negate (operation - "negate" (fn [_ da] (Subtract da))))

(def Square (operation square "square" (fn [a da] (Multiply two (Multiply a da)))))

(def Sqrt (operation sqrt "sqrt" (fn [a da] (Divide (Multiply da a)
                                                    (Multiply
                                                      two (Sqrt (Multiply (Square a) a)))))))

(declare Cosh)

(def Sinh (operation sinh "sinh" (fn [a da] (Multiply da (Cosh a)))))

(def Cosh (operation cosh "cosh" (fn [a da] (Multiply da (Sinh a)))))

(def ops
  {'+      Add,
   '-      Subtract,
   '*      Multiply,
   '/      Divide,
   'negate Negate
   'sqrt   Sqrt
   'square Square
   'sinh   Sinh
   'cosh   Cosh
   })

(defn parseSuffix [expr]
  (cond
    (number? expr) (Constant expr)
    (symbol? expr) (Variable (str expr))
    (seq? expr) (apply (ops (last expr)) (map parseSuffix (butlast expr)))))

(def parseObjectSuffix (comp parseSuffix read-expression))