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