~subsetpark/ec

d2f6c5bfd50cbdd931d9e072cc5ef54e11fd160d — Zach Smith 7 months ago 27dd77c
Add quote and compose, rexpress dip as composition
4 files changed, 93 insertions(+), 35 deletions(-)

M src/adverbs.janet
M src/compose.janet
M src/env.janet
A test/compose.janet
M src/adverbs.janet => src/adverbs.janet +34 -27
@@ 11,7 11,7 @@

(defadv apply-quotation 1
  ```
  q -- x
  S q -- S
  "Unwrap" a quotation and push its elements onto the stack.
  `1 1 (+) apply` is equivalent to `1 1 +`.
  ```


@@ 20,7 20,7 @@

(defadv map-quotation 2
  ```
  v q -- x
  S v q -- S
  Insert the contents of quotation `q` in between every element of
  `v`. If `v` is not a quotation, then `distribute` is equivalent to
  `apply`.


@@ 41,16 41,35 @@

(defadv wrap-stack 0
  ```
  (x) -- v
  S -- v
  Wrap the entire stack in a vector. 
  ```
  (let [v (calc/wrap ;(stack :data))]
    (array/clear (stack :data))
    (calc/push stack v)))

(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 ;(r :data) ;(q :data))]
    (calc/push stack s)))

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


@@ 75,12 94,11 @@

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

  If either element is a quotation, wraps the two top
  elements in a quotation.
  If `v?` is not a vector, wraps the two top elements in a vector.
  ```
  (let [elem (calc/pop stack)
        vector (calc/pop stack)


@@ 91,12 109,11 @@

(defadv slurp-left 2
  ```
  a q -- q
  If the topmost element on the stack `q` is a quotation,
  includes the second element as the first item in `q`.
  a v? -- v
  If `v?` is a vector, includes the second element as the first item
  in `v?`.
  
  If either element is a quotation, wraps the two top
  elements in a quotation.
  If `v?` is not a vector, wraps the two top elements in a vector.
  ```
  (let [vector (calc/pop stack)
        elem (calc/pop stack)


@@ 107,7 124,7 @@

(defadv fill 2
  ```
  a s -- a'
  a s -- v
  Given a quotation shape `s`, recursively repeats the
  element `a` until it has that shape.
  ```


@@ 123,7 140,7 @@

(defadv shape 1
  ```
  v -- w
  v -- s
  Pushes the shape of the vector `v`.
  ```
  (let [v (calc/pop stack)


@@ 133,7 150,7 @@

(defadv if 3
  ```
  qp qt qf -- x
  S qp qt qf -- S
  If `qp !` = 0, applies `qf`.
     else applies `qt`.
  ```


@@ 154,13 171,3 @@
  Pops the top element of the stack.
  ```
  (calc/pop stack))

(defadv dip 2
  ```
  a q --- a
  Pops the quotation `q`, pops `a`, applies `q`, and pushes `a`.
  ```
  (let [q (calc/pop stack)
        a (calc/pop stack)]
    (eval/apply-quotation stack q)
    (calc/push stack a)))

M src/compose.janet => src/compose.janet +32 -4
@@ 3,20 3,48 @@
(import /src/calc)

(defmacro defcompose
  [name arity & words]
  [name arity doc & words]
  ~(def ,name (:new calc/Adverb
                    :arity ,arity
                    :type ,(keyword name)
                    :doc ,doc
                    :fun-ref (fn ,name [stack]
                               ,;(seq [word :in words]
                                   ~(calc/push stack ,word))))))
                                      ~(calc/push stack ,word))))))

(defcompose square 1 adverbs/dup operations/mul)
(defcompose square 1
  ```
  a -- b
  square the top element.
  ```
  adverbs/dup operations/mul)

(defcompose abs 1
  ```
  a -- b
  get the absolute value of the top element.
  ```
  (calc/quote-wrap (:new calc/Int 0) operations/lt)
  (calc/quote-wrap (:new calc/Int 0) adverbs/swap operations/sub)
  (calc/quote-wrap)
  adverbs/if)

(defcompose wrap-1 1 (calc/wrap) adverbs/slurp-left)
(defcompose wrap-1 1
  ```
  a -- [a]
  wrap the top element in a vector.
  ```
  (calc/wrap) adverbs/slurp-left)

(defcompose dip 2
  ```
  S a q -- S q
  > saves [the second] element away, executes the quotation on whatever of the
  > stack is left, and then restores the saved element.

  - Manfred von Thun, _Rationale for Joy, a functional language_
  ```
  adverbs/swap
  adverbs/quote-element
  adverbs/compose
  adverbs/apply-quotation)

M src/env.janet => src/env.janet +7 -4
@@ 31,21 31,24 @@
                  "swap" adverbs/swap
                  "dup" adverbs/dup
                  "pop" adverbs/pop
                  "dip" adverbs/dip
                  # Array logic-bypassing
                  # Vector logic-bypassing
                  "shape" adverbs/shape
                  # Quotation
                  "quote" adverbs/quote-element
                  "compose" adverbs/compose
                  # Vectors
                  "wrap-all" adverbs/wrap-stack
                  "fill" adverbs/fill
                  "slurp" adverbs/slurp
                  "slurpl" adverbs/slurp-left
                  "slurpr" adverbs/slurp
                  # Definition
                  
                  "def" eval/define

                  "dip" compose/dip
                  "sqr" compose/square
                  "abs" compose/abs
                  "wrap-1" compose/wrap-1})
                  "wrap" compose/wrap-1})

(defn new-env
  []

A test/compose.janet => test/compose.janet +20 -0
@@ 0,0 1,20 @@
(import /src/calc)
(import /src/parser)
(import /src/env)

(import /src/operations :prefix "o/")
(import /src/adverbs :prefix "a/")

(use testament)
(use /test-support)

(deftest dip
  (let [s (env/new-env)
        in (parser/parse "2 3 4 (+) dip")]
    (eval-all s in)
    (let [four (calc/pop s)
          five (calc/pop s)]
      (is (= 4 (four :value)))
      (is (= 5 (five :value))))))

(run-tests!)