;; Last modified: 28.05.2002

;;
;; GUI for SEMCD machine (Teachpack)
;; =================================
;;
;; To use this teachpack, select in the menu of DrScheme: Language | Add Teachpack...
;;
;;
;; Provides the following functions:
;;   (stepper1 font-size max-len pairs)  ;; simple version (ragged right, fast)
;;   (stepper2 font-size max-len pairs)  ;; extended version (ragged left, slow)
;;
;;
;; These functions display two consecutive machine states in a window and
;; provide buttons for stepping forwards and backwards.
;;
;; The parameter 'font-size' defines the size of the font used.
;; The parameter 'max-len' defines the width of the window (in # of chars).
;; The parameter 'pairs' contains the trace output of a SEMCD machine, i.e.
;; it must evaluate to list of pairs '(number, state)' where 'state' is
;; either a string (e.g. error message) or a list of five strings (one string
;; for each stack).
;;
;; Example:
;;    (list (list 0 (list "nil" "nil" "nil" "Ap{2} 1 2 : nil" "nil"))
;;          (list 1 (list "nil" "nil" "Ap{2,2} : nil" "1 : 2 : nil" "nil"))
;;          (list 2 (list "1 : nil" "nil" "Ap{2,1} : nil" "2 : nil" "nil"))
;;          (list 3 "Finished!"))
;;
;; Assuming you have a proper function 'trace-semcd' which computes such a
;; trace output, the GUI may be invoked like this:
;;    (stepper2 10 180
;;              (trace-semcd (from-to 0 5000)
;;                           ...))              .
;;
;; If your function 'trace-semcd' produces a list of states only, i.e. without
;; state numbers, you can add the state numbers afterwards using the function
;; 'zip-trace'.
;; Assuming that 'trace-semcd' returns
;;    (list (list "nil" "nil" "nil" "Ap{2} 1 2 : nil" "nil")
;;          (list "nil" "nil" "Ap{2,2} : nil" "1 : 2 : nil" "nil")
;;          (list "1 : nil" "nil" "Ap{2,1} : nil" "2 : nil" "nil")
;;          "Finished!")                                             ,
;; you may use
;;    (zip-trace (from-to 0 5000) (trace-semcd ...))
;; in order to get the same output as in the first example, and you can call
;; 'stepper2' like this:
;;    (let ((cnt-list (from-to 0 5000)))
;;         (stepper2 10 180
;;                   (zip-trace cnt-list
;;                              (trace-semcd cnt-list ...))))   .
;;
;;
;; Have fun ...
;;
;;
;; By the way, if you find any errors or need further help, feel free to
;; drop me an e-mail at dkr@informatik.uni-kiel.de :-)
;;


(require-library "match.ss")


(define-signature semcd-guiS (zip-trace stepper1 stepper2))


(define semcd-guiU 
  (unit/sig semcd-guiS
    (import plt:userspace^)


;;
;; internal functions
;;

(define (check? pairs) (check-i? pairs 0))
(define (error cnt str)
        (string-append "List position "
                       (number->string cnt)
                       ": "
                       str))
(define (check-i? pairs cnt)
        (match pairs [()                       #t]
                     [((num state) tail ...)   (if (number? num)
                                                   (match state [(s e m c d)   (if (and (string? s)
                                                                                        (string? e)
                                                                                        (string? m)
                                                                                        (string? c)
                                                                                        (string? d))
                                                                                   (check-i? tail (+ cnt 1))
                                                                                   (error cnt "Element '(num (s e m c d))' with illegal stack found (should be a string)!"))]
                                                                [(state ...)   (error cnt "Element '(num stacks)' with illegal number of stacks found (should be 5)!")]
                                                                [message       (if (string? message)
                                                                                   (check-i? tail (+ cnt 1))
                                                                                   (error cnt "Element '(num message)' with illegal 'message' found (should be a string)!"))])
                                                   (error cnt "Element '(num state)' with illegal 'num' found (should be a number)!"))]
                     [(pair pairs ...)         (error cnt "Illegal element found (should be a list of two elements)!")]
                     [_                        "Argument is not a list!"]))

(define (get-incr max-pos)
        (max 2 (quotient max-pos 10)))

(define (print-cnt pairs pos)
        (string-append "State "
                       (number->string (car (list-ref pairs pos)))
                       ":"))

(define (print-notify max-pos pos)
        (string-append (number->string (- (- max-pos pos) 1))
                       " more states available"))

(define (stepper1-i font-size max-len pairs)
  (define pos-var -1)   ;; global variable
  (define max-pos (- (length pairs) 1))
  (define incr (get-incr max-pos))
  (define (print-names)
          (string-append "S |"
                         (make-string 1 #\newline)
                         "E |"
                         (make-string 1 #\newline)
                         "M |"
                         (make-string 1 #\newline)
                         "C |"
                         (make-string 1 #\newline)
                         "D |"))
  (define (print-frame lines str)
          (string-append (make-string max-len #\space)   ;; defines width of message field
                         (make-string lines #\newline)   ;; defines height of message field
                         str
                         (make-string lines #\newline)
                         (make-string max-len #\space)))
  (define (print-state pos)
          (letrec ((state (car (cdr (list-ref pairs pos)))))
                  (print-frame 1 (if (string? state)
                                     (string-append state
                                                    (make-string 4 #\newline))
                                     (string-append (list-ref state 0)
                                                    (make-string 1 #\newline)
                                                    (list-ref state 1)
                                                    (make-string 1 #\newline)
                                                    (list-ref state 2)
                                                    (make-string 1 #\newline)
                                                    (list-ref state 3)
                                                    (make-string 1 #\newline)
                                                    (list-ref state 4))))))
  (define (set-pos pos)
          (cond ((= pos pos-var)   void)
                ((< pos 0)         (set-pos 0))
                ((>= pos max-pos)  (set-pos (- max-pos 1)))
                (else (void (set! pos-var pos)
                            (send label1    set-label (print-cnt pairs pos))
                            (send label2    set-label (print-cnt pairs (+ pos 1)))
                            (send old-state set-label (print-state pos))
                            (send new-state set-label (print-state (+ pos 1)))
                            (send notify    set-label (print-notify max-pos pos))))))
  (define frame (make-object frame%  "SEMCD machine"))
  (define top (void (make-object message% (make-string max-len #\space) frame)
                    (send frame set-label-font (make-object font% font-size "-misc-fixed" 'roman 'normal 'normal #f))))
  (define label1 (make-object message% (print-cnt pairs max-pos) frame))
  (define state1 (make-object horizontal-panel% frame (list 'border)))
  (define names1 (make-object message% (print-names) state1))
  (define old-state (make-object message% (print-frame 3 "") state1))
  (define sep (make-object message% (make-string max-len #\space) frame))
  (define label2 (make-object message% (print-cnt pairs max-pos) frame))
  (define state2 (make-object horizontal-panel% frame (list 'border)))
  (define names2 (make-object message% (print-names) state2))
  (define new-state (make-object message% (print-frame 3 "") state2))
  (define bot (make-object message% (make-string max-len #\space) frame))
  (define panel (make-object horizontal-panel% frame))
  (define notify (make-object message% (print-notify max-pos pos-var) panel))
  (void (make-object button% "|<<" panel (lambda (button event) (set-pos 0)))
        (make-object button% "<<"  panel (lambda (button event) (set-pos (- pos-var incr))))
        (make-object button% " < " panel (lambda (button event) (set-pos (- pos-var 1))))
        (make-object button% " > " panel (lambda (button event) (set-pos (+ pos-var 1))))
        (make-object button% ">>"  panel (lambda (button event) (set-pos (+ pos-var incr))))
        (make-object button% ">>|" panel (lambda (button event) (set-pos (- max-pos 1))))
        (make-object button% "Cancel" panel (lambda (button event) (send frame show #f)))
        (send frame set-alignment 'left 'center)
        (send panel set-alignment 'left 'center)
        (set-pos 0)   ;; display initial states
        (send frame show #t)))

(define (stepper2-i font-size max-len pairs)
  (define pos-var -1)   ;; global variable
  (define max-pos (- (length pairs) 1))
  (define incr (get-incr max-pos))
  (define (print-stack pos num name)
          (letrec ((state (car (cdr (list-ref pairs pos))))
                   (str   (if (string? state) state (list-ref state num)))
                   (len   (string-length str)))
                  (string-append (if (> len max-len)
                                     (string-append "..."
                                                    (substring str (+ (- len max-len) 3) len))
                                     str)
                                 " | "
                                 name)))
  (define frame (make-object frame% "SEMCD machine"))
  (define content (make-object vertical-panel% frame))
  (define top (void (make-object message% (make-string max-len #\space) content)
                    (send content set-label-font (make-object font% font-size "-misc-fixed" 'roman 'normal 'normal #f))))
  (define label1 (make-object message% (print-cnt pairs max-pos) content))
  (define state1 (make-object vertical-panel% content (list 'border)))
  (define sep (make-object message% (make-string max-len #\space) content))
  (define label2 (make-object message% (print-cnt pairs max-pos) content))
  (define state2 (make-object vertical-panel% content (list 'border)))
  (define bot (make-object message% (make-string max-len #\space) content))
  (define panel (make-object horizontal-pane% content))
  (define notify (make-object message% (print-notify max-pos 0) panel))
  (define (change-state parent pos) (lambda (childs)
          (send parent delete-child (car childs))
          (let ((panel (make-object vertical-panel% parent)))
               (void (make-object message% (print-stack pos 0 "S") panel)
                     (make-object message% (print-stack pos 1 "E") panel)
                     (make-object message% (print-stack pos 2 "M") panel)
                     (make-object message% (print-stack pos 3 "C") panel)
                     (make-object message% (print-stack pos 4 "D") panel)
                     (send panel set-alignment 'right 'center))
               (list panel))))
  (define (set-pos pos)
          (cond ((= pos pos-var)   void)
                ((< pos 0)         (set-pos 0))
                ((>= pos max-pos)  (set-pos (- max-pos 1)))
                (else (void (set! pos-var pos)
                            (send content show #f)
                            (send label1 set-label (print-cnt pairs pos))
                            (send label2 set-label (print-cnt pairs (+ pos 1)))
                            (send state1 change-children (change-state state1 pos))
                            (send state2 change-children (change-state state2 (+ pos 1)))
                            (send notify set-label (print-notify max-pos pos))
                            (send content show #t)))))
  (void (make-object vertical-panel% state1)   ;; dummy
        (make-object vertical-panel% state2)   ;; dummy
        (make-object button% "|<<" panel (lambda (button event) (set-pos 0)))
        (make-object button% "<<"  panel (lambda (button event) (set-pos (- pos-var incr))))
        (make-object button% " < " panel (lambda (button event) (set-pos (- pos-var 1))))
        (make-object button% " > " panel (lambda (button event) (set-pos (+ pos-var 1))))
        (make-object button% ">>"  panel (lambda (button event) (set-pos (+ pos-var incr))))
        (make-object button% ">>|" panel (lambda (button event) (set-pos (- max-pos 1))))
        (make-object button% "Cancel" panel (lambda (button event) (send frame show #f)))
        (send content set-alignment 'right 'center)
        (send panel set-alignment 'right 'center)
        (set-pos 0)   ;; display initial states
        (send frame show #t)))

(define (stepper stepper-fun) (lambda (font-size max-len pairs)
        (if (< (length pairs) 2)
            "List must contain at least two states!"
            (let ((check (check? pairs)))
                 (if (string? check)
                     check
                     (stepper-fun font-size max-len pairs))))))


;;
;; exported functions
;;

(define (zip-trace cnt-lst trace-lst)
        (match (list cnt-lst trace-lst)
               [((cnt cnt-tail ...) (trace trace-tail ...))   (cons (list cnt trace)
                                                                    (zip-trace cnt-tail trace-tail))]
               [(()                 trace-lst)                ()]
               [(cnt-lst            ())                       ()]))

(define stepper1 (stepper stepper1-i))
(define stepper2 (stepper stepper2-i))


))


(compound-unit/sig
  (import (PLT : plt:userspace^))
  (link
    (DRAW : semcd-guiS (semcd-guiU PLT)))
  (export (open DRAW)))