Some experiments with Conway's game of life on the hexagonal field

hexlife_core.clj

(ns hexlife.core
  (:use clojure.set))

(defn nbrs [[x y]]
  "Расчет координат соседей для данной клетки с координатами [x y]"
  (let [++ (fn [x] (+ x 1)) -- (fn [x] (- x 1))]
    #{[(-- x) (-- y)] [(-- (-- x)) y] [(-- x) (++ y)]
      [(++ x) (-- y)] [(++ (++ x)) y] [(++ x) (++ y)]}))

; (= (nbrs [3 2]) #{[2 1] [4 3] [2 3] [1 2] [4 1] [5 2]})

(defn world
  "Ленивое создание полного поля через последовательный расчет соседей нулевой клетки"
  ([] (world #{[0 0]}))
  ([x] (let [around (fn [cs] (reduce union (map nbrs cs)))]
          (distinct (lazy-cat x (world (around x)))))))

(defn split-map [m nrs]
  (let [w (reduce union (map nrs m))]
       [(intersection w m) (difference w m)]))

(defn has-alive-nrs [m nrs n]
  (fn [c] (= n (count (intersection m (nrs c))))))

(defn nextgen [m]
  "Генерация нового поколения клеток на основе данного"
  (let [[al de] (split-map m nbrs)
        has-2-nrs (has-alive-nrs m nbrs 2)
        has-3-nrs (has-alive-nrs m nbrs 3)
        survivals-2 (filter has-2-nrs al)
        survivals-3 (filter has-3-nrs al)
        born (filter has-3-nrs de)]
     (set (concat survivals-2 survivals-3 born))))

(defn figure [pattern]
  "Создание набора живых клеток на основе линейного шаблона"
  (set (map first (filter #(= :a (second %))
                     (partition 2 (interleave (world #{[0 0]}) pattern))))))

(defn all-figures [n]
  "Генерация всех возможных фигур размера n, лежащих вокруг ноля"
  (let [app (fn [p s] (map #(conj % s) p))
        step (fn [p] (into [] (concat (app p :a) (app p :d))))]
    (if (<= n 1)
      [[:a] [:d]]
      (step (all-figures (- n 1))))))

(def are-there-not-dying-patterns
  "Проверка: есть ли начальные конфигурации, которые не умирают со временем?"
  (let [size [1 2 3 4 5 6]
        patterns (reduce concat (map all-figures size))
        game-fields (distinct (filter not-empty (map figure patterns)))
        evolve (fn [cs] (-> cs nextgen nextgen nextgen nextgen))]
    (filter not-empty (map evolve game-fields))))

(def some-small-patterns-that-do-not-die-fast
  "Набор пар [начальная конфигурация, её состояние через несколько шагов]"
  (let [size (take 16 (range 1 100))
        patterns (reduce concat (map all-figures size))
        game-fields (distinct (filter not-empty (map figure patterns)))
        dup (fn [x] [x x])
        doubled-game-fields (map dup game-fields)
        step (fn [[f f]] [f (nextgen f)])
        not-dead (fn [[f nf]] (not-empty nf))
        evolve (fn [cs] (-> cs step step step step step step step step))]
    (filter not-dead (map evolve doubled-game-fields))))

; (count some-small-patterns-that-do-not-die-fast) -> 25906

(def moving-or-blinking-figures
  "Ищем движущиеся или мигающие фигуры, которые не переходят сами в себя раз за разом"
  (let [p (map second some-small-patterns-that-do-not-die-fast)
        sample (first p)
        evolve-forever (fn [x] (iterate nextgen (nextgen x)))
        cycle-len (fn [sample] (count (take 10 (take-while (partial not= sample) (evolve-forever sample)))))]
    (filter #(> (cycle-len %) 0) p)))

; (count moving-or-blinking-figures) -> 1884
; notbad.jpg

(comment
  (def tri #{[3 2] [2 3] [4 3]})
  (split-map tri nbrs)
  (split-map #{[3 2]} nbrs)
  ((has-alive-nrs tri nbrs 2) [3 2])
  (= (figure [:a :d :a :a]) #{[1 -1] [0 0] [-1 -1]})
  (-> (figure [:a :d :a :a]) nextgen nextgen)
  (let [s [1 2 3]] (reduce concat (map all-figures s))))

Тащемта, надо ещё проверить алгоритм на стандартной топологии (квадратики). Там циклы должны находиться.

Единственное, что для этого надо, - изменить ф-ю nbrs