;;;-*- Mode:Common-Lisp; Package:PICTURES; Base:10 -*- ;;; ;;; ;;; ;;; TEXAS INSTRUMENTS INCORPORATED ;;; P.O. BOX 149149 ;;; AUSTIN, TEXAS 78714-9149 ;;; ;;; Copyright (C)1987,1988,1989,1990 Texas Instruments Incorporated. ;;; ;;; Permission is granted to any individual or institution to use, copy, modify, ;;; and distribute this software, provided that this complete copyright and ;;; permission notice is maintained, intact, in all copies and supporting ;;; documentation. ;;; ;;; Texas Instruments Incorporated provides this software "as is" without ;;; express or implied warranty. ;;; ;;; Authors: Delmar Hager, James Dutton, Teri Crowe ;;; Contributors: Kerry Kimbrough, Patrick Hogan, Eric Mielke (in-package "PICTURES") ;Parameter: *graphic-stack-initial-size* (defparameter *graphic-stack-initial-size* 10 "Initial number of elements in the graphic stack") ;Parameter: *graphic-stack-increment* (defparameter *graphic-stack-increment* 5 "Number of elements to add when expanding the graphic stack") ;;; Graphic-stack Class Definition: (defclass graphic-stack () ( (stack :type vector :initform (make-array (list *graphic-stack-initial-size*) :adjustable t :fill-pointer 0) :documentation "Dynamically expandable stack of (graphic . object) pairs"))) ;Constants ; These should not be modified!! (DEFPARAMETER *identity-transform* (make-transform)) (DEFPARAMETER *empty-gstate* (make-gstate)) ;Function: graphic-stack-empty-p ; Determine if the given GRAPHIC-STACK is empty. (proclaim '(inline graphic-stack-empty-p)) (defun graphic-stack-empty-p (graphic-stack) (declare (values boolean)) (zerop (fill-pointer (slot-value graphic-stack 'stack)))) ;Method: graphic-stack-fill ; Empty the given GRAPHIC-STACK and then re-fill it by pushing each of GRAPHIC's ; ancestors onto the stack in order beginning with the root ancestor and ending ; with GRAPHIC itself. (defmethod graphic-stack-fill ((graphic-stack graphic-stack) graphic) (declare (values graphic-stack)) (graphic-stack-purge graphic-stack) ; Empty the stack (when graphic ; Nil graphic means end of recursion (graphic-stack-fill graphic-stack (graphic-parent graphic)) ; Recurse on graphic's parent (graphic-stack-push graphic-stack graphic))) ; Push the graphic onto stack ;Method: graphic-stack-find ; Try to find the given GRAPHIC or its parent on the given GRAPHIC-STACK. If the ; GRAPHIC is found, return the pair containing it and make that the top of the stack. ; If the parent is found, make that the top of the stack, push the GRAPHIC onto the ; stack and return the resulting pair. If neither is found, purge the stack and rebuild ; it by pushing each of the ancestors of GRAPHIC starting with its root ancestor and ; ending with the GRAPHIC itself. Return the pair containing the GRAPHIC. (defmethod graphic-stack-find ((graphic-stack graphic-stack) graphic) (declare (values (or null consp))) (do ((parent (graphic-parent graphic)) ; Find the parent (for speed) (top-graphic ; Loop variable (graphic-stack-top-graphic graphic-stack) ; Initialize to top of stack (graphic-stack-top-graphic ; Step by popping stack (graphic-stack-pop graphic-stack)))) ((cond ; Termination conditions ((eq top-graphic graphic)) ; Graphic found, do nothing ((eq top-graphic parent) ; Parent found, (graphic-stack-push graphic-stack graphic)) ; Push graphic onto stack ((graphic-stack-empty-p graphic-stack) ; Stack is empty, (graphic-stack-fill graphic-stack graphic))) ; Fill it up (graphic-stack-top graphic-stack)))) ; Return the top entry ;Method: graphic-stack-pop ; Pop the given GRAPHIC-STACK and return the resultant graphic-stack. ; If the "object" is non-nil, set save-object to point to it so that we can reuse ; it next time. If GRAPHIC-STACK is empty, this function has no effect. (defmethod graphic-stack-pop ((graphic-stack graphic-stack)) (declare (values graphic-stack)) (with-slots (stack) graphic-stack (unless (graphic-stack-empty-p graphic-stack) (vector-pop stack)) graphic-stack)) ;Method: graphic-stack-purge ; Pop the GRAPHIC-STACK until the given GRAPHIC is found and then pop that entry as well. ; If the GRAPHIC is not on the stack, then pop everything. Return the resultant graphic-stack. ; Note that passing nil for GRAPHIC results in clearing everything off the stack. (defmethod graphic-stack-purge ((graphic-stack graphic-stack) &optional graphic) (declare (values graphic-stack)) (if (graphic-stack-empty-p graphic-stack) ; For an empty stack, graphic-stack ; just return it. (if (eq graphic (graphic-stack-top-graphic graphic-stack)) ; If graphic is on top (graphic-stack-pop graphic-stack) ; Just pop and return stack (graphic-stack-purge (graphic-stack-pop graphic-stack) ; Otherwise, continue looking graphic)))) ;Method: graphic-stack-push ; Push the given GRAPHIC onto the given GRAPHIC-STACK. The second element of the ; pair is initially unmodified. Expand the stack if needed (in which case the second element ; is initially nil). Return the newly pushed pair. (defmethod graphic-stack-push ((graphic-stack graphic-stack) graphic) (declare (values consp)) (with-slots (stack) graphic-stack (let* ((stack-pointer (fill-pointer stack)) ; Locals for stack pointer (current-size (array-total-size stack)) ; and current array size (top-entry (AREF stack stack-pointer))) ; and entry at top of stack (when (eql stack-pointer current-size) ; If stack will be full, (adjust-array stack (list (+ current-size *graphic-stack-increment*)))) ; Expand it first. (if (null top-entry) ; Is entry already there? (vector-push (cons (cons graphic nil) nil) stack) ; No, just push one (progn (setf (caar top-entry) graphic) ; Yes, change the graphic part (if (cdar top-entry) ; Is the "object" there? (setf (cdr top-entry) (cdar top-entry)) ; Yes, save it away (setf (cdar top-entry) (cdr top-entry))) ; No, use saved object (incf (fill-pointer stack)))) ; Increment stack pointer. (car (AREF stack stack-pointer))))) ; Return the pair we just pushed ;Function: graphic-stack-top ; Return the top entry on the given GRAPHIC-STACK (defun graphic-stack-top (graphic-stack) (declare (values (or null consp))) (with-slots (stack) graphic-stack (let ((stack-pointer (fill-pointer stack))) ; Local for stack pointer (if (zerop stack-pointer) ; Is stack empty? nil ; Yes, return nil (car (AREF stack (- stack-pointer 1))))))) ; No, return top entry ;Function: graphic-stack-top-graphic ; Return the graphic part of the top entry on the given GRAPHIC-STACK (defun graphic-stack-top-graphic (graphic-stack) (declare (values (or null graphic))) (with-slots (stack) graphic-stack (let ((stack-pointer (fill-pointer stack))) ; Local for stack pointer (if (zerop stack-pointer) ; Is stack empty? nil ; Yes, return nil (caar (AREF stack (- stack-pointer 1))))))) ; No, return top graphic ;Method: print-object ; Print the given GRAPHIC-STACK bottom to top. (defmethod print-object ((graphic-stack graphic-stack) stream) (with-slots (stack) graphic-stack (dotimes (i (length stack)) (PRINT (CAAR (ELT stack i)) stream) (print (cdar (elt stack i)) stream) (print '--------------------------- stream)))) ;;;Transform-stack Class Definition: (defclass transform-stack (graphic-stack) () (:documentation "A graphic stack for transform objects")) ;Method: graphic-stack-push ; Push the given GRAPHIC and its fully composed transform onto the given TRANSFORM-STACK. ; If a transform already exists in the pushed pair, it is reused. Otherwise a new transform ; is created. Return the newly pushed pair. (defmethod graphic-stack-push :around ((transform-stack transform-stack) graphic) (declare (values consp)) (let* ((current-transform ; Get top transform from stack (cdr (graphic-stack-top transform-stack))) (graphics-transform ; Get the graphic's transform (graphic-transform graphic)) (new-pair ; Push a new pair and remember it (call-next-method))) (setf (cdr new-pair) ; Change the stack transform (if (or current-transform graphics-transform) ; Is anything there? (compose-transform graphics-transform ; Compose the graphic's transform current-transform ; With the current transform (cdr new-pair)) ; Put result on pair nil)) ; Nope, just make it nil new-pair)) ; Return the new pair ;Macro: graphic-stack-transform ; Return the transform part of a transform-stack entry. (defmacro graphic-stack-transform (stack-entry) `(cdr ,stack-entry)) ;;;Gstate-stack Class Definition: (defclass gstate-stack (graphic-stack) () (:documentation "A graphic stack for gstate objects")) (defclass edge-gstate-stack (gstate-stack) () (:documentation "A graphic stack for gstate objects")) (DEFPARAMETER *gstate-stack* (make-instance 'gstate-stack)) (DEFPARAMETER *edge-gstate-stack* (make-instance 'edge-gstate-stack)) ;Method: graphic-stack-push ; Push the given GRAPHICS and its fully combined gstate onto the given GSTATE-STACK. ; If a gstate already exists in the pushed pair, it is reused. Otherwise a new gstate ; is created. Return the newly pushed pair. (defmethod graphic-stack-push :around ((gstate-stack gstate-stack) graphic) (declare (values consp)) (let* ((current-gstate ; Get top gstate from stack (cdr (graphic-stack-top gstate-stack))) (graphics-gstate ; Get the graphic's gstate (graphic-gstate graphic)) (new-pair ; Push a new pair and remember it (call-next-method))) (setf (cdr new-pair) ; Change the stack gstate (if (or current-gstate graphics-gstate) ; Is anything there? (gstate-combine graphics-gstate ; Compose current gstate current-gstate ; With the graphic's gstate (cdr new-pair)) ; Put result on pair nil)) ; Nope, just make it nil new-pair)) ; Return the new pair (defmethod graphic-stack-push :around ((gstate-stack edge-gstate-stack) graphic) (declare (values consp)) (let* ((current-gstate ; Get top gstate from stack (cdr (graphic-stack-top gstate-stack))) (graphics-gstate ; Get the graphic's gstate (edge-gstate graphic)) (new-pair ; Push a new pair and remember it (call-next-method))) (setf (cdr new-pair) ; Change the stack gstate (if (or current-gstate graphics-gstate) ; Is anything there? (gstate-combine graphics-gstate current-gstate ; Compose current gstate ; With the graphic's gstate (cdr new-pair)) ; Put result on pair nil)) ; Nope, just make it nil new-pair)) ;Macro: graphic-stack-gstate ; Return the gstate part of a gstate-stack entry. (defmacro graphic-stack-gstate (stack-entry) `(cdr ,stack-entry))