~subsetpark/ec

90ec763d7df1952b79d9c13cfd13f9f5b9e9818c — Zach Smith 9 months ago cb90476
Some help functions
M lockfile.jdn => lockfile.jdn +1 -1
@@ 1,3 1,3 @@
@[{:sha "12e2e338cba69b02f284d8082804d8e811436651" :repo "https://github.com/pyrmont/testament"}
  {:sha "3755e2108dca1322b0a0d1a1340be5c0c7a0abcd" :repo "https://github.com/janet-lang/pkgs.git"}
  {:sha "9b316a3a0b23df8672867b9bc25775aab53f77c3" :repo "https://git.sr.ht/~subsetpark/fugue"}]
  {:sha "e1527e635cce580d537b5fa1a4787cbac67a2367" :repo "https://git.sr.ht/~subsetpark/fugue"}]

M main.janet => main.janet +23 -1
@@ 13,13 13,35 @@
    (print (string/join inner " ")))
  "")

(defn display-help
  []
  (each [k v] (pairs parser/dictionary)
    (printf "%s: %s" k (string (v :type))))
  "")

(defn describe
  [elem]
  (printf "%s: %s"
          (string (elem :type))
          (elem :doc)))

(defn describe-all
  [q]
  (each item (q :data)
    (describe item))
  "")

(defn handle-commands
  [in s]

  (when (= (string in) "") (os/exit 0))

  (case (freeze (string/trim in))
    "" (os/exit 0)
    "." (display (calc/peek s))
    "p" (display (calc/pop s))
    "s" (display-all (s :data))
    "?" (describe-all (calc/pop s))
    "??" (display-help)
    in))

(defn repl

M src/adverbs.janet => src/adverbs.janet +95 -16
@@ 1,51 1,95 @@
(import /src/calc)

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

(defadv distribute-dyad 3
(defadv apply-quotation 1
  ```
  q -- x
  "Unwrap" a quotation and push its elements onto the stack.
  `1 1 [+] apply` is equivalent to `1 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 distribute 0
  ```
  v q -- x
  Insert the contents of quotation `q` in between every element of
  `v`. If `v` is not a quotation, then `distribute` is equivalent to
  `apply`.
  ```
  (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)
      (error "Distribute error: top argument must be a quotation"))

    (defn push-verb []
      (calc/check-arity stack quotation)

      (each verb-elem (calc/data quotation)
        (calc/push stack verb-elem)))))
        (calc/push stack verb-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))))
    (if (calc/Quotation? object)
      (each elem (calc/data object)
        (calc/push stack elem)
        (push-verb))
      (do
        (calc/push stack object)
        (push-verb)))))

(defadv wrap-stack 0
  ```
  (x) -- q
  Wrap the entire stack in a quotation. 
  ```
  (let [v (calc/wrap ;(stack :data))]
    (array/clear (stack :data))
    (calc/push stack v)))

(defadv clear-stack 0
  ```
  x -- 
  Clear the entire stack.
  ```
  (array/clear (stack :data)))

(defadv dup 1
  ```
  a --- a a
  Duplicate the top element on the stack.
  ```
  (let [top (calc/peek stack)]
    (calc/push stack top)))

(defadv swap 2
  ```
  a b -- b a
  Swap the two top elements on the stack.
  ```
  (let [top (calc/pop stack)
        second (calc/pop stack)]
    (calc/push stack top)
    (calc/push stack second)))

(defadv slurp 2
  ```
  q a -- q
  If the second element on the stack `q` is a quotation, includes the
  topmost element as the last item in `q`.

  If either element is a quotation, wraps the two top elements in a
  quotation.
  ```
  (let [elem (calc/pop stack)
        quotation (calc/pop stack)
        new-quotation (if (calc/Quotation? quotation)


@@ 54,9 98,44 @@
    (calc/push stack new-quotation)))

(defadv slurp-left 2
  ```
  a q -- q
  If the topmost element on the stack `q` is a quotation, includes the
  second element as the first item in `q`.
  
  If either element is a quotation, wraps the two top elements in a
  quotation.
  ```
  (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)))

(defadv fill 2
  ```
  a s -- a'
  Given a quotation shape `s`, repeats the element `a` until it has
  that shape.
  ```
  (let [shape (calc/pop stack)
        elem (calc/pop stack)]

    (unless (calc/shape? shape)
      (error "Fill error: top argument must be a shape"))

    (let [unwrapped-shape (map |($ :value) (shape :data))
          new-quotation (calc/fill elem unwrapped-shape)]
      (calc/push stack new-quotation))))

(defadv arity 1
  ```
  a -- n
  Returns the number of stack elements that `a` would consume if it
  were pushed to the stack.
  ```
  (let [elem (calc/pop stack)]
    (let [arity (calc/get-arity elem)
          new-elem (calc/make-element arity)]
      (calc/push stack new-elem))))

M src/calc.janet => src/calc.janet +38 -8
@@ 2,13 2,30 @@

(defproto Stack () data {:default @[]})

(defproto Element ())
(defproto Element ()
  doc {:default ""})

(defproto Int Element value {:init? true})
(defproto Float Element value {:init? true})
(defproto Number Element
  out-arity {:allocate-value 1})

(defproto Operation Element type {} arity {:default 0} fun-ref {})
(defproto Adverb Element type {} arity {:default 0})
(defproto Int Number
  type {:allocate-value :integer}
  value {:init? true})

(defproto Float Number
  type {:allocate-value :float}
  value {:init? true})

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

(defproto Adverb Element
  type {}
  arity {}
  out-arity {})

(defproto Quotation Element
  shape {:default [] :init? true}


@@ 18,11 35,19 @@
(defgeneric get-shape [_] [])
(defmethod get-shape Quotation [self] (self :shape))

(defgeneric get-arity [_] -1)
(defgeneric get-arity [_] 0)
(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)))
  (def arities @[])
  (loop [i :range [0 (length (q :data))]]
    (if (zero? i)
      (array/push arities (get-arity ((q :data) i)))
      (array/push arities
                  (+ (last arities)
                     (- (get-arity ((q :data) i))
                        (((q :data) (dec i)) :out-arity))))))
  (max ;arities))

(defgeneric fill
  [element shape-to-fill]


@@ 53,7 78,8 @@
            (reverse y))))

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

(defn- inner-apply


@@ 132,3 158,7 @@
  [stack args]
  (each arg args
    (push stack arg)))

(defn shape?
  [obj]
  (and (Quotation? obj) (all Number*? (obj :data))))

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

(defmacro defcompose
  [name arity & words]
  ~(def ,name (:new calc/Adverb
                    :arity ,arity
                    :type ,(keyword name)
                    :fun-ref (fn ,name [stack]
                               ,;(seq [word :in words]
                                   ~(calc/push stack ,word))))))

(defcompose square 1 adverbs/dup operations/mul)

M src/operations.janet => src/operations.janet +20 -12
@@ 1,20 1,28 @@
(import /src/calc)

(defmacro defop
  [name arity f]
  [name arity out-arity f]
  ~(def ,name (:new calc/Operation
                    :arity ,arity
                    :out-arity ,out-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)
(defmacro defcmp
  [name arity out-arity cmp]
  ~(defop ,name ,arity ,out-arity
     (fn [x y] (if (,cmp x y) 1 0))))

(defop add 2 1 +)
(defop sub 2 1 -)
(defop div 2 1 /)
(defop mul 2 1 *)
(defop cmp 2 1 cmp)
(defop pow 2 1 math/pow)
(defop sqrt 1 1 math/sqrt)

(defcmp lt 2 1 <)
(defcmp gt 2 1 >)
(defcmp lte 2 1 <=)
(defcmp gte 2 1 >=)
(defcmp eq 2 1 =)

M src/parser.janet => src/parser.janet +16 -4
@@ 1,6 1,7 @@
(import /src/calc)
(import /src/operations)
(import /src/adverbs)
(import /src/compose)

(def dictionary {"+" operations/add
                 "-" operations/sub


@@ 14,14 15,23 @@
                 "<=" operations/lte
                 "=" operations/eq
                 "cmp" operations/cmp
                 "/" adverbs/distribute-dyad
                 "pow" operations/pow

                 "distribute" adverbs/distribute
                 "/" adverbs/distribute
                 "apply" adverbs/apply-quotation
                 "!" adverbs/apply-quotation
                 "@" adverbs/wrap-stack
                 "swap" adverbs/swap
                 "slurp" adverbs/slurp
                 "slurpl" adverbs/slurp-left
                 "slurpr" adverbs/slurp
                 "c" adverbs/clear-stack})
                 "c" adverbs/clear-stack
                 "fill" adverbs/fill
                 "dup" adverbs/dup
                 "arity" adverbs/arity

                 "sqr" compose/square})

(defn handle-parens
  [& patt]


@@ 33,11 43,13 @@

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

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

(defn handle-word
  [patt]

M test/calc.janet => test/calc.janet +24 -4
@@ 44,7 44,7 @@
            @[8 10 12]]]
        (calc/apply-operation o/add m filled)))

(deftest distribute-dyad-add
(deftest distribute-add
  (def s (:new calc/Stack))
  # Initial value
  (calc/push s (:new calc/Int 0))


@@ 52,15 52,15 @@
  (calc/push s (wrap 1 2 3))
  # Operator
  (calc/push s (wrap o/add))
  (calc/push s a/distribute-dyad)
  (calc/push s a/distribute)
  (pop-and-compare 6 s))

(deftest distribute-dyad-multiple-operations
(deftest distribute-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)
  (calc/push s a/distribute)
  (pop-and-compare 18 s))

(deftest apply-quotation


@@ 109,4 109,24 @@
        (calc/push s a/wrap-stack))
      "Wrapping a stack requires homogeneous data"))

(deftest get-arity
  (is (= 2 (calc/get-arity (wrap o/add)))
      "A quoted operation's arity is the operation's arity")
  (is (= 3 (calc/get-arity (wrap o/add o/add)))
      ```
      A composition of operations' arity is the greatest of the
      individual operations' arities, each adjusted for the out-arity
      of the one prior
      ```)
  (is (= 2 (calc/get-arity (wrap o/add 2 o/add)))
      "Interposed numbers will reduce the arity of a quotation")
  (is (= 0 (calc/get-arity (:new calc/Int 2)))
      "A number's arity is 0")
  (is (= 0 (calc/get-arity (wrap 2)))
      "A quoted number's arity is 0")
  (is (= 0 (calc/get-arity (wrap 2 2 2 2)))
      "A quoted sequence of numbers is 0")
  (is (= 0 (calc/get-arity (wrap 2 2 o/add)))
      "A quoted operation is 0 if the quote enough values to fulfill it"))

(run-tests!)

M test/parser.janet => test/parser.janet +1 -1
@@ 34,7 34,7 @@
    (is (= add o/add))
    (is (calc/Operation? add))

    (is (= dist a/distribute-dyad))
    (is (= dist a/distribute))
    (is (calc/Adverb? dist))))

(deftest pushable