;;; FSA algebra, forming new FSA's from simpler ones

;; helpers

(define (fsa-transitions-project fsa old-states new-states)
  "return transitions of fsa from states in old-states so that they have
  been projected into transitions from each state in new-states.  This is
  equivalent to adding an epsilon transition from all states in old-states
  to all states in new-states."
  (crossmap transition-project (fsa-transitions-from fsa old-states) new-states))

(define (transitions-intersect trs1 trs2 statemap)
  "return a list of transitions that has, for each pair of transitions
  t1 in trs1 and t2 in trs2, for each possible input a new transition tr
  that could be made if automaton1 is in t1 and automaton2 is in t2"
  (define (find st1 st2) (statemap (list st1 st2)))
  (append-map
    (lambda (tr1)
      (filter-map
	(lambda (tr2)
	  (let ((input-set
		  (input-set-intersection (transition-input tr1)
					  (transition-input tr2))))
	    (and (not (null? input-set))
		 (let ((src-state (find (transition-state tr1)
					(transition-state tr2)))
		       (dst-state (find (transition-destination tr1)
					(transition-destination tr2))))
		   (make-transition src-state input-set dst-state)))))
	trs2))
    trs1))

(define (fsa-complement-transitions-into fsa goal)
  "return a list of transitions that has, for each state of fsa, a transition
  for all _other_ inputs from that state into state goal"
  (filter-map
    (lambda (state)
      (let* ((inputs (fold input-set-union (make-input)
			   (map transition-input
				(fsa-transitions-from fsa (list state)))))
	     (input-set (input-set-complement inputs)))
	(and (not (null? input-set))
	     (make-transition state input-set goal))))
    (fsa-states fsa)))

;; concatenation, union, Kleene star (repetition), intersection, complement

(define (fsa-concat fsa1 fsa2)
  "return a fsa that accepts an input which is a concatenation of input
  accepted by fsa1 and input accepted by fsa2.  The resulting fsa shares
  states with fsa1 and fsa2 and is not guaranteed to be minimal even if
  fsa1 and fsa2 are.
  > (fsa-concat (fsa-item 'foo) (fsa-any-item)) =>
  '(fsa S7 (S10) ((S8 (not) S10) (S9 (not) S10) (S7 foo S8))) "
  (let* ((collapse-state (fsa-start-state fsa2))
	 (conn-states (fsa-goal-states fsa1))
	 (new-transitions
	   (fsa-transitions-project fsa2 (list collapse-state) conn-states))
	 (new-goals (if (state-in? collapse-state (fsa-goal-states fsa2))
		      conn-states '())))
    (make-fsa (fsa-start-state fsa1) (append new-goals (fsa-goal-states fsa2))
	      (append new-transitions
		      (fsa-transitions fsa2) (fsa-transitions fsa1)))))

(define (fsa-union fsa1 fsa2)
  "return a fsa that accepts an input if it is accepted by either fsa1
  or by fsa2.  The resulting fsa shares states with fsa1 and fsa2 and is
  not guaranteed to be minimal even if fsa1 and fsa2 are.
  > (fsa-union (fsa-success) (fsa-item 'bar)) =>
  '(fsa S14 (S14 S11 S13) ((S14 bar S13) (S12 bar S13))) "
  (let* ((input-fsas (list fsa1 fsa2))
	 (collapse-states (map fsa-start-state input-fsas))
	 (conn-state (make-combined-state collapse-states "/"))
	 (new-fsa (make-fsa conn-state
			    (append-map fsa-goal-states input-fsas)
			    (append-map fsa-transitions input-fsas)))
	 (new-transitions
	   (fsa-transitions-project new-fsa collapse-states (list conn-state)))
	 (new-goals (if (any (lambda (state)
			       (state-in? state (fsa-goal-states new-fsa)))
			     collapse-states)
		      (list conn-state) '())))
    (make-fsa conn-state (append new-goals (fsa-goal-states new-fsa))
	      (append new-transitions (fsa-transitions new-fsa)))))

(define (fsa-repeat-nonempty fsa)
  "return a fsa that accepts an input where there are any number, except
  0, of inputs accepted by fsa, concatenated.  The resulting fsa shares
  states with the argument fsa.
  > (fsa-repeat-nonempty (fsa-concat (fsa-item #\a) (fsa-item #\b))) =>
  '(fsa S15 (S18) ((S18 #\a S16) (S16 #\b S18) (S17 #\b S18) (S15 #\a S16))) "
  (let* ((start-state (fsa-start-state fsa))
	 (new-transitions (fsa-transitions-project
			    fsa (list start-state) (fsa-goal-states fsa))))
    (make-fsa start-state (fsa-goal-states fsa)
	      (append new-transitions (fsa-transitions fsa)))))

(define (fsa-repeat fsa)
  "return a fsa that accepts an input where there are any number,
  including 0, of inputs accepted by fsa, concatenated.  The resulting
  fsa shares states with the argument fsa and is not guaranteed to be
  minimal even if fsa is.
  > (fsa-repeat (fsa-any-item)) =>
  '(fsa S22 (S22 S20 S21) ((S22 (not) S20) (S20 (not) S20) (S19 (not) S20))) "
  (fsa-union (fsa-repeat-nonempty fsa) (fsa-success)))

(define (fsa-intersect fsa1 fsa2)
  "return a fsa that accepts an input if it is accepted by both fsa1 and
  fsa2.  The resulting fsa does _not_ share states with the argument fsa
  and is not guaranteed to be minimal even if fsa1 and fsa2 are.
  > (fsa-intersect (fsa-item 'foo) (fsa-item 'bar)) => '(fsa S27 (S30) ())
  > (fsa-intersect (fsa-item 'foo) (fsa-complement (fsa-item 'foo))) =>
  '(fsa S6 (S10 S9) ((S7 foo S10) (S8 foo S10) (S6 foo S11)))
  > (fsa-intersect (fsa-any-item) (fsa-repeat (fsa-item 'z))) =>
  '(fsa S31 (S35 S36 S37) ((S31 z S36) (S32 z S36) (S34 z S36))) "
  (let ((statemap (make-statemap)))
    (define (find st1 st2) (statemap (list st1 st2)))
    (make-fsa (find (fsa-start-state fsa1) (fsa-start-state fsa2))
	      (crossmap find (fsa-goal-states fsa1) (fsa-goal-states fsa2))
	      (transitions-intersect (fsa-transitions fsa1)
				     (fsa-transitions fsa2) statemap))))

(define (fsa-complement fsa)
  "return a fsa that accepts exactly the inputs that fsa rejects.  The
  resulting fsa is not guaranteed to be minimal even if fsa is.
  > (fsa-complement (fsa-item 'foo)) =>
  '(fsa S43 (S45 S43) ((S45 (not) S45) (S43 (not . foo) S45) (S44 (not) S45) (S43 foo S44)))
  > (fsa-complement (fsa-repeat (fsa-any-item))) =>
  '(fsa S51 (S52 S48) ((S52 (not) S52) (S50 (not) S52) (S51 (not) S49) (S49 (not) S49) (S48 (not) S49))) "
  (let* ((fsa (fsa-determinise fsa))
	 (start-state (fsa-start-state fsa))
	 (goal-state (generate-state "goal")))
    (make-fsa (fsa-start-state fsa)
	      (cons goal-state
		    (lset-difference
		      eq? (fsa-states fsa) (fsa-goal-states fsa)))
	      (cons (make-transition goal-state (make-input-except) goal-state)
		    (append (fsa-complement-transitions-into fsa goal-state)
			    (fsa-transitions fsa))))))