;;;
;;; automaton.scm: automaton generation functions
;;;
;;;
;;; Copyright (C) 2001 Samuel Hocevar
;;; $Id: automaton.scm,v 1.3 2001/11/27 18:24:57 sam Exp $
;;;
;;; Authors: Samuel Hocevar <sam@zoy.org>
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; 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, USA.
;;;
;;; automaton:
;;; (cells transitions end_cells start_cells)
;;; extended determinized automaton:
;;; (cells transitions index end_cells start_cells)
;;;
(define make-nondeterministic-automaton (lambda (g)
(merge-info-from-lexems
'(("start" "end")
(("start" #\space "end")
("start" #\newline "end")
("start" #\tab "end"))
("end")
("start"))
(get-grammar-lexems g))))
(define print-automaton-info (lambda (a)
(display "Automaton information\n")
(display "---------------------\n")
(display "Stats: ")
(display (length (car a))) (display " states, ")
(display (length (cadr a))) (display " transitions, ")
(display (length (caddr a))) (display " end cells\n")))
;;;
;;; Determinization
;;;
(define determinize-automaton (lambda (nda)
(let* ((mc (metacell-extension (cadddr nda) nda))
(xda (determinize-automaton/in
mc
`(() () 0 () (,mc))
(get-automaton-alphabet nda)
nda)))
(replace-cells-with-indices
(cons (car xda) (cons (cadr xda) (cdddr xda)))))))
(define determinize-automaton/in (lambda (mc xda alphorig nda)
(determinize-automaton/in/2
mc
(insert-cell-in-automaton mc xda nda)
alphorig
alphorig
nda)))
(define determinize-automaton/in/2 (lambda (mc xda alph alphorig nda)
(if (null? alph)
xda
(let ((newmc (metacell-extension (metacell-target mc (car alph) nda) nda)))
(determinize-automaton/in/2
mc
(if (null? newmc)
xda
(if (member newmc (car xda))
(insert-transition-in-automaton mc (car alph) newmc xda)
(determinize-automaton/in
newmc
(insert-transition-in-automaton mc (car alph) newmc xda)
alphorig
nda)))
(cdr alph)
alphorig
nda)))))
; determinized automaton update procedures
(define insert-cell-in-automaton (lambda (mc xda nda)
(cons (append (car xda) (list mc)) ; append to cell list
(cons (cadr xda)
(cons (1+ (caddr xda)) ; we increment the cell index
(if (final-metacell? mc nda)
(cons (cons (caddr xda) (cadddr xda)) ; insert *index* in final cells
(cddddr xda))
(cdddr xda)))))))
(define insert-transition-in-automaton (lambda (mc1 ch mc2 xda)
(cons (car xda)
(cons (insert-transition-in-list/in mc1 ch mc2 (cadr xda))
(cddr xda)))))
(define insert-transition-in-list/in (lambda (mc1 ch mc2 tl)
(if (null? tl)
(list (list mc1 (list ch) mc2))
(if (equal? mc1 (caar tl))
(if (equal? mc2 (caddar tl))
(cons (list mc1 (insert ch (cadar tl)) mc2) (cdr tl))
(cons (car tl) (insert-transition-in-list/in mc1 ch mc2 (cdr tl))))
(cons (car tl) (insert-transition-in-list/in mc1 ch mc2 (cdr tl)))))))
; does the metacell contain a final state?
(define final-metacell? (lambda (mc nda)
(final-metacell?/in mc (caddr nda))))
(define final-metacell?/in (lambda (mc finals)
(and (not (null? mc))
(or (member (car mc) finals)
(final-metacell?/in (cdr mc) finals)))))
; destination of a cell of the determinized automaton
(define metacell-target (lambda (mc l nda)
(metacell-target/in mc l () (cadr nda))))
(define metacell-target/in (lambda (mc l tar lt)
(if (null? lt)
tar
(if (and (equal? l (cadar lt))
(member (caar lt) mc)
(not (member (caddar lt) tar)))
(metacell-target/in mc l (sorted-insert (caddar lt) tar) (cdr lt))
(metacell-target/in mc l tar (cdr lt))))))
; extension of a cell of the determinized automaton
(define metacell-extension (lambda (mc nda)
(metacell-extension/in mc mc (cadr nda))))
(define metacell-extension/in (lambda (mc mcorig lt)
(if (null? mc)
()
(sorted-merge (cell-extension/in (car mc) mcorig lt lt)
(metacell-extension/in (cdr mc) mcorig lt)))))
; extension of a cell of the non-deterministic automaton
(define cell-extension (lambda (c nda)
(cell-extension/in c (list c) (cadr nda) (cadr nda))))
(define cell-extension/in (lambda (c ext lt ltorig)
(if (null? lt)
ext
(if (and (null? (cadar lt))
(equal? c (caar lt))
(not (member (caddar lt) ext)))
(cell-extension/in
c
(cell-extension/in (caddar lt) (sorted-insert (caddar lt) ext) ltorig ltorig)
(cdr lt)
ltorig)
(cell-extension/in c ext (cdr lt) ltorig)))))
;;;
;;; make the automaton simpler by merging rules
;;;
(define simplify-automaton (lambda (a)
(simplify-automaton/in () a)))
(define simplify-automaton/in (lambda (new old)
(if (null? (car old))
new
; we add (caar old)th cell
(simplify-automaton/in
(cons
(cons
(caar old)
(cons
(if (member (caar old) (caddr old)) #t #f)
(get-all-corresponding-rules (caar old) (cadr old))))
new)
(cons (cdar old) (cdr old))))))
(define get-all-corresponding-rules (lambda (i lr)
(if (null? lr)
()
(if (= i (caar lr))
(cons (cdar lr) (get-all-corresponding-rules i (cdr lr)))
(get-all-corresponding-rules i (cdr lr))))))
;;;
;;; make the automaton nicer
;;;
(define replace-cells-with-indices (lambda (da)
(replace-cells-with-indices/in 0 da)))
(define replace-cells-with-indices/in (lambda (i da)
(if (null? (car da))
(cons () (cons (cadr da) (list (caddr da) (list 0))))
(let ((newda (replace-cells-with-indices/in
(1+ i)
(cons (cdar da) (cdr da)))))
(cons (cons i (car newda))
(cons (replace-cells-in-all-transitions (caar da) i (cadr newda))
(cddr newda)))))))
(define replace-cells-in-all-transitions (lambda (mc i tl)
(if (null? tl)
()
(cons
(replace-cell-in-transition mc i (car tl))
(replace-cells-in-all-transitions mc i (cdr tl))))))
(define replace-cell-in-transition (lambda (mc i t)
(cons
(if (equal? mc (car t))
i
(car t))
(cons (cadr t)
(list
(if (equal? mc (caddr t))
i
(caddr t)))))))
;;;
;;; Alphabet stuff
;;;
(define get-automaton-alphabet (lambda (nda)
(get-automaton-alphabet/in (cadr nda))))
(define get-automaton-alphabet/in (lambda (lt)
(if (null? lt)
()
(let ((letter (cadar lt)))
(if (null? letter)
(get-automaton-alphabet/in (cdr lt))
(insert letter (get-automaton-alphabet/in (cdr lt))))))))
;;;
;;; merge-info-from-lexems: add data to the automaton from the lexem list
;;;
(define merge-info-from-lexems (lambda (nda ll)
(if (null? ll)
nda
(merge-info-from-lexems (insert-lexem nda (car ll)) (cdr ll)))))
(define insert-lexem (lambda (nda l)
(let ((newnda (insert-lexem/in nda l l (make-lexcell l l))))
(cons (car newnda)
(cons (cons (list "start" () (make-lexcell l "")) (cadr newnda))
(cddr newnda))))))
(define insert-lexem/in (lambda (nda lorig l lexcell)
(if (= (string-length l) 0)
(cons (cons lexcell (car nda))
(cons (cadr nda)
(cons (cons (make-lexcell lorig lorig) (caddr nda))
(cdddr nda))))
(let* ((len-1 (1- (string-length l)))
(lnext (substring l 0 len-1))
(lexcellnext (make-lexcell lorig lnext)))
(insert-lexem/in
(cons (cons lexcell (car nda))
(cons (cons (list lexcellnext (string-ref l len-1) lexcell)
(cadr nda))
(cddr nda)))
lorig
lnext
lexcellnext)))))
(define make-lexcell (lambda (lorig l) (string-append "l-" lorig "/" l)))
;;;
;;; Ensemblist stuff
;;;
(define insert (lambda (x l) (if (member x l) l (cons x l))))
(define sorted-insert (lambda (x l)
(if (member x l)
l
(sorted-insert/in x l))))
(define sorted-insert/in (lambda (x l)
(if (null? l)
(list x)
(if (string<? x (car l))
(cons x l)
(cons (car l) (sorted-insert/in x (cdr l)))))))
(define sorted-merge (lambda (l1 l2)
(if (null? l1)
l2
(if (null? l2)
l1
(if (string<? (car l1) (car l2))
(cons (car l1) (sorted-merge (cdr l1) l2))
(cons (car l2) (sorted-merge l1 (cdr l2))))))))