You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
54 lines
1.5 KiB
Racket
54 lines
1.5 KiB
Racket
3 years ago
|
#lang racket/base
|
||
|
|
(provide digraph)
|
||
|
|
|
||
|
|
(define (zero-thunk) 0)
|
||
|
|
|
||
|
|
;; digraph:
|
||
|
|
;; ('a list) * ('a -> 'a list) * ('a -> 'b) * ('b * 'b -> 'b) * (-> 'b)
|
||
|
|
;; -> ('a -> 'b)
|
||
|
|
;; DeRemer and Pennello 1982
|
||
|
|
;; Computes (f x) = (f- x) union Union{(f y) | y in (edges x)}
|
||
|
|
;; We use a hash-table to represent the result function 'a -> 'b set, so
|
||
|
|
;; the values of type 'a must be comparable with eq?.
|
||
|
|
|
||
|
|
(define (digraph nodes edges f- union fail)
|
||
|
|
(define results (make-hasheq))
|
||
|
|
(define (f x) (hash-ref results x fail))
|
||
|
|
;; Maps elements of 'a to integers.
|
||
|
|
(define N (make-hasheq))
|
||
|
|
(define (get-N x) (hash-ref N x zero-thunk))
|
||
|
|
(define (set-N x d) (hash-set! N x d))
|
||
|
|
(define stack null)
|
||
|
|
(define (push x) (set! stack (cons x stack)))
|
||
|
|
(define (pop) (begin0
|
||
|
|
(car stack)
|
||
|
|
(set! stack (cdr stack))))
|
||
|
|
(define (depth) (length stack))
|
||
|
|
|
||
|
|
;; traverse: 'a ->
|
||
|
|
(define (traverse x)
|
||
|
|
(push x)
|
||
|
|
(define d (depth))
|
||
|
|
(set-N x d)
|
||
|
|
(hash-set! results x (f- x))
|
||
|
|
(for-each (λ (y)
|
||
|
|
(when (= 0 (get-N y))
|
||
|
|
(traverse y))
|
||
|
|
(hash-set! results
|
||
|
|
x
|
||
|
|
(union (f x) (f y)))
|
||
|
|
(set-N x (min (get-N x) (get-N y))))
|
||
|
|
(edges x))
|
||
|
|
(when (= d (get-N x))
|
||
|
|
(let loop ([p (pop)])
|
||
|
|
(set-N p +inf.0)
|
||
|
|
(hash-set! results p (f x))
|
||
|
|
(when (not (eq? x p))
|
||
|
|
(loop (pop))))))
|
||
|
|
;; Will map elements of 'a to 'b sets
|
||
|
|
(for ([x (in-list nodes)]
|
||
|
|
#:when (zero? (get-N x)))
|
||
|
|
(traverse x))
|
||
|
|
f)
|
||
|
|
|