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.
1556 lines
53 KiB
Scheme
1556 lines
53 KiB
Scheme
;; min-test.ss
|
|
|
|
(define debug-nfa #t)
|
|
(define pretty-debug-nfa (lambda (x) (when debug-nfa (pretty-print x))))
|
|
|
|
(define debug-min #f)
|
|
(define pretty-debug-min (lambda (x) (when debug-nfa (pretty-print x))))
|
|
|
|
; ======================================================================
|
|
; VIEWING CONSTRAINTS AS GRAMMARS
|
|
; ======================================================================
|
|
; Non-Terminalss
|
|
|
|
; x is an AVS
|
|
(define-structure (L x))
|
|
(define-structure (LI x))
|
|
(define-structure (U x))
|
|
(define-structure (UI x))
|
|
|
|
(define eq-nt?
|
|
(match-lambda*
|
|
[(($ L x1) ($ L x2)) (eq? x1 x2)]
|
|
[(($ LI x1) ($ LI x2)) (eq? x1 x2)]
|
|
[(($ U x1) ($ U x2)) (eq? x1 x2)]
|
|
[(($ UI x1) ($ UI x2)) (eq? x1 x2)]
|
|
[_ #f]))
|
|
|
|
(define nt?
|
|
(match-lambda
|
|
[(or ($ L) ($ U) ($ LI) ($ UI)) #t]
|
|
[_ #f]))
|
|
|
|
(define same-nt-type?
|
|
(match-lambda*
|
|
[(($ L x1) ($ L x2)) #t]
|
|
[(($ LI x1) ($ LI x2)) #t]
|
|
[(($ U x1) ($ U x2)) #t]
|
|
[(($ UI x1) ($ UI x2)) #t]
|
|
[_ #f]))
|
|
|
|
(define nt->AVS
|
|
(match-lambda
|
|
[($ L x1) x1]
|
|
[($ LI x1) x1]
|
|
[($ U x1) x1]
|
|
[($ UI x1) x1]))
|
|
|
|
(define nt-chg-AVS
|
|
(match-lambda*
|
|
[(f ($ L x)) (make-L (f x))]
|
|
[(f ($ LI x)) (make-LI (f x))]
|
|
[(f ($ U x)) (make-U (f x))]
|
|
[(f ($ UI x)) (make-UI (f x))]))
|
|
|
|
(define drop-I
|
|
(match-lambda
|
|
[(and nt (or ($ L _) ($ U _))) nt]
|
|
[($ LI x) (make-L x)]
|
|
[($ UI x) (make-U x)]))
|
|
|
|
(define mem-nt?
|
|
(lambda (nt l)
|
|
(and (not (null? l))
|
|
(or (eq-nt? nt (car l))
|
|
(mem-nt? nt (cdr l))))))
|
|
|
|
(define (set-NT-prop! NT val)
|
|
(let* ([AVS (nt->AVS NT)]
|
|
[old (get-AVS-prop AVS 'NT-prop #f)]
|
|
[old (if old old
|
|
(let ([v (vector #f #f #f #f)])
|
|
(add-AVS-prop! AVS 'NT-prop v)
|
|
v))])
|
|
(vector-set!
|
|
old
|
|
(match NT
|
|
[($ L x1) 0] [($ LI x1) 1] [($ U x1) 2] [($ UI x1) 3])
|
|
val)))
|
|
|
|
(define (get-NT-prop NT)
|
|
(let* ([AVS (nt->AVS NT)]
|
|
[old (get-AVS-prop AVS 'NT-prop #f)]
|
|
[old (if old old
|
|
(let ([v (vector #f #f #f #f)])
|
|
(add-AVS-prop! AVS 'NT-prop v)
|
|
v))])
|
|
(vector-ref
|
|
old
|
|
(match NT
|
|
[($ L x1) 0] [($ LI x1) 1] [($ U x1) 2] [($ UI x1) 3]))))
|
|
|
|
; ======================================================================
|
|
; Right hand side of a production
|
|
|
|
(define-structure (rhs* grsym nts))
|
|
(define (make-rhs grsym nt) (make-rhs* grsym (list nt)))
|
|
|
|
(define-structure (grsym ineq fn sign template field-no))
|
|
;; ineq is '<= or '>=
|
|
;; fn is 'inj, 'inj-tst or 'ext
|
|
;; sign is #t (monotonic) or #f (antimonotonic)
|
|
;; field-no may be #f
|
|
|
|
(define (make-grsym->=inj+ t f) (make-grsym '>= 'inj #t t f))
|
|
(define (make-grsym->=inj- t f) (make-grsym '>= 'inj #f t f))
|
|
(define (make-grsym->=inj? t f) (make-grsym '>= 'inj '? t f))
|
|
|
|
(define (make-grsym-<=inj-tst+ t f) (make-grsym '<= 'inj-tst #t t f))
|
|
(define (make-grsym-<=inj-tst- t f) (make-grsym '<= 'inj-tst #f t f))
|
|
|
|
(define (make-grsym-<=ext+ t f) (make-grsym '<= 'ext #t t f))
|
|
(define (make-grsym->=ext- t f) (make-grsym '>= 'ext #f t f))
|
|
|
|
(define (make-grsym->=ext+ t f) (make-grsym '>= 'ext #t t f))
|
|
(define (make-grsym-<=ext- t f) (make-grsym '<= 'ext #f t f))
|
|
|
|
;; a grsym can also be '>=epsilon or '<=epsilon
|
|
|
|
(define grsym-eq?
|
|
(match-lambda*
|
|
[(($ grsym i1 f1 s1 t1 n1) ($ grsym i2 f2 s2 t2 n2))
|
|
(and (eq? i1 i2) (eq? f1 f2) (eq? t1 t2) (eqv? n1 n2))]
|
|
[(x y) (eq? x y)]))
|
|
|
|
; ======================================================================
|
|
;; Initializing the L, ... fields of an AVS
|
|
|
|
(define (add-AVS-LI! AVS x) (set-AVS-LI! AVS (cons x (AVS-LI AVS))))
|
|
(define (add-AVS-UI! AVS x) (set-AVS-UI! AVS (cons x (AVS-UI AVS))))
|
|
(define (add-AVS-L! AVS x) (set-AVS-L! AVS (cons x (AVS-L AVS))))
|
|
(define (add-AVS-U! AVS x) (set-AVS-U! AVS (cons x (AVS-U AVS))))
|
|
|
|
(define zeroary-op-AVS (void))
|
|
|
|
(define (calc-productions! list-AVS use-AVS?
|
|
tree zeroary
|
|
epsilon-L epsilon-U epsilon-LI epsilon-UI
|
|
L->LI U->UI)
|
|
;; tree : bool -- controls if produce RTG or regular grammar
|
|
;; epsilon-...: bool -- control epsilon transitions
|
|
;; L->LI, ... : bool -- controls L->LI production rule
|
|
|
|
(for-each
|
|
(lambda (AVS)
|
|
(set-AVS-L! AVS '())
|
|
(set-AVS-U! AVS '())
|
|
(set-AVS-LI! AVS '())
|
|
(set-AVS-UI! AVS '())
|
|
(set-AVS-edgefrom! AVS '()))
|
|
list-AVS)
|
|
|
|
;; ------ Invert edges
|
|
(for-each
|
|
(lambda (AVS)
|
|
(for-each
|
|
(lambda (to) (when (use-AVS? to) (add-AVS-edgefrom! to AVS)))
|
|
(AVS-edgeto AVS)))
|
|
list-AVS)
|
|
|
|
;; ------ Now make L, etc, from AV, constraints and edges
|
|
(for-each
|
|
(lambda (AVS)
|
|
|
|
;; ------ Invert original AV
|
|
(for-each
|
|
(match-lambda
|
|
[($ AV _ (and template ($ template type signs)) misc fields)
|
|
(let ([l (vector-length fields)])
|
|
(cond
|
|
[tree
|
|
;; Make rhs
|
|
(add-AVS-L! AVS
|
|
(make-rhs* (make-grsym->=inj? template #f)
|
|
(map
|
|
(lambda (f sign)
|
|
(case sign
|
|
[>=inj+ (make-L f)]
|
|
[>=inj- (make-U f)]))
|
|
(vector->list fields)
|
|
(vector->list signs))))]
|
|
;; o/w not tree
|
|
[(= l 0)
|
|
;; Terminal
|
|
(add-AVS-L! AVS
|
|
(make-rhs* (make-grsym->=inj+ template #f) '()))]
|
|
[else
|
|
;; Non-terminal - return all prods
|
|
(for i 0 l
|
|
(let ([f (vector-ref fields i)])
|
|
(when (use-AVS? f)
|
|
(case (vector-ref signs i)
|
|
[>=inj+
|
|
(add-AVS-L! AVS
|
|
(make-rhs (make-grsym->=inj+ template i)
|
|
(make-L f)))]
|
|
[>=inj-
|
|
(add-AVS-L! AVS
|
|
(make-rhs (make-grsym->=inj- template i)
|
|
(make-U f)))]))))])
|
|
|
|
(if (and zeroary (zero? l))
|
|
;; Fake a unary op
|
|
(add-AVS-UI! zeroary-op-AVS
|
|
(make-rhs (make-grsym-<=ext+ template 0)
|
|
(make-UI AVS)))
|
|
|
|
(for i 0 l
|
|
(let ([f (vector-ref fields i)])
|
|
(when (use-AVS? f)
|
|
(case (vector-ref signs i)
|
|
[>=inj+
|
|
(add-AVS-UI!
|
|
f
|
|
(make-rhs (make-grsym-<=ext+ template i)
|
|
(make-UI AVS)))]
|
|
[>=inj-
|
|
(add-AVS-LI!
|
|
f
|
|
(make-rhs (make-grsym->=ext- template i)
|
|
(make-UI AVS)))]))))))])
|
|
(AVS-orig-objs AVS))
|
|
|
|
;; ------ Invert constraints
|
|
(for-each
|
|
(match-lambda
|
|
[($ con _ (and template ($ template type signs)) field-no AVS2)
|
|
(when (use-AVS? AVS2)
|
|
(case (vector-ref signs field-no)
|
|
[>=inj+
|
|
(add-AVS-U! AVS
|
|
(make-rhs (make-grsym-<=inj-tst+ template field-no)
|
|
(make-U AVS2)))
|
|
(add-AVS-LI! AVS2
|
|
(make-rhs (make-grsym->=ext+ template field-no)
|
|
(make-LI AVS)))]
|
|
[>=inj-
|
|
(add-AVS-U! AVS
|
|
(make-rhs (make-grsym-<=inj-tst- template field-no)
|
|
(make-L AVS2)))
|
|
(add-AVS-UI! AVS2
|
|
(make-rhs (make-grsym-<=ext- template field-no)
|
|
(make-LI AVS)))]))]
|
|
[($ con-filter _ filter AVS2)
|
|
(printf "Warning: con-filter~n")])
|
|
(AVS-constraints AVS))
|
|
|
|
(for-each
|
|
(lambda (to)
|
|
(when epsilon-L (add-AVS-L! to (make-rhs '>=epsilon (make-L AVS))))
|
|
(case epsilon-LI
|
|
[#t (add-AVS-LI! to (make-rhs '>=epsilon (make-LI AVS)))]
|
|
['concrete
|
|
(add-AVS-LI! to (make-rhs '>=concrete-epsilon (make-LI AVS)))])
|
|
(when epsilon-U (add-AVS-U! AVS (make-rhs '<=epsilon (make-U to))))
|
|
(when epsilon-UI (add-AVS-UI! AVS (make-rhs '<=epsilon (make-UI to)))))
|
|
(AVS-edgeto AVS))
|
|
|
|
(when L->LI (add-AVS-L! AVS (make-rhs '>=epsilon (make-LI AVS))))
|
|
(when U->UI (add-AVS-U! AVS (make-rhs '<=epsilon (make-UI AVS))))
|
|
)
|
|
list-AVS))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Restricting the grammer to certain NTs
|
|
|
|
(define (restrict-nts! list-AVS use-nt?)
|
|
;;(display `(restrict-nts! ,(map nt->sym list-nt))) (newline)
|
|
(let* ([filter-nt
|
|
(lambda (rhs*)
|
|
(filter-map
|
|
(match-lambda
|
|
[(and rhs ($ rhs* grsym nts))
|
|
(if (or (null? nts) (ormap use-nt? nts))
|
|
rhs
|
|
#f)])
|
|
rhs*))])
|
|
(for-each
|
|
(lambda (AVS)
|
|
(for-each
|
|
(match-lambda
|
|
[(set-AVS-NT! make-NT AVS-NT)
|
|
(set-AVS-NT! AVS (if (use-nt? (make-NT AVS))
|
|
(filter-nt (AVS-NT AVS))
|
|
'()))])
|
|
(list (list set-AVS-L! make-L AVS-L)
|
|
(list set-AVS-U! make-U AVS-U)
|
|
(list set-AVS-LI! make-LI AVS-LI)
|
|
(list set-AVS-UI! make-UI AVS-UI))))
|
|
list-AVS)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; for-each-prods
|
|
;; For this to work, must have AVS-L etc setup.
|
|
|
|
(define (for-each-prods f nt)
|
|
(match nt
|
|
[($ L x) (for-each f (AVS-L x))]
|
|
[($ U x) (for-each f (AVS-U x))]
|
|
[($ LI x) (for-each f (AVS-LI x))]
|
|
[($ UI x) (for-each f (AVS-UI x))]))
|
|
|
|
;; ======================================================================
|
|
|
|
(define (add-prod nt grsym nt*)
|
|
(assert (andmap nt? nt*))
|
|
(let ([rhs (make-rhs* grsym nt*)])
|
|
(match nt
|
|
[($ L x) (add-AVS-L! x rhs)]
|
|
[($ LI x) (add-AVS-LI! x rhs)]
|
|
[($ U x) (add-AVS-U! x rhs)]
|
|
[($ UI x) (add-AVS-UI! x rhs)])))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Assumes grammar is result of N->D
|
|
;; So is a D-RTG, and only has productions on L,U
|
|
;; not on LI,UI
|
|
|
|
(define (convert-productions-to-AV-etc! list-AVS)
|
|
;;(pretty-print `(cvt-prods ,(map name-for-AVS list-AVS)))
|
|
(let* ([AVS-empty (mk-AVS-tmp 'empty)]
|
|
[add-AV-field!
|
|
(lambda (AVS template field-no AVS2)
|
|
(or
|
|
;; Is the zeroary-op-AVS field
|
|
(>= field-no (vector-length (template-signs template)))
|
|
;; Reuse old AV, if possible
|
|
(ormap
|
|
(match-lambda
|
|
[($ AV _ (? (lambda (t) (eq? t template))) _ fields)
|
|
(cond
|
|
[(eq? (vector-ref fields field-no) AVS-empty)
|
|
;;; empty, fill it
|
|
(vector-set! fields field-no AVS2)
|
|
#t]
|
|
[(eq? (vector-ref fields field-no) AVS2)
|
|
;; Already in there
|
|
#t]
|
|
[else;; this won't work
|
|
#f])]
|
|
[_ #f])
|
|
(get-AVS-objs AVS))
|
|
;; No AV in there, create and add one
|
|
(let* ([l (vector-length (template-signs template))]
|
|
[fields (make-vector l AVS-empty)])
|
|
(vector-set! fields field-no AVS2)
|
|
(add-nohash-orig-AV!
|
|
AVS (create-AV-nolist template '() fields)))))])
|
|
|
|
;; Examine each production rule, and convert it.
|
|
(for-each
|
|
(lambda (AVS)
|
|
;;(pretty-print `(convert-prods AVS ,(AVS-num AVS)))
|
|
;; L-AVS
|
|
(for-each
|
|
(match-lambda
|
|
[($ rhs* (or '>=epsilon '>=concrete-epsilon) ((or ($ L x) ($ LI x))))
|
|
(unless (eq? AVS x) (add-edge! x AVS))]
|
|
[($ rhs* ($ grsym '>= 'inj sign template field-no) ())
|
|
(add-nohash-orig-AV! AVS (create-AV-nolist template '() (vector)))]
|
|
[($ rhs* ($ grsym '>= 'inj sign template #f)
|
|
((or ($ L x*) ($ U x*)) ...))
|
|
(map-with-n (lambda (x n) (add-AV-field! AVS template n x))
|
|
x*)]
|
|
[($ rhs* ($ grsym '>= 'inj sign template field-no)
|
|
((or ($ L x) ($ U x))))
|
|
(add-AV-field! AVS template field-no x)]
|
|
|
|
[($ rhs* ($ grsym '>= ext #t template field-no)
|
|
((or ($ LI x) ($ L x))))
|
|
(add-con! x (create-con template field-no AVS))]
|
|
[($ rhs* ($ grsym '>= ext #f template field-no)
|
|
((or ($ UI x) ($ U x))))
|
|
(add-AV-field! x template field-no AVS)]
|
|
|
|
[($ rhs* grsym nts)
|
|
(error 'prod-to-AV "Bad L/LI rhs ~s ~s"
|
|
(grsym->rep grsym) (map nt->sym nts))]
|
|
[rhs (error 'prod-to-AV "Bad L/LI rhs ~s" rhs)])
|
|
(append (AVS-L AVS) (AVS-LI AVS)))
|
|
|
|
;; U-AVS
|
|
(for-each
|
|
(match-lambda
|
|
[($ rhs* '<=epsilon ((or ($ U x) ($ UI x))))
|
|
(unless (eq? AVS x) (add-edge! AVS x))]
|
|
[($ rhs* ($ grsym '<= 'inj-tst #f template field-no) (($ L x)))
|
|
(add-con! AVS (create-con template field-no x))]
|
|
[($ rhs* ($ grsym '<= 'inj-tst #t template field-no) (($ U x)))
|
|
(add-con! AVS (create-con template field-no x))]
|
|
|
|
[($ rhs* ($ grsym '<= 'ext #f template field-no)
|
|
((or ($ L x) ($ LI x))))
|
|
(add-con! x (create-con template field-no AVS))]
|
|
[($ rhs* ($ grsym '<= 'ext #t template field-no)
|
|
((or ($ U x) ($ UI x))))
|
|
(add-AV-field! x template field-no AVS)]
|
|
|
|
[($ rhs* grsym nts)
|
|
(error 'prod-to-AV "Bad U/UI rhs ~s ~s"
|
|
(grsym->rep grsym) (map nt->sym nts))]
|
|
[rhs (error 'prod-to-AV "Bad U/UI rhs ~s" rhs)])
|
|
(append (AVS-U AVS) (AVS-UI AVS))))
|
|
|
|
list-AVS)
|
|
|
|
;; Now prop AVs
|
|
(for-each
|
|
(lambda (AVS)
|
|
(for-each (lambda (AV) (prop-AV! AVS AV))
|
|
(AVS-orig-objs AVS)))
|
|
list-AVS)
|
|
|
|
))
|
|
|
|
; ======================================================================
|
|
; COMPRESSING GRAMMARS
|
|
; ======================================================================
|
|
|
|
(define (epsilon-close-nt nt)
|
|
(epsilon-close-nts (list nt)))
|
|
|
|
(define (epsilon-close-nts nts)
|
|
(let ([done '()])
|
|
(letrec ([traverse
|
|
(lambda (nt)
|
|
(unless (mem-nt? nt done)
|
|
(set! done (cons nt done))
|
|
(for-each-prods
|
|
(match-lambda
|
|
[($ rhs* (or '>=epsilon '<=epsilon) (nt2))
|
|
(traverse nt2)]
|
|
[_ (void)])
|
|
nt)))])
|
|
(for-each traverse nts)
|
|
done)))
|
|
|
|
; --------------------
|
|
|
|
(define for-each-prods-joined
|
|
(lambda (fn nt*)
|
|
(let* ([rhs* '()])
|
|
(for-each
|
|
(lambda (nt)
|
|
(for-each-prods (lambda (rhs) (set! rhs* (cons rhs rhs*)))
|
|
nt))
|
|
nt*)
|
|
(recur loop ([rhs* rhs*])
|
|
(match rhs*
|
|
[() (void)]
|
|
[(($ rhs* grsym _) . _)
|
|
(match-let
|
|
([(nt** . rest)
|
|
(filter-map-split
|
|
(match-lambda
|
|
[($ rhs* grsym2 nt*)
|
|
(if (grsym-eq? grsym grsym2) nt* #f)])
|
|
rhs*)])
|
|
(fn grsym nt**)
|
|
(loop rest))])))))
|
|
|
|
; --------------------
|
|
|
|
(define (grammar-calc-reached roots)
|
|
(let ([reached '()]
|
|
[tag (gensym)])
|
|
(letrec
|
|
([traverse
|
|
(lambda (nt)
|
|
(unless (eq? (get-NT-prop nt) tag)
|
|
(set-NT-prop! nt tag)
|
|
(set! reached (cons nt reached))
|
|
(for-each-prods
|
|
(match-lambda
|
|
[($ rhs* _ nt*)
|
|
(for-each traverse nt*)])
|
|
nt)))])
|
|
(for-each traverse roots)
|
|
(list reached (lambda (nt) (eq? (get-NT-prop nt) tag))))))
|
|
|
|
; --------------------
|
|
|
|
(define (grammar-calc-nonempty num-NT NT->num num->NT final)
|
|
(let* ([table (make-vector num-NT '())])
|
|
;; entry is #t if nonempty,
|
|
;; or else list of NT to make nonempty if proved nonempty
|
|
(letrec ([set-nonempty!
|
|
(lambda (n)
|
|
'(pretty-print `(set-nonempty! ,(nt->sym (num->NT n))))
|
|
(let ([l (vector-ref table n)])
|
|
(vector-set! table n #t)
|
|
(when (list? l)
|
|
(for-each set-nonempty! l))))]
|
|
[add-depends
|
|
(lambda (i j)
|
|
'(pretty-print `(add-depends ,(nt->sym (num->NT i))
|
|
,(nt->sym (num->NT j))))
|
|
(if (list? (vector-ref table j))
|
|
(vector-set! table j (cons i (vector-ref table j)))
|
|
(set-nonempty! i)))])
|
|
|
|
;; fill out table
|
|
(for i 0 num-NT
|
|
(let ([nt (num->NT i)])
|
|
;;(pretty-print `(i ,i nt ,(nt->sym nt) ,(mem-nt? nt final)))
|
|
(if (mem-nt? nt final)
|
|
(set-nonempty! i)
|
|
;; Look at prods
|
|
(for-each-prods
|
|
(match-lambda
|
|
[($ rhs* grsym nt*)
|
|
;;(pretty-print `(-> ,(grsym->rep grsym) ,(nt->sym nt)))
|
|
(if (null? nt*)
|
|
(set-nonempty! i)
|
|
(for-each (lambda (nt) (add-depends i (NT->num nt)))
|
|
nt*))])
|
|
nt))))
|
|
|
|
;; return list of nonempty nts, plus membership predicate
|
|
;;
|
|
(list (filter-map
|
|
(lambda (x) x)
|
|
(map-with-n
|
|
(lambda (entry n)
|
|
(if (eq? entry #t)
|
|
(num->NT n)
|
|
#f))
|
|
(vector->list table)))
|
|
;; nonempty-nt?
|
|
(lambda (nt) (if (and (NT->num nt)
|
|
(eq? (vector-ref table (NT->num nt)) #t))
|
|
#t #f))
|
|
))))
|
|
|
|
; ======================================================================
|
|
; COMPRESSING CONSTRAINTS
|
|
; ======================================================================
|
|
|
|
(define select-L
|
|
(lambda (nt*)
|
|
(filter-map (match-lambda [($ L x) x][_ #f]) nt*)))
|
|
|
|
(define select-LI
|
|
(lambda (nt*)
|
|
(filter-map (match-lambda [($ LI x) x][_ #f]) nt*)))
|
|
|
|
(define select-U
|
|
(lambda (nt*)
|
|
(filter-map (match-lambda [($ U x) x][_ #f]) nt*)))
|
|
|
|
(define select-UI
|
|
(lambda (nt*)
|
|
(filter-map (match-lambda [($ UI x) x][_ #f]) nt*)))
|
|
|
|
; --------------------
|
|
|
|
(define (epsilon-close-forwards AVS)
|
|
(let ([done '()])
|
|
(recur traverse ([AVS AVS])
|
|
(unless (memq AVS done)
|
|
(set! done (cons AVS done))
|
|
(for-each traverse (AVS-edgeto AVS))))
|
|
done))
|
|
|
|
(define (epsilon-close-backwards AVS)
|
|
(let ([done '()])
|
|
(recur traverse ([AVS AVS])
|
|
(unless (memq AVS done)
|
|
(set! done (cons AVS done))
|
|
(for-each traverse (AVS-edgefrom AVS))))
|
|
done))
|
|
|
|
; ======================================================================
|
|
; Could use list-AVS to be more efficient here!
|
|
|
|
(define calc-NT<->num
|
|
(lambda (list-nt)
|
|
(let* ([num-NT 0]
|
|
[num->NT (make-vector (* 4 (length list-nt)) #f)]
|
|
[AVS->L-NT (make-vector num-AVS #f)]
|
|
[AVS->LI-NT (make-vector num-AVS #f)]
|
|
[AVS->U-NT (make-vector num-AVS #f)]
|
|
[AVS->UI-NT (make-vector num-AVS #f)]
|
|
[add-NT! (lambda (NT)
|
|
(vector-set! num->NT num-NT NT)
|
|
(begin0
|
|
num-NT
|
|
(set! num-NT (add1 num-NT))))])
|
|
(for-each
|
|
(lambda (nt)
|
|
(match nt
|
|
[($ L AVS) (vector-set! AVS->L-NT (AVS-num AVS) (add-NT! nt))]
|
|
[($ LI AVS) (vector-set! AVS->LI-NT (AVS-num AVS) (add-NT! nt))]
|
|
[($ U AVS) (vector-set! AVS->U-NT (AVS-num AVS) (add-NT! nt))]
|
|
[($ UI AVS) (vector-set! AVS->UI-NT (AVS-num AVS) (add-NT! nt))]))
|
|
list-nt)
|
|
(list num-NT
|
|
(match-lambda
|
|
[($ L x) (vector-ref AVS->L-NT (AVS-num x))]
|
|
[($ LI x) (vector-ref AVS->LI-NT (AVS-num x))]
|
|
[($ U x) (vector-ref AVS->U-NT (AVS-num x))]
|
|
[($ UI x) (vector-ref AVS->UI-NT (AVS-num x))])
|
|
(lambda (num) (vector-ref num->NT num))))))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define leq->equiv
|
|
(lambda (list-e e->num e-leq?)
|
|
;; Takes a list of elements in list-e,
|
|
;; with e-leq? a partial order
|
|
;; Calculates an equivalence relation
|
|
(match-let*
|
|
([e-eq? (lambda (i j)
|
|
(let ([r (and (e-leq? i j) (e-leq? j i))])
|
|
'(when r (printf "~s=~s~n" (nt->sym i) (nt->sym j)))
|
|
r))]
|
|
[AVS-leq? (lambda (x y)
|
|
(and (NT-leq? (make-L x) (make-L y))
|
|
(NT-leq? (make-LI x) (make-LI y))
|
|
(NT-leq? (make-U y) (make-U x))
|
|
(NT-leq? (make-UI y) (make-UI x))))]
|
|
[AVS->rep-AVS (make-vector num-AVS #f)]
|
|
[list-rep-AVS '()]
|
|
[old-AVS->AVS (lambda (old-AVS)
|
|
(let ([AVS (vector-ref AVS->rep-AVS
|
|
(AVS-num old-AVS))])
|
|
AVS))]
|
|
[old-nt->nt (lambda (nt) (nt-chg-AVS old-AVS->AVS nt))]
|
|
[AV-leq?
|
|
(match-lambda*
|
|
[(($ AV _ template1 misc1 fields1)
|
|
($ AV _ template2 misc2 fields2)
|
|
AVS-leq?)
|
|
(and (eq? template1 template2)
|
|
(eq? misc1 misc2)
|
|
(andmap2 AVS-leq?
|
|
(vector->list fields1)
|
|
(vector->list fields2)))])])
|
|
|
|
;; Have equivalence relation in AVS-eq?
|
|
;; want to create mapping AVS -> new AVS
|
|
(printf "Calculating AVS -> new AVS~n")
|
|
(for-each
|
|
(lambda (AVS)
|
|
(ormap
|
|
(lambda (rep)
|
|
(cond
|
|
[(eq? AVS rep)
|
|
;; This AVS not included in any representative AVS
|
|
(let ([rep-AVS (mk-AVS-nolist 'eqvcl)])
|
|
(vector-set! AVS->rep-AVS (AVS-num AVS) rep-AVS)
|
|
(set! list-rep-AVS (cons (cons AVS rep-AVS) list-rep-AVS))
|
|
#t)]
|
|
[(AVS-eq? AVS rep)
|
|
;; This NT is equivalent to rep
|
|
(let ([rep-AVS (vector-ref AVS->rep-AVS (AVS-num rep))])
|
|
;(assert (eq? rep ))
|
|
(vector-set! AVS->rep-AVS (AVS-num AVS) rep-AVS)
|
|
(set! list-rep-AVS (cons (cons AVS rep-AVS) list-rep-AVS)))
|
|
#t]
|
|
[else;; continue
|
|
#f]))
|
|
list-AVS))
|
|
list-AVS)
|
|
|
|
'(begin
|
|
(display
|
|
`(AVS->rep-AVS
|
|
,(map (lambda (AVS)
|
|
(cons (AVS-num AVS)
|
|
(AVS-num (vector-ref AVS->rep-AVS (AVS-num AVS)))))
|
|
list-AVS)))
|
|
(newline))
|
|
(printf "Num rep AVS=~s~n" (length list-rep-AVS))
|
|
|
|
;; Now fill in the AV's and constraints in the representative AVS
|
|
;; Maybe want to remove duplicate constraints
|
|
;; Not removing duplicate AV's from different AVSs in same rep-AVS
|
|
|
|
(printf "Copying grammar~n")
|
|
|
|
(for-each
|
|
(match-lambda
|
|
[(old-AVS . rep-AVS)
|
|
(for-each
|
|
(match-lambda
|
|
[(get-nt set-nt!)
|
|
(for-each
|
|
(match-lambda
|
|
[($ rhs* grsym nt*)
|
|
(or
|
|
;; Check if already there
|
|
(ormap (match-lambda
|
|
[($ rhs*
|
|
(? (lambda (grsym2) (grsym-eq? grsym grsym2)))
|
|
(? (lambda (nt2*) (andmap2 eq-nt? nt* nt2*))))
|
|
#t]
|
|
[_ #f])
|
|
(get-nt rep-AVS))
|
|
;; Add it
|
|
(set-nt! rep-AVS
|
|
(cons (make-rhs*
|
|
grsym
|
|
(map old-nt->nt nt*))
|
|
(get-nt rep-AVS))))])
|
|
(get-nt old-AVS))])
|
|
(list (list AVS-L set-AVS-L!)
|
|
(list AVS-LI set-AVS-LI!)
|
|
(list AVS-U set-AVS-U!)
|
|
(list AVS-UI set-AVS-UI!)))])
|
|
list-rep-AVS)
|
|
|
|
;; Done, return mapping
|
|
old-nt->nt)))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define apply-equivalence-relation
|
|
(lambda (list-nt num-NT NT->num num->NT NT-leq?)
|
|
;; NT-leq? is ordering on NTs
|
|
(match-let*
|
|
([list-AVS (list->set (map nt->AVS list-nt))]
|
|
[NT-eq? (lambda (i j)
|
|
(let ([r (and (NT-leq? i j) (NT-leq? j i))])
|
|
'(when r (printf "~s=~s~n" (nt->sym i) (nt->sym j)))
|
|
r))]
|
|
[AVS-eq? (lambda (x y)
|
|
(let ([r
|
|
(and (NT-eq? (make-L x) (make-L y))
|
|
(NT-eq? (make-LI x) (make-LI y))
|
|
(NT-eq? (make-U x) (make-U y))
|
|
(NT-eq? (make-UI x) (make-UI y)))])
|
|
'(when r (printf "~s=~s~n"
|
|
(name-for-AVS x) (name-for-AVS y)))
|
|
r))]
|
|
[AVS-leq? (lambda (x y)
|
|
(and (NT-leq? (make-L x) (make-L y))
|
|
(NT-leq? (make-LI x) (make-LI y))
|
|
(NT-leq? (make-U y) (make-U x))
|
|
(NT-leq? (make-UI y) (make-UI x))))]
|
|
[AVS->rep-AVS (make-vector num-AVS #f)]
|
|
[list-rep-AVS '()]
|
|
[old-AVS->AVS (lambda (old-AVS)
|
|
(let ([AVS (vector-ref AVS->rep-AVS
|
|
(AVS-num old-AVS))])
|
|
AVS))]
|
|
[old-nt->nt (lambda (nt) (nt-chg-AVS old-AVS->AVS nt))]
|
|
[AV-leq?
|
|
(match-lambda*
|
|
[(($ AV _ template1 misc1 fields1)
|
|
($ AV _ template2 misc2 fields2)
|
|
AVS-leq?)
|
|
(and (eq? template1 template2)
|
|
(eq? misc1 misc2)
|
|
(andmap2 AVS-leq?
|
|
(vector->list fields1)
|
|
(vector->list fields2)))])])
|
|
|
|
;; Have equivalence relation in AVS-eq?
|
|
;; want to create mapping AVS -> new AVS
|
|
(printf "Calculating AVS -> new AVS~n")
|
|
(for-each
|
|
(lambda (AVS)
|
|
(ormap
|
|
(lambda (rep)
|
|
(cond
|
|
[(eq? AVS rep)
|
|
;; This AVS not included in any representative AVS
|
|
(let ([rep-AVS (mk-AVS-nolist 'eqvcl)])
|
|
(vector-set! AVS->rep-AVS (AVS-num AVS) rep-AVS)
|
|
(set! list-rep-AVS (cons (cons AVS rep-AVS) list-rep-AVS))
|
|
#t)]
|
|
[(AVS-eq? AVS rep)
|
|
;; This NT is equivalent to rep
|
|
(let ([rep-AVS (vector-ref AVS->rep-AVS (AVS-num rep))])
|
|
;(assert (eq? rep ))
|
|
(vector-set! AVS->rep-AVS (AVS-num AVS) rep-AVS)
|
|
(set! list-rep-AVS (cons (cons AVS rep-AVS) list-rep-AVS)))
|
|
#t]
|
|
[else;; continue
|
|
#f]))
|
|
list-AVS))
|
|
list-AVS)
|
|
|
|
'(begin
|
|
(display
|
|
`(AVS->rep-AVS
|
|
,(map (lambda (AVS)
|
|
(cons (AVS-num AVS)
|
|
(AVS-num (vector-ref AVS->rep-AVS (AVS-num AVS)))))
|
|
list-AVS)))
|
|
(newline))
|
|
(printf "Num rep AVS=~s~n" (length list-rep-AVS))
|
|
|
|
;; Now fill in the AV's and constraints in the representative AVS
|
|
;; Maybe want to remove duplicate constraints
|
|
;; Not removing duplicate AV's from different AVSs in same rep-AVS
|
|
|
|
(printf "Copying grammar~n")
|
|
|
|
(for-each
|
|
(match-lambda
|
|
[(old-AVS . rep-AVS)
|
|
(for-each
|
|
(match-lambda
|
|
[(get-nt set-nt!)
|
|
(for-each
|
|
(match-lambda
|
|
[($ rhs* grsym nt*)
|
|
(or
|
|
;; Check if already there
|
|
(ormap (match-lambda
|
|
[($ rhs*
|
|
(? (lambda (grsym2) (grsym-eq? grsym grsym2)))
|
|
(? (lambda (nt2*) (andmap2 eq-nt? nt* nt2*))))
|
|
#t]
|
|
[_ #f])
|
|
(get-nt rep-AVS))
|
|
;; Add it
|
|
(set-nt! rep-AVS
|
|
(cons (make-rhs*
|
|
grsym
|
|
(map old-nt->nt nt*))
|
|
(get-nt rep-AVS))))])
|
|
(get-nt old-AVS))])
|
|
(list (list AVS-L set-AVS-L!)
|
|
(list AVS-LI set-AVS-LI!)
|
|
(list AVS-U set-AVS-U!)
|
|
(list AVS-UI set-AVS-UI!)))])
|
|
list-rep-AVS)
|
|
|
|
;; Done, return mapping
|
|
old-nt->nt)))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define (make-minimization-algorithm table-builder-helper)
|
|
(lambda (list-nt roots final)
|
|
(match-let*
|
|
([(num-NT NT->num num->NT) (calc-NT<->num list-nt)]
|
|
[table-leq (make-vector (* num-NT num-NT) (lambda () (void)))]
|
|
;; table-leq[x][y] = #f => not(x<=y)
|
|
;; otherwise a thunk to perform if not(x<=y)
|
|
[NT->rep-NT (make-vector num-NT)]
|
|
[list-rep-NT '()])
|
|
(letrec
|
|
([lookup (lambda (x y) (vector-ref table-leq (+ (* num-NT x) y)))]
|
|
[set-table-leq!
|
|
(lambda (x y v) (vector-set! table-leq (+ (* num-NT x) y) v))]
|
|
|
|
[record-not-leq
|
|
(lambda (x y)
|
|
'(pretty-print
|
|
`(record-not-leq ,(nt->sym (num->NT x))
|
|
,(nt->sym (num->NT y))))
|
|
(when (not (= x y))
|
|
(match (lookup x y)
|
|
[#f (void)]
|
|
[thunk
|
|
(set-table-leq! x y #f)
|
|
(thunk)])))]
|
|
|
|
[record-not-leq-action
|
|
(lambda (d-p d-q thunk)
|
|
'(pretty-print
|
|
`(record-not-leq-action ,(nt->sym (num->NT d-p))
|
|
,(nt->sym (num->NT d-q))))
|
|
(unless (eq? d-p d-q)
|
|
(match (lookup d-p d-q)
|
|
[#f (thunk)]
|
|
[entry (set-table-leq! d-p d-q
|
|
(lambda () (thunk) (entry)))])))]
|
|
|
|
[epsilon-close (make-vector num-NT #f)]
|
|
[nt->grsym->fields (make-vector num-NT #f)])
|
|
|
|
(printf "Calculating epsilon-close~n")
|
|
(for i 0 num-NT
|
|
(vector-set! epsilon-close i
|
|
(epsilon-close-nt (num->NT i))))
|
|
|
|
(printf "Calculating (x,c) -> { z* | x ->* y, y->c(z*) }~n")
|
|
(for i 0 num-NT
|
|
(let* ([alist '()])
|
|
(for-each-prods-joined
|
|
(lambda (grsym nt**)
|
|
'(printf "nt ~s grsym ~a nt** ~s~n"
|
|
(nt->sym (num->NT i))
|
|
(grsym->rep grsym)
|
|
nt**)
|
|
(set! alist (cons (cons grsym nt**) alist)))
|
|
(epsilon-close-nt (num->NT i)))
|
|
(vector-set! nt->grsym->fields i alist)))
|
|
|
|
(printf "Marking final NT's as distinct~n")
|
|
(for-each
|
|
(lambda (f)
|
|
(let ([n-f (NT->num f)])
|
|
(when n-f
|
|
(for i 0 num-NT
|
|
(unless (= n-f i)
|
|
(record-not-leq n-f i)
|
|
(record-not-leq i n-f))))))
|
|
final)
|
|
|
|
(printf "Filling not-leq table, num-NT=~s~n" num-NT)
|
|
;; Fill out table-leq
|
|
(for i 0 num-NT
|
|
;;(printf "i ~s ~s~n" i (nt->sym (num->NT i)))
|
|
(when (zero? (modulo i 25)) (printf ".") (flush-output))
|
|
(for-each-prods
|
|
(match-lambda
|
|
[($ rhs* (or '>=epsilon '<=epsilon) (nt))
|
|
(for j 0 num-NT
|
|
(record-not-leq-action
|
|
(NT->num nt) j
|
|
(lambda () (record-not-leq i j))))]
|
|
[($ rhs* grsym nt*)
|
|
(for j 0 num-NT
|
|
'(printf "i ~s j ~s grsym ~s nt ~s ~s ~n"
|
|
(nt->sym (num->NT i))
|
|
(nt->sym (num->NT j))
|
|
grsym
|
|
(map nt->sym nt*)
|
|
(map NT->num nt*))
|
|
(unless (= i j)
|
|
(let* ([nt** (or (ormap
|
|
(match-lambda
|
|
[(grsym2 . nt**)
|
|
(if (grsym-eq? grsym grsym2)
|
|
nt**
|
|
#f)])
|
|
(vector-ref nt->grsym->fields j))
|
|
'())]
|
|
[n (length nt**)])
|
|
'(printf "i ~s grsym ~a j ~s nt** ~s~n"
|
|
(nt->sym (num->NT i))
|
|
(grsym->rep grsym)
|
|
(nt->sym (num->NT j))
|
|
nt**)
|
|
(cond
|
|
[(zero? n) (record-not-leq i j)]
|
|
[(null? nt*) ; is a terminal
|
|
(void)]
|
|
[else
|
|
(table-builder-helper
|
|
i j nt* nt** n NT->num
|
|
record-not-leq record-not-leq-action)]))))])
|
|
(num->NT i)))
|
|
(newline)
|
|
|
|
'(begin
|
|
(display (map (lambda (x) (if x #t #f)) (vector->list table-leq)))
|
|
(newline)
|
|
(for-each
|
|
(lambda (nt1)
|
|
(for-each
|
|
(lambda (nt2)
|
|
(when (and (not (eq? nt1 nt2))
|
|
(same-nt-type? nt1 nt2)
|
|
(lookup (NT->num nt1) (NT->num nt2)))
|
|
(printf "~s <= ~s~n" (nt->sym nt1) (nt->sym nt2))))
|
|
list-nt))
|
|
list-nt)
|
|
(newline))
|
|
|
|
;; Apply the equivalence relation
|
|
(printf "Applying the eqv rel~n")
|
|
(apply-equivalence-relation
|
|
list-nt
|
|
num-NT NT->num num->NT
|
|
(lambda (i j)
|
|
(let ([num-i (NT->num i)]
|
|
[num-j (NT->num j)])
|
|
(cond
|
|
[(and (not num-i) (not num-j)) #t]
|
|
[(or (not num-i) (not num-j)) #f]
|
|
[else (lookup (NT->num i) (NT->num j))]))))))))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define (DFA-min list-nt roots final)
|
|
(printf "Calculating min DFA~n")
|
|
((make-minimization-algorithm
|
|
(lambda (i j nt* nt** n NT->num record-not-leq record-not-leq-action)
|
|
;; i -> c(nt*)
|
|
;; j -> c(nt*) forall nt* in nt**
|
|
(for-each
|
|
(lambda (nt*2)
|
|
(for-each
|
|
(lambda (nt nt2)
|
|
(record-not-leq-action (NT->num nt) (NT->num nt2)
|
|
(lambda () (record-not-leq i j))))
|
|
nt* nt*2))
|
|
nt**)))
|
|
list-nt roots final))
|
|
|
|
(define (NFA-min list-nt roots final)
|
|
(printf "Calculating min NFA~n")
|
|
((make-minimization-algorithm
|
|
(lambda (i j nt* nt** n NT->num record-not-leq record-not-leq-action)
|
|
;; i -> c(nt*)
|
|
;; j -> c(nt*) forall nt* in nt**
|
|
(recur loop ([nt* nt*][nt** nt**])
|
|
(unless (null? nt*)
|
|
(let* ([f (car nt*)]
|
|
[f* (map car nt**)]
|
|
[c n]
|
|
[fn (lambda ()
|
|
(set! c (sub1 c))
|
|
(when (zero? c) (record-not-leq i j)))])
|
|
(for-each
|
|
(lambda (f2)
|
|
(record-not-leq-action (NT->num f) (NT->num f2) fn))
|
|
f*)
|
|
(loop (cdr nt*) (map cdr nt**)))))))
|
|
list-nt roots final))
|
|
|
|
(define (RTG-min list-nt roots final)
|
|
(printf "Calculating min NFA~n")
|
|
((make-minimization-algorithm
|
|
(lambda (i j nt* nt** n NT->num record-not-leq record-not-leq-action)
|
|
;; i -> c(nt*)
|
|
;; j -> c(nt*) forall nt* in nt**
|
|
(let ([c n])
|
|
(for-each
|
|
(lambda (nt*2)
|
|
(let ([nt*2-done #f])
|
|
(for-each
|
|
(lambda (nt nt2)
|
|
(record-not-leq-action
|
|
(NT->num nt)
|
|
(NT->num nt2)
|
|
(lambda ()
|
|
(unless nt*2-done
|
|
(set! nt*2-done #t)
|
|
(set! c (sub1 c))
|
|
(when (zero? c) (record-not-leq i j))))))
|
|
nt* nt*2)))
|
|
nt**))))
|
|
list-nt roots final))
|
|
|
|
; ======================================================================;
|
|
; N->D section
|
|
; ======================================================================;
|
|
|
|
(define (N->D roots final tidy?)
|
|
;; n is an old nt
|
|
;; d is new nt
|
|
(printf "Calculating N->D~n")
|
|
(letrec
|
|
([n*->d '()] ; Maps set of NFA nts to a DFA nt
|
|
[n*<=
|
|
(lambda (n1* n2*)
|
|
(andmap (lambda (n1) (mem-nt? n1 n2*)) n1*))]
|
|
[n*=
|
|
(lambda (n1* n2*)
|
|
(and (n*<= n1* n2*) (n*<= n2* n1*)))]
|
|
[lookup
|
|
(lambda (n*)
|
|
(recur loop ([l n*->d])
|
|
(cond
|
|
[(null? l) #f]
|
|
[(n*= n* (caar l)) (cdar l)]
|
|
[else (loop (cdr l))])))]
|
|
[AVS->nu-AVS ; Use same d for L-AVS and U-AVS
|
|
(let ([l '()])
|
|
(lambda (AVS)
|
|
(match (assq AVS l)
|
|
[(_ . nuAVS) nuAVS]
|
|
[#f (let ([nuAVS (mk-AVS-nolist 'dfa-nuAVS)])
|
|
(set! l (cons (cons AVS nuAVS) l))
|
|
nuAVS)])))]
|
|
[make-d-for-nt*
|
|
(match-lambda
|
|
[(($ L x)) (make-L (AVS->nu-AVS x))]
|
|
[(($ U x)) (make-U (AVS->nu-AVS x))]
|
|
[(($ L _) ...) (make-L (mk-AVS-nolist 'dfa-L))]
|
|
[(($ U _) ...) (make-U (mk-AVS-nolist 'dfa-U))])]
|
|
[count 0]
|
|
[traverse
|
|
(lambda (n*)
|
|
(when (zero? (modulo count 25)) (printf ".") (flush-output))
|
|
(set! count (add1 count))
|
|
(let* ([n* (epsilon-close-nts n*)]
|
|
[n*-noI (map drop-I n*)])
|
|
'(pretty-print `(traverse ,(map nt->sym n*)))
|
|
(or (lookup n*-noI)
|
|
;; Need to traverse
|
|
;; assume n* epsilon-closed
|
|
(let* ([d (make-d-for-nt* n*-noI)])
|
|
(set! n*->d (cons (cons n*-noI d) n*->d))
|
|
(for-each-prods-joined
|
|
(lambda (grsym nt**)
|
|
(if (and (not tidy?)
|
|
(not (null? nt**))
|
|
(not (null? (car nt**)))
|
|
(not (null? (cdar nt**))))
|
|
;; Don't want to tidy multi-arity constructor
|
|
(for-each
|
|
(lambda (nt*)
|
|
(add-prod d grsym
|
|
(map (lambda (nt) (traverse (list nt)))
|
|
nt*)))
|
|
nt**)
|
|
;; Yeah, tidy it
|
|
(recur loop ([nt** nt**][d* '()])
|
|
(match nt**
|
|
[(() ...)
|
|
;; All done - add the resulting production
|
|
(add-prod d grsym (reverse d*))]
|
|
[((nt* . nt**) ...)
|
|
;; nt* is all nts for a particular field
|
|
(loop nt** (cons (traverse nt*) d*))]))))
|
|
n*)
|
|
d))))])
|
|
|
|
(for-each (lambda (nt) (traverse (list nt)))
|
|
roots)
|
|
(newline)
|
|
|
|
'(begin
|
|
(printf "Table:~n")
|
|
(pretty-print
|
|
(map (match-lambda
|
|
[(n* . d) (cons (map nt->sym n*) (nt->sym d))])
|
|
n*->d)))
|
|
|
|
(printf "Calculating new roots, final~n")
|
|
;; Return new roots, and nu final
|
|
(list
|
|
;; new roots
|
|
(map (lambda (nt) (lookup (map drop-I (epsilon-close-nt nt))))
|
|
roots)
|
|
;; new final
|
|
(map (lambda (nt)
|
|
(let* ([nt-noI (drop-I nt)]
|
|
[nu-nt (make-d-for-nt* (list nt-noI))])
|
|
(for-each
|
|
(match-lambda
|
|
[(n* . d)
|
|
(when (mem-nt? nt-noI n*)
|
|
(add-prod d
|
|
(match d
|
|
[($ L) '>=epsilon]
|
|
[($ U) '<=epsilon])
|
|
(list nu-nt)))])
|
|
n*->d)
|
|
nu-nt))
|
|
final))))
|
|
|
|
;; ======================================================================
|
|
;; A series of composable grammar manipulation stages
|
|
;; Each takes and returns (roots final list-NT list-AVS . rest)
|
|
;; May just return (roots final)
|
|
|
|
(define (stage-restrict-reached roots final list-NT list-AVS)
|
|
(printf "Calculating reached~n")
|
|
(match-let*
|
|
([(reached-nt reached-nt?) (grammar-calc-reached roots)])
|
|
(printf "Restricting NTs~n")
|
|
(restrict-nts! list-AVS reached-nt?)
|
|
;;(display (map nt->sym reached-nt)) (newline)
|
|
;;(st:prods)
|
|
;;(newline)
|
|
(list roots final reached-nt list-AVS)))
|
|
|
|
(define (stage-restrict-nonempty roots final list-NT list-AVS)
|
|
(match-let*
|
|
([_ (printf "Calculating NT<->num~n")]
|
|
[(num-NT NT->num num->NT) (calc-NT<->num list-NT)]
|
|
[_ (printf "Calculating nonempty~n")]
|
|
[(nonempty-nt nonempty-nt?)
|
|
(grammar-calc-nonempty num-NT NT->num num->NT final)])
|
|
(printf "Restricting NTs~n")
|
|
(restrict-nts! list-AVS nonempty-nt?)
|
|
;;(display (map nt->sym nonempty-nt)) (newline)
|
|
;;(st:prods)
|
|
;;(newline)
|
|
(list roots final nonempty-nt list-AVS)))
|
|
|
|
(define (stage-N->D roots final list-NT list-AVS)
|
|
(match-let*
|
|
([(nuroots nufinal) (N->D roots final #t)])
|
|
(list nuroots nufinal)))
|
|
|
|
(define (stage-N->D-notidy roots final list-NT list-AVS)
|
|
(match-let*
|
|
([(nuroots nufinal) (N->D roots final #f)])
|
|
(list nuroots nufinal)))
|
|
|
|
(define (stage-DFA-min roots final list-NT list-AVS)
|
|
(match-let*
|
|
([old-nt->nu-nt (DFA-min list-NT roots final)])
|
|
(list (map old-nt->nu-nt roots)
|
|
(map old-nt->nu-nt final))))
|
|
|
|
(define (stage-NFA-min roots final list-NT list-AVS)
|
|
(match-let*
|
|
([old-nt->nu-nt (NFA-min list-NT roots final)])
|
|
(list (map old-nt->nu-nt roots)
|
|
(map old-nt->nu-nt final))))
|
|
|
|
(define (stage-RTG-min roots final list-NT list-AVS)
|
|
(match-let*
|
|
([old-nt->nu-nt (NFA-min list-NT roots final)])
|
|
(list (map old-nt->nu-nt roots)
|
|
(map old-nt->nu-nt final))))
|
|
|
|
(define (stage-kill-live-AVS roots final list-NT list-AVS)
|
|
(for-each
|
|
(lambda (AVS)
|
|
(set-AVS-edgefrom! AVS '())
|
|
(set-AVS-edgeto! AVS '())
|
|
(set-AVS-objs! AVS '())
|
|
(set-AVS-orig-objs! AVS '())
|
|
(set-AVS-constraints! AVS '()))
|
|
list-AVS)
|
|
(list roots final))
|
|
|
|
(define (stage-invert-grammar roots final list-NT list-AVS)
|
|
(convert-productions-to-AV-etc! list-AVS)
|
|
(calc-productions! list-AVS
|
|
(lambda (AVS) (memq AVS list-AVS))
|
|
#t
|
|
#t #t #t #t
|
|
#f #f)
|
|
(list (append (map make-LI list-AVS)
|
|
(map make-UI list-AVS))
|
|
(map make-UI (select-L roots))))
|
|
|
|
(define (stage-nothing roots final list-NT list-AVS)
|
|
(list roots final))
|
|
|
|
(define (calc-roots-final-L->R B list-AVS use-AVS?)
|
|
(calc-productions! list-AVS use-AVS?
|
|
#t #f
|
|
#t #t #t #t
|
|
#t #f)
|
|
(list (map make-L B)
|
|
(append (map make-UI B))))
|
|
|
|
(define (calc-roots-final-LU->center B list-AVS use-AVS?)
|
|
(calc-productions! list-AVS use-AVS?
|
|
#t
|
|
#t #t #t #t
|
|
#t #f)
|
|
(match-let*
|
|
([L-B (map make-L B)]
|
|
[(reached _) (grammar-calc-reached L-B)]
|
|
;[_ (pretty-print `(reached ,(map nt->sym reached)))]
|
|
[reached-L (select-L reached)]
|
|
;[_ (pretty-print `(reached-L ,(map name-for-AVS reached-L)))]
|
|
[reached-U (select-U reached)]
|
|
;[_ (pretty-print `(reached-U ,(map name-for-AVS reached-U)))]
|
|
[cross-over (intersect reached-L reached-U)]
|
|
[final (append (map make-L cross-over)
|
|
(map make-U cross-over))])
|
|
;(pretty-print `(cross-over ,(map name-for-AVS cross-over)))
|
|
;(pretty-print `(final ,(map nt->sym final)))
|
|
(list L-B final)))
|
|
|
|
(define (calc-roots-final-center->out B list-AVS use-AVS?)
|
|
(set! zeroary-op-AVS (mk-AVS-tmp 'zeroary-op))
|
|
(calc-productions! list-AVS use-AVS?
|
|
#t #t
|
|
#t #t #t #t
|
|
#f #f)
|
|
(match-let*
|
|
([L-B (map make-L B)]
|
|
[(reached _) (grammar-calc-reached L-B)]
|
|
;[_ (pretty-print `(reached ,(map nt->sym reached)))]
|
|
[reached-L (select-L reached)]
|
|
;[_ (pretty-print `(reached-L ,(map name-for-AVS reached-L)))]
|
|
[reached-U (select-U reached)]
|
|
;[_ (pretty-print `(reached-U ,(map name-for-AVS reached-U)))]
|
|
[cross-over (intersect reached-L reached-U)]
|
|
[roots (append (list (make-UI zeroary-op-AVS))
|
|
(map make-LI cross-over)
|
|
(map make-UI cross-over))]
|
|
[final (map make-UI B)])
|
|
;(pretty-print `(cross-over ,(map name-for-AVS cross-over)))
|
|
;(pretty-print `(roots ,(map nt->sym roots)))
|
|
;(pretty-print `(final ,(map nt->sym final)))
|
|
(list roots final)))
|
|
|
|
(define (calc-roots-final-center->out-concrete-epsilon B list-AVS use-AVS?)
|
|
(set! zeroary-op-AVS (mk-AVS-tmp 'zeroary-op))
|
|
(calc-productions! list-AVS use-AVS?
|
|
#t #t
|
|
#t #t 'concrete #t
|
|
#f #f)
|
|
(match-let*
|
|
([L-B (map make-L B)]
|
|
[(reached _) (grammar-calc-reached L-B)]
|
|
;[_ (pretty-print `(reached ,(map nt->sym reached)))]
|
|
[reached-L (select-L reached)]
|
|
;[_ (pretty-print `(reached-L ,(map name-for-AVS reached-L)))]
|
|
[reached-U (select-U reached)]
|
|
;[_ (pretty-print `(reached-U ,(map name-for-AVS reached-U)))]
|
|
[cross-over (intersect reached-L reached-U)]
|
|
[roots (append (list (make-UI zeroary-op-AVS))
|
|
(map make-LI cross-over)
|
|
(map make-UI cross-over))]
|
|
[final (map make-UI B)])
|
|
;(pretty-print `(cross-over ,(map name-for-AVS cross-over)))
|
|
;(pretty-print `(roots ,(map nt->sym roots)))
|
|
;(pretty-print `(final ,(map nt->sym final)))
|
|
(list roots final)))
|
|
|
|
|
|
(define (get-AVS-select-L roots final) (select-L roots))
|
|
|
|
(define (get-AVS-select-LIUI roots final)
|
|
(select-UI final))
|
|
|
|
; ----------------------------------------------------------------------
|
|
|
|
(define calc-size
|
|
(lambda (str roots)
|
|
(match-let*
|
|
([(reached-nt reached-nt?) (grammar-calc-reached roots)]
|
|
[reached-AVS (list->set (map nt->AVS reached-nt))])
|
|
(printf "==========> ~a: #nt=~s #AVS=~s~n"
|
|
str
|
|
(length reached-nt)
|
|
(length reached-AVS))
|
|
;;(printf "~s~n" (map name-for-AVS list-AVS))
|
|
(list reached-nt reached-AVS))))
|
|
|
|
; --------
|
|
|
|
(define resultshow (void))
|
|
(define resultprod (void))
|
|
|
|
(define (minimize-constraints list-AVS use-AVS? B strategy)
|
|
|
|
(printf "#### STRATEGY: ~s~n" strategy)
|
|
|
|
(match-let*
|
|
([((calc-roots-final get-AVS) . stages) strategy]
|
|
[(roots final) ((eval calc-roots-final) B list-AVS use-AVS?)])
|
|
|
|
(recur loop ([roots roots]
|
|
[final final]
|
|
[rest '()]
|
|
[stages stages]
|
|
[sizes '()])
|
|
|
|
(match stages
|
|
[()
|
|
(match-let*
|
|
([(list-NT list-AVS) (calc-size "At end" roots)])
|
|
(printf "Creating AV, constraints, edges from grammar~n")
|
|
(convert-productions-to-AV-etc! list-AVS)
|
|
(set! resultshow (lambda () (for-each show-AVS list-AVS)))
|
|
(set! resultprod (lambda () (for-each prods-AVS list-AVS)))
|
|
(list ((eval get-AVS) roots final)
|
|
(reverse (cons (list (length list-NT) (length list-AVS))
|
|
sizes))))]
|
|
|
|
[(stage . rest-stages)
|
|
(match-let*
|
|
([(list-NT list-AVS)
|
|
(calc-size (format "Before ~a" stage) roots)])
|
|
(match (apply (eval stage) roots final list-NT list-AVS rest)
|
|
[(roots final . _)
|
|
(loop roots final '() rest-stages
|
|
(cons (list (length list-NT) (length list-AVS))
|
|
sizes))]))]))))
|
|
|
|
(define (minimize-all-constraints B stages)
|
|
(let ([n num-AVS])
|
|
(minimize-constraints list-AVS
|
|
(lambda (AVS) (< (AVS-num AVS) n))
|
|
B stages)))
|
|
|
|
; ======================================================================
|
|
|
|
(define (st:L files)
|
|
(st:analyze files)
|
|
(calc-productions! list-AVS (lambda (AVS) #t)
|
|
#t
|
|
#t #t #t #t
|
|
#t #f))
|
|
|
|
(define (test-min-strategy files strategy)
|
|
(printf "TEST-MIN: ~s~n" files)
|
|
(st:flow-sensitive #f)
|
|
(st:if-split #f)
|
|
(match-let*
|
|
([(_ in out)
|
|
(parameterize
|
|
([mrspidey:progress-handler (mrspidey:text-progress)]
|
|
[mrspidey:error-handler mrspidey:text-error])
|
|
(time (sba-analyze-a-file-in-out (files->file-thunk* files))))]
|
|
[io (map cdr (append in out))])
|
|
(for-each display (reverse summary))
|
|
(printf "Orig # AVSs: ~s~n" num-AVS)
|
|
(for-each
|
|
(match-lambda
|
|
[(sym . AVS)
|
|
(printf "Def: ~s, AVS-num=~s~n" sym (AVS-num AVS))
|
|
(pretty-print (AVS->SDL AVS))])
|
|
out)
|
|
(match-let
|
|
([(nu-defs . sizes) (time (minimize-all-constraints io strategy))])
|
|
|
|
(printf "~n=========== Summary of final types =========~n")
|
|
(for-each (lambda (AVS)
|
|
(printf "AVS-num=~s~n" (AVS-num AVS))
|
|
(pretty-print (AVS->SDL AVS)))
|
|
nu-defs)
|
|
sizes)))
|
|
|
|
|
|
(define (test-min files) (test-min-strategy files default-strategy))
|
|
|
|
; ======================================================================
|
|
|
|
(define (to) (test-min "test/one.ss"))
|
|
(define (ts) (test-min "test/sum.ss"))
|
|
(define (tt) (test-min "test/test.ss"))
|
|
|
|
(define test-files
|
|
(map (lambda (s) (string-append "mod/" s ".ss"))
|
|
'(
|
|
"TC-env"
|
|
"TC-parse"
|
|
"TC-test"
|
|
"TC-type"
|
|
"TC-eval"
|
|
|
|
"mod-env"
|
|
"2-1-env-list"
|
|
"2-22-p"
|
|
"2-22-tc2"
|
|
"mod-TC-typechk"
|
|
"shaft"
|
|
"physics"
|
|
"mod-gauss"
|
|
;;"mod-TC-parse"
|
|
;;"pcf-parse"
|
|
)))
|
|
|
|
; mod-interp - match
|
|
; pcf-tc.ss - syntax error
|
|
; mod-pp - match
|
|
; "elevator" - match
|
|
; mod-slatex.ss - too big
|
|
; mod-TC.ss - too big
|
|
|
|
; ======================================================================
|
|
|
|
(define strategy-L->R-NFA-min
|
|
'((calc-roots-final-L->R get-AVS-select-L)
|
|
stage-restrict-reached
|
|
stage-restrict-nonempty
|
|
;;stage-kill-live-AVS
|
|
stage-N->D-notidy
|
|
stage-NFA-min))
|
|
|
|
(define strategy-L->R-RTG-min
|
|
'((calc-roots-final-L->R get-AVS-select-L)
|
|
stage-restrict-reached
|
|
stage-restrict-nonempty
|
|
;;stage-kill-live-AVS
|
|
;;stage-N->D
|
|
stage-RTG-min))
|
|
|
|
(define strategy-fast
|
|
'((calc-roots-final-center->out-concrete-epsilon get-AVS-select-LIUI)
|
|
stage-restrict-reached
|
|
stage-restrict-nonempty
|
|
;;stage-kill-live-AVS
|
|
;stage-N->D-notidy
|
|
;stage-RTG-min
|
|
stage-DFA-min
|
|
))
|
|
|
|
(define default-strategy
|
|
'((calc-roots-final-L->R get-AVS-select-L)
|
|
;;stage-restrict-reached
|
|
;;stage-restrict-nonempty
|
|
;;stage-kill-live-AVS
|
|
;;stage-N->D
|
|
;;stage-RTG-min
|
|
))
|
|
;(define default-strategy strategy-fast)
|
|
|
|
(define strategy-options
|
|
'(((calc-roots-final-L->R get-AVS-select-L)
|
|
(calc-roots-final-center->out get-AVS-select-LIUI)
|
|
)
|
|
stage-restrict-reached
|
|
stage-restrict-nonempty
|
|
(stage-N->D stage-N->D-notidy stage-nothing)
|
|
(stage-RTG-min stage-NFA-min stage-DFA-min stage-nothing)
|
|
))
|
|
|
|
(define strategy-options
|
|
'(((calc-roots-final-center->out-concrete-epsilon get-AVS-select-LIUI)
|
|
(calc-roots-final-L->R get-AVS-select-L)
|
|
(calc-roots-final-center->out get-AVS-select-LIUI)
|
|
)
|
|
stage-restrict-reached
|
|
stage-restrict-nonempty
|
|
(stage-DFA-min stage-RTG-min stage-NFA-min stage-nothing)
|
|
))
|
|
|
|
(define test-strategies
|
|
(recur loop ([opt strategy-options])
|
|
(match opt
|
|
[() '(())]
|
|
[((? pair? opt1) . rest)
|
|
(let ([rest (loop rest)])
|
|
(apply append
|
|
(map (lambda (r)
|
|
(map (lambda (o) (cons o r)) opt1))
|
|
rest)))]
|
|
[(x . rest) (map (lambda (r) (cons x r))
|
|
(loop rest))])))
|
|
|
|
; ======================================================================
|
|
|
|
(define (test-min-files)
|
|
(mapLR
|
|
(lambda (file)
|
|
(printf "============================================================~n")
|
|
(let ([r (test-min file)])
|
|
(pretty-print r)
|
|
r))
|
|
test-files))
|
|
|
|
(define (test-min-strategies)
|
|
(map (lambda (s)
|
|
(printf "#########################################################~n")
|
|
(set! default-strategy s)
|
|
(list s (test-min-files)))
|
|
test-strategies))
|
|
|
|
;(trace NFA-min)
|
|
;(trace calc-LI-UI!)
|
|
;(trace make-minimization-algorithm)
|
|
;(trace minimize-constraints)
|
|
;(trace grammar-calc-nonempty)
|
|
|
|
(define (summarize l)
|
|
(map
|
|
(match-lambda
|
|
[(desc nums)
|
|
(let ([last-pairs (map (lambda (x) (rac (car x))) nums)])
|
|
(list desc
|
|
(apply + (map car last-pairs))
|
|
(apply + (map cadr last-pairs))))])
|
|
l))
|