~subsetpark/ec

ref: 23027903beabdba42f04dc75e4e6b628b66dbd55 ec/src/compose.janet -rw-r--r-- 2.2 KiB
23027903 — Zach Smith Factor out logic into surrounding modules 3 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
(import /src/operations)
(import /src/adverbs)
(import /src/calc)

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

(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.
  ```
  adverbs/dup
  (calc/quote-wrap (calc/new-Int 0) operations/lt)
  (calc/quote-wrap (calc/new-Int 0) adverbs/swap operations/sub)
  (calc/quote-wrap)
  adverbs/if)

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

(defcompose fac 1
  ```
  a -- b
  factorial.
  ```
  (calc/quote-wrap (calc/new-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)

(defcompose sum 1
  ```
  q -- n
  sum a quotation or vector.
  ```
  (calc/new-Int 0)
  (calc/quote-wrap operations/add)
  adverbs/dist)

(defcompose product 1
  ```
  q -- n
  find the product of a quotation or vector.
  ```
  (calc/new-Int 1)
  (calc/quote-wrap operations/mul)
  adverbs/dist)