Renaud Casenave-Péré
08706de1f4
Remove tree functionality from utils.lisp and generalize it as graph
68 lines
2.4 KiB
Common Lisp
68 lines
2.4 KiB
Common Lisp
#|
|
|
This file is a part of stoe project.
|
|
Copyright (c) 2014 Renaud Casenave-Péré (renaud@casenave-pere.fr)
|
|
|#
|
|
|
|
(uiop:define-package :stoe/core/graph
|
|
(:use :cl :stoe/core/utils)
|
|
(:export #:graph-node #:prior-nodes #:next-nodes
|
|
#:attach-node #:detach-node #:insert-node
|
|
#:cyclic-graph-p #:make-graph-node))
|
|
(in-package :stoe/core/graph)
|
|
|
|
(defclass graph-node ()
|
|
((prior-nodes :initform nil :accessor prior-nodes)
|
|
(next-nodes :initform nil :accessor next-nodes)))
|
|
|
|
(defgeneric attach-node (node &key prior next))
|
|
(defmethod attach-node ((node graph-node) &key prior next)
|
|
(let ((prior-list (safe-list prior))
|
|
(next-list (safe-list next)))
|
|
(with-slots (prior-nodes next-nodes) node
|
|
(setf prior-nodes (append prior-nodes prior-list))
|
|
(setf next-nodes (append next-nodes next-list)))
|
|
(mapc (lambda (pnode)
|
|
(with-slots (next-nodes) pnode
|
|
(setf next-nodes (append next-nodes (list node)))))
|
|
prior-list)
|
|
(mapc (lambda (nnode)
|
|
(with-slots (prior-nodes) nnode
|
|
(setf prior-nodes (append prior-nodes (list node)))))
|
|
next-list))
|
|
node)
|
|
|
|
(defgeneric detach-node (node &key prior next))
|
|
(defmethod detach-node ((node graph-node) &key prior next)
|
|
(let ((prior-list (if (eq prior t) (prior-nodes node) (safe-list prior)))
|
|
(next-list (if (eq next t) (next-nodes node) (safe-list next))))
|
|
(mapc (lambda (pnode)
|
|
(with-slots (next-nodes) pnode
|
|
(setf next-nodes (remove node next-nodes))))
|
|
prior-list)
|
|
(mapc (lambda (nnode)
|
|
(with-slots (prior-nodes) nnode
|
|
(setf prior-nodes (remove node prior-nodes))))
|
|
next-list))
|
|
(values))
|
|
|
|
(defgeneric insert-node (node prior next))
|
|
(defmethod insert-node ((node graph-node) prior next)
|
|
(detach-node prior :next next)
|
|
(attach-node node :prior prior :next next))
|
|
|
|
(defun cyclic-graph-p (node)
|
|
(let ((visited-nodes (list node))
|
|
(visit-stack (next-nodes node)))
|
|
(loop for node = (pop visit-stack)
|
|
do (cond
|
|
((null node) (return nil))
|
|
((member node visited-nodes) (return t))
|
|
(t
|
|
(push node visited-nodes)
|
|
(setf visit-stack (append (next-nodes node) visit-stack)))))))
|
|
|
|
(defun make-graph-node (&key prior next)
|
|
(let ((node (make-instance 'graph-node)))
|
|
(when (or prior next)
|
|
(attach-node node :prior prior :next next))
|
|
node))
|