今日の一行 2006-04-20 [quiz] 部分木の格上げ
http://oss.timedia.co.jp/index.fcgi/kahua-web/show/ossz/oneline/2006-04-20

「述語と木を与えて，述語を満すラベルの付いた部分木をその親の直ぐの弟にする関数を書け．」という問題。またまた出遅れ気味の回答。この翌日で、逆に部分木を格下げする問題も出題されているけど、こちらはカテゴリがquizではないらしいので手をつけないことにしよう。この問題だけで力尽きたともいう。

(define (lookup subtree pred)
  (let lookup-for-suns ((suns (cdr subtree)))
    (cond ((null? suns) '())
          ((pred (caar suns)) (car suns))
          (else
           (lookup-for-suns (cdr suns))))))

(define (include? subtree pred)
  (let check-for-suns ((suns (cdr subtree)))
    (cond ((null? suns) #f)
          ((pred (caar suns)) #t)
          (else
           (check-for-suns (cdr suns))))))

(define (without-grandchild? tree)
  (or (null? (cdr tree))
      (let without-children? ((suns (cdr tree)))
        (cond ((null? suns) #t)
              ((null? (cdr (car suns)))
               (without-children? (cdr suns)))
              (else #f)))))

(define (extract tree pred)
  (cond ((null? tree) '())
        ((pred (caar tree))
         (extract (cdr tree) pred))
        (else
         (cons (car tree)
               (extract (cdr tree) pred)))))

(define (rankup tree pred)
  (if (without-grandchild? tree)
      tree
      (cons (car tree)
            (let rankup-for-suns ((suns (cdr tree)))
              (cond ((null? suns) '())
                    ((include? (car suns) pred)
                     (cons
                      (cons (caar suns)
                            (extract (cdar suns) pred))
                      (cons (lookup (car suns) pred)
                            (rankup-for-suns (cdr suns)))))
                    (else
                     (cons (rankup (car suns) pred)
                           (rankup-for-suns (cdr suns)))))))))

(define test-tree
  (list 'A (list 'B (list 'F)
                    (list 'G (list 'L)
                             (list 'M)))
           (list 'C (list 'H)
                    (list 'I (list 'N)
                             (list 'O (list 'P)
                                      (list 'Q)))
                    (list 'J))
           (list 'D)
           (list 'E (list 'K))))

(define eq-I? (lambda (x) (eq? 'I x)))

gosh> test-tree
(A (B (F) (G (L) (M))) (C (H) (I (N) (O (P) (Q))) (J)) (D) (E (K)))
gosh> (rankup test-tree eq-I?)
(A (B (F) (G (L) (M))) (C (H) (J)) (I (N) (O (P) (Q))) (D) (E (K)))

いかにも、SICPの前半を読んでいる最中です、という雰囲気のただよう回答にみえる。きをあつかうのは大変だ。