examples/null-program.scm

   1 #!/usr/bin/env guile
   2 !#
   3
   4 ;;; figl
   5 ;;; Copyright (C) 2013 Andy Wingo <wingo@pobox.com>
   6 ;;;
   7 ;;; Figl is free software: you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU Lesser General Public License as
   9 ;;; published by the Free Software Foundation, either version 3 of the
  10 ;;; License, or (at your option) any later version.
  11 ;;;
  12 ;;; Figl is distributed in the hope that it will be useful, but WITHOUT
  13 ;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
  14 ;;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General
  15 ;;; Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU Lesser General Public
  18 ;;; License along with this program.  If not, see
  19 ;;; <http://www.gnu.org/licenses/>.
  20
  21 ;;; Commentary:
  22 ;;
  23 ;; This is the null OpenGL program.  Run as guile --listen
  24 ;; null-program.scm to build it out at runtime.
  25 ;;
  26 ;;; Code:
  27
  28 (use-modules (figl glut)
  29              (figl gl))
  30
  31 (define main-window #f)
  32
  33 (define accumulate-fps!
  34   (let ((frame-count 0)
  35         (last-time (get-internal-real-time))
  36         (last-frame-count 0))
  37     (lambda ()
  38       (let ((now (get-internal-real-time)))
  39         (set! frame-count (1+ frame-count))
  40         (when (> (- now last-time)
  41                  (* 2 internal-time-units-per-second))
  42           (format (current-error-port)
  43                   ";;; fps: ~a\n"
  44                   (/ (- frame-count last-frame-count)
  45                      (/ (- now last-time)
  46                         (exact->inexact internal-time-units-per-second))))
  47           (set! last-frame-count frame-count)
  48           (set! last-time now))))))
  49
  50 (define (on-display)
  51   (accumulate-fps!)
  52   (gl-clear (clear-buffer-mask color-buffer depth-buffer))
  53
  54   ;; Draw here!
  55
  56   ;; With double-buffering, swap-buffers will wait for the frame rate.
  57   (swap-buffers))
  58
  59 (define (on-reshape width height)
  60   (pk 'reshape width height))
  61
  62 (define (on-keyboard keycode x y)
  63   (let ((c (integer->char keycode)))
  64     (case c
  65       ((#\esc #\etx #\q)
  66        (format #t "~s pressed; quitting.\n" c)
  67        (exit))
  68       (else
  69        (pk 'keyboard c x y)))))
  70
  71 ;; Like keyboard, but for special keys.
  72 (define (on-special keycode x y)
  73   (pk 'special keycode x y))
  74
  75 (define (on-mouse button state x y)
  76   (pk 'mouse button state x y))
  77
  78 ;; Called when a button is down.  Set a passive-motion-callback if you
  79 ;; want motion when no button is down.
  80 (define (on-motion x y)
  81   (pk 'motion x y))
  82
  83 (define (on-visibility visible?)
  84   (pk 'visible visible?))
  85
  86 (define (on-idle)
  87   ;; Update the world here!
  88
  89   (post-redisplay main-window))
  90
  91 (define (main args)
  92   (initialize-glut args
  93                    #:window-size '(320 . 200)
  94                    #:display-mode (display-mode rgb double depth))
  95   (set! main-window (make-window "glut"))
  96   ;; The trampolines allow the handlers to be overridden at runtime by
  97   ;; an attached Guile REPL client.
  98   (set-display-callback (lambda () (on-display)))
  99   (set-reshape-callback (lambda (w h) (on-reshape w h)))
 100   (set-keyboard-callback (lambda (k x y) (on-keyboard k x y)))
 101   (set-special-callback (lambda (k x y) (on-special k x y)))
 102   (set-mouse-callback (lambda (b s x y) (on-mouse b s x y)))
 103   (set-motion-callback (lambda (x y) (on-motion x y)))
 104   (set-visibility-callback (lambda (visible?) (on-visibility visible?)))
 105   (set-idle-callback (lambda () (on-idle)))
 106   (glut-main-loop))
 107
 108 (when (batch-mode?)
 109   (exit (main (program-arguments))))