~subsetpark/ec

cb9047649f01b15e78a1cd66b6dc710c38792038 — Zach Smith 9 months ago 8c90cfc
Add some more useful adverbs
7 files changed, 91 insertions(+), 50 deletions(-)

M main.janet
M src/adverbs.janet
M src/calc.janet
M src/parser.janet
M src/print.janet
M test/calc.janet
M test/regressions.janet
M main.janet => main.janet +5 -3
@@ 34,9 34,11 @@

        (let [bak (array/slice (s :data))]
          (try (calc/push-all s parsed)
               ([err]
                (eprint err)
                (put s :data bak))))))))
            ([err fib]
              (eprint err)
              (if (os/getenv "EC_TRACEBACK")
                (propagate err fib)
                (put s :data bak)))))))))

(defn handle-line
  [line]

M src/adverbs.janet => src/adverbs.janet +35 -6
@@ 8,26 8,55 @@
                    :fun-ref (fn ,name [stack] ,;body))))

(defadv distribute-dyad 3
  (let [quoted-verb (calc/pop stack)
  (let [quotation (calc/pop stack)
        object (calc/pop stack)]
    # Leave the initial value on the stack.

    (unless (calc/Quotation? quotation)
      (errorf "Distribute error: top argument must be a quotation"))

    (each elem (calc/data object)
      (calc/push stack elem)
      (each verb-elem (calc/data quoted-verb)

      (calc/check-arity stack quotation)

      (each verb-elem (calc/data quotation)
        (calc/push stack verb-elem)))))

(defadv apply-vector 1
  (let [quoted-verb (calc/pop stack)]
    (each elem (calc/data quoted-verb)
      (calc/push stack elem))))
(defadv apply-quotation 1
  (let [quotation (calc/pop stack)]
    (if (calc/Quotation? quotation)
      (do (calc/check-arity stack quotation)
        (each elem (calc/data quotation)
          (calc/push stack elem)))
      (calc/push stack quotation))))

(defadv wrap-stack 0
  (let [v (calc/wrap ;(stack :data))]
    (array/clear (stack :data))
    (calc/push stack v)))

(defadv clear-stack 0
  (array/clear (stack :data)))

(defadv swap 2
  (let [top (calc/pop stack)
        second (calc/pop stack)]
    (calc/push stack top)
    (calc/push stack second)))

(defadv slurp 2
  (let [elem (calc/pop stack)
        quotation (calc/pop stack)
        new-quotation (if (calc/Quotation? quotation)
                        (calc/wrap ;(quotation :data) elem)
                        (calc/wrap quotation elem))]
    (calc/push stack new-quotation)))

(defadv slurp-left 2
  (let [quotation (calc/pop stack)
        elem (calc/pop stack)
        new-quotation (if (calc/Quotation? quotation)
                        (calc/wrap elem ;(quotation :data))
                        (calc/wrap elem quotation))]
    (calc/push stack new-quotation)))

M src/calc.janet => src/calc.janet +36 -30
@@ 10,12 10,19 @@
(defproto Operation Element type {} arity {:default 0} fun-ref {})
(defproto Adverb Element type {} arity {:default 0})

(defproto Vector Element
(defproto Quotation Element
  shape {:default [] :init? true}
  data {:init? true})
  data {:init? true}
  type {:allocate-value :quotation})

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

(defgeneric get-arity [_] -1)
(defmethod get-arity Adverb [a] (a :arity))
(defmethod get-arity Operation [a] (a :arity))
(defmethod get-arity Quotation [q]
  (reduce |(+ $0 (get-arity $1)) 0 (q :data)))

(defgeneric fill
  [element shape-to-fill]


@@ 23,10 30,10 @@
    element
    (let [y (array ;shape-to-fill)
          yi (last y)
          v (:new Vector [yi] (array/new-filled yi element))]
          v (:new Quotation [yi] (array/new-filled yi element))]
      (fill v y))))

(defmethod fill Vector
(defmethod fill Quotation
  [self shape-to-fill]
  (let [x (array ;(shape self))
        y (array ;shape-to-fill)]


@@ 35,13 42,13 @@
      (let [xi (array/pop x)
            yi (array/pop y)]
        (unless (= xi yi)
          (errorf "Shape error: can't fill vector with shape %q to %q"
          (errorf "Shape error: can't fill quotation 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)))
                (:new Quotation new-shape new-data)))
            self
            (reverse y))))



@@ 52,8 59,8 @@
(defn- inner-apply
  [op & args]
  (let [x (first args)]
    (if (Vector? x)
      (:new Vector
    (if (Quotation? x)
      (:new Quotation
            (x :shape)
            (map (partial inner-apply op) ;(map |($ :data) args)))
      (let [f (op :fun-ref)


@@ 74,10 81,10 @@
        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."
        (errorf "Quotation error: can't wrap heterogeneous data. Expected %j, got %j."
                inner-shape
                (get-shape datum))))
    (:new Vector (tuple (length data) ;inner-shape) data)))
    (:new Quotation (tuple (length data) ;inner-shape) data)))

(defmethod pop Stack
  [self]


@@ 91,32 98,31 @@
  [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))))
(defn check-arity
  [stack elem]
  (let [arity (get-arity elem)]
    (when (> arity (size stack))
      (errorf "Not enough stack: %s has arity %i; stack has size %i"
              (string (elem :type))
              arity
              (size stack)))))

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

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

    (def buf @[])
    (loop [_ :range [0 arity]]
      (array/insert buf 0 (pop self)))
    
    (->> (apply-operation op ;buf)
         (make-element)
         (push 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)))
  (check-arity self adv)
  ((adv :fun-ref) self))

(defmulti push [Stack _]
  [self item]

M src/parser.janet => src/parser.janet +6 -2
@@ 15,9 15,13 @@
                 "=" operations/eq
                 "cmp" operations/cmp
                 "/" adverbs/distribute-dyad
                 "!" adverbs/apply-vector
                 "!" adverbs/apply-quotation
                 "@" adverbs/wrap-stack
                 "swap" adverbs/swap})
                 "swap" adverbs/swap
                 "slurp" adverbs/slurp
                 "slurpl" adverbs/slurp-left
                 "slurpr" adverbs/slurp
                 "c" adverbs/clear-stack})

(defn handle-parens
  [& patt]

M src/print.janet => src/print.janet +1 -1
@@ 17,7 17,7 @@
(defmethod p calc/Adverb
  [a] (string (a :type)))

(defmethod p calc/Vector
(defmethod p calc/Quotation
  [v]
  (let [inner (map p (v :data))]
    (string "[" (string/join inner " ") "]")))

M test/calc.janet => test/calc.janet +7 -7
@@ 6,7 6,7 @@
(use testament)
(use /test-support)

(deftest vectors
(deftest quotations
  (def v (wrap 1 2 3))
  (def v2 (wrap 2 5 10))



@@ 20,7 20,7 @@

(deftest matrices
  (is (thrown? (wrap (wrap 1) (wrap 1 2)))
      "Inner vectors are of differing sizes")
      "Inner quotations are of differing sizes")

  (def m (wrap (wrap 1 2 3)
               (wrap 4 5 6)))


@@ 36,7 36,7 @@
        filled)

  (is (thrown? (calc/fill m [2 3 3]))
      "Vectors can be filled into shapes that share a suffix")
      "Quotations can be filled into shapes that share a suffix")

  (vec= @[@[@[2 4 6]
            @[8 10 12]]


@@ 63,10 63,10 @@
  (calc/push s a/distribute-dyad)
  (pop-and-compare 18 s))

(deftest apply-vector
(deftest apply-quotation
  (def s (:new calc/Stack))
  (calc/push s (wrap 1 2 3))
  (calc/push s a/apply-vector)
  (calc/push s a/apply-quotation)
  (pop-and-compare 3 s)
  (pop-and-compare 2 s)
  (pop-and-compare 1 s)


@@ 77,7 77,7 @@
  (calc/push s (:new calc/Int 3))
  (calc/push s (:new calc/Int 5))
  (calc/push s (wrap o/add))
  (calc/push s a/apply-vector)
  (calc/push s a/apply-quotation)
  (pop-and-compare 8 s)
  (is (empty? (s :data))))



@@ 91,7 91,7 @@
  (is (= [2] (calc/shape vec)))
  (is (empty? (s :data))))

(deftest wrap-vectors
(deftest wrap-quotations
  (def s (:new calc/Stack))
  (calc/push s (wrap 1 2))
  (calc/push s (wrap 2 4))

M test/regressions.janet => test/regressions.janet +1 -1
@@ 38,7 38,7 @@
  (def s (:new calc/Stack))
  (let [in (parser/parse "[2 3 4] 1 -")]
    (calc/push-all s in))
  

  (def res (calc/pop s))
  (vec= [1 2 3] res))