[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Postscript: the code

;;; -*- Mode: LISP; Package: CL-USER; Base: 10; Syntax: Common-Lisp -*-
;;; graphic-printing.lisp
;;; author:  J. Ari Kornfeld
;;; created: Aug 26, 1990
;; GRASPER-II is a proprietary sotware package written at SRI International
;;   it is used to draw node-edge graphs of the type used in many AI 
;;   applications. (Highly recommended!)
;;  Grasper also allows the user to associate values with an object (node
;;   or edge)  I use this capability here to cache the print sizes.
;; The function post-print-space will print out a Grasper-II graph
;; to the LGP device using Postscript commands.
;;   dw-print-space  prints it to a dynamic window (like LISP Listener...)
;; Suggested values for scale:
;;  Very Small:  .47
;;  Medium:      .65?
;;  Full Scale:  .75
(defun post-print-space (&optional (space (grasper:space)) (scale .75) (decache t) &aux
				   keys (pages 0))
  "Use postscript to draw a grasper graph. This function does not
produce an exact replica but it's close."
    (stream (hardcopy::make-hardcopy-stream
	      (hardcopy::get-hardcopy-device "toledo")
	      :landscape-p t
	      :title (format nil "GRAPSER-II Space:  ~A" (string space))
    (dw::with-hardcopy-upside-down-stream (stream)

      ;;  First figure out the size of the entire space.
      (multiple-value-bind (width height)
	  (grasper-space-size space :scale scale)
;; This works but is slower. (I.e. grasper has precomputed the values.)	
;	  (dw:continuation-output-size
;	    (setq continuation
;		  (dw::format-output-macro-continuation
;		    (:name post-print-space :DONT-SNAPSHOT-VARIABLES NIL)
;		    (STREAM)
;		    (graphics:with-graphics-scale (stream scale)
;		      (dw-print-space stream space))))
;	    stream)

	;; clear cached size values, if drawing has changed since we
	;; last printed
	(when decache
	  (decache-output-sizes space))

	;; Set up the scaling keys.  This could be fancier...
	(setq keys (when scale (list :scale scale)))
	(multiple-value-bind (pwidth pheight)
	    (funcall stream :inside-size)
	  (format t "~%Printing page:  ")

	  ;; For each page, move a fake viewport and print
	  (loop for y-pos from 0 to height by pheight
	       (loop for x-pos from 0 to width by pwidth
		    (format t "~D  " (incf pages))
		    (unless (and (= x-pos 0) (= y-pos 0))
		      (funcall stream :eject-page))
		    (apply 'print-space-within stream space
			   x-pos y-pos
			   (+ x-pos pwidth) (+ y-pos pheight)
	;(funcall stream :with-pages-for-box continuation stream width height)

(defun dw-print-space (&optional (stream *standard-output*) (space (grasper:space)))
  "Print a grasper graph onto a dynamic window."

  (for node in (nodes-in-space space)
	     (dw-draw-node node space stream)
	     (dw-draw-outgoing-edges node space stream)


;; The following function is called once for each page in the printout.
(defun print-space-within (stream space real-x1 real-y1 real-x2 real-y2 &rest keys)
  "Translate to x1 y1 and print anything that would be within the box."
  (let (x2 y2 ignore1 ignore2 x1 y1)
    (loop for node in (nodes-in-space space)
	 ;;  1. Get its display location
	 (if (value-in-node node '%output-size space)
	     ; Use a cached value if it's available
	     (multiple-value-setq (x1 y1 x2 y2 )
	       (apply 'values (cdr (value-in-node node '%output-size space))))
	     ;;else calculate the position 
	     (multiple-value-setq (x2 y2 ignore1 ignore2 x1 y1)
		   (:name post-print-node :DONT-SNAPSHOT-VARIABLES NIL)
		   (apply 'dw-draw-node node space stream keys))
		 stream :pixel))
	     (store-in-node node (list '%output-size x1 y1 x2 y2) space))
	 ;;  2. Draw it
	 (when (within-viewport stream real-x1 real-y1 real-x2 real-y2 x1 y1 x2 y2)
	   (graphics::with-graphics-translation (stream (- real-x1) (- real-y1))
	     (apply 'dw-draw-node node space stream keys)))
	 (loop for out in (outgoing-nodes node space)
	      (if (value-in-outgoing-edge node out '%output-edge-size space)
		  (multiple-value-setq (x1 y1 x2 y2 )
		    (apply 'values (cdr (value-in-outgoing-edge node out '%output-edge-size space))))
		  ;;else calculate the position
		  (multiple-value-setq (x2 y2 ignore1 ignore2 x1 y1)
			(:name post-print-edges :DONT-SNAPSHOT-VARIABLES NIL)
			(apply 'dw-draw-edge node out space stream keys))
		      stream :pixel))
		  (store-in-outgoing-edge node out (list '%output-edge-size x1 y1 x2 y2) space)
	      ;; DRAW THE EDGE
	      (when (and x1 (within-viewport stream real-x1 real-y1 real-x2 real-y2 x1 y1 x2 y2))
		(graphics::with-graphics-translation (stream (- real-x1) (- real-y1))
		  (apply 'dw-draw-edge node out space stream keys)))))

(defun within-viewport (stream left top right bottom x1 y1 x2 y2)
  "is area within viewport?"
  ;; Printer prints more than inside width but less than full width...
  (multiple-value-bind (x-margin y-margin)
      (get-margin-size stream)
      ;; Determine if the intersection of the two boxes forms a "positive" box.
      (< (max (- left x-margin) x1) (min (+ right x-margin) x2))
      (< (max (- top y-margin) y1)  (min (+ bottom y-margin) y2))

(defun guess-node-character-style (&key (scale 1) &allow-other-keys)
  "Guess an appropriate character style."
    ((< scale .5) '(:swiss :roman :very-small))
    ((and (>= scale .5) (< scale .75)) '(:swiss :bold :very-small))
     '(:swiss :bold :normal))

(defun dw-draw-node (node space stream  &rest keys)
  "Draw a node onto the Dynamic Window screen."
  ;; Example of draw-node

  ; This is the one that doesn't scale correctly
  (apply 'graphics:draw-string
	 (round (+ x1 x2) 2) (/ (+ y1 y2) 2)
	 :character-style (apply 'guess-node-character-style keys)
	 :attachment-y :center :attachment-x :center
	 :stream stream

(defun get-margin-size (stream)
  "Calculate page margins.  Assume uniform margins."
  (multiple-value-bind (pwidth pheight)
      (funcall stream :inside-size)
    (multiple-value-bind (full-width full-height)
	(funcall stream :size)
	(/ (- full-width pwidth) 2)
	(/ (- full-height pheight) 2)

(defun decache-output-sizes (space)
  "Delete all 'output-size' references."
  (loop for node in (nodes-in-space space)
       (store-in-node node '(%output-size) space)
       (store-in-edge node '(%output-edge-size) space)

;; *end-of-file*