~subsetpark/ec

81ff55c827af0fe4caf8d0606cd8f8d4984d4c8e — Zach Smith 7 months ago 9ce6436
Useful combinators + dist/each distinction
6 files changed, 158 insertions(+), 53 deletions(-)

M main.janet
M src/adverbs.janet
M src/compose.janet
M src/env.janet
M test/calc.janet
M test/eval.janet
M main.janet => main.janet +7 -6
@@ 30,13 30,14 @@
  "")

(defn- describe-all
  [q]
  [s q]
  (defn- describe
    [elem]
    (printf "%s\n\n%s: %s"
            (print/p elem)
            (string (elem :type))
            (elem :doc)))
    (let [evaled (eval/eval s elem)]
      (printf "%s: %s\n\n%s"
              (print/p evaled)
              (string (evaled :type))
              (evaled :doc))))
  (each item (q :data)
    (describe item))
  "")


@@ 47,7 48,7 @@
    "." (display (calc/pop s))
    "p" (display (calc/peek s))
    "s" (display-all (s :data))
    "?" (describe-all (calc/pop s))
    "?" (describe-all s (calc/pop s))
    "??" (display-help)))

(defn handle-commands

M src/adverbs.janet => src/adverbs.janet +60 -24
@@ 18,38 18,45 @@
  (let [quotation (calc/pop stack)]
    (eval/apply-quotation stack quotation)))

(defadv do-each 3
(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 the contents of quotation `q` in between every
  element of `v`. If `v` is not a quotation, then `each` is equivalent
  to `apply`.
  Insert `a`, then apply quotation `q` after every element of `v`.
  ```
  (let [q (calc/pop stack)
        quotation (if (calc/Quotation*? q)
                    q
                    (calc/quote-wrap q))
        quotation (ensure-quote q)
        base (calc/pop stack)
        v (calc/pop stack)]
    

    (calc/push stack base)
    
    (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)))))
    (do-distribute stack v quotation)))

(defadv wrap-stack 0
(defadv do-each 2
  ```
  S -- v
  Wrap the entire stack in a vector. 
  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 [v (calc/wrap ;(stack :data))]
    (array/clear (stack :data))
    (calc/push stack v)))
  (let [q (calc/pop stack)
        quotation (ensure-quote q)
        v (calc/pop stack)]
    (do-distribute stack v quotation)))

(defadv quote-element 1
  ```


@@ 185,6 192,14 @@
  ```
  (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)]


@@ 197,6 212,27 @@
        (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 ;(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 ;(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 ;(q :data)))))

(defadv primrec 3
  ```
  Primitive recursion.


@@ 214,10 250,10 @@

(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)

M src/compose.janet => src/compose.janet +37 -1
@@ 54,4 54,40 @@
  a -- b
  factorial.
  ```
  (calc/quote-wrap (:new calc/Int 1)) (calc/quote-wrap operations/mul) adverbs/primrec)
  (calc/quote-wrap (:new calc/Int 1))
  (calc/quote-wrap operations/mul)
  adverbs/primrec)

(defcompose quote-all 0
  ```
  S -- (S)
  quote the entire stack.
  ```
  adverbs/push-stack
  (calc/quote-wrap adverbs/clear-stack)
  dip)

(defcompose wrap-all 0
  ```
  S -- [S]
  wrap the entire stack in a vector.
  ```
  adverbs/push-stack-vector
  (calc/quote-wrap adverbs/clear-stack)
  dip)

(defcompose swop 2
  ```
  S a b -- S b
  remove the second element from the stack.
  ```
  adverbs/swap
  adverbs/pop)

(defcompose length 1
  ```
  q -- n
  Push the length of a quotation or vector.
  ```
  adverbs/shape
  adverbs/quotation-first)

M src/env.janet => src/env.janet +43 -12
@@ 22,6 22,7 @@

                  # Combinators
                  "each" adverbs/do-each
                  "dist" adverbs/dist
                  "apply" adverbs/apply-quotation
                  "i" adverbs/apply-quotation
                  "if" adverbs/if


@@ 33,11 34,13 @@
                  "swap" adverbs/swap
                  "dup" adverbs/dup
                  "pop" adverbs/pop
                  "stack" adverbs/push-stack
                  "unstack" adverbs/unstack
                  # Quotation
                  "first" adverbs/quotation-first
                  "quote" adverbs/quote-element
                  "compose" adverbs/compose
                  # Vectors
                  "wrap-all" adverbs/wrap-stack
                  "fill" adverbs/fill
                  "slurp" adverbs/slurp
                  "slurpl" adverbs/slurp-left


@@ 51,7 54,11 @@
                  "sqr" compose/square
                  "abs" compose/abs
                  "wrap" compose/wrap-1
                  "fac" compose/fac})
                  "fac" compose/fac
                  "quote-all" compose/quote-all
                  "wrap-all" compose/wrap-all
                  "swop" compose/swop
                  "length" compose/length})

(defn new-env
  [&opt proto]


@@ 60,7 67,7 @@
    (put s :env (table/setproto @{} proto))))

(adverbs/defadv map-vector 2
  ```
                ```
  v q -- v'
  Insert the contents of quotation `q` in between every element of
  `v`. Wrap the resulting elements in a vector.


@@ 69,14 76,38 @@
  directly. For instance, `v (dup 1 +) map` is equivalent to
  `v dup 1 +`.
  ```
  (let [q (calc/pop stack)
        v (calc/pop stack)
        substack (new-env (stack :env))]
    
    (each elem (calc/data v)
      (calc/push substack elem)
      (eval/apply-quotation substack q))
    
    (calc/push stack (calc/wrap ;(substack :data)))))
                (let [q (calc/pop stack)
                      v (calc/pop stack)
                      substack (new-env (stack :env))]

                  (each elem (calc/data v)
                    (calc/push substack elem)
                    (eval/apply-quotation substack q))

                  (calc/push stack (calc/wrap ;(substack :data)))))

(put dictionary "map" map-vector)

(adverbs/defadv fork 3
                ```
  S a q p -- S a' a'' 
  Apply q to a, and p to a, and push the results on the stack.
  ```
                (let [p (calc/pop stack)
                      q (calc/pop stack)
                      a (calc/pop stack)
                      p-env (new-env (stack :env))
                      q-env (new-env (stack :env))]
                  # Thread 1
                  (calc/push p-env a)
                  (eval/apply-quotation p-env p)
                  # Thread 2
                  (calc/push q-env a)
                  (eval/apply-quotation q-env q)
                  # Main Thread
                  (each elem (q-env :data)
                    (calc/push stack elem))
                  (each elem (p-env :data)
                    (calc/push stack elem))))

(put dictionary "fork" fork)

M test/calc.janet => test/calc.janet +10 -9
@@ 2,6 2,7 @@

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

(use testament)
(use /test-support)


@@ 44,20 45,20 @@
            @[8 10 12]]]
        (calc/apply-operation o/add m filled)))

(deftest each-add
(deftest dist-add
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 0))
  # Operands
  (calc/push s (wrap 1 2 3))
  (calc/push s (:new calc/Int 0))
  # Operator
  (calc/push s (quote-wrap o/add))
  (calc/push s a/do-each)
  (calc/push s a/dist)
  (pop-and-compare 6 s))

(deftest each-multiple-operations
(deftest dist-multiple-operations
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 0))
  (calc/push s (wrap 1 2 3))
  (calc/push s (:new calc/Int 0))
  (calc/push s (quote-wrap 4 o/mul o/add))
  # 0 [1 2 3]
  # [2 3] 0 1 4 * +


@@ 66,7 67,7 @@
  # [3] 12
  # 12 3 4 * +
  # 24
  (calc/push s a/do-each)
  (calc/push s a/dist)
  (pop-and-compare 24 s))

(deftest apply-quotation


@@ 100,7 101,7 @@
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 3))
  (calc/push s (:new calc/Int 4))
  (calc/push s a/wrap-stack)
  (calc/push s c/wrap-all)

  (def vec (calc/pop s))
  (is (= [2] (calc/shape vec)))


@@ 110,7 111,7 @@
  (def s (:new calc/Stack))
  (calc/push s (wrap 1 2))
  (calc/push s (wrap 2 4))
  (calc/push s a/wrap-stack)
  (calc/push s c/wrap-all)

  (def vec (calc/pop s))
  (is (= [2 2] (calc/shape vec)))


@@ 121,7 122,7 @@
  (calc/push s (wrap 1))
  (calc/push s (wrap 2 4))
  (is (thrown?
        (calc/push s a/wrap-stack))
        (calc/push s c/wrap-all))
      "Wrapping a stack requires homogeneous data"))

(run-tests!)

M test/eval.janet => test/eval.janet +1 -1
@@ 22,7 22,7 @@

(deftest push-adverb
  (let [s (env/new-env)
        parsed (parser/parse "0 [1 2 3] (+) each")]
        parsed (parser/parse "[1 2 3] 0 (+) dist")]
    (eval-all s parsed)

    (is (= 1 (length (s :data))))