File [qv]<IDL>NEXT>PLOT-IO!6

(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "PLOT")
(il:filecreated " 1-Dec-88 11:55:41" il:{qv}<idl>next>plot-io.\;6 14334  

      il:|changes| il:|to:|  (il:functions read-plot)

      il:|previous| il:|date:| "15-Nov-88 17:59:47" il:{qv}<idl>next>plot-io.\;5)


; Copyright (c) 1988 by Xerox Corporation.  All rights reserved.

(il:prettycomprint il:plot-iocoms)

(il:rpaqq il:plot-iocoms ((il:coms (il:* il:|;;| "Plot I/O") (il:functions print-plot print-plot-object) (il:functions print-font read-font) (il:functions read-plot read-plot-object)) (il:coms (il:* il:|;;| "Image objects") (il:variables *plot-imageobj-fns*) (il:functions imageobj-display-fn imageobj-imagebox-fn imageobj-put-fn imageobj-get-fn imageobj-copy-fn imageobj-buttoneventin-fn imageobj-editclose-fn) (il:functions make-plot-image-object make-plot-bitmap-object) (il:functions make-plot-sketch) (il:declare\: il:docopy il:donteval@load (il:p (il:* il:|;;| "because of a bug in image objects") (il:movd (quote imageobj-get-fn) (quote il:imageobj-get-fn))))) (xcl:file-environments "PLOT-IO")))



(il:* il:|;;| "Plot I/O")


(defun print-plot (plot stream) (il:* il:|;;| "Puts out a symbolic representation of PLOT on STREAM") (let ((il:* il:|;;| "So prin1 works on structure objects") (xcl:*print-structure* t) (*print-array* t) (*package* *package*) (*readtable* (il:find-readtable "XCL"))) (write-string "#<" stream) (prin1 (package-name *package*) stream) (write-char #\Space stream) (prin1 (length (plot-objects plot)) stream) (write-char #\Space stream) (dolist (object (plot-objects plot)) (print-plot-object object stream) (write-char #\Space stream)) (flet ((print-menu (menu stream &optional default-menu) (let ((menu-items (menu-items menu))) (if (and (menu-p default-menu) (equal menu-items (menu-items default-menu))) (prin1 :default stream) (prin1 menu-items stream))))) (print-menu (plot-middle-menu plot) stream *default-middle-menu*) (write-char #\Space stream) (print-menu (plot-right-menu plot) stream *default-right-menu*) (write-char #\Space stream) (let ((other-menus (plot-other-menus plot))) (prin1 (ash (length other-menus) -1) stream) (write-char #\Space stream) (do* ((prop-name-tail other-menus (cddr prop-name-tail)) (prop-name (car prop-name-tail) (car prop-name-tail)) (prop-value-tail (cdr prop-name-tail) (cdr prop-name-tail)) (prop-value (car prop-value-tail) (car prop-value-tail))) ((null prop-name-tail)) (prin1 prop-name stream) (write-char #\Space stream) (print-menu prop-value stream (gethash prop-name *plot-object-menus*)) (write-char #\Space stream)))) (write-string "(:scale-info " stream) (prin1 (plot-scale-info plot) stream) (write-string " :left-margin " stream) (prin1 (plot-left-margin plot) stream) (write-string " :right-margin " stream) (prin1 (plot-right-margin plot) stream) (write-string " :top-margin " stream) (prin1 (plot-top-margin plot) stream) (write-string " :bottom-margin " stream) (prin1 (plot-bottom-margin plot) stream) (let ((prop-list (plot-prop-list plot))) (when prop-list (write-string " :prop-list (" stream) (do* ((prop-name-tail (plot-prop-list plot) (cddr prop-name-tail)) (prop-name (car prop-name-tail) (car prop-name-tail)) (prop-value-tail (cdr prop-name-tail) (cdr prop-name-tail)) (prop-value (car prop-value-tail) (car prop-value-tail))) ((null prop-name-tail)) (when prop-value (prin1 prop-name stream) (write-char #\Space stream) (prin1 prop-value stream) (write-char #\Space stream))) (write-char #\) stream))) (write-char #\) stream) nil))

(defun print-plot-object (object stream) (prin1 (type-of-object object) stream) (write-char #\Space stream) (let ((menu (plot-object-menu object))) (prin1 (if (symbolp menu) menu (menu-items menu)) stream) (write-char #\Space stream)) (prin1 (plot-object-label object) stream) (write-char #\Space stream) (let ((prop-list (plot-object-prop-list object))) (write-char #\( stream) (do* ((prop-name-tail prop-list (cddr prop-name-tail)) (prop-name (car prop-name-tail) (car prop-name-tail)) (prop-value-tail (cdr prop-name-tail) (cdr prop-name-tail)) (prop-value (car prop-value-tail) (car prop-value-tail))) ((null prop-name-tail)) (when (and prop-value (il:* il:|;;| "Label objects are not preserved ") (not (eq prop-name :label-object))) (prin1 prop-name stream) (write-char #\Space stream) (prin1 prop-value stream) (write-char #\Space stream))) (write-char #\) stream)) (write-char #\Space stream) (funcall (pm-put-fn (plot-object-methods object)) object stream) nil)

(defun print-font (font stream) (cond ((eq font *small-plot-font*) (prin1 (quote *small-plot-font*) stream)) ((eq font *large-plot-font*) (prin1 (quote *large-plot-font*) stream)) (t (write-string "(:family " stream) (prin1 (font-family font) stream) (write-string " :size " stream) (prin1 (font-size font) stream) (write-string " :face " stream) (prin1 (font-face font) stream) (write-char #\) stream))) nil)

(defun read-font (stream) (let ((font-info (read stream))) (if (symbolp font-info) (if (eq font-info (quote *small-plot-font*)) *small-plot-font* (if (eq font-info (quote *large-plot-font*)) *large-plot-font* (error "Unrecognized-font: ~s" font-info))) (apply (function make-font) font-info))))

(defun read-plot (stream) (let ((*readtable* (il:find-readtable "XCL"))) (il:* il:|;;| "Skip \"#<\"") (read-char stream) (read-char stream) (let* ((*package* (find-package (read stream))) (n-objects (read stream)) (objects (pt:with-collection (dotimes (i n-objects) (pt:collect (read-plot-object stream)))))) (flet ((menu-from-list (items &optional default-position) (if (eq items :default) (default-menu default-position) (make-menu :items items :when-selected-fn (quote default-when-selected-fn))))) (let* ((middle-menu (menu-from-list (read stream) :middle)) (right-menu (menu-from-list (read stream) :right)) (n-other-menus (read stream)) (other-menus (pt:with-collection (dotimes (i n-other-menus) (let ((prop (read stream))) (pt:collect prop) (pt:collect (menu-from-list (read stream) prop)))))) (other-args (read stream))) (apply (function %make-plot) :objects objects :middle-menu middle-menu :right-menu right-menu :other-menus other-menus other-args))))))

(defun read-plot-object (stream) (let* ((type (read stream)) (menu (let ((value (read stream))) (if (consp value) (make-menu :items value :when-selected-fn (quote default-when-selected-fn)) value))) (label (read stream)) (prop-list (read stream)) (new-object (funcall (gethash type *plot-object-constructor-table*) :menu menu :label label :prop-list prop-list))) (funcall (pm-get-fn (plot-object-methods new-object)) new-object stream) new-object))



(il:* il:|;;| "Image objects")


(defvar *plot-imageobj-fns* (il:imagefnscreate (quote imageobj-display-fn) (quote imageobj-imagebox-fn) (quote imageobj-put-fn) (quote il:imageobj-get-fn) (quote imageobj-copy-fn) (quote imageobj-buttoneventin-fn)))

(defun imageobj-display-fn (plot-imageobj image-stream) (il:* il:|;;| "Displays plot image object") (let* ((plot (il:imageobjprop plot-imageobj (quote il:objectdatum))) (view-port (plot-view-port plot)) (scale (stream-scale image-stream)) (stream-region (make-region (stream-x image-stream) (stream-y image-stream) (truncate (* scale (il:imageobjprop plot-imageobj :width))) (truncate (* scale (il:imageobjprop plot-imageobj :height)))))) (when (or (null view-port) (not (eq (vp-parent-stream view-port) image-stream))) (setq view-port (make-view-port image-stream)) (setf (plot-view-port plot) view-port)) (make-tic-lists plot) (update-view-port view-port stream-region plot) (draw-plot plot image-stream view-port stream-region)))

(defun imageobj-imagebox-fn (plot-imageobj &optional image-stream current-x right-margin) (il:* il:|;;| "Determines size of plotimageobj") (let ((image-width (il:imageobjprop plot-imageobj :width)) (image-height (il:imageobjprop plot-imageobj :height)) (plot (il:imageobjprop plot-imageobj (quote il:objectdatum))) (scale (if image-stream (stream-scale image-stream) 1))) (il:* il:|;;| "(* this doesn't work with Sketch which has no rightmargin) (if (GREATERP (TIMES SCALE IMAGEWIDTH) (DIFFERENCE RIGHTMARGIN CURRENTX)) then (if (NOT (EQ (IMAGESTREAMTYPE IMAGESTREAM) (QUOTE DISPLAY))) then (HELP 'PLOT image object too big')) (PROMPTPRINT 'Image object too wide. Choose a smaller region') (SETQ MINSIZE (MINSTREAMREGIONSIZE IMAGESTREAM PLOT)) (SETQ NEWREGION (GETREGION (CAR MINSIZE) (CDR MINSIZE))) (SETQ IMAGEWIDTH (fetch WIDTH of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE WIDTH) IMAGEWIDTH) (SETQ IMAGEHEIGHT (fetch HEIGHT of NEWREGION)) (IMAGEOBJPROP PLOTIOBJ (QUOTE HEIGHT) IMAGEHEIGHT))") (xcl:record-create il:imagebox :xsize (* scale image-width) :ysize (* scale image-height) :ydesc 0 :xkern 0)))

(defun imageobj-put-fn (plot-imageobj stream) (il:* il:|;;| "PLOT IMAGEOBJECT PUTFN") (prin1 (il:imageobjprop plot-imageobj :width) stream) (write-char #\Space stream) (prin1 (il:imageobjprop plot-imageobj :height) stream) (write-char #\Space stream) (print-plot (il:imageobjprop plot-imageobj (quote il:objectdatum)) stream) nil)

(defun imageobj-get-fn (stream textstream) (il:* il:|;;| "PLOT IMAGEOBJECT GETFN") (let* ((width (read stream)) (height (read stream)) (plot (read-plot stream)) (plot-imageobj (il:imageobjcreate plot *plot-imageobj-fns*))) (il:imageobjprop plot-imageobj (quote :width) width) (il:imageobjprop plot-imageobj (quote :height) height) plot-imageobj))

(defun imageobj-copy-fn (plot-imageobj) (il:* il:|;;| "simple copy") (let ((new-obj (il:imageobjcreate (copy-plot (il:imageobjprop plot-imageobj (quote il:objectdatum))) *plot-imageobj-fns*))) (il:imageobjprop new-obj (quote :width) (il:imageobjprop plot-imageobj (quote :width))) (il:imageobjprop new-obj (quote :height) (il:imageobjprop plot-imageobj (quote :height))) new-obj))

(defun imageobj-buttoneventin-fn (plot-imageobj window-stream selection rel-x rel-y window text-stream button) (let ((choicemenu (il:constant (make-menu :items (quote (("Select" :select "Select the image object") ("Reshape" :reshape "Reshape the image objcet") ("Plot Window" :edit "Open a window containing plot"))) :center-p t))) (plot (il:imageobjprop plot-imageobj (quote il:objectdatum))) (image-width (il:imageobjprop plot-imageobj (quote :width))) (image-height (il:imageobjprop plot-imageobj (quote :height))) min-size new-region window new-plot) (if (eq button (quote il:left)) (case (pop-up-menu choicemenu) (:reshape (let* ((minsize (min-stream-region-size window-stream plot)) (new-region (get-region (car minsize) (cdr minsize) (make-region (stream-x window-stream) (stream-y window-stream) image-width image-height)))) (il:* il:|;;| "Assumes the WINDOW-STREAM has been changed to fit the imageobj") (il:imageobjprop plot-imageobj (quote :width) (region-width new-region)) (il:imageobjprop plot-imageobj (quote :height) (region-height new-region)) (il:* il:|;;| "Redraw the Image object") (quote il:changed))) (:edit (let* ((new-plot (copy-plot plot :region (get-region (width-if-window image-width) (height-if-window image-height t)) :title "Plot Edit Window")) (window (open-plot-window new-plot))) (il:* il:|;;| "Cache some info some that changes to NEW-PLOT may be reinserted into TEXT-STREAM.  Windowprops are used because they are not copied (HACK)") (il:* il:|;;| "sketch doesn't pass down anything for TEXT-STREAM arg so must use viewer window instead") (setf (window-prop window :source-stream) (or text-stream window window-stream)) (setf (window-prop window :source-imageobj) plot-imageobj) (il:* il:|;;| "Handle reinsert by a closefn rather than an new menu item -- similar to the behavior of Sketch image object edits") (add-window-method window :close (quote imageobj-editclose-fn) t) t))))))

(defun imageobj-editclose-fn (window) (il:* il:|;;| "this plot window is from an image object.  Reinsert plot if requested") (il:* il:|;;| "later could test if plot has been changed -- if no changes don't ask to reinsert") (when (eq :yes (pop-up-menu (il:constant (make-menu :items (quote (("Yes" :yes "This image used in the document instead of the one that is there.") ("No" :no "The changes made to this image will not be put into the document."))) :title "Change source image object?" :center-p t)))) (il:* il:|;;| "Allows modified plot to be reinserted in document") (let* ((plot (window-prop window :plot)) (host (window-prop window :source-stream)) (obj (window-prop window :source-imageobj))) (il:* il:|;;| "Destructively change imageobj to retain EQ ness") (il:imageobjprop obj (quote il:objectdatum) (copy-plot plot)) (il:imageobjprop obj :width (window-width window)) (il:imageobjprop obj :height (window-height window)) (il:image.object.changed host obj))) (delete-window-method window :close (quote imageobj-editclose-fn)) nil)

(defun make-plot-image-object (plot) (il:* il:|;;| "creates PLOT image object from PLOT") (let* ((window (plot-window plot)) (region (if (window-p window) (window-region window) (car window))) (obj (il:imageobjcreate (copy-plot plot) *plot-imageobj-fns*))) (il:imageobjprop obj :width (region-width region)) (il:imageobjprop obj :height (region-height region)) obj))

(defun make-plot-bitmap-object (plot) (let* ((window (plot-window plot)) (bitmap (make-bitmap (window-width window) (window-height window)))) (stream-bitblt window bitmap) (il:bitmapteditobj bitmap 1 0)))

(defun make-plot-sketch (plot) (il:* il:|;;| "Creates a SKETCH STREAM and dumps the contents of PLOT into it") (if (fboundp (quote il:opensketchstream)) (let* ((sketch-stream (il:opensketchstream "Layout of plot" (let ((plot-window (plot-window plot))) (if plot-window (list (quote il:region) (position-region (region-width (window-region plot-window)) (region-height (window-region plot-window)))))))) (sketch-view-port (make-view-port sketch-stream))) (update-view-port sketch-view-port (stream-clipping-region sketch-stream) plot) (draw-plot plot sketch-stream sketch-view-port (stream-clipping-region sketch-stream))) (print-plot-prompt "SKETCHSTREAM not loaded" plot)))
(il:declare\: il:docopy il:donteval@load 

(il:* il:|;;| "because of a bug in image objects")

(il:movd (quote imageobj-get-fn) (quote il:imageobj-get-fn))
)

(xcl:define-file-environment "PLOT-IO" :package "PLOT" :compiler :compile-file :readtable "XCL")
(il:putprops il:plot-io il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
  (il:filemap (nil)))
il:stop