home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / x11graph.scm < prev    next >
Text File  |  2001-02-10  |  34KB  |  1,001 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: x11graph.scm,v 1.51 2001/02/11 00:09:07 cph Exp $
  4.  
  5. Copyright (c) 1989-2001 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; X Graphics Interface
  23. ;;; package: (runtime x-graphics)
  24.  
  25. (declare (usual-integrations))
  26. (declare (integrate-external "graphics"))
  27.  
  28. (define-primitives
  29.   (x-close-all-displays 0)
  30.   (x-display-descriptor 1)
  31.   (x-display-get-default 3)
  32.   (x-display-process-events 2)
  33.   (x-font-structure 2)
  34.   (x-window-beep 1)
  35.   (x-window-clear 1)
  36.   (x-window-colormap 1)
  37.   (x-window-depth 1)
  38.   (x-window-event-mask 1)
  39.   (x-window-flush 1)
  40.   (x-window-iconify 1)
  41.   (x-window-id 1)
  42.   (x-window-lower 1)
  43.   (x-window-map 1)
  44.   (x-window-query-pointer 1)
  45.   (x-window-raise 1)
  46.   (x-window-set-background-color 2)
  47.   (x-window-set-border-color 2)
  48.   (x-window-set-border-width 2)
  49.   (x-window-set-cursor-color 2)
  50.   (x-window-set-event-mask 2)
  51.   (x-window-set-font 2)
  52.   (x-window-set-foreground-color 2)
  53.   (x-window-set-icon-name 2)
  54.   (x-window-set-input-hint 2)
  55.   (x-window-set-internal-border-width 2)
  56.   (x-window-set-mouse-color 2)
  57.   (x-window-set-mouse-shape 2)
  58.   (x-window-set-name 2)
  59.   (x-window-set-position 3)
  60.   (x-window-set-size 3)
  61.   (x-window-starbase-filename 1)
  62.   (x-window-visual 1)
  63.   (x-window-withdraw 1)
  64.   (x-window-x-size 1)
  65.   (x-window-y-size 1)
  66.   (x-graphics-copy-area 8)
  67.   (x-graphics-drag-cursor 3)
  68.   (x-graphics-draw-arc 8)
  69.   (x-graphics-draw-line 5)
  70.   (x-graphics-draw-lines 3)
  71.   (x-graphics-draw-point 3)
  72.   (x-graphics-draw-points 3)
  73.   (x-graphics-draw-string 4)
  74.   (x-graphics-draw-image-string 4)
  75.   (x-graphics-fill-polygon 2)
  76.   (x-graphics-map-x-coordinate 2)
  77.   (x-graphics-map-y-coordinate 2)
  78.   (x-graphics-move-cursor 3)
  79.   (x-graphics-open-window 3)
  80.   (x-graphics-reconfigure 3)
  81.   (x-graphics-reset-clip-rectangle 1)
  82.   (x-graphics-set-clip-rectangle 5)
  83.   (x-graphics-set-dashes 3)
  84.   (x-graphics-set-fill-style 2)
  85.   (x-graphics-set-function 2)
  86.   (x-graphics-set-line-style 2)
  87.   (x-graphics-set-vdc-extent 5)
  88.   (x-graphics-vdc-extent 1)
  89.   (x-bytes-into-image 2)
  90.   (x-create-image 3)
  91.   (x-destroy-image 1)
  92.   (x-display-image 8)
  93.   (x-get-pixel-from-image 3)
  94.   (x-set-pixel-in-image 4)
  95.   (x-allocate-color 4)
  96.   (x-create-colormap 3)
  97.   (x-free-colormap 1)
  98.   (x-query-color 2)
  99.   (x-set-window-colormap 2)
  100.   (x-store-color 5)
  101.   (x-store-colors 2)
  102.   (x-visual-deallocate 1))
  103.  
  104. ;; These constants must match "microcode/x11base.c"
  105. (define-integrable event-type:button-down 0)
  106. (define-integrable event-type:button-up 1)
  107. (define-integrable event-type:configure 2)
  108. (define-integrable event-type:enter 3)
  109. (define-integrable event-type:focus-in 4)
  110. (define-integrable event-type:focus-out 5)
  111. (define-integrable event-type:key-press 6)
  112. (define-integrable event-type:leave 7)
  113. (define-integrable event-type:motion 8)
  114. (define-integrable event-type:expose 9)
  115. (define-integrable event-type:delete-window 10)
  116. (define-integrable event-type:map 11)
  117. (define-integrable event-type:unmap 12)
  118. (define-integrable event-type:take-focus 13)
  119. (define-integrable event-type:visibility 14)
  120. (define-integrable number-of-event-types 15)
  121.  
  122. ;; This mask contains button-down, button-up,configure, enter,
  123. ;; focus-in, focus-out, key-press, leave, motion, delete-window, map,
  124. ;; unmap, and visibility.
  125. (define-integrable event-mask:normal #x5dff)
  126.  
  127. ;; This mask additionally contains take-focus.
  128. (define-integrable event-mask:ignore-focus #x7dff)
  129.  
  130. ;; This mask contains button-down.
  131. (define-integrable user-event-mask:default #x0001)
  132.  
  133. ;;;; X graphics device
  134.  
  135. (define (initialize-package!)
  136.   (set! x-graphics-device-type
  137.     (make-graphics-device-type
  138.      'X
  139.      `((available? ,x-graphics/available?)
  140.        (clear ,x-graphics/clear)
  141.        (close ,x-graphics/close-window)
  142.        (color? ,x-graphics/color?)
  143.        (coordinate-limits ,x-graphics/coordinate-limits)
  144.        (copy-area ,x-graphics/copy-area)
  145.        (create-colormap ,create-x-colormap)
  146.        (create-image ,x-graphics/create-image)
  147.        (device-coordinate-limits ,x-graphics/device-coordinate-limits)
  148.        (drag-cursor ,x-graphics/drag-cursor)
  149.        (draw-arc ,x-graphics/draw-arc)
  150.        (draw-circle ,x-graphics/draw-circle)
  151.        (draw-image ,image/draw)
  152.        (draw-line ,x-graphics/draw-line)
  153.        (draw-lines ,x-graphics/draw-lines)
  154.        (draw-point ,x-graphics/draw-point)
  155.        (draw-points ,x-graphics/draw-points)
  156.        (draw-subimage ,image/draw-subimage)
  157.        (draw-text ,x-graphics/draw-text)
  158.        (draw-text-opaque ,x-graphics/draw-text-opaque)
  159.        (fill-circle ,x-graphics/fill-circle)
  160.        (fill-polygon ,x-graphics/fill-polygon)
  161.        (flush ,x-graphics/flush)
  162.        (font-structure ,x-graphics/font-structure)
  163.        (get-colormap ,x-graphics/get-colormap)
  164.        (get-default ,x-graphics/get-default)
  165.        (iconify-window ,x-graphics/iconify-window)
  166.        (image-depth ,x-graphics/image-depth)
  167.        (lower-window ,x-graphics/lower-window)
  168.        (map-window ,x-graphics/map-window)
  169.        (move-cursor ,x-graphics/move-cursor)
  170.        (move-window ,x-graphics/move-window)
  171.        (open ,x-graphics/open)
  172.        (query-pointer ,x-graphics/query-pointer)
  173.        (raise-window ,x-graphics/raise-window)
  174.        (reset-clip-rectangle ,x-graphics/reset-clip-rectangle)
  175.        (resize-window ,x-graphics/resize-window)
  176.        (set-background-color ,x-graphics/set-background-color)
  177.        (set-border-color ,x-graphics/set-border-color)
  178.        (set-border-width ,x-graphics/set-border-width)
  179.        (set-clip-rectangle ,x-graphics/set-clip-rectangle)
  180.        (set-colormap ,x-graphics/set-colormap)
  181.        (set-coordinate-limits ,x-graphics/set-coordinate-limits)
  182.        (set-drawing-mode ,x-graphics/set-drawing-mode)
  183.        (set-font ,x-graphics/set-font)
  184.        (set-foreground-color ,x-graphics/set-foreground-color)
  185.        (set-icon-name ,x-graphics/set-icon-name)
  186.        (set-input-hint ,x-graphics/set-input-hint)
  187.        (set-internal-border-width ,x-graphics/set-internal-border-width)
  188.        (set-line-style ,x-graphics/set-line-style)
  189.        (set-mouse-color ,x-graphics/set-mouse-color)
  190.        (set-mouse-shape ,x-graphics/set-mouse-shape)
  191.        (set-window-name ,x-graphics/set-window-name)
  192.        (starbase-filename ,x-graphics/starbase-filename)
  193.        (visual-info ,x-graphics/visual-info)
  194.        (withdraw-window ,x-graphics/withdraw-window))))
  195.   (set! display-finalizer
  196.     (make-gc-finalizer (ucode-primitive x-close-display 1)))
  197.   (initialize-image-datatype)
  198.   (initialize-colormap-datatype))
  199.  
  200. (define (x-graphics/available?)
  201.   (implemented-primitive-procedure? x-graphics-open-window))
  202.  
  203. (define x-graphics-device-type)
  204.  
  205. ;;;; Open/Close Displays
  206.  
  207. (define display-finalizer)
  208.  
  209. (define-structure (x-display
  210.            (conc-name x-display/)
  211.            (constructor make-x-display (name xd))
  212.            (print-procedure
  213.             (standard-unparser-method 'X-DISPLAY
  214.               (lambda (display port)
  215.             (write-char #\space port)
  216.             (write (x-display/name display) port)))))
  217.   (name #f read-only #t)
  218.   xd
  219.   (window-finalizer (make-gc-finalizer (ucode-primitive x-close-window 1))
  220.             read-only #t)
  221.   (event-queue (make-queue))
  222.   (properties (make-1d-table) read-only #t))
  223.  
  224. (define (x-graphics/open-display name)
  225.   (let ((name
  226.      (cond ((not name)
  227.         (or x-graphics-default-display-name
  228.             (let ((name (get-environment-variable "DISPLAY")))
  229.               (if (not name)
  230.               (error "No DISPLAY environment variable."))
  231.               name)))
  232.            ((string? name)
  233.         name)
  234.            (else
  235.         (error:wrong-type-argument name
  236.                        "string or #f"
  237.                        x-graphics/open-display)))))
  238.     (or (search-gc-finalizer display-finalizer
  239.       (lambda (display)
  240.         (string=? (x-display/name display) name)))
  241.     (let ((xd ((ucode-primitive x-open-display 1) name)))
  242.       (if (not xd)
  243.           (error "Unable to open display:" name))
  244.       (let ((display (make-x-display name xd)))
  245.         (add-to-gc-finalizer! display-finalizer display xd)
  246.         (make-event-previewer display)
  247.         display)))))
  248.  
  249. (define (x-graphics/close-display display)
  250.   (without-interrupts
  251.    (lambda ()
  252.      (if (x-display/xd display)
  253.      (begin
  254.        (remove-all-from-gc-finalizer! (x-display/window-finalizer display))
  255.        (remove-from-gc-finalizer! display-finalizer display)
  256.        (set-x-display/xd! display #f))))))
  257.  
  258. (define (make-event-previewer display)
  259.   (let ((registration))
  260.     (set! registration
  261.       (permanently-register-input-thread-event
  262.        (x-display-descriptor (x-display/xd display))
  263.        (current-thread)
  264.        (lambda ()
  265.          (call-with-current-continuation
  266.           (lambda (continuation)
  267.         (bind-condition-handler
  268.             (list condition-type:bad-range-argument
  269.               condition-type:wrong-type-argument)
  270.             (lambda (condition)
  271.               ;; If X-DISPLAY-PROCESS-EVENTS or
  272.               ;; X-DISPLAY-DESCRIPTOR signals an argument error
  273.               ;; on its display argument, that means the
  274.               ;; display has been closed.
  275.               condition
  276.               (deregister-input-thread-event registration)
  277.               (continuation unspecific))
  278.           (lambda ()
  279.             (let ((event
  280.                (x-display-process-events (x-display/xd display)
  281.                              2)))
  282.               (if event
  283.               (process-event display event))))))))))
  284.     registration))
  285.  
  286. (define (read-event display)
  287.   (letrec ((loop
  288.         (let ((queue (x-display/event-queue display)))
  289.           (lambda ()
  290.         (if (queue-empty? queue)
  291.             (begin
  292.               (%read-and-process-event display)
  293.               (loop))
  294.             (dequeue! queue))))))
  295.     (with-thread-events-blocked loop)))
  296.  
  297. (define (%read-and-process-event display)
  298.   (let ((event
  299.      (and (eq? 'INPUT-AVAILABLE
  300.            (test-for-input-on-descriptor
  301.             (x-display-descriptor (x-display/xd display))
  302.             #t))
  303.           (x-display-process-events (x-display/xd display) 1))))
  304.     (if event
  305.     (process-event display event))))
  306.  
  307. (define (discard-events display)
  308.   (letrec ((loop
  309.         (let ((queue (x-display/event-queue display)))
  310.           (lambda ()
  311.         (cond ((not (queue-empty? queue))
  312.                (dequeue! queue)
  313.                (loop))
  314.               ((x-display-process-events (x-display/xd display) 2)
  315.                =>
  316.                (lambda (event)
  317.              (process-event display event)
  318.              (loop))))))))
  319.     (with-thread-events-blocked loop)))
  320.  
  321. (define (process-event display event)
  322.   (without-interrupts
  323.    (lambda ()
  324.      (let ((window
  325.         (search-gc-finalizer (x-display/window-finalizer display)
  326.           (let ((xw (vector-ref event 1)))
  327.         (lambda (window)
  328.           (eq? (x-window/xw window) xw))))))
  329.        (if window
  330.        (let ((type (vector-ref event 0)))
  331.          (let ((handler (vector-ref event-handlers type)))
  332.            (if handler
  333.            (handler window event)))
  334.          (if (or (fix:= event-type:delete-window type)
  335.              (not (fix:= 0
  336.                  (fix:and (fix:lsh 1 type)
  337.                       (x-window/user-event-mask window)))))
  338.          (begin
  339.            ;; This would prefer to be the graphics device, but
  340.            ;; that's not available from here.
  341.            (vector-set! event 1 window)
  342.            (enqueue!/unsafe (x-display/event-queue display)
  343.                     event)))))))))
  344.  
  345. (define event-handlers
  346.   (make-vector number-of-event-types #f))
  347.  
  348. (define-integrable (define-event-handler event-type handler)
  349.   (vector-set! event-handlers event-type handler))
  350.  
  351. (define-event-handler event-type:configure
  352.   (lambda (window event)
  353.     window
  354.     (x-graphics-reconfigure (vector-ref event 1)
  355.                 (vector-ref event 2)
  356.                 (vector-ref event 3))
  357.     (if (eq? 'NEVER (x-window/mapped? window))
  358.     (set-x-window/mapped?! window #t))))
  359.  
  360. (define-event-handler event-type:delete-window
  361.   (lambda (window event)
  362.     event
  363.     (close-x-window window)))
  364.  
  365. (define-event-handler event-type:map
  366.   (lambda (window event)
  367.     event
  368.     (set-x-window/mapped?! window #t)))
  369.  
  370. (define-event-handler event-type:unmap
  371.   (lambda (window event)
  372.     event
  373.     (set-x-window/mapped?! window #f)))
  374.  
  375. (define-event-handler event-type:visibility
  376.   (lambda (window event)
  377.     (case (vector-ref event 2)
  378.       ((0) (set-x-window/visibility! window 'UNOBSCURED))
  379.       ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED))
  380.       ((2) (set-x-window/visibility! window 'OBSCURED)))))
  381.  
  382. (let ((mouse-event-handler
  383.        (lambda (window event)
  384.      window
  385.      (let ((xw (vector-ref event 1)))
  386.        (vector-set! event 2
  387.             (x-graphics-map-x-coordinate xw
  388.                              (vector-ref event 2)))
  389.        (vector-set! event 3
  390.             (x-graphics-map-y-coordinate xw
  391.                              (vector-ref event 3)))))))
  392.   ;; ENTER and LEAVE events should be modified to have X,Y coordinates.
  393.   (define-event-handler event-type:button-down mouse-event-handler)
  394.   (define-event-handler event-type:button-up mouse-event-handler)
  395.   (define-event-handler event-type:motion mouse-event-handler))
  396.  
  397. ;;;; Standard Operations
  398.  
  399. (define x-graphics:auto-raise? #f)
  400.  
  401. (define-structure (x-window (conc-name x-window/)
  402.                 (constructor make-x-window (xw display)))
  403.   xw
  404.   (display #f read-only #t)
  405.   (mapped? 'NEVER)
  406.   (visibility #f)
  407.   (user-event-mask user-event-mask:default))
  408.  
  409. (define-integrable (x-graphics-device/xw device)
  410.   (x-window/xw (graphics-device/descriptor device)))
  411.  
  412. (define (x-graphics/display device)
  413.   (x-window/display (graphics-device/descriptor device)))
  414.  
  415. (define-integrable (x-graphics-device/xd device)
  416.   (x-display/xd (x-window/display (graphics-device/descriptor device))))
  417.  
  418. (define-integrable (x-graphics-device/mapped? device)
  419.   (eq? #t (x-window/mapped? (graphics-device/descriptor device))))
  420.  
  421. (define-integrable (x-graphics-device/visibility device)
  422.   (x-window/visibility (graphics-device/descriptor device)))
  423.  
  424. (define (x-graphics/close-window device)
  425.   (without-interrupts
  426.    (lambda ()
  427.      (close-x-window (graphics-device/descriptor device)))))
  428.  
  429. (define (close-x-window window)
  430.   (if (x-window/xw window)
  431.       (begin
  432.     (remove-from-gc-finalizer!
  433.      (x-display/window-finalizer (x-window/display window))
  434.      window)
  435.     (set-x-window/xw! window #f))))
  436.  
  437. (define (x-geometry-string x y width height)
  438.   (string-append (if (and width height)
  439.              (string-append (number->string width)
  440.                     "x"
  441.                     (number->string height))
  442.              "")
  443.          (if (and x y)
  444.              (string-append (if (negative? x) "" "+")
  445.                     (number->string x)
  446.                     (if (negative? y) "" "+")
  447.                     (number->string y))
  448.              "")))
  449.  
  450. (define x-graphics-default-geometry "512x512")
  451. (define x-graphics-default-display-name #f)
  452.  
  453. (define (x-graphics/open descriptor->device
  454.              #!optional display geometry suppress-map?)
  455.   (let ((display
  456.      (let ((display
  457.         (and (not (default-object? display))
  458.              display)))
  459.        (if (x-display? display)
  460.            display
  461.            (x-graphics/open-display display)))))
  462.     (call-with-values
  463.     (lambda ()
  464.       (decode-suppress-map-arg (and (not (default-object? suppress-map?))
  465.                     suppress-map?)
  466.                    'MAKE-GRAPHICS-DEVICE))
  467.       (lambda (map? resource class)
  468.     (let ((xw
  469.            (x-graphics-open-window
  470.          (x-display/xd display)
  471.          (if (default-object? geometry) 
  472.              x-graphics-default-geometry
  473.              geometry)
  474.          (vector #f resource class))))
  475.       (x-window-set-event-mask xw event-mask:normal)
  476.       (let ((window (make-x-window xw display)))
  477.         (add-to-gc-finalizer! (x-display/window-finalizer display)
  478.                   window xw)
  479.         (if map? (map-window window))
  480.         (descriptor->device window)))))))
  481.  
  482. (define (map-window window)
  483.   (let ((xw (x-window/xw window)))
  484.     (x-window-map xw)
  485.     ;; If this is the first time that this window has been mapped, we
  486.     ;; need to wait for a MAP event before continuing.
  487.     (if (not (boolean? (x-window/mapped? window)))
  488.     (begin
  489.       (x-window-flush xw)
  490.       (letrec ((loop
  491.             (let ((display (x-window/display window)))
  492.               (lambda ()
  493.             (if (not (eq? #t (x-window/mapped? window)))
  494.                 (begin
  495.                   (%read-and-process-event display)
  496.                   (loop)))))))
  497.         (with-thread-events-blocked loop))))))
  498.  
  499. (define (decode-suppress-map-arg suppress-map? procedure)
  500.   (cond ((boolean? suppress-map?)
  501.      (values (not suppress-map?) "schemeGraphics" "SchemeGraphics"))
  502.     ((and (pair? suppress-map?)
  503.           (string? (car suppress-map?))
  504.           (string? (cdr suppress-map?)))
  505.      (values #f (car suppress-map?) (cdr suppress-map?)))
  506.     ((and (vector? suppress-map?)
  507.           (fix:= (vector-length suppress-map?) 3)
  508.           (boolean? (vector-ref suppress-map? 0))
  509.           (string? (vector-ref suppress-map? 1))
  510.           (string? (vector-ref suppress-map? 2)))
  511.      (values (vector-ref suppress-map? 0)
  512.          (vector-ref suppress-map? 1)
  513.          (vector-ref suppress-map? 2)))
  514.     (else
  515.      (error:wrong-type-argument suppress-map?
  516.                     "X suppress-map arg"
  517.                     procedure))))
  518.  
  519. (define (x-graphics/clear device)
  520.   (x-window-clear (x-graphics-device/xw device)))
  521.  
  522. (define (x-graphics/coordinate-limits device)
  523.   (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device))))
  524.     (values (vector-ref limits 0) (vector-ref limits 1)
  525.         (vector-ref limits 2) (vector-ref limits 3))))
  526.  
  527. (define (x-graphics/device-coordinate-limits device)
  528.   (let ((xw (x-graphics-device/xw device)))
  529.     (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0)))
  530.  
  531. (define (x-graphics/drag-cursor device x y)
  532.   (x-graphics-drag-cursor (x-graphics-device/xw device)
  533.               (->flonum x)
  534.               (->flonum y)))
  535.  
  536. (define (x-graphics/draw-line device x-start y-start x-end y-end)
  537.   (x-graphics-draw-line (x-graphics-device/xw device)
  538.             (->flonum x-start)
  539.             (->flonum y-start)
  540.             (->flonum x-end)
  541.             (->flonum y-end)))
  542.  
  543. (define (x-graphics/draw-lines device xv yv)
  544.   (x-graphics-draw-lines (x-graphics-device/xw device) xv yv))
  545.  
  546. (define (x-graphics/draw-point device x y)
  547.   (x-graphics-draw-point (x-graphics-device/xw device)
  548.              (->flonum x)
  549.              (->flonum y)))
  550.  
  551. (define (x-graphics/draw-points device xv yv)
  552.   (x-graphics-draw-points (x-graphics-device/xw device) xv yv))
  553.  
  554. (define (x-graphics/draw-text device x y string)
  555.   (x-graphics-draw-string (x-graphics-device/xw device)
  556.               (->flonum x)
  557.               (->flonum y)
  558.               string))
  559.  
  560. (define (x-graphics/draw-text-opaque device x y string)
  561.   (x-graphics-draw-image-string (x-graphics-device/xw device)
  562.                 (->flonum x)
  563.                 (->flonum y)
  564.                 string))
  565.  
  566. (define (x-graphics/flush device)
  567.   (if (and x-graphics:auto-raise?
  568.        (x-graphics-device/mapped? device)
  569.        (not (eq? 'UNOBSCURED (x-graphics-device/visibility device))))
  570.       (x-graphics/raise-window device))
  571.   ((ucode-primitive x-display-flush 1) (x-graphics-device/xd device)))
  572.  
  573. (define (x-graphics/move-cursor device x y)
  574.   (x-graphics-move-cursor (x-graphics-device/xw device)
  575.               (->flonum x)
  576.               (->flonum y)))
  577.  
  578. (define (x-graphics/reset-clip-rectangle device)
  579.   (x-graphics-reset-clip-rectangle (x-graphics-device/xw device)))
  580.  
  581. (define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
  582.   (x-graphics-set-clip-rectangle (x-graphics-device/xw device)
  583.                  (->flonum x-left)
  584.                  (->flonum y-bottom)
  585.                  (->flonum x-right)
  586.                  (->flonum y-top)))
  587.  
  588. (define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
  589.   (x-graphics-set-vdc-extent (x-graphics-device/xw device)
  590.                  (->flonum x-left)
  591.                  (->flonum y-bottom)
  592.                  (->flonum x-right)
  593.                  (->flonum y-top)))
  594.  
  595. (define (x-graphics/set-drawing-mode device mode)
  596.   (x-graphics-set-function (x-graphics-device/xw device) mode))
  597.  
  598. (define (x-graphics/set-line-style device line-style)
  599.   (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
  600.       (error:wrong-type-argument line-style "graphics line style"
  601.                  'SET-LINE-STYLE))
  602.   (let ((xw (x-graphics-device/xw device)))
  603.     (if (zero? line-style)
  604.     (x-graphics-set-line-style xw 0)
  605.     (begin
  606.       (x-graphics-set-line-style xw 2)
  607.       (x-graphics-set-dashes xw
  608.                  0
  609.                  (vector-ref '#("\010\010"
  610.                         "\001\001"
  611.                         "\015\001\001\001"
  612.                         "\013\001\001\001\001\001"
  613.                         "\013\005"
  614.                         "\014\001\002\001"
  615.                         "\011\001\002\001\002\001")
  616.                          (- line-style 1)))))))
  617.  
  618. ;;;; Appearance Operations
  619.  
  620. (define (x-graphics/set-background-color device color)
  621.   (x-window-set-background-color (x-graphics-device/xw device) color))
  622.  
  623. (define (x-graphics/set-border-color device color)
  624.   (x-window-set-border-color (x-graphics-device/xw device) color))
  625.  
  626. (define (x-graphics/set-border-width device width)
  627.   (x-window-set-border-width (x-graphics-device/xw device) width))
  628.  
  629. (define (x-graphics/set-font device font)
  630.   (x-window-set-font (x-graphics-device/xw device) font))
  631.  
  632. (define (x-graphics/set-foreground-color device color)
  633.   (x-window-set-foreground-color (x-graphics-device/xw device) color))
  634.  
  635. (define (x-graphics/set-internal-border-width device width)
  636.   (x-window-set-internal-border-width (x-graphics-device/xw device) width))
  637.  
  638. (define (x-graphics/set-mouse-color device color)
  639.   (x-window-set-mouse-color (x-graphics-device/xw device) color))
  640.  
  641. (define (x-graphics/set-mouse-shape device shape)
  642.   (x-window-set-mouse-shape (x-graphics-device/xw device) shape))
  643.  
  644. ;;;; Miscellaneous Operations
  645.  
  646. (define (x-graphics/draw-arc device x y radius-x radius-y
  647.                  angle-start angle-sweep fill?)
  648.   (x-graphics-draw-arc (x-graphics-device/xw device)
  649.                (->flonum x)
  650.                (->flonum y)
  651.                (->flonum radius-x)
  652.                (->flonum radius-y)
  653.                (->flonum angle-start)
  654.                (->flonum angle-sweep)
  655.                fill?))
  656.    
  657. (define (x-graphics/draw-circle device x y radius)
  658.   (x-graphics-draw-arc (x-graphics-device/xw device)
  659.                (->flonum x)
  660.                (->flonum y)
  661.                (->flonum radius)
  662.                (->flonum radius)
  663.                0.
  664.                360.
  665.                #f))
  666.    
  667. (define (x-graphics/fill-circle device x y radius)
  668.   (x-graphics-draw-arc (x-graphics-device/xw device)
  669.                (->flonum x)
  670.                (->flonum y)
  671.                (->flonum radius)
  672.                (->flonum radius)
  673.                0.
  674.                360.
  675.                #t))
  676.    
  677. (define (x-graphics/fill-polygon device point-vector)
  678.   (x-graphics-fill-polygon (x-graphics-device/xw device)
  679.                (vector-map ->flonum point-vector)))
  680.    
  681. (define (x-graphics/copy-area device source-x-left source-y-top width height
  682.                   destination-x-left destination-y-top)
  683.   (let ((xw (x-graphics-device/xw device)))
  684.     (x-graphics-copy-area xw xw
  685.               (->flonum source-x-left)
  686.               (->flonum source-y-top)
  687.               (->flonum width)
  688.               (->flonum height)
  689.               (->flonum destination-x-left)
  690.               (->flonum destination-y-top))))
  691.  
  692. (define (x-graphics/get-default device resource-name class-name)
  693.   (x-display-get-default (x-graphics-device/xd device)
  694.              resource-name class-name))
  695.  
  696. (define (x-graphics/starbase-filename device)
  697.   (x-window-starbase-filename (x-graphics-device/xw device)))
  698.  
  699. (define (x-graphics/window-id device)
  700.   (x-window-id (x-graphics-device/xw device)))
  701.  
  702. ;;;; Event-Handling Operations
  703.  
  704. (define (x-graphics/set-input-hint device input?)
  705.   (x-window-set-input-hint (x-graphics-device/xw device) input?))
  706.  
  707. (define (x-graphics/disable-keyboard-focus device)
  708.   ;; Tell the window to participate in the TAKE-FOCUS protocol.  Since
  709.   ;; there is no handler for this event, focus will never be given to
  710.   ;; the window.
  711.   (x-window-set-event-mask (x-graphics-device/xw device)
  712.                event-mask:ignore-focus))
  713.  
  714. (define (x-graphics/enable-keyboard-focus device)
  715.   (x-window-set-event-mask (x-graphics-device/xw device) event-mask:normal))
  716.  
  717. (define (x-graphics/select-user-events device mask)
  718.   (set-x-window/user-event-mask! (graphics-device/descriptor device) mask))
  719.  
  720. (define (x-graphics/query-pointer device)
  721.   (let* ((window (x-graphics-device/xw device))
  722.      (result (x-window-query-pointer window)))
  723.     (values (x-graphics-map-x-coordinate window (vector-ref result 2))
  724.         (x-graphics-map-y-coordinate window (vector-ref result 3))
  725.         (vector-ref result 4))))
  726.  
  727. (define (x-graphics/read-button device)
  728.   (let ((event (read-event-of-type device event-type:button-down)))
  729.     (values (vector-ref event 2)
  730.         (vector-ref event 3)
  731.         (vector-ref event 4))))
  732.  
  733. (define (read-event-of-type device event-type)
  734.   (let ((window (graphics-device/descriptor device))
  735.     (display (x-graphics/display device)))
  736.   (let loop ()
  737.     (let ((event (read-event display)))
  738.       (if (eq? window (vector-ref event 1))
  739.       (begin
  740.         (if (fix:= (vector-ref event 0) event-type:delete-window)
  741.         (error "Window closed while waiting to read event."))
  742.         (if (fix:= (vector-ref event 0) event-type)
  743.         event
  744.         (loop)))
  745.       (loop))))))
  746.  
  747. (define (x-graphics/read-user-event device)
  748.   (read-event (x-graphics/display device)))
  749.  
  750. (define (x-graphics/discard-events device)
  751.   (discard-events (x-graphics/display device)))
  752.  
  753. ;;;; Font Operations
  754.  
  755. (define (x-graphics/font-structure device string)
  756.   (x-font-structure (x-graphics-device/xd device) string))
  757.  
  758. (define-structure (x-font-structure (conc-name x-font-structure/)
  759.                     (type vector))
  760.   (name #f read-only #t)
  761.   (direction #f read-only #t)
  762.   (all-chars-exist? #f read-only #t)
  763.   (default-char #f read-only #t)
  764.   (min-bounds #f read-only #t)
  765.   (max-bounds #f read-only #t)
  766.   (start-index #f read-only #t)
  767.   (character-bounds #f read-only #t)
  768.   (max-ascent #f read-only #t)
  769.   (max-descent #f read-only #t))
  770.  
  771. (define-structure (x-character-bounds (conc-name x-character-bounds/)
  772.                       (type vector))
  773.   (lbearing #f read-only #t)
  774.   (rbearing #f read-only #t)
  775.   (width #f read-only #t)
  776.   (ascent #f read-only #t)
  777.   (descent #f read-only #t))
  778.  
  779. ;;;; Window Management Operations
  780.  
  781. (define (x-graphics/map-window device)
  782.   (map-window (graphics-device/descriptor device)))
  783.  
  784. (define (x-graphics/withdraw-window device)
  785.   (x-window-withdraw (x-graphics-device/xw device)))
  786.  
  787. (define (x-graphics/iconify-window device)
  788.   (x-window-iconify (x-graphics-device/xw device)))
  789.  
  790. (define (x-graphics/raise-window device)
  791.   (x-window-raise (x-graphics-device/xw device)))
  792.  
  793. (define (x-graphics/lower-window device)
  794.   (x-window-lower (x-graphics-device/xw device)))
  795.  
  796. (define (x-graphics/set-icon-name device name)
  797.   (x-window-set-icon-name (x-graphics-device/xw device) name))
  798.  
  799. (define (x-graphics/set-window-name device name)
  800.   (x-window-set-name (x-graphics-device/xw device) name))
  801.  
  802. (define (x-graphics/move-window device x y)
  803.   (x-window-set-position (x-graphics-device/xw device) x y))
  804.  
  805. (define (x-graphics/resize-window device width height)
  806.   (x-window-set-size (x-graphics-device/xw device) width height))
  807.  
  808. ;;;; Images
  809.  
  810. ;; X-IMAGE is the descriptor of the generic images.
  811.  
  812. (define-structure (x-image (conc-name x-image/))
  813.   descriptor
  814.   window
  815.   width
  816.   height)
  817.  
  818. (define image-list)
  819.  
  820. (define (initialize-image-datatype)
  821.   (1d-table/put!
  822.    (graphics-type-properties x-graphics-device-type)
  823.    'IMAGE-TYPE
  824.    (make-image-type
  825.     `((create   ,create-x-image) ;;this one returns an IMAGE descriptor
  826.       (destroy  ,x-graphics-image/destroy)
  827.       (width    ,x-graphics-image/width)
  828.       (height   ,x-graphics-image/height)
  829.       (draw     ,x-graphics-image/draw)
  830.       (draw-subimage  ,x-graphics-image/draw-subimage)
  831.       (fill-from-byte-vector  ,x-graphics-image/fill-from-byte-vector))))
  832.   (set! image-list (make-gc-finalizer x-destroy-image))
  833.   unspecific)
  834.  
  835. (define (create-x-image device width height)
  836.   (let ((window (x-graphics-device/xw device)))
  837.     (let ((descriptor (x-create-image window width height)))
  838.       (let ((image (make-x-image descriptor window width height)))
  839.     (add-to-gc-finalizer! image-list image descriptor)
  840.     image))))
  841.  
  842. (define (x-image/destroy image)
  843.   (remove-from-gc-finalizer! image-list image))
  844.  
  845. (define (x-image/get-pixel image x y)
  846.   (x-get-pixel-from-image (x-image/descriptor image) x y))
  847.  
  848. (define (x-image/set-pixel image x y value)
  849.   (x-set-pixel-in-image (x-image/descriptor image) x y value))
  850.  
  851. (define (x-image/draw image window-x window-y)
  852.   (x-display-image (x-image/descriptor image)
  853.            0
  854.            0
  855.            (x-image/window image)
  856.            (->flonum window-x)
  857.            (->flonum window-y)
  858.            (x-image/width image)
  859.            (x-image/height image)))
  860.  
  861. (define (x-image/draw-subimage image x y width height window-x window-y)
  862.   (x-display-image (x-image/descriptor image)
  863.            x
  864.            y
  865.            (x-image/window image)
  866.            (->flonum window-x)
  867.            (->flonum window-y)
  868.            width
  869.            height))
  870.  
  871. (define (x-image/fill-from-byte-vector image byte-vector)
  872.   (x-bytes-into-image byte-vector (x-image/descriptor image)))
  873.  
  874. ;; Abstraction layer for generic images
  875.  
  876. (define (x-graphics/create-image device width height)
  877.   (image/create device width height))
  878.  
  879. ;;(define x-graphics-image/create create-x-image)
  880.  
  881. (define (x-graphics-image/destroy image)
  882.   (x-image/destroy (image/descriptor image)))
  883.  
  884. (define (x-graphics-image/width image)
  885.   (x-image/width (image/descriptor image)))
  886.  
  887. (define (x-graphics-image/height image)
  888.   (x-image/height (image/descriptor image)))
  889.  
  890. (define (x-graphics-image/draw device x y image)
  891.   (let* ((x-image (image/descriptor image))
  892.      (w (x-image/width x-image))
  893.      (h (x-image/height x-image)))
  894.     (x-display-image (x-image/descriptor x-image)
  895.              0
  896.              0
  897.              (x-graphics-device/xw device)
  898.              (->flonum x)
  899.              (->flonum y)
  900.              w
  901.              h)))
  902.  
  903. (define (x-graphics-image/draw-subimage device x y image im-x im-y w h)
  904.   (let ((x-image  (image/descriptor image)))
  905.     (x-display-image (x-image/descriptor x-image)
  906.              im-x
  907.              im-y
  908.              (x-graphics-device/xw device)
  909.              (->flonum x)
  910.              (->flonum y)
  911.              w
  912.              h)))
  913.  
  914. (define (x-graphics-image/fill-from-byte-vector image byte-vector)
  915.   (x-image/fill-from-byte-vector (image/descriptor image) byte-vector))
  916.  
  917. ;;;; Colormaps
  918.  
  919. (define x-colormap?)
  920. (define %make-colormap)
  921. (define colormap/descriptor)
  922. (define colormap-list)
  923.  
  924. (define (initialize-colormap-datatype)
  925.   (let ((rtd (make-record-type "colormap" '(DESCRIPTOR))))
  926.     (set! x-colormap? (record-predicate rtd))
  927.     (set! %make-colormap (record-constructor rtd))
  928.     (set! colormap/descriptor (record-accessor rtd 'DESCRIPTOR)))
  929.   (set! colormap-list (make-gc-finalizer x-free-colormap)))
  930.  
  931. (define (make-colormap descriptor)
  932.   (let ((colormap (%make-colormap descriptor)))
  933.     (add-to-gc-finalizer! colormap-list colormap descriptor)
  934.     colormap))
  935.  
  936. (define (x-graphics/get-colormap device)
  937.   (make-colormap (x-window-colormap (x-graphics-device/xw device))))
  938.  
  939. (define (x-graphics/set-colormap device colormap)
  940.   (x-set-window-colormap (x-graphics-device/xw device)
  941.              (colormap/descriptor colormap)))
  942.  
  943. (define (create-x-colormap device writeable?)
  944.   (let ((window (x-graphics-device/xw device)))
  945.     (let ((visual (x-window-visual window)))
  946.       (let ((descriptor (x-create-colormap window visual writeable?)))
  947.     (x-visual-deallocate visual)
  948.     (make-colormap descriptor)))))
  949.  
  950. (define (x-colormap/free colormap)
  951.   (remove-from-gc-finalizer! colormap-list colormap))
  952.  
  953. (define (x-colormap/allocate-color colormap r g b)
  954.   (x-allocate-color (colormap/descriptor colormap) r g b))
  955.  
  956. (define (x-colormap/query-color colormap position)
  957.   (x-query-color (colormap/descriptor colormap) position))
  958.  
  959. (define (x-colormap/store-color colormap position r g b)
  960.   (x-store-color (colormap/descriptor colormap) position r g b))
  961.  
  962. (define (x-colormap/store-colors colormap color-vector)
  963.   (x-store-colors (colormap/descriptor colormap) color-vector))
  964.  
  965. (define (x-graphics/color? device)
  966.   (let ((info (x-graphics/visual-info device)))
  967.     (let ((n (vector-length info)))
  968.       (let loop ((index 0))
  969.     (and (not (fix:= index n))
  970.          (or (let ((class (x-visual-info/class (vector-ref info index))))
  971.            (or (eq? x-visual-class:static-color class)
  972.                (eq? x-visual-class:pseudo-color class)
  973.                (eq? x-visual-class:true-color class)
  974.                (eq? x-visual-class:direct-color class)))
  975.          (loop (fix:+ index 1))))))))
  976.  
  977. (define (x-graphics/image-depth device)
  978.   (x-window-depth (x-graphics-device/xw device)))
  979.  
  980. (define (x-graphics/visual-info device)
  981.   ((ucode-primitive x-get-visual-info 10) (x-graphics-device/xw device)
  982.                       #f #f #f #f #f #f #f #f #f))
  983.  
  984. (define-structure (visual-info (type vector) (conc-name x-visual-info/))
  985.   (visual #f read-only #t)
  986.   (visual-id #f read-only #t)
  987.   (screen #f read-only #t)
  988.   (depth #f read-only #t)
  989.   (class #f read-only #t)
  990.   (red-mask #f read-only #t)
  991.   (green-mask #f read-only #t)
  992.   (blue-mask #f read-only #t)
  993.   (colormap-size #f read-only #t)
  994.   (bits-per-rgb #f read-only #t))
  995.  
  996. (define-integrable x-visual-class:static-gray 0)
  997. (define-integrable x-visual-class:gray-scale 1)
  998. (define-integrable x-visual-class:static-color 2)
  999. (define-integrable x-visual-class:pseudo-color 3)
  1000. (define-integrable x-visual-class:true-color 4)
  1001. (define-integrable x-visual-class:direct-color 5)