CLIM mail archive
[Prev][Next][Index][Thread]
Custom-records example slightly refined!
For CLIM2.0'ers ...
I can't seem to reach the clim library from my machine, but I thought I would
send this example out of how to merge output-records with your own classes, so
you can avoid consing output-records to mirror your class objects (everytime
you regenerate the display - which I happen to do bigtime) as was done in the
custom-record example with dataset-output-record for dataset objects.
The toy problem below allows you to add little filled in boxes within
large unfilled boxes and move them around. The little boxes are only allowed
to be moved within their parent box. This assumes a simple two
deep level output-record tree under your history record with no scaling
and such. I also assumed no real change in the extent of the large boxes
once they were made. Enjoy!
;;; -*- Mode: Common-Lisp -*-
(eval-when (load compile eval)
(defpackage clim-problems (:use clim clim-lisp)))
(in-package clim-problems)
(defvar *test* nil)
(defun Simple-Interval-Check (FROM TO BEGIN END)
"(FROM TO BEGIN END)
Arguments FROM Start of something
TO End of something
BEGIN Start of time interval
END End of time interval
Returns T if there is some overlap between FROM & TO with BEGIN & END, else nil
Side-Effect
"
(declare (fixnum BEGIN END FROM TO))
(cond ((= FROM TO) (<= BEGIN FROM END))
((< FROM END) (> TO BEGIN))
((> TO BEGIN) (< FROM END))))
(defclass Leaf-Display-Mixin
(presentation clim-internals::output-record-mixin clim-internals::output-record-element-mixin displayed-output-record)
;; In CLIM1.1 it had as its mixins (presentation output-record-mixin output-record-element-mixin displayed-output-record-element)
((Display-Y :initform 0 :initarg :Display-Y :accessor Display-Y) ;actual locations
(Display-X :initform 0 :initarg :Display-X :accessor Display-X)
(Internal-X :initform 0 :initarg :Internal-X :accessor Internal-X) ;relative locations
(Internal-Y :initform 0 :initarg :Internal-Y :accessor Internal-Y)
(Height :initform 1 :initarg :Height :accessor Height)
(Width :initform 1 :initarg :Width :accessor Width)
(type :initform 'Leaf-Display-Mixin :reader presentation-type)
(parent :initform nil :initarg :parent))
(:documentation "MOST INFERIOR OUTPUT-RECORD (a leaf)"))
(defmethod initialize-instance :after ((SELF Leaf-Display-Mixin) &key PARENT)
(setf (slot-value SELF 'Type) (type-of SELF) (Output-Record-Parent SELF) PARENT))
(defmethod presentation-object ((SELF Leaf-Display-Mixin)) SELF)
(defmethod presentation-single-box ((SELF Leaf-Display-Mixin)) t)
(defmethod tree-recompute-extent ((SELF Leaf-Display-Mixin)) nil)
(defmethod Internal-XY-Position ((SELF Leaf-Display-Mixin)) (values (Internal-X SELF) (Internal-Y SELF)))
(defmethod bounding-rectangle* ((SELF Leaf-Display-Mixin))
(with-slots (Display-X Display-Y Width Height) SELF
(values (- Display-X 1) (- Display-Y 1) (+ Display-X Width 1) (+ Display-Y Height 1))))
(defmethod output-record-cursor-position ((SELF Leaf-Display-Mixin))
;;use to be output-record-start-position*
(with-slots (Display-X Display-Y) SELF (values Display-X Display-Y)))
(defmethod output-record-set-position ((SELF Leaf-Display-Mixin) new-x new-y)
(declare (fixnum new-x new-y))
(setf (Display-X SELF) new-x (Display-Y SELF) new-y))
(defmethod highlight-output-record ((SELF Leaf-Display-Mixin) (STREAM stream) STATE)
;;use to be highlight-output-record-1
(declare (ignore state) (special +flipping-ink+))
(multiple-value-bind (xoff yoff) (convert-from-relative-to-absolute-coordinates STREAM (Output-Record-Parent SELF))
(with-bounding-rectangle* (left top right bottom) SELF
(with-drawing-options (STREAM :ink +flipping-ink+)
(medium-draw-rectangle* STREAM (+ xoff left) (+ yoff top) (+ xoff right) (+ yoff bottom) nil)))))
(defmethod map-over-output-records-overlapping-region
(continuation (SELF Leaf-Display-Mixin) region &optional (x-offset 0) (y-offset 0) &rest continuation-args)
(declare (ignore x-offset y-offset region continuation continuation-args))
nil)
(defmethod map-over-output-records-containing-position
(continuation (SELF Leaf-Display-Mixin) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args)
;;use to be map-over-output-record-elements-containing-point*
(declare (ignore x y x-offset y-offset continuation continuation-args))
nil)
(defmethod Display ((SELF Leaf-Display-Mixin) (STREAM stream) DRAW-MODE)
(declare (type symbol DRAW-MODE) (fixnum Internal-X Internal-Y) (type standard-object Parent))
(case DRAW-MODE
(:Erase (when (Output-Record-Parent SELF)
(with-drawing-options (STREAM :ink +background-ink+)
(multiple-value-bind (left top right bottom) (bounding-rectangle* SELF)
(medium-draw-rectangle* STREAM left top right bottom t)))
(delete-output-record SELF (Output-Record-Parent SELF))))
(t (with-slots (Internal-X Internal-Y Parent) SELF
(add-output-record SELF Parent)
(Output-Record-Set-Position SELF (+ Internal-X (Display-X Parent)) (+ Internal-Y (Display-Y Parent)))
(replay SELF STREAM)))))
(defclass Branch-Display-Mixin (leaf-display-mixin)
;;in CLIM1.1 only had Leaf-Display-Mixin as a superclass
((Inferiors-List :initform nil :Accessor Inferiors-List))
(:documentation "My parent OUTPUT-RECORD that has its own display stuff too!"))
(defmethod output-record-children ((SELF Branch-Display-Mixin)) (Inferiors-List SELF))
(defmethod output-record-element ((SELF Branch-Display-Mixin) index) (nth index (Inferiors-List SELF)))
(defmethod output-record-count ((SELF Branch-Display-Mixin) &key FASTP)
;; use to be output-record-element-count
(length (Inferiors-List SELF)))
(defmethod clear-output-record ((SELF Branch-Display-Mixin)) (setf (Inferiors-List SELF) nil (Output-Record-Parent SELF) nil))
(defmethod add-output-record (ELEMENT (SELF Branch-Display-Mixin))
;;use to be add-output-record-element with args switched!
(setf (Output-Record-Parent ELEMENT) SELF)
(push ELEMENT (Inferiors-List SELF)))
(defmethod delete-output-record (ELEMENT (SELF Branch-Display-Mixin) &optional (errorp t))
;;use to be delete-output-record-element
(declare (ignore errorp))
(setf (Inferiors-List SELF) (delete ELEMENT (Inferiors-List SELF) :count 1)))
(defmethod map-data ((SELF Branch-Display-Mixin) function)
(dolist (element (Inferiors-List SELF)) (funcall function element)))
(defmethod map-data-internal-xy ((SELF Branch-Display-Mixin) function)
(with-slots (Display-X Display-Y) SELF
(map-data SELF #'(lambda (ele)
(multiple-value-bind (int-x int-y) (Internal-XY-Position ele)
(funcall function (+ int-x Display-X) (+ int-y Display-Y) ele))))))
(defmethod adjust-data-display-xy ((SELF Branch-Display-Mixin))
(map-data-internal-xy SELF #'(lambda (x y ele)
(output-record-set-position ele x y)
(clim-utils:bounding-rectangle-set-edges ele (Display-X ele) (Display-Y ele)
(+ (Display-X ele) (Width ele))
(+ (Display-Y ele) (Height ele))))))
(defmethod map-data-display-xy ((SELF Branch-Display-Mixin) function)
(with-slots (Display-X Display-Y) SELF
(map-data-internal-xy SELF #'(lambda (x y ele) (funcall function (+ x Display-X) (+ y Display-Y) ele)))))
(defmethod map-over-output-records-overlapping-region
(continuation (SELF Branch-Display-Mixin) region &optional (x-offset 0) (y-offset 0) &rest continuation-args)
(declare (fixnum x-offset y-offset) (dynamic-extent continuation-args) (type stream stream) (type function continuation))
(cond ((or (null region) (eql region +everywhere+))
(map-data SELF #'(lambda (ele) (apply continuation ele continuation-args))))
(t (with-bounding-rectangle* (left1 top1 right1 bottom1) region
(translate-positions x-offset y-offset left1 top1 right1 bottom1)
(multiple-value-bind (xoff yoff) (output-record-position SELF)
(translate-positions (- xoff) (- yoff) left1 top1 right1 bottom1))
(map-data-display-xy SELF #'(lambda (d-x d-y ele)
(if (Simple-Interval-Check d-x (+ d-x (Width ele)) left1 right1)
(apply continuation ele continuation-args)))))))
nil)
(defmethod map-over-output-records-containing-position
(continuation (SELF Branch-Display-Mixin) x y &optional (x-offset 0) (y-offset 0) &rest continuation-args)
(declare (fixnum x y x-offset y-offset) (dynamic-extent continuation-args) (type function continuation))
(translate-positions x-offset y-offset x y)
(multiple-value-bind (xoff yoff) (output-record-position SELF) (translate-positions (- xoff) (- yoff) x y))
(map-data SELF #'(lambda (ele)
(with-bounding-rectangle* (left top right bottom) ele
(when (clim-utils::ltrb-contains-position-p left top right bottom x y)
(apply continuation ele continuation-args)))))
nil)
(defmethod Display ((SELF Branch-Display-Mixin) (STREAM stream) DRAW-MODE)
(declare (type symbol DRAW-MODE) (fixnum Internal-X Internal-Y) (type list Inferiors-List))
(case DRAW-MODE
(:Erase (when (Output-Record-Parent SELF)
(with-drawing-options (STREAM :ink +background-ink+)
(multiple-value-bind (left top right bottom) (bounding-rectangle* SELF)
(medium-draw-rectangle* STREAM left top right bottom t)))
(delete-output-record SELF (stream-current-output-record STREAM))
(setf (Output-Record-Parent SELF) nil)))
(t (with-slots (Display-X Display-Y Width Height Internal-X Internal-Y Inferiors-List) SELF
(add-output-record SELF (stream-current-output-record STREAM))
(Output-Record-Set-Position SELF Internal-X Internal-Y)
(Adjust-Data-Display-XY SELF)
(replay SELF STREAM)
(clim-utils:bounding-rectangle-set-edges SELF Display-X Display-Y (+ Display-X Width) (+ Display-Y Height))
(recompute-extent-for-new-child (Output-Record-Parent SELF) SELF)))))
(defclass small-box () ()) ;time for an inferior presentation type to inherit
(define-presentation-type small-box ())
(define-presentation-method present (obj 'small-box stream view &key)
(format STREAM "(~d . ~d)" (position (output-record-parent obj) (large-boxes *test*))
(position obj (Inferiors-List (output-record-parent obj)))))
(define-presentation-method accept ((type small-box) (STREAM stream) (view t) &key)
(declare (type string token) (type t obj))
(let* ((token (read STREAM nil nil)))
(cond ((consp token) (return-from accept (nth (cdr token) (Inferiors-List (nth (car token) (large-boxes *test*))))))
(t (input-not-of-required-type token type)))))
(defmethod replay-output-record ((SELF small-box) (STREAM stream) &optional REGION (X-OFFSET 0) (Y-OFFSET 0))
(declare (fixnum X-OFFSET Y-OFFSET Display-X Display-Y Height Width) (ignore REGION))
(with-slots (Display-X Display-Y Height Width) SELF
(medium-draw-rectangle* STREAM (+ Display-X X-OFFSET) (+ Display-Y Y-OFFSET)
(+ Display-X X-OFFSET Width) (+ Display-Y Y-OFFSET Height) t)
(clim-utils:bounding-rectangle-set-edges SELF Display-X Display-Y (+ Display-X Width) (+ Display-Y Height))))
(defclass large-box () ()) ;here is my presentation parent type for inheritance
(define-presentation-type large-box ())
(define-presentation-method present (obj 'large-box stream view &key) (format STREAM "~d" (position OBJ (large-boxes *test*))))
(define-presentation-method accept ((type large-box) (STREAM stream) (view t) &key)
(declare (type string token) (type t obj))
(let* ((token (read-from-string (read-token STREAM) nil)))
(cond ((integerp token) (return-from accept (nth token (large-boxes *test*))))
(t (input-not-of-required-type token type)))))
(defmethod :initialize-instance :after ((self large-box) &key)
(push SELF (large-boxes *test*)))
(defmethod replay-output-record ((SELF large-box) (STREAM stream) &optional REGION (X-OFFSET 0) (Y-OFFSET 0))
(declare (fixnum X-OFFSET Y-OFFSET Display-X Display-Y Height Width) (ignore REGION))
(with-slots (Display-X Display-Y Height Width Inferiors-List) SELF
(medium-draw-rectangle* STREAM (+ Display-X X-OFFSET) (+ Display-Y Y-OFFSET)
(+ Display-X X-OFFSET Width) (+ Display-Y Y-OFFSET Height) nil)
(dolist (ele Inferiors-List) (replay ele STREAM))))
(defclass big-guy (large-box branch-display-mixin) ()) ;here is my big box object
(defclass small-guy (small-box leaf-display-mixin) ()) ;here is my inferior small box object
(define-application-frame test ()
((large-boxes :initform nil :accessor large-boxes) (cursor-list :initform nil :accessor cursor-list))
(:panes (command :interactor :scroll-bars :both)
(display :application :scroll-bars :both)
(Documentation :pointer-documentation :scroll-bars nil))
(:layouts (main (vertically ()
(1/3 command)
(1/2 display)
(1/6 documentation)))))
(defun test ()
(let ((frame (or *test* (setf *test* (make-application-frame 'test :width 500 :height 400)))))
(mp:process-run-function "test" #'run-frame-top-level frame)
(setf (stream-current-output-record (get-frame-pane *test* 'display)) (slot-value (get-frame-pane *test* 'display) 'output-record)
(stream-recording-p (get-frame-pane *test* 'display)) nil)))
(define-command (com-make-large-guy :command-table test :name t) ((x 'integer) (y 'integer) (width 'integer) (height 'integer))
(let ((box (make-instance 'big-guy :internal-x x :internal-y y :width width :height height)))
(display box (get-frame-pane *test* 'display) :draw)
(push box (large-boxes *test*))))
(define-command (com-make-small-guy :command-table test :name t)
((in-box 'large-box) (x-offset 'integer) (y-offset 'integer) (width 'integer) (height 'integer))
"Put a small box inside a large one"
(display (make-instance 'small-guy :internal-x x-offset :internal-y y-offset :width width :height height :parent in-box)
(get-frame-pane *test* 'display) :draw))
(define-command (com-move-large-guy :command-table test :name t) ((which-box 'large-box) (new-x 'integer) (new-y 'integer))
(display which-box (get-frame-pane *test* 'display) :erase)
(setf (Internal-X which-box) new-x (Internal-Y which-box) new-y)
(display which-box (get-frame-pane *test* 'display) :draw))
(define-command (com-move-small-guy :command-table test :name t) ((which-box 'small-box) (new-x 'integer) (new-y 'integer))
(display which-box (get-frame-pane *test* 'display) :erase)
(setf (Internal-X which-box) new-x (Internal-Y which-box) new-y)
(display which-box (get-frame-pane *test* 'display) :draw))
(define-command (com-clear :command-table test :name t) ()
(setf (large-boxes *test*) nil)
(window-clear (get-frame-pane *test* 'command))
(window-clear (get-frame-pane *test* 'display)))
(define-command (com-exit :command-table test :name t) () (frame-exit *test*))
Main Index |
Thread Index