;;; finite state automaton -- the data structure

;; a state is represented by a symbol.

;; generic helper(s)

(define (tagged? tag obj) (and (pair? obj) (eq? tag (car obj))))

;; states

; version that gives states informative names, for debugging etc.
;
;(define generate-state
;  (let ((counter 0) (existing-states '(success failure)))
;    (lambda maybe-prefix
;      (let retry ((prefix (if (null? maybe-prefix)
;			    "state" (car maybe-prefix))))
;	(let ((state (string->symbol prefix)))
;	  (if (state-in? state existing-states)
;	    (begin
;	      (set! counter (+ counter 1))
;	      (retry (string-append prefix "-" (number->string counter))))
;	    (begin
;	      (set! existing-states (cons state existing-states))
;	      state)))))))

; version that just numbers states
(define generate-state
  (let ((counter 0))
    (lambda ign
      "return a new state (distinct symbol)
      > (generate-state) => 'S1
      > (state=? (generate-state) (generate-state)) => #f "
      (set! counter (+ counter 1))
      (string->symbol (string-append "S" (number->string counter))))))

(define state=? eq?)
(define state-in? memq)

(define (symbol<? s1 s2)
  (string<? (symbol->string s1) (symbol->string s2)))

(define (make-combined-state states separator)
  "return a new state named after the list of states in states"
  (generate-state
    (let join ((rest states))
      (cond ((null? rest) "unknown")
	    ((null? (cdr rest)) (symbol->string (car rest)))
	    (else (string-append (symbol->string (car rest))
				 separator
				 (join (cdr rest))))))))

(define (make-statemap)
  (let ((statemap '()))
    (lambda (state-set)
      (let ((set (sort state-set symbol<?)))
	(cond ((assoc set statemap) => cadr)
	      (else
		(let ((state (make-combined-state set "+")))
		  (set! statemap (cons (list set state) statemap))
		  state)))))))

;; input sets

; a set of inputs is either
; - some verbatim input token
; - a list beginning with symbol "in", listing possible input tokens
; - a pair whose car is the symbol "not", and whose cdr is a set of inputs.

; an input set is a definition of the input symbol(s) (or chars,
; numbers) that make a transition.  Input sets come in two kinds: either
; they are defined by which inputs belong to them, or they are defined
; by which inputs _don't_ belong to them.

; there are two basic constructors for input sets: make-input creates an
; input set which consists of its argument list, and make-input-except
; creates an input set which consists of the complement of its argument
; list.

(define (list->input-set ls)
  "> (list->input-set '(foo bar baz)) => '(in foo bar baz)"
  (cond ((null? ls) '())
	((null? (cdr ls)) (car ls))
	(else (cons 'in ls))))

(define (input-set->list inps)
  "> (input-set->list 'input) => '(input)"
  (cond ((tagged? 'in inps) (cdr inps))
	((null? inps) '())
	((tagged? 'not inps) (error "input-set->list: complement set" inps))
	(else (list inps))))

(define (make-input . args)
  "> (make-input #\a #\b) => '(in #\a #\b) "
  (list->input-set args))

(define (make-input-except . args)
  "> (make-input-except 'badguy) => '(not . badguy) "
  (cons 'not (list->input-set args)))

; basic input set operations: complement, union, intersection

(define (input-set-complement inps)
  "> (input-set-complement '(not in good bad)) => '(in good bad) "
  (if (tagged? 'not inps) (cdr inps) (cons 'not inps)))

(define (lset-fn->input-set-fn fn)
  (lambda (is1 is2)
    (list->input-set (fn eqv? (input-set->list is1) (input-set->list is2)))))
(define input-set-union-pos (lset-fn->input-set-fn lset-union))
(define input-set-intersect-pos (lset-fn->input-set-fn lset-intersection))
(define input-set-diff-pos (lset-fn->input-set-fn lset-difference))

(define (input-set-union is1 is2)
  "> (input-set-union '(not in good bad) 'bad) => '(not . good) "
  (cond ((and (tagged? 'not is1) (tagged? 'not is2))
	 (cons 'not (input-set-intersect-pos (cdr is1) (cdr is2))))
	((tagged? 'not is1) (cons 'not (input-set-diff-pos (cdr is1) is2)))
	((tagged? 'not is2) (input-set-union is2 is1))
	(else (input-set-union-pos is1 is2))))

(define (input-set-intersection is1 is2)
  "> (input-set-intersection '(not in good bad) 'bad) => '() "
  (cond ((and (tagged? 'not is1) (tagged? 'not is2))
	 (cons 'not (input-set-union-pos (cdr is1) (cdr is2))))
	((tagged? 'not is1) (input-set-diff-pos is2 (cdr is1)))
	((tagged? 'not is2) (input-set-intersection is2 is1))
	(else (input-set-intersect-pos is1 is2))))

; checking for input set membership: input-in?
; other-input points to an input symbol that is guaranteed to be
; distinct from all other inputs

(define other-input '(other))
(define (other-input? input)
  "> (other-input? other-input) => #t "
  (eq? other-input input))

(define (input-in? input input-set)
  "> (input-in? 'foo '(not in bar baz)) => #t "
  (or (eqv? input input-set)
      (and (tagged? 'in input-set) (memv input (cdr input-set)))
      (and (tagged? 'not input-set) (other-input? input))
      (and (tagged? 'not input-set) (not (input-in? input (cdr input-set))))))

;; transitions

; a state transition is a list of
; - the source state
; - a set of inputs that causes the transition
; - the destination state

; constructor and projections

(define make-transition list)
(define transition-state car)
(define transition-input cadr)
(define transition-destination caddr)

(define (transition-project trans state)
  "return transition trans as if it was a transition from given state"
  (cons state (cdr trans)))

(define transition-reverse reverse)

; inputs used in this transition

(define (transition-lexicon tr)
  "return list of inputs this transition specifically mentions
  > (transition-lexicon (make-transition (generate-state) (make-input 'z 'y) (generate-state))) => '(z y) "
  (let ((inps (transition-input tr)))
    (if (tagged? 'not inps) (list other-input) (input-set->list inps))))

;; finite state automata

; a FSA consists of:
; - a start state
; - a list of success states
; - a list of state transitions

; constructor, predicate and projections

(define (make-fsa . args) (cons 'fsa args))
(define (fsa? obj) (tagged? 'fsa obj))
(define fsa-start-state cadr)
(define fsa-goal-states caddr)
(define fsa-transitions cadddr)

; transformer for transition table

(define (fsa-update-transitions! fsa fn)
  (set-car! (cdddr fsa) (fn (fsa-transitions fsa)))
  fsa)

;; compound fsa queries

(define (fsa-states fsa)
  "return all states mentioned in fsa
  > (fsa-states (fsa-item 'foo)) => '(S6 S7) "
  (delete-duplicates
    (append (cons (fsa-start-state fsa) (fsa-goal-states fsa))
	    (map transition-state (fsa-transitions fsa))
	    (map transition-destination (fsa-transitions fsa)))))

(define (fsa-transitions-from fsa states)
  "return all transitions in fsa with some state in states as start state"
  (filter (lambda (trans) (state-in? (transition-state trans) states))
	  (fsa-transitions fsa)))

(define (fsa-transitions-to fsa states)
  "return all transitions in fsa with some state in states as end state"
  (filter (lambda (trans) (state-in? (transition-destination trans) states))
	  (fsa-transitions fsa)))

(define (fsa-transitions-without fsa states)
  "return all transitions in fsa except those that mention some state in states
  > (let ((f (fsa-concat (fsa-item #\y) (fsa-any-item))))
     (fsa-transitions-without f (fsa-start-state f))) => '((S19 (not) S21)) "
  (filter
    (lambda (tr) (and (not (state-in? (transition-state tr) states))
		      (not (state-in? (transition-destination tr) states))))
    (fsa-transitions fsa)))

(define (fsa-state-successors fsa state input)
  "return the state(s) into which fsa would transition from state on input
  > (let ((f (fsa-union (fsa-item #\a) (fsa-any-item)))) 
         (fsa-state-successors f (fsa-start-state f) #\a)) => '(S29 S27) "
  (map transition-destination
       (filter (lambda (trans)
		 (and (state=? state (transition-state trans))
		      (input-in? input (transition-input trans))))
	       (fsa-transitions fsa))))