local-utils.scm 0.20020909

local-utils.scm 0.20020909

[Thien-Thi Nguyen]

(for use w/ same-versioned circle-frisk.)

thi

__________________________________________
;;; local-utils.scm

;;; Copyright (C) 2002 Thien-Thi Nguyen
;;; This program is part of xplay, released under GNU GPL v2 with ABSOLUTELY
;;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.

;;; Version: 0.20020909

;;; Commentary:

;; save as ./local-utils.scm
;;
;; hardcoded values in compute-center-[xy] reflect hardcoded values in
;; guile-xlib's xlib.c.

;;; Code:

(define-module (local-utils)
  :use-module (xlib core)
  :use-module (xlib xlib)
  :export (new-d/w/gc/show/clear
           erasing-gc
           xor-gc
           simple-kick
           root->black!
           compute-center-x
           compute-center-y))

(define (new-d/w/gc/show/clear)
  (let* ((root? (member "root" (command-line))) ; ugh
         (d (x-open-display!))
         (w (if root?
                (x-root-window d)
                (x-create-window! d)))
         (gc (if root?
                 (x-create-gc! w
                               GCForeground (x-white-pixel d)
                               GCBackground (x-black-pixel d)
                               ;;GCFillStyle FillSolid
                               )
                 (x-default-gc d))))
    (values d w gc
            (lambda () (or root? (x-map-window! w)))
            (lambda () (and root? (root->black! d))))))

(define (erasing-gc d w)
  (x-create-gc! w GCForeground
                ((if (eq? w (x-root-window d))
                     x-black-pixel
                     x-white-pixel)
                 d)))

(define (xor-gc w)
  (x-create-gc! w GCFunction GXxor))

(define (simple-kick proc)
  (call-with-values new-d/w/gc/show/clear proc))

(define (root->black! d)
  (let* ((w (x-display-width d))
         (h (x-display-height d))
         (r (x-root-window d))
         (gc (x-create-gc! r
                           GCForeground (x-black-pixel d)
                           GCBackground (x-white-pixel d))))
    (do ((x 0 (1+ x)))
        ((= w x))
      (x-draw-line! r gc x 0 x h)))
  (x-flush! d))

(define (compute-center-x d w)
  (inexact->exact (/ (if (eq? w (x-root-window d))
                         (x-display-width d)
                         600)
                     2)))

(define (compute-center-y d w)
  (inexact->exact (/ (if (eq? w (x-root-window d))
                         (x-display-height d)
                         400)
                     2)))

;;; local-utils.scm ends here


_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user