Thermometers Solver [WIP]

algorithm.clj

(ns thermometers.algorithm
  (:require
   [clojure.string :as str]))

(def tags
  '{○ #{:start :empty}
    ● #{:start :full}
    ⇑ #{:up :empty}
    ⬆ #{:up :full}
    ⇓ #{:down :empty}
    ⬇ #{:down :full}
    ⇐ #{:left :empty}
    ⬅ #{:left :full}
    ⇒ #{:right :empty}
    ⮕ #{:right :full}})

(def empty->filled
  (let [tags->full (into {}
                         (keep (fn [[cell-type type-tags]]
                                 (when (type-tags :full)
                                   [(disj type-tags :full) cell-type])))
                         tags)]
    (into {}
          (keep (fn [[cell-type type-tags]]
                  (when (type-tags :empty)
                    [cell-type (get tags->full (disj type-tags :empty))])))
          tags)))

(defn cells-with-tag [tag]
  (into #{}
        (keep (fn [[cell-type type-tags]]
                (when (contains? type-tags tag)
                  cell-type)))
        tags))

(defn cell-at [board [x y]]
  (when (and (< 0 x (count board))
             (< 0 y (count board)))
    (get-in board [y x])))

(defn neighbor-cell-coordinates [[x y] direction]
  (case direction
    :up    [x (dec y)]
    :down  [x (inc y)]
    :left  [(dec x) y]
    :right [(inc x) y]))

(defn next-cell-in-direction [board [x y] direction]
  (let [neighbor-coordinates (neighbor-cell-coordinates [x y] direction)]
    (when-let [cell (cell-at board neighbor-coordinates)]
      (when (contains? (tags cell) direction)
        {:cell cell, :direction direction, :coordinates neighbor-coordinates}))))

(defn next-cell [board [x y]]
  (let [candidates (keep (partial next-cell-in-direction board [x y])
                         [:up :down :left :right])]
    (assert (<= (count candidates) 1)
            (format "Multiple next cells at %s: %s" [x y] (pr-str candidates)))
    (first candidates)))

(defn thermometer-starting-at [board [x y]]
  (loop [[x y] [x y]
         acc   [{:cell (cell-at board [x y]), :direction :start, :coordinates [x y]}]]
    (if-let [next-cell (next-cell board [x y])]
      (recur (:coordinates next-cell)
             (conj acc next-cell))
      acc)))

(defn thermometers [board]
  (for [x (range 1 (count board))
        y (range 1 (count board))
        :when (contains? (tags (cell-at board [x y])) :start)]
    (thermometer-starting-at board [x y])))

(defn valid-thermometer? [thermometer]
  ;; all :full cells must come before all :empty cells
  (letfn [(full? [cell]
            (contains? (tags (:cell cell)) :full))]
    (let [statuses (map full? thermometer)]
      (= statuses
         (sort-by #(if % 0 1) statuses)))))

(defn num-full [[_required-num-full & cells :as _line]]
  (transduce
   (keep #(when (contains? (tags %) :full) 1))
   +
   0
   cells))

(defn correct-num-full? [[required-num-full :as line]]
  (= (num-full line)
     required-num-full))

(defn nth-row [board i]
  (nth board i))

(defn nth-col [board i]
  (mapv #(nth % i)
        board))

(defn solved? [board]
  (and (every? (fn [row-num]
                 (let [row (nth-row board row-num)]
                   (correct-num-full? row)))
               (range 1 (count board)))
       (every? (fn [col-num]
                 (let [col (nth-col board col-num)]
                   (correct-num-full? col)))
               (range 1 (count board)))
       (every? valid-thermometer? (thermometers board))))

(defn solvable-line? [line]
  (<= (num-full line) (first line)))

(defn solvable? [board]
  (and (every? (fn [row-num]
                 (let [row (nth-row board row-num)]
                   (solvable-line? row)))
               (range 1 (count board)))
       (every? (fn [col-num]
                 (let [col (nth-col board col-num)]
                   (solvable-line? col)))
               (range 1 (count board)))
       (every? valid-thermometer? (thermometers board))))

(defn neighbor-cell-in-direction [board [x y] direction]
  (let [neighbor-coordinates (neighbor-cell-coordinates [x y] direction)]
    (cell-at board neighbor-coordinates)))

(defn- previous-cell-filled? [board [x y]]
  (let [cell             (cell-at board [x y])
        neighbor-filled? (fn [direction]
                           (contains? (tags (neighbor-cell-in-direction board [x y] direction)) :full))]
    (case cell
      ○  true
      ⇑  (neighbor-filled? :down)
      ⇓  (neighbor-filled? :up)
      ⇐  (neighbor-filled? :right)
      ⇒  (neighbor-filled? :left))))

(defn can-fill-addditional-cell-in-row? [board y]
  (let [row (nth-row board y)]
    (< (num-full row) (first row))))

(defn can-fill-additional-cell-in-col? [board x]
  (let [col (nth-col board x)]
    (< (num-full col) (first col))))

(defn fillable-cells [board]
  (for [x     (for [x     (range 1 (count board))
                    :when (can-fill-additional-cell-in-col? board x)]
                x)
        y     (for [y     (range 1 (count board))
                    :when (can-fill-addditional-cell-in-row? board y)]
                y)
        :when (let [cell (cell-at board [x y])]
                (and (contains? (tags cell) :empty)
                     (previous-cell-filled? board [x y])))]
    [x y]))

(defn fill-cell [board [x y]]
  (let [cell (cell-at board [x y])]
    (assert (contains? (tags cell) :empty))
    (let [board' (assoc-in board [y x] (empty->filled cell))]
      (assert (not= board board'))
      board')))

(defn solve-board* [board blacklist depth iterations]
  #_(printf "%s%s\n" (str/join (repeat depth " ")) (pr-str board)) ; NOCOMMIT
  (swap! iterations inc)
  (when (zero? (mod @iterations 10000))
    (printf "%sk\n" (long (/ @iterations 1000)))
    (flush))
  (cond
    (solved? board)
    board

    (not (solvable? board))
    (do
      #_(printf "%sUnsolvable!\n" (str/join (repeat depth " ")))
      (throw (ex-info "Unsolvable" {::backtrack true, :board board})))

    (> @iterations 100000000)
    (throw (ex-info "Too many iterations!" {:board board, :depth depth}))

    :else
    (loop [[unfilled & more] (remove blacklist (fillable-cells board)), blacklist blacklist]
      #_(printf "%sunfilled: %s\n" (str/join (repeat depth " ")) unfilled) ; NOCOMMIT
      (when (empty? unfilled)
        (throw (ex-info "No more empty cells to try filling" {::backtrack true, :board board})))
      #_(printf "%sFill cell @ %s depth: %d, iteration: %d\n" (str/join (repeat depth " ")) unfilled depth @iterations)
      (let [result (try
                     (solve-board* (fill-cell board unfilled) blacklist (inc depth) iterations)
                     (catch Throwable e
                       (when-not (::backtrack (ex-data e))
                         (throw e))
                       ::backtrack))]
        #_(println "result:" result)    ; NOCOMMIT
        (if (= result ::backtrack)
          (recur more (conj blacklist unfilled))
          result)))))

(defn solve-board [board]
  (solve-board* board #{} 0 (atom 0)))

(def board
  '[[nil 3 4 2 2 3 3]
    [3 ○ ⇐ ○ ⇐ ○ ○]
    [2 ⇓ ⇐ ○ ⇑ ⇑ ⇓]
    [3 ⇓ ⇑ ⇑ ⇑ ⇑ ⇓]
    [1 ⇓ ○ ○ ○ ⇑ ⇓]
    [4 ⇓ ⇐ ⇐ ○ ○ ⇑]
    [4 ⇓ ⇐ ⇐ ⇐ ○ ○]])

#_(def board
  '[[_ 2 1 3 1]
    [1 ⇐ ○ ○ ⇒]
    [2 ○ ○ ⇒ ○]
    [1 ⇓ ⇐ ○ ⇓]
    [3 ○ ⇒ ⇒ ⇓]])

#_(fn algo-2 [board]
  (let [board-size (count board)
        xform      (take 10)
        add-row-constraints
        add-total-filled-constraint ; min of total fillable by row and total fillable by col
        ])
  (into []
        xform
        (range 0 (Math/pow 2 (Math/pow board-size 2)))))

ui.clj

(ns thermometers.ui
  (:require
   [thermometers]
   [clojure.string :as str]
   [io.github.humbleui.util :as ui.util]
   [io.github.humbleui.signal :as ui.signal]
   [io.github.humbleui.ui :as ui]
   [clojure.data :as data]
   [thermometers.algorithm]
   [clojure.set :as set]))

(defn make-blank-board [board-size]
  (into [(into [nil] (repeat board-size 1))]
        (repeat
         board-size
         (into [1] (repeat board-size nil)))))

(defonce state
  (ui/signal
    {:board-size        4
     :board             (make-blank-board 4)
     :last-clicked-cell nil}))

(add-watch
 state
 ::update-state
 (fn [_key _ref old-state new-state]
   (when-not (= old-state new-state)
     (println "state updated" (pr-str old-state) '-> (pr-str new-state))) ; NOCOMMIT
   ))

(defn size-toggle []
  (let [*value (ui/signal (:board-size @state))]
    (add-watch *value
               ::on-change
               (fn [_key _ref _old-size new-size]
                 (assert (pos-int? new-size))
                 (assert (<= 4 new-size 15))
                 (reset! state {:board-size new-size
                                :board      (make-blank-board new-size)})))
    (letfn [(toggle-button [value]
              [ui/padding {:right 10}
               [ui/toggle-button {:style :outlined
                                  :*value *value
                                  :value-on value}
                (str value)]])]
      [ui/row
       [ui/padding {:right 10}
        [ui/align {:y :center}
         [ui/label "Board Size"]]]
       (toggle-button 4)
       (toggle-button 6)
       (toggle-button 10)
       (toggle-button 15)])))

(defn outlined [contents]
  [ui/rect {:paint {:stroke 0xFFCCCCCC}}
   contents])
2
(defn label-cell [text]
  [ui/align {:x :center, :y :center}
   [ui/label (or (some-> text str) "?")]])

(defn constraint-cell [cell-width [x y]]
  (let [value (get-in @state [:board y x] 0)]
    (assert (int? value))
    (assert (not (neg? value)))
    [ui/align {:x :center, :y :center}
     [ui/column
      [ui/padding {:bottom 20}
       [ui/align {:x :center}
        [ui/text-field
         (str value)]]]
      (let [enable-minus? (pos? value)
            enable-plus?  (< value (:board-size @state))
            button-width  (long (/ (- cell-width 15) 2))]
        [ui/row
         (when enable-minus?
           [ui/size {:width button-width}
            [ui/button
             {:on-click (fn [_event]
                          (swap! state assoc-in [:board y x] (max 0 (dec value))))}
             [ui/label "-"]]])
         (when (and enable-minus? enable-plus?)
           [ui/gap {:width 5}])
         (when enable-plus?
           [ui/size {:width button-width}
            [ui/button
             {:on-click (fn [_event]
                          (swap! state (fn [state]
                                         (assoc-in state [:board y x] (min (:board-size state)
                                                                           (inc value))))))}
             [ui/label "+"]]])])]]))

(defn row-constraint-cell [cell-width y]
  (constraint-cell cell-width [0 y]))

(defn col-constraint-cell [cell-width x]
  (constraint-cell cell-width [x 0]))

(def empty-types
  (into []
        (keep (fn [[cell-type type-tags]]
                (when (contains? type-tags :empty)
                  cell-type)))
        thermometers.algorithm/tags))

(def next-empty-type*
  (zipmap empty-types (cons (last empty-types) (butlast empty-types))))

(defn next-empty-type [cell [this-x this-y] [last-x last-y]]
  (cond
    ;; last cell was the cell above
    (= [last-x last-y] [this-x (dec this-y)])
    '⇓

    ;; below
    (= [last-x last-y] [this-x (inc this-y)])
    '⇑

    ;; left
    (= [last-x last-y] [(dec this-x) this-y])
    '⇒

    ;; right
    (= [last-x last-y] [(inc this-x) this-y])
    '⇐

    :else
    (get next-empty-type* cell '○)))

(defn regular-cell [cell-width [x y]]
  [ui/clickable
   {:on-click (fn [_event]
                (swap! state (fn [state]
                               (-> state
                                   (update-in [:board y x] next-empty-type [x y] (:last-clicked-cell state))
                                   (assoc :last-clicked-cell [x y])))))}
   (let [cell (get-in (:board @state) [y x])
         paint (merge
                {:stroke 0xFF000000}
                (when (contains? (thermometers.algorithm/tags cell) :full)
                  {:fill 0xFFFF0000}))]
     (cond
       (contains? (thermometers.algorithm/tags cell) :start)
       [ui/rect
        {:radius (long (/ cell-width 2)), :paint paint}
        (label-cell "")]

       (seq (set/intersection (thermometers.algorithm/tags cell) #{:left :right}))
       [ui/align {:y :center}
        [ui/size {:width cell-width, :height (long (/ cell-width 2))}
         [ui/rect
          {:paint paint}
          (label-cell cell)]]]

       (seq (set/intersection (thermometers.algorithm/tags cell) #{:up :down}))
       [ui/align {:x :center}
        [ui/size {:width (long (/ cell-width 2)), :height cell-width}
         [ui/rect
          {:paint paint}
          (label-cell cell)]]]

       :else
       (label-cell cell)))])

(defn cell-wrapper [cell-width contents]
  [ui/size {:width cell-width, :height cell-width}
   (outlined
    contents)])

(defn cell-contents [cell-width [x y]]
  #_[ui/column
     [ui/text-field (format "[%d, %d]" x y)]]
  (cond
    (and (zero? x)
         (zero? y))
    (label-cell "")

    (zero? x)
    (row-constraint-cell cell-width y)

    (zero? y)
    (col-constraint-cell cell-width x)

    :else
    (regular-cell cell-width [x y])))

(defn cell [cell-width [x y]]
  (cell-wrapper cell-width (cell-contents cell-width [x y])))

(defn board []
  [ui/align {:x :center}
   [ui/with-bounds
    (fn [{window-width :x, window-height :y}]
      (assert (pos-int? (:board-size @state)))
      (let [board-size  (-> (:board-size @state)
                            (max 4)
                            (min 15))
            board-width (max (- (min window-width window-height) 150) 500)
            cell-width  (long (/ board-width (inc board-size)))]
        [ui/padding {:padding 10}
         [ui/size {:height board-width
                   :width  board-width}
          (into [ui/grid {:cols (inc board-size), :rows (inc board-size)}]
                (map (fn [[x y]]
                       (cell cell-width [x y])))
                (for [y (range (inc (:board-size @state)))
                      x (range (inc (:board-size @state)))]
                  [x y]))]]))]])

(defn reset-button []
  [ui/button
   {:style :outlined, :on-click (fn [_event]
                                  (swap! state (fn [state]
                                                 (assoc state :board (make-blank-board (:board-size state))))))}
   [ui/label "Reset!"]])

(defn solve-button []
  [ui/padding {:top 10}
   [ui/button
    {:style :outlined, :on-click (fn [_event]
                                   (swap! state update :board thermometers.algorithm/solve-board))}
    [ui/label "Solve!"]]])

(defn ui []
  [ui/with-context {:scale 2}
   [ui/align {:x :center, :y :center}
    [ui/column
     (size-toggle)
     (board)
     (reset-button)
     (solve-button)]]])

(defonce app
  (ui/start-app!
   (ui/window
    {:title "Thermometers Solver"}
    #'ui)))