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