Scheme:Tree

Scheme:Tree

関連ファイル

木の統合

(Scheme:リスト処理から移動しました。)

次のような問題にしばしば出会う。

ノード(シンボル)の親子関係の集合が与えられているとき、 それらを全て満たす木の集合を求める。

親子関係はこんなリストで与えられている:

  (親 子1 子2 …)

子の親は常にユニーク。循環は無いものとする。 兄弟関係(親を共有する子の順序)は保存する。 入力には同じシンボルが「親」に二度以上出現しないものとする。

例えば、最初のセットが ((A B C) (B D E) (F G) (H F I) (J A))の場合、 出力は:

  ((J (A (B (D) (E)) (C))
   (H (F (G)) (I))
  )

バリエーションとして、次のような問題も考えられる。

今までに少なくとも数回はこういう問題を解くコードを書いた覚えが あるんだけど、その度に適当に書き散らしてきたので。 なんかカッコいい方法がありそうだよなあ。

とりあえず、副作用無しバージョン。stateとして残りのrelationの集合と 現在のtreeの集合を渡して行かなければならないのがちょっとmessy。

(use srfi-1)

(define (tree-merge relations)
  (define (pick node trees relations)
    (receive (picked rest)
        (partition (lambda (r) (eq? node (car r))) relations)
      (if (null? picked)
        (receive (subtree other-trees)
            (partition (lambda (t) (eq? node (car t))) trees)
          (if (null? subtree)
            (values (list node) trees relations)
            (values (car subtree) other-trees relations)))
        (receive (subtrees trees relations)
            (merge-fold (cdar picked) '() trees rest)
          (values (cons node subtrees) trees relations)))))

  (define (merge-fold kids subtrees trees relations)
    (if (null? kids)
      (values (reverse subtrees) trees relations)
      (receive (subtree trees relations) (pick (car kids) trees relations)
        (merge-fold (cdr kids) (cons subtree subtrees) trees relations))))

  (define (merge trees relations)
    (if (null? relations)
      trees
      (receive (subtree trees relations)
          (pick (caar relations) trees relations)
        (merge (cons subtree trees) relations))))

  (merge '() relations))

nobsun (2003/08/24 17:21:13 PDT) 複数の親を持たない木だとわかっているなら、こんなのはいかがでしょう。

(define (roots relations)
  (let ((children (delete-duplicates (concatenate (map cdr relations))))
        (parents (map car relations)))
    (filter (lambda (v) (not (memq v children))) parents)))

(define (lookup-tos vertex relations)
  (let ((node (assoc vertex relations)))
    (if node (cdr node) '())))

(define (make-tree relations vertex)
  (cons vertex (map (pa$ make-tree relations) 
                    (lookup-tos vertex relations))))
             
(define (make-forest relations)
  (map (pa$ make-tree relations) (roots relations)))

(define sample-relations
  '((A B C) (B D E) (F G) (H F I) (J A)))

;;(make-forest sample-relations) => ((H (F (G)) (I)) (J (A (B (D) (E)) (C))))

なんかnobsun さんの答えっぽい。でも、不思議な記号なんぞ使ってません。foldr はなんというか、使ってしまって悔しい。サイクルがあるとおわらんし。 - ささだ

(require (lib "list.ss"))

(define (solve tlist)
  (define (make-tree val)
    (if (assoc val tlist) (cons val (map (lambda (x) (make-tree x))
                                         (cdr (assoc val tlist))))
        (list val)))
  
  (define (childp x lst)
    (cond ((null? lst) #f)
          ((member x (cdar lst)) #t)
          (else (childp x (cdr lst)))))

  (foldr (lambda (v l)
           (if (childp (car v) tlist) l (cons v l))) '()
           (map (lambda (l) 
                  (make-tree (car l))) tlist)))

(solve '((A B C) (B D E) (F G) (H F I) (J A)))
;=> ((h (f (g)) (i)) (j (a (b (d) (e)) (c))))

私も挑戦してみました。素朴な解答。一杯飲みながら書いてるんで、ちょっとあやしいです。 −新潟のS

(define (roots sets)
  (define (root? x ls)
    (cond ((null? ls) #t)
          ((member x (cdar ls)) #f)
          (else (root? x (cdr ls)))))
  (define (search-roots ls)
    (cond ((null? ls) '())
          ((root? (caar ls) sets) (cons (car ls) (search-roots (cdr ls))))
          (else (search-roots (cdr ls)))))
  (search-roots sets))
 

(define (make-trees sets)
  (define (child? x)
    (and (atom? x) (not (assoc x sets))))
  (define (make-tree root)
    (cond ((child? root) (list root))
          ((atom? root) (make-tree (assoc root sets)))
          (else (cons (car root) (map make-tree (cdr root))))))
  (map make-tree (roots sets)))


(define test '((A B C) (B D E) (F G) (H F I) (J A)))

;;; > (make-trees test)
;;; ((h (f (g)) (i)) (j (a (b (d) (e)) (c)))) 

子になってない親から展開。

(define (tree-marge relations)
  (define (family x)
    (let ((y (assq x relations)))
      (cons x (if y (map family (cdr y)) '()))))
  (define (difference x y)
    (let loop ((r '()) (x x))
      (if (null? x) r
          (loop (if (memq (car x) y) r (cons (car x) r)) (cdr x)))))
  (map family (difference (map car relations) (apply append (map cdr relations)))))

hirokawa? (2004/02/22 12:08:23 PST): Scheme:マクロの効用のリストの内包表記にあるマクロlist-ofを用いたバージョンです。基本的にいままでのものと同じです。

(use srfi-1)

(define (make-tree rel x)
  (let1 lst (assoc x rel)
            (cons x (if lst (make-forest rel (cdr lst)) '()))))

(define (make-forest rel lst)
  (list-of (make-tree rel x) (x in lst)))

(define (tree-merge rel)
  (list-of (make-tree rel x)
           (x in (map car rel))
           (not (member x (concatenate (map cdr rel))))))

与えられた木から、子→親への対応を作る

(Scheme:リスト処理から移動しました。)

Shiro(2008/05/24 11:55:47 PDT): たまたま昨日、仕事で扱った小ネタ。 初級編クイズになりそうなので書き留めておく。

木構造が与えられる。たとえばこんなの:

(define *tree*
  '(Root (Spine (Neck (Head))
                (RClavicle (RUpperArm (RLowerArm (RHand))))
                (LClavicle (LUpperArm (LLowerArm (LHand)))))
         (RHip (RUpperLeg (RLowerLeg (RFoot))))
         (LHip (LUpperLeg (LLowerLeg (LFoot))))))

つまり、 <tree> := (<name> <tree> ...) という構造。

これから、子→親の対応を表すalistを作る手続きを書け、というもの。 結果の例はこんな感じ。各要素の順序は問わない。

((LHip . Root) (LUpperLeg . LHip) (LLowerLeg . LUpperLeg) (LFoot . LLowerLeg)
 (RHip . Root) (RUpperLeg . RHip) (RLowerLeg . RUpperLeg) (RFoot . RLowerLeg)
 (Spine . Root) (LClavicle . Spine) (LUpperArm . LClavicle)
 (LLowerArm . LUpperArm) (LHand . LLowerArm)
 (RClavicle . Spine) (RUpperArm . RClavicle)
 (RLowerArm . RUpperArm) (RHand . RLowerArm) (Neck . Spine) (Head . Neck))

30分で初級。10分で中級。

Shiro: 他にみつけた回答(なんか流行ってきた):

再帰が身についてるかどうかを見るのに手頃かな。 appendによる無駄も、push!による副作用も嫌う場合、 再帰パターンが樹状であっても結果がまっすぐなリストならfoldで つないでゆけることは覚えとくと便利かもしれません。


木の統合 (親 子 孫 ひ孫 …)

(Scheme:リスト処理から移動しました。)

ryoakg(2008/07/19 20:15:49 PDT): 上の方にある、木の統合をやっていたつもりでしたが勘違いして別の事をやっていました。私がアホだという話は別として折角なので問題として書いておきます。

入力は、元は

  (親 子1 子2 …)

のリストでしたが、

  (親 子 孫 ひ孫 …)

のリストとして扱います。 元のやつと同様に

  ((A B C) (B D E) (F G) (H F I) (J A))

を入力すると

  ((H (F (G) (I)))
   (J (A (B (C) (D (E))))))

になります

子→親 の結果をdottedリストでなく2要素の普通のリストにすれば、相互に逆変換できそうな気がします。(多分こっちの方が広い問題を扱っていると思いますが)

Shiro(2008/07/19 20:35:41 PDT): これは元データに

(define (cvt defs)
  (define (pairs xs) (map list xs (cdr xs)))
  (append-map pairs defs))

を適用すればオリジナルの「木の統合」がそのまま使えるんじゃないですかね。

gosh> (cvt '((A B C) (B D E) (F G) (H F I) (J A)))  ; ((親 子 孫 ...) ...)
((A B) (B C) (B D) (D E) (F G) (H F) (F I) (J A))   ; ((親 子) ...)

ryoakg(2008/07/20 01:34:25 PDT): なるほどぉ、そんな事には考えが及んでいませんでしたが、 親と子だけの2要素のリストに対して上手く働けば、オリジナルもコレも、それにオマケが付いているようなものなのかもしれませんね。 あと私のは、やっぱり間違えてました。

((A B) (B C) (B D) (D E) (F G) (H F) (F I) (J A))   ; ((親 子) ...)

を入れると変でした。あぁ

foldts

Scheme:末尾再帰で木をトラバース

関連

More ...