Untyped Push Interpreter Prototype

upush.clj

(ns upush
  (:require [clojure.math :refer [log]]
            [clojure.string :as str]
            [clojure.math.combinatorics :refer [selections]]))


(def instructions
  {'+ {:fn +
       :arity 2
       :invariant (fn [a b]
                    (and (number? a) (number? b)))}
   '/ {:fn /
       :arity 2
       :invariant (fn [n d]
                    (and (number? n)
                         (number? d)
                         (not (zero? d))))}
   'log {:fn log
         :arity 1
         :invariant (fn [x]
                      (and (number? x) (pos? x)))}
   'nth {:fn nth
         :arity 2
         :invariant (fn [s idx]
                      (and (or (sequential? s)
                               (string? s))
                           (nat-int? idx)
                           (< idx (count s))))}
   'merge {:fn merge
           :arity 2
           :invariant (fn [a b]
                        (and (map? a)
                             (map? b)))}
   'count {:fn count
           :arity 1
           :invariant (fn [x]
                        (or (coll? x)
                            (string? x)))}})

(defn dropvec
  "Drops items in the vector at `indices`."
  [v indices]
  (let [idxs (set indices)]
    (into []
          (comp (map-indexed (fn [i e] [i e]))
                (remove (fn [[i _]] (contains? idxs i)))
                (map second))
          v)))

(defn interleave-pad
  "Returns a lazy seq of the first item in each coll, then the second etc.
   Fills `pad` when a coll has been totally consumed. 
   Cannot be used with infinite collections.
   
   Modified copy of clojure.core.interleave"
  ([_] ())
  ([_ c1] (lazy-seq c1))
  ([pad c1 c2]
   (lazy-seq
    (let [s1 (seq c1)
          s2 (seq c2)]
      (when (or s1 s2)
        (cons (nth s1 0 pad)
              (cons (nth s2 0 pad)
                    (interleave-pad pad (rest s1) (rest s2))))))))
  ([pad c1 c2 & colls]
   (lazy-seq
    (let [ss (map seq (conj colls c2 c1))]
      (when (some identity ss)
        (concat (map #(nth % 0 pad) ss) (apply interleave-pad pad (map rest ss))))))))

(defn z-order
  [dims]
  (Long/parseLong (->> dims
                       (map #(reverse (Long/toString % 2)))
                       (apply interleave-pad \0)
                       (reverse)
                       (str/join))
                  2))

(defn find-arg-idxs
  [values instruction]
  (->>
   ;; Create a deterministiclly ordered seq of distinct indice combinations of size `:arity`.
   (selections (range (count values))
               (:arity instruction))
   (filter #(apply distinct? %))
   (map vec)
   (sort-by z-order)
   ;; Find first set of indices whose values satisfy the invariant function.
   (filter (fn [idxs]
             (let [;; Get candidate args at given indices
                   args (mapv #(nth values %) idxs)
                   ;; Extract invariant of instruction, default to passing in none.
                   invariant (get instruction :invariant (constantly true))]
               ;; Call invariant check on candidate args.
               (apply invariant args))))
   ;; Take the first set of indices that passes the invariant, null otherwise.
   first))

(defn run
  [program]
  (loop [code program
         values []]
    (println {:code code :values values})
    ;; Check if we are done.
    (if (empty? code)
      ;; Return the first valid return value.
      values
      ;; Evaluate the next Push unit.
      (let [unit (first code)]
        ;; Check if unit is instruction symbol or not.
        (cond
          ;; List units are code blocks to unpack.
          (list? unit)
          (recur (concat (reverse unit) (rest code))
                 values)
          ;; Symbol units are instruction names.
          (symbol? unit)
          (let [;; Get instruction's definition.
                instruction (get instructions unit)
                ;; Attempt to find indices of values that satisfy invariants.
                arg-idxs (find-arg-idxs values instruction)]
            (if (nil? arg-idxs)
              ;; If no complete set of args found, NOOP instruction.
              (recur (rest code)
                     values)
              ;; Perform the instruction.
              (let [args (mapv #(nth values %) arg-idxs)
                    new-value (apply (:fn instruction) args)
                    ;; Remove the consumed args.
                    values-no-args (dropvec values arg-idxs)]
                ;; Push new value to the "stack",
                (recur (rest code)
                       (into [new-value] values-no-args)))))
          ;; Push non-instruction units to the "stack".
          :else
          (recur (rest code)
                 (into [unit] values)))))))

(comment

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Example programs

  ;; Only adding numbers.
  (run (list 1 "A" 2 '+)) ;; => [3 "A"]

  ;; Adding different types of numbers
  (run (list 1.2 0 '+)) ;; => [1.2]

  ;; Zero will never be the denominator.
  (run (list 1 0 '/)) ;; => [0]
  (run (list 0 1 '/)) ;; => [0]

  ;; Can't take the log of a negative number.
  (run (list Math/E 'log)) ;; => [1.0]
  (run (list -5 'log)) ;; => [-5]
  (run (list Math/E -5 'log)) ;; => [1.0 -5]

  ;; Can't index out of bounds.
  (run (list [:a :b :c 1 2 3]
             1
             'nth))
  ;; => [:b]

  (run (list [:a :b :c 1 2 3]
             100
             'nth))
  ;; [100 [:a :b :c 1 2 3]]

  ;; Working with heterogeneous maps 
  ;; Also counting size of anything that can be counted.
  (run (list {:name "push" :version 3}
             {:name "upush" :prototype true}
             'merge
            ;;  "Count this instead."
            ;;  'count
             ))
  ;; => [{:name "upush", :version 3, :prototype true}]


  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;; Finding instruction arguments

  (find-arg-idxs
   [1 :a "B" 2]
   {:arity 2
    :invariant (fn [a b]
                 (and (string? a)
                      (number? b)))}))
    ;; => [2 0]