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.
491 lines
17 KiB
Scheme
491 lines
17 KiB
Scheme
27 years ago
|
; ======================================================================
|
||
|
|
; minimize-constraints-dfa-min-fast
|
||
|
|
;
|
||
|
|
; Input: lower : list Tvar
|
||
|
|
; upper : list Tvar
|
||
|
|
;
|
||
|
|
; see practical.tex
|
||
|
|
; ======================================================================
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
; Copyright (C) 1995-97 Cormac Flanagan
|
||
|
|
;
|
||
|
|
; This program is free software; you can redistribute it and/or
|
||
|
|
; modify it under the terms of the GNU General Public License
|
||
|
|
; version 2 as published by the Free Software Foundation.
|
||
|
|
;
|
||
|
|
; This program is distributed in the hope that it will be useful,
|
||
|
|
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
; GNU General Public License for more details.
|
||
|
|
;
|
||
|
|
; You should have received a copy of the GNU General Public License
|
||
|
|
; along with this program; if not, write to the Free Software
|
||
|
|
; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (minimize-constraints-dfa-min-fast
|
||
|
|
lower upper
|
||
|
|
helper-fn)
|
||
|
|
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(minimize-constraints-dfa-min-fast
|
||
|
|
lower ,(map Tvar-name lower)
|
||
|
|
upper ,(map Tvar-name upper)))
|
||
|
|
|
||
|
|
(let*-vals
|
||
|
|
([t (lambda (s)
|
||
|
|
(when timing-min
|
||
|
|
(min-record-progress
|
||
|
|
(cons 'minimize-constraints-dfa-min-fast s))))]
|
||
|
|
[_ (t 0)]
|
||
|
|
|
||
|
|
[(live-tvars live-tvar? live-nts tvar->equiv AV->equiv)
|
||
|
|
((copy-live-constraints-few-e #t #t) lower upper)]
|
||
|
|
[_ (t 1)]
|
||
|
|
|
||
|
|
;; Figure out representative elements for Tvars,
|
||
|
|
;; and live AV
|
||
|
|
[(tvar->rep set-tvar-rep!) (alloc-Tvar-field)]
|
||
|
|
[(is-rep? add-rep! get-list-rep) (field->set alloc-Tvar-field)]
|
||
|
|
[(live-AV? set-live-AV! get-live-AVs) (field->set alloc-AV-field)]
|
||
|
|
[_ (for-each
|
||
|
|
(lambda (tvar)
|
||
|
|
(for-each set-live-AV! (get-Tvar-objs tvar))
|
||
|
|
(unless (tvar->rep tvar)
|
||
|
|
(add-rep! tvar)
|
||
|
|
(for-each
|
||
|
|
(lambda (eq) (set-tvar-rep! eq tvar))
|
||
|
|
(tvar->equiv tvar))
|
||
|
|
(assert (tvar->rep tvar))))
|
||
|
|
live-tvars)]
|
||
|
|
[live-AVs (get-live-AVs)]
|
||
|
|
[rep-tvars (get-list-rep)]
|
||
|
|
[_ (t 2)]
|
||
|
|
|
||
|
|
;; states = rep-tvars + live-AVs + dummy-tvar
|
||
|
|
[dummy-tvar (mk-Tvar 'Grammar-dummy)]
|
||
|
|
[all-states (append rep-tvars (list dummy-tvar) live-AVs)]
|
||
|
|
[state->sym (lambda (state)
|
||
|
|
(cond
|
||
|
|
[(Tvar? state) (Tvar-name state)]
|
||
|
|
[(AV? state) (AV->rep state)]
|
||
|
|
[else (error 'state->sym "Bad state ~s" state)]))]
|
||
|
|
|
||
|
|
[grsym-eq?
|
||
|
|
(lambda (g1 g2)
|
||
|
|
;; (andmap eq? g1 g2)
|
||
|
|
(recur loop ([g1 g1][g2 g2])
|
||
|
|
(if (null? g1)
|
||
|
|
(null? g2)
|
||
|
|
(if (null? g2)
|
||
|
|
#f
|
||
|
|
(and (eq? (car g1) (car g2))
|
||
|
|
(loop (cdr g1) (cdr g2)))))))]
|
||
|
|
|
||
|
|
;; mapping from grsyms to numbers
|
||
|
|
[num-grsym 0]
|
||
|
|
[grsym-table '()]
|
||
|
|
[grsym->number
|
||
|
|
(lambda (g1)
|
||
|
|
(or
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[(n . g2) (and (grsym-eq? g1 g2) n)]
|
||
|
|
[_ #f])
|
||
|
|
grsym-table)
|
||
|
|
(begin
|
||
|
|
(set! grsym-table (cons (cons num-grsym g1) grsym-table))
|
||
|
|
(begin0
|
||
|
|
num-grsym
|
||
|
|
(set! num-grsym (add1 num-grsym))))))]
|
||
|
|
|
||
|
|
[(tvar-EF-epsilon set-tvar-EF-epsilon!)
|
||
|
|
(alloc-Tvar-field (lambda () '()))]
|
||
|
|
[(tvar-EF set-tvar-EF!)
|
||
|
|
(alloc-Tvar-field (lambda () '()))]
|
||
|
|
[(AV-EF-epsilon set-AV-EF-epsilon!)
|
||
|
|
(alloc-AV-field (lambda () '()))]
|
||
|
|
[(AV-EF set-AV-EF!)
|
||
|
|
(alloc-AV-field (lambda () '()))]
|
||
|
|
|
||
|
|
[add-tvar-EF!
|
||
|
|
(lambda (tvar g1 s1)
|
||
|
|
(let* ( [tvar (tvar->rep tvar)]
|
||
|
|
[n1 (grsym->number g1)]
|
||
|
|
[x (tvar-EF tvar)])
|
||
|
|
(unless (ormap
|
||
|
|
(match-lambda [(n2 . s2) (and (= n1 n2) (eq? s1 s2))])
|
||
|
|
x)
|
||
|
|
(set-tvar-EF! tvar (cons (cons n1 s1) x)))))]
|
||
|
|
[add-AV-EF!
|
||
|
|
(lambda (AV g1 s1)
|
||
|
|
(let ( [x (AV-EF AV)]
|
||
|
|
[n1 (grsym->number g1)])
|
||
|
|
(unless (ormap
|
||
|
|
(match-lambda [(n2 . s2) (and (= n1 n1) (eq? s1 s2))])
|
||
|
|
x)
|
||
|
|
(set-AV-EF! AV (cons (cons n1 s1) x)))))]
|
||
|
|
[add-tvar-EF-epsilon!
|
||
|
|
(lambda (tvar s1)
|
||
|
|
(let* ( [tvar (tvar->rep tvar)]
|
||
|
|
[x (tvar-EF-epsilon tvar)])
|
||
|
|
(unless (memq s1 x)
|
||
|
|
(set-tvar-EF-epsilon! tvar (cons s1 x)))))]
|
||
|
|
[add-AV-EF-epsilon!
|
||
|
|
(lambda (AV s1)
|
||
|
|
(let ([x (AV-EF-epsilon AV)])
|
||
|
|
(unless (memq s1 x)
|
||
|
|
(set-AV-EF-epsilon! AV (cons s1 x)))))]
|
||
|
|
[state-EF-epsilon
|
||
|
|
(lambda (state)
|
||
|
|
(if (AV? state)
|
||
|
|
(AV-EF-epsilon state)
|
||
|
|
(tvar-EF-epsilon state)))]
|
||
|
|
[state-EF
|
||
|
|
(lambda (state)
|
||
|
|
(if (AV? state)
|
||
|
|
(AV-EF state)
|
||
|
|
(tvar-EF state)))]
|
||
|
|
[_ (t 2.1)]
|
||
|
|
|
||
|
|
;; helper-fn sets things up for inv-delta-traversal
|
||
|
|
;; Sets U field of each state to:
|
||
|
|
;; (listof (cons (listof any) state))
|
||
|
|
|
||
|
|
[extra-seperate (helper-fn live-tvars live-tvar? tvar->rep live-AVs
|
||
|
|
add-tvar-EF! add-tvar-EF-epsilon!
|
||
|
|
add-AV-EF! add-AV-EF-epsilon!)]
|
||
|
|
[_ (t 3)]
|
||
|
|
|
||
|
|
;; Show productions
|
||
|
|
[_ (pretty-debug-dfa-min
|
||
|
|
`(productions
|
||
|
|
,(map
|
||
|
|
(lambda (state)
|
||
|
|
(list (state->sym state)
|
||
|
|
(map state->sym (state-EF-epsilon state))
|
||
|
|
(map
|
||
|
|
(match-lambda [(g . s) (cons g (state->sym s))])
|
||
|
|
(state-EF state))))
|
||
|
|
all-states)))]
|
||
|
|
|
||
|
|
;; Vector of buckets for productions
|
||
|
|
[buckets (make-vector num-grsym '())]
|
||
|
|
[_ (min-record-progress (cons 'num-buckets num-grsym))]
|
||
|
|
|
||
|
|
;; inv-delta-traversal:
|
||
|
|
;; P(states) x (P(states) -> void) -> void
|
||
|
|
;; inv-delta-traversal(X, split)
|
||
|
|
;; => no equiv class partially in X
|
||
|
|
;; => Call split with each "partition of equiv classes" ...
|
||
|
|
;; For effeciency, we call split with a "generator" for the set C_a
|
||
|
|
;; The generator is passed a function add-split!, and then
|
||
|
|
;; calls add-split! on each state in C_a
|
||
|
|
|
||
|
|
;; --- Set things up for Hopcrofts Algorithm
|
||
|
|
|
||
|
|
;; Condition 1, thms hopcroft lub and glb
|
||
|
|
;; Also, to make up for grammar being "incomplete",
|
||
|
|
;; seperate states into equiv classes so states in same equiv class
|
||
|
|
;; have productions on same grammar symbols
|
||
|
|
|
||
|
|
[seperate-grsyms (make-vector num-grsym '())]
|
||
|
|
[seperate-epsilon '()]
|
||
|
|
[_ (for-each
|
||
|
|
(lambda (state)
|
||
|
|
(when (not (null? (state-EF-epsilon state)))
|
||
|
|
(set! seperate-epsilon (cons state seperate-epsilon)))
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(g . s)
|
||
|
|
(vector-set! seperate-grsyms g
|
||
|
|
(cons s (vector-ref seperate-grsyms g)))])
|
||
|
|
(state-EF state)))
|
||
|
|
all-states)]
|
||
|
|
[_ (pretty-debug-dfa-min
|
||
|
|
`(seperate-epsilon ,(map state->sym seperate-epsilon)))]
|
||
|
|
[_ (pretty-debug-dfa-min
|
||
|
|
`(seperate-grsyms
|
||
|
|
,(map
|
||
|
|
(lambda (s) (map state->sym s))
|
||
|
|
(vector->list seperate-grsyms))))]
|
||
|
|
[seperate (append
|
||
|
|
(list rep-tvars)
|
||
|
|
(list live-AVs)
|
||
|
|
extra-seperate
|
||
|
|
;(map list lower)
|
||
|
|
;(map list upper)
|
||
|
|
(list seperate-epsilon)
|
||
|
|
(vector->list seperate-grsyms))]
|
||
|
|
[seperate (filter
|
||
|
|
(lambda (l) (not (null? l)))
|
||
|
|
seperate)]
|
||
|
|
[_ (pretty-debug-dfa-min
|
||
|
|
`(seperate ,(map (lambda (s) (map state->sym s)) seperate)))]
|
||
|
|
[_ (t 4)]
|
||
|
|
|
||
|
|
[inv-delta-traversal
|
||
|
|
(lambda (states split)
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(inv-delta-trav
|
||
|
|
,(map (lambda (state)
|
||
|
|
`(,(state->sym state)
|
||
|
|
(epsilon
|
||
|
|
,(map state->sym (state-EF-epsilon state)))
|
||
|
|
,(map
|
||
|
|
(match-lambda [(g . s) (cons g (state->sym s))])
|
||
|
|
(state-EF state))))
|
||
|
|
states)))
|
||
|
|
;; Do epsilons
|
||
|
|
(split
|
||
|
|
(lambda (add-split!)
|
||
|
|
(for-each
|
||
|
|
(lambda (state)
|
||
|
|
(for-each
|
||
|
|
add-split!
|
||
|
|
(state-EF-epsilon state)))
|
||
|
|
states)))
|
||
|
|
|
||
|
|
;; Put rest into buckets
|
||
|
|
(let ([bucket-ndxs '()])
|
||
|
|
(for-each
|
||
|
|
(lambda (state)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(n . s)
|
||
|
|
(let ([old (vector-ref buckets n)])
|
||
|
|
(vector-set! buckets n (cons s old))
|
||
|
|
(when (null? old)
|
||
|
|
(set! bucket-ndxs (cons n bucket-ndxs))))])
|
||
|
|
(state-EF state)))
|
||
|
|
states)
|
||
|
|
;; Run thru buckets ...
|
||
|
|
(for-each
|
||
|
|
(lambda (i)
|
||
|
|
(let ([s* (vector-ref buckets i)])
|
||
|
|
(split (lambda (add-split!) (for-each add-split! s*)))
|
||
|
|
(vector-set! buckets i '())))
|
||
|
|
bucket-ndxs)))]
|
||
|
|
|
||
|
|
[(state-aux set-state-aux!) (alloc-NT-field)]
|
||
|
|
[(state->rep state->equiv equiv-state? list-rep-states)
|
||
|
|
(Hopcroft-calc-equivalences
|
||
|
|
all-states
|
||
|
|
seperate
|
||
|
|
inv-delta-traversal
|
||
|
|
state-aux set-state-aux! state->sym)]
|
||
|
|
[_ (t 5)]
|
||
|
|
|
||
|
|
[_ (begin
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(list-rep-state ,(map state->sym list-rep-states)))
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(state->equiv
|
||
|
|
,(map (lambda (state)
|
||
|
|
(map state->sym (state->equiv state)))
|
||
|
|
list-rep-states))))]
|
||
|
|
|
||
|
|
;; ----------------------------------------
|
||
|
|
;; Have equivalence relation on states
|
||
|
|
;; Combine w/ previous relation on Tvars
|
||
|
|
;; Convert to equivalence relation on Tvars
|
||
|
|
|
||
|
|
[tvar->equiv
|
||
|
|
(lambda (tvar)
|
||
|
|
(let ([r (apply append (map tvar->equiv (state->equiv tvar)))])
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(tvar->equiv ,(state->sym tvar) = ,(map state->sym r)))
|
||
|
|
r))]
|
||
|
|
|
||
|
|
[AV->equiv
|
||
|
|
(lambda (x)
|
||
|
|
(pretty-debug-dfa-min `(AV->equiv ,(state->sym x)))
|
||
|
|
(let ([e (state->equiv x)])
|
||
|
|
(pretty-debug-dfa-min
|
||
|
|
`(AV->equiv ,(state->sym x) = ,(map state->sym e)))
|
||
|
|
e))]
|
||
|
|
[_ (t 6)])
|
||
|
|
|
||
|
|
(copy-constraints-equiv!
|
||
|
|
live-tvars
|
||
|
|
live-tvar?
|
||
|
|
live-nts
|
||
|
|
tvar->equiv
|
||
|
|
AV->equiv)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (minimize-constraints-dfa-min-lub lower upper)
|
||
|
|
(minimize-constraints-dfa-min-fast lower upper
|
||
|
|
|
||
|
|
;; helper-fn
|
||
|
|
;; helper-fn sets things up for inv-delta-traversal
|
||
|
|
;; Sets U field of each state to:
|
||
|
|
;; (listof (cons (listof any) state))
|
||
|
|
|
||
|
|
(lambda (live-tvars live-tvar? tvar->rep live-AVs
|
||
|
|
add-tvar-EF! add-tvar-EF-epsilon!
|
||
|
|
add-AV-EF! add-AV-EF-epsilon!)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (tvar)
|
||
|
|
|
||
|
|
;; --- Condition 2
|
||
|
|
;; If [a <= b] => forall a'~a exists b'~b st [a' <= b']
|
||
|
|
(for-each
|
||
|
|
(lambda (from)
|
||
|
|
(when (live-tvar? from)
|
||
|
|
(add-tvar-EF-epsilon! tvar (tvar->rep from))))
|
||
|
|
(Tvar-edgefrom tvar))
|
||
|
|
(for-each
|
||
|
|
(lambda (AV) (add-tvar-EF-epsilon! tvar AV))
|
||
|
|
(get-Tvar-objs tvar))
|
||
|
|
|
||
|
|
;; --- Conditions 4 and 5
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ template field alpha sign)
|
||
|
|
(when (live-tvar? alpha)
|
||
|
|
(if sign
|
||
|
|
;; [rng(tvar) <= alpha]
|
||
|
|
(add-tvar-EF! alpha
|
||
|
|
(list 'R4 template field) (tvar->rep tvar))
|
||
|
|
(when #t ;; (follow-antimono-fields template)
|
||
|
|
;; Condition 5
|
||
|
|
;; At bottom we put beta (or tvar) in own equiv class
|
||
|
|
;; [alpha <= dom(tvar)]
|
||
|
|
(add-tvar-EF! tvar
|
||
|
|
(list 'R5 template field) (tvar->rep alpha)))))]
|
||
|
|
[_ (void)])
|
||
|
|
(Tvar-constraints tvar)))
|
||
|
|
live-tvars)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(and AV ($ AV _ template _ fields+ fields-))
|
||
|
|
;; --- Condition 3
|
||
|
|
(for i 0 (vector-length fields+)
|
||
|
|
(let ([field (vector-ref fields+ i)])
|
||
|
|
(when (live-tvar? field)
|
||
|
|
(add-AV-EF! AV
|
||
|
|
(list 'R3 template i) (tvar->rep field)))))])
|
||
|
|
live-AVs)
|
||
|
|
|
||
|
|
;; extra partitions
|
||
|
|
(append
|
||
|
|
;; Put each beta st [alpha <= dom(beta)] in separate equiv class
|
||
|
|
(map list
|
||
|
|
(map tvar->rep
|
||
|
|
(filter
|
||
|
|
(lambda (tvar)
|
||
|
|
(ormap
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ template field alpha #f)
|
||
|
|
(live-tvar? alpha)]
|
||
|
|
[_ #f])
|
||
|
|
(Tvar-constraints tvar)))
|
||
|
|
live-tvars)))
|
||
|
|
|
||
|
|
;; put AVs into equiv class according to templates
|
||
|
|
;; h maps templates to list of AVs
|
||
|
|
(let ([h (make-hash-table)])
|
||
|
|
(for-each
|
||
|
|
(lambda (AV)
|
||
|
|
(let ([t (AV-template AV)])
|
||
|
|
(hash-table-put! h t
|
||
|
|
(cons AV (hash-table-get h t (lambda () ()))))))
|
||
|
|
live-AVs)
|
||
|
|
(hash-table-map h
|
||
|
|
(lambda (t AVs) AVs))))
|
||
|
|
|
||
|
|
)))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
(define (minimize-constraints-dfa-min-glb lower upper)
|
||
|
|
(minimize-constraints-dfa-min-fast lower upper
|
||
|
|
|
||
|
|
;; helper-fn
|
||
|
|
;; helper-fn sets things up for inv-delta-traversal
|
||
|
|
;; Sets U field of each state to:
|
||
|
|
;; (listof (cons (listof any) state))
|
||
|
|
|
||
|
|
(lambda (live-tvars live-tvar? tvar->rep live-AVs
|
||
|
|
add-tvar-EF! add-tvar-EF-epsilon!
|
||
|
|
add-AV-EF! add-AV-EF-epsilon!)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (tvar)
|
||
|
|
|
||
|
|
;; --- Condition 2
|
||
|
|
;; If [a <= b] => forall b'~b exists a'~a st [a' <= b']
|
||
|
|
(for-each
|
||
|
|
(lambda (from)
|
||
|
|
(when (live-tvar? from)
|
||
|
|
(add-tvar-EF-epsilon! from (tvar->rep tvar))))
|
||
|
|
(Tvar-edgefrom tvar))
|
||
|
|
(for-each
|
||
|
|
(lambda (AV) (add-AV-EF-epsilon! AV (tvar->rep tvar)))
|
||
|
|
(get-Tvar-objs tvar))
|
||
|
|
|
||
|
|
;; --- Condition 4
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ template field alpha #t)
|
||
|
|
(when (live-tvar? alpha)
|
||
|
|
;; [rng(tvar) <= alpha]
|
||
|
|
(add-tvar-EF! tvar
|
||
|
|
(list 'R4 template field) (tvar->rep alpha)))]
|
||
|
|
[_ (void)])
|
||
|
|
(Tvar-constraints tvar)))
|
||
|
|
live-tvars)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(and AV ($ AV _ template _ fields+ fields-))
|
||
|
|
;; --- Condition 3
|
||
|
|
(for i 0 (vector-length fields+)
|
||
|
|
(let ([field (vector-ref fields+ i)])
|
||
|
|
(when (live-tvar? field)
|
||
|
|
(add-tvar-EF! field (list 'R3 template i) AV))))
|
||
|
|
;; --- Condition 5
|
||
|
|
(when (follow-antimono-fields template)
|
||
|
|
(for i 0 (vector-length fields-)
|
||
|
|
(let ([field (vector-ref fields- i)])
|
||
|
|
(when (live-tvar? field)
|
||
|
|
;; [dom(AV) <= field]
|
||
|
|
;; At bottom we put AV in own equiv class
|
||
|
|
(add-AV-EF! AV
|
||
|
|
(list 'R5 template i) (tvar->rep field))))))])
|
||
|
|
live-AVs)
|
||
|
|
|
||
|
|
;; Conditions 5,6, thm 1.2
|
||
|
|
;; extra partitioning
|
||
|
|
(append
|
||
|
|
;; Conditions 5, thm 1.2
|
||
|
|
(filter-map
|
||
|
|
(match-lambda
|
||
|
|
[(and AV ($ AV _ template _ _ fields-))
|
||
|
|
(and
|
||
|
|
(follow-antimono-fields template)
|
||
|
|
(> (vector-length fields-) 0)
|
||
|
|
(list AV))])
|
||
|
|
live-AVs)
|
||
|
|
;; Conditions 6, thm 1.2
|
||
|
|
(let ([h (make-hash-table)])
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[(and AV ($ AV _ template))
|
||
|
|
(hash-table-put! h template
|
||
|
|
(cons AV
|
||
|
|
(hash-table-get h template (lambda () '()))))])
|
||
|
|
live-AVs)
|
||
|
|
(hash-table-map h
|
||
|
|
(lambda (template AVs) AVs)))))))
|
||
|
|
|
||
|
|
;; ======================================================================
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|