Most of the code behind http://gfredericks.com/sandbox/AYNI42

AYNI42.cljc

(ns forty-two-doubles.core
  (:require [clojure.walk :as walk]
            [clojure.string :as string]
            #?(:clj [com.gfredericks.doubles :refer [parse-double]])
            [forty-two-doubles.four :as four #?@(:cljs [:include-macros true])]
            [plumbing.core :as p]))

(defn positive-infinity?
  [x]
  #?(:clj (= x Double/POSITIVE_INFINITY)
     :cljs (and (not (js/isFinite x))
                (< 0.0 x))))

(defn negative-infinity?
  [x]
  #?(:clj (= x Double/NEGATIVE_INFINITY)
     :cljs (and (not (js/isFinite x))
                (< x 0.0))))

(defn NaN?
  [x]
  #?(:clj (Double/isNaN x)
     :cljs (js/isNaN x)))

(defn finite?
  [^double x]
  #?(:clj
     (not (or (Double/isNaN x)
              (Double/isInfinite x)))
     :cljs
     (js/isFinite x)))

(defn nonzero-finite?
  [x]
  (and (finite? x) (not (zero? x))))

(defn distance
  [^double x]
  {:pre [(finite? x)]}
  #?(:clj
     (+ (Math/abs (Math/getExponent x))
        (* 2000
           (- 66 (Long/numberOfTrailingZeros
                  (last (parse-double x))))))
     :cljs
     (cond (zero? x)
           1

           (neg? x)
           (inc (distance (- x)))

           :else
           (loop [a 0
                  x x]
             (cond
               (< x 0.5)
               (recur (inc a) (* x 2))

               (<= 1 x)
               (recur (inc a) (/ x 2))

               :else
               (loop [ret 0
                      x x]
                 (if (zero? x)
                   (+ a (* 2000 ret))
                   (recur (inc ret) (mod (* 2 x) 1)))))))))

(defn derived-exprs*
  [pairs-by-expr-size already-expressed? expr-size]
  (p/distinct-by
   first
   (for [left-size (range 1 (inc (quot expr-size 2)))
         [left-val left-expr] (four/shuffle (pairs-by-expr-size left-size))
         [right-val right-expr] (four/shuffle (pairs-by-expr-size (- expr-size
                                                                     left-size)))

         [op op-name flip?] [[+ '+ (zero? (four/rand-int 2))]
                             [- '- false]
                             [- '- true]
                             [* '* (zero? (four/rand-int 2))]
                             [/ '/ false]
                             [/ '/ true]]
         :let [[left-val left-expr right-val right-expr]
               (if flip?
                 [right-val right-expr left-val left-expr]
                 [left-val left-expr right-val right-expr])]
         :when (not (= ['/ 0.0] [op-name right-val]))
         :let [val (op left-val right-val)]
         :when (finite? val)
         :when (not (already-expressed? val))]
     [val (vary-meta (list op-name left-expr right-expr)
                     assoc ::val val)])))

(defn derived-exprs
  "Returns a lazy-seq of [x expr]."
  [a-sorted-set]
  ((fn self [pairs-by-expr-size already-expressed? expr-size]
     (lazy-seq
      (let [more-pairs (derived-exprs* pairs-by-expr-size already-expressed? expr-size)]
        (concat more-pairs
                (lazy-seq
                 (self (assoc pairs-by-expr-size expr-size more-pairs)
                       (into already-expressed? (map first more-pairs))
                       (inc expr-size)))))))
   {1 (for [x (four/shuffle a-sorted-set)] [x x])}
   a-sorted-set 2))

(defn lazy-shuffle
  [window-size coll]
  (let [[xs more] (split-at window-size coll)]
    (if (seq more)
      ((fn self [vec more]
         (if (empty? more)
           vec
           (lazy-seq
            (let [[x & more] more
                  idx (four/rand-int window-size)]
              (cons (get vec idx)
                    (self (assoc vec idx x) more))))))
       (vec (four/shuffle xs))
       more)
      (four/shuffle xs))))

(defn expr-replace
  [expr replacement-map]
  (walk/postwalk (fn [x] (if-let [[_ v] (find replacement-map x)]
                           v
                           x))
                 expr))

(defn help-me-express-this
  "Returns either
   [:expressed expr]
  or
   [:closer derived-number derived-expr derived-name full-expr new-number-to-express]."
  [number-to-express set-of-numbers-I-have]
  (if (set-of-numbers-I-have number-to-express)
    [:expressed number-to-express]
    (try
      (let [current-distance (distance number-to-express)
            a-gensym (gensym)
            firstish (fn [pairs]
                       (let [[pair & more-pairs] (drop-while (comp not second) pairs)]
                         (when-let [[idx ret] pair]
                           ;; looking at at least 1000 to make sure we
                           ;; get the best option
                           (->> (cons pair (take (max (* 2 (inc idx)) 400) more-pairs))
                                (map second)
                                (filter identity)
                                (apply min-key (fn [ret]
                                                 (-> ret
                                                     meta
                                                     ::distance
                                                     (or (throw (ex-info "WTF"
                                                                         {:ret ret}))))))))))]
        (or
         (firstish
          (map vector (range)
               (for [[expressable expr] (->> set-of-numbers-I-have
                                             (derived-exprs)
                                             (lazy-shuffle 100)
                                             ;; gotta timeout somehow
                                             (take 1000000)
                                             (concat (for [x set-of-numbers-I-have]
                                                       [x x])))
                     ;; flow control is fun
                     :let [_ (if (= number-to-express expressable)
                               (throw (ex-info "" {::ret [:expressed expr]})))
                           num number-to-express]
                     [simpler-num works? ret]
                     [(let [simpler-num (- num expressable)]
                        [simpler-num (= num (+ expressable simpler-num))
                         (list '+ a-gensym simpler-num)])
                      (let [simpler-num (- expressable num)]
                        [simpler-num (= num (- expressable simpler-num))
                         (list '- a-gensym simpler-num)])
                      (let [simpler-num (+ num expressable)]
                        [simpler-num (= num (- simpler-num expressable))
                         (list '- simpler-num a-gensym)])
                      (when (not= expressable 0.0)
                        (let [simpler-num (/ num expressable)]
                          [simpler-num (= num (* expressable simpler-num))
                           (list '* a-gensym simpler-num)]))
                      (when (not= num 0.0)
                        (let [simpler-num (/ expressable num)]
                          (when (not= simpler-num 0.0)
                            [simpler-num (= num (/ expressable simpler-num))
                             (list '/ a-gensym simpler-num)])))
                      (when (not= expressable 0.0)
                        (let [simpler-num (* num expressable)]
                          [simpler-num (= num (/ simpler-num expressable))
                           (list '/ simpler-num a-gensym)]))]
                     :let [new-distance (and simpler-num
                                             (finite? simpler-num)
                                             (distance simpler-num))]]
                 (and works?
                      (finite? simpler-num)
                      (< new-distance current-distance)
                      (let [name (gensym)]
                        (vary-meta
                         (if (number? expr)
                           [:closer-reused-num expressable a-gensym ret simpler-num]
                           [:closer-new-num expressable expr a-gensym ret simpler-num])
                         assoc ::distance new-distance))))))
         (throw (ex-info "Can't express!" {:num number-to-express}))))
      (catch #?(:clj clojure.lang.ExceptionInfo :cljs js/Error) e
        (or (::ret (ex-data e))
            (throw e))))))

(defn rename-bindings
  [let-expr]
  (let [[new-bindings replacement]
        (reduce (fn [[new-bindings replacement next-num] [name expr]]
                  (if (symbol? expr)
                    [new-bindings (assoc replacement name (get replacement expr)) next-num]
                    (if (number? expr)
                      [new-bindings (assoc replacement name expr) next-num]
                      (let [sym (symbol (str \x next-num))
                            expr' (expr-replace expr replacement)
                            replacement' (assoc replacement name sym)]
                        [(conj new-bindings [sym expr']) replacement' (inc next-num)]))))
                [[] {} 1]
                (partition 2 (second let-expr)))]
    `(~'let [~@(apply concat new-bindings)] ~(expr-replace (last let-expr) replacement))))

(defn special-cases
  [base special-case]
  {:pre [(nonzero-finite? base)]}
  (letfn [(f [current-base current-name bindings next-local-id]
            (let [next-num (* current-base current-base)
                  expr (list '* current-name current-name)]
              (if (positive-infinity? next-num)
                [bindings expr]
                (let [next-name (symbol (str "x" next-local-id))]
                  (recur next-num next-name (conj bindings [next-name expr]) (inc next-local-id))))))
          (make-inf []
            (if (< (* base base) 2.0)
              (f 2.0 'x1 [['x1 (list '+ (list '/ base base) (list '/ base base))]] 2)
              (f base base [] 1)))]

    (case special-case
      :+∞ (let [[bindings expr] (make-inf)]
            `(~'let [~@(apply concat bindings)] ~expr))
      :-∞ (let [[bindings expr] (make-inf)
                name1 (symbol (str "x" (inc (count bindings))))]
            `(~'let [~@(apply concat bindings) ~name1 ~expr] (~'- ~base ~name1)))
      :NaN (let [[bindings expr] (make-inf)
                 name1 (symbol (str "x" (inc (count bindings))))]
             `(~'let [~@(apply concat bindings) ~name1 ~expr]
               (~'- ~name1 ~name1)))
      :-0 (if (neg? base)
            `(~'let [~'x1 (~'- ~base ~base)]
              (~'/ ~'x1 ~base))
            `(~'let [~'x1 (~'- ~base ~base)
                     ~'x2 (~'- ~'x1 ~base)]
              (~'/ ~'x1 ~'x2))))))

(defn neg-zero?
  [^double x]
  (and (zero? x)
       (< (/ 1 x) 0)))

(defn interpret
  "Returns a new expression where every relevant sub-expression has had
  ::val metadata added."
  ([expr] (interpret expr {}))
  ([expr locals]
   (cond (number? expr) expr
         (symbol? expr) (vary-meta expr assoc ::val (get locals expr))

         (seq? expr)
         (case (first expr)
           (+ - * /)
           (let [args (map #(interpret % locals) (rest expr))
                 get-val #(if (number? %)
                            % (::val (meta %)))
                 _ (when-not (every? get-val args)
                     (throw (ex-info "HOOOW" {:args args :locals locals})))

                 val (apply (case (first expr) + + - - * * / /)
                            (map get-val args))]
             (vary-meta (cons (first expr) args)
                        assoc ::val val))

           let
           (let [[_ bindings body-expr] expr
                 [new-bindings out-locals]
                 (reduce (fn [[new-bindings out-locals] [n expr]]
                           (let [expr' (interpret expr out-locals)]
                             [(conj new-bindings [n expr'])
                              (assoc out-locals n (::val (meta expr')))]))
                         [[] locals]
                         (partition 2 bindings))

                 new-body-expr (interpret body-expr out-locals)]
             (vary-meta `(~'let [~@(apply concat new-bindings)] ~new-body-expr)
                        assoc ::val (if (number? new-body-expr)
                                      new-body-expr
                                      (::val (meta new-body-expr))))))

         :else
         (throw (ex-info "Unknown expr" {:expr expr})))))

(defn get-meta-val
  [expr]
  (if (number? expr) expr (::val (meta expr))))

(defn =doubles?
  "Like =, but only works on two doubles, considers two NaNs to be equal, and
  doesn't consider 0 to equal -0."
  [x y]
  (if (= x y)
    (= (neg-zero? x) (neg-zero? y))
    (and (NaN? x) (NaN? y))))

(defn express*
  [x bound-nums]
  (if-let [sym (bound-nums x)]
    [[] sym]
    (let [ret (help-me-express-this x (apply sorted-set (keys bound-nums)))]
      (case (first ret)
        :expressed
        [[] (second ret)]

        :closer-reused-num
        (let [[_ used-number used-name full-expr new-number-to-express] ret
              full-expr (expr-replace full-expr {used-name (bound-nums used-number)})
              [new-bindings expr] (express* new-number-to-express bound-nums)
              new-number-name (gensym)]
          [(concat new-bindings
                   [[new-number-name (expr-replace expr bound-nums)]])
           (expr-replace full-expr {new-number-to-express new-number-name})])

        :closer-new-num
        (let [[_ derived-number derived-expr derived-name full-expr new-number-to-express] ret
              bound-nums2 (assoc bound-nums derived-number derived-name)
              [new-bindings expr] (express* new-number-to-express bound-nums2)
              derived-expr' (expr-replace derived-expr bound-nums)
              new-number-name (gensym)]
          [(concat [[derived-name derived-expr']]
                   new-bindings
                   [[new-number-name (expr-replace expr bound-nums2)]])
           (expr-replace full-expr {new-number-to-express new-number-name})])))))

(def leaf? (some-fn symbol? number?))

(defn flatten-exprs
  [[_let bindings expr]]
  (let [flatten-expr (fn flatten-expr [expr]
                       (if (leaf? expr)
                         [[] expr]
                         (do
                           (assert (= 3 (count expr)))
                           (assert (symbol? (first expr)))
                           (let [[b1 expr1] (flatten-expr (second expr))
                                 [b2 expr2] (flatten-expr (last expr))
                                 name1 (gensym)
                                 name2 (gensym)]
                             [(-> b1
                                  (into b2)
                                  (cond->
                                    (coll? expr1)
                                    (conj [name1 expr1])

                                    (coll? expr2)
                                    (conj [name2 expr2])))
                              (list (first expr)
                                    (if (coll? expr1)
                                      name1
                                      expr1)
                                    (if (coll? expr2)
                                      name2
                                      expr2))]))))
        bindings (reduce (fn [bindings [n expr]]
                           (let [[new-bindings expr] (flatten-expr expr)]
                             (-> bindings
                                 (into new-bindings)
                                 (conj [n expr]))))
                         []
                         (partition 2 bindings))
        [yet-more-bindings expr] (flatten-expr expr)]
    `(~'let [~@(apply concat (into bindings yet-more-bindings))] ~expr)))

(defn remove-redundant-exprs
  "Sometimes flatten-exprs reveals redundant expressions."
  [let-expr]
  (let [[_let bindings expr] (interpret let-expr)
        [bindings replacements]
        (reduce (fn [[out-bindings replacements val->sym] [n v]]
                  (let [val (get-meta-val v)]
                    (if-let [sym (val->sym val)]
                      [out-bindings (assoc replacements n sym)
                       val->sym]
                      [(conj out-bindings [n (expr-replace v replacements)])
                       replacements
                       (assoc val->sym val n)])))
                [[] {} {}]
                (partition 2 bindings))]
    `(~'let [~@(apply concat bindings)]
      ~(expr-replace expr replacements))))

(defn express
  [x base]
  {:post [(=doubles? x (-> % meta ::val))]}
  (interpret
   (cond
     (positive-infinity? x)
     (special-cases base :+∞)

     (negative-infinity? x)
     (special-cases base :-∞)

     (NaN? x)
     (special-cases base :NaN)

     (neg-zero? x)
     (special-cases base :-0)

     :else
     (four/with-seed (hash (str x))
       (let [[new-bindings expr] (express* x {base 'x0})
             x0->42 #(expr-replace % {'x0 base})
             new-bindings (for [[k v] new-bindings]
                            [k (x0->42 v)])]
         (-> `(~'let [~@(apply concat new-bindings)] ~(x0->42 expr))
             flatten-exprs
             ;; running rename-bindings an extra time here because it
             ;; also removes right-hand-side-number-literals from the
             ;; let bindings and remove-redundant-exprs seems to need
             ;; that.
             rename-bindings
             remove-redundant-exprs
             rename-bindings))))))

(defn print-aligned
  [line-pairs]
  (let [max-len-first (->> line-pairs (map first) (map count) (apply max))]
    (doseq [[s1 s2] line-pairs
            :let [spacing (apply str (repeat (- max-len-first (count s1)) \space))]]
      (println s1 spacing s2))))

(defn num->str
  [x]
  #?(:clj (pr-str x)
     :cljs (if (neg-zero? x)
             "-0.0"
             (let [s (pr-str x)]
               (if (re-matches #"-?\d+" s)
                 (str s ".0")
                 s)))))

(defn expr->js
  ([expr] (expr->js expr false))
  ([expr parens?]
   (cond (number? expr)
         (num->str expr)

         (symbol? expr)
         (str expr)

         :else
         (do
           (assert (= 3 (count expr)))
           (let [[op arg1 arg2] expr]
             (str (if parens? "(" "")
                  (expr->js arg1 true)
                  " " op " "
                  (expr->js arg2 true)
                  (if parens? ")" "")))))))

(defn expr->clj
  "Like pr-str, but prints numbers with decimal points even in cljs."
  [expr]
  (cond (number? expr)
        (num->str expr)

        (symbol? expr)
        (str expr)

        :else
        (str "(" (string/join " " (map expr->clj expr)) ")")))

(defn print-clj
  [[_let bindings expr]]
  (if (empty? bindings)
    (println (expr->clj expr) ";;" (num->str (get-meta-val expr)))
    (let [bindings (partition 2 bindings)
          name-length (->> bindings (map first) (map str) (map count) (apply max))
          binding-prefixes (cons "(let [" (repeat "      "))
          binding-suffixes (concat (repeat (dec (count bindings)) "")
                                   ["]"])]
      (print-aligned
       (concat
        (for [[prefix [n v] suffix] (map vector binding-prefixes bindings binding-suffixes)]
          [(str prefix n " " (expr->clj v) suffix)
           (str ";; " n " = " (num->str (get-meta-val v)))])
        [[(str "  " (expr->clj expr) ")") (str ";; " (num->str (get-meta-val expr)))]])))))

(defn print-js
  [[_let bindings expr]]
  (println "(function(){")
  (print-aligned
   (concat (for [[n v] (partition 2 bindings)]
             [(str "   var " n " = " (expr->js v) ";")
              (str "// " n " = " (num->str (get-meta-val v)))])
           [[(str "   return " (expr->js expr) ";")
             (str "// " (num->str (get-meta-val expr)))]]))
  (println "}())"))

(defn print-ruby
  [[_let bindings expr]]
  (println "(lambda do")
  (print-aligned
   (concat (for [[n v] (partition 2 bindings)]
             [(str "   " n " = " (expr->js v))
              (str "# " n " = " (num->str (get-meta-val v)))])
           [[(str "   return " (expr->js expr))
             (str "# " (num->str (get-meta-val expr)))]]))
  (println "end).call()"))

(defn print-java
  [[_let bindings expr]]
  (println "(new java.util.concurrent.Callable<Double>(){")
  (println "   public Double call(){")
  (print-aligned
   (concat (for [[n v] (partition 2 bindings)]
             [(str "     double " n " = " (expr->js v) ";")
              (str "// " n " = " (num->str (get-meta-val v)))])
           [[(str "     return " (expr->js expr) ";")
             (str "// " (num->str (get-meta-val expr)))]]))
  (println "   }")
  (println " }).call()"))

(defn print-python
  [[_let bindings expr]]
  (println "def num_from_42s():")
  (print-aligned
   (concat (for [[n v] (partition 2 bindings)]
             [(str "    " n " = " (expr->js v))
              (str "# " n " = " (num->str (get-meta-val v)))])
           [[(str "    return " (expr->js expr))
             (str "# " (num->str (get-meta-val expr)))]])))