Add std/misc/dag (#1039)

This dag-walking algorithm is the essence of plan making of ASDF2, that
I plan to use in gxpkg. (ASDF3 is more complex needing propagation of a
CRDT due to phasing support for dynamic build-system extensions, but
hopefully we won't need that for gxpkg.)

doc/reference/std/misc/dag.md

@@ -0,0 +1,85 @@
+# Directed Acyclic Graph (DAG) utilities
+
+::: tip To use the bindings from this module:
+```scheme
+(import :std/misc/dag)
+```
+:::
+
+## walk-dag
+```scheme
+(walk-dag
+   walk                          ;; (Node -> Attribute) -> Result
+   arrows: arrows                ;; Node -> Arrows
+   [arrow-target: identity]      ;; Arrow -> Node
+   [synthetic-attribute: true]   ;; Node (List Arrows) (List Attribute) -> Attribute
+   [register-arrow void])        ;; Node Arrow -> Unit
+   -> Attribute
+```
+
+Recursively walk a DAG of transitive arrows depth-first from a set of nodes,
+possibly possibly register the visiting paths, and
+compute a synthetic attribute as we go.
+
+Every reachable node will be visited once and only once,
+wherein node identity is ascertained by the predicate `equal?`.
+An error will be raised if there is a cycle in the graph.
+
+The first and only positional argument, `walk`, is a function
+that takes a `visit` argument and calls it on one or many nodes,
+and finally returns a result.
+Typically, `walk` will look like `(cut <> start-node)`,
+or `(cut map <> start-node-list)` or `(cut for-each <> all-nodes)`.
+
+The only mandatory keyword argument, `arrows:`, is a function
+that takes a node as input, and returns a list of arrows that go from there.
+In the simplest case, an “arrow” is just the name of another node,
+i.e. a super class in an inheritance graph, or
+a sub-expression in an evaluation graph, etc.
+
+The optional keyword argument `arrow-target` takes one of the arrows returned
+by the `arrow` function and returns the target node that this arrow points to.
+The default value `identity` corresponds to the case where arrows do not carry
+any information beside pointing to another node, as is the case in a simple
+dependency graph. In the general case, arrows can be individually labeled
+with extra information, such as a position index within a larger expression,
+and the same target node can sometimes be reached from a same origin multiple
+times through distinct arrows.
+
+The optional keyword argument `synthetic-attribute` is a function that
+takes as arguments a node, the list of arrows from that node, and
+the list of attributes for the respective target node of each arrow,
+and returns the attribute value for the current node.
+
+The optional keyword argument `register-arrow` is a function that is called
+once for each arrow, with the origin node and the arrow as arguments.
+It is called for side-effect and defaults to `void`.
+
+Example:
+```scheme
+> (import :std/sugar)
+> (def operators (hash (+ +) (* *) (- -) (/ /)))
+> (def (simple-eval expr)
+    (walk-dag
+      (cut <> expr)
+      arrows:
+      (lambda (x) (if (pair? x) (cdr x) []))
+      synthetic-attribute:
+      (lambda (expr _subexpr values)
+        (cond
+          ((and (pair? expr) (hash-get operators (car expr)) =>
+           (cut apply <> values)))
+          ((number? expr) expr)
+          (else (error "invalid expression" expr))))))
+> (simple-eval '(- (* (+ (* 4 5) (/ 18 3)) 2) 10))
+42
+```
+The above example isn't realistic in that the representation of nodes
+causing the hashing and equality is in O(n),
+so the overall evaluation will be in O(n^2).
+Also, in this case, the DAG is actually a tree.
+However, the example illustrates the use of synthetic attributes
+to compute a value.
+In a more realistic example, nodes would be identified by labels in O(1),
+any identification of nodes through hash-consing or let-sharing
+would occur in a previous phase, and of course the evaluation would be richer.

src/std/build-spec.ss

@@ -321,6 +321,7 @@
     "crypto"
     ;; :std/misc
     "misc/atom"
+    "misc/dag"
     "misc/decimal"
     "misc/evector"
     "misc/prime"

src/std/misc/dag-test.ss

@@ -0,0 +1,24 @@
+(export dag-test)
+
+(import
+  :std/sugar
+  :std/test
+  ./dag)
+
+(def dag-test
+  (test-suite "test :std/misc/dag"
+    (test-case "walk-dag"
+      (def operators (hash (+ +) (* *) (- -) (/ /)))
+      (def (simple-eval expr)
+        (walk-dag
+         (cut <> expr)
+         arrows:
+         (lambda (x) (if (pair? x) (cdr x) []))
+         synthetic-attribute:
+         (lambda (expr _subexpr values)
+           (cond
+            ((and (pair? expr) (hash-get operators (car expr))) =>
+             (cut apply <> values))
+            ((number? expr) expr)
+            (else (error "invalid expression" expr))))))
+      (check (simple-eval '(- (* (+ (* 4 5) (/ 18 3)) 2) 10)) => 42))))

src/std/misc/dag.ss

@@ -0,0 +1,45 @@
+;;; -*- Gerbil -*-
+;;; © fare
+;;; DAG (directed acyclic graph) algorithms
+
+(export walk-dag)
+
+(import
+  (only-in :std/misc/hash hash-ensure-ref)
+  (only-in :std/misc/list push! pop!)
+  (only-in :std/sugar hash try finally))
+
+;; Recursively walk the DAG of transitive arrows from a set of nodes,
+;; possibly register the visiting paths, and
+;; compute a synthetic attribute as we go.
+;; Typically, walk is (cut <> start-node), or (cut map <> start-node-list).
+;; : ((Node -> Attribute) -> Result) \
+;;   arrows: (Node -> Arrows) \
+;;   arrow-target: (Arrow -> Node) \
+;;   synthetic-attribute: ?(Node (List Arrows) (List Attribute) -> Attribute)
+;;   register-arrow: (Node Arrow -> Unit) \
+;; -> Result
+(def (walk-dag
+      walk ;; chooses one or many (potentially all) initial nodes from which to start walking
+      arrows: arrows ;; annotated arrows from a node
+      arrow-target: (arrow-target identity)
+      synthetic-attribute: (synthetic-attribute true)
+      register-arrow: (register-arrow void))
+  (def visited-table (hash))
+  (def visiting-table (hash))
+  (def visiting-list [])
+  (def (visit node)
+    (when (hash-key? visiting-table node)
+      (error "Circularity in expected DAG for" node visiting-list))
+    (hash-put! visiting-table node #t)
+    (push! node visiting-list)
+    (try
+     (hash-ensure-ref visited-table node
+       (cut let (arrs (arrows node))
+            (synthetic-attribute node arrs
+                                 (map (lambda (arrow)
+                                        (register-arrow node arrow)
+                                        (visit (arrow-target arrow))) arrs))))
+     (finally (pop! visiting-list)
+              (hash-remove! visiting-table node))))
+  (walk visit))