~subsetpark/ec

ref: 32fb47a265790f03d6024e74593aad9cb6bd07b9 ec/src/calc.janet -rw-r--r-- 3.2 KiB
32fb47a2 — Zach Smith Working REPL 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
(use fugue)

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

(defproto Element ())

(defproto Int Element value {:init? true})
(defproto Float Element value {:init? true})

(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)]
                (:new Vector new-shape new-data)))
            self
            (reverse y))))

(defmethod apply-operation Operation
  [op & args]
  (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)
              unwrapped (map |($ :value) args)]
          (f ;unwrapped)))))

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

(defn wrap [& data]
  (let [hd (first data)
        inner-shape (get-shape hd)]
    (each datum data
      (unless (deep= (get-shape datum) inner-shape)
        (errorf "Vector error: can't wrap heterogeneous data. Expected %j, got %j."
                inner-shape
                (get-shape datum))))
    (:new Vector (tuple (length data) ;inner-shape) data)))

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

# TODO: Do we want to do something more sophisticated here?
(defmulti make-element [:number] [n] (:new Float n))
(defmulti make-element [_] [v] v)

(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 (make-element (apply-operation op ;buf)))))

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

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

(defn push-all
  [stack args]
  (each arg args
    (push stack arg)))