(define (make-finite-state-automaton start-state accept-state-list transitions . optional-parameter-list)
(let ((given-symbol-map (optional-parameter 1 optional-parameter-list #f)))
(let* ((automaton-alphabet (alphabet-of-automaton-transitions transitions))
(symbol-map (if given-symbol-map given-symbol-map (make-automaton-symbol-map automaton-alphabet)))
)
(list
'finite-state-automaton
start-state
accept-state-list
(list->vector (sort-list (if given-symbol-map transitions (compacted-transitions transitions symbol-map)) transition-leq?))
symbol-map))))
(define start-state-of-finite-state-automaton (make-selector-function 2 "start-state-of-finite-state-automaton"))
(define final-states-of-finite-state-automaton (make-selector-function 3 "final-states-of-finite-state-automaton"))
(define transitions-of-finite-state-automaton (make-selector-function 4 "transitions-of-finite-state-automaton"))
(define (transition-list-of-finite-state-automaton aut)
(let ((trans-vec (transitions-of-finite-state-automaton aut)))
(vector->list trans-vec)))
(define symbol-map-of-finite-state-automaton (make-selector-function 5 "symbol-map-of-finite-state-automaton"))
(define state-equal? =)
(define state-leq? <=)
(define state-lt? <)
(define (transition-leq? trans1 trans2)
(let ((from1 (from-state-of-transition trans1))
(from2 (from-state-of-transition trans2)))
(cond ((state-lt? from1 from2)
#t)
((state-equal? from1 from2)
(let ((sym1 (symbol-of-transition trans1))
(sym2 (symbol-of-transition trans2)))
(cond ((and (epsilon-symbol? sym1) (epsilon-symbol? sym2))
#t)
((and (epsilon-symbol? sym1) (not (epsilon-symbol? sym2)))
#t)
((and (symbol? sym1) (symbol? sym2))
(symbol-leq? sym1 sym2))
(else #f))))
(else #f))))
(define symbol-equal? eq?)
(define (make-automaton-transition in-state symbol out-state)
(list in-state symbol out-state))
(define from-state-of-transition (make-selector-function 1 "from-state-of-transition"))
(define symbol-of-transition (make-selector-function 2 "symbol-of-transition"))
(define to-state-of-transition (make-selector-function 3 "to-state-of-transition"))
(define epsilon-symbol #f)
(define (epsilon-symbol? s) (and (boolean? s) (not s)))
(define (epsilon-transition? trans) (epsilon-symbol? (symbol-of-transition trans)))
(define last-automaton-input-symbol #f)
(define automaton-input-number 0)
(define (deterministic-automaton-move automaton from-state symbol)
(let* ((transitions (transitions-of-finite-state-automaton automaton))
(symbol-map (symbol-map-of-finite-state-automaton automaton))
(matching-transition (search-transitions transitions from-state (get-compact-automata-symbol symbol symbol-map unknown-symbol))))
(set! last-automaton-input-symbol symbol)
(set! automaton-input-number (+ 1 automaton-input-number))
(if matching-transition
(to-state-of-transition matching-transition)
#f)))
(define (deterministic-automaton-move* automaton state symbol-list)
(if (null? symbol-list)
state
(let ((next-state (deterministic-automaton-move automaton state (car symbol-list))))
(if next-state
(deterministic-automaton-move* automaton next-state (cdr symbol-list))
#f))))
(define (trans-sel trans)
(cons (from-state-of-transition trans) (symbol-of-transition trans)))
(define (trans-eq? cell1 cell2)
(and (= (car cell1) (car cell2))
(eq? (cdr cell1) (cdr cell2))
))
(define (trans-leq? cell1 cell2)
(cond ((< (car cell1) (car cell2))
#t)
((= (car cell1) (car cell2))
(symbol-leq? (cdr cell1) (cdr cell2)))
(else #f)))
(define (search-transitions transitions from-state symbol)
(let ((search-res (binary-search-in-vector transitions (cons from-state symbol) trans-sel trans-eq? trans-leq?)))
(if search-res
search-res
#f)))
(define (automaton-accepts? automaton symbol-list)
(set! last-automaton-input-symbol #f)
(set! automaton-input-number 0)
(let ((end-state
(deterministic-automaton-move*
automaton (start-state-of-finite-state-automaton automaton) symbol-list)))
(if end-state
(turn-into-boolean (member-by-predicate end-state (final-states-of-finite-state-automaton automaton) state-equal?))
#f)))
(define (subset-construction nfa . optional-parameter-list)
(let ((support-epsilon-moves? (optional-parameter 1 optional-parameter-list #f)))
(letrec ((set-of-elements list))
(let* ((input-symbols
(remove-duplicates-by-predicate
(filter (lambda (s) (not (epsilon-symbol? s))) (map symbol-of-transition (transition-list-of-finite-state-automaton nfa))) symbol-equal?))
(dfa-start-state (if support-epsilon-moves?
(epsilon-closure-single-state (start-state-of-finite-state-automaton nfa) nfa)
(set-of-elements (start-state-of-finite-state-automaton nfa))
))
(unmarked-dstates (set-of-elements dfa-start-state))
(dstates (set-of-elements dfa-start-state))
(dtrans (set-of-elements))
)
(do ()
((null? unmarked-dstates) (make-subset-dfa (reverse dstates) (reverse dtrans) nfa))
(let ((first-unmarked-dstate (first unmarked-dstates)))
(set! unmarked-dstates (cdr unmarked-dstates))
(for-each
(lambda (input-symbol)
(let ((u (if support-epsilon-moves?
(epsilon-closure-set (subset-move nfa first-unmarked-dstate input-symbol) nfa)
(subset-move nfa first-unmarked-dstate input-symbol))))
(if (not (null? u))
(begin
(if (not (member-by-predicate u dstates subset-state-equal?))
(begin
(set! dstates (cons u dstates))
(set! unmarked-dstates (cons u unmarked-dstates))))
(let ((new-transition
(make-automaton-transition first-unmarked-dstate input-symbol u)))
(set! dtrans (cons new-transition dtrans)))))))
input-symbols)))))))
(define (make-subset-dfa states transition-list nfa)
(let* ((nfa-final-states (final-states-of-finite-state-automaton nfa))
(number-of-states (length states))
(new-states (number-interval 0 (- number-of-states 1)))
(old-new-state-map (map (lambda (old-state new-state) (cons old-state new-state)) states new-states)))
(letrec ((old-to-new
(lambda (old-state)
(get-by-predicate old-state old-new-state-map subset-state-equal?))))
(make-finite-state-automaton
(first new-states)
(map old-to-new (filter (lambda (old-state) (not (null? (intersection-by-predicate old-state nfa-final-states state-equal?)))) states))
(map
(lambda (subset-transition)
(make-automaton-transition
(old-to-new (from-state-of-transition subset-transition))
(symbol-of-transition subset-transition)
(old-to-new (to-state-of-transition subset-transition))))
transition-list)
(symbol-map-of-finite-state-automaton nfa)
))))
(define (epsilon-closure-single-state nfa-state nfa)
(epsilon-closure-1 nfa-state nfa (list nfa-state)))
(define (epsilon-closure-set nfa-state-set nfa)
(state-subset-normalize (flatten (map (lambda (nfa-state) (epsilon-closure-single-state nfa-state nfa)) nfa-state-set))))
(define (epsilon-closure-1 nfa-state nfa diregarded-end-states)
(let* ((relevant-transitions
(filter
(lambda (trans) (and (state-equal? (from-state-of-transition trans) nfa-state) (epsilon-transition? trans)))
(transition-list-of-finite-state-automaton nfa)))
(end-states (state-subset-normalize (map to-state-of-transition relevant-transitions)))
(end-states-filtered (filter (lambda (dis-state) (not (member-by-predicate dis-state diregarded-end-states state-equal?))) end-states))
)
(state-subset-normalize
(append
(list nfa-state)
end-states-filtered
(flatten (map (lambda (state) (epsilon-closure-1 state nfa (append diregarded-end-states end-states-filtered))) end-states-filtered)))
)))
(define (intersection-by-predicate lst1 lst2 pred)
(cond ((null? lst1) '())
((member-by-predicate (car lst1) lst2 pred)
(cons (car lst1)
(intersection-by-predicate (cdr lst1) lst2 pred)))
(else (intersection-by-predicate (cdr lst1) lst2 pred))))
(define (get-by-predicate key a-list pred)
(let ((res (assq-by-predicate key a-list pred)))
(if (pair? res)
(cdr res)
(error (string-append "Get: Cannot find " (as-string key) " in " (as-string a-list))))))
(define (assq-by-predicate key a-list pred)
(cond ((null? a-list) #f)
((pred key (caar a-list)) (car a-list))
(else (assq-by-predicate key (cdr a-list) pred))))
(define (subset-move nfa nfa-state-set symbol)
(let* ((nfa-transitions (transition-list-of-finite-state-automaton nfa))
(relevant-transitions
(filter
(lambda (trans)
(and (member-by-predicate (from-state-of-transition trans) nfa-state-set state-equal?)
(symbol-equal? symbol (symbol-of-transition trans))))
nfa-transitions))
)
(state-subset-normalize (map to-state-of-transition relevant-transitions))))
(define (state-subset-normalize state-subset)
(remove-duplicates-by-predicate
(sort-list state-subset state-leq?)
state-equal?))
(define (subset-state-equal? state-set1 state-set2)
(if (= (length state-set1) (length state-set2))
(let ((eq-pairs (map (lambda (s1 s2) (state-equal? s1 s2))
state-set1 state-set2)))
(accumulate-right and-fn #t eq-pairs))
#f))
(define (and-fn x y) (and x y))
(define (make-unique-symbol-list lgt)
(map (lambda (n) (as-symbol (special-number-in-base n 26))) (number-interval 1 lgt)))
(define (special-number-in-base n base)
(if (= n 0) "a"
(let ((ciffer-list (reverse (special-ciffers-in-base n base))))
(special-ciffer-output ciffer-list))))
(define (special-ciffers-in-base n base)
(if (= n 0)
'()
(let ((rem (modulo n base))
(newn (quotient n base)))
(cons rem (special-ciffers-in-base newn base)))))
(define (special-ciffer-output ciffer-list)
(apply string-append
(map special-ciffer-translation ciffer-list)))
(define (special-ciffer-translation c)
(cond ((and (>= c 0) (< c 26)) (make-string 1 (integer->char (+ c 97))))
(t "?")))
(define unknown-symbol (as-symbol (special-number-in-base 100000 26)))
(define (alphabet-of-automaton-transitions transition-list)
(remove-duplicates-by-predicate
(filter
(lambda (s) (not (epsilon-symbol? s)))
(map symbol-of-transition transition-list)) symbol-equal?))
(define (make-automaton-symbol-map alphabet-symbols)
(let ((unique-symbol-list (make-unique-symbol-list (length alphabet-symbols))))
(list->vector
(sort-list
(map (lambda (s us) (cons s us)) alphabet-symbols unique-symbol-list)
(lambda (pair1 pair2) (string<=? (as-string (car pair1)) (as-string (car pair2))))))))
(define (compacted-transitions transitions symbol-map)
(map
(lambda (trans)
(let ((fr (from-state-of-transition trans))
(sy (symbol-of-transition trans))
(to (to-state-of-transition trans)))
(make-automaton-transition fr (get-compact-automata-symbol sy symbol-map) to)))
transitions))
(define (symbol-leq? s1 s2)
(string<=? (symbol->string s1) (symbol->string s2)))
(define problem-map #f)
(define (get-compact-automata-symbol sy symbol-map . optional-parameter-list)
(let ((default-result (optional-parameter 1 optional-parameter-list #f)))
(if (epsilon-symbol? sy)
epsilon-symbol
(let ((search-res (binary-search-in-vector symbol-map sy car eq? symbol-leq?)))
(if search-res
(cdr search-res)
(if default-result
default-result
(laml-error "get-compact-automata-symbol: Cannot find value of symbol" sy "in" symbol-map)))))))