Sort nodes in tree according to their dependencies that has circular dependency

sort-tree-node-with-circular.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
    #+quicklisp (ql:quickload '(:anaphora) :silent t))

(defpackage :ros.script.sort-tree-node2.ros.3713686785
  (:use :cl
        :anaphora))
(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)
                  it
                  (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))))
    result))

;; --- 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))
                             result)
                 (push node result)
                 (dolist (child (get-children node))
                   (rec child)))))
      (dolist (node node-list)
        (rec node)))
    result))

(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)))))
             nil))
    (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)))
             group-list))

(defun recalc-groups-children (group-list)
  (dolist (group group-list)
    (setf (node-group-children group)
          (calc-group-children group group-list)))
  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))
                                          circular-list)))))
    (recalc-groups-children
     (cons new-group
           (remove-if (lambda (group)
                        (find group circular-list :test #'node-equalp))
                      group-list)))))

(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))
                  group-list)))
    (rec (recalc-groups-children
          (mapcar (lambda (node) (make-node-group :nodes (list node)))
                  all-node-list)))))

;; --- 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)))
                                     node-list))
                           node-list)))
    (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))
                           rest-nodes)
                  (rec (remove it rest-nodes :test #'node-equalp)
                       (cons it result))
                  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)
  (sort-tree-node-with-duplication
   (make-group-resolving-circular (linearize-all-nodes node-list))))

;; --- main functions --- ;;

(defmacro print-sorted-tree (tree sort-fn)
  `(progn
     (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)
  (handler-case
      (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: