typed-graph/graph.rkt

;;; 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

           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)))

  ;; 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)))]

  ;; 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))))

  (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")))