GINA Demo Applications 
GINA Version 2.1 for Common Lisp

Michael Spenke
Christian Beilken
Thomas Berlage
Andreas Bäcker
Andreas Genau

Gesellschaft für Mathematik und Datenverarbeitung mbH (GMD)
(German National Research Center for Computer Science)
P.O. Box 1316
D-5205 Sankt Augustin 1
Federal Republic of Germany

Contents
0. Overview of the Demo Programs	3
1. Hello	6
2. Micky	10
3. Text-Editor	14
4. Clock	16
5. Finder	17
6. Graphic-Editor	22
7. Graphic-Output	28
8. Bitmap-Editor	32
9. Lisp-Widgets	39
10. Tetris	42
11. Pacmen	44
12. Spreadsheet	47
13. Hyper-GINA	50
14. Lisp Listener	53
15. Chess Interface	57
16. Drag and Drop Demo	59
17. Mandelbrot Demo	64
18. Desk Calculator	68

0. Overview of the Demo Programs
This is a collection of simple, well-documented demo applications demonstrating most of the concepts of GINA. The documentation of each demo consists of 
•	a description of the functionality
•	a screen dump of the application window
•	an overview of the implementation and the GINA-features being used
•	limitations of the demo and suggestions for further extensions (sometimes).

The complete source code of all demo programs belongs to the GINA distribution. For the shorter demo programs the source code is also printed within this manual. 
Each of the demo applications consists of only a few pages of code. So, even though they are quite different, at least 95% of the code executed is part of GINA.

These are the demo applications
1.	Hello
	A simple Hello-World application. The string "Hi!" appears, where the mouse is clicked in the main view.
2.	Micky
	Similar to Schmucker's demo for MacApp. Our version, however, allows the user to stretch the width and height of Micky´s head using two scales.
3.	Text-Editor
	This demo shows, how with a few lines of code the Motif text-widget can be turned into a complete and useful application.
4.	Clock
	A simple digital clock.
5.	Finder
	This application shows directory contents in a scrollable list and launches applications and documents.
6.	Graphic-Editor
	Circles and rectangles can be created, moved, resized, and deleted.
7.	Graphic-Output
	Demonstrates the use of the drawing primitives and graphic-contexts of CLX .
8.	Bitmap-Editor
	A simple tool to draw bitmaps. Includes zooming and full undo/redo.
9.	Lisp-Widgets
	This demo shows how new types of widgets can be implemented in Lisp.
10.	Tetris
	A simple version of the well known arcade game.
11.	Pacmen 
	Demo of background processes. Not really a game.
12.	Spreadsheet 
	A usable spreadsheet program. Lisp expressions containing cell references can be used as formulas.
13.	Hyper-GINA
	Similar to HyperCard using widgets.
14.	Lisp Listener 
	A text widget is used as a lisp listener. 
15.	Chess Interface
	Chesspieces (movable icons) can be dragged around. Connection to GNU chess.
16.	Drag and Drop Demo
	Demonstration of drag and drop labels provided by GINA.
17.	Mandelbrot Demo
	Mandelbrot sets are displayed while computed in a background process.
18.	Desk Calculator
	Desk Calculator made with the help of the GINA interface builder.

If you are interested in examples for certain implementation techniques, this overview lists some important topics and the demos covering them
•	Saving documents to file
	Hello, Micky, Text-Editor, Finder, Graphic-Editor, Bitmap-Editor, Chess, Spreadsheet, Hyper-GINA
•	Use of the Interface Builder
	Calculator, Finder, Chess (for the promotion dialog)
•	Graphical output into views
	Graphic-Output, Hello, Micky, Graphic-Editor, Bitmap-Editor, Tetris, Lisp-Widgets, Chess, Pacmen, Spreadsheet, Hyper-GINA, Mandelbrot
•	Undoable commands
	Hello, Graphic-Editor, Bitmap-Editor, Lisp-Widgets, Chess, Spreadsheet, Hyper-GINA, Drag and Drop Demo, Mandelbrot
•	Mouse input in views
	Hello, Graphic-Editor, Bitmap-Editor, Lisp-Widgets, Spreadsheet, Chess, Hyper-GINA, Mandelbrot, Drag and Drop Demo
•	Mouse commands with graphical feedback
	Graphic-Editor, Bitmap-Editor, Lisp-Widgets, Chess, Spreadsheet, Hyper-GINA, Mandelbrot
•	View-objects
	Tetris, Graphic-Editor, Chess, Hyper-GINA, Drag and Drop Demo
•	Direct-manipulation objects
	Graphic-Editor, Chess, Hyper-GINA
•	Movable icons
	Chess
•	Timer
	Clock, Tetris
•	Starting foreign documents and applications
	Finder
•	Toggle buttons within a menu
	Micky, Chess
•	Applications without a menu bar
	Clock, Tetris, Calculator 
•	Color
	Tetris
•	Background processes (progress bar)
	Mandelbrot, Pacmen, Chess, Lisp-Listener
•	Drag and Drop
	Drag and Drop Demo, (Interface-Builder)
•	Double Buffering
	Mandelbrot, Chess
1. Hello
1.1 Functionality
The first experiment with a new programming environment is always the implementation of the hello-world program. The traditional version just prints out "Hello world!" on standard output. Of course, this is too simple in the context of graphical user interfaces. 
Our version of hello-world is somewhat more complex The user can click the mouse within the main area of our window and at this position the string "Hi!" will appear. An entry in the menu bar allows the user to clear all strings again. Hello-world documents can be saved in a file and remember the position of each string. Unlimited undo/redo is possible and the history scroller can be used to move back and forth in the command history.
	
1.2 Implementation

First of all, we have to define a subclass of the GINA class application. At run-time, exactly one instance of this class will exist. It contains the main event loop and transforms incoming events or callbacks into messages to other objects.
The initial values for some slots of the superclass are overridden. The slot name is used e.g. in the title of each document window. Document-type denotes the type of document to be created when the new-command is executed. Hello-world-document is a subclass of the GINA class document explained below. The file-type implies that the document shown above will be stored in the file named THE-S.hello when it is saved. The signature will be stored inside that file and will be later used to find the application which can handle the document.
Besides the definition of the new class, a constructor function is defined, that can be used to create instances of the new class. The constructor function of the subclass calls the constructor of the superclass.
Next, a subclass of the GINA class document is defined. An instance of this class will represent an open document at run-time. It contains the internal representation of the document contents and has methods to transform the contents into a stream of characters and vice versa.
The class hello-world-document contains a slot to hold the list of mouse click positions. The document defines its own representation on the screen by overriding the method create-windows. In this case a shell containing a scrollable view of class hello-world-view is created. The menu bar is implicitly created as part of the document-shell. An application-specific command "Clear all" is added to the menu bar. When the menu item is chosen, an object of class clear-all-command will be created.
Next, a subclass of the GINA class view has to be defined. Views are drawing areas, often larger than the screen and therefore scrollable, where documents display their contents. The contents of a view are normally not drawn by Motif, but by the Lisp application itself, using graphic primitives of the X library. Also, mouse clicks in the view are directly reported to the Lisp application.
The class hello-world-view overrides the method draw, which is called by GINA whenever the view or some part of it is exposed. It uses the method draw-glyphs, which directly corresponds to the CLX function draw-glyphs to draw the Hi-strings. 
The button-press method is called whenever the mouse button goes down in the view. It creates a new instance of the class add-hi-command. This is a subclass of the GINA class command. An instance of this class contains the coordinates of the mouse click. The method doit pushes the coordinate pair onto the hi-list, undoit pops the hi-list again. In both cases force-redraw is called to completely redraw the view. A possible optimization would be to draw or clear just one single "Hi!".
Clear-all-command is a subclass of the GINA class command. An instance of this class contains all the necessary information to execute and later undo the command. In this case, the current hi-list is stored. GINA calls the method doit (which clears the hi-list and redisplays) to execute the command and then pushes it onto a stack of commands already executed. Later, when the user calls the undo facility, GINA executes the method undoit. If the command is repeated in a redo operation, doit is called again. If repeating a command is different from executing it for the first time, the programmer can also override the method redoit.
Finally, signature, class, and file type of the the new application are registered in a central table of GINA. Opening a document of type hello will create an instance of class hello-world-application. In addition, we create a file hello.appl which just contains the signature "hello" (in double quotes). Clicking this file in the Finder will start the new application with an empty document. In order to test the application, we can also directly call the creator function of our application subclass.
1.3 Source Code
;;; -*- Mode LISP; Syntax Common-Lisp; Package hello; Base 10 -*-

(in-package GINA)
(defginapackage hello)
(in-package hello)
(setq *sccs-id* "@(#)hello.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class hello-world-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass hello-world-application (application)
  (;; overrides
   (name          initform "Hello World"         allocation class)
   (document-type initform 'hello-world-document allocation class)
   (signature     initform "hello"               allocation class)
   (file-type     initform "hello"               allocation class))
  (documentation "a simple demo application"))

(defun make-hello-world-application ()
  "start the hello-world-application"
  (make-application class 'hello-world-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class hello-world-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass hello-world-document (document)
  (;; instance-variables
   (hi-list       initform nil accessor hi-list
		  documentation "List of coordinates where HIs are displayed"))
  (documentation "application dependent document type"))

(defmethod write-to-stream ((doc hello-world-document) stream)
  "write the document to the specified stream"
  (prin1 (hi-list doc) stream))

(defmethod read-from-stream ((doc hello-world-document) stream) 
  "read the document from the specified stream"
  (setf (hi-list doc) (read stream)))

(defmethod create-windows ((doc hello-world-document) &aux scroller)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    (setq main-shell (make-document-shell doc))
    (setq scroller   (make-scroller main-shell))
    (setq main-view  (make-hello-world-view scroller doc))

    ;; add an application specific command
    (add-menu-command (main-menu main-shell)
		      "Hello" "Clear all" (make-callback #'make-clear-all-command doc))
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class hello-world-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass hello-world-view (view)
  ()
  (documentation "a view with special draw method and reaction to clicks"))

(defun make-hello-world-view (parent doc)
  "create a new hello-world-view"
  (make-view parent document doc class 'hello-world-view))

(defmethod draw ((view hello-world-view) count x y width height)
  "draw window contents"
  (declare (ignore x y width height))
  (when (zerop count) ;; Ignore all but the last exposure event
    (loop for (x y) in (hi-list (document view))
	  do (draw-glyphs view x y "Hi!"))))

(defmethod button-press ((view hello-world-view) code repetition x y)
  "react to button-press event in the window"
  (declare (ignore code repetition))
  (make-add-hi-command (document view) x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; undoable clear-all-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clear-all-command (command)
  ((name initform "Clear All Command" allocation class)
   (old-hi-list accessor old-hi-list initarg old-hi-list)))

(defun make-clear-all-command (document)
  "create command object storing the current hi-list"
  (make-command document
		class 'clear-all-command
		initargs (list old-hi-list (hi-list document))))

(defmethod doit ((cmd clear-all-command))
  "clear hi-list"
  (with-slots (document) cmd
    (setf (hi-list document) nil)
    (force-redraw (main-view document))))

(defmethod undoit ((cmd clear-all-command))
  "restore hi-list"
  (with-slots (document old-hi-list) cmd
    (setf (hi-list document) old-hi-list)
    (force-redraw (main-view document))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; undoable add-hi-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass add-hi-command (command)
  ((name initform "Add Hi Command" allocation class)
   (hi accessor hi initarg hi)))

(defun make-add-hi-command (document x y)
  "create command object storing the x/y coordinates of the mouse-click"
  (make-command document
		class 'add-hi-command
		initargs (list hi (list x y))))

(defmethod doit ((cmd add-hi-command))
  "add a new pair to hi-list"
  (with-slots (document hi) cmd
    (push hi (hi-list document))
    (force-redraw (main-view document))))

(defmethod undoit ((cmd add-hi-command))
  "pop hi-list"
  (with-slots (document) cmd
    (pop (hi-list document))
    (force-redraw (main-view document))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "hello" 'hello-world-application "hello")
'(make-hello-world-application)
2. Micky
2.1 Functionality
The Micky application was heavily influenced by Kurt Schmucker's demo for MacApp. Our version, however, allows the user to stretch the width and height of Micky´s head using the two scales. The size is stored as the document contents on disk. Because of performance problems of a former X release (X11R3) there is a menu containing a radio button group to choose between a circular and a rectangular shape.

2.2 Implementation
An application subclass is defined as usual. The document class contains the width and height of Micky´s head, a flag indicating the shape of the head, and references to the two scales. The slots shell-width and shell-height are overridden so that a certain initial size is used for the shell. By default the size of a shell is determined by the widgets contained in it. The user can resize the shell, and the new size will be stored on disk when the document is saved.
The shell contains a form widget which organizes the layout of the two scales and the scroller. The form constraints are defined in such a way that mainly the scroller is resized when the shell is resized.
Whenever a scale is operated, the method new-micky-width or new-micky-height is called at the document object with the new value of the scale as an argument. Note that the value-changed-callback of a scale can be set by a keyword parameter, while the less frequently used drag-callback must be explicitly assigned using setf.The methods new-micky-width and new-micky-height store the new size and redraw the view. In addition, the document is marked as modified. We must use the accessor function for the slot modified because it has a demon which makes then Save menu entry sensitive.
A radio button group is inserted in the main menu of the shell which allows to choose between the two possible shapes. Whenever the shape is changed the method toggle-shape is called. 
The method write-to-stream simply writes out the width and height of Micky. When the method read-from-stream is called, GINA automatically redraws the main view of the document, so that the new size of Micky is displayed. However, we explicitly have to indicate the new size in the two scales. Alternatively, we could override the method redraw-views which by default just redraws the views showing the document contents.
Finally, the draw method of class micky-view contains a lot of calls to draw-arc and draw-rectangle to display Micky´s head.
2.3 Limitations and Extensions
As a further extension, reshaping could be made undoable. To achieve this, a command object would have to be created each time a scale is operated.
2.4 Source Code
;;; -*- Mode LISP; Syntax Common-Lisp; Package micky;Base 10-*-

(in-package GINA)
(defginapackage micky)
(in-package micky)
(setq *sccs-id* "@(#)micky.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class micky-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass micky-application (application)
  (;; overrides
   (name          initform "Micky"         allocation class)
   (document-type initform 'micky-document allocation class)
   (signature     initform "micky"         allocation class)
   (file-type     initform "micky"         allocation class))
  (documentation "a simple demo application"))

(defun make-micky-application ()
  "start the micky-application"
  (make-application class 'micky-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class micky-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass micky-document (document)
  (;; instance-variables
   (circles      accessor circles initform t)
   (micky-width  initform 100 accessor micky-width
		 documentation "Width of scalable Micky-Mouse")
   (micky-height initform 100 accessor micky-height
		 documentation "Height of scalable Micky-Mouse")
   (h-scale      accessor h-scale)
   (v-scale      accessor v-scale)
   
   ;; overrides
   (shell-width  initform 300)
   (shell-height initform 400))
  (documentation "application dependent document type"))

(defmethod create-windows ((doc micky-document) &aux form scroller)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view h-scale v-scale) doc
    ;; create document-shell
    (setq main-shell (make-document-shell doc))
    ;; the main-part of the window is organized as a form
    (setq form (make-form main-shell))
    ;; horizontal scale to change the width of Micky
    (setq h-scale (make-scale form
			      orientation horizontal
			      value (micky-width  doc)
			      maximum 500
			      value-changed-callback
			      (make-callback #'new-micky-width doc)
			      ))
    (setf (drag-callback h-scale) (make-callback #'new-micky-width doc))
    
    ;; vertical scale to change the height of Micky
    (setq v-scale (make-scale form
			      orientation vertical
			      processing-direction max-on-bottom
			      value (micky-height doc)
			      maximum 500
			      value-changed-callback
			      (make-callback #'new-micky-height doc)
			      ))
    (setf (drag-callback v-scale) (make-callback #'new-micky-height doc))
    
    (setq scroller (make-scroller form motif-resources (list width 250 height 300)))
    
    ;; create the view
    (setq main-view (make-view scroller
			       width 500 height 500 document doc
			       class 'micky-view))
    ;; define the layout of the form
    (define-form-constraint h-scale
			    top-attachment   form 
			    left-attachment  widget left-widget v-scale
			    right-attachment form)
    (define-form-constraint v-scale
			    top-attachment    form top-offset 30
			    left-attachment   form
			    bottom-attachment form)
    (define-form-constraint scroller
			    top-attachment  widget top-widget  h-scale 
			    left-attachment widget left-widget v-scale 
			    right-attachment  form 
			    bottom-attachment form)

    ;; add a radio group within the main menu to set the desired shape
    (insert-menu-entry (main-menu main-shell) "Shape" "Group"
		       (make-radio-group-entry "Group"
						'("Circle" "Rectangle")
						(make-callback #'toggle-shape doc)
						is-submenu nil))
    
    ))

(defmethod new-micky-width ((doc micky-document) new-width)
  "user has changed width of Micky-Mouse"
  (with-slots (main-view micky-width) doc
    (setq micky-width new-width)
    (force-redraw main-view)
    (setf (modified doc) t)))

(defmethod new-micky-height ((doc micky-document) new-height)
  "user has changed height of Micky-Mouse"
  (with-slots (main-view micky-height) doc
    (setq micky-height new-height)
    (force-redraw main-view)
    (setf (modified doc) t)))

(defmethod toggle-shape ((doc micky-document) new-shape old-shape)
  "toggle between circle and rectangle presentation"
  (declare (ignore old-shape))
  (with-slots (circles main-view v-scale h-scale) doc
    (setq circles (equal new-shape "Circle"))
    (force-redraw main-view)))

(defmethod write-to-stream ((doc micky-document) stream)
  "write the document to the specified stream"
  (format stream "~d ~d~%" (micky-width  doc) (micky-height doc)))

(defmethod read-from-stream ((doc micky-document) stream) 
  "read the document from the specified stream"
  (with-slots (h-scale v-scale micky-width micky-height) doc
    (setq micky-width  (read stream))
    (setq micky-height (read stream))
    (setf (value h-scale) micky-width)
    (setf (value v-scale) micky-height)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class micky-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass micky-view (view)
  ()
  (documentation "a view with special draw method and reaction to clicks"))

(defmethod draw ((view micky-view) count x y width height)
  "draw window contents"
  (declare (ignore x y width height))
  (with-slots (x-window gcontext document) view
    (with-slots (micky-width micky-height circles) document 
      (when (zerop count) ;; Ignore all but the last exposure event
	(when circles 
	  ;; outline of the head
	  (draw-arc view
		    (round (* 0.35 micky-width)) (round (* 0.43 micky-height))
		    (round (* 0.5 micky-width)) (round (* 0.5 micky-height))
		    0 (* 2 pi) nil)
	  ;; ears
	  (draw-arc view 
		    (round (* 0.3 micky-width)) (round (* 0.3 micky-height))
		    (round (* 0.2 micky-width)) (round (* 0.2 micky-height))
		    0 (* 2 pi) t)
	  (draw-arc view
		    (round (* 0.7 micky-width)) (round (* 0.3 micky-height))
		    (round (* 0.2 micky-width)) (round (* 0.2 micky-height))
		    0 (* 2 pi) t)
	  ;; nose
	  (draw-arc view
		    (round (* 0.58 micky-width)) (round (* 0.64 micky-height))
		    (round (* 0.05 micky-width)) (round (* 0.05 micky-height))
		    0 (* 2 pi) t)
	  ;; eyes
	  (draw-arc view
		    (round (* 0.5 micky-width)) (round (* 0.55 micky-height))
		    (round (* 0.05 micky-width)) (round (* 0.05 micky-height))
		    0 (* 2 pi) nil)
	  (draw-arc view
		    (round (* 0.65 micky-width)) (round (* 0.55 micky-height))
		    (round (* 0.05 micky-width)) (round (* 0.05 micky-height))
		    0 (* 2 pi) nil)
	  ;; mouth
	  (draw-arc view
		    (round (* 0.45 micky-width)) (round (* 0.5 micky-height))
		    (round (* 0.3 micky-width)) (round (* 0.3 micky-height))
		    (* 1.3 pi) (* 0.4 pi) nil))

	(when (not circles) 
	  ;; outline of the head
	  (draw-rectangle view
			  (round (* 0.35 micky-width)) (round (* 0.43 micky-height))
			  (round (* 0.5 micky-width)) (round (* 0.5 micky-height)) nil)
	  ;; ears
	  (draw-rectangle view
			  (round (* 0.3 micky-width)) (round (* 0.3 micky-height))
			  (round (* 0.2 micky-width)) (round (* 0.2 micky-height))  t)
	  (draw-rectangle view
			  (round (* 0.7 micky-width)) (round (* 0.3 micky-height))
			  (round (* 0.2 micky-width)) (round (* 0.2 micky-height))  t)
	  ;; nose
	  (draw-rectangle view
			  (round (* 0.58 micky-width)) (round (* 0.64 micky-height))
			  (round (* 0.05 micky-width)) (round (* 0.05 micky-height)) t)
	  ;; eyes
	  (draw-rectangle view
			  (round (* 0.5 micky-width)) (round (* 0.55 micky-height))
			  (round (* 0.05 micky-width)) (round (* 0.05 micky-height)) nil)
	  (draw-rectangle view
			  (round (* 0.65 micky-width)) (round (* 0.55 micky-height))
			  (round (* 0.05 micky-width)) (round (* 0.05 micky-height)) nil)
	  ;; mouth
	  (draw-line view
		     (round (* 0.5 micky-width)) (round (* 0.8 micky-height))
		     (round (* 0.7 micky-width)) (round (* 0.8 micky-height))))
	))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "micky" 'micky-application "micky")
'(make-micky-application)
3. Text-Editor
3.1 Functionality
This demo shows how the Motif text widget can be turned into a complete and useful application with just a few lines of code. Multiple documents can be openend, edited, and saved.

3.2 Implementation
The implementation is completely straightforward. The value-changed-callback of the text widget is only used to recognize when the document is modified. It is therefore immediately turned off again when the first character is typed. The value of the text widget is written to and read from file in open and save operations.
3.3 Limitations and Extensions
Of course, a lot of extensions is still necessary to implement a full text editor.
3.4 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp;Package txedit ;Base10-*-

(in-package GINA)
(defginapackage txedit)
(in-package txedit)
(setq *sccs-id* "@(#)text-editor.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class text-editor-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass text-editor-application (application)
  (;; overrides
   (name          initform "Text-Edit"           allocation class)
   (document-type initform 'text-editor-document allocation class)
   (signature     initform "txedit"              allocation class)
   (file-type     initform "txedit"              allocation class))
  (documentation "a simple text-editor demo application"))

(defun make-text-editor-application ()
  "start the text-editor-application"
  (make-application class 'text-editor-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class text-editor-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass text-editor-document (document)
  (;; overrides
   (shell-width  initform 400)
   (shell-height initform 300)))

(defmethod create-windows ((doc text-editor-document))
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    ;; create document-shell containing a scroller and the text
    (setq main-shell (make-document-shell doc))
    ;; create the text-view
    (setq main-view (make-scrolled-text main-shell))
    ;; typing a character modifies the document
    (setf (value-changed-callback main-view)
	  (make-callback #'mark-modified doc))
    ))

(defmethod mark-modified ((doc text-editor-document) new-value)
  "mark document as modified"
  (declare (ignore new-value))
  (setf (modified doc) t)
  ;; no further value-changed-callbacks necessary
  (setf (value-changed-callback (main-view doc)) nil))

(defmethod write-to-stream ((doc text-editor-document) stream)
  "write the document to the specified stream"
  ;; write the current value of the text widget
  (format stream "~s~%" (value (main-view doc))))

(defmethod read-from-stream ((doc text-editor-document) stream)
  "read the document from the specified stream"
  ;; read and set the current value of the text widget
  (setf (value-changed-callback (main-view doc)) nil) ;;necessary in Motif 1.1 ???
  (setf (value (main-view doc)) (read stream))
  (setf (value-changed-callback (main-view doc))
	(make-callback #'mark-modified doc)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "txedit" 'text-editor-application "txedit")
'(make-text-editor-application)

4. Clock
4.1 Functionality
This is a simple digital clock which is updated every full second.

4.2 Implementation
In the class clock-application the slot idle-timeout is initialized to one second. As a consequence the method idle-action of the application is called periodically by GINA. The default version of this method does not do anything. We override the default version, so that a tick message is sent to each document whenever the timeout occurs. 
The document-shell used for the clock is somewhat unusual It does not have a menu bar and the title does not show the name of the document ("Untitled 1"). The user cannot create multiple clock documents and clocks cannot be saved into a file, because the corresponding menu entries are missing. The shell contains just one label widget. In the method tick, the label-string is updated to the current time.
4.3 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp; Packageclock; Base10-*-

(in-package GINA)
(defginapackage clock)
(in-package clock)
(setq *sccs-id* "@(#)clock.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class clock-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass clock-application (application)
  ((name          initform "Clock"          allocation class)
   (document-type initform 'clock-document  allocation class)
   (signature     initform "clock"          allocation class)
   (file-type     initform nil              allocation class)
   (idle-timeout  initform 1.0              allocation class))
  (documentation "a simple digital clock application"))

(defun make-clock-application ()
  "start the clock-application"
  (make-application class 'clock-application))

(defmethod idle-action ((clock clock-application))
  "periodically refresh the displayed time"
  (loop for document in (document-list clock)
	do (tick document)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class clock-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass clock-document (document)
  ())

(defmethod create-windows ((doc clock-document))
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    (setq main-shell (make-document-shell doc with-menu nil))
    (setf (title main-shell) "Clock")
    (set-motif-resources main-shell icon-name "Clock")
    (setq main-view (make-label main-shell " 000000 "))))

(defmethod tick ((doc clock-document) &aux now)
  "one second is over => refresh the clock"
  (with-slots (main-view) doc
    (setq now (multiple-value-list (decode-universal-time (get-universal-time))))
    (setf (label-string main-view)
	  (format nil " ~2,'0d~2,'0d~2,'0d " (third now) (second now) (first now)))))
    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "clock" 'clock-application nil)
'(make-clock-application)
5. Finder
5.1 Functionality
We also have implemented a simple Finder to start applications and documents in a hierarchical file system. Its function is similar to the Macintosh Finder. The contents of a directory a shown in a scrollable selection-list. Several directories can be shown in different windows (folders) at the same time. Double-clicking a file name opens a document or starts an application. Double-clicking a subdirectory creates a new finder window. Instead of double clicking the user can first select a file and then press the start button.
Using a push-button the user can go back to the parent directory. When the refresh button is pressed, the contents of the directory are read and displayed again. When the Finder is started it first shows the current directory on UNIX machines. On a Symbolics the Finder begins with the root directory.
The size of a folder-window can be modified and stored on disk just like any other document.

5.2 Implementation
A subclass of application is defined as usual. The function AC (Assisting-Computer) is introduced as a synonym for make-finder for GMD purposes.
The class finder-document contains slots for pathnames deduced from the slot file-pathname of the superclass. There is an after-demon for the method initialize-instance, because the name of a finder-document shown as the window title shall be the directory portion of the pathname.
The shell for the Finder was constructed using the Interface Builder. The code generated by the Interface Builder is contained in the file finder-shell.lisp. The file contains the definition of class finder-shell, a subclass of document-shell, and the corresponding constructor function. The class has slots for the widgets which are generated in the constructor function. In the method create-windows we call the constructor function make-finder-shell which creates a form widget containing a scrollable selection-list and some buttons. The callbacks for the buttons have to be explicitly set afterwards. Finally, some superfluous menu entries are removed. The Save entry is replaced by Save Window Size because only the size is stored on disk.
The Finder is somewhat unusual in that the documents correspond to directories rather than normal files. Therefore, the method read-from-file is overridden whereas in other applications the method read-from-stream is overridden. The default version of read-from-file opens the file, reads the header, calls create-windows and then read-from-stream. The Finder version of read-from-file, however, reads the header from the file finderinfo.text placed in the directory, calls create-windows and then determines the list of files of the directory. This list is shown in the scrollable selection-list. Analogously, the method write-to-file is overridden to write the header to the finderinfo file.
To start the selected file we simply have to call the GINA function start-file. If the selected file is a subdirectory, the value stored in the selection-list and passed to start-file is a wildcard. It is always the application with the signature "finder" which is responsible for handling wildcard pathnames. So if you want to implement another Finder it must replace this Finder and use the same signature.
To refresh the file list we simply list the files contained in the directory and call set-item-list for the scrollable selection-list. Subdirectories are placed at the beginning of the list.
5.3 Limitations and Extensions
As a simple extension, it is possible to periodically check if the directory was modified and refresh the file list if necessary. Facilities for moving and copying files could also be added.

5.4 Source Code
;;; -*- ModeLISP;Syntax Common-Lisp;Package GINA ;Base10-*-

(in-package GINA)
(setq *sccs-id* "@(#)finder.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class finder
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass finder (application)
  (;; overrides
   (name          initform "Finder"          allocation class)
   (document-type initform 'finder-document  allocation class)
   (signature     initform "finder"          allocation class)
   (file-type     initform "directory"       allocation class)
   ;;(idle-timeout  initform 10                allocation class)
   )
  (documentation "a simple menu oriented finder"))

(eval-when (eval load)
  (export 'make-finder))

(defun make-finder (&key (display-host *default-display-host*)
		         (toolkit-host *default-toolkit-host*)
			 (document-pathname (current-directory-wildcard)))
  "start the finder application"
  (make-application display-host display-host
		    toolkit-host toolkit-host
		    document-pathname document-pathname
		    class 'finder))

(eval-when (eval load)
  (export 'ac))

(defun AC (&optional (display-host *default-display-host*)
	             (toolkit-host *default-toolkit-host*))
  "just a synonym for the finder"
  (make-finder display-host display-host
	       toolkit-host toolkit-host))

;; impossible to find out if a directory has changed on Symbolics!!!
;(defmethod idle-action ((finder finder))
;  "periodically refresh the folders"
;  (loop for folder in (document-list finder)
;	do (refresh-file-list folder)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class finder-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass finder-document (document)
  (;; related pathnames
   ;; the slot file-pathname holds a wildcard like e.g. "w1>gina>documents>*.*.newest
   (finderinfo       accessor finderinfo) ;; e.g."w1>gina>documents>finderinfo.text"
   (parent-directory accessor parent-dir initform nil) ;; e.g. "w1>gina.directory"
   ;; overrides
   (shell-width  initform 250)
   (shell-height initform 300))
  (documentation "the internal representaion of a folder"))

(defmethod initialize-instance after ((doc finder-document) &rest initargs)
  "some special inits"
  (declare (ignore initargs))
  ;;the name of a finder document is constructed in a different way
  (setf (name doc) (directory-namestring (file-pathname doc))))

(defmethod create-windows ((doc finder-document))
  "create a window containig a scrollable list of files and some buttons"
  (with-slots (main-shell parent-directory) doc
    ;; create finder-shell containing the various widgets as slots
    (setq main-shell (make-finder-shell doc))

    ;; set callback of parent button
    (setf (activate-callback (parent-button main-shell))
	  (make-callback #'start-file parent-directory))
    (set-motif-resources (parent-button main-shell)
			 sensitive (when parent-directory t))

    ;; set the callback of the start-button
    (setf (default-action-button (file-list main-shell)) (start-button main-shell))
    (setf (activate-callback (start-button main-shell))
	  (make-callback #'start-selected-file doc))

    ;; set the callback of the refresh-button
    (setf (activate-callback (refresh-button main-shell))
	  (make-callback #'refresh-file-list doc))

    ;; remove or modify some main menu entries
    (remove-menu-entry (main-menu main-shell) "File" "New")
    (remove-menu-entry (main-menu main-shell) "File" "Open..")
    (remove-menu-entry (main-menu main-shell) "File" "Minifinder")

    ;; saving a documnet means storing its size
    (setf (label-string (save-menu-entry doc)) "Save Window Size")
    (setf (sensitive    (save-menu-entry doc)) t)
    
    (remove-menu-entry (main-menu main-shell) "File" "Save as..")
    (remove-menu-entry (main-menu main-shell) "File" "Revert")

    (remove-menu-entry (main-menu main-shell) "Edit" "Undo")
    (remove-menu-entry (main-menu main-shell) "Edit" "Redo")
    (remove-menu-entry (main-menu main-shell) "Edit" "Replay History")
    (remove-menu-entry (main-menu main-shell) "Edit" "History Scroller")
    
    ))

(defmethod read-from-file ((doc finder-document) wildcard-pathname &key (create-windows t))
  "list the directory instead of normally reading the file"
  (declare (ignore create-windows))
  ;; the parameter is a wildcard rather than a specific file !!
  ;; wildcard-pathname is of the form "w1>gina>documents>*.*.newest"
  (with-slots (finderinfo parent-directory main-shell) doc

    ;; something like "w1>gina>documents>finderinfo.text"
    (setq finderinfo (make-pathname name "finderinfo" type "text"
				    defaults wildcard-pathname))

    ;; something like "w1>gina.directory"
    (when (not (root-directory-p wildcard-pathname))
      (setq parent-directory (parent-directory-wildcard wildcard-pathname)))

    ;; read the finderinfo file placed in the directory if any
    (when (probe-file finderinfo)
      (with-open-file (stream finderinfo direction input)
	(read-header-from-stream doc stream)))

    ;; now that we know the size, we can create the windows
    (create-windows doc)

    ;; show the wildcard in the label
    (setf (label-string (directory-label main-shell))
	  (directory-namestring wildcard-pathname))

    ;; make a view containing the filenames and put it into the scroller
    (refresh-file-list doc)))

(defmethod write-to-file ((doc finder-document) pathname)
  "write the finderinfo to the directory"
  (declare (ignore pathname))
  (with-open-file (stream (finderinfo doc) direction output if-exists new-version)
    (write-header-to-stream doc stream)))

(defmethod start-selected-file ((doc finder-document))
  "start the file which has been selected in the file-list"
  (with-clock-cursor
    (start-file (value (file-list (main-shell doc))) from-document doc)))

(defmethod refresh-file-list ((doc finder-document) &aux files items)
  "read the directory again and build a new file-list"
  (with-slots (file-pathname main-shell) doc
    (with-clock-cursor
      ;; make an item-list of the filenames and put it into the scroller
      (setq files (sort (directory file-pathname) #'pathname-name<))
      (setq items
	    (append
	      (loop for file in files
		    when (directoryp file)
		      collect (list (concatenate 'string "-> " (pathname-name file))
				    (subdirectory-wildcard file)))
	      (loop for file in files
		    when (not (directoryp file))
		      collect (list (name-and-type file) file))))

      ;; change the item list
      (set-item-list (file-list main-shell) items)
      )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "finder" 'finder "directory")
'(make-finder)
Code generated by Interface Builder
;;;-*-ModeLISP; Syntax Common-Lisp;Packagegina;-*-

;; !!! Do not edit !!!
;; This code was generated by the GINA Interface Builder.

(in-package gina)

(defclass finder-shell
          (document-shell)
          ((form accessor form) (parent-button accessor parent-button)
           (directory-label accessor directory-label)
           (file-list accessor file-list) (button-row accessor button-row)
           (start-button accessor start-button)
           (refresh-button accessor refresh-button))
          (documentation ""))
(defun make-finder-shell (doc &key (initargs nil) (motif-resources nil)
                          (class 'finder-shell) &aux box)
  (setq box
        (make-document-shell
          doc
          class
          class
          initargs
          initargs
          motif-resources
          motif-resources))
  (setf (form box) (make-form box name "form"))
  (setf (parent-button box)
        (make-push-button (form box) "Parent Directory" name "parent-button"))
  (setf (directory-label box)
        (make-label (form box) "/home/spenke" name "directory-label"))
  (setf (file-list box)
        (make-scrollable-selection-list
          (form box)
          '("file1" "file2" "file3")
          name
          "file-list"))
  (setf (button-row box)
        (make-row-column
          (form box)
          name
          "button-row"
          orientation
          horizontal
          spacing
          50))
  (setf (start-button box)
        (make-push-button
          (button-row box)
          " Open "
          name
          "start-button"
          recompute-size
          nil))
  (setf (refresh-button box)
        (make-push-button
          (button-row box)
          " Refresh "
          name
          "refresh-button"
          recompute-size
          nil))
  (define-form-constraint
    (parent-button box)
    top-attachment
    form
    top-offset
    10
    left-attachment
    form
    left-offset
    10
    right-attachment
    none
    bottom-attachment
    none)
  (define-form-constraint
    (directory-label box)
    top-attachment
    widget
    top-widget
    (parent-button box)
    top-offset
    10
    left-attachment
    form
    left-offset
    10
    right-attachment
    none
    bottom-attachment
    none)
  (define-form-constraint
    (file-list box)
    top-attachment
    widget
    top-widget
    (directory-label box)
    top-offset
    10
    left-attachment
    form
    left-offset
    10
    right-attachment
    form
    right-offset
    10
    bottom-attachment
    widget
    bottom-widget
    (button-row box)
    bottom-offset
    10)
  (define-form-constraint
    (button-row box)
    top-attachment
    none
    left-attachment
    form
    left-offset
    10
    right-attachment
    none
    bottom-attachment
    form
    bottom-offset
    9)
  box)
6. Graphic-Editor

6.1 Functionality
Using this editor, circles and rectangles can be drawn, selected, moved, and resized using the mouse. The view is automatically scrolled if the mouse is moved outside while dragging or drawing an object. All commands are undoable. The history scroller can be used to travel through the command history. If necessary, the view is scrolled, to show the effect of an undo or redo operation.
The palette on the left is used to select the desired mode. In select mode existing objects can be selected by either clicking the mouse into them or dragging a dashed rectangle around them. Objects can be moved around if the mouse is held down and moved. If one of the four little resize handles is hit an object is resized. In rectangle and circle mode new rectangles (circles) are drawn even if the mouse goes down in an existing object. Squares and true circles with equal width and height are drawn, when pressing the left mouse button with shift for dragging. The three remaining modes are not implemented.
There is a main menu entry Clear All which can be used to delete all objects.
6.2 Implementation
The palette is implemented as a radio button group with a pixmap for each button. Each item in the item list consists of a pathname and keyword for the mode. When a radio button is pressed, the method set-mode of class graphic-editor-view is called. Form constraints define that the size of the palette is fixed and the size of the scroller containing the drawing area is variable.
When a document is saved, the representation of each object is written in a loop. The representation of each object begins with a keyword for the type of object (circle or rectangle). Before that, the number of objects is written, so that it is easier to read in the description later. When a document is read from a stream, we have to deinstall any existing objects first, because we can be in a revert command. There are read-from-stream methods specialized for the keywords circle and rectangle which create new objects from the parameters found in the input stream. 
When a mouse button is pressed in the graphic editor view, a mouse command is created depending on the currently selected mode. When the drawing mode is changed, the slot propagate-button-press of class view is also modified, because in circle and rectangle mode button-press messages are handled directly by the view while in select mode button-press is passed to the object hit (if any).
The class rectangle is a straightforward subclass of direct-manipulation-object which overrides the method draw to define the shape of a rectangle. Facilities for moving, selecting and resizing objects are inherited by the superclass. The method constrain-size is overridden to guarantee the a square remains a square.
The class circle is implemented analogously to class rectangle, but in addition the method draw-outline is overridden. This method is responsible for drawing the feedback while an object is moved or resized. The default feedback is a dashed rectangle but we prefer a dashed circle.
A rectangle-drawer is a special kind of mouse-down-command. The feedback is a dashed rubberband rectangle. The mouse coordinates used in the command are constrained so that the feedback rectangle always has positive width and height. If shift is held down the minimum of width and height is used for both so that a square is drawn. In the method doit a new rectangle is created and installed in the view. In case of a redo, doit is also called and just installs the already existing rectangle. Alternatively, we could have overridden the method redoit which by default calls doit. To undo the command the rectangle is deinstalled. Note that view-objects can - other than widgets - exist without having a parent. The class circle-drawer is implemented analogously.
A clear-all-command stores the list of objects being cleared, so that they can be installed again in undoit.
6.3 Limitations and Extensions
The commands and graphical objects for the remaining modes shown in the palette could be implemented as a simple and straightforward extension of this demo. 
Currently, circles are selected even if the the mouse is clicked outside the circle itself, but the enclosing rectangle is hit. To fix this problem, the method point-inside of class circle could be overridden to check more precisely, whether a point lies inside the circle. The default method just checks if the enclosing rectangle is hit.
The next step towards a serious graphic editor would be to add attributes like line width to the objects and to modify the graphic contexts in the draw methods accordingly.
6.4 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp;Packagegredit;Base10-*-

(in-package GINA)
(defginapackage gredit) 
(in-package gredit)
(setq *sccs-id* "@(#)graphic-editor.lisp	1.7  1/20/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-editor-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-editor-application (application)
  (;; overrides
   (name                 initform "Graphic Editor"         allocation class)
   (document-type        initform 'graphic-editor-document allocation class)
   (signature            initform "gredit"                 allocation class)
   (file-type            initform "gredit"                 allocation class))
  (documentation "a simple graphic editor application"))

(defun make-graphic-editor-application ()
  "start the graphic-editor-application"
  (make-application class 'graphic-editor-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-editor-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-editor-document (document)
  (;; overrides
   (shell-width  initform 400)
   (shell-height initform 500))
  (documentation "application dependent document type"))

(defmethod create-windows ((doc graphic-editor-document)
			   &aux scroller form radio-group)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    (setq main-shell (make-document-shell doc))
    ;; create a form containing the different parts
    (setq form      (make-form main-shell))
    (setq scroller  (make-scroller form))    
    (setq main-view (make-graphic-editor-view scroller doc))
    (setq radio-group
	  (make-radio-button-group form
			   '(("arrow"     select-mode)
                             ("rectangle" rect-mode)
			     ("circle"    circle-mode)
			     ("line"      line-mode)
			     ("triangle"  poly-mode)
                             ("glyph"     text-mode))
                           value-changed-callback
                              (make-callback #'set-mode main-view)
			   button-label-type pixmap
			   button-resources '(shadow-thickness 3)))
    
    ;; layout definition
    (define-form-constraint radio-group
			    top-attachment form
			    left-attachment form)
    (define-form-constraint scroller
			    left-attachment widget left-widget radio-group
			    top-attachment form 
			    right-attachment form
			    bottom-attachment form)
    
    ;; add some menu commands
    (add-menu-command (main-menu main-shell)
		      "Draw" "Clear All"
		      (make-callback #'make-clear-all-command doc))
    ))

(defmethod write-to-stream ((doc graphic-editor-document) stream)
  "write the document to the specified stream"
  ;; write number of objects
  (format stream "~d~%" (length (view-objects (main-view doc))))
  
  ;; write all objects
  (loop for object in (view-objects (main-view doc))
	do (write-to-stream object stream)))

(defmethod read-from-stream ((doc graphic-editor-document) stream
			     &aux nr-of-objects) 
  "read the document from the specified stream"
  ;; deinstall existing objects
  (loop for object in (view-objects (main-view doc))
	do (deinstall object))
  
  ;; read number of objects
  (setq nr-of-objects (read stream))

  ;; read positions of objects
  (loop repeat nr-of-objects
	as class = (read stream)
	do (install (read-from-stream class stream)
		    (main-view doc) (read stream) (read stream)) ;; x-pos y-pos
	   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-editor-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-editor-view (view)
  ((drawing-mode accessor drawing-mode initform select-mode))
  (documentation "a view with special reaction to clicks"))

(defun make-graphic-editor-view (parent doc)
  (make-view parent
	     width 1000 height 1000 document doc
	     class 'graphic-editor-view))

(defmethod button-press ((view graphic-editor-view) code repetition x y)
  "react to button-press event in the window"
  (declare (ignore repetition))
  (case (drawing-mode view)
    (select-mode  (make-object-selector  view x y code))
    (rect-mode    (make-rectangle-drawer view x y code))
    (circle-mode  (make-circle-drawer    view x y code))))

(defmethod set-mode ((view graphic-editor-view) new-mode old-mode)
  "depending on the palette, button-press is propagated to the objects or not"
  (declare (ignore old-mode))
  (with-slots (drawing-mode propagate-button-press) view
    (setq drawing-mode new-mode)
    (setq propagate-button-press (eql drawing-mode select-mode))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class rectangle
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass rectangle (direct-manipulation-object)
  (;;overrides
   (facilities initform resizable allocation class
	       documentation "rectangles can be moved, selected and resized")
   (outlines   initform t          allocation class
	       documentation
	       "just move an outline of the object, not the object itself")
   (ensure-square accessor ensure-square initarg ensure-square))
  (documentation "a rectangular object in the view"))

(defun make-rectangle (width height &key (ensure-square nil))
  (make-direct-manipulation-object 
   width height class 'rectangle
   initargs (list ensure-square ensure-square)))

(defmethod draw ((rect rectangle) count x y width height)
  "draw rect into the view"
  (declare (ignore x y width height))
  (when (zerop count) ;; Ignore all but the last exposure event
    (draw-rectangle rect 0 0 (width rect) (height rect))))

(defmethod constrain-size ((rect rectangle) width height)
  "make sure that width and height remain equal"
  (if (not (ensure-square rect))
      ;; just return width and height unmodified
      (values width height)
    ;; else compute minimum
    (values (min width height) (min width height))))

(defmethod write-to-stream ((rect rectangle) stream)
  "write textual representation of a rectangle to stream"
  (with-slots (x-pos y-pos width height) rect
    (format stream "rectangle ~d ~d ~d ~d~%" width height x-pos y-pos)))

(defmethod read-from-stream ((class (eql rectangle)) stream)
  "create a rectangle from its textual representation"
  (make-rectangle (read stream) (read stream)))  ;; width height
       
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class circle
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass circle (direct-manipulation-object)
  (;;overrides
   (facilities initform resizable  allocation class)
   (outlines   initform t           allocation class)
   (ensure-true-circle accessor ensure-true-circle 
		       initarg ensure-true-circle))
  (documentation "a circle in the view"))

(defun make-circle (width height &key (ensure-true-circle nil))
  (make-direct-manipulation-object 
   width height class 'circle
   initargs (list ensure-true-circle ensure-true-circle)))

(defmethod draw ((cc circle) count x y width height)
  "draw circle into the view"
  (declare (ignore x y width height))
  (when (zerop count) ;; Ignore all but the last exposure event
    (draw-arc cc 0 0 (width cc) (height cc) 0 (* 2 pi))))

(defmethod draw-outline ((cc circle) new-x new-y width height &key clear)
  "draw circular outline"
  (declare (ignore clear))
  (with-slots (parent-view) cc
    (xlibwith-gcontext ((gcontext parent-view) line-style dash)
      (draw-arc parent-view new-x new-y width height 0 (* 2 pi)))))

(defmethod constrain-size ((cc circle) width height)
  "make sure that width and height remain equal"
  (if (not (ensure-true-circle cc))
      ;; just return width and height unmodified
      (values width height)
    ;; else compute minimum
    (values (min width height) (min width height))))

(defmethod write-to-stream ((obj circle) stream)
  "write textual representation of object to stream"
  (with-slots (x-pos y-pos width height) obj
    (format stream "circle ~d ~d ~d ~d~%" 
                   width height x-pos y-pos)))

(defmethod read-from-stream ((class (eql circle)) stream)
  "create a circle from its textual representation"
  (make-circle (read stream) (read stream)))  ;; width height

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class rectangle-drawer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass rectangle-drawer (mouse-down-command)
  (;; overrides
   (name initform "Draw Rectangle" allocation class)
   (hysteresis initform 5          allocation class)
   ;; instance-variables
   (shift-pressed accessor  shift-pressed initarg shift-pressed)
   (new-rectangle accessor new-rectangle initform nil))
  (documentation "a mouse-down-command to draw a rectangle"))

(defun make-rectangle-drawer (view x y code)
  (make-mouse-down-command (document view) view x y
			   cursor crosshair
			   class 'rectangle-drawer
			   initargs (list shift-pressed (eq code extend))))

(defmethod constrain-mouse ((cmd rectangle-drawer) x y &aux edge-length)
  "make sure width and height of outline is > 0; ensure square"
  (with-slots (start-x start-y shift-pressed) cmd
    (setq x (max x (1+ start-x)))
    (setq y (max y (1+ start-y)))
    (when shift-pressed
      ;; we draw a square
      (setq edge-length (min (- x start-x) (- y start-y)))
      (setq x (+ start-x edge-length))
      (setq y (+ start-y edge-length))))
  (values x y))

(defmethod draw-feedback ((cmd rectangle-drawer) x y &key clear)
  "draw rectangular feedback"
  (declare (ignore clear))
  (with-slots (start-x start-y view) cmd
    (xlibwith-gcontext ((gcontext view) line-style dash)
      (draw-rectangle view start-x start-y (- x start-x)  (- y start-y)))))

(defmethod doit ((cmd rectangle-drawer))
  "install the specified rectangle"
  (with-slots (start-x start-y last-x last-y view 
		       new-rectangle shift-pressed) cmd
    (when (not new-rectangle)
      (setq new-rectangle (make-rectangle (- last-x start-x) (- last-y start-y)
					  ensure-square shift-pressed)))
    (install new-rectangle view start-x start-y)
    ))

(defmethod undoit ((cmd rectangle-drawer))
  "deinstall the specified rectangle again"
  (with-slots (new-rectangle) cmd
    (deinstall new-rectangle)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class circle-drawer
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass circle-drawer (mouse-down-command)
  (;; overrides
   (name initform "Draw Circle"    allocation class)
   (hysteresis initform 5          allocation class)
   ;; instance-variables
   (shift-pressed accessor  shift-pressed initarg shift-pressed)
   (new-circle accessor new-circle initform nil))
  (documentation "a mouse-down-command to draw a circle"))

(defun make-circle-drawer (view x y code)
  (make-mouse-down-command (document view) view x y
			   cursor crosshair
			   class 'circle-drawer
			   initargs (list shift-pressed (eq code extend))))

(defmethod constrain-mouse ((cmd circle-drawer) x y &aux diameter)
  "make sure width and height of outline is > 0"
  (with-slots (start-x start-y shift-pressed) cmd
    (setq x (max x (1+ start-x)))
    (setq y (max y (1+ start-y)))
    (when shift-pressed
      ;; we draw a true circle
      (setq diameter (min (- x start-x) (- y start-y)))
      (setq x (+ start-x diameter))
      (setq y (+ start-y diameter))))
  (values x y))

(defmethod draw-feedback ((cmd circle-drawer) x y &key clear)
  "draw circular feedback"
  (declare (ignore clear))
  (with-slots (start-x start-y view) cmd
    (xlibwith-gcontext ((gcontext view) line-style dash)
      (draw-arc view start-x start-y (- x start-x) (- y start-y) 0 (* 2 pi)))))

(defmethod doit ((cmd circle-drawer))
  "install the specified circle"
  (with-slots (start-x start-y last-x last-y view new-circle shift-pressed) cmd
    (when (not new-circle)
      (setq new-circle (make-circle (- last-x start-x) (- last-y start-y)
				    ensure-true-circle shift-pressed)))
    (install new-circle view start-x start-y)))

(defmethod undoit ((cmd circle-drawer))
  "deinstall the specified circle again"
  (with-slots (new-circle) cmd
    (deinstall new-circle)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class clear-all-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clear-all-command (command)
  (;; overrides
   (name initform "Clear All Command" allocation class)
   ;; instance-parameters
   (objects accessor objects initarg objects
	    documentation "objects being cleared"))
  (documentation "a command to delete all objects"))

(defun make-clear-all-command (document)
  "create a new command object with appropriate parameters"
  (make-command document
		class 'clear-all-command
		initargs `(objects ,(view-objects (main-view document)))))

(defmethod doit ((cmd clear-all-command))
  "delete all objects from the view"
  (loop for object in (objects cmd)
	do (deinstall object)))

(defmethod undoit ((cmd clear-all-command))
  "reinstall all objects in the view"
  (loop for object in (objects cmd)
	do (install object (main-view (document cmd))
		    (x-pos object) (y-pos object))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(register-application "gredit" 'graphic-editor-application "gredit")
'(make-graphic-editor-application) 
7. Graphic-Output
7.1 Functionality
This demo just shows the use of the graphics primitives of the X Window System. In the main view several rectangles, circles, lines etc. are shown. There are three modeless dialog boxes to change attributes of the graphics context like line width, arc mode etc. The changes are immediately reflected in the view.

7.2 Implementation
The main view of this application has a draw method which calls methods like draw-rectangle, draw-arc, etc. These methods directly correspond to the CLX functions with the same name (which they call). However, they do not have a gcontext parameter. Instead, the slot gcontext of class view is passed to each CLX function. Therefore, changes to the gcontext of the view caused by the dialog boxes affect the result of the calls to draw-rectangle etc. In some cases, attributes of the graphics contexts are explicitly set with the macro with-gcontext. For example, the first text line is always in font 6x10.
Each dialog box is created when it is used for the first time. Later, we just call pop-up for the existing box. In each callback an attribute of the gcontext is modified.
7.3 Source Code
;;; -*- Mode LISP; Syntax Common-Lisp; Package output;Base 10 -*-

(in-package GINA)
(defginapackage output)
(in-package output)
(setq *sccs-id* "@(#)graphic-output.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-output-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-output-application (application)
  (;; overrides
   (name          initform "Graphic Output"          allocation class)
   (document-type initform 'graphic-output-document  allocation class)
   (signature     initform "output"                  allocation class)
   (file-type     initform "output"                  allocation class)))

(defun make-graphic-output-application ()
  "start the graphic-output-application"
  (make-application class 'graphic-output-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-output-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-output-document (document)
  (;; instance-variables
   (line-dialog accessor line-dialog initform nil)
   (fill-dialog accessor fill-dialog initform nil)
   (font-dialog accessor font-dialog initform nil)
   ;; overrides
   (shell-width  initform 500)
   (shell-height initform 500)))

(defmethod create-windows ((doc graphic-output-document))
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    ;; create a simple document-shell
    (setq main-shell (make-document-shell-with-scroller doc))
    ;; create the view
    (setq main-view (make-graphic-output-view  main-shell doc))
    
    ;; add some menu commands
    (add-menu-command (main-menu main-shell)
		      "GContext" "Line ..."
		      (make-callback #'display-line-dialog doc))
    (add-menu-command (main-menu main-shell)
		      "GContext" "Fill ..."
		      (make-callback #'display-fill-dialog doc))
    (add-menu-command (main-menu main-shell)
		      "GContext" "Font ..."
		      (make-callback #'display-font-dialog doc))

    ;; remove unnecessary menu entries
    (remove-menu-entry (main-menu main-shell) "File" "Open..")
    (remove-menu-entry (main-menu main-shell) "File" "Save")
    (remove-menu-entry (main-menu main-shell) "File" "Save as..")
    (remove-menu-entry (main-menu main-shell) "File" "Revert")

    (remove-menu-entry (main-menu main-shell) "Edit" "Undo")
    (remove-menu-entry (main-menu main-shell) "Edit" "Redo")
    (remove-menu-entry (main-menu main-shell) "Edit" "Replay History")
    (remove-menu-entry (main-menu main-shell) "Edit" "History Scroller")

    ))

(defmethod display-line-dialog ((doc graphic-output-document) &aux column)
  "pop-up gcontext dialog, create if necessary"
  (with-slots (line-dialog main-view) doc
    (when (not line-dialog)
      (setq line-dialog (make-modeless-dialog-box "Line Attributes" document doc))
      (setq column (make-row-column line-dialog))
      ;; a scale to adjust the line width
      (make-scale column
		  orientation horizontal
		  title-string "line-width"
		  minimum 0 maximum 10 value 0
		  value-changed-callback
		  `(lambda (new)
		     (setf (xlibgcontext-line-width ',(gcontext main-view)) new)
		     (force-redraw ',main-view)))

      ;; radio button group for line style
      (make-radio-button-group
	column '(("solid" solid)
		 ("dash" dash)
		 ("double-dash" double-dash))
	label-string "line-style"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-line-style ',(gcontext main-view)) new)
	   (force-redraw ',main-view)))

      ;; radio button group for join-style
      (make-radio-button-group
	column '(("miter" miter)
		 ("round" round)
		 ("bevel" bevel))
	label-string "join-style"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-join-style ',(gcontext main-view)) new)
	   (force-redraw ',main-view)))

      ;; radio button group for cap-style
      (make-radio-button-group
	column '(("not-last" not-last)
		 ("butt" butt)
		 ("round" round)
		 ("projecting" projecting))
	label-string "cap-style"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-cap-style ',(gcontext main-view)) new)
	   (force-redraw ',main-view)))
      )
    (pop-up line-dialog)))

(defmethod display-fill-dialog ((doc graphic-output-document) &aux column)
  "create modeless dialog box"
  (with-slots (fill-dialog main-view) doc
    (when (not fill-dialog)
      (setq fill-dialog (make-modeless-dialog-box "Fill Attributes" document doc))
      (setq column (make-row-column fill-dialog))
 
      ;; radio button group for fill style
      (make-radio-button-group
	column '(("solid" solid)
		 ("tiled" tiled)
		 ("opaque-stippled" opaque-stippled)
		 ("stippled" stippled))
	label-string "fill-style"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-fill-style (gcontext (main-view ',doc))) new)
	   (force-redraw (main-view ',doc))))

      ;; radio button group for fill rule
      (make-radio-button-group 
	column '(("even-odd" even-odd)
		 ("even-odd" winding))
	label-string "fill-rule"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-fill-rule (gcontext (main-view ',doc))) new)
	   (force-redraw (main-view ',doc))))

      ;; radio button group for arc-mode
      (make-radio-button-group
	column '(("chord" chord)
		 ("pie-slice" pie-slice))
	label-string "arc-mode"
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-arc-mode (gcontext (main-view ',doc))) new)
	   (force-redraw (main-view ',doc))))

      ;; option-menu for drawing-function
      (make-option-menu
	column `(("boole-clr" ,boole-clr)
		 ("boole-set" ,boole-set)
		 ("boole-1" ,boole-1)
		 ("boole-2" ,boole-2)
		 ("boole-c1" ,boole-c1)
		 ("boole-c2" ,boole-c2)
		 ("boole-and" ,boole-and)
		 ("boole-ior" ,boole-ior)
		 ("boole-xor" ,boole-xor)
		 ("boole-eqv" ,boole-eqv)
		 ("boole-nand" ,boole-nand)
		 ("boole-nor" ,boole-nor)
		 ("boole-andc1" ,boole-andc1)
		 ("boole-andc2" ,boole-andc2)
		 ("boole-orc1" ,boole-orc1)
		 ("boole-orc2" ,boole-orc2))
	label-string "drawing-function"
	initial-value boole-1
	value-changed-callback
	`(lambda (new old)
	   (setf (xlibgcontext-function (gcontext (main-view ',doc))) new)
	   (force-redraw (main-view ',doc))))
    
      )
    (pop-up fill-dialog)))

(defmethod display-font-dialog ((doc graphic-output-document) &aux column font-list)
  "create modeless dialog box"
  (with-slots (font-dialog main-view) doc
    (when (not font-dialog)
      (setq font-dialog (make-modeless-dialog-box "Fonts" document doc))
      (setq column (make-row-column font-dialog))
 
      ;; font menu
      (setq font-list
	    (make-scrollable-selection-list column (xliblist-font-names *display* "*")))
      (setf (default-action-button font-list)
	    (make-push-button column "Change Font"
			      activate-callback
			      `(lambda ()
				 (setf (xlibgcontext-font (gcontext (main-view ',doc)))
				       (value ',font-list))
				 (force-redraw (main-view ',doc)))))
      )
    (pop-up font-dialog)))

'(with-application-stopped
   (print (xliblist-font-names *display* "*x*")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class graphic-output-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass graphic-output-view (view)
  ()
  (documentation "a view with special draw method"))

(defun make-graphic-output-view (parent document)
  (make-view parent
	     width 600 height 800 document document
	     backing-store t
	     class 'graphic-output-view))

(defmethod draw ((view graphic-output-view) count x y width height)
  "draw window contents"
  (declare (ignore x y width height))
  (with-slots (gcontext document) view
    (when (zerop count) ;; Ignore all but the last exposure event
	
      ;; draw some rectangles
      ;;(draw-rectangle view x y width height &optional fill-p)
      (draw-rectangle view 5  5 40 40 t)
      (xlibwith-gcontext (gcontext line-width 4)
	(draw-rectangle view 50 5 40 40 nil))

      ;; draw some arcs
      ;;(draw-arc view x y width height angle1 angle2 &optional fill-p)
      (draw-arc view 5  100 40 40 0 (* 2 pi) t)
      (draw-arc view 50 100 40 40 0 (* 2 pi) nil)

      (draw-arc view 100 100 40 40 0 (* 0.5 pi) t)
      (draw-arc view 150 100 40 40 0 (* 0.5 pi) nil)

      ;; draw some lines and points
      (draw-line view 5 150 100 150)
      (draw-lines view '(220 150 260 170 240 120 220 170) fill-p t)
      (draw-points view '(1 160 4 160 9 160 16 160 25 160 36 160 49 160 64 160 81 160 100 160))

      ;; draw some text in different fonts
      (xlibwith-gcontext (gcontext font "6x10")
	(draw-glyphs view 5 200 "This is a text in font 6x10"))
      (draw-glyphs view 5 230 "This is a text in a variable font")
      )))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "output" 'graphic-output-application "output")
'(make-graphic-output-application)
8. Bitmap-Editor

8.1 Functionality
Bitmaps can be edited by holding down and moving one of the three mouse buttons. Using the left mouse button, the user can set pixels. The middle button is used to clear pixels and the right button is used to toggle pixels. On a one-button mouse, the shift and control-shift keys are used instead of the middle and right button. Full undo/redo is possible for edit operations.
There are two views showing the bitmap. In the small view the bitmap is shown in original size and in the big view each pixel is shown as a large square. The size of these squares can be modified with the scale right below the main menu. The mouse can be pressed in any of the views and changes are immediately reflected in both views. 
The number of rows and columns of the bitmap can be modified using two scales in a modeless dialog box. To display the dialog box the menu entry Set Size is selected. The size of a bitmap can be temporarily modified without losing the contents of the bitmap. The menu entry Adapt Shell Size resizes the shell, so that the full bitmap is shown and no scrolling is necessary.
Using the menu entries Clear All and Set All all pixels can be cleared or set.
8.2 Implementation
The class bitmap-document contains the internal representation of a bitmap. The bitmap is stored as a list of the coordinates of the black pixels. There are methods to set, clear, and toggle single pixels which change the internal representation and also reflect the changes in the two views. 
When a bitmap is written to a file, only the the coordinates which lie within the current size of the bitmap are written. The external representation is a list of pairs. When a document is read from a file, the new size of the bitmap is indicated in the scale widgets and the views are resized. 
The method change-params is called when any of the three scales is operated. It resizes (and thus redraws) the two views.
The dialog box is created when it is used for the first time. Later, we just call pop-up for the existing box. The method adapt-shell-size corresponds to the main menu entry. It resizes the main shell, so that the full bitmap is shown. It might not work precisely if different fonts are used.
The class bitmap-view is used for both views of the application. The mini view does not have a gap between the individual pixels. In method button-press a command object is created, depending on which button is pressed. GINA passes a virtual button code to button-press. Therefore, the application does not have to care about one, two, and three button mice.
There are methods to set or clear individual pixels. The method draw just sets all black pixels in a loop.
The three mouse commands for pixel editing are quite similar. They are created when one of the mouse buttons goes down in any of the views. There is no feedback drawn, instead pixels are directly modified in method track-mouse, which is called each time the mouse moves. In this method x and y of the mouse position are translated into coordinates for the bitmap. Next, it is checked if a new square is under the mouse, or if the mouse has been moved inside a square representing a pixel. Only if at least one pixel is changed in a command, the slot call-doit is set, so that it is really submitted. The method doit remains empty because everything is already done in track-mouse. In undoit and redoit the pixels collected by track-mouse are changed again.
Finally, there is the class clear-all-command. Note that this class is used for both the Set All and Clear All menu entries. Therefore, the name slot has instance allocation, i.e. it may have a different value in two instances. To make the command undoable, the current bitmap is stored in each command object and can later be redisplayed. 
8.3 Limitations and Extensions
For a more efficient implementation an array should be used to hold the bitmap. Furthermore, it should be possible to write out a bitmap in the C language format used for Motif icons, buttons, etc.
8.4 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp;Package bitedit;Base10-*-

(in-package GINA)
(defginapackage bitedit)
(in-package bitedit)
(setq *sccs-id* "@(#)bitmap-editor.lisp	1.5  1/17/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; class bitmap-editor
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass bitmap-editor (application)
  (;; overrides
   (name                 initform "Bitmap Editor"  allocation class)
   (document-type        initform 'bitmap-document allocation class)
   (signature            initform "bitedit"        allocation class)
   (file-type            initform "bitmap"         allocation class))
  (documentation "a simple bitmap editor application"))

(defun make-bitmap-editor ()
  "start the bitmap-application"
  (make-application class 'bitmap-editor))

'(make-bitmap-editor)
		    
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; class bitmap-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass bitmap-document (document)
  ((bitmap     accessor bitmap     initform nil)
   (no-rows    accessor no-rows    initform 32)
   (no-columns accessor no-columns initform 32)
   
   (mini-view     accessor mini-view)
   (factor-scale  accessor factor-scale)
   (params-box    accessor params-box    initform nil)
   (rows-scale    accessor rows-scale    initform nil)
   (columns-scale accessor columns-scale initform nil)
   
   (shell-width  initform 370)
   (shell-height initform 420)))

;; forward declaration 
(defclass bitmap-view (view)
  ((factor  accessor factor  initarg factor
	    documentation "size of a single pixel on the screen")
   (gap     accessor gap     initarg gap
	    documentation "white space between pixels")))

(defmethod create-windows ((doc bitmap-document)
			   &aux form scroller frame mini-frame)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view mini-view factor-scale no-columns no-rows) doc
    (setq main-shell (make-document-shell doc))
    (setq form       (make-form main-shell))
    (setq scroller   (make-scroller form))
    (setq frame      (make-frame scroller shadow-type etched-out))
    (setq main-view (make-bitmap-view frame doc
				      factor 10
				      gap 1
				      columns no-columns
				      rows no-rows))
    (setq mini-frame (make-frame form shadow-type etched-out))
    (setq mini-view (make-bitmap-view mini-frame doc
				      factor 1
				      gap 0
				      columns no-columns
				      rows no-rows))
       
    (setq factor-scale
	  (make-scale form
		      orientation horizontal
		      title-string "Pixel Size"
		      value (factor (main-view doc))
		      minimum 2
		      maximum 30
		      value-changed-callback
		      (make-callback #'change-params doc factor)))

    (define-form-constraint factor-scale
			    top-attachment form
			    left-attachment form
			    right-attachment form)
    (define-form-constraint mini-frame
			    top-attachment widget top-widget factor-scale
			    left-attachment form)
    (define-form-constraint scroller
			    left-attachment widget left-widget mini-frame
			    top-attachment widget top-widget factor-scale
			    right-attachment form
			    bottom-attachment form)
    
    ;; add some menu commands
    (add-menu-command (main-menu main-shell)
		      "Edit" "Clear All" (make-callback #'make-clear-all-command doc))
    (add-menu-command (main-menu main-shell)
		      "Edit" "Set All"
		      (make-callback #'make-clear-all-command doc color black))
    (add-menu-command (main-menu main-shell)
		      "Bitmap" "Set Size ..."
		      (make-callback #'display-parms-box doc))
    (add-menu-command (main-menu main-shell)
		      "Bitmap" "Adapt Shell Size"
		      (make-callback #'adapt-shell-size doc))
    ))

(defmethod pixel-on ((doc bitmap-document) x y)
  "look up pixel value in data structure"
  (when (member (list x y) (bitmap doc) test #'equal)
    t))

(defmethod set-pixel ((doc bitmap-document) x y &key (redisplay t)
		      &allow-other-keys
		      &aux coordinates)
  "set a single pixel in the data structure and display in the view"
  (with-slots (main-view mini-view bitmap) doc
    (setq coordinates (list x y))
    (setq bitmap (remove coordinates bitmap test #'equal))
    (push coordinates bitmap)

    (when redisplay
      (set-pixel main-view x y)
      (set-pixel mini-view x y))))

(defmethod clear-pixel ((doc bitmap-document) x y &key (redisplay t)
			&allow-other-keys
			&aux coordinates)
  "clear a single pixel in the data structure and display in the view"
  (with-slots (main-view mini-view bitmap) doc
    (setq coordinates (list x y))
    (setq bitmap (remove coordinates bitmap test #'equal))
    (when redisplay
      (clear-pixel main-view x y)
      (clear-pixel mini-view x y))))
	 
(defmethod toggle-pixel ((doc bitmap-document) x y &key (redisplay t)
			 &aux coordinates)
  "toggle a single pixel in the data structure and display in the view"
  (setq coordinates (list x y))
  (if (member coordinates (bitmap doc) test #'equal)
      (clear-pixel doc x y redisplay redisplay)
      (set-pixel doc x y redisplay redisplay)))

(defmethod write-to-stream ((doc bitmap-document) stream)
  "write the document to the specified stream"
  (format stream "~d ~d ~d~%"
	  (no-rows doc) (no-columns doc) (factor (main-view doc)))
  (format stream "(")
  (loop for pair in (bitmap doc)
	when (and (<= (first  pair) (no-columns doc))
		  (<= (second pair) (no-rows doc)))
	  do (prin1 pair stream))
  (format stream ")~%"))

(defmethod read-from-stream ((doc bitmap-document) stream) 
  "read the document from the specified stream"
  (with-slots (no-rows no-columns main-view mini-view
		       factor-scale rows-scale columns-scale bitmap) doc
    (setq no-rows (read stream))
    (setq no-columns (read stream))
    (setf (factor main-view) (read stream))
    (setq bitmap (read stream))
    
    (when rows-scale
      (setf (value rows-scale) no-rows))
    (when columns-scale
      (setf (value columns-scale) no-columns))
    (setf (value factor-scale) (factor main-view))
    (resize main-view
	    (* (factor main-view) no-columns)
	    (* (factor main-view) no-rows))
    (resize (mini-view doc) no-columns no-rows)
    ))

(defmethod change-params ((doc bitmap-document)
			  &key (no-rows (no-rows doc))
			       (no-columns (no-columns doc))
			       (factor (factor (main-view doc))))
  "adapt to new layout params"
  (setf (no-rows doc) no-rows)
  (setf (no-columns doc) no-columns)
  (when (not (= factor (factor (main-view doc))))
    (setf (factor (main-view doc)) factor)
    ;; even the parts of the view that remain visible have to be redrawn
    (force-redraw (main-view doc))
    (force-redraw (mini-view doc)))

  ;; resize => expose-events for new areas
  (resize (main-view doc) (* factor no-columns) (* factor no-rows))
  (resize (mini-view doc) no-columns no-rows)
    (resize (main-shell doc) (+ (width (main-shell doc)) 1)
                             (height (main-shell doc)))
    (resize (main-shell doc) (- (width (main-shell doc)) 1)
                             (height (main-shell doc)))
  (setf (modified doc) t))

(defmethod display-parms-box ((doc bitmap-document))
  "bring up modeless dialog to set parms"
  (when (not (params-box doc))
    (setf (params-box doc)
	  (make-modeless-dialog-box "Bitmap Size" document doc
				    resize t
				    motif-resources '(width 250)))
    (setf (rows-scale doc)
	  (make-scale (params-box doc)
		      orientation horizontal 
		      title-string "Rows"
		      value (no-rows doc)
		      minimum 1
		      maximum 200
		      value-changed-callback
		      (make-callback #'change-params doc no-rows)))
    (setf (columns-scale doc)
	  (make-scale (params-box doc)
		      orientation horizontal 
		      title-string "Columns"
		      value (no-columns doc)
		      minimum 1
		      maximum 200
		      value-changed-callback
		      (make-callback #'change-params doc no-columns)))
    (define-form-constraint (rows-scale doc)
			    top-attachment form
			    left-attachment form
			    right-attachment form)
    (define-form-constraint (columns-scale doc)
			    top-attachment widget top-widget (rows-scale doc)
			    left-attachment form
			    right-attachment form))
  (pop-up (params-box doc)))

(defmethod adapt-shell-size ((doc bitmap-document))
  "resize shell so that complete bitmap is shown"
  (with-slots (no-columns no-rows main-shell main-view) doc
    (resize main-shell
	    (max 270 (+ 20 no-columns (* no-columns (factor main-view))))
	    (+ 100 (* no-rows (factor main-view))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; class bitmap-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

'(defclass bitmap-view (view)
  ((factor  accessor factor  initarg factor
	    documentation "size of a single pixel on the screen")
   (gap     accessor gap     initarg gap
	    documentation "white space between pixels")))

(defun make-bitmap-view (parent doc &key (factor 1) (rows 10) (columns 10) (gap 0))
  (make-view parent
	     width  (* factor columns)
	     height (* factor rows)
	     document doc
	     backing-store t
	     class 'bitmap-view
	     initargs (list factor factor gap gap)))

(defmethod button-press ((view bitmap-view) code repetition x y)
  "react to button-press event in the window"
  (declare (ignore repetition))
  (case code ;; which button      
    (select (make-set-pixel-command    (document view) view x y))
    (extend (make-clear-pixel-command  (document view) view x y))
    (menu (make-toggle-pixel-command (document view) view x y)))
  )

(defmethod set-pixel ((view bitmap-view) x y &key &allow-other-keys)
  "set a single pixel"
  (with-slots (factor gap) view
    (draw-rectangle view (* (1- x) factor) (* (1- y) factor)
		    (- factor gap) (- factor gap) t)))

(defmethod clear-pixel ((view bitmap-view) x y &key &allow-other-keys)
  "clear a single pixel"
  (with-slots (factor) view 
    (clear-area view (* (1- x) factor) (* (1- y) factor)
		factor factor)))

(defmethod draw ((view bitmap-view) count x y width height)
  "draw bits into view"
  (declare (ignore x y width height))
  (when (zerop count)
    (loop for (x y) in (bitmap (document view))
	  do (set-pixel view x y))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; mouse-commands
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; class set-pixel-command ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass set-pixel-command (mouse-down-command)
  (;; overrides
   (name       initform "Set Pixel" allocation class)
   (call-doit  initform nil)
   ;; new slots
   (last-coordinates accessor last-coordinates initform nil)
   (coordinate-list  accessor coordinate-list  initform nil)))

(defun make-set-pixel-command (document view x y)
  "create command object storing all touched x/y coordinates"
  (make-mouse-down-command document view x y
			   class 'set-pixel-command
			   cursor hand))

(defmethod draw-feedback ((cmd set-pixel-command) x y &key clear)
  "no feedback"
  (declare (ignore x y clear)))

(defmethod track-mouse ((cmd set-pixel-command) x y
			&key (started nil) (finished nil)
			&aux pixel-x pixel-y coordinates)
  "process each touched pixel"
  (declare (ignore started finished))
  (with-slots (last-coordinates coordinate-list document call-doit view) cmd
    (setq pixel-x (ceiling (/ x (factor view))))
    (setq pixel-y (ceiling (/ y (factor view))))
    (setq coordinates (list pixel-x pixel-y))
    (when (and (not (equal coordinates last-coordinates))
	       (not (pixel-on document pixel-x pixel-y)))
      (setq call-doit t)
      (setq last-coordinates coordinates)
      (push coordinates coordinate-list)
      (set-pixel document pixel-x pixel-y))
    ))

(defmethod undoit ((cmd set-pixel-command))
  "clear all pixels again"
  (with-slots (coordinate-list document) cmd
    (loop for coordinates in coordinate-list
	  do (clear-pixel document (first coordinates) (second coordinates)))
    ))

(defmethod redoit ((cmd set-pixel-command))
  "set all pixels again"
  (with-slots (coordinate-list document) cmd
    (loop for coordinates in coordinate-list
	  do (set-pixel document (first coordinates) (second coordinates)))
    ))

;; class clear-pixel-command ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clear-pixel-command (mouse-down-command)
  (;; overrides
   (name       initform "Clear Pixel" allocation class)
   (call-doit  initform nil)
   ;; new slots
   (last-coordinates accessor last-coordinates initform nil)
   (coordinate-list  accessor coordinate-list  initform nil)))

(defun make-clear-pixel-command (document view x y)
  "create command object storing all touched x/y coordinates"
  (make-mouse-down-command document view x y
			   class 'clear-pixel-command
			   cursor hand))

(defmethod draw-feedback ((cmd clear-pixel-command) x y &key clear)
  "no feedback"
  (declare (ignore x y clear)))

(defmethod track-mouse ((cmd clear-pixel-command) x y
			&key (started nil) (finished nil)
			&aux pixel-x pixel-y coordinates)
  "process each touched pixel"
  (declare (ignore started finished))
  (with-slots (last-coordinates coordinate-list document call-doit view) cmd
    (setq pixel-x (ceiling (/ x (factor view))))
    (setq pixel-y (ceiling (/ y (factor view))))
    (setq coordinates (list pixel-x pixel-y))
    (when (and (not (equal coordinates last-coordinates))
	       (pixel-on document pixel-x pixel-y))
      (setq call-doit t)
      (setq last-coordinates coordinates)
      (push coordinates coordinate-list)
      (clear-pixel document pixel-x pixel-y))
    ))

(defmethod undoit ((cmd clear-pixel-command))
  "set all pixels again"
  (with-slots (coordinate-list document) cmd
    (loop for coordinates in coordinate-list
	  do (set-pixel document (first coordinates) (second coordinates)))
    ))

(defmethod redoit ((cmd clear-pixel-command))
  "add new pixel to bitmap"
  "clear all pixels again"
  (with-slots (coordinate-list document) cmd
    (loop for coordinates in coordinate-list
	  do (clear-pixel document (first coordinates) (second coordinates)))
    ))

;; class toggle-pixel-command ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass toggle-pixel-command (mouse-down-command)
  (;; overrides
   (name        initform "Toggle Pixel" allocation class)
   ;; new slots
   (last-coordinates accessor last-coordinates initform nil)
   (coordinate-list  accessor coordinate-list  initform nil)))

(defun make-toggle-pixel-command (document view x y)
  "create command object storing the x/y coordinates of the mouse-click"
  (make-mouse-down-command document view x y
			   class 'toggle-pixel-command
			   cursor hand))

(defmethod draw-feedback ((cmd toggle-pixel-command) x y &key clear)
  "no feedback"
  (declare (ignore x y clear)))

(defmethod track-mouse ((cmd toggle-pixel-command) x y
			&key (started nil) (finished nil)
			&aux pixel-x pixel-y coordinates)
  "process each touched pixel"
  (declare (ignore started finished))
  (with-slots (last-coordinates coordinate-list document call-doit view) cmd
    (setq pixel-x (ceiling (/ x (factor view))))
    (setq pixel-y (ceiling (/ y (factor view))))
    (setq coordinates (list pixel-x pixel-y))
    (when (not (equal coordinates last-coordinates))
      (setq last-coordinates coordinates)
      (push coordinates coordinate-list)
      (toggle-pixel document pixel-x pixel-y))
    ))

(defmethod undoit ((cmd toggle-pixel-command))
  "toggle all pixels again"
  (with-slots (coordinate-list document) cmd
    (loop for coordinates in coordinate-list
	  do (toggle-pixel document (first coordinates) (second coordinates)))
    ))

(defmethod redoit ((cmd toggle-pixel-command))
  "toggle all pixels again"
  (undoit cmd))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class clear-all-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass clear-all-command (command)
  (;; instance-parameters
   (name initarg name) ;; turn class slot into an instance slot
   (color  accessor color  initarg color)
   (bitmap accessor bitmap initarg bitmap))
  (documentation "a command to delete all pixels"))

(defun make-clear-all-command (document &key (color white))
  "create a new command object with appropriate parameters"
  (make-command document
		class 'clear-all-command
		initargs `(bitmap ,(bitmap document)
			    color ,color
			    name ,(if (eq color white) "Clear All" "Set All"))))

(defmethod doit ((cmd clear-all-command))
  "construct coordinate list and redraw"
  (with-slots (bitmap main-view mini-view no-rows no-columns) (document cmd) 
    (setq bitmap
	  (if (eq (color cmd) white)
	      nil
	      ;; else set all to black
	      (loop for x from 0 to no-columns
		    append
		      (loop for y from 0 to no-rows
			    collect (list x y)))))
    (force-redraw main-view)
    (force-redraw mini-view)))

(defmethod undoit ((cmd clear-all-command))
  "reinstall old coordinate list and redraw"
  (with-slots (bitmap main-view mini-view) (document cmd)
    (setq bitmap (bitmap cmd))
    (force-redraw main-view)
    (force-redraw mini-view)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "bitedit" 'bitmap-editor "bitmap")
'(make-bitmap-editor) 
9. Lisp-Widgets
9.1 Functionality
This demo shows how new types of widgets can be implemented in Lisp. This is much easier than implementing new widgets in the C language. The only drawback is that the performance is worse. In our example we show how a new type of scrollbar is implemented. The slider jumps to the place where the mouse is clicked and can be dragged. While dragging, the current value is shown in the slider. When the shell is resized, the scrollbar is also resized.
	
9.2 Implementation
The class selfmade-scrollbar is a subclass of the GINA class view. It consists of a view with a frame around it. Therefore, the slot group-widget-id of the superclass widget is set to the frame object, so that move and resize operations as well as form constraints apply to the frame, which is the parent of the view. The draw method has to be prepared to display the scrollbar in any size. If the user resizes the scrollbar, draw is called by GINA and the slots width and height hold the current size of the view. When the application program modifies the current-value of the scrollbar the view is also redrawn. This is done by an after demon for (setf current-value).
If the mouse button is pressed in the scrollbar, an object of class scroll-command is instantiated which controls the interaction. In track-mouse the current-value is computed from the mouse position and the scrollbar is redrawn. In addition the value-changed-callback is executed. The method execute can handle callback objects, lambda-expressions and compiled functions. For undo and redo the current-value before a scroll operation is stored in the command object.
9.4 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp;Packagelisp-widgets;Base10-*-

(in-package GINA)
(defginapackage lisp-widgets)
(in-package lisp-widgets)
(setq *sccs-id* "@(#)lisp-widgets.lisp	1.4  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class lisp-widget-demo
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass lisp-widget-demo (application)
  (;; overrides
   (name          initform "Lisp Widgets"          allocation class)
   (document-type initform 'lisp-widget-document   allocation class)
   (signature     initform "lisp-widgets"          allocation class)
   (file-type     initform nil                     allocation class))
  (documentation "demo how new widgets can be implemented in Lisp"))

(defun make-lisp-widget-demo ()
  "start the lisp-widget-demo"
  (make-application class 'lisp-widget-demo))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class lisp-widget-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass lisp-widget-document (document)
  ()
  (documentation "application dependent document type"))

(defmethod create-windows ((doc lisp-widget-document) &aux form scrollbar)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    ;; create and install the view in a tool-window
    (setq main-shell (make-document-shell doc))
    (setq form (make-form main-shell motif-resources '(height 200)))
    (setq scrollbar (make-selfmade-scrollbar form
					     document doc
					     value-changed-callback
					     '(lambda (new-val) nil)))
    (define-form-constraint scrollbar
			    top-attachment  form 
			    left-attachment form
			    bottom-attachment form)
    (setq main-view scrollbar)

    ;; remove unnecessary menu entries
    (remove-menu-entry (main-menu main-shell) "File" "Open..")
    (remove-menu-entry (main-menu main-shell) "File" "Save")
    (remove-menu-entry (main-menu main-shell) "File" "Save as..")
    (remove-menu-entry (main-menu main-shell) "File" "Revert")
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class selfmade-scrollbar
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass selfmade-scrollbar (view)
  (;; instance-parameters
   (max-value     accessor max-value     initarg max-value
	          documentation "current value is between 0 and max-value")
   (value-changed-callback
     accessor value-changed-callback
     initarg value-changed-callback
     documentation "Function called with new value when user has scrolled")
   
   ;; instance-variables
   (current-value accessor current-value initform 0)))

(defun make-selfmade-scrollbar (parent &key (width 20)
				            (height 200)
					    (max-value 100)
					    (value-changed-callback nil)
					    (document nil)
				       &aux frame new-sb)
  "make a new selfmade-scrollbar widget"
  (setq frame (make-frame parent))
  (setq new-sb
	(make-view frame width width height height
		   document document
		   resize-policy any
		   initargs (list max-value max-value
				   value-changed-callback value-changed-callback)
		   class 'selfmade-scrollbar))
  (setf (group-widget-id new-sb) (widget-id frame))
  new-sb)

(defmethod (setf current-value) after (new-value (sb selfmade-scrollbar))
  "when the text is changed a redisplay is necessary"
  (declare (ignore new-value))
  (force-redraw sb))

(defmethod resized after ((view selfmade-scrollbar) ignore)
   "the whole scrollbar must be redrawn when resized"
   (declare (ignore ignore))
   (force-redraw view))

(defmethod draw ((view selfmade-scrollbar) count x y width height &aux current-y)
  "draw window contents"
  (declare (ignore x y width height))
  (with-slots (gcontext width height current-value max-value) view
    (when (zerop count) ;; Ignore all but the last exposure event
      (setq current-y (round (* (- height 10) (/ (float current-value) max-value))))
      (draw-rectangle view 0 current-y width 10 t)   ;; filled
      (xlibwith-gcontext (gcontext function boole-xor font "6x10")
	(draw-glyphs view 2 (+ 8 current-y) (format nil "~d" current-value)))

      )))

(defmethod button-press ((sb selfmade-scrollbar) code repetition x y)
  "react to button-press event in the window"
  (declare (ignore code repetition))
  (make-scroll-command sb x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class scroll-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass scroll-command (mouse-down-command)
  (;; overrides
   (name          initform "Scrolling" allocation class)
   (undoable      initform t           allocation class)
   (causes-change initform nil         allocation class)

   ;; instance-parameters
   (old-value accessor old-value initarg old-value)
   ;; instance-variables
   (new-value accessor new-value))
  (documentation "a mouse-down-command for scrolling"))

(defun make-scroll-command (sb mouse-x mouse-y &key (class 'scroll-command))
  (make-mouse-down-command (document sb) sb mouse-x mouse-y
			   class class
			   initargs `(old-value ,(current-value sb))))

(defmethod draw-feedback ((cmd scroll-command) x y &key clear)
  "no feedback"
  (declare (ignore clear x y)))

(defmethod doit ((cmd scroll-command))
  "nothing to do"
  )

(defmethod track-mouse ((cmd scroll-command) x y &key (started nil) (finished nil))
  "move the slider"
  (declare (ignore x started))
  (with-slots ((scrollbar view) new-value) cmd
    (with-slots (current-value max-value height value-changed-callback) scrollbar
      (setq current-value (round (* max-value (/ y (float height)))))
      (force-redraw scrollbar)
      (execute value-changed-callback (list current-value))
      (when finished
	(setq new-value current-value)))))

(defmethod undoit ((cmd scroll-command))
  "move the elevator and call callback"
  (with-slots ((scrollbar view) old-value) cmd
    (with-slots (current-value value-changed-callback) scrollbar
      (setq current-value old-value)
      (force-redraw scrollbar)
      (execute value-changed-callback (list current-value)))))

(defmethod redoit ((cmd scroll-command))
  "move the elevator and call callback"
  (with-slots ((scrollbar view) new-value) cmd
    (with-slots (current-value value-changed-callback) scrollbar
      (setq current-value new-value)
      (force-redraw scrollbar)
      (execute value-changed-callback (list current-value)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "lisp-widgets" 'lisp-widget-demo nil)
'(make-lisp-widget-demo)
10. Tetris

10.1 Functionality
This is a simple version of the well known arcade game. You press the New Game button to start. Rectangles of different size and color begin to fall down. Their speed depends on the level selected using the radio button group on the left. You can move the rectangles to the left and right using the "j" and "l" keys. Pessing "k" rotates the rectangle. Your task is to place the rectangles in such a way that no gaps remain. Each completed line immediately disappears. The space bar can be used to drop a rectangle to the ground. Please notice that you have to move the mouse cursor into the view where the rectangles are shown, because otherwise your key presses go unnoticed. You can interrupt a game at any time using the Pause button or by pressing "p".
10.2 Implementation
The basic idea is that each Tertris piece is a view-object. When a game is started, the slot idle-timeout of the application is set depending on the game level, so that the method idle-timeout is called several times per second. At each timeout, the falling piece is moved and some checks are performed, whether the ground is reached and so on. The method key-press of the Tetris view is called only when the mouse is inside the view.

11. Pacmen 
11.1 Functionality
This demo is much less than a real Pacman game. It only demonstrates the use of multiple processes within a single application. You can create a pacman by the menu entry NEW PACMAN. It will run down the window line by line at a random speed and disappear when the bottom is reached. On SUNs, the death of a pacmen is indicated by a "drip" sound. Because each pacman runs in his own process the user interface remains fully operable. The pacmen continue to run even during modal dialogs.
You can start multiple pacmen (as many as your Lisp can stand). Try to kill a pacman by clicking the mouse at him. A pacman overtaking a slower one will eat it up. A pacman can also be started with a progress bar indicating how many lines are already done. The progress bar can also be used to kill the pacman. You can explicitly kill all pacmen. This is implicitly done by GINA when a document is closed.

11.2 Implementation
•	Pacmen are view objects together with a background process. This differs from the Tetris demo where a timer is used instead.
•	Each pacmen loops through its possible positions in the window. In each repetition the view-object is moved, other men are eaten, the progress bar is updated if necessary and a sleep is done.
•	Access to the data structures of the document which are shared by all pacmen is synchronized using the macro WITH-DOCUMENT.
11.3 Source Code
;;; -*- ModeLISP;Syntax Common-Lisp;Packagepac;Base10-*-

(in-package GINA)
(defginapackage pac)
(in-package pac)
(setq *sccs-id* "@(#)pacmen.lisp	1.4  1/20/92")

;; This demo is much less than a real Pacman game. It only demonstrates
;; the use of multiple processes within a single application.
;; 
;; - You can create a pacman by the menu entry NEW PACMAN. It will run
;;   down the window line by line at a random speed and disappear when
;;   the bottom is reached.
;; - On SUNs, the death of a pacmen is indicated by a "drip" sound.
;; - Because each pacman runs in his own process the user interface remains
;;   fully operable. The pacmen continue to run even during modal dialogs.
;; - You can start multiple pacmen (as many as your Lisp can stand).
;; - Try to kill a pacman by clicking the mouse at him.
;; - A pacman overtaking a slower one will eat it up.
;; - A pacman can also be started with a progress bar indicating how
;;   many lines are already done. The progress bar can also be used to kill
;;   the pacman.
;; - You can explicitly kill all pacmen. This is implicitly done by GINA
;;   when a document is closed.
;; 
;; Implementation
;; - Pacmen are view objects together with a background process.
;;   This differs from the Tetris demo where a timer is used instead.
;; - Each pacmen loops through ist possible positions in the window. 
;;   In each repetition the view-object is moved, other men are eaten,
;;   the progress bar is updated if necessary and a sleep is done.
;; - Access to the data structures of the document which are shared by all
;;   pacmen is synchronized using the macro WITH-DOCUMENT.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class pacmen-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass pacmen-application (application)
  ((name          initform "Pacmen")
   (signature     initform "Pac")
   (file-type     initform "pac")
   (document-type initform 'pacmen-document allocation class)))

(defun make-pacmen-application ()
  (make-application class 'pacmen-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class pacmen-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass pacmen-document (document)
  ((nr-of-pacmen accessor nr-of-pacmen initform 0)
   (shell-width  initform 550)
   (shell-height initform 550)))

(defmethod create-windows((doc pacmen-document) &aux scroller)
  (with-slots (main-shell main-view) doc
    (setq main-shell (make-document-shell doc))
    (setq scroller   (make-scroller main-shell))
    (setq main-view  (make-view scroller
				document doc 
				width 500 height 500))

    (add-menu-command (main-menu main-shell)
		      "Play" "New Pacman" 
		      (make-callback 'create-pacman doc)
                      accelerator "P")
    (add-menu-command (main-menu main-shell)
		      "Play" "New Pacman with Progress Bar" 
		      (make-callback 'create-pacman doc progress-bar t))
    (add-menu-command (main-menu main-shell)
                      "Play" "Kill All Pacmen"
                      (make-callback 'kill-all-background-processes doc))
  ))

(defmethod create-pacman ((doc pacmen-document) &key (progress-bar nil))
  (when (not progress-bar)
    (in-background-process (doc)
      (run-pacman doc)))

  (when progress-bar
    (with-progress-bar
        (doc kill-on-abort t centered nil modal nil
         title (format nil "Pacman ~d" (1+ (nr-of-pacmen doc)))
	 message "Running ...             ")
      (run-pacman doc indicate-progess t))))

(defmethod run-pacman ((doc pacmen-document) 
		       &key (indicate-progess nil)
		       &aux pacman percent)
  "code executed by each background process"
   (setq pacman (make-pacman 40 (mod (incf (nr-of-pacmen doc)) 100)))
   (with-document (doc)
      (install pacman (main-view doc) 30 30))
   (unwind-protect
       (loop for y from 1 to 10 do
	 (loop for x from 1 to 20 do
	   (when indicate-progess
	     ;; update progress bar
             (setq percent (+ (* 10 (1- y)) (round (1- x) 2)))
	     (if (= x 1)
		 (indicate-progress percent 
		  new-message (format nil "Running in line ~d ..." y))
	         (indicate-progress percent)))

	   (setf (mouth-open pacman) (not (mouth-open pacman)))
	   (setf (right pacman) (oddp y))
	   (move pacman (if (right pacman) (* 20 x) (- 400 (* 20 x))) (* 40 y))
	   (xlibdisplay-force-output *display*)

	   ;; eat other men if at same position
	   (loop for p in (view-objects (main-view doc))
	    when (and (not (eq p pacman))
		      (= (x-pos pacman) (x-pos p))
		      (= (y-pos pacman) (y-pos p)))
	    do (kill-pacman p))
	   
	   (sleep (speed pacman))
	   ))
     ;; cleanup
     (with-document (doc)
	(deinstall pacman)
        (xlibdisplay-force-output *display*))
     #-genera
     (shell-command 
      "/usr/demo/SOUND/play -v100 /usr/demo/SOUND/sounds/drip.au &")))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class pacman
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass pacman (view-object)
 ((mouth-open accessor mouth-open initform t)
  (number     accessor number     initarg number)
  (right      accessor right      initform t)
  (speed      accessor speed      initform (+ 0.1 (* (random 3) 0.1)))
  (process    accessor process    initarg process)))

(defun make-pacman (size number)
  (make-view-object size size class 'pacman 
		    initargs (list process (xtkcurrent-process)
				    number (format nil "~d" number))))

(defmethod kill-pacman ((p pacman))
  "kill pacmen, but wait until he is out of critical sections"
  (kill-background-process (document (parent-view p)) (process p)))

(defmethod draw ((p pacman) count x y width height)
  (declare (ignore x y height))
  (when (zerop count)
    (if (not (mouth-open p))
	(draw-arc p 0 0 width width 0 (* 2 pi) t)
      (if (right p)
	  (draw-arc p 0 0 width width 0.4 (- (* 2 pi) 0.8) t)
	  (draw-arc p 0 0 width width (- 0.4 pi) (- (* 2 pi) 0.8) t)))
    (xlibwith-gcontext ((gcontext (parent-view p)) function boole-xor)
      (draw-glyphs p 10 25 (number p)))))

(defmethod button-press ((p pacman) code repetition x y)
  "react to button-press event in the window"
  (declare (ignore code repetition x y))
  (kill-pacman p))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main-program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "pac" 'pacmen-application "pac")
'(make-pacmen-application)
12. Spreadsheet 
12.1 Functionality
This demo shows how a typical Spreadsheet can be implemented with GINA. Arbitrary Lisp expressions containing cell references can be used as formulas. New functions can be programmed by example.

12.2 User Interface
•	Strings can be entered into cells via the input field at top
(ENTER-button or RETURN-Key).
•	Input editing can be cancelled using the CANCEL-button.
•	Columns can be resized by dragging the vertical lines with the mouse.
•	If the user subsequently resizes two columns to the same width, the program suggests to resize all columns. The question need not be answered.
•	The global font of a sheet can be changed.
•	Grid lines can be shown or hidden.
•	Cells can be selected using the mouse.
•	A cell name can be inserted into the input edited by any special click.
This is important for formula specification.
•	Borders can be drawn around selected cells.
•	All selected cells can be cleared.
•	The selected cells can be copied to the clipboard.
•	The clipboard can be pasted into selected cells.
•	Pasting is repeated if target area is at least twice as large as clipboard.
•	Unlimited undo/redo is possible for all editing operations.
12.3 Computation
•	The Lisp evaluator is used for formula evaluation.
•	Cell contents entered are regarded as numbers, lists or strings.
•	Formulas start with an equal sign (=).
•	A formula is any Lisp expresssion containing cell references like A1.
•	Examples =(* A1 (+ A2 A3)) or =(list A1 A2 A3 A4)
•	Syntax errors in formulas lead to a beep.
•	SHOW ERROR MESSAGE displays the last error diagnostic.
•	On errors during formula evaluation <error> is displayed in the cell.
•	Normally the values of formulas are shown.
•	With SHOW FORMULAS, formulas can be displayed in the sheet instead.
•	Formulas are evaluated after every modification of a cell.
•	Formulas can be replicated by COPY/PASTE.
•	While pasting, cell references in formulas are automatically transformed.
•	References into the copied selection are regarded as relative.
•	All other references are regarded as absolute.
•	New functions can be defined "by example"
Entering (define foo (A1 A2 A3) A4) into any cell defines a new function foo with three parameters. The formulas connecting A1,A2 and A3 to A4 are used as the body of the function (which is printed on standard-output).
12.4 Implementation
•	There is a complex draw method for the main-view with many parameters which draw the gridlines and the cell contents in diffrent fonts, with and without borders etc.
•	Column and row headers are also views in a scroller but without scrollbars. The views are scrolled synchronously with the main view.
•	Feedback during selection of cells is not implemented by overriding the method draw-feedback. Instead track-mouse is overridden. The internal data structure is immediatly entered and a part of the main-view is redrawn. This is because the selection is permanently displayed and is not only a temporary feedback.
•	The Lisp reader is used to parse constants and formulas entered into cells. In formulas, cell references (like e.g. A1) are internally replaced by an accessor expression for that cell.
•	The Lisp evaluator is used to compute the result of formulas
•	Cell references replaced by accessor expressions.
12.5 Limitations and Extensions
•	Currently a formula also recomputes all formulas it depends on. This leads to  superfluos recalculations in some cases.

13. Hyper-GINA
13.1 Functionality
This demo combines concepts from the GINA Interface Builder and from Hypercard. Simple Interfaces can be build and immediately be run. Widgets can be placed into a drawing area. Lisp code is directly attached to the callbacks of widgets and interpreted. Several Hyper-GINA documents are included in the distribution.

13.2 Facilities of Hyper-GINA
•	A mode can be selected on the left similar as in the graphic editor.
•	In most modes, "elements" can be drawn into the main view.
•	Elements are widgets like in the Interface Builder.
•	Elements can be moved around and resized.
•	Elements can be operated, but initially have no callbacks.
•	Lisp code can be entered into code elements.
•	Pressing the little black button in the upper right corner of the code element executes the code.
•	The border of each element contains the name of the element and one or more outlets (at least "value").
•	Name and outlets can be dragged onto other elements using the mouse. The semantics of such a dragging operation depends on the class of elements involved. This is implemented by multimethods. As feedback, the operation which will take place if the mouse button is released is displayed in the message area.
•	Dragging the name of a code into an element will set the callback of the element.
•	Callbacks have no parameters.
•	Within code, other elements can be referenced by their name. Internally element names are replaced by (value <denoted-element>) before the code is executed. An exception is the view-element its name is replaced by (widget <view-element>). Most elements have an accessor VALUE. The type of the VALUE depends on the element-type. For example, (setf number3 "25") will convert the string before storing it in the number-element. If the default-translation of an element-name is not appropriate you can explicitly specify (widget <element>) to access the motif-widget contained in the element (to set its colour for example). For list-elements you can write (items list5) to read and write the item-list. See method parse for details of the translation process.
•	Dragging the name of an element into a code inserts the element name.
•	By dragging the name of a code into a button, the activate-callback is set.
•	For string, text, number, scale and list, the value-changed-callback is set by dragging the name of a code into it.
•	Dragging a button name into a list means that the callback of the button is executed when a list item is double-clicked.
•	Using the value-changed-callback of a number-element the typical spreadsheet effect can be obtained editing a value immediately may update a derived value.
•	For views, setting the callback means defining its draw method. The name of the view can be used as the first parameter of methods like draw-rectangle or force-redraw.
•	The callback of a clock element is executed every second.
•	Dragging the value outlet to another element means assigning the value (including necessary conversions).
•	Dragging the items outlet of a list copies the item list.
•	Dragging something onto the items outlet sets the item list.
•	Setting the value of a button means setting its label-string.
•	Code elements are executed when a stack is openend if the init flag at the upper right corner is set.
•	You can have several cards see new card, next card, previous card. Within code you can write (goto 2) to select the second card.
•	Try the adjust commands to find out their meaning!! 
•	In user mode, elements cannot be moved or selected.
•	The function PLAY (e.g (PLAY "gong" volume 30)) plays sounds in /usr/demo/SOUND/sounds/* on SUN workstations.
*all-sounds* is a list of all available sounds.
•	*all-colors* is a list of colors for Motif widgets.
13.3 Implementation
•	Elements are implemented as direct-manipulation-objects with a  widget on top of it. There are after daemons which move and resize the widgets when a DMO is moved/resized. 
•	Typical mouse-down-commands are used to connect widgets, etc. As a feedback the label string of the message label is updated while dragging.
•	Widgets have a callback which executes the code-element stored in an element.
•	Explicit accessor functions for the value slot perform the necessary type conversions.

13.3 Limitations and Extensions
•	Drag-and-drop commands should be used in many cases so that the feedback is not covered by the Motif widgets.
•	Undo is not completely implemented and runs into problems if cards are changed.
•	The only way to find out afterwards which code has been assigned to an element is to perform an "inspect click" on an direct-manipulation-object and inspect the slot code.
•	A code-element should allow several expressions without a progn.
14. Lisp Listener 

 14.1 Functionality
•	You can type Lisp expressions into a text widget.
•	Input is entered by pressing the ENTER (not RETURN) key
(or whatever is necessary to cause an ACTIVATE callback).
•	The line containing the insertion-cursor is sent off.
If there is a text selection, it is sent off instead. 
•	Note that prompts are also regarded as input!
Normally however, the cursor is at the beginning of a line after each output. Functions like y-or-n-p might cause problems.
•	The class text-widget-stream is designed to be reusable
i.e. you can attach a stream to any text widget.
14.2 Implementation
•	The demo shows how a stream subclass can be defined which is connected to a text widget.
•	This demo only runs under Allegro4.0, where streams are CLOS classes.
•	Output to the stream is appended at the end of the text widget.
•	Reading from the stream blocks until some input is in the buffer.
•	The buffer is filled, when the user initiates an ACTIVATE callback (by pressing the ENTER key).
•	A read-print-eval-loop is started in a lightweight process. This process waits for input most of the time.
14.3 Limitations and Extensions
•	Any prompt is regarded as input!!
(Newline after prompt solves only half of the problem because there are other prompts e.g. from the y-or-n-p function)
•	Output to a stream cannot come from a foreign application, because eventually CLM-Functions are called, which are then sent off over the wrong connection. To allow output from foreign applications, write-char must place output into a buffer which is read by another lightweight process (similar to input).
14.4 Source Code
;;;-*-ModeLISP;Syntax Common-Lisp;Packagelisten ;Base10-*-
;;;
;;; Thanks to Dieter Bolz who gave some important hints concerning streams!

(in-package GINA)
(defginapackage listen)
(in-package listen)
(setq *sccs-id* "@(#)lisp-listener.lisp	1.2  1/15/92")

;; Lisp Listener Demo
;; - you can enter Lisp expressions into a text widget.
;; - input is entered by pressing the ENTER (not RETURN) key
;;   (or whatever is necessary to cause an ACTIVATE callback).
;; - the line containing the insertion-cursor is sent off.
;;   if there is a text selection, it is sent off instead. 
;; - note that prompts are also regarded as input!
;;   normally however, the cursor is at the beginning of a line after
;;   each output. Functions like y-or-n-p might cause problems.
;; - the class text-widget-stream is designed to be reusable
;;   i.e. you can attach a stream to any text widget

;; Implementation
;; - this demo shows how a stream subclass can be defined which
;;   is connected to a text widget
;; - this demo only runs under Allegro4.0, where streams are CLOS classes
;; - output to the stream is appended at the end of the text widget
;; - reading from the stream blocks until some input is in the buffer
;; - the buffer is filled, when the user initiates an ACTIVATE callback
;;   (by pressing the ENTER key)
;; - a read-print-eval-loop is started in a lightweight process
;;   this process waits for input most of the time

;; Restrictions 
;; - a prompt is regarded as input!!
;;   (newline after prompt solves only half of the problem)
;; - output to stream cannot come from a foreign application,
;;   because eventually CLM-Functions are called, which are then
;;   sent off over the wrong connection.
;;   To allow output from foreign applications, write-char must
;;   place output into a buffer which is read by another lightweight
;;   process (similar to input)

;; open questions
;; - how to tell text widget to start a new line if more than 80 columns
;;   resource resize-width does not work
;;   something like *print-width* ??
;; - delete part of the text in the text widget without rolling in 
;;   the complete text ??
;; - search for newline without rolling in the complete text??

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class lisp-listener
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass lisp-listener (application)
  (;; overrides
   (name          initform "Lisp Listener"    allocation class)
   (document-type initform 'listener-document allocation class)
   (signature     initform "listener"         allocation class)
   (file-type     initform "listener"         allocation class))
  (documentation "a simple lisp listener demo application"))

(defun make-lisp-listener ()
  (make-application class 'lisp-listener))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class listener-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass listener-document (document)
  ((stream accessor stream)))

(defmethod create-windows ((doc listener-document))
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    ;; create document-shell containing a scroller and the text
    (setq main-shell (make-document-shell doc))
    ;; create the text-view
    (setq main-view (make-scrolled-text main-shell columns 80 rows 25))

    ;; create a stream connected to the text-widget
    (setf (stream doc) (make-text-widget-stream main-view))

    ;; start a read-eval-print-loop
    (in-background-process (doc terminate-on-error nil)
       (setq tpl*prompt* "~%Lisp>~%")
       (tplstart-interactive-top-level 
	(stream doc) #'tpltop-level-read-eval-print-loop nil))

    ;; document is always modified by Lisp Listener prompt
    (setf (modified doc) t)
   ))

(defmethod write-to-stream ((doc listener-document) stream)
  "write the document to the specified stream"
  ;; write the current value of the text widget
  (format stream "~s~%" (value (main-view doc))))

(defmethod read-from-stream ((doc listener-document) stream)
  "read the document from the specified stream"
  (setf (value (main-view doc)) (read stream)))
   
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class text-widget-stream
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass text-widget-stream (streamfundamental-character-output-stream
			      streamfundamental-character-input-stream)
  ((text-widget accessor text-widget initarg text-widget)
   (input-buffer accessor input-buffer initform "")
   (input-pos    accessor input-pos    initform 0)
   (max-output-length accessor max-output-length initform 1000)
   (output-length accessor output-length initform 0)))

(defun make-text-widget-stream (text-widget 
				&key (class 'text-widget-stream)
				     (initargs nil)
				&aux new)
  (setq new (make-object class initargs text-widget text-widget))
  (setf (activate-callback text-widget) (make-callback 'activated new))
  new)

(defmethod streamstream-write-char ((tws text-widget-stream) character)
  "append character at the end of the text-widget"
  (incf (output-length tws))
  (clear-old-output-when-necessary tws)  
  (xtkappend-text (widget-id (text-widget tws)) 
		   (string character)
		   scroll-window t))

(defmethod streamstream-write-string 
              ((tws text-widget-stream) string &optional (start 0) (end nil)
	       &aux output-string)
  "append string at the end of the text-widget"
  (setq output-string (subseq string start end))
  (incf (output-length tws) (length output-string))
  (clear-old-output-when-necessary tws)
  (xtkappend-text (widget-id (text-widget tws))
		   output-string
		   scroll-window t))

(defmethod clear-old-output-when-necessary ((tws text-widget-stream))
  "cut off prefix of the text, when limit exceeded by 100%"
  (when (and (max-output-length tws)
             (> (output-length tws) (* 2 (max-output-length tws))))
    (setf (value (text-widget tws)) 
      (subseq (value (text-widget tws)) (max-output-length tws)))
    (decf (output-length tws) (max-output-length tws))))

(defmethod activated ((tws text-widget-stream) &rest parms 
		      &aux text-selection cursor-position string 
		      prev-newline next-newline
		      first-half second-half input-line)
  "enter text selection or line containing the cursor"
  (declare (ignore parms))
  ;; if some text is selected, this is the input
  (setq text-selection (xtktext-get-selection (widget-id (text-widget tws))))
  (if (not (equal text-selection ""))
    ;; then something selected
    (setq input-line text-selection)
    ;; else determine line containing the cursor
    (progn
      (setq cursor-position 
	(first (get-motif-resources (text-widget tws) cursor-position)))
      ;; get complete text from CLM 
      (setq string (value (text-widget tws)))
      ;; search for next and previous newline
      (setq first-half (subseq string 0 cursor-position))
      (setq second-half (subseq string cursor-position))
      (setq prev-newline (position #\newline first-half from-end t))
      (when (not prev-newline) (setq prev-newline -1))
      (setq next-newline (position #\newline second-half))
      (when next-newline
	(incf next-newline cursor-position))
      (setq input-line (subseq string (1+ prev-newline) next-newline))))
  ;;(print input-line)
  ;; append input line to stream buffer
  (mpwithout-scheduling ;; modify buffer in an atomic operation
   (setf (input-buffer tws)
     (concatenate 'string (input-buffer tws) input-line (string #\newline)))))

(defmethod streamstream-read-char ((tws text-widget-stream))
  (xtkprocess-wait "input wait" #'listen tws)
  (prog1
      (elt (input-buffer tws) (input-pos tws))
    (incf (input-pos tws))
    (when (> (input-pos tws) 110)
      ;; throw away old input from time to time
      ;; but keep some (?) characters for unread
      (mpwithout-scheduling
       (setf (input-buffer tws) (subseq (input-buffer tws) 100))
       (decf (input-pos tws) 100)))
    ))

(defmethod streamstream-unread-char ((tws text-widget-stream) char)
  (declare (ignore char))
  (decf (input-pos tws))
  nil)

(defmethod streamstream-read-char-no-hang ((tws text-widget-stream))
  (when (streamstream-listen tws)
    (streamstream-read-char tws)))

(defmethod streamstream-peek-char ((tws text-widget-stream))
  (xtkprocess-wait "input wait" #'listen tws)
  (elt (input-buffer tws) (input-pos tws)))

(defmethod streamstream-listen ((tws text-widget-stream))
  (> (length (input-buffer tws)) (input-pos tws)))

(defmethod streamstream-clear-input ((tws text-widget-stream))
  (setf (input-pos tws) (length (input-buffer tws)))
  nil)  

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "listener" 'lisp-listener "listener")
'(make-lisp-listener)
15. Chess Interface

15.1 Functionality
An interface for the game of chess. You can play a game by dragging the white and black pieces. All special moves of chess like castling, capture en passant and promotion are implemented. For castling you only move the king and the rook follows automatically. At promotion a pop-up dialog asks for the new piece. Upon capture en passant the correct pawn is removed. All moves are undoable. A game can be saved into a file and is written in readable chess notation. If you open a saved document the full history will be restored as well. The full game can be replayed and the point within the history from where the game was saved is remembered as well. On any time you can change sides (playing white from top to down or reverse). There is no check for correct moves. It will only be registered who is on the turn and shown with a white or black circle on the upper left corner. 
If GNU chess is available on your site, this GINA interface can be used for playing against the computer. To activate gnuchess press the button "Play Against Computer". The computer always uses the color shown on the upper part of the screen (black if lines 8 and 7 are on top (the default as shown in the figure), white otherwise). It immediately makes a move if it is its turn. Otherwise it indicates "Your Move" within the State text field. At any time the level (thinking time given to GNU from 0.1 seconds up to 10 hours) can be set by the level entry of menu chess. If you undo (or redo) any moves the connection to gnuchess is cut off, but can be reactivated at any desired point by pressing the button "Play Against Computer" again. The current positions of all pieces are then transmitted to GNU. 
15.2 Implementation
A chess piece is an object of the GINA class movable-icon. When creating a movable icon a pathname or the image can be given. To minimize the startup time in this chess application the icon- and mask-images are read from file while loading the chess program into the lisp world and the images are given to movable-icon. For black pieces the fact is used, that selected pieces are shown in reverse. When the user drags a piece it rises and settles down upon releasing it. This is easily implemented with the shadow-offset slot of movable-icon. The main view uses the double buffering feature of GINA for flicker free overlapping of chess pieces while they are dragged around. 
For playing against the computer you have to provide the chesstool (gnuchessr) of GNU, which has a general public license. It uses a line-by-line ascii-interface and is called from lisp. Set the the global variable *gnuchess-pathname* to the pathname of the gnuchess program of your installation within the file chess.lisp.
GINAs automatic hashing of bitmap pathnames to their images, images in any format to images in z-format and images to pixmaps is used in this program to optimize time for displaying bitmaps. Images are bitmap data on lisp side (an array of pixels). There are several formats and the z-format is necessary for accessing the array within point-inside. To display images they can be sent to the X-server and on this side they are called pixmaps. The Lisp program holds pointers to pixmaps. This topic is hidden from the application programmer and hashing is automatically done by GINA when using the class movable-icon.
15.3 Limitations and Extensions
We are experimenting with a general framework for storing command histories. You can test the experimental feedback animation (Debug menu) of GINA, which shows the movement of pieces upon redo. Bitmaps are borrowed from GNU Chess. 
Remember there is no checking of correct moves while gnuchess is deactivated. If you fool gnu you are on your own with its responses. Gnuchess can play against itself by changing sides after every move.
16. Drag and Drop Demo

16.1 Functionality
This demonstration program implements a number of different drag-commands. There are two different applications a drag application where triangles can be dragged into a view, and a drop application that can receive triangles for different purposes. However, the triangles in the drag application can also be copied between drag documents. The drag application consists of a main view where triangles can be installed, a drag-label looking like a magnet to delete triangles, a feedback label, and a triangle template that can be used to create new triangles. The triangle template uses a triangle bitmap that can be dragged into the view. It is an intra-document command, because it cannot create triangles in other documents. It demonstrates tracking, because the current position relative to the target view is displayed in the feedback label. The magnet demonstrates subtargets (highlighting the triangle it is over), but is also bound to the same document. The triangles in the view create a drag-command that may be received in other documents and applications. It uses a copy semantics and the transfer value is used to transfer the number of the triangle. Dragged triangle copies may be received by the drop application. The number of the triangle and the operation (depending on the target) are reported in a label. All the commands in the program are undoable. 
16.2 Implementation
Drag and Drop is a topic within the User Manual. See there for details.
16.3 Source Code
;;; -*- Mode LISP; Syntax Common-Lisp; Package dd;Base 10 -*-
(in-package GINA)
(defginapackage dd)
(in-package dd)
(setq *sccs-id* "@(#)drag-and-drop.lisp	1.3  1/16/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class drag-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drag-application (application)
  (;; overrides
   (name          initform "Drag"         allocation class)
   (document-type initform 'drag-document allocation class)
   (signature     initform "drag"               allocation class)
   (file-type     initform "drag"               allocation class))
  (documentation "a simple drag demo application"))

(defun make-drag-application ()
  "start the drag-application"
  (make-application class 'drag-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class drag-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drag-document (document)
  (;; instance-variables
   (track-label    accessor track-label
         documentation "a label where tracking information is displayed")
   (drag-template  accessor drag-template
         documentation "a drag label as triangle template")
   (drag-protocols initform '(copy_triangle) allocation class))
  (documentation "application dependent document type"))

(defmethod write-to-stream ((doc drag-document) stream)
  "write the document to the specified stream"
  (format stream "~d~%" (length (view-objects (main-view doc))))
  (loop for obj in (view-objects (main-view doc))
        do (format stream "~d ~d ~d~%" (x-pos obj) (y-pos obj) 
		   (id-number obj))))

(defmethod read-from-stream ((doc drag-document) stream &aux objects) 
  "read the document from the specified stream"
  ;; delete all present objects in case of revert
  (loop for obj in (view-objects (main-view doc))
        do (deinstall obj))

  (setq objects (read stream))
  (loop repeat objects
   do (let* ((x-pos (read stream))
	     (y-pos (read stream))
	     (view (main-view doc))
	     (new-tri (make-triangle (obj-width view) (obj-height view) 
				     (read stream))))
	(install new-tri view x-pos y-pos))))

(defmethod create-windows ((doc drag-document) 
			   &aux scroller form label)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    (setq main-shell (make-document-shell doc))
    (setq scroller   (make-scroller main-shell))
    (setq main-view  (make-drag-view scroller doc))
    (setq form (make-form main-shell))
    (set-motif-resources (main-window main-shell) 
			 command-window (widget-id form))

    (setq label (make-drag-label form doc "magnet"
                                 cursor-mask "magnet-mask"))
    (setf (activate-callback label)
          (make-callback 'make-magnet-dragger doc label))
    (define-form-constraint label left-attachment form top-attachment form
                            bottom-attachment form)

    (setf (drag-template doc) 
          (make-drag-label form doc "triangle"))
    (setf (activate-callback (drag-template doc))
          (make-callback 'make-triangle-dragger doc (drag-template doc)))
    (define-form-constraint (drag-template doc) left-attachment none 
			    top-attachment form right-attachment form)

    (setf (track-label doc)
          (make-label form ""))
    (define-form-constraint (track-label doc) left-attachment widget
			    left-widget label top-attachment form
			    bottom-attachment form
			    right-attachment widget
			    right-widget (drag-template doc))
    ))

(defmethod create-drop-command ((doc drag-document) shell x y protocol-id
				transfer-value received-from)
  "create a duplicate command when dropping from another document"
  (case protocol-id
    ((copy_triangle)
        (make-triangle-copier doc shell x y 
                              transfer-value transfer-value
                              received-from received-from))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class drag-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drag-view (view)
  ((bitmap-name   accessor bitmap-name  initform "triangle")
   (image         accessor image)
   (pixmap        accessor pixmap)
   (obj-width     accessor obj-width)
   (obj-height    accessor obj-height))
  (documentation "a view with special draw method and reaction to clicks"))

(defun make-drag-view (parent doc &aux new-view)
  "create a new drag-view"
  (setq new-view (make-view parent document doc class 'drag-view))
  (setf (image new-view)
        (xlibread-bitmap-file (find-bitmap (bitmap-name new-view))))
  (setf (obj-width new-view) (xlibimage-width (image new-view)))
  (setf (obj-height new-view) (xlibimage-height (image new-view)))
  new-view)

(defmethod determine-window-id after ((view drag-view) &aux gc)
  "create a pixmap for triangle drawing"
  (setf (pixmap view)
        (xlibcreate-pixmap width (obj-width view) height (obj-height view) 
                            depth 1 drawable (x-window view)))
  ;; must have a separate GC for the pixmap because of different depth
  (setq gc (xlibcreate-gcontext drawable (pixmap view)))
  (xlibput-image (pixmap view) gc (image view) x 0 y 0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class triangle
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass triangle (view-object)
  ((id-number accessor id-number initarg id-number))
  (documentation "a triangle in a view"))

(defun make-triangle (width height id-number)
  (make-view-object width height class 'triangle 
		    initargs (list id-number id-number)))

(defmethod draw ((obj triangle) count x y width height)
  (declare (ignore count x y width height))
  (xlibcopy-plane (pixmap (parent-view obj)) (gcontext (parent-view obj)) 1
                   0 0 
		   (obj-width (parent-view obj)) (obj-height (parent-view obj))
                   (x-window (parent-view obj)) (x-pos obj) (y-pos obj))
  (draw-glyphs obj (- (round (/ (width obj) 2)) 5) (- (height obj) 6) 
	       (write-to-string (id-number obj))))

(defmethod button-press ((obj triangle) code repetition x y)
  "create a copy-drag command for this triangle"
  (when (= repetition 1)
    (case code
      ((select)
            (make-triangle-copier (document (parent-view obj))
				  (parent-view obj) x y
				  transfer-value (id-number obj)
				  x-off (x-pos obj) y-off (y-pos obj))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class magnet-dragger
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass magnet-dragger (drag-command)
  ((name      initform "Delete Triangle"   allocation class)
   (deleted-object accessor deleted-object)))

(defun make-magnet-dragger (doc source x y)
  (make-drag-command doc source x y (list (list (main-view doc) view))
		     cursor (cursor source)
		     class 'magnet-dragger))

(defmethod draw-target-feedback ((cmd magnet-dragger) view x y value
				 &key (clear nil))
  "find view object under cursor and highlight it"
  (declare (ignore clear))
  (when (eql value view)
    (loop for obj in (view-objects view)
        when (point-inside obj x y)
        do (xlibwith-gcontext ((gcontext view) function boole-xor
				foreground (xor-foreground view))
             (draw-rectangle obj 0 0 (1- (width obj)) (1- (height obj))))
           (return nil))))

(defmethod executable ((cmd magnet-dragger))
  "check whether successful in final position"
  (setf (deleted-object cmd)
        (loop for obj in (view-objects (current-target cmd))
              when (point-inside obj (target-x cmd) (target-y cmd))
              return obj))
  (deleted-object cmd))

(defmethod doit ((cmd magnet-dragger))
  "delete the object"
  (deinstall (deleted-object cmd)))

(defmethod undoit ((cmd magnet-dragger))
  "reinstall the deleted object"
  (install (deleted-object cmd) (current-target cmd)
           (x-pos (deleted-object cmd)) (y-pos (deleted-object cmd))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class triangle-dragger
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass triangle-dragger (drag-command)
  ((name         initform "Make Triangle"   allocation class)
   (new-triangle accessor new-triangle   initform nil)))

(defun make-triangle-dragger (doc source x y)
  (make-drag-command doc source x y (list (list (main-view doc) nil))
		     cursor left-ptr
		     shell-to-move (drag-shell source)
		     class 'triangle-dragger))

(defmethod track-target ((cmd triangle-dragger) widget x y value)
  "display current position as feedback"
  (declare (ignore value))
  (setf (label-string (track-label (document cmd)))
        (if widget
            (format nil "(~d, ~d)" x y)
	    "")))

(defmethod doit ((cmd triangle-dragger))
  "create a new triangle at target position"
  (unless (new-triangle cmd)
    (let ((view (main-view (document cmd))))
      (setf (label-string (track-label (document cmd))) "")
      (setf (new-triangle cmd) 
	    (make-triangle (obj-width view) (obj-height view) 
			   (length (view-objects view))))))
  (install (new-triangle cmd) (main-view (document cmd))
           (target-x cmd) (target-y cmd)))

(defmethod undoit ((cmd triangle-dragger))
  "remove the installed triangle"
  (deinstall (new-triangle cmd)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class triangle-copier
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass triangle-copier (drag-command)
  ((name    initform "Copy Triangle"    allocation class)
   ;; triangle must be dragged away
   (hysteresis    initform 5            allocation class)
   ;; protocol-id needed to identify for foreign apps
   (protocol-id   initform copy_triangle  allocation class)
   ;; new slot
   (new-triangle  accessor new-triangle initform nil)))

(defun make-triangle-copier (doc source x y
			     &key (x-off 0) (y-off 0)
			          (transfer-value nil)
			          (received-from nil))
  (make-drag-command doc source 
		     (+ x x-off) (+ y y-off)
		     (list (list (main-view doc) nil))
		     shell-to-move (drag-shell (drag-template doc))  ;; abused
		     cursor left-ptr
		     x-off x-off
		     y-off y-off
		     transfer-value transfer-value  ;; triangle number will
		                                     ;; be transferred
		     received-from received-from
		     class 'triangle-copier))

(defmethod track-target ((cmd triangle-copier) widget x y value)
  "display current position as feedback, only in own document"
  (declare (ignore value))
  (setf (label-string (track-label (document cmd)))
        (if widget
            (format nil "(~d, ~d)" x y)
	    "")))

(defmethod doit ((cmd triangle-copier))
  "install a new triangle copy"
  (unless (new-triangle cmd)
    (setf (label-string (track-label (document cmd))) "")
    (setf (new-triangle cmd)
          (make-triangle (obj-width (main-view (document cmd)))
                         (obj-height (main-view (document cmd)))
                         (transfer-value cmd))))
  (install (new-triangle cmd) (main-view (document cmd))
           (target-x cmd) (target-y cmd)))

(defmethod undoit ((cmd triangle-copier))
  "remove the triangle"
  (deinstall (new-triangle cmd)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; start drag application

(register-application "drag" 'drag-application "drag")
'(make-drag-application)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class drop-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drop-application (application)
  (;; overrides
   (name          initform "Drop"         allocation class)
   (document-type initform 'drop-document allocation class)
   (signature     initform "drop"               allocation class)
   (file-type     initform "drop"               allocation class))
  (documentation "a simple drop demo application"))

(defun make-drop-application ()
  "start the drop-application"
  (make-application class 'drop-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class drop-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass drop-document (document)
  (;; instance-variables
   (fax            accessor fax)
   (phone          accessor phone)
   (panel          accessor panel)
   ;; signal the acceptance of a triangle-copier
   (drag-protocols initform '(copy_triangle) allocation class))
  (documentation "application dependent document type"))

(defmethod create-windows ((doc drop-document) 
			   &aux rc)
  "create the windows belonging to this document"
  (with-slots (main-shell) doc
    (setq main-shell (make-document-shell doc))
    (setq rc (make-row-column main-shell orientation vertical
             entry-alignment center))
    (setf (panel doc)
          (make-label rc " "))
    (setf (phone doc)
          (make-push-button rc "PHONE" 
		      motif-resources '(margin-height 20 margin-width 15)))
    (setf (fax doc)
          (make-push-button rc "FAX"
                      motif-resources '(margin-height 20 margin-width 15)))
    ))

(defmethod create-drop-command ((doc drop-document) shell x y protocol-id
				transfer-value received-from)
  "when accepting a triangle copier, a command of a different class is created"
  (case protocol-id
    ((copy_triangle)
        (make-triangle-receiver doc shell x y 
                                transfer-value transfer-value
                                received-from received-from))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class triangle-receiver
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass triangle-receiver (drag-command)
  ((causes-change initform nil             allocation class)
   (protocol-id   initform copy_triangle  allocation class)
   (do-tracking   initform nil             allocation class)
   ;; new slot
   (old-label     accessor old-label       initform nil)))

(defun make-triangle-receiver (doc source x y
			       &key (transfer-value nil)
			            (received-from nil))
  (make-drag-command doc source x y
		     (list (list (phone doc) phone)
			   (list (fax doc)   fax))
		     transfer-value transfer-value
		     received-from received-from
		     class 'triangle-receiver))

(defmethod doit ((cmd triangle-receiver))
  "display action that would have been taken, name depends on target"
  (unless (old-label cmd)
    (setf (old-label cmd) (label-string (panel (document cmd))))
    (setf (name cmd) 
          (format nil "~a #~d" (current-value cmd) (transfer-value cmd))))
  (setf (label-string (panel (document cmd))) (name cmd)))

(defmethod undoit ((cmd triangle-receiver))
  "restore old panel contents"
  (setf (label-string (panel (document cmd))) (old-label cmd)))

;;; start drop application
(register-application "drop" 'drop-application "drop")
'(make-drop-application)
17. Mandelbrot Demo

17.1 Functionality
This demo displays the Mandelbrot set with user-specified parameters. The computation which may take quite a long time is performed in a background process, so that the interface remains fully operational. The progress of the computation is shown in a progress bar, which also allows to abort the computation. Scales can be use to try different parameter settings. When a document is stored, the parameter combination is saved in a file (not the bitmap itself). Selecting a rectangular area of a picture with the mouse means to zoom into that area. Zooming is undoable.
17.2 Implementation
•	Double buffering is used to store computed Mandelbrot sets
17.3 Limitations and Extensions
•	Color would be nice.
17.4 Source Code
;;; -*- ModeLISP;SyntaxCommon-Lisp;Packagemandel;Base 10 -*-

(in-package GINA)
(defginapackage mandel)
(in-package mandel)
(setq *sccs-id* "@(#)mandelbrot.lisp	1.2  1/15/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class mandelbrot-application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass mandelbrot-application (application)
  (;; overrides
   (name          initform "Mandelbrot"         allocation class)
   (document-type initform 'mandelbrot-document allocation class)
   (signature     initform "mandel"             allocation class)
   (file-type     initform "mandel"             allocation class)))

(defun make-mandelbrot-application ()
  (make-application class 'mandelbrot-application))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class mandelbrot-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass mandelbrot-document (document)
  ((shell-width initform 600)
   (shell-height initform 400)
   (label accessor label)
   (scale1 accessor scale1)
   (scale2 accessor scale2)
   (scale3 accessor scale3)
   (button accessor button)
   (min-x  accessor min-x initform -2.0) 
   (max-x  accessor max-x initform  1.0)
   (min-y  accessor min-y initform -1.0)
   (max-y  accessor max-y initform  1.0)))

(defmethod create-windows ((doc mandelbrot-document) &aux form scroller)
  "create the windows belonging to this document"
  (with-slots (main-shell main-view label scale1 scale2 scale3 button) doc
    (setq main-shell (make-document-shell doc))
    (setq form       (make-form main-shell))
    (setq label      (make-label form "-2.0 < X < 1.0      -1.0 < Y < 1.0"))
    (setq scale1     (make-scale form orientation horizontal
				 title-string "Width"
				 minimum 1 maximum 1200 value 60
                                 value-changed-callback
                                 `(lambda (&rest ignore) 
				   (setf (modified ,doc) t))))
    (setq scale2     (make-scale form orientation horizontal
				 title-string "Height"
				 minimum 1 maximum 800 value 40
				 value-changed-callback
                                 `(lambda (&rest ignore) 
				   (setf (modified ,doc) t))))
    (setq scale3     (make-scale form orientation horizontal
				 title-string "Limit"
				 minimum 1 maximum 128 value 8
				 value-changed-callback
                                 `(lambda (&rest ignore) 
				   (setf (modified ,doc) t))))
    (setq button     (make-push-button form "Recompute"
                         activate-callback
                         (make-callback 'draw-mandelbrot-set doc)))
    (setq scroller   (make-scroller form))
    (setq main-view  (make-mandelbrot-view scroller document doc)) 
    
    (define-form-constraint label 
                            top-attachment form
                            left-attachment form
                            right-attachment form)
    (define-form-constraint scale1 
			    left-attachment form
			    left-offset 10
			    top-attachment widget top-widget label
			    right-attachment position right-position 25)
    (define-form-constraint scale2 
                            top-attachment widget top-widget label
                            left-attachment widget left-widget scale1
			    left-offset 10
                            right-attachment position right-position 50)
    (define-form-constraint scale3
                            top-attachment widget top-widget label
                            left-attachment widget left-widget scale2
			    left-offset 10
                            right-attachment position right-position 75)
    (define-form-constraint button 
                            top-attachment widget top-widget label
			    top-offset 5
                            left-attachment widget left-widget scale3
			    left-offset 10
                            right-attachment form right-offset 10
                            bottom-attachment widget bottom-widget scroller
                            bottom-offset 5)
    (define-form-constraint scroller
                            top-attachment widget top-widget scale1
                            left-attachment form
                            right-attachment form
                            bottom-attachment form)
    ))

(defmethod write-to-stream ((doc mandelbrot-document) stream)
  "write the current parameter setting to the specified stream"
  (format stream "~d ~d ~d ~d ~d ~d ~d ~%"
          (value (scale1 doc)) (value (scale2 doc)) (value (scale3 doc))
          (min-x doc) (max-y doc) (min-y doc) (max-y doc)))

(defmethod read-from-stream ((doc mandelbrot-document) stream) 
  "read the stored parameter settings from the specified stream"
  (with-slots (scale1 scale2 scale3) doc
    (setf (value scale1) (read stream))
    (setf (value scale2) (read stream))
    (setf (value scale3) (read stream))
    (setf (min-x doc) (read stream))
    (setf (max-y doc) (read stream))
    (setf (min-y doc) (read stream))
    (setf (max-y doc) (read stream))))

(defun draw-mandelbrot-set (document 
			    &aux view width height limit 
				 min-x max-x min-y max-y
				 step-x step-y)
  "loop through user-specified range of points"

  ;; kill all other computations in progress
  (kill-all-background-processes document)
  
  (setq view   (main-view document))
  (setq width  (value (scale1 document)))
  (setq height (value (scale2 document)))
  (setq limit  (value (scale3 document)))
  (setq min-x (min-x document) 
	max-x (max-x document)
	step-x (/ (- max-x min-x) width))
  (setq min-y (min-y document) 
	max-y (max-y document)
	step-y (/ (- max-y min-y) height))

  ;; adapt view size to parameters
  (resize view width height)

  ;; clear both window and pixmap buffer
  (clear-area view 0 0 width height)
  (progn (setf (drawable view) (pixmap-buffer view))
	 (clear-area view 0 0 width height)
	 (setf (drawable view) (x-window view)))

  (with-progress-bar (document modal nil 
			       centered nil
			       message "Recomputing Mandelbrot Set ...")
    (loop for x from min-x to max-x by step-x 
          for i from 0 
          while (not (progress-bar-aborted)) do
      ;; move slider of progress bar
      (indicate-progress (round (* (/ i (float width)) 100)))
      (loop for y from min-y to max-y by step-y
            for j from 0 do
	(when (in-mandelbrot-set x y limit)
	  ;; draw into both window and pixmap buffer
	  (draw-point view i j)
	  (progn  (setf (drawable view) (pixmap-buffer view))
		  (draw-point view i j)
		  (setf (drawable view) (x-window view)))))
      (xlibdisplay-force-output *display*))))

(defun in-mandelbrot-set (x y limit 
			  &aux (new-x x) (new-y y) z (k 0))
  "test whether point (x,y) is member of Mandelbrot set"
  (setq z (complex x y))
  (loop 
    while (and (<= (+ (* new-x new-x) (* new-y new-y)) 4) (< k limit)) 
    do (setq z (+ (complex x y) (* z z)))
       (setq new-x (realpart z))
       (setq new-y (imagpart z))
       (incf k))
   ;; return whether number of iterations reached the limit
   (= k limit))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class mandelbrot-view
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass mandelbrot-view (view)
  ())

(defun make-mandelbrot-view (parent &key document)
  (make-view parent document document
	            class 'mandelbrot-view
	            double-buffering t))

(defmethod determine-window-id after ((view mandelbrot-view))
  "immediately start computation of mandelbrot-set when view is ready"
  (draw-mandelbrot-set (document view)))

(defmethod button-press ((view mandelbrot-view) code repetition x y)
  (declare (ignore repetition code))
  (make-zoom-command view x y))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class zoom-command
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass zoom-command (mouse-down-command)
  ((name initform "Zoom" allocation class)
   (new-min-x  accessor new-min-x) 
   (new-max-x  accessor new-max-x)
   (new-min-y  accessor new-min-y)
   (new-max-y  accessor new-max-y)
   (old-min-x  accessor old-min-x initarg old-min-x) 
   (old-max-x  accessor old-max-x initarg old-max-x)
   (old-min-y  accessor old-min-y initarg old-min-y)
   (old-max-y  accessor old-max-y initarg old-max-y)))

(defun make-zoom-command (view x y)
  (make-mouse-down-command (document view) view x y
			   cursor crosshair
			   class 'zoom-command
			   initargs
			   (list old-min-x (min-x (document view))
				 old-max-x (max-x (document view)) 
				 old-min-y (min-y (document view))
				 old-max-y (max-y (document view)))))

(defmethod constrain-mouse ((cmd zoom-command) x y)
  "make sure width and height of area is > 0"
  (with-slots (start-x start-y) cmd
    (setq x (max x (1+ start-x)))
    (setq y (max y (1+ start-y))))
  (values x y))

(defmethod draw-feedback ((cmd zoom-command) x y &key clear)
  "draw rectangular feedback"
  (declare (ignore clear))
  (with-slots (start-x start-y view) cmd
    (xlibwith-gcontext ((gcontext view) line-style dash)
      (draw-rectangle view start-x start-y (- x start-x)  (- y start-y)))))

(defmethod track-mouse ((cmd zoom-command) x y &key &allow-other-keys)
  (with-slots (start-x start-y new-min-x new-max-x new-min-y new-max-y 
		       view document) cmd
     (setq new-min-x (+ (min-x document) 
			(* (- (max-x document) (min-x document)) ;; range
			   (/ start-x (float (width view))))))
     (setq new-min-y (+ (min-y document) 
			(* (- (max-y document) (min-y document)) ;; range
			   (/ start-y (float (height view))))))
     (setq new-max-x (+ (min-x document) 
			(* (- (max-x document) (min-x document)) ;; range
			   (/ x (float (width view))))))
     (setq new-max-y (+ (min-y document) 
		        (* (- (max-y document) (min-y document)) ;; range
			   (/ y (float (height view))))))
     (setf (label-string (label document))
       (format nil "~8d < X < ~8d    ~8d < Y < ~8d" 
		new-min-x new-max-x new-min-y new-max-y))
     ))

(defmethod doit ((cmd zoom-command))
  "change range parameters in document"
  (setf (min-x (document cmd)) (new-min-x cmd))
  (setf (max-x (document cmd)) (new-max-x cmd))
  (setf (min-y (document cmd)) (new-min-y cmd))
  (setf (max-y (document cmd)) (new-max-y cmd))
  (setf (label-string (label (document cmd)))
       (format nil "~8d < X < ~8d    ~8d < Y < ~8d" 
	       (new-min-x cmd) (new-max-x cmd) 
	       (new-min-y cmd) (new-max-y cmd)))
  (draw-mandelbrot-set (document cmd)))

(defmethod undoit ((cmd zoom-command))
  "restore range parameters in document"
  (setf (min-x (document cmd)) (old-min-x cmd))
  (setf (max-x (document cmd)) (old-max-x cmd))
  (setf (min-y (document cmd)) (old-min-y cmd))
  (setf (max-y (document cmd)) (old-max-y cmd))
  (setf (label-string (label (document cmd)))
       (format nil "~8d < X < ~8d    ~8d < Y < ~8d" 
	       (old-min-x cmd) (old-max-x cmd) 
	       (old-min-y cmd) (old-max-y cmd)))
  (draw-mandelbrot-set (document cmd)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(register-application "mandel" 'mandelbrot-application "mandel")
'(make-mandelbrot-application)
18. Desk Calculator 
18.1 Functionality
Just like a typical desk calculator. Rubout removes the last typed digit or the decimal point. Clear clears all internal registers and the display. This calculator demonstrates the use of the GINA interface-builder. 

18.2 Implementation
•	All visible items are drawn with the interface builder.
•	All callbacks of buttons are also set within the interface builder.
•	The code for this demo application is very small and is mostly restricted to the functions of the calculator.
18.3 Limitations and Extensions
•	Pressing any key from the keyboard is not recognized.
18.4 Source Code
;;; -*- Mode LISP; Syntax Common-Lisp; Package calc; Base 10-*-

(in-package GINA)
(defginapackage calc)
(in-package calc)
(setq *sccs-id* "@(#)calculator.lisp	1.2  1/21/92")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class calculator
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass calculator (application)
  (;; overrides
   (name          initform "Calculator"   allocation class)
   (document-type initform 'calc-document allocation class)
   (signature     initform "calc"         allocation class)
   (file-type     initform "calc"         allocation class)))

(defun make-calculator ()
  "start the desk-calculator"
  (make-application class 'calculator))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; class calc-document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass calc-document (document)
  (;; instance-variables
   (input-value   accessor input-value   initform 0)
   (input-string  accessor input-string  initform "")
   (decimal-point accessor decimal-point initform nil)
   (memory        accessor memory        initform 0)
   (operator      accessor operator      initform nil)))

(defmethod clear ((doc calc-document))
  "reset everything"
  (setf (input-string doc) "")
  (setf (input-value doc) 0)
  (setf (decimal-point doc) nil)
  (setf (label-string (display (main-shell doc))) "0")
  (setf (memory doc) 0)
  (setf (operator doc) nil))

(defmethod create-windows ((doc calc-document))
  "create the windows belonging to this document"
  (with-slots (main-shell main-view) doc
    ;; create instance of class generated by Interface Builder
    (setq main-shell (make-calculator-shell doc))

    ;; bypass GINAs automatic naming conventions
    (setf (title main-shell) "Calc")
    (set-motif-resources main-shell icon-name "Calc")))

(defmethod type-digit ((doc calc-document) digit
		       &aux (display (display (main-shell doc))))
  "a digit has been typed"
  (setf (input-string doc)
	(concatenate 'string (input-string doc) (format nil "~d" digit)))
  (when (not (operator doc)) (setf (memory doc) 0))
  (setf (label-string display) (input-string doc)))

(defmethod type-point ((doc calc-document)
		       &aux (display (display (main-shell doc))))
  "a point has been typed"
  (when (not (decimal-point doc))
    (setf (decimal-point doc) t)
    (setf (input-string doc)
	(concatenate 'string (input-string doc) "."))
    (setf (label-string display) (input-string doc))))

(defmethod type-rubout ((doc calc-document)
			  &aux string-length
			       (display (display (main-shell doc))))
  "backspace for input"
  (setq string-length (length (input-string doc)))
  (when (> string-length 0)
    (when (equal (position #\. (input-string doc)) (1- string-length))
      (setf (decimal-point doc) nil))
    (setf (input-string doc) (subseq (input-string doc) 0 (1- string-length)))
    (setf (label-string display) (input-string doc))))

(defmethod type-operator ((doc calc-document) operator
			  &aux (display (display (main-shell doc))))
  "an operator has been typed"
  (setf (input-value doc)
	(if (equal (input-string doc) "")
	    (memory doc)
	    (read-from-string (input-string doc))))
  (setf (input-string doc) "")
  (setf (decimal-point doc) nil)
  (if (operator doc)
    (setf (memory doc)
	  (ignore-errors
	    (funcall (operator doc) (memory doc) (input-value doc))))
    (setf (memory doc) (input-value doc)))
  (when (not (memory doc)) (setf (memory doc) "Error"))
  (setf (operator doc) operator)
  (setf (label-string display) (format nil "~f" (memory doc))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; main program
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(register-application "calc" 'calculator "calc")
'(make-calculator)