(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "TDG")
(il:filecreated "15-Nov-88 17:41:18" il:{qv}<idl>next>view-ports.\;3 23350
il:|changes| il:|to:| (il:functions clipped-draw-line apply-transform apply-scale-transform)
il:|previous| il:|date:| "30-Aug-88 17:42:30" il:{qv}<idl>next>view-ports.\;2)
; Copyright (c) 1988 by Xerox Corporation. All rights reserved.
(il:prettycomprint il:view-portscoms)
(il:rpaqq il:view-portscoms ((il:coms (il:* il:|;;| "Clipped display functions") (il:functions clip-code clipped-bitblt clipped-bltshade clipped-draw-line clipped-draw-between clipped-draw-to clipped-relative-draw-to clipped-plot-at clipped-princ)) (il:coms (il:* il:|;;| "view-ports ") (il:structures linear-transform view-port) (il:functions make-world-to-stream-lt make-stream-to-world-lt) (il:functions make-view-port adjust-view-port compute-transform compute-world-region) (il:functions apply-transform apply-scale-transform stream-to-world-x stream-to-world-length-x stream-to-world-y stream-to-world-length-y world-to-stream-x world-to-stream-length-x world-to-stream-y world-to-stream-length-y) (il:functions stream-to-world world-to-stream stream-region-to-world-region world-region-to-stream-region) (il:functions bitblt bltshade draw-line draw-between draw-to relative-draw-to relative-draw-to-point draw-to-point move-to move-to-point relative-move-to relative-move-to-point plot-at)) (xcl:file-environments "VIEW-PORTS")))
(il:* il:|;;| "Clipped display functions")
(defun clip-code (x y left right top bottom) (il:* il:|;;| "Cohen-Sutherland clip codes. Assumes integer args") (il:* il:|;;| "RIGHT and TOP are one past the region.") (let ((abovebit (if (> y top) 8 0)) (belowbit (if (> bottom y) 4 0)) (rightbit (if (> x right) 2 0)) (leftbit (if (> left x) 1 0))) (logior abovebit belowbit rightbit leftbit)))
(defun clipped-bitblt (source destination clipping-region &key (source-left 0) (source-bottom 0) (destination-left 0) (destination-bottom 0) (operation :default) width height) (il:* il:|;;| "Assume that source must be a window or a bitmap -- and hence has scale 1") (il:* il:|;;| "Process defaults") (if (null width) (setq width (cond ((window-p source) (window-width source)) ((bitmap-p source) (bitmap-width source)) (t (error "Not a window or a bitmap: ~s" source))))) (if (null height) (setq height (cond ((window-p source) (window-height source)) ((bitmap-p source) (bitmap-height source)) (t (error "Not a window or a bitmap: ~s" source))))) (let* ((clip-left (region-left clipping-region)) (clip-bottom (region-bottom clipping-region)) (clip-width (region-width clipping-region)) (clip-height (region-height clipping-region)) (scale (stream-scale destination)) (new-left destination-left) (new-bottom destination-bottom) (new-width (* scale width)) (new-height (* scale height)) (clipped-p nil)) (when (> clip-left new-left) (setq clipped-p t) (setq new-width (- new-width (- clip-left new-left))) (setq new-left clip-left)) (when (> clip-bottom new-bottom) (setq clipped-p t) (setq new-height (- new-height (- clip-bottom new-bottom))) (setq new-bottom clip-bottom)) (when (> (+ new-left new-width) (+ clip-left clip-width)) (setq clipped-p t) (setq new-width (- (+ clip-left clip-width) new-left))) (when (> (+ new-bottom new-height) (+ clip-bottom clip-height)) (setq clipped-p t) (setq new-height (- (+ clip-bottom clip-height) new-bottom))) (cond ((null clipped-p) (il:* il:|;;| "No clipping") (stream-bitblt source destination :source-left source-left :source-bottom source-bottom :destination-left destination-left :destination-bottom destination-bottom :width width :height height :operation operation)) ((or (<= new-width 0) (<= new-height 0)) (il:* il:|;;| "Gross clipping") nil) (t (il:* il:|;;| "Adjusted bitblt") (stream-bitblt source destination :source-left (+ source-left (truncate (- new-left destination-left) scale)) :source-bottom (+ source-bottom (truncate (- new-bottom destination-bottom) scale)) :destination-left new-left :destination-bottom new-bottom :width (truncate new-width scale) :height (truncate new-height scale) :operation operation)))))
(defun clipped-bltshade (texture destination clipping-region &key (destination-left 0) (destination-bottom 0) width height (operation :default)) (if (null width) (setq width (cond ((window-p destination) (window-width destination)) ((bitmap-p destination) (bitmap-width destination)) (t (error "Not a window or a bitmap: ~s" destination))))) (if (null height) (setq height (cond ((window-p destination) (window-height destination)) ((bitmap-p destination) (bitmap-height destination)) (t (error "Not a window or a bitmap: ~s" destination))))) (let ((clip-left (region-left clipping-region)) (clip-bottom (region-bottom clipping-region)) (clip-width (region-width clipping-region)) (clip-height (region-height clipping-region)) (new-left destination-left) (new-bottom destination-bottom) (new-width width) (new-height height)) (when (> clip-left new-left) (setq new-width (- new-width (- clip-left new-left))) (setq new-left clip-left)) (when (> clip-bottom new-bottom) (setq new-height (- new-height (- clip-bottom new-bottom))) (setq new-bottom clip-bottom)) (if (> (+ new-left new-width) (+ clip-left clip-width)) (setq new-width (- (+ clip-left clip-width) new-left))) (if (> (+ new-bottom new-height) (+ clip-bottom clip-height)) (setq new-height (- (+ clip-bottom clip-height) new-bottom))) (if (or (>= 0 new-width) (>= 0 new-height)) (il:* il:|;;| "Gross clipping") nil (il:* il:|;;| "Adjusted bitblt") (stream-bltshade texture destination :destination-left new-left :destination-bottom new-bottom :width new-width :height new-height :operation operation))))
(defun clipped-draw-line (x1 y1 x2 y2 stream clipping-region &key width (operation :default) color dashing) (il:* il:|;;| "Clip against CLIPPINGREGION and draw in STREAM. Implements Cohen-Sutherland clipping. From Foley and Van Dam, pg. 146") (let* ((clip-left (region-left clipping-region)) (clip-bottom (region-bottom clipping-region)) (clip-right (1- (+ clip-left (region-width clipping-region)))) (clip-top (1- (+ clip-bottom (region-height clipping-region)))) (old-x2 x2) (old-y2 y2) (accept-p nil) (done-p nil) outcode-1 outcode-2) (loop (if done-p (return nil)) (setq outcode-1 (clip-code x1 y1 clip-left clip-right clip-top clip-bottom)) (setq outcode-2 (clip-code x2 y2 clip-left clip-right clip-top clip-bottom)) (if (fixnum-eq 0 (logand outcode-1 outcode-2)) (il:* il:|;;| "Possible accept") (if (setq accept-p (fixnum-eq 0 (logior outcode-1 outcode-2))) (il:* il:|;;| "accept") (setq done-p t) (progn (il:* il:|;;| "Find intersections") (when (fixnum-eq 0 outcode-1) (il:* il:|;;| "Swap points so (X1 . Y1) is guaranteed to be outside") (rotatef x1 x2) (rotatef y1 y2) (rotatef outcode-1 outcode-2)) (cond ((not (fixnum-eq 0 (logand outcode-1 8))) (il:* il:|;;| "divide line at top") (setq x1 (+ x1 (truncate (* (- x2 x1) (- clip-top y1)) (- y2 y1)))) (setq y1 clip-top)) ((not (fixnum-eq 0 (logand outcode-1 4))) (il:* il:|;;| "divide line at bottom") (setq x1 (+ x1 (truncate (* (- x2 x1) (- clip-bottom y1)) (- y2 y1)))) (setq y1 clip-bottom)) ((not (fixnum-eq 0 (logand outcode-1 2))) (il:* il:|;;| "divide line at right") (setq y1 (+ y1 (truncate (* (- y2 y1) (- clip-right x1)) (- x2 x1)))) (setq x1 clip-right)) (t (il:* il:|;;| "divide line at left") (setq y1 (+ y1 (truncate (* (- y2 y1) (- clip-left x1)) (- x2 x1)))) (setq x1 clip-left))))) (il:* il:|;;| "Reject") (setq done-p t))) (il:* il:|;;| "actually draw a line if one accepted") (if accept-p (stream-draw-line x1 y1 x2 y2 stream :width width :operation operation :color color :dashing dashing)) (il:* il:|;;| "Correctly update position in stream") (stream-move-to old-x2 old-y2 stream)))
(defun clipped-draw-between (position-1 position-2 stream clipping-region &key width (operation :default) color dashing) (clipped-draw-line (position-x position-1) (position-y position-1) (position-x position-2) (position-y position-2) stream clipping-region :width width :operation operation :color color :dashing dashing))
(defun clipped-draw-to (x y stream clipping-region &key width (operation :default) color dashing) (clipped-draw-line (stream-x stream) (stream-y stream) x y stream clipping-region :width width :operation operation :color color :dashing dashing))
(defun clipped-relative-draw-to (dx dy stream clipping-region &key width (operation :default) color dashing) (let ((x (stream-x stream)) (y (stream-y stream))) (clipped-draw-line x y (+ x dx) (+ y dy) stream clipping-region :width width :operation operation :color color :dashing dashing)))
(defun clipped-plot-at (position glyph stream clipping-region &optional (operation :default)) (let* ((glyph-width (bitmap-width glyph)) (glyph-height (bitmap-height glyph)) (scale (stream-scale stream)) (newx (- (position-x position) (* scale (truncate glyph-width 2)))) (newy (- (position-y position) (* scale (truncate glyph-height 2))))) (clipped-bitblt glyph stream clipping-region :destination-left newx :destination-bottom newy :width glyph-width :height glyph-height :operation operation)))
(defun clipped-princ (string stream clipping-region) (if (not (stringp string)) (setq string (princ-to-string string))) (let ((string-region (stream-string-region string stream))) (if (subregion-p clipping-region string-region) (il:* il:|;;| "No clipping") (princ string stream) (let ((iregion (intersect-regions string-region clipping-region))) (if (and iregion (= (region-height iregion) (region-height string-region))) (il:* il:|;;| "Some chars visible") (let* ((minx (region-left clipping-region)) (maxx (1- (+ minx (region-width clipping-region)))) (x (stream-x stream)) (y (stream-y nil stream))) (dotimes (i (length string)) (let* ((char (char string i)) (charwidth (char-width char stream)) (nextx (+ x charwidth))) (if (not (or (< x minx) (> nextx maxx))) (write-char char stream) (stream-move-to nextx y stream)) (setq x nextx)))))))))
(il:* il:|;;| "view-ports ")
(defstruct (linear-transform (:conc-name "LT-") (:copier nil)) (il:* il:|;;| "slope") m (il:* il:|;;| "constant") a)
(defstruct (view-port (:conc-name "VP-") (:constructor %make-view-port)) parent-stream stream-subregion world-region (il:* il:|;;| "the following are LINEAR-TRANSFORM objects") world-to-stream-x world-to-stream-y stream-to-world-x stream-to-world-y)
(defun make-world-to-stream-lt (stream-a stream-b world-a world-b) (let* ((m (float (/ (il:* il:|;;| "1- since we are dealing with an integer grid") (1- stream-a) world-a))) (a (float (- stream-b (* m world-b))))) (make-linear-transform :m m :a a)))
(defun make-stream-to-world-lt (world-to-stream-lt) (let ((m (/ 1.0 (lt-m world-to-stream-lt))) (a (- (/ (lt-a world-to-stream-lt) (lt-m world-to-stream-lt))))) (make-linear-transform :m m :a a)))
(defun make-view-port (stream &optional (stream-subregion (copy-region (stream-clipping-region stream))) (source (make-region 0.0 0.0 1.0 1.0))) (il:* il:|;;| "Create a viewport. If source is a region , then treat it as a region in world coorinates and set up the transformation to stream coorindates. If source is a Viewport, inherit the transformation and set up the world coordinates. If source is not supplied then supply a default WORLDREGION.") (if (not (subregion-p (stream-clipping-region stream) stream-subregion)) (error "~s is not a subregion of ~s." stream-subregion (stream-clipping-region stream))) (cond ((region-p source) (compute-transform (%make-view-port :parent-stream stream :stream-subregion stream-subregion :world-region source))) ((typep source (quote view-port)) (compute-world-region (let ((view-port (copy-view-port source))) (setf (vp-parent-stream view-port) stream) (setf (vp-stream-subregion view-port) stream-subregion) view-port))) (t (error "Not a region or view-port: ~S" source))))
(defun adjust-view-port (view-port &key stream-subregion world-region) (if (and stream-subregion world-region) (error "Can't provide both :stream-subregion and :world-region")) (cond (world-region (setf (vp-world-region view-port) world-region)) (stream-subregion (if (not (subregion-p (stream-clipping-region (vp-parent-stream view-port)) stream-subregion)) (error "Not a subregion of stream: ~s" stream-subregion)) (setf (vp-stream-subregion view-port) stream-subregion)) (t (error "Must provide one of :stream-subregion and :world-region"))) (compute-transform view-port))
(defun compute-transform (view-port) (il:* il:|;;| "Computes the world to window transformation given a view-port's window-subregion and world-region") (let* ((stream-subregion (vp-stream-subregion view-port)) (world-region (vp-world-region view-port)) (world-to-stream-x (make-world-to-stream-lt (region-width stream-subregion) (region-left stream-subregion) (region-width world-region) (region-left world-region))) (world-to-stream-y (make-world-to-stream-lt (region-height stream-subregion) (region-bottom stream-subregion) (region-height world-region) (region-bottom world-region)))) (setf (vp-world-to-stream-x view-port) world-to-stream-x) (setf (vp-world-to-stream-y view-port) world-to-stream-y) (setf (vp-stream-to-world-x view-port) (make-stream-to-world-lt world-to-stream-x)) (setf (vp-stream-to-world-y view-port) (make-stream-to-world-lt world-to-stream-y)) view-port))
(defun compute-world-region (view-port) (il:* il:|;;| "Given a View-port's World-to-Stream transformation, computes the corresponding World region") (let ((stream-subregion (vp-stream-subregion view-port)) (world-to-stream-x (vp-world-to-stream-x view-port)) (world-to-stream-y (vp-world-to-stream-y view-port))) (setf (vp-world-region view-port) (make-region (/ (- (region-left stream-subregion) (lt-a world-to-stream-x)) (lt-m world-to-stream-x)) (/ (- (region-bottom stream-subregion) (lt-a world-to-stream-y)) (lt-m world-to-stream-y)) (/ (region-width stream-subregion) (lt-m world-to-stream-x)) (/ (region-height stream-subregion) (lt-m world-to-stream-y)))) view-port))
(defmacro apply-transform (x transform) (once-only (x transform) (il:bquote (+ (lt-a (il:\\\, transform)) (* (lt-m (il:\\\, transform)) (il:\\\, x))))))
(defmacro apply-scale-transform (x transform) (once-only (x transform) (il:bquote (* (lt-m (il:\\\, transform)) (il:\\\, x)))))
(defun stream-to-world-x (x view-port) (apply-transform x (vp-stream-to-world-x view-port)))
(defun stream-to-world-length-x (dx view-port) (apply-scale-transform dx (vp-stream-to-world-x view-port)))
(defun stream-to-world-y (y view-port) (apply-transform y (vp-stream-to-world-y view-port)))
(defun stream-to-world-length-y (dy view-port) (apply-scale-transform dy (vp-stream-to-world-y view-port)))
(defun world-to-stream-x (x view-port) (values (truncate (apply-transform x (vp-world-to-stream-x view-port)))))
(defun world-to-stream-length-x (dx view-port) (values (truncate (apply-scale-transform dx (vp-world-to-stream-x view-port)))))
(defun world-to-stream-y (y view-port) (values (truncate (apply-transform y (vp-world-to-stream-y view-port)))))
(defun world-to-stream-length-y (dy view-port) (values (truncate (apply-scale-transform dy (vp-world-to-stream-y view-port)))))
(defun stream-to-world (position view-port) (make-position (stream-to-world-x (position-x position) view-port) (stream-to-world-y (position-y position) view-port)))
(defun world-to-stream (position view-port) (make-position (world-to-stream-x (position-x position) view-port) (world-to-stream-y (position-y position) view-port)))
(defun stream-region-to-world-region (region view-port) (make-region (stream-to-world-x (region-left region) view-port) (stream-to-world-y (region-bottom region) view-port) (stream-to-world-length-x (region-width region) view-port) (stream-to-world-length-y (region-height region) view-port)))
(defun world-region-to-stream-region (region view-port) (make-region (world-to-stream-x (region-left region) view-port) (world-to-stream-y (region-bottom region) view-port) (world-to-stream-length-x (region-width region) view-port) (world-to-stream-length-y (region-height region) view-port)))
(defun bitblt (source destination-viewport &key source-left source-bottom destination-left destination-bottom width height (operation :default)) (il:* il:|;;| "Destination MUST be a VIEWPORT. Source can be either a VIEWPORT or some other form of BITMAP (in which case no transformations are performed) .") (if (not (view-port-p destination-viewport)) (error "Destination not a viewport: ~s" destination-viewport)) (let* ((stream (vp-parent-stream destination-viewport)) (stream-subregion (vp-stream-subregion destination-viewport)) (stream-left (if (null destination-left) (region-left stream-subregion) (world-to-stream-x destination-left destination-viewport))) (stream-bottom (if (null destination-bottom) (region-bottom stream-subregion) (world-to-stream-y destination-bottom destination-viewport))) (stream-clipping-region stream-subregion) (source-bitmap source) (source-bitmap-left (or source-left 0)) (source-bitmap-bottom (or source-bottom 0)) (source-width (or width (cond ((bitmap-p source) (bitmap-width source)) ((window-p source) (window-width source))))) (source-height (or height (cond ((bitmap-p source) (bitmap-height source)) ((window-p source) (window-height source)))))) (if (view-port-p source) (let ((source-subregion (vp-stream-subregion source))) (setq source-bitmap (vp-parent-stream source)) (setq source-bitmap-left (if (null source-left) (region-left source-subregion) (world-to-stream-x source-left source))) (setq source-bitmap-bottom (if (null source-bottom) (region-bottom source-subregion) (world-to-stream-y source-bottom source))) (setq source-width (if (null width) (region-width source-subregion) (world-to-stream-length-x width source))) (setq source-height (if (null height) (region-height source-subregion) (world-to-stream-length-y height source))) (setq stream-clipping-region (intersect-regions stream-clipping-region source-subregion)))) (il:* il:|;;| "(il:|if| (eq source-type 'texture) il:|then| (setq sourcewidth (il:|if| (null width) il:|then| (il:|fetch| (il:region width) il:|of| streamsubregion) il:|else| (il:worldtostreamxlength width destination-viewport))) (setq sourceheight (il:|if| (null height) il:|then| (il:|fetch| (il:region height) il:|of| streamsubregion) il:|else| (il:worldtostreamylength height destination-viewport))))") (clipped-bitblt source-bitmap stream stream-clipping-region :source-left source-bitmap-left :source-bottom source-bitmap-bottom :destination-left stream-left :destination-bottom stream-bottom :width source-width :height source-height :operation operation)))
(defun bltshade (texture destination-viewport &key source-left source-bottom destination-left destination-bottom width height (operation :default)) (il:* il:|;;| "Destination MUST be a VIEWPORT. Source can be either a VIEWPORT or some other form of BITMAP (in which case no transformations are performed) .") (if (not (view-port-p destination-viewport)) (error "Destination not a viewport: ~s" destination-viewport)) (let* ((stream (vp-parent-stream destination-viewport)) (stream-subregion (vp-stream-subregion destination-viewport)) (stream-left (if (null destination-left) (region-left stream-subregion) (world-to-stream-x destination-left destination-viewport))) (stream-bottom (if (null destination-bottom) (region-bottom stream-subregion) (world-to-stream-y destination-bottom destination-viewport))) (stream-clipping-region stream-subregion) (source-width (if (null width) (region-width stream-subregion) (world-to-stream-length-x width destination-viewport))) (source-height (if (null height) (region-height stream-subregion) (world-to-stream-length-y height destination-viewport)))) (clipped-bltshade texture stream stream-clipping-region :destination-left stream-left :destination-bottom stream-bottom :width source-width :height source-height :operation operation)))
(defun draw-line (x1 y1 x2 y2 view-port &key width (operation :default) color dashing) (let* ((world-to-stream-x (vp-world-to-stream-x view-port)) (world-to-stream-y (vp-world-to-stream-y view-port))) (clipped-draw-line (apply-transform x1 world-to-stream-x) (apply-transform y1 world-to-stream-y) (apply-transform x2 world-to-stream-x) (apply-transform y2 world-to-stream-y) (vp-parent-stream view-port) (vp-stream-subregion view-port) :width width :operation operation :color color :dashing dashing)))
(defun draw-between (position-1 position-2 view-port clipping-region &key width (operation :default) color dashing) (draw-line (position-x position-1) (position-y position-1) (position-x position-2) (position-y position-2) view-port :width width :operation operation :color color :dashing dashing))
(defun draw-to (x y view-port &key width (operation :default) color dashing) (clipped-draw-to (world-to-stream-x x view-port) (world-to-stream-y y view-port) (vp-parent-stream view-port) (vp-stream-subregion) :width width :operation operation :color color :dashing dashing))
(defun relative-draw-to (dx dy view-port &key width (operation :default) color dashing) (clipped-relative-draw-to (world-to-stream-length-x dx view-port) (world-to-stream-length-y dy view-port) (vp-parent-stream view-port) (vp-stream-subregion) :width width :operation operation :color color :dashing dashing))
(defun relative-draw-to-point (position view-port &key width (operation :default) color dashing) (clipped-relative-draw-to (world-to-stream-length-x (position-x position) view-port) (world-to-stream-length-y (position-y position) view-port) (vp-parent-stream view-port) (vp-stream-subregion) :width width :operation operation :color color :dashing dashing))
(defun draw-to-point (position view-port &key width (operation :default) color dashing) (clipped-draw-to (world-to-stream-x (position-x position) view-port) (world-to-stream-y (position-y position) view-port) (vp-parent-stream view-port) (vp-stream-subregion) :width width :operation operation :color color :dashing dashing))
(defun move-to (x y view-port) (stream-move-to (world-to-stream-x x view-port) (world-to-stream-y y view-port) (vp-parent-stream view-port)))
(defun move-to-point (position view-port) (stream-move-to (world-to-stream-x (position-x position) view-port) (world-to-stream-y (position-y position) view-port) (vp-parent-stream view-port)))
(defun relative-move-to (dx dy view-port) (let ((stream (vp-parent-stream view-port))) (stream-move-to (+ (stream-x stream) (world-to-stream-x dx view-port)) (+ (stream-y stream) (world-to-stream-y dy view-port)) stream)))
(defun relative-move-to-point (position view-port) (let ((stream (vp-parent-stream view-port))) (stream-move-to (+ (stream-x stream) (world-to-stream-x (position-x position) view-port)) (+ (stream-y stream) (world-to-stream-y (position-y position) view-port)) stream)))
(defun plot-at (position glyph view-port &optional (operation :default)) (clipped-plot-at (make-position (world-to-stream-x (position-x position) view-port) (world-to-stream-y (position-y position) view-port)) glyph (vp-parent-stream view-port) (vp-stream-subregion view-port) :operation operation))
(xcl:define-file-environment "VIEW-PORTS" :package "TDG" :compiler :compile-file :readtable "XCL")
(il:putprops il:view-ports il:copyright ("Xerox Corporation" 1988))
(il:declare\: il:dontcopy
(il:filemap (nil)))
il:stop