;;;-*- 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") (export '(save-graphic) 'pictures) ; - - - - - - - - - - - - generic function - - - - - - - - - - - - - - ; - - - - - - - - - - - - base class graphic - - - - - - - - - - - (defmethod save-graphic :before ((graphic graphic) (format (eql :nested-forms)) &optional (stream *standard-output*)) (normalize-graphic graphic) (format stream "(MAKE-~a " (class-name (class-of graphic)))) (defmethod save-graphic ((graphic graphic) (format (eql :nested-forms)) &optional (stream *standard-output*)) (declare (ignore stream)) ;; subclasses will save their own data in a specialized primary method ;; edge-gstate (when applicable), sensitivity, gstate are saved in an :after method ) (defmethod save-graphic :after ((graphic graphic) (format (eql :nested-forms)) &optional (stream *standard-output*)) ;; do edge-gstate first if applicable (when (typep graphic 'edge) (with-slots (edge-gstate) graphic (when edge-gstate (format stream ":edge-gstate ") (save-graphic edge-gstate format stream)))) ;; do sensitivity and normal gstate next (with-slots (sensitivity gstate) graphic (format stream ":sensitivity :~a " sensitivity) (when gstate (format stream ":gstate ") (save-graphic gstate format stream))) ;; sometimes transforms will still remain, even if graphic was normalized (let ((gt (graphic-transform graphic))) (when gt (format stream ":transform ") (save-graphic gt format stream))) (format stream ") ")) ; - - - - - - - - - transform - - - - - - - - - - (defmethod save-graphic ((graphic transform) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (t11 t12 t21 t22 t31 t32) graphic (format stream "(MAKE-TRANSFORM :t11 ~a :t12 ~a :t21 ~a :t22 ~a :t31 ~a :t32 ~a) " t11 t12 t21 t22 t31 t32))) ; - - - - - - - - - gstate - - - - - - - - - - (defmethod save-graphic ((graphic gstate) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "(MAKE-GSTATE ") (with-slots (gstate-array gstate-hash) graphic ;; save the gstate-array (dotimes (pos (length gstate-array)) (let ((element (elt gstate-array pos))) (when element (let ((keyword ;;(first (rassoc pos *gstate-index* :key #'first)))) (first (find pos *gstate-index* :key #'second)))) (unless (member keyword *no-storage-methods*) (format stream ":~a " keyword) (save-graphic (if (consp element) (car element) element) format stream)))))) ;; save the gstate-hash (maphash #'(lambda (keyword value) (unless (member keyword *no-storage-methods*) (FORMAT stream ":~a " keyword) (save-graphic value format stream))) gstate-hash) ) (format stream ") ")) ;------------- specialized primary methods for subclasses ----------------- ; - - - - - - - - - - - - circle - - - - - - - - - - - (defmethod save-graphic ((graphic circle) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (center-x center-y radius) graphic (format stream "~a ~a ~a " center-x center-y radius))) ; - - - - - - - - - - - - ellipse - - - - - - - - - - - (defmethod save-graphic ((graphic ellipse) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream " ~a ~a ~a ~a " (ellipse-origin-x graphic) (ellipse-origin-y graphic) (ellipse-width graphic) (ellipse-height graphic))) ; - - - - - - - - - - - - graphic image - - - - - - - - - - - (defmethod save-graphic ((graphic graphic-image) (format (eql :nested-forms)) &optional (stream *standard-output*)) (save-graphic (graphic-image-content graphic) format stream) (format stream ":base-x ~a :base-y ~a :gravity :~a :tile-p ~a " (graphic-image-base-x graphic) (graphic-image-base-y graphic) (graphic-image-gravity graphic) (graphic-image-tile-p graphic)) (when (graphic-image-tile-p graphic) ;; extent has to be specified for tiled objects (format stream ":extent-x ~a :extent-y ~a :extent-width ~a :extent-height ~a " (graphic-extent-x graphic) (graphic-extent-y graphic) (graphic-extent-width graphic) (graphic-extent-height graphic)))) (defmethod save-graphic ((graphic image-x) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "(XLIB::MAKE-IMAGE-X :width ~a :height ~a :depth ~a :plist " (image-width graphic) (image-height graphic) (image-depth graphic)) (save-graphic (image-plist graphic) format stream) (format stream " :format :~a :bytes-per-line ~a :bits-per-pixel ~a ~ :bit-lsb-first-p ~a :byte-lsb-first-p ~a :data " (xlib::image-x-format graphic) (xlib::image-x-bytes-per-line graphic) (xlib::image-x-bits-per-pixel graphic) (xlib::image-x-bit-lsb-first-p graphic) (xlib::image-x-byte-lsb-first-p graphic)) (save-graphic (xlib::image-x-data graphic) format stream) (format stream ") ")) (defmethod save-graphic ((graphic image-xy) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "(XLIB::MAKE-IMAGE-XY :width ~a :height ~a :depth ~a :plist " (image-width graphic) (image-height graphic) (image-depth graphic)) (save-graphic (image-plist graphic) format stream) (format stream ":bitmap-list ") (save-graphic (image-xy-bitmap-list graphic) format stream) (format stream ") ")) (defmethod save-graphic ((graphic image-z) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "(XLIB::MAKE-IMAGE-Z :width ~a :height ~a :depth ~a :plist " (image-width graphic) (image-height graphic) (image-depth graphic)) (save-graphic (image-plist graphic) format stream) (format stream ":bits-per-pixel ~a :pixarray " (image-z-bits-per-pixel graphic)) (save-graphic (image-z-pixarray graphic) format stream) (format stream ") ")) ; - - - - - - - - - - - - label - - - - - - - - - - - (defmethod save-graphic ((graphic label) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (label-string label-base-x label-base-y label-extent-x label-extent-y extent-height extent-width label-gravity label-angle) graphic ;; label-string is required argument to make-label - rest are keywords (format stream "\"~a\" :base-x ~a :base-y ~a :extent-x ~a :extent-y ~a ~ :extent-width ~a :extent-height ~a :gravity :~a :angle ~a " label-string label-base-x label-base-y label-extent-x label-extent-y extent-width extent-height label-gravity label-angle)) (let ((family (label-font-family graphic))) (when family (format stream ":font-family \"~a\" " (if (stringp family) family (family-name family)))))) ; - - - - - - - - - - - - line - - - - - - - - - - - (defmethod save-graphic ((graphic line) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (start-x start-y end-x end-y) graphic (format stream "~a ~a ~a ~a " start-x start-y end-x end-y))) ; - - - - - - - - - - - - polypoint - - - - - - - - - - - (defmethod save-graphic ((graphic polypoint) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (vertices) graphic (save-graphic vertices format stream))) ; - - - - - - - - - - - - polyline - - - - - - - - - - - ; uses polypoint ; - - - - - - - - - - - - bspline - - - - - - - - - - - ; uses polypoint ; - - - - - - - - - - - - polygon - - - - - - - - - - - ; uses polypoint ; - - - - - - - - - - - - rectangle - - - - - - - - - - - (defmethod save-graphic ((graphic rectangle) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream " ~a ~a ~a ~a " (rectangle-origin-x graphic) (rectangle-origin-y graphic) (rectangle-width graphic) (rectangle-height graphic)) ;; check for graphic transforms on rectangles ) ; - - - - - - - - - scene - - - - - - - - - (defmethod save-graphic ((graphic scene) (format (eql :nested-forms)) &optional (stream *standard-output*)) (with-slots (elements parent) graphic (when elements (format stream ":elements (LIST ") ;(format stream ":elements '( ") (dotimes (position (fill-pointer elements)) (save-graphic (elt elements position) :nested-forms stream)) (format stream ") ")) )) ;-------------------- Special cases ----------------- ; - - - - - - - - - - - - view - - - - - - - - - - - - (defmethod save-graphic ((graphic view) (format (eql :nested-forms)) &optional (stream *standard-output*)) (save-graphic (view-graphic graphic) format stream)) ;-------------------- Built in type classes --------------------- ; - - - - - - - - - - - - array - - - - - - - - - - - ;; warning - for portability's sake I have avoided array handling functions ;; that are implementation dependent and have only implemented saving ;; 1 & 2 dimensional arrays (the common variety) because I could not ;; figure out how to do this in a general manner for n dimensions ;; (i.e. like listarray in TICL). ;; It could be done in a portable manner with a macro to construct the ;; right number of dimensions, but I don't have the time at this writing. ;; (TAC - 3-28-90) (defmethod save-graphic ((graphic array) (format (eql :nested-forms)) &optional (stream *standard-output*)) (let ((ad (array-dimensions graphic)) (ar (array-rank graphic)) list-of-elements temp-list) (cond ((eql ar 1) (setq ad (length graphic)) (dotimes (n ad) (setf list-of-elements (cons (elt graphic n) list-of-elements)))) ((eql ar 2) (dotimes (n (car ad)) (setf temp-list nil) (dotimes (m (cadr ad)) (setf temp-list (cons (aref graphic n m) temp-list))) (setf list-of-elements (cons (nreverse temp-list) list-of-elements)))) (t (error "cannot yet save an array of rank ~a" ar))) (format stream "(MAKE-ARRAY ") (save-graphic ad format stream) (format stream " :initial-contents ") (save-graphic (nreverse list-of-elements) format stream) (format stream ") ") ;(format stream "(MAKE-ARRAY ~a :initial-contents ~a) " ad (nreverse list-of-elements)) )) ; - - - - - - - - - - - - character - - - - - - - - - - - (defmethod save-graphic ((graphic character) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "~a " graphic)) ; - - - - - - - - - - - - number - - - - - - - - - - - (defmethod save-graphic ((graphic number) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "~a " graphic)) ; - - - - - - - - - - - - symbol - - - - - - - - - - - (defmethod save-graphic ((graphic symbol) (format (eql :nested-forms)) &optional (stream *standard-output*)) (if (keywordp graphic) (format stream ":~a " graphic) (format stream "~a " graphic))) ; - - - - - - - - - - - - list - - - - - - - - - - - (defmethod save-graphic ((graphic list) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "(LIST ") ;(format stream "'( ") (dolist (item graphic) (save-graphic item format stream)) (format stream ") ")) ; - - - - - - - - - - - - vector - - - - - - - - - - - ;; done as one dimensional array ; - - - - - - - - - - - - string - - - - - - - - - - - (defmethod save-graphic ((graphic string) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "\"~a\" " graphic)) ; - - - - - - - - - - - - integer - - - - - - - - - - - (defmethod save-graphic ((graphic integer) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "~a " graphic)) ; - - - - - - - - - - - - float - - - - - - - - - - - (defmethod save-graphic ((graphic float) (format (eql :nested-forms)) &optional (stream *standard-output*)) (format stream "~a " graphic))