「こんなプログラムを書いてみよう」 in Scheme

文字列の集合{ BAB, AAB, BAA, AAA, ABA }があるとき、これらのすべてを1回ずつ含み、かつ、3文字の部分文字列としてはこれらの文字列しか含まない文字列は、BABAAABとBAAABABの２通りある。

文字列の集合が{ BAB, AAB, BAA, AAA }のときは、そのような条件では文字列が作れない。

こんなプログラムを書いてみよう - きしだのはては

たまたま見つけたパズル。もう1週間も前の話題だから完全に乗り遅れてるんだけど、せっかく解けたので。
クロージャでネットワークを作っといて、あとは勝手に解いてもらう方法を採用。

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

(define (make-node name)
  (let1 children '()
    (define (self msg . args)
      (case msg
        [(name) name]
        [(add) (set! children (car args))]
        [(traverse)
         (match-let1 (n path paths cont) args
           (define (rec children paths)
             (cond [(member name path)
                    (cont paths)]
                   [(= n 0)
                    (cont (cons (reverse (cons name path)) paths))]
                   [(null? children)
                    (cont paths)]
                   [else
                    ((car children)
                     'traverse
                     (- n 1)
                     (cons name path)
                     paths
                     (lambda (paths)
                       (rec (cdr children) paths)))]))
           (rec children paths))]))
    self))

(define (list->nodes lst)
  (define (child? node1 node2)
    (let ((name1 (node1 'name))
          (name2 (node2 'name)))
      (every eqv? (string->list name1) (cdr (string->list name2)))))
  (let1 nodes (map make-node lst)
    (dolist (node nodes)
      (node 'add (filter (cut child? <> node)  nodes)))
    nodes))

(define (problem lst)
  (define (rec paths nodes cont)
    (if (null? nodes)
        (cont paths)
        ((car nodes)
         'traverse
         (- (length lst) 1)
         '()
         paths
         (lambda (paths)
           (rec paths (cdr nodes) cont)))))
  (rec '() (list->nodes lst) identity))

完全に手段が目的のコード。さすがにJavaより長いと悲しくなる…。

gosh> (for-each print (problem '("bab" "aab" "baa" "aaa" "aba")))
(baa aaa aab aba bab)
(bab aba baa aaa aab)
#
gosh> (for-each print (problem '("aba" "bab" "abc" "bca" "cab" "caa" "aab")))
(caa aab abc bca cab aba bab)
(caa aab aba bab abc bca cab)
(cab abc bca caa aab aba bab)
(cab aba bab abc bca caa aab)
#
gosh> (for-each print (problem '("aba" "bab" "abc" "cab" "caa" "aab")))
#
gosh>