Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
Sort nodes in tree according to their dependencies that has circular dependency
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
(progn ;;init forms
#+quicklisp (ql:quickload '(:anaphora) :silent t))
(defpackage :ros.script.sort-tree-node2.ros.3713686785
(:use :cl
(in-package :ros.script.sort-tree-node2.ros.3713686785)
(defgeneric get-node-name (node))
(defgeneric node-equalp (node1 node2))
(defgeneric get-children (node))
;; --- structs and auxiality functions --- ;;
(defstruct node name children)
;; ((:parentA :childA1 :childA2) (:parentB :childB1 :childB2) ...)
(defun make-tree (parent-children-pair)
(let ((node-pool (make-hash-table))
(result nil))
(flet ((ensure-node (name)
(check-type name keyword)
(aif (gethash name node-pool)
(setf (gethash name node-pool)
(make-node :name name)))))
(dolist (pair parent-children-pair)
(let ((parent (ensure-node (car pair))))
(dolist (child-name (cdr pair))
(push (ensure-node child-name)
(node-children parent)))
(push parent result))))
(dolist (node result)
(setf (node-children node)
(nreverse (node-children node))))
;; --- methods --- ;;
(defmethod get-node-name ((node node))
(node-name node))
(defmethod node-equalp ((node1 node) (node2 node))
(eq (node-name node1) (node-name node2)))
(defmethod get-children ((node node))
(node-children node))
;; --- node functinos --- ;;
(defun all-children-are-processed (node processed-node-list)
(every (lambda (child) (or (node-equalp node child) ; Ignore self dependency
(find child processed-node-list :test #'node-equalp)))
(get-children node)))
(defun linearize-all-nodes (node-list)
(let ((result nil))
(labels ((rec (node)
(unless (some (lambda (target) (node-equalp target node))
(push node result)
(dolist (child (get-children node))
(rec child)))))
(dolist (node node-list)
(rec node)))
(defun extract-circular-nodes (node-list)
(labels ((rec (current-node traverse-list)
(setf traverse-list (cons current-node traverse-list))
(dolist (child (get-children current-node))
(unless (node-equalp current-node child) ; Ignore self dependency
(when (find child traverse-list :test #'node-equalp)
(let ((result (member child (reverse traverse-list)
:test #'node-equalp)))
(return-from rec result)))
(let ((next-result (rec child traverse-list)))
(when next-result
(return-from rec next-result)))))
(dolist (node node-list)
(awhen (rec node nil)
(return-from extract-circular-nodes it)))))
(defun check-circular-dependency (node-list)
(awhen (extract-circular-nodes node-list)
(error "There is (a) circular dependency: ~A"
(mapcar #'get-node-name it))))
;; --- node-group --- ;;
(defstruct node-group
nodes ; list of nodes
children ; list of groups
(defmethod get-node-name ((node node-group))
(format nil "~A"
(mapcar #'get-node-name (node-group-nodes node))))
;; There is an assumption that a node can be included in only one group.
;; So checking a first node in a group is enough to check equality.
(defmethod node-equalp ((node1 node-group) (node2 node-group))
(let ((first-node (first (node-group-nodes node1))))
;; An empty group is not allowed.
(assert first-node)
(find first-node (node-group-nodes node2) :test #'node-equalp)))
(defmethod get-children ((node node-group))
(node-group-children node))
(defun group-depend-p (target base)
(some (lambda (base-node)
(some (lambda (target-node)
(find target-node (get-children base-node) :test #'node-equalp))
(node-group-nodes target)))
(node-group-nodes base)))
(defun calc-group-children (group group-list)
(remove-if (lambda (target)
(not (group-depend-p target group)))
(defun recalc-groups-children (group-list)
(dolist (group group-list)
(setf (node-group-children group)
(calc-group-children group group-list)))
(defun gather-ciruclar-node-group (circular-list group-list)
(let ((new-group (make-node-group
:nodes (apply #'append
(mapcar (lambda (group) (node-group-nodes group))
(cons new-group
(remove-if (lambda (group)
(find group circular-list :test #'node-equalp))
(defun make-group-resolving-circular (all-node-list)
(labels ((rec (group-list)
(aif (extract-circular-nodes group-list)
(rec (gather-ciruclar-node-group it group-list))
(rec (recalc-groups-children
(mapcar (lambda (node) (make-node-group :nodes (list node)))
;; --- trees --- ;;
(defparameter *simple-tree*
'((:a :b :c) (:c :d :e) (:d :f :g)))
(defparameter *duplicated-tree*
'((:a :b :f :c) (:c :d :e) (:d :f :g) (:f :h :i)))
(defparameter *circular-tree1*
'((:a :b :f :c) (:f :h :g) (:g :d) (:d :f) (:c :d :e)))
(defparameter *circular-tree2*
'((:a :b :f :c) (:f :h :g) (:g :d :x) (:d :f) (:c :d :e)
(:x :y) (:y :z) (:z :x)))
(defparameter *circular-tree3*
'((:a :b :f :c) (:f :h :g) (:g :d :x) (:d :f) (:c :d :e)
(:x :y :d) (:y :z) (:z :x)))
(defparameter *tree-to-test-self-dependency*
'((:a :a :b :f :c) (:c :c :d :e) (:d :f :g) (:f :h :i)))
;; --- sorter --- ;;
(defun sort-tree-node-simply (node-list)
(let ((top-node (find-if (lambda (target)
;; If the target is not child of any node, it is a top node.
(notany (lambda (parent)
(some (lambda (child)
(node-equalp target child))
(get-children parent)))
(assert top-node)
;; There is dirty assumption that linealize-all-nodes do depth first search.
(linearize-all-nodes (list top-node))))
(defun sort-tree-node-with-duplication (node-list)
(labels ((rec (rest-nodes result)
(aif (find-if (lambda (node)
(all-children-are-processed node result))
(rec (remove it rest-nodes :test #'node-equalp)
(cons it result))
(reverse (rec (linearize-all-nodes node-list) nil))))
(defun sort-tree-node-checking-circular (node-list)
(check-circular-dependency (linearize-all-nodes node-list))
(sort-tree-node-with-duplication node-list))
(defun sort-tree-node-with-circular (node-list)
(make-group-resolving-circular (linearize-all-nodes node-list))))
;; --- main functions --- ;;
(defmacro print-sorted-tree (tree sort-fn)
(format t "~A: ~A~%" ',tree ,tree)
(format t " -> ~A~%"
(mapcar #'get-node-name
(funcall ,sort-fn (make-tree ,tree))))))
(defun print-separator (text)
(format t "--------------------~%")
(format t "--- ~A ---~%" text)
(format t "--------------------~%"))
(defun main (&rest argv)
(declare (ignorable argv))
(print-separator "Sort simply")
(print-sorted-tree *simple-tree* #'sort-tree-node-simply)
(print-sorted-tree *duplicated-tree* #'sort-tree-node-simply)
(print-separator "Sort considering duplicated parent")
(print-sorted-tree *simple-tree* #'sort-tree-node-with-duplication)
(print-sorted-tree *duplicated-tree* #'sort-tree-node-with-duplication)
(print-sorted-tree *circular-tree1* #'sort-tree-node-with-duplication)
(print-separator "Sort checking circular")
(print-sorted-tree *duplicated-tree* #'sort-tree-node-checking-circular)
(print-sorted-tree *circular-tree1* #'sort-tree-node-checking-circular)
(simple-error (c)
(format t " ERROR: ")
(apply #'format t
(simple-condition-format-control c)
(simple-condition-format-arguments c))
(format t "~%")))
(print-separator "Sort considering circular")
(print-sorted-tree *simple-tree* #'sort-tree-node-with-circular)
(print-sorted-tree *duplicated-tree* #'sort-tree-node-with-circular)
(print-sorted-tree *circular-tree1* #'sort-tree-node-with-circular)
(print-sorted-tree *circular-tree2* #'sort-tree-node-with-circular)
(print-sorted-tree *circular-tree3* #'sort-tree-node-with-circular)
(print-separator "(Test self dependncy)")
(print-sorted-tree *tree-to-test-self-dependency* #'sort-tree-node-with-duplication)
(print-sorted-tree *tree-to-test-self-dependency* #'sort-tree-node-checking-circular)
(print-sorted-tree *tree-to-test-self-dependency* #'sort-tree-node-with-circular))
;;; vim: set ft=lisp lisp:
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment