#! /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       address@hidden


(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)))