276 lines
9.4 KiB
Racket
276 lines
9.4 KiB
Racket
#lang racket
|
|
|
|
;; (C) Copyright Collin J. Doering 2014
|
|
;;
|
|
;; 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 3 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, see <http://www.gnu.org/licenses/>.
|
|
|
|
;; File: DFA.rkt
|
|
;; Author: Collin J. Doering <collin.doering@rekahsoft.ca>
|
|
;; Date: Aug 27, 2014
|
|
;; Description: an implementation of Determinalistic Finite Autamata
|
|
|
|
(require (for-syntax syntax/parse))
|
|
|
|
;; A structure to represent a dfa state
|
|
(struct dfaState (name trans end? dead?))
|
|
|
|
;; A structure representing a dfa
|
|
(struct dfa (alpha start states))
|
|
|
|
;; A structure to represent a nfa state
|
|
;; TODO
|
|
|
|
;; A structure representing a nfa
|
|
;; TODO
|
|
|
|
;; Given a dfa and a list of inputs returns 'accept when the dfa completes in a end success
|
|
;; state and 'reject otherwise
|
|
(define (compute-dfa m xs)
|
|
(define/match (run-dfa state ys)
|
|
[((dfaState _ _ #t _) '()) 'accept]
|
|
[(_ '()) 'reject]
|
|
[((dfaState _ _ #f #t) _) 'reject]
|
|
[((dfaState _ f _ _) (cons z zs)) (run-dfa (f z) zs)])
|
|
(run-dfa (dfa-start m) xs))
|
|
|
|
;; Macro for defining dfa structures in a syntactically clean way
|
|
(define-syntax (define-dfa stx)
|
|
(define-syntax-class transition
|
|
#:description "dfa state transition"
|
|
(pattern (in (~optional ->) out:id)))
|
|
|
|
(define-splicing-syntax-class state
|
|
#:description "dfa state"
|
|
;; (pattern (name:id (~or (~optional (~and #:dead deader?))
|
|
;; (~optional (~and #:end ender?))) ...)
|
|
;; #:with dead? #'(if deader? #'#t #'#f)
|
|
;; #:with end? #'(if ender? #'#t #'#f)
|
|
;; #:with (in ...) #'(_)
|
|
;; #:with (out ...) #'(name))
|
|
(pattern (name:id #:end trans:transition ...+)
|
|
#:with end? #'#t
|
|
#:with (in ...) #'(trans.in ...)
|
|
#:with (out ...) #'(trans.out ...))
|
|
(pattern (name:id trans:transition ...+)
|
|
#:with end? #'#f
|
|
#:with (in ...) #'(trans.in ...)
|
|
#:with (out ...) #'(trans.out ...)))
|
|
|
|
(syntax-parse stx
|
|
[(_ name:id alpha:expr start:state rests:state ...)
|
|
#:fail-when (check-duplicate-identifier
|
|
(syntax->list
|
|
#'(start.name rests.name ...)))
|
|
"duplicate state names"
|
|
#`(define name
|
|
(letrec ([start.name
|
|
(dfaState 'start.name
|
|
(match-lambda [start.in start.out] ...)
|
|
start.end?
|
|
#f ;start.dead?
|
|
)]
|
|
[rests.name
|
|
(dfaState 'rests.name
|
|
(match-lambda [rests.in rests.out] ...)
|
|
rests.end?
|
|
#f ;rests.dead?
|
|
)] ...)
|
|
(dfa alpha start.name `(,start.name ,rests.name ...))))]))
|
|
|
|
;; TODO: implement conversion of nfa to dfa using the powerset construction
|
|
(define (nfa->dfa n)
|
|
'undefined)
|
|
|
|
(define (dfa-reverse d)
|
|
(letrec ([states (dfa-states d)]
|
|
[end-states (map dfaState-name (filter dfaState-end? states))]
|
|
[dfa-trans-tbl (foldr (lambda (s acc)
|
|
(hash-set acc
|
|
(dfaState-name s)
|
|
(foldr (lambda (i a)
|
|
(hash-set a i (dfaState-name ((dfaState-trans s) i))))
|
|
(hash)
|
|
(dfa-alpha d))))
|
|
(hash)
|
|
(dfa-states d))]
|
|
[gen-nfa-trans-tbl (lambda (seen tbl)
|
|
(for ([(s h) (in-hash dfa-trans-tbl)])
|
|
(for ([(a t) (in-hash h)])
|
|
(set! tbl (hash-set tbl t (hash-set (hash-ref tbl t) a
|
|
(set-add (hash-ref (hash-ref tbl t) a) s))))
|
|
(when (not (equal? s t))
|
|
(set! seen (set-add seen s)))))
|
|
(for ([s (in-set (set-subtract (list->set (map dfaState-name states)) seen))])
|
|
(set! tbl (hash-remove tbl s)))
|
|
|
|
tbl)]
|
|
[nfa-trans-tbl->nfa (lambda (tbl)
|
|
tbl)])
|
|
(nfa-trans-tbl->nfa
|
|
(gen-nfa-trans-tbl
|
|
(list->set end-states)
|
|
(let* ([o (foldr (lambda (i acc)
|
|
(hash-set acc i (set))) (hash) (dfa-alpha d))]
|
|
[h (foldr (lambda (s acc)
|
|
(hash-set acc (dfaState-name s) o)) (hash) states)])
|
|
(if (<= (length end-states) 1)
|
|
h
|
|
(hash-set h (gensym) (hash 'epsilon (list->set end-states)))))))))
|
|
|
|
;; TODO
|
|
;; (list->vector (dfa-states d))
|
|
;; (define (dfa-reverse d)
|
|
;; (letrec ([alpha (dfa-alpha d)]
|
|
;; [start (dfa-start d)]
|
|
;; [ends (filter dfaState-end? (dfa-states d))]
|
|
;; [s0 (nfaState (match-lambda (['epsilon ends])) #f)]
|
|
;; [dfa-rev (match-lambda* (s n)
|
|
;; [((dfaState f e d) n-prime) 'undefined])])
|
|
;; (nfa alpha s0 (dfa-rev ends nnnnnn))
|
|
;; (dfa-rev start nnnnn)))
|
|
|
|
(define (minimize-dfa d)
|
|
(nfa->dfa (dfa-reverse (nfa->dfa (dfa-reverse d)))))
|
|
|
|
;; Todo:
|
|
;; - error when 'in' pattern in the transition syntax class is not an element of alpha
|
|
;; - error when given no end state
|
|
;; - add keyword #:dead to create a dead state: (define-dfa n (0 1) (s0 #:dead))
|
|
;; - check to ensure all transitions goto a valid state name; fail otherwise
|
|
;; - check to ensure all transitions 'come from' a valid input; fail otherwise
|
|
;; ----------------------------------------------------------------------------
|
|
|
|
;; Odd binary dfa expansion
|
|
(define odd-dfa-expansion
|
|
(letrec ([s0 (dfaState 's0
|
|
(match-lambda [0 s2]
|
|
[1 s1])
|
|
#f #f)]
|
|
[s1 (dfaState 's1
|
|
(match-lambda [0 s2]
|
|
[1 s1])
|
|
#t #f)]
|
|
[s2 (dfaState 's2
|
|
(match-lambda [0 s2]
|
|
[1 s1])
|
|
#f #f)])
|
|
(dfa '(0 1) s0 '(s0 s1 s2))))
|
|
|
|
;; Even binary dfa expansion
|
|
(define even-dfa-expansion
|
|
(letrec ([s0 (dfaState 's0
|
|
(match-lambda [0 s1]
|
|
[1 s2])
|
|
#f #f)]
|
|
[s1 (dfaState 's1
|
|
(match-lambda [0 s1]
|
|
[1 s2])
|
|
#t #f)]
|
|
[s2 (dfaState 's2
|
|
(match-lambda [0 s1]
|
|
[1 s2])
|
|
#f #f)])
|
|
(dfa '(0 1) s0 '(s0 s1 s2))))
|
|
|
|
;; Even binary DFA
|
|
(define-dfa even-dfa '(0 1)
|
|
[s0 (0 -> s1)
|
|
(1 -> s2)]
|
|
[s1 #:end
|
|
(0 -> s1)
|
|
(1 -> s2)]
|
|
[s2 (0 -> s1)
|
|
(1 -> s2)])
|
|
|
|
;; Odd binary DFA
|
|
(define-dfa odd-dfa '(0 1)
|
|
[s0 (0 -> s2)
|
|
(1 -> s1)]
|
|
[s1 #:end
|
|
(0 -> s2)
|
|
(1 -> s1)]
|
|
[s2 (0 -> s2)
|
|
(1 -> s1)])
|
|
|
|
(define-dfa divisible-by-four-dfa '(0 1)
|
|
[s0 (0 -> s3)
|
|
(1 -> s1)]
|
|
[s1 (0 -> s2)
|
|
(1 -> s1)]
|
|
[s2 (0 -> s3)
|
|
(1 -> s1)]
|
|
[s3 #:end
|
|
(0 -> s3)
|
|
(1 -> s1)])
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; This section shows two features that would be nice to have added to the define-dfa macro
|
|
;; Specifically:
|
|
;; - Add transition to dead state using #:dead keyword; dfa transition of form (in:id (~optional ->) #:dead)
|
|
|
|
(define-dfa text-file-dfa (string->list "AaBbCcDdEeFfGgHhJjLlMmNnOoPpQqRrSsTtUuVvWwRrXxYyZz1234567890-=\\`!@#$%^&*()_+|~[];',./{}:\"<>?")
|
|
[s0 (#\. -> s1)
|
|
(_ -> s0)]
|
|
[s1 (#\t -> s2)
|
|
(#\. -> s1)
|
|
(_ -> s0)]
|
|
[s2 (#\x -> s3)
|
|
(_ -> s0)]
|
|
[s3 (#\t -> s4)
|
|
(#\. -> s1)
|
|
(_ -> s0)]
|
|
[s4 #:end
|
|
(#\. -> s1)
|
|
(_ -> s0)])
|
|
|
|
;; (define-dfa text-file-dfa (#\A #\a #\B #\b #\C #\c #\D #\d #\E #\e #\F #\f #\G #\g #\H #\h #\I #\i #\J #\j #\K #\k #\L #\l #\M #\m #\N #\n #\O #\o #\P #\p #\Q #\q #\R #\r #\S #\s #\T #\t #\U #\u #\V #\v #\W #\w #\X #\x #\Y #\y #\Z #\z #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
|
;; [s0 (#\. -> s1)
|
|
;; (_ -> s0)]
|
|
;; [s1 (#\t -> s2)
|
|
;; (_ -> #:dead)]
|
|
;; [s2 (#\x -> s3)
|
|
;; (_ -> #:dead)]
|
|
;; [s3 (#\t -> s4)
|
|
;; (_ -> #:dead)]
|
|
;; [s4 #:end
|
|
;; (_ -> #:dead)])
|
|
|
|
;; (define-dfa empty-dfa ()
|
|
;; [s0 #:end
|
|
;; (_ -> dead)]
|
|
;; [dead (_ -> dead)])
|
|
|
|
;; (define-dfa empty-dfa ()
|
|
;; [s0 #:end (_ -> #:dead)])
|
|
|
|
;; (define-dfa empty-dfa ()
|
|
;; [s0 #:dead #:end])
|
|
|
|
;;(define-dfa binary-empty-dfa (0 1)
|
|
;; [s0 #:dead #:end])
|
|
|
|
;; ----------------------------------------------------------------------------
|
|
;; Some simple tests
|
|
|
|
(define (integer->binary-list n)
|
|
(define (ibl n acc)
|
|
(cond [(zero? n) acc]
|
|
[else (ibl (quotient n 2) (cons (modulo n 2) acc))]))
|
|
(if (zero? n) '(0) (ibl n '())))
|
|
|
|
(for ([i 1000])
|
|
(displayln (compute-dfa even-dfa (integer->binary-list i)))
|
|
(displayln (compute-dfa odd-dfa (integer->binary-list i)))
|
|
(newline))
|