typed-graph/graph.rkt
2021-10-31 22:19:53 +01:00

433 lines
18 KiB
Racket
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;; Copyright 2021 Sergiu Ivanov <sivanov@colimite.fr>
;;;
;;; 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
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))
;; 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)))]
;; Single-source Shortest Paths
[bellman-ford (-> Graph Any (Values (Mutable-HashTable Any Number)
(Mutable-HashTable Any Any)))]
;; 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))))
(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")))