├── .gitattributes ├── flow-logo.png ├── docs ├── flow-logo.png └── index.html ├── visualizer ├── package.lisp ├── flow-visualizer.asd ├── nodes.lisp └── visualizer.lisp ├── toolkit.lisp ├── README.md ├── flow.asd ├── LICENSE ├── package.lisp ├── conditions.lisp ├── nodes.lisp ├── graph.lisp ├── static-node.lisp └── documentation.lisp /.gitattributes: -------------------------------------------------------------------------------- 1 | 2 | doc/ linguist-vendored 3 | -------------------------------------------------------------------------------- /flow-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/flow/master/flow-logo.png -------------------------------------------------------------------------------- /docs/flow-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/Shinmera/flow/master/docs/flow-logo.png -------------------------------------------------------------------------------- /visualizer/package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:flow-visualizer 3 | (:nicknames #:org.shirakumo.flow.visualizer) 4 | (:use #:cl+qt #:flow) 5 | (:shadowing-import-from #:flow #:connect #:disconnect #:slot) 6 | (:export 7 | #:start)) 8 | -------------------------------------------------------------------------------- /toolkit.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | (defun find-slots-by-initarg (key slots) 4 | (loop for slot in slots 5 | when (find key (c2mop:slot-definition-initargs slot)) 6 | collect slot)) 7 | 8 | (defun find-slot-by-name (name slots) 9 | (find name slots :key #'c2mop:slot-definition-name)) 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # This repository has [moved](https://shinmera.com/projects/flow)! 2 | Due to Microsoft's continued enshittification of the platform this repository has been moved to [Codeberg](https://shinmera.com/projects/flow) in August of 2025. It will not receive further updates or patches. **Issues and pull requests will not be looked at here either**, please submit your patches and issue tickets on Codeberg, or send them directly via good old email patches to [shirakumo@tymoon.eu](mailto:shirakumo@tymoon.eu). 3 | 4 | Thanks. -------------------------------------------------------------------------------- /flow.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem flow 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "A flowchart and generalised graph library." 7 | :homepage "https://shinmera.com/docs/flow/" 8 | :bug-tracker "https://shinmera.com/project/flow/issues" 9 | :source-control (:git "https://shinmera.com/project/flow.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "toolkit") 13 | (:file "conditions") 14 | (:file "nodes") 15 | (:file "static-node") 16 | (:file "graph") 17 | (:file "documentation")) 18 | :depends-on (:documentation-utils 19 | :text-draw 20 | :closer-mop)) 21 | -------------------------------------------------------------------------------- /visualizer/flow-visualizer.asd: -------------------------------------------------------------------------------- 1 | (asdf:defsystem flow-visualizer 2 | :version "1.0.0" 3 | :license "zlib" 4 | :author "Yukari Hafner " 5 | :maintainer "Yukari Hafner " 6 | :description "A visualizer for the flow flowchart library." 7 | :homepage "https://shinmera.com/docs/flow/" 8 | :bug-tracker "https://shinmera.com/project/flow/issues" 9 | :source-control (:git "https://shinmera.com/project/flow.git") 10 | :serial T 11 | :components ((:file "package") 12 | (:file "nodes") 13 | (:file "visualizer")) 14 | :defsystem-depends-on (:qtools) 15 | :depends-on (:flow 16 | :qtcore 17 | :qtgui) 18 | :build-operation "qt-program-op" 19 | :build-pathname "flow-visualizer" 20 | :entry-point "flow-visualizer:start") 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Yukari Hafner 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 2. Altered source versions must be plainly marked as such, and must not be 16 | misrepresented as being the original software. 17 | 3. This notice may not be removed or altered from any source distribution. 18 | -------------------------------------------------------------------------------- /package.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:cl-user) 2 | (defpackage #:flow 3 | (:nicknames #:org.shirakumo.flow) 4 | (:use #:cl) 5 | ;; conditions.lisp 6 | (:export 7 | #:flow-condition 8 | #:connection-already-exists 9 | #:new-connection 10 | #:old-connection 11 | #:illegal-connection 12 | #:connection 13 | #:message 14 | #:designator-not-a-port 15 | #:node 16 | #:slot-name 17 | #:graph-structure-error 18 | #:graph-contains-cycles 19 | #:node 20 | #:graph-is-bipartite 21 | #:node-a 22 | #:node-b) 23 | ;; graph.lisp 24 | (:export 25 | #:visit 26 | #:extract-graph 27 | #:topological-sort 28 | #:color-nodes 29 | #:allocate-ports 30 | #:a*) 31 | ;; nodes.lisp 32 | (:export 33 | #:unit 34 | #:attributes 35 | #:attribute 36 | #:remove-attribute 37 | #:with-attributes 38 | #:connection 39 | #:left 40 | #:right 41 | #:connection= 42 | #:sever 43 | #:directed-connection 44 | #:port 45 | #:connections 46 | #:node 47 | #:name 48 | #:connect 49 | #:disconnect 50 | #:remove-connection 51 | #:check-connection-accepted 52 | #:n-port 53 | #:1-port 54 | #:in-port 55 | #:out-port 56 | #:node 57 | #:ports 58 | #:port 59 | #:dynamic-node 60 | #:other-node 61 | #:target-node) 62 | ;; static-node.lisp 63 | (:export 64 | #:*resolve-port* 65 | #:port-value 66 | #:port-value-boundp 67 | #:port-value-makunbound 68 | #:define-port-value-slot 69 | #:port-definition 70 | #:port-type 71 | #:static-node-class 72 | #:static-node 73 | #:define-node) 74 | ;; toolkit.lisp 75 | (:export)) 76 | -------------------------------------------------------------------------------- /conditions.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | (define-condition flow-condition (condition) 4 | ()) 5 | 6 | (define-condition connection-already-exists (flow-condition error) 7 | ((new-connection :initarg :new-connection :reader new-connection) 8 | (old-connection :initarg :old-connection :reader old-connection)) 9 | (:report (lambda (c s) (format s "The connection~% ~a~%already exists and is considered equal to~% ~a" 10 | (old-connection c) (new-connection c))))) 11 | 12 | (define-condition illegal-connection (flow-condition error) 13 | ((connection :initarg :connection :reader connection) 14 | (message :initarg :message :initform NIL :reader message)) 15 | (:report (lambda (c s) (format s "The connection~% ~a~%is not allowed~:[.~;~:*: ~a~]" 16 | (connection c) (message c))))) 17 | 18 | (define-condition designator-not-a-port (flow-condition error) 19 | ((node :initarg :node :reader node) 20 | (port-name :initarg :port-name :reader port-name)) 21 | (:report (lambda (c s) (format s "The name ~s does not designate a port on ~a." 22 | (port-name c) (node c))))) 23 | 24 | (define-condition graph-structure-error (flow-condition error) 25 | ()) 26 | 27 | (define-condition graph-contains-cycles (graph-structure-error) 28 | ((node :initarg :node :reader node)) 29 | (:report "The graph contains cycles.")) 30 | 31 | (define-condition graph-is-bipartite (graph-structure-error) 32 | ((node-a :initarg :node-a :reader node-a) 33 | (node-b :initarg :node-b :reader node-b)) 34 | (:report (lambda (c s) (format s "The nodes~% ~a~%and~% ~a~%are in bipartite graphs." 35 | (node-a c) (node-b c))))) 36 | -------------------------------------------------------------------------------- /visualizer/nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:flow-visualizer) 2 | (in-readtable :qtools) 3 | 4 | (defun filter-by-type (type list) 5 | (remove-if-not (lambda (el) (typep el type)) list)) 6 | 7 | (defmethod location ((node node)) 8 | (q+:make-qpointf (attribute node 'x) 9 | (attribute node 'y))) 10 | 11 | (defmethod location ((port port)) 12 | (location (node port))) 13 | 14 | (defmethod paint ((node node) painter) 15 | (with-finalizing ((rect (q+:make-qrectf 16 | (attribute node 'x) 17 | (attribute node 'y) 18 | (attribute node 'w) 19 | (attribute node 'h))) 20 | (pen (q+:make-qpen (q+:make-qcolor 0 0 0))) 21 | (back (q+:make-qbrush (q+:make-qcolor 255 255 255)))) 22 | (setf (q+:pen painter) pen) 23 | (setf (q+:brush painter) back) 24 | (q+:draw-rect painter rect) 25 | (q+:draw-text painter rect (q+:qt.align-center) 26 | (princ-to-string (or (attribute node 'text) 27 | node)) 28 | rect) 29 | (dolist (port (ports node)) 30 | (paint port painter)))) 31 | 32 | (defmethod paint ((port port) painter) 33 | (let ((node (node port)) 34 | (point (location port))) 35 | (setf (q+:clipping painter) T) 36 | (setf (q+:clip-rect painter) (q+:make-qrectf 37 | (+ (attribute node 'x) 1) 38 | (+ (attribute node 'y) 1) 39 | (- (attribute node 'w) 1) 40 | (- (attribute node 'h) 1))) 41 | (q+:draw-ellipse painter point 5. 5.) 42 | (setf (q+:clipping painter) NIL) 43 | (q+:draw-text painter point (princ-to-string (or (attribute port 'text) 44 | (name port)))) 45 | (dolist (connection (connections port)) 46 | (when (eql port (left connection)) 47 | (paint connection painter))))) 48 | 49 | (defmethod paint ((connection connection) painter) 50 | (q+:draw-line painter (location (left connection)) (location (right connection)))) 51 | 52 | (defclass in-port (n-port) 53 | ()) 54 | 55 | (defmethod location ((port in-port)) 56 | (let* ((point (location (node port))) 57 | (in-ports (filter-by-type 'in-port (ports (node port)))) 58 | (dist (/ (attribute (node port) 'w) (length in-ports)))) 59 | (setf (q+:x point) 60 | (+ (q+:x point) 61 | (* dist (position port in-ports)) 62 | (/ dist 2))) 63 | point)) 64 | 65 | (defclass out-port (1-port) 66 | ()) 67 | 68 | (defmethod location ((port out-port)) 69 | (let* ((point (location (node port))) 70 | (out-ports (filter-by-type 'out-port (ports (node port)))) 71 | (dist (/ (attribute (node port) 'w) (length out-ports)))) 72 | (setf (q+:x point) 73 | (+ (q+:x point) 74 | (* dist (position port out-ports)) 75 | (/ dist 2))) 76 | (setf (q+:y point) 77 | (+ (q+:y point) 78 | (attribute (node port) 'h))) 79 | point)) 80 | 81 | (define-node start () 82 | ((out :port-type out-port))) 83 | 84 | (define-node end () 85 | ((in :port-type in-port))) 86 | 87 | (define-node process () 88 | ((in :port-type in-port) 89 | (out :port-type out-port))) 90 | 91 | (define-node conditional () 92 | ((in :port-type in-port) 93 | (true :port-type out-port) 94 | (false :port-type out-port))) 95 | -------------------------------------------------------------------------------- /nodes.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | (defclass unit () 4 | ((attributes :initform (make-hash-table :test 'eql) :accessor attributes))) 5 | 6 | (defmethod attribute ((unit unit) name &optional default) 7 | (gethash name (attributes unit) default)) 8 | 9 | (defmethod (setf attribute) (value (unit unit) name) 10 | (setf (gethash name (attributes unit)) value)) 11 | 12 | (defmethod remove-attribute ((unit unit) name) 13 | (remhash name (attributes unit))) 14 | 15 | (defmacro with-attributes (attributes unit &body body) 16 | (let ((unitg (gensym "UNIT"))) 17 | `(let ((,unitg ,unit)) 18 | (symbol-macrolet ,(loop for attribute in attributes 19 | collect `(,attribute (attribute ,unitg ',attribute))) 20 | ,@body)))) 21 | 22 | (defclass connection (unit) 23 | ((left :initarg :left :accessor left) 24 | (right :initarg :right :accessor right))) 25 | 26 | (defmethod print-object ((connection connection) stream) 27 | (print-unreadable-object (connection stream :type T) 28 | (format stream "~a <-> ~a" 29 | (left connection) 30 | (right connection)))) 31 | 32 | (defmethod connection= (a b) 33 | (or (and (eql (left a) (left b)) 34 | (eql (right a) (right b))) 35 | (and (eql (left a) (right b)) 36 | (eql (right a) (left b))))) 37 | 38 | (defmethod sever ((connection connection)) 39 | (remove-connection connection (left connection)) 40 | (remove-connection connection (right connection)) 41 | connection) 42 | 43 | (defclass directed-connection (connection) 44 | ()) 45 | 46 | (defmethod print-object ((connection directed-connection) stream) 47 | (print-unreadable-object (connection stream :type T) 48 | (format stream "~a --> ~a" 49 | (left connection) 50 | (right connection)))) 51 | 52 | (defmethod connection= ((a directed-connection) (b directed-connection)) 53 | (or (and (eql (left a) (left b)) 54 | (eql (right a) (right b))))) 55 | 56 | (defclass port (unit) 57 | ((connections :initarg :connections :initform () :accessor connections) 58 | (node :initarg :node :initform NIL :accessor node) 59 | (name :initarg :name :initform NIL :accessor name))) 60 | 61 | (defmethod print-object ((port port) stream) 62 | (print-unreadable-object (port stream :type T) 63 | (format stream "~a/~a" (node port) (name port)))) 64 | 65 | (defmethod describe-object :after ((port port) stream) 66 | (format stream "~&~%Connections:~%") 67 | (dolist (connection (connections port)) 68 | (let ((other (if (eq port (left connection)) (right connection) (left connection)))) 69 | (cond ((not (typep connection 'directed-connection)) 70 | (format stream " --- ")) 71 | ((eq port (left connection)) 72 | (format stream " --> ")) 73 | (T 74 | (format stream " <-- "))) 75 | (format stream "~a ~a~%" (name other) (node other))))) 76 | 77 | (defmethod connect ((left port) (right port) &optional (connection-type 'connection) &rest initargs) 78 | (let ((connection (apply #'make-instance connection-type :left left :right right initargs))) 79 | (check-connection-accepted connection left) 80 | (check-connection-accepted connection right) 81 | (push connection (connections left)) 82 | (push connection (connections right)) 83 | connection)) 84 | 85 | (defmethod disconnect ((left port) (right port)) 86 | (let ((connection (make-instance 'directed-connection :left left :right right))) 87 | (remove-connection connection left :test #'connection=) 88 | (remove-connection connection right :test #'connection=) 89 | NIL)) 90 | 91 | (defmethod remove-connection (connection (port port) &key (test #'eql)) 92 | (setf (connections port) (remove connection (connections port) :test test))) 93 | 94 | (defgeneric check-connection-accepted (connection port) 95 | (:method-combination progn)) 96 | 97 | (defmethod check-connection-accepted progn (new-connection (port port)) 98 | (loop for connection in (connections port) 99 | do (when (connection= connection new-connection) 100 | (error 'connection-already-exists 101 | :new-connection new-connection 102 | :old-connection connection)))) 103 | 104 | (defmethod sever ((port port)) 105 | (mapc #'sever (connections port))) 106 | 107 | (defclass n-port (port) 108 | ()) 109 | 110 | (defclass 1-port (port) 111 | ()) 112 | 113 | (defmethod check-connection-accepted progn (connection (port 1-port)) 114 | (when (connections port) 115 | (error 'connection-already-exists 116 | :new-connection connection 117 | :old-connection (first (connections port))))) 118 | 119 | (defclass in-port (port) 120 | ()) 121 | 122 | (defmethod check-connection-accepted progn ((connection directed-connection) (port in-port)) 123 | (unless (eql port (right connection)) 124 | (error 'illegal-connection :connection connection :message "Only incoming connections are allowed."))) 125 | 126 | (defclass out-port (port) 127 | ()) 128 | 129 | (defmethod check-connection-accepted progn ((connection directed-connection) (port out-port)) 130 | (unless (eql port (left connection)) 131 | (error 'illegal-connection :connection connection :message "Only outgoing connections are allowed."))) 132 | 133 | (defclass node (unit) 134 | ()) 135 | 136 | (defmethod describe-object :after ((node node) stream) 137 | (format stream "~&~%") 138 | (flet ((filter-ports (type) 139 | (loop for port in (ports node) 140 | when (typep port type) 141 | collect (if (slot-boundp node (name port)) 142 | (cons (name port) (slot-value node (name port))) 143 | (name port))))) 144 | (org.shirakumo.text-draw:node 145 | (filter-ports 'in-port) (filter-ports 'out-port) :stream stream))) 146 | 147 | (defmethod sever ((node node)) 148 | (mapc #'sever (ports node))) 149 | 150 | (defmethod connections ((node node)) 151 | (reduce #'append (ports node) :key #'connections)) 152 | 153 | (defmethod remove-connection (connection (node node) &key (test #'eql)) 154 | (dolist (port (ports node)) 155 | (remove-connection connection port :test test)) 156 | connection) 157 | 158 | (defmethod disconnect ((node node) (port port)) 159 | (dolist (other-port (ports node)) 160 | (disconnect other-port port))) 161 | 162 | (defmethod disconnect ((port port) (node node)) 163 | (dolist (other-port (ports node)) 164 | (disconnect port other-port))) 165 | 166 | (defmethod disconnect ((a node) (b node)) 167 | (dolist (a-port (ports a)) 168 | (dolist (b-port (ports b)) 169 | (disconnect a-port b-port)))) 170 | 171 | (defclass dynamic-node (node) 172 | ((ports :initarg :ports :initform () :accessor ports))) 173 | 174 | (defmethod port ((node dynamic-node) (name symbol)) 175 | (or (find name (ports node) :key #'name) 176 | (error 'designator-not-a-port :port-name name :node node))) 177 | 178 | (defun other-node (node connection) 179 | (let ((right (flow:node (flow:right connection)))) 180 | (if (eq right node) 181 | (flow:node (flow:left connection)) 182 | right))) 183 | 184 | (defun target-node (node connection) 185 | (let ((left (flow:node (flow:left connection)))) 186 | (if (eq left node) 187 | (flow:node (flow:right connection)) 188 | (if (typep connection 'directed-connection) 189 | NIL 190 | left)))) 191 | -------------------------------------------------------------------------------- /visualizer/visualizer.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:flow-visualizer) 2 | (in-readtable :qtools) 3 | 4 | (define-widget main (QMainWindow) 5 | ()) 6 | 7 | (define-initializer (main setup) 8 | (setf (q+:window-title main) "Flow Visualizer")) 9 | 10 | (define-subwidget (main canvas) (make-instance 'canvas) 11 | (setf (q+:central-widget main) canvas)) 12 | 13 | (define-subwidget (main toolbar) (make-instance 'toolbar :canvas canvas) 14 | (q+:add-dock-widget main (q+:qt.left-dock-widget-area) toolbar)) 15 | 16 | 17 | (define-widget canvas (QWidget) 18 | ((nodes :initform NIL :accessor nodes) 19 | (tool :initform NIL :accessor tool))) 20 | 21 | (define-initializer (canvas setup) 22 | (setf (q+:size-policy canvas) (values (q+:qsizepolicy.minimum) 23 | (q+:qsizepolicy.minimum))) 24 | (setf (q+:focus-policy canvas) (q+:qt.strong-focus))) 25 | 26 | (define-override (canvas paint-event) (ev) 27 | (with-finalizing ((painter (q+:make-qpainter canvas))) 28 | (setf (q+:background painter) (q+:make-qbrush (q+:make-qcolor 150 150 150) 29 | (q+:qt.dense7-pattern))) 30 | (q+:fill-rect painter (q+:rect canvas) (q+:make-qcolor 255 255 255)) 31 | (q+:erase-rect painter (q+:rect canvas)) 32 | (dolist (node nodes) 33 | (paint node painter)) 34 | (when tool 35 | (paint tool painter)))) 36 | 37 | (define-override (canvas mouse-press-event) (ev) 38 | (when (tool canvas) 39 | (begin tool (q+:x (q+:pos-f ev)) (q+:y (q+:pos-f ev))) 40 | (q+:repaint canvas)) 41 | (q+:ignore ev)) 42 | 43 | (define-override (canvas mouse-release-event) (ev) 44 | (when (tool canvas) 45 | (end tool (q+:x (q+:pos-f ev)) (q+:y (q+:pos-f ev))) 46 | (q+:repaint canvas)) 47 | (q+:ignore ev)) 48 | 49 | (define-override (canvas mouse-move-event) (ev) 50 | (when (tool canvas) 51 | (update tool (q+:x (q+:pos-f ev)) (q+:y (q+:pos-f ev))) 52 | (q+:repaint canvas)) 53 | (q+:ignore ev)) 54 | 55 | (define-override (canvas key-press-event) (ev) 56 | (when (tool canvas) 57 | (action tool ev) 58 | (q+:repaint canvas)) 59 | (q+:ignore ev)) 60 | 61 | 62 | (define-widget toolbar (QDockWidget) 63 | ((canvas :initarg :canvas :reader canvas))) 64 | 65 | (define-initializer (toolbar setup) 66 | (setf (q+:window-title toolbar) "Tools") 67 | (setf (q+:features toolbar) (q+:qdockwidget.dock-widget-movable))) 68 | 69 | (define-subwidget (toolbar container) (q+:make-qwidget) 70 | (setf (q+:widget toolbar) container)) 71 | 72 | (define-subwidget (toolbar group) (q+:make-qbuttongroup)) 73 | 74 | (define-subwidget (toolbar layout) (q+:make-qgridlayout container) 75 | (setf (q+:margin layout) 0) 76 | (flet ((add-button (class i j) 77 | (let ((button (make-instance class :canvas canvas))) 78 | (setf (q+:checkable button) T) 79 | (q+:add-button group button) 80 | (q+:add-widget layout button i j)))) 81 | (loop for n from 0 82 | for class in '(select-tool 83 | start-node-tool end-node-tool 84 | process-node-tool conditional-node-tool) 85 | do (add-button class n 0) 86 | finally (let ((empty (q+:make-qwidget toolbar))) 87 | (setf (q+:size-policy empty) (values (q+:qsizepolicy.expanding) 88 | (q+:qsizepolicy.preferred))) 89 | (q+:add-widget layout empty n 0))))) 90 | 91 | (define-slot (toolbar clicked) ((id "int")) 92 | (declare (connected group (button-clicked int))) 93 | (let ((tool (q+:button group id))) 94 | (setf (tool canvas) tool))) 95 | 96 | 97 | (define-widget tool (QPushButton) 98 | ((canvas :initarg :canvas :accessor canvas) 99 | (start-pos :initform (q+:make-qpointf 0 0) :accessor start-pos) 100 | (current-pos :initform (q+:make-qpointf 0 0) :accessor current-pos) 101 | (label :initform "?"))) 102 | 103 | (define-initializer (tool setup) 104 | (setf (q+:minimum-size tool) (values 36 36)) 105 | (setf (q+:maximum-size tool) (values 36 36)) 106 | (setf (q+:size-policy tool) (values (q+:qsizepolicy.maximum) 107 | (q+:qsizepolicy.maximum))) 108 | (setf (q+:tool-tip tool) (string (class-name (class-of tool)))) 109 | (etypecase label 110 | (string (setf (q+:text tool) label)) 111 | (qobject (setf (q+:icon tool) label)))) 112 | 113 | (defmethod begin :before ((tool tool) x y) 114 | (setf (q+:x (start-pos tool)) x) 115 | (setf (q+:y (start-pos tool)) y) 116 | (setf (q+:x (current-pos tool)) x) 117 | (setf (q+:y (current-pos tool)) y)) 118 | 119 | (defmethod update :after ((tool tool) x y) 120 | (setf (q+:x (current-pos tool)) x) 121 | (setf (q+:y (current-pos tool)) y)) 122 | 123 | (defmethod begin ((tool tool) x y)) 124 | (defmethod end ((tool tool) x y)) 125 | (defmethod update ((tool tool) x y)) 126 | (defmethod action ((tool tool) key)) 127 | (defmethod paint ((tool tool) painter)) 128 | 129 | (define-widget select-tool (QPushButton tool) 130 | ((selected :initform NIL :accessor selected) 131 | (editing :initform NIL :accessor editing))) 132 | 133 | (defun unit-at-point (mx my nodes) 134 | (dolist (node nodes) 135 | (with-attributes (x y w h) node 136 | (when (and (<= x mx (+ x w)) 137 | (<= y my (+ y h))) 138 | (dolist (port (ports node)) 139 | (let ((point (location port))) 140 | (when (<= (sqrt (+ (expt (- (q+:x point) mx) 2) 141 | (expt (- (q+:y point) my) 2))) 142 | 5.0) 143 | (return-from unit-at-point port)))) 144 | (return-from unit-at-point node))))) 145 | 146 | (defmethod begin ((tool select-tool) mx my) 147 | (let ((new (unit-at-point mx my (nodes (canvas tool))))) 148 | (if (eql new (selected tool)) 149 | (setf (editing tool) (not (editing tool))) 150 | (setf (selected tool) new)))) 151 | 152 | (defmethod update ((tool select-tool) mx my) 153 | (typecase (selected tool) 154 | (node 155 | (let ((dx (- mx (q+:x (current-pos tool)))) 156 | (dy (- my (q+:y (current-pos tool))))) 157 | (incf (attribute (selected tool) 'x) dx) 158 | (incf (attribute (selected tool) 'y) dy))))) 159 | 160 | (defmethod end ((tool select-tool) mx my) 161 | (let ((end (unit-at-point mx my (nodes (canvas tool))))) 162 | (typecase (selected tool) 163 | (port 164 | (when (and (typep end 'port) (not (eql end (selected tool)))) 165 | (connect (selected tool) end 'directed-connection)) 166 | (setf (selected tool) NIL)) 167 | (node 168 | )))) 169 | 170 | (defmethod paint ((tool select-tool) painter) 171 | (typecase (selected tool) 172 | (port 173 | (q+:draw-line painter (location (selected tool)) (current-pos tool))))) 174 | 175 | (defmethod action ((tool select-tool) ev) 176 | (let ((selected (selected tool))) 177 | (when selected 178 | (cond ((editing tool) 179 | (with-attributes (text) selected 180 | (unless text 181 | (setf text "")) 182 | (qtenumcase (q+:key ev) 183 | ((q+:qt.key_backspace) 184 | (setf text (subseq text 0 (max 0 (1- (length text)))))) 185 | (T 186 | (setf text (concatenate 'string text (q+:text ev))))))) 187 | (T 188 | (qtenumcase (q+:key ev) 189 | ((q+:qt.key_delete) 190 | (sever selected) 191 | (setf (nodes (canvas tool)) (remove selected (nodes (canvas tool))))))))))) 192 | 193 | (define-widget node-tool (QPushButton tool) 194 | ((node-type :initform NIL :accessor node-type) 195 | (current :initform NIL :accessor current))) 196 | 197 | (defmethod begin ((tool node-tool) x y) 198 | (let ((node (make-instance (node-type tool)))) 199 | (setf (attribute node 'x) x) 200 | (setf (attribute node 'y) y) 201 | (setf (attribute node 'w) 10) 202 | (setf (attribute node 'h) 10) 203 | (setf (current tool) node) 204 | (push node (nodes (canvas tool))))) 205 | 206 | (defmethod update ((tool node-tool) x y) 207 | (let ((node (current tool))) 208 | (when node 209 | (let ((w (- x (attribute node 'x))) 210 | (h (- y (attribute node 'y)))) 211 | (setf (attribute node 'w) (max 10 w)) 212 | (setf (attribute node 'h) (max 10 h)))))) 213 | 214 | (defmethod end ((tool node-tool) x y) 215 | (setf (current tool) NIL)) 216 | 217 | (defmacro define-node-tool (class) 218 | (let* ((*print-case* #.(readtable-case *readtable*)) 219 | (tool-name (intern (format NIL "~a-~a" class 'node-tool)))) 220 | `(define-widget ,tool-name (QPushButton node-tool) 221 | ((node-type :initform ',class))))) 222 | 223 | (define-node-tool start) 224 | (define-node-tool end) 225 | (define-node-tool process) 226 | (define-node-tool conditional) 227 | 228 | (defun start () 229 | (with-main-window (w 'main))) 230 | -------------------------------------------------------------------------------- /graph.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | (defun visit (node function) 4 | (let ((visited (make-hash-table :test 'eq))) 5 | (labels ((%visit (node) 6 | (unless (gethash node visited) 7 | (setf (gethash node visited) node) 8 | (funcall function node) 9 | (dolist (connection (connections node)) 10 | (cond ((eql node (node (left connection))) 11 | (%visit (node (right connection)))) 12 | ((eql node (node (right connection))) 13 | (%visit (node (left connection))))))))) 14 | (%visit node)))) 15 | 16 | (defun extract-graph (node) 17 | (let ((vertices ()) 18 | (edges ())) 19 | (flet ((connect (left right) 20 | (pushnew (list left right) edges :test #'equal))) 21 | (visit node (lambda (node) 22 | (push node vertices) 23 | (dolist (connection (connections node)) 24 | (etypecase connection 25 | (directed-connection 26 | (connect (node (left connection)) (node (right connection)))) 27 | (connection 28 | (connect (node (left connection)) (node (right connection))) 29 | (connect (node (right connection)) (node (left connection)))))))) 30 | (values vertices edges)))) 31 | 32 | (defun topological-sort (nodes) 33 | (let ((sorted ()) 34 | (visited (make-hash-table :test 'eq))) 35 | (labels ((%visit (node) 36 | (case (gethash node visited) 37 | (:temporary 38 | (error 'graph-contains-cycles :node node)) 39 | (:permanently) 40 | ((NIL) 41 | (setf (gethash node visited) :temporary) 42 | (dolist (connection (connections node)) 43 | (etypecase connection 44 | (directed-connection 45 | (when (eql node (node (left connection))) 46 | (%visit (node (right connection))))) 47 | (connection 48 | (cond ((eql node (node (left connection))) 49 | (%visit (node (right connection)))) 50 | ((eql node (node (right connection))) 51 | (%visit (node (left connection)))))))) 52 | (setf (gethash node visited) :permanently) 53 | (push node sorted))))) 54 | (dolist (node nodes) 55 | (%visit node))) 56 | sorted)) 57 | 58 | (defun color-nodes (node &key (attribute :color) (clear T)) 59 | (multiple-value-bind (vertices edges) 60 | (extract-graph node) 61 | (let ((colors (make-array (length vertices) :initial-element :available))) 62 | (flet ((mark-adjacent (vertex how) 63 | (loop for (from to) in edges 64 | do (cond ((eql vertex from) 65 | (let ((color (attribute to attribute))) 66 | (when color (setf (aref colors color) how)))) 67 | ((eql vertex to) 68 | (let ((color (attribute from attribute))) 69 | (when color (setf (aref colors color) how)))))))) 70 | (when clear 71 | (dolist (vertex vertices) 72 | (remove-attribute vertex attribute))) 73 | (dolist (vertex vertices vertices) 74 | (mark-adjacent vertex :unavailable) 75 | (setf (attribute vertex attribute) (position :available colors)) 76 | (mark-adjacent vertex :available)))))) 77 | 78 | (defun allocate-ports (nodes &key (attribute :color) (clear T) (in-place-attribute :in-place) test (sort #'topological-sort)) 79 | (let ((test (or test (constantly T))) 80 | (nodes (funcall (or sort #'identity) nodes)) 81 | (length 0)) 82 | (flet ((color (port) (attribute port attribute)) 83 | ((setf color) (value port) (setf (attribute port attribute) value)) 84 | (applicable-p (port) (funcall test port))) 85 | ;; Clear and count number of ports. 86 | (dolist (node nodes nodes) 87 | (dolist (port (ports node)) 88 | (when (applicable-p port) 89 | (unless (typep port 'in-port) 90 | (incf length)) 91 | (when clear (setf (color port) NIL))))) 92 | ;; Perform the actual colouring. 93 | (let ((colors (make-array length :initial-element :available))) 94 | (dolist (node (reverse nodes) nodes) 95 | ;; If we have a port that is in-place we 96 | ;; immediately release the colours to allow them 97 | ;; to be re-used in predecessor ports. 98 | (dolist (port (ports node)) 99 | (when (and (applicable-p port) (color port) (attribute port in-place-attribute)) 100 | (setf (aref colors (color port)) :available))) 101 | ;; Distribute colours across predecessor ports. 102 | (dolist (port (ports node)) 103 | (when (typep port 'in-port) 104 | (dolist (connection (connections port)) 105 | (let ((other (if (eql port (left connection)) 106 | (right connection) 107 | (left connection)))) 108 | (when (and (applicable-p other) (not (color other))) 109 | (let ((color (position :available colors))) 110 | (setf (color other) color) 111 | (setf (aref colors color) :unavailable))))))) 112 | ;; Distribute colours across internal ports. 113 | ;; This only happens if a node has unconnected ports. 114 | (dolist (port (ports node)) 115 | (unless (typep port 'in-port) 116 | (when (and (applicable-p port) (not (color port))) 117 | (let ((color (position :available colors))) 118 | (setf (color port) color) 119 | (setf (aref colors color) :unavailable))))) 120 | ;; Mark own as available again. 121 | (dolist (port (ports node)) 122 | (when (and (applicable-p port) (color port)) 123 | (setf (aref colors (color port)) :available)))))))) 124 | 125 | (defun a* (start goal cost-fun &key test) 126 | (let ((test (or test (constantly T))) 127 | (open (list start)) 128 | (source (make-hash-table :test 'eq)) 129 | (score (make-hash-table :test 'eq)) 130 | (cost (make-hash-table :test 'eq))) 131 | (labels ((source (node) 132 | (gethash node source)) 133 | ((setf source) (value node) 134 | (setf (gethash node source) value)) 135 | (score (node) 136 | (gethash node score)) 137 | ((setf score) (value node) 138 | (setf (gethash node score) value)) 139 | (cost (node) 140 | (gethash node cost)) 141 | ((setf cost) (value node) 142 | (setf (gethash node cost) value)) 143 | (current () 144 | (let ((min NIL) (min-cost NIL)) 145 | (dolist (current open min) 146 | (let ((cost (cost current))) 147 | (when (or (null min) (< cost min-cost)) 148 | (setf min current) 149 | (setf min-cost cost))))))) 150 | (setf (score start) 0) 151 | (setf (cost start) (funcall cost-fun start goal)) 152 | (loop while open 153 | do (let ((current (current))) 154 | (when (eq current goal) 155 | (let ((path (list))) 156 | (loop for connection = (source current) 157 | while connection 158 | do (setf current (other-node current connection)) 159 | (push connection path)) 160 | (return path))) 161 | (setf open (delete current open)) 162 | (dolist (port (ports current)) 163 | (dolist (connection (connections port)) 164 | (let ((target (target-node current connection))) 165 | (when (and target (funcall test connection)) 166 | (let ((tentative-score (+ (score current) 1)) 167 | (score (score target))) 168 | (when (or (null score) (< tentative-score score)) 169 | (setf (source target) connection) 170 | (setf (score target) tentative-score) 171 | (setf (cost target) (+ tentative-score 172 | (funcall cost-fun target goal))) 173 | (pushnew target open)))))))) 174 | finally (error 'graph-is-bipartite :node-a start :node-b goal))))) 175 | -------------------------------------------------------------------------------- /static-node.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | (defvar *resolve-port* T) 4 | 5 | (defmacro define-port-value-slot (port-class slot &optional accessor) 6 | `(progn (defmethod port-value ((,port-class ,port-class)) 7 | ,(if accessor 8 | `(,accessor ,port-class) 9 | `(slot-value ,port-class ,slot))) 10 | 11 | (defmethod (setf port-value) (value (,port-class ,port-class)) 12 | (setf ,(if accessor 13 | `(,accessor ,port-class) 14 | `(slot-value ,port-class ,slot)) 15 | value)) 16 | 17 | (defmethod port-value-boundp ((,port-class ,port-class)) 18 | (slot-boundp ,port-class ',slot)) 19 | 20 | (defmethod port-value-makunbound ((,port-class ,port-class)) 21 | (slot-makunbound ,port-class ',slot)))) 22 | 23 | (define-port-value-slot port connections connections) 24 | 25 | (defclass port-definition () 26 | ((port-type :initarg :port-type :accessor port-type) 27 | (port-initargs :initform () :accessor port-initargs)) 28 | (:default-initargs 29 | :port-type NIL)) 30 | 31 | (defmethod port-type ((slot c2mop:slot-definition)) 32 | NIL) 33 | 34 | (defclass direct-port-definition (port-definition c2mop:standard-direct-slot-definition) 35 | ()) 36 | 37 | (defmethod initialize-instance :after ((definition port-definition) &rest initargs &key &allow-other-keys) 38 | (let ((initargs (copy-list initargs))) 39 | (dolist (attr '(:initargs :initform :initfunction :allocation 40 | :accessor :readers :writers :port-type 41 | :type :documentation :class :name #+sbcl SB-PCL::SOURCE)) 42 | (remf initargs attr)) 43 | (setf (port-initargs definition) initargs))) 44 | 45 | (defclass effective-port-definition (port-definition c2mop:standard-effective-slot-definition) 46 | ()) 47 | 48 | (defclass static-node-class (standard-class) 49 | ()) 50 | 51 | (defmethod c2mop:validate-superclass ((class static-node-class) (superclass t)) 52 | NIL) 53 | 54 | (defmethod c2mop:validate-superclass ((class standard-class) (superclass static-node-class)) 55 | T) 56 | 57 | (defmethod c2mop:validate-superclass ((class static-node-class) (superclass standard-class)) 58 | T) 59 | 60 | (defmethod c2mop:validate-superclass ((class static-node-class) (superclass static-node-class)) 61 | T) 62 | 63 | ;; SIGH. Why oh why do we have to replicate this shit just to customise the effective slot definition 64 | ;; class conditionally. 65 | (defun compute-effective-slot-definition-initargs (direct-slotds) 66 | (let ((args (list :name (c2mop:slot-definition-name (first direct-slotds)) :type T)) 67 | (_ '#:no-value)) 68 | (dolist (slotd direct-slotds args) 69 | (when slotd 70 | (when (and (eq _ (getf args :initfunction _)) (c2mop:slot-definition-initfunction slotd)) 71 | (setf (getf args :initfunction) (c2mop:slot-definition-initfunction slotd)) 72 | (setf (getf args :initform) (c2mop:slot-definition-initform slotd))) 73 | (when (and (eq _ (getf args :documentation _)) (documentation slotd T)) 74 | (setf (getf args :documentation) (documentation slotd T))) 75 | (when (and (eq _ (getf args :allocation _)) (c2mop:slot-definition-allocation slotd)) 76 | (setf (getf args :allocation) (c2mop:slot-definition-allocation slotd))) 77 | (setf (getf args :initargs) (union (getf args :initargs) (c2mop:slot-definition-initargs slotd))) 78 | (let ((slotd-type (c2mop:slot-definition-type slotd))) 79 | (setf (getf args :type) (cond ((eq (getf args :type) T) slotd-type) 80 | (T `(and ,slotd-type ,(getf args :type)))))))))) 81 | 82 | (defmethod c2mop:compute-effective-slot-definition ((class static-node-class) name direct-slots) 83 | (declare (ignore name)) 84 | (let* ((initargs (compute-effective-slot-definition-initargs direct-slots)) 85 | (slot (loop for direct in direct-slots 86 | do (when (and (typep direct 'port-definition) (port-type direct)) (return direct))))) 87 | (cond (slot 88 | (setf initargs (list* :port-type (port-type slot) (append (port-initargs slot) initargs))) 89 | (apply #'make-instance (apply #'c2mop:effective-slot-definition-class class initargs) initargs)) 90 | (T 91 | (call-next-method))))) 92 | 93 | (defmethod c2mop:direct-slot-definition-class ((class static-node-class) &rest initargs &key port-type) 94 | (declare (ignore initargs)) 95 | (if port-type 96 | (find-class 'direct-port-definition) 97 | (call-next-method))) 98 | 99 | (defmethod c2mop:effective-slot-definition-class ((class static-node-class) &rest initargs &key port-type port-initargs) 100 | (declare (ignore initargs port-initargs)) 101 | (if port-type 102 | (find-class 'effective-port-definition) 103 | (call-next-method))) 104 | 105 | (defmethod c2mop:slot-value-using-class ((node static-node-class) object (slot effective-port-definition)) 106 | (let ((port (call-next-method))) 107 | (if (and (port-type slot) *resolve-port*) 108 | (port-value port) 109 | port))) 110 | 111 | (defmethod (setf c2mop:slot-value-using-class) (value (node static-node-class) object (slot effective-port-definition)) 112 | (if (and (port-type slot) *resolve-port*) 113 | (setf (port-value (port-slot-value object slot)) value) 114 | (call-next-method))) 115 | 116 | (defmethod c2mop:slot-boundp-using-class ((node static-node-class) object (slot effective-port-definition)) 117 | (if (and (port-type slot) *resolve-port*) 118 | (and (call-next-method) 119 | (port-value-boundp (port-slot-value object slot))) 120 | (call-next-method))) 121 | 122 | (defmethod c2mop:slot-makunbound-using-class ((node static-node-class) object (slot effective-port-definition)) 123 | (if (and (port-type slot) *resolve-port*) 124 | (port-value-makunbound (port-slot-value object slot)) 125 | (call-next-method))) 126 | 127 | (defmethod change-class :around (instance (node static-node-class) &rest initargs) 128 | (declare (ignore initargs)) 129 | ;; The implementation might touch the slots with s-v-u-c during class change, and 130 | ;; clobber the fields that way. To prevent this we revert to using standard method 131 | ;; access during this time. 132 | (let ((*resolve-port* NIL)) 133 | (call-next-method))) 134 | 135 | (defun port-slot-value (node slot) 136 | (c2mop:standard-instance-access node (c2mop:slot-definition-location slot))) 137 | 138 | (defun (setf port-slot-value) (value node slot) 139 | (setf (c2mop:standard-instance-access node (c2mop:slot-definition-location slot)) 140 | value)) 141 | 142 | (defun port-slot-boundp (node name) 143 | (let ((*resolve-port* NIL)) 144 | (slot-boundp node name))) 145 | 146 | (defclass static-node (node) 147 | () 148 | (:metaclass static-node-class)) 149 | 150 | (defmethod shared-initialize ((node static-node) initform-slots &rest initargs) 151 | (let ((slots (c2mop:class-slots (class-of node)))) 152 | (flet ((init-slot (slot value) 153 | (let ((name (c2mop:slot-definition-name slot))) 154 | (if (port-type slot) 155 | (let ((port (if (port-slot-boundp node name) 156 | (slot-value node name) 157 | (apply #'make-instance (port-type slot) 158 | :node node :name name (port-initargs slot))))) 159 | (apply #'change-class port (port-type slot) (port-initargs slot)) 160 | (setf (connections port) value) 161 | (setf (port-slot-value node slot) port)) 162 | (setf (slot-value node name) value))))) 163 | ;; FIXME: handle conversion of slots between non-port-type and port-type 164 | ;; Process initargs 165 | (loop with initialized = () 166 | for (key value) on initargs by #'cddr 167 | for init-slots = (find-slots-by-initarg key slots) 168 | do (dolist (slot init-slots) 169 | ;; See §7.1.4 Rules for Initialization Arguments 170 | (unless (find slot initialized) 171 | (init-slot slot value) 172 | (push slot initialized)))) 173 | ;; Process initforms 174 | (when (eql initform-slots T) 175 | (setf initform-slots (mapcar #'c2mop:slot-definition-name slots))) 176 | (loop for name in initform-slots 177 | for slot = (find-slot-by-name name slots) 178 | for initfunction = (c2mop:slot-definition-initfunction slot) 179 | do (unless (slot-boundp node name) 180 | (cond (initfunction 181 | (init-slot slot (funcall initfunction))) 182 | ((port-type slot) 183 | (init-slot slot NIL))))) 184 | node))) 185 | 186 | (defmacro define-node (name direct-superclasses direct-slots &rest options) 187 | (unless (find :metaclass options :key #'first) 188 | (push `(:metaclass static-node-class) options)) 189 | `(defclass ,name (,@direct-superclasses static-node) 190 | ,direct-slots 191 | ,@options)) 192 | 193 | (defmethod ports ((node static-node)) 194 | (loop for slot in (c2mop:class-slots (class-of node)) 195 | when (port-type slot) 196 | collect (port-slot-value node slot))) 197 | 198 | (defmethod port ((node static-node) (name symbol)) 199 | (let ((slot (find name (c2mop:class-slots (class-of node)) 200 | :key #'c2mop:slot-definition-name))) 201 | (unless (and (typep slot 'port-definition) (port-type slot)) 202 | (error 'designator-not-a-port :port-name name :node node)) 203 | (port-slot-value node slot))) 204 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | Flow
1.0.0

A flowchart and generalised graph library.

Table of Contents

About Flow

Flow is a flowchart graph library. Unlike other graphing libraries, this one focuses on nodes in a graph having distinct "ports" through which connections to other nodes are formed. This helps in many concrete scenarios where it is important to distinguish not only which nodes are connected, but also how they are connected to each other.

Particularly, a lot of data flow and exchange problems can be reduced to such a "flowchart". For example, an audio processing library may present its pipeline as a flowchart of segments that communicate with each other through audio sample buffers. Flow gives a convenient view onto this kind of problem, and even allows the generic visualisation of graphs in this format.

How To

In a Flow graph there's three kinds of units: nodes, ports, and connections. A node is analogous to a vertex in a graph, a port is analogous to a place where a connection can be made on a node, and a connection is analogous to an edge in a graph.

Of the nodes, there's two kinds:

  • dynamic-node A dynamic node's ports are determined at runtime for each individual instance. This is useful for when you're constructing your graph out of elements that you don't know ahead of time.
  • static-node A static node's ports are determined at class definition time, and each port corresponds to a special kind of slot on the graph. This is usually what you want when you define your graph entirely yourself.

Of the ports, there's several mixin classes that can be used to define the kind of port you want. Naturally, if you want to add extra information you can define your own port classes to use instead.

  • n-port A port that accepts an arbitrary number of connections.
  • 1-port A port that only accepts a single connection.
  • in-port A port that only accepts incoming connections.
  • out-port A port that only accepts outgoing connections.

Of the connections, only two are predefined, though it is easy to imagine situations where other kinds of connections might also come in handy.

  • connection A basic undirected connection that goes both ways.
  • directed-connection A directed connection that only goes from left to right.

You can then manage connections between ports using connect, disconnect, and sever. You can also inspect nodes and ports with ports, and connections.

A Flow Chart Example

If you wanted to build a classic flow chart library, you could use something like this as your basic building blocks:

(defclass in (in-port n-port)
 2 |   ())
 3 | 
 4 | (defclass out (out-port 1-port)
 5 |   ())
 6 | 
 7 | (define-node start ()
 8 |   ((out :port-type out)))
 9 | 
10 | (define-node end ()
11 |   ((in :port-type in)))
12 | 
13 | (define-node process ()
14 |   ((in :port-type in)
15 |    (out :port-type out)))
16 | 
17 | (define-node decision ()
18 |   ((in :port-type in)
19 |    (true :port-type out)
20 |    (false :port-type out)))
21 |

Using these basic classes we can then create a flow chart like this:

(let ((start (make-instance 'start))
22 |       (pick-library (make-instance 'process))
23 |       (evaluate-library (make-instance 'process))
24 |       (decide-if-good (make-instance 'decision))
25 |       (end (make-instance 'end)))
26 |   (connect (port start 'out) (port pick-library 'in))
27 |   (connect (port pick-library 'out) (port evaluate-library 'in))
28 |   (connect (port evaluate-library 'out) (port decide-if-good 'in))
29 |   (connect (port decide-if-good 'true) (port end 'in))
30 |   (connect (port decide-if-good 'false) (port pick-library 'in))
31 |   start)
32 |

Operating on Flow Graphs

Flow also includes a couple of operations to help your process the graphs you created using the library. It can do a topological-sort, extract-graph for you, color-nodes, and allocate-ports. There's also a generic visit to allow you to quickly traverse the graph. See the docstrings of the functions for an in-depth explanation of what they do.

Visualising a Flow Graph

There is an additional system included called flow-visualizer. This system includes a primitive graph visualizer that lets you view and edit a graph directly in a GUI. It isn't very advanced at this point, but will probably be extended in the future to a usable flowchart editor.

System Information

1.0.0
Yukari Hafner
zlib
https://Shinmera.github.io/flow/
https://github.com/Shinmera/flow/issues
https://github.com/Shinmera/flow.git
-------------------------------------------------------------------------------- /documentation.lisp: -------------------------------------------------------------------------------- 1 | (in-package #:org.shirakumo.flow) 2 | 3 | ;; conditions.lisp 4 | (docs:define-docs 5 | (type flow-condition 6 | "Base type for all conditions from the Flow library.") 7 | 8 | (type connection-already-exists 9 | "Error signalled if an equivalent connection is added. 10 | 11 | See NEW-CONNECTION 12 | See OLD-CONNECTION 13 | See FLOW-CONDITION") 14 | 15 | (function new-connection 16 | "Returns the new connection that was attempted to be added. 17 | 18 | See CONNECTION-ALREADY-EXISTS") 19 | 20 | (function old-connection 21 | "Returns the old connection that already exists on the ports. 22 | 23 | See CONNECTION-ALREADY-EXISTS") 24 | 25 | (type illegal-connection 26 | "Error signalled if the connection is not permitted by the ports. 27 | 28 | See CONNECTION 29 | See MESSAGE 30 | See FLOW-CONDITION") 31 | 32 | (function connection 33 | "Returns the connection that could not be added. 34 | 35 | See ILLEGAL-CONNECTION") 36 | 37 | (function message 38 | "Returns a reason for the failure. 39 | 40 | See ILLEGAL-CONNECTION") 41 | 42 | (type designator-not-a-port 43 | "Error signalled when a port is accessed that does not exist. 44 | 45 | See NODE 46 | See PORT-NAME") 47 | 48 | (function node 49 | "Returns the node the failure is associated with. 50 | 51 | See DESIGNATOR-NOT-A-PORT") 52 | 53 | (function port-name 54 | "Returns the name of the port that was attempted to be accessed. 55 | 56 | See DESIGNATOR-NOT-A-PORT") 57 | 58 | (type graph-structure-error 59 | "Base type for conditions related to structural problems in graphs. 60 | 61 | These conditions are used by the various generic 62 | algorithms offered in Flow to signal that a 63 | precondition of an operation is not fulfilled in 64 | some way. 65 | 66 | See FLOW-CONDITION") 67 | 68 | (type graph-contains-cycles 69 | "Error signalled if the graph is cyclic. 70 | 71 | This error is signalled on algorithms that expect 72 | an acyclic graph. 73 | 74 | See NODE 75 | See GRAPH-STRUCTURE-ERROR") 76 | 77 | (type graph-is-bipartite 78 | "Error signalled if the graph is bipartite. 79 | 80 | This error is signalled on algorithms that expect 81 | a singular, connected graph. 82 | 83 | See NODE-A 84 | See NODE-B 85 | See GRAPH-STRUCTURE-ERROR") 86 | 87 | (function node-a 88 | "Returns the first node associated with the failure. 89 | 90 | See GRAPH-IS-BIPARTITE") 91 | 92 | (function node-b 93 | "Returns the second node associated with the failure. 94 | 95 | See GRAPH-IS-BIPARTITE")) 96 | 97 | ;; graph.lisp 98 | (docs:define-docs 99 | (function visit 100 | "Visit each node in the graph, starting from the given node. 101 | 102 | The visiting proceeds by calling the function on a 103 | node, then recursing through each connection of the 104 | node. The recursion does not respect directed 105 | connections. It is guaranteed that each node is 106 | only visited once, regardless of cycles.") 107 | 108 | (function extract-graph 109 | "Extract the graph starting from the given node. 110 | 111 | This returns two lists, the first being the list of 112 | vertices (nodes), and the second being the list of 113 | edges, with each edge being a list of left and right 114 | vertex that are connected. The edges are intended to 115 | be directed. Undirected edges are represented by 116 | two edges, one from left to right and one from right 117 | to left. 118 | 119 | The order of the vertices and edges in the returned 120 | lists is unspecified. 121 | 122 | See VISIT") 123 | 124 | (function topological-sort 125 | "Produces a topological sorting of the given nodes. 126 | 127 | This uses Tarjan's algorithm to compute the 128 | topological sorting. Note that if the given list 129 | of nodes does not include all reachable nodes, the 130 | result may be erroneous. 131 | 132 | Signals an error of type GRAPH-CONTAINS-CYCLES if the 133 | graph contains cycles. 134 | 135 | See GRAPH-CONTAINS-CYCLES") 136 | 137 | (function color-nodes 138 | "Perform a graph colouring. 139 | 140 | Each node in the graph from the given starting node 141 | out is assigned a \"colour\" to the specified 142 | attribute. This colour is in practise an integer in 143 | the range [0,n] where n is the number of nodes in 144 | the graph. The colours are distributed in such a way 145 | that no neighbouring nodes have the same colour. 146 | 147 | The employed algorithm is greedy and cannot guarantee 148 | an optimal colouring. Optimal colouring is an NP- 149 | complete problem, and the results produced by a 150 | greedy algorithm are usually shown to be good enough. 151 | 152 | The full list of coloured nodes is returned.") 153 | 154 | (function allocate-ports 155 | "Perform a colour \"allocation\" on the ports of the graph. 156 | 157 | Each port reachable in the graph from the given 158 | starting nodes out that is not of type in-port is 159 | assigned a \"colour\" to the specified attribute. 160 | If clear is non-NIL, the colour attribute is first 161 | cleared off of each port, ensuring a clean colouring. 162 | 163 | The colouring rules are as follows: 164 | A port may not have the same colour as any of the 165 | other ports on the same node. Unless the node's 166 | in-place-attribute is non-NIL, the colour must 167 | also be distinct from the colour of any of the 168 | node's predecessor ports. A predecessor port being 169 | any port that is connected to an in-port of the 170 | node. 171 | 172 | In effect this produces a colouring that is useful 173 | to calculate the allocation of buffers and other 174 | resources necessary to perform a calculation for 175 | a node. These rules ensure that the calculation 176 | can be performed without accidentally overwriting 177 | buffer data necessary at a later point in the 178 | execution of the graph, while at the same time 179 | also minimising the number of necessary buffers. 180 | 181 | The given graph may not contain any cycles. 182 | 183 | Before the nodes are processed, they are sorted by 184 | SORT, defaulting to a TOPOLOGICAL-SORT. The sorted 185 | nodes must be in such an order that the nodes 186 | appear in a topological order. 187 | 188 | If TEST is given, only ports for which the TEST 189 | function returns non-NIL are considered for the 190 | colouring. This allows you to distribute multiple 191 | colour \"kinds\" across a single graph by running 192 | the colouring once for each kind of colour and 193 | excluding the ports that should not be coloured for 194 | that kind. 195 | 196 | See TOPOLOGICAL-SORT") 197 | 198 | (function a* 199 | "Performs an A* shortest-path calculation. 200 | 201 | Returns a list of connections along the shortest 202 | path. 203 | 204 | START and GOAL must be nodes of the same graph. 205 | COST-FUN must be a function of two arguments that 206 | returns an estimated cost to move from the first 207 | to the second node that is passed. 208 | 209 | The TEST function can be used to exclude 210 | connections from the shortest path computation. 211 | Only connections for which TEST returns T will be 212 | considered viable for use in the path. 213 | 214 | Signals an error of type GRAPH-IS-BIPARTITE if no 215 | valid path can be found between START and GOAL. 216 | 217 | See GRAPH-IS-BIPARTITE")) 218 | 219 | ;; nodes.lisp 220 | (docs:define-docs 221 | (type unit 222 | "Superclass for all any entity in a Flow graph. 223 | 224 | See ATTRIBUTES 225 | See ATTRIBUTE 226 | See REMOVE-ATTRIBUTE 227 | See WITH-ATTRIBUTES") 228 | 229 | (function attributes 230 | "Accessor to the unit's hash table of attributes. 231 | 232 | See UNIT 233 | See ATTRIBUTE 234 | See REMOVE-ATTRIBUTE") 235 | 236 | (function attribute 237 | "Accessor to the named attribute on the unit. 238 | 239 | The attribute's name must be comparable by EQL. 240 | If the attribute does not exist on the unit, the 241 | default value is returned instead. 242 | 243 | See ATTRIBUTES 244 | See REMOVE-ATTRIBUTE 245 | See UNIT") 246 | 247 | (function remove-attribute 248 | "Remove the named attribute from the unit. 249 | 250 | See ATTRIBUTES 251 | See ATTRIBUTE 252 | See UNIT") 253 | 254 | (function with-attributes 255 | "Shorthand macro to access the given attributes through a variable. 256 | 257 | This is similar to WITH-SLOTS. 258 | 259 | See UNIT 260 | See ATTRIBUTE 261 | See CL:WITH-SLOTS") 262 | 263 | (type connection 264 | "Representation of a connection between two ports. 265 | 266 | This connection is undirected, meaning that it is 267 | intended to represent information flowing in both 268 | directions. 269 | 270 | See LEFT 271 | See RIGHT 272 | See UNIT 273 | See CONNECTION= 274 | See SEVER") 275 | 276 | (function left 277 | "Accessor to the \"left\" port of a connection. 278 | 279 | See CONNECTION") 280 | 281 | (function right 282 | "Accessor to the \"right\" port of a connection. 283 | 284 | See CONNECTION") 285 | 286 | (function connection= 287 | "Tests whether two connections are considered equal. 288 | 289 | Connections are the same under this comparison, if 290 | they are connected to the same ports \"in the same 291 | way\". This simply means that whether ports are 292 | connected the same may depend on the specific 293 | connection being tested. For example, directed 294 | connections are only the same if the left and right 295 | ports match up, whereas undirected connections are 296 | the same regardless of the order between them. 297 | 298 | See CONNECTION") 299 | 300 | (function sever 301 | "Sever the connections of this unit. 302 | 303 | For a connection, severing it means simply removing 304 | that connection. For a port severing means severing 305 | all connections of the port. For a node severing 306 | severing all connections of all of its ports. 307 | 308 | See CONNECTION 309 | See PORT 310 | See NODE") 311 | 312 | (type directed-connection 313 | "A connection for which information only flows from left to right. 314 | 315 | See CONNECTION") 316 | 317 | (type port 318 | "Representation of a connection port on a node. 319 | 320 | Ports are named places on a node through which 321 | connections between nodes can be made. 322 | 323 | See UNIT 324 | See CONNECTIONS 325 | See NODE 326 | See SLOT 327 | See CONNECT 328 | See DISCONNECT 329 | See REMOVE-CONNECTION 330 | See CHECK-CONNECTION-ACCEPTED 331 | See SEVER") 332 | 333 | (function connections 334 | "Accessor to the list of connections on this unit. 335 | 336 | The list is not guaranteed to be fresh and thus 337 | may not be modified without potentially messing things 338 | up. 339 | 340 | See PORT 341 | See NODE") 342 | 343 | (function node 344 | "Accessor to the node this port is home to. 345 | 346 | See PORT") 347 | 348 | (function slot 349 | "Accessor to the name of the slot this port is contained in. 350 | 351 | See PORT") 352 | 353 | (function connect 354 | "Forge a connection between the two units. 355 | 356 | The connection is only made if it is accepted on both 357 | left and right hand sides by CHECK-CONNECTION-ACCEPTED. 358 | If both accept the connection, it is pushed onto their 359 | respective connections lists. 360 | 361 | See PORT 362 | See CHECK-CONNECTION-ACCEPTED 363 | See CONNECTIONS") 364 | 365 | (function disconnect 366 | "Remove any matching connection from left to right. 367 | 368 | This constructs a directed-connection between the two 369 | and then removes all connections from each of them that 370 | matches the constructed connection by CONNECTION=. 371 | 372 | See PORT 373 | See DIRECTED-CONNECTION 374 | See REMOVE-CONNECTION 375 | See CONNECTION=") 376 | 377 | (function remove-connection 378 | "Remove the given connection from the unit. 379 | 380 | See PORT 381 | See NODE 382 | See CONNECTIONS") 383 | 384 | (function check-connection-accepted 385 | "Check whether the given connection is accepted on the given unit. 386 | 387 | If it is not accepted, an error is signalled. This 388 | generic function uses a PROGN method combination, 389 | which forces tests of all superclasses to be performed 390 | as well. 391 | 392 | See CONNECTION-ALREADY-EXISTS 393 | See ILLEGAL-CONNECTION") 394 | 395 | (type n-port 396 | "A port that accepts an arbitrary number of connections. 397 | 398 | See PORT") 399 | 400 | (type 1-port 401 | "A port that only accepts a single connection. 402 | 403 | See PORT") 404 | 405 | (type in-port 406 | "A port that only accepts incoming connections. 407 | 408 | See PORT") 409 | 410 | (type out-port 411 | "A port that only accepts outgoing connections. 412 | 413 | See PORT") 414 | 415 | (type node 416 | "Superclass for all nodes in a Flow graph. 417 | 418 | A node has a set of PORT instances that are 419 | used to form connections to other nodes over. 420 | 421 | See UNIT 422 | See PORT 423 | See PORTS 424 | See SEVER 425 | See CONNECTIONS 426 | See REMOVE-CONNECTION 427 | See DISCONNECT") 428 | 429 | (function ports 430 | "Returns a list of port objects that the node contains. 431 | 432 | This list may not be fresh and thus must not be modified. 433 | 434 | See NODE") 435 | 436 | (function port 437 | "Return the port object contained in the node with the specified name. 438 | 439 | If the name does not designate a port, an error of type 440 | DESIGNATOR-NOT-A-PORT is signalled. 441 | 442 | See NODE 443 | See DESIGNATOR-NOT-A-PORT") 444 | 445 | (type dynamic-node 446 | "Superclass for all dynamic nodes. 447 | 448 | A dynamic node's ports are allocated on a per-instance 449 | basis, rather than on a per-class basis like for the 450 | static-node. 451 | 452 | See NODE") 453 | 454 | (function other-node 455 | "Return the node on the other side of the connection. 456 | 457 | This works with both directed and undirected connections. 458 | 459 | See TARGET-NODE") 460 | 461 | (function target-node 462 | "Return the node on the other side of the connection. 463 | 464 | If the connection is directed, the target node is only 465 | returned if the left-side of the connection is the given 466 | node. Otherwise NIL is returned. For undirected connections 467 | this acts the same as OTHER-NODE. 468 | 469 | See OTHER-NODE")) 470 | 471 | ;; static-node.lisp 472 | (docs:define-docs 473 | (variable *resolve-port* 474 | "Whether a slot-value/slot-makunbound/slot-boundp call should resolve the port. 475 | 476 | If this is T (the default), then the port's 477 | slot within the object's slot is resolved, 478 | rather than directly resolving the slot that the 479 | port is itself contained in.") 480 | 481 | (function port-value 482 | "Accessor to the primary \"value\" contained in this static port. 483 | 484 | For standard ports this is the CONNECTIONS slot. 485 | 486 | See STATIC-NODE 487 | See PORT-VALUE-BOUNDP 488 | See PORT-VALUE-MAKUNBOUND 489 | See DEFINE-PORT-VALUE-SLOT") 490 | 491 | (function port-value-boundp 492 | "Returns non-NIL if the value slot in this static port is bound. 493 | 494 | See STATIC-NODE 495 | See PORT-VALUE 496 | See PORT-VALUE-MAKUNBOUND 497 | See DEFINE-PORT-VALUE-SLOT") 498 | 499 | (function port-value-makunbound 500 | "Makes the value slot in this static port unbound. 501 | 502 | See STATIC-NODE 503 | See PORT-VALUE 504 | See PORT-VALUE-BOUNDP 505 | See DEFINE-PORT-VALUE-SLOT") 506 | 507 | (function define-port-value-slot 508 | "Easily define a slot to be used for the port value of a port class. 509 | 510 | If ACCESSOR is given it should be a symbol denoting 511 | the name of an accessor responsible for getting and 512 | setting the appropriate value on the port. If it is 513 | not given, SLOT-VALUE is used instead. 514 | 515 | This automatically generates appropriate methods for 516 | the port value functions. 517 | 518 | See PORT-VALUE 519 | See PORT-VALUE-BOUNDP 520 | See PORT-VALUE-MAKUNBOUND") 521 | 522 | (type port-definition 523 | "Superclass for port definition slot classes. 524 | 525 | See PORT-TYPE") 526 | 527 | (function port-type 528 | "Accessor to the port type contained in this slot. 529 | 530 | See PORT-DEFINITION") 531 | 532 | (type direct-port-definition 533 | "Class for direct port slot definitions 534 | 535 | See PORT-DEFINITION 536 | See C2MOP:STANDARD-DIRECT-SLOT-DEFINITION") 537 | 538 | (type effective-port-definition 539 | "Class for effective port slot definitions 540 | 541 | See PORT-DEFINITION 542 | See C2MOP:STANDARD-EFFECTIVE-SLOT-DEFINITION") 543 | 544 | (type static-node-class 545 | "Metaclass for all static nodes. 546 | 547 | This class allows the usage of the :PORT-TYPE initarg 548 | on slots. If non-null, the slot is treated as a port 549 | of the node, allowing to be used for connections 550 | between nodes. When such a slot is accessed normally, 551 | it immediately resolves to the PORT-VALUE of the 552 | port contained in the slot. 553 | 554 | Every port of a port-typed slot is also automatically 555 | instantiated upon instantiation of the class itself, 556 | ensuring that it is consistent with the definition. 557 | 558 | If an access to the actual port object contained in the 559 | slot is necessary, the PORT-SLOT-VALUE and 560 | PORT-SLOT-BOUNDP functions can be used instead. 561 | 562 | See PORT-VALUE 563 | See DIRECT-PORT-DEFINITION 564 | See EFFECTIVE-PORT-DEFINITION 565 | See DEFINE-NODE 566 | See PORT-SLOT-VALUE 567 | See PORT-SLOT-BOUNDP") 568 | 569 | (function port-slot-value 570 | "Accessor to the actual port object contained in the node's slot. 571 | 572 | See STATIC-NODE 573 | See *RESOLVE-PORT*") 574 | 575 | (function port-slot-boundp 576 | "Test to see whether the actual port object contained in the node's slot is bound. 577 | 578 | For any successfully initialised node, this should 579 | always return T. 580 | 581 | See STATIC-NODE 582 | See *RESOLVE-PORT*") 583 | 584 | (type static-node 585 | "Superclass for all static nodes. 586 | 587 | The set of ports of a static node is defined per-class 588 | and is thus the same for each instance of the class. 589 | 590 | In addition to the standard slot keywords, a node 591 | supports the :PORT-TYPE keyword. This takes a symbol 592 | as argument, designating the name of the class to 593 | use for the port of this slot. 594 | 595 | If a slot is a port on the class, connections to 596 | other ports may be established through that port. 597 | 598 | See NODE 599 | See STATIC-NODE-CLASS 600 | See DEFINE-NODE 601 | See PORTS 602 | See PORT 603 | See SEVER 604 | See CONNECTIONS 605 | See REMOVE-CONNECTION 606 | See DISCONNECT") 607 | 608 | (function define-node 609 | "Shorthand macro to define a static node class. 610 | 611 | All this does is add the necessary :METACLASS option 612 | and inject STATIC-NODE as a direct-superclass. 613 | 614 | See STATIC-NODE")) 615 | 616 | ;; toolkit.lisp 617 | (docs:define-docs 618 | (function find-slots-by-initarg 619 | "Returns the list of slots that have key as an initarg.") 620 | 621 | (function find-slot-by-name 622 | "Returns the slot whose name matches the given one.")) 623 | --------------------------------------------------------------------------------