ぷよぷよ連鎖 in Clojure

puyo.clj

;;; Copyright (c) 2013 Yoshinori Kohyama. Distributed under the BSD 3-Clause License.
(ns puyo
  (:require [clojure.test :refer (with-test run-tests are)]
            [clojure.set :refer (union)]
            [clojure.string :as string]))

(with-test
  (defn- fall-one [b s]
    (->> (reverse b)
      (apply map vector)
      (map #(reduce
              (fn [[h & r] x]
                (if h
                    (if (and (= h s) (not= x s))
                        (cons h (cons x r))
                        (cons x (cons h r)))
                    (list x)))
              ()
              %))
      (apply map vector)
      vec))
 
  (are [b s a] (= (fall-one b s) a)
    [[:s :s :s :A]
     [:A :s :s :s]
     [:A :B :s :D]
     [:s :s :C :s]]
    :s
    [[:s :s :s :s]
     [:s :s :s :A]
     [:A :s :s :s]
     [:A :B :C :D]]))
 

(with-test
  (defn- connect
  "Separate sets of sets 'ss' into two group,
  by if it has one or more elements equals to one of 'ev' or not.
  And take the union of the former and conj 'e' to it,
  and conj it to the latter."
  [ev ss e]
  (let [hn (group-by (fn [s] (some (fn [e] (some #(= e %) s)) ev)) ss)
        h (hn true)
        n (set (hn nil))]
    (conj n (conj (apply union h) e))))

  (are [ev ss e nss] (= (connect ev ss e) nss)
    [:a] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b :g} #{:c} #{:d :e :f}}
    [:c] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c :g} #{:d :e :f}}
    [:d] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c} #{:d :e :f :g}}
    [:e] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c} #{:d :e :f :g}}
    [:a :b] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b :g} #{:c} #{:d :e :f}}
    [:a :c] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b :c :g} #{:d :e :f}}
    [:a :d] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b :d :e :f :g} #{:c}}
    [:c :d] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c :d :e :f :g}}
    [:d :e] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c} #{:d :e :f :g}}
    [] #{#{:a :b} #{:c} #{:d :e :f}} :g #{#{:a :b} #{:c} #{:d :e :f} #{:g}}
    [] #{} :g #{#{:g}}))

(with-test
  (defn- grouped-indices [b]
    (let [h (count b)
          w (count (first b))]
      (reduce
        (fn [a [y x :as yx]]
          (let [c (get-in b yx)
                uyx [(dec y) x]
                lyx [y (dec x)]]
            (connect (filter #(= (get-in b %) c) [uyx lyx]) a yx)))
        #{}
        (for [y (range h) x (range w)] [y x]))))

  (are [b g] (= (grouped-indices b) g)
    [[:A :s :A :A] [:A :A :C :C] [:C :B :B :B]]
      #{#{[0 0] [1 0] [1 1]}  ; :A
        #{[0 1]}              ; :s
        #{[0 2] [0 3]}        ; :A
        #{[1 2] [1 3]}        ; :C
        #{[2 0]}              ; :C
        #{[2 1] [2 2] [2 3]}} ; :B
    [[:A :A :s :D] [:s :A :A :D] [:C :C :C :C] [:F :F :F :D]]
      #{#{[0 0] [0 1] [1 1] [1 2]} ; :A
        #{[0 2]}                   ; :s
        #{[0 3] [1 3]}             ; :D
        #{[1 0]}                   ; :s
        #{[2 0] [2 1] [2 2] [2 3]} ; :C
        #{[3 0] [3 1] [3 2]}       ; :F
        #{[3 3]}}))                ; :D

(with-test
  (defn- erase [b s n]
    (->> (grouped-indices b)
      (remove #(= (get-in b (first %)) s))
      (filter #(< n (count %)))
      (apply union)
      (reduce #(assoc-in %1 %2 s) (mapv vec b))))

  (are [b s n a] (= (erase b s n) a)
    [[:A :s :s :s] [:A :s :A :A] [:A :A :C :B] [:C :B :B :B]] :s 3
      [[:s :s :s :s] [:s :s :A :A] [:s :s :C :s] [:C :s :s :s]]
    [[:A :A :s :D] [:s :A :A :D] [:C :C :C :C] [:F :F :F :D]] :s 3
      [[:s :s :s :D] [:s :s :s :D] [:s :s :s :s] [:F :F :F :D]]))

(with-test
  (defn- step
  "fall or erase"
  [b s n]
  (let [c (fall-one b s)]
    (if (not= c b) c (erase b s n))))

  (are [b s n r] (= (step b s n) r)
    [[:A :s :s :D] [:A :B :s :s] [:s :s :C :s]] :s 3
      [[:s :s :s :s] [:A :s :s :D] [:A :B :C :s]]
    [[:A :s :C :s] [:s :D :A :D] [:B :C :s :s]] :s 3
      [[:s :s :s :s] [:A :D :C :s] [:B :C :A :D]]
    [[:A :s :s :s] [:A :s :A :A] [:A :A :C :B] [:C :B :B :B]] :s 3
      [[:s :s :s :s] [:s :s :A :A] [:s :s :C :s] [:C :s :s :s]]
    [[:A :A :s :D] [:s :A :A :D] [:C :C :C :C] [:F :F :F :D]] :s 3
      [[:s :A :s :D] [:A :A :A :D] [:C :C :C :C] [:F :F :F :D]]))

(defn- bprint [b]
  (print "\033[0;0H") ; move (0,0)
  (dorun
    (map (fn [l]
           (println
             (apply str
               (map #({\R "\033[0;31mR\033[0m"
                       \G "\033[0;32mG\033[0m"
                       \B "\033[0;34mB\033[0m"
                       \Y "\033[0;33mY\033[0m"}
                      % %)
                    l))))
         b)))

(defn- stage [b w]
  (print "\033[2J") ; clear
  (loop [b b]
    (bprint b)
    (Thread/sleep w)
    (let [a (mapv #(apply str %) (step (mapv vec b) \space 3))]
      (if (not= a b)
          (recur a)))))

(defn from-file
  ([f w] (stage (string/split (slurp f) #"\n") w))
  ([f] (from-file f 500)))

(if-let [f (first *command-line-args*)]
  (from-file f))

seq19.dat

 YGYRR
R YGYG
GYGYRR
RYGYRG
YGYRYG
GYRYRG
YGYRYR
YGYRYR
YRRGRG
RYGYGG
GRYGYR
GRYGYR
GRYGYR

ぷよぷよ連鎖

随分前の記事ですが http://okajima.air-nifty.com/b/2011/01/2011-ffac.html の問題2が面白そうだったので clojure でやってみました.

java -cp /path/to/clojure.jar clojure.main puyo.clj seq19.dat
で19連鎖の確認ができます.

動作の様子: http://www.youtube.com/watch?v=NwXH8vbAfY8

(clojure になじみの無い方へ.
http://clojure.org/downloads から
clojure-1.5.1.zip をダウンロードして展開し,
上記 /path/to/clojure.jar のところを, 展開した中に入っている
clojure-1.5.1.jar のパスで置き換えてください.
Java の実行環境はあるものとします.)

ぷよが落ちて来て始まるように, データはちょっといじっています.

以下, 解説です.

構成

汎用的な関数は

(with-test
  (defn- 関数名 [引数 ...]
     関数本体
     ...)

  (are [テストの仮引数] (仮引数によるテストの実行方法)
    テストの実引数
    ...))

のような書き方をしています.

テストの書き方はいろいろあります.
環境やライブラリへの依存が少ないと思われる関数のテストを with-test を使って,
関数の直後に定義するのは単に私の好みであり, 他の方法もあります.

fall-one

行列 b とある要素 s が与えられた時,
全てのセルについて要素が s でなく (e とします).
1行下の要素が s ならば, そのセルの要素を s とし,
1行下の要素を e とします.
他のセルの移動であるセルが s になる場合は,
その上のセルの要素も下に移動します.

要素の型は問いません.

テストの例で言うと,

b | [[:s :s :s :A]
     [:A :s :s :s]
     [:A :B :s :D]
     [:s :s :C :s]]
s | :s

が与えられた時に s のセルには上から要素が落ちて来て

[[:s :s :s :s]
 [:s :s :s :A]
 [:A :s :s :s]
 [:A :B :C :D]]

を返すようにします.

                     ; b | [[:s :s :s :A]
                     ;      [:A :s :s :s]
                     ;      [:A :B :s :D]
                     ;      [:s :s :C :s]]
                     ; s | :s
                     ; が与えられたものとして動作例を書きます.
(->> (reverse b)     ; 行の順番を逆転します.
                     ; ([:s :s :C :s]
                     ;  [:A :B :s :D]
                     ;  [:A :s :s :s]
                     ;  [:s :s :s :A])
  (apply map vector) ; 転置します.
                     ; ([:s :A :A :s]
                     ;  [:s :B :s :s]
                     ;  [:C :s :s :s]
                     ;  [:s :D :s :A])
                     ; それぞれのベクタは元の行列の列を下から 
                     ; 順に見たシーケンスです. 
  (map #(reduce          ; それら全てについてこの reduce を行います.
          (fn [[h & r] x]
            (if h
                (if (and (= h s) (not= x s))

                    (cons h (cons x r))
                    (cons x (cons h r)))
                (list x)))
          ()
          %))            ; reduce が終わると, 要素が落ちる処理が行われた
                         ; 後の元の行列の列を「上から」見ている状態
                         ; になります.
                         ; 例として % が 4列目 [:s :D :s :A] だった場合
                         ; (:s :A :s :D) が返ります.
                     ; 全ての列について処理が終わると
                     ; ((:s :s :A :A)
                     ;  (:s :s :s :B)
                     ;  (:s :s :s :C)
                     ;  (:s :A :s :D))
                     ; のようになっています.
  (apply map vector) ; 各行をベクタにしながら転置します.
                     ; ([:s :s :s :s]
                     ;  [:s :s :s :A]
                     ;  [:A :s :s :s]
                     ;  [:A :B :C :D])
  vec)               ; 全体をベクタで返します.
                     ; [[:s :s :s :s]
                     ;  [:s :s :s :A]
                     ;  [:A :s :s :s]
                     ;  [:A :B :C :D]]

connect

要素のベクタ ev, 集合の集合 ss および要素 e が与えられた時に,
ss の中で ev に含まれる要素を持つような集合を全て連結し,
その中に e を追加します.

#{} は集合で表示上の要素の順序は無意味です.

テストの例で動作を説明しますと,

ev | [:a :c]
ss | #{#{:a :b} #{:c} #{:d :e :f}}
e  | :g

が与えられた場合, :a または :c を含む集合, #{:a :b} と #{:c} を
連結し, これに :g を追加して

#{#{:a :b :c :g} #{:d :e :f}}

を返します.

ev | [:a :b]
ss | #{#{:a :b} #{:c} #{:d :e :f}}
e  | :g

が与えられた場合, :a または :b を含む集合は #{:a :b} だけですので,
これに :g を追加して

#{#{:a :b :g} #{:c} #{:d :e :f}}

を返します.

         ; ev | [:a :c]
         ; ss | #{#{:a :b} #{:c} #{:d :e :f}}
         ; e  | :g
         ; が与えられたものとして例示します.
(let [hn (group-by (fn [s] (some (fn [e] (some #(= e %) s)) ev)) ss)
         ; ev の要素のいずれか (例の場合 :a または :c) のいずれかが
         ; 含まれるか? という問いへの返り値で ss をグループ分けします.
         ; hn は
         ; {true  [#{:a :b} #{:c}] 
         ;  false [#{:d :e :f}]
         ; }
         ; のようになります. (各ベクタ内の順序は不定です.)
         ;
      h (hn true)
         ; ev の要素のいずれかが含まれる集合のベクタです.
         ; h は [#{:a :b} #{:c}] です.
         ;
      n (set (hn nil))]
         ; ev の要素のいずれも含まない集合のベクタを集合の集合に戻します.
         ; n は #{#{:d :e :f}} です.
         ;
  (conj n (conj (apply union h) e))))
         ; n に
         ;   h の中の全ての集合を結合して e を加えたもの
         ; を追加します.
         ; 例ですと
         ; #{#{:d :e :f}} に
         ;   [#{:a :b} #{:c}] の中の全ての集合を結合して :g を加えたもの
         ;   すなわち #{:a :b :c :g}
         ; を追加し,
         ; #{#{:a :b :c :g} #{:d :e :f}}
         ; を返します.

grouped-indices

行列が与えられたとき,
縦または横に等しい要素が並んでいたらこれらを全て連結し,
[行番号, 列番号] の形で表される各座標の集合の集合を返します.

テストの例でいうと

[[:A :s :A :A]
 [:A :A :C :C]
 [:C :B :B :B]]

が与えられた場合

   +- #{[0 0] [1 0] [1 1]}
   |   +- #{[0 1]}
+--+-+-+--+---------+
| :A | :s | :A   :A +- #{[0 2] [0 3]}
|    +----+---------+
| :A   :A | :C   :C +- #{[1 2] [1 3]}
+----+--------------+
| :C | :B   :B   :B +- #{[2 1] [2 2] [2 3]}
+--+-+--------------+
   +- #{[2 0]}

のようにグループにできますので, 座標の集合の集合

#{#{[0 0] [1 0] [1 1]}
  #{[0 1]
  #{[0 2] [0 3]}
  #{[1 2] [1 3]}
  #{[2 0]}
  #{[2 1] [2 2] [2 3]}}

を返します.

                           ; b として
                           ; [[:A :s :A :A]
                           ;  [:A :A :C :C]
                           ;  [:C :B :B :B]]
                           ; が与えられたとして例示します.
(let [h (count b)          ; 行数を覚えます h 3
      w (count (first b))] ; 列数を覚えます w 4
  (reduce                  ; 行列内の全ての座標 [y x] <-----------------+
                           ;   この場合 ([0 0] [0 1] [0 2] [0 3]        |
                           ;             [1 0] [1 1] [1 2] [1 3]        |
                           ;             [2 0] [2 1] [2 2] [2 3])       |
                           ; について, 左上から順に,                    |
                           ; アキュムレータを空集合 #{} に初期化して -+ |
                           ; 以下を行います.                          | |
    (fn [a [y x :as yx]]      ; 例として [1 0] まで処理が終わり       | |
                              ; a が                                  | |
                              ;   #{#{[0 0] [1 0]} ; :A               | |
                              ;     #{[0 1]}       ; :s               | |
                              ;     #{[0 2] [0 3]} ; :A               | |
                              ; の状態で                              | |
                              ; yx [1 1] の所に来たとします.          | |
      (let [c (get-in b yx)   ; yx の要素を取得します                 | |
                              ; 今の場合 c は [1 1] にある :A です.   | |
            uyx [(dec y) x]   ; 上の座標 uyx [0 1]                    | |
            lyx [y (dec x)]]  ; 左の座標 lyx [1 0]                    | |
        (connect (filter #(= (get-in b %) c) [uyx lyx]) a yx))) ;     | |
                              ; 上と左のうち c と要素が等しいものと連 | |
                              ; 結します.                             | |
                              ; 例では,                               | |
                              ; 対象セルの要素 c は :A                | |
                              ; 上の要素 (get-in b uyx) は :s         | |
                              ; 左の要素 (get-in b lyx) は :A         | |
                              ; なので左のセルと連結され              | |
                              ; 新しいアキュムレータの状態は          | |
                              ;   #{#{[0 0] [1 0] [1 1]} ; :A         | |
                              ;     #{[0 1]}             ; :s         | |
                              ;     #{[0 2] [0 3]}}      ; :A         | |
    #{}                   ;-------------------------------------------+ |
    (for [y (range h) x (range w)] [y x])))) ; -------------------------+
                          ; 例では全ての座標についてこれを行った後の
                          ; アキュムレータは
                          ; #{#{[0 0] [1 0] [1 1]}
                          ;   #{[0 1]
                          ;   #{[0 2] [0 3]}
                          ;   #{[1 2] [1 3]}
                          ;   #{[2 0]}
                          ;   #{[2 1] [2 2] [2 3]}}
                          ; になっています.

erase

行列 b, ある要素 s, 数 n が与えられた時,
縦横に同じ要素が連接するものを全て結合してグループとした場合,
s 以外の要素からなるグループで要素数が n を越えるグループについて
要素を s に置き換えます.

テストにある例で言うと,

b | [[:A :s :s :s]
  |  [:A :s :A :A]
  |  [:A :A :C :B]
  |  [:C :B :B :B]]
s | :s
n | 3

が与えられた時,

+----+--------------+
| :A | :s   :s   :s |
|    |    +---------+
| :A | :s | :A   :A |
|    +----+----+----+
| :A   :A | :C | :B |
+----+----+----+    |
| :C | :B   :B   :B |
+--+-+--------------+

の用にグループ分けできますので, :s で無い 3 を越える要素数の
グループ内の要素を全て :s で置き換え,

+----+--------------+
| :s | :s   :s   :s |
|    |    +---------+
| :s | :s | :A   :A |
|    +----+----+----+
| :s   :s | :C | :s |
+----+----+----+    |
| :C | :s   :s   :s |
+--+-+--------------+

すなわち

[[:s :s :s :s]
 [:s :s :A :A]
 [:s :s :C :s]
 [:C :s :s :s]]

を返します.

条件を満たしたグループの要素を s で置き換えるので,
「s 以外の要素からなるグループ」という条件はあっても無くても同じ結果ですが,
条件を判定するコストと,
全ての s からなるグループの要素をあらためて s で上書きするコストの
うち後者の方が大きいと判断し, 条件を追加することにしました.

                            ; b | [[:A :s :s :s]
                            ;   |  [:A :s :A :A]
                            ;   |  [:A :A :C :B]
                            ;   |  [:C :B :B :B]]
                            ; s | :s
                            ; n | 3
                            ; が与えられたとして例示します.
(->> (grouped-indices b)    ; 連結します.
                            ; 例では
                            ; #{#{[0 0] [1 0] [2 0] [2 1]}
                            ;   #{[0 1] [0 2] [0 3] [1 1]}
                            ;   #{[1 2] [1 3]}
                            ;   #{[2 2]}
                            ;   #{[2 3] [3 1] [3 2] [3 3]}
                            ;   #{[3 0]}}
                            ; となります.
  (remove #(= (get-in b (first %)) s))
                            ; s で与えられた要素に相当する座標の集合を
                            ; 削除します.
                            ; 例の場合, :s からなる集合を削除し
                            ; (#{[0 0] [1 0] [2 0] [2 1]}
                            ;  #{[1 2] [1 3]}
                            ;  #{[2 2]}
                            ;  #{[2 3] [3 1] [3 2] [3 3]}
                            ;  #{[3 0]})
                            ; となります.
                            ; 集合から取り出す順序は不定なので,
                            ; この途中経過のリストの順序も不定です.
  (filter #(< n (count %))) ; 要素数が n を越えるもののみ残します.
                            ; 例では 3 を越える要素のもののみを残し
                            ; (#{[0 0] [1 0] [2 0] [2 1]}
                            ;  #{[2 3] [3 1] [3 2] [3 3]})
                            ; となります.
                            ; 順序は不定です.
  (apply union)             ; 残った座標を全部結合します.
                            ; 例では
                            ; #{[0 0] [1 0] [2 0] [2 1] [2 3] [3 1]
                            ;   [3 1] [3 2] [3 3]}
                            ; となります.
  (reduce #(assoc-in %1 %2 s) (mapv vec b)))
                            ; b における該当座標の要素を全て s に
                            ; 置き換えた行列を返します.
                            ; インデクスで assoc-in するためには,
                            ; b はベクタのベクタである必要があるので,
                            ; そうで無い場合を考慮し,
                            ; ベクタのベクタに確実に変換してから
                            ; 適用します.
                            ; 例では
                            ; [[:s :s :s :s]
                            ;  [:s :s :A :A]
                            ;  [:s :s :C :s]
                            ;  [:C :s :s :s]]
                            ; となります.

step

行列 b, 要素 s, 数 n について, fall-one を適用して変更があった
場合, その行列を, 変更が無かった場合は erase を適用した結果を
返します.

テストの例では

b | [[:A :s :s :D]
     [:A :B :s :s]
     [:s :s :C :s]]
s | :s
n | 3

に対しては, fall-one を適用した結果

[[:s :s :s :s]
 [:A :s :s :D]
 [:A :B :C :s]]

となり, これは元の b と変更されているので, これが結果となります.

b | [[:A :A :s :D]
  |  [:s :A :A :D]
  |  [:C :C :C :C]
  |  [:F :F :F :D]]
s | :s
n | 3

に対しては, fall-one を適用した結果が b と変わらないため,
erase が適用され,

[[:s :s :s :D]
 [:s :s :s :D]
 [:s :s :s :s]
 [:F :F :F :D]]

が返ります.

(let [c (fall-one b s)]
  (if (not= c b) c (erase b s n)))

コードの解説は割愛します.

入出力の形式への依存

これ以後のコードは,

• 各行がぷよぷよの各段を表す文字の列であるようなテキストファイルを入力
  とすること
• エスケープシーケンスの使える端末に出力すること
• 各ぷよは R, G, B, Y のいずれかの文字で表現すること
• ぷよの無い箇所はスペースで表現すること

などに依存していますが,
これより前のコードは, そういった詳細に依存していません.

副作用を伴わないコードですので, テストが簡単にかけますし,
要素の型も特定していませんので,
入出力時に扱う要素の表現が変わっても機能します.

例えばなんらかのグラフィック表示で出力を行う場合でも, 再利用できます.

bprint

文字列のシーケンス b が与えられた場合に,
端末の左上から各文字列を1行ずつ表示します.
その際, 端末のエスケープシーケンスが使えれば,
文字 R は赤, G は緑, B は青, Y は黄色で表示します.

端末の色表示をカスタマイズされている場合はこの限りではありません.

(print "\033[0;0H") ; move (0,0)
(dorun
  (map (fn [l]
         (println
           (apply str
             (map #({\R "\033[0;31mR\033[0m"
                     \G "\033[0;32mG\033[0m"
                     \B "\033[0;34mB\033[0m"
                     \Y "\033[0;33mY\033[0m"}
                    % %)
                  l))))
       b))

コードの説明は割愛しますが map の中の副作用が遅延しないよう,
dorun で囲んでいることだけ注記しておきます.

stage

盤の初期状態を表す文字列のシーケンス b と, ミリ秒単位の次のステップまでの待ち時間 w が与えられた場合に,
端末のクリアした後,

• 盤面を表示 bprint
• w ミリ秒の待ち
• 一段階の処理 step

をループします.
一段階の処理の結果が, 処理前と変わらない場合はループを終了します.

(print "\033[2J") ; clear
(loop [b b]
  (bprint b)
  (Thread/sleep w)
  (let [a (mapv #(apply str %) (step (mapv vec b) \space 3))]
    (if (not= a b)
        (recur a))))

step に渡す際に, 文字列のシーケンス b を,

(mapv vec b)

で文字のベクタのベクタに変換し, step によって処理された結果の
ベクタのベクタを

(mapv #(apply str %) ...)

で文字列のベクタにしています.

from-file

ファイル名 f と待ち時間 w を与えると,
ファイルから文字列を読み出し stage を実行します.
待ち時間は省略でき, デフォルトは 500 ミリ秒です.

([f w] (stage (string/split (slurp f) #"\n") w))
([f] (from-file f 500)))

if-let

ロードされた場合にもし引数があれば,
その最初の引数がファイル名であるとして,
待ち時間を指定せずに from-file を呼び出します.

(if-let [f (first *command-line-args*)]
  (from-file f))