麻雀の待ちを出力する問題を amb で

毎度流行りには乗り遅れる傾向にあるけど、麻雀の待ちを出力する例の問題をいまさら解いてみる。

「バックトラックするだけの問題なら amb 使えば楽勝でしょ」と思って amb を使ってやってみたんだけど、思いのほかてこずった。しかも、なんだかうまく頭を切り替えられず、いまいち非決定性を活かしきれないコードになってしまっているような気もする。が、これ以上悩んでも自分ではもうコードを劇的に変えるのは難しそうだったので、とりあえず今の時点のものを晒しておく。

ちなみに、麻雀のルールについてよく知らないまま書いているので、そのあたりの間違いは大いにありうる。ただし、七対子に対応してないのは一応心得たうえでの判断ということで。

ソースコード

(use srfi-1)
(use srfi-11)

(define fail #f)

(define-syntax amb
  (syntax-rules ()
    [(_) (fail)]
    [(_ a) a]
    [(_ a b ...)
     (let/cc cont
       (let1 fail0 fail
         (set! fail
               (lambda ()
                 (set! fail fail0)
                 (receive vals (amb b ...)
                   (apply cont vals))))
         a))]))

(define (assert cond)
  (if cond #t (amb)))

(define (select-one pais)
  (let next ([rev '()] [pais pais])
    (assert (not (null? pais)))
    (amb (values (car pais) (fold cons (cdr pais) rev))
         (receive (vs r) (span (cut = (car pais) <>) pais)
           (next (fold cons rev vs) r)))))

(define (select-pattern pais pat)
  (define (collect ms ps vs)
    (if (null? ms)
      (values (reverse vs) ps)
      (receive (v r) (select-one ps)
        (assert (= v (car ms)))
        (collect (cdr ms) r (cons v vs)))))
  (receive (v r) (select-one pais)
    (collect (map (cut + (- v (car pat)) <>) (cdr pat)) r (list v))))

(define (ambiguous-solution pais)
  (define (select-kezi-or-shunzi pais)
    (amb (select-pattern pais '(0 0 0))
         (select-pattern pais '(0 1 2))))
  (define (arrange-rest pais)
    (amb (select-kezi-or-shunzi pais)
         (let*-values ([(x r) (select-pattern pais '(0 0))]
                       [(y _) (select-pattern r (amb '(0 0) '(0 1) '(0 2)))])
           (values x y))))
  (define (<=? . args)
    (every (rec (f x y)
             (or (and (null? x) (null? y))
                 (and (not (> (car x) (car y)))
                      (or (< (car x) (car y))
                          (f (cdr x) (cdr y))))))
           args (cdr args)))
  (let*-values ([(x r) (select-kezi-or-shunzi pais)]
                [(y r) (select-kezi-or-shunzi r)]
                [(z r) (select-kezi-or-shunzi r)]
                [(v w) (arrange-rest r)])
    (assert (and (<=? x y z)
                 (or (= (length v) 2) (<=? z v))))
    (list x y z v w)))

(define (print-solutions pais)
  (define (p s x e)
    (display s) (for-each display x) (display e))
  (define (print-solution x)
    (do ([x x (cdr x)])
        ((null? (cdr x)) (p #\[ (car x) #\]) (newline))
      (p #\( (car x) #\))))
  (let/cc cc
    (set! fail (cut cc #f))
    (print-solution (ambiguous-solution pais))
    (while #t (print-solution (amb)))))

;; (print '(1 1 1 2 2 2 4 5 8 8 8 9 9))
;; (print-solutions '(1 1 1 2 2 2 4 5 8 8 8 9 9))
;; (print '(1 1 2 2 3 3 5 5 5 6 7 9 9))
;; (print-solutions '(1 1 2 2 3 3 5 5 5 6 7 9 9))
;; (print '(1 1 1 2 2 2 3 3 3 5 5 5 9))
;; (print-solutions '(1 1 1 2 2 2 3 3 3 5 5 5 9))
;; (print '(1 2 2 3 3 4 4 8 8 8 9 9 9))
;; (print-solutions '(1 2 2 3 3 4 4 8 8 8 9 9 9))
;; (print '(1 1 1 2 3 4 5 6 7 8 9 9 9))
;; (print-solutions '(1 1 1 2 3 4 5 6 7 8 9 9 9))