Xelf: The Graphical User Interface Toolkit

Table of Contents

Overview

Xelf includes a Lisp GUI toolkit inspired by MIT Scratch and Berkeley SNAP, with visual grammar and style similar to Jens Mönig's Smalltalk Elements (pdf) (software) and shared anterior influences in Squeak Morphic and Self. (See also The Sun Microsystems Self Movie (Youtube) or (archive.org)

My own implementation of these concepts is not yet documented. But there are some video demos to see in the interim.

New documentation is forthcoming. In the meantime you can read the code included here.

See also "Buffer base class" and "Node class" in the parent document, Xelf: eXtensible Emacs-Like Facility.

NOTE: To test the GUI Shell in git head, you must do the following before creating your buffer:

(setf xelf:*shell-enabled-p* t)

Then create your buffer and press Alt-X to enter the Shell.

It is also recommended to set

(setf xelf:*scale-output-to-window* nil)

before opening your game window, so that enlarging the window shows more of the buffer.

Package declaration

(in-package :xelf)

Type declaration for optional strings

  (defun optional-string-p (s)
    (or (null s) (stringp s)))

  (deftype optional-string () '(satisfies optional-string-p))

Buffer class

The class QBUFFER (defined in the parent document under "Buffer base class") covers collision detection and updating; here we implement a wrapper class with more functionality. The class BUFFER includes graphics utilities, smooth scrolling/zooming, drag-and-drop GUI and map editing functionality (experimental, see GUI section below.)

The buffers you create should all subclass from BUFFER. (Notice that every BUFFER is also a NODE.)

Class declaration

  (defclass buffer (node qbuffer)
    ((name :initform nil :type optional-string :accessor name :initarg :name)
     (zbuffer :initform (make-array 100 :adjustable t :initial-element nil :fill-pointer t)
              :accessor zbuffer
              :documentation "Temporary array of z-sorted nodes for rendering."
              :initarg :zbuffer)
     (z-sort-p :initform t :initarg :z-sort-p :accessor z-sort-p
               :documentation "When non-nil, draw objects in correct Z-order."
               :type symbol)
     (selection :initform nil)
     (buffer-name :initform "*untitled*"
                  :accessor buffer-name
                  :initarg :buffer-name
                  :type string)
     (variables :initform nil :accessor variables :initarg :variables)
     (clip-rectangle :initform nil :accessor clip-rectangle :initarg :clip-rectangle)
     (point :initform nil)
     (modified-p :initform nil)
     (redraw-cursor :initform t)
     (followed-object :initform nil)
     (background-image :initform nil :accessor background-image :initarg nil :type optional-string)
     (background-color :initform nil :accessor background-color :initarg nil :type optional-string)
     (x :initform 0)
     (y :initform 0)
     (paused :initform nil :accessor paused-p :initarg :paused-p)
     (height :initform 256 :type number)
     (width :initform 256 :type number)
     (depth :initform *z-far*)
     (layered :initform nil)
     (field-of-view :initform *field-of-view*)
     (was-key-repeat-p :initform nil)
     ;; viewing window 
     (window-x :initform 0) ;; :accessor window-x :initarg :window-x)
     (window-y :initform 0) ;; :accessor window-y :initarg :window-y)
     (window-z :initform 0) ;; :accessor window-z :initarg :window-z)
     (window-x0 :initform nil) ;; :accessor window-x0 :initarg :window-x0)
     (window-y0 :initform nil) ;; :accessor window-y0 :initarg :window-y0)
     (window-z0 :initform nil) ;; :accessor window-z0 :initarg :window-z0)
     (horizontal-scrolling-margin :initform 1/4 :type number
                                  :accessor horizontal-scrolling-margin
                                  :initarg :horizontal-scrolling-margin)
     (vertical-scrolling-margin :initform 1/4 :type number
                                :accessor vertical-scrolling-margin
                                :initarg :vertical-scrolling-margin)
     (window-scrolling-speed :initform 5 :type number
                             :accessor window-scrolling-speed
                             :initarg :window-scrolling-speed)
     (window-scale-x :initform 1 :accessor window-scale-x :initarg :window-scale-x)
     (window-scale-y :initform 1 :accessor window-scale-y :initarg :window-scale-y)
     (window-scale-z :initform 1 :accessor window-scale-z :initarg :window-scale-z)
     (projection-mode :initform :orthographic)
     (default-events :initform nil)
     ;; prototype control
     (field-collection-type :initform :hash)
     ;; rectangle-select
     (region :initform nil)
     (region-start :initform nil)
     ;; shell active?
     (shell-p :initform nil :accessor shell-p)
     ;; dragging info
     (already-failed :initform nil)
     (drag :initform nil)
     (drag-button :initform nil)
     (hover :initform nil)
     (highlight :initform nil)
     (ghost :initform nil)
     (focused-block :initform nil)
     (last-focus :initform nil)
     (click-start :initform nil)
     (click-start-block :initform nil)
     (drag-origin :initform nil)
     (object-p :initform nil)
     (drag-start :initform nil)
     (drag-offset :initform nil)))

Render a buffer with clipping

(defun enable-clipping ()
  (gl:enable :scissor-test))

(defun disable-clipping ()
  (gl:disable :scissor-test))

(defun set-clip-rectangle (x y width height)
  (gl:scissor x y width height))

(defmethod clip ((buffer buffer) &rest args)
  (setf (clip-rectangle buffer) args))

(defmethod clipped-p ((buffer buffer))
  (not (null (clip-rectangle buffer))))

Initialization

  (defmethod ensure-unique-buffer-name ((buffer buffer))
    (setf (buffer-name buffer) (uniquify-buffer-name (buffer-name buffer))))

  (defmethod install-shell-keybindings ((self buffer))
    (bind-event self '(:f1) 'show-help-command)
    (bind-event self '(:h :control) 'show-help-command)
    (bind-event self '(:c :control) 'edit-copy)
    (bind-event self '(:x :control) 'edit-cut)
    (bind-event self '(:v :control) 'edit-paste)
    (bind-event self '(:v :shift :control) 'paste-at-pointer)
    (bind-event self '(:tab) 'tab)
    (bind-event self '(:tab :control) 'backtab)
    (bind-event self '(:g :control) 'close-shell)
    (bind-event self '(:escape) 'close-shell)
    (bind-event self '(:x :alt) 'open-shell))

  (defmethod initialize-instance :after ((self buffer) &key)
    (ensure-unique-buffer-name self)
    (register-buffer self)
    (with-shell 
      (install-shell-keybindings self)))

  (defmethod emptyp ((self buffer))
    (with-slots (objects) self
      (or (null objects)
          (zerop (hash-table-count objects)))))

Buffer resize hook

(defun resize-current-buffer-to-window ()
  (resize (current-buffer) *screen-width* *screen-height*))

(add-hook '*resize-hook* #'resize-current-buffer-to-window)

Buffers can't have halos or be selected

(defmethod make-halo :around ((self buffer))
  (when (clipped-p self)
    (call-next-method)))
      
(defmethod select :around ((self buffer))
  (when (clipped-p self)
    (call-next-method)))

(defmethod unselect :around ((self buffer))
  (when (clipped-p self)
    (call-next-method)))

Pausing the action

  (defmethod pause ((buffer buffer))
    (setf (paused-p buffer) t))

  (defmethod play ((buffer buffer))
    (setf (paused-p buffer) nil))

Opening and closing the shell

See also "Command shell" below.

  (defmethod open-shell ((self buffer))
    (with-shell
        ;; (adopt self *shell*)
        (when (null *modeline-status-string*)
          (show-status "Welcome to Xelf. Press <F1> for help, or <Alt-X> to enter the command line."))
      (setf (shell-p self) t)
      (with-slots (last-focus focused-block) self
        (setf last-focus focused-block))
      (when (shell-prompt)
        (focus-on self (shell-prompt)))))

  (defmethod close-shell ((self buffer))
    (with-shell
        (setf (shell-p self) nil)
      (with-slots (last-focus focused-block selection) self
        (when *menubar* (close-menus *menubar*))
        (focus-on self last-focus)
        (setf last-focus nil)
        (setf selection nil))))

Showing a help box

(defun show-help ()
  (let ((help (make-instance 'text :text *help-text*)))
    (add-node (current-buffer) help (window-origin-x) (window-origin-y))
    (layout help)
    (center help)
    (align-to-pixels help)
    (bring-to-front help)))

(defmethod show-help-command ((self buffer))
  (show-help))

Visiting buffers

Here we make sure that any hanging menus are closed after switching buffers.

(defmethod visit ((buffer buffer))
  (when (shell-p buffer)
    (close-menus *menubar*)))

Handling events

(defmethod handle-event ((self buffer) event)
  (or (call-next-method)
      (with-slots (cursor selection command-line buffer quadtree focused-block) self
        (with-buffer self
          (prog1 t 
            (with-quadtree quadtree
              (let ((node (cond
                            ;; we're focused. send the event there
                            (focused-block
                             (when (xelfp focused-block) focused-block))
                            ;; only one block selected. use that.
                            ((= 1 (length selection))
                             (first selection))
                            ;; fall back to command-line
                            (t (with-shell (shell-prompt))))))
                (when (find-object node :noerror)
                  (handle-event (find-object node) event)))))))))

Capturing ESCAPE key to exit shell

When a game's BUFFER subclass has bound the ESCAPE key, we want to trap that to close the shell in the case that it is open.

(defmethod handle-event :around ((self buffer) event)
  (if (and (eq :escape (first (first event)))
           (shell-p self))
      (close-shell self)
      (call-next-method)))

Finding and indexing buffers by name

(defvar *buffers* nil)

(defun initialize-buffers ()
  (setf *buffers* 
        (make-hash-table :test 'equal)))

(defparameter *buffer-delimiter* #\*)

(defun special-buffer-name-p (name)
  (position *buffer-delimiter* name))
(defun register-buffer (buffer)
  (when (null *buffers*)
    (initialize-buffers))
  (prog1 t
    (setf (gethash (buffer-name buffer)
                   *buffers*)
          buffer)))
    
(defun find-buffer (name &key create class noerror)
  (find-object 
   (or (gethash name *buffers*)
       (if create
           (let ((buffer (make-instance (or class 'buffer) :buffer-name name)))
             (prog1 buffer (register-buffer buffer)))
           (unless noerror
             (error "Cannot find buffer ~S" name))))))
  
(defun unregister-buffer (name)
  (remhash name *buffers*))

(defun kill-buffer (name)
  (destroy (find-buffer name))
  (unregister-buffer name))

Handling buffer names

  (defun uniquify-buffer-name (name)
      (let ((n 1)
            (name0 name))
      (block naming
        (loop while name0 do
          (if (find-buffer name0 :noerror t)
              (setf name0 (format nil "~A<~S>" name n)
                    n (1+ n))
              (return-from naming name0))))))

  (defun make-buffer-name (name)
    (uniquify-buffer-name (or name "*untitled*")))

  (defmethod rename-buffer ((self buffer) name)
    (assert (stringp name))
    (setf (buffer-name self) name)
    (ensure-unique-buffer-name self)
    (register-buffer self))

Buffers associated with a file

  (defun safe-file-name-string (string)
    (substitute #\- #\Space (strip-asterisks string)))

  (defmethod buffer-file-name ((self buffer))
    (when (slot-value self 'buffer-name)
      (safe-file-name-string (concatenate 'string (slot-value self 'buffer-name) ".xelf"))))

Modification flag for editing

When a buffer has been modified in the editor since last saving, it is marked as modified.

  (defmethod set-modified-p ((self buffer) &optional (value t))
    (setf (slot-value self 'modified-p) value))

  (defun buffer-modified-p (&optional (buffer (current-buffer)))
    (slot-value buffer 'modified-p))

The active region

A rectangle can be designated as the editor's Region.

  (defmethod begin-region ((self buffer))
    (setf (slot-value self 'region-start) (list (window-pointer-x) (window-pointer-y))))

  (defmethod update-region ((self buffer))
    (when (slot-value self 'region-start)
      (let ((x (window-pointer-x))
            (y (window-pointer-y)))
        (destructuring-bind (x0 y0) (slot-value self 'region-start)
          ;; always normalize it
          (setf (slot-value self 'region)
                (list (min x x0)
                      (min y y0)
                      (abs (- x x0))
                      (abs (- y y0))))))))

  (defmethod end-region ((self buffer))
    (setf (slot-value self 'region-start) nil))
        
  (defun flash (&optional (divisor 4))
    (let ((factor (case *frame-rate*
                     (30 1)
                     (60 1/2))))
      (sin (* (/ *updates* divisor)
              (or factor 1)))))

  (defmethod draw-region ((self buffer))
    (when (consp (slot-value self 'region))
      (destructuring-bind (x y width height) (slot-value self 'region)
        (draw-box x y width height :color "cyan" :alpha (max 0.2 (+ 0.1 (flash 6)))))))

  (defmethod clear-region ((self buffer))
    (setf (slot-value self 'region) nil (slot-value self 'region-start) nil))

The selection

The Selection is a list of the currently selected objects.

  (defmethod get-selection ((self buffer))
    (let ((all (append (get-nodes self) (slot-value self 'inputs))))
     (remove-if-not #'selected-p all)))

  (defmethod draw :after ((node node))
    (when (selected-p node)
      (with-slots (x y width height) node
        (draw-box x y width height :color "cyan" :alpha (max 0.2 (+ 0.2 (flash 3)))))))

  (defun selection ()
    (get-selection (current-buffer)))

  (defun selected-object ()
    (let ((sel (selection)))
      (when (consp sel))
        (first sel)))

  (defun clear-selection ()
    (clear-halos (current-buffer))
    (do-nodes (node (current-buffer))
      (unselect node))
    nil)

  (defun select-all ()
    (clear-halos (current-buffer))
    (do-nodes (node (current-buffer))
      (select node)))

  (defun invert-selection ()
    (clear-halos (current-buffer))
    (do-nodes (node (current-buffer))
      (toggle-selected node)))

  (defmethod destroy-selection ((self buffer))
    (prog1 nil (mapc #'destroy (selection))))

Selecting the region

Find out which objects intersect the region, and select them.

  (defmethod region-objects ((self buffer))
    (when (slot-value self 'region)
      (destructuring-bind (x y width height) (slot-value self 'region)
        (loop for thing being the hash-values of (slot-value self 'objects)
              when (colliding-with-rectangle-p (find-object thing) y x width height)
                collect (find-object thing)))))

  (defmethod select-region ((self buffer))
    (when (slot-value self 'region)
      (clear-selection)
      (dolist (each (region-objects self))
        (select each))
      (clear-region self)))

Destroying the region

Destroy the objects intersecting the region, without selecting them.

  (defmethod destroy-region ((self buffer))
    (when (slot-value self 'region)
      (clear-selection)
      (prog1 nil
        (dolist (each (region-objects self))
          (destroy each)))))

Z-order sorting

  (defun %z (x) (or (slot-value x 'z) 0))

  (defun z-sort (objects)
    (sort objects #'< :key #'%z))

  (defmethod maximum-z-value ((self buffer))
    (if (not (xelfp (current-buffer)))
        0
        (let ((z 0))
          (loop for object being the hash-values in (slot-value (current-buffer) 'objects)
                do (when (find-object object t)
                     (setf z (max z (%z (find-object object))))))
          z)))

Smoothly scrolling the buffer's window

  (defun window-origin-y () (if (current-buffer) (slot-value (current-buffer) 'window-y) 0))
  (defun window-origin-x () (if (current-buffer) (slot-value (current-buffer) 'window-x) 0))

  (defmethod window-bounding-box ((self buffer))
    (values (cfloat (slot-value self 'window-y))
            (cfloat (slot-value self 'window-x))
            (cfloat (+ (slot-value self 'window-x) *nominal-screen-width*))
            (cfloat (+ (slot-value self 'window-y) *nominal-screen-height*))))

  (defmethod move-window-to ((self buffer) x y &optional z)
    (setf (slot-value self 'window-x) x 
          (slot-value self 'window-y) y)
    (when z (setf (slot-value self 'window-z) z)))

  (defmethod move-window-to-node ((self buffer) object)
    (multiple-value-bind (top left right bottom) 
        (bounding-box object)
      (declare (ignore right bottom))
      (move-window-to 
       self 
       (max 0 (- left (/ *gl-screen-width* 2)))
       (max 0 (- top (/ *gl-screen-width* 2))))))

  (defmethod move-window-to-point ((self buffer))
    (when (slot-value self 'point)
      (move-window-to-node self (slot-value self 'point))))

  (defmethod snap-window-to-node ((self buffer) object)
    (multiple-value-bind (top left right bottom) 
        (bounding-box (find-object object))
      (declare (ignore right bottom))
      (move-window-to 
       self 
       (min (- (slot-value self 'width) *gl-screen-width*)
            (max 0 (- left (/ *gl-screen-width* 2))))
       (min (- (slot-value self 'height) *gl-screen-height*)
            (max 0 (- top (/ *gl-screen-width* 2)))))))

  (defmethod snap-window-to-point ((self buffer))
    (when (slot-value self 'point)
      (snap-window-to-node self (slot-value self 'point))))

  (defmethod move-window ((self buffer) dx dy &optional dz)
    (incf (slot-value self 'window-x) dx)
    (incf (slot-value self 'window-y) dy)
    (when dz (setf (slot-value self 'window-dz) dz)))

  (defmethod glide-window-to ((self buffer) x y &optional z)
    (setf (slot-value self 'window-x0) x)
    (setf (slot-value self 'window-y0) y)
    (when z (setf (slot-value self 'window-z) z)))

  (defmethod glide-window-to-node ((self buffer) object)
    (multiple-value-bind (top left right bottom) 
        (bounding-box (find-object object))
      (declare (ignore right bottom))
      (glide-window-to 
       self 
       (max 0 (- left (/ *gl-screen-width* 2)))
       (max 0 (- top (/ *gl-screen-width* 2))))))

  (defmethod glide-window-to-point ((self buffer))
    (when (slot-value self 'point)
      (glide-window-to-node self (slot-value self 'point))))

  (defmethod follow-with-camera ((self buffer) thing)
    (assert (or (null thing) (xelfp thing)))
    (snap-window-to-node self thing)
    (setf (slot-value self 'followed-object) thing)
    (glide-window-to-node self (slot-value self 'followed-object)))

  (defmethod stop-following ((self buffer))
    (setf (slot-value self 'followed-object) nil))

  (defmethod glide-follow ((self buffer) object)
    (with-slots (window-x window-y width height) self
      (let ((margin-x (* (slot-value self 'horizontal-scrolling-margin) *gl-screen-width*))
            (margin-y (* (slot-value self 'vertical-scrolling-margin) *gl-screen-height*))
            (object-x (slot-value object 'x))
            (object-y (slot-value object 'y)))
      ;; are we outside the "comfort zone"?
      (if (or 
           ;; too far left
           (> (+ window-x margin-x) 
              object-x)
           ;; too far right
           (> object-x
              (- (+ window-x *gl-screen-width*)
                 margin-x))
           ;; too far up
           (> (+ window-y margin-y) 
              object-y)
           ;; too far down 
           (> object-y 
              (- (+ window-y *gl-screen-height*)
                 margin-y)))
          ;; yes. recenter.
          (glide-window-to self
                           (max 0
                                (min (- width *gl-screen-width*)
                                     (- object-x 
                                        (truncate (/ *gl-screen-width* 2)))))
                           (max 0 
                                (min (- height *gl-screen-height*)
                                     (- object-y 
                                        (truncate (/ *gl-screen-height* 2))))))))))

  (defmethod update-window-glide ((self buffer))
    (with-slots (window-x window-x0 window-y window-y0 window-scrolling-speed) self
      (labels ((nearby (a b)
                 (> window-scrolling-speed (abs (- a b))))
               (jump (a b)
                 (if (< a b) window-scrolling-speed (- window-scrolling-speed))))
        (when (and window-x0 window-y0)
          (if (nearby window-x window-x0)
              (setf window-x0 nil)
              (incf window-x (jump window-x window-x0)))
          (if (nearby window-y window-y0)
              (setf window-y0 nil)
              (incf window-y (jump window-y window-y0)))))))

  (defmethod update-window-movement ((self buffer))
    (with-slots (followed-object drag point) self
      (let ((thing (or followed-object
                       (when (holding-shift) drag)
                       point)))
        (when (xelfp thing)
          (glide-follow self thing))
          (update-window-glide self))))

  (defmethod scale-window ((self buffer) &optional (window-scale-x 1.0) (window-scale-y 1.0))
    (setf (slot-value self 'window-scale-x) window-scale-x)
    (setf (slot-value self 'window-scale-y) window-scale-y))

Window projection for OpenGL

  (defmethod project-window ((self buffer))
    (ecase (slot-value self 'projection-mode) 
      (:orthographic (project-orthographically (slot-value self 'layered)))
      (:perspective (project-with-perspective :field-of-view (slot-value self 'field-of-view) :depth (slot-value self 'depth))))
    (transform-window :x (slot-value self 'window-x) :y (slot-value self 'window-y) :z (slot-value self 'window-z) 
                      :scale-x (slot-value self 'window-scale-x) 
                      :scale-y (slot-value self 'window-scale-y)
                      :scale-z (slot-value self 'window-scale-z)))

Buffer-local variables

  (defmethod initialize-variables-maybe ((self buffer)) 
    (when (null (slot-value self 'variables)) 
      (setf (slot-value self 'variables) (make-hash-table :test 'equal))
      (setf (gethash "BUFFER" (slot-value self 'variables)) self)))

  (defmethod set-variable ((self buffer) var value)
    (initialize-variables-maybe self)
    (setf (gethash var (slot-value self 'variables)) value))

  (defmethod get-variable ((self buffer) var)
    (initialize-variables-maybe self)
    (gethash var (slot-value self 'variables)))

  (defun buffer-variable (var-name)
    (get-variable (current-buffer) var-name))

  (defun set-buffer-variable (var-name value)
    (set-variable (current-buffer) var-name value))

  (defsetf buffer-variable set-buffer-variable)

  (defmacro with-buffer-variables (vars &rest body)
    (labels ((make-clause (sym)
               `(,sym (buffer-variable ,(make-keyword sym)))))
      (let* ((symbols (mapcar #'make-non-keyword vars))
             (clauses (mapcar #'make-clause symbols)))
        `(symbol-macrolet ,clauses ,@body))))

Object layer   obsolete

This section is obsolete and will be removed in a future version.

   (defvar *object-placement-capture-hook*)

  (defmethod drop-node ((self buffer) object &optional x y z)
    (add-node self object x y z))

  (defmethod finish-drag ((self buffer)) nil)

  (defmethod drop-selection ((self buffer))
    (dolist (each (get-selection self))
      (drop-node self each)))

  (defmethod destroy-block ((self buffer) object)
    (remhash (the simple-string (find-uuid object)) (slot-value self 'objects)))

Buffer point   obsolete

This section is obsolete and will be removed in the future.

  (defmethod get-point ((self buffer))
    (find-object (slot-value self 'point)))

  (defun point ()
    (find-object (get-point (current-buffer))))

  (defun pointp (thing)
    (object-eq thing (point)))

  (defmethod set-point ((self buffer) point)
    (setf (slot-value self 'point) (find-uuid point)))

Drawing the buffer

(defmethod grab-focus ((self buffer)))

(defmethod after-draw-object ((self buffer) object))

(defmethod draw :around ((self buffer))
  (if (not (clipped-p self))
      (progn (project-window self)
             (call-next-method))
      (progn 
        (apply #'set-clip-rectangle (clip-rectangle self))
        (enable-clipping)
        (gl:matrix-mode :projection)
        (destructuring-bind (x y w h) (clip-rectangle self)
          (gl:translate x y 0))
        (call-next-method)
        (gl:matrix-mode :projection)
        (destructuring-bind (x y w h) (clip-rectangle self)
          (gl:translate (- 0 x) (- 0 y) 0))
        (disable-clipping))))

(defmethod visit :after ((self buffer))
  (clip self))

(defmethod bounding-box :around ((self buffer))
  (if (clipped-p self)
      (destructuring-bind (x y width height) (clip-rectangle self)
        (values y x (+ x width) (+ y height)))
      (call-next-method)))

(defmethod add-node :after ((parent buffer) (child buffer) &optional x y z)
  (clip child 0 0 256 256))

(defmethod move-to :after ((child buffer) x y &optional z)
  (when (clipped-p child)
    (setf (first (clip-rectangle child)) x)
    (setf (second (clip-rectangle child)) y)))

 (defmethod draw-object-layer ((self buffer))
    (multiple-value-bind (top left right bottom) (window-bounding-box self)
      (loop for object being the hash-keys of (slot-value self 'objects) do
        ;; only draw onscreen objects
        (when (colliding-with-bounding-box-p (find-object object) top left right bottom)
          (draw (find-object object))))))

  (defmethod draw-object-layer-z-sorted ((self buffer))
    (with-slots (zbuffer) self
      (setf (fill-pointer zbuffer) 0)
      (multiple-value-bind (top left right bottom) (window-bounding-box self)
        (loop for object being the hash-keys of (slot-value self 'objects) do
             (when (colliding-with-bounding-box-p (find-object object) top left right bottom)
               (vector-push-extend (find-object object) zbuffer))))
      (setf zbuffer (sort zbuffer #'< :key #'%z))
      (map nil #'draw zbuffer)))

  (defmethod draw ((self buffer))
    (with-buffer self
      (with-slots (objects width focused-block height drag hover ghost inputs
                                  background-image background-color) self
        ;; draw background 
        (if background-image
            (draw-image background-image 0 0 :height height :width width)
            (when background-color
              (draw-box 0 0 width height
                        :color background-color)))
        ;; now draw the object layer
        (if (or (shell-p self)
                (z-sort-p self))
            (draw-object-layer-z-sorted self)
            (draw-object-layer self))
        (with-shell 
            (draw-region self))
        (mapc #'draw inputs)
        (when drag 
          (layout drag)
          (when (slot-value drag 'parent)
            (draw-ghost ghost))
          ;; also draw any hover-over highlights 
          ;; on objects you might drop stuff onto
          (when hover 
            (draw-hover (find-object hover)))
          (draw drag))
        (when focused-block
          (when (find-object focused-block :noerror)
            (draw-focus (find-object focused-block)))))))

Automatic resizing to an image

  (defmethod resize-to-background-image ((self buffer))
    (when (slot-value self 'background-image)
      (resize self (image-width (slot-value self 'background-image)) (image-height (slot-value self 'background-image)))))

  (defmethod reset ((self buffer)))

Trimming empty space

  (defmethod trim ((self buffer))
    (prog1 self
      (let ((objects (get-nodes self)))
        (when objects
          (with-slots (quadtree height width) self
            ;; adjust bounding box so that all objects have positive coordinates
            (multiple-value-bind (top left right bottom)
                (find-bounding-box objects)
              ;; resize the buffer so that everything just fits
              (setf (slot-value self 'x) 0 (slot-value self 'y) 0)
              (resize self (- right left) (- bottom top))
              ;; move all the objects
              (dolist (object (mapcar #'find-object objects))
                (with-slots (x y) object
                  (with-quadtree quadtree
                    (move-to object (- x left) (- y top)))))))))))

  (defmethod trim-conservatively ((self buffer))
    (prog1 self
      (let ((objects (get-nodes self)))
        (when objects
          (multiple-value-bind (top left right bottom)
              (find-bounding-box objects)
            (resize self right bottom))))))

Copy, cut, and paste

(defvar *clipboard* nil)

(defun initialize-clipboard-maybe (&optional force)
  (when (or force (null *clipboard*))
    (setf *clipboard* (make-instance 'buffer))))

(defun clear-clipboard ()
  (initialize-clipboard-maybe :force))

(defun clipboard ()
  (initialize-clipboard-maybe)
  *clipboard*)

(defun make-clipboard ()
  (let ((clipboard (make-instance 'buffer :buffer-name "*clipboard*")))
  (register-buffer clipboard)
  clipboard))
  (defun copy (&optional (self (current-buffer)) objects0)
    (let ((objects (or objects0 (get-selection self))))
      (clear-halos self)
      (when objects
        (destroy-maybe *clipboard*)
        (setf *clipboard* (make-clipboard))
        (dolist (object objects)
          (let ((duplicate (duplicate-safely object)))
            ;; don't keep references to anything in the (current-buffer)
            (clear-buffer-data duplicate)
            (add-node *clipboard* duplicate))))))

  (defun cut (&optional (self (current-buffer)) objects0)
    (with-buffer self
      (let ((objects (or objects0 (get-selection self))))
        (when objects
          (clear-halos self)
          (destroy-maybe *clipboard*)
          (setf *clipboard* (make-clipboard))
          (dolist (object objects)
            (with-quadtree (slot-value self 'quadtree)
              (remove-node-maybe self object))
            (add-node *clipboard* object))))))

  (defun paste-from (destination source &optional (dx 0) (dy 0))
    "Copy the objects in SOURCE into DESTINATION with offset DX,DY."
    (let ((count 0))
      (dolist (object (mapcar #'duplicate-safely (get-nodes (find-object source))))
        (incf count)
        (with-slots (x y) object
          (clear-buffer-data object)
          (with-buffer destination
            (with-quadtree (quadtree destination)
              (add-node destination object)
              (move-to object (+ x dx) (+ y dy))
              (after-paste object)))))
      count))
  
  (defun paste-into (self source &optional (dx 0) (dy 0))
    (paste-from self source dx dy)
    (destroy (find-object source)))

  (defun paste (&optional (self (current-buffer)) (dx 0) (dy 0))
    (if (null *clipboard*)
        (progn (setf *clipboard* (make-clipboard))
               (notify "Clipboard is null."))
        (if (null (get-nodes *clipboard*))
            (notify "Clipboard is empty.")
            (paste-from self *clipboard* dx dy))))
  
  (defun paste-at-pointer (&optional (self (current-buffer)))
    (let ((temp (make-instance 'buffer)))
      (paste-from temp *clipboard*)
      (trim temp)
      (paste-from self temp
                  (window-pointer-x)
                  (window-pointer-y))))

  (defmethod paste-here ((self buffer))
    (paste-at-pointer self))

  (defmethod edit-cut ((self buffer))
    (cut))

  (defmethod edit-paste ((self buffer))
    (paste))

  (defmethod edit-copy ((self buffer))
    (copy))

Destroying buffers

  (defmethod destroy ((self buffer))
    (with-slots (objects quadtree) self
      (loop for thing being the hash-keys of objects do
        (with-quadtree quadtree
          (when (xelfp thing)
            (destroy (find-object thing))))
        (remhash (the simple-string thing) objects))
      (mapc #'destroy-maybe (slot-value self 'tasks))
      (setf (slot-value self 'quadtree) nil)
      (unregister-buffer self)
      (call-next-method self)))

Combining buffers

  (defmethod adjust-bounding-box-maybe ((self buffer))
    (if (emptyp self)
        self
        (let ((objects-bounding-box 
                (mapcar #'cfloat
                        (multiple-value-list 
                         (find-bounding-box (get-nodes self))))))
          (destructuring-bind (top left right bottom)
              (mapcar #'cfloat objects-bounding-box)
            ;; are all the objects inside the existing box?
            (prog1 self
              (unless (bounding-box-contains 
                       (mapcar #'cfloat (multiple-value-list (bounding-box self)))
                       objects-bounding-box)
                (resize self right bottom)))))))

  (defmacro with-new-buffer (&body body)
    "Evaluate the BODY forms in a new buffer."
    `(with-buffer (make-instance 'buffer)
       ,@body
       (adjust-bounding-box-maybe (current-buffer))))

  (defun translate (buffer dx dy)
    (when buffer
      (assert (and (numberp dx) (numberp dy)))
      (with-new-buffer 
        (paste-from (current-buffer) buffer dx dy)
        (destroy buffer)
        (current-buffer))))

  (defun compose (buffer1 buffer2)
    "Return a new buffer containing all the objects from both BUFFER1
  and BUFFER2. The original buffers are destroyed."
    (with-new-buffer 
      (when (and buffer1 buffer2)
        (let* ((nodes-1 (get-nodes buffer1))
               (nodes-2 (get-nodes buffer2))
               (count-1 (length nodes-1))
               (count-2 (length nodes-2))
               (all-nodes (append nodes-1 nodes-2))
               (count-all (length all-nodes)))
          (assert (not (and (zerop count-1) (zerop count-2))))
          (assert (= count-all (+ count-1 count-2)))
          (dolist (object all-nodes)
            (add-node (current-buffer) 
                      (duplicate-safely object)))
          (destroy buffer1)
          (destroy buffer2)
          (assert (= count-all (length (get-nodes (current-buffer)))))
          (current-buffer)))))

  (defmethod scale ((self buffer) sx &optional sy)
    (let ((objects (get-nodes self)))
      (dolist (object objects)
        (with-slots (x y width height) object
          (move-to object (* x sx) (* y (or sy sx)))
          (resize object (* width sx) (* height (or sy sx))))))
    (trim self))

  (defun vertical-extent (buffer)
    (if (or (null buffer)
            (emptyp buffer))
        0
        (multiple-value-bind (top left right bottom)
            (bounding-box buffer)
          (declare (ignore left right))
          (- bottom top))))

  (defun horizontal-extent (buffer)
    (if (or (null buffer)
            (emptyp buffer))
        0
        (multiple-value-bind (top left right bottom)
            (bounding-box buffer)
          (declare (ignore top bottom))
          (- right left))))
  
  (defun compose-below (&optional buffer1 buffer2)
    "Return a new buffer containing all the objects from BUFFER1 and
  BUFFER2, with BUFFER2's objects pasted below those of BUFFER1. The
  original buffers are destroyed."
    (when (and buffer1 buffer2)
      (compose buffer1
               (translate buffer2
                          0 
                          (slot-value buffer1 'height)))))

  (defun compose-beside (&optional buffer1 buffer2)
    "Return a new buffer containing all the objects from BUFFER1 and
  BUFFER2, with BUFFER2's objects pasted beside those of BUFFER1. The
  original buffers are destroyed."
    (when (and buffer1 buffer2)
      (compose buffer1 
               (translate buffer2
                          (slot-value buffer1 'width)
                          0))))

  (defun stack-vertically (&rest buffers)
    "Combine BUFFERS into a single buffer, with each buffer stacked vertically."
    (reduce #'compose-below buffers :initial-value (with-new-buffer)))

  (defun stack-horizontally (&rest buffers)
    "Combine BUFFERS into a single buffer, with each buffer stacked horizontally."
    (reduce #'compose-beside buffers :initial-value (with-new-buffer)))

  (defmethod flip-horizontally ((self buffer))
    (let ((objects (get-nodes self)))
      (dolist (object objects)
        (with-slots (x y) object
          (move-to object (- x) y))))
    ;; get rid of negative coordinates
    (trim self))

  (defmethod flip-vertically ((self buffer))
    (let ((objects (get-nodes self)))
      (dolist (object objects)
        (with-slots (x y) object
          (move-to object x (- y)))))
    (trim self))

  (defmethod mirror-horizontally ((self buffer))
    (stack-horizontally 
     self 
     (flip-horizontally (duplicate self))))

  (defmethod mirror-vertically ((self buffer))
    (stack-vertically 
     self 
     (flip-vertically (duplicate self))))

  (defun with-border (border buffer)
    "Return a new buffer with the objects from BUFFER
  surrounded by a border of thickness BORDER units."
    (with-slots (height width) buffer
      (with-new-buffer 
        (paste-from (current-buffer) (find-object buffer) border border)
        (destroy (find-object buffer))
        (resize (current-buffer)
                (+ width (* border 2))
                (+ height (* border 2))))))

System update triggers

  (defmethod clear-deleted-objects ((self buffer))
    (loop for object being the hash-keys of (slot-value self 'objects) 
          do (unless (xelfp object) (remhash (the simple-string object) (slot-value self 'objects)))))

  (defmethod update :before ((buffer buffer))
    (update-window-movement buffer)
    (let ((selection (selection)))
      (when selection (mapc #'layout selection))))

  (defmethod update :after ((buffer buffer))
    (when (and (not (clipped-p buffer))
               *shell* 
               (shell-p buffer))
      (layout *shell*)
      (update *shell*)))
  (defmethod evaluate ((self buffer))
    (prog1 self
      (with-buffer self
        (mapc #'evaluate (slot-value self 'inputs)))))

  (defmethod layout ((self buffer))
    ;; take over the entire GL window
    (with-buffer self
      ;; (setf (slot-value self 'x) 0 (slot-value self 'y) 0)
            ;; (slot-value self 'width) *gl-screen-width* 
            ;; (slot-value self 'height) *gl-screen-height*)
      (mapc #'layout (slot-value self 'inputs))))

Hit testing

  (defmethod hit ((self buffer) x y)
    ;; return self no matter where mouse is, so that we get to process
    ;; all the events.
    (declare (ignore x y))
    self)

  (defmethod get-objects ((self buffer))
    (loop for object being the hash-values in (slot-value self 'objects)
       when (xelfp object) collect (find-object object)))

  (defmethod z-sorted-objects ((self buffer))
    (nreverse (z-sort (get-objects self))))

  (defmethod hit-inputs ((self buffer) x y)
    "Recursively search the blocks in this buffer for a block
  intersecting the point X,Y. We have to search the top-level blocks
  starting at the end of `%INPUTS' and going backward, because the
  blocks are drawn in list order (i.e. the topmost blocks for
  mousing-over are at the end of the list.) The return value is the
  block found, or nil if none is found."
    ;; remove any dead objects
    (setf (slot-value self 'inputs) (remove-if-not #'xelfp (slot-value self 'inputs)))
    (with-buffer self 
      (with-quadtree (slot-value self 'quadtree)
        (labels ((try (b)
                   (when b
                     (hit (find-object b) x y))))
          ;; check shell and inputs first
          (let* ((object-p nil)
                 (result 
                   (or 
                    (let ((parent 
                           (find-if #'try 
                                    (if (shell-p self)
                                        (with-shell (append (slot-value self 'inputs)
                                                            (list *shell* *menubar*)))
                                        (slot-value self 'inputs))  
                                    :from-end t)))
                      (when parent
                        (try parent)))
                    ;; try buffer objects
                    (block trying
                      (dolist (object (z-sorted-objects self))
                        (let ((result (try object)))
                          (when result 
                            (setf object-p t)
                            (return-from trying result))))))))
            (values result object-p))))))
  
  (defparameter *minimum-drag-distance* 6)
  
  (defmethod clear-halos ((self buffer))
    (mapc #'destroy-halo (get-nodes self)))

Tabbing between focused nodes

(defmethod find-tab-parent ((self node))
  (parent self))

(defmethod find-tab-proxy ((self node))
  self)

(defmethod tab ((self buffer) &optional backward)
  (with-slots (focused-block) self
    (when focused-block
      (assert (xelfp focused-block))
      (let ((proxy (find-tab-proxy (find-object focused-block)))
            (parent (find-tab-parent (find-object focused-block))))
            (when (and proxy parent)
          (let ((index (position-within-parent proxy)))
            (when (numberp index)
              (focus-on self
                        (with-slots (inputs) parent
                          (nth (mod (+ index
                                       (if backward -1 1))
                                    (length inputs))
                               inputs))))))))))

(defmethod backtab ((self buffer))
  (tab self :backward))

Focus and dragging

  (defmethod focus-on ((self buffer) block &key (clear-selection t))
    ;; possible to pass nil
    (with-slots (focused-block) self
      (with-buffer self
        (let ((last-focus focused-block))
          (if (null block)
              (progn (when (xelfp last-focus) (lose-focus (find-object last-focus)))
                     (setf focused-block nil))
              ;; don't do this for same block
              (when (not (object-eq last-focus block))
                ;; there's going to be a new focused block. 
                ;; tell the current one it's no longer focused.
                (when (and clear-selection (xelfp last-focus))
                  (lose-focus (find-object last-focus)))
                ;; now set up the new focus (possibly nil)
                (setf focused-block (when (xelfp block)
                                      (find-uuid 
                                       (pick-focus (find-object block)))))
                ;; clean up if object destroyed itself after losing focus
                (when (and last-focus (not (xelfp last-focus)))
                  (setf last-focus nil))
                ;; now tell the block it has focus, but only if not the same
                (when (if last-focus 
                          (not (object-eq last-focus focused-block))
                          t)
                  (focus (find-object block)))))))))

  (defmethod begin-drag ((self buffer) mouse-x mouse-y block)
    (with-slots (drag drag-origin inputs drag-start ghost drag-offset) self
      (when (null ghost) (setf ghost (make-instance 'node)))
      (with-buffer self
        (setf drag (as-drag block mouse-x mouse-y))
        (setf drag-origin (find-parent drag))
        (when drag-origin
            ;; parent might produce a new object
          (unplug-from-parent block))
        (let ((dx (slot-value block 'x))
              (dy (slot-value block 'y))
              (dw (slot-value block 'width))
              (dh (slot-value block 'height)))
          (with-slots (x y width height) ghost
            ;; remember the relative mouse coordinates from the time the
            ;; user began dragging, so that the block being dragged is not
            ;; simply anchored with its top left corner located exactly at
            ;; the mouse pointer.
            (let ((x-offset (- mouse-x dx))
                  (y-offset (- mouse-y dy)))
              (when (null drag-start)
                (setf x dx y dy width dw height dh)
                (setf drag-start (cons dx dy))
                (setf drag-offset (cons x-offset y-offset)))))))))

  (defmethod drag-fail ((self buffer) x y object))

  (defmethod drag-maybe ((self buffer) x y)
    ;; require some actual mouse movement to initiate a drag
    (with-buffer self
      (with-slots (focused-block drag-button click-start click-start-block) self
        (when click-start
          (destructuring-bind (x1 . y1) click-start
            (when (and (xelfp focused-block) (xelfp click-start-block)
                     (> (distance x y x1 y1)
                        *minimum-drag-distance*))
                (if (can-pick (find-object click-start-block))
                    (let ((drag 
                            (if (and drag-button (= 3 drag-button))
                                ;; right-drag means "grab whole thing"
                                (topmost (find-object click-start-block))
                                (pick (find-object click-start-block)))))
                      (when drag 
                        (begin-drag self x y (find-object drag))
                        ;; clear click data
                        (setf click-start nil)
                        (setf click-start-block nil)))
                    ;; signal any failure to pick
                    (unless (slot-value self 'already-failed)
                      (setf (slot-value self 'already-failed) t)
                      (drag-fail self (find-object click-start-block)
                                 x y)))))))))

  (defmethod drag-candidate ((self buffer) drag x y)
    (declare (ignore drag))
    (assert (not (object-eq self drag)))
    (hit-inputs self x y))

  (defmethod handle-point-motion ((self buffer) mouse-x mouse-y)
    (with-slots (hover highlight click-start drag-offset quadtree
                         region-start region
                         drag-start drag) self
      (with-buffer self
        (when region-start
          (update-region self))
        (with-quadtree quadtree
          (setf hover nil)
          (drag-maybe self mouse-x mouse-y)
          (if drag
              ;; we're in a mouse drag.
              (destructuring-bind (ox . oy) drag-offset
                (let ((target-x (- mouse-x ox))
                      (target-y (- mouse-y oy)))
                  (let ((candidate (drag-candidate self drag target-x target-y)))
                    ;; obviously we dont want to plug a block into itself.
                    (setf hover (if (object-eq drag candidate) nil
                                    (find-uuid candidate)))
                    ;; keep moving along with the mouse
                    (drag drag target-x target-y))))
              ;; not dragging, just moving
              (progn
                (setf highlight (find-uuid (hit-inputs self mouse-x mouse-y)))))))))
      ;; (when (null highlight)
      ;; (when *shell*
      ;;   (with-buffer self (close-menus *shell*))))))))

  (defmethod press ((self buffer) x y &optional button)
    (with-buffer self
      (with-slots (click-start drag-button click-start-block
                                region-start region focused-block) self
        ;; region select
        (if (holding-shift)
            (begin-region self)
            ;; or, regular select.
            ;; now find what we're touching
            (progn
              (multiple-value-bind (block object-p)
                  (hit-inputs self x y)
                (setf (slot-value self 'object-p) object-p)
                (if (null block)
                    (focus-on self nil)
                    ;; (when *shell-open-p*
                    ;;  (exit-shell self)))
                    (progn 
                      (setf click-start (cons x y))
                      (setf click-start-block (find-uuid block))
                      (setf drag-button button)
                      ;; now focus; this might cause another block to be
                      ;; focused, as in the case of the Shell
                      (focus-on self (find-object block))))))))))

  (defmethod press :around ((self buffer) x y &optional buttom)
    (with-shell (call-next-method)))

  (defmethod clear-drag-data ((self buffer))
    (setf (slot-value self 'drag-start) nil
          (slot-value self 'drag-offset) nil
          (slot-value self 'object-p) nil
          (slot-value self 'drag-origin) nil
          (slot-value self 'drag-button) nil
          (slot-value self 'drag) nil
          (slot-value self 'hover) nil
          (slot-value self 'highlight) nil
          (slot-value self 'last-focus) nil
          (slot-value self 'click-start-block) nil
          (slot-value self 'click-start) nil))

  (defmethod release ((self buffer) x y &optional button)
    (with-buffer self
      (with-slots 
          (drag-offset drag-start hover drag quadtree click-start drag-button
                       region-start region click-start-block drag-origin already-failed
                       focused-block) self
        (setf already-failed nil)
        (end-region self)
        (select-region self)
        (if drag
            ;; we're dragging
            (destructuring-bind (x0 . y0) drag-offset
              (setf drag-button nil)
              (let ((drag-parent (get-parent drag))
                    (drop-x (- x x0))
                    (drop-y (- y y0)))
                (if (not (can-escape drag))
                    ;; put back in halo or wherever
                    (when drag-origin 
                          (add-node (find-object drag-origin) drag drop-x drop-y))
                    ;; ok, drop. where are we dropping?
                    (progn 
                      (if (and (xelfp hover) (will-accept (find-object hover) 
                                                  (find-object drag)))
                          ;; drop into container
                          (accept (find-object hover) (find-object drag))
                          ;; drop onto map
                          (with-quadtree quadtree
                            (add-node self drag drop-x drop-y)))
                      (finish-drag drag)))))
            ;;
            ;; we were clicking instead of dragging
            (progn
              ;; clicks that don't hit an object are sent to self
              ;; (if you hold shift, they are ALWAYS sent to buffer)
              (let ((it (if (holding-shift) self
                            (find-object (or focused-block self) :noerror))))
                (when (xelfp it)
                  (with-buffer self 
                    (cond
                      ;; DISABLED BELOW: right click and control click are equivalent
                      ((or (= button 3) nil)
                           ;; (and (holding-control) (= button 1)))
                       (alternate-tap it x y))
                      ;; scroll wheel (middle) click and shift click are equivalent
                      ((or (= button 2)
                           (and (holding-shift) (= button 1)))
                       (scroll-tap self x y))
                      ;; horizontal scrolling with shift-mousewheel
                      ((and (= button 4)
                            (holding-shift))
                       (scroll-left self))
                      ((and (= button 5)
                            (holding-shift))
                       (scroll-right self))
                      ;; vertical scrolling with mousewheel
                      ((= button 4)
                       (scroll-up self))
                      ((= button 5)
                       (scroll-down self))
                      ;; plain old click
                      (t 
                       (process-tap self it x y)))))
                ;;(select self focused-block))
                (setf click-start nil))))
        ;; clean up bookeeping
        (clear-drag-data self))))

  (defmethod process-tap ((self buffer) (tapped-node node) x y)
    (tap tapped-node x y))

  (defmethod release :around ((self buffer) x y &optional buttom)
    (with-shell (call-next-method)))

  (defmethod tap ((self buffer) x y) 
    (with-shell (when *menubar* (close-menus *menubar*))
      (let ((menus (find-instances self 'context-menu)))
        (mapc #'destroy menus))))

  (defmethod alternate-tap ((self buffer) x y)
    (show-context-menu self))

  (defmethod scroll-distance ((self buffer) direction) 40)

  (defmethod scroll-position ((self buffer) x y direction)
    (let ((distance (scroll-distance self direction)))
      (ecase direction
        (:up (values x (- y distance)))
        (:down (values x (+ y distance)))
        (:left (values (- x distance) y))
        (:right (values (+ x distance) y)))))

(defmethod scroll-tap ((self buffer) x y)
  (move-window-to self 0 0))

(defmethod scroll ((self buffer) direction)
  (multiple-value-bind (x y)
      (scroll-position self (window-origin-x) (window-origin-y) direction)
    (glide-window-to self x y)))

(defmethod scroll-up ((self buffer))
  (scroll self :up))

(defmethod scroll-down ((self buffer))
  (scroll self :down))

(defmethod scroll-left ((self buffer))
  (scroll self :left))

(defmethod scroll-right ((self buffer))
  (scroll self :right))

Basic help text

(defparameter *help-text*
  "Welcome to Xelf.

Left-click-and-drag to move objects. Click objects to select them.
Use Control-click to select multiple objects.

Right-click to open a \"halo\" menu with operation handles.  
\"X\" handle deletes objects. Lower right corner handle resizes
objects. Lambda handle executes objects.

Press <Alt-X> to enter Lisp commands, and <ESC> to quit the shell.

Copy: Control-C     Cut: Control-X    Paste: Control-V
Paste at pointer: Shift-Control-V
Toggle minibuffer view: F9    Pause/unpause: F12

See sidebar for more commands to try.
")

Indicator icons

The GUI handles that make up each "halo" use a special standard icon set included with Xelf. See also "Loading standard fonts and icons" above.

  (defparameter *active-indicator-color* "yellow")
  (defparameter *inactive-indicator-color* "gray70")

  (defun indicator-size () (* 0.37 (font-height *font*)))

  (defparameter *indicators* 
    '(:asterisk :bang :top-left-triangle :bottom-right-triangle
      :down-triangle-open :down-triangle-closed :copy :paste :cut
      :menu :collapse :move :resize :define :close))

  (defparameter *indicator-images* 
    '(:asterisk "asterisk"
      :bang "bang"
      :top-left-triangle "top-left-triangle-indicator"
      :down-triangle-open "down-triangle-open"
      :down-triangle-closed "down-triangle-closed"
      :menu "menu"
      :collapse "collapse"
      :move "move"
      :copy "copy"
      :cut "cut"
      :rotate "rotate"
      :paste "paste"
      :drop "downright"
      :pick-up "upleft"
      :resize "resize"
      :define "define" 
      :close "close"
      :bottom-right-triangle "bottom-right-triangle-indicator"))

  (defun find-indicator-texture (indicator)
    (assert (keywordp indicator))
    (let ((texture-name (getf *indicator-images* indicator)))
      (assert (stringp texture-name))
      (find-texture texture-name)))

  (defun draw-indicator (indicator x y &key color (scale 1) (state :inactive)
                                            background)
    (let ((size (indicator-size)))
      (when background
        (draw-circle (+ x size (dash 1))
                     (+ y size (dash 1)) (* (/ scale 2) size) :color background :type :solid))
      (draw-textured-rectangle x y 0 (* scale size) (* scale size)
                               (find-indicator-texture indicator)
                               :blend :alpha
                               :vertex-color 
                               (or color (ecase state
                                           (:active *active-indicator-color*)
                                           (:inactive *inactive-indicator-color*))))))

Text keybindings

  (defun bind-event-to-text-insertion (self key mods text)
    (bind-event-to-task self key mods 
                           (make-instance 'task :insert-string self (list text))))
    
  (defmethod insert ((self node) &optional x y z)
    (add-node (current-buffer) self x y z))

  (defmethod insert-string ((self node) string)
    (declare (ignore string))
    nil)

  (defvar *lowercase-alpha-characters* "abcdefghijklmnopqrstuvwxyz")
  (defvar *uppercase-alpha-characters* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  (defvar *numeric-characters* "0123456789")
  (defvar *graphic-characters* "`~!@#$%^&*()_-+={[}]|\:;\"'<,>.?/")

  (defparameter *text-qwerty-keybindings*
    '((:f (:control) forward-char)
      (:b (:control) backward-char)
      (:n (:alt) forward-history)
      (:p (:alt) backward-history)
      (:right nil forward-char)
      (:left nil backward-char)
      (:backspace nil backward-delete-char)
      (:delete nil delete-char)
      (:d (:control) delete-char)
      (:a (:control) beginning-of-line)
      (:e (:control) end-of-line)
      (:tab nil tab)
      (:tab (:shift) backtab)
      (:return nil enter)
      (:return (:control) execute)
      (:k (:control) clear-line)
      ;; (:return (:control) evaluate-here)
      ;; (:delete (:alt) delete-word)
      ;; (:d (:alt) :delete-word)
      (:x (:control) exit)
      (:g (:control) exit)
      (:escape nil exit)))

  (defparameter *arrow-key-text-navigation-keybindings*
    '((:up nil previous-line)
      (:down nil next-line)
      (:left nil backward-char)
      (:right nil forward-char)
      (:up (:alt) previous-line)
      (:down (:alt) next-line)
      (:left (:alt) backward-word)
      (:right (:alt) forward-word)
      (:home nil beginning-of-line)
      (:end nil end-of-line)))

  (defun keybinding-event (binding)
    (cons (first binding)
          (second binding)))

  (defun keybinding-action (binding)
    (nthcdr 2 binding))

  (defmethod install-keybindings ((self node) keybindings)
    (dolist (binding keybindings)
      (bind-event self 
                  (keybinding-event binding)
                  (keybinding-action binding))))
        
  (defmethod install-text-keybindings ((self node) &optional (keybindings *text-qwerty-keybindings*))
    ;; install UI keys that will vary by locale
    (with-slots (events) self
      (setf events (make-hash-table :test 'equal))
      (dolist (binding keybindings)
        (destructuring-bind (key mods result) binding
          (etypecase result
            (symbol (bind-event-to-method self key mods result))
            (string (bind-event-to-text-insertion self key mods result)))))))

Mouse events

  (defmethod alternate-tap ((self node) x y)
    (if (holding-control)
        (show-context-menu self)
        (toggle-halo self)))
  
  (defmethod tap ((self node) x y) nil)

  (defmethod tap :after ((node node) x y)
    (bring-to-front node)
    (with-shell
      (when (shell-p (current-buffer))
        (when (not (holding-control))
          (clear-selection))
        (toggle-selected node))))

  (defmethod scroll-tap ((self node) x y)
    (declare (ignore x y))
    nil)

  (defmethod scroll-up ((self node)))

  (defmethod scroll-down ((self node)))

  (defmethod scroll-left ((self node)))

  (defmethod scroll-right ((self node)))

  (defmethod handle-point-motion ((self node) x y)
    (declare (ignore x y)))

  (defmethod press ((self node) x y &optional button)
    (declare (ignore x y button)))

  (defmethod release ((self node) x y &optional button)
    (declare (ignore x y button)))

  (defmethod can-pick ((self node)) 
    (not (slot-value self 'pinned)))

  (defmethod pick ((self node))
    (with-slots (pinned parent) self
      (if (not pinned)
          self
          (when (and parent
                     (can-pick parent))
            (pick parent)))))

  (defmethod topmost ((self node))
    (let ((this self)
          (next nil))
      (block searching
        (loop while this do
          (setf next (slot-value this 'parent))
          (when (or (null next)
                    (typep next (find-class 'buffer)))
            (return-from searching this))
          (setf this next)))))

  (defmethod after-add-hook ((self node)) nil)

  (defmethod after-drag-hook ((self node)) nil)

  (defmethod focus ((self node)) (setf (slot-value self 'focused-p) t))

  (defmethod lose-focus ((self node)) (setf (slot-value self 'focused-p) nil))

  (defmethod grab-focus ((self node)) 
    (focus-on (current-buffer) self :clear-selection nil))

  (defmethod pick-focus ((self node)) self)

Halos

  (defparameter *handle-scale* 3.2)

  (defparameter *handle-highlight-background-color* "gray50")
  (defparameter *handle-highlight-foreground-color* "white")

  (defparameter *indicator-positions* 
    '(:asterisk (0 1)
      :bang (0 0)
      :top-left-triangle (0 0)
      :menu (1/2 0)
      :move (2/3 1)
      :drop (1/3 1)
      :rotate (0 1)
      :pick-up (1/3 0)
      :resize (1 1)
      :define (0 0)
      :close (1 0)
      :copy (0 1/2)
      :cut (1 1/2)
      :bottom-right-triangle (1 1)))

  (defclass handle (node)
    ((target :initform nil)
     (indicator :initform nil)
     (color :initform nil)
     (foreground-color :initform nil)))

  (defmethod initialize-instance :after ((self handle) &key target)
    (setf (slot-value self 'target) target)
    (bring-to-front self))

  (defmethod can-pick ((self handle)) t)
  (defmethod pick ((self handle)) self)
  (defmethod can-escape ((self handle)) nil)
  (defmethod toggle-halo ((self handle) &optional force) nil) ;; don't let halos have halos

  (defmethod highlight ((self handle))
    (setf (slot-value self 'color) *handle-highlight-background-color*)
    (setf (slot-value self 'foreground-color) *handle-highlight-foreground-color*))

  (defmethod alternate-tap ((self handle) x y) 
    (tap self x y))

  (defmethod scroll-tap ((self handle) x y) 
    (tap self x y))

  (defmethod layout ((self handle))
    (with-slots (x y width height) (slot-value self 'target)
      (destructuring-bind (px py) (getf *indicator-positions* (slot-value self 'indicator))
        (let* ((margin (* *handle-scale* (indicator-size)))
               (x0 (- x margin))
               (y0 (- y margin)))
          (setf (slot-value self 'x) (+ x0 
                                        (* px (+ width margin))))
          (setf (slot-value self 'y) (+ y0 
                                        (* py (+ height margin))))
          (setf (slot-value self 'width) margin)
          (setf (slot-value self 'height) margin)))))

  (defmethod draw ((self handle))
    (draw-indicator (slot-value self 'indicator) (slot-value self 'x) (slot-value self 'y) 
                    :color (slot-value self 'foreground-color)
                    :scale *handle-scale*
                    :background (slot-value self 'color)))

  (defmethod draw-hover ((self handle)))

  (defmacro define-handle (name indicator 
                           &key (color "gray10")
                                (foreground-color "white")
                                slots)
    (assert (symbolp name))
    (assert (stringp color))
    `(defclass ,name (handle)
       ((indicator :initform ,indicator)
        (color :initform ,color)
        (foreground-color :initform ,foreground-color)
        ,@slots)))

  ;;; Evaluation

  (define-handle evaluate :define)

  (defmethod tap ((self evaluate) x y)
    (evaluate (slot-value self 'target)))

  ;;; Getting a context menu

  (define-handle open-menu :menu)

  (defmethod tap ((self open-menu) x y)
    (show-context-menu (slot-value self 'target)))

  ;;; Dropping things down into the object layer

  (define-handle drop :drop)

  (defmethod tap ((self drop) x0 y0)
    (drop-selection (current-buffer)))

  (defmethod update ((self drop))
    (when (slot-value (slot-value self 'target) 'quadtree-node)
      ;; ghost/highlight when already in object layer
      (highlight self))
      (call-next-method self))

  ;;; Picking them up from the object layer

  (define-handle pick-up :pick-up)

  (defmethod tap ((self pick-up) x0 y0)
    (unless (contains (current-buffer) (slot-value self 'target))
      (remove-node-maybe (current-buffer) (slot-value self 'target))
      (add-node (current-buffer) (slot-value self 'target))))

  (defmethod update ((self pick-up))
    (when (null (slot-value (slot-value self 'target) 'quadtree-node))
      ;; ghost/highlight when not in object layer
      (highlight self))
      (call-next-method self))

  ;;; Moving objects or groups of them

  (define-handle move :move
    :slots ((positions :initform nil)))

  (defmethod can-pick ((self move)) t)

  (defmethod pick ((self move)) self)

  (defmethod drag ((self move) x0 y0)
    (with-slots (positions) self
      (when (null positions)
        ;; drag all selected objects
        (dolist (thing (cons (slot-value self 'target) (get-selection (current-buffer))))
          (with-slots (x y) thing
            ;; store initial offset from pointer
            (push (list thing 
                        (- x x0)
                        (- y y0))
                  positions))))
      (dolist (entry positions)
        (destructuring-bind (thing x y) entry
          (move-to thing
                   (+ x x0)
                   (+ y y0))))))

  ;;; Resizing objects interactively

  (define-handle resize :resize)

  (defmethod can-pick ((self resize)) t)

  (defmethod pick ((self resize)) self)

  (defmethod drag ((self resize) x0 y0)
    (with-slots (x y width height) (slot-value self 'target)
      (resize (slot-value self 'target) 
              (- x0 x)
              (- y0 y))
      (layout (slot-value (slot-value self 'target) 'halo))))

  ;;; Rotating objects interactively

  (define-handle rotate :rotate
    :slots ((initial-heading :initform nil)))

  (defmethod can-pick ((self rotate)) t)

  (defmethod pick ((self rotate)) self)

  (defmethod drag ((self rotate) x0 y0)
    (with-slots (heading x) (slot-value self 'target)
      (with-slots (initial-heading) self
        (when (null initial-heading)
          (setf initial-heading heading))
        (setf heading (radian-angle (- x0 initial-heading))))))

  ;;; Definitions

  (define-handle define :define)

  (defmethod tap ((self define) x y)
    (show-definition (slot-value self 'target)))

  ;;; Destroying objects

  (define-handle destroy :close)

  (defmethod tap ((self destroy) x y)
    (assert (slot-value self 'target))
    (destroy (slot-value self 'target))
    ;; get rid of halo
    (when (slot-value self 'parent)
      (destroy (slot-value self 'parent))))

  (define-handle collapse :collapse)

  ;;; Copy and cut

  (define-handle copy :copy)

  (defmethod tap ((self copy) x y)
    (copy (current-buffer)))

  (define-handle cut :cut)

  (defmethod tap ((self cut) x y)
    (cut (current-buffer)))

  ;;; The halo, which manages all the handles

  (defparameter *halo-handles* 
    '(evaluate drop move open-menu rotate resize pick-up cut copy destroy))

  (defclass halo (node) ((target :initform nil)))

  (defmethod add-node ((halo halo) (node node) &optional x y (z 0))
    (with-slots (inputs) halo
      (push node inputs)
      (adopt halo node)))

  (defmethod initialize-instance :after ((self halo) &key target)
    (assert (or (typep target (find-class 'node)) (xelfp target)))
    (setf (slot-value self 'target) target)
    (setf (slot-value self 'inputs)
          (mapcar #'(lambda (handle)
                      (make-instance handle :target (find-object target)))
                  *halo-handles*))
    (update-parent-links (find-object self))
    (update-result-lists (find-object self))
    (layout (find-object self)))

  (defun halo-minimum-height () (* 5 *handle-scale* (indicator-size)))
  (defun halo-minimum-width () (* 5 *handle-scale* (indicator-size)))

  (defmethod layout ((self halo))
    (with-slots (x y width height) (slot-value self 'target)
      (let ((size (* *handle-scale* (indicator-size))))
        (setf (slot-value self 'x) (- x size))
        (setf (slot-value self 'y) (- y size))
        ;; add twice the halo border to make sure we get clicks all the
        ;; way to the right of the halo
        (setf (slot-value self 'width) (max (+ width (* 2 size)) (halo-minimum-width)))
        (setf (slot-value self 'height) (max (+ height (* 2 size)) (halo-minimum-height)))
        ;; now lay out the individual items
        (mapc #'layout (mapcar #'find-object (slot-value self 'inputs))))))

  (defmethod draw ((self halo))
    (mapc #'draw (slot-value self 'inputs)))

  (defmethod can-pick ((self halo))
    (can-pick (slot-value self 'target)))

  (defmethod pick ((self halo))
    (pick (slot-value self 'target)))

  (defmethod tap ((self halo) x y)
    (toggle-halo (slot-value self 'target)))

  (defmethod make-halo ((self halo)) nil)

  (defmethod scroll-tap ((self halo) x y)
    (toggle-halo (slot-value self 'target)))

  (defmethod alternate-tap ((self halo) x y)
    (destroy-halo (slot-value self 'target)))

  (defmethod draw-hover ((self halo)))
  (defmethod draw-focus ((self halo)))
  (defmethod draw-highlight ((self halo)))
  (defmethod accept ((self halo) other))

  (defmethod destroy :before ((halo halo))
    (mapc #'destroy (inputs halo)))

Opening a halo

  (defmethod make-halo ((self node))
    (when (null (slot-value self 'halo))
      (setf (slot-value self 'halo) (make-instance 'halo :target self))
      (add-node (current-buffer) (slot-value self 'halo))))

  (defmethod destroy-halo ((self node))
    (when (xelfp (slot-value self 'halo))
      (destroy (slot-value self 'halo)))
    (setf (slot-value self 'halo) nil))

  (defmethod toggle-halo ((self node) &optional force)
    (if (slot-value self 'halo)
        (destroy-halo self)
        (when (or force (not (slot-value self 'pinned)))
          (make-halo self))))

  (defmethod align-to-pixels ((self node))
    (setf (slot-value self 'x) (truncate (slot-value self 'x)))
    (setf (slot-value self 'y) (truncate (slot-value self 'y))))

  (defmethod drag ((self node) x y)
    (move-to self x y))

  (defmethod as-drag ((self node) x y)
    self)

  (defmethod as-target ((self node)) self)

  (defmethod can-escape ((self node))
    t)

Node Visibility

  (defmethod show ((self node))
    (setf (slot-value self 'visible) t))

  (defmethod hide ((self node))
    (setf (slot-value self 'visible) nil))

  (defmethod toggle-visibility ((self node))
    (if (slot-value self 'visible)
        (hide self)
        (show self)))

  (defmethod visiblep ((self node))
    (slot-value self 'visible))

Data entry prompt

  (defvar *prompt* nil)

  (defparameter *active-prompt-color* "blue")
  (defparameter *inactive-prompt-color* "gray40")
  (defparameter *prompt-cursor-inactive-color* "gray50")
  (defparameter *default-prompt-text-color* "white")
  (defparameter *default-prompt-outside-text-color* "yellow")
  (defparameter *default-prompt-label-color* "white")
  (defparameter *default-entry-text-color* "white")
  (defparameter *default-entry-label-color* "white")
  (defparameter *default-prompt-string* "M-x: ")
  (defparameter *default-prompt-margin* 4)
  (defparameter *default-prompt-history-size* 100)
  (defparameter *default-cursor-width* 2)
  (defparameter *prompt-font* "sans-11")

  (defclass prompt (node)
    ((font :initform *prompt-font*)
     (read-only :initform nil :accessor read-only :initarg :read-only)
     (point :initform 0 :documentation "Integer index of cursor within prompt line.")
     (line :initform "" :documentation "Currently edited command line.")
     (last-line :initform nil)
     (background :initform t)
     (error-output :initform "")
     (minimum-width :initform 100)
     (text-color :initform *default-prompt-text-color*)
     (label-color :initform *default-prompt-label-color*)
     options label 
     (pinned :initform nil)
     (prompt-string :initform *default-prompt-string*)
     (cursor-clock :initform 0 :accessor cursor-clock :initarg :cursor-clock)
     (category :initform :data)
     (history :initform nil :documentation "A queue of strings containing the command history.")
     (history-position :initform 0)))

  (defmethod select ((self prompt)) nil)
  (defmethod unselect ((self prompt)) nil)

  (defmethod find-methods append ((prompt prompt))
    '(toggle-read-only))

  (defmethod accept ((self prompt) arg)
    nil)

  (defmethod exit ((self prompt))
    (clear-line self))

  (defmethod goto ((self prompt))
    (say self "Enter command below at the >> prompt. Press ENTER when finished, or CONTROL-X to cancel."))

  (defmethod initialize-instance :after ((self prompt) &key)
      (when (null (slot-value self 'history))
        (setf (slot-value self 'history) (make-queue :max *default-prompt-history-size* :count 0)))
      (install-text-keybindings self))

  (defmethod handle-event ((self prompt) event)
    (unless (slot-value self 'read-only)
      (handle-text-event self event)))

  (defmethod forward-char ((self prompt))
    (setf (slot-value self 'point) (min (1+ (slot-value self 'point))
                       (length (slot-value self 'line)))))

  (defmethod backward-char ((self prompt))
    (setf (slot-value self 'point) (max 0 (1- (slot-value self 'point)))))

  (defmethod insert-string ((self prompt) string)
    (setf (slot-value self 'line) (concatenate 'string
                              (subseq (slot-value self 'line) 0 (slot-value self 'point))
                              string
                              (subseq (slot-value self 'line) (slot-value self 'point))))
    (incf (slot-value self 'point) (length string)))

  (defmethod backward-delete-char ((self prompt))
    (when (< 0 (slot-value self 'point)) 
      (setf (slot-value self 'line) (concatenate 'string
                                (subseq (slot-value self 'line) 0 (1- (slot-value self 'point)))
                                (subseq (slot-value self 'line) (slot-value self 'point))))
      (decf (slot-value self 'point))))

  (defmethod delete-char ((self prompt))
    (with-slots (point line) self
      (when (<= 0 point (1- (length line)))
        (setf line (concatenate 'string
                                (subseq line 0 point)
                                (subseq line (1+ point)))))))

  (defmethod print-data ((self prompt) data &optional comment)
    (dolist (line (split-string-on-lines (write-to-string data :circle t :pretty t :escape nil :lines 5)))
      (say self (if comment ";; ~A"
                    " ~A") line)))

  (defmethod evaluate-expression ((self prompt) sexp))

  (defmethod read-expression ((self prompt) input-string)
    (handler-case 
        (let ((*read-eval* nil)) 
          (read-from-string input-string))
      (condition (c)
        (prog1 (format nil "~S" c)
          (logging "~S" c)))))

  (defmethod enter* ((self prompt) &optional no-clear)
    (labels ((print-it (c) 
               (message "~A" c)))
      (let* ((line (slot-value self 'line)))
        (setf (slot-value self 'last-line) line)
        (unless no-clear (clear-line self))
        (with-output-to-string (*standard-output*)
          (let ((expression (read-expression self line)))
            (evaluate-expression self expression))))))

(defmethod enter ((self prompt) &optional no-clear)
  (with-slots (line result history error-output) self
      (let* ((*read-eval* nil)
             (sexp (read-expression self line))
             (line* line)
             (error-p nil))
        (labels ((print-it (c) 
                   (setf error-p t)
                   (message "~A" c)))
          ;;(unless no-clear (clear-line self))
          (setf error-output
                (with-output-to-string (*standard-output*)
                  (when sexp 
                    (if *debug-on-error*
                        (evaluate-expression self sexp)
                        (handler-case
                            (handler-bind (((not serious-condition)
                                            (lambda (c) 
                                              (print-it c)
                                              ;; If there's a muffle-warning
                                              ;; restart associated, use it to
                                              ;; avoid double-printing.
                                              (let ((r (find-restart 'muffle-warning c)))
                                                (when r (invoke-restart r))))))
                              (evaluate-expression self sexp))
                          (condition (c)
                            (print-it c)))))))
          (if (not error-p)
              (setf error-output nil)
              (setf result nil))
        (when (plusp (length line*))
          (queue line* history))))))

  (defmethod newline ((self prompt))
    (enter self))

  (defmethod history-item ((self prompt) n)
    (assert (integerp n))
    (assert (not (minusp n)))
    (nth (- (queue-count (slot-value self 'history)) n)
         (queue-head (slot-value self 'history))))

  (defmethod forward-history ((self prompt))
    (when (> (slot-value self 'history-position) 0)
      (setf (slot-value self 'line) (history-item self (progn (decf (slot-value self 'history-position))
                                           (slot-value self 'history-position))))
      (when (null (slot-value self 'line)) (setf (slot-value self 'line) ""))
      (setf (slot-value self 'point) (length (slot-value self 'line)))))

  (defmethod backward-history ((self prompt))
    (when (slot-value self 'history) 
      (when (numberp (slot-value self 'history-position))
        (when (< (slot-value self 'history-position) (queue-count (slot-value self 'history)))
        (setf (slot-value self 'line) (history-item self (progn (incf (slot-value self 'history-position))
                                              (slot-value self 'history-position))))
        (setf (slot-value self 'point) (length (slot-value self 'line)))))))

  (defmethod previous-line ((self prompt))
    (backward-history self))

  (defmethod next-line ((self prompt))
    (forward-history self))

  (defmethod clear-line ((self prompt))
    (setf (slot-value self 'line) "")
    (setf (slot-value self 'point) 0)
    (setf (slot-value self 'history-position) 0))

  (defmethod end-of-line ((self prompt))
    (setf (slot-value self 'point) (length (slot-value self 'line))))

  (defmethod beginning-of-line ((self prompt))
    (setf (slot-value self 'point) 0))

  (defmethod draw-cursor ((self prompt) &rest args)
    (destructuring-bind (&key (x-offset 0) (y-offset 0)
                              color blink) args
      (with-slots (x y width height clock point parent background
                      prompt-string line) self
        (draw-cursor-glyph self
                           ;;
                           (+ x (or x-offset 0)
                              (font-text-width (if (<= point (length line))
                                                   (subseq line 0 point)
                                                   " ")
                                               (slot-value self 'font))
                              (if x-offset 0 (font-text-width prompt-string (slot-value self 'font))))
                           ;;
                           (+ y (or y-offset 0) *default-prompt-margin*)
                           *default-cursor-width*
                           (* (font-height (slot-value self 'font)) 0.8)
                           :color color
                           :blink blink))))

  (defmethod label-width ((self prompt)) 
    (font-text-width (slot-value self 'prompt-string) (slot-value self 'font)))

  (defmethod label-string ((self prompt)) (slot-value self 'prompt-string))

  (defmethod draw-border ((self prompt) &optional (color *selection-color*)))

  (defmethod draw-hover ((self prompt)))

  (defmethod recompile ((self prompt)) (slot-value self 'value))

  (defmethod layout ((self prompt)))

  (defmethod update-layout-maybe ((self prompt))
    (with-slots (line) self
      (resize self 
              (+ 12 (* 5 *dash*)
                 (font-text-width line (slot-value self 'font))
                 (font-text-width *default-prompt-string* (slot-value self 'font)))
              (+ (* 2 *default-prompt-margin*) (font-height (slot-value self 'font))))))

  (defmethod draw-input-area ((self prompt) state)
    ;; draw shaded area for data entry.
    ;; makes the cursor show up a bit better too.
    (with-slots (x y label line fixed-width) self
      (assert (not (null line)))
      (let ((label-width (label-width self))
            (line-width (font-text-width line (slot-value self 'font))))
        (draw-box (dash 0.5 x label-width)
                  (dash 0.2 y)
                  (or fixed-width (dash 2 line-width))
                  (dash 0.8 (font-height (slot-value self 'font)))
                  :color (ecase state
                           (:active *active-prompt-color*)
                           (:inactive 
                            *inactive-prompt-color*))))))

  (defmethod draw-indicators ((self prompt) state)
    (with-slots (x y options text-color width parent height line) self
      (let ((label-width (label-width self))
            (line-width (font-text-width line (slot-value self 'font)))
            (fh (font-height (slot-value self 'font))))
        ;; (draw-indicator :top-left-triangle
        ;;                    (dash 1 x 1 label-width)
        ;;                    (dash 1 y)
        ;;                    :state state)
        (draw-indicator :bottom-right-triangle
                        (dash 1 x -2 label-width line-width)
                        (+ y -2 fh)
                        :state state))))

  (defmethod draw-focus ((self prompt)) 
    (unless (slot-value self 'read-only)
      (with-slots (cursor-clock x y width line parent) self
        (let* ((label (label-string self))
               (label-width (label-width self))
               (line-width (font-text-width line (slot-value self 'font))))
          ;; draw shaded area for input
          (draw-input-area self :active)
          ;; draw cursor.
          (update-cursor-clock self)
          (draw-cursor self 
                       :x-offset
                       (dash 3 (font-text-width label (slot-value self 'font)))
                       :blink t)
          ;; draw highlighted indicators
          (draw-indicators self :active)
          ;; redraw content (but not label)
          (draw self :nolabel)))))

  (defmethod draw ((self prompt))
    (with-slots (x y width height point parent background line prompt-string) self
      (when (null line) (setf line ""))
      (let ((strings-y *default-prompt-margin*))
        ;; draw prompt string
        (assert (stringp (slot-value self 'text-color)))
        (draw-string prompt-string (+ x *default-prompt-margin*) (+ y strings-y)
                     :color (random-choose '("cyan" "white" "yellow"))
                     :font (slot-value self 'font))
                     (update-layout-maybe self)
        ;; draw background for input
        (unless (slot-value self 'read-only)
          (draw-input-area self :inactive)
          (draw-indicators self :inactive))
        ;; draw current command line text
        (when (null line) (setf line ""))
        (unless (zerop (length line))
          (draw-string line
                       (dash 1 x (label-width self))
                       (+ y strings-y)
                       :color (slot-value self 'text-color)
                       :font (slot-value self 'font))))))

(defmethod draw :after ((self prompt))
  (when *notification*
    (draw *notification*))
  (let ((text (find-instances 'text (current-buffer))))
    (when text 
      (mapc #'draw text))))

(defmethod draw :after ((self buffer))
  (when *menubar*
    (draw *menubar*))
  (when (shell-p self)
    (draw *shell*))
  (when *notification*
    (draw *notification*)))

(defmethod tap ((self prompt) mouse-x mouse-y)
  (declare (ignore mouse-y))
  (with-slots (x y width height clock point parent background
                  line) self
    ;; find the left edge of the data area
    (let* ((left (+ x (label-width self) (dash 3)))
           (tx (- mouse-x left)))
      ;; which character was clicked?
      (let ((click-index 
              (block measuring
                (dotimes (ix (length line))
                  (when (< tx (font-text-width 
                               (subseq line 0 ix)
                               *font*))
                    (return-from measuring ix))))))
        (when (numberp click-index)
          (setf point click-index))))))

System terminal overlay

  (defvar *terminal-lines* nil)
  (defvar *terminal-timer* 1)
  (defvar *terminal-show-time* (seconds 15))
  (defvar *terminal-bottom* (- *screen-height* (units 1)))
  (defvar *terminal-left* (units 1))

  (defun show-terminal (&optional (time *terminal-show-time*))
    "Show the system terminal for TIME ticks."
    (setf *terminal-timer* time))

  (defun hide-terminal ()
    "Hide the system terminal."
    (setf *terminal-timer* 0))

  (defun update-terminal-timer ()
    (when (plusp *terminal-timer*)
      (decf *terminal-timer*)))

  (defparameter *terminal-display-lines* 20)
  (defparameter *terminal-font* "sans-mono-bold-11")

  (defparameter *lines-per-screen* 38)

  (defun lines-per-screen () *lines-per-screen*)

  (defun clear-terminal () (setf *terminal-lines* nil))
  (defun last-terminal-line () (first *terminal-lines*))

  (defun add-terminal-line (string)
    (setf string (coerce string 'simple-string))
    (when (and string (not (string= string (coerce (last-terminal-line) 'simple-string))))
      (push string *terminal-lines*)))

  (defun format-terminal (format-string &rest args)
    (add-terminal-line (clean-string (apply #'format nil format-string args))))

  (defparameter *terminal-foreground-color* "white")
  (defparameter *terminal-error-color* "red")
  (defparameter *terminal-background-color* "gray30")
  (defparameter *terminal-bottom* (- *screen-height* (units 2)))

  (defun draw-terminal (&optional (number-of-lines *terminal-display-lines*) translucent)
    (let* ((x *terminal-left*)
           (y *terminal-bottom*)
           (lines *terminal-lines*)
           (count (min (abs number-of-lines) (length *terminal-lines*)))
           (line-height (font-height *terminal-font*))
           (height (* count line-height))
           (n 0))
      (when lines
        (loop while (and lines (< n count)) do
          (draw-string (nice-string (pop lines)) x (- y line-height)
                       :color *terminal-foreground-color*
                       :font *terminal-font*)
          (decf y line-height)
          (incf n))
        (let ((last-line (first *terminal-lines*)))
          (when (and last-line
                     (not *prompt*))
            (draw-string (nice-string last-line) *terminal-left* (- *terminal-bottom* line-height)
                         :color (random-choose '("cyan" "white" "yellow"))
                         :font *terminal-font*))))))

  (defun draw-terminal-maybe (&optional number-of-lines translucent)
    (when (plusp *terminal-timer*)
      (draw-terminal number-of-lines translucent)))

Rendering Smalltalk style controls

This section implements drawing primitives and color themes for a hybrid GUI inspired by MIT Scratch and its derivatives.

  (defparameter *background-color* "white"
    "The default background color of the XELF user interface.")

  (defparameter *socket-color* "gray80"
    "The default background color of node sockets.")

  (defparameter *node-font* "sans-11"
    "Name of the font used in drawing node captions and input data.")

  (defparameter *node-bold* "sans-bold-11")

  (defmacro with-font (font &rest body)
    "Evaluate forms in BODY with FONT as the current font."
    `(let ((*font* ,font))
       ,@body))

  (defvar *dash* 3
    "Size in pseudo-pixels of (roughly) the size of the space between
  two words. This is used as a unit for various layout operations.
  See also `*style'.")

  (defun dash (&optional (n 1) &rest terms)
    "Return the number of pixels in N dashes. Add any remaining
  arguments. Uses `*dash*' which may be configured by `*style*'."
    (apply #'+ (* n *dash*) terms))

  (defvar *text-baseline* nil 
  "Screen Y-coordinate for text baseline.
  This is used to override layout-determined baselines in cases where
  you want to align a group of text items across layouts.")

  (defparameter *node-colors*
    '(:motion "cornflower blue"
      :system "gray40"
      :expression "gray60"
      :button "orange"
      :terminal "gray25"
      :event "gray80"
      :menu "white"
      :hover "red"
      :socket "gray60"
      :data "gray40"
      :structure "gray50"
      :comment "khaki1"
      :looks "purple"
      :sound "orchid"
      :message "orange"
      :parameters "YellowGreen"
      :control "orange1"
      :variables "maroon3"
      :slots "MediumOrchid"
      :operators "OliveDrab3"
      :sensing "DeepSkyBlue3")
    "X11 color names of the different node categories.")

  (defparameter *node-highlight-colors*
    '(:motion "sky blue"
      :system "gray60"
      :hover "dark orange"
      :button "gold"
      :expression "gray90"
      :event "gray90"
      :menu "gray80"
      :slots "orchid"
      :terminal "gray30"
      :comment "gray88"
      :parameters "GreenYellow"
      :looks "medium orchid"
      :socket "gray80"
      :data "gray60"
      :structure "gray60"
      :sound "plum"
      :message "gold"
      :control "gold"
      :variables "maroon2"
      :operators "OliveDrab1"
      :sensing "DeepSkyBlue2")
    "X11 color names of highlights on the different node categories.")

  (defparameter *node-shadow-colors*
    '(:motion "royal blue"
      :system "gray42"
      :event "gray70"
      :socket "gray90"
      :data "gray25"
      :expression "gray50"
      :slots "DarkOrchid"
      :menu "gray80"
      :terminal "gray21"
      :button "DarkOrange"
      :parameters "OliveDrab"
      :structure "gray35"
      :comment "gray70"
      :hover "orange red"
      :looks "dark magenta"
      :sound "violet red"
      :message "DarkOrange"
      :control "dark orange"
      :variables "maroon4"
      :operators "OliveDrab4"
      :sensing "steel blue")
    "X11 color names of shadows on the different node categories.")

  (defparameter *node-foreground-colors*
    '(:motion "white"
      :system "white"
      :button "yellow"
      :event "gray40"
      :expression "white"
      :terminal "white"
      :comment "gray20"
      :slots "white"
      :socket "gray20"
      :hover "yellow"
      :parameters "white"
      :data "white"
      :menu "gray60"
      :structure "white"
      :message "white"
      :looks "white"
      :sound "white"
      :control "white"
      :variables "white"
      :operators "white"
      :sensing "white")
    "X11 color names of the text used for different node categories.")

  (defmethod find-color ((self node) &optional (part :background))
    "Return the X11 color name of this node's PART as a string.
  If PART is provided, return the color for the corresponding
  part (:BACKGROUND, :SHADOW, :FOREGROUND, or :HIGHLIGHT) of this
  category of node."
    (let* ((colors (ecase part
                    (:background *node-colors*)
                    (:highlight *node-highlight-colors*)
                    (:shadow *node-shadow-colors*)
                    (:foreground *node-foreground-colors*)))
           (category (if (keywordp (slot-value self 'category)) (slot-value self 'category) :system))
           (result (getf colors category)))
        (prog1 result 
          (assert category)
          (assert result))))

  (defparameter *selection-color* "red" 
    "Name of the color used for highlighting objects in the selection.")

  (defparameter *styles* '((:rounded :dash 3)
                           (:flat :dash 1))
    "Graphical style parameters for node drawing.")

  (defvar *style* :flat "The default style setting; must be a keyword.")

  (defmacro with-style (style &rest body)
    "Evaluate the forms in BODY with `*style*' bound to STYLE."
    (let ((st (gensym)))
    `(let* ((,st ,style)
            (*style* ,st)
            (*dash* (or (getf *styles* ,st)
                        *dash*)))
       ,@body)))

  (defmacro with-node-drawing (&body body)
    "Run BODY forms with drawing primitives.
  The primitives are CIRCLE, DISC, LINE, BOX, and TEXT. These are used
  in subsequent functions as the basis of drawing nested diagrams of
  nodes."
    `(let* ((foreground (find-color self :foreground))
            (background (find-color self :background))
            (highlight (find-color self :highlight))
            (shadow (find-color self :shadow))
            (radius (+ 6 *dash*))
            (diameter (* 2 radius)))
       (labels ((circle (x y &optional color)
                  (draw-circle x y radius
                               :color (or color background)
                               :blend :alpha))
                (disc (x y &optional color)
                  (draw-solid-circle x y radius
                                     :color (or color background)
                                     :blend :alpha))
                (line (x0 y0 x1 y1 &optional color)
                  (draw-line x0 y0 x1 y1
                             :color (or color background)))
                (box (x y r b &optional color)
                  (draw-box x y (- r x) (- b y)
                            :color (or color background)))
                (text (x y string &optional color2)
                  (draw-string string x 
                               (or *text-baseline* y)
                               :color (or color2 foreground)
                               :font *font*)))
         ,@body)))

  (defmethod draw-rounded-patch ((self node) x0 y0 x1 y1
                                      &key depressed dark socket color)
    "Draw a standard XELF node notation patch with rounded corners.
  Places the top left corner at (X0 Y0), bottom right at (X1 Y1). If
  DEPRESSED is non-nil, draw an indentation; otherwise a raised area is
  drawn. If DARK is non-nil, paint a darker region. If SOCKET is
  non-nil, cut a hole in the node where the background shows
  through. If COLOR is non-nil, its value will override all other
  arguments."
    (with-node-drawing 
      (let ((bevel (or color (if depressed shadow highlight)))
            (chisel (or color (if depressed highlight shadow)))
            (fill (or color (if socket
                                *socket-color*
                                (if dark background background)))))
  ;      (disc (- x0 10) (- y0 10) fill) ;; a circle by itself
        ;; y1 x1
        (disc (- x1 radius ) (- y1 radius ) fill)
        (circle (- x1 radius ) (- y1 radius ) chisel) ;; chisel
        ;; y1 left
        (disc (+ x0 radius ) (- y1 radius ) fill)
        (circle (+ x0 radius ) (- y1 radius) chisel)
        ;; top left
        (disc (+ x0 radius ) (+ y0 radius) fill)
        (circle (+ x0 radius ) (+ y0 radius) bevel) ;;bevel
        ;; top x1
        (disc (- x1 radius ) (+ y0 radius ) fill)
        (circle (- x1 radius ) (+ y0 radius ) chisel) ;; chisel
        ;; y1 (bottom) 
        (box (+ x0 radius) (- y1 diameter)
             (- x1 radius 1) y1
             fill)
        (line (+ x0 radius -2) (1- y1)
              (- x1 radius 1) y1 chisel)
        ;; top
        (box (+ x0 radius) y0
             (- x1 radius) (+ y0 diameter)
             fill)
        (line (+ x0 radius) (+ y0 0)
              (- x1 radius -2) (+ y0 1) bevel)
        ;; left
        (box x0 (+ y0 radius)
             (+ x0 diameter) (- y1 radius)
             fill)
        (line (+ x0 1) (+ y0 radius)
              (+ x0 1) (- y1 radius -2) bevel)
        ;; x1
        (box (- x1 diameter) (+ y0 radius)
             x1 (- y1 radius)
             fill)
        (line x1 (+ y0 radius)
              x1 (- y1 radius) chisel)
        ;; content area
        (box (+ x0 radius) (+ y0 radius)
             (- x1 radius) (- y1 radius)
             fill)
        ;; cover seams
        (disc (- x1 radius 1) (- y1 radius 1) fill) ;; y1 x1
        (disc (+ x0 radius 1) (- y1 radius 1) fill) ;; y1 left
        (disc (+ x0 radius 1) (+ y0 radius 1) fill) ;; top left
        (disc (- x1 radius 1) (+ y0 radius 1) fill) ;; top x1
        )))

  (defmethod draw-flat-patch ((self node) x0 y0 x1 y1
                                      &key depressed dark socket color)
    "Draw a square-cornered Xelf notation patch. 
  Places its top left corner at (X0 Y0), bottom right at (X1 Y1). If
  DEPRESSED is non-nil, draw an indentation; otherwise a raised area is
  drawn. If DARK is non-nil, paint a darker region."
    (with-node-drawing 
      (let ((bevel (or color (if depressed shadow highlight)))
            (chisel (or color (if depressed highlight shadow)))
            (fill (or color (if socket
                                *socket-color*
                                (if dark background background)))))
        ;; content area
        (box x0 y0  
             x1 y1
             fill)
        ;; bottom
        (line x0 y1 
              x1 y1 
              chisel)
        ;; top
        (line x0 y0
              x1 y0 
              bevel)
        ;; left
        (line x0 y0
              x0 y1 
              bevel)
        ;; right
        (line x1 y0
              x1 y1 
              chisel)
        )))

  (defmethod draw-patch ((self node) x0 y0 x1 y1 
                                      &key depressed dark socket color (style *style*))
    "Draw a Xelf notation patch in the current `*style*'.
  Places its top left corner at (X0 Y0), bottom right at (X1 Y1)."
    (let ((draw-function (ecase style
                           (:rounded #'draw-rounded-patch)
                           (:flat #'draw-flat-patch))))
      (funcall draw-function self
               x0 y0 x1 y1 
               :depressed depressed :dark dark 
               :socket socket :color color)))

  ;;; Standard ways of blinking a cursor

  (defparameter *cursor-blink-time* 8 
    "The number of frames the cursor displays each color while blinking.")

  (defparameter *cursor-color* "magenta" 
    "The color of the cursor when not blinking.")

  (defparameter *cursor-blink-color* "cyan"
    "The color of the cursor when blinking.")

(defmethod update-cursor-clock ((self prompt))
  (with-slots (cursor-clock) self
    (decf cursor-clock)
    (when (> (- 0 *cursor-blink-time*) cursor-clock)
      (setf cursor-clock *cursor-blink-time*))))

(defmethod draw-cursor-glyph ((self prompt)
    &optional (x 0) (y 0) (width 2) (height (font-height *font*))
    &key color blink)
  (with-slots (cursor-clock) self
    (let ((color2
            (if blink
                (if (minusp cursor-clock)
                    *cursor-color*
                    *cursor-blink-color*)
                *cursor-color*)))
      (draw-box x y width height :color (or color color2)))))

  (defmethod draw-cursor ((self node) &rest ignore)
    "Draw the cursor. By default, it is not drawn at all."
    nil)

  (defparameter *highlight-background-color* "white")

  (defparameter *highlight-foreground-color* "gray50")

  (defmethod draw-focus ((self node))
    "Draw any additional indications of input focus." nil)

  (defmethod draw-background ((self node) &key color)
    (with-slots (x y width height) self
      (draw-patch self x y (+ x width) (+ y height) :color color)))

  (defmethod draw-highlight ((self node)) 
    "Draw any additional indications of mouseover." nil)

  (defparameter *hover-color* "cyan" 
    "Name of the color used to indicate areas where objects can be
  dropped.")

  (defparameter *hover-alpha* 0.8)

  (defmethod draw-cursor ((self node) &rest args)
    (draw-indicator :drop
                    (- (slot-value self 'x) (dash 1)) 
                    (- (slot-value self 'y) (dash 1))
                    :color "white"
                    :scale 1.0
                    :background "gray70"))

  (defmethod draw-hover ((self node))
    "Draw something to indicate that this object can recieve a drop."
    (with-slots (x y width height inputs) self
      (draw-box x y width height
                :color *hover-color* :alpha *hover-alpha*)
      (dolist (input inputs)
        (draw input))))

Layout

  (defmethod draw-ghost ((self node))
    (with-slots (x y width height) self
      (draw-patch self x y (+ x width) (+ y height)
                   :depressed t :socket t)))

  (defmethod header-height ((self node)) 0)

  (defmethod header-width ((self node)) (slot-value self 'width))

  (defparameter *socket-width* (* 18 *dash*))

  (defmethod fancy-format-expression (expression)
    (assert (not (xelf::object-p expression)))
    (string-downcase
     (typecase expression
       (symbol
          (substitute #\Space #\- (symbol-name expression)))
       (otherwise (format nil "~s" expression)))))

(defmethod set-label-string ((self node) label)
  (assert (stringp label))
  (setf (slot-value self 'label) label))

(defmethod label-string ((self node))
  (slot-value self 'label))

(defmethod label-width ((self node))
  (if (or (null (slot-value self 'label)) (string= "" (slot-value self 'label)))
      0
      (+ (dash 2)
         (font-text-width (slot-value self 'label) *font*))))

(defmethod draw-label ((self node))
  (draw-label-string self (fancy-format-expression (label-string self))))

  (defun expression-width (expression &optional (font *font*))
    (if (xelf::object-p expression)
        *socket-width*
        (font-text-width (fancy-format-expression expression) font)))

  (defmethod center ((self node))
    (with-slots (window-x window-y) (current-buffer)
      (with-slots (x y width height) self
        (let ((center-x (+ window-x (/ *screen-width* 2)))
              (center-y (+ window-y (/ *screen-height* 2))))
          (setf x (+ (- center-x (/ width 2))))
          (setf y (+ (- center-y (/ height 2))))))))

  (defmethod center-as-dialog ((self node))
    (layout self)
    (center self)
    (align-to-pixels self))

  (defmethod pin ((self node))
    "Prevent dragging and moving of this node."
    (setf (slot-value self 'pinned) t))

  (defmethod unpin ((self node)) 
    "Allow dragging and moving of this node."
    (setf (slot-value self 'pinned) nil))

  (defmethod pinnedp ((self node))
    "When non-nil, dragging and moving are disallowed for this node."
    (slot-value self 'pinned))

  (defmethod layout ((self node))
    (when (slot-value self 'halo)
      (layout (slot-value self 'halo))))
  (defmethod play-sound ((self node) name)
    (when (or (null (cursor))
              (and (cursor) (slot-value (cursor) 'hearing-distance)))
      (when (<= (distance-to-cursor self)
                (slot-value (cursor) 'hearing-distance))
        (play-sample name))))

  (defmethod hit ((self node) mouse-x mouse-y)
    "Return this nil (or child input node) if the coordinates MOUSE-X
  and MOUSE-Y identify a point inside the nil (or input node.)"
    (with-slots (x y width height inputs) self
      (when (and x y width height)
        (when (within-extents mouse-x mouse-y x y
                              (+ x width) (+ y height))
          (labels ((try (it)
                     (hit it mouse-x mouse-y)))
            (or (some #'try inputs) 
                self))))))

  (defmethod location ((self node))
    (values (slot-value self 'x) (slot-value self 'y)))

  (defmethod left-of ((self node) &optional other)
    (let ((width (slot-value (or other self) 'width)))
      (values (- (slot-value self 'x) width) (slot-value self 'y))))

  (defmethod right-of ((self node))
    (values (+ (slot-value self 'x) (slot-value self 'width)) (slot-value self 'y)))

  (defmethod above ((self node) &optional other)
    (let ((height (slot-value (or other self) 'height)))
      (values (- (slot-value self 'x) (slot-value self 'width)) (slot-value self 'y))))

  (defmethod below ((self node))
    (values (slot-value self 'x) (+ (slot-value self 'y) (slot-value self 'height))))

  (defmethod left-of-center ((self node) &optional other)
    (multiple-value-bind (x y) (left-of self other)
      (values x (+ y (/ (slot-value self 'height) 2)))))

  (defmethod right-of-center ((self node))
    (multiple-value-bind (x y) (left-of-center self)
      (values (+ x (slot-value self 'width)) y)))

  (defmethod above-center ((self node) &optional other)
    (multiple-value-bind (x y) (above self other)
      (values (+ x (/ (slot-value self 'width) 2)) y)))

  (defmethod below-center ((self node))
    (multiple-value-bind (x y) 
        (above-center self)
      (values x (+ y (slot-value self 'height)))))

  (defmethod collide ((self node) object)
    (declare (ignore object))
    "Respond to a collision detected with OBJECT. The default implementation does nothing."
    nil)

Duplicating a node   ccl sbcl ecl

We need some MOP (Meta-Object Protocol) tricks to make this work: SLOT-DEFINITION-NAME and CLASS-SLOTS. The block below uses conditional compilation directives to choose the right MOP package for each supported compiler.

  (defmethod duplicate ((node node) &rest initargs &key &allow-other-keys)
    (let* ((class (class-of node))
           (new-node (allocate-instance class)))
      (flet ((slot-definition-name (slot)
               #+ecl (clos::slot-definition-name slot)
               #+ccl (ccl:slot-definition-name slot)
               #+sbcl (sb-mop:slot-definition-name slot))
             (class-slots (class)
               #+ecl (clos::class-slots class)
               #+ccl (ccl:class-slots class)
               #+sbcl (sb-mop:class-slots class)))
        (let ((slots (mapcar #'slot-definition-name (class-slots class))))
          (dolist (slot-name slots) 
            (when (slot-boundp node slot-name)
            (setf (slot-value new-node slot-name) (slot-value node slot-name))))
            ;; (setf (uuid node) nil)  ;; needs a new UUID during init
          (apply #'reinitialize-instance new-node initargs)))))

  (defmethod duplicate-safely ((thing node))
    (let ((dupe (duplicate thing)))
      (prog1 (find-object dupe)
        (setf (slot-value dupe 'halo) nil)
        (setf (slot-value dupe 'selected-p) nil)
        (setf (uuid dupe) (make-uuid))
        (register-uuid dupe)
        (setf (quadtree-node dupe) nil))))

Checking values against slot type declarations   ccl sbcl ecl

  (defun slot-type (object slot)
    (flet ((class-slots (class)
             #+ecl (clos::class-slots class)
             #+ccl (ccl:class-slots class)
             #+sbcl (sb-mop:class-slots class))
           (slot-definition-name (slot)
             #+ecl (clos::slot-definition-name slot)
             #+ccl (ccl:slot-definition-name slot)
             #+sbcl (sb-mop:slot-definition-name slot)))
      (let ((slots (class-slots (class-of object))))
        (block searching
          (dolist (slot0 slots)
            (when (eq slot (slot-definition-name slot0))
              (return-from searching
                #+ecl (clos::slot-definition-type slot0)
                #+ccl (ccl:slot-definition-type slot0)
                #+sbcl (sb-mop:slot-definition-type slot0))))))))

  (defun check-value-for-slot (value object slot)
    (typep value (slot-type object slot)))

Visual Lisp lists

Phrase class

  (defclass phrase (node)
    ((spacing :initform 1)
     (dash :initform 2)
     (frozen :initform nil)
     (orientation :initform :vertical)
     (operation :initform :empty-phrase)
     (result :initform nil)
     (collision-type :initform nil)
     (category :initform :structure)))

  (defmethod update :after ((self phrase))
    (layout self))

  (defmethod evaluate ((self phrase)) 
    (mapcar #'evaluate (slot-value self 'inputs)))

  (defmethod recompile ((self phrase)) 
    (mapcar #'recompile (slot-value self 'inputs)))

  (defparameter *null-display-string* "   ")

Manipulability

  (defmethod frozenp ((self phrase)) 
    (slot-value self 'frozen))

  (defmethod freeze ((self phrase))
    (setf (slot-value self 'frozen) t)
    (mapc #'pin (mapcar #'find-object (slot-value self 'inputs))))

  (defmethod unfreeze ((self phrase))
    (setf (slot-value self 'frozen) nil)
    (mapc #'unpin (mapcar #'find-object (slot-value self 'inputs))))

  (defmethod select ((self phrase)) nil)
  (defmethod unselect ((self phrase)) nil)

Orientation

  (defmethod set-orientation ((self phrase) orientation)
    (assert (member orientation '(:horizontal :vertical)))
    (setf (slot-value self 'orientation) orientation))

  (defmethod toggle-orientation ((self phrase))
    (setf (slot-value self 'orientation) 
          (ecase (slot-value self 'orientation)
            (:horizontal :vertical)
            (:vertical :horizontal))))

Inputs

  (defmethod can-accept ((self phrase)) 
    (not (slot-value self 'frozen)))

  (defmethod can-pick ((self phrase)) t)

  (defmethod pick ((self phrase))
    (if (slot-value self 'pinned) (slot-value self 'parent) self))

  (defmethod as-drag ((self phrase) x y)
    (labels ((try (it)
               (hit it x y)))
      (if (slot-value self 'frozen)
          (phrase-root self)
          (or (some #'try (slot-value self 'inputs)) self))))

  (defmethod accept ((self phrase) input)
    (assert (xelfp input))
    (when (not (slot-value self 'frozen))
      (prog1 t
        (invalidate-layout self)
        (with-slots (inputs) self
          (if inputs
              ;; we've got inputs. add it to the phrase (prepending or not)
              (progn 
                (assert (valid-connection-p self input))
                ;; set parent if necessary 
                (when (get-parent input)
                  (unplug-from-parent input))
                (set-parent (find-object input) self)
                (setf inputs 
                      ;; (if prepend
                      ;;        (append (list input) inputs)
                          (append inputs (list input))))
              ;; no inputs yet. make a single-element inputs list
              (progn
                (setf inputs (list input))
                (set-parent (find-object input) self)))))))
  (defmethod take-first ((self phrase))
    (with-slots (inputs) self
      (let ((block (first inputs)))
        (prog1 block
          (unplug self block)))))

  (defmethod get-length ((self phrase))
    (length (slot-value self 'inputs)))

Phrase layout

  (defmethod header-height ((self phrase)) 0)

  (defmethod label-width ((self phrase)) 0)

  (defmethod layout-as-null ((self phrase))
    (with-slots (height width) self
      (setf width (+ (* 4 *dash*)
                     (font-text-width *null-display-string*
                                        *font*))
            height (+ (font-height *font*) (* 4 *dash*)))))

  (defmethod layout-vertically ((self phrase))
    (with-slots (x y height width spacing inputs dash) self
      (flet ((ldash (&rest args)
               (apply #'dash 1 args)))
      (let* ((header-height (header-height self))
             (y0 (+ y (if (zerop header-height) spacing (dash 2 header-height))))
             (line-height (font-height *font*)))
        (setf height (ldash))
        (setf width (dash 6))
        (dolist (element inputs)
          (move-to element (ldash x) y0)
          (layout element)
          (incf height (slot-value element 'height))
          (incf height spacing)
          (incf y0 (slot-value element 'height))
          (setf width (max width (slot-value element 'width))))
        (incf width (dash 2))))))

  (defmethod layout-horizontally ((self phrase))
    (with-slots (x y height spacing width inputs dash) self
      (flet ((ldash (&rest args) (apply #'+ (slot-value self 'spacing) args)))
        (let ((x0 (+ x spacing))
              (y0 (ldash y))
              (line-height (font-height *font*)))
          (setf height (ldash line-height))
          (setf width (dash 2))
          (dolist (element inputs)
            (move-to element x0 y0)
            (layout element)
            (setf height (max height (+ (ldash) (slot-value element 'height))))
            (incf x0 (slot-value element 'width))
            (incf width (slot-value element 'width)))
            ;; (incf width spacing))
          (incf height spacing)))))

  (defmethod layout ((self phrase))
    (with-slots (inputs) self
      (if (null inputs)
          (layout-as-null self)
          (ecase (slot-value self 'orientation)
            (:horizontal (layout-horizontally self))
            (:vertical (layout-vertically self))))))

  (defmethod insert-before ((self phrase) index object)
    (with-slots (inputs) self
      (setf inputs
            (append (subseq inputs 0 index)
                    (list object)
                    (subseq inputs index)))))

  (defmethod draw ((self phrase))
    (with-slots (inputs) self
      (unless (slot-value self 'no-background) 
        (draw-background self))
      (if (null inputs)
          (draw-label-string self *null-display-string*)
          (dolist (each inputs)
            (draw each)))))

Phrase / S-expression correspondence

  (defun make-sentence (contents &optional (class 'phrase))
    (let ((phrase (apply #'new class :inputs (list contents))))
      (prog1 phrase
        (update-parent-links phrase)
        (with-slots (orientation no-background dash spacing) phrase
          (setf orientation :horizontal)
          (setf no-background t)
          (setf dash 1)
          (setf spacing 0)))))

  (defun make-paragraph (contents) 
    (let ((phrase (apply #'make-instance 'phrase :inputs (list contents))))
      (prog1 phrase
        (update-parent-links phrase)
        (freeze (first (slot-value phrase 'inputs))) ;; wait, is this wrong? 
        (with-slots (orientation no-background dash spacing) phrase
          (setf orientation :vertical)
          (setf dash 1)
          (setf spacing 0)))))

  (defun phrasep (x) (typep x (find-class 'phrase)))

  (defun phrase-root (phrase)
    (let ((p phrase))
      (loop while (slot-value p 'parent)
            do (setf p (slot-value p 'parent)))
      p))

  (defun make-phrase (sexp)
    (cond
      ;; pass-through already created objects
      ((xelfp sexp)
       sexp) 
      ;; lists become phrases
      ((consp sexp)
       (funcall 
        (if (consp (first sexp))
            #'make-paragraph
            #'make-sentence)
        (mapcar #'make-phrase sexp)))
      ;; 
      ((eq '&body sexp)
       (make-sentence nil))
      ;; base case
      (t (make-instance 'expression-entry :value sexp :read-only nil))))

  (defun compile-phrase (phrase)
    ;; also compiles entries!
    (recompile phrase))

  (defun duplicate-phrase (phrase)
    (make-phrase (compile-phrase phrase)))

Data entry and validation

  (defclass entry (prompt)
    ((old-line :initform nil) 
     (tags :initform '(:word))
     (category :initform :data)
     (locked :initform nil)
     (pinned :initform nil)
     (minimum-width :initform 10)
     (text-color :initform *default-entry-text-color*)
     (label-color :initform *default-entry-label-color*)
     type-specifier value))

  (defmethod tab ((self entry) &optional backward)
    (setf (slot-value self 'old-line) nil)
    (enter self)
    (next-entry (shell)))

  (defmethod backtab ((self entry))
    (previous-entry (shell)))

  (defmethod alternate-tap ((self entry) x y)
    (toggle-halo self))

  (defmethod scroll-tap ((self entry) x y))

  (defmethod start-editing ((self entry))
    (set-read-only self nil)
    (setf (slot-value self 'old-line) (copy-tree (slot-value self 'line)))
    (grab-focus self))

  (defmethod tap ((self entry) x y)
  ;  (setf (point) self)
    (start-editing self)
    (call-next-method))

  (defmethod finish-editing ((self entry))
    (setf (slot-value self 'old-line) nil)
    (enter self)
    (set-read-only self t))

  (defmethod cancel-editing ((self entry))
    (when (slot-value self 'old-line)
      (setf (slot-value self 'point) 0)
      (setf (slot-value self 'line) (copy-tree (slot-value self 'old-line)))
      (finish-editing self)))

  (defmethod lose-focus ((self entry))
    (setf (slot-value self 'old-line) nil)
    (enter self))

    ;; (cancel-editing self)
    ;; (when (null (slot-value self 'value))
    ;;   ;; user never typed anything here.
    ;;   (destroy self)))

  (defmethod as-drag ((self entry) x y)
    (declare (ignore x y))
    (if (slot-value self 'pinned) (phrase-root self) self))

  (defmethod initialize-instance :after ((self entry)
      &key value type-specifier options label label-color parent locked line font
      read-only)
      (when parent (setf (slot-value self 'parent) parent))
      (setf (slot-value self 'type-specifier) type-specifier
      (slot-value self 'options) options
      (slot-value self 'locked) locked
      (slot-value self 'read-only) read-only
      (slot-value self 'value) value)
      ;; fill in the input box with the value, unless LINE was provided
      (if line
          (progn
            (setf (slot-value self 'line) (coerce line 'simple-string))
            (setf (slot-value self 'value) (read-from-string line)))
          (setf (slot-value self 'line) 
                (format nil "~S" value)))
      (setf (slot-value self 'label) 
            (or label 
                (getf options :label)))
      (when font (setf (slot-value self 'font) font))
      (when label-color (setf (slot-value self 'label-color) label-color)))

  (defmethod set-read-only ((self entry) &optional (value t))
    (setf (slot-value self 'read-only) value))

  (defmethod set-value ((self entry) value)
    (setf (slot-value self 'value) value)
    (setf (slot-value self 'line) (prin1-to-string value)))

  (defmethod get-value ((self entry))
    (slot-value self 'value))

  (defmethod recompile ((self entry))
    (slot-value self 'value))

  (defmethod label-string ((self entry))
    (or (slot-value self 'label) 
        (getf (slot-value self 'options) :label)
        ""))

  (defmethod can-pick ((self entry)) 
    t)

  (defmethod pick ((self entry))
    (if (slot-value self 'pinned) (pick (slot-value self 'parent)) self))

  (defmethod toggle-read-only ((self entry))
    (unless (slot-value self 'locked)
      (setf (slot-value self 'read-only) (if (slot-value self 'read-only) nil t))))

  (defmethod label-width ((self entry)) 0)
  (defmethod draw-label ((self entry)) nil)

  (defmethod draw ((self entry))
    (with-slots (x y options read-only 
                    text-color width background
                    parent height line) self
      (let ((label-width (label-width self))
            (line-width (font-text-width line (slot-value self 'font))))
        ;; draw the label string 
        (let ((*text-baseline* (+ y (dash 1))))
          (unless nil 
            (when (plusp (length (slot-value self 'label)))
              (draw-label self))
            ;; draw shaded area for input
            (when (not read-only)
              (draw-input-area self :inactive)))
              ;; ;; draw indicators
              ;; (draw-indicators self :inactive)))
          ;; draw current input string
          (when (null line) (setf line ""))
          (unless (zerop (length line))
            (draw-string line
                         (+ (dash 1 x) label-width)
                         *text-baseline*
                         :color (find-color self :foreground)
                         :font (slot-value self 'font)))))))

  (defmethod draw-focus ((self entry))
    (unless (slot-value self 'read-only) 
      (with-slots (x y line) self
        (draw-input-area self :active)
        (let ((*text-baseline* (+ y (dash 1))))
          (unless (zerop (length line))
            (draw-string line
                         (dash 1 x)
                         *text-baseline*
                         :color *default-prompt-text-color*
                         :font (slot-value self 'font)))
          (draw-indicators self :active)
          (update-cursor-clock self)
          (draw-cursor self 
                       :x-offset
                       (dash 1)
                       :blink t)))))

  (defmethod draw-point ((self entry)) 
    (with-slots (x y width height) self
      (draw-box x y width height 
                :color "white"
                :alpha (min 0.45 (+ 0.2 (sin (flash 2)))))))

  (defmethod evaluate-expression ((self entry) sexp)
    (with-slots (value type-specifier parent) self
      (let ((sexp0 (if (and (listp sexp) (= 1 (length sexp)))
                       sexp
                       (list sexp))))
        (let ((datum (first sexp0)))
          (if (or (null type-specifier)
                  (type-check self datum))
              (progn (setf value datum) (message "Set datum ~A" datum))
              (message "Warning: value entered does not match type ~S. Not storing value."
                       type-specifier))
          (when parent (child-updated parent self))))))
    
  (defmethod enter ((self entry) &optional no-clear)
    (unless (slot-value self 'read-only)
      (call-next-method self no-clear)))

  (defmethod execute ((self entry))
    (enter self))
    ;;(evaluate-output (shell)))

  (defmethod evaluate-here ((self entry))
    (finish-editing self)
    (let ((output (eval (slot-value self 'value))))
      (multiple-value-bind (x y) (below self)
        (drop-object (current-buffer)
                     (if (xelfp output)
                         output
                         (make-phrase (list output)))
                     x y))))

  (defmethod evaluate-here-and-die ((self entry))
    (evaluate-here self)
    (destroy self))

  (defmethod evaluate ((self entry))
    (slot-value self 'value))

  (defmethod layout ((self entry))
    (with-slots (height width value line) self
      (setf height (+ 1 (* 1 *dash*) (font-height (slot-value self 'font))))
      (setf width
            (or (fixed-width self)
                (+ 1 (* 2 *dash*)
                   (label-width self)
                   (max (slot-value self 'minimum-width)
                        (font-text-width line (slot-value self 'font))))))))
    
  ;;; Dropping words into phrases

  (defmethod accept ((self entry) thing)
    (with-slots (parent) self
      (when (phrasep parent)
        (prog1 t
          (let ((index (position-within-parent self)))
            (insert-before parent index thing))))))

  ;;; Allow dragging the parent block more easily

  (defmethod hit ((self entry) x y)
    (when (call-next-method)
      ;; always allow clicking data area
      (if (< x (+ (slot-value self 'x) (label-width self)))
          (slot-value self 'parent)
          self)))

  (defmethod type-check ((self entry) datum)
    (typep datum (slot-value self 'type-specifier)))

  ;;; Easily defining new entry blocks

  (defmacro defentry (name type value &rest specs)
    `(defclass ,name (entry)
       ((type-specifier :initform ',type)
        (value :initform ',value)
        ,@specs)))

  (defentry integer-entry integerp 0)
  (defentry number-entry numberp 0)
  (defentry non-negative-number-entry (number 0 *) 0)
  (defentry float-entry floatp 0.0)
  (defentry symbol-entry symbolp nil 
    (category :initform :data))

  (defentry pretty-symbol-entry symbolp nil)

  (defmethod evaluate ((self pretty-symbol-entry))
    (get-value self))

  (defmethod layout :after ((self pretty-symbol-entry))
    (resize self 210 (slot-value self 'height)))

  (defmethod tap ((self pretty-symbol-entry) x y) nil)
  (defmethod alternate-tap ((self pretty-symbol-entry) x y) nil)

  (defmethod initialize-instance :after ((self pretty-symbol-entry) &key)
    (with-slots (value line locked pinned read-only) self 
      (setf locked t pinned t read-only t)
      (setf line (pretty-string value))))

  (defentry positive-integer-entry (integer 1 *) 1)
  (defentry non-negative-integer-entry (integer 0 *) 0)
  (defentry string-entry stringp "")
  (defentry expression-entry t nil 
    (category :initform :expression))

  (defmethod evaluate ((self expression-entry))
    (eval (get-value self)))

  ;;; Keyword

  (defentry keyword-entry keywordp :default)
  (defmethod update ((self keyword-entry))
    (labels ((command-argument-string (thing)
               (concatenate 'string (command-name-string thing) ": "))
             (command-name-string (thing)
               (let ((name (etypecase thing
                             (symbol (symbol-name thing))
                             (string thing))))
                 (coerce 
                  (string-capitalize 
                   (substitute #\Space #\- 
                               (string-trim " " name)))
                  'simple-string))))
    (setf (slot-value self 'line) (command-argument-string (slot-value self 'value)))))

  ;;; String display

  (defentry label stringp "")

  (defmethod read-expression ((self label) input-string)
    ;; pass-through; don't read string at all.
    input-string)

  (defmethod evaluate-expression ((self label) sexp)
    (assert (stringp sexp))
    (setf (slot-value self 'value) sexp)
    (when (slot-value self 'parent) (child-updated (slot-value self 'parent) self)))

  (defmethod set-value ((self label) value)
    (when (stringp value)
      (setf (slot-value self 'value) value)
      (setf (slot-value self 'line) value)))

  (defmethod tap ((self label) x y) nil)
  (defmethod alternate-tap ((self label) x y) nil)

Multiline text edit control

  (defparameter *text-margin* (dash 2) "Default onscreen margin (in pixels) of a text.")

  (defparameter *text-minimum-width* 80) 

  (defparameter *text-monospace* "sans-mono-bold-11")

  (defclass text (node)
    ((font :initform "sans-11")
     (buffer :initform nil)
     (category :initform :comment)
     (timeout :initform nil)
     (read-only :initform nil)
     (bordered :initform nil)
     (indicator :initform nil)
     (max-displayed-lines :initform 16 :documentation "An integer when scrolling is enabled.")
     (max-displayed-columns :initform nil)
     (background-color :initform "cornsilk" :accessor background-color)
     (foreground-color :initform "black" :accessor foreground-color)
     (cursor-color :initform "red")
     (point-row :initform 0)
     (point-column :initform 0)
     (auto-fit :initform t)
     (visible :initform t)))

  (defmethod find-methods append ((text text))
    '(page-up page-down center resize-to-fit view-messages))

  (defmethod tap ((self text) x y)
    (with-slots (buffer width parent height) self
      (with-slots (x y font point-row point-column indicator) self
        (with-slots (x y clock point parent background) self
          ;; find the left edge of the text
          (let* ((left (+ x *text-margin*))
                 (tx (- x left))
                 (ty (- y (slot-value self 'y))) 
                 ;; which row was clicked?
                 (row (truncate (/ (+ *text-margin* ty) (font-height font))))
                 (line (nth row buffer)))
            ;; move to correct row
            (setf point-row row)
            ;; which character was clicked?
            (let ((click-index 
                   (block measuring
                     (dotimes (ix (length line))
                       (when (< tx (font-text-width 
                                    (subseq line 0 ix)
                                    *font*))
                         (return-from measuring ix))))))
              ;; move to correct column
              (when (numberp click-index)
                (setf point-column click-index))))))))

  (defmethod get-first-line ((self text))
    (or (first (slot-value self 'buffer))
        "Notification text not found."))

  (defmethod can-pick ((self text)) t)
  (defmethod pick ((self text)) (or (slot-value self 'parent) self))

  (defmethod accept ((self text) thing))

  (defmethod enter ((self text) &optional no-clear)
    (newline self))

  (defmethod set-read-only ((self text) &optional (value t))
    (setf (slot-value self 'read-only) value))

  (defmethod handle-event ((self text) event)
    (handle-text-event self event))

  (defmethod set-buffer ((self text) buffer)
    (setf (slot-value self 'buffer) buffer))

  (defmethod get-buffer-as-string ((self text))
    (apply #'concatenate 'string (slot-value self 'buffer)))

  (defparameter *next-screen-context-lines* 3)

  (defmethod set-font ((self text) font)
    (setf (slot-value self 'font) font))

  (defmethod set-background-color ((self text) color)
    ;; (assert (stringp color))
    ;; (assert (eq :color (resource-type (find-resource color))))
    (setf (slot-value self 'background-color) color))

  (defmethod set-foreground-color ((self text) color)
    ;; (assert (stringp color))
    ;; (assert (eq :color (resource-type (find-resource color))))
    (setf (slot-value self 'foreground-color) color))

  (defmethod update ((self text))
    (layout self)
    (when (integerp (slot-value self 'timeout))
      (decf (slot-value self 'timeout))
      (unless (plusp (slot-value self 'timeout))
        (destroy self))))

  (defmethod page-up ((self text))
    "Scroll up one page, only when (slot-value self 'max-displayed-lines) is set."
    (with-slots (max-displayed-lines) self
      (when (integerp max-displayed-lines)
        (setf (slot-value self 'point-row) (max 0
                             (- (slot-value self 'point-row) (- max-displayed-lines
                                               *next-screen-context-lines*)))))))

  (defmethod page-down ((self text))
    "Scroll down one page, only when (slot-value self 'max-displayed-lines) is set."
    (with-slots (max-displayed-lines) self
      (when (integerp max-displayed-lines)
        (setf (slot-value self 'point-row) (min (- (length (slot-value self 'buffer)) max-displayed-lines)
                               (+ (slot-value self 'point-row) (- max-displayed-lines
                                               *next-screen-context-lines*)))))))

  (defmethod resize-to-scroll ((self text) width height)
    "Resize the text to WIDTH * HEIGHT and enable scrolling of contents."
    (assert (and (numberp width) (numberp height)))
    (resize self width height)
    (setf (slot-value self 'max-displayed-lines) (truncate (/ height (font-height (slot-value self 'font))))))

  (defmethod resize-to-fit ((self text))
    "Automatically resize the text to fit the text, and disable scrolling."
    ;; disable scrolling
    (setf (slot-value self 'max-displayed-lines) nil)
    ;; measure text
    (let* ((buffer (slot-value self 'buffer))
           (line-height (font-height (slot-value self 'font)))
           (line-lengths (mapcar #'(lambda (s)
                                     (font-text-width s (slot-value self 'font)))
                                 buffer)))
      ;; update geometry
      (let ((width0 (max *text-minimum-width*
                         (+ (* 2 *text-margin*) 4
                            (if (null line-lengths)
                                0 
                                (apply #'max line-lengths)))))
            (height0 (+ (* 2 *text-margin*)
                        (* line-height (max 1 (length buffer))))))
        (when (or (< (slot-value self 'width) width0)
                  (< (slot-value self 'height) height0))
          (resize self width0 height0)))))

  (defmethod view-messages ((self text))
    (setf (slot-value self 'auto-fit) nil)
    (setf (slot-value self 'max-displayed-lines) 3)
    (add-to-list '*message-hook-functions* 
                 #'(lambda (string)
                     (insert-string self string)
                     (newline self))))
    ;; (setf (slot-value self 'buffer) (reverse *message-history*)))

  (defmethod initialize-instance :after ((self text) &key text)
     (if (stringp text)
         (setf (slot-value self 'buffer) (split-string-on-lines text))
         (setf (slot-value self 'buffer) text))
         ;; (when (and buffer (listp buffer) (every #'stringp buffer))
         ;;     (setf (slot-value self 'buffer) buffer))
     (layout self)
     (install-text-keybindings 
      self
      (append *text-qwerty-keybindings*
              *arrow-key-text-navigation-keybindings*)))

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

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

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

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

  (defmethod newline ((self text))
    (with-slots (buffer point-row point-column) self
      (if (null buffer)
          (progn (push "" buffer)
                 (setf point-row 1))
          (if (and (= point-row (length buffer))
                   (= point-column (length (nth point-row buffer))))
              (progn (setf buffer (append buffer (list "")))
                     (incf point-row)
                     (setf point-column 0))
              ;;  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 ((self text))
    (with-slots (buffer point-row point-column) self
      (if (and (= 0 point-column) 
               (not (= 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))
                  (len (length buffer)))
              (setf buffer (append (subseq buffer 0 (- point-row 1))
                                   (list (concatenate 'string line (nth point-row buffer)))
                                   (subseq buffer (min len (+ point-row 1)))))
              ;; (setf (cdr (nthcdr (- point-row 1) buffer))
              ;;          (nth (+ point-row 1) buffer))
              ;;
              ;; move cursor too
              (decf point-row)
              (setf point-column (length line))))
          ;; otherwise, delete within current line.
          (when (not (= 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 get-current-line ((self text))
    (nth (slot-value self 'point-row) (slot-value self 'buffer)))

  (defmethod end-of-line-p ((self text))
    (= (slot-value self 'point-column)
       (1- (length (get-current-line self)))))

  (defmethod beginning-of-line-p ((self text))
    (= (slot-value self 'point-column) 0))

  (defmethod top-of-buffer-p ((self text))
    (= (slot-value self 'point-row) 0)) 

  (defmethod bottom-of-buffer-p ((self text))
    (= (slot-value self 'point-row)
       (1- (length (slot-value self 'buffer)))))

  (defmethod beginning-of-buffer-p ((self text))
    (and (beginning-of-line-p self)
         (top-of-buffer-p self)))

  (defmethod end-of-buffer-p ((self text))
    (and (end-of-line-p self)
         (bottom-of-buffer-p self)))

  (defmethod delete-char ((self text))
    (with-slots (buffer point-row point-column) self
      (if (end-of-line-p self)
          ;; just remove line break
          (unless (bottom-of-buffer-p self)
            (next-line self)
            (beginning-of-line self)
            (backward-delete-char self))
          ;; remove a character
          (progn 
            (forward-char self)
            (backward-delete-char self)))))

  (defmethod insert-string ((self text) key)       
    (with-slots (buffer point-row point-column) self
      (if (null buffer)
          (progn
            (push 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)
                                 key
                                 remainder)))
            (incf point-column)))))

  (defmethod insert-string ((self text) string)
    (dolist (character (coerce string 'list))
      (insert self (string character))))

  (defmethod visible-lines ((self text))
    (with-slots (buffer max-displayed-lines) self
      (let ((end (length buffer)))
        (if (slot-value self 'auto-fit) 
            buffer
            (subseq buffer 
                    (slot-value self 'point-row)
                    (if max-displayed-lines
                        (min end max-displayed-lines)
                        end))))))

  (defmethod layout ((self text))
    (with-slots (height width font) self
      (when (slot-value self 'auto-fit)
        (resize-to-fit self))
      (setf width 0)
      (let* ((lines (visible-lines self))
             (text-height (* (font-height (slot-value self 'font)) (length lines))))
        (setf height (dash 4 text-height))
        (dolist (line lines)
          (callf max width (dash 4 (font-text-width line font)))))))

Notification bubbles

  (defmethod notify-style ((self text) &optional (timeout (seconds->frames 5.5)))
    (setf (slot-value self 'timeout) timeout)
    (setf (slot-value self 'category) :system)
    (setf (foreground-color self) "black")
    (setf (background-color self) "cornsilk")
    (layout self)
    (move-to self (+ (window-pointer-x) 12)
                  (- (window-pointer-y) 20)))

  (defun recent-messages (&optional (n 5))
      (nreverse (subseq *message-history* 0 
                        (min n (length *message-history*)))))

  (defun notify-message (lines)
    (let ((notification (make-instance 'text :text (split-string-on-lines lines))))
      (notify-style notification)
      ;; remove any existing notification
      (when *notification*
        (remove-object (current-buffer) *notification*)
        (setf *notification* notification))
      (add-node (current-buffer) notification)
      (bring-to-front notification)))

  (defun notify-message-maybe ()
    (when *use-notifications*
      (notify-message (recent-messages))))

  (defun notify (text)
    (mapcar #'message (split-string-on-lines text))
    (show-status text)
    (notify-message text))

  (add-hook '*message-hook* #'notify-message-maybe)

  (defparameter *text-cursor-width* 2)

  (defmethod draw ((self text))
    (with-slots (buffer width parent height) self
      (with-slots (x y font point-row indicator) self
        ;; measure text
        (let ((line-height (font-height font)))
            ;; draw background
          (when (slot-value self 'background-color)
           (with-style :rounded 
           (draw-patch self x y 
           (+ x width)
           (+ y height)
           :color (or (slot-value self 'background-color) (find-color self)))))
          ;; draw text
          (let* ((x0 (+ x *text-margin*))
                 (y0 (+ y *text-margin*))
                 (lines (visible-lines self))
                 (text-height (* line-height (length lines))))
            (dolist (line lines)
              (when (plusp (length line))
                (draw-string line x0 y0 
                             :font font :color (foreground-color self)))
              (incf y0 line-height)))))))
        ;; ;; possibly draw emblem
        ;; (draw-emblem self))))

  ;; (defmethod draw-focus ((self text))
  ;;   (with-slots (buffer width parent height) self
  ;;     (with-slots (x y font point-row) self
  ;;       (when (null (slot-value self 'read-only))
  ;;    (let* ((line-height (font-height font))
  ;;           (current-line (nth point-row buffer))
  ;;           (cursor-width *text-cursor-width*)
  ;;           (x1 (+ x *text-margin*
  ;;                  (font-text-width (subseq current-line 0 (slot-value self 'point-column))
  ;;                                   font)))
  ;;           (y1 (+ y *text-margin*
  ;;                  (* point-row (font-height font)))))
  ;;      (draw-cursor-glyph self x1 y1 cursor-width line-height 
  ;;                         :blink t))))))

  (defmethod draw-hover ((self text)) nil)

Collapsible tree browser widget

(defvar *tree-depth* 0)

(defmacro deeper (&rest body)
  `(let ((*tree-depth* (1+ *tree-depth*)))
     ,@body))

(defparameter *depth-gray-slope* -4)
(defparameter *depth-gray-base* 50)

(defun depth-gray (depth)
  (percent-gray (+ *depth-gray-base* (* depth *depth-gray-slope*))))

(defclass tree (phrase)
  ((category :initform :structure)
   (treep :initform t)
   (always-visible :initform nil)
   (style :initform :rounded)
   (method :initform nil)
   (draw-frame :initform t)
   (indentation-width :initform (dash 2))
   (top-level :initform nil)
   (locked :initform nil)
   (temporary :initform t)
   (action :initform nil)
   (target :initform nil)
   (expanded :initform nil :accessor expanded :initarg :expanded)
   (visible :initform t)))

(defun treep (thing)
  (typep thing (find-class 'tree)))

(defmethod children ((self tree)) (slot-value self 'inputs))

(defmethod initialize-instance :after ((self tree)
                                       &key action target top-level inputs pinned locked method category
                                            expanded (draw-frame t) label)
  (setf (slot-value self 'action) action
        (slot-value self 'pinned) pinned
        (slot-value self 'draw-frame) draw-frame
        (slot-value self 'expanded) expanded
        (slot-value self 'category) category
        (slot-value self 'locked) locked
        (slot-value self 'target) target
        (slot-value self 'method) method
        (slot-value self 'top-level) top-level
        (slot-value self 'label) label)
  (when inputs (setf (slot-value self 'inputs) inputs))
  ;; become the parent
  (when inputs
    (dolist (each inputs)
      (pin (find-object each))
      (set-parent (find-object each) self))))

(defmethod evaluate ((self tree))
  (deeper (mapcar #'evaluate (slot-value self 'inputs))))

(defmethod toggle-expanded ((self tree) &optional force)
  (with-slots (expanded locked) self
    (when (or force (not locked))
      (setf expanded (if expanded nil t))
      (invalidate-layout self))))

(defmethod expandedp ((self tree))
  (slot-value self 'expanded))

(defmethod expand ((self tree) &optional force)
  (when (or force (not (slot-value self 'locked)))
    (setf (slot-value self 'expanded) t)
    (invalidate-layout self)))

(defmethod unexpand ((self tree) &optional force)
  (when (or force (not (slot-value self 'locked)))
    (setf (slot-value self 'expanded) nil)
    (invalidate-layout self)))

(defmethod tap ((self tree) x y)
  (declare (ignore x y))
  (toggle-expanded self))

(defmethod display-string ((self tree))     
  (with-slots (action label top-level) self
    (let ((ellipsis (concatenate 'string (or label "") *null-display-string*)))
      (if action
          (etypecase action
            ((or string xelf:node) ellipsis)
            (symbol (pretty-string action)))
          (if top-level (or label "") ellipsis)))))

(defmethod layout-as-string ((self tree) string)
  (with-slots (height width) self
    (setf height (dash 1 (font-height *font*)))
    (setf width 
          (+ (dash 2) (font-text-width string *font*)))))

(defmethod layout ((self tree))
  (with-slots (expanded x y always-visible height inputs label width) self
    (if expanded 
        ;; we're an expanded subtree. lay it out
        (progn 
          ;; lay out the children as in a typical list
          (layout-vertically self)
          ;; add a little padding to the bottom
          (incf height (dash 7))
          ;; handle the case that the label is wider than the content.
          (when label 
            (setf width 
                  (max width 
                       (dash 6 (font-text-width label *font*)))))
          ;; make all inputs equally wide
          (dolist (each inputs)
            (setf (slot-value each 'width) (- width (dash 2))))
          ;; possibly adjust to stay onscreen 
          (when always-visible
            (multiple-value-bind (top left bottom right)
                (window-bounding-box (current-buffer))
              (let ((overlap (- bottom  
                                (+ y height))))
                (when (minusp overlap)
                  (incf y overlap)
                  (layout-vertically self))))))
        ;; we're not expanded. just lay out for label.
        (layout-as-string self (display-string self)))))

(defmethod header-height ((self tree))
  (if (slot-value self 'label) (font-height *font*) 0))

(defmethod header-width ((self tree))
  (if (slot-value self 'expanded)
      (dash 2 (font-text-width (display-string self) *font*))
      (slot-value self 'width)))

(defmethod hit ((self tree) mouse-x mouse-y)
  (with-slots (x y expanded inputs width height) self
    (when (within-extents mouse-x mouse-y x y (+ x width) (+ y height))
      (flet ((try (item)
               (hit item mouse-x mouse-y)))
        (if (not expanded)
            self
            ;; we're expanded. is the mouse to the left of this
            ;; tree's header tab thingy?
            (if (slot-value self 'top-level)
                (when (and (< mouse-x (+ x (header-width self)))
                           (< (header-height self) mouse-y))
                  (some #'try inputs))
                (or (some #'try inputs) self)))))))

;;       (let ((hh (header-height self))
;;          (hw (header-width self)))
;; ;;   (message "HIT TREE")
;;      (if (< y mouse-y (+ y hh))
;;          ;; we're even with the header text for this tree.
;;          ;; are we touching it?
;;          (if (< x mouse-x (+ x hw))
    ;;          ;; mouse is over tree title. return self to get event
;;              ;; we're in the corner (possibly over top of the text
;;              ;; of the next tree item's title in the tree bar). 
;;              ;; so, we close this tree.
;;              (prog1 nil (unexpand self)))
;;          (labels ((try (it)
;;                     (hit it mouse-x mouse-y)))
;;            (some #'try inputs)))))))

(defmethod draw-hover ((self tree))
      nil)

(defmethod draw-border ((self tree) &optional (color *selection-color*)))

(defmethod draw-highlight ((self tree)) 
  nil)

(defmethod draw-expanded ((self tree) &optional label)
  (with-slots (x y width height parent inputs) self
    (let ((display-string (or label *null-display-string*))
          (header (header-height self)))
      ;; possibly draw a background
      (when (or (null parent)
                (not (null inputs))
                (not (treep parent)))
        (draw-patch self x y (+ x width) (+ y height)))
      ;; possibly colored by depth
      ;; (when (plusp *tree-depth*)
      ;;   (draw-box x y width height :color (depth-gray *tree-depth*))))
      (draw-label-string self display-string)
      ;; (draw-indicator :down-triangle-open
      ;;                      (+ (slot-value self 'x) (font-text-width display-string)
      ;;                         (dash 4))
      ;;                      (+ (slot-value self 'y) (dash 2))
      ;;                      :scale 1.6
      ;;                      :color "gray60")
      (when (slot-value self 'label) 
        (draw-line (+ x 1) (dash 2 y header) 
                   (+ x width -1) (dash 2 y header)
                   :color (find-color self :highlight))))))

(defmethod draw-unexpanded ((self tree) &optional label)
                                        ;  (draw-background self)
  (let ((string (or label (display-string self))))
    (draw-label-string self string)
    (draw-indicator :down-triangle-closed 
                    (+ (slot-value self 'x) (font-text-width string)
                       (dash 4))
                    (+ (slot-value self 'y) (dash 2))
                    :scale 1.6
                    :color "yellow")))

(defmethod draw-subtree ((self tree))
  (deeper 
   (dolist (each (slot-value self 'inputs))
     (draw each))))

(defmethod draw ((self tree))
  (with-slots (visible draw-frame expanded label inputs) self
    (when visible
      (with-style (slot-value self 'style)
        (if expanded 
            (progn 
              (when draw-frame
                (draw-expanded self label))
              (draw-subtree self))
            (when draw-frame (draw-unexpanded self label)))))))

;; see system.lisp for example tree menu
(defun make-tree (items &key target category (tree-class 'tree))
  (labels ((xform (item)
             (if (listp item)
                 (if (listp (first item))
                     (mapcar #'xform item)
                     (apply #'make-instance tree-class
                            :target target
                            :category category
                            (mapcar #'xform item)))
                 item)))
    (xform items)))

Menu widget

(defclass menu (tree)
  ((action :initform nil)
   (always-visible :initform t)
   (style :initform :rounded)
   (top-level :initform nil)
   (category :initform :menu)
   (tags :initform '(:menu))))

(defmethod find-methods append ((menu menu))
  '(evaluate))

(defun menup (thing)
  (typep (find-class 'menu) thing))

(defmethod siblings ((self menu))
  (when (slot-value self 'parent) 
    (remove-if-not #'menup (slot-value (slot-value self 'parent) 'inputs))))

;; (defmethod layout-as-string :after ((self menu) string)
;;   (with-slots (width parent) self
;;     (when parent (setf width (1- (slot-value parent 'width))))))

(defmethod make-halo ((self menu)) nil)

(defvar *menu-prototype* nil)

(defun make-menu (items &key target (class 'menu))
  (make-tree items 
             :target target 
             :category :menu
             :tree-class class))

;; menu items should not accept any dragged widgets.
(defmethod accept ((self menu) arg) nil)

(defmethod can-pick ((self menu)) nil)
;; ;; allow making code blocks from menu items
;; (or (slot-value self 'method)
;;        (or (keywordp (slot-value self 'action)) 
;;            ;; disallow pulling main menus
;;            (not (slot-value self 'top-level)))))

(defmethod pick ((self menu))
  (when (slot-value self 'target)
    (if (keywordp (slot-value self 'method))
        (let ((message
               (message-for-method (slot-value self 'method) (slot-value self 'target))))
          (prog1 message 
            (with-slots (x y) message
              (setf x (slot-value self 'x) y (slot-value self 'y)))))
        self)))

(defmethod alternate-tap ((self menu) x y)
  (when (or (null (slot-value self 'parent))
            (not (typep (slot-value self 'parent) (find-class 'menu))))
    (alternate-tap (slot-value self 'parent) x y)))

(defmethod tap :around ((self menu) x y)
  (declare (ignore x y))
  (with-slots (action target) self
    (if action
        (typecase action 
          (function (funcall action))
          (string (evaluate action)) 
          (symbol 
           (when (fboundp action)
             (funcall (symbol-function action))))
          (node (evaluate action)))
        (progn
          ;; we're a submenu, not an individual menu command.
          ;; first close any other open menus
          (mapc #'unexpand (siblings self))
          (toggle-expanded self)))))

(defparameter *menu-tab-color* "gray80")
(defparameter *menu-title-color* "gray40")

(defmethod draw-expanded ((self menu) &optional label)
  (with-slots (action x y width height parent inputs top-level) self
    (let ((header (header-height self)))
      (if top-level
          (progn
            ;; draw the tree background
            (draw-patch self
                        x (dash 2 y header)
                        (dash 0 x width)
                        (- (dash 1 y height) (dash 1))
                        :color "gray18")
            ;; draw the header a bit differently to avoid over-drawing
            ;; other headers in a menu bar situation.
            (draw-patch self x (+ 1 y)
                        (+ (dash 2) x (header-width self))
                        (dash 3 y header -2)
                        :color *menu-tab-color*)
            (draw-label-string 
             self (or label *null-display-string*) *menu-title-color*))
          ;; nope, draw in the typical fashion.
          (when (parent self) (draw-expanded (slot-value self 'parent) label)))
      ;; draw status indicator on submenus
      (when (and (not (slot-value self 'locked)) parent (menup parent))
        (draw-indicator :down-triangle-open 
                        (+ (slot-value self 'x) (font-text-width (or label *null-display-string*))
                           (dash 4))
                        (+ (slot-value self 'y) (dash 2))
                        :scale 1.6
                        :color "gray50")))))

(defmethod draw-unexpanded ((self menu) &optional label)
  (with-slots (action target parent top-level) self
    (let ((x (window-pointer-x))
          (y (window-pointer-y))
          (width (when parent (- (slot-value parent 'width) 1))))
      (multiple-value-bind (top left right bottom) (bounding-box self)
        (when (and (< left x right) (< top y bottom))
          (if top-level
              (draw-box (+ left 2) (+ top 1) (or width (- right left -2)) (- bottom top -2) :color "gray30")
              (draw-box (- left 3) (+ top 1) (or width (- right left -8)) (- bottom top -2) :color "gray30")))))
    (let ((text (or label (display-string self))))
      (draw-label-string self 
                         text
                         (if (or (functionp action)
                                 (null action)
                                 (typep action (find-class 'task))
                                 (and (symbolp action)
                                      (fboundp action)))
                             "gray80"
                             "gray60")))))

(defmethod draw-highlight ((self menu))
  (with-slots (y height expanded action parent top-level) self
    (when (and parent (fboundp action))
      (with-slots (x width) parent
        ;; don't highlight top-level trees.
        (when (and (not expanded) (not top-level))
          (draw-box (+ x (dash 2))
                    (+ y (dash 1)) 
                    (- width (dash 4))
                    (+ height 1)
                    :color *highlight-background-color*)
          (draw-label-string self (display-string self) *highlight-foreground-color*))))))

(defmethod layout :after ((self menu))
  (assert (valid-bounding-box-p (multiple-value-list (bounding-box self))))
  (with-slots (width height expanded top-level) self
    (when (and expanded top-level)
      (incf width 45)
      (incf height 10)
      (mapc #'layout (inputs self)))))

(defmethod draw :after ((self menu))
  (with-slots (inputs) self
    (let ((x (window-pointer-x))
          (y (window-pointer-y)))
      (dolist (input inputs)
        (multiple-value-bind (top left right bottom)
            (bounding-box input)
          (when (and (< left x right)
                     (< top y bottom))
            (draw-highlight self)))))))

Shell workspace (shell.lisp)

(in-package :xelf)

Messenger widget

(defclass messenger (node)
  ((category :initform :terminal)
   (messages :initform nil)))

(defmethod initialize-instance :after ((self messenger) &key messages) 
  (typecase messages
    ((stringp messages)
     (setf (slot-value self 'messages) (list messages)))
    ((consp messages)
     (setf (slot-value self 'messages) messages))))

(defmethod add-message ((self messenger) message-string)
  (assert (stringp message-string))
  (push message-string (slot-value self 'messages)))

(defparameter *messenger-columns* 80)
(defparameter *messenger-rows* 7)

(defmethod get-messages ((self messenger))
  (or (slot-value self 'messages) *message-history*))

(defmethod layout ((self messenger))
  (setf (slot-value self 'height) (+ (* (font-height *font*) *messenger-rows*)
                   (dash 4)))
  (let ((width 0))
    (block measuring
      (dotimes (n *messenger-rows*)
        (if (<= (length (get-messages self)) n)
            (return-from measuring nil)
            (setf width 
                  (max width 
                       (font-text-width 
                        (nth n (get-messages self))
                        *block-font*))))))
    (setf (slot-value self 'width) (+ width (dash 5)))))

(defparameter *messenger-color* "gray80")

(defmethod draw ((self messenger))
  (draw-background self)
  (with-slots (x y width height) self
      (let ((y0 (+ y height (- 0 (font-height *font*) (dash 2))))
            (x0 (+ x (dash 3))))
        (dotimes (n *messenger-rows*)
          (unless (<= (length (get-messages self)) n)
            (draw-string (nth n (get-messages self))
                         x0 y0
                         :color *messenger-color*
                         :font *block-font*)
            (decf y0 (font-height *font*)))))))

Modeline

   (defvar *modeline-status-string* nil)

   (defun show-status (string)
     (setf *modeline-status-string* (concatenate 'string "        " (clean-string string))))

   (defun modeline-status-string ()
     (if *notification*
         (get-first-line *notification*)
         *modeline-status-string*))

   (defun-memo modeline-position-string (x y)
       (:key #'identity :test 'equal :validator #'identity)
     (format nil "X:~S Y:~S" x y))

   (defun-memo modeline-database-string (selected local global)
       (:key #'identity :test 'equal :validator #'identity)
     (format nil "~S objects selected from ~S/~S objects" selected local global))

   (define-visual-macro modeline
       (:super phrase
        :slots 
        ((orientation :initform :horizontal)
         (no-background :initform t)
         (spacing :initform 4))
        :inputs (:buffer-id (make-instance 'label :read-only t)
                 :position (make-instance 'label :read-only t)
                 :mode (make-instance 'label :read-only t)
                 :objects (make-instance 'label :read-only t)
                 :status (make-instance 'label :read-only t))))

   (defmethod update ((self modeline))
     (mapc #'pin (slot-value self 'inputs))
     (with-visual-slots (buffer-id objects position mode status) self
       (set-value buffer-id (slot-value (current-buffer) 'buffer-name))
       (set-value objects (modeline-database-string
                           (length (selection))
                           (hash-table-count (slot-value (current-buffer) 'objects))
                           (hash-table-count *database*)))
       (set-value position
                  (modeline-position-string
                   (slot-value (current-buffer) 'window-x)
                   (slot-value (current-buffer) 'window-y)))
       (set-value mode
                  (if (current-buffer)
                      (if (slot-value (current-buffer) 'paused)
                          "(paused)"
                          "(playing)")
                      "(empty)"))
       (set-value status
                  (or (modeline-status-string) " "))))
   
   (defmethod draw ((self modeline))
     (with-slots (x y width height) self
       (call-next-method)
       (draw-line x y (+ x width) y :color "gray50")))

Interactive dialog box tools

(defun arglist-input-forms (argument-forms)
  (mapcar #'(lambda (f)
              `(make-sentence 
                (list
                 (make-instance 'pretty-symbol-entry :value ,(make-keyword (first f)) :read-only t)
                 (make-instance 'property-value-entry :value ,(second f) :read-only nil))))
          argument-forms))

(defun command-inputs (name arglist)
  `(;;(let ((label (make-instance 'label :read-only t :font "sans-condensed-bold-18")))
    ;;  (prog1 label (set-value label ,(command-name-string (symbol-name name)))))
    (make-paragraph (list ,@(arglist-input-forms arglist)))))

(defun command-name-string (thing)
  (let ((name (etypecase thing
                (symbol (symbol-name thing))
                (string thing))))
    (coerce 
     (string-capitalize 
      (substitute #\Space #\- 
                  (string-trim " " name)))
     'simple-string)))

(defun command-argument-string (thing)
  (concatenate 'string (command-name-string thing) ": "))

(defun action-name (name)
  (intern (concatenate 'string (symbol-name name) "-ACTION")))

(defun show-name (name)
  (intern (concatenate 'string "SHOW-" (symbol-name name) "-DIALOG")))

(defun dialog-class-name (name)
  (intern (concatenate 'string (symbol-name name) "-DIALOG")))

Shell prompt

  (defclass shell-prompt (entry)
    ((result :initform nil)
     (background :initform nil)
     (history :initform nil)))

  (defmethod make-halo ((self shell-prompt))
    nil)

  (defmethod can-pick ((self shell-prompt)) nil)

  (defmethod pick ((self shell-prompt))
    nil)

  (defmethod evaluate-expression ((self shell-prompt) sexp)
    (let ((*interactive-p* t))
      (with-slots (result) self 
        (setf result (eval sexp)))))

  (defmethod enter :after ((self shell-prompt) &optional no-clear)
    (with-slots (result error-output) self
      (if error-output
          (progn
            (replace-output (shell) (list (make-phrase (clean-string error-output))))
            (notify "There was an error. Check the output area for more info."))
          (when result
            (replace-output (shell) (list (make-phrase result))))))
    (clear-line self))
    
  (defmethod lose-focus ((self shell-prompt))
    (cancel-editing self))

  ;; (defmethod close-shell ((self shell-prompt))
  ;;   (setf (shell-p (current-buffer)) nil))

  ;; (defmethod initialize-instance :after ((self shell-prompt) &key)
  ;;   (bind-event self '(:g :control) 'close-shell)
  ;;   (bind-event self '(:escape) 'close-shell))
(defparameter *minimum-shell-width* 400)
(defparameter *shell-background-color* "gray20")

(defparameter *default-command-prompt-string* " > ")

(defun make-label (string &optional font)
  (let ((label (make-instance 'label)))
    (prog1 label
      (set-value label string)
      (set-read-only label t)
      (when font
        (setf (slot-value label 'font) font)))))

(define-visual-macro shell
    (:super (phrase traveler)
            :slots 
            ((orientation :initform :vertical)
             (frozen :initform t)
             (category :initform :system)
             (spacing :initform 4)
             ;;
             (entry-index :initform 0)
             (target-x :initform 0)
             (target-y :initform 0))
            :inputs
            (:output (make-instance 'phrase)
                     :modeline (make-instance 'modeline)
                     :command-area (make-sentence 
                                    (list
                                     (make-label *default-command-prompt-string*)
                                     (make-instance 'shell-prompt)))))
  (at-next-update (evaluate-expression (shell-prompt) (list 'in-package (package-name (project-package)))))
  (setf *menubar* (make-instance 'menubar))
  (setf *system* (make-instance 'system)))

(defmethod draw :after ((self shell))
  (let ((focus (slot-value (current-buffer) 'focused-block)))
    (when (xelfp focus)
      (draw-focus (find-object focus)))))

(defun create-shell-maybe ()
  (when (null *shell*) 
    (setf *shell* (make-instance 'shell))))

Captions and labels (commands.lisp)

  (in-package :xelf)

  (defmethod set-caption-string ((self node) caption)
    (assert (stringp caption))
    (setf (slot-value self 'caption) caption))

  (defmethod caption-string ((self node))
    (slot-value self 'caption))

  (defmethod caption-width ((self node))
    (if (or (null (slot-value self 'caption)) (string= "" (slot-value self 'caption)))
        0
        (+ (dash 2)
           (font-text-width (slot-value self 'caption) *node-font*))))

  (defmethod draw-caption-string ((self node) string &optional color)
    (with-node-drawing 
      (with-slots (x y) self
        (let* ((dash *dash*)
               (left (+ x (* 2 dash)))
               (y0 (+ y dash 1)))
          (draw-string string left y0 :color color)))))

  (defmethod draw-label-string ((self node) string &optional color)
    (with-node-drawing 
      (with-slots (x y) self
        (let* ((dash *dash*)
               (left (+ x (* 2 dash)))
               (y0 (+ y dash 1)))
          (draw-string string left y0 :color color)))))

  (defmethod draw-caption ((self node) expression)
    (draw-caption-string self (fancy-format-expression expression)))

Shell operations

  (defmethod drag ((self shell) x y)
    (with-slots (target-x target-y) self
      (setf target-x (- x (window-origin-x)))
      (setf target-y (- y (window-origin-y)))
      (move-to self x y)))

  (defmethod layout ((self shell))
    ;; (with-slots (target-x target-y) self
    ;;   (move-to self 
    ;;         (+ target-x (window-origin-x))
    ;;         (+ target-y (window-origin-y)))
    (with-slots (target-x target-y) self
      (setf target-x 0 target-y 0))
    (with-slots (inputs orientation) self
      (if (null inputs)
          (layout-as-null self)
          (ecase orientation
            (:horizontal (layout-horizontally self))
            (:vertical (layout-vertically self)))))
            (call-next-method)
    (move-to self (window-origin-x) (- (+ (window-origin-y) *screen-height*) (slot-value self 'height)))
    (resize self *screen-width* (slot-value self 'height)))

  (defmethod layout :after ((self shell))
    (when *menubar* (layout *menubar*)))

  (defmethod insert-output ((self shell) item)
    (unfreeze (input-node self :output))
    (accept (input-node self :output) item)
    (freeze (input-node self :output)))

  (defmethod destroy-output ((self shell))
    (mapc #'destroy (%inputs (input-node self :output)))
    (setf (slot-value (input-node self :output) 'inputs) nil))

  (defmethod replace-output ((self shell) items)
    (destroy-output self)
    (dolist (item items)
      (insert-output self item)))

(defmethod hit ((self menu) mouse-x mouse-y)
  (with-slots (x y expanded inputs width height) self
    (when (within-extents mouse-x mouse-y x y (+ x width) (+ y height))
      (flet ((try (item)
               (hit item mouse-x mouse-y)))
        (if (not expanded)
            self
            (some #'try inputs))))))
            ;; ;; we're expanded. is the mouse to the left of this
            ;; ;; tree's header tab thingy?
            ;; (if (slot-value self 'top-level)
            ;;  (when (and (< mouse-x (+ x (header-width self)))
            ;;             (< (header-height self) mouse-y))
            ;;    (some #'try inputs))
            ;;  (or (some #'try inputs) self)))))))

(defmethod hit ((self shell) x y)
  (with-buffer self 
    (with-slots (inputs) self
      (labels ((try (b)
                 (when b 
                   (hit b x y))))
        (when inputs
           (find-if #'try inputs))))))

  ;; (defmethod hit ((self shell) x y)
  ;;   (when (within-extents x y (slot-value self 'x) (slot-value self 'y) (+ (slot-value self 'x) (slot-value self 'width)) (+ (slot-value self 'y) (slot-value self 'height)))
  ;;     (flet ((try (thing)
  ;;           (hit thing x y)))
  ;;    (or (some #'try (%inputs (slot-value self 'output)))
  ;;        self))))

  (defmethod tap ((self shell) x y)
    (focus-on-entry self))

  (defmethod alternate-tap ((self shell) x y) nil)

  (defmethod get-prompt-label ((self shell)) (first (%inputs (input-node self :xcommand-area))))
  (defmethod set-prompt-label ((self shell) label) (set-value (get-prompt-label self) label))
  (defmethod get-prompt ((self shell)) (second (%inputs (input-node self :command-area))))
  (defmethod set-prompt-line ((self shell) line) (set-value (get-prompt self) line))
  (defmethod get-modeline ((self shell)) (input-node self :modeline))
  (defmethod get-output ((self shell)) (input-node self :output))

  (defmethod get-output-items ((self shell)) 
    (let ((phrase (first (%inputs (get-output self)))))
      (when phrase (%inputs phrase))))

  (defmethod get-dialog ((self shell))
    (first (%inputs (get-output self))))

  (defmethod get-argument-phrases ((self shell))
    (let ((container (second (get-output-items self))))
      (when (xelfp container) (%inputs container))))

  (defmethod get-entries ((self shell))
    (cons (get-prompt self)
          (mapcar #'second (mapcar #'%inputs (get-argument-phrases self)))))

  (defmethod evaluate-output ((self shell))
    (replace-output self (list (make-phrase (evaluate (get-dialog self))))))

  (defmethod current-entry ((self shell))
    (let ((entries (get-entries self)))
      (with-slots (entry-index) self 
        (setf entry-index (mod entry-index (length entries)))
        (nth entry-index entries))))

  (defmethod focus-on-entry ((self shell))
    (let ((entry (current-entry self)))
      (set-read-only entry nil)
      (grab-focus entry)
      (end-of-line entry)))

  (defmethod next-entry ((self shell))
    (incf (slot-value self 'entry-index))
    (focus-on-entry self))

  (defmethod previous-entry ((self shell))
    (decf (slot-value self 'entry-index))
    (focus-on-entry self))

  (defmethod draw-background ((self shell) &key color)
    (with-slots (x y width height) self
      (draw-box x y (+ x width) (+ y height) :color "gray50" :alpha 0.8)))

  (defmethod draw ((self shell))
    (with-style :flat
      (draw-background self))
    (mapc #'draw (slot-value self 'inputs))
    (when *notification*
      (draw *notification*)))

  (defun shell () *shell*)
  (defun shell-prompt () (get-prompt (shell)))
  (defun shell-modeline () (get-modeline (shell)))
  (defun shell-output () (get-output (shell)))
  (defun shell-insert-output (object) (insert-output (shell) object))
  (defun shell-destroy-output () (destroy-output (shell)))
  (defun shell-evaluate-output ()  (evaluate-output (shell)))

Automatic layout

   (defmethod update :after ((self shell))
      (layout self)
      (mapc #'layout (%inputs self))
      (mapc #'update (%inputs self))
      (when (and *menubar* (paused-p (current-buffer)))
        (layout *menubar*)
        (update *menubar*)))

System menu and commands

Dialog box builder

(defclass dialog (phrase) 
  ((orientation :initform :vertical)
   (no-background :initform nil)
   (style :initform :rounded)))

(defmethod draw-background ((self dialog) &key color)
  (with-slots (x y width height) self
    (draw-patch self x y (+ x width) (+ y height) :color color :style :rounded)))

(defmethod tap ((dialog dialog) x y)
  (bring-to-front (or (parent dialog) dialog))
  (when (parent dialog) 
    (tap (parent dialog) x y)))

(defmethod freeze :after ((dialog dialog))
  (mapc #'freeze (inputs dialog)))

(defmacro define-dialog (name arglist &body body)
  `(progn
     (defun ,(action-name name) (&key ,@(mapcar #'car arglist)) ,@body)
     (export ',(action-name name))
     (defun ,(show-name name) (&rest args) 
       (show-dialog (apply #'make-instance ',(dialog-class-name name) args)
                    ,(command-name-string name)
                    :destroy-after-evaluate-p t))
     (export ',(show-name name))
     (define-visual-macro ,(dialog-class-name name)
         (:super dialog
                 :slots ((orientation :initform :vertical)
                         (no-background :initform t))
                 :inputs ,(command-inputs name arglist)))
     (export ',(dialog-class-name name))
     (defmethod evaluate ((self ,(dialog-class-name name)))
       ;; call the command function
       (apply #'funcall #',(action-name name)
              ;; with the evaluated results of
              (mapcar #'evaluate 
                      ;; all the argument names/values
                      (mapcan #'identity 
                              (mapcar #'%inputs 
                                      ;; from the dialog box
                                      (%inputs (first (slot-value self 'inputs))))))))))

(defmacro define-command-dialog (name arglist &body body)
  `(define-dialog ,name ,arglist 
     (labels ((arg (name) (getf ^args^ name)))
       ,@body)))

(defclass property-sheet (dialog)
  ((orientation :initform :vertical)
   (initial-values :initform nil)
   (instance :initform nil :initarg :instance :accessor instance)
   (properties :initform nil :initarg :properties :accessor properties)))

(defmethod find-methods append ((dialog dialog))
  '(evaluate restore-initial-values cancel))

(defclass property-row (phrase)
  ((no-background :initform nil)
   (style :initform :rounded)))

(defmethod focus-on :after ((buffer buffer) (row property-row) &key (clear-selection t))
  (when row
    (focus-on buffer (second (inputs row)))))

(defclass property-value-entry (expression-entry) ())

(defmethod backtab ((entry property-value-entry))
  (backtab (current-buffer)))

(defmethod find-tab-parent ((entry property-value-entry))
  (parent (parent entry)))

(defmethod find-tab-proxy ((entry property-value-entry))
  (parent entry))

(defmethod evaluate ((entry property-value-entry))
  (get-value entry)) 

(defmethod draw-background ((self property-row) &key color)
  (with-slots (x y width height) self
    (draw-patch self x y (+ x width) (+ y height) :depressed nil :style :rounded)))

(defmethod initialize-instance :after ((sheet property-sheet) &key)
  (with-slots (inputs properties instance initial-values) sheet
    (dolist (property properties)
      (let ((row (make-sentence
                  (list
                   (make-instance 'pretty-symbol-entry
                                  :value property
                                  :locked t
                                  :read-only t)
                   (make-instance 'property-value-entry
                                  :value (slot-value instance property)
                                  :read-only nil))
                  'property-row)))
        ;; (setf (no-background row) nil)
        (push row inputs)
        (push (slot-value instance property) initial-values)))
    (setf initial-values (nreverse initial-values))
    (setf inputs (nreverse inputs))
    (update-parent-links sheet)
    (freeze sheet)))

(defmethod restore-initial-values ((sheet property-sheet))
  (with-slots (inputs properties instance initial-values) sheet
    (let ((i inputs)
          (d initial-values))
      (flet ((entry () (second (inputs (first i)))))
        (dolist (property properties)
          (set-value (entry) (pop d))
          (pop i))))))

(defmethod get-property-object-pairs ((sheet property-sheet))
  (mapcar #'inputs (inputs sheet)))

(defmethod get-property-entries ((sheet property-sheet))
  (apply #'append (get-property-object-pairs sheet)))

(defmethod get-property-list ((sheet property-sheet))
  (mapcar #'evaluate (get-property-entries sheet)))

(defmethod apply-properties ((sheet property-sheet) &optional instance)
  (let ((plist (get-property-list sheet))
        (i (or instance (instance sheet))))
    (loop while plist do
         (let* ((slot (pop plist))
                (value (pop plist)))
           (setf (slot-value i slot) value)))))

(defmethod check-properties ((sheet property-sheet) &optional instance)
  (let ((plist (get-property-list sheet))
        (i (or instance (instance sheet))))
    (block checking
      (loop while plist do
           (let* ((slot (pop plist))
                  (value (pop plist)))
             (when (not (check-value-for-slot value i slot))
               (notify (format nil "Error: Value ~S is of wrong type for slot ~S." value slot))
               (return-from checking nil))))
      (return-from checking t))))

(defmethod cancel ((sheet property-sheet))
  (if (parent sheet)
      (destroy (parent sheet))
      (destroy sheet)))

(defmethod evaluate ((sheet property-sheet))
  (when (check-properties sheet)
    (apply-properties sheet (instance sheet))))

(defvar *instance* nil)

(defmacro define-properties-dialog (name slot-names &rest body)
  `(progn
     (defun ,(show-name name) (&optional (instance *instance*))
       (show-dialog (make-instance ',(dialog-class-name name) :instance instance)
                    ,(command-name-string name)
                    :destroy-after-evaluate-p nil))
     (defclass ,(dialog-class-name name) (property-sheet)
       ((properties :initform ',slot-names)))))

System object

(defvar *system* nil)

(defclass system (node)
  ((type :initform :system)
   (running :initform nil)))

(defmethod add-widget ((buffer buffer) (node node))
  (when (not (contains buffer node))
    (push node (inputs buffer))
    (adopt buffer node)))
    
(defmethod remove-widget ((buffer buffer) (node node))
  (delete-input buffer node))

(defun show-dialog (dialog title &key destroy-after-evaluate-p)
  (let ((frame (make-frame title dialog :destroy-after-evaluate-p destroy-after-evaluate-p)))
    (add-node (current-buffer) frame)
    (layout dialog)
    (layout frame)
    (center frame)
    (align-to-pixels frame)
    (freeze dialog)
    (close-menus *menubar*)
    nil))

(defun do-cut ()
  (cut))

(defun do-copy ()
  (copy))

(defun do-paste ()
  (paste))

(defun transport-play ()
  (play (current-buffer)))

(defun transport-pause ()
  (pause (current-buffer)))

(defun show-copyright-notice ()
  (let ((notice (make-instance 'text :text *copyright-notice*)))
    (add-node (current-buffer) notice 80 80)
    (resize-to-scroll notice 300 300)
    (setf (slot-value notice 'max-displayed-lines) 20)
    (layout notice)
    (center notice)
    (align-to-pixels notice)
    (bring-to-front notice)))

(defun save-before-exit ())

(defun create-project ())

;; (defun open-existing-project ((self system) (project-name string :default " "))
             
(defun save-changes ()
  (save-project))

(defun save-everything ()
  (save-project :force))

(defun create-trash ()
  (add-block (shell) (make-instance 'trash) 100 100))

(defun create-text ()
  (add-block (shell) (make-instance 'text) 100 100))

;; (defun create-listener ()
;;   (add-block (shell) (new listener) 100 100))

(defun ticks ()
  (get-ticks))

(defun exit-xelf* ()
  ;; TODO destroy textures
  (exit-xelf))

User dialogs

(define-dialog visit-buffer
    ((buffer-name (or (first *buffer-history*) 
                      (buffer-name (current-buffer)))))
  (at-next-update (switch-to-buffer buffer-name)))

(define-dialog create-buffer
    ((buffer-name (uniquify-buffer-name "*untitled*"))
     (buffer-class (class-name (class-of (current-buffer)))))
  (at-next-update
   (switch-to-buffer (make-instance buffer-class :buffer-name buffer-name))))

(define-dialog paste-as-new-buffer
    ((buffer-name (uniquify-buffer-name "*pasted-buffer*"))
     (buffer-class (class-name (class-of (current-buffer))))
     (offset-x 0)
     (offset-y 0))
  (at-next-update
   (let ((buffer (make-instance buffer-class :buffer-name buffer-name)))
     (switch-to-buffer buffer-name)
     (paste (current-buffer) offset-x offset-y)
     (trim-conservatively (current-buffer)))))

(define-properties-dialog buffer-properties 
    (buffer-name width height z-sort-p background-image background-color 
                 window-scrolling-speed horizontal-scrolling-margin vertical-scrolling-margin))

(defmethod apply-properties :after ((dialog buffer-properties-dialog) &optional buffer)
  (notify (format nil "Applied buffer properties to ~S." buffer))
  (let ((buffer (or buffer (current-buffer))))
    (with-slots (height width buffer-name) buffer
      (resize buffer width height)
      (rename-buffer buffer buffer-name))))

(define-properties-dialog project-properties
    (path width height double-tap-time scale-output-to-window frame-rate resizable author author-contact title license))

(defmethod apply-properties :after ((dialog project-properties-dialog) &optional project)
  (with-slots (name path resizable scale-output-to-window frame-rate title author author-contact
                    width height double-tap-time license) project
    (setf *scale-output-to-window* scale-output-to-window)
    (set-frame-rate frame-rate)
    (setf *title* title)
    (setf *double-tap-time* double-tap-time)
    (setf *author* author)
    (setf *author-contact* author)
    (setf *screen-width* width)
    (setf *screen-height* height)
    (setf *resizable* resizable))
  (notify (format nil "Applied project properties to ~S." project)))

(defun all-buffer-names ()
  (loop for name being the hash-keys of *buffers* collect name))
(define-dialog change-buffer-class 
    ((new-class (class-name (class-of (current-buffer)))))
  (change-class (current-buffer) new-class))

Menu bar structure

(defparameter *project-menu*
  '(:label "Project"
     :inputs
     (;; (:label "Create a new project" :action create-project)
      ;; (:label "Open an existing project" :action open-existing-project)
      (:label "Save current changes" :action save-changes)
      (:label "Edit project properties" :action do-show-project-properties-dialog)
      (:label "Show current changes" :action show-changes)
      (:label "Show classes" :action show-classes-dialog)
      (:label "Export as archive" :action show-export-archive-dialog)
      (:label "Export as application" :action show-export-application-dialog)
      (:label "Publish to FTP" :action show-publish-ftp-dialog)
      (:label "Edit preferences" :action edit-preferences)
      (:label "Exit" :action show-exit-dialog))))

(defun do-show-project-properties-dialog ()
  (show-project-properties-dialog (current-project)))

(defparameter *edit-menu* 
  '(:label "Edit"
    :inputs
    ((:label "Cut" :action do-cut)
     (:label "Copy" :action do-copy)
     (:label "Paste" :action do-paste)
     (:label "Paste as new buffer" :action show-paste-as-new-buffer-dialog)
     (:label "Paste from" :action show-paste-from-dialog)
     (:label "Paste selection from" :action show-paste-selection-from-dialog)
     (:label "Select all" :action select-all)
     (:label "Clear selection" :action clear-selection)
     (:label "Invert selection" :action invert-selection)
     (:label "Node properties" :action show-node-properties-dialog)
     (:label "Shell command history" :action show-shell-history-dialog))))

(defparameter *play-menu*
  '(:label "Play"
    :inputs
    ((:label "Play" :action transport-play)
     (:label "Pause" :action transport-pause))))

(defparameter *buffers-menu*
  '(:label "Buffers"
     :inputs
     ((:label "Create a new buffer" :action show-create-buffer-dialog)
      (:label "Load a buffer from a file" :action show-load-buffer-from-file-dialog)
      (:label "Switch to buffer" :action show-switch-to-buffer-dialog)
      (:label "Edit buffer properties" :action do-show-buffer-properties-dialog)
      ;; (:label "Rename buffer" :action show-rename-buffer-dialog)
      ;; (:label "Resize buffer" :action show-resize-buffer-dialog)
      (:label "Trim empty space" :action do-trim)
      (:label "Trim empty space on right/bottom" :action do-trim-conservatively)
      (:label "Save buffer in project" :action show-save-buffer-in-project-dialog)
      (:label "Copy buffer" :action show-copy-buffer-dialog)
      (:label "Destroy buffer" :action show-destroy-buffer-dialog)
      (:label "Save buffer in new file" :action show-save-buffer-in-new-file-dialog)
      (:label "Change buffer class" :action show-change-buffer-class-dialog)
      (:label "Revert buffer" :action show-revert-buffer-dialog)
      (:label "Resize to background image" :action do-resize-to-background-image)
      (:label "Make snapshot" :action show-take-snapshot-dialog)
      (:label "View clipboard" :action view-clipboard)
      (:label "View buffer list" :action show-buffer-list))))

(defun show-buffer-list ()
  (at-next-update 
    (switch-to-buffer (find-buffer "*buffer-list*" :create t :class 'buffer-list))))

(defun do-resize-to-background-image ()
  (if (background-image (current-buffer))
      (resize-to-background-image (current-buffer))
      (notify "No background image to resize to.")))

(defun do-show-buffer-properties-dialog ()
  (show-buffer-properties-dialog (current-buffer)))

(defun do-trim () (trim (current-buffer)))
(defun do-trim-conservatively () (trim-conservatively (current-buffer)))

(defparameter *view-menu* 
    '(:label "View"
      :inputs
      ((:label "Move viewport to location" :action show-move-viewport-dialog)
      ;;(:label "Edit scrolling properties" :action show-scrolling-properties-dialog)
       (:label "Adjust zoom level" :action show-zoom-level-dialog)
       (:label "Reset zoom level" :action reset-zoom-level))))

(defparameter *resources-menu*
  '(:label "Resources"
    :inputs
    ((:label "Import new resource" :action show-import-resource-dialog)
     (:label "Edit resource properties" :action show-resource-properties-dialog)
     (:label "Edit resource in external program" :action edit-resource-externally)
     (:label "Search resources" :action show-search-resources-dialog)
     (:label "Export resources" :action show-export-resources-dialog)
     (:label "Browse resources" :action browse-resources)
     (:label "Create sprite sheet" :action show-create-sprite-sheet-dialog)
     (:label "Edit sprite sheet" :action show-edit-sprite-sheet-dialog)
     (:label "Edit fonts" :action show-edit-fonts-dialog)
     (:label "Preload resources" :action show-preload-resources-dialog)
     (:label "Clear cached resources" :action show-clear-cached-resources-dialog))))

(defparameter *tools-menu*
  '(:label "Tools" 
    :inputs
    ((:label "Create a Lisp listener" :action create-listener)
     (:label "Create a text box" :action create-text)
     (:label "Create a trash can" :action create-trash))))

(defparameter *desktop-menu*
  '(:label "Desktop" :inputs
     ((:label "Switch to Root Desktop" :action show-root-desktop)
     ;; (:label "Switch to Desktop 2" :action desktop-2)
     ;; (:label "Switch to Desktop 3" :action desktop-3)
     ;; (:label "Switch to Desktop 4" :action desktop-4)
     (:label "Arrange icons" :action auto-arrange-icons)
     (:label "Toggle snap-to-grid" :action toggle-snap-to-grid)
     (:label "Go back to the previous desktop" :action previous-desktop)
     (:label "Create a new desktop" :action create-desktop)
     (:label "Rename this desktop" :action rename-desktop)
     (:label "Delete this desktop" :action delete-desktop)
     (:label "Edit Desktop properties" :action show-desktop-properties-dialog))))

(defun find-root-desktop ()
  (find-buffer "*root-desktop*" :create t :class 'desktop))

(defun show-root-desktop ()
  (at-next-update 
     (switch-to-buffer (find-root-desktop))))

(defparameter *emacs-menu*
  '(:label "Emacs" :inputs
    ((:label "Show Emacs" :action switch-to-emacs)
     (:label "Edit Lisp" :action show-edit-lisp-dialog)
     (:label "Inspect object" :action show-inspect-object-dialog)
     (:label "Version control" :action show-version-control-dialog))))

(defparameter *windows-menu*
  '(:label "Windows"
    :inputs
    ((:label "Create a new window" :action create-window)
     (:label "Switch to the next window" :action next-window)
     (:label "Switch to window" :action switch-window)
     (:label "Close this window" :action close-window))))

(defparameter *devices-menu*
  '(:label "Devices"
    :inputs
    ((:label "Browse available devices" :action browse-devices)
     (:label "Scan for devices" :action scan-for-devices)
     (:label "Configure joystick" :action configure-joystick)
     (:label "Configure keyboard" :action configure-keyboard))))
     ;;(:label "Configure microphone" :action configure-microphone))))
     ;; (:label "Configure dance pad" :action configure-dance-pad))))

(defparameter *help-menu*
  '(:label "Help"
    :inputs
    ((:label "Copyright notice" :action show-copyright-notice)
     (:label "Documentation" :action show-documentation)
     (:label "General help" :action show-help)
     (:label "Examples" :action show-examples)
     (:label "API Reference" :action show-reference))))

(defun system-menu-entries ()
  (apply #'append
         (mapcar #'list (list *project-menu*
                              *edit-menu*
                              *play-menu*
                              *buffers-menu*
                              *view-menu*
                              *resources-menu*
                              *desktop-menu*
                              *emacs-menu*
                              ;; *tools-menu*
                              ;; *windows-menu*
                              *devices-menu*
                              *help-menu*))))

(defparameter *system-menu* (system-menu-entries))

Traveling nodes

(defclass traveler (node)
  ((parent-buffer :initform nil)))

(defmethod add-node :before ((new-buffer buffer) (traveler traveler) &optional x y z)
  (with-slots (parent-buffer) traveler
    (when (and (not (null parent-buffer))
               (xelfp parent-buffer)
               (not (object-eq new-buffer parent-buffer)))
      (remove-node parent-buffer traveler)
      (setf parent-buffer new-buffer))))

Menubar class

(defclass menubar (tree traveler)
    ((category :initform :menu)
     (temporary :initform t)))

(defmethod make-halo ((self menubar)) nil)

(defmethod collide ((menu menu) (node node)) nil)
(defmethod collide ((node node) (menu menu)) nil)

(defmethod update :after ((self menubar))
    (layout self)
    (dolist (input (inputs self))
      (layout input)
      (mapc #'layout (inputs input))))

(defmethod initialize-instance :after ((self menubar) &key (menus *system-menu*))
  (with-slots (inputs) self
    (layout self)
    (setf inputs (make-menu menus))
    (dolist (each inputs)
      (setf (slot-value each 'top-level) t)
      (pin each))))

(defmethod hit ((self menubar) mouse-x mouse-y)
  (with-slots (x y width height inputs) self
    (when (within-extents mouse-x mouse-y x y (+ x width) (+ y height))
      ;; are any of the menus open?
      (let ((opened-menu (find-if #'expanded inputs)))
        (labels ((try (m)
                   (when m (hit m mouse-x mouse-y))))
          (let ((moused-menu (find-if #'try inputs)))
            (if (and ;; moused-menu opened-menu
                     (object-eq moused-menu opened-menu))
                ;; we're over the opened menu, let's check if 
                ;; the user has moused onto the other parts of the menubar
                (flet ((try-other (menu)
                         (when (not (object-eq menu opened-menu))
                           (try menu))))
                  (let ((other (some #'try-other inputs)))
                    ;; are we touching one of the other menubar items?
                    (if (null other)
                        ;; nope, just hit the opened submenu items.
                        (try opened-menu)
                        ;; yes, switch menus.
                        (prog1 other
                          (unexpand opened-menu)
                          (expand other)))))
                ;; we're somewhere else. just try the main menus in
                ;; the menubar.
                (let ((candidate (find-if #'try inputs)))
                  (if (null candidate)
                      ;; the user moused away. close the menus.
                      self
                      ;; we hit one of the other menus.
                      (if opened-menu
                          ;; there already was a menu open.
                          ;; close this one and open the new one.
                          (prog1 candidate
                            (unexpand opened-menu)
                            (expand candidate))
                          ;; no menu was open---just hit the menu headers
                          (some #'try inputs)))))))))))

(defmethod draw-border ((self menubar) &optional ignore) nil)

(defmethod layout ((self menubar))
  (with-slots (x y width height inputs) self
    (setf x (window-origin-x) y (window-origin-y) width *screen-width* height (dash 1)) 
    (let ((x1 (dash 1)))
      (dolist (item inputs)
        (move-to item x1 y)
        (layout item)
        (incf x1 (dash 1 (header-width item)))
        (setf height (max height (slot-value item 'height)))))))
        
(defmethod draw ((self menubar))
  (with-slots (x y width inputs) self
    (let ((bar-height (dash 2 2 (font-height *font*))))
      (draw-box x y 
                width bar-height
                :color "gray18")
      (draw-line x bar-height width bar-height
                 :color "gray30")
      (with-slots (inputs) self
        (dolist (each inputs)
          (draw each))))))

(defmethod draw :around ((self menubar))
  (when (shell-p (current-buffer))
    (call-next-method)))

(defmethod close-menus ((self menubar))
  (with-slots (inputs) self
    (when (some #'expanded inputs)
      (mapc #'unexpand inputs))))

(defmethod tap ((self menubar) x y)
  (let ((target (hit self x y)))
    (show-status (format nil "Hitting target ~S" target))
    (when (and (xelfp target)
               (not (object-eq target self)))
      (tap target x y))
      (close-menus self)))

;; Don't allow anything to be dropped on the menus, for now.

(defmethod draw-hover ((self menubar)) nil)

(defmethod accept ((self menubar) thing)
  (declare (ignore thing))
  nil)

Floating window frames

(define-handle frame-close-button :close
  :slots ((target-frame :initform nil :initarg :target-frame :accessor target-frame)))

(defmethod tap ((self frame-close-button) x y)
  (with-slots (parent) self
    (when parent (at-next-update (destroy (parent parent))))))

(defmethod layout ((self frame-close-button))
  (resize self 20 20))

(defclass titlebar-label (label) ())

(defmethod tap ((self titlebar-label) x y)
  (let ((it (parent (parent self))))
    (when it
      (tap it x y))))

(define-visual-macro titlebar
    (:super phrase
            :slots ((frozen :initform t)
                    (orientation :initform :horizontal)
                    (no-background :initform t) 
                    (spacing :initform 2)
                    (dash :initform 1)
                    (category :initform :system))
            :inputs (:close-button (make-instance 'frame-close-button)
                     :title (make-instance 'titlebar-label :font "sans-bold-11" :read-only t :locked t))))

(defmethod set-title ((self titlebar) title)
  (set-value (input-node self :title) title))

(define-visual-macro frame
    (:super phrase
            :slots ((frozen :initform t)
                    (orientation :initform :vertical)
                    (no-background :initform t)
                    (spacing :initform 2)
                    (dash :initform 1)
                    (style :initform :rounded)
                    (destroy-after-evaluate-p 
                     :initform t 
                     :initarg :destroy-after-evaluate-p
                     :accessor destroy-after-evaluate-p)
                    (category :initform :system))
            :inputs (:titlebar (make-instance 'titlebar)
                     :content (make-instance 'label :read-only t))))

(defmethod set-title ((self frame) title)
  (set-title (input-node self :titlebar) title))

(defmethod set-content ((self frame) content)
  (destroy (input-node self :content))
  (with-slots (inputs) self
    (setf (second inputs) content)))

(defun make-frame (title content &key destroy-after-evaluate-p (class 'frame))
  (let ((frame (make-instance class :destroy-after-evaluate-p destroy-after-evaluate-p)))
    (prog1 frame
      (set-title frame title)
      (set-content frame content)
      (center frame)
      (add-node (current-buffer) frame))))

(defmethod update :before ((self frame))
  (layout self))

(defmethod draw :before ((self frame))
  (multiple-value-bind (top left right bottom) (bounding-box self)
    (draw-patch self left top right bottom :color "gray30" :style :rounded)))

(defmethod destroy :before ((frame frame))
  (mapc #'destroy (inputs frame)))

(defmethod evaluate ((frame frame))
  (evaluate (second (inputs frame))))

(defmethod evaluate :after ((frame frame))
  (when (destroy-after-evaluate-p frame)
    (destroy frame)))

(defmethod make-halo :after ((frame frame))
  (bring-to-front (slot-value frame 'halo))
  (bring-to-front frame))

(defmethod context-menu ((frame frame))
  (context-menu (second (inputs frame))))

(defmethod show-context-menu ((node node))
  (let ((menu (context-menu node)))
    (when menu
      (add-node (current-buffer) menu)
      (move-to menu (window-pointer-x) (window-pointer-y))
      (bring-to-front menu))))

;; (defmethod as-drag ((self menu) x y)
;;   (make-menu-frame self))

Context menus

(defmethod make-method-menu-item ((self node) method target)
  (assert (and target method (symbolp method)))
  (let ((method-string (pretty-string method)))
    (list :label method-string
          :pinned t
          :locked t
          :method method
          :target (find-object target)
          :action (make-instance 'task :method-name method :target (find-object target)))))

(defclass context-menu (menu)
  ((no-background :initform nil)
   (category :initform :text)))

(defclass context-menu-item (menu)
  ((category :initform :text)))

(defmethod tap :around ((menu context-menu-item) x y)
  (call-next-method)
  (destroy (parent menu)))

(defmethod context-menu ((self node))
    (let ((methods (find-methods self)))
      (when methods
        (let (inputs)
          (dolist (method methods)
            (push (make-method-menu-item self method self) inputs))
          (flet ((menu-item (args)
                   (make-menu args :target self :class 'context-menu-item)))
            (make-instance 'context-menu
                           :inputs (mapcar #'menu-item (nreverse inputs))
                           :pinned nil
                           :expanded t
                           :locked t))))))

(defmethod initialize-instance :after ((menu context-menu) &key)
  (layout menu)
  (freeze menu))

(defmethod draw :before ((menu context-menu))
  (with-slots (x y width height) menu
    (draw-patch menu x y (+ width x) (+ y height) :style :rounded )))

(defmethod draw-highlight ((self context-menu))
  (with-slots (y height expanded action parent) self
    (when parent
      (with-slots (x width) parent
        (when (not expanded) 
          (draw-box (+ x (dash 3))
                    (+ y (dash 1)) 
                    (- width (dash 4))
                    (+ height 1)
                    :color *highlight-background-color*)
          (draw-label-string self (display-string self) *highlight-foreground-color*))))))

TODO Emacs live integration   experimental

Show methods definitions in Emacs   emacs

  (defmethod show-method ((self node) method)
    (let ((sym (definition method (find-object self))))
      (assert (symbolp sym))
      (let ((name (string-upcase 
                 (format nil "~A::~A"
                         (package-name (symbol-package sym))
                         (symbol-name sym)))))
        (eval-in-emacs `(glass-show-definition ,name)))))

  (defmethod show-definition ((self node))
    (let ((name 
          (concatenate 'string 
                       (package-name *package*)
                       "::"
                       (prototype-variable-name 
                        (find-super-prototype-name self)))))
      (message "SHOWING DEF ON CL SIDE: ~S" name)
      (eval-in-emacs `(glass-show-definition ,name))))

Evaluate expressions in emacs

  (defun eval-in-emacs (expression)
    (if (find-package :swank)
        (let ((sym (intern "EVAL-IN-EMACS" (find-package :swank))))
          (funcall sym expression))
        (message "(eval-in-emacs) failed; swank/emacs not available?")))

Switching between the Xelf and Emacs windows

  (defmethod toggle-other-windows ((self buffer))
    (glass-toggle))

  (defun glass-toggle ()
    (eval-in-emacs '(glass-toggle)))

  (defun glass-show ()
    (eval-in-emacs '(glass-show)))

  (defun glass-hide ()
    (eval-in-emacs '(glass-hide)))

  (defun glass-show-at (x y)
    (eval-in-emacs 
     `(glass-show :x ,x :y ,y)))

Spreadsheets

(defun make-vector (n i)
  (make-array n :initial-element i :adjustable t))

(defun make-grid (rows cols)
  (let ((grid (make-vector rows nil)))
    (dotimes (row rows) 
      (setf (aref grid row) (make-vector cols nil))) 
    grid))

(defun grid-get (grid row col)
  (aref (aref grid row) col))

(defun grid-set (grid row col value)
  (let ((row (aref grid row)))
    (setf (aref row col) value)))

(defun grid-columns (grid)
  (length (aref grid 0)))

(defun grid-rows (grid)
  (length grid))

(defun vector-insert (oldvec pos elt)
  "Insert ELT into VECTOR at POS, moving elements at POS and
afterward down the list."
  (let* ((len (length oldvec))
         (newvec (make-vector (+ len 1) nil)))
    (dotimes (i (+ 1 len))
      (setf (aref newvec i) (cond 
                             (( < i pos)
                              (aref oldvec i))
                             (( equal i pos)
                              elt)
                             (( > i pos) 
                              (aref oldvec (- i 1))))))
    newvec))

(defun vector-delete (oldvec pos)
  "Remove position POS from OLDVEC."
  (let* ((len (length oldvec))
         (newvec (make-vector (- len 1) nil)))
    (dotimes (i (- len 1))
      (setf (aref newvec i) (cond
                             (( < i pos)
                              (aref oldvec i))
                             (( >= i pos)
                              (aref oldvec (+ i 1))))))
    newvec))

(defun grid-insert-row (grid row)
  "Returns a new grid with a row inserted at row ROW. You should
  replace the original grid with this one."
  (let* ((newrow (make-vector (grid-columns grid) nil)))
    (vector-insert grid row newrow)))
        
(defun grid-insert-column (grid col)
  "Returns a new grid with a column inserted at column COL. You
should replace the original grid with this one."
  (dotimes (i (grid-rows grid))
    (setf (aref grid i) (vector-insert (aref grid i) col nil)))
  grid)

(defun grid-delete-row (grid row)
  "Returns a new grid with the row ROW removed. You should replace the original 
grid with this one."
  (vector-delete grid row))

(defun grid-delete-column (grid col)
  "Returns a new grid with the column COL removed. You should
replace the original grid with this one."
  (dotimes (i (grid-rows grid))
    (setf (aref grid i) (vector-delete (aref grid i) col)))
  grid)

(defclass sheet (buffer) 
  ((top-margin :initform 18 :initarg :top-margin :accessor top-margin)
   (node-spacing :initform 10 :initarg :node-spacing :accessor node-spacing)
   (node-size :initform *default-icon-size* :initarg :node-size :accessor node-size)
   (snap-to-grid-p :initform t :initarg :snap-to-grid-p :accessor snap-to-grid-p)
   (x-offset :initform 0 :initarg :x-offset :accessor x-offset)
   (y-offset :initform 0 :initarg :x-offset :accessor x-offset)))

(defmethod top-margin ((sheet sheet))
  (if (shell-p sheet)
      (+ 8 (font-height *font*))
      0))

(defmethod find-methods append ((sheet sheet)) '(clean-up auto-arrange toggle-snap-to-grid))

(defmethod node-stride ((sheet sheet))
  (+ (node-size sheet)
     (node-spacing sheet)))

(defmethod populate ((sheet sheet)) nil)

(defmethod initialize-instance :after ((sheet sheet) &key)
  (resize sheet *screen-width* *screen-height*)
  (open-shell sheet)
  (populate sheet))

(defmethod grid-position ((sheet sheet) x y)
  (let ((stride (node-stride sheet))
        (spacing (node-spacing sheet))
        (top-margin (top-margin sheet)))
    (values (+ spacing (* x stride))
            (+ top-margin spacing (* y stride)))))

(defmethod place-node ((sheet sheet) (node node) x y)
  (move-to node x y))

(defmethod auto-resize ((node node) (sheet sheet))
  (let ((size (node-size sheet)))
    (resize node size size)))

(defmethod last-column ((sheet sheet))
  (1- (length (aref (grid sheet) 0))))

(defmethod last-row ((sheet sheet))
  (1- (length (grid sheet))))

(defmethod last-screen-column ((sheet sheet))
  (1- (truncate (/ *screen-width* (node-stride sheet)))))

(defmethod last-screen-row ((sheet sheet))
  (1- (truncate (/ *screen-height* (node-stride sheet)))))

(defmethod snap-to-grid ((node node) (sheet sheet))
  (with-slots (x y) node
    (place-node sheet node
                (truncate (/ x (node-stride sheet)))
                (truncate (/ y (node-stride sheet))))))

(defmethod toggle-snap-to-grid ((sheet sheet))
  (setf (snap-to-grid-p sheet) (if (snap-to-grid-p sheet) nil t)))

Cell spreadsheets

(defclass cell-sheet (sheet)
  ((grid :initform (make-grid 20 8) :accessor grid :initarg :grid)
   (node-spacing :initform 2 :initarg :node-spacing :accessor node-spacing)
   (cursor-row :initform 0 :initarg :cursor-row :accessor cursor-row)
   (cursor-column :initform 0 :initarg :cursor-column :accessor cursor-column)
   (row-heights :initform nil :initarg :row-heights :accessor row-heights)
   (column-widths :initform nil :initarg :column-widths :accessor column-widths)
   (column-labels :initform nil :initarg :column-labels :accessor column-labels)
   (borders-p :initform nil :initarg :borders-p :accessor borders-p)
   (headers-p :initform t :initarg :headers-p :accessor headers-p)))

(defmethod populate ((sheet sheet))
  (dotimes (row (grid-rows (grid sheet)))
    (dotimes (column (grid-columns (grid sheet)))
      (setf (cell sheet row column)
            (make-instance 'property-value-entry :value 
               (or (percent-of-time 50 (random 382712))
                   (random-choose '("a string" "a longer string" "(empty)"))))))))

(defmethod find-methods append ((sheet cell-sheet)) 
  '(toggle-headers toggle-borders toggle-snap-to-grid))

(defmethod toggle-headers ((sheet cell-sheet))
  (setf (headers-p sheet) (if (headers-p sheet) nil t)))

(defmethod set-cell ((sheet cell-sheet) (node node) row column)
  (add-node sheet node)
  (grid-set (grid sheet) row column node))

(defmethod get-cell ((sheet cell-sheet) row column)
  (grid-get (grid sheet) row column))

(defmethod cell ((sheet cell-sheet) row column)
  (get-cell sheet row column))

(defmethod (setf cell) ((node node) (sheet cell-sheet) row column)
  (set-cell sheet node row column))

(defmethod insert-row ((sheet cell-sheet))
  (with-slots (grid cursor-row) sheet
    (setf grid (grid-insert-column grid cursor-row))))

(defmethod insert-column ((sheet cell-sheet))
  (with-slots (grid cursor-column) sheet
    (setf grid (grid-insert-column grid cursor-column))))

(defmethod delete-row ((sheet cell-sheet))
  (with-slots (grid cursor-row) sheet
    (setf grid (grid-delete-column grid cursor-row))))

(defmethod delete-column ((sheet cell-sheet))
  (with-slots (grid cursor-column) sheet
    (setf grid (grid-delete-column grid cursor-column))))

(defmethod set-cursor ((sheet cell-sheet) row column)
  (setf (cursor-row sheet) row)
  (setf (cursor-column sheet) column))

(defmethod move-cursor ((sheet cell-sheet) direction)
  (with-slots (grid cursor-row cursor-column) sheet
    (let* ((rows (grid-rows grid))
           (cols (grid-columns grid))
           (cursor (list cursor-row cursor-column))
           (new-cursor
            (case direction
              (:up (if (/= 0 cursor-row)
                       (list (- cursor-row 1) cursor-column)
                       cursor))
              (:left (if (/= 0 cursor-column)
                         (list cursor-row (- cursor-column 1))
                         cursor))
              (:down (if (< cursor-row (- rows 1))
                         (list (+ cursor-row 1) cursor-column)
                         cursor))
              (:right (if (< cursor-column (- cols 1))
                          (list cursor-row (+ cursor-column 1))
                          cursor)))))
      (destructuring-bind (row column) new-cursor
        (set-cursor sheet row column)))))

(defmethod move-cursor-up ((sheet cell-sheet))
  (move-cursor sheet :up))

(defmethod move-cursor-left ((sheet cell-sheet))
  (move-cursor sheet :left))

(defmethod move-cursor-down ((sheet cell-sheet))
  (move-cursor sheet :down))

(defmethod move-cursor-right ((sheet cell-sheet))
  (move-cursor sheet :right))

(defmethod all-cells ((sheet cell-sheet))
  (let ((grid (grid sheet))
        (cell nil)
        (cells nil))
    (dotimes (r (grid-rows grid))
      (dotimes (c (grid-columns grid))
        (when (setf cell (grid-get grid r c))
          (push cell cells))))
    (nreverse cells)))

(defparameter *sheet-header-font* "sans-9")

(defmethod header-width ((sheet cell-sheet))
  (if (headers-p sheet)
      (+ 12 (font-text-width (format nil "~d" (grid-rows (grid sheet))) *sheet-header-font*))
      0))

(defmethod header-height ((sheet cell-sheet))
  (if (headers-p sheet) 
      (font-height *sheet-header-font*)
      0))

(defparameter *minimum-column-width* 12)
(defparameter *minimum-row-height* 12)

(defmethod layout ((sheet cell-sheet))
  (with-slots (grid cursor-row node-spacing cursor-column column-widths row-heights headers-p borders-p) sheet
    (let* ((rows (grid-rows grid))
           (columns (grid-columns grid))
           (column-width 0)
           (row-height 0)
           (cell-width 0)
           (cell nil)
           (row-header-width 0)
           (column-header-height 0)
           (widths (make-vector columns 0))
           (heights (make-vector rows 0))
           (top-margin (top-margin sheet)))
      ;; compute row header width for along left side
      (setf row-header-width (header-width sheet))
      (setf column-header-height (header-height sheet))
      ;; compute widths of columns
      (dotimes (col columns)
        (setf column-width *minimum-column-width*)
        (dotimes (row rows)
          (setf cell (cell sheet row col))
          (when cell
            (layout cell)
            (setf column-width (max column-width (width cell)))))
        (setf (aref widths col) column-width))
      ;; compute heights of rows
      (dotimes (row rows)
        (setf row-height *minimum-row-height*)
        (dotimes (col columns)
          (setf cell (cell sheet row col))
          (when cell
            (setf row-height (max row-height (height cell)))))
        (setf (aref heights row) row-height))
      ;; save layout info
      (setf row-heights heights)
      (setf column-widths widths)
      ;; move objects
      (dotimes (row rows)
        (dotimes (column columns)
          (let ((cell (cell sheet row column)))
            (when cell
              (multiple-value-bind (top left right bottom)
                  (cell-bounding-box sheet row column)
                (move-to cell left top)
                (setf (fixed-width cell) (aref column-widths column))))))))))
          
(defmethod auto-arrange ((sheet cell-sheet))
  (layout sheet))              

(defmethod cell-at ((sheet sheet) x y)
  (block finding
    (dotimes (row (grid-rows (grid sheet)))
      (dotimes (column (grid-columns (grid sheet)))
        (let ((cell (cell sheet row column)))
          (when (hit cell x y)
            (return-from finding
              (values cell row column))))))
    (values nil nil nil)))

Rendering cell sheets

(defmethod draw-cell ((sheet cell-sheet) (node node))
  (draw node))

(defmethod cell-bounding-box ((sheet cell-sheet) row column)
  (let* ((top 
          (+ (header-height sheet)
             (top-margin sheet)
             (reduce #'+ (subseq (row-heights sheet)
                                 0 row))))
         (left
          (+ (header-width sheet)
             (reduce #'+ (subseq (column-widths sheet)
                                 0 column))))
         (right (+ left (aref (column-widths sheet) column)))
         (bottom (+ top (aref (row-heights sheet) row))))
    (values top left right bottom)))

(defparameter *empty-cell-color* "gray40")

(defmethod draw-empty-cell ((sheet cell-sheet) row column)
  (multiple-value-bind (top left right bottom)
      (cell-bounding-box sheet row column)
    (draw-box left top (- right left) (- bottom top)
              :color *empty-cell-color*)))

(defmethod row-header-bounding-box ((sheet cell-sheet) row)
  (let* ((top 
          (+ (header-height sheet)
             (top-margin sheet)
             (reduce #'+ (subseq (row-heights sheet)
                                 0 row))))
         (left 0)
         (right (header-width sheet))
         (bottom (+ top (aref (row-heights sheet) row))))
    (values top left right bottom)))

(defmethod column-header-bounding-box ((sheet cell-sheet) column)
  (let* ((top (top-margin sheet))
         (left 
          (+ (header-width sheet)
             (reduce #'+ (subseq (column-widths sheet)
                                 0 column))))
         (right (+ left (aref (column-widths sheet) column)))
         (bottom (+ top (header-height sheet))))
    (values top left right bottom)))

(defmethod draw-header-cell ((sheet cell-sheet) string top left right bottom)
  (draw-box left top (- right left) (- bottom top) :color "gray20")
  (draw-string string left top :color "white" :font *sheet-header-font*))

(defmethod row-label ((sheet cell-sheet) row)
  (format nil "~d" row))

(defmethod column-label ((sheet cell-sheet) column)
  (with-slots (column-labels) sheet
    (if (and (consp column-labels)
             (> (length column-labels)
                column))
        (nth column column-labels)
        (format nil "~d" column))))
             
(defmethod draw-row-header ((sheet cell-sheet) row)
  (apply #'draw-header-cell
         sheet
         (row-label sheet row)
         (multiple-value-list 
          (row-header-bounding-box sheet row))))

(defmethod draw-column-header ((sheet cell-sheet) column)
  (apply #'draw-header-cell
         sheet
         (column-label sheet column)
         (multiple-value-list 
          (column-header-bounding-box sheet column))))

(defmethod draw ((sheet cell-sheet))
  (layout sheet)
  (draw-box 0 0 *screen-width* *screen-height* :color "gray30")
  (when (row-heights sheet)
    (dotimes (row (grid-rows (grid sheet)))
      (draw-row-header sheet row)
      (dotimes (column (grid-columns (grid sheet)))
        (draw-column-header sheet column)))
    (do-nodes (node sheet)
      (draw node))))

(defmethod process-tap :after ((cell-sheet cell-sheet) (node node) x y)
  (multiple-value-bind (cell row column) (cell-at cell-sheet x y)
    (when cell
      (glide-window-to-node cell-sheet node))))

Buffer list sheet

(defclass buffer-list (cell-sheet) 
  ((column-labels :initform '("Name" "Class" "Objects" "File"))))

(defmethod populate ((buffer-list buffer-list))
  (setf (grid buffer-list) (make-grid (hash-table-count *buffers*) 4))
  (let ((row 0))
    (dolist (buffer-name (all-buffer-names))  
      (let ((buffer (find-buffer buffer-name)))
        (setf (cell buffer-list row 0) (make-instance 'string-entry :value buffer-name :label buffer-name))
        (setf (cell buffer-list row 1) (make-instance 'property-value-entry :value (class-name (class-of buffer))))
        (setf (cell buffer-list row 2) (make-instance 'property-value-entry :value (hash-table-count (objects buffer))))
        (setf (cell buffer-list row 3) (make-instance 'property-value-entry :value (buffer-file-name buffer))))
      (incf row))))

(defmethod process-tap :after ((buffer-list buffer-list) (node node) x y)
  (multiple-value-bind (cell row column) (cell-at buffer-list x y)
    (when cell
      (let ((buffer (get-value (cell buffer-list row 0))))
        (at-next-update (switch-to-buffer buffer))))))

(defmethod visit :after ((buffer-list buffer-list))
  (with-slots (grid) buffer-list
    (setf grid nil)
    (do-nodes (node buffer-list)
      (destroy node))
    (populate buffer-list)))
(defclass image-preview (node) ())

(defmethod initialize-instance :after ((image-preview image-preview) &key image)
  (setf (slot-value image-preview 'image) image)
  (resize image-preview 64 64))

(defmethod draw ((image-preview image-preview))
  (with-slots (image x y width height) image-preview
    (draw-image image x y :width width :height height)))

(defclass image-list (cell-sheet) 
  ((column-labels :initform '("Preview" "Width" "Height" "File"))))

(defmethod populate ((image-list image-list))
  (let ((images (all-image-names (current-project))))
    (setf (grid image-list) (make-grid (length images) 4))
    (let ((row 0))
      (dolist (image-name images)
        (setf (cell image-list row 0) (make-instance 'image-preview :image image-name))
        (setf (cell image-list row 1) (make-instance 'property-value-entry :value (image-width image-name)))
        (setf (cell image-list row 2) (make-instance 'property-value-entry :value (image-height image-name)))
        (setf (cell image-list row 3) (make-instance 'property-value-entry :value (find-file (current-project) image-name)))
        (incf row)))))

;; (defmethod process-tap :after ((image-list image-list) (node node) x y)
;;   (multiple-value-bind (cell row column) (cell-at image-list x y)
;;     (when cell
;;       (let ((buffer (get-value (cell image-list row 0))))
;;      (at-next-update (switch-to-buffer buffer))))))

(defmethod visit :after ((image-list image-list))
  (with-slots (grid) image-list
    (setf grid nil)
    (do-nodes (node image-list)
      (destroy node))
    (populate image-list)))

Desktop

The included icons are inspired by the Xerox Star interface. Ironically, when using SBCL these objects are also implemented via PCL, the CLOS implementation written originally by Xerox.

(defparameter *default-icon-size* 64)

(defvar *icon-size* *default-icon-size*)

(defparameter *icon-font* "sans-9")

(defparameter *default-icon-color* "white")

(defparameter *icon-images*
  '(:empty "icon-empty.png"
    :caption "icon-caption.png"
    :document "icon-document.png"
    :folder "icon-folder.png"
    :grid "icon-grid.png"
    :open-folder "icon-open-folder.png"
    :project "icon-project.png"))

(defun icon-image (name)
  (getf *icon-images* name))

(defclass icon (node)
  ((image :initform (icon-image :empty) :initarg :image :accessor image)
   (color :initform *default-icon-color* :initarg :color :accessor color)
   (left-margin :initform 5 :initarg :left-margin :accessor left-margin)
   (last-tap-time :initform nil)
   (right-margin :initform 5 :initarg :right-margin :accessor right-margin)
   (bottom-margin :initform 15 :initarg :bottom-margin :accessor bottom-margin)
   (caption :initform nil :initarg :caption :accessor caption)
   (action :initform nil :initarg :action :accessor action)))

(defparameter *double-tap-time* 8)

(defmethod tap ((self icon) x y)
  (with-slots (last-tap-time) self
    (let* ((time *updates*)
           (elapsed-time (- time (or last-tap-time 0))))
      (cond ((null last-tap-time)
             (setf last-tap-time time))
            ((<= elapsed-time *double-tap-time*)
             (setf last-tap-time nil)
             (double-tap self x y))))))

(defmethod update :before ((self icon))
  (with-slots (last-tap-time) self
    ;; we actually catch the end of single-click here.
    (when (and last-tap-time
               (> (- *updates* last-tap-time)
                  *double-tap-time*))
      (setf last-tap-time nil)
      (select self))))

(defmethod double-tap ((self icon) x y)
  (evaluate self))

(defmethod initialize-instance :after ((icon icon) &key caption action)
  (resize icon *icon-size* *icon-size*))

(defmethod draw ((icon icon))
  (with-slots (x y width height caption color left-margin right-margin bottom-margin image) icon
    (set-vertex-color color)
    (draw-image image x y :width width :height height)
    (set-vertex-color "white")
    (when caption
      (draw-string caption (+ x left-margin) (- (+ y height) bottom-margin) :color "black" :font *icon-font*))))

(defparameter *default-desktop-background-color* "gray30")

(defclass desktop (sheet)
  ((background-color :initform *default-desktop-background-color*)
   (top-margin :initform 18 :initarg :top-margin :accessor top-margin)))

(defmethod find-methods append ((desktop desktop)) '(clean-up auto-arrange))

(defmethod clean-up ((desktop desktop))
  (dolist (node (find-instances desktop 'node))
    (snap-to-grid node desktop)
    (auto-resize node desktop)))

(defmethod auto-arrange-column ((desktop desktop) nodes column)
  (let ((row (last-screen-row desktop)))
    (dolist (node nodes)
      (multiple-value-bind (x y) (grid-position desktop column row)
        (place-node desktop node x y)
        (decf row)))))

(defmethod auto-arrange ((desktop desktop))
  (let* ((nodes-per-column (last-screen-row desktop))
         (last-screen-column (last-screen-column desktop))
         (column last-screen-column)
         (nodes (find-instances desktop 'node)))
    (loop while (and nodes
                     (not (minusp column)))
         do (progn (if (> (length nodes) nodes-per-column)
                       (progn
                         (auto-arrange-column desktop (subseq nodes 0 (1- nodes-per-column)) column)
                         (setf nodes (subseq nodes nodes-per-column)))
                       (auto-arrange-column desktop nodes column))
                   (decf column)))))

(defun strip-asterisks (string)
  (remove #\* string))

(defclass folder-icon (icon)
  ((image :initform (icon-image :folder))
   (bottom-margin :initform 18 :initarg :bottom-margin :accessor bottom-margin)
   (buffer-name :initform nil :initarg :buffer-name :accessor buffer-name)))

(defmethod initialize-instance :after ((icon folder-icon) &key buffer-name)
  (setf (caption icon) (strip-asterisks buffer-name)))

(defmethod evaluate ((icon folder-icon))
  (at-next-update (switch-to-buffer
                   (find-buffer (buffer-name icon)
                                :create t
                                :class 'desktop))))

(defclass buffer-icon (icon)
  ((image :initform (icon-image :grid))
   (buffer-name :initform nil :initarg :buffer-name :accessor buffer-name)))

(defmethod initialize-instance :after ((icon buffer-icon) &key buffer-name)
  (setf (caption icon) buffer-name))

(defmethod evaluate ((icon buffer-icon))
  (at-next-update (switch-to-buffer
                   (find-buffer (buffer-name icon)
                                :create t
                                :class 'buffer))))

(defclass button-icon (icon)
  ((image :initform (icon-image :caption))
   (action :initform nil :initarg :action :accessor action)))

(defmethod initialize-instance :after ((icon button-icon) &key action)
  (when (null (caption icon))
    (setf (caption icon) (format nil "~S" action))))

(defmethod evaluate ((icon button-icon))
  (funcall (action icon)))

(defclass text-icon (icon)
  ((image :initform (icon-image :document))
   (text :initform nil :initarg :text :accessor text)
   (left-margin :initform 14 :initarg :left-margin :accessor left-margin)
   (right-margin :initform 5 :initarg :right-margin :accessor right-margin)
   (bottom-margin :initform 17 :initarg :bottom-margin :accessor bottom-margin)
   (title :initform nil :initarg :title :accessor title)))

(defmethod initialize-instance :after ((icon text-icon) &key buffer-name title)
  (setf (caption icon) title))

(defmethod evaluate ((icon text-icon))
  (let ((text (make-instance 'text :text (text icon))))
    (add-node (current-buffer) text)
    (center text)
    (bring-to-front text)
    (align-to-pixels text)))
(defmethod default-icons ((desktop desktop))
  (list
   (make-instance 'text-icon :text *help-text* :title "Help")
   (make-instance 'text-icon :text *copyright-notice* :title "License")
   (make-instance 'button-icon
                  :image (icon-image :open-folder) 
                  :caption "Cell sheet"
                  :action #'(lambda ()
                              (at-next-update
                                (switch-to-buffer
                                 (make-instance 'cell-sheet :buffer-name "*cell sheet*")))))
   ;; (make-instance 'buffer-icon :buffer-name "New Buffer")
   ;; (make-instance 'buffer-icon :buffer-name "New Class")
   ;; (make-instance 'folder-icon :buffer-name "Classes")
   ;; (make-instance 'folder-icon :buffer-name "Resources")
   ;; (make-instance 'folder-icon :buffer-name "Buffers")
   (make-instance 'button-icon :image (icon-image :project) 
                  :action #'show-buffer-list
                  :caption "Buffer List")
   (make-instance 'button-icon :image (icon-image :project) 
                  :action #'show-image-list
                  :caption "Image List")))

(defun show-image-list ()
 (at-next-update (switch-to-buffer (find-buffer "*image-list*" :create t :class 'image-list))))

(defmethod populate ((desktop desktop))
  (dolist (icon (default-icons desktop))
    (add-node desktop icon))
  (auto-arrange desktop))

(defmethod resize :after ((desktop desktop) width height)
  (auto-arrange desktop))
(defclass buffer-frame (frame)
  ((buffer :initarg :buffer :accessor buffer)))

(defmethod initialize-instance :after ((frame buffer-frame) &key buffer)
  (assert (not (null buffer)))
  (set-title frame (buffer-name buffer))
  (set-content frame buffer)
  (resize frame 320 200))

(defmethod layout ((frame buffer-frame)) nil)

(defmethod resize :after ((frame buffer-frame) width height)
  (with-slots (x y buffer) frame
    (clip buffer x y width height)))

(defun show-cell-sheet ()
  (let ((frame (make-instance 'buffer-frame :buffer (make-instance 'cell-sheet))))
    (add-node (current-buffer) frame)
    (resize frame 400 300)
    (center frame)
    (align-to-pixels frame)
    (bring-to-front frame)))

(defun show-cell-sheet* ()
  (let ((sheet (find-buffer "*cell sheet*" :create t :class 'cell-sheet)))
    (add-node (current-buffer) sheet)
    ;; (resize sheet 400 400)
    (move-to sheet 200 200)))

Author: David O'Toole <dto@xelf.me>

Created: 2017-05-03 Wed 16:01

Validate