Re: examples/tictactoe.scm

[Andy Wingo <wingo@pobox.com>]

[-- Attachment #1: Type: text/plain, Size: 813 bytes --]

On Sun, 15 Jun 2003, Marius Vollmer wrote:

> The tictactoe example didn't ever work.  I had a locally patched
> version of Gtk+ that had the necessary additions to the Gtk+ object
> model, but I couldn't convince the Gtk+ guys to include the patch.
> Thus, tictactoe will never work right with a stock Gtk+ 1.2.  Don't
> know about Gtk+ 2.0, though.

Just for the record, I've attached the current version of
tic-tac-toe.scm for guile-gobject. The version in the latest release
also works, but it's not as nice.

Speaking of which: Can I have cvs access to guile-gtk so I can put in
guile-gobject? My savannah username is "wingo".

I've also attached a copy of a sine source element for GStreamer, just
to show off the gstreamer bindings (in GStreamer cvs), that also depend
on guile-gobject.

Regards,

wingo.


[-- Attachment #2: sinesrc.scm --]
[-- Type: text/plain, Size: 6158 bytes --]

;;; Commentary:
;;
;; A reimplementation of GStreamer's sine src in scheme. It's slow slow
;; slow -- my PIII/600 laptop can't do it in realtime. This is really
;; just a proof of concept.
;;
;;; Code:

(define-module (examples gstreamer sinesrc)
  :use-module (gnome gstreamer)
  :use-module (gnome gobject primitives)
  :export (<scm-sinesrc>))

(read-set! keywords 'prefix) ;; :keywords rather than #:keywords

(define-gobject-class <scm-sinesrc> <gst-element> "scm-sinesrc")

(let-params <scm-sinesrc>
            ((sample-rate (<gparam-int>
                           :nick "Sample rate" :blurb "Sample rate"
                           :minimum 4000 :maximum 48000 :default-value 44100
                           :flags '(read write construct)))
             (table-size (<gparam-int>
                          :nick "Table size" :blurb "Size of wavetable"
                          :minimum 1 :maximum gruntime:int-max :default-value 1024
                          :flags '(read write construct)))
             (buffer-size (<gparam-int>
                           :nick "Buffer size" :blurb "Buffer size (frames)"
                           :minimum 1 :maximum gruntime:int-max :default-value 1024
                           :flags '(read write construct)))
             (frequency (<gparam-float>
                         :nick "Frequency" :blurb "Frequency of sine source"
                         :minimum 0.0 :maximum 20000.0 :default-value 440.0
                         :flags '(read write construct)))
             (volume (<gparam-float>
                      :nick "Volume" :blurb "Volume of sine source"
                      :minimum 0.0 :maximum 1.0 :default-value 0.8
                      :flags '(read write construct)))
             (src-pad #f)
             (timestamp #f)
             (wavetable #f)
             (new-caps? #f)
             (table-pos #f))

  ;; the defines need to come before the define-methods

  (define uv-set! uniform-vector-set!)
  (define uv-ref uniform-vector-ref)

  (define (populate-sinetable src)
    (let* ((tsize (table-size src))
           (t (make-uniform-vector tsize 1.0))
           (pi2scaled (/ (* 3.141592653589 2 ) tsize)))
      (let loop ((i 0))
        (uv-set! t i (sin (* i pi2scaled)))
        (if (eq? (1+ i) tsize)
            #t
            (loop (1+ i))))
      (set! (wavetable src) t)))
  
  (define (get-func pad)
    (let* ((this (get-parent pad))
           (data-len (buffer-size this))
           (data (make-uniform-vector data-len 's)) ;; a vector of shorts
           (buffer (gst-buffer-new))
           (table-size (table-size this))
           (wavetable (wavetable this))
           (volume (volume this))
           (table-step (* table-size (/ (frequency this) (sample-rate this)))))
;;      (set-timestamp buffer (timestamp this))
      (gst-buffer-set-data buffer data)
      
;;      (set! (timestamp this) (+ (timestamp this) (* data-len gst:second)))
      
      (let ((lookup 0) (lookup-next 0) (f 0.0))
        (do ((i 0 (1+ i))
             (pos (table-pos this) (+ pos table-step)))
            ((eq? i data-len) (set! (table-pos this) pos))
          (set! lookup (modulo (inexact->exact (floor pos)) table-size))
          (set! lookup-next (modulo (1+ lookup) table-size))
          (set! f (- pos (floor pos)))
          
          ;; linear interpolation
          (uv-set! data i (inexact->exact
                           (* (+ (* f (uv-ref wavetable lookup-next))
                                 (* (- 1 f) (uv-ref wavetable lookup)))
                              (* volume 32767))))))
      
      (if (new-caps? this)
          (let ((caps (gst-caps-new
                       "sinesrc-src" "audio/raw"
                       (gst-props-new
                        '("format" string-type "int")
                        '("channels" int-type 1)
                        `("rate" int-type ,(sample-rate this))
                        '("law" int-type 0)
                        `("endianness" int-type ,gruntime:byte-order)
                        '("signed" boolean-type #t)
                        '("depth" int-type 16)
                        '("width" int-type 16)))))
            (try-set-caps (src-pad this) caps)
            (set! (new-caps? this) #f)))
      
      buffer))
  
  (define-method (gobject:set-property (obj <scm-sinesrc>) (name <symbol>) value)
    (case name
      ((sample-rate)
       (set! (sample-rate obj) value)
       (set! (new-caps? obj) #t))
      ((table-size)
       (set! (table-size obj) value)
       (populate-sinetable obj))
      ((buffer-size)
       (set! (buffer-size obj) value))
      ((frequency)
       (set! (frequency obj) value))
      ((volume)
       (set! (volume obj) value))
      (else
       (error "Unknown property: " name))))

  (define-method (gobject:get-property (obj <scm-sinesrc>) (name <symbol>))
    (case name
      ((sample-rate) (sample-rate obj))
      ((table-size) (table-size obj))
      ((buffer-size) (buffer-size obj))
      ((frequency) (frequency obj))
      ((volume) (volume obj))
      (else (error "Unknown property: " name))))

  (define-method (gobject:instance-init (class <gst-element>) (obj <scm-sinesrc>))
    (let* ((templates (get-pad-templates <scm-sinesrc>))
           (src-template (get-pad-template templates "src"))
           (src (gst-pad-new-from-template src-template "src")))
      (set! (src-pad obj) src)
      (add-pad obj src)
      (set-get-function src get-func)
      
      ;; no dparams (yet), sorry...
      ;; wavetable will be populated on construction automagically

      (set! (table-pos obj) 0.0)
      (set! (timestamp obj) 0)))

  (add-pad-template
   <scm-sinesrc>
   (gst-pad-template-new
    "src" 'src 'always
    (gst-caps-new
     "sinesrc-src" "audio/raw"
     (gst-props-new
      '("format" string-type "int")
      '("channels" int-type 1)
      '("rate" int-range-type 8000 48000)
      '("law" int-type 0)
      `("endianness" int-type ,gruntime:byte-order)
      '("signed" boolean-type #t)
      '("depth" int-type 16)
      '("width" int-type 16)))))
  
  (register-new-element <scm-sinesrc> "scm-sinesrc"))

[-- Attachment #3: tic-tac-toe.scm --]
[-- Type: text/plain, Size: 4700 bytes --]

(read-set! keywords 'prefix)
(use-modules (gnome gtk) (gnome gobject primitives))

(define-gobject-class <tic-tac-toe> <gtk-vbox> "tic-tac-toe"
  ;; signals follow
  (tic-tac-toe #f))

;; there are many ways to define the class functionality; the let-params
;; way is (imho) the most flexible, so we use it here as an example. as
;; a way to demonstrate how to set object properties with equivalents on
;; the gobject side of things, we add a property to change the board
;; size.
;;
;; see examples/gobject/my-object.scm for more info on let-params.
(let-params <tic-tac-toe>
            ((board-size (<gparam-int> ; a gobject property and a
				       ; procedure-with-setter of the
				       ; same name
                          :minimum 2 :maximum 100 :default-value 3
                          :flags '(read write construct)))
             (table #f) ; a procedure-with-setter only -- with some
			; voodoo so that it sets to the gtype-instance,
			; not the gobject wrapper
             (buttons #f)
             (winning-combinations #f))
  (define (ttt-clear ttt)
    (let ((buttons (buttons ttt)))
      (do ((p 0 (1+ p)))
          ((>= p (vector-length buttons)))
        (set (vector-ref buttons p) 'active #f))))

  (define (ttt-toggle ttt)
    (let ((buttons (buttons ttt)))
      (let loop ((wins (winning-combinations ttt)))
        (cond ((not (null? wins))
               (cond ((and-map (lambda (wp) 
                                 (get (vector-ref buttons wp) 'active))
                               (car wins))
                      (emit ttt 'tic-tac-toe)
                      (ttt-clear ttt))
                     (else
                      (loop (cdr wins)))))))))

  (define (make-sequence len init step)
    (let loop ((i len) (val init))
      (if (eq? i 0)
          '()
          (cons val (loop (1- i) (+ val step))))))

  (define-method (gobject:set-property (ttt <tic-tac-toe>) (name <symbol>) value)
    (case name
      ((board-size)
       (if (table ttt) (destroy (table ttt)))
       (let ((t (gtk-table-new value value #f))
             (bvect (make-vector (* value value))))
         (do ((p 0 (1+ p)))
             ((>= p (vector-length bvect)))
           (let ((b (make <gtk-toggle-button>))
                 (i (quotient p value))
                 (j (remainder p value)))
             (vector-set! bvect p b)
             (attach-defaults t b i (1+ i) j (1+ j))
             (connect b 'toggled (lambda (unused-arg) (ttt-toggle ttt)))))
         (set! (winning-combinations ttt)
               (map (lambda (pair) (make-sequence value (car pair) (cadr pair)))
                    (cons*
                     ;; the diagonals
                     (list 0 (1+ value)) 
                     (list (1- value) (1- value))
                     (append
                      ;; the horizontals
                      (let loop ((i 0))
                        (if (eq? i value)
                            '()
                            (cons (list i value) (loop (1+ i)))))
                      ;; the verticals
                      (let loop ((i 0))
                        (if (eq? i (* value value))
                            '()
                            (cons (list i 1) (loop (+ i value)))))))))
         (set! (table ttt) t)
         (set! (buttons ttt) bvect)
         (pack-start-defaults ttt t)
         (show-all t))
       (set! (board-size ttt) value))
      (else (next-method))))

  (define-method (gobject:get-property (ttt <tic-tac-toe>) (name <symbol>))
    (case name
      ((board-size) (board-size ttt))
      (else (next-method))))

  (define-method (gobject:instance-init (class <gtk-vbox>) (ttt <tic-tac-toe>))
    (next-method)
    ;; setting the 'board-size property on ttt, which is done on
    ;; construction (due to the 'construct flag in the param's flags),
    ;; takes care of setting up widget internals. we don't actually do
    ;; anything here -- which is nice, that means the object has a
    ;; robust interface.
    ))

(let* ((w (make <gtk-window> :type 'toplevel :title "Tic tac toe"))
       (vbox (make <gtk-vbox>))
       (ttt (make <tic-tac-toe>))
       (adj (gtk-adjustment-new 3 2 100 1 1 1)) ;; not a gobject yet, argh
       (spin (make <gtk-spin-button>)))
  (set spin 'adjustment adj)
  (connect adj 'value-changed
           (lambda (a) (set ttt 'board-size (inexact->exact (get-value a)))))
  (set-default-size w 250 250)
  (add w vbox)
  (pack-start-defaults vbox ttt)
  (pack-start vbox spin #f #f 0)
  (show-all w)
  (g-timeout-add 100 (lambda () #t))
  (connect ttt 'tic-tac-toe (lambda (ttt) (display "Yay!\n")))
  (connect w 'delete-event (lambda (ttt e) (gtk-main-quit) #f)))

(gtk-main)