diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt index 7b0ecbfc..98aa2326 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/env/type-alias-helper.rkt @@ -3,7 +3,7 @@ ;; This module provides helper functions for type aliases (require "../utils/utils.rkt" - (utils tc-utils) + (utils tarjan tc-utils) (env type-alias-env type-name-env) (rep type-rep) (private parse-type) @@ -26,18 +26,13 @@ register-all-type-aliases parse-type-alias) -;; A Vertex is a -;; (vertex Identifier Boolean Option Option Listof) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; interp. a vertex in a graph, we only use this for Tarjan's algorithm -;; id - identifier (labels vertices) -;; stack? - whether this vertex is on the stack (for speed) -;; index - index tracked in Tarjan's algorithm -;; lowlink - see index -;; adjacent - list of adjacent vertices -(struct vertex (id [stack? #:mutable] [index #:mutable] - [lowlink #:mutable] adjacent) - #:transparent) +;; Data definitions for aliases +;; +;; A TypeAliasInfo is a (list Syntax (Listof Identifier)) +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Dict)> -> Listof> ;; Find strongly connected type aliases in order to @@ -47,54 +42,12 @@ (define (find-strongly-connected-type-aliases dep-map) (define vertex-map (make-free-id-table)) (for ([(id adjacent) (in-dict dep-map)]) - (free-id-table-set! vertex-map id (vertex id #f #f #f adjacent))) - ;; Implements Tarjan's algorithm. See Wikipedia - ;; http://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm - (define (tarjan vertices) - (define (strongly-connected vtx) - (set-vertex-index! vtx index) - (set-vertex-lowlink! vtx index) - (set! index (add1 index)) - (enqueue-front! stack vtx) - (set-vertex-stack?! vtx #t) - (for ([successor-id (in-list (vertex-adjacent vtx))]) - (define successor (free-id-table-ref vertices successor-id)) - (cond [(not (vertex-index successor)) - (strongly-connected successor) - (set-vertex-lowlink! vtx - (min (vertex-lowlink vtx) - (vertex-lowlink successor)))] - [(vertex-stack? successor) - (set-vertex-lowlink! vtx - (min (vertex-lowlink vtx) - (vertex-index successor)))])) - ;; sets a result component if this was a root vertex - (when (= (vertex-lowlink vtx) (vertex-index vtx)) - (define new-scc - (for/list ([elem (in-queue stack)] - #:final (equal? vtx elem)) - (dequeue! stack) - (set-vertex-stack?! elem #f) - (vertex-id elem))) - (set! sccs (cons new-scc sccs)))) - - ;; the body - (define index 0) - (define stack (make-queue)) - (define sccs '()) - (for ([(id vtx) (in-dict vertices)] - #:unless (vertex-index vtx)) - (strongly-connected vtx)) - sccs) - (tarjan vertex-map)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; Data definitions for aliases -;; -;; A TypeAliasInfo is a (list Syntax (Listof Identifier)) -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (free-id-table-set! vertex-map id (make-vertex id adjacent))) + (define components (tarjan vertex-map)) + ;; extract the identifiers out of the results since we + ;; don't need the whole vertex + (for/list ([component components]) + (map vertex-data component))) ;; check-type-alias-contractive : Id Type -> Void ;; diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tarjan.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tarjan.rkt new file mode 100644 index 00000000..bfd53dc1 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tarjan.rkt @@ -0,0 +1,73 @@ +#lang racket/base + +;; This module provides an implementation of Tarjan's algorithm that +;; will find the strongly connected components in a graph. + +(require data/queue + racket/dict) + +(provide tarjan + make-vertex + (struct-out vertex)) + +;; The graph for the algorithm is defined by a dictionary mapping +;; keys to vertices (see the contract on `tarjan` below). The vertices +;; encode edges by holding the keys to adjacent vertices. + +;; A (Vertex K V) is a +;; (vertex V Boolean (Option Integer) (Option Integer) (Listof K)) +;; +;; interp. a vertex in a graph, we only use this for Tarjan's algorithm +;; data - data in the vertex, might be the key +;; stack? - whether this vertex is on the stack (for speed) +;; index - index tracked in Tarjan's algorithm +;; lowlink - see index +;; adjacent - list of adjacent vertices by key +(struct vertex (data [stack? #:mutable] [index #:mutable] + [lowlink #:mutable] adjacent) + #:transparent) + +;; make-vertex : V (Listof K) -> (Vertex K V) +;; A more convenient constructor for vertices +(define (make-vertex key adjacent) + (vertex key #f #f #f adjacent)) + +;; tarjan : (Dict K (Vertex K V)) -> (Listof (Listof (Vertex K V))) +;; Implements Tarjan's algorithm. See Wikipedia +;; http://en.wikipedia.org/wiki/Tarjan's_strongly_connected_components_algorithm +(define (tarjan vertices) + (define (strongly-connected vtx) + (set-vertex-index! vtx index) + (set-vertex-lowlink! vtx index) + (set! index (add1 index)) + (enqueue-front! stack vtx) + (set-vertex-stack?! vtx #t) + (for ([successor-key (in-list (vertex-adjacent vtx))]) + (define successor (dict-ref vertices successor-key)) + (cond [(not (vertex-index successor)) + (strongly-connected successor) + (set-vertex-lowlink! vtx + (min (vertex-lowlink vtx) + (vertex-lowlink successor)))] + [(vertex-stack? successor) + (set-vertex-lowlink! vtx + (min (vertex-lowlink vtx) + (vertex-index successor)))])) + ;; sets a result component if this was a root vertex + (when (= (vertex-lowlink vtx) (vertex-index vtx)) + (define new-scc + (for/list ([elem (in-queue stack)] + #:final (equal? vtx elem)) + (dequeue! stack) + (set-vertex-stack?! elem #f) + elem)) + (set! sccs (cons new-scc sccs)))) + + ;; the body + (define index 0) + (define stack (make-queue)) + (define sccs '()) + (for ([(key vtx) (in-dict vertices)] + #:unless (vertex-index vtx)) + (strongly-connected vtx)) + sccs)