From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: David Pirotte Newsgroups: gmane.lisp.guile.gtk,gmane.lisp.guile.user Subject: guile-clutter - examples Date: Tue, 16 Oct 2012 14:11:42 -0300 Message-ID: <20121016141142.726a2a5c@capac> References: <873970jvri.fsf@pobox.com> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="MP_/x9ELKoTyPO1Qua19veFHd+=" X-Trace: ger.gmane.org 1350407559 22798 80.91.229.3 (16 Oct 2012 17:12:39 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Tue, 16 Oct 2012 17:12:39 +0000 (UTC) Cc: guile-user , guile-gtk-general To: Andy Wingo Original-X-From: guile-gtk-general-bounces+glgg-guile-gtk-general=m.gmane.org@gnu.org Tue Oct 16 19:12:46 2012 Return-path: Envelope-to: glgg-guile-gtk-general@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1TOAh6-0006Nd-VZ for glgg-guile-gtk-general@m.gmane.org; Tue, 16 Oct 2012 19:12:41 +0200 Original-Received: from localhost ([::1]:47639 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TOAgz-0007y3-Oz for glgg-guile-gtk-general@m.gmane.org; Tue, 16 Oct 2012 13:12:33 -0400 Original-Received: from eggs.gnu.org ([208.118.235.92]:47553) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TOAgo-0007x0-43 for guile-gtk-general@gnu.org; Tue, 16 Oct 2012 13:12:32 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1TOAgi-0007Q7-5R for guile-gtk-general@gnu.org; Tue, 16 Oct 2012 13:12:22 -0400 Original-Received: from maximusconfessor.all2all.org ([62.58.108.13]:52441) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1TOAgh-0007N4-OH; Tue, 16 Oct 2012 13:12:16 -0400 Original-Received: from localhost (unknown [192.168.0.2]) by maximusconfessor.all2all.org (Postfix) with ESMTP id 5642BA04C0E7; Tue, 16 Oct 2012 19:11:54 +0200 (CEST) Original-Received: from maximusconfessor.all2all.org ([192.168.0.1]) by localhost (maximusconfessor.all2all.org [192.168.0.2]) (amavisd-new, port 10024) with ESMTP id TcfC6Ml5Q2Zv; Tue, 16 Oct 2012 18:43:52 +0200 (CEST) Original-Received: from capac (unknown [139.82.89.157]) by maximusconfessor.all2all.org (Postfix) with ESMTPSA id 2EA7DA04C0D3; Tue, 16 Oct 2012 19:11:44 +0200 (CEST) In-Reply-To: <873970jvri.fsf@pobox.com> X-Mailer: Claws Mail 3.8.1 (GTK+ 2.24.10; x86_64-pc-linux-gnu) X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.6 (newer, 3) X-Received-From: 62.58.108.13 X-BeenThere: guile-gtk-general@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: General discussions about guile-gtk List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-gtk-general-bounces+glgg-guile-gtk-general=m.gmane.org@gnu.org Original-Sender: guile-gtk-general-bounces+glgg-guile-gtk-general=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.gtk:1046 gmane.lisp.guile.user:9620 Archived-At: --MP_/x9ELKoTyPO1Qua19veFHd+= Content-Type: text/plain; charset=US-ASCII Content-Transfer-Encoding: 7bit Content-Disposition: inline Hello Attached, some more examples. Andy, could you kindly add them to git? Many thanks. Cheers, David --MP_/x9ELKoTyPO1Qua19veFHd+= Content-Type: text/x-scheme Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=bouncer.scm #! /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 #:background-color color #:width w #:height h)) (define* (make-label text font color #:optional markup?) (let ((l (make #: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 #: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 #:width w #:height h)) (bouncer (make #: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: ~A 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))) --MP_/x9ELKoTyPO1Qua19veFHd+= Content-Type: text/x-scheme Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=drag-action.scm #! /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 #: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 #: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 #: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))) --MP_/x9ELKoTyPO1Qua19veFHd+= Content-Type: text/x-scheme Content-Transfer-Encoding: 7bit Content-Disposition: attachment; filename=drop-action.scm #! /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 #:background-color color #:width w #:height h)) (define (make-label text font color) (let ((l (make #: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 #: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)))) --MP_/x9ELKoTyPO1Qua19veFHd+= Content-Type: text/plain; charset="us-ascii" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Disposition: inline _______________________________________________ guile-gtk-general mailing list guile-gtk-general@gnu.org https://lists.gnu.org/mailman/listinfo/guile-gtk-general --MP_/x9ELKoTyPO1Qua19veFHd+=--