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)) )
バリエーションとして、次のような問題も考えられる。
- 結果がDAGになる場合 (子が複数の親を持ち得る)
- 結果がDGになる場合 (循環も許す)
今までに少なくとも数回はこういう問題を解くコードを書いた覚えが あるんだけど、その度に適当に書き散らしてきたので。 なんかカッコいい方法がありそうだよなあ。
- 結果がDAG/DGになる場合、出力形式ってどんな感じになるのですか? hidenao 2003/08/26 05:49:50 PDT
- Shiro (2003/08/26 12:30:16 PDT): 出力は単なるリストのリストでいいでしょう。 (printしない限り、DGもDAGも単なるデータ構造です)。 printする場合は、例えばsrfi-38 のような表現を使う必要があります。Gaucheは今のところ、手続きwrite* に よってsrfi-38形式の印字だけサポートしています (読み込みはまだ)。
とりあえず、副作用無しバージョン。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分で中級。
- 素直に書いてきっかり10分でした -- Pla?(2008/05/25 23:56:13 PDT)
(use util.match) (define (symtree->alist tree) (let1 result '() (let loop ((tree tree)) (match tree ((parent . children) (for-each (lambda (child) (loop child) (push! result (cons (car child) parent))) children) ))) result))
- 最初に書いたやつから4バージョン。append-mapはsrfi-1のを使うよりマクロの方が速かった。所要10分前後 -- naoya_t2008/05/26 04:18:49 PDT
;(use srfi-1) (define-macro (append-map proc l) `(apply append (map ,proc ,l))) (define (foo1 t) (define (itr p t) (cons (cons (car t) p) (if (null? (cdr t)) '() (append-map (cut itr (car t) <>) (cdr t)))) ) (append-map (cut itr (car t) <>) (cdr t))) (define (foo2 l) (let ([parent (car l)] [children (cdr l)]) (append-map (lambda (child) (cons (cons (car child) parent) (if (null? (cdr child)) '() (foo2 child)))) children))) (define (foo3 l) (append-map (lambda (child) (cons (cons (car child) (car l)) (if (null? (cdr child)) '() (foo3 child)))) (cdr l))) (define (foo4 l) (append-map (lambda (child) `((,(car child) . ,(car l)) ,@(if (null? (cdr child)) '() (foo4 child)))) (cdr l)))
- Shiro(2008/05/26 05:54:03 PDT): あんま流行らなかったな…簡単すぎ?
私のはこんな感じで。
(use util.match) (define (get-parent-alist tree) (define (rec p t s) (match-let1 (n . ts) t (acons n p (fold (cut rec n <> <>) s ts)))) (fold (cute rec (car tree) <> <>) '() (cdr tree)))
- nfunato(2008/05/26 06:32:44 PDT): 最近、知人にS式言語を拒絶されたので、強面にならないよう、できるだけ教科書的に書いてみました。実はCL5分(loop macro 使用)、その後、mapcan が無いとか、lambda の仮引数でpattern destructuringが出来ないとか、勝手言語仕様を試行錯誤しているうちに、あっという間に初級に…
- nfunato(2008/06/01 04:38:50 PDT): Shiroさんの解から得た版(本質は同じ)を追記して、以前の私のも名前を合わす等、整理させていただきました。
実は、最初 ボトムアップ的で無駄に走査しないと分かっても、宣言的に読んで理解できなかった。マニュアルと読み直すと、基本的な高階オペレータ(特にfold の arg1 lambda にわたる引数順)がうろ覚えのせいでした。日曜プログラマには壁かも…
ところで、cut のparameterに書く '<>' って何て読むんでしょうね。私は頭の中で「トシ(ちゃんの口)」って読んでます :-)(define name-of car) (define children-of cdr) (define (get-parent-alist p) (apply append! (map (lambda (c) (cons (name-of c) (name-of p))) (children-of p)) (map get-parent-alist (children-of p)))) ;; Shiroさんのを元にしたもの (define (get-parent-alist p) (define (gather p so-far) (fold (cut build p <> <>) so-far (children-of p))) (define (build p c so-far) (acons (name-of c) (name-of p) (gather c so-far))) (gather p '()))
- nobsun(2008/05/26 20:39:46 PDT):でおくれた。得意なぶるいかも 5min :)
(use srfi-1) (use util.match) (define (dfs t) (cons t (append-map dfs (cdr t)))) (define (tree-child-parent-list t) (define (chpa t) (match-let1 (p . cs) t (map (cut cons <> p) (map car cs)))) (append-map chpa (dfs t)))
- 追記: 「効率はどないなってんねん」「そんなこと気にするやつおらんやろ。(大木こだま風)」
- Shiro(2008/06/02 14:54:49 PDT): Haskellの(++)はlazyだからconstant timeと考えて いいんですよね。Schemeでappend-mapすると子リストのほとんどがコピーされるので、 今回のようにツリーで再帰してるとO(n^2)のセルがコピーされるかな? まあでも、今回の場合そこまで考えることは要求しません。もともとが使い捨てスクリプトですもん。
Shiro: 他にみつけた回答(なんか流行ってきた):
- http://d.hatena.ne.jp/scinfaxi/20080601/1212329435 ておりあさん
- http://d.hatena.ne.jp/sumim/20080602/p1 sumimさん
- http://d.hatena.ne.jp/athos/20080602/p1 athosさん
- http://d.hatena.ne.jp/yad-EL/20080602/p1 yad-ELさん
- http://d.hatena.ne.jp/SaitoAtsushi/20080602/1212419400 SaitoAtsushiさん
- http://d.hatena.ne.jp/katona/20080603/p1 MEMO:はてな支店さん ←matchとquasiquoteを使った非常にエレガントな解。
再帰が身についてるかどうかを見るのに手頃かな。 appendによる無駄も、push!による副作用も嫌う場合、 再帰パターンが樹状であっても結果がまっすぐなリストならfoldで つないでゆけることは覚えとくと便利かもしれません。
- nobsun: 「根から遠い順に」とか制約を加えるとちょっと頭を使うことになるかも
- maeda: R4RSの頃から語彙が増えてないold typeの解
(define (tree->alist tree) (let t->a ((tree tree) (alist '())) (do ((parent (car tree)) (children (cdr tree) (cdr children)) (a alist (t->a (car children) (cons (cons (caar children) parent) a)))) ((null? children) a))))
appendとか副作用とかの発想は浮かびませんねえ…2008/06/05 01:51:12 PDT
- とおる。(2008/06/10 02:25:55 PDT): ささださんのところから来ました。srfi-1 くらいは覚えないとなぁ。
(define (child-parent-alist tree) (define (iter tree parent) (if (null? tree) '() (if (pair? tree) (if (pair? (car tree)) (append (iter (car tree) parent) (iter (cdr tree) parent)) (cons (cons (car tree) parent) (iter (cdr tree) (car tree)))) (cons tree parent)))) (iter (cdr tree) (car tree)))
木の統合 (親 子 孫 ひ孫 …)
(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要素の普通のリストにすれば、相互に逆変換できそうな気がします。(多分こっちの方が広い問題を扱っていると思いますが)
- ryoakg(2008/07/19 20:15:49 PDT): 私が作ったもの。もう少しどうにかと思いましたが、疲れたのでとりあえずこの辺りで。まちがっていたらゴメンナサイ
(use srfi-1) (use srfi-11) (use util.match) (define rel->tree (match-lambda ((r) `(,r)) ((r . rs) `(,r . (,(rel->tree rs)))))) (define (rel->tree&concat r tree) (let loop ((r r)) (match r ((r) `(,r ,tree)) ((r . rs) `(,r . (,(loop rs))))))) (define (tree:enlarge-parent trees rel) (let/cc cc (let1 at-last (pa$ cc #f) (let loop ((ts trees)) (match ts (() (at-last)) (((and (sym . _) t) . ts) (cons (let-values (((gt le) (break (pa$ eq? sym) rel))) (if (null? le) t (begin (set! at-last (pa$ list)) (let1 lt (cdr le) (rel->tree&concat gt (if (null? lt) t (append t `(,(rel->tree lt))))))))) (loop ts)))))))) (define (lkup key trees) (let/cc cc (let loop ((ts trees)) (match ts (() #f) ((t . ts) (match t (() (loop ts)) ((sym . children) (if (eq? key sym) (cc t) (begin (loop children) (loop ts)))))))))) (define relations->tree (match-lambda (() '()) ((r . rs) (let loop ((acc `(,(rel->tree r))) (rs rs)) (match rs (() acc) (((and (sym . rel-) r) . rs) (loop (or (tree:enlarge-parent acc r) (and-let* ((part (lkup sym acc))) (append! part `(,(rel->tree rel-))) acc) (cons (rel->tree r) acc)) rs))))))) ;; test ;; (relations->tree '((A B C) (B D E) (F G) (H F I) (J A))) ;; #=> ((H (F (G) (I))) (J (A (B (C) (D (E))))))
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
- Oleg Kiselyov : A better XML parser through functional programming
(LNCS volume 2257)
http://okmij.org/ftp/papers/XML-parsing.ps.gz
http://okmij.org/ftp/papers/XML-parsing-talk.ps.gz