~subsetpark/ec

ref: 23027903beabdba42f04dc75e4e6b628b66dbd55 ec/src/adverbs.janet -rw-r--r-- 7.0 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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
(use fugue)
(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/data r) ;(calc/Quotation/data q))]
    (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/data r) ;(calc/Vector/data q))]
    (calc/push stack s)))

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

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

(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/data stack))]
    (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/data stack))]
    (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)))