経路からツリーへの変換

30分プログラム、その614。昨日やっていたやつ(id:mzp:20090630:tree)の逆変換。一晩寝たら、すんなり解けた。

(foo)
(foo bar)
(foo bar baz)
(foo xyzzy)
(foo baz)

みたいな木の根から末端までの経路リストがあったとする。これから、木を再構築したい。

(make-tree 'foo
           (make-tree 'bar (make-tree 'baz))
           (make-tree 'xyzzy)
           (make-tree 'baz))

これで、flash.display.Spriteとかflash.text.TextFieldみたいな完全修飾名からパッケージの階層構造を再構築できるようになる。

使い方

gosh> (path-list->tree '((foo bar baz) (foo bar) (foo xyzzy)))
(foo ((bar ((baz ()))) (xyzzy ())))

ソースコード

#! /opt/local/bin/gosh
;; -*- mode:scheme; coding:utf-8 -*-
;;
;; tree.scm -
;;
;; Copyright(C) 2009 by mzp
;; Author: MIZUNO Hiroki / mzpppp at gmail dot com
;; http://howdyworld.org
;;
;; Timestamp: 2009/06/30 21:39:50
;;
;; This program is free software; you can redistribute it and/or
;; modify it under MIT Lincence.
;;
(use srfi-1)
(use gauche.collection)

(define (make-tree name . sub-trees)
  (list name sub-trees))
(define (tree-name tree)
  (car tree))
(define (sub-trees tree)
  (cadr tree))
(define (leaf? tree)
  (eq? tree '()))

(define (fold-right-1 f xs)
  (fold-right f (car xs) (cdr xs)))

(define (merge-tree x y)
  (cond [(leaf? x) y]
	[(leaf? y) x]
	[(eq? (tree-name x) (tree-name y))
	 (apply make-tree
		(tree-name x)
		(map (lambda (ts) (fold-right-1 merge-tree ts))
		     (group-collection (append (sub-trees x) (sub-trees y))
				       :key tree-name)))]
	[else (error "invalid argument")]))

(define (path->tree path)
  (fold-right (lambda (x tree) (if (null? tree)
				   (make-tree x)
				   (make-tree x tree)))
	      '()
	      path))

(define (path-list->tree path-list)
  (fold-right-1 merge-tree
		(map path->tree path-list)))

(define (tree->path-list tree)
  (cons (list (tree-name tree))
	(map (cute cons (tree-name tree) <>)  (append-map tree->path-list (sub-trees tree)))))

(define *path-list* '((foo bar baz) (foo bar) (foo xyzzy) (foo baz)))
(define *tree* (make-tree 'foo
			  (make-tree 'bar (make-tree 'baz))
			  (make-tree 'xyzzy)
			  (make-tree 'baz)))

(tree->path-list *tree*)
(path-list->tree *path-list*)

(print (eq? *tree* (path-list->tree *path-list*)))

(path-list->tree '((foo bar baz)
		   (foo bar)
		   (foo xyzzy)))

参考

• 過去の30分プログラム