blob: c8177f23a3b99c2cc6f48c5ad0747b9461ac36a0 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
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))))
|
