Genetic nonogram

core.clj

(ns non.core)

(def radioactivity 0.001)

(defn board
  [cols rows]
  (vec (repeat rows
               (vec (repeat cols 0)))))

(defn random-board
  [cols rows]
  (vec (repeatedly rows
                   #(vec (repeatedly cols (fn [] (rand-int 2)))))))

(defn initial-generation
  [n cols rows]
  (repeatedly n #(random-board cols rows)))

(defn rows
  [board]
  board)

(defn cols
  [board]
  (apply mapv vector board))

(defn abs
  [n]
  (max n (- n)))

(defn line-diffs
  [constraint line-as-constraint]
  (if (> (count constraint ) (count line-as-constraint))
    (map (comp abs -) constraint (concat line-as-constraint (repeat 0)))
    (map (comp abs -) line-as-constraint (concat constraint (repeat 0)))))

(defn score-line
  [constraint row]
  (apply + (line-diffs constraint (map count (remove #(= 0 (first %)) (partition-by identity row))))))

(defn score
  [board [row-constraints col-constraints]]
  (apply
   + (concat (map score-line row-constraints (rows board))
             (map score-line col-constraints (cols board)))))

(defn flip
  [x]
  (abs (- x 1)))

(defn mutate
  [x]
  (if (< (rand) radioactivity) (flip x) x))

(defn breed-board
  [x y]
  (mapv (fn breed-line [line-x line-y]
          (mapv (fn breed-cell [& cells] (mutate (rand-nth cells))) line-x line-y)) x y))

(defn next-gen
  [population]
  (pmap (fn [[l r]] (breed-board l r)) (partition 2 (concat (shuffle population) (shuffle population)))))

(defn add-score-as-metadata
  [board constraints]
  (if (meta board)
    board
    (with-meta board {:score (score board constraints)})))

(defn breed-and-split
  [population constraints]
  (->> population
       (concat (next-gen population))
       (map #(add-score-as-metadata % constraints))
       (sort-by #(-> % meta :score))
       (take (count population))))

(defn run
  [constraints]
  (let [rows (count (first constraints))
        cols (count (second constraints))
        gen-0 (map #(add-score-as-metadata % constraints) (initial-generation 20 cols rows))]
    (iterate #(breed-and-split % constraints) gen-0)))

(defn best
  [pop-seq]
  (->> pop-seq
       (drop-while #(pos? (-> % first meta :score)))
       ffirst))

(defn test-run
  []
  (let [row-constraints [[3] [3] [1 3] [1] [1 1]]
        col-constraints [[3 1] [2] [3] [1] [3]]
        constraints [row-constraints col-constraints]]
    (best (run constraints))))

(defn gchq
  []
  (let [row-constraints [[7 3 1 1 7]
                         [1 1 2 2 1 1]
                         [1 3 1 3 1 1 3 1]
                         [1 3 1 1 6 1 3 1]
                         [1 3 1 5 2 1 3 1]
                         [1 1 2 1 1]
                         [7 1 1 1 1 1 7]
                         [3 3]
                         [1 2 3 1 1 3 1 1 2]
                         [1 1 3 2 1 1]
                         [4 1 4 2 1 2]
                         [1 1 1 1 1 4 1 3]
                         [2 1 1 1 2 5]
                         [3 2 2 6 3 1]
                         [1 9 1 1 2 1]
                         [2 1 2 2 3 1]
                         [3 1 1 1 1 5 1]
                         [1 2 2 5]
                         [7 1 2 1 1 1 3]
                         [1 1 2 1 2 2 1]
                         [1 3 1 4 5 1]
                         [1 3 1 3 10 2]
                         [1 3 1 1 6 6]
                         [1 1 2 1 1 2]
                         [7 2 1 2 5]]

        col-constraints [[7 2 1 1 7]
                         [1 1 2 2 1 1]
                         [1 3 1 3 1 3 1 3 1]
                         [1 3 1 1 5 1 3 1]
                         [1 3 1 1 4 1 3 1]
                         [1 1 1 2 1 1]
                         [7 1 1 1 1 1 7]
                         [1 1 3]
                         [2 1 2 1 8 2 1]
                         [2 2 1 2 1 1 1 2]
                         [1 7 3 2 1]
                         [1 2 3 1 1 1 1 1]
                         [4 1 1 2 6]
                         [3 3 1 1 1 3 1]
                         [1 2 5 2 2]
                         [2 2 1 1 1 1 1 2 1]
                         [1 3 3 2 1 8 1]
                         [6 2 1]
                         [7 1 4 1 1 1 3]
                         [1 1 1 1 4]
                         [1 3 1 3 7 1]
                         [1 3 1 1 1 2 1 1 4]
                         [1 3 1 4 3 3]
                         [1 1 2 2 2 6 1]
                         [7 1 3 2 1 1]]
        constraints [row-constraints col-constraints]]
    (run constraints)))

(defn board-string
  [board]
  (clojure.string/join "\n"
                       (map #(apply str (map (fn [c] (if (pos? c) \x \space)) %)) board)))