;;;; -*- Mode:LISP; Syntax:COMMON-LISP; Package:LIMO-EXAMPLE; Base:10 -*- ;;;; *-* File: g:/v-400/dev/source/gbb/examples/limo-example-graphics.lisp *-* ;;;; *-* Edited-By: kevin *-* ;;;; *-* Last-Edit: Mon Jun 14 14:44:51 1999 *-* ;;;; *-* Machine: FIELDSTONE *-* ;;;; ************************************************************************** ;;;; ************************************************************************** ;;;; * ;;;; * LIMO SCHEDULING PROBLEM (GRAPHICS MODIFICATIONS) ;;;; * ;;;; ************************************************************************** ;;;; ************************************************************************** ;;; ;;; Load this file if viewing the limo scheduling application using GBB's ;;; graphics facilities. ;;; ;;; Written by: Participants in ;;; ``Implementing Blackboard Applications'' ;;; Amherst, Massachusetts, December 5-7, 1990 ;;; ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ;;; ;;; 12-05-90 File created. ;;; 07-16-91 Added setup-windows option. (Cork) ;;; 09-21-98 Converted to GBB V4.0 (KTI) release. (Cork) ;;; ;;; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * (in-package "LIMO-EXAMPLE") ;;; --------------------------------------------------------------------------- (defvar *LIMO-WINDOW-BACKGROUND-COLOR* nil) (defvar *LIMO-WIDGET-BACKGROUND-COLOR* nil) (defvar *LIMO-WIDGET-FOREGROUND-COLOR* nil) (defvar *LIMO-WINDOW-FOREGROUND-COLOR* nil) ;;; --------------------------------------------------------------------------- (defvar *city-font* *small-italic-font*) (defvar *limo-bitmap* nil) (defvar *waiting-place-bitmap* nil) (defvar *limo-order-window* nil) (defvar *currently-placing-order* nil) (defun initialize-limo-graphics-objects () ;; Create the bitmaps used in the limo displays. (setf *limo-bitmap* (make-bitmap "Limo" (make-array '(7 11) :element-type 'bit :initial-contents '((0 0 0 1 1 1 1 1 0 0 0) (0 0 0 1 1 1 1 1 0 0 0) (1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1) (1 1 1 1 1 1 1 1 1 1 1) (0 0 1 1 1 0 0 1 1 1 0) (0 0 0 1 0 0 0 0 1 0 0))))) (setf *waiting-place-bitmap* (make-bitmap "Waiting Place" (make-array '(12 8) :element-type 'bit :initial-contents '((0 0 0 1 1 0 0 0) (0 0 1 0 0 1 0 0) (0 1 0 0 0 0 1 0) (0 1 0 0 0 0 1 0) (0 0 1 0 0 1 0 0) (0 0 0 1 1 0 0 0) (0 0 0 1 1 0 0 0) (0 0 0 1 1 0 0 0) (0 0 0 1 1 0 0 0) (0 0 0 1 1 0 0 0) (0 0 1 1 1 1 0 0) (0 1 1 1 1 1 1 0)))))) ;; Create the fonts and bitmaps when this file is loaded. (initialize-limo-graphics-objects) ;; Also, ensure that ChalkBox is reinitialized that the ;; limo fonts and bitmaps get rebuilt. (pushnew 'initialize-limo-graphics-objects *initialize-chalkbox-hooks*) ;;; --------------------------------------------------------------------------- (defmethod draw-unit ((obj place) widget x y &key foreground-color &allow-other-keys) (let* ((name (unit-name obj)) (space (position #\space name :test #'char=)) (the-font *city-font*)) ;; Draw a taxi stand sign for waiting places, otherwise draw the regular dot. (if (place.waiting-place obj) (draw-bitmap widget *waiting-place-bitmap* (- x 5) (- y 13)) (call-next-method)) ;; Draw the first few letters of the place name. (when (> (length name) 10) (setf name (subseq name 0 (if (and space (< space 10)) space 10)))) (draw-string widget name (+ 2 x) (+ 2 y) :foreground-color foreground-color :font the-font))) ;;; --------------------------------------------------------------------------- (defmethod draw-unit ((obj limo) widget x y &key &allow-other-keys) (call-next-method) ;; Draw a taxi icon in addition to the regular dot. (draw-bitmap widget *limo-bitmap* (- x 5) (- y 3))) ;;; --------------------------------------------------------------------------- ;;; Setup GBB graphics windows to show some interesting views. (defun SETUP-LIMO-WINDOWS () (unless (chalkbox-initialized-p) (unless (initialize-chalkbox) (return-from setup-limo-windows (values :stop "ChalkBox is not initialized.")))) ;; Put this in the application menu so the user can exit easily. (chalkbox::add-to-application-menu '("Exit Limo Example" . do-exit-limo-example)) ;; Do this now so it comes up right away the first time (make-interactive-get-order-menu :reset-places t :activate nil) ;; Ensure that this flag is cleared. (setf *currently-placing-order* nil) (setup-limo-colors) (labels ((setup (n paths x-dim y-dim label x y width height &rest args) (let* ((widget (apply #'setup-blackboard-widget n :label label :paths paths :x-dimension x-dim :y-dimension y-dim :x x :y y :width width :height height :foreground-color *limo-widget-foreground-color* :background-color *limo-widget-background-color* :activate nil args)) (window (widget-window widget))) (when window (setf (widget-foreground-color window) *limo-widget-foreground-color*) (setf (widget-background-color window) *limo-widget-background-color*)) window))) (let* ((width 0.375) (height 0.333) (logo-height (widget-outer-height *logo-window*)) (w1 ;; UPPER LEFT: Map window (setup 1 '(map) 'x 'y "Route Map" 0 0 width height :x-min 0 :x-max 1000 :y-min 0 :y-max 1000)) (w2 ;; UPPER RIGHT: Order window (setup 2 '((map) (orders)) 'x 'y "Orders Received" width 0 width height :x-min 0 :x-max 1000 :y-min 0 :y-max 1000 :unit-classes '(order place))) (w3 ;; LOWER LEFT: Time/Place window (setup 3 '(tasks) 'time 'place "Time/Place View" 0 height width height :x-tic-label-function 'time-tic-label-string)) (w4 ;; LOWER RIGHT: Task Status window (setup 4 '((map) (tasks)) 'x 'y "Planned Tasks" width height width height :x-min 0 :x-max 1000 :y-min 0 :y-max 1000 :unit-classes '(empty carrying-fare place))) (w5 ;; Task Interval (positioned on the right, below the logo window) (setup 5 '(tasks) 'time-interval 'task-status "Task Status" ;; x & y (* 2 width) logo-height ;; width (- 1.0 (* 2 width)) ;; height (- (* 2 height) (/ logo-height (screen-height))) :x-tic-label-function 'time-tic-label-string))) ;; Ensure the `Place an Order' window exists (when (control-shells::ks.enabled (get-unit 'get-order-interactive-ks)) (make-pow-window width)) ;; Deal with small screens, for more esthetic display: (let* ((mouse-window-width (min cb::*mouse-window-width* (floor (* 2 (screen-width)) 3))) (mouse-window-height (if (cb::widget-exists-p cb::*mouse-documentation-window*) cb::*mouse-window-height* 0)) #+(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL) (chain-manager-height 0)) (cond ((cb::small-screen-p) ;; We have a small screen so setup a chain of windows (let* ((cs-window (make-control-shell-window :activate nil)) (chain-manager (cb::setup-window-chain (list w1 w2 w3 w4 w5 cs-window) ;; Position & size of the windows in the chain :x 0 :y 0 :width mouse-window-width :height `(1.0 ,(- mouse-window-height)) ;; Initial position of the chain manager :chain-manager-x '(:right 0) :chain-manager-y (1+ logo-height) :chain-manager-width (- (screen-width) mouse-window-width)))) #-(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL) (declare (ignore chain-manager)) #+(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL) (setf chain-manager-height (widget-outer-height chain-manager))) ;; Adjust lisp listener window (if there is one). (let ((w (chalkbox::lisp-listener))) (when w (reshape-widget w :x `(:right 0) :y `(:bottom 0) :width 500 :height `(1.0 ,(- (+ logo-height #+(or (and :CL-ALLEGRO :OS-WINDOWS) :CL-MCL) chain-manager-height))))))) (t ;; Screen is large enough to tile the windows: (mapc #'activate-widget (list w1 w2 w3 w4 w5)) ;; Create the control shell window (make-control-shell-window :x 0 :y (* 2 height) :width mouse-window-width :height `(,height ,(- mouse-window-height)) :initial-configuration :landscape) ;; Adjust lisp listener window (if there is one). (let ((w (chalkbox::lisp-listener))) (when w (reshape-widget w :x `(:right 0) :y `(:bottom 0) :width (max 680 (- (screen-width) mouse-window-width)) :height `(1.0 ,(- (+ logo-height (widget-outer-height w5)))))))))) nil))) ;;; --------------------------------------------------------------------------- (defun do-exit-limo-example () (gbb-graphics::delete-all-bb-windows) (when (exists-window *control-shell-window*) (delete-widget *control-shell-window*)) (when (exists-window *limo-order-window*) (delete-widget *limo-order-window*)) (chalkbox::delete-from-application-menu '("Exit Limo Example" . do-exit-limo-example)) (control-shells::exit-control-shell)) ;;; --------------------------------------------------------------------------- (defun setup-limo-colors () (case (display-type) (:color (set-unit-color 'road *yellow*) (set-unit-color 'place *black*) (set-unit-color 'order *cyan*) (set-unit-color 'carrying-fare *red*) (set-unit-color 'empty *green*) (setf *limo-window-background-color* *gray*) (setf *limo-window-foreground-color* *black*) (setf *limo-widget-background-color* *lightgray*) (setf *limo-widget-foreground-color* *blue*)) (:grayscale (setf *limo-window-background-color* *gray*) (setf *limo-window-foreground-color* *black*) (setf *limo-widget-background-color* *lightgray*) (setf *limo-widget-foreground-color* *black*)) (:monochrome (setf *limo-window-background-color* *white*) (setf *limo-window-foreground-color* *black*) (setf *limo-widget-background-color* *white*) (setf *limo-widget-foreground-color* *black*)))) ;;; --------------------------------------------------------------------------- (defmethod time-tic-label-string (time widget axis &optional data) ;; This method returns a string for the time TIME in normal time ;; syntax rather than the internal representation which is the ;; number of minutes from 9:00am. (declare (ignore widget axis data)) (pretty-time time)) ;;; ------------------------------------------------------------------------ (defun make-pow-window (width) (cond ((exists-window *limo-order-window*) *limo-order-window*) (t (let* ((logo-width (widget-outer-width *logo-window*)) (logo-height (widget-outer-height *logo-window*)) (limo-windows-width (* 2 width *screen-width*)) (fgnd "Blue") (window (make-window 'window :x limo-windows-width :y 0 :width (- *screen-width* limo-windows-width logo-width) :height logo-height #+(and :CL-ALLEGRO :OS-WINDOWS) :border-type #+(and :CL-ALLEGRO :OS-WINDOWS) :none))) (make-widget 'command-button :parent window :value "Place an order" :x :center :y :center :border-size 4 :font "Normal Bold" :foreground-color fgnd :function 'place-an-order) (setf *limo-order-window* window))))) ;;; ------------------------------------------------------------------------ (defun place-an-order (&rest rest) (declare (ignore rest)) (cond (*currently-placing-order* (cb::beep)) (t (setf *currently-placing-order* t) (signal-event 'get-order-event)))) ;;; ------------------------------------------------------------------------ ;;; LIMO ORDERS MENU ;;; ------------------------------------------------------------------------ (defclass limo-order-menu (chalkbox::menu-window) ()) (defvar *limo-order-menu* nil) ;; Set *limo-order-menu* to nil when the window is deleted (defmethod chalkbox::handle-delete-widget :after ((widget limo-order-menu)) (setf *limo-order-menu* nil)) ;;; ------------------------------------------------------------------------ (defun GET-ORDER-INTERACTIVE (ksa) (declare (ignore ksa)) (cb::mouse-call "Menu" #'(lambda () (with-abort-computation-handler (get-order-interactive-internal) :STOP)))) (defun get-order-interactive-internal () ;; Create the menu (make-interactive-get-order-menu) ;; Activate the menu and wait for the user to enter an order (cb::activate-menu-window-and-wait *limo-order-menu* :delete-widgets-p nil) ;; If the user deleted the window then exit (when (null *limo-order-menu*) (return-from get-order-interactive-internal nil)) ;; The user is all done, deactivate the menu (deactivate-widget *limo-order-menu*) ;; Clear the state (setf *currently-placing-order* nil) ;; If the user clicked 'quit' then exit the limo-example (when (cb::menu-cancel *limo-order-menu*) (return-from get-order-interactive-internal nil)) ;; Extract the order values and create an order: (let* ((selections (cb::return-selections *limo-order-menu*)) (origin (cdr (assoc :origin selections))) (dest (cdr (assoc :destination selections))) (time (cdr (assoc :pickup-time selections))) (people (cdr (assoc :passengers selections)))) ;; Convert time to minutes after 9:00 (unless (numberp time) (setf time (parse-time time))) ;; Create the order (make-unit 'order :route (list origin dest) :pickup-time time :n-passengers people))) ;;; ------------------------------------------------------------------------ (defun make-interactive-get-order-menu (&key (activate t) (reset-places nil) (delete nil)) ;; Make the `Get Order' menu. ;; If :reset-places is true then the two place widgets will be cleared. ;; If :delete is true then any existing menu will be deleted. (when (and *limo-order-menu* (or delete (not (exists-window *limo-order-menu*)))) (when (exists-window *limo-order-menu*) (delete-widget *limo-order-menu*)) (setf *limo-order-menu* nil)) (let* ((window (or *limo-order-menu* (make-get-order-menu-internal))) (origin (find-widget window :origin)) (destination (find-widget window :destination))) (cond (reset-places (setf (widget-item-list origin) nil) (setf (widget-item-list destination) nil)) ((null (widget-item-list origin)) (let ((item-list ;; Build an item list of all the places, sorted alphabetically (mapcar #'(lambda (name) `(,name :value ,(get-unit name 'place))) (all-place-names)))) (setf (widget-item-list origin) item-list) (setf (widget-item-list destination) item-list))) (t nil)) (setf (cb::menu-all-done window) nil) (setf (cb::menu-cancel window) nil) (when activate (activate-widget window)) (setf *limo-order-menu* window))) (defun make-get-order-menu-internal () (let ((window (make-window 'limo-order-menu :label "Enter a Limo Order" :activate nil))) ;; Create the widgets (cb::make-widget-menu ;; Parent window ;; Kids `(((:origin textscroll-widget :label "Origin" :height-in-items 10 :selection-type :exactly-one :mouse-documentation #.(cb::make-mouse-documentation :mouse-left "Select the pickup place.")) (:destination textscroll-widget :label "Destination" :height-in-items 10 :selection-type :exactly-one :mouse-documentation #.(cb::make-mouse-documentation :mouse-left "Select a destination place."))) (:pickup-time text-input-widget :label "Pickup time: " :validation-function valid-limo-time-p :item-alignment :right :auto-height-p nil :mouse-documentation #.(cb::make-mouse-documentation :mouse-left "Select a pickup time.") :initial-value "11:00") (:passengers radio-buttons-widget :label "Number of passengers: " :item-list (1 2 3 4) :item-horizontal-alignment :spread :selection-type :exactly-one :auto-height-p nil :mouse-documentation #.(cb::make-mouse-documentation :mouse-left "Choose the number of passengers.") :initial-value 1) :max-width) :buttons `((:OK :override :value "Place order") :RESET (:CANCEL :override :value "Dismiss" :mouse-documentation "Dismiss the menu") :spread* :max-width) :label "Limo Order Menu") (refresh-widget window) window)) ;;;-------------------------------------------------------------------;;; ;;; This is the validation function for the pickup-time. It assures ;;; that the text typed in by the user in the form HH:MM (defun valid-limo-time-p (widget text) (declare (ignore widget)) (let ((time (parse-time text))) (cond (time (values :new-value time)) (t (values nil (format nil "The time you have entered, ~a, is invalid. ~ Please enter a valid time in the form HH:MM.~%~%~%~ Also note that the Lazy Limo limousine service ~ is only open from 9:00 AM to 5:00 PM, Monday ~ through Friday. We thank you for your patronage.~%" text)))))) ;;; ------------------------------------------------------------------------ ;;; End of File ;;; ------------------------------------------------------------------------