diff options
Diffstat (limited to 'src/guile/silex/sweep.scm')
| -rw-r--r-- | src/guile/silex/sweep.scm | 128 |
1 files changed, 128 insertions, 0 deletions
diff --git a/src/guile/silex/sweep.scm b/src/guile/silex/sweep.scm new file mode 100644 index 0000000..c8177f2 --- /dev/null +++ b/src/guile/silex/sweep.scm @@ -0,0 +1,128 @@ +; SILex - Scheme Implementation of Lex +; Copyright (C) 2001 Danny Dube' +; +; 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-1307, USA. + +; Preparer les arcs pour digraph +(define sweep-mkarcs + (lambda (trans-v) + (let* ((nbnodes (vector-length trans-v)) + (arcs-v (make-vector nbnodes '()))) + (let loop1 ((n 0)) + (if (< n nbnodes) + (let loop2 ((trans (vector-ref trans-v n)) (arcs '())) + (if (null? trans) + (begin + (vector-set! arcs-v n arcs) + (loop1 (+ n 1))) + (loop2 (cdr trans) (noeps-merge-1 (cdar trans) arcs)))) + arcs-v))))) + +; Preparer l'operateur pour digraph +(define sweep-op + (let ((acc-min (lambda (rule1 rule2) + (cond ((not rule1) + rule2) + ((not rule2) + rule1) + (else + (min rule1 rule2)))))) + (lambda (acc1 acc2) + (cons (acc-min (car acc1) (car acc2)) + (acc-min (cdr acc1) (cdr acc2)))))) + +; Renumerotation des etats (#f pour etat a eliminer) +; Retourne (new-nbnodes . dict) +(define sweep-renum + (lambda (dist-acc-v) + (let* ((nbnodes (vector-length dist-acc-v)) + (dict (make-vector nbnodes))) + (let loop ((n 0) (new-n 0)) + (if (< n nbnodes) + (let* ((acc (vector-ref dist-acc-v n)) + (dead? (equal? acc '(#f . #f)))) + (if dead? + (begin + (vector-set! dict n #f) + (loop (+ n 1) new-n)) + (begin + (vector-set! dict n new-n) + (loop (+ n 1) (+ new-n 1))))) + (cons new-n dict)))))) + +; Elimination des etats inutiles d'une liste d'etats +(define sweep-list + (lambda (ss dict) + (if (null? ss) + '() + (let* ((olds (car ss)) + (news (vector-ref dict olds))) + (if news + (cons news (sweep-list (cdr ss) dict)) + (sweep-list (cdr ss) dict)))))) + +; Elimination des etats inutiles d'une liste d'arcs +(define sweep-arcs + (lambda (arcs dict) + (if (null? arcs) + '() + (let* ((arc (car arcs)) + (class (car arc)) + (ss (cdr arc)) + (new-ss (sweep-list ss dict))) + (if (null? new-ss) + (sweep-arcs (cdr arcs) dict) + (cons (cons class new-ss) (sweep-arcs (cdr arcs) dict))))))) + +; Elimination des etats inutiles dans toutes les transitions +(define sweep-all-arcs + (lambda (arcs-v dict) + (let loop ((n (- (vector-length arcs-v) 1))) + (if (>= n 0) + (begin + (vector-set! arcs-v n (sweep-arcs (vector-ref arcs-v n) dict)) + (loop (- n 1))) + arcs-v)))) + +; Elimination des etats inutiles dans un vecteur +(define sweep-states + (lambda (v new-nbnodes dict) + (let ((nbnodes (vector-length v)) + (new-v (make-vector new-nbnodes))) + (let loop ((n 0)) + (if (< n nbnodes) + (let ((new-n (vector-ref dict n))) + (if new-n + (vector-set! new-v new-n (vector-ref v n))) + (loop (+ n 1))) + new-v))))) + +; Elimination des etats inutiles +(define sweep + (lambda (nl-start no-nl-start arcs-v acc-v) + (let* ((digraph-arcs (sweep-mkarcs arcs-v)) + (digraph-init acc-v) + (digraph-op sweep-op) + (dist-acc-v (digraph digraph-arcs digraph-init digraph-op)) + (result (sweep-renum dist-acc-v)) + (new-nbnodes (car result)) + (dict (cdr result)) + (new-nl-start (sweep-list nl-start dict)) + (new-no-nl-start (sweep-list no-nl-start dict)) + (new-arcs-v (sweep-states (sweep-all-arcs arcs-v dict) + new-nbnodes + dict)) + (new-acc-v (sweep-states acc-v new-nbnodes dict))) + (list new-nl-start new-no-nl-start new-arcs-v new-acc-v)))) |