(require-library "graphicss.ss" "graphics")
(require-library "error.ss" "htdp")

;; Implementation:
;;   Stephanie Weirich (1994),
;;   Mark Krentel (1995),
;;   Matthias Felleisen (1996)

(define-signature elevatorS (run))

(define elevatorU 
  (unit/sig elevatorS
    (import errorS plt:userspace^ graphics:posn-less^)

    ;;  There are really  three distinct levels: graphics, hardware,
    ;;  and software. Don't mix them!

    ;;
    ;;  HARDWARE/GRAPHICS level for Elevator.
    ;;  This level provides the basic primitives for writing an elevator.
    ;;  The hardware level are the guards for the graphics level.
    ;;
    ;;  Hardware functions:
    ;;
    ;;     make-elevator  max-floor
    ;;     current-floor  move-up-floor    move-down-floor
    ;;     update-input   wait-for-input
    ;;     open?          open-doors       close-doors
    ;;     up-call?       down-call?       demand?
    ;;     clear-up-call  clear-down-call  clear-demand
    ;;     busy-wait      info
    ;;

    ;;  Compute the layout and draw the window.

    (define  init-graphics
      (lambda  ()
	(init-layout-and-window)
	(init-shaft)
	(init-calls)
	(init-info)
	(init-demands)
	(init-stop)
	(init-car)
	(busy-wait  800)
	(draw-open-doors)))

    ;;
    ;;  Overall layout for the window.
    ;;  Currently need max-floor >= 4.
    ;;

    (define  BORDER  100)
    (define  SHAFT-INFO-GAP   40)
    (define  STOP-DEMAND-GAP  50)

    (define  init-layout-and-window
      (lambda  ()
	(let* 
	  ([shaft  (make-posn  BORDER  BORDER)]
	   [call   (add-hv  shaft  SHAFT-WIDTH  0)]
	   [top    (add-hv  call  CALL-WIDTH  0)]
	   [bot    (add-hv  top  0  (* (max-floor) FLOOR-SIZE))]
	   [info   (add-hv  top  SHAFT-INFO-GAP  0)]
	   [stop   (add-hv  bot  SHAFT-INFO-GAP  (- STOP-HEIGHT))]
	   [demand (add-hv  stop  0  (- 0 STOP-DEMAND-GAP DEMAND-HEIGHT))]
	   [horiz  (+  (posn-x info)  STOP-WIDTH  BORDER)]
	   [vert   (+  (posn-y bot)  BORDER)])
	  (set!  SHAFT-ORIGIN   shaft)
	  (set!  CALL-ORIGIN    call)
	  (set!  INFO-ORIGIN    info)
	  (set!  STOP-ORIGIN    stop)
	  (set!  DEMAND-ORIGIN  demand)
	  (init-window  horiz  vert))))

    ;;
    ;;  Window primitives for lines, strings, mouse clicks.
    ;;  These should be the only functions that use elev-win.
    ;;

    (define  elev-win  #f)
    (define  d-line    #f)
    (define  c-line    #f)
    (define  d-string  #f)
    (define  c-string  #f)
    (define  mouse-click?    (lambda () (ready-mouse-click elev-win)))
    (define  wait-for-click  (lambda () (get-mouse-click elev-win)))

    (define  init-window
      (lambda  (horiz  vert)
	(set!  elev-win  (open-viewport "Elevator Simulation" horiz vert))
	(set!  d-line  (draw-line  elev-win))
	(set!  c-line  (clear-line  elev-win))
	(set!  d-string  (draw-string  elev-win))
	(set!  c-string  (clear-string  elev-win))))

    (define  d-string-bf
      (lambda  (posn  string)
	(d-string  posn  string)
	(d-string  (add-hv posn 1 0)  string)))

    (define  c-string-bf
      (lambda  (posn  string)
	(c-string  posn  string)
	(c-string  (add-hv posn 1 0)  string)))

    ;;
    ;;  Helper functions for position, offsets, etc.
    ;;  SIXLib should provide better primitives here.
    ;;

    (define  under?   (lambda  (p1  p2)  (>  (posn-y p1)  (posn-y p2))))

    (define  add-posn
      (lambda  (p1  p2)
	(make-posn  (+  (posn-x p1)  (posn-x p2))
	  (+  (posn-y p1)  (posn-y p2)))))

    (define  add-hv
      (lambda  (p  horiz  vert)
	(make-posn  (+  (posn-x p)  horiz) 
	  (+  (posn-y p)  vert))))

    ;;
    ;;  Low-level primitives for lines, rectangles, etc.
    ;;
        
    (define  paint-rect
      (lambda  (origin  horiz  vert)
	(when  (>= vert 0)
	  (let ([right  (add-hv origin horiz 0)]
		[next   (add-hv origin 0 +1)])
	    (d-line  origin  right)
	    (paint-rect  next  horiz  (- vert 1))))))

    (define  outline-rect
      (lambda  (origin  horiz  vert  thick)
	(let* ([x0  (posn-x origin)]  [y0  (posn-y origin)])
	  (recur  loop  ([lf   x0]  [rt   (+ x0 horiz thick -1)]
			 [top  y0]  [bot  (+ y0 vert  thick -1)]
			 [n  thick])
	    (when  (> n 0)
	      (d-line  (make-posn lf top)  (make-posn rt top))
	      (d-line  (make-posn rt top)  (make-posn rt bot))
	      (d-line  (make-posn rt bot)  (make-posn lf bot))
	      (d-line  (make-posn lf bot)  (make-posn lf top))
	      (loop  (+ lf 1)  (- rt 1)  (+ top 1)  (- bot 1)  (- n 1)))))))

    (define  clear-inside-rect
      (lambda  (origin  horiz  vert  thick)
	(recur  loop  ([lf  (add-hv origin thick thick)]
		       [rt  (add-hv origin (- horiz 1) thick)]
		       [n  thick])
	  (when  (< n vert)
	    (c-line  lf  rt)
	    (loop  (add-hv lf 0 +1)  (add-hv rt 0 +1) (+ n 1))))))

    ;;
    ;;  Elevator Shaft and Car 
    ;;

    (define  SHAFT-ORIGIN #f)
    (define  STOP-ORIGIN  #f)
    (define  SHAFT-WIDTH  64)
    (define  FLOOR-SIZE   64)
    (define  CAR-WIDTH    44)
    (define  CAR-HEIGHT   44)
    (define  MIN-DOOR-SEP  3)
    (define  NUMBER-POSN  (make-posn -22 (floor (/ FLOOR-SIZE 2))))

    (define  init-shaft
      (lambda  ()
	(let ([height  (* (max-floor) FLOOR-SIZE)])
	  (outline-rect  SHAFT-ORIGIN  SHAFT-WIDTH  height  2)
	  (recur  loop  ([p  (add-posn SHAFT-ORIGIN NUMBER-POSN)]
			 [n  (max-floor)])
	    (when  (>= n 1)
	      (d-string-bf  p  (number->string n))
	      (loop  (add-hv p 0 FLOOR-SIZE)  (- n 1)))))))

    (define  init-car
      (lambda  ()
	(let* ([origin  (car-posn 1)])
	  (outline-rect  origin  CAR-WIDTH  CAR-HEIGHT  1)
	  (outline-rect  origin  (floor (/ CAR-WIDTH 2))  CAR-HEIGHT  1))))

    (define  car-posn
      (lambda  (n)
	(add-hv  SHAFT-ORIGIN
	  (floor (/ (- SHAFT-WIDTH CAR-WIDTH) 2))
	  (+  (floor (/ (- FLOOR-SIZE  CAR-HEIGHT) 2))
	     (*  (- (max-floor) n)  FLOOR-SIZE)))))

    (define  move-car-door
      (lambda  (horiz  delta)
	(let* ([origin   (car-posn (current-floor))]
	       [old-top  (add-hv origin horiz +1)]
	       [old-bot  (add-hv origin horiz (- CAR-HEIGHT 1))]
	       [new-top  (add-hv old-top delta 0)]
	       [new-bot  (add-hv old-bot delta 0)])
	  (d-line  new-top  new-bot)
	  (c-line  old-top  old-bot))))

    (define  draw-open-doors
      (lambda  ()
	(recur  loop  ([lf  (floor   (/ CAR-WIDTH 2))]
		       [rt  (ceiling (/ CAR-WIDTH 2))])
	  (when  (<  MIN-DOOR-SEP  lf)
	    (move-car-door  lf  -1)
	    (move-car-door  rt  +1)
	    (busy-wait)
	    (loop  (- lf 1)  (+ rt 1))))
	(draw-little-man)))

    (define  draw-close-doors
      (lambda  ()
	(recur  loop  ([lf  MIN-DOOR-SEP]
		       [rt  (- CAR-WIDTH MIN-DOOR-SEP)])
	  (when  (>=  (- rt lf)  2)
	    (move-car-door  lf  +1)
	    (move-car-door  rt  -1)
	    (busy-wait)
	    (loop  (+ lf 1)  (- rt 1))))))

    (define  move-fwd-edge
      (lambda  (origin  delta)
	(let* ([new-lf  (add-hv origin 0 delta)]
	       [new-rt  (add-hv origin CAR-WIDTH delta)]
	       [old-1-lf  (add-hv origin +1 0)]
	       [old-1-rt  (add-hv origin (- (floor (/ CAR-WIDTH 2)) 1) 0)]
	       [old-2-lf  (add-hv origin (+ (ceiling (/ CAR-WIDTH 2)) 1) 0)]
	       [old-2-rt  (add-hv origin (- CAR-WIDTH 1) 0)])
	  (d-line  new-lf  new-rt)
	  (c-line  old-1-lf  old-1-rt)
	  (c-line  old-2-lf  old-2-rt))))

    (define  move-back-edge
      (lambda  (origin  delta)
	(let*  ([new-lf  (add-hv origin 0 delta)]
		[new-rt  (add-hv origin CAR-WIDTH delta)]
		[old-lf  origin]
		[old-rt  (add-hv origin CAR-WIDTH 0)])
	  (d-line  new-lf  new-rt)
	  (c-line  old-lf  old-rt))))

    (define  draw-up-floor
      (lambda  ()
	(let ([goal  (car-posn (+ (current-floor) 1))])
	  (recur  loop  ([cur  (car-posn (current-floor))])
	    (when  (under?  cur  goal)
	      (move-fwd-edge  cur  -1)
	      (move-back-edge  (add-hv cur 0 CAR-HEIGHT)  -1)
	      (busy-wait)
	      (loop  (add-hv cur 0 -1)))))))

    (define  draw-down-floor
      (lambda  ()
	(let ([goal  (car-posn (- (current-floor) 1))])
	  (recur  loop  ([cur  (car-posn (current-floor))])
	    (when  (under?  goal  cur)
	      (move-fwd-edge  (add-hv cur 0 CAR-HEIGHT)  +1)
	      (move-back-edge  cur  +1)
	      (busy-wait)
	      (loop  (add-hv cur 0 +1)))))))

    ;;  This is probably going too far ...
    ;;  But he's more than just a list of lines!

    (define  MAN-POSN  (make-posn 18 14))

    (define  LITTLE-MAN
      (list  (make-posn 5 0)   (make-posn 9 0)    ; head
	(make-posn 9 0)   (make-posn 9 4)
	(make-posn 9 4)   (make-posn 5 4)
	(make-posn 5 4)   (make-posn 5 0)
	(make-posn 7 4)   (make-posn 7 12)   ; body
	(make-posn 7 12)  (make-posn 2 23)   ; legs
	(make-posn 7 12)  (make-posn 12 23)
	(make-posn 0 23)  (make-posn 2 23)   ; feet
	(make-posn 12 23) (make-posn 14 23)
	(make-posn 1 8)   (make-posn 13 8)   ; arms
	(make-posn 0 9)   (make-posn 1 8)    ; hands
	(make-posn 13 8)  (make-posn 14 7)))

    (define  draw-little-man
      (lambda  ()
	(let ([origin  (add-posn (car-posn (current-floor)) MAN-POSN)])
	  (recur  loop  ([l  LITTLE-MAN])
	    (unless  (null? l)
	      (d-line  (add-posn  origin  (car l))  
		(add-posn  origin  (cadr l)))
	      (loop  (cddr l)))))))

    ;;
    ;;  Call Buttons 
    ;;

    (define  CALL-ORIGIN  #f)
    (define  CALL-WIDTH   50)
    (define  CALL-HEIGHT  (floor (/ FLOOR-SIZE 2)))

    (define  UP-CALL-SHAPE  
      (list  (make-posn 13 28)  (make-posn 25 4)   (make-posn 37 28)))
    (define  DOWN-CALL-SHAPE
      (list  (make-posn 13 4)   (make-posn 25 28)  (make-posn 37 4)))

    (define  UP-CALL-POSN
      (lambda  (floor)
	(add-hv  CALL-ORIGIN  0  (* FLOOR-SIZE (- (max-floor) floor)))))

    (define  DOWN-CALL-POSN
      (lambda  (floor)  
	(add-hv  (UP-CALL-POSN floor)  0  CALL-HEIGHT)))

    (define  init-calls
      (lambda  ()
	(recur  loop  ([n  1])
	  (when  (<=  n  (max-floor))
	    (outline-rect  (UP-CALL-POSN n)  CALL-WIDTH  FLOOR-SIZE  2)
	    (outline-call  (UP-CALL-POSN n)  UP-CALL-SHAPE)
	    (outline-call  (DOWN-CALL-POSN n)  DOWN-CALL-SHAPE)
	    (loop  (+ n 1))))))

    (define  draw-clear-up
      (lambda  (floor)
	(clear-call    (UP-CALL-POSN floor)  UP-CALL-SHAPE)
	(outline-call  (UP-CALL-POSN floor)  UP-CALL-SHAPE)))

    (define  draw-clear-down
      (lambda  (floor)
	(clear-call    (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)
	(outline-call  (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)))

    (define  paint-up-call
      (lambda  (floor)
	(paint-call  (UP-CALL-POSN floor)  UP-CALL-SHAPE)))

    (define  paint-down-call
      (lambda  (floor)
	(paint-call  (DOWN-CALL-POSN floor)  DOWN-CALL-SHAPE)))

    (define  outline-call
      (lambda  (origin  l)
	(let* ([p  (add-posn origin (car l))]
	       [q  (add-posn origin (cadr l))] 
	       [r  (add-posn origin (caddr l))])
	  (d-line  p  q)
	  (d-line  q  r)
	  (d-line  r  p))))

    (define  clear-call
      (lambda  (origin  l)
	(let* ([p  (add-posn origin (car l))]
	       [q  (add-posn origin (cadr l))] 
	       [r  (add-posn origin (caddr l))]
	       [top  (min (posn-y p) (posn-y q))]
	       [bot  (max (posn-y p) (posn-y q))])
	  (recur  loop  ([y  (+ top 1)])
	    (when  (< y bot)
	      (let ([lf  (ceiling (x-val p q y))]
		    [rt  (floor   (x-val q r y))])
		(c-line  (make-posn lf y)  (make-posn rt y))
		(loop  (+ y 1))))))))

    (define  paint-call
      (lambda  (origin  l)
	(let* ([p  (add-posn origin (car l))]
	       [q  (add-posn origin (cadr l))] 
	       [r  (add-posn origin (caddr l))]
	       [top  (min (posn-y p) (posn-y q))]
	       [bot  (max (posn-y p) (posn-y q))])
	  (recur  loop  ([y  (+ top 1)])
	    (when  (< y bot)
	      (let ([lf  (ceiling (x-val p q y))]
		    [rt  (floor   (x-val q r y))])
		(d-line  (make-posn lf y)  (make-posn rt y))
		(loop  (+ y 1))))))))

    (define  x-val
      (lambda  (a  b  y)
	(let ([ax  (posn-x a)]  [ay  (posn-y a)]
	      [bx  (posn-x b)]  [by  (posn-y b)])
	  (+  ax  (*  (/  (-  y  ay)  (-  by  ay))
		     (-  bx  ax))))))

    ;;
    ;;  Demand Buttons
    ;;

    (define  DEMAND-ORIGIN  #f)
    (define  DEMAND-WIDTH   40)
    (define  DEMAND-HEIGHT  40)
    (define  DEMAND-TEXT  (make-posn 18 25))

    (define  DEMAND-POSN
      (let ([HORIZ  (+ DEMAND-WIDTH 20)]  
	    [VERT   (+ DEMAND-HEIGHT 20)])
	(lambda  (i)
	  (let ([x  (remainder (sub1 i) 2)]
		[y  (quotient  (sub1 i) 2)])
	    (add-hv  DEMAND-ORIGIN  (* x HORIZ)  (* -1 y VERT))))))

    (define  init-demands
      (lambda  ()
	(recur  loop  ([n  1])
	  (when  (<= n (max-floor))
	    (outline-rect  (DEMAND-POSN n)  DEMAND-WIDTH  DEMAND-HEIGHT  2) 
	    (d-string-bf  (add-posn (DEMAND-POSN n) DEMAND-TEXT)  (number->string n))
	    (loop  (+ n 1))))))

    (define  paint-demand
      (lambda  (k)
	(let ([nw  (DEMAND-POSN k)])
	  (paint-rect  nw  DEMAND-WIDTH  DEMAND-HEIGHT)
	  (c-string-bf  (add-posn nw DEMAND-TEXT)  (number->string k)))))

    (define  draw-clear-demand
      (lambda  (k)
	(clear-inside-rect  (DEMAND-POSN k)  DEMAND-WIDTH  DEMAND-HEIGHT  2)
	(d-string-bf  (add-posn (DEMAND-POSN k) DEMAND-TEXT)  (number->string k))))

    ;;
    ;;  "Stop Program" Button
    ;;

    (define  STOP-WIDTH  100)
    (define  STOP-HEIGHT  40)
    (define  STOP-TEXT  (make-posn 15 25))

    (define  init-stop
      (lambda  ()
	(outline-rect  STOP-ORIGIN  STOP-WIDTH  STOP-HEIGHT  2)
	(d-string  (add-posn STOP-ORIGIN STOP-TEXT)  "Stop Program")))

    ;;
    ;;  Mouse Clicks
    ;;  Look for up/down calls, demands and stop-program button.
    ;;  If you can get access to a real-time clock, then change the
    ;;  delay loop to use sleep-for or real-time.
    ;;  The units are (fake) milliseconds.
    ;;  SCALE is the multiplier for waiting time.
    ;;  SCALE > 1 slows down the simulation.
    ;;

    (define  DEFAULT-WAIT    25) 
    (define  SCALE  0.75)

    (define  busy-wait
      (lambda  l
	(let* ([cur-time   (current-milliseconds)]
	       [wait-time  (if (null? l) DEFAULT-WAIT (car l))]
	       [new-time   (+ cur-time (* SCALE wait-time))])
	  (recur  loop  ()
	    (check-buttons)
	    (yield)
	    (when (< (current-milliseconds) new-time)
	      (loop))))))
      
    (define  check-buttons
      (lambda  ()
	(let ([click  (mouse-click?)])
	  (when  click
	    (process-click  click)
	    (check-buttons)))))

    (define  wait-for-button
      (lambda  ()
	(let ([click  (wait-for-click)])
	  (process-click  click)
	  (check-buttons))))

    (define  process-click
      (lambda  (click)
	(recur  loop  ([n  1])
	  (cond
	    [(>  n  (max-floor))  (void)]
	    [(click-here? click (UP-CALL-POSN n) CALL-WIDTH CALL-HEIGHT)
	     (push-up-call  n)]
	    [(click-here? click (DOWN-CALL-POSN n) CALL-WIDTH CALL-HEIGHT)
	     (push-down-call  n)]
	    [(click-here? click (DEMAND-POSN n) DEMAND-WIDTH DEMAND-HEIGHT)
	     (push-demand  n)]
	    [(click-here? click STOP-ORIGIN STOP-WIDTH STOP-HEIGHT)
	     (push-stop)]
	    [else  (loop (+ n 1))]))))

    (define  click-here?
      (lambda  (click  origin  horiz  vert)
	(let* ([x0  (posn-x origin)]
	       [y0  (posn-y origin)]
	       [x   (posn-x (mouse-click-posn click))]
	       [y   (posn-y (mouse-click-posn click))])
	  (and  (<= x0 x (+ x0 horiz))
            (<= y0 y (+ y0 vert))))))

    ;;
    ;;  Info
    ;;  Just floor, goal, dir. 
    ;;

    (define  INFO-ORIGIN  #f)
    (define-struct  info  (sym  posn  label  prev))

    (define  INFO-LIST
      (list  (make-info  'floor  (make-posn 0 12)   "floor = "  #f)
	(make-info  'goal   (make-posn 0 28)  "goal = "   #f)
	(make-info  'dir    (make-posn 0 44)  "dir = "    #f)))

    (define  init-info
      (lambda  ()
	(let  loop  ([l  INFO-LIST])
	  (unless  (null? l)
	    (set-info-prev!  (car l)  "")
	    (loop  (cdr l))))
	(info  'floor  1)
	(info  'goal  1)
	(info  'dir  'none)))

    (define  my-lookup
      (lambda  (sym)
	(let  loop  ([l  INFO-LIST])
	  (cond
	    [(null? l)  (error 'info "Unknown info type: ~e" sym)]
	    [(eq? sym (info-sym (car l)))  (car l)]
	    [else  (loop  (cdr l))]))))

    (define  info
      (lambda  (sym  obj)
	(let* ([item  (my-lookup sym)]
	       [posn  (add-posn  INFO-ORIGIN  (info-posn item))]
	       [str   (if (string? obj) obj (format "~s" obj))]
	       [full-str  (string-append (info-label item) str)])
	  (unless  (string=?  full-str  (info-prev item))
	    (c-string  posn  (info-prev item))
	    (d-string  posn  full-str)
	    (set-info-prev!  item  full-str)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;                                           ;;
    ;;  Functions to show to the outside world.  ;;
    ;;                                           ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;;  This is really the (virtual) elevator hardware level.
    ;;  This includes state and the basic elevator operations.
    ;;  You write an elevator from these primitives.
    ;;
    ;;  This could be a separate module, but you'd just write all of
    ;;  these functions twice.  Also, they make nice guards for the
    ;;  graphics functions.

    ;;  Elevator State
    ;;
    ;;  the-floor = integer 1..THE-MAX-FLOOR
    ;;  the-doors = 'open, 'closed
    ;;  up-call-vec, down-call-vec, demand-vec = vectors 1..THE-MAX-FLOOR
    ;;     for buttons, #t = pushed, #f = not pushed

    (define  max-floor  #f)
    (define  the-floor  #f)
    (define  the-doors  #f)
    (define  up-call-vec  #f)
    (define  down-call-vec  #f)
    (define  demand-vec  #f)
    (define  exit-continuation  #f)

    ;;  Initialize the hardware state and draw the picture.
    ;;  f = THE-MAX-FLOOR,  k = exit continuation

    (define  make-elevator
      (lambda  (f  k)
	(let ([n  (add1 f)])
	  (set!  max-floor  (lambda () f))
	  (set!  exit-continuation  k)
	  (set!  the-floor  1)
	  (set!  the-doors  'open)
	  (set!  up-call-vec    (build-vector n (lambda (i) #f)))
	  (set!  down-call-vec  (build-vector n (lambda (i) #f)))
	  (set!  demand-vec     (build-vector n (lambda (i) #f)))
	  (init-graphics))))

    (define  push-stop  
      (lambda  ()  (exit-continuation  'game-over)))

    ;;  Functions that use the-floor.
    ;;  Only (move-up-floor) and (move-down-floor) are allowed to use
    ;;  the-floor and THE-MAX-FLOOR directly.

    (define  current-floor  (lambda  ()  the-floor))

    (define  move-up-floor
      (lambda  ()
	(if  (=  the-floor  (max-floor))
	  (error  'move-up-floor  "Elevator already at MAX-FLOOR")
	  (begin  (info  'dir  'up)
	    ;;  (info  'floor  (format "~s~s" the-floor '+))
	    (when  (open?)  (close-doors))
	    (draw-up-floor)
	    (set!  the-floor  (add1 the-floor))
	    (info  'floor  the-floor)))))

    (define  move-down-floor
      (lambda  ()
	(if  (=  the-floor  1)
	  (error  'move-down-floor  "Elevator already at ground floor")
	  (begin  (info  'dir  'down)
	    ;;  (info  'floor  (format "~s~s" the-floor '-))
	    (when  (open?)  (close-doors))
	    (draw-down-floor)
	    (set!  the-floor  (sub1 the-floor))
	    (info  'floor  the-floor)))))

    ;;  Functions that use the-doors.
    ;;  Again, only (open-doors) and (close-doors) are allowed to use
    ;;  the-doors directly.

    (define  open?  (lambda  ()  (eq? the-doors 'open)))

    (define  open-doors
      (lambda  ()
	(unless  (open?)
	  (draw-open-doors)
	  (set!  the-doors  'open))))

    (define  close-doors
      (lambda  ()
	(when  (open?)
	  (draw-close-doors)
	  (set!  the-doors  'closed))))

    ;;  Functions that use buttons: up/down-calls, demands.
    ;;  Again, these are the only functions that are allowed to use
    ;;  up/down-calls and demands directly.

    (define  up-call?    (lambda  (floor)  (vector-ref up-call-vec floor)))
    (define  down-call?  (lambda  (floor)  (vector-ref down-call-vec floor)))
    (define  demand?     (lambda  (floor)  (vector-ref demand-vec floor)))

    (define  update-input  check-buttons)
    (define  wait-for-input  wait-for-button)

    (define  clear-up-call
      (lambda  (floor)
	(when  (up-call?  floor)
	  (draw-clear-up  floor)
	  (vector-set!  up-call-vec  floor  #f))))

    (define  clear-down-call
      (lambda  (floor)
	(when  (down-call?  floor)
	  (draw-clear-down  floor)
	  (vector-set!  down-call-vec  floor  #f))))

    (define  clear-demand
      (lambda  (floor)
	(when  (demand?  floor)
	  (draw-clear-demand  floor)
	  (vector-set!  demand-vec  floor  #f))))

    ;;  The push functions are not visible outside, but they need to
    ;;  be here because graphics calls them.

    (define  push-up-call
      (lambda  (floor)
	(when  (not  (up-call? floor))
	  (paint-up-call  floor)
	  (vector-set!  up-call-vec  floor  #t))))

    (define  push-down-call
      (lambda  (floor)
	(when  (not  (down-call? floor))
	  (paint-down-call  floor)
	  (vector-set!  down-call-vec  floor  #t))))

    (define  push-demand
      (lambda  (floor)
	(when  (not  (demand? floor))
	  (paint-demand  floor)
	  (vector-set!  demand-vec  floor  #t))))


    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    ;;                                     ;;
    ;;  SOFTWARE level for elevator.       ;;
    ;;                                     ;;
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    ;;  Here, you design your own elevator, using the primitives from
    ;;  the graphics-module and the user's Control function.

    (define  THE-MAX-FLOOR  8)

    (define  start-program
      (lambda  ()
	(dynamic-wind
	  (lambda ()
	    (unless  (graphics-open?)  (open-graphics)))
	  (lambda ()
	    (call/cc
	      (lambda  (k)
		(make-elevator  THE-MAX-FLOOR  k)
		(elevator  'open  #f  'up))))
	  close-graphics)
	(void)))

    ;;
    ;;  Main Loop.
    ;;
    ;;  This version gives the user complete control.
    ;;  All we do is ask the user for a goal, move one floor closer,
    ;;  check to see if we're at the goal (stop and open doors if so),
    ;;  and ask for another goal. 
    ;;  Any kind of fairness or ignoring the down-calls when moving up
    ;;  is totally up to Control.
    ;;
    ;;  floor, goal = integer 1..THE-MAX-FLOOR
    ;;  state = 'arrive, 'open, 'wait, 'move
    ;;    'arrive = just arrived at this floor, check if it's the goal
    ;;    'open = open doors, wait, ignore goal, get new one
    ;;    'wait = no requests, wait until there is one
    ;;    'move = start moving toward the goal
    ;;  dir = 'up, 'down
    ;;
    ;;  We call new-goal at each floor.
    ;;

    (define  OPEN-DOOR-WAIT-TIME  1500)

    (define  elevator
      (lambda  (state  goal  dir)
	(let ([floor  (current-floor)])
	  (cond
	    [(eq?  state  'arrive)
	     (if  (=  floor  goal)
	       (elevator  'open  goal  dir)
	       (elevator  'move  (new-goal dir)  dir))]
	    [(eq?  state  'open) 
	     (begin
	       (open-doors)
	       (clear-all-buttons  floor)
	       (busy-wait  OPEN-DOOR-WAIT-TIME)
	       (update-input)
	       (clear-all-buttons  floor)
	       (elevator  'wait  (new-goal dir)  dir))]
	    [(eq?  state  'wait)
	     (if  (=  floor  goal)
	       (begin
		 (update-input)
		 (clear-all-buttons  floor)
		 (wait-for-request)
		 (elevator  'wait  (new-goal dir)  dir))
	       (elevator  'move  goal  dir))]
	    [(=  goal  floor)  
	     (elevator  'open  goal  dir)]
	    [(<  goal  floor)
	     (begin  
	       (move-down-floor)
	       (elevator  'arrive  goal  'down))]
	    [(>  goal  floor)
	     (begin  
	       (move-up-floor)
	       (elevator  'arrive  goal  'up))]
	    [else  (error 'elevator "Internal error in main loop")]))))

    ;;  Don't get stuck on the same floor forever.

    (define  clear-all-buttons
      (lambda  (floor) 
	(clear-up-call  floor)
	(clear-down-call  floor) 
	(clear-demand  floor)))

    ;;  Don't return until at least one button is pushed.

    (define  wait-for-request
      (lambda  ()
	(recur  loop  ([n  1])
	  (cond
	    [(> n (max-floor))  (wait-for-input)]
	    [(or  (up-call? n)  (down-call? n)  (demand? n))  #t]
	    [else  (loop  (add1 n))]))))

    ;;  Call the user's function Control and check that the floor is valid.

    (define  list-of-floors
      (lambda  ()
	(recur  loop  ([f  (max-floor)]  [l  null])
	  (cond
	    [(= f 0)  l]
	    [(or (up-call? f) (down-call? f) (demand? f))
	     (loop  (sub1 f)  (cons f l))]
	    [else  (loop  (sub1 f)  l)]))))

    (define  new-goal
      (lambda  (dir)
	(update-input)
	(let 
	  ([ans  (Next-Floor  dir (current-floor)  (list-of-floors))]) 
	  (if  (and  (integer? ans)  (exact? ans)  (<= 1 ans (max-floor)))
	    (begin  (info  'goal  ans)  ans)
	    (error 'Next-Floor "~e is not a valid floor number" ans)))))

    ;;  Functions to show the user.
    ;;  Remember, the elevator calls Next-Floor, not the other way.

    (define Next-Floor (lambda x (error 'Next-Floor "undefined")))
  
    (define  run 
      (lambda (f)
	(check-proc 'run f 3 'first "3 arguments")
	(set! Next-Floor f)
	(start-program)))

    ))

(compound-unit/sig
  (import (PLT : plt:userspace^))
  (link
    (GRAPHICS : graphics:posn-less^ ((require-library "graphicspr.ss" "graphics")
				     (PLT : mzlib:file^)
				     (PLT : mred^)
				     (PLT : graphics:posn^)))
    (ERR  : errorS (errorU))
    (DRAW : elevatorS (elevatorU ERR PLT GRAPHICS)))
  (export (open DRAW))) 
