麻雀の待ちを出力する問題を 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))