Sort nodes in tree according to their dependencies

sort-tree-node.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-node.ros.3713084013
  (:use :cl
        :anaphora))
(in-package :ros.script.sort-tree-node.ros.3713084013)

;; --- generics --- ;;

(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))

;; --- sorter --- ;;

(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-tree*
  '((:a :b :f :c) (:f :h :g) (:g :d) (:d :f) (:c :d :e)))

(defun get-top-node-list (list)
  (let ((result nil))
    ;; No node have it as a child if it is a top node.
    (dolist (node list)
      (when (notany (lambda (target)
                      (some (lambda (child)
                              (node-equalp node child))
                            (node-children target)))
                    list)
        (push node result)))
    (reverse result)))

;; dfs = depth first search
(defun extract-all-nodes-by-dfs (top-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 top-node-list)
        (rec node)))
    result))

(defun sort-tree-node-simply (top-node-list)
  (extract-all-nodes-by-dfs top-node-list))

(defun all-children-are-processed (node processed-node-list)
  (every (lambda (child) (find child processed-node-list :test #'node-equalp))
         (get-children node)))

(defun sort-tree-node-with-duplication (top-node-list)
  (labels ((rec (rest-nodes pending-list result)
             (when pending-list
               (dolist (node pending-list)
                 (when (all-children-are-processed node result)
                   (return-from rec
                     (rec rest-nodes
                          (remove node pending-list :test #'node-equalp)
                          (cons node result))))))
             (if rest-nodes
                 (let ((node (car rest-nodes)))
                   (if (all-children-are-processed node result)
                       (rec (cdr rest-nodes) pending-list (cons node result))
                       (rec (cdr rest-nodes) (cons node pending-list) result)))
                 result)))
    (reverse (rec (extract-all-nodes-by-dfs top-node-list) nil nil))))

(defun check-circular-dependency (node-list)
  (labels ((rec (current-node node-list result)
             (setf result (cons current-node result))
             (dolist (child (get-children current-node))
               (when (find child result :test #'node-equalp)
                 (return-from rec (member child (reverse result)
                                                       :test #'node-equalp)))
               (when (find child node-list :test #'node-equalp)
                 (let ((next-result (rec child node-list result)))
                   (when next-result
                     (return-from rec next-result)))))
             nil))
    (dolist (node node-list)
      (let ((circular-list (rec node node-list nil)))
        (when circular-list
          (error "Find circular dependency: ~A"
                 (mapcar #'node-name circular-list)))))))

(defun sort-tree-node-detecting-circular (top-node-list)
  (check-circular-dependency (extract-all-nodes-by-dfs top-node-list))
  (sort-tree-node-with-duplication top-node-list))

(defun print-sorted-tree (tree sort-fn)
  (format t "~A~%" tree)
  (dolist (node (funcall sort-fn (get-top-node-list (make-tree tree))))
    (format t "~A " (node-name node)))
  (format t "~%---------~%"))

(defun main (&rest argv)
  (declare (ignorable argv))
  (format t "--- simple sort ---~%")
  (print-sorted-tree *simple-tree* #'sort-tree-node-simply)
  (print-sorted-tree *duplicated-tree* #'sort-tree-node-simply)

  (format t "--- sort considering duplicated dependency ---~%")
  (print-sorted-tree *simple-tree* #'sort-tree-node-with-duplication)
  (print-sorted-tree *duplicated-tree* #'sort-tree-node-with-duplication)
  (print-sorted-tree *circular-tree* #'sort-tree-node-with-duplication)

  (format t "--- sort detecting circular dependency error ---~%")
  (print-sorted-tree *simple-tree* #'sort-tree-node-detecting-circular)
  (print-sorted-tree *duplicated-tree* #'sort-tree-node-detecting-circular)
  (handler-case
      (print-sorted-tree *circular-tree* #'sort-tree-node-detecting-circular)
    (simple-error (c)
      (format t "ERROR: ")
      (apply #'format t
             (simple-condition-format-control c)
             (simple-condition-format-arguments c)))))
;;; vim: set ft=lisp lisp: