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

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