home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / X / mit / lib / CLX / graphics.l < prev    next >
Encoding:
Text File  |  1991-07-07  |  16.4 KB  |  448 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; CLX drawing requests
  4.  
  5. ;;;
  6. ;;;             TEXAS INSTRUMENTS INCORPORATED
  7. ;;;                  P.O. BOX 2909
  8. ;;;                   AUSTIN, TEXAS 78769
  9. ;;;
  10. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  11. ;;;
  12. ;;; Permission is granted to any individual or institution to use, copy, modify,
  13. ;;; and distribute this software, provided that this complete copyright and
  14. ;;; permission notice is maintained, intact, in all copies and supporting
  15. ;;; documentation.
  16. ;;;
  17. ;;; Texas Instruments Incorporated provides this software "as is" without
  18. ;;; express or implied warranty.
  19. ;;;
  20.  
  21. (in-package :xlib)
  22.  
  23. (defvar *inhibit-appending* nil)
  24.  
  25. (defun draw-point (drawable gcontext x y)
  26.   ;; Should be clever about appending to existing buffered protocol request.
  27.   (declare (type drawable drawable)
  28.        (type gcontext gcontext)
  29.        (type int16 x y))
  30.   (let ((display (drawable-display drawable)))
  31.     (declare (type display display))
  32.     (with-display (display)
  33.       (force-gcontext-changes-internal gcontext)
  34.       (with-buffer-output (display :length *requestsize*)
  35.     (let* ((last-request-byte (display-last-request display))
  36.            (current-boffset buffer-boffset))
  37.       ;; To append or not append, that is the question
  38.       (if (and (not *inhibit-appending*)
  39.            last-request-byte
  40.            ;; Same request?
  41.            (= (aref-card8 buffer-bbuf last-request-byte) *x-polypoint*)
  42.            (progn ;; Set buffer pointers to last request
  43.              (set-buffer-offset last-request-byte)
  44.              ;; same drawable and gcontext?
  45.              (or (compare-request (4)
  46.                (data 0)
  47.                (drawable drawable)
  48.                (gcontext gcontext))
  49.              (progn ;; If failed, reset buffer pointers
  50.                (set-buffer-offset current-boffset)
  51.                nil))))
  52.           ;; Append request
  53.           (progn
  54.         ;; Set new request length        
  55.         (card16-put 2 (index+ 1 (index-ash (index- current-boffset last-request-byte)
  56.                            -2)))
  57.         (set-buffer-offset current-boffset)
  58.         (put-items (0)            ; Insert new point
  59.           (int16 x y))
  60.         (setf (display-boffset display) (index+ buffer-boffset 4)))
  61.         ;; New Request
  62.         (progn
  63.           (put-items (4)
  64.         (code *x-polypoint*)
  65.         (data 0) ;; Relative-p false
  66.         (length 4)
  67.         (drawable drawable)
  68.         (gcontext gcontext)
  69.         (int16 x y))
  70.           (buffer-new-request-number display)
  71.           (setf (buffer-last-request display) buffer-boffset)
  72.           (setf (display-boffset display) (index+ buffer-boffset 16)))))))
  73.     (display-invoke-after-function display))) 
  74.  
  75.  
  76. (defun draw-points (drawable gcontext points &optional relative-p)
  77.   (declare (type drawable drawable)
  78.        (type gcontext gcontext)
  79.        (type sequence points)        ;(repeat-seq (integer x) (integer y))
  80.        (type boolean relative-p))
  81.   (with-buffer-request ((drawable-display drawable) *x-polypoint* :gc-force gcontext)
  82.     ((data boolean) relative-p)
  83.     (drawable drawable)
  84.     (gcontext gcontext)
  85.     ((sequence :format int16) points)))
  86.  
  87. (defun draw-line (drawable gcontext x1 y1 x2 y2 &optional relative-p)
  88.   ;; Should be clever about appending to existing buffered protocol request.
  89.   (declare (type drawable drawable)
  90.        (type gcontext gcontext)
  91.        (type int16 x1 y1 x2 y2)
  92.        (type boolean relative-p))
  93.   (let ((display (drawable-display drawable)))
  94.     (declare (type display display))
  95.     (when relative-p
  96.       (incf x2 x1)
  97.       (incf y2 y1))
  98.     (with-display (display)
  99.       (force-gcontext-changes-internal gcontext)
  100.       (with-buffer-output (display :length *requestsize*)
  101.     (let* ((last-request-byte (display-last-request display))
  102.            (current-boffset buffer-boffset))
  103.       ;; To append or not append, that is the question
  104.       (if (and (not *inhibit-appending*)
  105.            last-request-byte
  106.            ;; Same request?
  107.            (= (aref-card8 buffer-bbuf last-request-byte) *x-polysegment*)
  108.            (progn ;; Set buffer pointers to last request
  109.              (set-buffer-offset last-request-byte)
  110.              ;; same drawable and gcontext?
  111.              (or (compare-request (4)
  112.                (drawable drawable)
  113.                (gcontext gcontext))
  114.              (progn ;; If failed, reset buffer pointers
  115.                (set-buffer-offset current-boffset)
  116.                nil))))
  117.           ;; Append request
  118.           (progn
  119.         ;; Set new request length
  120.         (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
  121.                            -2)))
  122.         (set-buffer-offset current-boffset)
  123.         (put-items (0)            ; Insert new point
  124.           (int16 x1 y1 x2 y2))
  125.         (setf (display-boffset display) (index+ buffer-boffset 8)))
  126.         ;; New Request
  127.         (progn
  128.           (put-items (4)
  129.         (code *x-polysegment*)
  130.         (length 5)
  131.         (drawable drawable)
  132.         (gcontext gcontext)
  133.         (int16 x1 y1 x2 y2))
  134.           (buffer-new-request-number display)
  135.           (setf (buffer-last-request display) buffer-boffset)
  136.           (setf (display-boffset display) (index+ buffer-boffset 20)))))))
  137.     (display-invoke-after-function display))) 
  138.  
  139. (defun draw-lines (drawable gcontext points &key relative-p fill-p (shape :complex))
  140.   (declare (type drawable drawable)
  141.        (type gcontext gcontext)
  142.        (type sequence points) ;(repeat-seq (integer x) (integer y))
  143.        (type boolean relative-p fill-p)
  144.        (type (member :complex :non-convex :convex) shape))
  145.   (if fill-p
  146.       (fill-polygon drawable gcontext points relative-p shape)
  147.     (with-buffer-request ((drawable-display drawable)  *x-polyline* :gc-force gcontext)
  148.       ((data boolean) relative-p)
  149.       (drawable drawable)
  150.       (gcontext gcontext)
  151.       ((sequence :format int16) points))))
  152.  
  153. ;; Internal function called from DRAW-LINES
  154. (defun fill-polygon (drawable gcontext points relative-p shape)
  155.   ;; This is clever about appending to previous requests.  Should it be?
  156.   (declare (type drawable drawable)
  157.        (type gcontext gcontext)
  158.        (type sequence points)        ;(repeat-seq (integer x) (integer y))
  159.        (type boolean relative-p)
  160.        (type (member :complex :non-convex :convex) shape))
  161.   (with-buffer-request ((drawable-display drawable)  *x-fillpoly* :gc-force gcontext)
  162.     (drawable drawable)
  163.     (gcontext gcontext)
  164.     ((member8 :complex :non-convex :convex) shape)
  165.     (boolean relative-p)
  166.     ((sequence :format int16) points)))
  167.  
  168. (defun draw-segments (drawable gcontext segments)
  169.   (declare (type drawable drawable)
  170.        (type gcontext gcontext)
  171.        ;; (repeat-seq (integer x1) (integer y1) (integer x2) (integer y2)))
  172.        (type sequence segments)) 
  173.   (with-buffer-request ((drawable-display drawable) *x-polysegment* :gc-force gcontext)
  174.     (drawable drawable)
  175.     (gcontext gcontext)
  176.     ((sequence :format int16) segments)))
  177.  
  178. (defun draw-rectangle (drawable gcontext x y width height &optional fill-p)
  179.   ;; Should be clever about appending to existing buffered protocol request.
  180.   (declare (type drawable drawable)
  181.        (type gcontext gcontext)
  182.        (type int16 x y)
  183.        (type card16 width height)
  184.        (type boolean fill-p))
  185.   (let ((display (drawable-display drawable))
  186.     (request (if fill-p *x-polyfillrectangle* *x-polyrectangle*)))
  187.     (declare (type display display)
  188.          (type card16 request))
  189.     (with-display (display)
  190.       (force-gcontext-changes-internal gcontext)
  191.       (with-buffer-output (display :length *requestsize*)
  192.     (let* ((last-request-byte (display-last-request display))
  193.            (current-boffset buffer-boffset))
  194.       ;; To append or not append, that is the question
  195.       (if (and (not *inhibit-appending*)
  196.            last-request-byte
  197.            ;; Same request?
  198.            (= (aref-card8 buffer-bbuf last-request-byte) request)
  199.            (progn ;; Set buffer pointers to last request
  200.              (set-buffer-offset last-request-byte)
  201.              ;; same drawable and gcontext?
  202.              (or (compare-request (4)
  203.                (drawable drawable)
  204.                (gcontext gcontext))
  205.              (progn ;; If failed, reset buffer pointers
  206.                (set-buffer-offset current-boffset)
  207.                nil))))
  208.           ;; Append request
  209.           (progn
  210.         ;; Set new request length
  211.         (card16-put 2 (index+ 2 (index-ash (index- current-boffset last-request-byte)
  212.                            -2)))
  213.         (set-buffer-offset current-boffset)
  214.         (put-items (0)            ; Insert new point
  215.           (int16 x y)
  216.           (card16 width height))
  217.         (setf (display-boffset display) (index+ buffer-boffset 8)))
  218.         ;; New Request
  219.         (progn
  220.           (put-items (4)
  221.         (code request)
  222.         (length 5)
  223.         (drawable drawable)
  224.         (gcontext gcontext)
  225.         (int16 x y)
  226.         (card16 width height))
  227.           (buffer-new-request-number display)
  228.           (setf (buffer-last-request display) buffer-boffset)
  229.           (setf (display-boffset display) (index+ buffer-boffset 20)))))))
  230.     (display-invoke-after-function display))) 
  231.  
  232. (defun draw-rectangles (drawable gcontext rectangles &optional fill-p)
  233.   (declare (type drawable drawable)
  234.        (type gcontext gcontext)
  235.        ;; (repeat-seq (integer x) (integer y) (integer width) (integer height)))
  236.        (type sequence rectangles)
  237.        (type boolean fill-p))
  238.   (with-buffer-request ((drawable-display drawable)
  239.             (if fill-p *x-polyfillrectangle* *x-polyrectangle*)
  240.             :gc-force gcontext)
  241.     (drawable drawable)
  242.     (gcontext gcontext)
  243.     ((sequence :format int16) rectangles)))
  244.  
  245. (defun draw-arc (drawable gcontext x y width height angle1 angle2 &optional fill-p)
  246.   ;; Should be clever about appending to existing buffered protocol request.
  247.   (declare (type drawable drawable)
  248.        (type gcontext gcontext)
  249.        (type int16 x y)
  250.        (type card16 width height)
  251.        (type angle angle1 angle2)
  252.        (type boolean fill-p))
  253.   (let ((display (drawable-display drawable))
  254.     (request (if fill-p *x-polyfillarc* *x-polyarc*)))
  255.     (declare (type display display)
  256.          (type card16 request))
  257.     (with-display (display)
  258.       (force-gcontext-changes-internal gcontext)
  259.       (with-buffer-output (display :length *requestsize*)
  260.     (let* ((last-request-byte (display-last-request display))
  261.            (current-boffset buffer-boffset))
  262.       ;; To append or not append, that is the question
  263.       (if (and (not *inhibit-appending*)
  264.            last-request-byte
  265.            ;; Same request?
  266.            (= (aref-card8 buffer-bbuf last-request-byte) request)
  267.            (progn ;; Set buffer pointers to last request
  268.              (set-buffer-offset last-request-byte)
  269.              ;; same drawable and gcontext?
  270.              (or (compare-request (4)
  271.                (drawable drawable)
  272.                (gcontext gcontext))
  273.              (progn ;; If failed, reset buffer pointers
  274.                (set-buffer-offset current-boffset)
  275.                nil))))
  276.           ;; Append request
  277.           (progn
  278.         ;; Set new request length        
  279.         (card16-put 2 (index+ 3 (index-ash (index- current-boffset last-request-byte)
  280.                            -2)))
  281.         (set-buffer-offset current-boffset)
  282.         (put-items (0)            ; Insert new point
  283.           (int16 x y)
  284.           (card16 width height)
  285.           (angle angle1 angle2))
  286.         (setf (display-boffset display) (index+ buffer-boffset 12)))
  287.         ;; New Request
  288.         (progn
  289.           (put-items (4)
  290.         (code request)
  291.         (length 6)
  292.         (drawable drawable)
  293.         (gcontext gcontext)
  294.         (int16 x y)
  295.         (card16 width height)
  296.         (angle angle1 angle2))
  297.           (buffer-new-request-number display)
  298.           (setf (buffer-last-request display) buffer-boffset)
  299.           (setf (display-boffset display) (index+ buffer-boffset 24)))))))
  300.     (display-invoke-after-function display))) 
  301.  
  302. (defun draw-arcs-list (drawable gcontext arcs &optional fill-p)
  303.   (declare (type drawable drawable)
  304.        (type gcontext gcontext)
  305.        (type list arcs) 
  306.        (type boolean fill-p))
  307.   (let* ((display (drawable-display drawable))
  308.      (limit (index- (buffer-size display) 12))
  309.      (length (length arcs))
  310.      (request (if fill-p *x-polyfillarc* *x-polyarc*)))
  311.     (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
  312.       (drawable drawable)
  313.       (gcontext gcontext)
  314.       (progn
  315.     (card16-put 2 (index+ (index-ash length -1) 3))    ; Set request length (in words)
  316.     (set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
  317.     (do ((arc arcs))
  318.         ((endp arc)
  319.          (setf (buffer-boffset display) buffer-boffset))
  320.       ;; Make sure there's room
  321.       (when (index>= buffer-boffset limit)
  322.         (setf (buffer-boffset display) buffer-boffset)
  323.         (buffer-flush display)
  324.         (set-buffer-offset (buffer-boffset display)))
  325.       (int16-put  0 (pop arc))
  326.       (int16-put  2 (pop arc))
  327.       (card16-put 4 (pop arc))
  328.       (card16-put 6 (pop arc))
  329.       (angle-put  8 (pop arc))
  330.       (angle-put 10 (pop arc))
  331.       (set-buffer-offset (index+ buffer-boffset 12)))))))
  332.  
  333. (defun draw-arcs-vector (drawable gcontext arcs &optional fill-p)
  334.   (declare (type drawable drawable)
  335.        (type gcontext gcontext)
  336.        (type vector arcs) 
  337.        (type boolean fill-p))
  338.   (let* ((display (drawable-display drawable))
  339.      (limit (index- (buffer-size display) 12))
  340.      (length (length arcs))
  341.      (request (if fill-p *x-polyfillarc* *x-polyarc*)))
  342.     (with-buffer-request ((drawable-display drawable) request :gc-force gcontext)
  343.       (drawable drawable)
  344.       (gcontext gcontext)
  345.       (progn
  346.     (card16-put 2 (index+ (index-ash length -1) 3))    ; Set request length (in words)
  347.     (set-buffer-offset (index+ buffer-boffset 12))  ; Position to start of data
  348.     (do ((n 0 (index+ n 6))
  349.          (length (length arcs)))
  350.         ((index>= n length)
  351.          (setf (buffer-boffset display) buffer-boffset))
  352.       ;; Make sure there's room
  353.       (when (index>= buffer-boffset limit)
  354.         (setf (buffer-boffset display) buffer-boffset)
  355.         (buffer-flush display)
  356.         (set-buffer-offset (buffer-boffset display)))
  357.       (int16-put  0 (aref arcs (index+ n 0)))
  358.       (int16-put  2 (aref arcs (index+ n 1)))
  359.       (card16-put 4 (aref arcs (index+ n 2)))
  360.       (card16-put 6 (aref arcs (index+ n 3)))
  361.       (angle-put  8 (aref arcs (index+ n 4)))
  362.       (angle-put 10 (aref arcs (index+ n 5)))
  363.       (set-buffer-offset (index+ buffer-boffset 12)))))))
  364.  
  365. (defun draw-arcs (drawable gcontext arcs &optional fill-p)
  366.   (declare (type drawable drawable)
  367.        (type gcontext gcontext)
  368.        (type sequence arcs) 
  369.        (type boolean fill-p))
  370.   (etypecase arcs
  371.     (list (draw-arcs-list drawable gcontext arcs fill-p))
  372.     (vector (draw-arcs-vector drawable gcontext arcs fill-p))))
  373.  
  374. ;; The following image routines are bare minimum.  It may be useful to define
  375. ;; some form of "image" object to hide representation details and format
  376. ;; conversions.  It also may be useful to provide stream-oriented interfaces
  377. ;; for reading and writing the data.
  378.  
  379. (defun put-raw-image (drawable gcontext data &key
  380.               (start 0)
  381.               (depth (required-arg depth))
  382.               (x (required-arg x))
  383.               (y (required-arg y))
  384.               (width (required-arg width))
  385.               (height (required-arg height))
  386.               (left-pad 0)
  387.               (format (required-arg format)))
  388.   ;; Data must be a sequence of 8-bit quantities, already in the appropriate format
  389.   ;; for transmission; the caller is responsible for all byte and bit swapping and
  390.   ;; compaction.  Start is the starting index in data; the end is computed from the
  391.   ;; other arguments.
  392.   (declare (type drawable drawable)
  393.        (type gcontext gcontext)
  394.        (type sequence data) ; Sequence of integers
  395.        (type array-index start)
  396.        (type card8 depth left-pad) ;; required
  397.        (type int16 x y) ;; required
  398.        (type card16 width height) ;; required
  399.        (type (member :bitmap :xy-pixmap :z-pixmap) format))
  400.   (with-buffer-request ((drawable-display drawable) *x-putimage* :gc-force gcontext)
  401.     ((data (member :bitmap :xy-pixmap :z-pixmap)) format)
  402.     (drawable drawable)
  403.     (gcontext gcontext)
  404.     (card16 width height)
  405.     (int16 x y)
  406.     (card8 left-pad depth)
  407.     (pad16 nil)
  408.     ((sequence :format card8 :start start) data)))
  409.  
  410. (defun get-raw-image (drawable &key
  411.               data
  412.               (start 0)
  413.               (x (required-arg x))
  414.               (y (required-arg y))
  415.               (width (required-arg width))
  416.               (height (required-arg height))
  417.               (plane-mask #xffffffff)
  418.               (format (required-arg format))
  419.               (result-type '(vector card8)))
  420.   ;; If data is given, it is modified in place (and returned), otherwise a new sequence
  421.   ;; is created and returned, with a size computed from the other arguments and the
  422.   ;; returned depth.  The sequence is filled with 8-bit quantities, in transmission
  423.   ;; format; the caller is responsible for any byte and bit swapping and compaction
  424.   ;; required for further local use.
  425.   (declare (type drawable drawable)
  426.        (type (or null sequence) data) ;; sequence of integers
  427.        (type int16 x y) ;; required
  428.        (type card16 width height) ;; required
  429.        (type array-index start)
  430.        (type pixel plane-mask)
  431.        (type (member :xy-pixmap :z-pixmap) format))
  432.   (declare (values (sequence integer) depth visual-info))
  433.   (let ((display (drawable-display drawable)))
  434.     (with-buffer-request-and-reply (display *x-getimage* nil :sizes (8 32))
  435.      (((data (member error :xy-pixmap :z-pixmap)) format)
  436.       (drawable drawable)
  437.       (int16 x y)
  438.       (card16 width height)
  439.       (card32 plane-mask))
  440.       (let ((depth (card8-get 1))
  441.         (length (* 4 (card32-get 4)))
  442.         (visual (resource-id-get 8)))
  443.     (values (sequence-get :result-type result-type :format card8
  444.                   :length length :start start :data data
  445.                   :index *replysize*)
  446.         depth
  447.         (visual-info display visual))))))
  448.