Hello Attached, some more examples.
Andy, could you kindly add them to git? Many thanks. Cheers, David
#! /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 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)))
#! /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) (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)))
#! /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) (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))))
