2007/05/28

パズル「グリッド色分け問題」少し改良版

「組合せ最適化」をぱらぱらめくったけど安直な方法が見つけられなかったので、オクトーバーフェストに行ってビールをのみながらほげほげ考えていたら、行ごとに組み合わせを求めつつ枝刈りして、それを枝刈りしながら列に集めれば、ずいぶんメモリを省略できるはずだと思いついた。実際これはうまくいって、4x4程度なら瞬時に計算できる。

たとえば10番目に得られた結果。10番目であることに特に意味はない。
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 


(use srfi-1)
(use util.stream)

(define (line-colorings width colors pred)
(cond ((= 1 width)
(apply stream (zip (iota colors colors -1))))
((= 0 colors)
stream-null)
(else
(let R ((top colors))
(if (= 0 top)
stream-null
(stream-append
(stream-filter
pred
(stream-map (cut cons top <>)
(line-colorings (- width 1) colors pred)))
(R (- top 1))))))))

;; (stream of lists) -> (stream of lists)
(define (grid-colorings hight rows patterns pred)
(cond ((= 1 hight)
patterns)
((stream-null? patterns)
stream-null)
(else
(let R ((top (stream-car patterns))
(rest (stream-cdr patterns)))
(stream-append
(stream-filter
pred
(stream-map (cut append top <>)
(grid-colorings (- hight 1) rows patterns pred)))
(if (stream-null? rest)
stream-null
(R (stream-car rest) (stream-cdr rest))))))))

(define (tiles lines rows colors)
(stream-filter
(cut egalite? <> (quotient (* lines rows) colors) colors)
(grid-colorings lines rows
(line-colorings rows colors
(cut stripe? <>))
(cut staggered? <> rows))))


;;;; predicates
; Doesn't the list contain adjacent cells with same color?
(define (stripe? ls)
(cond ((null? ls)
#t)
((null? (cdr ls))
#t)
(else
(let ((v (car ls))
(w (cadr ls)))
(and (not (= v w))
(stripe? (cdr ls)))))))

; Doesn't the list contain vertically adjucent cells with same color?
(define (staggered? ls rows)
(let R ((rows (transpose ls rows)))
(if (null? rows)
#t
(and (stripe? (car rows))
(R (cdr rows))))))

; Does each color appear at least n times?
(define (egalite? ls n c)
(let R ((c c) (ls ls))
(cond ((= c 0) #t)
((< (length ls) n) #f)
(else
(receive (the-colors rest)
(partition (cut = c <>) ls)
(and (>= (length the-colors) n)
(R (- c 1) rest)))))))



;;;; some list utils
(define (group ls n)
(receive (front end)
(split-at ls n)
(if (null? end)
(list ls)
(cons front (group end n)))))
(define (transpose ls rows)
(apply zip (group ls rows)))

0 件のコメント: