Quarto stalement counter

quarto.clj

(ns quarto.core
  "Trying to count the number of stalemate positions in quarto."
  (:refer-clojure :exclude [bit-clear bit-test])
  (:require [clojure.set :as sets]))

(def quadruples
  #{#{0 1 2 3} #{4 5 6 7} #{8 9 10 11} #{12 13 14 15}
    #{0 4 8 12} #{1 5 9 13} #{2 6 10 14} #{3 7 11 15}
    #{0 5 10 15} #{3 6 9 12}})

(defn ! [n]
  (reduce * (range 1 (inc n))))

(defn choose [n m] (/ (! n) (! m) (! (- n m))))

(! 8) 40320
(choose 16 8) 12870
(* 40320 12870 (! 8))
(! 16) 20922789888000

(choose 16 4) 1820
(! 12) 479001600
(! 4) 24

;; So a seed is identified by [#{a b c d} e]
;; where e is one of a,b,c,d but not the least.

;; Seeds:
;; X _ _ X
;; _ _ _ _
;; _ _ _ _
;; X _ _ X

(def search-tree-steps
  (:steps
   (reduce
    (fn [{:keys [vars steps quads-left]} new-var]
      (let [vars' (conj vars new-var)
            new-quads (set (filter #(sets/subset? % vars') quads-left))
            step {:var   new-var
                  :quads new-quads}]
        {:vars       vars'
         :steps      (conj steps step)
         :quads-left (sets/difference quads-left new-quads)}))
    {:vars       #{0 3 12 15}
     :steps      []
     :quads-left quadruples}
    ;; this order can be optimized...maybe we can compute the optimal order?
    [5 10 9 6 1 2 4 8 7 11 13 14])))

(defn different?
  [nums]
  (every? (fn [i]
            (let [mask (bit-shift-left 1 i)]
              (apply not= (map (partial bit-and mask) nums))))
          (range 4)))

(defn stalemate-count
  [corners distinguished]
  {:pre [(not= (apply min corners) distinguished)]}
  (let [[a b c] (->> corners
                     (remove #{distinguished})
                     (sort))
        grid (-> (vec (repeat 16 nil))
                 (assoc 0 a)
                 (assoc 3 b)
                 (assoc 12 c)
                 (assoc 15 distinguished))
        nums-left (set (remove (set corners) (range 16)))]
    ((fn f [grid nums-left steps]
       (if-let [[{:keys [var quads]} & more] (seq steps)]
         (->> nums-left
              (map (fn [choice]
                     (let [grid' (assoc grid var choice)]
                       #_(when-let [bad-quad
                                  (->> quads
                                       (remove (fn [q]
                                                 (every? grid' q)))
                                       (first))]
                         (throw (ex-info "POOP"
                                         {:grid' grid'
                                          :quad bad-quad})))
                       (if (every? (fn [quad]
                                     (different? (map grid' quad)))
                                   quads)
                         (f grid' (disj nums-left choice) more)
                         0))))
              (reduce +))
         ;; base case -- we have a complete stalemate
         1))
     grid
     nums-left
     search-tree-steps)))

;; Basic macro version

(defn var-name [n] (symbol (str \x n)))

(defmacro not=*
  [& args]
  (let [v (gensym)]
    `(let [~v ~(first args)]
       ~(reduce (fn [form arg]
                  `(if (= ~arg ~v)
                     ~form
                     true))
                false
                (rest args)))))

(defmacro bit-test
  [x n]
  `(if (zero? (bit-and ~x (bit-shift-left 1 ~n))) false true))

(defmacro bit-clear
  [x n]
  `(bit-and ~x (bit-not (bit-shift-left 1 ~n))))

(defmacro stalemate-count-1*
  [x0 x3 x12 x15]
  (let [available (gensym "available")]
    `(let [~(var-name 0) ~x0
           ~(var-name 3) ~x3
           ~(var-name 12) ~x12
           ~(var-name 15) ~x15
           ~available (reduce bit-set 0 (remove #{~@(map var-name [0 3 12 15])}
                                                (range 16)))]
       ~((fn f [steps]
           (if-let [[{:keys [var quads]} & more] (seq steps)]
             `(loop [total# 0
                     choice# 0]
                (if (= 16 choice#)
                  total#
                  (recur (if (bit-test ~available choice#)
                           (let [~(var-name var) choice#]
                             (if (and ~@(for [quad quads
                                              att (range 4)]
                                          (list* `not=*
                                                 (for [var quad
                                                       :let [name (var-name var)]]
                                                   `(bit-test ~name ~att)))))
                               (+ total# (let [~available (bit-clear ~available choice#)]
                                           ~(f more)))
                               total#))
                           total#)
                         (inc choice#))))
             1))
         search-tree-steps))))

(defn stalemate-count-1
  [corners distinguished]
  (let [[a b c] (->> corners
                     (remove #{distinguished})
                     (sort))]
    (stalemate-count-1* a b c distinguished)))


(defmacro read-num
  "Macro for reading a 4-bit number from a 64-bit long that
  is a logical 16-value array."
  [long i]
  `(let [shift-amt# (bit-shift-left ~i 2)]
     (-> ~long
         (bit-shift-right shift-amt#)
         (bit-and 15))))

(defmacro write-num
  "Macro for writing a 4-bit number to a 64-bit long that
  is a logical 16-value array."
  [long i num]
  `(let [shift-amt# (bit-shift-left ~i 2)
         mask#      (bit-not (bit-shift-left 15 shift-amt#))]
     (-> ~long
         (bit-and mask#)
         (bit-or (bit-shift-left ~num shift-amt#)))))

(defmacro push-num [long num] `(-> ~long (bit-shift-left 4) (bit-or ~num)))
(defmacro pop-num [long] `(bit-shift-right ~long 4))
(defmacro peek-num [long] `(bit-and ~long 15))

(defn into-long
  [nums]
  (->> nums
       (map list (range))
       (reduce (fn [x [i num]]
                 (write-num x i num))
               0)))

(defn stalemate-count-2
  [corners distinguished]
  (let [[a b c] (->> corners
                     (remove #{distinguished})
                     (sort))
        initial-grid (-> 0
                         (write-num 0 a)
                         (write-num 3 b)
                         (write-num 12 c)
                         (write-num 15 distinguished))
        vars (->> (range 16)
                  (remove #{0 3 12 15})
                  (into-long))
        vals (->> (range 16)
                  (remove #{a b c distinguished})
                  (into-long))
        m-enter 0

        ]
    (loop [mode      m-enter
           grid      initial-grid
           ;; grid-idxs is a stack containing indexes into vals
           grid-idxs 0
           total     0
           var-idx   0
           val-idx   0]
      (case mode
        0                               ; m-enter
        (cond
         (= 12 var-idx)
         (recur m-enter grid grid-idxs (inc total) 11 (inc val-idx))

         (= 12 val-idx)
         (if (zero? var-idx)
           total ; all done
           (recur m-enter grid (pop-num grid-idxs) total (dec var-idx) (inc (peek-num grid-idxs))))

         :else
         ;; this is where we actually try a new value
         (let [var (read-num vars var-idx)
               val (read-num vals val-idx)
               grid' (write-num grid var val)]
           (recur m-check))
          )))))

;;
;; Timing things and other experiments
;;

(defn stalemate?
  [v]
  (every? (fn [q]
            (different? (map v q)))
          quadruples))

(defn r-search
  []
  (let [candidate (vec (shuffle (range 16)))]
    [(stalemate? candidate) candidate]))

(defmacro t
  [expr]
  `(let [b# (System/currentTimeMillis)
         ret# ~expr]
     {:ret ret#, :t (- (System/currentTimeMillis) b#)}))

(comment
  ;; Supposedly valid: [2 5 1 15 10 8 4 3 12 7 14 0 11 6 9 13]

  ;; (stalemate-count-1 [0 1 2 3] 2) => 4664128
  ;; Ran in 899688ms with the macro version
  ;;
  ;; Write my own bit-test: 76919ms
  ;;
  ;; Wrote a bit-clear 61947ms

  (def f (future (t (stalemate-count-1 [0 1 2 3] 2))))

  ;; galago w/ bit-clear: 11739ms

  (def all-seeds
    (for [a (range 16)
          b (range a)
          c (range b)
          d (range c)
          :let [min (min a b c d)
                others (remove #{min} [a b c d])]
          dist others]
      {:nums [a b c d] :distinguished dist}))

  (def f (future
           (->> all-seeds
                (pmap (fn [{:keys [nums distinguished] :as seed}]
                        [seed (stalemate-count nums distinguished)]))
                (into {}))))

  (defn publish
    [s]
    (spit "quarto.txt" s)
    (sh/sh "scp" "quarto.txt" "nginx:/home/gary/public/"))

  (future
    (publish (with-out-str (clojure.pprint/pprint @f))))

  )