#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.15 1992/02/25 22:38:44 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.16 1992/03/20 05:18:02 cph Exp $
Copyright (c) 1989-92 Massachusetts Institute of Technology
MIT in each case. |#
;;;; X Graphics Interface
-;;; package: (runtime X-graphics)
+;;; package: (runtime x-graphics)
(declare (usual-integrations))
+(declare (integrate-external "graphics"))
\f
(define-primitives
(x-debug 1)
(x-window-beep 1)
(x-window-clear 1)
- (x-window-display 1)
(x-window-iconify 1)
+ (x-window-lower 1)
(x-window-map 1)
+ (x-window-query-pointer 1)
+ (x-window-raise 1)
(x-window-set-background-color 2)
(x-window-set-border-color 2)
(x-window-set-border-width 2)
(x-window-set-cursor-color 2)
+ (x-window-set-event-mask 2)
(x-window-set-font 2)
(x-window-set-foreground-color 2)
(x-window-set-icon-name 2)
+ (x-window-set-input-hint 2)
(x-window-set-internal-border-width 2)
(x-window-set-mouse-color 2)
(x-window-set-mouse-shape 2)
(x-window-set-position 3)
(x-window-set-size 3)
(x-window-starbase-filename 1)
- (x-window-unmap 1)
+ (x-window-withdraw 1)
(x-window-x-size 1)
(x-window-y-size 1)
(x-graphics-draw-line 5)
(x-graphics-draw-point 3)
(x-graphics-draw-string 4)
+ (x-graphics-map-x-coordinate 2)
+ (x-graphics-map-y-coordinate 2)
(x-graphics-move-cursor 3)
(x-graphics-open-window 3)
(x-graphics-reset-clip-rectangle 1)
(x-window-visual 1)
(x-visual-deallocate 1))
+
+;; These constants must match "microcode/x11base.c"
+(define-integrable event-type:button-down 0)
+(define-integrable event-type:button-up 1)
+(define-integrable event-type:configure 2)
+(define-integrable event-type:enter 3)
+(define-integrable event-type:focus-in 4)
+(define-integrable event-type:focus-out 5)
+(define-integrable event-type:key-press 6)
+(define-integrable event-type:leave 7)
+(define-integrable event-type:motion 8)
+(define-integrable event-type:expose 9)
+(define-integrable event-type:delete-window 10)
+(define-integrable event-type:map 11)
+(define-integrable event-type:unmap 12)
+(define-integrable event-type:take-focus 13)
+(define-integrable event-type:visibility 14)
+(define-integrable number-of-event-types 15)
+
+;; This mask contains configure, delete-window, map, unmap, and visibility.
+(define-integrable event-mask #x5c04)
\f
;;;; Protection lists
(let ((next (cdr associations)))
(set-cdr! previous next)
(loop next previous)))))))
+
+(define (search-protection-list list predicate)
+ (let loop ((associations (cdr list)))
+ (and (not (null? associations))
+ (let ((scheme-object (weak-car (car associations))))
+ (if (and scheme-object (predicate scheme-object))
+ scheme-object
+ (loop (cdr associations)))))))
+
+(define (protection-list-elements list)
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (let loop ((associations (cdr list)))
+ (cond ((null? associations)
+ '())
+ ((weak-pair/car? (car associations))
+ (cons (weak-car (car associations))
+ (loop (cdr associations))))
+ (else
+ (loop (cdr associations))))))))
\f
;;;; X graphics device
(define (initialize-package!)
(set! x-graphics-device-type
(make-graphics-device-type
- `((available? ,operation/available?)
- (clear ,operation/clear)
- (close ,operation/close)
- (coordinate-limits ,operation/coordinate-limits)
- (copy-area ,operation/copy-area)
- (create-colormap ,operation/create-colormap)
- (create-image ,operation/create-image)
- (device-coordinate-limits ,operation/device-coordinate-limits)
- (drag-cursor ,operation/drag-cursor)
- (draw-line ,operation/draw-line)
- (draw-point ,operation/draw-point)
- (draw-text ,operation/draw-text)
- (flush ,operation/flush)
- (font-structure ,operation/font-structure)
- (get-colormap ,operation/get-colormap)
- (get-default ,operation/get-default)
- (iconify-window ,operation/iconify-window)
- (map-window ,operation/map-window)
- (move-cursor ,operation/move-cursor)
- (move-window ,operation/move-window)
- (open ,operation/open)
- (reset-clip-rectangle ,operation/reset-clip-rectangle)
- (resize-window ,operation/resize-window)
- (set-background-color ,operation/set-background-color)
- (set-border-color ,operation/set-border-color)
- (set-border-width ,operation/set-border-width)
- (set-clip-rectangle ,operation/set-clip-rectangle)
- (set-colormap ,operation/set-colormap)
- (set-coordinate-limits ,operation/set-coordinate-limits)
- (set-drawing-mode ,operation/set-drawing-mode)
- (set-font ,operation/set-font)
- (set-foreground-color ,operation/set-foreground-color)
- (set-icon-name ,operation/set-icon-name)
- (set-internal-border-width ,operation/set-internal-border-width)
- (set-line-style ,operation/set-line-style)
- (set-mouse-color ,operation/set-mouse-color)
- (set-mouse-shape ,operation/set-mouse-shape)
- (set-window-name ,operation/set-window-name)
- (starbase-filename ,operation/starbase-filename)
- (unmap-window ,operation/unmap-window))))
- (set! window-list (make-protection-list))
- (add-gc-daemon! close-lost-windows-daemon)
+ `((available? ,x-graphics/available?)
+ (clear ,x-graphics/clear)
+ (close ,x-graphics/close-window)
+ (coordinate-limits ,x-graphics/coordinate-limits)
+ (copy-area ,x-graphics/copy-area)
+ (create-colormap ,create-x-colormap)
+ (create-image ,create-x-image)
+ (device-coordinate-limits ,x-graphics/device-coordinate-limits)
+ (drag-cursor ,x-graphics/drag-cursor)
+ (draw-line ,x-graphics/draw-line)
+ (draw-point ,x-graphics/draw-point)
+ (draw-text ,x-graphics/draw-text)
+ (flush ,x-graphics/flush)
+ (font-structure ,x-graphics/font-structure)
+ (get-colormap ,x-graphics/get-colormap)
+ (get-default ,x-graphics/get-default)
+ (iconify-window ,x-graphics/iconify-window)
+ (lower-window ,x-graphics/lower-window)
+ (map-window ,x-graphics/map-window)
+ (move-cursor ,x-graphics/move-cursor)
+ (move-window ,x-graphics/move-window)
+ (open ,x-graphics/open)
+ (query-pointer ,x-graphics/query-pointer)
+ (raise-window ,x-graphics/raise-window)
+ (reset-clip-rectangle ,x-graphics/reset-clip-rectangle)
+ (resize-window ,x-graphics/resize-window)
+ (set-background-color ,x-graphics/set-background-color)
+ (set-border-color ,x-graphics/set-border-color)
+ (set-border-width ,x-graphics/set-border-width)
+ (set-clip-rectangle ,x-graphics/set-clip-rectangle)
+ (set-colormap ,x-graphics/set-colormap)
+ (set-coordinate-limits ,x-graphics/set-coordinate-limits)
+ (set-drawing-mode ,x-graphics/set-drawing-mode)
+ (set-font ,x-graphics/set-font)
+ (set-foreground-color ,x-graphics/set-foreground-color)
+ (set-icon-name ,x-graphics/set-icon-name)
+ (set-input-hint ,x-graphics/set-input-hint)
+ (set-internal-border-width ,x-graphics/set-internal-border-width)
+ (set-line-style ,x-graphics/set-line-style)
+ (set-mouse-color ,x-graphics/set-mouse-color)
+ (set-mouse-shape ,x-graphics/set-mouse-shape)
+ (set-window-name ,x-graphics/set-window-name)
+ (starbase-filename ,x-graphics/starbase-filename)
+ (withdraw-window ,x-graphics/withdraw-window))))
+ (set! display-list (make-protection-list))
+ (add-gc-daemon! close-lost-displays-daemon)
(initialize-image-datatype)
(initialize-colormap-datatype))
-\f
+
+(define (x-graphics/available?)
+ (implemented-primitive-procedure? x-graphics-open-window))
+
(define x-graphics-device-type)
+\f
+;;;; Open/Close Displays
+
+(define display-list)
+
+(define-structure (x-display
+ (conc-name x-display/)
+ (constructor make-x-display (name xd))
+ (print-procedure
+ (unparser/standard-method 'X-DISPLAY
+ (lambda (state display)
+ (unparse-object state (x-display/name display))))))
+ (name false read-only true)
+ xd
+ (window-list (make-protection-list) read-only true))
+
+(define (x-graphics/open-display name)
+ (let ((name
+ (cond ((not name)
+ (let ((name (get-environment-variable "DISPLAY")))
+ (if (not name)
+ (error "No DISPLAY environment variable."))
+ name))
+ ((string? name)
+ name)
+ (else
+ (error:wrong-type-argument name
+ "string or #f"
+ x-graphics/open-display)))))
+ (or (search-protection-list display-list
+ (lambda (display)
+ (string=? (x-display/name display) name)))
+ (let ((xd (x-open-display name)))
+ (if (not xd)
+ (error "Unable to open display:" name))
+ (let ((display (make-x-display name xd)))
+ (add-to-protection-list! display-list display xd)
+ (create-thread false (make-event-previewer display))
+ display)))))
+
+(define (x-graphics/close-display display)
+ (without-interrupts
+ (lambda ()
+ (if (x-display/xd display)
+ (begin
+ (do ((windows
+ (protection-list-elements (x-display/window-list display))
+ (cdr windows)))
+ ((null? windows))
+ (close-x-window (car windows)))
+ (x-close-display (x-display/xd display))
+ (set-x-display/xd! display false)
+ (remove-from-protection-list! display-list display))))))
+
+(define (close-lost-displays-daemon)
+ (clean-lost-protected-objects display-list x-close-display)
+ (do ((associations (cdr display-list) (cdr associations)))
+ ((null? associations))
+ (clean-lost-protected-objects
+ (x-display/window-list (weak-car (car associations)))
+ x-close-window)))
+\f
+(define (make-event-previewer display)
+ (lambda ()
+ (detach-thread (current-thread))
+ (bind-condition-handler (list condition-type:bad-range-argument
+ condition-type:wrong-type-argument)
+ (lambda (condition)
+ ;; If x-display-process-events signals an argument error on
+ ;; its display argument, that means the display has been
+ ;; closed. When that happens, kill this thread.
+ (if (and (eq? x-display-process-events
+ (access-condition condition 'OPERATOR))
+ (eqv? 0 (access-condition condition 'OPERAND)))
+ (exit-current-thread unspecific)))
+ (lambda ()
+ (let ((handlers event-handlers)
+ (interval event-previewer-interval))
+ (do () (false)
+ (let loop ()
+ (let ((event
+ (x-display-process-events (x-display/xd display) 2)))
+ (if event
+ (begin
+ (let ((handler
+ (vector-ref handlers (vector-ref event 0))))
+ (if handler
+ (let ((window
+ (search-protection-list
+ (x-display/window-list display)
+ (let ((xw (vector-ref event 1)))
+ (lambda (window)
+ (eq? (x-window/xw window) xw))))))
+ (if window
+ (handler window event)))))
+ (loop)))))
+ (sleep-current-thread interval)))))))
+
+(define event-previewer-interval
+ 1000)
+
+(define event-handlers
+ (make-vector number-of-event-types false))
+
+(define-integrable (define-event-handler event-type handler)
+ (vector-set! event-handlers event-type handler))
+
+(define-event-handler event-type:delete-window
+ (lambda (window event)
+ event
+ (without-interrupts (lambda () (close-x-window window)))))
+
+(define-event-handler event-type:map
+ (lambda (window event)
+ event
+ (set-x-window/mapped?! window true)))
+
+(define-event-handler event-type:unmap
+ (lambda (window event)
+ event
+ (set-x-window/mapped?! window false)))
+
+(define-event-handler event-type:visibility
+ (lambda (window event)
+ (case (vector-ref event 2)
+ ((0) (set-x-window/visibility! window 'UNOBSCURED))
+ ((1) (set-x-window/visibility! window 'PARTIALLY-OBSCURED))
+ ((2) (set-x-window/visibility! window 'OBSCURED)))))
+\f
+;;;; Standard Operations
+
+(define-structure (x-window (conc-name x-window/)
+ (constructor make-x-window (xw display)))
+ xw
+ (display false read-only true)
+ (mapped? false)
+ (visibility false))
+
+(define-integrable (x-graphics-device/xw device)
+ (x-window/xw (graphics-device/descriptor device)))
+
+(define-integrable (x-graphics-device/xd device)
+ (x-display/xd (x-window/display (graphics-device/descriptor device))))
+
+(define (x-graphics/open display geometry #!optional suppress-map?)
+ (let ((display
+ (if (x-display? display)
+ display
+ (x-graphics/open-display display))))
+ (let ((xw
+ (x-graphics-open-window (x-display/xd display)
+ geometry
+ (and (not (default-object? suppress-map?))
+ suppress-map?))))
+ (x-window-set-event-mask xw event-mask)
+ (let ((window (make-x-window xw display)))
+ (add-to-protection-list! (x-display/window-list display) window xw)
+ window))))
+
+(define (x-graphics/close-window device)
+ (without-interrupts
+ (lambda ()
+ (close-x-window (graphics-device/descriptor device)))))
+
+(define (close-x-window window)
+ (if (x-window/xw window)
+ (begin
+ (x-close-window (x-window/xw window))
+ (set-x-window/xw! window false)
+ (remove-from-protection-list!
+ (x-display/window-list (x-window/display window))
+ window))))
(define (x-geometry-string x y width height)
(string-append (if (and width height)
(if (negative? y) "" "+")
(number->string y))
"")))
+\f
+(define (x-graphics/clear device)
+ (x-window-clear (x-graphics-device/xw device)))
-(define-structure (x-graphics-descriptor (conc-name x-graphics-descriptor/))
- (window false read-only true)
- (display false read-only true))
-
-(define (x-graphics-device/window device)
- (x-graphics-descriptor/window (graphics-device/descriptor device)))
+(define (x-graphics/coordinate-limits device)
+ (let ((limits (x-graphics-vdc-extent (x-graphics-device/xw device))))
+ (values (vector-ref limits 0) (vector-ref limits 1)
+ (vector-ref limits 2) (vector-ref limits 3))))
-(define (x-graphics-device/display device)
- (x-graphics-descriptor/display (graphics-device/descriptor device)))
+(define (x-graphics/device-coordinate-limits device)
+ (let ((xw (x-graphics-device/xw device)))
+ (values 0 (- (x-window-y-size xw) 1) (- (x-window-x-size xw) 1) 0)))
-(define (x-graphics-device/process-events! device)
- (let ((xd (x-graphics-device/display device)))
- (let loop ()
- (if (x-display-process-events xd 0)
- (loop)))))
+(define (x-graphics/drag-cursor device x y)
+ (x-graphics-drag-cursor (x-graphics-device/xw device) x y))
-(define (operation/available?)
- (implemented-primitive-procedure? x-graphics-open-window))
-
-(define (operation/clear device)
- (x-graphics-device/process-events! device)
- (x-window-clear (x-graphics-device/window device)))
-
-(define (operation/close device)
- (x-graphics-device/process-events! device)
- (x-close-window (x-graphics-device/window device))
- (remove-from-protection-list!
- window-list
- (graphics-device/descriptor device)))
-
-(define (close-lost-windows-daemon)
- (clean-lost-protected-objects window-list x-close-window))
-
-(define (operation/coordinate-limits device)
- (x-graphics-device/process-events! device)
- (let ((limits (x-graphics-vdc-extent (x-graphics-device/window device))))
- (values (vector-ref limits 0)
- (vector-ref limits 1)
- (vector-ref limits 2)
- (vector-ref limits 3))))
-
-(define (operation/copy-area device
- source-x-left source-y-top
- width height
- destination-x-left destination-y-top)
- (x-graphics-device/process-events! device)
- (x-graphics-copy-area (x-graphics-device/window device)
- source-x-left source-y-top
- width height
- destination-x-left destination-y-top))
+(define (x-graphics/draw-line device x-start y-start x-end y-end)
+ (x-graphics-draw-line (x-graphics-device/xw device)
+ x-start y-start x-end y-end))
-(define (operation/device-coordinate-limits device)
- (x-graphics-device/process-events! device)
- (let ((xw (x-graphics-device/window device)))
- (values 0 (-1+ (x-window-y-size xw)) (-1+ (x-window-x-size xw)) 0)))
+(define (x-graphics/draw-point device x y)
+ (x-graphics-draw-point (x-graphics-device/xw device) x y))
-(define (operation/drag-cursor device x y)
- (x-graphics-device/process-events! device)
- (x-graphics-drag-cursor (x-graphics-device/window device) x y))
+(define (x-graphics/draw-text device x y string)
+ (x-graphics-draw-string (x-graphics-device/xw device) x y string))
-(define (operation/draw-line device x-start y-start x-end y-end)
- (x-graphics-device/process-events! device)
- (x-graphics-draw-line (x-graphics-device/window device)
- x-start y-start x-end y-end))
+(define (x-graphics/flush device)
+ (x-display-flush (x-graphics-device/xd device)))
-(define (operation/draw-point device x y)
- (x-graphics-device/process-events! device)
- (x-graphics-draw-point (x-graphics-device/window device) x y))
+(define (x-graphics/move-cursor device x y)
+ (x-graphics-move-cursor (x-graphics-device/xw device) x y))
-(define (operation/draw-text device x y string)
- (x-graphics-device/process-events! device)
- (x-graphics-draw-string (x-graphics-device/window device) x y string))
+(define (x-graphics/reset-clip-rectangle device)
+ (x-graphics-reset-clip-rectangle (x-graphics-device/xw device)))
-(define (operation/flush device)
- (x-display-flush (x-graphics-device/display device))
- (x-graphics-device/process-events! device))
-
-(define (operation/font-structure device string)
- (x-graphics-device/process-events! device)
- (x-font-structure (x-graphics-device/display device) string))
+(define (x-graphics/set-clip-rectangle device x-left y-bottom x-right y-top)
+ (x-graphics-set-clip-rectangle (x-graphics-device/xw device)
+ x-left y-bottom x-right y-top))
-(define (operation/get-default device resource-name class-name)
- (x-graphics-device/process-events! device)
- (x-display-get-default (x-graphics-device/display device)
- resource-name class-name))
-\f
-(define (operation/map-window device)
- (x-graphics-device/process-events! device)
- (x-window-map (x-graphics-device/window device)))
-
-(define (operation/move-cursor device x y)
- (x-graphics-device/process-events! device)
- (x-graphics-move-cursor (x-graphics-device/window device) x y))
-
-(define (operation/move-window device x y)
- (x-graphics-device/process-events! device)
- (x-window-set-position (x-graphics-device/window device) x y))
-
-(define default-display-hash
- false)
-
-(define window-list)
-
-(define (operation/open display geometry #!optional suppress-map?)
- (let ((xw
- (x-graphics-open-window
- (let ((open
- (lambda ()
- (let ((d (x-open-display display)))
- (if (not d)
- (error "unable to open display" display))
- d))))
- (cond ((false? display)
- (or (and default-display-hash
- (object-unhash default-display-hash))
- (let ((d (open)))
- (set! default-display-hash (object-hash d))
- d)))
- ((string? display)
- (open))
- (else
- display)))
- geometry
- (and (not (default-object? suppress-map?))
- suppress-map?))))
- (let ((descriptor (make-x-graphics-descriptor xw (x-window-display xw))))
- (add-to-protection-list! window-list descriptor xw)
- descriptor)))
-
-(define (operation/reset-clip-rectangle device)
- (x-graphics-device/process-events! device)
- (x-graphics-reset-clip-rectangle (x-graphics-device/window device)))
-
-(define (operation/resize-window device width height)
- (x-graphics-device/process-events! device)
- (x-window-set-size (x-graphics-device/window device) width height))
-
-(define (operation/set-background-color device color)
- (x-graphics-device/process-events! device)
- (x-window-set-background-color (x-graphics-device/window device) color))
-
-(define (operation/set-border-color device color)
- (x-graphics-device/process-events! device)
- (x-window-set-border-color (x-graphics-device/window device) color))
-
-(define (operation/set-border-width device width)
- (x-graphics-device/process-events! device)
- (x-window-set-border-width (x-graphics-device/window device) width))
-
-(define (operation/set-coordinate-limits device x-left y-bottom x-right y-top)
- (x-graphics-device/process-events! device)
- (x-graphics-set-vdc-extent (x-graphics-device/window device)
+(define (x-graphics/set-coordinate-limits device x-left y-bottom x-right y-top)
+ (x-graphics-set-vdc-extent (x-graphics-device/xw device)
x-left y-bottom x-right y-top))
-(define (operation/set-clip-rectangle device x-left y-bottom x-right y-top)
- (x-graphics-device/process-events! device)
- (x-graphics-set-clip-rectangle (x-graphics-device/window device)
- x-left y-bottom x-right y-top))
-\f
-(define (operation/set-drawing-mode device mode)
- (x-graphics-device/process-events! device)
- (x-graphics-set-function (x-graphics-device/window device) mode))
-
-(define (operation/set-font device font)
- (x-graphics-device/process-events! device)
- (x-window-set-font (x-graphics-device/window device) font))
-
-(define (operation/set-foreground-color device color)
- (x-graphics-device/process-events! device)
- (x-window-set-foreground-color (x-graphics-device/window device) color))
-
-(define (operation/set-internal-border-width device width)
- (x-graphics-device/process-events! device)
- (x-window-set-internal-border-width (x-graphics-device/window device) width))
-
-(define (operation/set-line-style device line-style)
- (x-graphics-device/process-events! device)
- (if (not (and (exact-nonnegative-integer? line-style)
- (< line-style 8)))
+(define (x-graphics/set-drawing-mode device mode)
+ (x-graphics-set-function (x-graphics-device/xw device) mode))
+
+(define (x-graphics/set-line-style device line-style)
+ (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8)))
(error:wrong-type-argument line-style "graphics line style"
'SET-LINE-STYLE))
- (let ((xw (x-graphics-device/window device)))
+ (let ((xw (x-graphics-device/xw device)))
(if (zero? line-style)
(x-graphics-set-line-style xw 0)
(begin
(x-graphics-set-line-style xw 2)
- (x-graphics-set-dashes
- xw
- 0
- (vector-ref '#("\010\010"
- "\001\001"
- "\015\001\001\001"
- "\013\001\001\001\001\001"
- "\013\005"
- "\014\001\002\001"
- "\011\001\002\001\002\001")
- (-1+ line-style)))))))
-
-(define (operation/set-mouse-color device color)
- (x-graphics-device/process-events! device)
- (x-window-set-mouse-color (x-graphics-device/window device) color))
-
-(define (operation/set-mouse-shape device shape)
- (x-graphics-device/process-events! device)
- (x-window-set-mouse-shape (x-graphics-device/window device) shape))
-
-(define (operation/starbase-filename device)
- (x-graphics-device/process-events! device)
- (x-window-starbase-filename (x-graphics-device/window device)))
-
-(define (operation/unmap-window device)
- (x-graphics-device/process-events! device)
- (x-window-unmap (x-graphics-device/window device)))
-
-(define (operation/iconify-window device)
- (x-graphics-device/process-events! device)
- (x-window-iconify (x-graphics-device/window device)))
-
-(define (operation/set-icon-name device name)
- (x-graphics-device/process-events! device)
- (x-window-set-icon-name (x-graphics-device/window device) name))
-
-(define (operation/set-window-name device name)
- (x-graphics-device/process-events! device)
- (x-window-set-name (x-graphics-device/window device) name))
+ (x-graphics-set-dashes xw
+ 0
+ (vector-ref '#("\010\010"
+ "\001\001"
+ "\015\001\001\001"
+ "\013\001\001\001\001\001"
+ "\013\005"
+ "\014\001\002\001"
+ "\011\001\002\001\002\001")
+ (- line-style 1)))))))
+\f
+;;;; Appearance Operations
+
+(define (x-graphics/set-background-color device color)
+ (x-window-set-background-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-border-color device color)
+ (x-window-set-border-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-border-width device width)
+ (x-window-set-border-width (x-graphics-device/xw device) width))
+
+(define (x-graphics/set-font device font)
+ (x-window-set-font (x-graphics-device/xw device) font))
+
+(define (x-graphics/set-foreground-color device color)
+ (x-window-set-foreground-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-internal-border-width device width)
+ (x-window-set-internal-border-width (x-graphics-device/xw device) width))
+
+(define (x-graphics/set-mouse-color device color)
+ (x-window-set-mouse-color (x-graphics-device/xw device) color))
+
+(define (x-graphics/set-mouse-shape device shape)
+ (x-window-set-mouse-shape (x-graphics-device/xw device) shape))
+
+;;;; Miscellaneous Operations
+
+(define (x-graphics/copy-area device
+ source-x-left source-y-top
+ width height
+ destination-x-left destination-y-top)
+ (x-graphics-copy-area (x-graphics-device/xw device)
+ source-x-left source-y-top
+ width height
+ destination-x-left destination-y-top))
+
+(define (x-graphics/get-default device resource-name class-name)
+ (x-display-get-default (x-graphics-device/xd device)
+ resource-name class-name))
+
+(define (x-graphics/set-input-hint device input?)
+ (x-window-set-input-hint (x-graphics-device/xw device) input?))
+
+(define (x-graphics/query-pointer device)
+ (let ((result (x-window-query-pointer (x-graphics-device/xw device))))
+ (values (x-graphics-map-x-coordinate (vector-ref result 2))
+ (x-graphics-map-y-coordinate (vector-ref result 3))
+ (vector-ref result 4))))
+
+(define (x-graphics/starbase-filename device)
+ (x-window-starbase-filename (x-graphics-device/xw device)))
+\f
+;;;; Font Operations
+
+(define (x-graphics/font-structure device string)
+ (x-font-structure (x-graphics-device/xd device) string))
+
+(define-structure (x-font-structure (conc-name x-font-structure/)
+ (type vector))
+ (name false read-only true)
+ (direction false read-only true)
+ (all-chars-exist? false read-only true)
+ (default-char false read-only true)
+ (min-bounds false read-only true)
+ (max-bounds false read-only true)
+ (start-index false read-only true)
+ (character-bounds false read-only true)
+ (max-ascent false read-only true)
+ (max-descent false read-only true))
+
+(define-structure (x-character-bounds (conc-name x-character-bounds/)
+ (type vector))
+ (lbearing false read-only true)
+ (rbearing false read-only true)
+ (width false read-only true)
+ (ascent false read-only true)
+ (descent false read-only true))
+
+;;;; Window Management Operations
+
+(define (x-graphics/map-window device)
+ (x-window-map (x-graphics-device/xw device)))
+
+(define (x-graphics/withdraw-window device)
+ (x-window-withdraw (x-graphics-device/xw device)))
+
+(define (x-graphics/iconify-window device)
+ (x-window-iconify (x-graphics-device/xw device)))
+
+(define (x-graphics/raise-window device)
+ (x-window-raise (x-graphics-device/xw device)))
+
+(define (x-graphics/lower-window device)
+ (x-window-lower (x-graphics-device/xw device)))
+
+(define (x-graphics/set-icon-name device name)
+ (x-window-set-icon-name (x-graphics-device/xw device) name))
+
+(define (x-graphics/set-window-name device name)
+ (x-window-set-name (x-graphics-device/xw device) name))
+
+(define (x-graphics/move-window device x y)
+ (x-window-set-position (x-graphics-device/xw device) x y))
+
+(define (x-graphics/resize-window device width height)
+ (x-window-set-size (x-graphics-device/xw device) width height))
\f
;;;; Images
(set! image-list (make-protection-list))
(add-gc-daemon! destroy-lost-images-daemon))
-(define (operation/create-image device width height)
- (let ((window (x-graphics-device/window device)))
+(define (create-x-image device width height)
+ (let ((window (x-graphics-device/xw device)))
(let ((descriptor (x-create-image window width height)))
(let ((image (make-x-image descriptor window width height)))
(add-to-protection-list! image-list image descriptor)
(add-to-protection-list! colormap-list colormap descriptor)
colormap))
-(define (operation/get-colormap device)
- (make-colormap (x-window-colormap (x-graphics-device/window device))))
+(define (x-graphics/get-colormap device)
+ (make-colormap (x-window-colormap (x-graphics-device/xw device))))
-(define (operation/set-colormap device colormap)
- (x-set-window-colormap (x-graphics-device/window device)
+(define (x-graphics/set-colormap device colormap)
+ (x-set-window-colormap (x-graphics-device/xw device)
(colormap/descriptor colormap)))
-(define (operation/create-colormap device writeable?)
- (let ((window (x-graphics-device/window device)))
+(define (create-x-colormap device writeable?)
+ (let ((window (x-graphics-device/xw device)))
(let ((visual (x-window-visual window)))
(let ((descriptor (x-create-colormap window visual writeable?)))
(x-visual-deallocate visual)
(x-store-color (colormap/descriptor colormap) position r g b))
(define (x-colormap/store-colors colormap color-vector)
- (x-store-colors (colormap/descriptor colormap) color-vector))
-\f
-;;;; Fonts
-
-(define-structure (x-font-structure (conc-name x-font-structure/)
- (type vector))
- (name false read-only true)
- (direction false read-only true)
- (all-chars-exist? false read-only true)
- (default-char false read-only true)
- (min-bounds false read-only true)
- (max-bounds false read-only true)
- (start-index false read-only true)
- (character-bounds false read-only true)
- (max-ascent false read-only true)
- (max-descent false read-only true))
-
-(define-structure (x-character-bounds (conc-name x-character-bounds/)
- (type vector))
- (lbearing false read-only true)
- (rbearing false read-only true)
- (width false read-only true)
- (ascent false read-only true)
- (descent false read-only true))
\ No newline at end of file
+ (x-store-colors (colormap/descriptor colormap) color-vector))
\ No newline at end of file
projects / mit-scheme.git / commitdiff