Building some domino tilings in code

(ns domino-tilings.core
  (:require [quil.core :as q :include-macros true]
            [quil.middleware :as m]
            [clojure.math.combinatorics :as combo]
            [clojure.set :as set]
            ))

(def config
  "global stuff for setting up"
   {:cell-size 20
    :lattice-side 20}
    )


(defn rectangular-region-of-cells
  "returns a Clojure set containing 2-d position index vectors; yes, this is weird"
  [width height]
  (into #{}
    (for [i (range width)
          j (range height)]
      [i j]))
      )


(defn adjacent-cells?
  "given two cells (2d index vectors), returns `true` if they are Von Neumann neighbors of one another"
  [cell1 cell2]
  (let [[i1 j1] cell1
        [i2 j2] cell2]
    (or
      (and (= i1 i2) (= 1 (Math/abs (- j1 j2))))
      (and (= j1 j2) (= 1 (Math/abs (- i1 i2))))
      )))

(defn neighboring-cells
  "given a cell and a set of cells, returns all neighbors of the former"
  [cell set-of-cells]
  (filter #(adjacent-cells? cell set-of-cells)))


(defn all-neighbors
  "produces a set of all pairs of Von Neumann neighbors (as sets) from a given set of cells"
  [set-of-cells]
  (set (map
    set
    (filter
      #(apply adjacent-cells? %)
      (combo/combinations set-of-cells 2)
      ))))


(defn draw-cell
  "draw a square, with a 1-pixel border on the right and bottom"
  [cell size hue saturation brightness]
  (q/fill hue saturation brightness)
  (q/rect (* size (first cell)) (* size (second cell)) (dec size) (dec size))
  )

(defrecord Domino [cells color])

(defn initial-rectangle-dominoes
  "given a rectangular region/collection of cells, construct nonoverlapping dominoes covering the region, in vertical alignment; assign them various colors as well, just to be a bit fancy"
  [width height]
  (let [scale (:lattice-side config)
        delta-h (/ 256 scale)]
    (for [i (range width)
          j (range 0 height 2)]
      (->Domino
        #{[i j] [i (inc j)]}
        {:hue (mod (+ (* delta-h i) (* delta-h j)) 256)
         :saturation (+ (* delta-h i) j 150)
         :brightness (+ (* delta-h j) i 100)}
         ))))


(defn draw-domino
  "given a domino, place it on the canvas in the appropriate position, size and color"
  ([domino size hue saturation brightness]
    (let [columns (map first (:cells domino))
          rows    (map second (:cells domino))
          left    (apply min columns)
          right   (apply max columns)
          top     (apply min rows)
          bottom  (apply max rows)
          width   (- right left)
          height  (- bottom top)]
      (q/fill hue saturation brightness)
      (q/rect (* size left)
              (* size top)
              (dec (* (inc width) size))
              (dec (* (inc height) size))
              )))
    ([domino size]
      (let [color (:color domino)
            h (:hue color)
            s (:saturation color)
            b (:brightness color)]
        (draw-domino domino size h s b))))


(defn highlight-domino
  "draw a highlighted border around a given domino"
  [domino size]
  (let [color (:color domino)
        h (:hue color)
        s (:saturation color)
        b (:brightness color)]
    (q/stroke h (+ s 50) (+ b 50) 125)
    (q/stroke-weight 10)
    (draw-domino domino size h s b)
    (q/no-stroke)
    ))


(defn neighboring-cells-of-cell
  "given a cell, return a set of all the other cells that are its neighbors, accoring to the neighborhood lattice provided"
  [cell neighbor-lattice]
  (apply set/union (filter #(contains? % cell) neighbor-lattice)))


(defn neighboring-cells-of-tile
  "given a tile, return a set of all cells that are neighbors of any of the tile's cells (and not part of the tile)"
  [tile neighbor-lattice]
  (let [insides (:cells tile)]
    (set/difference
      (apply
        set/union
        (map #(neighboring-cells-of-cell % neighbor-lattice) insides))
      insides
      )))


(defn tile-on-cell
  "return the tile that occupies a given cell"
  [cell tiles]
  (first (filter #(contains? (:cells %) cell) tiles)))


(defn set-overlap?
  "return `true` if the intersection of two sets is nonempty"
  [set1 set2]
  (not (empty? (set/intersection set1 set2))))


(defn neighboring-tiles-of-tile
  "given a tile, return all other tiles that contain cells adjacent to that tile's cells"
  [tile tiles neighbor-lattice]
  (let [surroundings (neighboring-cells-of-tile tile neighbor-lattice)]
    (into #{} (map #(tile-on-cell % tiles) surroundings))
    ))


(defn snug-neighbors-of-tile
  "given a tile, return all neighboring tiles where _every cell_ of the tile is a neighbor of the given tile; these are the 'snug' neighbors, at least for dominoes"
  [tile tiles neighbor-lattice]
  (let [surroundings (neighboring-cells-of-tile tile neighbor-lattice)]
    (filter
      #(set/subset? (:cells %) surroundings)
      (neighboring-tiles-of-tile tile tiles neighbor-lattice))
      ))


(defn highlight-cell
  "draw a black dot on a cell"
  [cell size]
  (let [half-square (/ size 2)]
    (q/translate half-square half-square)
    (q/fill 10 10 10)
    (q/ellipse
      (* size (first cell))
      (* size (second cell))
      half-square
      half-square)
    (q/translate (- half-square) (- half-square))
    ))


(defn rotated-domino-pair
  "given two snug dominoes, return the pair of rotated dominoes, with equal probability of clockwise or counterclockwise rotation"
  [domino1 domino2]
  (let [c1 (sort (:cells domino1))
        c2 (sort (:cells domino2))]
    (if (< (rand) 0.5)
      (vector
        (assoc domino1 :cells #{(first c1) (first c2)})
        (assoc domino2 :cells #{(second c1) (second c2)}))
      (vector
        (assoc domino1 :cells #{(second c1) (second c2)})
        (assoc domino2 :cells #{(first c1) (first c2)}))
        )))


(defn setup []
  "build the Quil state"
  (let [s              (:lattice-side config)
        all-positions  (rectangular-region-of-cells s s)
        cell-neighbors (all-neighbors all-positions)
        initial-tiles  (initial-rectangle-dominoes s s)]
  (q/frame-rate 60)
  (q/color-mode :hsb)
  {:cells         all-positions
   :lattice       cell-neighbors
   :tiles         initial-tiles
   :changed-tiles []}
  ))


(defn swap-in-pair
  "replace a pair of 'old' tiles with a pair of 'new' ones (probably because you rotated a snug pair)"
  [old1 old2 new1 new2 tiles]
    (into (set (remove #{old1 old2} tiles)) #{new1 new2})
    )


(defn update-state [state]
  "pick a random tile, and see if it has any snug neighbors; if it does, rotate it with one of the snug neighbors picked at random; if it doesn't, return it; make a note of the dominoes that want to be highlighted"
  (let [cells       (:cells state)
        tiles       (:tiles state)
        lattice     (:lattice state)
        focus-tile  (rand-nth (into [] tiles))
        neighbors   (snug-neighbors-of-tile
                      focus-tile
                      (:tiles state)
                      (:lattice state))
                      ]
    (if (empty? neighbors)
      {:cells         cells
       :lattice       lattice
       :tiles         tiles
       :changed-tiles [focus-tile]}
      (let [old1 focus-tile
            old2 (rand-nth neighbors)
            [new1 new2] (rotated-domino-pair old1 old2)]
        {:cells         cells
         :lattice       lattice
         :tiles         (swap-in-pair old1 old2 new1 new2 tiles)
         :changed-tiles [new1 new2]}
         ))))


(defn draw-state [state]
  "clear the background, draw all the cells and domino tiles, and highlight any that want highlighting"
  (let [s (:cell-size config)]
    (q/background 240)
    (q/no-stroke)
    (doall (map #(draw-cell % s 0 0 200) (:cells state)))
    (doall (map #(draw-domino % s) (:tiles state)))
    (doall (map #(highlight-domino % s) (:changed-tiles state)))
    ))


(q/defsketch domino-tilings
  :host "domino-tilings"
  :size [400 400]
  :setup setup
  :update update-state
  :draw draw-state
  :middleware [m/fun-mode])