~subsetpark/ec

ref: dd1a81dbaadd73bb0fa354e38036f5a86b5f031d ec/calc.janet -rw-r--r-- 3.3 KiB
dd1a81db — Zach Smith Integrate adverbs 11 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
(use fugue)

(defproto Stack () data {:default @[]})

(defproto Element ())

(defproto Operation Element type {} arity {:default 0} fun-ref {})
(defproto Adverb Element type {} arity {:default 0})

(defproto Vector Element
  shape {:default [] :init? true}
  data {:init? true})

(defgeneric get-shape [_] [])
(defmethod get-shape Vector [self] (self :shape))

(defgeneric fill
  [element shape-to-fill]
  (if (empty? shape-to-fill)
    element
    (let [y (array ;shape-to-fill)
          yi (last y)
          v (:new Vector [yi] (array/new-filled yi element))]
      (fill v y))))

(defmethod fill Vector
  [self shape-to-fill]
  (let [x (array ;(shape self))
        y (array ;shape-to-fill)]
    (while (not (empty? x))
      (let [xi (array/pop x)
            yi (array/pop y)]
        (unless (= xi yi)
          (errorf "Shape error: can't fill vector with shape %q to %q"
                  (shape self) shape-to-fill))))
    (reduce (fn [acc length]
              (let [new-shape (tuple length ;(shape acc))
                    new-data (array/new-filled length acc)]
                (tracev (:new Vector new-shape new-data))))
            self
            (reverse y))))

(defmethod apply-operation Operation
  [op & vectors]
  (defn inner-apply [op & args]
    (let [x (first args)]
      (if (Vector? x)
        (:new Vector
              (x :shape)
              (map (partial inner-apply op) ;(map |($ :data) args)))
        (let [f (op :fun-ref)]
          (f ;args)))))

  (let [cmpr (comp length get-shape)
        largest (get-shape (extreme |(> (cmpr $0) (cmpr $1)) vectors))
        filled (map |(fill $ largest) vectors)]
    (inner-apply op ;filled)))

(defn make-vector [& data] (:new Vector [(length data)] data))

# TODO: Insert ~= J /
# Take first arity items from quoted list, put them on the stack, apply fun, put next item on stack, apply fun, extc

(defmacro defop
  [name arity f]
  ~(def ,name (:new Operation :arity ,arity :type ,(keyword name) :fun-ref ,f)))

(defop add 2 +)
(defop sub 2 -)
(defop div 2 /)
(defop mul 2 *)
(defop sqrt 1 math/sqrt)


(defmethod pop Stack
  [self]
  (-> (self :data) (array/pop)))

(defmethod peek Stack
  [self]
  (-> (self :data) (last)))

(defmethod size Stack
  [self]
  (-> (self :data) (length)))

(defn- check-arity
  [stack arity name]
  (when (> arity (size stack))
    (errorf "Not enough stack; %s has arity %i; stack has size %i"
            (string name)
            arity
            (size stack))))

(defmulti push [Stack Operation]
  [self op]
  (let [{:arity arity :type op-type} op]
    (check-arity self arity op-type)

    (def buf @[])
    (loop [_ :range [0 arity]]
      (array/push buf (pop self)))

    (push self (apply-operation op ;buf))))

(defmulti push [Stack _]
  [self item]
  (array/push (self :data) item))

(defmacro defadv
  [name arity & body]
  ~(def ,name (:new Adverb
                    :arity ,arity
                    :type ,(keyword name)
                    :fun-ref (fn ,name [stack] ,;body))))

(defadv distribute-dyad 3
  (let [quoted-verb (pop stack)
        object (pop stack)]
    # Leave the initial value on the stack.
    (each elem (data object)
      (push stack elem)
      (each verb-elem (data quoted-verb)
        (push stack verb-elem)))))

(defmulti push [Stack Adverb]
  [self adv]
  (let [{:arity arity :type adv-type} adv]
    (check-arity self arity adv-type)
    ((adv :fun-ref) self)))