(module automaton mzscheme
(require (prefix a: "ahocorasick.ss")
(prefix s: "state.ss")
(prefix q: "queue.ss"))
(require (lib "list.ss"))
(provide ahocorasick->sexp)
(define *state-counter* 0)
(define *state-hash-table* (make-hash-table))
(define (new-state-name)
(set! *state-counter* (add1 *state-counter*))
(string->symbol (string-append "state-" (number->string *state-counter*))))
(define (reset-state-parameters!)
(set! *state-counter* 0)
(set! *state-hash-table* (make-hash-table)))
(define state-name
(lambda (tree state)
(let ((lookup (hash-table-get *state-hash-table* state (lambda () #f))))
(when (not lookup)
(hash-table-put! *state-hash-table* state
(if (eq? state (a:root tree))
'root
(new-state-name))))
(hash-table-get *state-hash-table* state))))
(define-syntax set-front!
(syntax-rules ()
[(set-front! pair-var val)
(set! pair-var (cons val pair-var))]))
(define (ahocorasick->sexp tree)
(define collected-state-sexps ())
(define (s-name state)
(state-name tree state))
(define (visit state)
(let [(sexp-rev (list ': (s-name state)))]
(when (not (empty? (s:output state)))
(set-front! sexp-rev (list 'outputs (s:output state))))
(let loop ((outs (s:out-labels state)))
(when (not (empty? outs))
(set-front! sexp-rev (list (first outs)
'->
(s-name (s:goto state (first outs)))))
(loop (rest outs))))
(if (not (eq? (a:root tree) state))
(set-front! sexp-rev (list 'fail '-> (s-name (s:fail state))))
(set-front! sexp-rev (list 'else '-> (s-name state))))
(set-front! collected-state-sexps (reverse sexp-rev))))
(begin
(reset-state-parameters!)
(s:breadth-first visit (q:insert q:empty (a:root tree)))
(append '(automaton root) (reverse collected-state-sexps))))
)