* guile-clutter - examples
2012-05-16 9:54 guile-clutter 1.10.0 released Andy Wingo
@ 2012-10-16 17:11 ` David Pirotte
0 siblings, 0 replies; 2+ messages in thread
From: David Pirotte @ 2012-10-16 17:11 UTC (permalink / raw)
To: Andy Wingo; +Cc: guile-user, guile-gtk-general
[-- 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
^ permalink raw reply [flat|nested] 2+ messages in thread