mf-bug.rkt

#! /bin/sh
 #|
 exec racket -tm "$0" ${1+"$@"}
 |#
 
 #lang racket
 
 (provide main)
 
 ;; accept the shortest sequence of LetterKeyEvents that match some = regular exp. 
;; =  --------------------------------------------------------------------------= -------------------------
 
 (require 2htdp/universe 2htdp/image rackunit)
 
 (require xml/xml)
 ;; should come with the above:
 (define-syntax-rule
   (element-named-attributes msg name:id ...)
   ;; XML-Element -> [Listof String]
   (lambda (e)
     (match (element-attributes e)
       [(list-no-order (attribute _ _ 'name:id name:id) ...)
        (values name:id ...)]
       [else (error 'parse (format msg e))])))
 
 ;; XML-Element Symbol *->* [Listof XML-Element]
 ;; retrieve all elements with name n in name*
 (define (elements-named-content e . name*)
   (define c (filter element? (element-content e)))
   (define l
     (for/list ((n name*)) (filter (lambda (x) (eq? (element-name x) n)) 
 c)))
   (unless (= (- (length c) (apply + (map length l))) 0)
     (displayln (- (length c) (length l)))
     (for ((e c))
       (unless (memq e l)
         (displayln `(not found ,e))))
     (error 'element-named-elements "too many [~s] elements: ~e" name* 
 l))
   (apply values l))
 
 ;; = --------------------------------------------------------------------------= -------------------------
 ;; THE MAIN FUNCTION=20
 
 ;; String[File] -> "d" or "error"
 (define (main f)
   (with-handlers ((exn:fail? (lambda (e) (displayln (exn-message e)))))
     (define x:xml (with-input-from-file f read-xml/element))
     (define x:fsm (parse x:xml))
     (accept x:fsm)
     (sleep 1)))
    
 ;; = --------------------------------------------------------------------------= -------------------------
 ;; Parse the XML into the internal FSM data structure=20
 
 ;; Any -> FSM=20
 ;; parse the given=20
 
 (module+ test=20
   (define (read-parse xml0:string)
     (parse (read-xml/element (open-input-string xml0:string))))
   (define xml0:string
     #<<eos
     <fsm initial=3D"a">
        <final name=3D"d"></final>
        <transition current=3D"a" next=3D"bc">
           <action value=3D"a"></action>
        </transition>
        <transition current=3D"bc" next=3D"bc">
           <action value=3D"b"></action>
           <action value=3D"c"></action>
        </transition>
        <transition current=3D"bc" next=3D"d">
          <action value=3D"d"></action>
        </transition>
     </fsm>
eos
     )
   (check-equal? (read-parse xml0:string) fsm0)
  
   (define xml0-b:string
     #<<eos
     <fsm initial=3D"a">
        <final name=3D"d" />
        <transition current=3D"a" next=3D"bc">
           <action value=3D"a" />
        </transition>
        <transition current=3D"bc" next=3D"bc">
           <action value=3D"b" />
           <action value=3D"c" />
        </transition>
        <transition current=3D"bc" next=3D"d">
          <action value=3D"d" />
        </transition>
     </fsm>
eos
     )
   (check-equal? (read-parse xml0-b:string) fsm0))
 
 (define (parse x)
   ;; parse does not check the names of states because all strings are  allowed
   (define (<fsm> x)
     (define parse-initial
       (element-named-attributes "not an initial: ~e" initial))
     (define (<finals> e*)
       (map (element-named-attributes "not a final specification: ~e" 
 name) e*))
     (define (<transition*> e*)
       (define (<transition> e)
         (define-values (c n) ((element-named-attributes "not a 
 transition: ~e" current next) e))
         (define k* (elements-named-content e 'action))
         (transition c (map (compose key>>> (element-named-attributes 
 "not an action:" value)) k*) n))
       (map <transition> e*))
     (define (key>>> x)
       (unless (and (= (string-length x) 1) (regexp-match 
 #px"\\d|[a-zA-Z]" x))
         (error "not an alphanumeric key: ~e" x))
       x)
     ;; -- IN --=20
     (unless (eq? (element-name x) 'fsm) (error 'parse "not an fsm: ~e" 
 x))
     (define-values (f t) (elements-named-content x 'final 'transition))
     (fsm (parse-initial x) (<finals> f) (<transition*> t)))
   ;; -- IN --=20
   (<fsm> x))
 
 ;; = --------------------------------------------------------------------------= -------------------------
 ;; deal with one FSM=20
 
 ;; FSM        =3D (fsm State [List-of State] [List-of Transition])
 ;; State      =3D String=20
 ;; Transition =3D (transition State [List-of LetterKeyEvent] State)
 
 (struct fsm (initial finals transitions) #:transparent)
 (struct transition (current keys next) #:transparent)
 
 (define ER "error")
 (define state? string?)
 (define state=? string=?)
 
 ;; EXAMPLE: a(b|c)*d
 (define AA "a")
 (define BC "bc")
 (define DD "d")
 
 (define t*
   (list (transition AA (list "a") BC)
         (transition BC (list "b" "c") BC)
         (transition BC (list "d") DD)))
 (define i0 AA)
 (define f* (list DD))
 (define fsm0 (fsm i0 f* t*))
 
 ;; = --------------------------------------------------------------------------= ---
 ;; GRAPHICAL CONSTANTS
 (define SIZE 100)
 (define white  (square SIZE "solid" "white"))
 (define yellow (square SIZE "solid" "yellow"))
 (define green  (square SIZE "solid" "green"))
 (define red    (square SIZE "solid" "red"))
 
 ;; = --------------------------------------------------------------------------= ---
 ;; FSM -> State or "unacceptable"
 (define (accept fsm)
   (define i0 (fsm-initial fsm))
   (define f* (fsm-finals fsm))
   (big-bang i0
             (on-key (next (fsm-transitions fsm)))
             (to-draw (image i0 f*))
             (stop-when (lambda (w) (cons? (member w (cons ER f*)))))))
 
 ;; = --------------------------------------------------------------------------= ---
 ;; Transition* State KeyEvent -> State=20
 ;; retrieve the next state from a (transition ...) in t* such that ...
 ;; if there is no such transition, signal the error "can't happen"
 
 (module+ test
   (check-equal? ((next t*) AA "a") BC)
   (check-equal? ((next t*) AA "b") ER)
   (check-equal? ((next t*) AA "c") ER)
   (check-equal? ((next t*) AA "d") ER)
   (check-equal? ((next t*) AA "e") ER)
   (check-equal? ((next t*) AA "left") ER)
  
   (check-equal? ((next t*) BC "a") ER)
   (check-equal? ((next t*) BC "b") BC)
   (check-equal? ((next t*) BC "c") BC)
   (check-equal? ((next t*) BC "d") DD)
   (check-equal? ((next t*) BC "e") ER)
   (check-equal? ((next t*) BC "left") ER)
  
   (check-equal? ((next t*) DD "a") ER))
 
 (define ((next t*) current ke)
   (or (for/or ((t t*))
         (and (state=? (transition-current t) current)
              (member ke (transition-keys t))
              (transition-next t)))
       ER))
 
 ;; = --------------------------------------------------------------------------= ---
 ;; State State [Listof State] -> Image=20
 ;; render state as image=20
 
 (module+ test
   (check-equal? ((image i0 f*) AA) white)
   (check-equal? ((image i0 f*) BC) yellow)
   (check-equal? ((image i0 f*) DD) green)
   (check-equal? ((image i0 f*) ER) red))
 
 (define ((image initial finals) current)
   (cond
     [(state=? current initial) white]
     [(member current finals) green]
     [(state=? current ER) red]
     [else yellow]))