home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / test / image.l next >
Encoding:
Text File  |  1990-05-30  |  5.0 KB  |  154 lines
  1. ;;; -*- Mode:Lisp; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
  2.  
  3. ;;; Tests image code by randomly reading, copying and then writing images to
  4. ;;; the exact same place on the screen.  If everything works, just the borders
  5. ;;; of the image windows appear.  If one of these image windows is garbled,
  6. ;;; then somewhere something is broken.  Entry point is the function
  7. ;;; IMAGE-TEST
  8.  
  9. (in-package :xlib)
  10.  
  11. (export '(image-test))
  12.  
  13. (defvar *image-test-host* "")
  14.  
  15. (defvar *image-test-nimages* 25)
  16.  
  17. (defvar *image-test-copy* t)
  18.  
  19. (defvar *image-test-copy-random-subimage* t)
  20.  
  21. (defvar *image-test-put-random-subimage* t)
  22.  
  23. (defvar *image-test-get-image-result-type-choices*
  24.   '(image-x image-x image-xy image-z))
  25.  
  26. (defvar *image-test-get-image-image-x-format-choices*
  27.   '(:xy-pixmap :z-pixmap))
  28.  
  29. (defun image-test
  30.        (&key
  31.     (host *image-test-host*)
  32.     (nimages *image-test-nimages*)
  33.     (copy *image-test-copy*)
  34.     (copy-random-subimage *image-test-copy-random-subimage*)
  35.     (put-random-subimage *image-test-put-random-subimage*)
  36.     (get-image-result-type-choices
  37.       *image-test-get-image-result-type-choices*)
  38.     (get-image-image-x-format-choices
  39.       *image-test-get-image-image-x-format-choices*))
  40.   (let* ((display nil)
  41.      (abort t)
  42.      (images nil))
  43.     (loop 
  44.       (setq images nil)
  45.       (unwind-protect
  46.       (progn
  47.         (setq display (open-display host))
  48.         (let* ((screen (display-default-screen display))
  49.            (window (screen-root screen))
  50.            (gcontext (create-gcontext
  51.                    :drawable window
  52.                    :font (open-font display "fixed"))))
  53.           (dotimes (i nimages)
  54.         (let ((image (image-test-get-image
  55.                    window
  56.                    get-image-result-type-choices
  57.                    get-image-image-x-format-choices)))
  58.           (format t "~&Image=~S~%" image)
  59.           (let ((copy (if copy
  60.                   (image-test-copy-image
  61.                     image
  62.                     copy-random-subimage)
  63.                 image)))
  64.             (format t "~&Copy=~S~%" copy)
  65.             (push (list image copy) images)
  66.             (image-test-put-image
  67.               screen gcontext copy
  68.               (concatenate
  69.             'string (image-info image) (image-info copy))
  70.               put-random-subimage))))
  71.           (unless (y-or-n-p "More ") (return))
  72.           (setq abort nil)))
  73.     (close-display (shiftf display nil) :abort abort))
  74.       (sleep 10))
  75.     (reverse images)))
  76.  
  77. (defun image-test-choose (list)
  78.   (nth (random (length list)) list))
  79.  
  80. (defun image-test-get-image (window result-type-choices image-x-format-choices)
  81.   (let* ((x (random (floor (drawable-width window) 3)))
  82.      (y (random (floor (drawable-height window) 3)))
  83.      (hw (floor (- (drawable-width window) x) 3))
  84.      (hh (floor (- (drawable-height window) y) 3))
  85.      (width (+ hw hw (random hw)))
  86.      (height (+ hh hh (random hh)))
  87.      (result-type (image-test-choose result-type-choices))
  88.      (format
  89.        (ecase result-type
  90.          (image-x (image-test-choose image-x-format-choices))
  91.          (image-xy :xy-pixmap)
  92.          (image-z :z-pixmap)))
  93.      (image (get-image window :x x :y y :width width :height height
  94.                :format format :result-type result-type)))
  95.     (setf (image-x-hot image) (- x))
  96.     (setf (image-y-hot image) (- y))
  97.     image))
  98.  
  99. (defun image-test-subimage-parameters (image random-subimage-p)
  100.   (if random-subimage-p 
  101.       (let* ((x (random (floor (image-width image) 3)))
  102.          (y (random (floor (image-height image) 3)))
  103.          (hw (floor (- (image-width image) x) 3))
  104.          (hh (floor (- (image-height image) y) 3))
  105.          (width (+ hw hw (random hw)))
  106.          (height (+ hh hh (random hh))))
  107.     (values x y width height))
  108.     (values 0 0 (image-width image) (image-height image))))
  109.  
  110. (defun image-test-copy-image (image random-subimage-p)
  111.   (let ((result-type
  112.       (if (zerop (random 2))
  113.           (type-of image)
  114.         (etypecase image
  115.           (image-x (ecase (image-x-format image)
  116.              (:xy-pixmap 'image-xy)
  117.              (:z-pixmap 'image-z)))
  118.           ((or image-xy image-z) 'image-x)))))
  119.     (multiple-value-bind (x y width height)
  120.     (image-test-subimage-parameters image random-subimage-p)
  121.       (copy-image image :x x :y y :width width :height height
  122.           :result-type result-type))))
  123.  
  124. (defun image-test-put-image (screen gcontext image info random-subimage-p)
  125.   (multiple-value-bind (src-x src-y width height)
  126.       (image-test-subimage-parameters image random-subimage-p)
  127.     (let* ((border-width 1)
  128.        (x (- src-x (image-x-hot image) border-width))
  129.        (y (- src-y (image-y-hot image) border-width)))
  130.       (unless (or (zerop width) (zerop height))
  131.     (let ((window
  132.         (create-window
  133.           :parent (screen-root screen) :x x :y y
  134.           :width width :height height
  135.           :border-width border-width
  136.           :background (screen-white-pixel screen)
  137.           :override-redirect :on)))
  138.       (map-window window)
  139.       (display-finish-output (drawable-display window))
  140.       (put-image window gcontext image
  141.              :x 0 :y 0 :src-x src-x :src-y src-y
  142.              :width width :height height)
  143.       (draw-image-glyphs window gcontext 0 (1- height) info)
  144.       (display-finish-output (drawable-display window))
  145.       window)))))
  146.  
  147. (defun image-info (image)
  148.   (etypecase image
  149.     (image-x (ecase (image-x-format image)
  150.            (:xy-pixmap "XXY")
  151.            (:z-pixmap  "XZ ")))
  152.     (image-xy "XY ")
  153.     (image-z  "Z  ")))
  154.