[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Postscript: the code
Enjoy:
;;; -*- 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."
(with-open-stream
(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
do
(loop for x-pos from 0 to width by pwidth
do
(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)
keys))))
))
;(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)
do
(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)
do
;; DRAW A NODE.
;; 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)
(dw:continuation-output-size
(dw::format-output-macro-continuation
(:name post-print-node :DONT-SNAPSHOT-VARIABLES NIL)
(stream)
(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)))
;; DRAW EACH OUTGOING EDGE FOR THIS NODE.
(loop for out in (outgoing-nodes node space)
do
(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)
(dw:continuation-output-size
(dw::format-output-macro-continuation
(:name post-print-edges :DONT-SNAPSHOT-VARIABLES NIL)
(stream)
(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)
(and
;; 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."
(cond
((< scale .5) '(:swiss :roman :very-small))
((and (>= scale .5) (< scale .75)) '(:swiss :bold :very-small))
(t
'(: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
string
(round (+ x1 x2) 2) (/ (+ y1 y2) 2)
:character-style (apply 'guess-node-character-style keys)
:attachment-y :center :attachment-x :center
:stream stream
keys))
(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)
(values
(/ (- 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)
do
(store-in-node node '(%output-size) space)
(store-in-edge node '(%output-edge-size) space)
)
)
;; *end-of-file*
-------