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.
323 lines
11 KiB
Scheme
323 lines
11 KiB
Scheme
27 years ago
|
;; gram.ss
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
|
||
|
|
(define debugging-gram #f)
|
||
|
|
(defmacro pretty-debug-gram args `(when debugging-gram (pretty-print ,@args)))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; VIEWING CONSTRAINTS AS GRAMMARS
|
||
|
|
; ======================================================================
|
||
|
|
; Non-Terminals
|
||
|
|
|
||
|
|
(define-structure (NT AVS type)
|
||
|
|
([rhs* '()][prop #f][tag #f][sources #f][num #f][edgefrom '()]))
|
||
|
|
|
||
|
|
(define mk-AVS-NTs!
|
||
|
|
(lambda (AVS)
|
||
|
|
(set-AVS-L! AVS (make-NT AVS 'L ))
|
||
|
|
(set-AVS-U! AVS (make-NT AVS 'U ))
|
||
|
|
(set-AVS-LI! AVS (make-NT AVS 'LI))
|
||
|
|
(set-AVS-UI! AVS (make-NT AVS 'UI))))
|
||
|
|
|
||
|
|
(define same-nt-type?
|
||
|
|
(match-lambda*
|
||
|
|
[(($ NT _ t1) ($ NT _ t2)) (eq? t1 t2)]))
|
||
|
|
|
||
|
|
(define nt-chg-AVS
|
||
|
|
(match-lambda*
|
||
|
|
[(f ($ NT x type)) (make-NT (f x) type)]))
|
||
|
|
|
||
|
|
(define drop-I
|
||
|
|
(match-lambda
|
||
|
|
[(and nt ($ NT AVS type _))
|
||
|
|
(case type
|
||
|
|
[(or 'L 'U) nt]
|
||
|
|
[LI (AVS-L AVS)]
|
||
|
|
[UI (AVS-U AVS)])]))
|
||
|
|
|
||
|
|
(define invert-nt
|
||
|
|
(match-lambda
|
||
|
|
[($ NT AVS 'L) (AVS-UI AVS)]
|
||
|
|
[($ NT AVS 'LI) (AVS-U AVS)]
|
||
|
|
[($ NT AVS 'U) (AVS-LI AVS)]
|
||
|
|
[($ NT AVS 'UI) (AVS-L AVS)]))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; Right hand side of a production
|
||
|
|
|
||
|
|
(define-structure (rhs* grsym misc 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))
|
||
|
|
|
||
|
|
;;(define (make-grsym-filter filter) (make-grsym '<= 'filter #t filter #f))
|
||
|
|
(define (make-grsym-filter filter) (make-grsym '>= 'filter #t filter #f))
|
||
|
|
(define grsym-crossover '>=crossover)
|
||
|
|
|
||
|
|
;; 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)]))
|
||
|
|
|
||
|
|
(define invert-grsym
|
||
|
|
(match-lambda
|
||
|
|
[($ grsym '>= 'inj sign template field-no)
|
||
|
|
(make-grsym '<= 'ext sign template field-no)]
|
||
|
|
[($ grsym '<= 'inj-tst sign template field-no)
|
||
|
|
(make-grsym '>= 'ext sign template field-no)]
|
||
|
|
[($ grsym '>= 'filter #t filter #f)
|
||
|
|
(make-grsym '<= 'unfilter #t filter #f)]
|
||
|
|
['>=crossover '<=crossover]
|
||
|
|
[(and g ($ grsym))
|
||
|
|
(error 'invert-grsym "Bad grsym ~s" (grsym->rep g))]))
|
||
|
|
|
||
|
|
(define grsym-epsilon-or-filter?
|
||
|
|
(match-lambda
|
||
|
|
[(? symbol?) #t]
|
||
|
|
[($ grsym _ 'filter) #t]
|
||
|
|
[_ #f]))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
; Parameters for creating grammar
|
||
|
|
|
||
|
|
(define-structure
|
||
|
|
(parameters-grammar
|
||
|
|
interp-sign ; applied to sign of each field
|
||
|
|
prims ; #t => treat prims as constants
|
||
|
|
filters ; #t => filters are not epsilon edges
|
||
|
|
assignable-fields ; #t => assignable fields in grammar
|
||
|
|
structure-opaque ; #t => structures are constants
|
||
|
|
))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
;; Prepare for creating grammar
|
||
|
|
|
||
|
|
(define (prep-gram!)
|
||
|
|
(for-each mk-AVS-NTs! list-AVS))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
;; Initializing the NT fields of an AVS
|
||
|
|
|
||
|
|
(define (add-rhs! NT rhs)
|
||
|
|
(pretty-debug-gram
|
||
|
|
(match rhs
|
||
|
|
[($ rhs* grsym _ nts)
|
||
|
|
(assert (list? nts))
|
||
|
|
(list `(add-rhs! ,(nt->sym NT) ,(grsym->rep grsym)
|
||
|
|
,(map nt->sym nts)))]))
|
||
|
|
(set-NT-rhs*! NT (cons rhs (NT-rhs* NT))))
|
||
|
|
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (for-each-calc-prods-L L paras fn)
|
||
|
|
(match L
|
||
|
|
[($ NT AVS 'L)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ AV _ (and template ($ template _ signs _ _ _ _ structure?))
|
||
|
|
misc fields)
|
||
|
|
(if (or (zero? (vector-length fields))
|
||
|
|
(and structure?
|
||
|
|
(parameters-grammar-structure-opaque paras)))
|
||
|
|
(fn (make-rhs* (make-grsym '>= 'inj #t template '?) misc '()))
|
||
|
|
(for i 0 (vector-length fields)
|
||
|
|
(let ([field (vector-ref fields i)]
|
||
|
|
[interp-sign (parameters-grammar-interp-sign paras)]
|
||
|
|
[sign (interp-sign (vector-ref signs i))])
|
||
|
|
(fn (make-rhs*
|
||
|
|
(make-grsym '>= 'inj (eq? sign '>=inj+) template i)
|
||
|
|
misc
|
||
|
|
(case sign
|
||
|
|
[>=inj+ (list (AVS-L field))]
|
||
|
|
[>=inj-
|
||
|
|
(if (or #f ;; mk-assignable-part-fields?
|
||
|
|
(eq? template template-lam))
|
||
|
|
(map AVS-U (AVS-transitive-edgeto field))
|
||
|
|
'())]))))))])
|
||
|
|
(get-AVS-objs AVS))]))
|
||
|
|
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (for-each-calc-prods-U U paras fn)
|
||
|
|
(match U
|
||
|
|
[($ NT AVS 'U)
|
||
|
|
(let ([interp-sign (parameters-grammar-interp-sign paras)])
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ (and template ($ template type signs)) field-no AVS2 misc)
|
||
|
|
(case (interpret-sign (vector-ref signs field-no))
|
||
|
|
[>=inj+
|
||
|
|
(fn (make-rhs*
|
||
|
|
(make-grsym-<=inj-tst+ template field-no)
|
||
|
|
misc
|
||
|
|
(list (AVS-U AVS2))))]
|
||
|
|
[>=inj-
|
||
|
|
(fn (make-rhs*
|
||
|
|
(make-grsym-<=inj-tst- template field-no)
|
||
|
|
misc
|
||
|
|
(list (AVS-U AVS2))))])]
|
||
|
|
[($ con-filter _ the-filter AVS2)
|
||
|
|
(fn (make-rhs*
|
||
|
|
(make-grsym-filter the-filter)
|
||
|
|
'()
|
||
|
|
(list (AVS-U AVS2))))])
|
||
|
|
(AVS-constraints AVS)))
|
||
|
|
(for-each
|
||
|
|
(lambda (AVS2) (fn (make-rhs* '<=epsilon '() (list (AVS-U AVS2)))))
|
||
|
|
(AVS-transitive-edgeto AVS))]))
|
||
|
|
|
||
|
|
; ----------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define (for-each-calc-prods nt paras fn)
|
||
|
|
(match nt
|
||
|
|
[($ NT AVS 'L) (for-each-calc-prods-L nt paras fn)]
|
||
|
|
[($ NT AVS 'U) (for-each-calc-prods-U nt paras fn)]))
|
||
|
|
|
||
|
|
; ======================================================================
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
(define (calc-productions!
|
||
|
|
live-nts live-nt?
|
||
|
|
mk-L? mk-U? mk-LI? mk-UI?
|
||
|
|
L->LI
|
||
|
|
mk-assignable-part-fields?
|
||
|
|
treat-all-mono)
|
||
|
|
|
||
|
|
;; live-AVS, crossover-AVS, live-nt and live-nt?
|
||
|
|
;; all come from calc-live-AVS-nt
|
||
|
|
;; mk-... : bool -- controls which NTs to produce
|
||
|
|
;; L->LI, ... : bool -- controls L->LI production rule
|
||
|
|
|
||
|
|
(let ([interpret-sign
|
||
|
|
(if treat-all-mono
|
||
|
|
(lambda (x) '>=inj+)
|
||
|
|
(lambda (x) x))])
|
||
|
|
|
||
|
|
(for-each (lambda (nt) (set-NT-rhs*! nt '()))
|
||
|
|
live-nts)
|
||
|
|
|
||
|
|
;; ------ Now fill NTs from AV, constraints and edges
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (AVS)
|
||
|
|
(pretty-debug-gram `(Prods for AVS ,(name-for-AVS AVS)))
|
||
|
|
|
||
|
|
;; ------ Invert AV
|
||
|
|
(when (and mk-L? (live-nt? (AVS-L AVS)))
|
||
|
|
(AVs->prods AVS interpret-sign live-nt?))
|
||
|
|
|
||
|
|
;; ------ Invert constraints
|
||
|
|
(when (and mk-U? (live-nt? (AVS-U AVS)))
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ con _ (and template ($ template type signs)) field-no AVS2 misc)
|
||
|
|
(case (interpret-sign (vector-ref signs field-no))
|
||
|
|
[>=inj+
|
||
|
|
(add-rhs! (AVS-U AVS)
|
||
|
|
(make-rhs*
|
||
|
|
(make-grsym-<=inj-tst+ template field-no)
|
||
|
|
misc
|
||
|
|
(filter live-nt?
|
||
|
|
(map AVS-U (AVS-transitive-edgeto AVS2)))))]
|
||
|
|
[>=inj-
|
||
|
|
(add-rhs! (AVS-U AVS)
|
||
|
|
(make-rhs*
|
||
|
|
(make-grsym-<=inj-tst- template field-no)
|
||
|
|
misc
|
||
|
|
(filter live-nt? (list (AVS-L AVS2)))))])]
|
||
|
|
[($ con-filter _ the-filter AVS2)
|
||
|
|
(add-rhs! (AVS-U AVS)
|
||
|
|
(make-rhs*
|
||
|
|
(make-grsym-filter the-filter)
|
||
|
|
'()
|
||
|
|
(filter live-nt?
|
||
|
|
(map AVS-U (AVS-transitive-edgeto AVS2)))))
|
||
|
|
'(for-each
|
||
|
|
(lambda (to)
|
||
|
|
(when (live-nt? (AVS-L to))
|
||
|
|
(add-rhs! (AVS-L to)
|
||
|
|
(make-rhs*
|
||
|
|
(make-grsym-filter the-filter)
|
||
|
|
'()
|
||
|
|
(list (AVS-L AVS))))))
|
||
|
|
(AVS-transitive-edgeto AVS2))
|
||
|
|
])
|
||
|
|
(AVS-constraints AVS)))
|
||
|
|
)
|
||
|
|
live-AVS)
|
||
|
|
|
||
|
|
;; ------ Add L->LI productions
|
||
|
|
(when L->LI
|
||
|
|
(for-each
|
||
|
|
(lambda (AVS)
|
||
|
|
(for-each
|
||
|
|
(lambda (to)
|
||
|
|
(when (and (NT? (AVS-L to)) (live-nt? (AVS-L to)))
|
||
|
|
(add-rhs! (AVS-L to)
|
||
|
|
(make-rhs* grsym-crossover '() (list (AVS-LI AVS))))))
|
||
|
|
(AVS-transitive-edgeto AVS)))
|
||
|
|
crossover-AVS))
|
||
|
|
|
||
|
|
;; ------ convert L, U productions into LI, UI productions
|
||
|
|
(pretty-debug '(inverting productions))
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (nt)
|
||
|
|
(for-each
|
||
|
|
(match-lambda
|
||
|
|
[($ rhs* grsym misc to-nts)
|
||
|
|
(unless (eq? grsym '<=crossover)
|
||
|
|
(let* ([inv-grsym (invert-grsym grsym)]
|
||
|
|
[inv-nt (invert-nt nt)]
|
||
|
|
[inv-rhs (make-rhs* inv-grsym misc (list inv-nt))])
|
||
|
|
(for-each (lambda (to) (add-rhs! (invert-nt to) inv-rhs))
|
||
|
|
to-nts)))])
|
||
|
|
(NT-rhs* nt)))
|
||
|
|
live-nts)
|
||
|
|
|
||
|
|
(let ([live-nts
|
||
|
|
(apply append
|
||
|
|
(map
|
||
|
|
(match-lambda
|
||
|
|
[($ NT AVS 'L) (list (AVS-L AVS) (AVS-UI AVS))]
|
||
|
|
[($ NT AVS 'U) (list (AVS-U AVS) (AVS-LI AVS))])
|
||
|
|
live-nts))])
|
||
|
|
|
||
|
|
;; Now group together all productions for given NT with given grsym
|
||
|
|
(for-each
|
||
|
|
(lambda (nt)
|
||
|
|
(let ([rhs* (NT-rhs* nt)])
|
||
|
|
(set-NT-rhs*! nt '())
|
||
|
|
(for-each (lambda (rhs)
|
||
|
|
(assert (list? (rhs*-nts rhs)))
|
||
|
|
(add-rhs! nt rhs))
|
||
|
|
(group-rhs* rhs*))))
|
||
|
|
live-nts)
|
||
|
|
|
||
|
|
(list live-nts))))
|