;; 3d-hack.jl -- too much spare time..
;; $Id: 3d-hack.jl,v 1.8 2000/10/27 00:31:09 jsh Exp $
;; Commentary:
;; Load this, then do `(3d-init 3d-make-cube)', or `(3d-init 3d-make-saw)'
;; then `(3d-destroy)' when you've had enough

(define-structure clock
  (export clock-init
          clock-destroy
          clock-run)

  (open rep
        rep.system
        rep.io.timers
        sawfish.wm.events
        sawfish.wm.util.x
        sawfish.wm.colors
        sawfish.wm.commands
        sawfish.wm.misc
        sawfish.wm.events
        sawfish.wm.util.decode-events)

  (define clock-window nil)
  (define clock-white-gc nil)
  (define clock-black-gc nil)
  (define clock-timer nil)
  (define clock-frame-delay 50)

  (define (clock-init)
    (setq clock-window
          (x-create-window (cons (- (/ (screen-width) 2) 200)
                                 (- (/ (screen-height) 2) 200))
                           '(400 . 400) 1
                           `((background . ,(get-color "white")))
                           clock-redraw))
    (setq clock-white-gc
          (x-create-gc clock-window
                       `((foreground . ,(get-color "white")))))
    (setq clock-black-gc
          (x-create-gc clock-window
                       `((foreground . ,(get-color "black")))))
    (x-map-window clock-window)
    (setq clock-timer
          (make-timer (lambda ()
                        (clock-redraw)
                        (x-window-swap-buffers clock-window)
                        (set-timer clock-timer)) 0 clock-frame-delay)))

  (define (clock-destroy)
    (x-destroy-window clock-window)
    (delete-timer clock-timer)
    (setq clock-timer nil)
    (setq clock-window nil)
    (setq clock-white-gc nil)
    (setq clock-black-gc nil))

  (define (clock-run)
    (let ((thrower (lambda ()
		     (let ((event (and (current-event)
				       (decode-event (current-event)))))
		       (when (and (eq (car event) 'key)
				  (not (memq 'release (cadr event))))
			 (throw '3d-out nil))))))
      (catch '3d-out
	(when (grab-keyboard)
	  (unwind-protect
	      (progn
		(add-hook 'unbound-key-hook thrower)
		(3d-init 3d-make-saw)
		(recursive-edit))
	    (ungrab-keyboard)
	    (remove-hook 'unbound-key-hook thrower)
	    (3d-destroy)))))))