diff options
Diffstat (limited to 'src/guile/silex/nfa2dfa.scm')
| -rw-r--r-- | src/guile/silex/nfa2dfa.scm | 768 |
1 files changed, 768 insertions, 0 deletions
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))))) |