#! /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 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)))