; Copyright 2010 William D Clinger.
;
; Permission to copy this software, in whole or in part, to use this
; software for any lawful purpose, and to redistribute this software
; is granted subject to the restriction that all copies made of this
; software must include this copyright notice in full.
;
; I also request that you send me a copy of any improvements that you
; make to this software so that they may be incorporated within it to
; the benefit of the Scheme community.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; DFA simulator, written as an R6RS Scheme top-level program
; with two local libraries.
;
; Simulates unidirectional single-tape Turing Machines
; as formalized in Michael Sipser's textbook,
; Introduction to the Theory of Computation, Second Edition,
; Thompson Course Technology, 2006.
; 
; Usage will vary depending on your implementation of R6RS Scheme.
;
; Usage in Larceny:
;
; larceny --r6rs --program dfa.sps -- <machine> <input>
;
; where <machine> is the name of a file containing a description
; of a DFA as specified by the grammar below, and <input> is the
; name of a file containing an input for the DFA.  The <input>
; may be omitted, in which case the input is taken from standard
; input.
;
; <DFA>  -->  <DESC>  |  <DESC> <DFA>
; <DESC>  -->  state <NAME> <TRANSITIONS>
;           |  accept <NAME> <TRANSITIONS>
; <NAME>  -->  <symbol>
; <TRANSITIONS>  -->
;                  |  <symbol> => <NAME> <TRANSITIONS>
;                  |  <number> => <NAME> <TRANSITIONS>
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Parser for DFA descriptions written according to the following
; grammar:
;
; <DFA>  -->  <DESC>  |  <DESC> <DFA>
; <DESC>  -->  state <NAME> <TRANSITIONS>
;           |  accept <NAME> <TRANSITIONS>
; <NAME>  -->  <symbol>
; <TRANSITIONS>  -->
;                  |  <symbol> => <NAME> <TRANSITIONS>
;                  |  <number> => <NAME> <TRANSITIONS>
; 
; Usage:
;
;     (parse-dfa input)
;
; where input is one of the following:
;     a list of Scheme datums
;     an input port
;     a string naming an input file
;
; The output is a representation acceptable to run-dfa.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(library (local parse-dfa)
  (export parse-dfa basic-parse-test1 basic-parse-test2)
  (import (rnrs base)
          (rnrs io simple))

(define (parse-dfa input)
  (cond ((list? input)
         (parse input))
        ((input-port? input)
         (let loop ((tokens '()))
           (let ((x (read input)))
             (if (eof-object? x)
                 (parse (reverse tokens))
                 (loop (cons x tokens))))))
        ((string? input)
         (call-with-input-file input parse-dfa))
        (else
         (error 'parse-dfa "illegal input" input))))

; Given a list of tokens as input,
; returns a representation of the DFA.

(define (parse input)
  (call-with-values
   (lambda () (parse-description input))
   (lambda (description input)
     (if (null? input)
         (list description)
         (cons description
               (parse input))))))

; Given an input that begins with a description,
; returns two values:
;     a representation of the state described by the description
;     the rest of the input following the description

(define (parse-description input)
  (cond ((null? input)
         (parse-error input 'description))
        ((eq? 'state (car input))
         (parse-description2 (cdr input) #f))
        ((eq? 'accept (car input))
         (parse-description2 (cdr input) #t))
        (else
         (parse-error input 'description))))

(define (parse-description2 input accepting?)
  (cond ((null? input)
         (parse-error input 'state-name))
        ((symbol? (car input))
         (parse-description3 (cdr input) accepting? (car input) '()))
        (else
         (parse-error input 'state-name))))

(define (parse-description3 input accepting? name transitions)
  (cond ((or (null? input)
             (eq? 'state (car input))
             (eq? 'accept (car input)))
         (values (cons name (cons accepting? (reverse transitions)))
                 input))
        ((and (>= (length input) 3)
              (or (symbol? (car input))
                  (number? (car input)))
              (eq? '=> (cadr input))
              (symbol? (caddr input)))
         (parse-description3 (cdddr input)
                             accepting?
                             name
                             (cons (list (car input) (caddr input))
                                   transitions)))
        (else
         (parse-error input 'description))))

(define (parse-error input expected)
  (error 'parse-error
         "syntax error while parsing DFA"
         expected
         input))

(define (basic-parse-test1)
  (define ends01
    '(state  start 0 => s0   1 => s1
      state  s0    0 => s00  1 => s01
      state  s1    0 => s10  1 => s11
      state  s00   0 => s00  1 => s01
      accept s01   0 => s10  1 => s11
      state  s10   0 => s00  1 => s01
      state  s11   0 => s10  1 => s11))
  (parse-dfa ends01))

(define (basic-parse-test2)
  (define length3
    '(accept s0 * => s1
      state  s1 * => s2
      state  s2 * => s0))
  (parse-dfa length3))

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; DFA simulator, written as an R6RS Scheme library.
;
; Simulates unidirectional single-tape Turing Machines
; as formalized in Michael Sipser's textbook,
; Introduction to the Theory of Computation, Second Edition,
; Thompson Course Technology, 2006.
; 
; Usage:
;
;     (run dfa input)
;     (run dfa input output-port)
;
; where dfa is the description of a deterministic finite automaton
; and input is a list of symbols and numbers.
;
; A trace will be written to the output-port,
; or to the current output port is no output-port is specified.
; Warning and/or error messages may be written to the current error port.
;
; Returns a boolean (#t means accept, #f means reject or stuck).
; 
; The description of the DFA to be simulated looks like
;
;     ((state accepts? (sym next) ...) ...)
;
; where state and next are states,
; accepts? is a boolean (#t iff state is an accepting state),
; and sym is an input symbol (a symbol or number).
; 
; The symbol * acts as a wildcard that matches any input symbol.
; 
; The input is represented as a list of input symbols,
; which should be Scheme symbols and/or numbers.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(library (local dfa)
  (export run basic-tests)
  (import (rnrs base)
          (rnrs control)
          (rnrs lists)
          (rnrs io simple)
          (rnrs files))

; Given the description of a DFA as described above,
; an input,
; and an optional output file name or output port,
; the simulator returns a boolean indicating whether
; the DFA accepts the input.
;
; If the optional output file or port is specified,
; then an execution trace is output to that file or port.
; Otherwise the trace will be written to the current output port.
; The trace will be more readable if all input symbols
; have the same length.

(define (run dfa input . rest)
  (if (null? rest)
      (run-dfa dfa input (current-output-port))
      (run-dfa dfa input (car rest))))

; Given the description of a Turing machine,
; an input,
; and an optional output file name or output port,
; the simulator returns two values (if it returns at all):
;     a boolean (#t means accept, #f means reject)
;     the tape contents when the machine halted
;
; If the optional output file or port is specified,
; then a trace of the Turing machine's execution
; is output to that file or port.
; The trace will be more readable if all tape symbols
; have the same length.

(define (run-dfa dfa input . rest)
  (if (null? rest)
      (simulate-dfa dfa input #f)
      (let ((x (car rest)))
        (cond ((string? x)
               (delete-file x)
               (call-with-output-file
                x
                (lambda (out) (simulate-dfa dfa input out))))
              ((output-port? x)
               (simulate-dfa dfa input x))
              (else
               (error 'run-dfa
                      "invalid optional argument to run-dfa"
                      x))))))

; Accessors for a state's information.

(define state-accepts? cadr)
(define state-transitions cddr)

; Accessors for the components of a transition.

(define transition-symbol car)
(define transition-next cadr)

; Given a description of a DFA,
; an input, and an output port (or #f),
; simulates the DFA on the input
; while writing a trace to the output port.

(define (simulate-dfa dfa input out)
  (if (and (list? dfa)
           (list? input)
           (or (eqv? out #f)
               (output-port? out))
           (not (null? dfa))
           (for-all list? dfa)
           (for-all (lambda (x) (or (symbol? x) (number? x))) input)
           (for-all (lambda (n) (>= n 2)) (map length dfa))
           (for-all symbol? (map car dfa))
           (for-all boolean? (map state-accepts? dfa))
           (let ((transition-lists (map state-transitions dfa)))
             (and (for-all (lambda (transitions)
                             (and (for-all list? transitions)
                                  (for-all
                                   (lambda (transition)
                                     (and (= 2 (length transition))
                                          (let ((sym (transition-symbol
                                                      transition))
                                                (next (transition-next
                                                       transition)))
                                            (and (or (symbol? sym)
                                                     (number? sym))
                                                 (symbol? next)))))
                                   transitions)))
                           transition-lists))))
      (let ((start (caar dfa)))
        (simulate dfa (list->vector input) 0 start out))
      (error 'simulate-dfa
             "invalid argument to simulate-dfa"
             dfa input out)))

; Given a description of a DFA,
; a vector representing the complete input,
; an index into that vector representing the next input symbol,
; the current state,
; and an output port (or #f),
; simulates the DFA on the input
; while writing a trace to the output port.

(define (simulate dfa input head q out)
  (display-state! input head q out)
  (let ((state-info (assq q dfa)))
    (cond ((not state-info)
           (error 'simulate "unknown state" q))
          ((= head (vector-length input))
           (state-accepts? state-info))
          (else
           (let ((transitions (state-transitions state-info)))
             (let ((transition (assv (vector-ref input head) transitions)))
               (if transition
                   (let ((next (transition-next transition)))
                     (simulate dfa
                               input
                               (+ head 1)
                               next
                               out))
                   (let ((transition (assq '* transitions)))
                     (if transition
                         (let ((next (transition-next transition)))
                           (simulate dfa
                                     input
                                     (+ head 1)
                                     next
                                     out))
                         (begin
                          (display "no transition for current state"
                                   (current-error-port))
                          (newline (current-error-port))
                          #f))))))))))

; Outputs appropriate message and returns appropriate values.

(define (accept tape head out)
  (if out
      (begin
       (display "Accepted" out)
       (newline out)))
  #t)

(define (reject tape head out)
  (if out
      (begin
       (display "Rejected" out)
       (newline out)))
  #f)

; Displays the current state.

(define (display-state! input head q out)
  (do ((i 0 (+ i 1)))
      ((>= i head))
    (display " " out)
    (write (vector-ref input i) out))
  (display "@" out)
  (if (< head (vector-length input))
      (write (vector-ref input head) out))
  (do ((i (+ head 1)
       (+ i 1)))
      ((>= i (vector-length input)))
    (display " " out)
    (write (vector-ref input i) out))
  (if (< head (vector-length input))
      (display " " out))
  (display "   " out)
  (write q out)
  (newline out))

; Accepts binary numerals ending in 10.

(define (basic-tests)
  (define ends10
    '((start #f (0 s0) (1 s1))
      (s0  #f (0 s00) (1 s01))
      (s1  #f (0 s10) (1 s11))
      (s00 #f (0 s00) (1 s01))
      (s01 #f (0 s10) (1 s11))
      (s10 #t (0 s00) (1 s01))
      (s11 #f (0 s10) (1 s11))))
  (define length4
    '((s0 #f (* s1))
      (s1 #f (* s2))
      (s2 #f (* s3))
      (s3 #f (* s4))
      (s4 #t (* s5))
      (s5 #f (* s5))))
  (write
   (run-dfa ends10 '(0 1 1 1 0 1 1 0) (current-output-port)))
  (newline)
  (write
   (run-dfa length4 '(a b c d e f) (current-output-port)))
  (newline))

;(basic-tests)

)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; DFA simulator, written as an R6RS Scheme top-level program.
;
; Simulates unidirectional single-tape Turing Machines
; as formalized in Michael Sipser's textbook,
; Introduction to the Theory of Computation, Second Edition,
; Thompson Course Technology, 2006.
; 
; Usage varies depending on the implementation of R6RS Scheme.
; Usage in Larceny:
;
; larceny --r6rs --program dfa.sps -- <machine> <input>
;
; where <machine> is the name of a file containing a description
; of a DFA as specified by the grammar below, and <input> is the
; name of a file containing an input for the DFA.  The <input>
; may be omitted, in which case the input is taken from standard
; input.
;
; <DFA>  -->  <DESC>  |  <DESC> <DFA>
; <DESC>  -->  state <NAME> <TRANSITIONS>
;           |  accept <NAME> <TRANSITIONS>
; <NAME>  -->  <symbol>
; <TRANSITIONS>  -->
;                  |  <symbol> => <NAME> <TRANSITIONS>
;                  |  <number> => <NAME> <TRANSITIONS>
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import (rnrs)
        (local parse-dfa)
        (local dfa))

(define usage-message
  "larceny --r6rs --program dfa.sps -- <machine> <input>")

(define (read-input in)
  (let loop ((tokens '()))
    (let ((x (read in)))
      (if (eof-object? x)
          (reverse tokens)
          (loop (cons x tokens))))))

(define files (command-line))

(if (not (<= 2 (length files) 3))
    (error #f usage-message))

(define dfa (parse-dfa (cadr files)))

(define input
  (if (= (length files) 2)
      (read-input (current-input-port))
      (call-with-input-file (caddr files) read-input)))

(let ((okay? (run dfa input (current-output-port))))
  (display (if okay? "Accepted" "Rejected"))
  (newline))