examples/Xlib-simple/bounce.scm

   1 #!/usr/bin/env gsi-script
   2
   3 ;;; File: "bounce.scm"
   4
   5 ;;; Copyright (c) 2005-2011 by Marc Feeley, All Rights Reserved.
   6
   7 ;;; Create two windows and bounce many colored balls in them.
   8
   9 (##include "Xlib#.scm") ;; import Xlib procedures and variables
  10
  11 (define win-width   600)
  12 (define win-height  401)
  13 (define ball-width  25)
  14 (define ball-height 25)
  15 (define nb-balls    100)
  16
  17 (define-type ball
  18   id ;; identifier
  19   x  ;; x coordinate
  20   y  ;; y coordinate
  21   dx ;; speed on x axis
  22   dy ;; speed on y axis
  23   gc ;; graphic context
  24 )
  25
  26 (define (iota n)
  27   (let loop ((i (- n 1)) (lst '()))
  28     (if (< i 0)
  29         lst
  30         (loop (- i 1) (cons i lst)))))
  31
  32 (define (create-balls x11-display screen window)
  33   (random-source-randomize! default-random-source)
  34   (map (lambda (id)
  35          (let* ((gc (XCreateGC x11-display window 0 #f))
  36                 (v (make-XGCValues-box))
  37                 (cmap (XDefaultColormapOfScreen screen))
  38                 (c (make-XColor-box)))
  39            (XColor-red-set! c (random-integer 20000))
  40            (XColor-green-set! c (random-integer 20000))
  41            (XColor-blue-set! c (random-integer 20000))
  42            (if (= (XAllocColor x11-display cmap c) 1)
  43                (begin
  44                  (XGCValues-foreground-set! v (XColor-pixel c))
  45                  (XChangeGC x11-display
  46                             gc
  47                             GCForeground
  48                             v)))
  49            (make-ball id
  50                       (* (random-real) (- win-width ball-width))
  51                       (* (random-real) (- win-height ball-height))
  52                       (- (* (random-real) 2.0) 1.0)
  53                       (- (* (random-real) 2.0) 1.0)
  54                       gc)))
  55        (iota nb-balls)))
  56
  57 (define (draw-ball b x11-display window gc-text font)
  58   (let ((x (inexact->exact (floor (ball-x b))))
  59         (y (inexact->exact (floor (ball-y b))))
  60         (dx (ball-dx b))
  61         (dy (ball-dy b))
  62         (gc (ball-gc b))
  63         (ascent (XFontStruct-ascent font))
  64         (descent (XFontStruct-descent font)))
  65
  66     (XFillArc
  67      x11-display
  68      window
  69      gc
  70      x
  71      y
  72      ball-width
  73      ball-height
  74      (* 64 0)
  75      (* 64 360))
  76
  77     (let* ((str (number->string (ball-id b)))
  78            (n (string-length str))
  79            (w (XTextWidth font str n)))
  80       (XDrawString
  81        x11-display
  82        window
  83        gc-text
  84        (+ x (quotient (- ball-width w) 2))
  85        (+ y (quotient (+ ball-height ascent) 2))
  86        str
  87        n))))
  88
  89 (define (move-ball b steps)
  90   (let loop ((n steps)
  91              (x (ball-x b))
  92              (y (ball-y b))
  93              (dx (ball-dx b))
  94              (dy (ball-dy b)))
  95     (if (> n 0)
  96         (let ((new-dx
  97                (if (or (< (+ x dx) 0)
  98                        (>= (+ x dx) (- win-width ball-width)))
  99                    (- dx)
 100                    dx))
 101               (new-dy
 102                (if (or (< (+ y dy) 0)
 103                        (>= (+ y dy) (- win-height ball-height)))
 104                    (- dy)
 105                    dy)))
 106           (loop (- n 1)
 107                 (+ x new-dx)
 108                 (+ y new-dy)
 109                 new-dx
 110                 new-dy))
 111         (begin
 112           (ball-x-set! b x)
 113           (ball-y-set! b y)
 114           (ball-dx-set! b dx)
 115           (ball-dy-set! b dy)))))
 116
 117 (define (make-gate name)
 118   (vector #f
 119           (make-mutex name)
 120           (make-condition-variable name)))
 121
 122 (define (gate-pulse gate)
 123   (let ((mut (vector-ref gate 1))
 124         (cv (vector-ref gate 2)))
 125     (mutex-lock! mut)
 126     (vector-set! gate 0 #t)
 127     (condition-variable-signal! cv)
 128     (mutex-unlock! mut)))
 129
 130 (define (gate-wait gate timeout)
 131   (let ((mut (vector-ref gate 1))
 132         (cv (vector-ref gate 2)))
 133     (let loop ()
 134       (if (mutex-lock! mut timeout)
 135           (if (vector-ref gate 0) ;; pulsed?
 136               (begin
 137                 (vector-set! gate 0 #f)
 138                 (mutex-unlock! mut)
 139                 #t)
 140               (if (mutex-unlock! mut cv timeout)
 141                   (loop)
 142                   #f))
 143           #f))))
 144
 145 (define (make-x11-event-queue x11-display)
 146   (let* ((x11-display-fd
 147           (XConnectionNumber x11-display))
 148          (x11-display-port
 149           (##open-predefined 1 ;; (macro-direction-in)
 150                              '(X11-display)
 151                              x11-display-fd))
 152          (check-x11-connection-events
 153           (make-gate 'check-x11-connection-get))
 154          (get-x11-events
 155           (make-gate 'get-x11-events))
 156          (x11-connection-monitor-thread
 157           (make-thread
 158            (lambda ()
 159              (let loop ()
 160
 161                ;; wait until we need to check for events from the connection
 162                (gate-wait check-x11-connection-events +inf.0)
 163
 164                ;; wait until an event is available from the X11 connection
 165                (##device-port-wait-for-input! x11-display-port)
 166
 167                ;; tell the event loop it should get events
 168                (gate-pulse get-x11-events)
 169
 170                (loop))))))
 171
 172     (thread-start! x11-connection-monitor-thread)
 173
 174     (vector x11-display
 175             get-x11-events
 176             check-x11-connection-events
 177             x11-connection-monitor-thread)))
 178
 179 (define (x11-event-get x11-event-queue absrel-timeout)
 180   (let ((x11-display
 181          (vector-ref x11-event-queue 0))
 182         (get-x11-events
 183          (vector-ref x11-event-queue 1))
 184         (check-x11-connection-events
 185          (vector-ref x11-event-queue 2))
 186         (timeout
 187          (if (time? absrel-timeout)
 188              absrel-timeout
 189              (seconds->time
 190               (+ absrel-timeout
 191                  (time->seconds (current-time)))))))
 192     (let loop ()
 193       (or (XCheckMaskEvent x11-display -1)
 194           (begin
 195             (gate-pulse check-x11-connection-events)
 196             (if (gate-wait get-x11-events timeout)
 197                 (loop)
 198                 #f))))))
 199
 200 (define (main)
 201   (let* ((x11-display
 202           (XOpenDisplay #f))
 203          (screen-number
 204           (XDefaultScreen x11-display))
 205          (screen
 206           (XScreenOfDisplay x11-display screen-number))
 207          (root
 208           (XRootWindow x11-display screen-number))
 209          (black
 210           (XBlackPixel x11-display screen-number))
 211          (white
 212           (XWhitePixel x11-display screen-number))
 213          (x11-event-queue
 214           (make-x11-event-queue x11-display)))
 215
 216     (define (create-window)
 217       (thread-start!
 218        (make-thread
 219         (lambda ()
 220           (let* ((window
 221                   (XCreateSimpleWindow
 222                    x11-display
 223                    root
 224                    100
 225                    200
 226                    win-width
 227                    win-height
 228                    10
 229                    black
 230                    white))
 231                  (font
 232                   (XLoadQueryFont x11-display
 233                                   "lucidasans-12"))
 234                  (gc-text
 235                   (XCreateGC x11-display window 0 #f)))
 236
 237             (let* ((v (make-XGCValues-box))
 238                    (cmap (XDefaultColormapOfScreen screen))
 239                    (c (make-XColor-box))
 240                    (x (XParseColor x11-display
 241                                    cmap
 242                                    "yellow"
 243                                    c)))
 244               (if (and (= (XAllocColor x11-display cmap c) 1) (= x 1) font)
 245                   (begin
 246                     (XGCValues-foreground-set! v (XColor-pixel c))
 247                     (XGCValues-font-set! v (XFontStruct-fid font))
 248                     (XChangeGC x11-display
 249                                gc-text
 250                                (+ GCForeground GCFont)
 251                                v))))
 252
 253             (XMapWindow x11-display window)
 254             (XFlush x11-display)
 255
 256             (XSelectInput
 257              x11-display
 258              window
 259              (+ KeyPressMask
 260                 KeyReleaseMask
 261                 ButtonPressMask
 262                 ButtonReleaseMask
 263                 PointerMotionMask
 264                 EnterWindowMask
 265                 LeaveWindowMask))
 266             (XFlush x11-display)
 267
 268             (let ((balls (create-balls x11-display screen window)))
 269
 270               (let loop ((n 200))
 271                 (if (> n 0)
 272                     (let ((start (current-time)))
 273
 274                       (for-each
 275                        (lambda (b) (move-ball b 5))
 276                        balls)
 277
 278                       (XClearWindow x11-display window)
 279
 280                       (for-each
 281                        (lambda (b)
 282                          (draw-ball b x11-display window gc-text font))
 283                        balls)
 284
 285                       (XFlush x11-display)
 286
 287                       ;; slow down to about 30 frames per second
 288
 289                       (let ((timeout
 290                              (seconds->time
 291                               (+ 1/30
 292                                  (time->seconds start)))))
 293                         (let event-loop ()
 294                           (let ((ev (x11-event-get x11-event-queue timeout)))
 295                             (if ev
 296                                 (begin
 297                                   (pp (convert-XEvent ev))
 298                                   (event-loop))))))
 299
 300                       (loop (- n 1)))))
 301
 302               (for-each
 303                (lambda (b) (XFreeGC x11-display (ball-gc b)))
 304                balls)
 305
 306               (XFreeGC x11-display gc-text)))))))
 307
 308     (for-each
 309      thread-join!
 310      (list (create-window)
 311            (create-window)))
 312
 313     ;; Can't close display because closing the connection
 314     ;; causes the (##device-port-wait-for-input! x11-display-port)
 315     ;; to raise an os-exception (closed file descriptor).
 316     ;;
 317     ;; (XCloseDisplay x11-display)
 318     )
 319
 320   (##gc)
 321
 322   ;; For checking memory leaks on Mac OS X:
 323   #;
 324   (begin
 325     (shell-command (string-append "leaks " (number->string (##os-getpid))))
 326     (thread-sleep! 3))
 327 )