麻雀とPrologとCommon Lisp

前の投稿Prologのようなものを作る - nptclのブログでは、 Common LispでPrologのようなものを作りました。
これが想像以上にPrologっぽかったので驚きました。
ちゃんとPrologしてますよ。

実は今まで私はPrologを使ったことがありませんでした。
でもせっかくうまく動いているようなので、勉強として何か作ることにします。
なんとなく麻雀のあがり判定を作りたいと思っていました。
やってみます。

1. 判定する内容

あがり判定の何が難しいかというと、 形になっているかどうかじゃないでしょうか。
役の判定ではなく、面子とアタマがちゃんとそろっているかどうかの確認です。

七対子や国士無双のように変則的なものもありますが、 こういうのは逆に判定しやすいと思いますので考えません。
さらに面前オンリー、暗槓も無しとします。
その方が難しいからです。

順子か刻子が合わせて4つ、対子が1つあるかどうか判定します。
まずは用語の説明をします。

順子（しゅんつ）：🀉🀊🀋 　数値が3並つんでいるもの。
刻子（こうつ）：🀀🀀🀀 　同じものが3つ並んでいるもの。
対子（といつ）：🀟🀟 　同じものが2つ並んでいるもの。

あがり形式の例を下記に示します。

あがり例：🀉🀊🀋🀓🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀

あがりじゃない例も示します。

途中の例：🀉🀊🀋🀓🀔🀔🀕🀕🀘🀟🀟🀀🀀🀀

ではどうやって判定するのでしょうか。
順に説明しますので、まずはCommon Lispの世界で準備をしましょう。

2. Common Lispで準備

matchをロードして準備してください。
init-matchまで済ませたものとします。

麻雀は手元に牌が14個あってあがりとなります。
牌の種類は、Lispのリストを使って次のように表現します。

(man 4)

manは萬子、pinは筒子、souは索子です。
例を挙げると🀊🀡🀐は、 ((man 4) (pin 9) (sou 1))。
三元牌🀆🀅🀄は、 ((haku nil) (hatu nil) (chun nil))。
風牌🀀🀁🀂🀃は、 ((east nil) (south nil) (west nil) (north nil))。

あがりの例である次の内容を考えます。

🀉🀊🀋🀓🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀

この内容をCommon Lispで表してみましょう。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6) (sou 7)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

配牌があがっているかどうかの確認を行う、 Prologのルールagari-allがあるとします。
これが本題なのですが、例えば次のように宣言されているものとします。

(defrule (agari-all ?x)
  ...)

先行して、Common Lispから呼び出す方法を示します。

(multiple-value-bind (list bool)
  (match-true
    `(agari-all ,*haipai*))
  (format t "~A, ~A~%" list bool))

正しく動作した場合は、次のように出力されるはずです。

NIL, T

それでは、Prologの世界に移動して、 ルールagari-allを作成しましょう。

3. 面子を削除する

ここからはPrologの世界です。

面子とは、順子と刻子のことです。
判定のアルゴリズムとして考えたのは、

「面子をすべて削除したら対子だけが残るか？」

というものです。
次の例を考えましょう。

あがり例：🀉🀊🀋🀓🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀

それではどんどん削除していきます。

順子🀉🀊🀋削除： 🀓🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀
順子🀓🀔🀕削除： 🀔🀕🀖🀟🀟🀀🀀🀀
順子🀔🀕🀖削除： 🀟🀟🀀🀀🀀
刻子🀀🀀🀀削除： 🀟🀟

残った牌が、対子🀟🀟なのであがりです。

では、順子と刻子の判定から見て行きます。

刻子の判定は簡単です。
全部同じかどうか調べればいいだけですから。
例えばこんな感じ。

(defrule (koutu ?x ?x ?x))

問題は順子です。
順番を考えるために、次の規則を作成します。

(defrule (order2 1 2))
(defrule (order2 2 3))
(defrule (order2 3 4))
(defrule (order2 4 5))
(defrule (order2 5 6))
(defrule (order2 6 7))
(defrule (order2 7 8))
(defrule (order2 8 9))

isとか使って計算したほうがいいの？とも思いましたが、 多分上記のようにダイレクトに列挙したほうがいいです。
order2は2つの数値の比較なので、 これを用いて2つの麻雀牌の判定を行います。

(defrule (order-pair (?n ?x) (?n ?y))
  (order2 ?x ?y))

順子の判定は次の通り。

(defrule (shuntu ?x ?y ?z)
  (order-pair ?x ?y)
  (order-pair ?y ?z))

今回は上記のものを用いますが、問題もあります。
それは逆順は順子と判定されないということです。
つまり🀚🀛🀜は順子ですが、 🀜🀛🀚は否定されます。
もしちゃんとやりたいならshuntuに規則を追加するだけですが、 今回作成するものは上記の定義で話を進めます。

例は次の通り。

(shuntu (pin 2) (pin 3) (pin 4))
-> true

(shuntu (pin 4) (pin 3) (pin 2))
-> fail

では面子を削除する、agari-all-removeを作成します。
引数は次の通りです。

(defrule (agari-all-remove 第一引数 第二引数 第三引数)
  ...)

第一引数は、ループ用の変数。
第二引数は、削除した全体の牌。
第三引数は、返却用。

例えば、次の配牌を考えます。

🀅🀅🀔🀕🀖🀄

ループ用の変数には、先頭から順番に牌を指定します。
最初は🀅です。
実行内容は下記の通り。

実行: 第一引数：1番目🀅、 第二引数：🀅🀅🀔🀕🀖🀄
刻子🀅🀅🀅があるかどうか調べる。
無いので次のループへ。

実行: 第一引数：2番目🀅、 第二引数：🀅🀅🀔🀕🀖🀄
刻子🀅🀅🀅は無い。

実行: 第一引数：3番目🀔、 第二引数：🀅🀅🀔🀕🀖🀄
刻子🀔🀔🀔は無い、 順子🀔🀕🀖は有るので削除。

実行: 第一引数：1番目🀅、 第二引数：🀅🀅🀄、無い。

実行: 第一引数：2番目🀅、 第二引数：🀅🀅🀄、無い。

実行: 第一引数：3番目🀄、 第二引数：🀅🀅🀄、無い。

よって、第三引数に🀅🀅🀄を返却。

コードは次の通り。

(defrule (agari-all-remove () ?x ?x))
(defrule (agari-all-remove (?a . _) ?x ?r)
  (agari-shunkou-all ?a ?x ?xp)
  (agari-all-remove ?xp ?xp ?r))
(defrule (agari-all-remove (_ . ?xs) ?x ?r)
  (agari-all-remove ?xs ?x ?r))

典型的な再帰呼出です。
順子と刻子の判定を、agari-shunkou-all規則に任せているので説明します。

まずは、牌を見つけるfind、牌を削除するdelete1を作ります。
findはただ探すだけなので、定義も簡単です。

(defrule (find ?x (?x . _)))
(defrule (find ?x (_ . ?z)) (find ?x ?z))

delete1は、指定した牌をたった一つだけ削除します。
さらにfindのように、牌が見つからなかったら失敗します。

(defrule (delete1 ?x (?x . ?ys) ?ys))
(defrule (delete1 ?x (?y . ?xs) (?y . ?ys))
  (delete1 ?x ?xs ?ys))

まずは順子を削除してみましょう。

(defrule (agari-shunkou-all ?a ?x ?r)
  (shuntu ?a ?b ?c)
  (find ?b ?x)
  (find ?c ?x)
  (delete1 ?a ?x ?x1)
  (delete1 ?b ?x1 ?x2)
  (delete1 ?c ?x2 ?r))

第一引数は順子の最初の牌。
第二引数は配牌全体。
第三引数は返却です。

例えば

(agari-shunkou-all 🀔 (🀅🀅🀔🀕🀖🀄) ?r)

のような場合を考えます。

最初の行の、

(shuntu 🀔 ?b ?c)

は、順子が作成されて?bと?cに割り当てられます。
つまり次の通り。

(shuntu 🀔 🀕 🀖)

次の行のfindは、もし見つからなかったら終了です。
今回は次のような実行なので見つかります。

(find 🀕 (🀅🀅🀔🀕🀖🀄))
(find 🀖 (🀅🀅🀔🀕🀖🀄))

最初の要素🀔は 絶対に存在するのでfindを省略しています。

順子すべてが見つかったら削除です。

(delete1 🀔 (🀅🀅🀔🀕🀖🀄) (🀅🀅🀕🀖🀄))
(delete1 🀕 (🀅🀅🀕🀖🀄) (🀅🀅🀖🀄))
(delete1 🀖 (🀅🀅🀖🀄) (🀅🀅🀄))

結果、?rに(🀅🀅🀄)が 返却されます。

これで順子は完了です。
刻子はもっと簡単です。

(defrule (agari-shunkou-all ?a ?x ?r)
  (delete1 ?a ?x ?x1)
  (delete1 ?a ?x1 ?x2)
  (delete1 ?a ?x2 ?r))

順子とは違って、刻子は配牌全体から判定する必要がありません。
findを行う必要がなくなるので、 delete1だけで済ませました。

順子の判定と刻子の判定は、 どちらも同じ規則agari-shunkou-allに配置しました。
こうすることで、バックトラッキングが動作して 適切な形になるまで判定してくれることを期待しています。

さて、これでagari-all-removeは完了です。
呼び出し用のagari-allを作成しましょう。

(defrule (agari-all ?x)
  (agari-all-remove ?x ?x (?y ?y)))

この呼び出しでは、agari-all-removeの返却値である第三引数を(?y ?y)にして、 対子のパターンマッチを行っています。
これで判定用の規則はすべて完了ですので、Common Lispの世界に戻りましょう。

4. 実行と問題点

では最初に例で出した、次の配牌を判定してみます。

🀉🀊🀋🀓🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀

実行するコードは次の通り。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6) (sou 7)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(multiple-value-bind (list bool)
  (match-true
    `(agari-all ,*haipai*))
  (format t "~A, ~A~%" list bool))

結果は下記の通り。

NIL, T

うまく行きました。
もう少しPrologの機能を使ってみましょう。
次のようなコードを考えます。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    ?x (sou 5) (sou 5) (sou 6) (sou 6) (sou 7)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

元は(sou 4)の個所を、?xの変数にしています。
つまりはこんな感じ。

🀉🀊🀋🀫🀔🀔🀕🀕🀖🀟🀟🀀🀀🀀

実行してみましょう。

(multiple-value-bind (list bool)
  (match-true
    `(agari-all ,*haipai*))
  (format t "~A, ~A~%" list bool))

実行結果

((?X SOU 4)), T

ちゃんと出てきました。
個人的にはすごいと思います。
というか何でこうなるのか全然わからん。
自分でPrologを作っておいてわからんとは不思議な話です。

さて、ここまでは調子よく行ってましたが、ここからは問題だらけです。
変数を使った例では 🀓が出てきましたが、 両面待ちなので🀖も答えのはずです。

こういう時はqueryを使って バックトラッキングを確認します。

(multiple-value-bind (list bool)
  (query-lisp
    `(agari-all ,*haipai*))
  (format t "~A, ~A~%" list bool))

?X = (SOU 4)
(y or n) n

?X = (SOU 4)
(y or n) n
・・・

やってみると、いつまでたっても回答が出てこないのです。
それなら重複しないように全部の解を出してみましょう。

(let (list)
  (match-lisp
    `(agari-all ,*haipai*)
    (lambda (alist)
      (let ((x (cdr (assoc '?x alist :test #'eq))))
        (pushnew x list :test #'equal)
        nil)))
  (format t "~A~%" list))

★止まってしまう

これがもう全然帰ってこないんです。
それなら全部出力して、moreコマンドとかで確認してみます。

(match-lisp
  `(agari-all ,*haipai*)
  (lambda (alist)
    (format t "~A~%" alist)
    nil))

・・・
((?X SOU 4))
((?X SOU 7))
((?X SOU 4))
((?X SOU 7))
((?X SOU 4))
((?X SOU 7))
・・・

膨大な出力の中から、求める回は見つけることができました。

agari-allの最大の問題は遅い事です。
変数を使ったから遅くなるというわけではなく、 もしあがり形式ではなかった場合も遅くなります。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6) (sou 9)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(multiple-value-bind (list bool)
  (match-true
    `(agari-all ,*haipai*))
  (format t "~A, ~A~%" list bool))

実行結果
NIL, NIL

判定した配牌は下記の通り。

🀉🀊🀋🀓🀔🀔🀕🀕🀘🀟🀟🀀🀀🀀

ただしこちらは完全に止まるという訳ではなく、数秒で戻ってきました。
個人的には数秒すら遅いです。
何とかならないものか考えます。

5. あがりかどうかだけを考える

高速化のポイントは、用途を限定することです。
今回は、最初の目的である「あがりかどうか」だけに注目します。
つまり配牌に変数?xを使うのをやめましょう。

Prologで高速化を行う場合は、カットを使います。
配牌に変数がない場合は、一体どこでカットできるでしょうか？

色々考えたのですが、順子と刻子の判定のときにカットできそうです。
順子の例を示します。

;; ★問題ありバージョン
(defrule (agari-shunkou! ?a ?x ?r)
  (shuntu ?a ?b ?c) !
  (find ?b ?x) !
  (find ?c ?x)
  (delete1 ?a ?x ?x1)
  (delete1 ?b ?x1 ?x2)
  (delete1 ?c ?x2 ?r))

名前をagari-shuntu!に変更しています。
元のagari-shuntu-allとの違いは、カット!を2か所追加したことです。
配牌には変数が無いはずなので、findで見つからなかった場合は、 すぐ処理を終了させても問題ないはずです。
ただし、一体どこまで戻るのかということはちゃんと考えなければいけません。
上記の例の場合、順子の判定が失敗したら、刻子の判定まで飛ばしてしまいます。
次のように修正しましょう。

(defrule (agari-shuntu ?a ?x ?r)
  (shuntu ?a ?b ?c) !
  (find ?b ?x) !
  (find ?c ?x)
  (delete1 ?a ?x ?x1)
  (delete1 ?b ?x1 ?x2)
  (delete1 ?c ?x2 ?r))

(defrule (agari-koutu ?a ?x ?r)
  (delete1 ?a ?x ?x1) !
  (delete1 ?a ?x1 ?x2) !
  (delete1 ?a ?x2 ?r))

(defrule (agari-shunkou ?a ?x ?r)
  (agari-shuntu ?a ?x ?r))
(defrule (agari-shunkou ?a ?x ?r)
  (agari-koutu ?a ?x ?r))

刻子の判定にもカットを入れました。
ルールを分けることで、カットされた際にどこまで戻るかをコントロールしています。
それでは、これらの判定を用いた規則agariを作成します。

(defrule (agari-remove () ?x ?x))
(defrule (agari-remove (?a . _) ?x ?r)
  (agari-shunkou ?a ?x ?xp)
  (agari-remove ?xp ?xp ?r))
(defrule (agari-remove (_ . ?xs) ?x ?r)
  (agari-remove ?xs ?x ?r))

(defrule (agari ?x)
  (agari-remove ?x ?x (?y ?y)))

実行例を示します。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6) (sou 7)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(multiple-value-bind (list bool)
  (match-true
    `(agari ,*haipai*))
  (format t "~A, ~A~%" list bool))

;; NIL, T

失敗例を示します。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6) (sou 9)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(multiple-value-bind (list bool)
  (match-true
    `(agari ,*haipai*))
  (format t "~A, ~A~%" list bool))

;; NIL, NIL

この方法でも返却まで多少の遅延があります。
もう少し効率の良いやり方があるのかもしれません。
もしかしたら配牌がソートされていればもう少し方法があるかもしれません。
今の自分では、この方法が限界だと思います。

6. あがり牌を探す

最後に、あがり牌を効率よく探す方法を示します。

変数?xを使った例では、動作がとまってしまいました。
たった14個しかデータが無いのに難しいものですね。

やり方は、テンパイ時の配牌を、agari-removeに渡すというものです。
agari-removeは、面子である順子と刻子を削除するルールです。
agariの中では、面子を削除したら牌が対子になっているか確認していました。

今回は、対子の確認ではなく、下記の4つの場合を考えます。

1つめ：🀃、 単騎待ち、あがり牌🀃。
2つめ：🀊🀋🀄🀄、 両面待ち（ペンチャン待ち）、 あがり牌🀉🀌。
3つめ：🀙🀙🀃🀃、 シャンポン待ち、あがり牌🀙🀃。
4つめ：🀖🀘🀍🀍、 カンチャン待ち、あがり牌🀗。

ここまで分かればあがり牌は求められます。
あがり牌を求める規則tenpaiを示します。

(defrule (tenpai-atama (?a . _) ?x ?a ?r)
  (delete1 ?a ?x ?y)
  (delete1 ?a ?y ?r))
(defrule (tenpai-atama (_ . ?xs) ?x ?a ?r)
  (tenpai-atama ?xs ?x ?a ?r))

(defrule (tenpai-match2 ?a ?x ?x ?a))  ;; シャンポン待ち
(defrule (tenpai-match2 _ ?x ?x ?x))   ;; シャンポン待ち
(defrule (tenpai-match2 _ ?x ?y ?r)    ;; 両面待ち（ペンチャン待ち）
  (or (shuntu ?x ?y ?r)
      (shuntu ?y ?x ?r)
      (shuntu ?r ?x ?y)
      (shuntu ?r ?y ?x)))
(defrule (tenpai-match2 _ ?x ?y ?r)    ;; カンチャン待ち
  (or (shuntu ?x ?r ?y)
      (shuntu ?y ?r ?x)))

(defrule (tenpai-match (?x) ?x))       ;; 単騎待ち
(defrule (tenpai-match ?x ?r)
  (tenpai-atama ?x ?x ?a (?y ?z))
  (tenpai-match2 ?a ?y ?z ?r))

(defrule (tenpai ?x ?r)
  (agari-remove ?x ?x ?y)
  (tenpai-match ?y ?r))

実行してみましょう。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 5) (sou 5) (sou 6) (sou 6)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(let (list)
  (match-lisp
    `(tenpai ,*haipai* ?x)
    (lambda (alist)
      (let ((x (cdr (assoc '?x alist :test #'eq))))
        (pushnew x list :test #'equal))
      nil))
  (format t "~A~%" list))

配牌は下記のとおり。
🀉🀊🀋🀓🀔🀔🀕🀕🀟🀟🀀🀀🀀

((SOU 4) (SOU 7))

つまり、🀓🀖です。

残念なことに、多少待ち時間があります。
以前よりは全然マシですけどね。
今はこの程度で我慢することにします。

両面とシャンポンの多面待ちを実行してみます。

(defparameter *haipai*
  '((man 3) (man 4) (man 5)
    (sou 4) (sou 4) (sou 4) (sou 5) (sou 6)
    (pin 7) (pin 7)
    (east nil) (east nil) (east nil)))

(let (list)
  (match-lisp
    `(tenpai ,*haipai* ?x)
    (lambda (alist)
      (let ((x (cdr (assoc '?x alist :test #'eq))))
        (pushnew x list :test #'equal))
      nil))
  (format t "~A~%" list))

配牌は下記のとおり。
🀉🀊🀋🀓🀓🀓🀔🀕🀟🀟🀀🀀🀀

((SOU 7) (PIN 7) (SOU 4))

つまり、🀓🀖🀟です。
うまく行ってるみたいです。

さいごに

麻雀牌ですけど、これUnicode文字らしいですよ。

🀀🀁🀂🀃🀆🀅🀄
🀇🀈🀉🀊🀋🀌🀍🀎🀏
🀐🀑🀒🀓🀔🀕🀖🀗🀘
🀙🀚🀛🀜🀝🀞🀟🀠🀡

すごい！
がんばれば、こんなコードも作れますね。

(defrule (刻子 ?x ?x ?x))
(match (刻子 🀀 🀀 ?🀫))
-> ((?🀫 . 🀀)), T