;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Fonts:(CPTFONT); Syntax:Common-Lisp; -*- ;;;----------------------------------------------------------------------------------+ ;;; | ;;; TEXAS INSTRUMENTS INCORPORATED | ;;; P.O. BOX 149149 | ;;; AUSTIN, TEXAS 78714 | ;;; | ;;; Copyright (C) 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. | ;;; | ;;;----------------------------------------------------------------------------------+ (in-package "CLIO-OPEN") (export '( make-display-image display-image display-image-source ) 'clio-open) ;;;----------------------------------------------------------------------------+ ;;; | ;;; DISPLAY IMAGE | ;;; | ;;;----------------------------------------------------------------------------+ (defcontact display-image (gravity-mixin core contact) ;; Source is what is given and/or returned by/to outside callers. ;; Internally, source is converted to source-pixmap for all other operations. ((source :type (or null pixmap image) :initform nil :initarg :source :reader display-image-source ;; SETF method defined below ) (source-pixmap :type (or null pixmap) ;; internal storage :initform nil) (source-pixmap-width :type card16 ;; internal storage :initform 0) (source-pixmap-height :type card16 ;; internal storage :initform 0) (compress-exposures :initform :off :type (member :off :on) :reader contact-compress-exposures :allocation :class)) (:resources source)) (defmethod (setf display-gravity) (new-gravity (display-image display-image)) (check-type new-gravity (or gravity (member :tiled))) (setf (slot-value display-image 'gravity) new-gravity)) (defmethod (setf display-image-source) ((new-source pixmap) (display-image display-image)) (with-slots (source source-pixmap source-pixmap-width source-pixmap-height depth) display-image (with-state (new-source) (let ((source-depth (drawable-depth new-source))) (assert (or (= source-depth depth) (= source-depth 1)) () "~a depth is ~a, which is neither 1 nor ~a." new-source source-depth depth) (setf source-pixmap-width (drawable-width new-source) source-pixmap-height (drawable-height new-source) source-pixmap (when (realized-p display-image) (realize-display-image display-image new-source))) (setf source new-source))))) (defmethod (setf display-image-source) ((new-source image) (display-image display-image)) (with-slots (source source-pixmap source-pixmap-width source-pixmap-height foreground depth) display-image (let ((source-depth (image-depth new-source))) (assert (or (= source-depth depth) (= source-depth 1)) () "~a depth is ~a, which is neither 1 nor ~a." new-source source-depth depth) (setf source-pixmap-width (image-width new-source) source-pixmap-height (image-height new-source) source-pixmap (when (realized-p display-image) (realize-display-image display-image new-source))) (setf source new-source)))) (defmethod (setf display-image-source) (new-source (display-image display-image)) (assert (not new-source) () "New source is ~a, which is not NIL, a PIXMAP, or an IMAGE.") (with-slots (source source-pixmap source-pixmap-width source-pixmap-height) display-image (setf source-pixmap-width 0 source-pixmap-height 0 source-pixmap nil) (setf source new-source))) (defmethod (setf display-image-source) :after (new-source (display-image display-image)) (declare (ignore new-source)) (when (realized-p display-image) (clear-area display-image) (display display-image))) (defmethod realize-display-image ((display-image display-image) (new-source pixmap)) (with-slots (source-pixmap-width source-pixmap-height foreground depth) display-image (if (= (drawable-depth new-source) depth) new-source ;; Else expand bitmap to full depth pixmap. (let ((pixmap (create-pixmap :drawable display-image :width source-pixmap-width :height source-pixmap-height :depth depth))) (using-gcontext (gc :drawable display-image :foreground foreground :background (contact-current-background-pixel display-image)) (copy-plane new-source gc 1 ; Note, this is a mask, not an index. 0 0 source-pixmap-width source-pixmap-height pixmap 0 0)) pixmap)))) (defmethod realize-display-image ((display-image display-image) (new-source image)) (with-slots (source-pixmap-width source-pixmap-height foreground depth) display-image (if (= (image-depth new-source) depth) (contact-image-pixmap display-image new-source) ;; Else expand bitmap to full depth pixmap. (contact-image-mask display-image new-source :foreground foreground :background (contact-current-background-pixel display-image))))) (defmethod realize :after ((display-image display-image)) (with-slots (source source-pixmap) display-image (when source (setf source-pixmap (realize-display-image display-image source))))) (defmethod (setf contact-foreground) :after (new-value (display-image display-image)) (declare (ignore new-value)) (with-slots (source source-pixmap) display-image (when (and source (realized-p display-image)) (setf source-pixmap (realize-display-image display-image source))))) (defmethod (setf contact-background) :after (new-value (display-image display-image)) (declare (ignore new-value)) (with-slots (source source-pixmap) display-image (when (realized-p display-image) (when source (setf source-pixmap (realize-display-image display-image source))) (clear-area display-image) (display display-image)))) ;;;----------------------------------------------------------------------------+ ;;; | ;;; Initialization | ;;; | ;;;----------------------------------------------------------------------------+ (defun make-display-image (&rest initargs &key &allow-other-keys) (declare (values display-image)) (apply #'make-contact 'display-image initargs)) (defmethod initialize-instance :after ((display-image display-image) &key source &allow-other-keys) (with-slots (width height) display-image ;; Insure that source-pixmap & source-pixmap-width & source-pixmap-height ;; get set up if the source arg is specified. Also check for valid source argument. (setf (display-image-source display-image) source) ;; Initialize required geometry (when (or (zerop width) (zerop height)) (multiple-value-bind (pwidth pheight) (preferred-size display-image :width width :height height) (change-geometry display-image :width pwidth :height pheight))))) ;;;----------------------------------------------------------------------------+ ;;; | ;;; Geometry Management | ;;; | ;;;----------------------------------------------------------------------------+ (defmethod preferred-size ((display-image display-image) &key width height border-width) (declare (values preferred-width preferred-height preferred-border-width)) (with-slots ((current-border-width border-width) (current-height height) (current-width width) gravity source-pixmap-height source-pixmap-width) display-image (values ;; Preferred-width (max (or width current-width) source-pixmap-width) ;; Preferred-height (max (or height current-height) source-pixmap-height) ;; Preferred-border-width (max 0 (or border-width current-border-width))))) ;;;----------------------------------------------------------------------------+ ;;; | ;;; DISPLAY | ;;; | ;;;----------------------------------------------------------------------------+ (defmethod display ((display-image display-image) &optional (exposed-x 0) (exposed-y 0) exposed-width exposed-height &key) (with-slots (source-pixmap source-pixmap-height source-pixmap-width gravity width height clip-rectangle) display-image (when source-pixmap (let ((exposed-width (or exposed-width (- width exposed-x))) (exposed-height (or exposed-height (- height exposed-y))) (tiled-p (eq gravity :tiled))) (using-gcontext (gc :drawable display-image :exposures :off :clip-mask clip-rectangle :fill-style (when tiled-p :tiled) :tile (when tiled-p source-pixmap) :ts-x (when tiled-p (display-clip-x display-image)) :ts-y (when tiled-p (display-clip-y display-image))) (if tiled-p (draw-rectangle display-image gc exposed-x exposed-y exposed-width exposed-height :fill-p) (multiple-value-bind (extent-x extent-y) (case gravity (:north-west (values (display-clip-x display-image) (display-clip-y display-image))) (:north (values (+ (display-clip-x display-image) (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2)) (display-clip-y display-image))) (:north-east (values (+ (display-clip-x display-image) (- (display-clip-width display-image) source-pixmap-width)) (display-clip-y display-image))) (:west (values (display-clip-x display-image) (+ (display-clip-y display-image) (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2)))) (:center (values (+ (display-clip-x display-image) (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2)) (+ (display-clip-y display-image) (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2)))) (:east (values (+ (display-clip-x display-image) (- (display-clip-width display-image) source-pixmap-width)) (+ (display-clip-y display-image) (pixel-round (- (display-clip-height display-image) source-pixmap-height) 2)))) (:south-west (values (display-clip-x display-image) (+ (display-clip-y display-image) (- (display-clip-height display-image) source-pixmap-height)))) (:south (values (+ (display-clip-x display-image) (pixel-round (- (display-clip-width display-image) source-pixmap-width) 2)) (+ (display-clip-y display-image) (- (display-clip-height display-image) source-pixmap-height)))) (:south-east (values (+ (display-clip-x display-image) (- (display-clip-width display-image) source-pixmap-width)) (+ (display-clip-y display-image) (- (display-clip-height display-image) source-pixmap-height))))) (multiple-value-setq (exposed-x exposed-y exposed-width exposed-height) (area-overlaps-p exposed-x exposed-y exposed-width exposed-height extent-x extent-y source-pixmap-width source-pixmap-height)) (when exposed-x (copy-area source-pixmap gc (- exposed-x extent-x) (- exposed-y extent-y) exposed-width exposed-height display-image exposed-x exposed-y))))))))) (defmethod resize :around ((display-image display-image) new-width new-height new-border-width) (with-slots (width height border-width gravity) display-image (let* ((delta-width (- new-width width)) (delta-height (- new-height height)) ;; Establish new size. (resized-p (call-next-method))) (unless (or (not resized-p) ;; If bit-gravity is :forget, then usual exposure handling is sufficient. (case gravity ((:north :south) (/= (display-left-margin display-image) (display-right-margin display-image))) ((:west :east) (/= (display-top-margin display-image) (display-bottom-margin display-image))) (:center (or (/= (display-left-margin display-image) (display-right-margin display-image)) (/= (display-top-margin display-image) (display-bottom-margin display-image)))))) ;; Otherwise, must redisplay part of image previously obscured by margins. (cond ((plusp delta-width) ;; Redisplay exposed part of left margin. (multiple-value-bind (left-x left-y left-width left-height) (case gravity ((:north :center :south) (values (display-clip-x display-image) (display-clip-y display-image) (pixel-round delta-width 2) (display-clip-height display-image))) ((:north-east :east :south-east) (values (display-clip-x display-image) (display-clip-y display-image) delta-width (display-clip-height display-image)))) (when left-x (display display-image left-x left-y left-width left-height))) ;; Redisplay exposed part of right margin. (multiple-value-bind (right-x right-y right-width right-height) (case gravity ((:north :center :south) (let ((delta (pixel-round delta-width 2))) (values (- width (display-right-margin display-image) delta) (display-clip-y display-image) delta (display-clip-height display-image)))) ((:north-west :west :south-west :tiled) (values (- width (display-right-margin display-image) delta-width) (display-clip-y display-image) delta-width (display-clip-height display-image)))) (when right-x (display display-image right-x right-y right-width right-height)))) (:else ;; Clear out left margin for smaller window. (unless (case gravity ((:north-west :west :south-west) t)) (clear-area display-image :x 0 :y 0 :width (display-left-margin display-image) :height height)) ;; Clear out right margin for smaller window. (unless (case gravity ((:north-east :east :south-east) t)) (clear-area display-image :x (- width (display-right-margin display-image)) :y 0 :width (display-right-margin display-image) :height height)))) (cond ((plusp delta-height) ;; Redisplay exposed part of top margin. (multiple-value-bind (top-x top-y top-width top-height) (case gravity ((:west :center :east) (values (display-clip-x display-image) (display-clip-y display-image) (display-clip-width display-image) (pixel-round delta-height 2))) ((:south-west :south :south-east) (values (display-clip-x display-image) (display-clip-y display-image) (display-clip-width display-image) delta-height))) (when top-x (display display-image top-x top-y top-width top-height))) ;; Redisplay exposed part of bottom margin. (multiple-value-bind (bottom-x bottom-y bottom-width bottom-height) (case gravity ((:west :center :east) (let ((delta (pixel-round delta-height 2))) (values (display-clip-x display-image) (- height (display-bottom-margin display-image) delta) (display-clip-width display-image) delta))) ((:north-west :north :north-east :tiled) (values (display-clip-x display-image) (- height (display-bottom-margin display-image) delta-height) (display-clip-width display-image) delta-height))) (when bottom-x (display display-image bottom-x bottom-y bottom-width bottom-height)))) (:else ;; Clear out top margin for smaller window. (unless (case gravity ((:north-west :north :north-east) t)) (clear-area display-image :x 0 :y 0 :width width :height (display-top-margin display-image))) ;; Clear out bottom margin for smaller window. (unless (case gravity ((:south-west :south :south-east) t)) (clear-area display-image :x 0 :y (- height (display-bottom-margin display-image)) :width width :height (display-bottom-margin display-image)))))) resized-p)))