~subsetpark/ec

23027903beabdba42f04dc75e4e6b628b66dbd55 — Zach Smith 30 days ago 91f88d6
Factor out logic into surrounding modules
M src/adverbs.janet => src/adverbs.janet +16 -5
@@ 1,13 1,24 @@
(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 calc/Adverb
                    :doc ,doc
                    :arity ,arity
                    :type ,(keyword name)
                    :fun-ref (fn ,name [stack] ,;body))))
  ~(def ,name (,new-Adverb
                 :doc ,doc
                 :arity ,arity
                 :type ,(keyword name)
                 :fun-ref (fn ,name [stack] ,;body))))

(defadv apply-quotation 1
  ```

M src/calc.janet => src/calc.janet +9 -53
@@ 22,14 22,6 @@
  [n]
  (not (zero? (n :value))))

(defproto Operation Element
  type {}
  arity {}
  fun-ref {})

(defproto Adverb Element
  type {})

(defproto Quotation Element
  data {:init? true}
  type {:allocate-value :quotation})


@@ 50,12 42,12 @@
  [q] (empty? (data q)))

(defmethod pred Number
  [n] (:new (table/getproto n) (- (value n) 1)))
  [n] (:new n (- (value n) 1)))

(defmethod pred Quotation
  [q]
  (let [rest (array/slice (data q) 1)]
    (:new (table/getproto q) ;rest)))
    (:new q ;rest)))

(defgeneric get-shape [elem]
  (errorf "Shape error: attempted vector operation on a %s"


@@ 70,7 62,7 @@
    element
    (let [y (array ;shape-to-fill)
          yi (last y)
          v (:new Vector [yi] (array/new-filled yi element))]
          v (new-Vector [yi] (array/new-filled yi element))]
      (fill v y))))

(defmethod fill Vector


@@ 88,40 80,21 @@
    (reduce (fn [acc length]
              (let [new-shape (tuple length ;(shape acc))
                    new-data (array/new-filled length acc)]
                (:new Vector new-shape new-data)))
                (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
                                           :doc (string n)))
(defmulti make-element [:number] [n] (new-Float n
                                                :doc (string n)))
(defmulti make-element [:boolean] [b] (if b
                                        (make-element 1)
                                        (make-element 0)))
(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 (fun-ref op)
            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 quote-wrap
  [& data]
  (:new Quotation data))
  (new-Quotation data))

(defn wrap
  [& data]


@@ 132,7 105,7 @@
        (errorf "Vector error: can't wrap heterogeneous data. Expected shape %j, got %j."
                inner-shape
                (get-shape datum))))
    (:new Vector (tuple (length data) ;inner-shape) data)))
    (new-Vector (tuple (length data) ;inner-shape) data)))

(defmethod pop Stack
  [self]


@@ 151,7 124,7 @@

(defn check-arity
  [stack elem]
  (let [arity (arity elem)]
  (let [arity (elem :arity)]
    (when (> arity (size stack))
      (errorf "Not enough stack: %s has arity %i; Stack has size %i"
              (string (elem :type))


@@ 160,23 133,6 @@

(declare-open-multi push)

(extend-multi push [Stack Operation]
              [self op]
              (check-arity self op)

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

              (->> (apply-operation op ;buf)
                   (make-element)
                   (push self)))

(extend-multi push [Stack Adverb]
              [self adv]
              (check-arity self adv)
              ((fun-ref adv) self))

(extend-multi push [Stack _]
              [self item]
              (array/push (data self) item))

M src/compose.janet => src/compose.janet +13 -13
@@ 4,14 4,14 @@

(defmacro defcompose
  [name arity doc & words]
  ~(def ,name (:new calc/Adverb
                    :arity ,arity
                    :type ,(keyword name)
                    :doc ,doc
                    :composes (array ,;words)
                    :fun-ref (fn ,name [stack]
                               ,;(seq [word :in words]
                                   ~(calc/push stack ,word))))))
  ~(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
  ```


@@ 26,8 26,8 @@
  get the absolute value of the top element.
  ```
  adverbs/dup
  (calc/quote-wrap (:new calc/Int 0) operations/lt)
  (calc/quote-wrap (:new calc/Int 0) adverbs/swap operations/sub)
  (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)



@@ 56,7 56,7 @@
  a -- b
  factorial.
  ```
  (calc/quote-wrap (:new calc/Int 1))
  (calc/quote-wrap (calc/new-Int 1))
  (calc/quote-wrap operations/mul)
  adverbs/primrec)



@@ 99,7 99,7 @@
  q -- n
  sum a quotation or vector.
  ```
  (:new calc/Int 0)
  (calc/new-Int 0)
  (calc/quote-wrap operations/add)
  adverbs/dist)



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

M src/env.janet => src/env.janet +11 -2
@@ 5,6 5,15 @@
(import /src/eval)


(def- define (adverbs/new-Adverb
               :arity 2
               :type :define
               :fun-ref (fn define [stack]
                          (let [sym (calc/pop stack)
                                q (calc/pop stack)]
                            (match sym
                              {:value sym-value :quoted? true} (put-in stack [:env sym-value] q))))))

(def dictionary @{"+" operations/add
                  "-" operations/sub
                  "*" operations/mul


@@ 49,7 58,7 @@
                  "shape" adverbs/shape
                  "concat" adverbs/concat

                  "def" eval/define
                  "def" define

                  "dip" compose/dip
                  "sqr" compose/square


@@ 150,7 159,7 @@
 
  1 swap wrap fill 0 (+) scan
  ```
  (:new calc/Int 1)
  (calc/new-Int 1)
  adverbs/swap
  compose/wrap-1
  adverbs/fill

M src/eval.janet => src/eval.janet +0 -10
@@ 1,16 1,6 @@
(use fugue)
(import /src/calc)

(def define (:new calc/Adverb
                  :arity 2
                  :type :define
                  :fun-ref (fn define [stack]
                             (let [sym (calc/pop stack)
                                   q (calc/pop stack)]
                               (match sym
                                 {:value sym-value :quoted? true} (put-in stack [:env sym-value] q))))))


(defn lookup
  ```
  Look up a symbol in a stack 's environment. The symbol might refer

M src/operations.janet => src/operations.janet +42 -5
@@ 1,12 1,49 @@
(use fugue)
(import /src/calc)

(defproto Operation calc/Element
  type {}
  arity {}
  fun-ref {})

(defn- inner-apply
  [op & args]
  (let [x (first args)]
    (if (calc/Vector? x)
      (calc/new-Vector
        (x :shape)
        (map (partial inner-apply op) ;(map |(calc/Vector/data $) args)))
      (let [f (fun-ref op)
            unwrapped (map |(calc/value $) args)]
        (->> (f ;unwrapped)
             (calc/make-element))))))

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

(extend-multi calc/push [calc/Stack Operation]
              [self op]
              (calc/check-arity self op)

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

              (->> (apply-operation op ;buf)
                   (calc/make-element)
                   (calc/push self)))

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

(defop add 2 +)
(defop sub 2 -)

M src/print.janet => src/print.janet +4 -2
@@ 2,6 2,8 @@

(import /src/calc)
(import /src/parser)
(import /src/operations)
(import /src/adverbs)

(defmulti p [calc/Int]
  [n] (string (n :value)))


@@ 9,10 11,10 @@
(defmulti p [calc/Float]
  [n] (string (n :value)))

(defmulti p [calc/Operation]
(defmulti p [operations/Operation]
  [o] (string (o :type)))

(defmulti p [calc/Adverb]
(defmulti p [adverbs/Adverb]
  [a] (string (a :type)))

(defmulti p [parser/Symbol]

M test/calc.janet => test/calc.janet +6 -6
@@ 11,13 11,13 @@
  (def v (wrap 1 2 3))
  (def v2 (wrap 2 5 10))

  (vec= [4 5 6] (calc/apply-operation o/add v (:new calc/Int 3)))
  (vec= [3 7 13] (calc/apply-operation o/add v v2))
  (vec= [4 5 6] (o/apply-operation o/add v (:new calc/Int 3)))
  (vec= [3 7 13] (o/apply-operation o/add v v2))

  (vec= [-2 -1 0] (calc/apply-operation o/sub v (:new calc/Int 3)))
  (vec= [2 1 0] (calc/apply-operation o/sub (:new calc/Int 3) v))
  (vec= [-2 -1 0] (o/apply-operation o/sub v (:new calc/Int 3)))
  (vec= [2 1 0] (o/apply-operation o/sub (:new calc/Int 3) v))

  (is (vec= 6 (calc/apply-operation o/add (:new calc/Int 3) (:new calc/Int 3)))))
  (is (vec= 6 (o/apply-operation o/add (:new calc/Int 3) (:new calc/Int 3)))))

(deftest matrices
  (is (thrown? (wrap (wrap 1) (wrap 1 2)))


@@ 43,7 43,7 @@
            @[8 10 12]]
          @[@[2 4 6]
            @[8 10 12]]]
        (calc/apply-operation o/add m filled)))
        (o/apply-operation o/add m filled)))

(deftest dist-add
  (def s (:new calc/Stack))