From 41a34e29e27546b44e4c398e25161138ffb7fb8c Mon Sep 17 00:00:00 2001
From: cer <cer>
Date: Fri, 31 Jan 1992 14:32:12 +0000
Subject: [PATCH] Initial revision

---
 demo/address-book.lisp   |  208 +++++
 demo/cad-demo.lisp       |  923 +++++++++++++++++++++
 demo/demo-driver.lisp    |   72 ++
 demo/demo-prefill.lisp   |  152 ++++
 demo/graphics-demos.lisp |  268 ++++++
 demo/listener.lisp       |  510 ++++++++++++
 demo/navdata.lisp        |  176 ++++
 demo/navfun.lisp         | 1665 ++++++++++++++++++++++++++++++++++++++
 demo/packages.lisp       |   20 +
 demo/puzzle.lisp         |  189 +++++
 demo/sysdcl.lisp         |   65 ++
 demo/thinkadot.lisp      |  192 +++++
 12 files changed, 4440 insertions(+)
 create mode 100644 demo/address-book.lisp
 create mode 100644 demo/cad-demo.lisp
 create mode 100644 demo/demo-driver.lisp
 create mode 100644 demo/demo-prefill.lisp
 create mode 100644 demo/graphics-demos.lisp
 create mode 100644 demo/listener.lisp
 create mode 100644 demo/navdata.lisp
 create mode 100644 demo/navfun.lisp
 create mode 100644 demo/packages.lisp
 create mode 100644 demo/puzzle.lisp
 create mode 100644 demo/sysdcl.lisp
 create mode 100644 demo/thinkadot.lisp

diff --git a/demo/address-book.lisp b/demo/address-book.lisp
new file mode 100644
index 00000000..9ab63790
--- /dev/null
+++ b/demo/address-book.lisp
@@ -0,0 +1,208 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: address-book.lisp,v 1.4 91/03/26 12:37:27 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990 International Lisp Associates.  All rights reserved."
+
+;;; Define a simple CLIM program.  This program maintains a simple address book.
+;;; First, we need a minimal address database.
+
+;;; A structure to hold each address
+(defclass address ()
+    ((name :initarg :name :accessor address-name)
+     (address :initarg :address :accessor address-address)
+     (number :initarg :number :accessor address-number))
+  (:default-initargs :name "Unsupplied" :address "Unsupplied" :number "Unsupplied"))
+
+;;; Database maintenance.
+(defun make-address (&key name address number)
+  (make-instance 'address :name name :address address :number number))
+
+;;; A support utility.
+(defun last-name (name)
+  (subseq name (1+ (or (position #\Space name :test #'char-equal :from-end T) -1))))
+
+;;; And a function which operates on the address class.
+(defun address-last-name (address)
+  (last-name (address-name address)))
+
+;;; A place to keep addresses.
+(defvar *addresses* nil)
+
+(defun add-address (address)
+  ;; Obviously could deal with multiple address entries with same name
+  ;; here, but that's outside the scope of this demo.
+  (pushnew address *addresses* :key #'address-name :test #'string-equal)
+  (setq *addresses* (sort *addresses* #'string-lessp :key #'address-last-name)))
+
+(progn
+  (add-address (make-address :name "Bill York"
+			     :address "ILA, Mountain View"
+			     :number "415-968-3656"))
+  (add-address (make-address :name "Dennis Doughty"
+			     :address "ILA, Cambridge"
+			     :number "617-576-1151"))
+  (add-address (make-address :name "Mark Son-Bell"
+			     :address "ILA, Cambridge"
+			     :number "617-576-1151"))
+  (add-address (make-address :name "Richard Lamson"
+			     :address "ILA, San Francisco"
+			     :number "415-661-5477")))
+
+;;; --------------------------------
+;;; Define the user interface here.
+;;;
+;;; First, we define a presentation type for address, which enables us to make them
+;;; mouse-sensitive.  We define the :printer for the presentation-type to print out just
+;;; the personal name of the address entry.
+
+(define-presentation-type address ())
+
+(define-presentation-method present (object (type address) stream view &key)
+  (write-string (address-name object) stream))
+
+;;; For translators
+(define-presentation-type address-name ())
+(define-presentation-type address-address ())
+(define-presentation-type address-number ())
+
+;;; Define a method for displaying the "Rolodex" form of entry.  
+;;; This will be redisplayed efficiently by CLIM's updating output facility.
+;;; [Note that the addition of calls to UPDATING-OUTPUT with specific cache values
+;;; could be inserted around each of the fields here to improve the performance if the
+;;; amount of information on display became large.  The trade-off would be the relative
+;;; speed difference between whatever mechanism would be used to compare unique-ids and 
+;;; cache-values (typically EQL) versus the default mechanism for comparing strings
+;;; (STRING-EQUAL).]
+(defmethod display-address ((address-to-display address) stream)
+  (with-slots (name address number) address-to-display
+    (with-text-face (stream :italic)
+      (write-string "Name: " stream))
+    (with-output-as-presentation (stream address-to-display 'address-name)
+      (write-string name stream))
+    (terpri stream)
+    (with-text-face (stream :italic)
+      (write-string "Address: " stream))
+    (with-output-as-presentation (stream address-to-display 'address-address)
+      (write-string address stream))
+    (terpri stream)
+    (with-text-face (stream :italic)
+      (write-string "Number: " stream))
+    (with-output-as-presentation (stream address-to-display 'address-number)
+      (write-string number stream))))
+
+;;; Define the application-frame for our application
+(define-application-frame address-book
+			  ()
+    ;; This application has two state variables, the currently displayed
+    ;; address and the window from which user queries should be read.
+    ((current-address :initform nil)
+     (interaction-pane )
+     (name-pane))
+  (:panes
+    ((interactor :interactor)
+     (menu :command-menu)
+     (address :application
+	      :incremental-redisplay t
+	      :display-function 'display-current-address)
+     (names :application
+	    :incremental-redisplay t
+	    :display-function 'display-names)))
+  (:layout
+    ((default
+       (:column 1
+	(:row 1/2
+	 (address 1/2)
+	 (names :rest))
+	(menu :compute)
+	(interactor :rest))))))
+
+;;; This is the display-function for the upper-left pane, which specified 
+;;; :display-function '(incremental-redisplay-display-function display-current-address).
+(defmethod display-current-address ((frame address-book) stream)
+  (let ((current-address (slot-value frame 'current-address)))
+    (when current-address
+       (updating-output (stream :unique-id current-address)
+	 (display-address current-address stream)))))
+
+;;; This is the display-function for the upper-right pane, which specified
+;;; :display-function '(display-names).
+(defmethod display-names ((frame address-book) stream)
+  (dolist (address *addresses*)
+    ;; PRESENT invokes the :PRINTER for the ADDRESS presentation-type, defined above.
+    ;; It also makes each address printed out mouse-sensitive.
+    (updating-output (stream :unique-id address)
+      (present address 'address :stream stream)
+      (terpri stream))))
+
+(define-address-book-command (com-quit-address-book :menu "Quit")
+   ()
+ (frame-exit *application-frame*))
+
+(define-address-book-command com-select-address
+    ((address 'address :gesture :select))
+   (setf (slot-value *application-frame* 'current-address) address))
+
+(define-address-book-command (com-new-address :menu "New")
+    ()
+   (let ((name nil)
+	 (address nil)
+	 (number nil))
+     (let ((stream (frame-query-io *application-frame*)))
+       (window-clear stream)
+       ;; ACCEPTING-VALUES collects all calls to ACCEPT within its body
+       ;; into dialog entries and allows parallel, random editing of the fields.
+       ;; In this case, a dialog that looks like:
+       ;;  Name: a string
+       ;;  Address: a string
+       ;;  Number: a string
+       ;; is produced, where each "a string" is sensitive and can be edited.
+       (accepting-values (stream)
+	 (setq name (accept 'string :stream stream :prompt "Name"))
+	 (terpri stream)
+	 (setq address (accept 'string :stream stream :prompt "Address"))
+	 (terpri stream)
+	 (setq number (accept 'string :stream stream :prompt "Number")))
+       (window-clear stream)
+       (add-address (make-address :name name :address address :number number)))))
+
+(define-address-book-command com-delete-address
+    ((address 'address :gesture :delete))
+   (setf *addresses* (delete address *addresses*)))
+
+(define-address-book-command com-change-address-name
+    ((address 'address-name :gesture :select))
+  (let ((new-name (accept 'string :stream (frame-query-io *application-frame*)
+			  :prompt "New name" :default (address-name address))))
+    (setf (address-name address) new-name)
+    (setq *addresses* (sort *addresses* #'string-lessp :key #'address-last-name))))
+
+(define-address-book-command com-change-address-address
+    ((address 'address-address :gesture :select))
+  (let ((new-address (accept 'string :stream (frame-query-io *application-frame*)
+			     :prompt "New address" :default (address-address address))))
+    (setf (address-address address) new-address)))
+
+(define-address-book-command com-change-address-number
+    ((address 'address-number :gesture :select))
+  (let ((new-number (accept 'string :stream (frame-query-io *application-frame*)
+			    :prompt "New number" :default (address-number address))))
+    (setf (address-number address) new-number)))
+
+(defvar *address-books* nil)
+
+(defun address-book (&key reinit root)
+  (let ((book (cdr (assoc root *address-books*))))
+    (when (or (null book) reinit)
+      (multiple-value-bind (left top right bottom)
+	  (size-demo-frame root 100 100 500 400)
+	(setq book (make-application-frame 'address-book :parent root
+					   :left left :top top
+					   :right right :bottom bottom)))
+      (push (cons root book) *address-books*))
+    (run-frame-top-level book)))
+
+(define-demo "Address Book" (address-book :root *demo-root*))
+
diff --git a/demo/cad-demo.lisp b/demo/cad-demo.lisp
new file mode 100644
index 00000000..dc0f6c77
--- /dev/null
+++ b/demo/cad-demo.lisp
@@ -0,0 +1,923 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: new-cad-demo.lisp,v 1.5 91/03/26 12:37:37 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+;;; A simple gate-level CAD program.
+
+;;; First we define the application-specific data structures, the components and their
+;;; connection terminals.  The only part of the user interface specified at this
+;;; level is the displayed representation (appearance) of the entities when they
+;;; are drawn on the screen.
+
+(defclass basic-thing (presentation displayed-output-record)
+     ((x :initarg :x :accessor thing-x)
+      (y :initarg :y :accessor thing-y)
+      (size :initarg :size :accessor thing-size)))
+
+(defmethod bounding-rectangle* ((thing basic-thing))
+  (with-slots (x y size) thing
+    #-Silica (declare (fixnum x y size))
+    (values x y (+ x size) (+ y size))))
+
+(defmethod region-contains-point*-p ((thing basic-thing) x y)
+  (with-bounding-rectangle* (left top right bottom) thing
+    (and (<= left x)
+	 (<= top y)
+	 (>= right x)
+	 (>= bottom y))))
+
+(defmethod output-record-start-cursor-position* ((thing basic-thing))
+  (values 0 0))
+
+;; NEW-X and NEW-Y had better be fixnums
+(defmethod output-record-set-position* ((thing basic-thing) new-x new-y)
+  (with-slots (x y) thing
+    (setf x new-x y new-y)))
+
+(defmethod map-over-output-records-overlapping-region
+	   (function (thing basic-thing) region
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (ignore region function x-offset y-offset continuation-args))
+  (declare (dynamic-extent continuation-args))
+  nil)
+
+(defmethod map-over-output-records-containing-point*
+	   (function (thing basic-thing) x y
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (ignore x y function x-offset y-offset continuation-args))
+  (declare (dynamic-extent continuation-args))
+  nil)
+
+(defmethod tree-recompute-extent ((thing basic-thing))
+  nil)
+
+(defvar *draw-connections* t)
+(defmethod replay-output-record ((thing basic-thing) stream
+				 &optional region (x-offset 0) (y-offset 0))
+  (declare (ignore region x-offset y-offset))
+  (if *draw-connections*
+      (draw-self thing stream)
+      (draw-body thing stream)))
+
+(defmethod output-record-parent ((thing basic-thing))
+  *application-frame*)
+
+(defmethod output-record-refined-sensitivity-test ((comp basic-thing) x y)
+  (declare (ignore x y))
+  t)
+
+(defmethod presentation-single-box ((thing basic-thing)) nil)
+
+(defmethod presentation-object ((thing basic-thing))
+  thing)
+
+(defmethod thing-position ((thing basic-thing))
+  (with-slots (x y) thing
+    (values x y)))
+
+;; NEW-X and NEW-Y had better be fixnums
+(defmethod move ((thing basic-thing) new-x new-y)
+  (with-slots (x y) thing
+    (setf x new-x y new-y)))
+
+
+;;;****************************************************************
+
+;;; This is +red+ for color systems, otherwise +flipping-ink+.
+(defvar *highlight-ink* +flipping-ink+)
+
+(defvar *component-size* 
+	#+Imach (sys:system-case
+		  (:macivory 18)
+		  (otherwise 25))
+	#-Imach 25
+ "Default display size of a component.")
+
+;;; A connection belongs to a component.  The component may have any number of
+;;; input and output connections, although currently only one output is supported.
+(defclass connection
+	  (basic-thing)
+     ((component :initform nil :initarg :component :accessor connection-component)
+      (other-connections :initform nil :accessor connection-other-connections)
+      ;; Give wire router some hints
+      (early :initarg :early :reader connection-early-p)
+      (wire-offset :initarg :wire-offset :reader connection-wire-offset))
+  (:default-initargs :size 5 :early nil :wire-offset 20))
+
+(defmethod draw-body ((connection connection) stream &key (ink +foreground-ink+))
+  ;; Don't do a thing
+  )
+
+(defmethod draw-self ((connection connection) stream &key (ink +foreground-ink+))
+  (with-slots (x y size) connection
+    (draw-circle* stream x y size
+		  ;; compute filled from the value,
+		  ;; white for on, black for off
+		  :filled (not (connection-value connection))	;required method
+		  :ink ink)))
+
+(defmethod highlight-output-record-1 ((connection connection) stream state)
+  (if (eq *highlight-ink* +flipping-ink+)
+      (with-slots (x y size) connection
+	(draw-circle* stream x y (1+ size)
+		      :filled t :ink +flipping-ink+))
+      (ecase state
+	(:highlight (draw-self connection stream :ink *highlight-ink*))
+	(:unhighlight (draw-self connection stream :ink +foreground-ink+)))))
+
+(defmethod bounding-rectangle* ((conn connection))
+  (let ((fudge 2))
+    (with-slots (x y size) conn
+      #-Silica (declare (fixnum x y size))
+      ;; size is a radius, but make the box larger so that connections
+      ;; are easier to point to
+      (values (- x size fudge) (- y size fudge)
+	      (+ x size fudge) (+ y size fudge)))))
+
+(defun connect (output input)
+  ;; Inputs can have only one incoming connection, so remove this input
+  ;; from its former incoming connection's outputs list.
+  (with-slots (other-connections) input
+    (when other-connections
+      (setf (connection-other-connections (first other-connections))
+	    (remove input (connection-other-connections (first other-connections)))))
+    (setf other-connections (list output)))
+  ;; Add this input to the list of other-connections of the output.
+  (push input (connection-other-connections output)))
+
+;;; Sort of hairy, but it always computes a connection's position relative to
+;;; the current position of its owning component.  So, when the component is moved
+;;; the new connection position is reflected immediately.
+(defun compute-connection-position (connection)
+  (with-slots (component) connection
+    ;;--- CLOS bug, can't use COMPONENT in subsequent WITH-SLOTS
+    (let ((foo component))
+      (with-slots (x y inputs outputs) foo
+	;; We don't deal with multiple outputs
+	(assert (<= (length outputs) 1) nil
+		"Don't know how to handle multiple outputs")
+	(cond ((member connection outputs)
+	       ;; The output has a constant location
+	       (return-from compute-connection-position
+		 (values (+ x *component-size*) y)))
+	      ((member connection inputs)
+	       ;; Divide up the available space (the height of the
+	       ;; component) among the inputs, then figure out which input we are
+	       ;; interested in and therefore how far down it is.
+	       (let ((spacing (floor (* *component-size* 2) (1+ (length inputs))))
+		     ;; Start at the top of the component
+		     (y-pos (- y *component-size*)))
+		 (let ((index (position connection inputs)))
+		   (return-from compute-connection-position
+		     (values x (+ y-pos (* spacing (1+ index))))))))
+	      (t (error "Connection ~S is not among the connections of its component ~S"
+			connection component)))))))
+
+#-Allegro
+(defclass input (connection) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass input (connection) ()))
+
+(defmethod presentation-type ((input input))
+  'input)
+
+;;; An input connection's logic value is determined by the value of the output
+;;; connection that is feeding it.
+(defmethod connection-value ((conn input))
+  (with-slots (other-connections) conn
+    (assert (<= (length other-connections) 1)
+	    nil
+	    "Don't know how to handle multiple inputs to one connection.")
+    ;; Floating inputs default to "off"
+    (when other-connections
+      (connection-value (first other-connections)))))
+
+#-Allegro
+(defclass output (connection) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass output (connection) ()))
+
+(defmethod presentation-type ((output output))
+  'output)
+
+;;; An output connection's logic value is computed from the inputs by the
+;;; component.
+(defmethod connection-value ((conn output))
+  (connection-value (slot-value conn 'component)))
+
+;;;****************************************************************
+
+
+#-Allegro
+(defclass component
+	  (basic-thing)
+     ((inputs :initform nil)
+      (outputs :initform nil))
+  (:default-initargs :size *component-size*))
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass component
+	    (basic-thing)
+      ((inputs :initform nil)
+       (outputs :initform nil))
+    (:default-initargs :size *component-size*)))
+
+;;; Fill in the inputs and outputs from the init args.
+(defmethod initialize-instance :after ((component component) &key (n-inputs 1) (n-outputs 1))
+  ;; This early-p stuff is all a big kludge to get slightly better wire routing
+  (let ((early-p nil)
+	(offset-1 20)
+	(offset-2 30))
+    (flet ((make-one (type component)
+	     (prog1 (make-instance type :component component
+				   :early early-p
+				   :wire-offset offset-1)
+		    (rotatef offset-1 offset-2)
+		    (setq early-p (not early-p)))))
+      (dotimes (n n-inputs)
+	(push (make-one 'input component) (slot-value component 'inputs)))
+      (setq early-p nil)
+      (setq offset-1 20 offset-2 30)
+      (dotimes (n n-outputs)
+	(push (make-one 'output component) (slot-value component 'outputs)))))
+  ;; Place the newly-created connections relative to the component
+  (move component (thing-x component) (thing-y component)))
+
+(defun all-connections (component)
+  (with-slots (inputs outputs) component
+    (append inputs outputs)))
+
+;;; When a component is added to the database, add its connections
+(defmethod add-new-object :after (cd (new-object component))
+  (dolist (conn (all-connections new-object))
+    (add-new-object cd conn)))
+
+(defmethod move :after ((component component) new-x new-y)
+  (declare (ignore new-x new-y))
+  (dolist (conn (all-connections component))
+    (multiple-value-bind (x y)
+	;; place the connections relative to their component
+	(compute-connection-position conn)
+      (move conn x y))))
+
+;;; Call this on a component to display the whole thing
+(defmethod draw-self ((component component) stream &key (ink +foreground-ink+))
+  (draw-body component stream :ink ink)
+  (draw-connections component stream :ink ink)
+  (draw-wires component stream :ink ink))
+
+;; Elegant, ain't we?
+;; Why the hell can't Genera draw half circles in :ALU :FLIP?
+;; Note the superb attention to detail in the selection of the
+;; *ONLY* magic numbers that appear to work.
+(defvar *component-start-angle* (+ #+genera .00001 (* pi 3/2)))
+(defvar *component-end-angle* (+ #+genera .000001 (* pi 1/2)))
+
+;;; Default body is a half-circle
+(defmethod draw-body ((comp component) stream &key (ink +foreground-ink+))
+  (with-slots (x y size) comp
+    (draw-circle* stream x y size
+		  :start-angle *component-start-angle*
+		  :end-angle *component-end-angle*
+		  :ink ink)))
+
+;;; make a component behave as an output record
+(defmethod bounding-rectangle* ((comp component))
+  (with-slots (x y size) comp
+    ;; Not (- X SIZE) because the component is a half-circle
+    (values x (- y size) (+ x size) (+ y size))))
+
+;; NEW-X and NEW-Y had better be fixnums
+(defmethod output-record-set-position* ((thing basic-thing) new-x new-y)
+  (with-slots (x y size) thing
+    (setf x new-x y (+ new-y size))))
+
+
+(defmethod presentation-type ((comp component))
+  'component)
+
+(defmethod highlight-output-record-1 ((comp component) stream state)
+  (if (eq *highlight-ink* +flipping-ink+)
+      (with-slots (x y size) comp
+	(draw-circle* stream x y (1+ size)
+		      :start-angle *component-start-angle*
+		      :end-angle *component-end-angle*
+		      :ink +flipping-ink+))
+      (ecase state
+	(:highlight (draw-body comp stream :ink *highlight-ink*))
+	(:unhighlight (draw-body comp stream :ink +foreground-ink+)))))
+
+(defmethod draw-connections ((comp component) stream &key (ink +foreground-ink+))
+  (dolist (conn (all-connections comp))
+    (draw-self conn stream :ink ink)))
+
+(defvar *draw-junctions* t)
+
+;;; This guy is responsible for wire layout.  It doesn't have any global
+;;; knowledge, so it can't avoid running over things or draw little humps
+;;; where unconnected wires cross.
+(defmethod draw-wires ((comp component) stream &key (ink +foreground-ink+))
+  (with-slots (inputs outputs) comp
+    (labels ((round-val (val &optional (direction :down))
+	       (let ((chunk-size 20))
+		 (ecase direction
+		   (:up (incf val chunk-size))
+		   (:down (decf val chunk-size) ))
+		 (* chunk-size (round val chunk-size))))
+	     (draw-junction (x y)
+	       (when *draw-junctions*
+		 (draw-rectangle* stream (- x 2) (- y 2) (+ x 3) (+ y 3) :ink ink)))
+	     ;; Various routing helper functions.
+	     ;; This one forks near X2, rounding down to the next CHUNK-SIZE
+	     ;; X coord.
+	     (draw-path-fork-late (x1 y1 x2 y2)
+	       (draw-line* stream x1 y1 (round-val x2) y1 :ink ink)
+	       (draw-junction (round-val x2) y1)
+	       (draw-line* stream (round-val x2) y1 (round-val x2) y2 :ink ink)
+	       (draw-junction (round-val x2) y2)
+	       (draw-line* stream (round-val x2) y2 x2 y2 :ink ink))
+	     ;; This one forks near X1, rouding up to the next CHUNK-SIZE
+	     ;; X coord.
+	     (draw-path-fork-early (x1 y1 x2 y2)
+	       (draw-line* stream x1 y1 (round-val x1 :up) y1 :ink ink)
+	       (draw-junction (round-val x1 :up) y1)
+	       (draw-line* stream (round-val x1 :up) y1 (round-val x1 :up) y2 :ink ink)
+	       (draw-junction (round-val x1 :up) y2)
+	       (draw-line* stream (round-val x1 :up) y2 x2 y2 :ink ink))
+	     ;; This one forks near X2, splitting off OFFSET units away.
+	     (draw-path-fork-late-offset (x1 y1 x2 y2 offset)
+	       (let ((x-mid (- x2 offset)))
+		 (draw-line* stream x1 y1 x-mid y1 :ink ink)
+		 (draw-line* stream x-mid y1 x-mid y2 :ink ink)
+		 (draw-line* stream x-mid y2 x2 y2 :ink ink)))
+	     ;; Path policy functions.  The one currently named DRAW-WIRE wins.
+	     ;; This one forks late, extracting the offset from the connection.
+	     ;; (see the code that creates connections)
+	     (draw-wire-conn-offset (connection direction)
+	       (dolist (other-conn (connection-other-connections connection))
+		 (let ((conn connection))
+		   ;; Always draw line from :FROM to :TO
+		   (ecase direction
+		     (:to (rotatef conn other-conn))
+		     (:from ))
+		   (multiple-value-bind (x y) (thing-position conn)
+		     (multiple-value-bind (ox oy) (thing-position other-conn)
+		       (draw-path-fork-late-offset x y ox oy (connection-wire-offset other-conn)))))))
+	     ;; This one forks early or late depending on a value stored in the connection
+	     ;; at make-instance time.
+	     (draw-wire #+ignore -early-late (connection direction)
+	       (dolist (other-conn (connection-other-connections connection))
+		 (let ((conn connection))
+		   ;; Always draw line from :FROM to :TO
+		   (ecase direction
+		     (:to (rotatef conn other-conn))
+		     (:from ))
+		   (multiple-value-bind (x y) (thing-position conn)
+		     (multiple-value-bind (ox oy) (thing-position other-conn)
+		       (if (connection-early-p other-conn)
+			   (draw-path-fork-early x y ox oy)
+			   (draw-path-fork-late x y ox oy)))))))
+	     ;; This one simply forks early for all connections.
+	     (draw-wire-early (connection direction)
+	       (multiple-value-bind (x y) (thing-position connection)
+		 (dolist (oc (connection-other-connections connection))
+		   (multiple-value-bind (ox oy)
+		       (thing-position oc)
+		     ;;(draw-line stream x y ox oy :ink ink)
+		     ;; The draw-path guys need to know left-to-right ordering
+		     ;; to do their jobs.
+		     (ecase direction
+		       (:to (draw-path-fork-early ox oy x y))
+		       (:from (draw-path-fork-early x y ox oy)))))))
+	     ;; This one simply forks late for all connections.
+	     (draw-wire-late (connection direction)
+	       (multiple-value-bind (x y) (thing-position connection)
+		 (dolist (oc (connection-other-connections connection))
+		   (multiple-value-bind (ox oy)
+		       (thing-position oc)
+		     ;;(draw-line stream x y ox oy :ink ink)
+		     ;; The draw-path guys need to know left-to-right ordering
+		     ;; to do their jobs.
+		     (ecase direction
+		       (:to (draw-path-fork-late ox oy x y))
+		       (:from (draw-path-fork-late x y ox oy))))))))
+      (dolist (i inputs)
+	(draw-wire i :to))
+      (dolist (o outputs)
+	(draw-wire o :from)))))
+
+;;; Various components
+
+(defclass and-gate
+	  (component)
+     ()
+  (:default-initargs :n-inputs 2))
+
+(defmethod connection-value ((ag and-gate))
+  (every #'connection-value (slot-value ag 'inputs)))
+
+(defmethod equation-part ((ag and-gate))
+  (let ((equation nil))
+    (dolist (in (slot-value ag 'inputs))
+      (let ((out (first (connection-other-connections in))))
+	(when out
+	  (unless (null equation)
+	    (push "&" equation))
+	  (push (equation-part (connection-component out))
+		equation))))
+    equation))
+
+(defclass or-gate
+	  (component)
+     ()
+  (:default-initargs :n-inputs 2))
+
+(defmethod connection-value ((og or-gate))
+  (some #'connection-value (slot-value og 'inputs)))
+
+(defmethod equation-part ((og or-gate))
+  (let ((equation nil))
+    (dolist (in (slot-value og 'inputs))
+      (let ((out (first (connection-other-connections in))))
+	(when out
+	  (unless (null equation)
+	    (push "|" equation))
+	  (push (equation-part (connection-component out))
+		equation))))
+    equation))
+
+;; Elegant, ain't we?
+;; Why the hell can't Genera draw half circles in :ALU :FLIP?
+;; Note the superb attention to detail in the selection of the
+;; *ONLY* magic numbers that appear to work.
+(defvar *or-gate-start-angle* (+ #+genera .00001 (* pi 3/2) -0.3))
+(defvar *or-gate-end-angle* (+ #+genera .000001 (* pi 1/2) 0.3))
+
+;;; Default body is an almost-half-circle, so we get a different look
+;;; for OR gates.  Looks marginal and XOR's funny under Genera.
+(defmethod draw-body ((comp or-gate) stream &key (ink +foreground-ink+))
+  (with-slots (x y size) comp
+    (draw-circle* stream x y size
+		  :start-angle *or-gate-start-angle*
+		  :end-angle *or-gate-end-angle*
+		  :ink ink)))
+
+(defclass logic-constant
+	  (component)
+     ((name :initform nil)
+      (value :initarg :value))
+  (:default-initargs :n-inputs 0))
+
+(defvar *name-code* (1- (char-code #\A)))
+
+(defmethod initialize-instance :after ((lc logic-constant) &key)
+	   (when *name-code*
+	     (setf (slot-value lc 'name)
+		   (string (code-char (incf *name-code*))))))
+
+(defmethod connection-value ((component logic-constant))
+  (slot-value component 'value))
+
+(defmethod equation-part ((lc logic-constant))
+  (slot-value lc 'name))
+
+;;; Draw the logic "variable" name next to the component, or erase it.
+;;; ---kludge since we have no draw-glyphs yet
+(defmethod draw-body :after ((lc logic-constant) stream &key (ink +foreground-ink+))
+	   (with-slots (x y name) lc
+	     (when name
+	       (cond ((eq ink +background-ink+)
+		      ;;--- gee, am I getting carried away?
+		      (multiple-value-bind (nx ny)
+			  (drawing-surface-to-viewport-coordinates stream x y)
+			(window-clear-area stream (- nx 10) (- ny 10) nx (+ ny 20))))
+		     (t
+		      (draw-text* stream name (- x 10) (- y 10)))))))
+
+(defclass logic-one
+	  (logic-constant)
+     ()
+  (:default-initargs :value t))
+
+(defclass logic-zero
+	  (logic-constant)
+     ()
+  (:default-initargs :value nil))
+
+(defvar *component-types* '(("And Gate" :value and-gate)
+			    ("Or Gate" :value or-gate)
+			    ("Logic One" :value logic-one)
+			    ("Logic Zero" :value logic-zero)))
+
+;
+;;; ****************************************************************
+
+;;; The User Interface
+
+;;; First define a "application" that manages the application's state variables
+;;; and defines a high-level division of screen real estate.
+(define-application-frame cad-demo
+			  (standard-application-frame output-record)
+    ((object-list :initform nil))
+  (:panes
+    ((title :title
+	    :display-string "Mini-CAD")
+     (menu :command-menu)
+     (design-area :application)
+     (documentation :pointer-documentation)))
+  (:layout
+    ((main
+       (:column :rest
+	(title :compute)
+	(menu :compute)
+	(design-area :rest)
+	(documentation :compute)))
+     (other
+       (:column :rest
+	(title :compute)
+	(:row :rest
+	 (menu :compute)
+	 (design-area :rest))
+	(documentation :compute)))))
+  (:top-level
+    (default-frame-top-level :partial-command-parser cad-demo-partial-command-parser)))
+
+(defun cad-demo-partial-command-parser (partial-command command-table stream start-location)
+  (let ((name (command-name partial-command)))
+    (if (eql name 'com-create-component)
+	(accept-values-command-parser
+	  name command-table (frame-top-level-sheet *application-frame*) partial-command
+	  :own-window t)
+        (menu-read-remaining-arguments-for-partial-command
+	  partial-command command-table stream start-location))))
+
+(defmethod bounding-rectangle* ((cd cad-demo))
+  (let ((left 0)
+	(top 0)
+	(right 0)
+	(bottom 0))
+    (flet ((compute-edges (element)
+	     (with-bounding-rectangle* (le to ri bo) element
+	       (clim-utils:minf left le)
+	       (clim-utils:minf top to)
+	       (clim-utils:maxf right ri)
+	       (clim-utils:maxf bottom bo))))
+      (declare (dynamic-extent #'compute-edges))
+      (map-over-output-records-overlapping-region #'compute-edges cd nil))
+    (values left top right bottom)))
+
+(defmethod add-new-object ((cd cad-demo) new-object)
+  (push new-object (slot-value cd 'object-list)))
+
+;;; Make the cad demo application act as an output history
+(defmethod map-over-output-records-overlapping-region
+	   (function (cd cad-demo) region
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (dynamic-extent continuation-args))
+  (dolist (object (slot-value cd 'object-list))
+    (when (or (null region) (eql region +everywhere+)
+	      (clim-internals::region-intersects-offset-region-p 
+		object region x-offset y-offset))
+      (apply function object continuation-args))))
+
+(defmethod map-over-output-records-containing-point*
+	   (function (cd cad-demo) x y
+	    &optional (x-offset 0) (y-offset 0) &rest continuation-args)
+  (declare (dynamic-extent continuation-args))
+  (translate-positions x-offset y-offset x y)
+  (dolist (object (slot-value cd 'object-list))
+    (when (region-contains-point*-p object x y)
+      (apply function object continuation-args))))
+
+(defmethod output-record-start-cursor-position* ((record cad-demo))
+  (values 0 0))
+
+(defmethod add-output-record (element (record cad-demo))
+  (add-new-object record element))
+
+(defmethod clear-output-record ((record cad-demo))
+  (setf (slot-value record 'object-list) nil))
+
+(defmethod output-record-parent ((record cad-demo))
+  nil)
+
+(defmethod replay-output-record ((record cad-demo) stream
+				 &optional region (x-offset 0) (y-offset 0))
+  (when (eql region +everywhere+)
+    (setq region nil))
+  (multiple-value-bind (rl rt rr rb)
+      (and region (bounding-rectangle* region))
+    (multiple-value-bind (xoff yoff) (output-record-position* record)
+      (map-over-output-records-overlapping-region
+	#'(lambda (element)
+	    (with-bounding-rectangle* (left top right bottom) element
+	      (when (or (null region)
+			(clim-internals::ltrb-overlaps-ltrb-p left top right bottom
+							      rl rt rr rb))
+		(replay-output-record element stream region
+				      (+ x-offset xoff) (+ y-offset yoff)))))
+	record nil x-offset y-offset))))
+
+
+;;; The display function for the application-controlled output pane.  The
+;;; application substrate automatically runs this.
+(defmethod display-stuff ((frame cad-demo) stream)
+  (dolist (object (slot-value frame 'object-list))
+    (draw-self object stream)))
+
+;;; Utility routines
+
+;;; Should already exist on the POINT datatype
+(define-presentation-type cad-position () )
+
+(define-presentation-method present (object (type cad-position) stream (view textual-view)
+				     &key)
+  (format stream "~D, ~D" (car object) (cdr object)))
+
+(define-presentation-method accept ((type cad-position) stream (view textual-view) &key)
+  (values (accept '(sequence-enumerated integer integer)
+		  :prompt nil :view view :stream stream)))
+
+(define-presentation-method presentation-typep (object (type cad-position))
+  (and (consp object)
+       (integerp (car object))
+       (integerp (cdr object))))
+
+;;; Only over blank areas.
+(define-presentation-translator select-position
+    (blank-area cad-position cad-demo)
+    (x y)
+  (values (cons x y) nil '(:echo nil)))
+
+;;; Now define the commands or commands of the application.  They will automatically
+;;; show up in the :command-menu pane specified in the define-application form.
+
+(defvar *component-prototypes* nil)
+
+(defun make-component-prototypes ()
+  (setq *component-prototypes* nil)
+  ;; inhibit giving names to logic vars
+  (let ((*name-code* nil))
+    (dolist (ct (map 'list 'third *component-types*))
+      (push (make-instance ct :x 0 :y 0) *component-prototypes*))))
+
+;(make-component-prototypes)
+
+;;; Return the class name of the selected component
+(defun select-component (parent)
+  (labels ((draw-icon-menu (menu presentation-type)
+	     (formatting-table (menu :x-spacing 5)
+	       (dolist (icon *component-prototypes*)
+		 (with-output-as-presentation (menu icon presentation-type)
+		   (formatting-row (menu)
+		     (formatting-cell (menu)
+		       (progn ;; (with-user-coordinates (menu)
+			 (draw-self icon menu)
+			 (multiple-value-bind (x y)
+			     (stream-cursor-position* menu)
+			   (stream-set-cursor-position*
+			     menu
+			     ;; fudge for the fact that the presentation encloses the
+			     ;; half of the circle that's invisible
+			     (- x 20) (+ y *component-size*)))
+			 (write-string (string (class-name (class-of icon))) menu)
+			 )))))))))
+    (with-menu (menu parent)
+      (let ((component (menu-choose-from-drawer
+			 menu 'menu-item #'draw-icon-menu)))
+	(class-name (class-of component))))))
+
+
+
+(defvar *component-menu* nil)
+
+;;; This version caches the component menu.  Unfortunately this has problems
+;;; when running on multiple roots!  Good for demos.
+#+ignore
+;;; Return the class name of the selected component
+(defun select-component (parent)
+  (labels ((draw-icon-menu (menu presentation-type)
+	     (formatting-table (menu :x-spacing 5)
+	       (dolist (icon *component-prototypes*)
+		 (with-output-as-presentation (menu icon presentation-type)
+		   (formatting-row (menu)
+		     (formatting-cell (menu)
+		       (with-user-coordinates (menu)
+			 (draw-self icon menu)
+			 (multiple-value-bind (x y)
+			     (stream-cursor-position* menu)
+			   (stream-set-cursor-position*
+			     menu
+			     ;; fudge for the fact that the presentation encloses the
+			     ;; half of the circle that's invisible
+			     (- x 20) (+ y *component-size*)))
+			 (write-string (string (class-name (class-of icon))) menu)
+			 ))))))
+	     nil))
+    (cond ((null *component-menu*)
+	   (setq *component-menu* (allocate-resource 'clim-internals::menu parent))
+	   (let ((component (menu-choose-from-drawer
+			      *component-menu* 'menu-item #'draw-icon-menu)))
+	     (class-name (class-of component))))
+	  ;; Cached menu, so simulate the rest of the menu-choose mechanism here.
+	  (t (let ((menu *component-menu*))
+	       (multiple-value-bind (x y)
+		   (stream-pointer-position-in-window-coordinates
+		     (window-parent menu))
+		 (position-window-near-carefully menu x y))
+	       (window-expose menu)
+	       (unwind-protect
+		   (with-input-context ('menu-item)
+				       (object presentation-type gesture)
+			(loop (read-gesture :stream menu)
+			      (beep))
+		      (t (values (class-name (class-of object))
+				 gesture)))
+		 (window-set-visibility menu nil)))))))
+
+;;; Try to start with a reasonable drawing for the demo.
+(defun make-drawing (cd)
+  (setq *name-code* (1- (char-code #\A)))
+  (setf (slot-value cd 'object-list) nil)
+  (flet ((mi (type x y)
+	   (let ((obj (make-instance type
+				     :x (floor (* x (/ *component-size* 25)))
+				     :y (floor (* y (/ *component-size* 25))))))
+	     (add-new-object cd obj)
+	     obj))
+	 (splice (out-comp in-comp conn-number)
+	   (let ((out-conn (first (slot-value out-comp 'outputs)))
+		 (in-conn (elt (slot-value in-comp 'inputs) conn-number)))
+	     (connect out-conn in-conn))))
+  (let (;; column 1
+	(one1 (mi 'logic-one 100 100))
+	(zero1 (mi 'logic-zero 100 200))
+	(one2 (mi 'logic-one 100 300))
+	(zero2 (mi 'logic-zero 100 450))
+	;; column two
+	(and1 (mi 'and-gate 200 150))
+	(or1 (mi 'or-gate 200 350))
+	;; colum three
+	(or2 (mi 'or-gate 300 108))
+	(and2 (mi 'and-gate 300 300))
+	(or3 (mi 'or-gate 300 420))
+	;; column four
+	(or4 (mi 'or-gate 400 150))
+	(and3 (mi 'and-gate 400 350))
+	;; column five
+	(or5 (mi 'or-gate 500 250))
+	)
+    (splice one1 and1 0)
+    (splice zero1 and1 1)
+    (splice one2 or1 0)
+    (splice zero2 or1 1)
+    (splice and1 and2 0)
+    (splice or1 and2 1)
+    (splice one1 or2 0)
+    (splice and1 or2 1)
+    (splice and1 and2 0)
+    (splice or1 and2 1)
+    (splice or1 or3 0)
+    (splice zero2 or3 1)
+    (splice or2 or4 0)
+    (splice zero1 or4 1)
+    (splice and2 and3 0)
+    (splice or3 and3 1)
+    (splice or4 or5 0)
+    (splice and3 or5 1)
+    )))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Commands
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+#+++ignore	;---why doesn't this work?
+(define-cad-demo-command (com-create-component :menu "Create")
+    ((type `(member-alist ,*component-types*)
+	   :prompt "Component type")
+     (position 'cad-position
+	       :prompt "Position"))
+  (let ((object (make-instance type :x (car position) :y (cdr position))))
+    (add-new-object *application-frame* object)
+    (draw-self object (get-frame-pane *application-frame* 'design-area))))
+
+#---ignore
+(define-cad-demo-command (com-create-component :menu "Create" :keystroke #\C)
+    ;; The substrate doesn't yet support popping up the menu for the first arg...
+    #+ignore ((type `((menu-alist ,*component-types*)))
+	      (position 'cad-position))
+    #-ignore ()
+  ;; ... so we do it in the command body.
+  (let* ((window (get-frame-pane *application-frame* 'design-area))
+	 (type (menu-choose *component-types*
+			    :associated-window (window-root window)
+			    :cache T :unique-id 'component-types))
+	 (position (accept 'cad-position :stream window :prompt nil))
+	 (object (make-instance type :x (car position) :y (cdr position))))
+    (add-new-object *application-frame* object)
+    (draw-self object window)))
+
+;;; Takes two operands, an input terminal and an output terminal
+;;; --- This needs to propagate value changes down the line, or
+;;; rather redraw those components whose values have changed.
+(define-cad-demo-command (com-connect-gates :menu "Connect")
+    ((output 'output :gesture :select)
+     (input 'input :gesture :select))
+  (let ((win (get-frame-pane *application-frame* 'design-area)))
+    (draw-self (connection-component input) win :ink +background-ink+)
+    (draw-self (connection-component output) win :ink +background-ink+)
+    (connect output input)
+    (draw-self (connection-component input) win)
+    (draw-self (connection-component output) win)))
+
+;;; Moves a component.
+(define-cad-demo-command (com-move-component :menu "Move")
+    ((component 'component :gesture :select))
+  (let ((stream (get-frame-pane *application-frame* 'design-area)))
+    (draw-self component stream :ink +background-ink+)
+    (multiple-value-bind (x y)
+	(let ((*draw-connections* nil))
+	  (drag-output-record stream component
+			      :repaint t
+			      :erase #'(lambda (c s)
+					 (draw-body c s :ink +background-ink+))))
+      (move component x y))
+    (draw-self component stream)))
+
+(define-cad-demo-command (com-clear :menu "Clear" :keystroke #\L)
+    ()
+  (with-slots (object-list) *application-frame*
+    (setf object-list nil)
+    (window-clear (get-frame-pane *application-frame* 'design-area))))
+
+(define-cad-demo-command (com-refresh :menu "Refresh" :keystroke #\R)
+    ()
+  (window-erase-viewport (get-frame-pane *application-frame* 'design-area))
+  (redisplay-frame-pane *application-frame* 'design-area :force-p t))
+
+(define-cad-demo-command (com-show :menu "Show")
+    ((output 'output :gesture :describe))
+  (let ((comp (connection-component output))
+	(win (get-frame-pane *application-frame* 'design-area)))
+    (stream-set-cursor-position* win 0 0)
+    (draw-rectangle* win 0 0 800 20 :ink +background-ink+)
+    (with-text-style (win '(:sans-serif :bold :very-large))
+      (format win "~A" (equation-part comp)))))
+
+(define-cad-demo-command (com-setup :menu "Setup" :keystroke #\S)
+    ()
+  (make-drawing *application-frame*)
+  (com-refresh))
+
+(define-cad-demo-command (com-exit-CAD-demo :menu "Exit" :keystroke #\X)
+    ()
+  ;; assume called via run-cad-demo
+  (throw 'exit-cad-demo nil))
+
+(define-cad-demo-command (com-swap-layouts :menu "Swap Layouts")
+    ()
+  (let ((current-layout (frame-current-layout *application-frame*)))
+    (setf (frame-current-layout *application-frame*)
+	  (case current-layout
+	    (main 'other)
+	    (other 'main)))))
+
+#||
+
+Things to do
+
+
+add commands to scale up and down
+but first get better menu formatting!
+
+||#
+
+;;; A per-root alist of cad demo objects.
+(defvar *cad-demos* nil)
+
+(defun run-cad-demo (&key reinit root)
+  (let ((cd (cdr (assoc root *cad-demos*)))
+	(*highlight-ink* (if (color-stream-p root) +red+ +flipping-ink+)))
+    (when (or (null cd) reinit)
+      (setq cd (make-application-frame 'cad-demo :parent root))
+      (push (cons root cd) *cad-demos*)
+      ;; The application implements its own output history
+      (let ((dp (get-frame-pane cd 'design-area)))
+	;;--- kludge this one pane
+	(setf (stream-output-history dp) cd)
+	(setf (stream-recording-p dp) nil)))
+    (catch 'exit-cad-demo
+      (run-frame-top-level cd))))
+
+(define-demo "Mini-CAD" (run-cad-demo :root *demo-root*))
diff --git a/demo/demo-driver.lisp b/demo/demo-driver.lisp
new file mode 100644
index 00000000..a48dec83
--- /dev/null
+++ b/demo/demo-driver.lisp
@@ -0,0 +1,72 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: aaai-demo-driver.lisp,v 1.4 91/03/26 12:37:26 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+#-Silica
+(defvar *demo-root* nil)
+
+(defvar *demos* nil)
+
+(defmacro define-demo (name start-form)
+  `(clim-utils:push-unique (cons ,name #'(lambda () ,start-form)) *demos*
+			   :test #'string-equal :key #'car))
+
+(define-demo "Exit" (exit-demo))
+
+(defun exit-demo () (throw 'exit-demo nil))
+
+(define-presentation-type demo-menu-item ())
+
+#-Silica
+(defun size-demo-frame (root desired-left desired-top desired-width desired-height)
+  (declare (values left top right bottom))
+  (multiple-value-bind (left top right bottom)
+      (window-inside-edges root)
+    (let ((desired-right (+ desired-left desired-width))
+	  (desired-bottom (+ desired-top desired-height)))
+      (when (> desired-right right)
+	(setf desired-right right
+	      desired-left (max left (- desired-right desired-width))))
+      (when (> desired-bottom bottom)
+	(setf desired-bottom bottom
+	      desired-top (max top (- desired-bottom desired-height))))
+      (values desired-left desired-top desired-right desired-bottom))))
+
+(defun start-demo (&optional (root #-Silica *demo-root*))
+  #-Silica
+  (unless root
+    (lisp:format t "~&No current value for *DEMO-ROOT*.  Use what value? ")
+    (setq root (eval (lisp:read)))
+    (setq *demo-root* root))
+  (labels ((demo-menu-drawer (stream type &rest args)
+	     (declare (dynamic-extent args))
+	     (with-text-style (stream '(:serif :roman :very-large))
+	       (apply #'draw-standard-menu stream type args)))
+	   (demo-menu-choose (list associated-window)
+	     (with-menu (menu associated-window)
+	       (setf (window-label menu)
+		     '("Clim Demonstrations" :text-style (:fix :bold :normal)))
+	       (menu-choose-from-drawer
+		 menu 'demo-menu-item
+		 #'(lambda (stream type)
+		     (demo-menu-drawer stream type list nil))
+		 :cache t
+		 :unique-id 'demo-menu :id-test #'eql
+		 :cache-value *demos* :cache-test #'equal))))
+    (catch 'exit-demo
+      (loop
+	(let* ((demo-name (demo-menu-choose (nreverse (map 'list #'car *demos*)) root))
+	       (demo-fcn (cdr (assoc demo-name *demos* :test #'string-equal))))
+	  (when demo-fcn
+	    (funcall demo-fcn)))))))
+
+(defparameter *color-stream-p* t)
+(defun color-stream-p (stream)
+  #-Genera *color-stream-p*		;--- kludge
+  #+Genera (if (typep stream 'clim-internals::sheet-window-stream)
+	       (slot-value stream 'clim-internals::color-p)
+	       *color-stream-p*))
diff --git a/demo/demo-prefill.lisp b/demo/demo-prefill.lisp
new file mode 100644
index 00000000..21ee6fa9
--- /dev/null
+++ b/demo/demo-prefill.lisp
@@ -0,0 +1,152 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: demo-prefill.lisp,v 1.4 91/03/26 12:37:32 cer Exp $
+
+(in-package :clim-internals)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+;;; This file prefills generic function dispatch caches at load time so that
+;;; there won't be so much delay starting things up the first time the application
+;;; is run.  This file contains the things that aren't in CLIM:CLIM;PREFILL because
+;;; they pertain to particular demos.
+
+
+;;; (generate-prefill-dispatch-caches 'design)
+
+(PREFILL-DISPATCH-CACHES
+  (SIZE-FRAME-PANE
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::FLIGHT-PLANNER (EQL :COMMAND-MENU) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::FLIGHT-PLANNER (EQL :TITLE) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::FLIGHT-PLANNER (EQL :APPLICATION) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::FLIGHT-PLANNER (EQL :POINTER-DOCUMENTATION) T T T T) 
+
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::CAD-DEMO (EQL :COMMAND-MENU) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::CAD-DEMO (EQL :TITLE) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::CAD-DEMO (EQL :APPLICATION) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::CAD-DEMO (EQL :POINTER-DOCUMENTATION) T T T T)
+ 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::LISP-LISTENER (EQL :COMMAND-MENU) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::LISP-LISTENER (EQL :TITLE) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::LISP-LISTENER (EQL :APPLICATION) T T T T) 
+    (#+Cloe-Runtime CLOE-WINDOW-STREAM #+Genera SHEET-WINDOW-STREAM
+     CLIM-DEMO::LISP-LISTENER (EQL :POINTER-DOCUMENTATION) T T T T)))
+
+;;; (generate-prefill-dispatch-caches 'basic-view)
+
+(PREFILL-DISPATCH-CACHES
+  (ACCEPT-METHOD (CLIM-DEMO::ROUTE T T T T TEXTUAL-VIEW)
+		 (CLIM-DEMO::AIRPORT T T T T TEXTUAL-VIEW)) 
+  (PRESENT-METHOD (INTERSECTION T T T T T ICONIC-VIEW) 
+		  (CLIM-DEMO::AIRPORT T T T T T ICONIC-VIEW) 
+		  (CLIM-DEMO::AIRPORT T T T T T TEXTUAL-VIEW) 
+		  (CLIM-DEMO::VOR T T T T T ICONIC-VIEW) 
+		  (CLIM-DEMO::NDB T T T T T ICONIC-VIEW) 
+		  (CLIM-DEMO::VISUAL-CHECKPOINT T T T T T ICONIC-VIEW)))
+
+;;; (generate-prefill-dispatch-caches 'application-frame)
+
+(PREFILL-DISPATCH-CACHES
+  (CLIM-DEMO::ADD-NEW-OBJECT (CLIM-DEMO::CAD-DEMO CLIM-DEMO::LOGIC-ONE) 
+			     (CLIM-DEMO::CAD-DEMO CLIM-DEMO::OUTPUT) 
+			     (CLIM-DEMO::CAD-DEMO CLIM-DEMO::LOGIC-ZERO) 
+			     (CLIM-DEMO::CAD-DEMO CLIM-DEMO::AND-GATE) 
+			     (CLIM-DEMO::CAD-DEMO CLIM-DEMO::INPUT) 
+			     (CLIM-DEMO::CAD-DEMO CLIM-DEMO::OR-GATE)) 
+  (EXECUTE-FRAME-COMMAND (CLIM-DEMO::GRAPHICS-DEMO T) 
+			 (CLIM-DEMO::FLIGHT-PLANNER T) 
+			 (CLIM-DEMO::CAD-DEMO T)) 
+  (FRAME-COMMAND-TABLE (CLIM-DEMO::GRAPHICS-DEMO) 
+		       (CLIM-DEMO::FLIGHT-PLANNER) 
+		       (CLIM-DEMO::CAD-DEMO) 
+		       (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-CURRENT-LAYOUT (CLIM-DEMO::GRAPHICS-DEMO) 
+			(CLIM-DEMO::FLIGHT-PLANNER) 
+			(CLIM-DEMO::CAD-DEMO) 
+			(CLIM-DEMO::LISP-LISTENER)) 
+  ((SETF FRAME-CURRENT-LAYOUT) (T CLIM-DEMO::GRAPHICS-DEMO)) 
+  (FRAME-DOCUMENT-HIGHLIGHTED-PRESENTATION (CLIM-DEMO::FLIGHT-PLANNER T T T T T T) 
+					   (CLIM-DEMO::CAD-DEMO T T T T T T) 
+					   (CLIM-DEMO::LISP-LISTENER T T T T T T)) 
+  (FRAME-EXIT (CLIM-DEMO::GRAPHICS-DEMO) 
+	      (CLIM-DEMO::FLIGHT-PLANNER)) 
+  (FRAME-FIND-INNERMOST-APPLICABLE-PRESENTATION
+    (CLIM-DEMO::GRAPHICS-DEMO T T T T) 
+    (CLIM-DEMO::FLIGHT-PLANNER T T T T) 
+    (CLIM-DEMO::CAD-DEMO T T T T) 
+    (CLIM-DEMO::LISP-LISTENER T T T T)) 
+  (FRAME-INPUT-CONTEXT-BUTTON-PRESS-HANDLER 
+    (CLIM-DEMO::GRAPHICS-DEMO T T) 
+    (CLIM-DEMO::FLIGHT-PLANNER T T) 
+    (CLIM-DEMO::CAD-DEMO T T) 
+    (CLIM-DEMO::LISP-LISTENER T T)) 
+  (FRAME-NAME (CLIM-DEMO::GRAPHICS-DEMO) 
+	      (CLIM-DEMO::FLIGHT-PLANNER) 
+	      (CLIM-DEMO::CAD-DEMO) 
+	      (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-PANES (CLIM-DEMO::GRAPHICS-DEMO) 
+	       (CLIM-DEMO::FLIGHT-PLANNER) 
+	       (CLIM-DEMO::CAD-DEMO) 
+	       (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-POINTER-DOCUMENTATION-OUTPUT (CLIM-DEMO::GRAPHICS-DEMO) 
+				      (CLIM-DEMO::FLIGHT-PLANNER) 
+				      (CLIM-DEMO::CAD-DEMO) 
+				      (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-QUERY-IO (CLIM-DEMO::GRAPHICS-DEMO) 
+		  (CLIM-DEMO::FLIGHT-PLANNER) 
+		  (CLIM-DEMO::CAD-DEMO) 
+		  (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-REPLAY (CLIM-DEMO::GRAPHICS-DEMO T) 
+		(CLIM-DEMO::FLIGHT-PLANNER T) 
+		(CLIM-DEMO::CAD-DEMO T) 
+		(CLIM-DEMO::LISP-LISTENER T)) 
+  (FRAME-STANDARD-INPUT (CLIM-DEMO::GRAPHICS-DEMO) 
+			(CLIM-DEMO::CAD-DEMO) 
+			(CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-STANDARD-OUTPUT (CLIM-DEMO::GRAPHICS-DEMO) 
+			 (CLIM-DEMO::FLIGHT-PLANNER) 
+			 (CLIM-DEMO::CAD-DEMO) 
+			 (CLIM-DEMO::LISP-LISTENER)) 
+  (FRAME-TOP-LEVEL-SHEET (CLIM-DEMO::GRAPHICS-DEMO) 
+			 (CLIM-DEMO::FLIGHT-PLANNER) 
+			 (CLIM-DEMO::CAD-DEMO) 
+			 (CLIM-DEMO::LISP-LISTENER)) 
+  (INITIALIZE-INSTANCE (CLIM-DEMO::GRAPHICS-DEMO) 
+		       (CLIM-DEMO::FLIGHT-PLANNER) 
+		       (CLIM-DEMO::CAD-DEMO) 
+		       (CLIM-DEMO::LISP-LISTENER)) 
+  (LAYOUT-FRAME-PANES (CLIM-DEMO::GRAPHICS-DEMO T) 
+		      (CLIM-DEMO::FLIGHT-PLANNER T) 
+		      (CLIM-DEMO::CAD-DEMO T) 
+		      (CLIM-DEMO::LISP-LISTENER T)) 
+  (MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION
+    (T CLIM-DEMO::CAD-DEMO T)) 
+  (MAP-OVER-OUTPUT-RECORDS-CONTAINING-POINT*
+    (T CLIM-DEMO::CAD-DEMO T T)) 
+  (READ-FRAME-COMMAND (CLIM-DEMO::GRAPHICS-DEMO) 
+		      (CLIM-DEMO::FLIGHT-PLANNER) 
+		      (CLIM-DEMO::CAD-DEMO)) 
+  (REDISPLAY-FRAME-PANES (CLIM-DEMO::GRAPHICS-DEMO) 
+			 (CLIM-DEMO::FLIGHT-PLANNER) 
+			 (CLIM-DEMO::CAD-DEMO)) 
+  (REPLAY-OUTPUT-RECORD (CLIM-DEMO::CAD-DEMO T)) 
+  (RUN-FRAME-TOP-LEVEL (CLIM-DEMO::GRAPHICS-DEMO) 
+		       (CLIM-DEMO::FLIGHT-PLANNER) 
+		       (CLIM-DEMO::CAD-DEMO) 
+		       (CLIM-DEMO::LISP-LISTENER)) 
+  ((SETF FRAME-CURRENT-LAYOUT) (T CLIM-DEMO::GRAPHICS-DEMO)) 
+  (SHARED-INITIALIZE (CLIM-DEMO::GRAPHICS-DEMO T) 
+		     (CLIM-DEMO::FLIGHT-PLANNER T) 
+		     (CLIM-DEMO::CAD-DEMO T) 
+		     (CLIM-DEMO::LISP-LISTENER T)))
diff --git a/demo/graphics-demos.lisp b/demo/graphics-demos.lisp
new file mode 100644
index 00000000..66172cf5
--- /dev/null
+++ b/demo/graphics-demos.lisp
@@ -0,0 +1,268 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: graphics-demos.lisp,v 1.4 91/03/26 12:37:33 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1989, 1990 International Lisp Associates."
+
+#-Silica
+(define-application-frame graphics-demo 
+			  ()
+    ()
+  (:panes ((commands :command-menu)
+	   (demo :application)
+	   (explanation :application :scroll-bars nil)))
+  (:layout ((default
+	      (:column 1
+	       (:row :rest
+		(demo :rest)
+		(commands :compute))
+	       (explanation 1/6))))))
+
+#+Silica
+(define-application-frame graphics-demo 
+    ()
+  ()
+  (:panes (demo (scrolling ()
+		  (realize-pane 'application-pane)))
+	  (explanation (scrolling ()
+		         (realize-pane 'application-pane
+				       :height 100))))
+  (:layout (:default
+	      (vertically () demo explanation))))
+
+(define-graphics-demo-command (com-Exit-Graphics-Demo :menu "Exit")
+    ()
+  (frame-exit *application-frame*))
+
+(defmacro define-gdemo (name explanation (window) &body body)
+  `(define-graphics-demo-command (,(intern (format nil "~A-~A-~A" 'com name 'graphics-demo))
+				  :menu ,name) ()
+     (explain ,explanation)
+     (let ((,window (get-frame-pane *application-frame* 'demo)))
+       (window-clear ,window)
+       ,@body)))
+
+(define-gdemo "Spin" "A simple example of the use of affine transforms.
+Take a simple function that draws a picture and invoke it
+repeatedly under various rotations."
+	      (stream)
+  (multiple-value-bind (w h) (window-inside-size stream)
+    (with-translation (stream (round w 2) (round h 2))
+      (with-scaling (stream (/ (min w h) 500))
+	(flet ((draw (stream)
+		 (draw-rectangle* stream 0 0 50 50 :ink +blue+)
+		 (draw-triangle* stream 50 50 50 75 75 50 :ink +cyan+)
+		 #+Ignore
+		 (draw-circle* stream 70 30 20 :ink +cyan+)))
+	  (dotimes (i 8)
+	    (let ((angle (* pi (/ i 4))))
+	      (with-rotation (stream angle)
+		(with-translation (stream 100 0)
+		  (draw stream))))))))))
+
+(define-gdemo "Big Spin" "A more complex example using both
+rotation and scaling."
+	      (stream)
+  (multiple-value-bind (w h) (window-inside-size stream)
+    (with-translation (stream (round w 2) (round h 2))
+      (with-scaling (stream (/ (min w h) 500))
+	(with-scaling (stream 1.7)
+	  (with-translation (stream 0 -25)
+	    (do ((angle 0 (+ angle (/ pi 4)))
+		 (scale 1 (* scale 7/8)))
+		((< scale .07) nil)
+	      ;; ((> angle (* 2 pi)) nil)
+	      (with-rotation (stream angle)
+		(with-scaling (stream scale)
+		  (with-translation (stream 100 0)
+		    (dotimes (i 4)
+		      (with-translation (stream (* i 18) 0)
+			(with-scaling (stream (/ (- 5 i) 5))
+			  (draw-rectangle* stream 0 10 10 80)
+			  (draw-rectangle* stream 0 70 80 80)
+			  (draw-triangle* stream 10 0 10 10 0 10)
+			  (draw-triangle* stream 80 70 90 70 80 80)
+			  ;; (draw-triangle* stream 0 0 0 10 10 10)
+			  ;; (draw-triangle* stream 80 70 80 80 91 80)
+			  )))))))))))))
+
+(defun draw-crosshairs-on-window (ws &optional (scale-p nil) (x nil) (y nil) (size nil) (ink +foreground-ink+))
+  (multiple-value-bind (width height)
+      (window-inside-size ws)
+    (unless size
+      (setq size (max width height)))
+    (unless (and x y)
+      (setf x (/ width 4))
+      (setf y (/ height 4)))
+    (draw-line* ws x (- y size) x (+ y size) :ink ink)
+    (draw-line* ws (- x size) y (+ x size) y :ink ink)
+    (when scale-p
+      (do ((x1 x (- x1 scale-p))
+	   (x2 x (+ x2 scale-p))
+	   (y1 y (- y1 scale-p))
+	   (y2 y (+ y2 scale-p)))
+	  ((and (>= x2 size) (>= y2 size)) nil)
+	(let ((x3 (- x (/ scale-p 2)))
+	      (x4 (+ x (/ scale-p 2)))
+	      (y3 (- y (/ scale-p 2)))
+	      (y4 (+ y (/ scale-p 2))))
+	  (draw-line* ws x3 y1 x4 y1 :ink ink)
+	  (draw-line* ws x3 y2 x4 y2 :ink ink)
+	  (draw-line* ws x1 y3 x1 y4 :ink ink)
+	  (draw-line* ws x2 y3 x2 y4 :ink ink))))
+    ))
+
+(define-gdemo "CBS Logo" ""
+	      (stream)
+  (multiple-value-bind (w h) (window-inside-size stream)
+    (with-translation (stream (round w 2) (round h 2))
+      (with-scaling (stream (/ (min w h) 500))
+	(let ((ink (make-rgb-color 0 .5 1)))
+	  (draw-circle* stream 0 0 200 :ink ink)
+	  (draw-ellipse* stream 0 0 200 0 0 100 :ink +background-ink+)
+	  (draw-circle* stream 0 0 100 :ink ink)
+	  (draw-crosshairs-on-window stream 25 0 0 200 +background-ink+))))))
+
+(defun demo-sleep (ws secs)
+  (finish-output ws)
+  (let ((end-time (+ (get-internal-real-time) (* internal-time-units-per-second secs))))
+    (loop
+      (let ((time-to-go (- end-time (get-internal-real-time))))
+	(unless (plusp time-to-go) (return nil))
+	(multiple-value-bind (gesture type)
+	    (read-gesture :stream ws :timeout (/ time-to-go internal-time-units-per-second))
+	  (case type
+	    ((:timeout) (return nil))
+	    ((nil)
+	     (if (characterp gesture)
+		 (return t)
+		 (frame-exit *application-frame*)))))))))
+
+(defun compute-regular-polygon (x1 y1 x2 y2 n)
+  (let ((theta (* pi (1- (/ 2.0 n))))
+	(coords (make-list (* 2 n))))
+    (let ((temp coords))
+      (macrolet ((addit (x)
+		   `(progn
+		      (setf (car temp) (float ,x 0s0))
+		      (setf temp (cdr temp)))))
+	(addit x1)
+	(addit y1)
+	(addit x2)
+	(addit y2)
+	(do ((i 2 (1+ i))
+	     (sin-theta (sin theta))
+	     (cos-theta (cos theta))
+	     (x3) (y3))
+	    ((not (< i n)))
+	  (setq x3 (+ (- (- (* x1 cos-theta)
+			    (* y1 sin-theta))
+			 (* x2 (1- cos-theta)))
+		      (* y2 sin-theta))
+		y3 (- (- (+ (* x1 sin-theta)
+			    (* y1 cos-theta))
+			 (* x2 sin-theta))
+		      (* y2 (1- cos-theta))))
+	  (addit x3)
+	  (addit y3)
+	  (setq x1 x2 y1 y2 x2 x3 y2 y3))))
+    coords))
+
+(defvar *polygons* (make-array 10))
+(do ((i 3 (1+ i)))
+    ((= i 10))
+  (setf (aref *polygons* i) (compute-regular-polygon 0 1 0 -1 i)))
+
+(define-gdemo "Polygons" ""
+	      (stream)
+  (multiple-value-bind (w h) (window-inside-size stream)
+    (with-translation (stream (- (round w 2) 200) (round h 2))
+      (with-scaling (stream (/ (min w h) 500))
+	(dolist (number-of-sides '(3 #+Ignore 4 5 #+Ignore 6 #+Ignore 7 8))
+	  (window-clear stream)
+	  (do ((i 100 (- i 5)))
+	      ((< i 10) nil)
+	    ;;--- assumption about size of viewport and current transform
+	    (with-scaling (stream i)
+	      (draw-polygon* stream (aref *polygons* number-of-sides) :filled t
+			     :ink (if (oddp i) +background-ink+ +foreground-ink+))))
+	  (demo-sleep stream 2))))))
+
+(defconstant *random-ink-list*
+	     (list +red+ +green+ +blue+
+		   +cyan+ +magenta+ +yellow+ +black+))
+
+(defun random-ink ()
+  (nth (random (length *random-ink-list*)) *random-ink-list*))
+
+(define-gdemo "Circles" "A lot of circles in a variety of colors.
+On a monochrome display, stipples are used to simulate the colors."
+	      (stream)
+  (let* ((radius 20)
+	 (separation (+ 2 (* 2 radius))))
+    (multiple-value-bind (wid hei)
+	(window-inside-size stream)
+      (do ((y separation (+ y separation)))
+	  ((> y (- hei separation)) nil)
+	(do ((x separation (+ x separation)))
+	    ((> x (- wid separation)) nil)
+	  (draw-circle* stream x y radius :filled nil :ink (random-ink)))))))
+
+(define-gdemo "Maze" "This simple maze drawer uses the graphics
+scaling feature to adjust the maze size
+to the window in which it is displayed."
+	      (stream)
+  (multiple-value-bind (w h) (window-inside-size stream)
+    ;; --- seems to be designed for 700x600 window, so scale appropriately
+    (let ((xs (/ w 700)) (ys (/ h 600)))
+      (with-scaling (stream xs ys)
+	(draw-polygon* stream '(30   40 670  40 670 560  30 560  30  80  70  80
+				 70  520 630 520 630  80 590  80 590 480 110 480
+				 110 120 510 120 510 400 190 400 190 160)
+		       :closed nil :filled nil :line-thickness 3)
+	(draw-polygon* stream '(110  80 550  80 550 440 150 440 150 160 470 160
+				 470 360 230 360 230 200 430 200 430 320 270 320
+				 270 240 390 240 390 280)
+		       :closed nil :filled nil :line-thickness 3)
+	;;draw start
+	(draw-circle* stream 25 60 5)
+	;; draw finish
+	(draw-circle* stream 330 280 5)
+  
+	(demo-sleep stream 3)
+
+	;; draw a solution path
+	(draw-polygon* stream '(30 60 570  60 570 460 130 460 130 140 490 140
+			       490 380 210 380 210 180 450 180 450 340 250 340
+			       250 220 410 220 410 300 330 280)
+		       :ink +green+
+		       :closed nil :filled nil)
+	))))
+
+;;; The EXPLAINs should probably be in some def-graphics-demo form rather
+;;; than scattered in the code...
+(defun explain (text)
+  (let ((window (get-frame-pane *application-frame* 'explanation)))
+    (when window
+      (window-clear window)
+      (with-text-style (window '(:sans-serif :roman :large))
+	(write-string text window)))))
+
+(defvar *graphics-demos* nil)
+
+(defun run-graphics-demos (root &key reinit)
+  (let ((gd (cdr (assoc root *graphics-demos*))))
+    (when (or (null gd) reinit)
+      (multiple-value-bind (left top right bottom)
+	  (size-demo-frame root 0 0 800 600)
+	(setq gd (make-application-frame 'graphics-demo
+					 :parent root
+					 :left left :top top
+					 :right right :bottom bottom)))
+      (push (cons root gd) *graphics-demos*))
+    (run-frame-top-level gd)))
+
+(define-demo "Graphics Demos" (run-graphics-demos *demo-root*))
diff --git a/demo/listener.lisp b/demo/listener.lisp
new file mode 100644
index 00000000..c050471a
--- /dev/null
+++ b/demo/listener.lisp
@@ -0,0 +1,510 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: listener.lisp,v 1.4 91/03/26 12:37:34 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+(define-application-frame lisp-listener
+			  ()
+    ()
+  #-Silica
+  (:panes ((listener :application
+		     :initial-cursor-visibility :off)
+	   (documentation :pointer-documentation)))
+  #+Silica
+  (:pane (scrolling ()
+           (realize-pane 'clim-internals::interactor-pane)))
+  (:command-table (lisp-listener :inherit-from (user-command-table)))
+  (:command-definer t)
+  (:top-level (lisp-listener-top-level)))
+
+(defmethod frame-maintain-presentation-histories ((frame lisp-listener)) t)
+
+(defmacro condition-restart-loop ((conditions description . args) &body body)
+  (let ((tag (clim-utils:gensymbol 'restart)))
+    `(tagbody ,tag
+       (restart-case
+	   (progn ,@body)
+	 (nil ()
+	   #|| :test (lambda (condition)
+		       (some #'(lambda (x) (typep condition x)) ',conditions)) ||#
+	   :report (lambda (stream)
+		     (format stream ,description ,@args))))
+       (go ,tag))))
+
+(defvar *listener-depth* -1)
+
+(defun lisp-listener-top-level (frame)
+  "Run a simple Lisp listener using the window provided."
+  #+Silica (enable-frame frame)
+  (let* ((window (frame-query-io frame))
+	 (command-table (frame-command-table frame))
+	 (presentation-type `(command-or-form :command-table ,command-table)))
+    (with-input-focus (window)
+      (terpri window)
+      (let* ((*standard-input* window)
+	     (*standard-output* window)
+	     #+Minima (*error-output* window)
+	     (*query-io* window)
+	     #+Minima (*debug-io* window)
+	     (*package* *package*)
+	     (*listener-depth* (1+ *listener-depth*))
+	     (*** nil) (** nil) (* nil)
+	     (/// nil) (// nil) (/ nil)
+	     (+++ nil) (++ nil) (+ nil)
+	     (- nil))
+	(with-command-table-keystrokes (keystrokes command-table)
+	  (condition-restart-loop (#+Genera (sys:error sys:abort)
+				   #-Genera (error)
+				   "Restart CLIM lisp listener")
+	    (lisp-listener-command-reader
+	      frame command-table presentation-type
+	      :keystrokes keystrokes
+	      :listener-depth *listener-depth*
+	      :prompt (concatenate 'string 
+		        (make-string (1+ *listener-depth*) :initial-element #\=) "> "))))))))
+
+(defun lisp-listener-command-reader (frame command-table presentation-type 
+				     &key keystrokes listener-depth (prompt "=> "))
+  (catch-abort-gestures ("Return to ~A command level ~D"
+			 (frame-pretty-name frame) listener-depth)
+    ;; Eat any abort characters that might be hanging around.
+    ;; We need to do this because COMMAND-OR-FORM is wierd.
+    (let* ((abort-chars *abort-gestures*)
+	   (*abort-gestures* nil))
+      (when (member (stream-read-gesture *standard-input* :timeout 0 :peek-p t) abort-chars)
+	(stream-read-gesture *standard-input* :timeout 0)))
+    (fresh-line *standard-input*)
+    (multiple-value-bind (command-or-form type numeric-arg)
+	(block keystroke
+	  (handler-bind ((accelerator-gesture
+			   #'(lambda (c)
+			       ;; The COMMAND-OR-FORM type is peeking for the
+			       ;; first character, looking for a ":", so we
+			       ;; have to manually discard the accelerator
+			       (stream-read-gesture *standard-input* :timeout 0)
+			       (return-from keystroke
+				 (values
+				   (accelerator-gesture-event c)
+				   :keystroke
+				   (accelerator-gesture-numeric-argument c))))))
+	    (let ((*accelerator-gestures* keystrokes))
+	      (accept presentation-type
+		      :stream *standard-input*
+		      :prompt prompt :prompt-mode :raw
+		      :additional-activation-gestures '(#+Genera #\End)))))
+      (when (eql type :keystroke)
+	(let ((command (lookup-keystroke-command-item command-or-form command-table 
+						      :numeric-argument numeric-arg)))
+	  (unless (characterp command)
+	    (when (partial-command-p command)
+	      (setq command (funcall *partial-command-parser*
+				     command command-table *standard-input* nil
+				     :for-accelerator t)))
+	    (setq command-or-form command
+		  type 'command))))
+      (cond ((eql type ':keystroke)
+	     (beep))
+	    ((eql (presentation-type-name type) 'command)
+	     (terpri)
+	     (let ((*debugger-hook* #'listener-debugger-hook))
+	       (apply (command-name command-or-form)
+		      (command-arguments command-or-form)))
+	     (terpri))
+	    (t
+	     (terpri)
+	     (let ((values (multiple-value-list
+			     (let ((*debugger-hook* #'listener-debugger-hook))
+			       (eval command-or-form)))))
+	       (fresh-line)
+	       (dolist (value values)
+		 (present value 'expression :single-box :highlighting)
+		 (terpri))
+	       (setq - command-or-form)
+	       (shiftf +++ ++ + -)
+	       (when values
+		 ;; Don't change this stuff if no returned values
+		 (shiftf /// // / values)
+		 (shiftf *** ** * (first values)))))))))
+
+(defun listener-debugger-hook (condition hook)
+  (declare (ignore hook))
+  (let ((*debug-io* (frame-query-io *application-frame*))
+	(*error-output* (frame-query-io *application-frame*)))
+    (describe-error condition *error-output*)
+    (lisp-listener-top-level *application-frame*)))
+
+(define-presentation-type restart-name ())
+
+(define-presentation-method presentation-typep (object (type restart-name))
+  (typep object 'restart))
+
+(define-presentation-method present (object (type restart-name) stream (view textual-view)
+				     &key)
+  (prin1 (restart-name object) stream))
+
+(define-presentation-translator invoke-restart
+    (restart-name form lisp-listener
+     :documentation ((object stream)
+		     (format stream "Invoke the restart ~S" (restart-name object)))
+     :pointer-documentation "Invoke this restart"
+     :gesture :select)
+    (object)
+  `(invoke-restart ',object))
+
+(defun describe-error (condition stream)
+  (with-output-as-presentation (stream condition 'form
+				:single-box t)
+    (format stream "~2&Error: ~A" condition))
+  (let ((process (clim-sys:current-process)))
+    (when process
+      (format stream "~&In process ~A." process)))
+  (let ((restarts (compute-restarts condition)))
+    (when restarts
+      (let ((actions '(invoke-restart)))
+	(dolist (restart (reverse restarts))
+	  (let ((action (member (restart-name restart)
+				'(abort continue muffle-warning store-value use-value))))
+	    (when action
+	      (pushnew (first action) actions))))
+	(format stream "~&Use~?to resume~:[~; or abort~] execution:"
+		       "~#[~; ~S~; ~S or ~S~:;~@{~#[~; or~] ~S~^,~}~] "
+		       actions (member 'abort actions)))
+      (fresh-line stream)
+      (let ((i 0))
+	(formatting-table (stream :x-spacing '(2 :character))
+	  (dolist (restart restarts)
+	    (with-output-as-presentation (stream restart 'restart-name
+					  :single-box t)
+	      (formatting-row (stream)
+		(formatting-cell (stream)
+		  (format stream "~D" i))
+		(formatting-cell (stream)
+		  (format stream "~S" (restart-name restart)))
+		(formatting-cell (stream)
+		  (format stream "~A" restart))))
+	    (incf i))))))
+  (force-output stream))
+
+
+;;; Lisp-y stuff
+
+(defun quotify-object-if-necessary (object)
+  (if (or (consp object)
+	  (and (symbolp object)
+	       (not (keywordp object))
+	       (not (eq object nil))
+	       (not (eq object t))))
+      (list 'quote object)
+    object))
+
+(define-presentation-translator describe-lisp-object
+    (expression form lisp-listener
+     :documentation
+       ((object stream)
+	(let ((*print-length* 3)
+	      (*print-level* 3)
+	      (*print-pretty* nil))
+	  (present `(describe ,(quotify-object-if-necessary object)) 'expression
+		   :stream stream :view +pointer-documentation-view+)))
+     :gesture :describe)
+    (object)
+  `(describe ,(quotify-object-if-necessary object)))
+
+(define-presentation-translator expression-identity
+    (expression nil lisp-listener
+     :tester
+       ((object context-type)
+	(if (and (eq (presentation-type-name context-type) 'sequence)
+		 (or (vectorp object)
+		     (listp object)))
+	    (clim-utils:with-stack-list
+	        (type 'sequence (reasonable-presentation-type (elt object 0)))
+	      (presentation-subtypep type context-type))
+	    (presentation-subtypep (reasonable-presentation-type object) context-type)))
+     :tester-definitive t
+     :documentation ((object stream)
+		     (let ((*print-length* 3)
+			   (*print-level* 3)
+			   (*print-pretty* nil))
+		       (present object 'expression 
+				:stream stream :view +pointer-documentation-view+)))
+     :gesture :select)
+    (object)
+  object)
+
+(defun reasonable-presentation-type (object)
+  (let* ((class (class-of object))
+	 (class-name (class-name class)))
+    (when (presentation-type-specifier-p class-name)
+      ;; Don't compute precedence list if we don't need it
+      (return-from reasonable-presentation-type class-name))
+    (dolist (class (class-precedence-list class))
+      (when (presentation-type-specifier-p (class-name class))
+	(return-from reasonable-presentation-type (class-name class))))
+    nil))
+
+(define-lisp-listener-command (com-edit-function :name t)
+    ((function 'expression :prompt "function name"))
+  (ed function))
+
+(define-presentation-to-command-translator edit-function
+    (expression com-edit-function lisp-listener
+     :tester ((object)
+	      (functionp object))
+     :gesture :edit)
+    (object)
+  (list object))
+
+
+;;; Useful commands
+
+(define-lisp-listener-command (com-clear-output-history :name t)
+    ()
+  (window-clear (frame-standard-output *application-frame*)))
+
+#+Genera
+(add-keystroke-to-command-table 'lisp-listener #\c-m-L :command 'com-clear-output-history)
+
+#-Minima (progn
+
+(define-lisp-listener-command (com-copy-output-history :name t)
+    ((pathname 'pathname :prompt "file"))
+  (with-open-file (stream pathname :direction :output)
+    (copy-textual-output-history *standard-output* stream)))
+
+(define-lisp-listener-command (com-show-homedir :name t)
+    ()
+  (show-directory (make-pathname :defaults (user-homedir-pathname)
+				 :name :wild
+				 :type :wild
+				 :version :newest)))
+
+(define-lisp-listener-command (com-show-directory :name t)
+    ((directory '((pathname) :default-type :wild) :prompt "file"))
+  (show-directory directory))
+
+(defun show-directory (directory-pathname)
+  (let ((stream *standard-output*)
+	(pathnames #+Genera (rest (fs:directory-list directory-pathname))
+		   #-Genera (directory directory-pathname)))
+    (flet ((pathname-lessp (p1 p2)
+	     (let ((name1 (pathname-name p1))
+		   (name2 (pathname-name p2)))
+	       (or (string-lessp name1 name2)
+		   (and (string-equal name1 name2)
+			(let ((type1 (pathname-type p1))
+			      (type2 (pathname-type p2)))
+			  (and type1 type2 (string-lessp type1 type2))))))))
+      (setq pathnames (sort pathnames #'pathname-lessp 
+			    :key #+Genera #'first #-Genera #'identity)))
+    (fresh-line stream)
+    (format stream "~A" (namestring directory-pathname))
+    (fresh-line stream)
+    (formatting-table (stream :x-spacing "   ")
+      (dolist (pathname pathnames)
+	(let* (#-Genera (file-stream (open pathname :direction :input))
+	       (size #+Genera (getf (rest pathname) :length-in-bytes)
+		     #-Genera (file-length file-stream))
+	       (creation-date #+Genera (getf (rest pathname) :modification-date)
+			      #-Genera (file-write-date file-stream))
+	       (author #+Genera (getf (rest pathname) :author)
+		       #-Genera (file-author file-stream))
+	       #+Genera (pathname (first pathname)))
+	(with-output-as-presentation (stream pathname 'pathname
+				      :single-box t)
+	  (formatting-row (stream)
+	    (formatting-cell (stream)
+	      (format stream "  ~A" (file-namestring pathname)))
+	    (formatting-cell (stream :align-x :right)
+	      (format stream "~D" size))
+	    (formatting-cell (stream :align-x :right)
+	      (when creation-date
+		(multiple-value-bind (secs minutes hours day month year)
+		    (decode-universal-time creation-date)
+		  (format stream "~D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D"
+		    month day year hours minutes secs))))
+	    (formatting-cell (stream)
+	      (write-string author stream)))))))))
+
+(define-lisp-listener-command (com-show-file :name t)
+    ((pathname 'pathname :gesture :select :prompt "file"))
+  (show-file pathname *standard-output*))
+
+;;; I can't believe CL doesn't have this
+(defun show-file (pathname stream)
+  (with-temporary-string (line-buffer :length 100)
+    (with-open-file (file pathname :if-does-not-exist nil)
+      (when file
+	(loop
+	  (let ((ch (read-char file nil 'eof)))
+	    (case ch
+	      (eof
+		(return-from show-file))
+	      ((#\Return #\Newline)
+	       (write-string line-buffer stream)
+	       (write-char #\Newline stream)
+	       (setf (fill-pointer line-buffer) 0))
+	      (otherwise
+		(vector-push-extend ch line-buffer)))))))))
+
+(define-lisp-listener-command (com-edit-file :name t)
+    ((pathname 'pathname :gesture :edit :prompt "file"))
+  (ed pathname))
+
+(define-lisp-listener-command (com-delete-file :name t)
+    ((pathname 'pathname :prompt "file"))
+  (delete-file pathname))
+
+(define-presentation-to-command-translator delete-file
+    (pathname com-delete-file lisp-listener
+     :gesture nil)
+    (object)
+  (list object))
+
+#+Genera
+(define-lisp-listener-command (com-expunge-directory :name t)
+    ((directory 'pathname :prompt "directory"))
+  (fs:expunge-directory directory))
+
+;;--- We can do better than this
+(define-lisp-listener-command (com-copy-file :name t)
+    ((from-file 'pathname :prompt "from file")
+     (to-file 'pathname :default from-file :prompt "to file"))
+  (write-string "Would copy ")
+  (present from-file 'pathname)
+  (write-string " to ")
+  (present to-file 'pathname)
+  (write-string "."))
+
+(define-lisp-listener-command (com-compile-file :name t)
+    ((pathname 'pathname :prompt "file"))
+  (compile-file pathname))
+
+(define-presentation-to-command-translator compile-file
+    (pathname com-compile-file lisp-listener
+     :gesture nil)
+    (object)
+  (list object))
+
+(define-lisp-listener-command (com-load-file :name t)
+    ((pathname 'pathname :prompt "file"))
+  (load pathname))
+
+(define-presentation-to-command-translator load-file
+    (pathname com-load-file lisp-listener
+     :gesture nil)
+    (object)
+  (list object))
+
+)
+
+(define-lisp-listener-command (com-quit :name t)
+    ()
+  (frame-exit *application-frame*))
+
+
+;;; Just for demonstration...
+
+(define-presentation-type printer ())
+
+(defparameter *printer-names*
+	      '(("The Next Thing" tnt)
+		("Asahi Shimbun" asahi)
+		("Santa Cruz Comic News" comic-news)
+		("Le Figaro" figaro)
+		("LautScribner" lautscribner)))
+		
+(define-presentation-method accept ((type printer) stream (view textual-view) &key)
+  (completing-from-suggestions (stream)
+    (dolist (printer *printer-names*)
+      (suggest (first printer) (second printer)))))
+
+(define-presentation-method present (printer (type printer) stream (view textual-view)
+				     &key acceptably)
+  (let ((name (or (first (find printer *printer-names* :key #'second))
+		  (string printer))))
+    (write-token name stream :acceptably acceptably)))
+
+(define-presentation-method presentation-typep (object (type printer))
+  (symbolp object))
+
+#-Minima
+(define-lisp-listener-command (com-hardcopy-file :name t)
+    ((file 'pathname :gesture :describe)
+     (printer 'printer :gesture :select)
+     &key
+     (orientation '(member normal sideways) :default 'normal
+      :documentation "Orientation of the printed result")
+     (query 'boolean :default nil :mentioned-default t
+      :documentation "Ask whether the file should be printed")
+     (reflect 'boolean :when (and file (equal (pathname-type file) "SPREADSHEET"))
+      :default nil :mentioned-default t
+      :documentation "Reflect the spreadsheet before printing it"))
+  (format t "Would hardcopy ")
+  (present file 'pathname)
+  (format t " on ")
+  (present printer 'printer)
+  (format t " in ~A orientation." orientation)
+  (when query
+    (format t "~%With querying."))
+  (when reflect
+    (format t "~%Reflected.")))
+
+;;--- Just for demonstration...
+(define-lisp-listener-command (com-show-some-commands :name t)
+    ()
+  (let ((ptype `(command :command-table user-command-table)))
+    (formatting-table ()
+      #-Minima
+      (formatting-row ()
+	(formatting-cell ()
+	  (present `(com-show-file ,(merge-pathnames "foo" (user-homedir-pathname)))
+		   ptype)))
+      #-Minima
+      (formatting-row ()
+	(formatting-cell ()
+	  (present `(com-show-directory ,(merge-pathnames "*" (user-homedir-pathname)))
+		   ptype)))
+      #-Minima
+      (formatting-row ()
+	(formatting-cell ()
+	  (present `(com-copy-file ,(merge-pathnames "source" (user-homedir-pathname))
+				   ,(merge-pathnames "dest" (user-homedir-pathname)))
+		   ptype)))
+      #-Minima
+      (formatting-row ()
+	(formatting-cell ()
+	  (present `(com-hardcopy-file ,(merge-pathnames "quux" (user-homedir-pathname))
+				       asahi)
+		   ptype)))
+      (formatting-row ()
+	(formatting-cell ()
+	  (present '(com-quit) ptype))))))
+
+
+(defvar *listeners* nil)
+
+(defun do-lisp-listener (&key reinit root)
+  (let* ((entry (assoc root *listeners*))
+	 (ll (cdr entry)))
+    (when (or (null ll) reinit)
+      (multiple-value-bind (left top right bottom)
+	  (size-demo-frame root 50 50 500 500)
+	(setq ll (make-application-frame 'lisp-listener
+					 :parent root
+					 :left left :top top
+					 :right right :bottom bottom)))
+      (if entry
+	  (setf (cdr entry) ll)
+	  (push (cons root ll) *listeners*)))
+    (let ((window (frame-query-io ll)))
+      (clear-input window))
+    (run-frame-top-level ll)))
+
+(define-demo "Lisp Listener" (do-lisp-listener :root *demo-root*))
+
+#+Genera
+(define-genera-application lisp-listener :pretty-name "CLIM Lisp Listener" :select-key #\ˆ)
diff --git a/demo/navdata.lisp b/demo/navdata.lisp
new file mode 100644
index 00000000..bd52782c
--- /dev/null
+++ b/demo/navdata.lisp
@@ -0,0 +1,176 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: navdata.lisp,v 1.4 91/03/26 12:37:35 cer Exp $
+
+(in-package :clim-demo)
+
+(DEFPARAMETER *DEFAULT-NAV-DATA* '(
+( 5 "0B6"   A    122.8  "Chatham, CT          " 41 41.3   69 59.3  15.0 W   72 )
+( 6 "22B"   A    122.8  "Burlington,CT Jnycak " 41 46.4   73  0.7  13.0 W 1020 )
+( 7 "3B9"   A    122.8  "Chester, CT          " 41 23.0   72 30.3  13.0 W  416 )
+( 8 "42B"   A    122.8  "E Hadden, CT Gdspeed " 41 26.7   72 27.4  13.0 W    9 )
+( 9 "4B8"   A    122.8  "Plainville,CT Rbrtsn " 41 41.4   72 51.9  13.0 W  200 )
+(12 "5B3"   A    123.0  "Danielson, CT        " 41 49.2   71 54.1  14.0 W  239 )
+(15 "7B8"   A    122.9  "Waterford, CT        " 41 22.0   71  9.0  14.0 W   64 )
+(16 "7B9"   A    123.0  "Ellington, CT        " 41 55.5   72 27.5  14.0 W  253 )
+(17 "BDL"   A    120.3  "Windsor Locks, CT    " 41 56.3   72 41.0  14.0 W  174 )
+(18 "BDR"   V    108.8  "BRIDGEPORT,CT VORTAC " 41  9.6   73  7.5  14.0 W   10 )
+(20 "HFD"   V    114.9  "HARTFORD,CT VORTAC   " 41 38.5   72 32.9  13.0 W  850 )
+(21 "HVN"   V    109.8  "NEW HAVEN,CT VORTAC  " 41 15.7   72 53.2  13.0 W   10 )
+(23 "MMK"   AN   238    "Meridan-markham,CT   " 41 30.6   72 49.8  13.0 W  102 )
+(24 "N04"   A    122.8  "Madison,CT GRiswold  " 41 16.3   72 33.0  13.0 W   15 )
+(25 "ORW"   V    110.0  "NORWICH,CT VORTAC    " 41 33.4   71 59.0  14.0 W  310 )
+(26 "OXC"   A    nil    "Waterbury-Oxford,CT  " 41 28.8   73  8.1  13.0 W  727 )
+(27 "PUT"   V    117.4  "PUTNAM,CT VORTAC     " 41 57.3   71 50.7  14.0 W  650 )
+(28 "TMU"   V    111.8  "GROTON,CT VORTAC     " 41 19.8   72  3.2  14.0 W   10 )
+
+(85 "0B5"   A    123.0  "Montague,MA Turners  " 42 35.5   72 31.4  14.0 W  356 )
+(86 "1B6"   A    122.8  "Hopedale, MA Draper  " 42  6.4   71 30.7  14.0 W  269 )
+(87 "1B9"   AN   220    "Mansfield, MA        " 42  0.3   71 12.0  15.0 W  124 )
+(88 "2B2"   A    123.0  "Newburyport,MA Plum  " 42 47.8   70 50.5  15.0 W   11 )
+(89 "2B6"   A    122.8  "N Adams,MA Harriman  " 42 41.8   73 10.3  14.0 W  654 )
+(91 "3B2"   AN   368    "Marshfield, MA       " 42  5.9   70 40.3  15.0 W    9 )
+(92 "3B3"   A    122.9  "Sterling, MA         " 42 25.5   71 47.5  14.0 W  459 )
+(93 "5B6"   A    122.8  "Falmouth, MA         " 41 35.1   70 32.5  15.0 W   43 )
+(94 "6B6"   A    122.8  "Stow, MA Minit Man   " 42 27.8   71 31.0  15.0 W  268 )
+(95 "7B2"   A    122.7  "Northampton,MA       " 42 19.7   72 36.7  14.0 W  123 )
+(00 "ACK"   A    118.3  "Nantucket, MA Arpt   " 41 15.1   70  3.6  15.0 W   48 )
+(02 "B09"   A    122.8  "Tewksbury, MA        " 42 35.8   71 12.3  15.0 W   92 )
+(03 "BAF"   AV   113.0  "Westfield, MA Barnes " 42 16.9   72 43.0  14.0 W  270 )
+(04 "BAF"   A    118.9  "Westfield, MA Arpt.  " 42  9.4   72 42.9  14.0 W  271 )
+(05 "BED"   A    118.5  "Bedford, MA Hanscom  " 42 28.2   71 17.4  15.0 W  133 )
+(06 "BOS"   A    119.1  "Boston, MA Logan Apt " 42 21.8   71  0.3  15.0 W   20 )
+(07 "BOS"   AV   112.7  "Boston, MA Logan     " 42 21.9   71  0.4  15.0 W   20 )
+(08 "BUZCP" C    nil    "Buzzards Bay CP, MA  " 41 36.0   70 49.0  15.5 W   50 )
+(09 "BVY"   A    125.2  "Beverly, MA          " 42 35.1   70 55.1  15.0 W  108 )
+(10 "CEF"   AV   114.0  "Chcopee,MA Wstvr AFB " 42 11.9   72 31.8  14.0 W  245 )
+(11 "CTR"   V    115.1  "Chester, MA VOR      " 42 17.5   72 57.0  13.0 W 1600 )
+(12 "EWB"   A    118.1  "New Bedford, MA      " 41 40.6   70 57.5  14.0 W   80 )
+(13 "FALCP" C    nil    "Fall River CP, MA    " 41 49.0   71  4.0  15.0 W  361 )
+(14 "FIT"   A    122.7  "Fitchburg, MA        " 42 33.1   71 45.4  14.0 W  350 )
+(15 "FLR"   AN   201    "Fall River, MA       " 41 45.3   71  6.7  14.0 W  193 )
+(16 "GBR"   AN   395    "Great Barrinton, MA  " 42 11.0   73 24.2  13.0 W  739 )
+(17 "GDM"   AV   110.6  "Gardner, MA          " 42 32.8   72  3.5  14.0 W  350 )
+(18 "HTM"   V    114.5  "Whitman, MA VOR      " 42  3.8   70 59.0  15.0 W  120 )
+(20 "HYA"   A    119.5  "Hyannis MUN., MA     " 41 40.1   70 16.8  15.0 W   52 )
+(21 "LWM"   AV   112.5  "Lawrence, MA         " 42 43.0   71  7.4  15.0 W  149 )
+(22 "MA02"  A   122.975 "Hanson, MA Cranland  " 42  1.5   70 50.3  13.0 W   71 )
+(25 "MA08"  A    122.9  "Oxford, MA           " 42  9.1   71 50.1  14.0 W  763 )
+(26 "MANCP" C    nil    "Mansfield CP, MA     " 42  5.0   71 20.0  15.0 W  640 )
+(28 "MVY"   A    121.4  "Martha's Vineyard,MA " 41 23.5   70 36.9  15.0 W   68 )
+(29 "ORE"   AN   365    "Orange, MA           " 42 34.1   72 17.5  14.0 W  555 )
+(30 "ORH"   A    120.5  "Worcester, MA        " 42 16.0   71 52.6  14.0 W 1008 )
+(31 "OWD"   A    126.0  "Norwood, MA          " 42 11.5   71 10.4  15.0 W   50 )
+(32 "PMX"   AN   212    "Palmer, MA Metro     " 42 13.4   72 18.7  14.0 W  418 )
+(33 "PRVCP" C    nil    "Provincetown/V431,MA " 42  3.0   70 21.0  16.0 W    0 )
+(34 "PSF"   A    122.7  "Pittsfield, MA       " 42 25.6   73 17.6  13.0 W 1194 )
+(35 "PVC"   AN   232    "Provincetown, MA     " 42  4.3   70 13.3  15.0 W    8 )
+(36 "PYM"   A    123.0  "Plymouth, MA Arpt    " 41 54.7   70 43.7  15.0 W  149 )
+(38 "RKPCP" C    nil    "Rockport, MA.        " 42 39.0   70 37.0  16.0 W  500 )
+(39 "TAN"   AN   227    "Taunton, MA          " 41 52.8   71  1.3  14.0 W   42 )
+(62 "1B0"   A    122.9  "Dexter, ME           " 45  0.5   69 14.4  19.0 W  533 )
+(63 "43B"   A    122.9  "Deblois, ME          " 44 43.5   67 59.5  19.0 W  217 )
+(64 "47B"   A    122.8  "Eastport, ME         " 44 54.7   67  0.8  20.0 W   67 )
+(65 "65B"   A    122.8  "Lubec, ME (turf)     " 44 50.3   67  2.0  19.0 W   85 )
+(66 "7B4"   AN   251    "Machias Valley,ME    " 44 42.2   67 28.7  19.0 W  107 )
+(67 "98B"   AN   278    "Belfast, ME          " 44 24.6   69  0.8  19.0 W  195 )
+(68 "AUG"   A    123.6  "Augusta St, ME Arpt. " 44 19.1   69 47.8  18.0 W  353 )
+(69 "AUG"   AV   111.4  "Augusta, ME VOR      " 44 19.2   69 47.8  18.0 W  353 )
+(70 "B19"   A    123.0  "Biddeford, ME        " 43 27.9   70 28.4  17.0 W  162 )
+(71 "B21"   A    122.8  "Carrabassett,ME S'1f " 45  5.2   70 13.0  18.0 W  885 )
+(72 "BGR"   AV   114.8  "Bangor, ME VOR       " 44 50.5   68 52.5  19.0 W  192 )
+(73 "BGR"   A    120.7  "Bangor Intl., ME     " 44 48.4   68 49.3  19.0 W  192 )
+(74 "BHB"   A    123.0  "Bar Harbor,ME Hncock " 44 27.0   68 21.7  19.0 W   84 )
+(75 "CAR"   A    122.8  "Caribou, ME          " 46 52.3   68  1.3  21.0 W  623 )
+(76 "ENE"   V    117.1  "Kennebunkport, ME    " 43 25.5   70 36.8  17.0 W  190 )
+(77 "HUL"   V    116.1  "Houlton, ME VOR      " 46  2.4   67 50.1  21.0 W  860 )
+(78 "LEW"   A    122.8  "Auburn-Lewiston, ME  " 44  2.9   70 17.0  18.0 W  288 )
+(79 "MLT"   V    117.9  "Millinocket, ME VOR  " 45 35.2   68 30.0  20.0 W  550 )
+(80 "NHZ"   V    115.2  "Brunswick, ME VOR    " 43 54.1   69 56.7  18.0 W   80 )
+(81 "OLD"   A    122.8  "Old Town, ME         " 44 57.3   68 40.5  19.0 W  126 )
+(82 "PNN"   V    114.3  "Princton, ME VOR     " 45 19.7   67 42.3  21.0 W  400 )
+(83 "PQI"   V    116.4  "Presque Isle, ME VOR " 46 46.4   68  5.7  21.0 W  590 )
+(84 "PWM"   A    120.9  "Portland, ME         " 43 38.8   70 18.5  17.0 W   74 )
+(85 "RKD"   A    122.8  "Rockland,ME Knox Co. " 44  3.6   69  6.0  18.0 W   55 )
+
+(23 "BLO"   N    328    "Belkap, NH NDB       " 43 32.2   71 32.3  16.0 W  500 )
+(24 "BML"   V    110.4  "Berlin, NH VOR       " 44 38.1   71 11.2  17.0 W 1685 )
+(25 "CON"   AV   112.9  "Concord, NH          " 43 12.2   71 30.2  15.0 W  346 )
+(26 "EEN"   AV   109.4  "Keene, NH            " 42 53.9   72 16.3  14.0 W  487 )
+(27 "IVV"   N    379    "White River, NH NDB  " 43 33.6   72 28.0  15.0 W 1500 )
+(28 "LEB"   AV   113.7  "Lebanon, NH          " 43 37.7   72 18.3  15.0 W  581 )
+(29 "MHT"   A    121.3  "Manchester, NH       " 42 56.0   71 26.3  15.0 W  234 )
+(30 "MHT"   V    114.4  "Manchester,NH VOR    " 42 52.1   71 22.2  15.0 W  470 )
+(31 "PSM"   V    116.5  "Pease, NH VOR        " 43  5.1   70 49.0  16.0 W  100 )
+
+(62 "01G"   A    nil    "Perry-Warsaw, NY     " 42 44.5   78  3.0   9.0 W 1557 )
+(63 "06N"   A    nil    "Middletown,NY Rndall " 41 25.9   74 23.8  11.0 W  524 )
+(64 "0B8"   A    nil    "Fishers Is,NY Elzbth " 41 15.3   72  2.0  14.0 W    9 )
+(65 "0G0"   A    nil    "Lockport, NY         " 43  6.2   78 42.2   9.0 W  587 )
+(66 "0G7"   A    nil    "Seneca Falls, NY     " 42 52.8   76 46.9  10.0 W  491 )
+(67 "10N"   A    nil    "Walkill, NY          " 41 37.7   74  8.1  12.0 W  420 )
+(69 "1B8"   A    nil    "Canastota, NY        " 43  4.3   75 46.3  11.0 W  545 )
+(73 "3G7"   A    nil    "Williamson-Sodus, NY " 43 14.1   77  7.3   9.0 W  425 )
+(77 "4B2"   A    nil    "Utica,NY Riverside   " 43  8.0   75 16.1  12.0 W  410 )
+(80 "4G2"   A    nil    "Hamburg, NY Airdrome " 42 42.1   78 54.9   8.0 W  751 )
+(81 "4G6"   A    nil    "Hornell, NY Muni     " 42 22.8   77 40.9   9.0 W 1193 )
+(84 "6B4"   A    nil    "Frankfurt/Utica,NY   " 43  1.3   75 10.3  10.0 W 1325 )
+(85 "6B9"   A    nil    "Skaneateles, NY      " 42 54.9   76 26.4  11.0 W 1038 )
+(86 "7G0"   A    nil    "Brockport, NY        " 43 10.9   77 54.8   9.0 W  665 )
+(87 "9G0"   A    nil    "Buffalo, NY Airpark  " 42 51.7   78 43.0   8.0 W  670 )
+(88 "9G3"   A    nil    "Akron, NY            " 43  1.3   78 29.1   8.0 W  840 )
+(89 "9G5"   A    nil    "Gasport, NY Royalton " 43 10.9   78 33.5   9.0 W  628 )
+(90 "9G6"   A    nil    "Pine Hill, NY        " 43 10.4   78 16.5   8.0 W  663 )
+(93 "ART"   AV   109.8  "WATERTOWN,NY VOR     " 43 57.1   76  3.9  12.0 W  370 )
+(94 "B01"   A    nil    "Granville, NY        " 43 25.5   73 15.8  14.0 W  420 )
+(95 "B24"   A    nil    "Hamilton,NY AMA Exec " 42 50.6   75 33.7  11.0 W 1134 )
+(00 "CAM"   V    115.0  "CAMBRIDGE,NY VORTAC  " 42 59.7   73 20.7  14.0 W 1490 )
+(04 "D22"   A    nil    "Angola, NY           " 42 39.4   78 59.5   7.0 W  709 )
+(05 "D77"   A    nil    "Lancaster, NY        " 42 55.3   78 36.8   9.0 W  750 )
+(06 "DKK"   V    116.2  "DUNKIRK,NY VOR       " 42 29.4   79 16.5   7.0 W  680 )
+(07 "DNY"   V    112.1  "DE LANCEY,NY VOR     " 42 10.7   74 57.4  11.0 W 2560 )
+(09 "DSV"   A    nil    "Dansville, NY        " 42 34.3   77 42.8   9.0 W  662 )
+(10 "ELM"   V    109.65 "ELMIRA,NY  VOR       " 42  5.7   77  1.5   9.0 W 1620 )
+(11 "ELM"   A    121.1  "ELMIRA REG,NY ARPT   " 42  9.5   76 53.5   9.0 W  955 )
+(12 "ELZ"   AV   111.4  "WELLSVILLE,NY VOR    " 42  5.4   77 59.0   9.0 W 2300 )
+(16 "GEE"   V    108.2  "GENESEO,NY VOR       " 42 50.1   77 43.0   9.0 W  990 )
+(17 "GFL"   V    110.2  "GLENS FALLS,NY VOR   " 43 20.5   73 36.7  14.0 W  320 )
+(18 "GGT"   V    115.2  "GEORGETOWN,NY VOR    " 42 47.3   75 49.6  11.0 W 2040 )
+(19 "HNK"   V    116.8  "HANCOCK,NY VOR       " 42  3.8   75 19.0  11.0 W 2070 )
+(20 "HPN"   A    nil    "White Plains, NY     " 41  4.0   73 42.5  12.0 W  439 )
+(23 "HUO"   V    116.1  "HUGUENOT,NY VOR      " 41 24.6   74 35.5  11.0 W 1300 )
+(29 "JHW"   A    nil    "Jamestown, NY        " 42  9.2   79 15.5   7.0 W 1724 )
+(30 "JHW"   V    114.7  "JAMESTOWN,NY VOR     " 42 11.3   79  7.3   7.0 W 1790 )
+(33 "MAL"   A    nil    "Malone-Dufort, NY    " 44 51.2   74 19.7  14.0 W  791 )
+(34 "MGJ"   A    nil    "Mntgmry,NY Orange Co " 41 30.7   74 15.9  11.0 W  365 )
+(35 "MSS"   A    nil    "Massena, NY Richards " 44 56.2   74 50.8  14.0 W  214 )
+(36 "MSS"   V    114.1  "MASSENA,NY VORTAC    " 44 54.9   74 43.4  14.0 W  200 )
+(37 "MSV"   A    nil    "Monticello,NY Sullvn " 41 42.1   74 47.7  11.0 W 1403 )
+(39 "N00"   A    nil    "Fulton, NY Oswego    " 43 21.0   76 23.3  11.0 W  469 )
+(40 "N03"   A    nil    "Cortland, NY         " 42 35.6   76 12.9  11.0 W 1197 )
+(41 "N17"   A    nil    "Endicott, NY         " 42  4.7   76  5.8  10.0 W  833 )
+(42 "N22"   A    nil    "Penn Yan, NY         " 42 38.6   77  3.3  10.0 W  903 )
+(43 "N23"   A    nil    "Sidney, NY Muni      " 42 18.2   75 25.0  11.0 W 1027 )
+(45 "N37"   A    nil    "Monticello, NY       " 41 37.2   74 42.2  11.0 W 1545 )
+(46 "N66"   A    nil    "Oneonta,NY Muni      " 42 31.4   75  4.0  11.0 W 1764 )
+(48 "N82"   A    nil    "Wurtsboro, NY        " 41 35.9   74 27.5  12.0 W  560 )
+(49 "N89"   A    nil    "Ellenville, NY       " 41 43.7   74 22.7  12.0 W  292 )
+(50 "NK03"  A    nil    "Durhamville, NY      " 43  8.1   75 38.9  12.0 W  443 )
+(51 "NY08"  A    nil    "Brewerton, NY (Syr)  " 43 16.0   76 10.7  11.0 W  400 )
+(52 "NY43"  A    nil    "Piseco, NY           " 43 27.2   74 31.1  12.0 W 1704 )
+(53 "OGS"   A    nil    "Ogdensburg, NY Intl  " 44 40.9   75 28.0  14.0 W  297 )
+(54 "OIC"   A    nil    "Norwich, NY Eaton    " 42 34.0   75 31.5  11.0 W 1019 )
+(55 "OLE"   A    nil    "Olean, NY Muni       " 42 14.4   78 22.3   9.0 W 2135 )
+(56 "PLB"   V    116.9  "PLATTSBURGH,NY VOR   " 44 41.1   73 31.4  15.0 W  344 )
+(57 "PLB"   A    nil    "Plattsburgh,NY Clntn " 44 41.2   73 31.4  15.0 W  371 )
+(59 "PTD"   A    nil    "Potsdam, NY Damon    " 44 40.0   74 57.0  14.0 W  474 )
+(61 "RKA"   V    112.6  "ROCKDALE,NY VORTAC   " 42 27.0   75 14.4  11.0 W 2030 )
+(62 "ROC"   AV   110.0  "ROCHESTER,NY VORTAC  " 43  7.3   77 40.4   9.0 W  550 )
+(63 "RYK"   V    108.4  "Romulus,NY VOR       " 42 42.8   76 53.0  10.0 W  635 )
+(65 "SLK"   AV   111.2  "SARANAC LAKE,NY VOR  " 44 23.1   74 12.3  14.0 W 1650 )
+(67 "SYR"   V    117.0  "SYRACUSE,NY VORTAC   " 43  9.6   76 12.3  11.0 W  420 )
+(68 "SYR"   A    nil    "Syracuse,NY Hancock  " 43  6.7   76  6.5  11.0 W  421 )
+(69 "UCA"   V    108.6  "UTICA,NY VORTAC      " 43  1.6   75  9.9  12.0 W 1420 )
+(70 "UCA"   A    nil    "Utica, NY Oneida     " 43  8.7   75 23.1  12.0 W  743 )
+
+))
diff --git a/demo/navfun.lisp b/demo/navfun.lisp
new file mode 100644
index 00000000..94ea8ed9
--- /dev/null
+++ b/demo/navfun.lisp
@@ -0,0 +1,1665 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: navfun.lisp,v 1.4 91/03/26 12:37:36 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1989, 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+;;; Database support
+
+(defvar *print-object-readably* nil)
+
+(defvar *position-list*      nil "The position database")
+(defvar *route-list*         nil "The route database")
+(defvar *victor-airway-list* nil "The victor-airway database")
+(defvar *aircraft-list*      nil "The aircraft database")
+
+(defvar *max-latitude*  44)
+(defvar *min-latitude*  41)
+(defvar *max-longitude* 74)
+(defvar *min-longitude* 70)
+
+(defvar *magnifier* #-Cloe-Runtime (float 150)
+		    #+Cloe-Runtime (float 100))
+
+;; Given longitude,latitude return X,Y
+(defun scale-coordinates (longitude latitude)
+  (values (* *magnifier* (- *max-longitude* longitude))
+	  (* *magnifier* (- *max-latitude* latitude))))
+
+;; Given X,Y return longitude,latitude
+(defun unscale-coordinates (x y window)
+  (declare (ignore window))
+  (values (- *max-longitude* (/ x *magnifier*))
+	  (- *max-latitude* (/ y *magnifier*))))
+
+(defmacro rounding-coordinates ((&rest coordinates) &body body)
+  (let ((coords nil))
+    (dolist (coord coordinates)
+      (push `(,coord (round ,coord)) coords))
+    `(let (,@(nreverse coords)) ,@body)))
+
+(defvar *label-text-style* #+Genera '(:fix :roman :small)
+			   #-Genera '(:fix :roman :normal))
+
+
+;;; Basic data structures - points and positions
+
+#-Allegro
+(defclass fp-point ()
+    ((latitude :initarg :latitude
+	       :accessor point-latitude)
+     (longitude :initarg :longitude
+		:accessor point-longitude)))
+
+#-Allegro
+(defclass ground-position (fp-point)
+    ((altitude :initarg :altitude
+	       :accessor position-altitude)
+     (deviation :initarg :deviation
+		:accessor position-deviation)))
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass fp-point ()
+      ((latitude :initarg :latitude
+		 :accessor point-latitude)
+       (longitude :initarg :longitude
+		  :accessor point-longitude)))
+  (defclass ground-position (fp-point)
+      ((altitude :initarg :altitude
+		 :accessor position-altitude)
+       (deviation :initarg :deviation
+		  :accessor position-deviation))))
+
+(defmethod draw-position ((position ground-position) stream &optional label)
+  (with-slots (longitude latitude) position
+    (multiple-value-bind (x y) (scale-coordinates longitude latitude)
+      (let* ((xx (+ x (/ 3 (tan (radian 30))))))
+	(rounding-coordinates (xx y)
+	  (draw-circle* stream xx y 2)
+	  (draw-label label stream (+ xx 5) y))))))
+
+;; Assumes X and Y are already rounded...
+(defun draw-label (label stream x y)
+  (when label
+    (draw-text* stream label (+ x 5) y
+		:text-style *label-text-style*)))
+
+(defun distance (from-position to-position)
+  (values (geodesic (point-latitude from-position) (point-longitude from-position)
+		    (point-latitude to-position) (point-longitude to-position))))
+
+(defun azimuth (from-position to-position)
+  (multiple-value-bind (dist azim) 
+      (geodesic (point-latitude from-position) (point-longitude from-position) 
+                (point-latitude to-position) (point-longitude to-position))
+    (declare (ignore dist))
+    azim))
+
+#-Allegro
+(defclass named-position (ground-position)
+    ((name :initarg :name
+	   :accessor position-name)
+     (longname :initarg :longname
+	       :accessor position-longname)))
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass named-position (ground-position)
+      ((name :initarg :name
+	     :accessor position-name)
+       (longname :initarg :longname
+		 :accessor position-longname))))
+
+(defmethod describe-position-object ((position named-position) stream)
+  (with-slots (name longname) position
+    (format stream "~:(~A~) ~A ~A"
+      (class-name (class-of position)) name longname)))
+
+(defmethod print-object ((position named-position) stream)
+  (if (or *print-object-readably* (not *print-escape*))
+      (write (position-name position) :stream stream :escape nil)
+    (print-unreadable-object (position stream :type t :identity t)
+      (write (position-name position) :stream stream :escape nil))))
+
+
+(eval-when (compile load eval)
+
+(defun degminsec (degrees &optional (minutes 0) (seconds 0))
+  (float (/ (+ (* degrees 3600) (* minutes 60) seconds) 3600)))
+
+(defun getdegminsec (angle-in-degrees)
+  (let* ((angle (* 3600 angle-in-degrees))
+	 (seconds (rem angle 60))
+	 (minutes (rem (/ angle 60) 60))
+	 (degrees (/ angle 3600)))
+    (values (floor degrees) (floor minutes) (floor seconds))))
+
+(defun coast-segment (latitudes longitudes)
+  (let* ((result (make-list (* 2 (length latitudes))))
+	 (rpos result))
+    (loop
+      (when (null rpos) (return result))
+      (setf (car rpos) (pop longitudes))
+      (setf rpos (cdr rpos))
+      (setf (car rpos) (pop latitudes))
+      (setf rpos (cdr rpos)))))
+
+)	;eval-when
+
+(defvar *coastline* 
+      (list
+	(coast-segment				; Boston coastline
+	  (list (degminsec 40 48) (degminsec 41 10) (degminsec 41 15) (degminsec 41 20)
+		(degminsec 41 25) 
+		(degminsec 41 30) (degminsec 41 30) (degminsec 41 35) (degminsec 41 40) 
+		(degminsec 41 45) (degminsec 41 45) (degminsec 41 40) (degminsec 41 35) 
+		(degminsec 41 30) (degminsec 41 35) (degminsec 41 40) (degminsec 41 45) 
+		(degminsec 41 50) (degminsec 41 55) (degminsec 42 00) (degminsec 42 05) 
+		(degminsec 42 05) (degminsec 42 00) (degminsec 41 55) (degminsec 41 50)
+		(degminsec 41 45) (degminsec 41 45) (degminsec 41 50) (degminsec 41 55)
+		(degminsec 42 00) (degminsec 42 05) (degminsec 42 10) (degminsec 42 15) 
+		(degminsec 42 20) (degminsec 42 25) (degminsec 42 30) (degminsec 42 35) 
+		(degminsec 42 40) (degminsec 42 45) (degminsec 42 50) (degminsec 42 55) 
+		(degminsec 43 00) (degminsec 43 05) (degminsec 43 10) (degminsec 43 15) 
+		(degminsec 43 20) (degminsec 43 25) (degminsec 43 30) (degminsec 43 35) 
+		(degminsec 43 40) (degminsec 43 45) (degminsec 43 50) (degminsec 43 55) 
+		(degminsec 43 60))
+	  (list (degminsec 73 47) (degminsec 73 07) (degminsec 72 58) (degminsec 71 45)
+		(degminsec 71 30)
+		(degminsec 71 25) (degminsec 71 02) (degminsec 70 57) (degminsec 70 46)
+		(degminsec 70 42) (degminsec 70 39) (degminsec 70 39) (degminsec 70 39)
+		(degminsec 70 40) (degminsec 70 28) (degminsec 69 57) (degminsec 69 56)
+		(degminsec 69 56) (degminsec 69 58) (degminsec 70 01) (degminsec 70 13)
+		(degminsec 70 14) (degminsec 70 05) (degminsec 70 05) (degminsec 70 00)
+		(degminsec 70 10) (degminsec 70 24) (degminsec 70 32) (degminsec 70 33)
+		(degminsec 70 42) (degminsec 70 39) (degminsec 70 42) (degminsec 70 46)
+		(degminsec 71 00) (degminsec 71 00) (degminsec 70 50) (degminsec 70 41)
+		(degminsec 70 37) (degminsec 70 48) (degminsec 70 49) (degminsec 70 48)
+		(degminsec 70 45) (degminsec 70 40) (degminsec 70 47) (degminsec 70 46)
+		(degminsec 70 42) (degminsec 70 23) (degminsec 70 23) (degminsec 70 13)
+		(degminsec 70 14) (degminsec 70 12) (degminsec 70 00) (degminsec 69 27)
+		(degminsec 69 08)))
+	(coast-segment				; Martha's vinyard
+	  (list 
+	    (degminsec 41 29) (degminsec 41 28) (degminsec 41 25) (degminsec 41 24) 
+	    (degminsec 41 23) (degminsec 41 24) (degminsec 41 21) (degminsec 41 21) 
+	    (degminsec 41 20) (degminsec 41 18) (degminsec 41 22) (degminsec 41 22) 
+	    (degminsec 41 25) (degminsec 41 27) (degminsec 41 29))
+	  (list
+	    (degminsec 70 36) (degminsec 70 34) (degminsec 70 33) (degminsec 70 31)
+	    (degminsec 70 30) (degminsec 70 28) (degminsec 70 27) (degminsec 70 44)
+	    (degminsec 70 45) (degminsec 70 46) (degminsec 70 50) (degminsec 70 45)
+	    (degminsec 70 44) (degminsec 70 41) (degminsec 70 36)))
+	(coast-segment				; Nantucket
+	  (list
+	    (degminsec 41 24) (degminsec 41 20) (degminsec 41 15) (degminsec 41 14) 
+	    (degminsec 41 14) (degminsec 41 16) (degminsec 41 18) (degminsec 41 18) 
+	    (degminsec 41 19) (degminsec 41 24))
+	  (list
+	    (degminsec 70 03) (degminsec 70 00) (degminsec 69 57) (degminsec 70 00)
+	    (degminsec 70 07) (degminsec 70 12) (degminsec 70 11) (degminsec 70 03)
+	    (degminsec 70 01) (degminsec 70 03)))
+	(coast-segment				; Block Island
+	  (list
+	    (degminsec 41 14) (degminsec 41 13) (degminsec 41 11) (degminsec 41 09) 
+	    (degminsec 41 08) (degminsec 41 09) (degminsec 41 12) (degminsec 41 14))
+	  (list
+	    (degminsec 71 34) (degminsec 71 33) (degminsec 71 34) (degminsec 71 32)
+	    (degminsec 71 36) (degminsec 71 37) (degminsec 71 35) (degminsec 71 34)))))
+
+(defun draw-coastline (coastline &optional (stream *standard-output*))
+  (with-scaling (stream (- *magnifier*))
+    (with-translation (stream (- *max-longitude*) (- *max-latitude*))
+      (dolist (coast coastline)
+	(draw-polygon* stream coast :filled nil :closed nil :line-thickness 2)))))
+
+(defun redraw-display ()
+  (draw-coastline *coastline*)
+  (flet ((present-position (object)
+	   (present object (class-name (class-of object))
+		    :view +iconic-view+ :single-box t)))
+    (mapc #'present-position *position-list*))
+  (flet ((present-route (object)
+	   (present object (class-name (class-of object))
+		    :view +iconic-view+ :single-box nil)))
+    (mapc #'present-route *route-list*)
+    (mapc #'present-route *victor-airway-list*)))
+
+
+;;; Concrete position objects
+
+#-Allegro
+(defclass airport (named-position) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass airport (named-position) ()))
+
+(defmethod draw-position ((airport airport) stream &optional label)
+  (with-slots (longitude latitude) airport
+    (multiple-value-bind (x y) (scale-coordinates longitude latitude)
+      (rounding-coordinates (x y)
+	(let ((color-args (and (color-stream-p stream)
+			       (list :ink +green+))))
+	  (apply #'draw-circle* stream x y 5 color-args))
+	(draw-line* stream x (- y 2) x (+ y 2) :ink +background-ink+ :line-thickness 2)
+	(draw-label label stream (+ x 5) y)))))
+
+#-Allegro
+(defclass waypoint (named-position) ())
+
+#-Allegro
+(defclass VOR (named-position) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass waypoint (named-position) ())
+  (defclass VOR (named-position) ()))
+
+(defmethod describe-position-object ((VOR VOR) stream)
+  (with-slots (name longname) VOR
+    (format stream "VOR ~A ~A" name longname)))
+
+(defmethod draw-position ((VOR VOR) stream &optional label)
+  (with-slots (longitude latitude) VOR
+    (multiple-value-bind (x y) (scale-coordinates longitude latitude)
+      (let ((xx (+ x (/ 3 (tan (radian 30)))))
+	    (color-args (and (color-stream-p stream)
+			     (list :ink +cyan+))))
+	(apply #'draw-hexagon (+ xx 5) (- y 3) (+ xx 5) (+ y 3) stream color-args)
+	(rounding-coordinates (xx y)
+	  (apply #'draw-circle* stream xx y 2  color-args)
+	  (draw-label label stream (+ xx 5) y))))))
+
+(defun draw-hexagon (x1 y1 x2 y2 stream &rest color-args)
+  (declare (dynamic-extent color-args))
+  (let* ((n 6)
+	 (theta (* pi (1- (/ 2.0 n))))
+	 (sin-theta (sin theta))
+	 (cos-theta (cos theta)))
+    (do ((i 1 (1+ i))
+	 (x3) (y3))
+	((not (<= i n)))
+      (setq x3 (+ (- (- (* x1 cos-theta)
+			(* y1 sin-theta))
+		     (* x2 (1- cos-theta)))
+		  (* y2 sin-theta))
+	    y3 (- (- (+ (* x1 sin-theta)
+			(* y1 cos-theta))
+		     (* x2 sin-theta))
+		  (* y2 (1- cos-theta))))
+      (rounding-coordinates (x1 y1 x2 y2)
+	(apply #'draw-line* stream x1 y1 x2 y2 color-args))
+      (setq x1 x2 y1 y2 x2 x3 y2 y3))))
+
+#-Allegro
+(defclass NDB (named-position) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass NDB (named-position) ()))
+
+(defmethod describe-position-object ((NDB NDB) stream)
+  (with-slots (name longname) NDB
+    (format stream "NDB ~A ~A" name longname)))
+
+#-Allegro
+(defclass intersection (named-position) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass intersection (named-position) ()))
+
+(defmethod draw-position ((intersection intersection) stream &optional label)
+  (with-slots (longitude latitude) intersection
+    (multiple-value-bind (x y) (scale-coordinates longitude latitude)
+      (rounding-coordinates (x y)
+	(let ((color-args (and (color-stream-p stream)
+			       (list :ink +magenta+))))
+	  (apply #'draw-triangle* stream x (- y 3) (- x 3) (+ y 2) (+ x 3) (+ y 2)
+		 color-args))
+	(draw-label label stream (+ x 5) y)))))
+
+#-Allegro
+(defclass visual-checkpoint (named-position) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass visual-checkpoint (named-position) ()))
+
+
+;; User interfaces to concrete position objects
+
+(defun concrete-position-parser (type stream)
+  (let ((object (completing-from-suggestions (stream)
+		  (dolist (position *position-list*)
+		    (when (typep position type)
+		      (suggest (position-name position) position))))))
+    object))
+
+
+(define-presentation-type ground-position ())
+
+(define-presentation-method present (object (type ground-position) stream (view iconic-view) &key)
+  (draw-position object stream))
+
+
+(define-presentation-type named-position ())
+
+(define-presentation-method present (object (type named-position) stream view &key acceptably)
+  (declare (ignore view))
+  (let ((*print-object-readably* acceptably))
+    (format stream "~A" (position-name object))))
+
+(define-presentation-method present (object (type named-position) stream (view iconic-view)
+				     &key)
+  (draw-position object stream
+		 (and (typep object 'named-position)
+		      (position-name object))))
+
+(define-presentation-method accept ((type named-position) stream view &key)
+  (declare (ignore view))
+  (with-presentation-type-decoded (name) type
+    (concrete-position-parser name stream)))
+
+
+(define-presentation-type airport ())
+
+(define-presentation-type VOR ())
+
+(define-presentation-type NDB ())
+
+(define-presentation-type intersection ())
+
+(define-presentation-type visual-checkpoint ())
+
+
+;;; Route objects
+
+#-Allegro
+(defclass basic-route-segment ()
+    ((at :initarg :at
+	 :accessor route-segment-at)))
+
+#-Allegro
+(defclass route-segment (basic-route-segment)
+    ((altitude :initarg :altitude :accessor route-segment-altitude)
+     (wind-info :initarg :wind-info :accessor route-segment-wind-info)))
+
+#-Allegro
+(defclass basic-route ()
+    ((name :initarg :name :accessor route-name)
+     (legs :initarg :legs :accessor route-legs)))
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass basic-route-segment ()
+      ((at :initarg :at
+	   :accessor route-segment-at)))
+  (defclass route-segment (basic-route-segment)
+      ((altitude :initarg :altitude :accessor route-segment-altitude)
+       (wind-info :initarg :wind-info :accessor route-segment-wind-info)))
+  (defclass basic-route ()
+      ((name :initarg :name :accessor route-name)
+       (legs :initarg :legs :accessor route-legs))))
+
+(defmethod print-object ((route basic-route) stream)
+  (if (or *print-object-readably* (not *print-escape*))
+      (write (route-name route) :stream stream :escape t)
+    (print-unreadable-object (route stream :type t :identity t)
+      (write (route-name route) :stream stream :escape nil))))
+
+(defmethod describe-position-object ((route basic-route) stream)
+  (with-slots (name legs) route
+    (format stream "Route ~A ~A" name legs)))
+
+(defmethod draw-route ((route basic-route) stream &rest drawing-args)
+  (declare (dynamic-extent drawing-args))
+  (with-slots (legs) route
+    (let* ((start-pos (first legs))
+	   (start-lat (route-segment-latitude start-pos))
+	   (start-lon (route-segment-longitude start-pos)))
+      (do* ((next-legs (cdr legs) (cdr next-legs))
+	    next-pos next-lat next-lon)
+	   ((null next-legs) nil)
+	(setq next-pos (car next-legs)
+	      next-lat (route-segment-latitude next-pos)
+	      next-lon (route-segment-longitude next-pos))
+	(multiple-value-bind (xfrom yfrom) (scale-coordinates start-lon start-lat)
+	  (multiple-value-bind (xto yto) (scale-coordinates next-lon next-lat)
+	    (rounding-coordinates (xfrom yfrom xto yto)
+	      (apply #'draw-line* stream xfrom yfrom xto yto drawing-args))))
+	(setq start-lat next-lat start-lon next-lon)))))
+
+#-Allegro
+(defclass route (basic-route) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass route (basic-route) ()))
+
+(defun route-segment-position-name (route-segment)
+  (position-name (route-segment-at route-segment)))
+
+(defun route-segment-position-longname (route-segment)
+  (position-longname (route-segment-at route-segment)))
+
+(defun route-segment-leg-name (route-segment)
+  (concatenate 'string "-" (route-segment-position-name route-segment)))
+
+(defun generate-route-name-from-legs (leg-list)
+  (apply #'concatenate 'string 
+	 (route-segment-position-name (car leg-list))
+	 (mapcar #'route-segment-leg-name (cdr leg-list))))
+
+(defun route-segment-latitude (route-segment)
+  (point-latitude (route-segment-at route-segment)))
+
+(defun route-segment-longitude (route-segment)
+  (point-longitude (route-segment-at route-segment)))
+
+
+;;; Victor Airways
+
+#-Allegro
+(defclass victor-airway-segment (basic-route-segment)
+    ((properties :accessor victor-airway-segment-properties)
+     (next-leg :accessor victor-airway-segment-next-leg)))
+
+#-Allegro
+(defclass victor-airway (basic-route) ())
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass victor-airway-segment (basic-route-segment)
+      ((properties :accessor victor-airway-segment-properties)
+       (next-leg :accessor victor-airway-segment-next-leg)))
+  (defclass victor-airway (basic-route) ()))
+
+(defun route-parser (type list stream)
+  (let ((object (completing-from-suggestions (stream)
+		  (dolist (aroute list)
+		    (when (typep aroute type)
+		      (suggest (route-name aroute) aroute))))))
+    object))
+
+
+(define-presentation-type route ())
+
+(define-presentation-method present (object (type route) stream view &key acceptably)
+  (declare (ignore view))
+  (let ((*print-object-readably* acceptably))
+    (format stream "~A" (route-name object))))
+
+(define-presentation-method present (object (type route) stream (view iconic-view) &key)
+  (let ((drawing-args (if (color-stream-p stream)
+			  (list :ink +red+)
+			  '(:line-dashes t))))
+    (apply #'draw-route object stream drawing-args)))
+
+(define-presentation-method accept ((type route) stream view &key)
+  (declare (ignore view))
+  (route-parser 'route *route-list* stream))
+
+(define-presentation-method highlight-presentation ((type route) record stream state)
+  (highlight-route (presentation-object record) stream state))
+
+(defvar *route-highlight-style* (make-line-style :thickness 2))
+
+(defun highlight-route (route stream state)
+  (declare (ignore state))
+  (with-drawing-options (stream :line-style *route-highlight-style*)
+    (draw-route route stream :ink +flipping-ink+)))
+
+
+(define-presentation-type victor-airway ())
+
+(define-presentation-method present (object (type victor-airway) stream view &key acceptably)
+  (declare (ignore view))
+  (let ((*print-object-readably* acceptably))
+    (format stream "~A" (route-name object))))
+
+(define-presentation-method present (object (type victor-airway) stream (view iconic-view)
+				     &key)
+  (let ((drawing-args (if (color-stream-p stream)
+			  (list :ink +blue+)
+			  '(:line-dashes nil))))
+    (apply #'draw-route object stream drawing-args)))
+
+(define-presentation-method accept ((type victor-airway) stream view &key)
+  (declare (ignore view))
+  (route-parser 'route *victor-airway-list* stream))
+
+(define-presentation-method highlight-presentation ((type victor-airway) record stream state)
+  (highlight-route (presentation-object record) stream state))
+
+
+;;; Preferred Routes
+
+;;; ADIZ
+
+;;; Airspace
+
+;;; TCA
+;;; ARSA
+;;; Warning
+;;; Restricted
+;;; Prohibited
+;;; MOA
+
+
+;;; Aircraft description
+
+#-Allegro
+(defclass aircraft ()
+    ((identification :initarg :identification	; Aircraft tail number
+		     :accessor aircraft-identification)
+     (type :initarg :type			; eg C-172
+	   :accessor aircraft-type)
+     (taxi-fuel :initarg :taxi-fuel		; fuel used for taxi&runup (estimate)
+		:accessor aircraft-taxi-fuel)
+     (preferred-cruising-altitude :initarg :preferred-cruising-altitude
+				  :accessor aircraft-preferred-cruising-altitude)
+     (normal-cruise-speed :initarg :normal-cruise-speed
+			  :accessor aircraft-normal-cruise-speed)
+     (fuel-consumption-at-normal-cruise :initarg :fuel-consumption-at-normal-cruise
+					:accessor aircraft-fuel-consumption-at-normal-cruise)
+     (maximum-usable-fuel :initarg :maximum-usable-fuel
+			  :accessor aircraft-maximum-usable-fuel)
+     (cost-per-hour :initarg :cost-per-hour
+		    :accessor aircraft-cost-per-hour)
+     (hobs-or-tach :initarg :hobs-or-tach
+		   :accessor aircraft-hobs-or-tach)))
+
+#+Allegro
+(eval-when (compile load eval)
+  (defclass aircraft ()
+      ((identification :initarg :identification	; Aircraft tail number
+		       :accessor aircraft-identification)
+       (type :initarg :type :accessor aircraft-type)
+       (taxi-fuel :initarg :taxi-fuel :accessor aircraft-taxi-fuel)
+       (preferred-cruising-altitude :initarg :preferred-cruising-altitude
+				    :accessor aircraft-preferred-cruising-altitude)
+       (normal-cruise-speed :initarg :normal-cruise-speed
+			    :accessor aircraft-normal-cruise-speed)
+       (fuel-consumption-at-normal-cruise :initarg :fuel-consumption-at-normal-cruise
+					  :accessor aircraft-fuel-consumption-at-normal-cruise)
+       (maximum-usable-fuel :initarg :maximum-usable-fuel
+			    :accessor aircraft-maximum-usable-fuel)
+       (cost-per-hour :initarg :cost-per-hour
+		      :accessor aircraft-cost-per-hour)
+       (hobs-or-tach :initarg :hobs-or-tach
+		     :accessor aircraft-hobs-or-tach))))
+
+(define-presentation-type aircraft ())
+
+(define-presentation-method present (object (type aircraft) stream view &key acceptably)
+  (declare (ignore view))
+  (let ((*print-object-readably* acceptably))
+    (format stream "~A" (aircraft-identification object))))
+
+(define-presentation-method accept ((type aircraft) stream view &key)
+  (declare (ignore view))
+  (let ((ac (completing-from-suggestions (stream)
+	      (dolist (aircraft *aircraft-list*)
+		(suggest 
+		  (aircraft-identification aircraft) aircraft)))))
+    ac))
+
+(defvar *last-plane* nil "The last plane referred to")
+
+(defun edit-aircraft (aircraft)
+  (let ((identification (aircraft-identification aircraft))
+	(type (aircraft-type aircraft))
+	(preferred-altitude (aircraft-preferred-cruising-altitude aircraft))
+	(cruise-speed (aircraft-normal-cruise-speed aircraft))
+	(fuel-consumption (aircraft-fuel-consumption-at-normal-cruise aircraft))
+	(maximum-usable-fuel (aircraft-maximum-usable-fuel aircraft))
+	(cost-per-hour (aircraft-cost-per-hour aircraft)))
+    (accepting-values (*query-io* :own-window t)
+      (setq identification (accept 'string :prompt "Identification" 
+				   :default identification))
+      (terpri *query-io*)
+      (setq type (accept 'string :prompt "Type" 
+			 :default type))
+      (terpri *query-io*)
+      (setq preferred-altitude (accept 'integer :prompt "Preferred cruising altitude" 
+				       :default preferred-altitude))
+      (terpri *query-io*)
+      (setq cruise-speed (accept 'integer :prompt "Normal cruise speed" 
+				 :default cruise-speed))
+      (terpri *query-io*)
+      (setq fuel-consumption (accept 'float :prompt "Fuel consumption at normal cruise" 
+				     :default fuel-consumption))
+      (terpri *query-io*)
+      (setq maximum-usable-fuel (accept 'float :prompt "Maximum usable fuel" 
+					:default maximum-usable-fuel))
+      (terpri *query-io*)
+      (accept 'float :prompt "Cost per hour" 
+	      :default cost-per-hour)
+      (terpri *query-io*))
+    (setf (aircraft-identification aircraft) identification)
+    (setf (aircraft-type aircraft) type)
+    (setf (aircraft-taxi-fuel aircraft) 0)
+    (setf (aircraft-preferred-cruising-altitude aircraft) preferred-altitude)
+    (setf (aircraft-normal-cruise-speed aircraft) cruise-speed)
+    (setf (aircraft-fuel-consumption-at-normal-cruise aircraft) fuel-consumption)
+    (setf (aircraft-maximum-usable-fuel aircraft) maximum-usable-fuel)
+    (setf (aircraft-cost-per-hour aircraft) cost-per-hour)))
+
+
+;;; Flight plans
+
+#-Allegro
+(defclass flight-plan ()
+    ((type :initarg :type
+	   :accessor flight-plan-type)
+     (aircraft-id :initarg :aircraft-id
+		  :accessor flight-plan-aircraft-id)
+     (aircraft-type :initarg :aircraft-type
+		    :accessor flight-plan-aircraft-type)
+     (true-speed :initarg :true-speed
+		 :accessor flight-plan-true-speed)
+     (departure-point :initarg :departure-point
+		      :accessor flight-plan-departure-point)
+     (departure-time :initarg :departure-time
+		     :accessor flight-plan-departure-time)
+     (cruising-alt :initarg :cruising-alt
+		   :accessor flight-plan-cruising-alt)
+     (route :initarg :route
+	    :accessor flight-plan-route)
+     (destination :initarg :destination
+		  :accessor flight-plan-destination)
+     (ete :initarg :ete
+	  :accessor flight-plan-ete)
+     (remarks :initarg :remarks
+	      :accessor flight-plan-remarks)
+     (fuel-on-board :initarg :fuel-on-board
+		    :accessor flight-plan-fuel-on-board)
+     (alternate :initarg :alternate
+		:accessor flight-plan-alternate)
+     (pilot :initarg :pilot
+	    :accessor flight-plan-pilot)
+     (souls :initarg :souls
+	    :accessor flight-plan-souls)
+     (color :initarg :color
+	    :accessor flight-plan-color)))
+#+Allegro
+(eval-when (compile load eval)
+  (defclass flight-plan ()
+      ((type :initarg :type :accessor flight-plan-type)
+       (aircraft-id :initarg :aircraft-id :accessor flight-plan-aircraft-id)
+       (aircraft-type :initarg :aircraft-type :accessor flight-plan-aircraft-type)
+       (true-speed :initarg :true-speed :accessor flight-plan-true-speed)
+       (departure-point :initarg :departure-point :accessor flight-plan-departure-point)
+       (departure-time :initarg :departure-time :accessor flight-plan-departure-time)
+       (cruising-alt :initarg :cruising-alt :accessor flight-plan-cruising-alt)
+       (route :initarg :route :accessor flight-plan-route)
+       (destination :initarg :destination :accessor flight-plan-destination)
+       (ete :initarg :ete :accessor flight-plan-ete)
+       (remarks :initarg :remarks :accessor flight-plan-remarks)
+       (fuel-on-board :initarg :fuel-on-board :accessor flight-plan-fuel-on-board)
+       (alternate :initarg :alternate :accessor flight-plan-alternate)
+       (pilot :initarg :pilot :accessor flight-plan-pilot)
+       (souls :initarg :souls :accessor flight-plan-souls)
+       (color :initarg :color :accessor flight-plan-color))))
+
+(defun compute-flight-plan (fp-stream plan)
+  (let* ((route (flight-plan-route plan))
+	 (plane (flight-plan-aircraft-id plan))
+	 (leg-list (route-legs route))
+	 (start (first leg-list))
+	 (end   (car (last leg-list))))
+    (progn		;surrounding-output-with-border (fp-stream)
+      (multiple-value-bind (distance true-course)
+	  (geodesic (route-segment-latitude start)
+		    (route-segment-longitude start)
+		    (route-segment-latitude end)
+		    (route-segment-longitude end))
+	(declare (ignore true-course))
+	(format fp-stream 
+	    "~&Flight Plan from ~A and ~A:~%The great circle distance is ~3,1F NM.~%"
+	  (route-segment-position-name start) (route-segment-position-name end)
+	  distance))
+      (format fp-stream  "~&Route: [ ")
+      (dolist (waypoint leg-list)
+	(format fp-stream "~A " (route-segment-position-name waypoint)))
+      (format fp-stream "].~%")
+      (format fp-stream  "~&Plane: ~A ~A.~%"
+	(aircraft-identification plane) (aircraft-type plane))
+      (let ((Total-Distance 0)
+	    (Total-Time-Enroute 0))
+	(do* ((currently-at start)
+	      (route-to (cdr leg-list) (cdr route-to)))
+	     ((null route-to) nil)
+	  (multiple-value-bind (leg-distance leg-true-course)
+	      (geodesic (route-segment-latitude currently-at)
+			(route-segment-longitude currently-at)
+			(route-segment-latitude (car route-to))
+			(route-segment-longitude (car route-to)))
+	    (declare (ignore leg-true-course))
+	    (setq total-distance (+ total-distance leg-distance))
+	    (setq currently-at  (car route-to))))
+	(format fp-stream "~%")
+	(formatting-table (fp-stream)
+	  (surrounding-output-with-border (fp-stream :shape :underline)
+	    (formatting-row (fp-stream)
+	      (with-text-face (fp-stream :italic)
+		(formatting-cell (fp-stream) (write-string "CHECKPOINT" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "ID" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "TC" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "Leg" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "Rem" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "MC" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "MH" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "GS" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "ETE" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "ETA" fp-stream))
+		(formatting-cell (fp-stream :align-x :right) (write-string "FUEL" fp-stream)))))
+	  (setq total-time-enroute 0)
+	  (do* ((Currently-At start)
+		(rem total-distance)
+		(route-to (cdr leg-list) (cdr route-to)))	       
+	       ((null route-to) nil)
+	    (multiple-value-bind (leg-distance leg-true-course)
+		(geodesic (route-segment-latitude currently-at) 
+			  (route-segment-longitude currently-at) 
+			  (route-segment-latitude (car route-to)) 
+			  (route-segment-longitude (car route-to)))
+	      (let* ((altitude (flight-plan-cruising-alt plan))
+		     (estimated-wind (estimate-wind-at currently-at altitude))
+		     (cruising-speed (aircraft-normal-cruise-speed plane))
+		     (fuel-rate (aircraft-fuel-consumption-at-normal-cruise plane))
+		     (deviation (position-deviation (route-segment-at currently-at)))
+		     (MC (+ leg-true-course deviation)))
+		(multiple-value-bind (th gs)
+		    (true-heading-and-groundspeed leg-true-course cruising-speed 
+						  (car estimated-wind) (cadr estimated-wind))
+		  (let* ((MH (+ th deviation))
+			 (leg-time (/ leg-distance gs))
+			 (eta 
+			   (+ total-time-enroute leg-time (flight-plan-departure-time plan)))
+			 (fuel (* leg-time fuel-rate)))
+		    (setq total-time-enroute (+ total-time-enroute leg-time))
+		    (formatting-row (fp-stream)
+		      (formatting-cell (fp-stream) 
+			(format fp-stream "~A"
+			  (route-segment-position-longname currently-at)))
+		      (formatting-cell (fp-stream :align-x :right)	;ID
+			(format fp-stream "~A"
+			  (route-segment-position-name currently-at)))
+		      (formatting-cell (fp-stream :align-x :right)	;TC
+			(format fp-stream "~D" (floor leg-true-course))	)
+		      (formatting-cell (fp-stream :align-x :right)	;Leg
+			(format fp-stream "~1,1F" leg-distance))
+		      (formatting-cell (fp-stream :align-x :right)	;Rem
+			(format fp-stream "~1,1F" rem))
+		      (formatting-cell (fp-stream :align-x :right)	;MC
+			(format fp-stream "~D" (floor MC)))
+		      (formatting-cell (fp-stream :align-x :right)	;MH
+			(format fp-stream "~D" (floor MH)))
+		      (formatting-cell (fp-stream :align-x :right)	;GS
+			(format fp-stream "~D" (floor GS)))
+		      (formatting-cell (fp-stream :align-x :right)	;ETE
+			(format fp-stream "~A" (time-hhmm leg-time)))
+		      (formatting-cell (fp-stream :align-x :right)	;ETA
+			(format fp-stream "~A" (time-hhmm ETA)))
+		      (formatting-cell (fp-stream :align-x :right)	;Fuel
+			(format fp-stream "~1,1F" Fuel))))))
+	      (setq Currently-at  (car route-to) rem (setq rem (- rem leg-distance))))))
+	(format fp-stream "~%")
+	(formatting-table (fp-stream)
+	  (formatting-row (fp-stream)
+	    (formatting-cell (fp-stream) 
+	      (format fp-stream "~A" (route-segment-position-longname end)))
+	    (formatting-cell (fp-stream :align-x :right)	;ID
+	      (format fp-stream "~A" (route-segment-position-name end)))))
+	(format fp-stream "~%")
+	(let* ((departure-time (flight-plan-departure-time plan))
+	       (final-eta (+ Total-time-enroute (flight-plan-departure-time plan)))
+	       (fuel-on-board (flight-plan-fuel-on-board plan))
+	       (fuel-consumption-at-cruise (aircraft-fuel-consumption-at-normal-cruise plane))
+	       (total-fuel-used
+		 (+ (aircraft-taxi-fuel plane)
+		    (* total-time-enroute fuel-consumption-at-cruise)))
+	       (average-fuel-usage 
+		 (/ (* total-time-enroute fuel-consumption-at-cruise) Total-time-enroute))
+	       (cruising-altitude (flight-plan-cruising-alt plan))
+	       (reserve-fuel (- fuel-on-board total-fuel-used))
+	       (reserve-time (/ reserve-fuel fuel-consumption-at-cruise))
+	       (true-airspeed (flight-plan-true-speed plan))
+	       (reserve-distance (* reserve-time true-airspeed)))
+	  (format fp-stream "~%")
+	  (formatting-table (fp-stream)
+	    (formatting-row (fp-stream)
+	      (with-text-face (fp-stream :italic)
+		(formatting-cell (fp-stream) (format fp-stream ""))
+		(formatting-cell (fp-stream :align-x :center)
+		  (write-string "A N A L Y S I S" fp-stream))))
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Depart at ~A" (time-hhmm departure-time)))
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Total Time ~A" (time-hhmm Total-time-enroute)))
+	      (setf (flight-plan-ete plan) total-time-enroute)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Final ETA ~A" (time-hhmm final-eta))))
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Fuel on board ~1,1F" fuel-on-board))
+	      (formatting-cell (fp-stream)
+		(format fp-stream "Total Fuel ~1,1F gallons" total-fuel-used))
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Average fuel usage ~1,1F/hr" average-fuel-usage)))
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Total Distance ~1,1F nm" Total-distance))
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Total Time ~A" (time-hhmm Total-time-enroute)))	;+++
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Total Fuel ~1,1F gallons" total-fuel-used)))	;+++
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Cruise altitude ~A" cruising-altitude))    
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "TAS ~A" true-airspeed))
+	      #+ignore
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "" #+ignore "CAS ~A" #+ignore 0)))	;unf +++
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Reserve Time ~A" (time-hhmm reserve-time)))
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Reserve Dist ~1,1F" reserve-distance))
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Reserve Fuel ~1,1F" reserve-fuel)))
+	    ;+++ unf
+	    (formatting-row (fp-stream)
+	      (formatting-cell (fp-stream) 
+		(format fp-stream "Cost @ $~1,2F/hr = $~1,2F"
+		  (aircraft-cost-per-hour plane)
+		  (* total-time-enroute (aircraft-cost-per-hour plane))))))
+	  ;; Output any known wind info.
+	  (format fp-stream "~%Winds Aloft~%")
+	  (dolist (waypoint leg-list)
+	    (let ((waypoint-printed nil))
+	      (dolist (alt '(sfc 3000 6000 9000 12000))
+		(let ((awind (cdr (assoc alt (route-segment-wind-info waypoint)))))
+		  (when awind
+		    (unless waypoint-printed
+		      (format fp-stream "~%~A~%" (route-segment-position-longname waypoint)))
+		    (setq waypoint-printed t)
+		    (format fp-stream "~7A: ~A@~A~%" alt (car awind) (cadr awind))))))))))
+    (format fp-stream "~%")))
+
+;;; This needs to be a lot smarter!
+(defun estimate-wind-at (waypoint altitude)
+  (or (cdr (assoc altitude (route-segment-wind-info waypoint))) (list 0 0)))
+
+
+(defun location-parser (stream compass-points)
+  (let ((location
+	  (accept `((sequence-enumerated
+		      (member ,@compass-points)		;N/S or E/W
+		      (integer 0 90)			;hours
+		      (float 0.0 60.0)			;minutes
+		      (null-or-type (integer 0 60)))	;seconds
+		    :separator #\space)
+		  :stream stream :prompt nil)))
+    (let* ((compass-point (pop location))
+	   (hours (pop location))
+	   (minutes (pop location))
+	   (seconds (or (pop location) 0)))
+      (/ (float (+ seconds (* minutes 60) (* hours 3600)))
+	 (if (eq compass-point (first compass-points)) 3600.0 -3600.00)))))
+
+(defun location-printer (object stream compass-points &key acceptably)
+  (if acceptably
+      (format stream "~A" object)
+    (format stream "~A ~3,'0D ~2,2F" 
+      (if (< object 0) (second compass-points) (first compass-points))
+      (floor (abs object))
+      (- (* (abs object) 60) (* (floor (abs object)) 60)))))
+
+(define-presentation-type longitude ())
+
+(define-presentation-method present (object (type longitude) stream view &key acceptably)
+  (declare (ignore view))
+  (location-printer object stream '(W E) :acceptably acceptably))
+
+(define-presentation-method accept ((type longitude) stream view &key)
+  (declare (ignore view))
+  (location-parser stream '(W E)))
+
+(define-presentation-type latitude ())
+
+(define-presentation-method present (object (type latitude) stream view &key acceptably)
+  (declare (ignore view))
+  (location-printer object stream '(N S) :acceptably acceptably))
+
+(define-presentation-method accept ((type latitude) stream view &key)
+  (declare (ignore view))
+  (location-parser stream '(N S)))
+
+
+(defun time-hhmmss (time-in-hours)
+  (let* ((time-in-seconds (floor (* time-in-hours 3600)))
+	 (hours (floor time-in-hours))
+	 (minutes (- (floor time-in-seconds 60) (* hours 60)))
+	 (seconds (- time-in-seconds (* hours 3600) (* minutes 60))))
+    (if (zerop hours)
+	(format nil "~1D:~2,'0D" minutes seconds)
+      (format nil "~1D:~2,'0D:~2,'0D" hours minutes seconds))))
+
+(defun time-hhmm (time-in-hours)
+  (let* ((time-in-seconds (floor (* time-in-hours 3600)))
+	 (hours (floor time-in-hours))
+	 (minutes (- (floor time-in-seconds 60) (* hours 60))))
+    (if (zerop hours)
+	(format nil ":~2,'0D" minutes)
+      (format nil "~1D:~2,'0D" hours minutes))))
+
+(define-presentation-type time ())
+
+(define-presentation-method present (object (type time) stream view &key acceptably)
+  (declare (ignore view))
+  (if acceptably
+      (format stream "~A" object)
+      (format stream "~A" (time-hhmm object))))
+
+(define-presentation-method accept ((type time) stream view &key)
+  (declare (ignore view))
+  (let ((hhmm (accept '((sequence-enumerated
+			  (integer 0 24)
+			  (integer 0 60))
+			:separator #\: :echo-space nil)
+		      :stream stream :prompt nil)))
+    (let* ((hours (pop hhmm))
+	   (minutes (pop hhmm)))
+      (/ (float (+ (* hours 60) minutes)) 60.0))))
+
+(define-presentation-type wind ())
+
+(define-presentation-method present (object (type wind) stream view &key acceptably)
+  (declare (ignore view))
+  (if acceptably
+      (format stream "~A" object)
+      (format stream "~A@~A" (first object) (second object))))
+
+(define-presentation-method accept ((type wind) stream view &key)
+  (declare (ignore view))
+  (values (accept '((sequence-enumerated
+		      (integer 0 360)		;direction
+		      (integer 0 300))		;speed
+		    :separator #\@ :echo-space nil)
+		  :stream stream :prompt nil)))
+
+
+;;; Viewport scaling
+
+(defun get-display-center ()
+  (let ((window *standard-output*))
+    (with-bounding-rectangle* (left top right bottom) (window-viewport window)
+      (unscale-coordinates (/ (+ left right) 2.0) (/ (+ top bottom) 2.0) window))))
+
+(defun set-display-center (longitude latitude)
+  (let ((window *standard-output*))
+    (multiple-value-bind (x y)
+	(scale-coordinates longitude latitude)
+    (with-bounding-rectangle* (left top right bottom) (window-viewport window)
+      (window-set-viewport-position* window
+				     (max 0 (- (floor x) (floor (- right left) 2)))
+				     (max 0 (- (floor y) (floor (- bottom top) 2))))))))
+
+
+;;; Flight-Planner user interface
+
+(define-application-frame Flight-Planner
+			  ()
+    ((fp-window))
+  (:panes ((title :title)
+	   (display :application)
+	   (commands :command-menu)
+	   (interactor :interactor)
+	   (documentation :pointer-documentation)))
+  (:layout ((default
+	      (:column 1
+	       (title :compute)
+	       (display :rest)
+	       (commands :compute)
+	       (interactor 1/5)
+	       (documentation :compute))))))
+
+(define-Flight-Planner-command (com-Zoom-In :name t :menu t) ()
+  (multiple-value-bind (longitude latitude)
+      (get-display-center)
+    (setf *magnifier* (* *magnifier* 1.5))
+    (window-clear *standard-output*)
+    (set-display-center longitude latitude)
+    (redraw-display)))
+
+(define-Flight-Planner-command (com-Zoom-Out :name t :menu t) ()
+  (multiple-value-bind (longitude latitude)
+      (get-display-center)
+    (setf *magnifier* (/ *magnifier* 1.5))
+    (window-clear *standard-output*)
+    (set-display-center longitude latitude)
+    (redraw-display)))
+
+(define-Flight-planner-command (com-Show-Map :name t :menu t)
+    ()
+  (window-clear *standard-output*)
+  (redraw-display))
+
+(defmethod initialize-instance :after ((fp flight-planner) &key)
+  (unless *position-list*
+    (set-up))
+  (with-slots (fp-window) fp
+    (setf fp-window
+	  (open-window-stream :parent (window-root (frame-top-level-sheet fp))
+			      :left 50 :top 50 :width 750 :height 350
+			      :save-under T))
+    (let ((*application-frame* fp)
+	  (*standard-output* (frame-standard-output fp)))
+      (redraw-display))))
+
+(defmethod frame-standard-output ((p flight-planner))
+  (get-frame-pane p 'display))
+
+(defmethod frame-query-io ((p flight-planner))
+  (get-frame-pane p 'interactor))
+
+(define-Flight-Planner-command (com-Exit-Flight-Planner :name t :menu "Exit")
+    ()
+  ;; assume called via run-flight-planner
+  (frame-exit *application-frame*))
+
+
+;;; Database commands and support
+
+(define-presentation-type latitude-and-longitude ())
+
+(define-presentation-method present (object (type latitude-and-longitude) stream view &key)
+  (declare (ignore view))
+  (present (first object) 'latitude :stream stream)
+  (write-char #\, stream)
+  (present (second object) 'longitude :stream stream))
+
+(define-presentation-method accept ((type latitude-and-longitude) stream view &key)
+  (declare (ignore view))
+  (values (accept '((sequence-enumerated latitude longitude))
+		  :stream stream :prompt nil)))
+
+;; Allows you to click anywhere when reading an X-and-Y to indicate that spot
+(define-presentation-translator t-to-latitude-and-longitude
+    ((or t blank-area) latitude-and-longitude flight-planner
+     :gesture :select)
+    (x y window)
+  (multiple-value-bind (longitude latitude)
+      (unscale-coordinates x y window)		;--- Why does this get bad value for Y ?
+    (list latitude longitude)))
+
+(defun route-start-object-p (thing)		;--- kludge!
+  (or (typep thing 'airport)
+      (typep thing 'intersection)
+      (typep thing 'vor)))
+
+(define-presentation-type-abbreviation route-start-object ()
+  '(or airport intersection vor))
+
+;;; Add <kind>
+(define-Flight-Planner-command (com-Add-Object :name t :menu "Add")
+    ((object '(member ground-position route victor-airway aircraft) ;; :confirm t
+	     :prompt "Object")
+     ;;--- what about keywords?
+     (route-start '(null-or-type route-start-object)
+		  :default nil
+		  #+Ignore :when #+Ignore (eq object 'route)))
+  (ecase object
+    (ground-position
+      (let ((new-position (query-new-position)))
+	(when new-position
+	  (present new-position 'ground-position :view +iconic-view+)
+	  (push new-position *position-list*))))
+    (route
+      (let* ((new-route (query-new-route :route-start route-start)))
+	(when new-route
+	  (present new-route 'route :view +iconic-view+)
+	  (push new-route *route-list*))))
+    (victor-airway
+      (let ((new-victor-airway (query-new-victor-airway)))
+	(when new-victor-airway
+	  (present new-victor-airway 'victor-airway :view +iconic-view+)
+	  (push new-victor-airway *victor-airway-list*))))
+    (aircraft
+      (let ((new-aircraft (query-new-aircraft)))
+	(when new-aircraft
+	  (push new-aircraft *aircraft-list*))))))
+
+(define-presentation-to-command-translator add-route
+    (named-position com-add-object flight-planner
+     :tester ((object)
+	      (route-start-object-p object))
+     :gesture :select)
+    (object)
+  (list 'route object))
+
+(defun query-new-position ()
+  (let (name
+	long-name
+	kind
+	lat-and-long
+	(altitude 0))
+    (accepting-values (*query-io* :own-window t)
+      (setq name (accept 'string :prompt "Name"))
+      (terpri *query-io*)
+      (setq long-name (accept 'string :prompt "Long name"))
+      (terpri *query-io*)
+      (setq kind (accept '(member airport vor intersection visual-checkpoint)
+			 :prompt "Kind of position"))
+      (terpri *query-io*)
+      (setq lat-and-long (accept 'latitude-and-longitude :prompt "Latitude, Longitude"))
+      (terpri *query-io*)
+      (setq altitude (accept '(integer 0 60000) :prompt "Altitude" 
+			     :default altitude))
+      (terpri *query-io*))
+    (make-instance kind
+		   :name name
+		   :longname long-name
+		   :latitude (first lat-and-long)
+		   :longitude (second lat-and-long)
+		   :altitude altitude)))
+
+(defun waypoint-object-p (thing)		;--- kludge!
+  (or (null thing)
+      (typep thing 'airport)
+      (typep thing 'intersection)
+      (typep thing 'vor)))
+
+(define-presentation-type-abbreviation waypoint-object ()
+  '(or null airport intersection vor))
+
+(defun query-new-route (&key (name nil) (route-start nil))
+  (do* ((overfly ())
+	(point (or route-start
+		   (accept 'route-start-object :prompt "Start"))
+	       (accept 'waypoint-object :prompt "Waypoint"
+		       :default nil :display-default nil)))
+       ((null point)
+	(setq overfly (nreverse overfly))
+	(make-instance 'route 
+		       :name (or name (generate-route-name-from-legs overfly))
+		       :legs overfly))
+    (push (make-instance 'route-segment :at point :wind-info nil) overfly)))
+
+(defun query-new-victor-airway (&optional (name (accept 'string
+							:prompt "Name of this Victor Airway")))
+  (do* ((overfly ())
+	(point (accept 'route-start-object  :prompt "Start")
+	       (accept 'waypoint-object :prompt "Waypoint"
+		       :default nil)))
+       ((null point)
+	(make-instance 'victor-airway :name name :legs (nreverse overfly)))
+    (push (make-instance 'victor-airway-segment :at point) overfly)))
+
+(defun query-new-aircraft ()
+  (let (identification
+	type
+	(preferred-altitude 3500)
+	(cruise-speed 110)
+	(fuel-consumption 6)
+	(maximum-usable-fuel 0)
+	(cost-per-hour 50))
+    (accepting-values (*query-io* :own-window t)
+      (setq identification (accept 'string :prompt "Identification"))
+      (terpri *query-io*)
+      (setq type (accept 'string :prompt "Type"))
+      (terpri *query-io*)
+      (setq preferred-altitude (accept 'integer :prompt "Preferred cruising altitude"
+				       :default preferred-altitude))
+      (terpri *query-io*)
+      (setq cruise-speed (accept 'integer :prompt "Normal cruise speed"
+				 :default cruise-speed))
+      (terpri *query-io*)
+      (setq fuel-consumption (accept 'float :prompt "Fuel consumption at normal cruise"
+				     :default fuel-consumption))
+      (terpri *query-io*)
+      (setq maximum-usable-fuel (accept 'float :prompt "Maximum usable fuel"
+					:default maximum-usable-fuel))
+      (terpri *query-io*)
+      (setq cost-per-hour (accept 'float :prompt "Cost per hour"
+				  :default cost-per-hour))
+      (terpri *query-io*))
+    (make-instance 'aircraft
+		   :identification identification
+		   :type type
+		   :taxi-fuel 0
+		   :preferred-cruising-altitude preferred-altitude
+		   :normal-cruise-speed cruise-speed
+		   :fuel-consumption-at-normal-cruise fuel-consumption
+		   :maximum-usable-fuel maximum-usable-fuel
+		   :cost-per-hour cost-per-hour)))
+
+(defun concrete-object-p (object)		;--- kludge!
+  (or (typep object 'aircraft)
+      (typep object 'victor-airway)
+      (typep object 'route)
+      (typep object 'ground-position)))
+
+(define-presentation-type-abbreviation concrete-object ()
+  '(or aircraft victor-airway route named-position ground-position))
+
+;;; Delete <object>
+(define-Flight-Planner-command (com-Delete-Object :name t :menu "Delete")
+    ((object 'concrete-object :prompt "Object")
+     &key
+     (presentation 't :default nil)
+     (window 't :default nil))
+  (etypecase object
+    (ground-position
+      (format *query-io* "~&Deleting position ~a.~%" object)
+      (setq *position-list* (delete object *position-list*)))
+    (route
+      (format *query-io* "~&Deleting route ~a.~%" object)
+      (setq *route-list* (delete object *route-list*)))
+    (victor-airway
+      (format *query-io* "~&Deleting victor-airway ~a.~%" object)
+      (setq *victor-airway-list* (delete object *victor-airway-list*)))
+    (aircraft
+      (format *query-io* "~&Deleting aircraft ~a.~%" object)
+      (setq *aircraft-list* (delete object *aircraft-list*))))
+  (when presentation
+    (clim:erase-output-record presentation window)))
+
+(define-presentation-to-command-translator delete-object
+    (t com-delete-object flight-planner
+     :tester ((object)
+	      (concrete-object-p object))
+     :gesture :delete
+     :documentation ((object stream)
+		     ;; So that we don't see the keyword arguments...
+		     (format stream "Delete Object ~A" object)))
+    (object presentation window)
+  (list object :presentation presentation :window window))
+
+;;; Describe <object>
+(define-Flight-Planner-command (com-Describe-Object :name t :menu "Describe")
+    ((object 'concrete-object :prompt "Object"))
+  (let ((stream *query-io*))
+    (fresh-line stream)
+    (describe-position-object object stream)))
+
+(define-presentation-to-command-translator describe-object
+    (t com-describe-object flight-planner
+     :tester ((object)
+	      (concrete-object-p object))
+     :gesture :describe)
+    (object)
+  (list object))
+
+;;; Edit <object>
+(define-Flight-Planner-command (com-Edit-Object :name t :menu "Edit")
+    ((argument 'aircraft ;; :confirm t
+	       :prompt "Object"))
+  (edit-aircraft argument))
+
+(define-presentation-to-command-translator edit-object
+    (aircraft com-edit-object flight-planner
+     :gesture :edit)
+    (object)
+  (list object))
+
+(define-flight-planner-command (com-Flight-Plan :name t :menu "Plan Flight")
+    ((route 'route :prompt "Route"))
+  (let* (plan
+	 (plane (or *last-plane* (first *aircraft-list*)))
+	 (type 'VFR)
+	 (equip (or (and plane (aircraft-type plane)) "C172/U"))
+	 (airsp (or (and plane (aircraft-normal-cruise-speed plane)) 110))
+	 (orig (route-segment-at (first (route-legs route))))
+	 (dest (route-segment-at (car (last (route-legs route)))))
+	 (deptm (/ (+ (* 12 60) 00) 60))
+	 (alt (or (and plane (aircraft-preferred-cruising-altitude plane)) 3000))
+	 remks
+	 (fuel (or (and plane (aircraft-maximum-usable-fuel plane)) 0))
+	 (alts nil)
+	 pilot
+	 (souls 1)
+	 color)
+    (accepting-values (*query-io* :own-window t)
+      (setq type (accept '(member VFR IFR DVFR) :Prompt "Type"
+			 :default type))
+      (terpri *query-io*)
+      (multiple-value-bind (new-plane ptype changed)
+	  (accept 'aircraft :prompt "Aircraft Identification"
+		  :default plane)
+	(declare (ignore ptype))
+	(setq plane new-plane)
+	(when (and changed plane)
+	  ;; We would need to resynchronize the dialog, too, except that
+	  ;; all the fields that depend on PLANE are after this one.
+	  (setq equip (or (aircraft-type plane) "C172/U")
+		airsp (or (aircraft-normal-cruise-speed plane) 110)
+		alt   (or (aircraft-preferred-cruising-altitude plane) 3000)
+		fuel  (or (aircraft-maximum-usable-fuel plane) 0))))
+      (terpri *query-io*)
+      (setq equip (accept 'string :prompt "Aircraft Type/Special Equipment" 
+			  :default equip))
+      (terpri *query-io*)
+      (setq airsp (accept 'integer :prompt "True Airspeed (kts)" 
+			  :default airsp))
+      (terpri *query-io*)
+      (setq deptm (accept 'time :prompt "Proposed Departure Time"
+			  :default deptm))
+      (terpri *query-io*)
+      (setq alt (accept 'integer :prompt "Cruising Altitude" 
+			:default alt))
+      (terpri *query-io*)
+      (setq remks (accept '(null-or-type string) :prompt "Remarks"))
+      (terpri *query-io*)
+      (setq fuel (accept 'integer :prompt "Fuel on Board" 
+			 :default fuel))
+      (terpri *query-io*)
+      (setq alts  (accept '(null-or-type airport) :prompt "Alternate Airport"
+			  :default alts))
+      (terpri *query-io*)
+      (setq pilot (accept '(null-or-type string)
+			  :prompt "Pilot's Name, Address, Phone number & Home Base"))
+      (terpri *query-io*)
+      (setq souls (accept '(integer 1 500) :prompt "Number Aboard"
+			  :default souls))
+      (terpri *query-io*)
+      (accept '(null-or-type string) :prompt "Color of Aircraft"
+	      :default color)
+      (terpri *query-io*))
+    (setq *last-plane* plane)
+    (setq plan (make-instance 'flight-plan
+			      :type type
+			      :aircraft-id plane
+			      :aircraft-type equip
+			      :true-speed airsp
+			      :departure-point orig
+			      :departure-time deptm
+			      :cruising-alt alt
+			      :route route
+			      :destination dest
+			      :remarks remks
+			      :fuel-on-board fuel
+			      :alternate alts
+			      :pilot pilot
+			      :souls souls
+			      :color color))
+    (with-slots (fp-window) *application-frame*
+      (window-clear fp-window)
+      (compute-flight-plan fp-window plan)
+      (window-expose fp-window)
+      (present "Click here to remove this display" 'string :stream fp-window)
+      (with-input-context ('string)
+			  ()
+	   (loop
+	     (read-gesture :stream fp-window))
+	 (T nil))
+      (setf (window-visibility fp-window) nil))))
+
+(define-presentation-to-command-translator flight-plan
+    (route com-flight-plan flight-planner
+     :gesture :describe
+     :priority +1)
+    (object)
+  (list object))
+
+(define-Flight-Planner-command (com-Show-Distance :name t :menu t)
+    ((start 'route-start-object :gesture :select)
+     (end 'route-start-object))
+  (multiple-value-bind (distance tc)
+      (geodesic (point-latitude start) 
+		(point-longitude start) 
+		(point-latitude end) 
+		(point-longitude end))
+    (format *query-io* 
+       "~&The distance between ~a and ~a is ~1,2F NM, and the true course is ~1,2F.~%"
+      (position-name start) (position-name end) distance tc)))
+
+
+;;; Misc. functions and constants
+
+(defun square (n) (* n n))
+
+(defun radian (degrees) (* degrees (/ pi 180)))
+(defun degree (radians) (* radians (/ 180 pi)))
+
+(defun Geodesic (K M L N)			;arguments are in degrees
+  (let* ((CC 0.0033901)
+	 (O 3443.95594)				;semi major axis of Earth
+	 (A (atan (* (- 1 CC) (tan (radian K)))))	;radians
+	 (COSA (cos A))
+	 (SINA (sin A))
+	 (B (atan (* (- 1 CC) (tan (radian L)))))	;radians
+	 (COSB (cos B))
+	 (SINB (sin B))
+	 (D (* SINA SINB))
+	 (E (radian (- M N)))			;radians
+	 (ABSE (abs E))
+	 (COSE (cos E))
+	 (SINABSE (sin ABSE))
+	 (FF (+ (* SINA SINB) (* COSA COSB COSE)))
+	 (S (* (square SINABSE) (square COSB)))
+	 (TT (square (- (* SINB COSA) (* SINA COSB COSE))))
+	 (H (sqrt (+ S TT)))
+	 (I (/ (- (square H)
+		  (* (square SINABSE) (square COSA) (square COSB)))
+	       (square H)))
+	 (J (* (atan (/ H FF))))		;radian
+	 (G (+ J (* (/ (+ (square CC) CC) 2) (+ (* J (- 2 I)) (* H (- (* 2 D) (* I CC)))))))
+	 (V (+ D (* H (/ 1 (tan (/ (* 180 J) pi)))) 
+	       (* (square H) FF (+ (* 8 D (- (* I FF) D)) (- 1 (* 2 (square (abs FF))))))))
+	 (P (+ G (* (/ (square CC) (* 16 H)) (+ (* 8 (square J) (- I 1) V) (* H J)))))
+	 (R (* (- 1 CC) O P))			;R is distance
+
+	 (A1 (* J (+ CC (square CC))))
+	 (A3 (+ (* (/ (* D CC) (* 2 H)) (square (abs H))) (* 2 (square (abs J)))))
+	 (A2 (* (/ (* I (square CC)) 4) (+ (* H FF) (* -5 J) 
+				       (* 4 (square (abs J)) (/ 1 (tan J))))))
+	 (Q (+ A1 (- A2) A3))
+	 (U (+ (* (/ (* (sin E) COSA COSB) H) Q) E))
+	 (W (- (* SINB COSA) (* (cos U) SINA COSB)))
+	 (X (* (sin U) COSB))
+	 (A4 (atan (/ X W)))
+	 (Y (if (< A4 0) (+ A4 pi) A4))
+	 (Z (if (< E 0) (+ Y pi) Y)))
+    (if (and (zerop Z) (< L K)) (setq Z pi))
+    (values R (degree Z))))
+;    (list A B D E FF S TT H I J G V P 'dist R a1 a3 a2 q u w x a4 y 'dir z)))
+
+;;; A position on the Geodesic globe.
+;;; Miscellaneous functions
+
+;;; Wind correction
+
+;; tc=true course
+;; th=true heading
+;; v =true airspeed
+;; gs=ground speed
+(defun wind-speed-and-direction (tc th v gs)
+  (let* ((w (- th tc))
+	 (ht (- (* v (cos (radian w))) gs))
+	 (cx (* v (sin (radian w))))
+	 (ws (square (+ (abs (square ht)) (abs (square cx)))))
+	 (w2 (* (degree (asin (/ cx ws))) (if (minusp (- v gs)) -1 1)))
+	 (w1 (+ tc w2 (if (> gs v) 180 0)))
+	 (wd (- w1 (* (floor (/ w1 360)) 360))))
+    (setq wd (floor (+ (* 100 wd) 0.5) 100))
+    (setq ws (floor (+ (* 100 ws) 0.5) 100))
+    (values wd ws)))
+
+;; tc=true course
+;; v =true airspeed
+;; wd=wind direction
+;; b =wind speed
+(defun true-heading-and-groundspeed (tc v wd b)
+  (let* ((a (+ 180 wd (- 360 tc)))
+	 (ht (* b (cos (radian a))))
+	 (w (degree (asin (* b (/ (sin (radian a)) v)))))
+	 (gs (+ (* v (cos (radian w))) ht))
+	 (tt (- tc w))
+	 (th (- tt (* (floor tt 360) 360))))
+;    (setq th (floor (+ (* 100 wd) 0.5) 100))
+;    (setq gs (floor (+ (* 100 wd) 0.5) 100))
+    (values th gs)))
+
+;(true-heading-and-groundspeed 229 125 270 14)
+;(true-heading-and-groundspeed 229 125 0 0)
+
+;;; Crosswind components
+
+#+ignore
+(defun wind-components (wind-angle wind-speed)
+  (let ((angle (radian wind-angle)))
+    (values (* (cos angle) wind-speed)		;The headwind component
+	    (* (sin angle) wind-speed))))	;The crosswind component
+
+;(wind-components 45 50)
+
+#+ignore
+(defun density-altitude (pressure-altitude temperature)
+  (* 145426 (- 1 (expt (/ (expt (/ (- 288.16 (* pressure-altitude 0.001981)) 288.16) 5.2563)
+			  (/ (+ 273.16 temperature) 288.16))
+		       0.235))))
+
+;(density-altitude 11000 10)
+
+#+ignore
+(defun feet-per-minute (feet-per-mile ground-speed)
+  (* feet-per-mile (/ ground-speed 60.0)))
+
+#+ignore
+(defun true-airspeed (indicated-airspeed altitude temperature)
+  (let ((D (/ altitude (- 63691.776 (* 0.2190731712 altitude)))))
+    (* indicated-airspeed (sqrt (/ (+ 273.16 temperature) (/ 288 (expt 10 D)))))))
+
+#+ignore
+;; mach = mach number, temperature is true OAT Celcius
+(defun mach-to-true-airspeed (mach temperature)
+  (* 38.967 mach (sqrt (+ 273.16 temperature))))
+
+#+ignore
+(defun leg-time (leg-distance leg-speed)
+  (/ leg-distance leg-speed))
+
+#+ignore
+(defun leg-speed (leg-distance leg-time)
+  (/ leg-distance leg-time))
+
+#+ignore
+(defun leg-distance (leg-speed leg-time)
+  (* leg-speed leg-time))
+
+#+ignore
+(defun bank-angle-for-standard-rate-turn (speed)
+  (degree (atan (/ (* speed 9.2177478 1.15) 3860))))
+
+#+ignore
+(defun G-force-in-bank (bank-angle)
+  (/ 1 (cos (radian bank-angle))))
+
+#+ignore
+(defun diameter-of-turn (TAS bank-angle)
+  (/ (square TAS) (* 34208 (tan (radian bank-angle)))))
+
+#+ignore
+(defun wind-correction-angle (wa ws tas)
+  (degree (asin (/ (* ws (sin (radian wa))) tas))))
+
+#+ignore
+(defun speed-loss-due-to-crabbing (tas wca tas)
+  (- tas (* tas (cos (radian wca)))))
+
+
+;;; A simple cheat setup database
+
+(defun add-position (name kind latitude longitude altitude deviation long-name)
+  (when (or (> latitude *max-latitude*)
+	    (< latitude *min-latitude*)
+	    (> longitude *max-longitude*)
+	    (< longitude *min-longitude*))
+    (return-from add-position nil))
+  (push (make-instance kind 
+		       :name name 
+		       :longname long-name
+		       :latitude latitude 
+		       :longitude longitude 
+		       :altitude altitude
+		       :deviation deviation) 
+	*position-list*))
+
+(defun add-aircraft (identification type altitude speed fuel-consumption max-fuel cost)
+  (let ((aircraft (make-instance 'aircraft
+				 :identification identification
+				 :type type
+				 :taxi-fuel 0
+				 :preferred-cruising-altitude altitude
+				 :normal-cruise-speed speed
+				 :fuel-consumption-at-normal-cruise fuel-consumption
+				 :maximum-usable-fuel max-fuel
+				 :cost-per-hour cost)))
+    (push aircraft *aircraft-list*)))
+
+(defun customize-database ()
+  ;; Airports
+  (add-position "HFD" 'airport (degminsec 41 44) (degminsec 72 39) 19  15 "Hartford-Brainard")
+ 
+  ;; Intersections
+  (add-position "DREEM" 'intersection (degminsec 42 21.6) (degminsec 71 44.3) 0 15 "DREEM")
+  (add-position "GRAYM" 'intersection (degminsec 42 06.1) (degminsec 72 01.9) 0 15 "GRAYM")
+  (add-position "WITNY" 'intersection (degminsec 42 03) (degminsec 72 14.2) 0 15 "WITNY")
+  (add-position "EAGRE" 'intersection (degminsec 41 45) (degminsec 72 20.6) 0 15 "EAGRE")
+
+  ;; VOR's
+
+  ;; Aircraft
+  ;;            ident      type       alt   sp     fuel cost
+  (add-aircraft "NCC-1701" "Starship" 35000 550 25 1000 10000)
+  (add-aircraft "xyzzy"    "C172"     3500  110  6   50    50)
+  
+  )
+
+(defun set-up ()
+  (setq *position-list* nil
+	*route-list* nil
+	*victor-airway-list* nil
+	*aircraft-list* nil)
+  (dolist (bits *default-nav-data*)
+    (apply #'(lambda (num name type freq longname lat1 lat2 lon1 lon2 dev ew elev)
+	       (declare (ignore num))
+	       (add-position 
+		 name 
+		 (case type
+		   (A 'airport)
+		   (V 'vor)
+		   ((VA AV) 'airport)
+		   ((AN NA) 'airport)
+		   (C 'visual-checkpoint)	;actually visual cp
+		   (N 'ndb))			;actually ndb
+		 (degminsec lat1 lat2)
+		 (degminsec lon1 lon2)
+		 elev
+		 dev
+		 longname))
+	   bits))
+  (customize-database)
+  t)
+
+(defvar *flight-planners* nil)
+
+(defun run-flight-planner (&key reinit root)
+  (let ((fp (cdr (assoc root *flight-planners*))))
+    (when (or (null fp) reinit)
+      (setq fp (make-application-frame 'flight-planner :parent root))
+      (push (cons root fp) *flight-planners*))
+    (run-frame-top-level fp)))
+
+(define-demo "Flight Planner" (run-flight-planner :root *demo-root*))
+
diff --git a/demo/packages.lisp b/demo/packages.lisp
new file mode 100644
index 00000000..2c8a014e
--- /dev/null
+++ b/demo/packages.lisp
@@ -0,0 +1,20 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
+
+(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+(#-ANSI-90 clim-lisp::defpackage #+ANSI-90 defpackage CLIM-DEMO
+  (:use CLIM-LISP CLIM)
+  (:shadowing-import-from CLIM-UTILS
+    defun
+    flet labels
+    defgeneric defmethod
+    #+(or Lucid (and Allegro (or :rs6000 (not (version>= 4 1))))) with-slots
+    dynamic-extent non-dynamic-extent)
+
+  (:export   
+    *demo-root*
+    define-demo
+    start-demo))
diff --git a/demo/puzzle.lisp b/demo/puzzle.lisp
new file mode 100644
index 00000000..cba7f53d
--- /dev/null
+++ b/demo/puzzle.lisp
@@ -0,0 +1,189 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: puzzle.lisp,v 1.4 91/03/26 12:37:38 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1989, 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+(define-application-frame puzzle 
+			  ()
+    ((puzzle :initform (make-array '(4 4))
+	     :accessor puzzle-puzzle))
+  (:panes ((title :title)
+	   (menu :command-menu)
+	   (display :application
+		    :default-text-style '(:fix :bold :very-large)
+		    :incremental-redisplay T
+		    :display-function 'draw-puzzle))))
+
+(defmethod frame-query-io ((puzzle puzzle))
+  (get-frame-pane puzzle 'display))
+
+(defmethod frame-standard-output ((puzzle puzzle))
+  (get-frame-pane puzzle 'display))
+
+(defmethod run-frame-top-level :before ((puzzle puzzle))
+  (initialize-puzzle puzzle))
+
+(defmethod read-frame-command ((puzzle puzzle) &key (stream *query-io*))
+  (let ((abort-chars #+Genera '(#\Abort #\End)
+		     #-Genera nil))
+    (let ((command (read-command-using-keystrokes
+		     (frame-command-table puzzle) abort-chars
+		     :stream stream)))
+      (if (characterp command)
+	  (frame-exit puzzle)
+	  command))))
+
+(define-presentation-type puzzle-cell ()
+  :inherit-from '(integer 1 15))
+
+(define-presentation-method highlight-presentation ((type puzzle-cell) record stream state)
+  state
+  (multiple-value-bind (xoff yoff)
+      (convert-from-relative-to-absolute-coordinates 
+	stream (output-record-parent record))
+    (with-bounding-rectangle* (left top right bottom) record
+      (draw-rectangle* stream
+		       (+ left xoff) (+ top yoff)
+		       (+ right xoff) (+ bottom yoff)
+		       :ink +flipping-ink+))))
+
+(defun encode-puzzle-cell (row column)
+  (+ (* row 4) column))
+
+(defun decode-puzzle-cell (encoding)
+  (floor encoding 4))
+
+(defmethod initialize-puzzle ((puzzle puzzle))
+  (let ((puzzle-array (puzzle-puzzle puzzle)))
+    (dotimes (row 4)
+      (dotimes (column 4)
+	(setf (aref puzzle-array row column) (mod (1+ (encode-puzzle-cell row column)) 16))))))
+
+(defmethod draw-puzzle ((puzzle puzzle) stream)
+  (with-end-of-page-action (stream :allow)
+    (let ((puzzle-array (puzzle-puzzle puzzle)))
+      ;; I'm not sure why the table sometimes draws in the wrong place if I don't do this
+      (stream-set-cursor-position* stream 0 0)
+      (updating-output (stream)
+	(formatting-table (stream)
+	  (dotimes (row 4)
+	    (formatting-row (stream)
+	      (dotimes (column 4)
+		(let ((value (aref puzzle-array row column)))
+		  (updating-output (stream
+				     :unique-id (encode-puzzle-cell row column)
+				     :cache-value value)
+		    (formatting-cell (stream :align-x :right)
+		      (unless (zerop value)
+			(with-output-as-presentation 
+			    (stream (encode-puzzle-cell row column) 'puzzle-cell)
+			  (format stream "~D" value))))))))))))))
+
+(defun find-open-cell (puzzle)
+  (dotimes (row 4)
+    (dotimes (column 4)
+      (when (zerop (aref puzzle row column))
+	(return (encode-puzzle-cell row column))))))
+
+(defun cell-adjacent-to-open-cell (puzzle r c)
+  ;; check row
+  (or
+    (dotimes (column 4)
+      (when (and (/= column c) (zerop (aref puzzle r column)))
+	(return (encode-puzzle-cell r column))))
+    (dotimes (row 4)
+      (when (and (/= row r) (zerop (aref puzzle row c)))
+	(return (encode-puzzle-cell row c))))))
+
+(define-puzzle-command com-move-cell
+    ((cell 'puzzle-cell))
+  (with-slots (puzzle) *application-frame*
+    (multiple-value-bind (this-row this-column) (decode-puzzle-cell cell)
+      (let ((open-cell (cell-adjacent-to-open-cell puzzle this-row this-column)))
+	(multiple-value-bind (open-row open-column) (decode-puzzle-cell open-cell)
+	  (cond ((= open-row this-row)
+		 (cond ((> open-column this-column)
+			(do ((c open-column (1- c)))
+			    ((= c this-column))
+			  (setf (aref puzzle this-row c)
+				(aref puzzle this-row (1- c)))))
+		       (t (do ((c open-column (1+ c)))
+			      ((= c this-column))
+			    (setf (aref puzzle this-row c)
+				  (aref puzzle this-row (1+ c)))))))
+		((= open-column this-column)
+		 (cond ((> open-row this-row)
+			(do ((r open-row (1- r)))
+			    ((= r this-row))
+			  (setf (aref puzzle r this-column)
+				(aref puzzle (1- r) this-column))))
+		       (t (do ((r open-row (1+ r)))
+			      ((= r this-row))
+			    (setf (aref puzzle r this-column)
+				  (aref puzzle (1+ r) this-column)))))))))
+      (setf (aref puzzle this-row this-column) 0))))
+
+(define-presentation-to-command-translator move-cell
+    (puzzle-cell com-move-cell puzzle
+     :documentation "Move cell"
+     :tester ((object)
+	      (multiple-value-bind (r c)
+		  (decode-puzzle-cell object)
+		(cell-adjacent-to-open-cell (puzzle-puzzle *application-frame*) r c))))
+    (object)
+  (list object))
+
+(define-puzzle-command (com-scramble :menu t)
+    ()
+  (let ((ordering (list 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14))
+	(puzzle-array (puzzle-puzzle *application-frame*)))
+    (flet ((random-predicate (x y)
+	     (declare (ignore x y))
+	     (zerop (random 2))))
+      (declare (dynamic-extent #'random-predicate))
+      (setq ordering (sort ordering #'random-predicate)))
+    (flet ((ordering-parity (ordering)
+	     (do* ((ordering2 (copy-list ordering))
+		   (total-parity t)
+		   (start (position-if #'identity ordering2)
+			  (position-if #'identity ordering2)))
+		  ((null start) total-parity)
+	       (let ((cycle-parity (do* ((evenp t (not evenp))
+					 (item (nth start ordering) (nth item ordering)))
+					((= item start)
+					 (setf (nth start ordering2) nil)
+					 evenp)
+				     (setf (nth item ordering2) nil))))
+		 (when (null cycle-parity)
+		   (setq total-parity (not total-parity)))))))
+      (unless (ordering-parity ordering)
+	(rotatef (first ordering) (second ordering))))
+    (dotimes (row 4)
+      (dotimes (column 4)
+	(setf (aref puzzle-array row column) (if ordering (+ 1 (pop ordering)) 0))))))
+
+(define-puzzle-command (com-exit-puzzle :menu "Exit")
+    ()
+  (frame-exit *application-frame*))
+
+;;; Standard demo driver...
+(defvar *puzzles* nil)
+
+(defun do-puzzle (&key reinit root)
+  (let* ((entry (assoc root *puzzles*))
+	 (p (cdr entry)))
+    (when (or (null p) reinit)
+      (multiple-value-bind (left top right bottom)
+	  (size-demo-frame root 100 100 172 160)
+	(setq p (make-application-frame 'puzzle :parent root
+					:left left :top top
+					:right right :bottom bottom)))
+      (if entry
+	  (setf (cdr entry) p)
+	  (push (cons root p) *puzzles*)))
+    (run-frame-top-level p)))
+
+(define-demo "15 Puzzle" (do-puzzle :root *demo-root*))
diff --git a/demo/sysdcl.lisp b/demo/sysdcl.lisp
new file mode 100644
index 00000000..25a98e7f
--- /dev/null
+++ b/demo/sysdcl.lisp
@@ -0,0 +1,65 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: sysdcl.lisp,v 1.6 91/03/29 18:01:38 cer Exp $
+
+(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved.
+ Portions copyright (c) 1988, 1989, 1990 International Lisp Associates."
+
+(defsys:defsystem clim-demo
+  (:default-pathname #+Genera "SYS:CLIM;REL-2;DEMO;"
+		     #+Minima "SYS:CLIM;REL-2;DEMO;"
+		     #+Cloe-Runtime "\\clim\\rel-2\\demo\\"
+		     #+Lucid "/home/hornig/clim/rel-2/demo/"
+		     #+Allegro (frob-pathname "demo")
+		     #+CMU "/home/hornig/clim/rel-2/demo/"
+		     #+CCL-2 "ccl;clim-2.0:demo:"
+   :default-binary-pathname #+Genera "SYS:CLIM;REL-2;DEMO;"
+			    #+Minima "SYS:CLIM;REL-2;DEMO;"
+			    #+Cloe-Runtime "\\clim\\rel-2\\bin\\"
+			    #+Lucid "/home/hornig/clim/rel-2/lcl4/"
+			    #+Allegro (frob-pathname "demo")
+			    #+CMU "/home/hornig/clim/rel-2/cmu/"
+			    #+CCL-2 "ccl;clim-2.0:fasls:"
+   :needed-systems (clim-standalone))
+
+  ("packages")
+  ("aaai-demo-driver" :load-before-compile ("packages"))
+  ("graphics-demos" :load-before-compile ("aaai-demo-driver" "packages")
+		    :features (not Minima))
+  ("cad-demo"	    :load-before-compile ("aaai-demo-driver" "packages")
+		    :features (not Minima))
+  ("navdata"	    :load-before-compile ("packages")
+		    :features (not Minima))
+  ("navfun"         :load-before-compile ("aaai-demo-driver" "navdata" "packages")
+		    :features (not Minima))
+  ("listener"       :load-before-compile ("aaai-demo-driver" "packages"))
+  ("puzzle"         :load-before-compile ("aaai-demo-driver" "packages"))
+  ("address-book"   :load-before-compile ("aaai-demo-driver" "packages"))
+  ("thinkadot"      :load-before-compile ("aaai-demo-driver" "packages"))
+  ("demo-prefill" :features (or Genera Cloe-Runtime))
+  )
+
+#+Genera
+(defsys:import-into-sct 'clim-demo 
+			:pretty-name "CLIM Demo"
+			:default-pathname "SYS:CLIM;REL-2;DEMO;"
+			:default-destination-pathname "SYS:CLIM;REL-2;DEMO;")
+
+#+Minima
+(defsys:import-into-sct 'clim-demo :subsystem t
+			:sct-name :minima-clim-demo-standalone
+			:pretty-name "Minima CLIM Demo Standalone"
+			:default-pathname "SYS:CLIM;REL-2;DEMO;"
+			:default-destination-pathname "SYS:CLIM;REL-2;DEMO;")
+
+#+Minima
+(zl:::sct:defsystem minima-clim-demo
+    (:pretty-name "Minima CLIM Demo"
+     :default-pathname "SYS:CLIM;REL-2;DEMO;"
+     :maintain-journals nil
+     :default-module-type :system
+     :patches-reviewed "Bug-CLIM"
+     :source-category :optional)
+  (:parallel "minima-clim-demo-standalone"))
diff --git a/demo/thinkadot.lisp b/demo/thinkadot.lisp
new file mode 100644
index 00000000..6039b619
--- /dev/null
+++ b/demo/thinkadot.lisp
@@ -0,0 +1,192 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
+
+;; $fiHeader: thinkadot.lisp,v 1.4 91/03/26 12:37:43 cer Exp $
+
+(in-package :clim-demo)
+
+"Copyright (c) 1990, 1991 Symbolics, Inc.  All rights reserved."
+
+;;; Simulates a mechanical toy finite-state-machine called "Thinkadot".
+
+;;; in all node-state stuff, t = left, nil = right
+
+(defstruct td-node
+  (direction t)
+  left-successor
+  right-successor
+  x
+  y
+  (color-phase nil)
+  (entry-p nil))
+
+(defstruct td-exit
+  (ball-p nil)
+  x
+  y)
+
+(define-presentation-type entry-node ())
+
+
+;;;       1     2     3
+;;;       |\   / \   /|
+;;;       | \ /   \ / |
+;;;       |  4     5  |
+;;;       | / \   / \ |
+;;;       |/   \ /   \|
+;;;       6     7     8
+;;;      /|    / \    |\
+;;;     LLL   RRR
+
+
+(define-application-frame thinkadot ()
+    ((node1)
+     (node2)
+     (node3)
+     (node4)
+     (node5)
+     (node6)
+     (node7)
+     (node8)
+     (all-nodes)
+     (lexit)
+     (rexit))
+  (:panes ((display :application
+		    :display-function 'draw-the-display
+		    :incremental-redisplay t
+		    :scroll-bars nil)
+	   (menu :command-menu))))
+
+(defmethod initialize-instance :after ((frame thinkadot) &key)
+  (multiple-value-bind (w h)
+      (bounding-rectangle-size (get-frame-pane frame 'display))
+    (let* ((left (round w 6))
+	   (right (- w left))
+	   (x-mid (round (+ left right) 2))
+	   (l-mid (round (+ left x-mid) 2))
+	   (r-mid (round (+ right x-mid) 2))
+	   (top (round h 6))
+	   (bot (- h top))
+	   (y-mid (round (+ top bot) 2)))
+      (with-slots (node1 node2 node3 node4 node5 node6 node7 node8 all-nodes lexit rexit) frame
+	(setf lexit (make-td-exit :x (- left 25)  :y (+ bot 10)))
+	(setf rexit (make-td-exit :x (+ right 25) :y (+ bot 10)))
+	(setf node8 (make-td-node :x right :y bot   :left-successor rexit :right-successor rexit))
+	(setf node7 (make-td-node :x x-mid :y bot   :left-successor lexit :right-successor rexit))
+	(setf node6 (make-td-node :x left  :y bot   :left-successor lexit :right-successor lexit))
+	(setf node5 (make-td-node :x r-mid :y y-mid :left-successor node7 :right-successor node8))
+	(setf node4 (make-td-node :x l-mid :y y-mid :left-successor node6 :right-successor node7))
+	(setf node3 (make-td-node :x right :y top   :left-successor node5 :right-successor node8 :entry-p t))
+	(setf node2 (make-td-node :x x-mid :y top   :left-successor node4 :right-successor node5 :entry-p t))
+	(setf node1 (make-td-node :x left  :y top   :left-successor node6 :right-successor node4 :entry-p t))
+	(setf (td-node-color-phase node2) t
+	      (td-node-color-phase node4) t
+	      (td-node-color-phase node5) t
+	      (td-node-color-phase node7) t)
+	(setf all-nodes (list node1 node2 node3 node4 node5 node6 node7 node8))))))
+
+(defvar *dot-radius* 10)
+(defvar *light-color* (make-gray-color 0.667))
+(defvar *dark-color* +black+)
+
+(defmethod draw-the-display ((frame thinkadot) stream)
+  (with-slots (all-nodes lexit rexit) frame
+    (let ((id 0))
+      (dolist (node all-nodes)
+	(incf id)
+	(let ((x (td-node-x node)) (y (td-node-y node)))
+	  (updating-output (stream :unique-id id
+				   :cache-value (td-node-direction node)
+				   :cache-test #'eql)
+	    #+ignore ; for debugging when you'd like to see the internal state
+	    (if (td-node-direction node)
+		(draw-line* stream (+ x 10) (- y 10) (- x 10) (+ y 10))
+	        (draw-line* stream (+ x 10) (+ y 10) (- x 10) (- y 10)))
+	    (if (eql (td-node-direction node) (td-node-color-phase node))
+		(draw-circle* stream x y *dot-radius* :ink *light-color*)
+	        (draw-circle* stream x y *dot-radius* :ink *dark-color*)))
+	  (when (td-node-entry-p node)
+	    (with-output-as-presentation (stream node 'entry-node
+					  :single-box t)
+	      (let* ((x1 (- x 20)) (x2 (+ x 20)) (y1 (- y 5 *dot-radius*)) (y2 (- y1 20)))
+		(draw-line* stream x1 y2 x y1)
+		(draw-line* stream x2 y2 x y1)))))))
+    (macrolet ((draw-exit (exit)
+		 `(let ((ball-p (td-exit-ball-p ,exit)))
+		    (updating-output (stream :unique-id ',exit
+					     :cache-value ball-p)
+		      (when ball-p
+			(draw-circle* stream (td-exit-x ,exit) (td-exit-y ,exit) *dot-radius* :filled nil))))))
+      (draw-exit lexit)
+      (draw-exit rexit))))
+
+(defun drop-a-marble (node &optional state-change-function)
+  (loop
+    (when (typep node 'td-exit)
+      (setf (td-exit-ball-p node) t)
+      (return))
+    (let ((new-node (if (td-node-direction node)
+			(td-node-left-successor node)
+		        (td-node-right-successor node))))
+      (setf (td-node-direction node) (not (td-node-direction node)))
+      (when state-change-function (funcall state-change-function node))
+      (setq node new-node))))
+
+(define-thinkadot-command (com-drop-marble) ((node 'entry-node))
+  (with-slots (lexit rexit) *application-frame*
+    (setf (td-exit-ball-p lexit) nil
+	  (td-exit-ball-p rexit) nil))
+  (drop-a-marble node))
+
+(define-presentation-to-command-translator drop-a-marble
+    (entry-node com-drop-marble thinkadot)
+    (object)
+  `(,object))
+
+(define-thinkadot-command (com-reset-left :menu "Reset-Left") ()
+  (with-slots (lexit rexit all-nodes) *application-frame*
+    (setf (td-exit-ball-p lexit) nil
+	  (td-exit-ball-p rexit) nil)
+    (dolist (node all-nodes)
+      (setf (td-node-direction node) t))))
+
+(define-thinkadot-command (com-reset-right :menu "Reset-Right") ()
+  (with-slots (lexit rexit all-nodes) *application-frame*
+    (setf (td-exit-ball-p lexit) nil
+	  (td-exit-ball-p rexit) nil)
+    (dolist (node all-nodes)
+      (setf (td-node-direction node) nil))))
+
+(define-thinkadot-command (com-exit :menu T) ()
+  (let ((window (frame-top-level-sheet *application-frame*)))
+    (window-clear window)
+    (setf (window-visibility window) nil))
+  (frame-exit *application-frame*))
+
+
+#||
+() ;standalone testing
+(setq tdt (make-application-frame 'thinkadot 
+				  :parent *clim-root*
+				  :width 300 :height 340 :left 500 :top 100))
+(run-frame-top-level tdt)
+||#
+
+
+;;; demo interface
+
+;;; A per-root alist of thinkadot frames.
+(defvar *thinkadots* nil)
+
+(defun run-thinkadot (&key reinit root)
+  (let ((tdt (cdr (assoc root *thinkadots*))))
+    (when (or (null tdt) reinit)
+      (multiple-value-bind (r-width r-height) (window-inside-size root)
+	(let ((l-offset (round (- r-width 300) 2))
+	      (t-offset (round (- r-height 340) 2)))
+	  (setq tdt (make-application-frame 'thinkadot :parent root
+					    :width 300 :height 340
+					    :left l-offset :top t-offset))))
+      (push (cons root tdt) *thinkadots*))
+    (run-frame-top-level tdt)))
+
+(define-demo "Thinkadot" (run-thinkadot :root *demo-root*))
-- 
GitLab