summaryrefslogtreecommitdiff
path: root/src/guile/silex/sweep.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/guile/silex/sweep.scm')
-rw-r--r--src/guile/silex/sweep.scm128
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))))