From 7efd05778cddec0293e0d48199f3aeee2aad6178 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès
Date: Fri, 18 Jan 2008 12:36:59 +0100
Subject: Add SILex, for simplicity.

---
 src/guile/silex/sweep.scm | 128 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 128 insertions(+)
 create mode 100644 src/guile/silex/sweep.scm

(limited to 'src/guile/silex/sweep.scm')

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))))
-- 
cgit v1.2.3