scx/scheme/xlib/display.scm

;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese

;; TODO: pixmap-formats (XListPixmapFormats)
(define-record-type display :display
  (make-display cpointer connection-number protocol-version protocol-revision
		server-vendor image-byte-order bitmap-unit bitmap-pad
		bitmap-bit-order vendor-release queue-length name
		default-screen screens after-function wakeup)
  display?
  (cpointer display:cpointer)
  (connection-number display:connection-number)
  (protocol-version display:protocol-version)
  (protocol-revision display:protocol-revision)
  (server-vendor display:server-vendor)
  (image-byte-order display:image-byte-order)
  (bitmap-unit display:bitmap-unit)
  (bitmap-pad display:bitmap-pad)
  (bitmap-bit-order display:bitmap-bit-order)
  (vendor-release display:vendor-release)
  (queue-length display:queue-length)
  (name display:name)
  (default-screen display:default-screen)
  (screens display:screens)
  (after-function display:after-function set-display:after-function!)
  (wakeup display:wakeup set-display:wakeup!))

(define-exported-binding "scx-display" :display)

;(define (wakeup-display dpy)
;  (placeholder-set! dpy #t))

;(define (sleep-display dpy)
;  (let ((ph (make-placeholder)))
;    (set-display:wakeup! dpy ph)
;    (placeholder-value ph)))

(define (initialize-display dpy)
;  (set-display:wakeup! dpy (make-placeholder))
;  ;; spawn a thread that weaks up a waiting wait-event call if the
;  ;; inport has data available
;  (spawn (lambda ()
;	   (let loop ()
;	     (block-on-message-inport dpy)
;	     (wakeup-display dpy)
;	     (loop))))
  ;; the after-function may also send a wakup
  #t)

(define-exported-binding "scx-initialize-display" initialize-display)

(define (display-message-inport display)
  (fdes->inport (display:connection-number display)))

(define (block-on-message-inport dpy . maybe-timeout)
  (let ((port (display-message-inport dpy)))
    (call-with-values
     (lambda () (apply select (vector port) (vector) (vector) maybe-timeout))
     (lambda (ready-read ready-write ex)
       (member port (vector->list ready-read))))))

(define-enumerated-type byte-order :byte-order
  byte-order? byte-orders byte-order-name byte-order-index
  (lsb-first msb-first))

(define-exported-binding "scx-byte-order" :byte-order)
(define-exported-binding "scx-byte-orders" byte-orders)

(define-enumerated-type bit-order :bit-order
  bit-order? bit-orders bit-order-name bit-order-index
  (lsb-first msb-first))

(define-exported-binding "scx-bit-order" :bit-order)
(define-exported-binding "scx-bit-orders" bit-orders)

(define-record-type screen-format :screen-format ;; aka pixmap-format
  (make-screen-format depth bits-per-pixel scanline-pad)
  screen-format?
  (depth screen-format:depth)
  (bits-per-pixel screen-format:bits-per-pixel)
  (scanline-pad screen-format:scanline-pad))

(define-exported-binding "scx-screen-format" :screen-format)

(define-record-type screen :screen
  (make-screen cpointer display root-window width height width-mm
	       height-mm number root-depth default-visual default-gc
	       default-colormap white-pixel black-pixel max-maps min-maps
	       does-backing-store does-save-unders? event-mask)
  ;; maybe add depths ?? (TODO)
  ;; does event-mask change ?? (TODO)
  screen?
  (cpointer screen:cpointer)
  (display screen:display)
  (root-window screen:root-window)
  (width screen:width)
  (height screen:height)
  (width-mm screen:width-mm)
  (height-mm screen:height-mm)
  (number screen:number)
  (root-depth screen:root-depth)
  (default-visual screen:default-visual)
  (default-gc screen:default-gc)
  (default-colormap screen:default-colormap)
  (white-pixel screen:white-pixel)
  (black-pixel screen:black-pixel)
  (max-maps screen:max-maps)
  (min-maps screen:min-maps)
  (does-backing-store screen:does-backing-store)
  (does-save-unders? screen:does-save-unders?)
  (event-mask screen:event-mask))

(define-exported-binding "scx-screen" :screen)

;(define (screen:cells screen)
;  (visual:map-entries (screen:default-visual screen)))

;; *** connect or disconnect to X server *****************************

(import-lambda-definition %open-display (display-name)
  "scx_Open_Display")

;; returns a display or #f
(define (open-display . args)
  (let ((display-name (if (null? args)
			  ""
			  (if (null? (cdr args))
			      (cadr args)
			      (error "invalid arguments" (cdr args))))));; TODO
    (%open-display display-name)))

(import-lambda-definition close-display (display)
  "scx_Close_Display")

(define none 0)
(define parent-relative 1)
(define copy-from-parent 0)
(define pointer-window 0)
(define input-focus 1)
(define pointer-root 1)
(define any-property-type 0)
(define any-key 0)
(define all-temporary 0)
(define current-time 0)
(define no-symbol 0)
(define all-planes (- (arithmetic-shift 1 32) 1))

(import-lambda-definition display:last-request-read (display)
  "scx_Display_Last_Request_Read")

;; *** convenience functions *****************************************

(define (default-root-window display)
  (screen:root-window (display:default-screen display)))

(define (black-pixel display)
  (screen:black-pixel (display:default-screen display)))

(define (white-pixel display)
  (screen:white-pixel (display:default-screen display)))

(import-lambda-definition next-request (display)
  "scx_Next_Request")

;; *** enable or disable synchronization *****************************

(define (synchronize dpy on?)
  (if on?
      (set-after-function! dpy
			   (lambda (dpy)
			     (display-sync dpy #f)))
      (set-after-function! dpy #f)))

;; returns the previous after-function. An after-function is called
;; with the display object.

(define (general-after-function display)
  (if (display:after-function display)
      ((display:after-function display) display)
      ;; else the default behaviour ;; TODO: check if this is the real one
      (display-flush display))
  )
  ;; if events are in the queue now, then wakeup a wait-event call
  ;;(if (> (events-queued display (queued-mode already)) 0)
  ;;    (wakeup-display display)))

(define-exported-binding "scx-general-after-function" general-after-function)

(define (set-after-function! display fun)
  (let ((prev (display:after-function display)))
    (set-display:after-function! display fun)
    prev))

;; *** handle output buffer or event queue ***************************

(import-lambda-definition display-flush (display)
  "scx_Display_Flush")

(import-lambda-definition display-sync (display discard?)
  "scx_Display_Sync")

;; display-no-op sends a NoOperation protocol request to the X server, thereby
;; exercising the connection. See XNoOp.

(import-lambda-definition display-no-op (display)
  "scx_No_Op")

;; *** select input events *******************************************

(import-lambda-definition display-select-input (display window event-mask)
  "scx_Display_Select_Input")