~subsetpark/ec

1e60d23ca0e66745bbf358a6f9dc2c372faade55 — Zach Smith 9 months ago dd1a81d
Working parser and structure
8 files changed, 228 insertions(+), 39 deletions(-)

A .gitignore
A main.janet
A project.janet
A src/adverbs.janet
R calc.janet => src/calc.janet
A src/operations.janet
A src/parser.janet
A test/calc.janet
A .gitignore => .gitignore +1 -0
@@ 0,0 1,1 @@
janet_modules/

A main.janet => main.janet +5 -0
@@ 0,0 1,5 @@
(import /src/calc)

(defn main
  [args]
  (let [s (:new calc/Stack)]))

A project.janet => project.janet +13 -0
@@ 0,0 1,13 @@
(declare-project
  :name "ec"
  :description "a very good calculator"
  :dependencies ["fugue"
                 "https://github.com/pyrmont/testament"])

(def *static-build* (= (or (os/getenv "EC_STATIC_BUILD") "0") "1"))

(declare-executable
  :name "ec"
  :entry "main.janet"
  :lflags (if *static-build* ["-static"] [])
  :install true)

A src/adverbs.janet => src/adverbs.janet +22 -0
@@ 0,0 1,22 @@
(import /src/calc)

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

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

(defadv apply-operation 1
  (let [quoted-verb (calc/pop stack)]
    (each elem (calc/data quoted-verb)
      (calc/push stack elem))))

R calc.janet => src/calc.janet +34 -39
@@ 4,6 4,9 @@

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



@@ 27,50 30,47 @@
  [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))))
                (:new Vector new-shape new-data)))
            self
            (reverse y))))

(defmethod apply-operation Operation
  [op & vectors]
  [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)]
          (f ;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)) vectors))
        filled (map |(fill $ largest) vectors)]
        largest (get-shape (extreme |(> (cmpr $0) (cmpr $1)) args))
        filled (map |(fill $ largest) args)]
    (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)

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


@@ 92,6 92,12 @@
            arity
            (size stack))))

(defn- make-element
  # TODO: Do we want to do something more sophisticated here?
  [elem]
  (cond (number? elem)
        (:new Float elem)))

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


@@ 100,31 106,20 @@
    (def buf @[])
    (loop [_ :range [0 arity]]
      (array/push buf (pop self)))

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

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

A src/operations.janet => src/operations.janet +20 -0
@@ 0,0 1,20 @@
(import /src/calc)

(defmacro defop
  [name arity f]
  ~(def ,name (:new calc/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)
(defop lt 2 (fn [x y] (if (< x y) 1 0)))
(defop gt 2 (fn [x y] (if (> x y) 1 0)))
(defop lte 2 (fn [x y] (if (<= x y) 1 0)))
(defop gte 2 (fn [x y] (if (>= x y) 1 0)))
(defop eq 2 (fn [x y] (if (= x y) 1 0)))
(defop cmp 2 cmp)

A src/parser.janet => src/parser.janet +51 -0
@@ 0,0 1,51 @@
(import /src/calc)
(import /src/operations)
(import /src/adverbs)

(def- dictionary {"+" operations/add
                  "-" operations/sub
                  "*" operations/mul
                  "x" operations/mul
                  "%" operations/div
                  "sqrt" operations/sqrt
                  "/" adverbs/distribute-dyad
                  ">" operations/gt
                  "<" operations/lt
                  ">=" operations/gte
                  "<=" operations/lte
                  "=" operations/eq
                 "cmp" operations/cmp})

(defn handle-parens
  [& patt]
  [:parens (string ;patt)])

(defn handle-brackets
  [& patt]
  (calc/wrap ;patt))

(defn handle-float
  [patt]
  (:new calc/Float (scan-number patt)))

(defn handle-int
  [patt]
  (:new calc/Int (scan-number patt)))

(defn handle-word
  [patt]
  (or (dictionary patt)
      (errorf "syntax error: unknown word %s" patt)))

(def- peg (peg/compile
           ~{:main (any (+ :s+ :brackets :token))
             :brackets (cmt (* "[" :main "]") ,handle-brackets)
             :number-part (some (+ :d "_"))
             :float (cmt (<- (* (? "-") :number-part "." :number-part)) ,handle-float)
             :int (cmt (<- (* (? "-") :number-part)) ,handle-int)
             :word (cmt (<- (some (if-not (+ :s (set "()[]")) 1))) ,handle-word)
             :token (+ :float :int :word)}))

(defn parse
  [str]
  (peg/match peg str))

A test/calc.janet => test/calc.janet +82 -0
@@ 0,0 1,82 @@
(import /src/calc)

(import /src/operations :prefix "o/")
(import /src/adverbs :prefix "a/")

(use testament)
  
(defn- rec-data [vec]
  (match vec
    {:data data} (map rec-data data)
    {:value value} (rec-data value)
    data data))

(defn- vec=
  [val vec]
  (is (== val (rec-data vec))))

(defn- wrap
  [& args]
  (calc/wrap ;(map |(if (number? $)
                      (:new calc/Int $)
                      $)
                   args)))

(deftest vectors
  (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= [-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))

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

(deftest matrices
  (is (thrown? (wrap (wrap 1) (wrap 1 2)))
      "Inner vectors are of differing sizes")
  
  (def m (wrap (wrap 1 2 3)
               (wrap 4 5 6)))
  (is (= [2 3] (calc/get-shape m)))
  
  (def filled (calc/fill m [2 2 3]))
  (is (= [2 2 3] (calc/get-shape filled)))
  
  (vec= @[@[@[1 2 3]
            @[4 5 6]]
          @[@[1 2 3]
            @[4 5 6]]]
        filled)

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

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

(deftest distribute-dyad-add
  (def s (:new calc/Stack))
  # Initial value
  (calc/push s (:new calc/Int 0))
  # Operands
  (calc/push s (wrap 1 2 3))
  # Operator
  (calc/push s (wrap o/add))
  (calc/push s a/distribute-dyad)
  (is (= 6 (calc/value (calc/peek s)))))

(deftest distribute-dyad-multiple-operations
  (def s (:new calc/Stack))
  (calc/push s (:new calc/Int 0))
  (calc/push s (wrap 1 2 3))
  (calc/push s (wrap 3 o/mul o/add))
  (calc/push s a/distribute-dyad)
  (is (= 18 (calc/value (calc/peek s)))))

(run-tests!)