From 7474c1e8bd948f993d42b1f343d6fdd18f65dcf6 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Wed, 8 Jul 1992 11:34:54 +0000 Subject: [PATCH] Initial revision --- demo/graphics-editor.lisp | 467 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 467 insertions(+) create mode 100644 demo/graphics-editor.lisp diff --git a/demo/graphics-editor.lisp b/demo/graphics-editor.lisp new file mode 100644 index 00000000..ae6851bb --- /dev/null +++ b/demo/graphics-editor.lisp @@ -0,0 +1,467 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-lisp; Package: (GRAPHICS-EDITOR :use (CLIM-LISP CLIM)); Base: 10; Lowercase: Yes -*- + +;; $fiHeader$ + +(eval-when (compile load eval) +(defpackage graphics-editor + (:use clim-lisp clim)) +) ;eval-when + +(in-package :graphics-editor) + + + +;;; Define a "mix-in" frame class that manages a selected object + +;;--- This facility is not part of CLIM itself, but is part of a +;;--- graphical editing system that I have been developing privately, +;;--- which I call Zdrava. + +(define-application-frame selected-object-mixin () + ((selected-object :accessor frame-selected-object + :initform nil)) + (:command-definer nil)) + +(defmethod object-selected-p ((frame selected-object-mixin) object) + (eql object (frame-selected-object frame))) + +;; Deselect the current object and select the new one. Tick the redisplay +;; tick to force the handles to be displayed. +(defmethod select-object ((frame selected-object-mixin) object) + (when (frame-selected-object frame) + (deselect-object frame (frame-selected-object frame))) + (setf (frame-selected-object frame) object) + (tick-object object)) + +;; Deselect the current object and tick the redisplay tick. +(defmethod deselect-object ((frame selected-object-mixin) object) + (setf (frame-selected-object frame) nil) + (tick-object object)) + + +;;; Define the basic object handle class + +;;--- This facility is part of Zdrava. + +(defclass object-handle (standard-point) + ((object :initarg :object :reader handle-object) + (type :initarg :type :reader handle-type))) + +;; Moving a handle causes tha object it is attached to to be reshaped. +(defmethod move-handle ((handle object-handle) x y) + (setf (point-x handle) x) + (setf (point-y handle) y) + (reshape-object (handle-object handle) x y (handle-type handle))) + + +;;; Define the basic object classes + +;;--- This facility is part of Zdrava. + +(defclass basic-object (standard-bounding-rectangle) + ((style :accessor object-style ;all objects have a line style + :initform (make-line-style :thickness 1 :dashes nil) :initarg :style) + (redisplay-tick :initform 0))) ;redisplay when this changes + +;; Ticking the object causes it to be redisplayed +(defmethod tick-object ((object basic-object)) + (incf (slot-value object 'redisplay-tick))) + +;; All objects participate in redisplay... +(defmethod draw-object :around ((object basic-object) stream) + (updating-output (stream :unique-id object + :cache-value (slot-value object 'redisplay-tick)) + (call-next-method) + (when (object-selected-p *application-frame* object) + (draw-object-handles object stream)))) + +(defmethod draw-object ((object basic-object) stream) + (declare (ignore stream ink))) + +(defmethod draw-object-handles ((object basic-object) stream) + (declare (ignore stream ink))) + +;; For simplicity, moving an object entails moving its bounding box. +(defmethod move-object ((object basic-object) x y) + (multiple-value-bind (width height) (bounding-rectangle-size object) + (clim-utils:bounding-rectangle-set-edges object x y (+ x width) (+ y height)))) + +;; Moving (or reshaping) requires redisplay +(defmethod move-object :after ((object basic-object) x y) + (declare (ignore x y)) + (tick-object object)) + +(defmethod reshape-object :after ((object basic-object) x y type) + (declare (ignore x y type)) + (tick-object object)) + + +(defclass object-with-handles-mixin () + ((handles :initform nil))) + +(defmethod object-handles ((object object-with-handles-mixin)) + (when (null (slot-value object 'handles)) + (setf (slot-value object 'handles) (compute-object-handles object))) + (slot-value object 'handles)) + +(defun make-handle (object x y type) + (make-instance 'object-handle :x x :y y :object object :type type)) + +(defmethod draw-object-handles ((object object-with-handles-mixin) stream) + (dolist (handle (object-handles object)) + (multiple-value-bind (x y) (point-position handle) + ;; Present the object as an OBJECT-HANDLE so that commands in the + ;; application can be written using that presentation type. + (with-output-as-presentation (stream handle 'object-handle) + (draw-rectangle* stream (- x 2) (- y 2) (+ x 2) (+ y 2) + :filled t))))) + +;; Moving (or reshaping) an object changes its handle locations +(defmethod move-object :after ((object object-with-handles-mixin) x y) + (declare (ignore x y)) + (setf (slot-value object 'handles) nil)) + +(defmethod reshape-object :after ((object object-with-handles-mixin) x y type) + (declare (ignore x y type)) + (setf (slot-value object 'handles) nil)) + + + +;;; Define the box and arrow classes + +;;--- Using Zdrava, a programmer would build these classes out of the +;;--- classes supplied by Zdrava. + +(defclass box (object-with-handles-mixin basic-object) + ((label :initarg :label :reader box-label) + (arrow-in :initform nil :accessor box-arrow-in) + (arrow-out :initform nil :accessor box-arrow-out))) + +(defun make-box (left top right bottom label style) + (make-instance 'box :left left :top top :right right :bottom bottom + :label label :style style)) + +(defmethod compute-object-handles ((object box)) + (with-bounding-rectangle* (left top right bottom) object + (list (make-handle object left top :nw) + (make-handle object right top :ne) + (make-handle object left bottom :sw) + (make-handle object right bottom :se)))) + +(defmethod draw-object ((object box) stream) + (with-bounding-rectangle* (left top right bottom) object + ;; Present the object as a BOX so that commands in the application + ;; can be written using that presentation type. + (with-output-as-presentation (stream object 'box :single-box t) + (draw-rectangle* stream left top right bottom + :filled nil :line-style (object-style object)) + (draw-text* stream (box-label object) (+ left (floor (- right left) 2)) (+ top 2) + :align-x :center :align-y :top)))) + +(defmethod move-object :after ((object box) x y) + (declare (ignore x y)) + (when (box-arrow-in object) + (tick-object (box-arrow-in object))) + (when (box-arrow-out object) + (tick-object (box-arrow-out object)))) + +(defmethod reshape-object ((object box) x y type) + (with-bounding-rectangle* (left top right bottom) object + (ecase type + (:nw (setq left x + top y)) + (:ne (setq right x + top y)) + (:sw (setq left x + bottom y)) + (:se (setq right x + bottom y))) + (clim::bounding-rectangle-set-edges object left top right bottom))) + +(defmethod reshape-object :after ((object box) x y type) + (declare (ignore x y type)) + (when (box-arrow-in object) + (tick-object (box-arrow-in object))) + (when (box-arrow-out object) + (tick-object (box-arrow-out object)))) + + +(defclass arrow (object-with-handles-mixin basic-object) + ((box1 :initarg :box1) + (box2 :initarg :box2))) + +(defun make-arrow (box1 box2 style) + (let ((arrow (make-instance 'arrow :box1 box1 :box2 box2 + :style style))) + (setf (box-arrow-out box1) arrow) + (setf (box-arrow-in box2) arrow) + arrow)) + +(defmethod draw-object ((object arrow) stream) + (with-slots (box1 box2) object + (multiple-value-bind (x1 y1) (clim-utils::bounding-rectangle-center* box1) + (multiple-value-bind (x2 y2) (clim-utils::bounding-rectangle-center* box2) + (with-output-as-presentation (stream object 'arrow) + (draw-arrow* stream x1 y1 x2 y2 + :line-style (object-style object))))))) + +(defmethod compute-object-handles ((object arrow)) + (with-slots (box1 box2) object + (multiple-value-bind (x1 y1) (clim-utils::bounding-rectangle-center* box1) + (multiple-value-bind (x2 y2) (clim-utils::bounding-rectangle-center* box2) + (list (make-handle object x1 y1 nil) + (make-handle object x2 y2 nil)))))) + + +;;; The application itself + +(define-application-frame graphics-editor (selected-object-mixin) + ((objects :initform nil) + (counter :initform 0) + (last-box :initform nil) + (style :initform (make-line-style :thickness 1 :dashes nil))) + (:command-definer define-ged-command) + (:command-table (graphics-editor :inherit-from (accept-values-pane))) + (:pointer-documentation t) + ;; Three panes: a display pane, and command menu, and a modeless + ;; dialog containing the line style options + (:panes + (display :application + :incremental-redisplay t + :display-after-commands t + :display-function 'display-objects + :scroll-bars :both) + (options :accept-values + :display-function '(accept-values-pane-displayer + :displayer accept-ged-options))) + (:layouts + (default + (vertically () + (:fill display) + (1/5 options))))) + + +(define-presentation-type line-thickness () + :inherit-from `(integer 1 4)) + +;;--- CLIM should provide a better way to do this one function +(define-presentation-method accept-present-default ((type line-thickness) stream + (view clim-internals::dialog-view-mixin) + default default-supplied-p + present-p + query-identifier &key) + (declare (ignore default-supplied-p present-p)) + (flet ((presenter (thing stream) + (let ((y (stream-line-height stream))) + (with-room-for-graphics (stream) + (draw-rectangle* stream 0 2 16 (- y 2) + :filled nil :ink +background-ink+) + (draw-line* stream 0 (floor y 2) 16 (floor y 2) + :line-thickness thing))))) + (declare (dynamic-extent #'presenter)) + (clim-internals::accept-values-choose-from-sequence-1 + stream '(("1" 1) ("2" 2) ("3" 3) ("4" 4)) + #'second default #'eql type query-identifier + #'(lambda (choice-value query-value) + (declare (ignore query-value)) + choice-value) + #'(lambda (continuation object stream) + (surrounding-output-with-border (stream) + (funcall continuation object stream))) + 'clim-internals::accept-values-one-of #'presenter))) + +(defmethod accept-ged-options ((frame graphics-editor) stream) + (with-slots (style) frame + (flet ((accept (type default prompt query-id) + (fresh-line stream) + (accept type + :stream stream :default default + :query-identifier query-id :prompt prompt))) + (declare (dynamic-extent #'accept)) + (terpri stream) + (let ((thickness (line-style-thickness style)) + (dashes (line-style-dashes style))) + (multiple-value-bind (thickness ignore thickness-changed) + (accept 'line-thickness thickness "Thickness" 'thickness) + (declare (ignore ignore)) + (multiple-value-bind (dashes ignore dashes-changed) + (accept 'boolean dashes "Dashed" 'dashes) + (declare (ignore ignore)) + (when (or thickness-changed dashes-changed) + (setq style (make-line-style :thickness thickness :dashes dashes)) + (when (frame-selected-object frame) + (setf (object-style (frame-selected-object frame)) + (slot-value frame 'style)) + (tick-object (frame-selected-object frame)) + (redisplay-frame-pane frame 'display))))))))) + +(defmethod display-objects ((frame graphics-editor) stream) + (dolist (object (slot-value frame 'objects)) + (draw-object object stream))) + +(define-ged-command com-create-box + ((left 'integer) + (top 'integer)) + (com-deselect-object) + (let ((stream (get-frame-pane *application-frame* 'display)) + (right left) + (bottom top) + (rectangle-drawn nil) + (box nil) + (label (format nil "Box ~D" (slot-value *application-frame* 'counter))) + (last-box (slot-value *application-frame* 'last-box)) + (style (slot-value *application-frame* 'style))) + ;;--- Zdrava supplies primitives to input basic objects such as + ;;--- points, lines, rectangles and polygons, circles and ellipses, + ;;--- and so forth. Using Zdrava, the following code would be a + ;;--- replaced by 3 or 4 lines of code. + (block track-pointer + (with-output-recording-options (stream :draw t :record nil) + (tracking-pointer (stream :multiple-window t) + (:pointer-motion (window x y) + (when rectangle-drawn + (draw-rectangle* stream left top right bottom + :filled nil :ink +flipping-ink+) + (setq rectangle-drawn nil)) + (when (eql window stream) + (setq right x + bottom y) + (draw-rectangle* stream left top right bottom + :filled nil :ink +flipping-ink+) + (setq rectangle-drawn t))) + (:pointer-button-release (event) + (when (eql (event-sheet event) stream) + (when rectangle-drawn + (draw-rectangle* stream left top right bottom + :filled nil :ink +flipping-ink+) + (setq rectangle-drawn nil)) + ;; If the mouse didn't move very far, don't bother + ;; creating a box. Just deselect the current object. + (when (or (> (abs (- right left)) 3) + (> (abs (- bottom top)) 3)) + (multiple-value-bind (width height) + (text-size stream label) + (when (< (- right left) width) + (setq right (+ left width 8))) + (when (< (- bottom top) height) + (setq bottom (+ top height 4)))) + (setq box (make-box left top right bottom label style)) + (return-from track-pointer))) + (beep stream) + (return-from com-create-box))))) + (when box + (setf (slot-value *application-frame* 'objects) + (append (slot-value *application-frame* 'objects) (list box))) + (setf (slot-value *application-frame* 'last-box) box) + (incf (slot-value *application-frame* 'counter)) + (when last-box + (let ((arrow (make-arrow last-box box style))) + (setf (slot-value *application-frame* 'objects) + (append (slot-value *application-frame* 'objects) (list arrow)))))))) + +;; A mouse click over blank area creates a new box. +(define-presentation-to-command-translator create-box + (blank-area com-create-box graphics-editor + :gesture :select :menu nil) + (x y) + (list x y)) + +;; Select an object by clicking "select" (Mouse-Left) on it. +(define-ged-command com-select-object + ((object 'basic-object :gesture :select)) + (select-object *application-frame* object) + (setf (slot-value *application-frame* 'style) (object-style object))) + +;; Deselect an object by clicking the Deselect menu button, or by +;; clicking over blank area without moving the mouse. +(define-ged-command (com-deselect-object :menu "Deselect") () + (when (frame-selected-object *application-frame*) + (deselect-object *application-frame* (frame-selected-object *application-frame*)))) + +;; Move an object by clicking Mouse-Middle on it and dragging the mouse. +(define-ged-command com-move-object + ((object 'box :gesture :describe)) + (let ((stream (get-frame-pane *application-frame* 'display))) + (with-bounding-rectangle* (left top right bottom) object + (multiple-value-bind (x y dx dy) + (dragging-output (stream t t) + ;; Use a rectangle as feedback + (draw-rectangle* stream left top right bottom + :filled nil)) + (move-object object (- x dx) (- y dy)))))) + +;; Delete an object by clicking "delete" (shift-Mouse-Middle) on it. +(define-ged-command com-delete-object + ((object 'basic-object :gesture :delete)) + (delete-object *application-frame* object) + (when (eql object (slot-value *application-frame* 'last-box)) + (setf (slot-value *application-frame* 'last-box) nil))) + +(defmethod delete-object ((frame graphics-editor) (object basic-object)) + (setf (slot-value frame 'objects) + (delete object (slot-value frame 'objects)))) + +(defmethod delete-object :after ((frame graphics-editor) (object box)) + (when (box-arrow-in object) + (delete-object frame (box-arrow-in object))) + (when (box-arrow-out object) + (delete-object frame (box-arrow-out object)))) + +(defmethod delete-object :after ((frame graphics-editor) (object arrow)) + (with-slots (box1 box2) object + (setf (box-arrow-out box1) nil) + (setf (box-arrow-in box2) nil))) + +;; Add a menu item that deletes the selected object +(add-menu-item-to-command-table 'graphics-editor "Delete" + :function 'delete-selected-object) + +(defun delete-selected-object (gesture numeric-arg) + (declare (ignore gesture numeric-arg)) + (and (frame-selected-object *application-frame*) + `(com-delete-object ,(frame-selected-object *application-frame*)))) + +;; Move a handle by clicking Mouse-Middle on it and dragging the mouse. +(define-ged-command com-move-handle + ((handle 'object-handle :gesture :describe)) + (let ((stream (get-frame-pane *application-frame* 'display))) + (multiple-value-bind (x y) (point-position handle) + (multiple-value-bind (x y dx dy) + (dragging-output (stream t t) + (draw-rectangle* stream (- x 2) (- y 2) (+ x 2) (+ y 2) + :filled t)) + (move-handle handle (- x dx) (- y dy)))))) + +;; OK, I added a menu button to clear the window. +(define-ged-command (com-clear :menu t) () + (with-slots (objects selected-object last-box) *application-frame* + (setq objects nil + selected-object nil + last-box nil) + (window-clear (get-frame-pane *application-frame* 'display)))) + +;; OK, I added a menu button to redisplay the window, too, although +;; it's only here for debugging. +(define-ged-command (com-redisplay :menu t) () + (redisplay-frame-pane *application-frame* 'display :force-p t)) + +(define-ged-command (com-quit :menu t) () + (frame-exit *application-frame*)) + + + + +(defvar *graphics-editor* nil) + +(defun do-graphics-editor (&optional force) + (when (or force (null *graphics-editor*)) + (setq *graphics-editor* (make-application-frame 'graphics-editor + :left 100 :top 0 :right 800 :bottom 600 + #+Genera :parent + #+Genera (first clim::*sheet-roots*)))) + (run-frame-top-level *graphics-editor*)) + +(clim-demo::define-demo "Graphics Editor" (do-graphics-editor)) + + + -- GitLab