;; aquax-window.scm --- MacOS X Aqua window decoration
;;
;; Author: Anders Holst  (aho@sics.se) 
;; Copyright (C) 2002  Anders Holst
;;
;; --------------------------------------------------------------------- 
;;
;; Approximative MacOS X Aqua decoration, pixmaps and layout stolen
;; directly from a Sawmill theme.
;;
;; Usage: (set-window #t aquax-window)
;; 

(define (aquax-plug-behavior action when)
  (make-behavior (on (enter)
                     (if (get-property (top-deco deco) 'active)
                         (set-deco-part! deco 1 (get-property deco 'pah))
                         (set-deco-part! deco 1 (get-property deco 'pih))))
                 (on (leave)
                     (if (get-property (top-deco deco) 'active)
                         (set-deco-part! deco 1 (get-property deco 'pa))
                         (set-deco-part! deco 1 (get-property deco 'pi))))
                 (on (user-event 'focus-in)
                     (set-deco-part! deco 1 (get-property deco 'pa)))
                 (on (user-event 'focus-out)
                     (set-deco-part! deco 1 (get-property deco 'pi)))
                 (on-event (button any any)
                           (if (eq? when 'release)
                               (lambda (deco event)
                                 (if (get-property (top-deco deco) 'active)
                                     (set-deco-part! deco 1 (get-property deco 'pac))
                                     (set-deco-part! deco 1 (get-property deco 'pic))))
                               (lambda (deco event)
                                 (if (get-property (top-deco deco) 'active)
                                     (set-deco-part! deco 1 (get-property deco 'pac))
                                     (set-deco-part! deco 1 (get-property deco 'pic)))
                                 (action (top-deco deco) event)))
                           (if (eq? when 'release)
                               (lambda (deco event)
                                 (let ((x (event-relative-x event))
                                       (y (event-relative-y event)))
                                   (if (get-property (top-deco deco) 'active)
                                       (set-deco-part! deco 1 (get-property deco 'pah))
                                       (set-deco-part! deco 1 (get-property deco 'pih)))
                                   (if (and (>= x 0)
                                            (< x (deco-width deco))
                                            (>= y 0)
                                            (< y (deco-height deco)))
                                       (action (top-deco deco) event))))
                               (lambda (deco event)
                                 (if (get-property (top-deco deco) 'active)
                                     (set-deco-part! deco 1 (get-property deco 'pah))
                                     (set-deco-part! deco 1 (get-property deco 'pih))))))))

(define (aquax-corner-behavior)
  (make-behavior (on (user-event 'focus-in)
                     (set-deco-part! deco 1 (get-property deco 'pa)))
                 (on (user-event 'focus-out)
                     (set-deco-part! deco 1 (get-property deco 'pi)))))

(define (aquax-back-behavior)
  (make-behavior (on (user-event 'focus-in)
                     (set-deco-background! deco (get-property deco 'pa)))
                 (on (user-event 'focus-out)
                     (set-deco-background! deco (get-property deco 'pi)))))

(define (aquax-window-behavior virtcoli virtcola)
  (make-behavior 
   (on (user-event 'focus-out)
       (set-property! deco 'virt-col virtcoli)
       (set-property! deco 'active #f)
       (if (defined? 'virtual-update)
           (virtual-update)))
   (on (user-event 'focus-in)
       (set-property! deco 'virt-col virtcola)
       (set-property! deco 'active #t)
       (if (defined? 'virtual-update)
           (virtual-update)))))

(define (aquax-make-plug action when pi pa pih pah pic pac)
  (make-deco pi
             :property `((pi . ,pi)
                         (pa . ,pa)
                         (pih . ,pih)
                         (pah . ,pah)
                         (pic . ,pic)
                         (pac . ,pac))
             :behavior (aquax-plug-behavior action when)
             :background (make-color 'transparent)))

(define (aquax-make-corner pix apix)
    (make-deco pix
               :property `((pi . ,pix)
                           (pa . ,apix))
               :behavior (aquax-corner-behavior)
               :background (make-color 'hole)))

(define (aquax-roundify pix)
  (draw-ellipse pix 2 3 15 17 :foreground (make-color 'transparent) :borderwidth 10)
  pix)

(define aquax-window
  (let ((ti (load-pixmap "aquax-window/title-inactive"))
        (ta (load-pixmap "aquax-window/title-active"))
        (tli (load-pixmap "aquax-window/title_l-inactive"))
        (tla (load-pixmap "aquax-window/title_l-active"))
        (tri (load-pixmap "aquax-window/title_r-inactive"))
        (tra (load-pixmap "aquax-window/title_r-active"))
        (bi (make-color "#2C4973"))
        (ba (make-color "#797979"))
        (vi (make-color "#99ADC8"))
        (va (make-color "#E6E6E6"))
        (bbi (load-pixmap "aquax-window/border_b-inactive"))
        (bba (load-pixmap "aquax-window/border_b-active"))
        (bbli (load-pixmap "aquax-window/border_bl-inactive"))
        (bbla (load-pixmap "aquax-window/border_bl-active"))
        (bbri (load-pixmap "aquax-window/border_br-inactive"))
        (bbra (load-pixmap "aquax-window/border_br-active"))
        (button (aquax-roundify (load-pixmap "aquax-window/button-inactive")))
        (close-a (aquax-roundify (load-pixmap "aquax-window/close-active")))
        (close-c (aquax-roundify (load-pixmap "aquax-window/close-clicked")))
        (close-h (aquax-roundify (load-pixmap "aquax-window/close-highlight")))
        (close-ic (aquax-roundify (load-pixmap "aquax-window/close-inactive-clicked")))
        (close-ih (aquax-roundify (load-pixmap "aquax-window/close-inactive-highlight")))
        (icon-a (aquax-roundify (load-pixmap "aquax-window/iconify-active")))
        (icon-c (aquax-roundify (load-pixmap "aquax-window/iconify-clicked")))
        (icon-h (aquax-roundify (load-pixmap "aquax-window/iconify-highlight")))
        (icon-ic (aquax-roundify (load-pixmap "aquax-window/iconify-inactive-clicked")))
        (icon-ih (aquax-roundify (load-pixmap "aquax-window/iconify-inactive-highlight")))
        (maxi-a (aquax-roundify (load-pixmap "aquax-window/maximize-active")))
        (maxi-c (aquax-roundify (load-pixmap "aquax-window/maximize-clicked")))
        (maxi-h (aquax-roundify (load-pixmap "aquax-window/maximize-highlight")))
        (maxi-ic (aquax-roundify (load-pixmap "aquax-window/maximize-inactive-clicked")))
        (maxi-ih (aquax-roundify (load-pixmap "aquax-window/maximize-inactive-highlight")))
        (one-a (aquax-roundify (load-pixmap "aquax-window/one_window-focused-inactive")))
        (one-c (aquax-roundify (load-pixmap "aquax-window/one_window-clicked")))
        (one-h (aquax-roundify (load-pixmap "aquax-window/one_window-highlight")))
        (one-ic (aquax-roundify (load-pixmap "aquax-window/one_window-inactive-clicked")))
        (one-ih (aquax-roundify (load-pixmap "aquax-window/one_window-inactive-highlight")))
        (font (make-font "-*-helvetica-bold-r-normal-*-*-140-*-*-p-*-*")))
    (lambda (win)
      (make-deco (make-deco (aquax-make-corner tli tla)
                            (aquax-make-plug (lambda (w e) (or (delete-window w) (kill-window w))) 'release
                                             button close-a close-ih close-h close-ic close-c)
                            (aquax-make-plug (lambda (w e) (iconify-window w)) 'release
                                             button icon-a icon-ih icon-h icon-ic icon-c)
                            (aquax-make-plug (lambda (w e) (zoom-window w)) 'release
                                             button maxi-a maxi-ih maxi-h maxi-ic maxi-c)
                            (make-deco
                             '()
                             (make-label (window-name win)
                                         :font font
                                         :background (make-color 'transparent))
                             '() 
                             :background (make-color 'transparent)
                             :direction 'horizontal)
                            (aquax-make-plug (lambda (w e) (menu-pop (window-pop) w e)) 'press
                                             button one-a one-ih one-h one-ic one-c)
                            (aquax-make-corner tri tra)
                            :background ti
                            :property `((pi . ,ti) (pa . ,ta))
                            :behavior (aquax-back-behavior))
                 (make-deco (make-deco '() 
                                       :width 1 :background bi
                                       :property `((pi . ,bi) (pa . ,ba))
                                       :behavior (aquax-back-behavior))
                            win
                            (make-deco '() 
                                       :width 1 :background bi
                                       :property `((pi . ,bi) (pa . ,ba))
                                       :behavior (aquax-back-behavior)))
                 (make-deco (aquax-make-corner bbli bbla)
                            '()
                            (aquax-make-corner bbri bbra)
                            :background bbi
                            :property `((pi . ,bbi) (pa . ,bba))
                            :behavior (aquax-back-behavior))
                 :behavior (make-behavior window-behavior
                                          (aquax-window-behavior vi va)
                                          std-window-behavior)
                 :property `((active . #f)
                             (virt-col . ,vi))))))
