DouKaku?

; 親子ペア定義
(setf pair-lst '((a b)
                 (b c)
                 (c d)
                 (c e)
                 (a f)
                 (d x)
                 (y z)
                 (z c)
                 ))

;; 同一の親を持つペアをマージする
;; ex) ((p1 c1) (p1 c2) (p2 c3) (p2 c4)) -> ((p1 c1 c2) (p2 c3 c4))
(defun gen-fmly-lst (plst)
  (defun merge-lst (frst rst)
    (if (null rst)
      frst
      (if (eq (car frst) (caar rst))
        (merge-lst (append frst (cdar rst)) (cdr rst))
        (merge-lst frst (cdr rst)))))
  (labels ((rec (lst acc)
                (if (null lst)
                  acc
                  (if (member (caar lst) acc :key #'car)
                    (rec (cdr lst) acc)
                    (rec (cdr lst) (cons (merge-lst (car lst) (cdr lst)) acc))))))
    (rec plst nil)))

;; fmlyのリストからツリーを生成する
(defun gen-fmly-tr (fmly-lst)
  (labels ((rec (flst acc)
                (if (null flst)
                  acc
                  ; hook前のfmlyをhook後のfmly(n次元リスト)に置き換えて処理をする
                  (let* ((nD-fmly (car (member (caar flst) acc :key #'car)))
                         (othr (other nD-fmly acc)))
                    ; fmlyをhook処理し、一箇所もhookできなかったらfmlyをそのままaccに加える
                    (if (equal othr (hook nD-fmly othr))
                      (rec (cdr flst) (cons nD-fmly othr))
                      (rec (cdr flst) (hook nD-fmly othr)))))))
    (rec fmly-lst fmly-lst)))

;; リストからobjを除いたリストを取得する
(defmacro other (obj lst)
  `(remove-if #'(lambda (x) (equal ,obj x)) ,lst))

;; リストのcarと一致するatomをツリーの中で見つけた場合、該当atomをリストで置き換える
;; ex) (hook '(a x) '(a (b a) (c (d a)))) -> ((a x) (b (a x)) (c (d (a x))))
(defun hook (lst tree)
  (cond ((eq (car lst) tree) lst)
        ((atom tree) tree)
        (t (cons (hook lst (car tree))
                 (hook lst (cdr tree))))))

(defun main ()
  (gen-fmly-tr (gen-fmly-lst pair-lst)))
; 実行すると、下記の構造が得られる
; ((A (B (C (D X) E)) F) (Y (Z (C (D X) E))))
; インデントすると
;((A
;   (B
;     (C
;       (D
;         X)
;       E))
;   F)
; (Y
;   (Z
;     (C
;       (D
;         X)
;        E)))
; )

; 親子ペア定義
(setf pair-lst '((a b)
                 (b c)
                 (c d)
                 (c e)
                 (a f)
                 (d x)
                 (y z)
                 (z c)
                 ))

;; 同一の親を持つペアをマージする
;; ex) ((p1 c1) (p1 c2) (p2 c3) (p2 c4)) -> ((p1 c1 c2) (p2 c3 c4))
(defun gen-fmly-lst (plst)
  (defun merge-lst (frst rst)
    (if (null rst)
      frst
      (if (eq (car frst) (caar rst))
        (merge-lst (append frst (cdar rst)) (cdr rst))
        (merge-lst frst (cdr rst)))))
  (labels ((rec (lst acc)
                (if (null lst)
                  acc
                  (if (member (caar lst) acc :key #'car)
                    (rec (cdr lst) acc)
                    (rec (cdr lst) (cons (merge-lst (car lst) (cdr lst)) acc))))))
    (rec plst nil)))

;; fmlyのリストからツリーを生成する
(defun gen-fmly-tr (fmly-lst)
  (labels ((rec (flst acc)
                (if (null flst)
                  acc
                  ; hook前のfmlyをhook後のfmly(n次元リスト)に置き換えて処理をする
                  (let* ((nD-fmly (car (member (caar flst) acc :key #'car)))
                         (othr (other nD-fmly acc)))
                    ; fmlyをhook処理し、一箇所もhookできなかったらfmlyをそのままaccに加える
                    (if (equal othr (hook nD-fmly othr))
                      (rec (cdr flst) (cons nD-fmly othr))
                      (rec (cdr flst) (hook nD-fmly othr)))))))
    (rec fmly-lst fmly-lst)))

;; リストからobjを除いたリストを取得する
(defmacro other (obj lst)
  `(remove-if #'(lambda (x) (equal ,obj x)) ,lst))

;; リストのcarと一致するatomをツリーの中で見つけた場合、該当atomをリストで置き換える
;; ex) (hook '(a x) '(a (b a) (c (d a)))) -> ((a x) (b (a x)) (c (d (a x))))
(defun hook (lst tree)
  (cond ((eq (car lst) tree) lst)
        ((atom tree) tree)
        (t (cons (hook lst (car tree))
                 (hook lst (cdr tree))))))

(defun main ()
  (gen-fmly-tr (gen-fmly-lst pair-lst)))
; 実行すると、下記の構造が得られる
; ((A (B (C (D X) E)) F) (Y (Z (C (D X) E))))
; インデントすると
;((A
;   (B
;     (C
;       (D
;         X)
;       E))
;   F)
; (Y
;   (Z
;     (C
;       (D
;         X)
;        E)))
; )

(setf pair-lst '((a  b)
                 (b  c)
                 (c  d)
                 (c  e)
                 (a  f)
                 (d  x)
                 (y  z)
                 (z  c) ))

(defun gen-family-relation (list env)
  (let ( node result )
    (dolist (x list result)
        (setf node (assoc (car x) env))
        (if node
            (setf (cdr node) (append (cdr node) (cdr x)))
            (push x env) )
        (setf result env) )))

(defun query (s env)
  (let ((node (assoc s env)))
    (if node
        (cons (car node)(mapcar #'(lambda (x)(query x env)) (cdr node)))
        s)))

(defpackage :dokaku178
  (:use :common-lisp))
(in-package :dokaku178)

(defvar *population* (make-hash-table))
(defstruct tree
   id children parents)

(defun get-node (key)
  (multiple-value-bind (hash-value flag) (gethash key *population*)
    (if (null flag)
    (setf (gethash key *population*) (make-tree :id key
                          :parents nil
                          :children nil))
    hash-value)))

(defun set-node (pair-list)
  (let* ((parent (car pair-list))
     (child (cdr pair-list))
     (parent-node (get-node parent))
     (child-node (get-node child)))
    (pushnew parent (tree-parents child-node))
    (pushnew child (tree-children parent-node))))

(defun get-origins ()
  (let ((origins nil))
    (maphash #'(lambda(k v)
         (if (null (tree-parents v))
             (pushnew k origins))) *population*)
    origins))

(defun print-tree (id)
  (let ((id (gethash id *population*)))
    (format t "~a => ~a => ~a ~%"  (tree-parents id)
                               (tree-id id)
                   (tree-children id))))

(defun main()     
  (let ((pair-lst
     '((a . b)(b . c)(c . d)(c . e)
       (a . f)(d . x)(y . z)(z . c))))
    (loop for n in pair-lst do
     (set-node n))))