(import /src/calc)
(import /src/operations)
(import /src/adverbs)
(import /src/compose)
(import /src/eval)
(def- define (adverbs/new-Adverb
:arity 2
:type :define
:fun-ref (fn define [stack]
(let [sym (calc/pop stack)
q (calc/pop stack)]
(match sym
{:value sym-value :quoted? true} (put-in stack [:env sym-value] q))))))
(def dictionary @{"+" operations/add
"-" operations/sub
"*" operations/mul
"x" operations/mul
"%" operations/div
"sqrt" operations/sqrt
">" operations/gt
"<" operations/lt
">=" operations/gte
"<=" operations/lte
"=" operations/eq
"cmp" operations/cmp
"pow" operations/pow
"small" operations/small
# Combinators
"each" adverbs/do-each
"dist" adverbs/dist
"/" adverbs/dist
"apply" adverbs/apply-quotation
"i" adverbs/apply-quotation
"if" adverbs/if
"primrec" adverbs/primrec
"linrec" adverbs/linrec
# Stack operations
"clear" adverbs/clear-stack
"c" adverbs/clear-stack
"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
"fill" adverbs/fill
"slurp" adverbs/slurp
"slurpl" adverbs/slurp-left
"slurpr" adverbs/slurp
"shape" adverbs/shape
"concat" adverbs/concat
"load" adverbs/load
"def" define
"dip" compose/dip
"sqr" compose/square
"abs" compose/abs
"wrap" compose/wrap-1
"fac" compose/fac
"quote-all" compose/quote-all
"wrap-all" compose/wrap-all
"swop" compose/swop
"length" compose/length
"sum" compose/sum
"product" compose/product})
(defn new-env
[&opt proto]
(default proto dictionary)
(let [s (:new calc/Stack)]
(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.
For ordinary operations, this is equivalent to applying them
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)))))
(put dictionary "map" map-vector)
(adverbs/defadv
scan-vector 3
```
v a q -- w
Insert `a`, then apply quotation `q` after every element of `v`.
Collect the top element of the stack after each application into a
new vector.
```
(let [q (calc/pop stack)
base (calc/pop stack)
v (calc/pop stack)
substack (new-env (stack :env))
return (new-env (stack :env))]
(calc/push substack base)
(each elem (calc/data v)
(calc/push substack elem)
(eval/apply-quotation substack q)
(calc/push return (calc/peek substack)))
(calc/push stack (calc/wrap ;(return :data)))))
(put dictionary "scan" scan-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)
(compose/defcompose
range 1
```
n -- v
generate a vector with numbers 0 up to `n`.
1 swap wrap fill 0 (+) scan
```
(calc/new-Int 1)
adverbs/swap
compose/wrap-1
adverbs/fill
(:new calc/Int -1)
(calc/quote-wrap operations/add)
scan-vector)
(put dictionary "range" range)