#lang scheme/gui

(require htdp/big-draw
         htdp/error
         lang/prim
         lang/posn
         mzlib/etc)

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

(provide run)

(define-higher-order-primitive run run/proc (elevator-controller))

;;  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 einfo  (sym  posn  label  prev) #:mutable)

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

(define  init-info
  (lambda  ()
    (let  loop  ([l  INFO-LIST])
      (unless  (null? l)
        (set-einfo-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 (einfo-sym (car l)))  (car l)]
        [else  (loop  (cdr l))]))))

(define  info
  (lambda  (sym  obj)
    (let* ([item  (my-lookup sym)]
           [posn  (add-posn  INFO-ORIGIN  (einfo-posn item))]
           [str   (if (string? obj) obj (format "~s" obj))]
           [full-str  (string-append (einfo-label item) str)])
      (unless  (string=?  full-str  (einfo-prev item))
        (c-string  posn  (einfo-prev item))
        (d-string  posn  full-str)
        (set-einfo-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)
    (lambda () #t)))

;;
;;  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/proc 
  (lambda (f)
    (check-proc 'run f 3 'first "3 arguments")
    (set! Next-Floor f)
    (start-program)))