Re: guile-clutter - prelim work - patch 1,3,4 out of 4

#! /bin/sh
# -*- scheme -*-
exec guile -e main -s $0 "$@"
!#
;; guile-gnome
;; Copyright (C) 2008, 2012 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or    
;; modify it under the terms of the GNU General Public License as   
;; published by the Free Software Foundation; either version 2 of   
;; the License, or (at your option) any later version.              
;;                                                                  
;; This program is distributed in the hope that it will be useful,  
;; but WITHOUT ANY WARRANTY; without even the implied warranty of   
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the    
;; GNU General Public License for more details.                     
;;                                                                  
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, contact:
;;
;; Free Software Foundation           Voice:  +1-617-542-5942
;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
;; Boston, MA  02111-1307,  USA       [email protected]


(use-modules (ice-9 receive)
	     (system foreign)
	     (gnome-2)
             (oop goops)
	     (cairo)
             (gnome gobject)
             (gnome glib)
             (gnome clutter))

(define pi (acos -1))

(define libguile-gnome-gobject-2 (dynamic-link "libguile-gnome-gobject-2"))
(define libguile-cairo (dynamic-link "libguile-cairo"))

(define scm-c-gvalue-peek-boxed
  (pointer->procedure 
   '*
   (dynamic-func "scm_c_gvalue_peek_boxed" libguile-gnome-gobject-2)
   (list '*)))

(define scm-from-cairo
  (pointer->procedure 
   '*
   (dynamic-func "scm_from_cairo" libguile-cairo)
   (list '*)))

(define (fix-cairo x)
  (pointer->scm (scm-from-cairo (scm-c-gvalue-peek-boxed (scm->pointer x)))))

(define (get-colour name)
  (or (clutter-color-from-string name)
      (begin
	(pk "Warning! undefined color " name)
	'(#xff #xcc #xcc #xdd))))

(define (prep-stage w h bg title loop)
  (let ((stage  (clutter-stage-new)))
    (set-background-color stage bg)
    (set-size stage w h)
    (set-title stage title)
    (connect stage
	     'delete-event
	     (lambda (. args)
	       (g-main-loop-quit loop)
	       #t)) ;; stops the event to be propagated
    stage))

(define (draw-bouncer cairo-t cairo-cbf) ;; cairo-context-before-fix
  (clear cairo-t)
  (receive (w h)
      (clutter-cairo-texture-get-surface-size cairo-t)
    (let* ((cairo-c (fix-cairo cairo-cbf))
	   (radius (max w h))
	   (radius/2 (/ radius 2))
	   (dummy (cairo-arc cairo-c radius/2 radius/2 radius/2 0 (* 2 pi)))
	   (pattern (cairo-pattern-create-radial radius/2 radius/2 0 radius radius radius))
	   (color (get-colour "Bisque4"))
	   (red (/ (car color) 255))
	   (green (/ (cadr color) 255))
	   (blue (/ (caddr color) 255))
	   (alpha (/ (cadddr color) 255)))
      ;; (pk w h radius)
      (cairo-pattern-add-color-stop-rgba pattern 0 red green blue alpha)
      (cairo-pattern-add-color-stop-rgba pattern 0.85 red green blue 0.25)
      ;; (cairo-set-source-rgba cairo-c red green blue alpha)
      (cairo-set-source cairo-c pattern)
      (cairo-fill-preserve cairo-c))))

(define (make-bouncer w h x y stage)
  (let ((b (clutter-cairo-texture-new w h)))
    (connect b
	     'draw
	     (lambda (cairo-t cairo-c)
	       (pk "drawing the bouncer" cairo-t cairo-c)
	       (draw-bouncer cairo-t cairo-c)
	       #t)) ;; stops the event to be propagated
    (set-name b "bouncer")
    (set-size b w h) ;; c code does that, but is it not done above ?
    (set-anchor-point b (/ w 2) (/ h 2))
    (set-position b x y)
    (set-reactive b #t)
    (add-child stage b)
    (invalidate b) ;; <- drawing the bouncer immediately
    b))

(define (main args)
  (let* ((loop (g-main-loop-new))
	 (bg '(#x3c #x3c #x3c #xdd))
	 (sw 600)
	 (sh 400)
	 (stage (prep-stage sw sh bg "Bouncer" loop))
	 (bouncer (make-bouncer 75 75 200 200 stage)))
    (connect stage
	     'button-press-event
	     (lambda (s e) 
	       (receive (x y)
		   (get-coords e)
		 ;; (pk "button pressed @ x y: " x y)
		 (save-easing-state bouncer)
		 (set-position bouncer x y)
		 (restore-easing-state bouncer))
	       #t)) ;; stops the event to be propagated
    (show stage)
    (g-main-loop-run loop)
    (exit 0)))