examples/null-program.scm

   1 #!/usr/bin/env guile
   2 !#
   3
   4 ;; This is the null OpenGL program.  Run as guile --listen
   5 ;; null-program.scm to build it out at runtime.
   6
   7 (use-modules (figl glut)
   8              (figl gl))
   9
  10 (define main-window #f)
  11
  12 (define accumulate-fps!
  13   (let ((frame-count 0)
  14         (last-time (get-internal-real-time))
  15         (last-frame-count 0))
  16     (lambda ()
  17       (let ((now (get-internal-real-time)))
  18         (set! frame-count (1+ frame-count))
  19         (when (> (- now last-time)
  20                  (* 2 internal-time-units-per-second))
  21           (format (current-error-port)
  22                   ";;; fps: ~a\n"
  23                   (/ (- frame-count last-frame-count)
  24                      (/ (- now last-time)
  25                         (exact->inexact internal-time-units-per-second))))
  26           (set! last-frame-count frame-count)
  27           (set! last-time now))))))
  28
  29 (define (on-display)
  30   (accumulate-fps!)
  31   (gl-clear (clear-buffer-mask color-buffer depth-buffer))
  32
  33   ;; Draw here!
  34
  35   ;; With double-buffering, swap-buffers will wait for the frame rate.
  36   (swap-buffers))
  37
  38 (define (on-reshape width height)
  39   (pk 'reshape width height))
  40
  41 (define (on-keyboard keycode x y)
  42   (let ((c (integer->char keycode)))
  43     (case c
  44       ((#\esc #\etx #\q)
  45        (format #t "~s pressed; quitting.\n" c)
  46        (exit))
  47       (else
  48        (pk 'keyboard c x y)))))
  49
  50 ;; Like keyboard, but for special keys.
  51 (define (on-special keycode x y)
  52   (pk 'special keycode x y))
  53
  54 (define (on-mouse button state x y)
  55   (pk 'mouse button state x y))
  56
  57 ;; Called when a button is down.  Set a passive-motion-callback if you
  58 ;; want motion when no button is down.
  59 (define (on-motion x y)
  60   (pk 'motion x y))
  61
  62 (define (on-visibility visible?)
  63   (pk 'visible visible?))
  64
  65 (define (on-idle)
  66   ;; Update the world here!
  67
  68   (post-redisplay main-window))
  69
  70 (define (main args)
  71   (initialize-glut args
  72                    #:window-size '(320 . 200)
  73                    #:display-mode (display-mode rgb double depth))
  74   (set! main-window (make-window "glut"))
  75   ;; The trampolines allow the handlers to be overridden at runtime by
  76   ;; an attached Guile REPL client.
  77   (set-display-callback (lambda () (on-display)))
  78   (set-reshape-callback (lambda (w h) (on-reshape w h)))
  79   (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
  80   (set-special-callback (lambda (k x y) (on-special k x y)))
  81   (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
  82   (set-motion-callback (lambda (x y) (on-motion x y)))
  83   (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
  84   (set-idle-callback (lambda () (on-idle)))
  85   (glut-main-loop))
  86
  87 (when (batch-mode?)
  88   (exit (main (program-arguments))))