~subsetpark/ec

ref: 8c90cfc6ae2baefd4800e61a5894a97ba4a8367b ec/src/calc.janet -rw-r--r-- 3.2 KiB
8c90cfc6 — Zach Smith Basic error handling 10 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
(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))))

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

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

(defmethod apply-operation Operation
  [op & args]
  (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))))

(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/insert buf 0 (pop self)))
    
    (->> (apply-operation op ;buf)
         (make-element)
         (push self))))

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

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

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