cl-frame.lisp

;;; cl-frame.lisp --- open emacs-style frames with structured graphics.
;;       _        __                          
;;   ___| |      / _|_ __ __ _ _ __ ___   ___ 
;;  / __| |_____| |_| '__/ _` | '_ ` _ \ / _ \
;; | (__| |_____|  _| | | (_| | | | | | |  __/
;;  \___|_|     |_| |_|  \__,_|_| |_| |_|\___|
;;
;; Copyright (C) 2006  David O'Toole
;;
;; Author: David O'Toole <[email protected]>
;; Keywords: multimedia, tools, lisp, frames, unix
;; Version: $Id: cl-frame.lisp,v 1.22 2006/10/28 05:39:56 dto Exp dto $
;;
;; This file is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary: 

;; There is no commentary as of yet. This file is very preliminary.

;;; Links:

;; CLX Manual:
;; http://www.stud.uni-karlsruhe.de/~unk6/clxman/
;;
;; CLX examples:
;; (find-file "/usr/lib/sbcl/site/clx_0.7.3/demo/")
;;
;; Snd home page:
;; http://ccrma.stanford.edu/software/snd/
;;
;; Realtime Snd:
;; http://www.notam02.no/arkiv/src/snd/
;; http://www.notam02.no/arkiv/doc/snd-rt/
;; (find-file "~/e/snd.e)
;; (find-file "/home/dto/src/snd-ls-0.9.7.5/snd-8/clm-ins.scm")
;; (find-file "/home/dto/src/snd-ls-0.9.7.5/")


;;; Code:


(eval-when (:compile-toplevel :load-toplevel :execute) 
  (require :clx))


(defpackage cl-frame
  (:documentation "A structured graphical workspace toolkit for Lisp.")
  (:use :xlib :common-lisp)
  (:export widget frame worksheet connection port dataflow listener toolbar
	   textbox template channel 
	   do-test do-test-from-file
	   ))


(in-package :cl-frame)			 


;;;; (@* "major modes")


(defvar *major-mode* nil "A keyword symbol identifying the
current major mode.")


;;;; (@* "widgets")
;;           _     _            _       
;; __      _(_) __| | __ _  ___| |_ ___ 
;; \ \ /\ / / |/ _` |/ _` |/ _ \ __/ __|
;;  \ V  V /| | (_| | (_| |  __/ |_\__ \
;;   \_/\_/ |_|\__,_|\__, |\___|\__|___/
;;                   |___/              
;;
;; Widgets are the things that frames display and edit. This is the
;; base class for interactive elements in CL-FRAME.
;;
;; Widgets are user interface elements that represent objects in a
;; problem domain. A widget may be transformed into an alternative
;; representation called the "model" of a widget. Actions on widgets
;; can result in changes to the model.
;;
;; A model can be saved to disk, transformed into another model, or
;; into a program that implements the model.
;;
;; A model may contain some information that is not meaningful in the
;; problem domain. For example, in order to save diagrams to disk, we
;; should save the X and Y positions of the widgets. In most cases,
;; these coordinates will not matter to the model. They should be
;; ignored by any further transformations. 
;;
;; Widgets may have child widgets, and so on. Widgets have a position
;; within the parent widget and a label to be used when appearing in a
;; composition of widgets.
;;


(defclass widget ()
  ((parent :accessor parent :initform nil :initarg :parent)
   (children :accessor children :initform nil :initarg :children)
   (label :accessor label :initform "()" :initarg :label)
   (position-x :accessor position-x :initform 0 :initarg :position-x)
   (position-y :accessor position-y :initform 0 :initarg :position-y)
   (height :accessor height :initform 0 :initarg :height)
   (width :accessor width :initform 0 :initarg :width)))


(defgeneric default-map-key (widget key key-sym modifiers))


(defmethod default-map-key ((w widget) key key-sym modifiers)
  nil)


(defgeneric touch (widget x y)
  (:documentation "The widget should respond to being touched at 
position X,Y. The meaning of being touched is up to the subclass."))


(defmethod touch ((w widget) x y)
  nil)


(defgeneric model (widget)
  (:documentation "Return an S-expression representing the model of the
widget. The default behavior is to transform the widget into a
property list. The model of the 'parent' slot is not saved, as
this would lead to infinite recursion."))


(defmethod model ((w widget))
  (with-slots (children label position-x position-y height width) w
    (list :class (class-name (class-of w))
	  :label label
	  :position-x position-x 
	  :position-y position-y
	  :children (mapcar #'model children)
	  :height height
	  :width width)))
 

(defgeneric unmodel (widget)
  (:documentation "Do any initialization neccessary during the
unmodeling process."))


(defmethod unmodel ((w widget))
  ;;
  ;; make sure children are set up correctly
  (dolist (c (children w))
    (setf (parent c) w))
  nil)


(defgeneric cursor-key (widget)
  (:documentation "Return a keyword representing the cursor to be displayed on
mouseover. Examples are :cursor, :touch-cursor, :join-cursor
etc."))


(defmethod cursor-key ((w widget))
  :cursor)


(defgeneric join-widgets (source sink &optional x y)
  (:documentation "Operate on the SOURCE and SINK widgets. The
actual operation to occur is determined by the classes of SOURCE
and SINK."))


(defmethod join-widgets ((source widget) (sink widget) &optional x y)
  nil)


(defgeneric adjoin-child (parent child)
  (:documentation "Add CHILD to the widget P's children."))


(defmethod adjoin-child ((p widget) (child widget))
  (setf (children p) (adjoin child (children p)))
  (setf (parent child) p))


(defgeneric remove-child (parent child)
  (:documentation "Remove CHILD from the widget P's children."))


(defmethod remove-child ((p widget) (child widget))
  (setf (children p) (remove child (children p))))


(defgeneric move (widget x y)
  (:documentation "Reposition the widget W within the worksheet."))


(defmethod move ((w widget) x y)
  (setf (position-x w) x)
  (setf (position-y w) y))


(defun within-extents (x y x0 y0 x1 y1)
  (and (>= x x0) 
       (<= x x1)
       (>= y y0)
       (<= y y1)))
  

(defgeneric hit-test (widget x y)
  (:documentation "Return W when the position (x,y) is within the
bounding rectangle for the widget W, nil
otherwise. Non-rectangular widgets or widgets with clickable
subcomponents should override this method."))


(defmethod hit-test ((w widget) x y)
  (with-slots (position-x position-y height width) w
    (if (within-extents x y 
			position-x position-y 
			(+ position-x width)
			(+ position-y height))
	w
	nil)))

    
(defun hit-widgets (widgets x y)
  (some #'(lambda (w)
	    (hit-test w x y))
	(reverse widgets)))


(defun hit-widgets-or-parent (widgets parent x y)
  (or (hit-widgets widgets x y) parent))



;;;; (@* "keymaps")
;; Mapping key combinations to methods
;;  _                                        
;; | | _____ _   _ _ __ ___   __ _ _ __  ___ 
;; | |/ / _ \ | | | '_ ` _ \ / _` | '_ \/ __|
;; |   <  __/ |_| | | | | | | (_| | |_) \__ \
;; |_|\_\___|\__, |_| |_| |_|\__,_| .__/|___/
;;           |___/                |_|        
;;
;; A keypress is a triple of the form (key keysym modifiers).  
;;
;; A keymap is a list of functions to be called in order with the
;; keypress as an argument, until one returns a method to be invoked
;; on the object in question. If no method is obtained, the process
;; repeats with the widget's parent.
;;


(defvar *class->keymap* nil "Hash table mapping class names to keymaps.")


(defun define-key (class-name key-spec func)
  (destructuring-bind (&key key keysym modifiers) key-spec
    (let ((preds nil))
      (when key 
	(push `(eql key ,key) preds))
      (when keysym 
	(push `(eql keysym ,keysym) preds))
      (when modifiers
	(push `(subsetp ',modifiers modifiers) preds))
      (let ((tester (eval `(lambda (key keysym modifiers)
			     (when (and ,@preds)
			       ,func)))))
	(push tester (gethash class-name *class->keymap*))))))


(defun map-key (w key keysym modifiers)
  (let* ((keymap (gethash (class-name (class-of w))
			  *class->keymap*))
	 (method (some (lambda (f)
			 (funcall f key keysym modifiers))
		       keymap)))
    (if method
	(funcall method w)
	(when (not (default-map-key w key keysym modifiers))
	  (when (parent w)
	    (map-key (parent w) key keysym modifiers))))))
	  
	 
;;;; (@* "frames")
;;   __                               
;;  / _|_ __ __ _ _ __ ___   ___  ___ 
;; | |_| '__/ _` | '_ ` _ \ / _ \/ __|
;; |  _| | | (_| | | | | | |  __/\__ \
;; |_| |_|  \__,_|_| |_| |_|\___||___/
;;                                   
;; A frame is an X window for viewing and interacting with widgets.
;;
;; A frame has one associated widget. The widget's label is taken as
;; the title of the frame. The widget's children are displayed in the
;; frame for interaction purposes.
;;
;; Several user actions can occur. 
;;
;; The user can drag a widget by holding shift and the left mouse
;; button. This causes the "move" method to be invoked on the widget.
;;
;; The user can join two widgets by right-mouse-dragging one onto the
;; other. This causes the "join-widgets" method to be invoked with the
;; two widgets as the source and sink arguments.
;;
;; The user can click a widget with the left mouse button. This
;; causes the "touch" method to be invoked on the widget, and also
;; causes keyboard focus to move to the widget.
;;
;; The user can type with the keyboard into the focused widget. The
;; method name to be invoked is looked up in the widget's keymap.


(defvar *window->frame* "Hash table mapping X window ID's to frame objects.")
(defvar *display* "The X display object.")


(defun find-frame (window)
  (gethash window *window->frame*))


(defclass frame ()
  (;;
   ;; the associated widget   
   (widget :accessor widget :initform nil :initarg :widget)
   ;;
   ;; the widget being dragged, if any
   (dragging :accessor dragging :initform nil)
   ;;
   ;; the widget being joined to another, if any
   (joining :accessor joining :initform nil)
   ;;
   ;; the widget having keyboard focus, if any
   (focusing :accessor focusing :initform nil)
   ;;
   ;; CLX-related resources
   (screen :accessor screen :initform nil)
   (colormap :accessor colormap :initform nil)
   (foreground :accessor foreground :initform nil)
   (background :accessor background :initform nil)
   (context :accessor context :initform nil :initarg :context)
   (highlight-context :accessor highlight-context :initform nil)
   (accent-context :accessor accent-context :initform nil)
   (shadowed-context :accessor shadowed-context :initform nil)
   (active-context :accessor active-context :initform nil)
   (clear-context :accessor clear-context :initform nil)
   (cursor :accessor cursor :initform nil :initarg :cursor)
   (join-cursor :accessor join-cursor :initform nil :initarg :join-cursor)
   (touch-cursor :accessor touch-cursor :initform nil :initarg :touch-cursor)
   (font :accessor font :initform nil :initarg :font)
   (window :accessor window :initform nil :initarg :window)
   (canvas :accessor canvas :initform nil :initarg :canvas)))


;;;; Loading some pre-defined X cursors


(defconstant arrow-cursor-id 132)
(defconstant circle-cursor-id 24)
(defconstant hand-cursor-id 60)


(defun X-predefined-cursor (frame cursor-id)
  "Load and return one of the predefined X cursors."
  (let ((font (open-font *display* "cursor")))
    (setf (window-cursor (window frame))
	  (create-glyph-cursor :source-font font
			       :source-char cursor-id
			       :mask-font font
			       :mask-char (1+ cursor-id)
			       :foreground 
			       (make-color :red 1.0 :green 1.0 :blue 1.0)
			       :background 
			       (make-color :red 0.0 :green 0.0 :blue 0.0)))))


;;;; Creating frames


(defmethod initialize-instance :after ((f frame) &rest initargs)
  "Initialize a new frame on the default display."
  (with-slots (screen colormap foreground context canvas
		      cursor join-cursor touch-cursor
		      highlight-context accent-context
		      shadowed-context active-context clear-context
		      background widget font window) f
    (setf screen (display-default-screen *display*))
    (setf colormap (screen-default-colormap screen))
    (setf foreground (alloc-color colormap (make-color 
					      :red 0.8
					      :green 0.8
					      :blue 0.8)))
    (setf background (alloc-color colormap (make-color
					      :red 0.3
					      :green 0.3
					      :blue 0.3)))
    (setf window (create-window
		  :parent (screen-root screen)
		  :x 0
		  :y 0
		  :height 400
		  :width 640
		  :background background
		  :border foreground
		  :border-width 1
		  :backing-store :when-mapped
		  :colormap colormap
		  :bit-gravity :center
		  :event-mask '(:exposure :button-press :key-press
				:button-release :pointer-motion)))
    (setf canvas (create-pixmap :width (drawable-width (screen-root screen))
				:height (drawable-height (screen-root screen))
				:depth (drawable-depth window)
				:drawable window))
    (setf font (open-font *display* "8x13"))
    (setf context (create-gcontext :drawable window
				   :foreground foreground
				   :background background
				   :font font))
    (setf accent-context (create-gcontext :foreground 
					  (alloc-color colormap (make-color
								 :red 1.0
								 :green 1.0
								 :blue 1.0))
					  :line-width 2
					  :background background
					  :drawable window
					  :font font))
    (setf highlight-context (create-gcontext :foreground
					     (alloc-color colormap (make-color
								    :red (/ 236.0 255.0)
								    :green (/ 242.0 255.0)
								    :blue (/ 69.0 255.0)))
					     :background background
					     :drawable window
					     :font font))
    (setf shadowed-context (create-gcontext :foreground
					    (alloc-color colormap (make-color
								   :red 0.7
								   :green 0.7
								   :blue 0.7))
					    :line-style :dash
					    :dashes '(2 2)
					    :background background
					    :drawable window
					    :font font))
    (setf active-context (create-gcontext :foreground
					  (alloc-color colormap (make-color
								 :red 0.3
								 :green 0.7
								 :blue 0.8))
					  :background background
					  :drawable window
					  :font font))
    (setf clear-context (create-gcontext :foreground background
					 :background foreground
					 :drawable window
					 :font font))
    (setf cursor (X-predefined-cursor f arrow-cursor-id))
    (setf join-cursor (X-predefined-cursor f circle-cursor-id))
    (setf touch-cursor (X-predefined-cursor f hand-cursor-id))
    ;;
    ;; set window properties
    (set-wm-properties window
		       :name 'hello-world
		       :icon-name "hello-world"
		       :resource-name "hello-world"
		       :resource-class 'hello-world
		       :x 0 :y 0 :width 640 :height 400
		       :input :off :initial-state :normal)
    ;;
    ;; map the window
    (map-window window)
    ;;
    ;; save the frame so that we can look it up later
    (setf (gethash window *window->frame*) f)
    f))


(defparameter *widget-horizontal-margin* 4)
(defparameter *widget-vertical-margin* 2)
(defparameter *widget-minimum-width* 40)


(defun X-default-render-widget (widget drawable context font)
  "Render the WIDGET with default X appearance to DRAWABLE with
gcontext CONTEXT and font FONT."
  (with-slots (position-x position-y label height width) widget
    ;; calculate size of widget based on font
    (setf width (max *widget-minimum-width*
		     (+ (* 2 *widget-horizontal-margin* )
			(text-extents font label))))
    (setf height (+ (* 2 *widget-vertical-margin*)
		    (font-ascent font) (font-descent font)))
    ;; now draw
    (draw-rectangle drawable context 
		    position-x position-y
		    width height)
    (draw-glyphs drawable context 
		 (+ 2 position-x)
		 (+ 2 (font-ascent font) position-y)
		 label)))
    

(defgeneric render-widget (frame widget)
  (:documentation "Render the widget to the frame with default
appearance. Different widget subclasses that need different
appearances should override this method."))


(defmethod render-widget ((f frame) (w widget))
  (with-slots (context canvas font) f
    (X-default-render-widget w canvas context font)))


(defgeneric render (frame)
  (:documentation "Redraw the widgets in the frame to the frame's
associated window."))


(defmethod render ((f frame))
  (with-slots (canvas widget context clear-context window) f
    (with-state (window)
      (with-state (canvas)
	;;
	;; clear background of canvas
	(draw-rectangle canvas clear-context 0 0 
			(drawable-width window)
			(drawable-height window)
			:fill)
	;;
	;; render widgets 
	(dolist (child (children (widget f)))
	  (render-widget f child))
	;;
	;; copy canvas to window
	(copy-area canvas context 0 0 
		   (drawable-width window)
		   (drawable-height window)
		   window 0 0)))))
		   
  

(defgeneric click (frame x y)
  (:documentation "Respond to a mouse click from the user at
point X,Y. The default action is to 'touch' the widget at that
position."))


(defmethod click ((f frame) x y)
  (let* ((widgets (children (widget f)))
	 (widget (hit-widgets-or-parent widgets (widget f) x y)))
    (when widget
      (setf (focusing f) widget)
      (touch widget x y))))


(defgeneric start-dragging (frame x y)
  (:documentation "Begin dragging the selected widget."))


(defmethod start-dragging ((f frame) x y)
  (let* ((widgets (children (widget f)))
	 (widget (hit-widgets widgets x y)))
    (setf (dragging f) widget)
    (setf (focusing f) widget)))


(defgeneric stop-dragging (frame)
  (:documentation "Stop dragging the selected widget."))


(defmethod stop-dragging ((f frame))
  (setf (dragging f) nil))


(defgeneric start-joining (frame x y)
  (:documentation "Begin joining two widgets."))


(defmethod start-joining ((f frame) x y)
  (let ((widgets (children (widget f))))
    (setf (joining f) (hit-widgets widgets x y))))


(defgeneric stop-joining (frame x y)
  (:documentation "Join the selected widgets."))


(defmethod stop-joining ((f frame) x y)
  (let ((source (joining f))
	(sink (hit-widgets-or-parent (children (widget f)) (widget f) x y)))
    (when (and source sink)
      (join-widgets source sink x y))
    (setf (joining f) nil)))


(defgeneric set-cursor (frame cursor)
  (:documentation "Set the cursor type for the given frame."))


(defmethod set-cursor ((f frame) cursor)
  (setf (window-cursor (window f)) cursor))


;;;; (@* "X event loop")
;; __  __                       _     _                   
;; \ \/ /   _____   _____ _ __ | |_  | | ___   ___  _ __  
;;  \  /   / _ \ \ / / _ \ '_ \| __| | |/ _ \ / _ \| '_ \ 
;;  /  \  |  __/\ V /  __/ | | | |_  | | (_) | (_) | |_) |
;; /_/\_\  \___| \_/ \___|_| |_|\__| |_|\___/ \___/| .__/ 
;;                                                 |_|    


(defun run-frames ()
  (unwind-protect 
       (event-case (*display* :discard-p t :force-output-p t)
	 (exposure
	  (window)
	  (let ((frame (find-frame window)))
	    (when frame
	      (render frame)
	      nil)))
	 ;;
	 (button-release 
	  (window state)
	  (let ((frame (find-frame window))
		(state-keys (make-state-keys state)))
	    (when frame
	      (multiple-value-bind (x y)
		  (pointer-position window)
		(cond 
		  ((member :button-1 state-keys)
		   (stop-dragging frame)
		   (render frame))
		  ((member :button-3 state-keys)
		   (stop-joining frame x y)
		   (render frame))))))
	  nil)
	 ;;
	 (button-press
	  (window)
	  (multiple-value-bind (x y s c state) 
	      (query-pointer window)
	    (let ((frame (find-frame window))
		  (state-keys (make-state-keys state)))
	      (when frame
		(multiple-value-bind (x y)
		    (pointer-position window)
		  (cond 
		    ((subsetp '(:shift :button-1) state-keys)
		     (click frame x y))
		    ((member :button-1 state-keys)
		     (start-dragging frame x y))
		    ((member :button-3 state-keys)
		     (start-joining frame x y)))))))
	  nil)
	 ;;
	 (key-press
	  (window code state)
	  (let* ((frame (find-frame window))
		 (state-keys (make-state-keys state))
		 (widget (or (focusing frame) (widget frame)))
		 (keysym (keycode->keysym *display* 
					  code (if (member :shift state-keys)
						   1
						   0)))
		 (key (keysym->character *display* keysym)))
	    (when widget
	      (map-key widget key keysym state-keys)
	      (render frame)))
	  nil)
	 ;;
	 (motion-notify
	  (window button)
	  (multiple-value-bind (x y)
	      (pointer-position window)
	    (let* ((frame (find-frame window))
		   (widgets (children (widget frame)))
		   (dragged-widget (dragging frame))
		   (joined-widget (joining frame)))
	      (cond
		((and dragged-widget frame)
		 (move dragged-widget x y)
		 (render frame))
		;;
		((and joined-widget frame)
		 nil))
	      ;;
	      ;; hit-test to see what cursor we should use. 
	      (let ((cursor 
		     (let ((widget (hit-widgets widgets x y)))
		       (if widget
			   (case (cursor-key widget)
			     (:cursor (cursor frame))
			     (:join-cursor (join-cursor frame))
			     (:touch-cursor (touch-cursor frame)))
			   (cursor frame)))))
		(setf (window-cursor window) cursor))))
	  nil))
    ;;
    ;;
    (close-display *display*)))


;;;; (@* "textboxes")
;;  _            _   _                        
;; | |_ _____  _| |_| |__   _____  _____  ___ 
;; | __/ _ \ \/ / __| '_ \ / _ \ \/ / _ \/ __|
;; | ||  __/>  <| |_| |_) | (_) >  <  __/\__ \
;;  \__\___/_/\_\\__|_.__/ \___/_/\_\___||___/
;;
;; Textboxes allow you to edit their contents interactively.
                                           

(defvar *textbox-margin* 4 "Default onscreen margin of a textbox.")


(defclass textbox (widget) 
  ((buffer :accessor buffer :initform nil :initarg :buffer)
   (point-row :accessor point-row :initform 0 :initarg :point-row)
   (point-column :accessor point-column :initform 0 :initarg :point-column)))


(defmethod model ((box textbox))
  (with-slots (buffer point-row point-column) box
    (append (call-next-method)
	    (list :buffer buffer
		  :point-row point-row
		  :point-column point-column))))


(defmethod render-widget ((f frame) (box textbox))
  (with-slots (window canvas context font highlight-context focusing) f
    (with-slots (position-x position-y height width 
			    buffer point-row point-column) box
      (with-state (window)
	  (let* ((font-height (+ 2 (font-ascent font) (font-descent font))))
	    ;;
	    ;; update textbox geometry
	    (let ((line-lengths (mapcar (lambda (s)
					  (text-extents font s))
					buffer)))
	      (setf width (max *widget-minimum-width*
			       (+ (* 2 *textbox-margin*)
				  (if (null line-lengths)
				      0 (apply #'max line-lengths))))))		      
	    (setf height (+ (* 2 *textbox-margin*)
			    (* font-height (max 1 (length buffer)))))
	    ;;
	    ;; draw border
	    (draw-rectangle canvas context 
			    position-x position-y
			    width height)
	    ;;
	    ;; draw buffer
	    (let ((x (+ position-x *textbox-margin*))
		  (y (+ -2 position-y *textbox-margin*)))
	      (dolist (line buffer)
		(incf y font-height)
		(draw-glyphs canvas context x y line)))
	    ;; 
	    ;; draw cursor
	    (when (eq focusing box)
	      (let* ((line (nth point-row buffer))
		     (cursor-width (text-extents font " "))
		     (x (+ position-x *textbox-margin*
			   (text-extents font (subseq line 0 point-column))))
		     (y (+ 2 position-y *textbox-margin*
			   (* font-height point-row))))
		(draw-rectangle canvas highlight-context 
				x y cursor-width font-height t))))))))
	 

(defmethod default-map-key ((box textbox) key keysym modifiers)
  (when (typep key 'standard-char)
    (insert box key))
  ;;
  ;; return true to notify keymapper that we've handled the event
  t)


(defmethod forward-char ((box textbox))
  (with-slots (buffer point-row point-column) box
    (setf point-column (min (1+ point-column)
			    (length (nth point-row buffer))))))


(defmethod backward-char ((box textbox))
  (with-slots (buffer point-row point-column) box
    (setf point-column (max 0 (1- point-column)))))


(defmethod next-line ((box textbox))
  (with-slots (buffer point-row point-column) box
    (setf point-row (min (1+ point-row)
			 (1- (length buffer))))
    (setf point-column (min point-column 
			    (length (nth point-row buffer))))))


(defmethod previous-line ((box textbox))
  (with-slots (buffer point-row point-column) box
    (setf point-row (max 0 (1- point-row)))
    (setf point-column (min point-column
			    (length (nth point-row buffer))))))


(defmethod move-end-of-line ((box textbox))
  (with-slots (buffer point-row point-column) box
    (setf point-column (length (nth point-row buffer)))))


(defmethod move-beginning-of-line ((box textbox))
  (setf (point-column box) 0))


(defmethod newline ((box textbox))       
  (with-slots (buffer point-row point-column) box
    ;;  insert line break
    (let* ((line (nth point-row buffer))
	   (line-remainder (subseq line point-column))
	   (buffer-remainder (nthcdr (1+ point-row) buffer)))
      ;; truncate current line
      (setf (nth point-row buffer) 
	    (subseq line 0 point-column))
      ;; insert new line
      (if (= 0 point-row)
	  (setf (cdr buffer)
		(cons line-remainder (cdr buffer)))
	  (setf (cdr (nthcdr (- point-row 1) buffer))
		(cons (nth point-row buffer)
		      (cons line-remainder buffer-remainder))))
      ;;
      (incf point-row)			
      (setf point-column 0))))


(defmethod backward-delete-char ((box textbox))       
  (with-slots (buffer point-row point-column) box
    (if (and (= 0 point-column) (/= 0 point-row))
	(progn 
	  ;;
	  ;; we need to remove a line break.
	  (let ((line (nth (- point-row 1) buffer))
		(next-line (nth (+ point-row 1) buffer)))
	    (setf (nth (- point-row 1) buffer)
		  (concatenate 'string line (nth point-row buffer)))
	    (setf (cdr (nthcdr (- point-row 1) buffer))
		  (nth (+ point-row 1) buffer))
	    ;;
	    ;; move cursor too
	    (decf point-row)
	    (setf point-column (length line))))
	(progn
	  ;;
	  ;; otherwise, delete within current line.
	  (when (/= 0 point-column)
	    (let* ((line (nth point-row buffer))
		   (remainder (subseq line point-column)))
	      (setf (nth point-row buffer)
		    (concatenate 'string 
				 (subseq line 0 (- point-column 1))
				 remainder))
	      (decf point-column)))))))
    

(defmethod insert ((box textbox) key)       
  (with-slots (buffer point-row point-column) box
    (if (null buffer)
	(progn
	  (push (string key) buffer)
	  (incf point-column))
	(progn
	  (let* ((line (nth point-row buffer))
		 (remainder (subseq line point-column)))
	    (setf (nth point-row buffer)
		  (concatenate 'string
			       (subseq line 0 point-column)
			       (string key)
			       remainder)))
	  (incf point-column)))))
    
    

;;;; (@* "buttons")
;;  _           _   _                  
;; | |__  _   _| |_| |_ ___  _ __  ___ 
;; | '_ \| | | | __| __/ _ \| '_ \/ __|
;; | |_) | |_| | |_| || (_) | | | \__ \
;; |_.__/ \__,_|\__|\__\___/|_| |_|___/
;;
;; A button evaluates the lisp expression inside when you click on it.
                                    

(defclass button (textbox) ())


(defmethod render-widget ((f frame) (b button))
  (with-slots (highlight-context canvas font) f
    (X-default-render-widget b canvas highlight-context font)))


(defmethod touch ((b button) x y)
  (with-slots (label) b
    (handler-case
	(eval (read-from-string label))
      ;; print any errors to standard output for now
      (condition (c) (format t "~S" c)))))


;;;; (@* "templates")
;;  _                       _       _            
;; | |_ ___ _ __ ___  _ __ | | __ _| |_ ___  ___ 
;; | __/ _ \ '_ ` _ \| '_ \| |/ _` | __/ _ \/ __|
;; | ||  __/ | | | | | |_) | | (_| | ||  __/\__ \
;;  \__\___|_| |_| |_| .__/|_|\__,_|\__\___||___/
;;                   |_|                         
;;
;; A template allows you to create new objects within a worksheet.


(defclass template (widget) ())


(defmethod render-widget ((f frame) (tmp template))
  (with-slots (shadowed-context canvas font) f
    (X-default-render-widget tmp canvas shadowed-context font)))


(defmethod cursor-key ((tem template))
  :join-cursor)


;;;; (@* "worksheets")
;;                     _        _               _       
;; __      _____  _ __| | _____| |__   ___  ___| |_ ___ 
;; \ \ /\ / / _ \| '__| |/ / __| '_ \ / _ \/ _ \ __/ __|
;;  \ V  V / (_) | |  |   <\__ \ | | |  __/  __/ |_\__ \
;;   \_/\_/ \___/|_|  |_|\_\___/_| |_|\___|\___|\__|___/
;;
;; Worksheets are used to organize widgets into a page.
                                                     

(defclass worksheet (widget) ())

(defmethod join-widgets ((tmp template) (wrk worksheet) &optional x y)
  "Create a new widget of the class indicated by template TMP
in worksheet WRK at location X Y."
  (let* ((class-symbol (intern (string-upcase (label tmp))))
	 (widget (make-instance class-symbol 
				:label (concatenate 'string
						    "*new " 
						    (label tmp)
						    "*")
				:position-x x
				:position-y y
				:parent wrk)))
    (adjoin-child wrk widget)))
    

;;;; (@* "toolbars")
;;  _              _ _                    
;; | |_ ___   ___ | | |__   __ _ _ __ ___ 
;; | __/ _ \ / _ \| | '_ \ / _` | '__/ __|
;; | || (_) | (_) | | |_) | (_| | |  \__ \
;;  \__\___/ \___/|_|_.__/ \__,_|_|  |___/
;;
;; A toolbar full of widgets is displayed across the top of the frame.
                                       

(defclass toolbar (widget) ())


(defparameter *toolbar-margin* 5)


(defmethod render-widget ((f frame) (b toolbar))
  (with-slots (window canvas accent-context font) f
    (let ((toolbar-height (+ 4
			     (* 2 *toolbar-margin*) 
			     (* 2 *widget-vertical-margin*)
			     (font-ascent font)
			     (font-descent font))))
      ;; update toolbar geometry 
      (with-state (window)
	(with-slots (position-x position-y height width) b
	  (setf position-x 0)
	  (setf position-y 0)
	  (setf height toolbar-height)
	  (setf width (drawable-width window)))
	;;
	;; draw toolbar border
	(draw-line canvas accent-context
		   0 toolbar-height
		   (drawable-width window) toolbar-height))
      ;;
      ;; position and render children
      (let ((x *toolbar-margin*))
	(dolist (child (children b))
	  (setf (position-x child) x)
	  (setf (position-y child) *toolbar-margin*)
	  (render-widget f child)
	  (incf x (+ *toolbar-margin* (width child))))))))


(defmethod hit-test ((b toolbar) x y)
  (hit-widgets (children b) x y))


;;;; (@* "listeners")
;;  _ _     _                           
;; | (_)___| |_ ___ _ __   ___ _ __ ___ 
;; | | / __| __/ _ \ '_ \ / _ \ '__/ __|
;; | | \__ \ ||  __/ | | |  __/ |  \__ \
;; |_|_|___/\__\___|_| |_|\___|_|  |___/
;;
;; A listener gives you the read-eval-print loop at the bottom of the frame.
  

(defparameter *listener-lines* 5 "Number of lines to display in listener.")
(defparameter *listener-margin* 5 "Size of margins in listener.") 


(defclass listener (textbox)
  ((history-position :accessor history-position :initform 0 
		     :initarg :history-position)))


(defmethod model ((box textbox))
  (append (call-next-method)
	  (list :history-position (history-position box))))


(defmethod add-listener ((f frame))
  (let ((listener (make-instance 'listener)))
    (adjoin-child (widget f) listener)))


(defmethod render-widget ((f frame) (L listener))
  (with-slots (window canvas highlight-context accent-context font focusing) f
    (with-state (window)
      (with-slots (position-x position-y height width 
			      buffer point-row point-column) L
	(let* ((font-height (+ 2 (font-ascent font) (font-descent font)))
	       (font-width (text-extents font "a"))
	       (listener-height (+ 4 
				   (* 2 *listener-margin*)
				   (* *listener-lines* font-height))))
	  ;;
	  ;; update listener geometry
	  (setf position-y (- (drawable-height window)
			      listener-height))
	  (setf position-x 0)
	  (setf width (drawable-width window))
	  (setf height listener-height)
	  ;;
	  ;; draw border
	  (draw-line canvas accent-context 
		     position-x position-y 
		     (drawable-width window) position-y)
	  ;;
	  ;; draw text lines
	  (let ((y (- (drawable-height window)
		      *listener-margin*
		      )))
	    (dotimes (i *listener-lines*)
	      (draw-glyphs canvas accent-context 
			   *listener-margin* y
			   (nth i buffer))
	      (decf y font-height)))
	  ;;
	  ;; draw cursor
	  (when (eq focusing L)
	    (draw-rectangle canvas highlight-context 
			    (+ *listener-margin*
			       (* point-column font-width))
			    (- (drawable-height window)
			       *listener-margin*
			       font-height)
			    font-width font-height t)))))))


(defmethod evaluate ((L listener))
  (with-slots (buffer point-row point-column history-position) L
       (setf point-row 0)
       (setf history-position 0)
       (setf point-column 0)
       (push (concatenate 'string " "
			  (handler-case 
			      (prin1-to-string 
			       (eval (read-from-string (car buffer))))
			    (condition (c) (format nil "~S" c))))
	     buffer)
       (push "" buffer)))


(defmethod previous-history ((L listener))
  (with-slots (buffer history-position point-column) L
    (setf history-position (min (1+ history-position)
				(length buffer)))
    (setf (car buffer) (copy-seq (nth history-position buffer)))
    (setf point-column (length (car buffer)))))


(defmethod next-history ((L listener))
  (with-slots (buffer history-position point-row point-column) L
    (setf history-position (max 0 (1- history-position)))
    (setf (car buffer) (copy-seq (nth history-position buffer)))
    (setf point-column (length (car buffer)))))


;; (@* "channels")
;;       _                            _     
;;   ___| |__   __ _ _ __  _ __   ___| |___ 
;;  / __| '_ \ / _` | '_ \| '_ \ / _ \ / __|
;; | (__| | | | (_| | | | | | | |  __/ \__ \
;;  \___|_| |_|\__,_|_| |_|_| |_|\___|_|___/
;;
;; A channel manages communication with an external program.  The
;; default implementation uses sb-ext:run-program and talks to the
;; standard input/output streams of the program being run.
;;


(defclass channel ()
  ((process :accessor process :initarg :process :initform nil)))


(defgeneric run (channel program args)
  (:documentation "Run program PROGRAM with ARGS and connect it
  to the channel."))


(defgeneric stop (channel)
  (:documentation "Kill the program attached to the channel."))


(defgeneric send-string (channel string)
  (:documentation "Send a string through the channel to the external program."))


(defgeneric send-sexp (channel sexp)
  (:documentation "Send an S-expression through the channel to
  the external program."))


(defgeneric receive-string (channel)
  (:documentation "Read any output from the channel."))


(defmethod run ((ch channel) program args)
  (setf (process ch) (sb-ext:run-program program args
					 :input :stream
					 :output :stream
					 :search t
					 :pty nil
					 :wait nil)))


(defmethod stop ((ch channel))
  (sb-ext:process-kill (process ch) 9))


(defmethod send-string ((ch channel) string)
  (let ((stream (sb-ext:process-input (process ch))))
    (format stream "~A ~%" string)
    (force-output stream)))


(defmethod send-sexp ((ch channel) sexp)
  (let ((stream (sb-ext:process-input (process ch)))
	(*print-case* :downcase))
    (format stream "~S~%" sexp)
    (force-output stream)))                                                               


;; (@* "soundframe")
;;                            _  __                          
;;  ___  ___  _   _ _ __   __| |/ _|_ __ __ _ _ __ ___   ___ 
;; / __|/ _ \| | | | '_ \ / _` | |_| '__/ _` | '_ ` _ \ / _ \
;; \__ \ (_) | |_| | | | | (_| |  _| | | (_| | | | | | |  __/
;; |___/\___/ \__,_|_| |_|\__,_|_| |_|  \__,_|_| |_| |_|\___|
;;


;;;; Connecting CL-FRAME and Snd


(defvar *snd* nil "Channel to the SND editor.")

(defvar *snd-rt-init-file* "/home/dto/rt-init.scm")

(defun snd-mode ()
  "Activate snd-mode. Start the Snd process and load the realtime engine."
  (setf *major-mode* :snd-mode)
  (setf *snd* (make-instance 'channel))
  (run *snd* "snd" nil)
  (send-sexp *snd* `(load ,*snd-rt-init-file*)))


;;;; Connections link together two ports 


(defclass connection (widget)
  ((source :accessor source :initform nil :initarg :source)
   (sink :accessor sink :initform nil :initarg :sink)
   (handle :accessor handle :initform nil :initarg :handle)))


(defmethod model ((c connection))
  (with-slots (source sink) c
    (append (call-next-method)
	    (list :source (model source)
		  :sink (model sink)))))
	    

(defmethod unmodel ((c connection))
  (with-slots (source sink handle) c
    ;;
    ;; the ports will not have their connections at this point.
    ;; fill them in here.
    (adjoin-connection source c)
    (adjoin-connection sink c)
    ;;
    ;; now create a new handle object
    (setf handle (make-instance 'connection-handle :parent c))))

  
(defmethod disconnect ((c connection))
  (with-slots (source sink) c
    (let ((parent (parent (parent source))))
      (remove-connection source c)
      (remove-connection sink c)
      (remove-child parent c))))


(defmethod endpoints ((c connection))
  (with-slots (source sink) c
    (let ((x0 (port-extents-x (parent source) 
			      (port-number source) 
			      (num-outlets (parent source))))
	  (y0 (port-extents-y (parent source) :outlet-p))
	  (x1 (port-extents-x (parent sink) 
			      (port-number sink) 
			      (num-inlets (parent sink))))
	  (y1 (+ *port-height* (port-extents-y (parent sink)))))
      (values x0 y0 x1 y1))))


(defparameter *handle-radius* 5 "Default on-screen radius of a connection handle.")


(defmethod handle-extents ((c connection))
  (multiple-value-bind (x0 y0 x1 y1) (endpoints c)
    (let* ((mid-x (truncate (/ (+ x0 x1) 2)))
	   (mid-y (truncate (/ (+ y0 y1) 2)))
	   (hx0 (- mid-x *handle-radius*))
	   (hx1 (+ mid-x *handle-radius*))
	   (hy0 (- mid-y *handle-radius*))
	   (hy1 (+ mid-y *handle-radius*)))
      (values hx0 hy0 hx1 hy1))))


(defmethod render-widget ((f frame) (c connection))
  (with-slots (context canvas) f
    (multiple-value-bind (x0 y0 x1 y1) (endpoints c)
      (draw-line canvas context x0 y0 x1 y1))
    (multiple-value-bind (x0 y0 x1 y1) (handle-extents c)
      (draw-arc canvas context x0 y0 (- x1 x0) (- y1 y0)
		0.0 (* 2.0 3.14159)))))


(defmethod hit-test ((c connection) x y)
  (multiple-value-bind (x0 y0 x1 y1) (handle-extents c)
    (if (within-extents x y x0 y0 x1 y1)
	(handle c)
	nil)))
       

;;;; Connection handles make it easy to select a connection


(defclass connection-handle (widget) ())


(defmethod touch ((h connection-handle) x y)
  (disconnect (parent h)))


;;;; Ports are the components of a dataflow where connections attach


(defclass port (widget)
  ((port-number :accessor port-number :initform 0 :initarg :port-number)
   (connections :accessor connections :initform nil :initarg :connections)
   (port-type :accessor port-type :initform :inlet :initarg :port-type)))


(defmethod model ((p port))
  "Model a port. Don't model the connections; this leads to
infinite recursion."
  (with-slots (port-number connections parent) p
      (append (call-next-method)
	      (list :port-number port-number
		    :parent (model parent)))))

      

(defmethod unmodel ((p port))
  ;;
  ;; dataflows will not have their ports at this point.
  ;; fill them in here.
  (with-slots (port-number parent port-type) p
    (replace-port parent p port-type)))


(defmethod adjoin-connection ((p port) connection)
  (setf (connections p) (adjoin connection (connections p))))


(defmethod remove-connection ((p port) connection)
  (setf (connections p) (remove connection (connections p))))


(defmethod join-widgets ((source port) (sink port) &optional x y)
  (when (not (eq source sink))
    (connect-ports source sink)))


(defmethod connect-ports ((source port) (sink port))
  (let* ((parent (parent (parent source)))
	 (connection (make-instance 'connection
				    :source source
				    :sink sink
				    :parent parent))
	 (handle (make-instance 'connection-handle)))
    ;;
    (setf (handle connection) handle)
    (setf (parent handle) connection)
    ;;
    (adjoin-connection source connection)
    (adjoin-connection sink connection)
    ;;
    ;; save new connection in parent widget
    (adjoin-child parent connection)))


(defmethod cursor-key ((p port))
  :join-cursor)


;;;; Dataflow widgets are sources and sinks of data with attached ports. 
                                  
        
(defclass dataflow (textbox)
  ((num-inlets :accessor num-inlets :initform 0 :initarg :num-inlets)
   (inlets :accessor inlets :initform nil)
   (num-outlets :accessor num-outlets :initform 0 :initarg :num-outlets)
   (outlets :accessor outlets :initform nil)))


(defmethod model ((d dataflow))
  "Produce a model of a dataflow object. Note that we do not
model the ports explicitly---this would lead to infinite recursion."
  (with-slots (num-inlets num-outlets inlets outlets) d
    (append (call-next-method)
	    (list :num-inlets num-inlets
		  :num-outlets num-outlets))))

			

(defmethod unmodel ((d dataflow))
  "Create blank ports on the dataflow."
  (with-slots (num-inlets num-outlets inlets outlets) d
        (setf (inlets d) (make-sequence 'vector num-inlets))
    (setf (outlets d) (make-sequence 'vector num-outlets))
    (dotimes (i num-inlets)
      (setf (aref (inlets d) i) (make-instance 'port 
					       :port-number i
					       :parent d
					       :port-type :inlet)))
    (dotimes (i num-outlets)
      (setf (aref (outlets d) i) (make-instance 'port 
						:port-number i
						:parent d
						:port-type :outlet)))))


(defmethod replace-port ((d dataflow) (p port) port-type)
  (case port-type
    (:inlet 
     (setf (aref (inlets d) (port-number p)) p))
    (:outlet
     (setf (aref (outlets d) (port-number p)) p))))
     


(defmethod initialize-instance :after ((d dataflow) &rest initargs)
       (unmodel d))
    

(defmethod port-extents-x ((self dataflow) nth-port num-ports)
  "Return the x-coordinates of the left and right edges of the port NTH-PORT
in SELF."
  (with-slots (position-x width) self
    (let ((left (+ position-x (* nth-port (/ width num-ports)))))
      (values left (+ left *port-width*)))))


(defmethod port-extents-y ((self dataflow) &optional outlet-p)
  "Return the y-coordinates of the top and bottom edges of the
inlets for widget SELF. If outlet-p is non-nil, return the outlet
coordinates instead."
  (with-slots (position-y height) self
    (let ((top (if outlet-p
		   (+ position-y height)
		   (- position-y *port-height*))))
      (values top (+ top *port-height*)))))


(defparameter *port-width* 8 "Default onscreen width of a data port.")
(defparameter *port-height* 8 "Default hit-test height of a data port.")


(defmethod render-widget ((f frame) (w dataflow))
  (with-slots (context accent-context canvas) f
    (with-slots (position-x position-y height width
			    num-inlets num-outlets) w
      ;;
      ;; draw default appearance
      (call-next-method)
      ;;
      ;; decorate it with ports
      (dotimes (n num-inlets)
	(multiple-value-bind (x0 x1) (port-extents-x w n num-inlets)
	  (multiple-value-bind (ignore y) (port-extents-y w)
	    (draw-line canvas accent-context x0 y x1 y))))
      (dotimes (n num-outlets)
	(multiple-value-bind (x0 x1) (port-extents-x w n num-outlets)
	  (multiple-value-bind (y ignore) (port-extents-y w :outlet-p)
	    (draw-line canvas accent-context x0 y x1 y)))))))
	  

(defmethod hit-test ((d dataflow) x y)
  "Return the widget (either D or one of its ports) when
hit-testing succeeds, nil otherwise."
  (with-slots (inlets outlets num-inlets num-outlets) d
    (labels ((hit-port (p n outlet-p)
	       (multiple-value-bind (x0 x1) 
		   (port-extents-x (parent p) (port-number p) n)
		 (multiple-value-bind (y0 y1) 
		     (port-extents-y (parent p) outlet-p)
		   (if (and (>= x x0) (<= x x1)
			    (>= y y0) (<= y y1))
		       p
		       nil))))
	     (hit-inlet (p n)
	       (hit-port p n nil))
	     (hit-outlet (p n)
	       (hit-port p n t)))
      ;;
      (or (some #'(lambda (p)
		    (hit-inlet p num-inlets))
		inlets)
	  (some #'(lambda (p)
		    (hit-outlet p num-outlets))
		outlets)
	  ;;
	  ;; none of the inlets or outlets were hit. 
	  (call-next-method)))))
	       					 

(defmethod cursor-key ((d dataflow))
  :touch-cursor)


;;;; (@* "models")
;;                      _      _     
;;  _ __ ___   ___   __| | ___| |___ 
;; | '_ ` _ \ / _ \ / _` |/ _ \ / __|
;; | | | | | | (_) | (_| |  __/ \__ \
;; |_| |_| |_|\___/ \__,_|\___|_|___/
;;
;; Functions for transforming and serializing models. 
                                  

(defun fold-model (model)
  "Turn a model with many duplicate (but equal) sublists into a
model with a table of objects and references between
them. Returns a hash table mapping sexps to integers, and the
transformed model."
  (let ((sexps->integers (make-hash-table :test 'equal))
	(id 0)
	(m (copy-tree model)))
    (labels ((fold-sexp (L)
	       (let* ((sexp (car L))
		      (sexp-id nil))
		 ;;
		 ;;
		 ;; don't match keywords or already-substituted references
		 (when (and (listp sexp)
			    (not (null sexp))
			    (not (equal 'folded-reference (car sexp))))
		   (fold-sexp sexp)
		   (if (setf sexp-id (gethash sexp sexps->integers))
		       (nsubst `(folded-reference ,sexp-id) sexp L :test 'equal)
		       ;;
		       ;; it's not in the hashtable. put it in
		       (progn 
			 (incf id)
			 (setf (gethash sexp sexps->integers) id))))			
		 ;;
		 (when (not (null L))
		   (fold-sexp (cdr L))))))
      (fold-sexp m)
      ;;
      ;; give the object table a "root object"
      (setf (gethash m sexps->integers) 0)
      ;;
      ;; now fold sexps that are in the hash table already
      (let ((new-sexps (make-hash-table :test 'equal)))
	;;
	;; first make a copy; we can't modify a hash table while iterating over it
	(maphash (lambda (k v)
		   (setf (gethash k new-sexps) v))
		 sexps->integers)
	;;
	;; now fold the keys of the copy while modifying the original 
	(maphash (lambda (k v)
		   (fold-sexp k))
		 new-sexps))
      ;;
      ;; return the mapping and the folded model
      (values sexps->integers m))))
      

(defun serialize-model (model)
  "Serialize a model into a set of sexps suitable for writing to a text file."
  (multiple-value-bind (sexp-hash folded-model) (fold-model model)
    (let ((sexps nil))
      (maphash (lambda (k v)
		 (push (cons v k) sexps))
	       sexp-hash)
      (sort sexps (lambda (x y)
			(> (car x) (car y))))
      (nreverse sexps))))
	      

(defun write-model (model filename)
  "Write a model to disk."
  (with-open-file (file filename :direction :output 
			:if-exists :overwrite
			:if-does-not-exist :create)
    (format t "~S" model)
    (format file "~S" model)))
    

(defvar *model*)


(defmethod save-worksheet ((wrk worksheet) filename)
  (let ((model (serialize-model (model wrk))))
    (setf *model* model)
    (write-model model filename)))


(defun read-model (filename)
  "Read a model from disk."
  (with-open-file (file filename :direction :input)
    (read file)))


(defun load-worksheet (filename)
  "Construct a worksheet from a file."
  (let* ((model (read-model filename))
	 (integers->sexps (make-hash-table :test 'eql))
	 (integers->objects (make-hash-table :test 'eql))
	 (worksheet-model nil))
    ;;
    ;; grab the worksheet object, which is always first
    (setf worksheet-model (car model))
    ;;
    ;; read in all the sexps
    (dolist (m model)
      (setf (gethash (car m) integers->sexps) (cdr m)))
    ;;
    ;; now expand the sexps into objects by recursively unfolding all references
    ;;
    (labels ((remove-class-keywords (plist)
 	       ;;
 	       ;; we do this because it makes it easier to
 	       ;; pass the plist to make-instance during
 	       ;; the unmodeling process.
 	       (let ((plist1 plist)
 		     (plist2 nil))
 		 (do ((p (pop plist1) (pop plist1)))
 		     ((null plist1))
 		   (if (equal :class p)
 		       (pop plist1) ; skip value after keyword
 		       (push p plist2)))
 		 ;;
 		 ;; handle the last element
 		 (push (car (last plist)) plist2)
 		 (prog1 
 		     (reverse plist2))))
	     ;;
	     (unmodel-object (plist)
	       (let* ((plist2 (remove-class-keywords plist))
		      (object-class (getf plist :class))
		      (object (apply #'make-instance object-class plist2)))
		 (unmodel object)
		 object))
	     ;;
	     (expand (sexp)
	       (if (not (listp sexp))
		   sexp
		   ;;
		   ;; what type of list? 
		   (cond
		     ;;
		     ;; a folded reference? 
		     ((equal 'folded-reference (car sexp))
		      (let* ((reference-number (car (cdr sexp)))
			     (object (gethash reference-number integers->objects)))
			;;
			;; if already in object cache, return it.
			;; otherwise, put it in
			(if object
			    object
			    ;;
			    ;; time to make the donuts!
			    (let ((reference-sexp 
				   (gethash reference-number integers->sexps)))
			      (setf (gethash reference-number integers->objects)
				    (expand reference-sexp))))))
		     ;;
		     ;; a modeled object?
		     ((listp sexp)
		      ;;
		      ;; expand all subforms
		      (setf sexp (mapcar #'expand sexp))
		      ;;
		      ;; create object when ready
		      (if (equal :class (car sexp))
			  (unmodel-object sexp)
			  ;; otherwise just return sexp
			  sexp))))))
      ;;
      ;;
      (values 
       (expand (gethash 0 integers->sexps))
       integers->objects integers->sexps))))
    

;;;; (@* "initialization")
;;  _       _ _   
;; (_)_ __ (_) |_ 
;; | | '_ \| | __|
;; | | | | | | |_ 
;; |_|_| |_|_|\__|
;;
;; Initializing the CL-FRAME library
               

(defun initialize-cl-frame ()
  "Get the cl-frame library ready to go."
  (setf *window->frame* (make-hash-table :test #'equal))
  (setf *display* (open-default-display))
  (setf *class->keymap* (make-hash-table :test #'equal))
  ;;
  ;; define initial keymaps
  (define-key 'textbox '(:modifiers (:control) :key #\f) #'forward-char)
  (define-key 'textbox '(:modifiers (:control) :key #\b) #'backward-char)
  (define-key 'textbox '(:modifiers (:control) :key #\n) #'next-line)
  (define-key 'textbox '(:modifiers (:control) :key #\p) #'previous-line)
  (define-key 'textbox '(:keysym 65363) #'forward-char)
  (define-key 'textbox '(:keysym 65361) #'backward-char)
  (define-key 'textbox '(:keysym 65364) #'next-line)
  (define-key 'textbox '(:keysym 65362) #'previous-line)
  (define-key 'textbox '(:modifiers (:control) :key #\e) #'move-end-of-line)
  (define-key 'textbox '(:modifiers (:control) :key #\a) #'move-beginning-of-line)
  (define-key 'textbox '(:key #\Return) #'newline)
  (define-key 'textbox '(:key #\Backspace) #'backward-delete-char)
  ;;
  (define-key 'dataflow '(:modifiers (:control) :key #\f) #'forward-char)
  (define-key 'dataflow '(:modifiers (:control) :key #\b) #'backward-char)
  (define-key 'dataflow '(:modifiers (:control) :key #\n) #'next-line)
  (define-key 'dataflow '(:modifiers (:control) :key #\p) #'previous-line)
  (define-key 'dataflow '(:keysym 65363) #'forward-char)
  (define-key 'dataflow '(:keysym 65361) #'backward-char)
  (define-key 'dataflow '(:keysym 65364) #'next-line)
  (define-key 'dataflow '(:keysym 65362) #'previous-line)
  (define-key 'dataflow '(:modifiers (:control) :key #\e) #'move-end-of-line)
  (define-key 'dataflow '(:modifiers (:control) :key #\a) #'move-beginning-of-line)
  (define-key 'dataflow '(:key #\Return) #'newline)
  (define-key 'dataflow '(:key #\Backspace) #'backward-delete-char)
  ;;
  (define-key 'listener '(:modifiers (:control) :key #\f) #'forward-char)
  (define-key 'listener '(:modifiers (:control) :key #\b) #'backward-char)
  (define-key 'listener '(:modifiers (:control) :key #\n) #'next-history)
  (define-key 'listener '(:modifiers (:control) :key #\p) #'previous-history)
  (define-key 'listener '(:keysym 65363) #'forward-char)
  (define-key 'listener '(:keysym 65361) #'backward-char)
  (define-key 'listener '(:keysym 65364) #'next-history)
  (define-key 'listener '(:keysym 65362) #'previous-history)
  (define-key 'listener '(:modifiers (:control) :key #\e) #'move-end-of-line)
  (define-key 'listener '(:modifiers (:control) :key #\a) #'move-beginning-of-line)
  (define-key 'listener '(:key #\Return) #'evaluate)
  (define-key 'listener '(:key #\Backspace) #'backward-delete-char))
  

	       			 
;;; Tests:


(defvar *frame*)
(defvar *model*)
(defvar *model2*)
(defvar *model3*) 


(defun do-test ()    
    (initialize-cl-frame)
    (setf *frame* (make-instance 'frame))
    ;;
    ;; fill frame with widgets
    (let ((widget (make-instance 'worksheet))
	  (toolbar (make-instance 'toolbar)))
      (setf (widget *frame*) widget)
      (dotimes (i 10)
	(let ((box (make-instance 'dataflow :parent widget
				  :label (nth (random 4) 
					      '("a" "b" "c" "d"))
				  :num-inlets (1+ (random 2))
				  :num-outlets (1+ (random 2)))))
	  (setf (position-x box) (random 200))
	  (setf (position-y box) (random 200))
	  (push box (children widget))))
      (dotimes (i 4)
	(let ((box (make-instance 'template  
				  :parent widget
				  :label (nth (random 2) 
					      '("dataflow" "textbox")))))
	  (adjoin-child toolbar box)))
      (adjoin-child widget toolbar))
    (add-listener *frame*)
    ;;
    ;; now get going
    (run-frames))


(defun do-test-from-file (filename)
  (initialize-cl-frame)
  (setf *frame* (make-instance 'frame))
  ;;
  ;;
  (setf (widget *frame*) (load-worksheet filename))
  (run-frames))