;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: FREE-CLIM; -*- ;;; --------------------------------------------------------------------------- ;;; Title: Free-CLIM -- Output Recording ;;; Created: 2008-03-28 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2008 by Gilbert Baumann ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. (in-package :FREE-CLIM) ;;;; -- Implementation Notes ------------------------------------------------------------------ ;; We implement relative coordinates here. The following agreements ;; exist: ;; - Cooridinates of an output record are in its own coordinate ;; system. ;; - Position is in the coordinate system of the parent ;; - The bounding rectangle is in the coordinate system of the parent ;; [in contrast to sheets]. ;; - region arguments to output record query functions are in the ;; records coordinate space but x-offset and y-offset. ;; However, we might want to draw in some abstraction layer, that ;; would allow us to have both interfaces. S.th. like ;; OUTPUT-RECORD-BOUNDING-RECTANGLE*-IN-STREAM-COORDINATES and ;; OUTPUT-RECORD-BOUNDING-RECTANGLE*-IN-LOCAL-COORDINATES. ;; We even might consider to have the specified interface work at ;; stream coordinates, and introduce new accessors to which operate in ;; local coordinates. ;; Any bounding rectangle that has x1=x2 and y1=y2 is considered ;; empty. ;; Unlike in McCLIM, we don't confuse output records with rectangles ;; and we also don't confuse an output record's position with its ;; bounding rectangle. ;; Like with sheets the primary method of ADD-OUTPUT-RECORD and ;; DELETE-OUTPUT-RECORD just does the change notification, while ;; :before methods specialized on the parent or the child does the ;; book keeping. ;;;; -- TODO ---------------------------------------------------------------------------------- ;; - ### which method should handle errorp in delete-output-record? ;; - ### We really need to specify what exactly x-offset and y-offset ;; is to MAP-OVER-OUTPUT-RECORDS-OVERLAPPING-REGION and ;; REPLAY-OUTPUT-RECORD. ;;;; -- mcclim fixes -------------------------------------------------------------------------- ;; Missing in mcclim: (defmethod bounding-rectangle ((region bounding-rectangle)) (multiple-value-call #'make-rectangle* (bounding-rectangle* region))) ;;;; ------------------------------------------------------------------------------------------ (defclass output-record (bounding-rectangle) ()) (defun output-record-p (object) (typep object 'output-record)) (defclass displayed-output-record (output-record) ()) (defun displayed-output-record-p (object) (typep object 'displayed-output-record)) (defmethod add-output-record ((child output-record) (record output-record)) (recompute-extent-for-new-child record child)) (defmethod delete-output-record ((child output-record) (record output-record) &optional errorp) (declare (ignore errorp)) (multiple-value-call #'recompute-extent-for-changed-child record child (bounding-rectangle* child))) ;;;; -- The whole Output Recording Protocol --------------------------------------------------- ;; This is the whole protocol that needs to be implemented for output ;; records. It is not awfully much. ;; :x-position, :y-position, :parent, :size initargs (defgeneric output-record-position (record)) (defgeneric* (setf output-record-position) (nx ny record)) (defgeneric output-record-start-cursor-position (record)) (defgeneric* (setf output-record-start-cursor-position) (nx ny record)) (defgeneric output-record-end-cursor-position (record)) (defgeneric* (setf output-record-end-cursor-position) (nx ny record)) (defgeneric output-record-parent (record)) (defgeneric replay (record stream &optional region)) (defgeneric replay-output-record (record stream &optional region x-offset y-offset)) (defgeneric output-record-hit-detection-rectangle* (record)) (defgeneric output-record-refined-position-test (record x y)) (defgeneric highlight-output-record (record stream state)) (defgeneric displayed-output-record-ink (displayed-output-record)) (defgeneric output-record-children (record)) (defgeneric add-output-record (child record)) (defgeneric delete-output-record (child record &optional errorp)) (defgeneric clear-output-record (record)) (defgeneric output-record-count (record)) (defgeneric map-over-output-records-containing-position (function record x y &optional x-offset y-offset &rest function-args)) (defgeneric map-over-output-records-overlapping-region (function record region &optional x-offset y-offset &rest function-args)) (defgeneric recompute-extent-for-new-child (record child)) (defgeneric recompute-extent-for-changed-child (record child old-x1 old-y1 old-x2 old-y2)) (defgeneric tree-recompute-extent (record)) ;; bounding-rectangle (defgeneric bounding-rectangle* (record)) ;;;; -- Basic Output Record ------------------------------------------------------------------- ;; Our basic-output-record class includes a position, a parent as well ;; as a bounding box. (defclass basic-output-record (output-record) ((x-position :initarg :x-position :initform 0) (y-position :initarg :y-position :initform 0) (parent :initarg :parent :initform nil :reader output-record-parent) (size :initarg :size :initform 0) ;; The bounding rectangle (bx1 :initform 0 :initarg :bx1) (by1 :initform 0 :initarg :by1) (bx2 :initform 0 :initarg :bx2) (by2 :initform 0 :initarg :by2))) (defmethod output-record-position ((record basic-output-record)) (with-slots (x-position y-position) record (values x-position y-position))) (defmethod* (setf output-record-position) (nx ny (record basic-output-record)) (with-slots (x-position y-position parent) record (multiple-value-bind (ox1 oy1 ox2 oy2) (bounding-rectangle* record) (setf x-position nx) (setf y-position ny) (when parent (recompute-extent-for-changed-child parent record ox1 oy1 ox2 oy2)) (values nx ny)))) (defmethod bounding-rectangle* ((record basic-output-record)) (with-slots (x-position y-position bx1 by1 bx2 by2) record (values (+ x-position bx1) (+ y-position by1) (+ x-position bx2) (+ y-position by2)))) (defmethod add-output-record :before ((child basic-output-record) record) (with-slots (parent) child (setf parent record))) (defmethod delete-output-record :before ((child basic-output-record) record &optional errorp) (declare (ignore record errorp)) (with-slots (parent) child (setf parent nil))) ;;;; -- Standard Sequence Output Record ------------------------------------------------------- (defclass standard-sequence-output-record (basic-output-record) ;; does this have a cursor start/end position? ((children :initform nil :reader output-record-children) )) (defclass standard-tree-output-record (standard-sequence-output-record) ;for now ()) ;; (defgeneric output-record-position (record)) -- defined in basic-output-record ;; (defgeneric* (setf output-record-position) (nx ny record)) -- defined in basic-output-record ;; (defgeneric output-record-start-cursor-position (record)) nyi ;; (defgeneric* (setf output-record-start-cursor-position) (nx ny record)) nyi ;; (defgeneric output-record-end-cursor-position (record)) nyi ;; (defgeneric* (setf output-record-end-cursor-position) (nx ny record)) nyi ;; (defgeneric output-record-parent (record)) -- defined in basic-output-record (defmethod replay ((record basic-output-record) stream &optional region) (setf region (or region +everywhere+)) ;; ### (setf region (region-intersection region (sheet-effective-region stream))) ;; draw? (with-output-recording-options (stream :record nil) (replay-output-record record stream region 0 0))) (defmethod replay-output-record ((record standard-sequence-output-record) stream &optional region x-offset y-offset) (setf region (or region +everywhere+) x-offset (or x-offset 0) y-offset (or y-offset 0)) (map-over-output-records-overlapping-region (lambda (child) (multiple-value-bind (px py) (output-record-position child) (replay-output-record child stream region (+ px x-offset) (+ py y-offset)))) record region x-offset y-offset)) ;;(defmethod output-record-hit-detection-rectangle* ((record standard-sequence-output-record))) ;;(defmethod output-record-refined-position-test ((record standard-sequence-output-record) x y)) ;;(defmethod highlight-output-record ((record standard-sequence-output-record) stream state)) ;;(defmethod displayed-output-record-ink (displayed-output-record)) ;; (defmethod output-record-children ((record standard-sequence-output-record))) -- defined as reader (defmethod add-output-record :before (child (record standard-sequence-output-record)) (with-slots (children) record (setf children (nconc children (list child))))) (defmethod delete-output-record :before (child (record standard-sequence-output-record) &optional errorp) (declare (ignore errorp)) (with-slots (children) record (setf children (delete child children)))) (defmethod clear-output-record ((record standard-sequence-output-record)) ;; hmm (mapc #'(lambda (c) (delete-output-record c record)) (copy-seq (output-record-children record)))) (defmethod output-record-count ((record standard-sequence-output-record)) (length (output-record-children record))) #+NYI (defmethod map-over-output-records-containing-position (function (record standard-sequence-output-record) x y &optional x-offset y-offset &rest function-args)) (defmethod map-over-output-records-overlapping-region (function (record standard-sequence-output-record) region &optional x-offset y-offset &rest function-args) (setf x-offset (or x-offset nil)) (setf y-offset (or y-offset nil)) (loop for child in (output-record-children record) do (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* child) (when (region-intersects-region-p region (make-rectangle* (+ x-offset x1) (+ y-offset y1) (+ x-offset x2) (+ y-offset y2))) (apply function child function-args))))) ;; Hmm ... No idea, if this is a good idea. (clim-sys:defresource rectangle (x1 y1 x2 y2) :constructor (make-rectangle* x1 y1 x2 y2) :initializer (let ((v (slot-value rectangle 'climi::coordinates))) (setf (svref v 0) x1 (svref v 1) y1 (svref v 2) x2 (svref v 3) y2)) :matcher t) (defmethod map-over-output-records-overlapping-region (function (record standard-sequence-output-record) region &optional x-offset y-offset &rest function-args) (setf x-offset (or x-offset nil)) (setf y-offset (or y-offset nil)) (cond ((eql region +everywhere+) (loop for child in (output-record-children record) do (apply function child function-args))) ((eql region +nowhere+) ;; nothing to doe nil) (t (multiple-value-bind (rx1 ry1 rx2 ry2) (bounding-rectangle* region) (loop for child in (output-record-children record) do (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* child) (incf x1 x-offset) (incf x2 x-offset) (incf y1 y-offset) (incf y2 y-offset) (when (and (and (<= rx1 x2) (<= x1 rx2) (<= ry1 y2) (<= y1 ry2)) (clim-sys:using-resource (rectangle rectangle x1 y1 x2 y2) (region-intersects-region-p region rectangle))) (apply function child function-args)))))))) (declaim (inline bbox-empty-p)) (defun bbox-empty-p (x1 y1 x2 y2) (and (= x1 x2) (= y1 y2))) (defmethod recompute-extent-for-new-child ((record standard-sequence-output-record) child) ;; This is the very same situation as the child previously being just empty. (unless (multiple-value-call #'bbox-empty-p (bounding-rectangle* child)) (recompute-extent-for-changed-child record child 0 0 0 0))) (defmethod recompute-extent-for-changed-child ((record standard-sequence-output-record) child ocx1 ocy1 ocx2 ocy2) ;; We are careful here to handle all the cases of one of the partners being ;; empty. As otherwise we easily can wind up with excessivly large bounding ;; boxes, if the (0,0) point coming from the empty bounding box is included. (with-slots (parent bx1 by1 bx2 by2 x-position y-position) record (multiple-value-bind (ox1 oy1 ox2 oy2) (values bx1 by1 bx2 by2) (multiple-value-bind (ncx1 ncy1 ncx2 ncy2) (bounding-rectangle* child) (let ((child-empty-p (or ;; a deleted output record is considerd empty for our purposes (null (output-record-parent child)) (bbox-empty-p ncx1 ncy1 ncx2 ncy2))) (parent-empty-p (bbox-empty-p bx1 by1 bx2 by2)) (old-child-empty-p (bbox-empty-p ocx1 ocy1 ocx2 ocy2)) (recomputep nil)) '(format *trace-output* "REFCC: bbox = ~S, child-bbox = ~S.~%" (list bx1 by1 bx2 by2) (list ncx1 ncy1 ncx2 ncy2)) (cond (parent-empty-p (unless old-child-empty-p (warn "Paradox situation.")) (cond (child-empty-p nil) ;nothing to do (t ;; just update our bounding box to that of the child (setf bx1 ncx1 by1 ncy1 bx2 ncx2 by2 ncy2)))) ((and old-child-empty-p child-empty-p) ;; child remains empty, so no change nil) ((and old-child-empty-p (not child-empty-p)) ;; just merge the child into (setf bx1 (min bx1 ncx1) by1 (min by1 ncy1) bx2 (max bx2 ncx2) by2 (max by2 ncy2))) ((and (not old-child-empty-p) child-empty-p) ;; child is getting empty; for each of the edges see if it was ;; shared with the child and set the recompute flag as ;; neccessary. (when (or (= bx1 ocx1) (= by1 ocy1) (= bx2 ocx2) (= by2 ocy2)) (setf recomputep t))) ((and (not old-child-empty-p) (not child-empty-p)) ;; Generic case. For each edge of the bounding rectangle, test ;; if that was shared with the old bounding box; if so and the ;; child would extend the bounding rectangle, do so, otherwise ;; we need to recompute. If the edge was not shared, merge in. (if (= ox1 ocx1) (if (<= ncx1 ocx1) (setf bx1 ncx1) (setf recomputep t)) (setf bx1 (min ncx1 ox1))) (if (= oy1 ocy1) (if (<= ncy1 ocy1) (setf by1 ncy1) (setf recomputep t)) (setf by1 (min ncy1 oy1))) (if (= ox2 ocx2) (if (>= ncx2 ocx2) (setf bx2 ncx2) (setf recomputep t)) (setf bx2 (max ncx2 ox2))) (if (= oy2 ocy2) (if (>= ncy2 ocy2) (setf by2 ncy2) (setf recomputep t)) (setf by2 (max ncy2 oy2))))) ;; recompute if flag was set. ;; ### reuse tree-recompute-extent (when recomputep (let (x1 y1 x2 y2) (loop for child in (output-record-children record) do (multiple-value-bind (cx1 cy1 cx2 cy2) (bounding-rectangle* child) (cond ((bbox-empty-p cx1 cy1 cx2 cy2)) ((null x1) (setf (values x1 y1 x2 y2) (values cx1 cy1 cx2 cy2))) (t (setf (values x1 y1 x2 y2) (values (min x1 cx1) (min y1 cy1) (max x2 cx2) (max y2 cy2))))))) (setf (values bx1 by1 bx2 by2) (if (null x1) (values 0 0 0 0) (values x1 y1 x2 y2))))) ;; Invoke change notification protocol if neccessary. (unless (and (= ox1 bx1) (= oy1 by1) (= ox2 bx2) (= oy2 by2)) (when parent (recompute-extent-for-changed-child parent record (+ x-position ox1) (+ y-position oy1) (+ x-position ox2) (+ y-position oy2))))))))) (defmethod tree-recompute-extent ((record standard-sequence-output-record)) ;; I really wonder what this is needed for. If I read the spec, ;; refnc and refcc need to be called, when ever something changes ;; anyway. There is no advertised protocol for turning that ;; mechanismn off. (with-slots (parent bx1 by1 bx2 by2 x-position y-position) record (multiple-value-bind (ox1 oy1 ox2 oy2) (values bx1 by1 bx2 by2) (let (x1 y1 x2 y2) (loop for child in (output-record-children record) do (multiple-value-bind (cx1 cy1 cx2 cy2) (bounding-rectangle* child) (cond ((bbox-empty-p cx1 cy1 cx2 cy2)) ((null x1) (setf (values x1 y1 x2 y2) (values cx1 cy1 cx2 cy2))) (t (setf (values x1 y1 x2 y2) (values (min x1 cx1) (min y1 cy1) (max x2 cx2) (max y2 cy2))))))) (setf (values bx1 by1 bx2 by2) (if (null x1) (values 0 0 0 0) (values x1 y1 x2 y2))) ;; Invoke change notification protocol if neccessary. (unless (and (= ox1 bx1) (= oy1 by1) (= ox2 bx2) (= oy2 by2)) (when parent (recompute-extent-for-changed-child parent record (+ x-position ox1) (+ y-position oy1) (+ x-position ox2) (+ y-position oy2)))))))) ;; (defmethod bounding-rectangle* ((record standard-sequence-output-record))) -- defined on basic-output-record ;;;; -- 16.3.3 Text Displayed Output Record --------------------------------------------------- (defclass text-displayed-output-record () ()) (defun text-displayed-output-record-p (object) (typep object 'text-displayed-output-record)) (defclass standard-text-displayed-output-record (basic-output-record) ((cx1 :initarg :cx1 :initform 0) (cy1 :initarg :cy1 :initform 0) (cx2 :initarg :cx2 :initform 0) (cy2 :initarg :cy2 :initform 0) (string :initarg :string :initform "") (text-style :initarg :text-style :initform nil) (ink :initarg :ink ) (clipping-region :initarg :clipping-region ))) (defmethod output-record-start-cursor-position ((record standard-text-displayed-output-record)) (with-slots (cx1 cy1) record (values cx1 cy1))) (defmethod* (setf output-record-start-cursor-position) (nx ny (record standard-text-displayed-output-record)) (with-slots (cx1 cy1) record (setf (values cx1 cy1) (values nx ny)))) (defmethod output-record-end-cursor-position ((record standard-text-displayed-output-record)) (with-slots (cx2 cy2) record (values cx2 cy2))) (defmethod* (setf output-record-end-cursor-position) (nx ny (record standard-text-displayed-output-record)) (with-slots (cx2 cy2) record (setf (values cx2 cy2) (values nx ny)))) (defmethod add-character-to-text-record ((record standard-text-displayed-output-record) character text-style width height baseline) (add-string-to-text-record record (string character) text-style width height baseline)) (defmethod add-string-to-text-record ((record standard-text-displayed-output-record) string text-style width height baseline) (with-slots ((record-text-style text-style) (record-string string)) record (unless (or (null record-text-style) (eql text-style record-text-style)) (error "Sorry, can't do.")) (setf record-text-style text-style) (setf record-string (concatenate 'string record-string string)) ;; Hmm. (with-slots (cx1 cy1 bx1 by1 bx2 by2 x-position y-position parent) record (multiple-value-bind (obx1 oby1 obx2 oby2) (values bx1 by1 bx2 by2) (cond ((bbox-empty-p bx1 by1 bx2 by2) (setf bx1 cx1 by1 cy1 bx2 width by2 (+ cy1 height))) (t (incf bx2 width) (setf by2 (max by2 (+ cy1 height))))) (when (and parent (not (and (= bx1 obx1) (= by1 oby1) (= bx2 obx2) (= by2 oby2)))) (recompute-extent-for-changed-child parent record (+ x-position obx1) (+ y-position oby1) (+ x-position obx2) (+ y-position oby2))))) )) (defmethod replay-output-record ((record standard-text-displayed-output-record) stream &optional region x-offset y-offset) (declare (ignore region)) (setf x-offset (or x-offset 0)) (setf y-offset (or y-offset 0)) (with-stream-excursion (stream) (multiple-value-bind (x y) (output-record-start-cursor-position record) (setf (stream-cursor-position stream) (values (+ x x-offset) (+ y y-offset)))) (with-drawing-options (stream :ink #x000000) (write-string (text-displayed-output-record-string record) stream)))) (defmethod text-displayed-output-record-string ((record standard-text-displayed-output-record)) (with-slots (string) record string)) ;;;; -- -------------------------------------------------------------------------------------- (defmethod replay-output-record :after (record stream &optional region x-offset y-offset) (setf x-offset (or x-offset 0) y-offset (or y-offset 0)) (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* record) (multiple-value-bind (px py) (output-record-position record) (decf x-offset px) (decf y-offset py) (draw-rectangle* stream (+ x-offset x1) (+ y-offset y1) (+ x-offset x2) (+ y-offset y2) :filled nil :ink +red+)))) (defmethod map-over-output-records-overlapping-region (function (record standard-sequence-output-record) region &optional x-offset y-offset &rest function-args) (setf x-offset (or x-offset 0)) (setf y-offset (or y-offset 0)) (loop for child in (output-record-children record) do (multiple-value-bind (x1 y1 x2 y2) (bounding-rectangle* child) (multiple-value-bind (px py) (output-record-position child) '(print (list record region (make-rectangle* (+ x-offset x1) (+ y-offset y1) (+ x-offset x2) (+ y-offset y2))) *trace-output*) (when (region-intersects-region-p region (make-rectangle* (+ x-offset x1) (+ y-offset y1) (+ x-offset x2 ) (+ y-offset y2))) (apply function child function-args)))))) (defmethod replay-output-record :before (record stream &optional region x-offset y-offset) '(print `(replay-output-record ,record ,region ,x-offset ,y-offset) *trace-output*)) (defmethod print-object ((object standard-text-displayed-output-record) stream) (with-slots (string) object (print-unreadable-object (object stream :type t :identity t) (format stream "~S" string))))