230 lines
11 KiB
Racket
230 lines
11 KiB
Racket
;;; 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))
|
|
(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?
|
|
|
|
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)))
|
|
|
|
;; 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)]
|
|
|
|
;; 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)
|
|
|
|
(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 "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")))
|