;;; Copyright 2021 Sergiu Ivanov ;;; ;;; Licensed under the Apache License, Version 2.0 (the "License"); ;;; you may not use this file except in compliance with the License. ;;; You may obtain a copy of the License at ;;; ;;; http://www.apache.org/licenses/LICENSE-2.0 ;;; ;;; Unless required by applicable law or agreed to in writing, software ;;; distributed under the License is distributed on an "AS IS" BASIS, ;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. ;;; See the License for the specific language governing permissions and ;;; limitations under the License. #lang typed/racket ;;; This file implements Alex Knauth's solution presented here: ;;; ;;; https://stackoverflow.com/questions/65386334/racket-generic-graph-library-in-typed-racket (module graph-wrapper racket (require (prefix-in g: graph) data/gen-queue/fifo) (provide (struct-out graph) has-vertex? has-edge? vertex=? add-vertex! remove-vertex! rename-vertex! add-edge! add-directed-edge! remove-edge! remove-directed-edge! get-vertices in-vertices get-neighbors in-neighbors get-edges in-edges edge-weight transpose graph-copy graph-union! unweighted-graph? unweighted-graph/undirected unweighted-graph/directed unweighted-graph/adj weighted-graph? weighted-graph/undirected weighted-graph/directed undirected-graph directed-graph matrix-graph? bfs bfs/generalized fewest-vertices-path dfs dfs/generalized dag? tsort cc cc/bfs scc min-st-kruskal max-st-kruskal min-st-prim max-st-prim bellman-ford dijkstra dag-shortest-paths floyd-warshall transitive-closure johnson coloring graphviz) ;; Wrap the opaque graph structure coming from the generic ;; graph library. (struct graph (g)) (define gg graph-g) ;; 1 Generic Graph Interface (define (has-vertex? g v) (g:has-vertex? (gg g) v)) (define (has-edge? g u v) (g:has-edge? (gg g) u v)) (define (vertex=? g u v) (g:vertex=? (gg g) u v)) (define (add-vertex! g v) (g:add-vertex! (gg g) v)) (define (remove-vertex! g v) (g:remove-vertex! (gg g) v)) (define (rename-vertex! g u v) (g:rename-vertex! (gg g) u v)) (define (add-edge! g u v [weight 'default-value]) (g:add-edge! (gg g) u v weight)) (define (add-directed-edge! g u v [weight 'default-value]) (g:add-directed-edge! (gg g) u v weight)) (define (remove-edge! g u v) (g:remove-edge! (gg g) u v)) (define (remove-directed-edge! g u v) (g:remove-directed-edge! (gg g) u v)) (define (get-vertices g) (g:get-vertices (gg g))) (define (in-vertices g) (g:in-vertices (gg g))) (define (get-neighbors g v) (g:get-neighbors (gg g) v)) (define (in-neighbors g v) (g:in-neighbors (gg g) v)) (define (get-edges g) (g:get-edges (gg g))) (define (in-edges g) (g:in-edges (gg g))) (define (edge-weight g u v #:default [default +inf.0]) (g:edge-weight (gg g) u v #:default default)) (define (transpose g) (graph (g:transpose (gg g)))) (define (graph-copy g) (graph (g:graph-copy (gg g)))) (define (graph-union! g other) (g:graph-union! (gg g) (gg other))) ;; 2 Graph constructors ;; 2.1 Unweighted Graphs (define (unweighted-graph? g) (g:unweighted-graph? (gg g))) (define (unweighted-graph/undirected edges) (graph (g:unweighted-graph/undirected edges))) (define (unweighted-graph/directed edges) (graph (g:unweighted-graph/directed edges))) (define (unweighted-graph/adj edges) (graph (g:unweighted-graph/adj edges))) ;; 2.2 Weighted Graphs (define (weighted-graph? g) (g:weighted-graph? (gg g))) (define (weighted-graph/undirected edges) (graph (g:weighted-graph/undirected edges))) (define (weighted-graph/directed edges) (graph (g:weighted-graph/directed edges))) (define (undirected-graph es [ws #f]) (graph (g:undirected-graph es ws))) (define (directed-graph es [ws #f]) (graph (g:directed-graph es ws))) ;; 2.3 Matrix Graphs (define (matrix-graph? g) (g:matrix-graph? (gg g))) ;; 4 Basic Graph Functions ;; 4.1 Breadth-first Search (define (bfs g source) (g:bfs (gg g) source)) (define (bfs/generalized g source #:init-queue [init-queue (mk-empty-fifo)] #:break [break? (λ (G source from to) #f)] #:init [init void] #:visit? [custom-visit?-fn (λ (G source from to) #f)] #:discover [discover (λ (G s u v acc) acc)] #:visit [visit (λ (G s v acc) acc)] #:return [finish (λ (G s acc) acc)]) (g:bfs/generalized (gg g) source #:init-queue init-queue #:break break? #:init init #:visit? custom-visit?-fn #:discover discover #:visit visit #:return finish)) (define (fewest-vertices-path G source target) (g:fewest-vertices-path (gg G) source target)) ;; 4.2 Depth-first Search (define (dfs g) (g:dfs (gg g))) (define (dfs/generalized g #:order [order (λ (x) x)] #:break [break (λ (g from to acc) #f)] #:init [init void] #:inner-init [inner-init (λ (acc) acc)] #:visit? [custom-visit?-fn #f] #:prologue [prologue (λ (G u v acc) acc)] #:epilogue [epilogue (λ (G u v acc) acc)] #:process-unvisited? [process-unvisited? (λ (G u v) #f)] #:process-unvisited [process-unvisited (λ (G u v acc) acc)] #:combine [combine (λ (x acc) x)] #:return [finish (λ (G acc) acc)]) (g:dfs/generalized (gg g) #:order order #:break break #:init init #:inner-init inner-init #:visit? custom-visit?-fn #:prologue prologue #:epilogue epilogue #:process-unvisited? process-unvisited? #:process-unvisited process-unvisited #:combine combine #:return finish)) (define (dag? g) (g:dag? (gg g))) (define (tsort g) (g:tsort (gg g))) (define (cc g) (g:cc (gg g))) (define (cc/bfs g) (g:cc/bfs (gg g))) (define (scc g) (g:scc (gg g))) ;; 5 Spanning Trees (define (min-st-kruskal g) (g:min-st-kruskal (gg g))) (define (max-st-kruskal g) (g:max-st-kruskal (gg g))) (define (min-st-prim g source) (g:min-st-prim (gg g) source)) (define (max-st-prim g source) (g:max-st-prim (gg g) source)) ;; 6 Single-source Shortest Paths (define (bellman-ford g source) (g:bellman-ford (gg g) source)) (define (dijkstra g source) (g:dijkstra (gg g) source)) (define (dag-shortest-paths g source) (g:dag-shortest-paths (gg g) source)) ;; 7 All-pairs Shortest Paths (define (floyd-warshall g) (g:floyd-warshall (gg g))) (define (transitive-closure g) (g:transitive-closure (gg g))) (define (johnson g) (g:johnson (gg g))) ;; 8 Coloring (define (coloring g num-colors #:order [order (λ (x) x)]) (g:coloring (gg g) num-colors #:order order)) ;; 10 Graphviz (define (graphviz g #:output [output #f] #:colors [colors #f]) (g:graphviz (gg g) #:output output #:colors colors))) (require/typed/provide 'graph-wrapper [#:opaque Graph graph?] ;; 1 Generic Graph Interface [has-vertex? (-> Graph Any Boolean)] [has-edge? (-> Graph Any Any Boolean)] [vertex=? (-> Graph Any Any Boolean)] [add-vertex! (-> Graph Any Void)] [remove-vertex! (-> Graph Any Void)] [rename-vertex! (-> Graph Any Any Void)] [add-edge! (->* (Graph Any Any) (Any) Void)] [add-directed-edge! (->* (Graph Any Any) (Any) Void)] [remove-edge! (-> Graph Any Any Void)] [remove-directed-edge! (-> Graph Any Any Void)] [get-vertices (-> Graph (Listof Any))] [in-vertices (-> Graph (Sequenceof Any))] [get-neighbors (-> Graph Any (Listof Any))] [in-neighbors (-> Graph Any (Sequenceof Any))] [get-edges (-> Graph (U (Listof (List Any Any)) (Listof (List Any Any Any))))] [in-edges (-> Graph (Sequenceof (U (List Any Any) (List Any Any Any))))] [edge-weight (->* (Graph Any Any) (#:default Any) Any)] [transpose (-> Graph Graph)] [graph-copy (-> Graph Graph)] [graph-union! (-> Graph Graph Void)] ;; 2 Graph constructors ;; 2.1 Unweighted Graphs [unweighted-graph? (-> Graph Boolean)] [unweighted-graph/undirected (-> (Listof (List Any Any)) Graph)] [unweighted-graph/directed (-> (Listof (List Any Any)) Graph)] [unweighted-graph/adj (-> (Listof (Listof Any)) Graph)] ;; 2.2 Weighted Graphs [weighted-graph? (-> Graph Boolean)] [weighted-graph/undirected (-> (Listof (List Any Any Any)) Graph)] [weighted-graph/directed (-> (Listof (List Any Any Any)) Graph)] [undirected-graph (->* ((Listof (List Any Any))) ((Listof Any)) Graph)] [directed-graph (->* ((Listof (List Any Any))) ((Listof Any)) Graph)] ;; 2.3 Matrix Graphs [matrix-graph? (-> Graph Boolean)] ;; 4 Basic Graph Functions ;; 4.1 Breadth-first Search [bfs (-> Graph Any (Values (Mutable-HashTable Any Number) (Mutable-HashTable Any Any)))] [bfs/generalized (->* (Graph Any) (#:init-queue Any ; TODO: Add a proper type. #:break (-> Graph Any Any Any Boolean) #:init (-> Graph Any Void) #:visit? (-> Graph Any Any Any Boolean) #:discover (-> Graph Any Any Any Any Any) #:visit (-> Graph Any Any Any Any) #:return (-> Graph Any Any Any)) Any)] [fewest-vertices-path (-> Graph Any Any (U (Listof Any) False))] ;; 4.2 Depth-first Search [dfs (-> Graph (Values (Mutable-HashTable Any Number) (Mutable-HashTable Any Any) (Mutable-HashTable Any Number)))] [dfs/generalized (->* (Graph) (#:order (-> (Listof Any) (Listof Any)) #:break (-> Graph Any Any Any Boolean) #:init (-> Graph Void) #:inner-init (-> Any Any) #:visit? (-> Graph Any Any Boolean) #:prologue (-> Graph Any Any Any Any) #:epilogue (-> Graph Any Any Any Any) #:process-unvisited? (-> Graph Any Any Boolean) #:process-unvisited (-> Graph Any Any Any Any) #:combine (-> Any Any Any) #:return (-> Graph Any Any)) Any)] [dag? (-> Graph Boolean)] [tsort (-> Graph (Listof Any))] [cc (-> Graph (Listof (Listof Any)))] [cc/bfs (-> Graph (Listof (Listof Any)))] [scc (-> Graph (Listof (Listof Any)))] ;; 5 Spanning Trees [min-st-kruskal (-> Graph (Listof (List Any Any)))] [max-st-kruskal (-> Graph (Listof (List Any Any)))] [min-st-prim (-> Graph Any (Listof (List Any Any)))] [max-st-prim (-> Graph Any (Listof (List Any Any)))] ;; 6 Single-source Shortest Paths [bellman-ford (-> Graph Any (Values (Mutable-HashTable Any Number) (Mutable-HashTable Any Any)))] [dijkstra (-> Graph Any (Values (Mutable-HashTable Any Number) (Mutable-HashTable Any Any)))] [dag-shortest-paths (-> Graph Any (Values (Mutable-HashTable Any Number) (Mutable-HashTable Any Any)))] ;; 7 All-pairs Shortest Paths [floyd-warshall (-> Graph (Mutable-HashTable (List Any Any) Number))] [transitive-closure (-> Graph (Mutable-HashTable (List Any Any) Boolean))] [johnson (-> Graph (Mutable-HashTable (List Any Any) Number))] ;; 8 Coloring [coloring (->* (Graph Natural) (#:order (-> (Listof Any) (Listof Any))) (U (Mutable-HashTable Any Number) False))] ;; 10 Graphviz [graphviz (->* (Graph) (#:output Output-Port #:colors (HashTable Any Natural)) String)]) (module+ test ;; The goal of the tests is to check that all of the provided ;; functions can be invoked without errors. The tests do not check ;; whether the results make sense. (require typed/rackunit) ;; TODO: Submit an update to hash->list in Racket and then remove ;; this function. (: hash->ordered-list (All (a b) (-> (HashTable a b) (Listof (Pairof a b))))) (define (hash->ordered-list h) (hash-map h (inst cons a b) #t)) (test-case "1 Generic Graph Interface" (define g (directed-graph '((a b) (b c)))) (check-false (has-edge? g 'a 'c)) (check-true (has-vertex? g 'a)) (check-false (vertex=? g 'a 'c)) (add-vertex! g 'd) (remove-vertex! g 'a) (rename-vertex! g 'd 'a) (add-edge! g 'a 'c) (add-edge! g 'a 'c "a->c") (add-directed-edge! g 'a 'c) (add-directed-edge! g 'a 'c "a->c") (remove-edge! g 'a 'c) (remove-directed-edge! g 'a 'c) (check-equal? (get-vertices g) '(c b a)) (check-equal? (sequence->list (in-vertices g)) '(c b a)) (check-equal? (get-neighbors g 'b) '(c)) (check-equal? (sequence->list (in-neighbors g 'b)) '(c)) (check-equal? (get-edges g) '((b c))) (check-equal? (sequence->list (in-edges g)) '((b c))) (check-equal? (edge-weight g 'a 'c) +inf.0) (check-equal? (edge-weight g 'a 'c #:default 'none) 'none) (check-equal? (graphviz (transpose g)) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode0 -> node2;\n\t}\n}\n") (check-equal? (graphviz (graph-copy g)) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode2 -> node0;\n\t}\n}\n") (graph-union! g (transpose g))) (test-case "2 Graph Constructors" ;; 2.1 Unweighted Graphs (check-true (unweighted-graph? (directed-graph '((a b) (b c))))) (check-equal? (graphviz (unweighted-graph/undirected '((a b) (b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node2;\n\t\tnode1 -> node2;\n\t}\n\tsubgraph D {\n\t}\n}\n") (check-equal? (graphviz (unweighted-graph/directed '((a b) (b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node2;\n\t\tnode2 -> node0;\n\t}\n}\n") (check-equal? (graphviz (unweighted-graph/adj '((a b c) (b c d)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"d\"];\n\tnode3 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node0;\n\t\tnode1 -> node3;\n\t\tnode3 -> node0;\n\t\tnode3 -> node2;\n\t}\n}\n") ;; 2.2 Weighted Graphs (check-false (weighted-graph? (directed-graph '((a b) (b c))))) (check-equal? (graphviz (weighted-graph/undirected '((10 a b) (20 b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node2 [label=\"20\"];\n\t\tnode1 -> node2 [label=\"10\"];\n\t}\n\tsubgraph D {\n\t}\n}\n") (check-equal? (graphviz (weighted-graph/directed '((10 a b) (20 b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node2 [label=\"10\"];\n\t\tnode2 -> node0 [label=\"20\"];\n\t}\n}\n") (check-equal? (graphviz (undirected-graph '((a b) (b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node2;\n\t\tnode1 -> node2;\n\t}\n\tsubgraph D {\n\t}\n}\n") (check-equal? (graphviz (undirected-graph '((a b) (b c)) '(1 "hello"))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t\tnode0 -> node2 [label=\"hello\"];\n\t\tnode1 -> node2 [label=\"1\"];\n\t}\n\tsubgraph D {\n\t}\n}\n") (check-equal? (graphviz (directed-graph '((a b) (b c)))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node2;\n\t\tnode2 -> node0;\n\t}\n}\n") (check-equal? (graphviz (directed-graph '((a b) (b c)) '(1 "hello"))) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node2 [label=\"1\"];\n\t\tnode2 -> node0 [label=\"hello\"];\n\t}\n}\n") ;; 2.3 Matrix Graphs (check-false (matrix-graph? (directed-graph '((a b) (b c)))))) (test-case "4 Basic Graph Functions" ;; 4.1 Breadth-first Search (define-values (bfs-lens bfs-tree) (bfs (directed-graph '((a b) (b c))) 'a)) (check-equal? (hash->ordered-list bfs-lens) '((a . 0) (b . 1) (c . 2))) (check-equal? (hash->ordered-list bfs-tree) '((a . #f) (b . a) (c . b))) (check-equal? (bfs/generalized (directed-graph '((a b) (a c) (b d) (c d))) 'a) (void)) (check-equal? (fewest-vertices-path (directed-graph '((a b) (b c) (c d))) 'a 'd) '(a b c d)) ;; 4.2 Depth-first Search (define-values (dfs-discovery dfs-pred dfs-finish) (dfs (directed-graph '((a b) (a c) (b d) (c d))))) (check-equal? (hash->ordered-list dfs-discovery) '((a . 4) (b . 5) (c . 0) (d . 1))) (check-equal? (hash->ordered-list dfs-pred) '((a . #f) (b . a) (c . #f) (d . c))) (check-equal? (hash->ordered-list dfs-finish) '((a . 7) (b . 6) (c . 3) (d . 2))) (check-equal? (dfs/generalized (directed-graph '((a b) (a c) (b d) (c d)))) (void)) (check-true (dag? (directed-graph '((a b) (b c))))) (check-false (dag? (directed-graph '((a b) (b a))))) (check-equal? (tsort (directed-graph '((a b) (b c) (a d) (d b)))) '(a d b c)) (check-equal? (cc (undirected-graph '((a b) (b c) (d e)))) '((e d) (a b c))) (check-equal? (cc/bfs (undirected-graph '((a b) (b c) (d e)))) '((e d) (a b c))) (check-equal? (scc (directed-graph '((a b) (b c) (c a) (c d) (e a)))) '((e) (c b a) (d)))) ;; 5 Spanning Trees (test-case "5 Spanning Trees" (define g0 (weighted-graph/undirected '((1 a b) (2 b c) (3 c a) (4 c d) (5 e a)))) (check-equal? (min-st-kruskal g0) '((a e) (c d) (c b) (a b))) (check-equal? (max-st-kruskal g0) '((c b) (c a) (c d) (a e))) (check-equal? (min-st-prim g0 'e) '((b c) (e a) (c d) (a b))) (check-equal? (max-st-prim g0 'e) '((a c) (e a) (c d) (c b)))) (test-case "6 Single-source Shortest Paths" (define g0 (weighted-graph/directed '((1 a b) (2 a c) (3 b d) (3 c d)))) (define-values (bf-dists bf-pred) (bellman-ford g0 'a)) (check-equal? (hash->ordered-list bf-dists) '((a . 0) (b . 1) (c . 2) (d . 4))) (check-equal? (hash->ordered-list bf-pred) '((a . #f) (b . a) (c . a) (d . b))) (define-values (dj-dists dj-pred) (dijkstra g0 'a)) (check-equal? (hash->ordered-list dj-dists) '((a . 0) (b . 1) (c . 2) (d . 4))) (check-equal? (hash->ordered-list dj-pred) '((a . #f) (b . a) (c . a) (d . b))) (define-values (dsp-dists dsp-pred) (dag-shortest-paths g0 'a)) (check-equal? (hash->ordered-list dsp-dists) '((a . 0) (b . 1) (c . 2) (d . 4))) (check-equal? (hash->ordered-list dsp-pred) '((a . #f) (b . a) (c . a) (d . b)))) (test-case "7 All-pairs Shortest Paths" (define g0 (weighted-graph/directed '((1 a b) (2 a c) (3 b d) (3 c d)))) (check-equal? (hash->ordered-list (floyd-warshall g0)) '(((a d) . 4.0) ((c c) . 0.0) ((b a) . +inf.0) ((a a) . 0.0) ((d c) . +inf.0) ((a c) . 2.0) ((c b) . +inf.0) ((d d) . 0.0) ((c a) . +inf.0) ((b c) . +inf.0) ((d a) . +inf.0) ((c d) . 3.0) ((b d) . 3.0) ((b b) . 0) ((d b) . +inf.0) ((a b) . 1.0))) (check-equal? (hash->ordered-list (transitive-closure g0)) '(((a d) . #t) ((c c) . #t) ((b a) . #f) ((a a) . #t) ((d c) . #f) ((a c) . #t) ((c b) . #f) ((d d) . #t) ((c a) . #f) ((b c) . #f) ((d a) . #f) ((c d) . #t) ((b d) . #t) ((b b) . #t) ((d b) . #f) ((a b) . #t))) (check-equal? (hash->ordered-list (johnson g0)) '(((a d) . 4) ((c c) . 0) ((b a) . +inf.0) ((a a) . 0) ((d c) . +inf.0) ((a c) . 2) ((c b) . +inf.0) ((d d) . 0) ((c a) . +inf.0) ((b c) . +inf.0) ((d a) . +inf.0) ((c d) . 3) ((b d) . 3) ((b b) . 0) ((d b) . +inf.0) ((a b) . 1)))) (test-case "8 Coloring" (define g0 (undirected-graph '((a b) (b c) (c d) (d a)))) (check-equal? (hash->ordered-list (cast (coloring g0 5) (Mutable-HashTable Any Number))) '((a . 0) (b . 1) (c . 0) (d . 1))) (check-false (coloring g0 1))) (test-case "10 Graphviz" (define g (directed-graph '((a b) (b c)))) (check-equal? (graphviz g) "digraph G {\n\tnode0 [label=\"c\"];\n\tnode1 [label=\"a\"];\n\tnode2 [label=\"b\"];\n\tsubgraph U {\n\t\tedge [dir=none];\n\t}\n\tsubgraph D {\n\t\tnode1 -> node2;\n\t\tnode2 -> node0;\n\t}\n}\n")))