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/nfa2dfa.scm | 768 ++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 768 insertions(+)
 create mode 100644 src/guile/silex/nfa2dfa.scm

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

diff --git a/src/guile/silex/nfa2dfa.scm b/src/guile/silex/nfa2dfa.scm
new file mode 100644
index 0000000..185337b
--- /dev/null
+++ b/src/guile/silex/nfa2dfa.scm
@@ -0,0 +1,768 @@
+; 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.
+
+; Recoupement de deux arcs
+(define n2d-2arcs
+  (lambda (arc1 arc2)
+    (let* ((class1 (car arc1))
+	   (ss1 (cdr arc1))
+	   (class2 (car arc2))
+	   (ss2 (cdr arc2))
+	   (result (class-sep class1 class2))
+	   (classl (vector-ref result 0))
+	   (classc (vector-ref result 1))
+	   (classr (vector-ref result 2))
+	   (ssl ss1)
+	   (ssc (ss-union ss1 ss2))
+	   (ssr ss2))
+      (vector (if (or (null? classl) (null? ssl)) #f (cons classl ssl))
+	      (if (or (null? classc) (null? ssc)) #f (cons classc ssc))
+	      (if (or (null? classr) (null? ssr)) #f (cons classr ssr))))))
+
+; Insertion d'un arc dans une liste d'arcs a classes distinctes
+(define n2d-insert-arc
+  (lambda (new-arc arcs)
+    (if (null? arcs)
+	(list new-arc)
+	(let* ((arc (car arcs))
+	       (others (cdr arcs))
+	       (result (n2d-2arcs new-arc arc))
+	       (arcl (vector-ref result 0))
+	       (arcc (vector-ref result 1))
+	       (arcr (vector-ref result 2))
+	       (list-arcc (if arcc (list arcc) '()))
+	       (list-arcr (if arcr (list arcr) '())))
+	  (if arcl
+	      (append list-arcc list-arcr (n2d-insert-arc arcl others))
+	      (append list-arcc list-arcr others))))))
+
+; Regroupement des arcs qui aboutissent au meme sous-ensemble d'etats
+(define n2d-factorize-arcs
+  (lambda (arcs)
+    (if (null? arcs)
+	'()
+	(let* ((arc (car arcs))
+	       (arc-ss (cdr arc))
+	       (others-no-fact (cdr arcs))
+	       (others (n2d-factorize-arcs others-no-fact)))
+	  (let loop ((o others))
+	    (if (null? o)
+		(list arc)
+		(let* ((o1 (car o))
+		       (o1-ss (cdr o1)))
+		  (if (equal? o1-ss arc-ss)
+		      (let* ((arc-class (car arc))
+			     (o1-class (car o1))
+			     (new-class (class-union arc-class o1-class))
+			     (new-arc (cons new-class arc-ss)))
+			(cons new-arc (cdr o)))
+		      (cons o1 (loop (cdr o)))))))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes distinctes
+(define n2d-distinguish-arcs
+  (lambda (arcs)
+    (let loop ((arcs arcs) (n-arcs '()))
+      (if (null? arcs)
+	  n-arcs
+	  (loop (cdr arcs) (n2d-insert-arc (car arcs) n-arcs))))))
+
+; Transformer une liste d'arcs quelconques en des arcs a classes et a
+; destinations distinctes
+(define n2d-normalize-arcs
+  (lambda (arcs)
+    (n2d-factorize-arcs (n2d-distinguish-arcs arcs))))
+
+; Factoriser des arcs a destination unique (~deterministes)
+(define n2d-factorize-darcs
+  (lambda (arcs)
+    (if (null? arcs)
+	'()
+	(let* ((arc (car arcs))
+	       (arc-end (cdr arc))
+	       (other-arcs (cdr arcs))
+	       (farcs (n2d-factorize-darcs other-arcs)))
+	  (let loop ((farcs farcs))
+	    (if (null? farcs)
+		(list arc)
+		(let* ((farc (car farcs))
+		       (farc-end (cdr farc)))
+		  (if (= farc-end arc-end)
+		      (let* ((arc-class (car arc))
+			     (farc-class (car farc))
+			     (new-class (class-union farc-class arc-class))
+			     (new-arc (cons new-class arc-end)))
+			(cons new-arc (cdr farcs)))
+		      (cons farc (loop (cdr farcs)))))))))))
+
+; Normaliser un vecteur de listes d'arcs
+(define n2d-normalize-arcs-v
+  (lambda (arcs-v)
+    (let* ((nbnodes (vector-length arcs-v))
+	   (new-v (make-vector nbnodes)))
+      (let loop ((n 0))
+	(if (= n nbnodes)
+	    new-v
+	    (begin
+	      (vector-set! new-v n (n2d-normalize-arcs (vector-ref arcs-v n)))
+	      (loop (+ n 1))))))))
+
+; Inserer un arc dans une liste d'arcs a classes distinctes en separant
+; les arcs contenant une partie de la classe du nouvel arc des autres arcs
+; Retourne: (oui . non)
+(define n2d-ins-sep-arc
+  (lambda (new-arc arcs)
+    (if (null? arcs)
+	(cons (list new-arc) '())
+	(let* ((arc (car arcs))
+	       (others (cdr arcs))
+	       (result (n2d-2arcs new-arc arc))
+	       (arcl (vector-ref result 0))
+	       (arcc (vector-ref result 1))
+	       (arcr (vector-ref result 2))
+	       (l-arcc (if arcc (list arcc) '()))
+	       (l-arcr (if arcr (list arcr) '()))
+	       (result (if arcl
+			   (n2d-ins-sep-arc arcl others)
+			   (cons '() others)))
+	       (oui-arcs (car result))
+	       (non-arcs (cdr result)))
+	  (cons (append l-arcc oui-arcs) (append l-arcr non-arcs))))))
+
+; Combiner deux listes d'arcs a classes distinctes
+; Ne tente pas de combiner les arcs qui ont nec. des classes disjointes
+; Conjecture: les arcs crees ont leurs classes disjointes
+; Note: envisager de rajouter un "n2d-factorize-arcs" !!!!!!!!!!!!
+(define n2d-combine-arcs
+  (lambda (arcs1 arcs2)
+    (let loop ((arcs1 arcs1) (arcs2 arcs2) (dist-arcs2 '()))
+      (if (null? arcs1)
+	  (append arcs2 dist-arcs2)
+	  (let* ((arc (car arcs1))
+		 (result (n2d-ins-sep-arc arc arcs2))
+		 (oui-arcs (car result))
+		 (non-arcs (cdr result)))
+	    (loop (cdr arcs1) non-arcs (append oui-arcs dist-arcs2)))))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Recherche lineaire.  Creation naive
+; ; des arcs d'un ensemble d'etats.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((n 0))
+;       (if (= n n2d-state-count)
+; 	  (n2d-add-state ss)
+; 	  (let* ((dentry (vector-ref n2d-state-dict n))
+; 		 (dentry-ss (get-dentry-ss dentry)))
+; 	    (if (equal? dentry-ss ss)
+; 		n
+; 		(loop (+ n 1))))))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (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))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcss (map (lambda (s) (vector-ref arcs-v s)) ss))
+; 		   (arcs (apply append arcss))
+; 		   (dist-arcs (n2d-distinguish-arcs arcs))
+; 		   (darcs (n2d-translate-arcs dist-arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Recherche lineaire.  Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((n 0))
+;       (if (= n n2d-state-count)
+; 	  (n2d-add-state ss)
+; 	  (let* ((dentry (vector-ref n2d-state-dict n))
+; 		 (dentry-ss (get-dentry-ss dentry)))
+; 	    (if (equal? dentry-ss ss)
+; 		n
+; 		(loop (+ n 1))))))))
+; 
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+;   (lambda (arcs-l)
+;     (if (null? arcs-l)
+; 	'()
+; 	(let* ((arcs (car arcs-l))
+; 	       (other-arcs-l (cdr arcs-l))
+; 	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; 	  (n2d-combine-arcs arcs other-arcs)))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (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))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start))
+; 	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; 		   (arcs (n2d-combine-arcs-l arcs-l))
+; 		   (darcs (n2d-translate-arcs arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; ; 
+; ; Section temporaire: vieille facon de generer le dfa
+; ; Dictionnaire d'etat det.  Arbre de recherche.  Creation des
+; ; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; ; classes distinctes.
+; ; 
+; 
+; ; Quelques variables globales
+; (define n2d-state-dict '#(#f))
+; (define n2d-state-len 1)
+; (define n2d-state-count 0)
+; (define n2d-state-tree '#(#f ()))
+; 
+; ; Fonctions de gestion des entrees du dictionnaire
+; (define make-dentry (lambda (ss) (vector ss #f #f)))
+; 
+; (define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+; (define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+; (define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+; 
+; (define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+; (define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+; 
+; ; Fonctions de gestion de l'arbre de recherche
+; (define make-snode (lambda () (vector #f '())))
+; 
+; (define get-snode-dstate   (lambda (snode) (vector-ref snode 0)))
+; (define get-snode-children (lambda (snode) (vector-ref snode 1)))
+; 
+; (define set-snode-dstate
+;   (lambda (snode dstate)   (vector-set! snode 0 dstate)))
+; (define set-snode-children
+;   (lambda (snode children) (vector-set! snode 1 children)))
+; 
+; ; Initialisation des variables globales
+; (define n2d-init-glob-vars
+;   (lambda ()
+;     (set! n2d-state-dict (vector #f))
+;     (set! n2d-state-len 1)
+;     (set! n2d-state-count 0)
+;     (set! n2d-state-tree (make-snode))))
+; 
+; ; Extension du dictionnaire
+; (define n2d-extend-dict
+;   (lambda ()
+;     (let* ((new-len (* 2 n2d-state-len))
+; 	   (v (make-vector new-len #f)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (begin
+; 	      (set! n2d-state-dict v)
+; 	      (set! n2d-state-len new-len))
+; 	    (begin
+; 	      (vector-set! v n (vector-ref n2d-state-dict n))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Ajout d'un etat
+; (define n2d-add-state
+;   (lambda (ss)
+;     (let* ((s n2d-state-count)
+; 	   (dentry (make-dentry ss)))
+;       (if (= n2d-state-count n2d-state-len)
+; 	  (n2d-extend-dict))
+;       (vector-set! n2d-state-dict s dentry)
+;       (set! n2d-state-count (+ n2d-state-count 1))
+;       s)))
+; 
+; ; Recherche d'un etat
+; (define n2d-search-state
+;   (lambda (ss)
+;     (let loop ((s-l ss) (snode n2d-state-tree))
+;       (if (null? s-l)
+; 	  (or (get-snode-dstate snode)
+; 	      (let ((s (n2d-add-state ss)))
+; 		(set-snode-dstate snode s)
+; 		s))
+; 	  (let* ((next-s (car s-l))
+; 		 (alist (get-snode-children snode))
+; 		 (ass (or (assv next-s alist)
+; 			  (let ((ass (cons next-s (make-snode))))
+; 			    (set-snode-children snode (cons ass alist))
+; 			    ass))))
+; 	    (loop (cdr s-l) (cdr ass)))))))
+; 
+; ; Combiner des listes d'arcs a classes dictinctes
+; (define n2d-combine-arcs-l
+;   (lambda (arcs-l)
+;     (if (null? arcs-l)
+; 	'()
+; 	(let* ((arcs (car arcs-l))
+; 	       (other-arcs-l (cdr arcs-l))
+; 	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+; 	  (n2d-combine-arcs arcs other-arcs)))))
+; 
+; ; Transformer un arc non-det. en un arc det.
+; (define n2d-translate-arc
+;   (lambda (arc)
+;     (let* ((class (car arc))
+; 	   (ss (cdr arc))
+; 	   (s (n2d-search-state ss)))
+;       (cons class s))))
+; 
+; ; Transformer une liste d'arcs non-det. en ...
+; (define n2d-translate-arcs
+;   (lambda (arcs)
+;     (map n2d-translate-arc arcs)))
+; 
+; ; Trouver le minimum de deux acceptants
+; (define n2d-acc-min2
+;   (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))))))
+; 
+; ; Trouver le minimum de plusieurs acceptants
+; (define n2d-acc-mins
+;   (lambda (accs)
+;     (if (null? accs)
+; 	(cons #f #f)
+; 	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+; 
+; ; Fabriquer les vecteurs d'arcs et d'acceptance
+; (define n2d-extract-vs
+;   (lambda ()
+;     (let* ((arcs-v (make-vector n2d-state-count))
+; 	   (acc-v (make-vector n2d-state-count)))
+;       (let loop ((n 0))
+; 	(if (= n n2d-state-count)
+; 	    (cons arcs-v acc-v)
+; 	    (begin
+; 	      (vector-set! arcs-v n (get-dentry-darcs
+; 				     (vector-ref n2d-state-dict n)))
+; 	      (vector-set! acc-v n (get-dentry-acc
+; 				    (vector-ref n2d-state-dict n)))
+; 	      (loop (+ n 1))))))))
+; 
+; ; Effectuer la transformation de l'automate de non-det. a det.
+; (define nfa2dfa
+;   (lambda (nl-start no-nl-start arcs-v acc-v)
+;     (n2d-init-glob-vars)
+;     (let* ((nl-d (n2d-search-state nl-start))
+; 	   (no-nl-d (n2d-search-state no-nl-start))
+; 	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+;       (let loop ((n 0))
+; 	(if (< n n2d-state-count)
+; 	    (let* ((dentry (vector-ref n2d-state-dict n))
+; 		   (ss (get-dentry-ss dentry))
+; 		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+; 		   (arcs (n2d-combine-arcs-l arcs-l))
+; 		   (darcs (n2d-translate-arcs arcs))
+; 		   (fact-darcs (n2d-factorize-darcs darcs))
+; 		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+; 		   (acc (n2d-acc-mins accs)))
+; 	      (set-dentry-darcs dentry fact-darcs)
+; 	      (set-dentry-acc   dentry acc)
+; 	      (loop (+ n 1)))))
+;       (let* ((result (n2d-extract-vs))
+; 	     (new-arcs-v (car result))
+; 	     (new-acc-v (cdr result)))
+; 	(n2d-init-glob-vars)
+; 	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
+
+; 
+; Section temporaire: vieille facon de generer le dfa
+; Dictionnaire d'etat det.  Table de hashage.  Creation des
+; arcs d'un ensemble d'etats en combinant des ensembles d'arcs a
+; classes distinctes.
+; 
+
+; Quelques variables globales
+(define n2d-state-dict '#(#f))
+(define n2d-state-len 1)
+(define n2d-state-count 0)
+(define n2d-state-hash '#())
+
+; Fonctions de gestion des entrees du dictionnaire
+(define make-dentry (lambda (ss) (vector ss #f #f)))
+
+(define get-dentry-ss    (lambda (dentry) (vector-ref dentry 0)))
+(define get-dentry-darcs (lambda (dentry) (vector-ref dentry 1)))
+(define get-dentry-acc   (lambda (dentry) (vector-ref dentry 2)))
+
+(define set-dentry-darcs (lambda (dentry arcs) (vector-set! dentry 1 arcs)))
+(define set-dentry-acc   (lambda (dentry acc)  (vector-set! dentry 2 acc)))
+
+; Initialisation des variables globales
+(define n2d-init-glob-vars
+  (lambda (hash-len)
+    (set! n2d-state-dict (vector #f))
+    (set! n2d-state-len 1)
+    (set! n2d-state-count 0)
+    (set! n2d-state-hash (make-vector hash-len '()))))
+
+; Extension du dictionnaire
+(define n2d-extend-dict
+  (lambda ()
+    (let* ((new-len (* 2 n2d-state-len))
+	   (v (make-vector new-len #f)))
+      (let loop ((n 0))
+	(if (= n n2d-state-count)
+	    (begin
+	      (set! n2d-state-dict v)
+	      (set! n2d-state-len new-len))
+	    (begin
+	      (vector-set! v n (vector-ref n2d-state-dict n))
+	      (loop (+ n 1))))))))
+
+; Ajout d'un etat
+(define n2d-add-state
+  (lambda (ss)
+    (let* ((s n2d-state-count)
+	   (dentry (make-dentry ss)))
+      (if (= n2d-state-count n2d-state-len)
+	  (n2d-extend-dict))
+      (vector-set! n2d-state-dict s dentry)
+      (set! n2d-state-count (+ n2d-state-count 1))
+      s)))
+
+; Recherche d'un etat
+(define n2d-search-state
+  (lambda (ss)
+    (let* ((hash-no (if (null? ss) 0 (car ss)))
+	   (alist (vector-ref n2d-state-hash hash-no))
+	   (ass (assoc ss alist)))
+      (if ass
+	  (cdr ass)
+	  (let* ((s (n2d-add-state ss))
+		 (new-ass (cons ss s)))
+	    (vector-set! n2d-state-hash hash-no (cons new-ass alist))
+	    s)))))
+
+; Combiner des listes d'arcs a classes dictinctes
+(define n2d-combine-arcs-l
+  (lambda (arcs-l)
+    (if (null? arcs-l)
+	'()
+	(let* ((arcs (car arcs-l))
+	       (other-arcs-l (cdr arcs-l))
+	       (other-arcs (n2d-combine-arcs-l other-arcs-l)))
+	  (n2d-combine-arcs arcs other-arcs)))))
+
+; Transformer un arc non-det. en un arc det.
+(define n2d-translate-arc
+  (lambda (arc)
+    (let* ((class (car arc))
+	   (ss (cdr arc))
+	   (s (n2d-search-state ss)))
+      (cons class s))))
+
+; Transformer une liste d'arcs non-det. en ...
+(define n2d-translate-arcs
+  (lambda (arcs)
+    (map n2d-translate-arc arcs)))
+
+; Trouver le minimum de deux acceptants
+(define n2d-acc-min2
+  (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))))))
+
+; Trouver le minimum de plusieurs acceptants
+(define n2d-acc-mins
+  (lambda (accs)
+    (if (null? accs)
+	(cons #f #f)
+	(n2d-acc-min2 (car accs) (n2d-acc-mins (cdr accs))))))
+
+; Fabriquer les vecteurs d'arcs et d'acceptance
+(define n2d-extract-vs
+  (lambda ()
+    (let* ((arcs-v (make-vector n2d-state-count))
+	   (acc-v (make-vector n2d-state-count)))
+      (let loop ((n 0))
+	(if (= n n2d-state-count)
+	    (cons arcs-v acc-v)
+	    (begin
+	      (vector-set! arcs-v n (get-dentry-darcs
+				     (vector-ref n2d-state-dict n)))
+	      (vector-set! acc-v n (get-dentry-acc
+				    (vector-ref n2d-state-dict n)))
+	      (loop (+ n 1))))))))
+
+; Effectuer la transformation de l'automate de non-det. a det.
+(define nfa2dfa
+  (lambda (nl-start no-nl-start arcs-v acc-v)
+    (n2d-init-glob-vars (vector-length arcs-v))
+    (let* ((nl-d (n2d-search-state nl-start))
+	   (no-nl-d (n2d-search-state no-nl-start))
+	   (norm-arcs-v (n2d-normalize-arcs-v arcs-v)))
+      (let loop ((n 0))
+	(if (< n n2d-state-count)
+	    (let* ((dentry (vector-ref n2d-state-dict n))
+		   (ss (get-dentry-ss dentry))
+		   (arcs-l (map (lambda (s) (vector-ref norm-arcs-v s)) ss))
+		   (arcs (n2d-combine-arcs-l arcs-l))
+		   (darcs (n2d-translate-arcs arcs))
+		   (fact-darcs (n2d-factorize-darcs darcs))
+		   (accs (map (lambda (s) (vector-ref acc-v s)) ss))
+		   (acc (n2d-acc-mins accs)))
+	      (set-dentry-darcs dentry fact-darcs)
+	      (set-dentry-acc   dentry acc)
+	      (loop (+ n 1)))))
+      (let* ((result (n2d-extract-vs))
+	     (new-arcs-v (car result))
+	     (new-acc-v (cdr result)))
+	(n2d-init-glob-vars 0)
+	(list nl-d no-nl-d new-arcs-v new-acc-v)))))
-- 
cgit v1.2.3