(use fugue)
(import csv)

(import /src/calc)
(import /src/eval)

(defproto Adverb calc/Element
  type {}
  arity {}
  fun-ref {})

(extend-multi calc/push [calc/Stack Adverb]
              [self adv]
              (calc/check-arity self adv)
              ((fun-ref adv) self))

(defmacro defadv
  [name arity doc & body]
  ~(def ,name (,new-Adverb
                 :doc ,doc
                 :arity ,arity
                 :type ,(keyword name)
                 :fun-ref (fn ,name [stack] ,;body))))

(defadv apply-quotation 1
  ```
  S q -- S
  "Unwrap" a quotation and push its elements onto the stack.
  `1 1 (+) apply` is equivalent to `1 1 +`.
  ```
  (let [quotation (calc/pop stack)]
    (eval/apply-quotation stack quotation)))

(defn- ensure-quote
  [q]
  (if (calc/Quotation*? q)
    q
    (calc/quote-wrap q)))

(defn- do-distribute
  [stack v quotation]
  (if (calc/Quotation*? v)
    (each elem (calc/data v)
      (calc/push stack elem)
      (eval/apply-quotation stack quotation))
    (do
      (calc/push stack v)
      (eval/apply-quotation stack quotation))))

(defadv dist 3
  ```
  S v a q -- S
  Insert `a`, then apply quotation `q` after every element of `v`.
  ```
  (let [q (calc/pop stack)
        quotation (ensure-quote q)
        base (calc/pop stack)
        v (calc/pop stack)]

    (calc/push stack base)
    (do-distribute stack v quotation)))

(defadv do-each 2
  ```
  S v q -- S
  Apply quotation `q` after every element of vector `v`. If `v` is not
  a quotation, then `each` is equivalent to `apply`.
  ```
  (let [q (calc/pop stack)
        quotation (ensure-quote q)
        v (calc/pop stack)]
    (do-distribute stack v quotation)))

(defadv quote-element 1
  ```
  a -- (a)
  Wrap the top element in a quotation.
  ```
  (let [x (calc/pop stack)
        q (calc/quote-wrap x)]
    (calc/push stack q)))

(defadv compose 2
  ```
  q r -- q'
  Combine the top two quotations into a single quotation.
  ```
  (let [q (calc/pop stack)
        r (calc/pop stack)
        s (calc/quote-wrap ;(@ calc/Quotation r :data) ;(@ calc/Quotation q :data))]
    (calc/push stack s)))

(defadv concat 2
  ```
  v w -- v'
  Combine the top two vectors into a single vector.
  ```
  (let [q (calc/pop stack)
        r (calc/pop stack)
        s (calc/wrap ;(@ calc/Vector r :data) ;(@ calc/Vector q :data))]
    (calc/push stack s)))

(defadv clear-stack 0
  ```
  S -- <>
  Clear the entire stack.
  ```
  (array/clear (@ calc/Stack stack :data)))

(defadv dup 1
  ```
  a --- a a
  Duplicate the top element on the stack.
  ```
  (let [top (calc/peek stack)]
    (calc/push stack top)))

(defadv swap 2
  ```
  a b -- b a
  Swap the two top elements on the stack.
  ```
  (let [top (calc/pop stack)
        second (calc/pop stack)]
    (calc/push stack top)
    (calc/push stack second)))

(def- root-slurp slurp)

(defadv slurp 2
  ```
  v? a -- v
  If `v?` is a vector, includes the topmost element as the last item in
  `v?`.

  If `v?` is not a vector, wraps the two top elements in a vector.
  ```
  (let [elem (calc/pop stack)
        vector (calc/pop stack)
        new-vector (if (calc/Vector? vector)
                     (calc/wrap ;(calc/data vector) elem)
                     (calc/wrap vector elem))]
    (calc/push stack new-vector)))

(defadv slurp-left 2
  ```
  a v? -- v
  If `v?` is a vector, includes the second element as the first item
  in `v?`.
  
  If `v?` is not a vector, wraps the two top elements in a vector.
  ```
  (let [vector (calc/pop stack)
        elem (calc/pop stack)
        new-vector (if (calc/Vector? vector)
                     (calc/wrap elem ;(calc/data vector))
                     (calc/wrap elem vector))]
    (calc/push stack new-vector)))

(defadv fill 2
  ```
  a s -- v
  Given a quotation shape `s`, recursively repeats the
  element `a` until it has that shape.
  ```
  (let [shape (calc/pop stack)
        elem (calc/pop stack)]

    (unless (calc/shape? shape)
      (error "Fill error: top argument must be a shape"))

    (let [unwrapped-shape (map |(calc/value $) (calc/data shape))
          new-quotation (calc/fill elem unwrapped-shape)]
      (calc/push stack new-quotation))))

(defadv shape 1
  ```
  v -- s
  Pushes the shape of the vector `v`.
  ```
  (let [v (calc/pop stack)
        shape (calc/get-shape v)
        new-elem (calc/wrap ;(map calc/make-element shape))]
    (calc/push stack new-elem)))

(defadv if 3
  ```
  S qp qt qf -- S
  If `qp !` = 0, applies `qf`.
     else applies `qt`.
  ```
  (let [qf (calc/pop stack)
        qt (calc/pop stack)
        qp (calc/pop stack)]

    (eval/apply-quotation stack qp)

    (let [result (calc/pop stack)]
      (if (calc/is-true? result)
        (eval/apply-quotation stack qt)
        (eval/apply-quotation stack qf)))))

(defadv pop 1
  ```
  a b --- a
  Pops the top element of the stack.
  ```
  (calc/pop stack))

(defadv quotation-first 1
  ```
  (x | xs) -- x
  Push the first element of a quotation or vector.
  ```
  (let [{:data data} (calc/pop stack)]
    (calc/push stack (first data))))

(defn primitive-recursion
  [stack operation zero]
  (let [data (calc/peek stack)]
    (if (calc/null? data)
      (do
        (calc/pop stack)
        (eval/apply-quotation stack zero))
      (do
        (calc/push stack (calc/pred data))
        (primitive-recursion stack operation zero)
        (eval/apply-quotation stack operation)))))

(defadv push-stack-vector 0
  ```
  Push a quotation containing all the elements of the stack.
  ```
  (let [s (calc/wrap ;(@ calc/Stack stack :data))]
    (calc/push stack s)))

(defadv push-stack 0
  ```
  Push a quotation containing all the elements of the stack.
  ```
  (let [s (calc/quote-wrap ;(@ calc/Stack stack :data))]
    (calc/push stack s)))

(defadv unstack 1
  ```
  Pop a quotation or vector from the stack and make that the new stack.
  ```
  (let [q (calc/pop stack)]
    (put stack :data (array ;(calc/data q)))))

(defadv primrec 3
  ```
  Primitive recursion.

  S d zq oq -- S
  > If the data parameter is [zero or empty], then the first quotation has to
  > produce the value to be returned. If the data parameter is
  > positive then the second has to combine the data parameter with
  > the result of applying the function to its predecessor.
  
  Manfred von Thun, _Tutorial on Joy_
  ```
  (let [operation-param (calc/pop stack)
        zero-param (calc/pop stack)]
    (primitive-recursion stack operation-param zero-param)))

(defn linear-recursion
  [stack if-q then else else2]

  (calc/push stack dup)
  (eval/apply-quotation stack if-q)

  (let [if-result (calc/pop stack)]
    (if (calc/is-true? if-result)
      (eval/apply-quotation stack then)
      (do
        (eval/apply-quotation stack else)
        (linear-recursion stack if-q then else else2)
        (eval/apply-quotation stack else2)))))

(defadv linrec 4
  ```
  S d if then else else2 -- S
  Duplicate `d` and apply `if`. If the result is true, apply
  `then`. Otherwise, apply `else` and recurse. After recursion, apply
  `else2`.
  ```
  (let [else2 (calc/pop stack)
        else (calc/pop stack)
        then (calc/pop stack)
        if-q (calc/pop stack)]
    (linear-recursion stack if-q then else else2)))

(defadv load 2
  ```
  filename format -- v
  Load the file at `filename` and parse according to `format`. Push
  the resulting vector to the stack.

  Currently supported formats:
  - csv
  ```
  (let [format (calc/pop stack)
        format-parser (case (format :value)
                        "csv" csv/parse)
        filename ((calc/pop stack) :value)
        parsed (->> filename
                    (root-slurp)
                    (format-parser)
                    (map |(map parse $)))
        wrapped (calc/wrap ;(map
                              |(calc/wrap ;(map calc/make-element $))
                              parsed))]
    (calc/push stack wrapped)))