Thanks to visit codestin.com
Credit goes to github.com

Skip to content

Commit 94810e1

Browse files
author
sjf
committed
Minimisation, fixed complete
1 parent 6392555 commit 94810e1

3 files changed

Lines changed: 154 additions & 129 deletions

File tree

‎dfa.scm‎

Lines changed: 113 additions & 104 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@
1717
(dfa-intersection dfaA dfaB)
1818
(dfa-less dfaA dfaB)
1919
(dfa-states dfaA)
20+
(dfa-minimize! dfaA)
2021
(dfa-remove-unreachable-states! dfaA)
2122
(dfa-rename-states dfaA)
2223
test-dfa
@@ -72,6 +73,8 @@
7273
(else
7374
(%run-dfa next-state dfa (cdr input))))))))
7475

76+
;; Convert a dfa to an nfa, this doesn't really have to do anything
77+
;; except make a new nfa record.
7578
(define (dfa->nfa dfaA)
7679
(nfa (dfa-alphabet dfaA)
7780
(dfa-states dfaA)
@@ -85,75 +88,39 @@
8588
(let* ((nfaC (apply nfa-concat (map dfa->nfa (cons dfaA (cons dfaB rest))))))
8689
(nfa->dfa nfaC)))
8790

88-
;; ;; Concatenate two dfas.
89-
;; ;; The start state of B becomes the final state of dfaA.
90-
;; ;; Replace each reference to the start state of dfaB
91-
;; ;; with a references to the final states of dfaA.
92-
;; (define (dfa-concat dfaA dfaB)
93-
;; (let* ((qfinal-A (dfa-final-states dfaA))
94-
;; (qfinal-B (dfa-final-states dfaB))
95-
;; (q0-B (dfa-start-state dfaB))
96-
;; (new-start (dfa-start-state dfaA))
97-
;; (new-final (if (member q0-B qfinal-B)
98-
;; ;; replace q0-B with the set qfinal-A
99-
;; (append (remq q0-B qfinal-B)
100-
;; qfinal-A)
101-
;; qfinal-B))
102-
;; (new-trans-B (flatten
103-
;; (map (lambda (qfinal)
104-
;; (map (lambda (trans)
105-
;; (let ((qA (if (equal? (first trans) q0-B)
106-
;; qfinal (first trans)))
107-
;; (qB (if (equal? (third trans) q0-B)
108-
;; qfinal (third trans))))
109-
;; (list qA (second trans) qB)))
110-
;; (dfa-transition-list dfaB)))
111-
;; qfinal-A)))
112-
;; (new-trans (append (dfa-transition-list dfaA) new-trans-B))
113-
;; (new-alphabet (union (dfa-alphabet dfaA) (dfa-alphabet dfaB))))
114-
;; (print new-trans)
115-
;; ; (dfa-rename-states
116-
;; (dfa
117-
;; new-start
118-
;; new-trans
119-
;; new-final
120-
;; new-alphabet)))
121-
12291
;; A complete dfa has transitions out of every state for every symbol
12392
;; in the language.
12493
;; This will add in the necessary extra transitions, which will go
12594
;; to a new sink state
12695
(define (dfa-complete dfaA)
12796
(define transitions (dfa-transition-list dfaA))
12897
(define sink-state (gensym "sink"))
129-
(let loop0 ((states (cons sink-state
130-
(nub (append
131-
(map first (dfa-transition-list dfaA))
132-
(map third (dfa-transition-list dfaA)))))))
133-
; (print states)
134-
(cond ((not (null? states))
135-
(let loop1 ((alphabet (dfa-alphabet dfaA)))
136-
;(print alphabet)
137-
(cond ((not (null? alphabet))
138-
; (print (car states) " " (car alphabet) " "
139-
; ((dfa-transition dfaA) (car states) (car alphabet)))
140-
(if (equal? (dfa-trans dfaA (car states) (car alphabet)) #f)
141-
; There is no transition for this state and symbol
142-
; So add a transition to the sink state
143-
(set! transitions
144-
(cons (list (car states)
145-
(car alphabet)
146-
sink-state)
147-
transitions)))
148-
(loop1 (cdr alphabet)))))
149-
(loop0 (cdr states)))
150-
(else
151-
(dfa-rename-states
152-
(dfa (dfa-start-state dfaA)
153-
transitions
154-
(dfa-final-states dfaA)
155-
(dfa-alphabet dfaA)))))))
98+
;; Check if is complete beforehand
99+
(cond ((is-complete? dfaA) dfaA)
100+
(else (map (lambda (state)
101+
(map (lambda (symbol)
102+
(if (equal? (dfa-trans dfaA state symbol) #f)
103+
;; Add a transition to the sink state
104+
(set! transitions
105+
(cons (list state symbol sink-state)
106+
transitions))))
107+
(dfa-alphabet dfaA)))
108+
(cons sink-state (dfa-states dfaA)))
109+
(dfa-rename-states
110+
(dfa (dfa-start-state dfaA)
111+
transitions
112+
(dfa-final-states dfaA)
113+
(dfa-alphabet dfaA))))))
114+
115+
(define (is-complete? dfaA)
116+
(let loop ((states (dfa-states dfaA))
117+
(alphabet (dfa-alphabet dfaA)))
118+
(cond ((null? states) #t)
119+
((null? alphabet) (loop (cdr states) (dfa-alphabet dfaA)))
120+
((equal? #f (dfa-trans dfaA (car states) (car alphabet))) #f)
121+
(else (loop states (cdr alphabet))))))
156122

123+
;; Returns the dfa for the universal language, eg. E*
157124
(define (dfa-universal alphabet)
158125
(let* ((q0 (gensym "q"))
159126
(trans (map
@@ -183,10 +150,24 @@
183150
new-final
184151
(dfa-alphabet cdfa)))))
185152

153+
154+
(define (dfa-less dfa1 dfa2)
155+
(dfa-intersection dfa1 (dfa-complement dfa2)))
156+
;; (let* ((i (dfa-complement dfa2))
157+
;; (l (dfa-intersection dfa1 i)))
158+
;; (print "inv")(read)
159+
;; (show-graph (graph i))
160+
;; (print "dfa1")(read)
161+
;; (show-graph (graph dfa1))
162+
;; (print "intersection")(read)
163+
;; (show-graph (graph l))
164+
;; l))
165+
166+
186167
;; Returns a dfa that is the intersection of dfaA and dfaB
187168
(define (dfa-intersection dfaA dfaB)
188-
(print-dfa dfaA)
189-
(print-dfa dfaB)
169+
; (print-dfa dfaA)
170+
; (print-dfa dfaB)
190171
(let* ((alphabet (union (dfa-alphabet dfaA)
191172
(dfa-alphabet dfaB)))
192173
(new-start (list (dfa-start-state dfaA)
@@ -237,9 +218,35 @@
237218
(else
238219
new-transitions))))
239220

221+
(define (dfa-minimize! dfa1)
222+
(dfa-remove-unreachable-states! dfa1)
223+
(%dfa-minimize! dfa1))
224+
225+
;; Minimise a dfa
226+
;; Find the states that are equivalent and merge them
227+
(define (%dfa-minimize! dfa1)
228+
(let loop0 ((states1 (dfa-states dfa1)))
229+
(if (not (null? states1))
230+
(let loop1 ((states2 (dfa-states dfa1)))
231+
(if (not (null? states2))
232+
(let ((state1 (car states1))
233+
(state2 (car states2)))
234+
(if (and (not (equal? state1 state2))
235+
(equivalent-states? dfa1 state1 state2))
236+
(rename-states! dfa1 state2 state1))
237+
(loop1 (cdr states2))))
238+
(loop0 (cdr states1))))))
239+
240+
241+
242+
;; Returns true if q1 and q2 are equivalent states.
243+
;; Two states in a dfa are equivalent if
244+
;; for every symbol in the alphabet they go the
245+
;; next state. They must also both be either final or not
246+
;; final.
240247
(define (equivalent-states? dfa1 q1 q2)
241248
(if (not (equal? (member q1 (dfa-final-states dfa1))
242-
(member q2 (dfa-final-states dfa2))))
249+
(member q2 (dfa-final-states dfa1))))
243250
#f
244251
(let loop ((symbols (dfa-alphabet dfa1)))
245252
(cond ((null? symbols)
@@ -250,48 +257,28 @@
250257
(else
251258
(loop (cdr symbols)))))))
252259

253-
(define (dfa-minimize! dfa1)
254-
(let loop0 ((states1 (dfa-states dfa1)))
255-
(if (not (null? states1))
256-
(let loop1 ((states2 (dfa-states dfa2)))
257-
(if (not (null? states2))
258-
(let ((state1 (car states1))
259-
(state2 (car states2)))
260-
(if (and (not (equal? state1 state2))
261-
(equivalent? state1 state2))
262-
(rename-states! dfa1 state2 state1))
263-
(loop1 (cdr states2))))
264-
(loop0 (cdr states2))))))
265-
266-
260+
;; Takes a dfa and renames all occurrences of state1 to state2
267261
(define (rename-states! dfa1 state1 state2)
268262
(define (replace-state x)
269263
(if (equal? x state1) state2 x))
270-
(let ((new-trans (map
271-
(lambda (trans)
272-
(let ((q1 (replace-state (first trans)))
273-
(q2 (replace-state (third trans))))
274-
(list q1 (second trans) q2)))
275-
(dfa-tranisition-list dfa1)))
276-
(new-start (replace-state (dfa-start-state dfa1)))
277-
(new-final (map replace-state (dfa-final-states dfa1))))
278-
(dfa-transition-list-set! new-trans)
279-
(dfa-start-state-set! new-start)
280-
(dfa-final-states-set! new-final)))
281-
282-
283-
(define (dfa-less dfa1 dfa2)
284-
(dfa-intersection dfa1 (dfa-complement dfa2)))
285-
;; (let* ((i (dfa-complement dfa2))
286-
;; (l (dfa-intersection dfa1 i)))
287-
;; (print "inv")(read)
288-
;; (show-graph (graph i))
289-
;; (print "dfa1")(read)
290-
;; (show-graph (graph dfa1))
291-
;; (print "intersection")(read)
292-
;; (show-graph (graph l))
293-
;; l))
294-
264+
(let ((new-start (replace-state (dfa-start-state dfa1)))
265+
(new-final (map replace-state (dfa-final-states dfa1))))
266+
(dfa-start-state-set! dfa1 new-start)
267+
(dfa-final-states-set! dfa1 new-final)
268+
;; Replace all references to state1 in the list of transitions
269+
(let loop ((transitions (dfa-transition-list dfa1))
270+
(new-trans (list)))
271+
(if (not (null? transitions))
272+
(let* ((trans (car transitions))
273+
(q1 (replace-state (first trans)))
274+
(q2 (replace-state (third trans)))
275+
(n-trans (list q1 (second trans) q2)))
276+
;; avoid duplicate transitions
277+
(if (equal? (first trans) state1)
278+
(loop (cdr transitions) new-trans)
279+
(loop (cdr transitions) (cons n-trans new-trans))))
280+
(dfa-transition-list-set! dfa1 new-trans)))))
281+
295282

296283
(define (dfa-remove-unreachable-states! dfaA)
297284
(let loop ((unreachable-states (%unreachable-states dfaA)))
@@ -422,8 +409,30 @@
422409
'(qA)
423410
'(d)))
424411

412+
(define test-dfa-m
413+
(dfa
414+
'q0
415+
'((q0 a q1)
416+
(q0 b q2)
417+
(q1 a q3)
418+
(q1 b q4)
419+
(q2 a q4)
420+
(q2 b q3)
421+
(q3 a q5)
422+
(q3 b q5)
423+
(q4 a q5)
424+
(q4 b q5)
425+
(q5 a q5)
426+
(q5 b q5))
427+
'(q5)
428+
'(a b)))
429+
425430
(define (main argv)
426-
(view
431+
(view (graph test-dfa-m))
432+
(dfa-minimize! test-dfa-m)
433+
(view (graph test-dfa-m))
434+
435+
(exit)
427436

428437
; (print-dfa test-dfa)
429438
; (print-dfa test-dfa1)

‎graph.scm‎

Lines changed: 6 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,12 @@
1111
(dfa "dfa.scm")
1212
(utils "utils.scm"))
1313
(export
14-
(show-graph graph)
14+
(view graph)
1515
(graph state-machine)
1616
(graph-to-file state-machine file)))
1717

18+
(define *image-viewer* "eog")
19+
1820
(define (graph state-machine)
1921
(cond ((nfa? state-machine)
2022
(graph-nfa state-machine))
@@ -94,18 +96,18 @@
9496

9597
;; Generate a png from the graph
9698
;; using dot. Display the graph using eog.
97-
(define (show-graph graph)
99+
(define (view graph)
98100
(let* ((tempfile (temp-filename))
99101
(proc (run-process "dot" "-Tpng" "-o" tempfile :input :pipe))
100102
(proc-input (process-input-port proc)))
101103
(fprint proc-input graph)
102104
(flush-output-port proc-input)
103105
(close-output-port proc-input)
104106
(process-wait proc)
105-
(run-process "eog" tempfile)))
107+
(run-process *image-viewer* tempfile)))
106108

107109
(define (main-graph argv)
108-
(show-graph (graph test-dfa1))
110+
(view (graph test-dfa1))
109111
(print (graph test-dfa1))
110112
;(print (graph test-nfa3))
111113
;(show-graph (graph test-dfa1))

‎snapshots.scm‎

Lines changed: 35 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -70,26 +70,31 @@
7070

7171
;; Return the dfa that is the superposition of dfa1 and dfa2
7272
(define (superposition dfa1 dfa2)
73-
(let* ((start-state (list (dfa-start-state dfa1) (dfa-start-state dfa2)))
74-
(final-states (cross-product (dfa-final-states dfa1) (dfa-final-states dfa2)))
73+
(let* ((new-start (list (dfa-start-state dfa1) (dfa-start-state dfa2)))
74+
(new-final (cross-product (dfa-final-states dfa1) (dfa-final-states dfa2)))
7575
(trans1 (dfa-transition-list dfa1))
7676
(trans2 (dfa-transition-list dfa2))
77-
(new-trans (nub (map (lambda (pair) (apply superpos-transition pair))
78-
(cross-product trans1 trans2))))
77+
(new-trans (nub
78+
(map (lambda (pair) (apply superpos-transition pair))
79+
(cross-product trans1 trans2))))
7980
;; TODO: this isn't really correct
8081
;; it should be powerset(phi(dfa1) union phi(dfa2))
81-
(new-alphabet (dfa-alphabet dfa1)))
82-
(map print trans1)
83-
(map print trans2)
84-
(map print new-trans)
85-
(dfa-rename-states
86-
(dfa-remove-unreachable-states!
87-
(dfa
88-
start-state
89-
new-trans
90-
final-states
91-
new-alphabet)))))
82+
(new-alphabet (dfa-alphabet dfa1))
83+
(dfa-new (dfa-rename-states
84+
(dfa new-start
85+
new-trans
86+
new-final
87+
new-alphabet))))
88+
(dfa-minimize! dfa-new)
89+
90+
dfa-new))
91+
; (map print trans1)
92+
; (map print trans2)
93+
; (map print new-trans)
9294

95+
96+
;; The subsumptive closure, L |>=, is
97+
;; the same as L&E*
9398
(define (subsumptive-closure dfaA)
9499
(superposition dfaA (dfa-universal (dfa-alphabet dfaA))))
95100

@@ -103,10 +108,18 @@
103108
(temp
104109
(dfa-concat (dfa-universal alphabet)
105110
intersec
106-
(dfa-universal alphabet))))
107-
(map (lambda (d) (write "*") (read) (show-graph (graph d)))
108-
(list s-closure-A s-closure-B s-closure-B-inv intersec temp))
109-
(dfa-complement temp)))
111+
(dfa-universal alphabet)))
112+
(result (dfa-complement temp)))
113+
(print "****")
114+
(print-dfa temp)
115+
(print-dfa result)
116+
(print "****")
117+
(view (graph temp))
118+
(view (graph result))
119+
result))
120+
; (map (lambda (d) (write "*") (read) (view (graph d)))
121+
; (list s-closure-A s-closure-B s-closure-B-inv intersec temp))
122+
110123

111124
;; the empty snapshot: []
112125
(define empty-snapshot (list))
@@ -131,8 +144,9 @@
131144

132145
(define (main-snapshots argv)
133146
(let ((c (constraint A B)))
134-
(map print-dfa (list A B c))
135-
(show-graph (graph c))))
147+
'()))
148+
;(map print-dfa (list A B c))))
149+
; (view (graph c))))
136150
;; (if (> (length argv) 1)
137151
;; (begin
138152
;; (print (str->snapshot-seq (string-join (cdr argv) " ")))

0 commit comments

Comments
 (0)