guile-clutter 1.10.0 released

guile-clutter 1.10.0 released

[Andy Wingo]

Good news, everyone!

Guile-Clutter 1.10.0 is out!

Get it here:

  http://ftp.gnu.org/gnu/guile-gnome/guile-clutter/guile-clutter-1.10.0.tar.gz

Guile-Clutter is a Guile wrapper for the Clutter library.  It lets you
create reactive, modern graphical interfaces from the Scheme language.

This release is the first of the 1.x series.  It wraps all of Clutter.
However, since there was no binding for Clutter 1.8 or before, we took
advantage of the opportunity to omit functionality that has been
deprecated within the 1.x series.

Guile-Clutter is almost entirely documented in Texinfo, generated from
the upstream Docbook documentation, automatically adapted to the actual
names and interfaces that Guile-Clutter exposes.  This has the advantage
of completeness and correctness, though it's still pretty obvious that
this is generated documentation.  Check it out here:

  http://www.gnu.org/software/guile-gnome/docs/clutter/

Learn more about Guile and Clutter here:

  http://www.gnu.org/software/guile/
  http://www.clutter-project.org/

Guile-Clutter depends on the Guile bindings for GLib, GObject, ATK,
Cairo, and Pango.  These can be found, among others, in the
guile-gnome-platform 2.16.2 release.  For more details:

  http://www.gnu.org/software/guile-gnome/

Thanks to David Pirotte for his support in making this work possible.

Regards,

Andy
-- 
http://wingolog.org/

guile-clutter - examples

[David Pirotte]

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

Hello

Attached, some more examples.

Andy, could you kindly add them to git? Many thanks.

Cheers,
David

[-- Attachment #2: bouncer.scm --]
[-- Type: text/x-scheme, Size: 7904 bytes --]

#! /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       gnu@gnu.org


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


(define get-current-easing-mode #f)
(define get-next-easing-mode #f)

(eval-when (compile load eval)
  (let* ((i 0)
	 (easing-modes '( ;; /* linear */
			 linear
			 ;; /* quadratic */
			 ease-in-quad
			 ease-out-quad
			 ease-in-out-quad
			 ;; /* cubic */
			 ease-in-cubic
			 ease-out-cubic
			 ease-in-out-cubic
			 ;; /* quartic */
			 ease-in-quart
			 ease-out-quart
			 ease-in-out-quart
			 ;; /* quintic */
			 ease-in-quint
			 ease-out-quint
			 ease-in-out-quint
			 ;; /* sinusoidal */
			 ease-in-sine
			 ease-out-sine
			 ease-in-out-sine
			 ;; /* exponential */
			 ease-in-expo
			 ease-out-expo
			 ease-in-out-expo
			 ;; /* circular */
			 ease-in-circ
			 ease-out-circ
			 ease-in-out-circ
			 ;; /* elastic */
			 ease-in-elastic
			 ease-out-elastic
			 ease-in-out-elastic
			 ;; /* overshooting cubic */
			 ease-in-back
			 ease-out-back
			 ease-in-out-back
			 ;; /* exponentially decaying parabolic */
			 ease-in-bounce
			 ease-out-bounce
			 ease-in-out-bounce))
	 (its-length (length easing-modes)))
    (set! get-current-easing-mode
	  (lambda ()
		 (list-ref easing-modes i)))
    (set! get-next-easing-mode
	  (lambda ()
	    (set! i (if (= i (1- its-length)) 0 (1+ i)))
	    (list-ref easing-modes i)))))

(define pi (acos -1))

(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 (make-rectangle w h color)
  (make <clutter-actor>
    #:background-color color
    #:width w
    #:height h))

(define* (make-label text font color #:optional markup?)
  (let ((l (make <clutter-text>
	     #:font-name font
	     #:text text
	     #:color color)))
    (when markup? (set-use-markup l #t))
    (receive (w h)
	(get-size l)
      (values l w h))))

(define (get-char-width font . char)
  (get-width (make <clutter-text> #:font-name font
		   #:text (if (null? char) "a" (string (car char))))))

(define (show-title text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let ((r (make-rectangle (+ w 20) 2 (get-colour "Chocolate"))))
	;; (pk w h (* h 2/3))
	(set-position l (/ (- sw w) 2) (* h 2/3))
	(add-child stage l)
	(set-position r (/ (- sw w 20) 2) (+ h (* h 2/3) 4))
	(add-child stage r)))))

(define (show-footer text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let* ((rh (+ h (* 2/3 h)))
	     (r (make-rectangle sw rh (get-colour "Black"))))
	(set-position r 0 (- sh rh))
	(set-opacity r 180)
	(add-child stage r)
	(set-position l (/ (- sw w) 2) (- sh h (* h 1/3)))
	(add-child stage l)))))

(define* (show-help-message text font color stage #:optional (boxed? #f))
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color 'use-markup)
      (if boxed?
	  (let* ((pw (+ w 8))
		 (ph (+ h 8))
		 (parent (make-rectangle pw ph '(#x3c #x3c #x3c #xdd)))
		 (layout (clutter-box-layout-new)))
	    (set-spacing layout 4)
	    (set-homogeneous layout #t)
	    (set-layout-manager parent layout)
	    (add-child parent l)
	    (set-position parent (- sw pw 8) (- sh ph ph))
	    (add-child stage parent))
	  (begin
	    (set-position l (- sw w h) (- sh h h 8))
	    (add-child stage l)))
      (values l w h))))

(define (draw-bouncer canvas cr w h)
  (cairo-set-operator cr 'clear)
  (cairo-paint cr)
  (cairo-set-operator cr 'over)
  (let* ((radius (max w h))
	 (radius/2 (/ radius 2))
	 (color (get-colour #;"DarkScarletRed" "Green3" #;"DarkOliveGreen3"))
	 (red (/ (car color) 255))
	 (green (/ (cadr color) 255))
	 (blue (/ (caddr color) 255))
	 (alpha (/ (cadddr color) 255))
	 (pattern (cairo-pattern-create-radial radius/2 radius/2 0 radius radius radius)))
    ;; (cairo-set-source-rgba cr red green blue alpha)
    (cairo-arc cr radius/2 radius/2 radius/2 0 (* 2 pi))
    (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 cr pattern)
    (cairo-fill-preserve cr)))

(define (make-bouncer w h x y stage)
  (let* ((canvas (make <clutter-canvas> #:width w #:height h))
         (bouncer (make <clutter-actor>
		    #:width w #:height h #:x x #:y y
		    #:content canvas)))
    (connect canvas 'draw
             (lambda (canvas cr w h)
               ;; use the cr here
               ;; no need to cairo-destroy
	       ;; (pk "drawing the bouncer" canvas cr w h)
	       (draw-bouncer canvas cr w h)
	       #t)) ;; stops the event to be propagated
    (set-name bouncer "bouncer")
    (set-anchor-point bouncer (/ w 2) (/ h 2))
    (set-position bouncer x y)
    (set-reactive bouncer #t)
    (add-child stage bouncer)
    (invalidate canvas)
    bouncer))

(define *help-message*
  "Easing mode: <span foreground=\"LightSkyBlue\">~A</span>
Left click to tween
Right click to change the easing mode")

(define (get-help-message)
  (format #f "~?" *help-message* (list (get-current-easing-mode))))

(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 50 50 300 200 stage)))
    (show-title "Bouncer example" "Mono 22" (get-colour "BurlyWood") stage)
    (show-footer "this is guile-clutter, a direct binding of the clutter library for the guile language"
		 "Mono 9" (get-colour "green") stage)
    (receive (l w h)
	(show-help-message (get-help-message) "Dejavu Sans 9" (get-colour "Gainsboro") stage)
      (connect stage
	       'button-press-event
	       (lambda (s e)
		 (case (get-button e)
		   ((1 2)
		    (receive (x y)
			(get-coords e)
		      ;; (pk "button pressed @ x y: " x y)
		      ;; (pk "flags: " (gflags->symbol-list (get-flags e)))
		      (save-easing-state bouncer)
		      (set-easing-duration bouncer 1000)
		      (set-easing-mode bouncer (get-current-easing-mode))
		      (set-position bouncer x y)
		      (restore-easing-state bouncer)))
		   ((3)
		    (get-next-easing-mode)
		    (set-markup l (format #f "~?" *help-message* (list (get-current-easing-mode))))))
		 #t))) ;; stops the event to be propagated
    (show stage)
    (g-main-loop-run loop)
    (exit 0)))

[-- Attachment #3: drag-action.scm --]
[-- Type: text/x-scheme, Size: 4798 bytes --]

#! /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       gnu@gnu.org


(use-modules (ice-9 receive)
	     (gnome-2)
             (srfi srfi-11)
             (oop goops)
             (gnome gobject)
             (gnome glib)
             (gnome clutter))

(define (get-colour name) (clutter-color-from-string name))

(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 (make-rectangle w h color)
  (make <clutter-actor>
    #:background-color color
    #:width w
    #:height h))

(define (show-active-rectangle w h color stage)
  (receive (sw sh)
      (get-size stage)
    (let ((r (make-rectangle w h color))
	  (r2 (make-rectangle w h (get-colour "Maroon")))
	  (d (clutter-drag-action-new)))
      (set-opacity r2 120)
      (set-position r (/ (- sw w) 2) (/ (- sh h) 2))
      (set-reactive r #t)
      (connect r
	       'enter-event
	       (lambda (a e)
		 (save-easing-state a)
		 (set-opacity a 120)
		 (restore-easing-state a)
		 #f)) ;; yes, please propagate the event
      (connect r
	       'leave-event
	       (lambda (a e)
		 (save-easing-state a)
		 (set-opacity a 255)
		 (restore-easing-state a)
		 #f)) ;; yes, please propagate the event
      (connect d
	       'drag-begin
	       (lambda (d r event-x event-y modifiers)
		 ;; (pk d r event-x event-y modifiers)
		 (if (memq 'shift-mask (gflags->symbol-list modifiers))
		     (receive (x y)
			 (get-position r)
		       (set-position r2 x y)
		       (add-child stage r2)
		       (set-drag-handle d r2))
		     (set-drag-handle d r))))
      (connect d
	       'drag-end
	       (lambda (d r event-x event-y modifiers) 
		 ;; (pk d r event-x event-y modifiers)
		 (if (eq? (get-drag-handle d) r2)
		     (receive (x y)
			 (get-position r2)
		       (save-easing-state r)
		       (set-position r x y)
		       (restore-easing-state r)
		       (destroy r2)))))
      (add-action r d)
      (add-child stage r))))

(define (make-label text font color)
  (let ((l (make <clutter-text>
	     #:font-name font
	     #:text text
	     #:color color)))
    (receive (w h)
	(get-size l)
      (values l w h))))

(define (get-char-width font . char)
  (get-width (make <clutter-text> #:font-name font
		   #:text (if (null? char) "a" (string (car char))))))

(define (show-title text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let ((r (make-rectangle (+ w 20) 2 (get-colour "Chocolate"))))
	;; (pk w h (* h 2/3))
	(set-position l (/ (- sw w) 2) (* h 2/3))
	(add-child stage l)
	(set-position r (/ (- sw w 20) 2) (+ h (* h 2/3) 4))
	(add-child stage r)))))

(define (show-footer text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let* ((rh (+ h (* 2/3 h)))
	     (r (make-rectangle sw rh (get-colour "Black"))))
	(set-position r 0 (- sh rh))
	(set-opacity r 180)
	(add-child stage r)
	(set-position l (/ (- sw w) 2) (- sh h (* h 1/3)))
	(add-child stage l)))))

(define (main args)
  (let* ((loop (g-main-loop-new))
	 (bg (get-colour "DarkSlateGrey"))
	 (stage (prep-stage 600 400 bg "Drag action" loop)))
    (show-title "Drag action example" "Mono 22" (get-colour "BurlyWood") stage)
    (show-footer "this is guile-clutter, a direct binding of the clutter library for the guile language"
		 "Mono 9" (get-colour "green") stage)
    (show-active-rectangle 128 128 (get-colour "DarkBlue") stage)
    (show stage)
    (g-main-loop-run loop)
    (exit 0)))

[-- Attachment #4: drop-action.scm --]
[-- Type: text/x-scheme, Size: 7373 bytes --]

#! /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       gnu@gnu.org


(use-modules (ice-9 receive)
	     (gnome-2)
             (srfi srfi-11)
             (oop goops)
             (gnome gobject)
             (gnome glib)
             (gnome clutter))

(define set-drop #f)
(define get-drop #f)

(eval-when (compile load eval)
  (let ((drop-value #f))
    (set! set-drop
	  (lambda (value) (set! drop-value value)))
    (set! get-drop
	  (lambda ()
	    (if drop-value
		(values (car drop-value) (cadr drop-value) (caddr drop-value))
		(values #f #f #f))))))

(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 (make-rectangle w h color)
  (make <clutter-actor>
    #:background-color color
    #:width w
    #:height h))

(define (make-label text font color)
  (let ((l (make <clutter-text>
	     #:font-name font
	     #:text text
	     #:color color)))
    (receive (w h)
	(get-size l)
      (values l w h))))

(define (get-char-width font . char)
  (get-width (make <clutter-text> #:font-name font
		   #:text (if (null? char) "a" (string (car char))))))

(define (show-title text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let ((r (make-rectangle (+ w 20) 2 (get-colour "Chocolate"))))
	;; (pk w h (* h 2/3))
	(set-position l (/ (- sw w) 2) (* h 2/3))
	(add-child stage l)
	(set-position r (/ (- sw w 20) 2) (+ h (* h 2/3) 4))
	(add-child stage r)))))

(define (show-footer text font color stage)
  (receive (sw sh)
      (get-size stage)
    (receive (l w h)
	(make-label text font color)
      (let* ((rh (+ h (* 2/3 h)))
	     (r (make-rectangle sw rh (get-colour "Black"))))
	(set-position r 0 (- sh rh))
	(set-opacity r 180)
	(add-child stage r)
	(set-position l (/ (- sw w) 2) (- sh h (* h 1/3)))
	(add-child stage l)))))

(define (transpose actor x y tx ty spacing)
  ;; x, y are relative to the actor's parent, tx, ty are the target
  ;; pos in the stage. in this drop example case, y remains unchanged.
  (if (< x 0)
      (receive (px py)
	  (get-position (get-parent actor))
	;; (pk x y  (+ px x -10) y)
	(values (+ px x (- spacing)) y))
      (begin
	;; (pk x y (- (+ x 10) tx) y)
	(values (- (+ x spacing) tx) y))))

(define (add-drag-object w h color target stage spacing)
  (receive (tw th)
      (get-size target)
    (let ((r (make-rectangle w h color))
	  (d (clutter-drag-action-new)))
      (set-opacity r 128)
      (set-position r (/ (- tw w) 2) (/ (- th h) 2))  ;; relative
      (set-reactive r #t)
      (connect r
	       'enter-event
	       (lambda (a e)
		 (save-easing-state a)
		 (set-opacity a 255)
		 (restore-easing-state a)
		 #f)) ;; yes, please propagate the event
      (connect r
	       'leave-event
	       (lambda (a e)
		 (save-easing-state a)
		 (set-opacity a 128)
		 (restore-easing-state a)
		 #f)) ;; yes, please propagate the event
      (connect d
	       'drag-begin
	       (lambda (d a event-x event-y modifiers)
		 ;; (pk "drag-begin, d " d " a: " a)
		 (set-drop #f)
		 (set-drag-handle d r)))
      (connect d
	       'drag-end
	       (lambda (d a event-x event-y modifiers)
		 (let ((parent (get-parent a)))
		   (receive (drop-t drop-x drop-y)
		       (get-drop)
		     (receive (x y)
			 (get-position a)
		       ;; (pk "drag-end, x:" event-x " y: " event-y " x: " x " y: " y)
		       (if (and drop-t
				(not (eq? drop-t parent)))
			   (receive (tx ty)
			       (get-position drop-t)
			     (receive (trans-x trans-y)
				 (transpose a x y tx ty spacing)
			       (remove-child parent a)
			       (add-child drop-t a)
			       (set-position a trans-x trans-y))
			     (save-easing-state a)
			     (set-position a (/ (- tw w) 2) (/ (- th h) 2))
			     (restore-easing-state a)
			     (save-easing-state drop-t)
			     (set-opacity drop-t 64)
			     (restore-easing-state drop-t))
			   (begin
			     (save-easing-state a)
			     (set-position a (/ (- tw w) 2) (/ (- th h) 2))
			     (restore-easing-state a)
			     (save-easing-state parent)
			     (set-opacity parent 64)
			     (restore-easing-state parent))))))))
      (add-action r d)
      (add-child target r)
      r)))

(define (show-box x y w h color stage . constraint?)
  (let ((b (make-rectangle w h color)))
    (set-position b x y)
    (set-opacity b 64)
    (unless (null? constraint?)
      (let ((d (clutter-drop-action-new)))
	(set-reactive b #t)	
	(add-constraint b (clutter-align-constraint-new stage (car constraint?) (cadr constraint?)))
	(connect d
		 'over-in
		 (lambda (action actor)
		   ;(pk "over-in" action actor)
		   (save-easing-state actor)
		   (set-opacity actor 128)
		   (restore-easing-state actor)))
	(connect d
		 'over-out
		 (lambda (action actor)
		   ;(pk "over-out" action actor)
		   (save-easing-state actor)
		   (set-opacity actor 64)
		   (restore-easing-state actor)))
	(connect d
		 'drop
		 (lambda (action actor x y)
		   ;(pk "drop" action actor x y)
		   (set-drop `(,actor ,x ,y))))
	(add-action b d)))
    (add-child stage b)
    b))

(define (main args)
  (let* ((loop (g-main-loop-new))
	 (bg (get-colour "DarkSlateGrey"))
	 (sw 600)
	 (sh 400)
	 (spacing 10)
	 (bw (/ (- sw (* spacing 4)) 3))
	 (by (- (/ sh 2) (/ bw 2)))
	 (ow (- bw 60))
	 (oh ow)
	 (stage (prep-stage sw sh bg "Drop action" loop)))
    (show-title "Drop action example" "Mono 22" (get-colour "BurlyWood") stage)
    (show-footer "this is guile-clutter, a direct binding of the clutter library for the guile language"
		 "Mono 9" (get-colour "green") stage)
    (let* ((target1 (show-box 10 by bw bw (get-colour "DarkRed") stage 'y-axis 0.5))
	   (box (show-box (+ 20 bw) by bw bw (get-colour "Orange") stage))
	   (target2 (show-box (+ 30 bw bw) by bw bw (get-colour "DarkMagenta") stage 'y-axis 0.5))
	   (drag-obj (add-drag-object ow oh (get-colour "PowderBlue") target1 stage spacing)))
      (show stage)
      (g-main-loop-run loop)
      (exit 0))))

[-- Attachment #5: Type: text/plain, Size: 162 bytes --]

_______________________________________________
guile-gtk-general mailing list
guile-gtk-general@gnu.org
https://lists.gnu.org/mailman/listinfo/guile-gtk-general