alist->treeを作る

どこかのサイトにalist->treeもやってみたらとか書いてあったので作ることにした

とりあえず

1. 根っこを見つける
2. 特定の親を持つpairを抽出
3. 子をぶら下げて2に再帰

という方針でいけるかな

ということで根っこを見つける処理を書いた

(define (find-root alist)
  (define (scan-children s alist)
    (cond ((null? alist) s)
          ((eq? s (caar alist)) #f)
          (else (scan-children s (cdr alist)))))
  (define (find lst alist)
    (if (or (null? alist) (null? lst)) #f
        (let ((result (scan-children (cdar lst) alist)))
          (if result result
              (find (cdr lst) alist)))))
  (find alist alist))

続きはWebで

【追記】
こっちのほうがいいかなあ

(define (find-root alist)
  (define (scan parent-list child-list)
    (if (null? parent-list) #f
	(let ((parent (car parent-list)))
	  (if (memq parent child-list)
	      (scan (cdr parent-list) child-list)
	      parent))))
  (scan (map cdr alist) (map car alist)))

【追記】
でけた

(define (pickup-parent parent alist)
  (define (devide upper lower alist)
    (if (null? alist)
        (cons upper lower)
        (if (eq? (cdar alist) parent)
            (devide (cons (car alist) upper) lower (cdr alist))
            (devide upper (cons (car alist) lower) (cdr alist)))))
  (devide '() '() alist))

(define (alist->tree alist)
  (define (make-tree root alist)
    (let* ((p-list (pickup-parent root alist))
           (upper (car p-list))
           (lower (cdr p-list)))
      (if (null? lower) (cons root (map list (map car upper)))
          (cons root (map (lambda (x) (make-tree x lower))
                          (map car upper))))))
  (make-tree (find-root alist) alist))

【追記】
upperには親情報は不要なので削除

(define (pickup-parent parent alist)
  (define (devide upper lower alist)
    (if (null? alist)
        (cons upper lower)
        (if (eq? (cdar alist) parent)
            (devide (cons (caar alist) upper) lower (cdr alist))
            (devide upper (cons (car alist) lower) (cdr alist)))))
  (devide '() '() alist))

(define (alist->tree alist)
  (define (make-tree root alist)
    (let* ((p-list (pickup-parent root alist))
           (upper (car p-list))
           (lower (cdr p-list)))
      (if (null? lower) (cons root (map list upper))
          (cons root (map (lambda (x) (make-tree x lower))
                          upper)))))
  (make-tree (find-root alist) alist))