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

@@ 0,0 1,1 @@
+janet_modules/

@@ 0,0 1,5 @@
+(import /src/calc)
+
+(defn main
+  [args]
+  (let [s (:new calc/Stack)]))

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

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

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

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

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

@@ 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!)