ペントミノ パズル(明治ミルクチョコパズル)をGaucheで解く(1時間で解けるようになった)

Karetta|Cパズルプログラミング-再帰編|ペントミノを参考にアルゴリズムを改良した。

• ピースXを左上1/4に制限
• 近傍を予備的にチェック
• 使用済みピースを調べない(これは前回もそうだった)

ちゃんと2339通りが出力される。1時間(PenR E2140 Mem 2GB)で。
この限界を越えるには、solveの再帰を末尾再帰にするしかあるまい。
どう書く.orgに投稿しようかな。

(use srfi-1)
(use srfi-43)

(define count 0)
(define board (make-vector 60 #f))

(define (check-board-multiple5-space?)
  (define (fill start)
    (define l (list start))
    (let propagete! ((x start))
      (let ((m (remove! (lambda (p)
			  (or (not p) (vector-ref board p) (memq p l)))
			(receive (row col) (quotient&remainder x 10)
			  (list (and (> row 0) (- x 10))
				(and (< row 5) (+ x 10))
				(and (> col 0) (- x 1))
				(and (< col 9) (+ x 1)))))))
	(unless (zero? (length m))
	  (set! l (append! m l))
	  (for-each propagete! m))))
    l)
  (let ((i (vector-index not board)))
    (or (not i)
	(zero? (remainder (length (fill i)) 5)))))

(define (plot mino index v)
  (for-each (lambda (xy)
	      (vector-set! board (+ index (* (car xy) 10) (cdr xy)) v))
	    mino))

(define (solve remain-kind)
  (let1 i (vector-index not board)
    (if i
      (receive (row col) (quotient&remainder i 10)
	(for-each (lambda (kind)
		    (for-each (lambda (mino)
				(when (every (lambda (xy)
					       (let ((r (+ (car xy) row))
						     (c (+ (cdr xy) col)))
						 (and (>= r 0) (< r 6) (>= c 0) (< c 10)
						      (not (vector-ref board (+ (* r 10) c))))))
					     mino)
				  (plot mino i kind)
				  (when (check-board-multiple5-space?)
				    (solve (delete kind remain-kind)))
				  (plot mino i #f)))
			      (vector-ref pentominos kind)))
		  remain-kind))
      ;; found answer
      (print-board))))

(define (main args)
  (for-each (lambda (i)
	      (plot (car (vector-ref pentominos 0)) i 0)
	      (solve (iota 11 1))
	      (plot (car (vector-ref pentominos 0)) i #f))
	    '(2 3 4 11 12 13 14)))

(define (print-board)
  (print "Answer No." (inc! count))
  (vector-for-each (lambda (i x)
		     (if x
		       (format #t "~X" x)
		       (display '*))
		     (when (= 9 (remainder i 10)) (newline)))
		   board)
  (newline))

(define (to-data mino)
  (let ((offset (string-scan (car mino) "#")))
    (append-map (lambda (line row)
		  (filter-map (lambda (x col)
				(if (char=? x #\space)
				  #f
				  (cons row (- col offset))))
			      (string->list line) (iota 5)))
		mino (iota 5))))

(define pentominos
  (list->vector
   (map (cut map to-data <>)
	'(((" #"
	    "###"
	    " #"))
	  
	  ((" #"
	    "###"
	    "  #")
	   
	   (" ##"
	    "##"
	    " #")
	   
	   ("#"
	    "###"
	    " #")
	   
	   (" #"
	    " ##"
	    "##")
	   
	   (" #"
	    "###"
	    "#")
	   
	   (" #"
	    "##"
	    " ##")
	   
	   ("  #"
	    "###"
	    " #")
	   
	   ("##"
	    " ##"
	    " #"))
	  
	  (("####"
	    "#")
	   
	   ("#"
	    "#"
	    "#"
	    "##")
	   
	   ("   #"
	    "####")
	   
	   ("##"
	    " #"
	    " #"
	    " #")
	   
	   ("####"
	    "   #")
	   
	   ("##"
	    "#"
	    "#"
	    "#")
	   
	   ("#"
	    "####")
	   
	   (" #"
	    " #"
	    " #"
	    "##"))
	  
	  ((" #"
	    "##"
	    "#"
	    "#")
	   
	   ("##"
	    " ###")
	   
	   (" #"
	    " #"
	    "##"
	    "#")

	   ("###"
	    "  ##")
	   
	   ("#"
	    "##"
	    " #"
	    " #")
	   
	   (" ###"
	    "##")

	   ("#"
	    "#"
	    "##"
	    " #")
	   
	   ("  ##"
	    "###"))
	  
	  (("##"
	    "##"
	    "#")
	   
	   ("##"
	    "###")
	   
	   (" #"
	    "##"
	    "##")
	   
	   ("###"
	    " ##")
	   
	   ("##"
	    "##"
	    " #")
	   
	   ("###"
	    "##")

	   ("#"
	    "##"
	    "##")

	   (" ##"
	    "###"))

	  ((" #"
	    "##"
	    " #"
	    " #")
	   
	   ("####"
	    " #")
	   
	   ("  #"
	    "####")
	   
	   ("#"
	    "##"
	    "#"
	    "#")

	   (" #"
	    "####")

	   ("#"
	    "#"
	    "##"
	    "#")

	   (" #"
	    " #"
	    "##"
	    " #")
	   
	   ("####"
	    "  #"))
	  
	  (("##"
	    " #"
	    " ##")
	   
	   ("  #"
	    "###"
	    "#")
	   
	   ("#"
	    "###"
	    "  #")
	   
	   (" ##"
	    " #"
	    "##"))
	  
	  (("#"
	    "###"
	    "#")
	   
	   (" #"
	    " #"
	    "###")
	   
	   ("  #"
	    "###"
	    "  #")
	   
	   ("###"
	    " #"
	    " #"))
	  
	  (("# #"
	    "###")
	   
	   ("##"
	    " #"
	    "##")
	   
	   ("###"
	    "# #")
	   
	   ("##"
	    "#"
	    "##"))
	  
	  (("#"
	    "#"
	    "###")
	   
	   ("  #"
	    "  #"
	    "###")
	   
	   ("###"
	    "  #"
	    "  #")
	   
	   ("###"
	    "#"
	    "#"))
	  
	  (("#"
	    "##"
	    " ##")
	   
	   ("  #"
	    " ##"
	    "##")
	   
	   ("##"
	    " ##"
	    "  #")
	   
	   (" ##"
	    "##"
	    "#"))
	  
	  (("#"
	    "#"
	    "#"
	    "#"
	    "#")
	   
	   ("#####"))))))