Stack math evaluator

stack-math.clj

#!/usr/bin/env bb

(ns stack-math
  (:require [clojure.string :as str]
            [clojure.core.match :refer [match]]
            [clojure.tools.cli :as cli]))

(defn parse-stack [s]
  (read-string (format "[%s]" s)))

(def cli-opts
  [["-e" "--eval PROGRAM" "evaluate operations"
    :id :to-eval
    :parse-fn parse-stack]])

(defn pick [stack]
  [(pop stack) (peek stack)])

(defn swap-top [stack f & args]
  (let [[stack x] (pick stack)]
    (conj stack (apply f x args))))

(defn swap-top2 [stack f & args]
  (let [[stack y] (pick stack)
        [stack x] (pick stack)]
    (conj stack (apply f x y args))))

(defmulti op (fn [word _] word))

(defn execute [stack prog]
  (reduce
    (fn [stack word]
      (if (symbol? word)
        (op word stack)
        (conj stack word)))
    stack prog))

;; Stack operations

(defmethod op 'dup [_ stack]
  (let [[stack top] (pick stack)]
    (conj stack top top)))

(defmethod op 'left [_ stack]
  (let [[stack ops] (pick stack)
        [stack top] (if (= 1 (count stack))
                      [stack (peek stack)]
                      (pick stack))]
    (conj (execute stack ops) top)))

(defmethod op 'right [_ stack]
  (let [[stack ops] (pick stack)
        stack (if (= 1 (count stack))
                (conj stack (peek stack))
                stack)]
    (execute stack ops)))

(defmacro defop [nm f & args]
  `(defmethod op '~nm [_ stack#]
     (~f stack# ~@args)))

(defop +                 swap-top2 +)
(defop -                 swap-top2 -)
(defop *                 swap-top2 *)
(defop /                 swap-top2 /)
(defop halve             swap-top / 2)
(defop double            swap-top * 2)
(defop third             swap-top / 3)
(defop triple            swap-top * 3)
(defop two-thirds        swap-top * 2/3)
(defop quarter           swap-top / 4)
(defop quadruple         swap-top * 4)
(defop tenth             swap-top / 10)
(defop tenfold           swap-top * 10)
(defop seven-hundredth   swap-top / 700)
(defop seven-hundredfold swap-top * 700)
(defop hundredth         swap-top / 100)
(defop hundredfold       swap-top * 100)
(defop thousandth        swap-top / 1000)
(defop thousandfold      swap-top * 1000)
(defop four-thousandth   swap-top / 4000)
(defop four-thousandfold swap-top * 4000)
(defop five-thousandth   swap-top / 5000)
(defop five-thousandfold swap-top * 5000)
(defop ten-thousandth    swap-top / 10000)
(defop ten-thousandfold  swap-top * 10000)
(defop +quarter          swap-top * 1.25)
(defop -quarter          swap-top * 0.75)
(defop +half             swap-top * 1.5)
(defop +fifth            swap-top * 1.2)
(defop -fifth            swap-top * 0.8)
(defop +tenth            swap-top * 1.1)
(defop -tenth            swap-top * 0.9)
(defop +twentieth        swap-top * 1.05)
(defop -twentieth        swap-top * 0.95)
(defop sqrt              swap-top #(Math/sqrt %))
(defop square            swap-top #(* % %))
(defop cube-root         swap-top #(Math/cbrt %))
(defop cube              swap-top #(* % % %))

;; Error checking

(defn error [expected actual]
  (if (zero? expected)
    (if (zero? actual)
      0
      ##Inf)
    (let [expected (float expected)]
      (/ (Math/abs (- expected (float actual))) expected))))

(defn sample-error [exact approx]
  (->> [0 1 10 100 1000]
       (sequence
         (comp
           (map #(error
                   (last (execute [%] exact))
                   (last (execute [%] approx))))
           (remove nil?)))
       (apply max)))

(defn find-error [exact approx]
  (match exact
    [x '*] (error x (last (execute [1] approx)))
    [x '/] (error (/ x) (last (execute [1] approx)))
    :else  (sample-error exact approx)))

(defn format-percent [x]
  (let [x (float (* 100 x))
        fmt (if (< 10 x) "%.2g%%" "%.1g%%")]
    (format fmt x)))

(let [{{:keys [to-eval]} :options [exact & approxs] :arguments}
      , (-> (cli/parse-opts *command-line-args* cli-opts)
            (update :arguments (partial map parse-stack)))]
  (cond
    to-eval
    , (println (execute [] to-eval))
    :else
    , (doseq [approx approxs]
        (println (str (str/join " " approx) ":")
                 (format-percent (find-error exact approx))))))