default.edc

collections {
  group {
    name: "modules/switch-window/popup";
    images {
      image: "vgrad_dark.png" COMP;
      image: "vgrad_light.png" COMP;
      image: "shelf_alt_over.png" COMP;
    }
    styles {
      style {
        name: "sw_style_normal";
        base: "font=Sans:style=Bold font_size=32 text_class=tb_plain align=center color=#444 wrap=word";
        tag: "br" "\n";
        tag: "hilight" "+ font=Sans:style=Bold text_class=tb_light";
      }
      style {
        name: "sw_style_selected";
        base: "font=Sans:style=Bold font_size=32 text_class=tb_plain align=center color=#fff style=soft_shadow shadow_color=#0000001f wrap=word";
        tag: "br" "\n";
        tag: "hilight" "+ font=Sans:style=Bold text_class=tb_light";
      }
    }
    parts {
      part {
        name: "base";
        mouse_events: 0;
        description {
          state: "default" 0.0;
          min: 48 48;
          image.normal: "vgrad_light.png";
          fill {
            size {
              relative: 0 1.0;
              offset: 36 0;
            }
          }
        }
      }
      part {
        name: "bg";
        mouse_events: 0;
        description {
          state: "default" 0.0;
          visible: 0;
          color: 255 255 255 0;
          rel1.to: "base";
          rel2 {
            to: "base";
            relative: 1.0 1.0;
          }
          image.normal: "vgrad_light.png";
        }
        description {
          state: "selected" 0.0;
          inherit: "default" 0.0;
          visible: 1;
          color: 255 255 255 255;
          rel2 {
            to: "base";
            relative: 1.0 1.0;
          }
          image.normal: "vgrad_dark.png";
        }
      }
      part {
        name: "over";
        mouse_events: 0;
        description {
          state: "default" 0.0;
          image {
            normal: "shelf_alt_over.png";
            border: 5 5 5 5;
            middle: 0;
          }
          fill.smooth: 0;
        }
      }
      part {
        name: "e.textblock.message";
        type: TEXTBLOCK;
        mouse_events: 0;
        scale: 1;
        description {
          state: "default" 0.0;
          rel1 {
            relative: 0.0 0.0;
            offset: 8 8;
          }
          rel2 {
            offset: -9 -9;
          }
          text {
            style: "sw_style_normal";
            min: 1 1;
            text: "J";
          }
        }
        description {
          state: "selected" 0.0;
          inherit: "default" 0.0;
          text {
            style: "sw_style_selected";
          }
        }
      }
    }
    programs {
      program {
        name: "sel";
        signal: "e,state,selected";
        source: "e";
        action: STATE_SET "selected" 0.0;
        //transition: LINEAR 0.2;
        target: "e.textblock.message";
        target: "bg";
      }
      program {
        name: "unsel";
        signal: "e,state,unselected";
        source: "e";
        action: STATE_SET "default" 0.0;
        //transition: LINEAR 0.05;
        target: "e.textblock.message";
        target: "bg";
      }
    }
  }
}

e.scm

(define-module egauche.e
  (use c-wrapper)
  (export e-load import-c-symbols)
  )
(select-module egauche.e)

(define-macro (import-c-symbols . syms)
  `(begin ,@(map (^s `(define-constant ,s (c-symbol ,s))) syms)))

(define-syntax e-load
  (syntax-rules ()
    ((_ eh)
     (let1 tmp eh
       (c-load tmp
               :cppflags-cmd "pkg-config enlightenment --cflags-only-I"
               :cflags-cmd   "pkg-config enlightenment --cflags-only-other"
               :libs-cmd     "pkg-config enlightenment --libs"
               :compiled-lib "elib")
       (e-extend!)))))

(define (e-extend!)
  (define %e-extend! (cut eval <> (find-module 'c-wrapper.c-ffi.sandbox)))

  (%e-extend!
   '(begin
      (use gauche.collection)
      (use gauche.sequence)
      (use util.match)

      (define-method call-with-iterator
          ((coll <c-ptr:c-struct:_Eina_List>) proc . args)
        (let ((len (eina_list_count coll))
              (i   (get-keyword :start args 0)))
          (proc (cut >= i len)
                (cut begin0 (eina_list_nth coll i) (inc! i)))))

      (define-method cast
          ((c-type <c-ptr-meta>) (seq <c-ptr:c-struct:_Eina_List>))
        seq)

      (define-method referencer ((_seq <c-ptr:c-struct:_Eina_List>))
        (^(o i . _args) (eina_list_nth o i)))

      (update! (~ <c-ptr:c-struct:_Eina_List> 'cpl)
               (^x (match-let1 (top obj . rest) (reverse x)
                     `(,@(reverse rest) ,<sequence> ,<collection> ,obj ,top))))
      )))

egauche.scm

;; switch-window.el-sh for enlightenment window manager.
;;
;; * Plaese add THIS directory to your GAUCHE_LAOD_PATH.
;; * Please configure your keybindings like this,
;;   http://www.flickr.com/photos/hchbaw/5070612615/
;; * Please build the edj file like this,
;;   % edje_cc -id /PATH-TO/e/data/themes/images/ default.edc
;; * Please adjust some code in this file! (search XXX in this file)
;;   I'm very sorry for the inconveniences.
(select-module user)

(define *shutdowns* '())

(define (shutdown)
  ;; module C code calls this proc by its name if any.
  (dolist (sh *shutdowns*)
    (guard (e (else (report-error e)))
      (sh))))

;; XXX: Please adjust
(use file.util)
(define *edj* (build-path (sys-getenv "HOME")
                          "c/experiment/egauche-scripts/data/default.edj"))

(use c-wrapper)
(use egauche.e)
;; XXX: Please adjust
(e-load (build-path (sys-getenv "HOME") "c/experiment/egauche/src/ew.h"))
(import-c-symbols
 <c-ptr:c-struct:_E_Border>
 <c-ptr:c-struct:_E_Container>
 <c-ptr:c-struct:_E_Zone>
 <c-ptr:c-struct:_Ecore_Event_Key>)

(use gauche.collection)
(use gauche.sequence)
(use srfi-13)
(use srfi-42)
(use util.match)

(define *input-window* #f)
(define *handlers* NULL)
(define *hints* #f)

(define (show) (%show (e_util_zone_current_get (e_manager_current_get))))

(define (%show zone)
  (define (add-handler! ev cb)
    (update! *handlers*
             (^x (eina_list_append
                  x (ecore_event_handler_add ev cb (make-null-ptr))))))
  (define (make-input-window z)
    (rlet1 w (ecore_x_window_input_new (~ z'container'win) 0 0 1 1)
      (ecore_x_window_show w)
      (e_grabinput_get w 0 w)))
  
  (set! *input-window* (make-input-window zone))
  (show-hints!)
  (add-handler! ECORE_EVENT_KEY_DOWN keydown))

(define (hide)
  (define (del-input-window!)
    (ecore_x_window_free *input-window*)
    (e_grabinput_release *input-window* *input-window*)
    (set! *input-window* #f))
  (define (del-handlers!)
    (for-each ecore_event_handler_del *handlers*)
    (dotimes (n (size-of *handlers*))
      (update! *handlers* (^x (eina_list_remove_list x x)))))

  (del-handlers!)
  (del-input-window!)
  (del-hints!))

(define (modifiers-set? evmod cmod) (not (zero? (logand evmod cmod))))

(define (keydown _data _type event)
  (let1 ev (cast <c-ptr:c-struct:_Ecore_Event_Key> event)
    (keydown1 (x->string (~ ev'key))
              ev
              (any (pa$ modifiers-set? (~ ev'modifiers))
                   (list ECORE_EVENT_MODIFIER_SHIFT
                         ECORE_EVENT_MODIFIER_CTRL
                         ECORE_EVENT_MODIFIER_ALT
                         ECORE_EVENT_MODIFIER_WIN)))
    ECORE_CALLBACK_PASS_ON))

(define keydown1
  (let1 keybuffer ""
    (^(str ev any-mod?)
      (cond ((string=? str "Escape")
             (hide)
             (set! keybuffer ""))
            ((and (modifiers-set? (~ ev'modifiers) ECORE_EVENT_MODIFIER_CTRL)
                  (string-ci=? str "u"))
             (set! keybuffer "")
             (for-each (^h (e_popup_show (~ h'popup))) *hints*))
            (any-mod?)
            (#t (let1 s (string-append keybuffer str)
                  (call-with-values
                    (cut partition
                         (^h (string-prefix-ci? s (~ h'label)))
                         *hints*)
                    (pa$ focus-maybe
                         (cut set! keybuffer "")
                         (cut set! keybuffer s))))
                #f)))))

(define (focus-maybe succ fail shows hides)
  (for-each (^h (e_popup_hide (~ h'popup))) hides)
  (match shows
    ((h) (begin (focus! h) (succ)))
    (else (fail))))

(define (focus! h)
  (let1 bd (~ h'bd)
    (ecore_x_pointer_warp (~ bd'zone'container'win)
                          (+ (~ bd'x) (truncate->exact (/. (~ bd'w) 2)))
                          (+ (~ bd'y) (truncate->exact (/. (~ bd'h) 2))))
    (e_border_raise bd)
    (e_border_focus_set bd 1 1)
    (hide)
    ))

(define-class <hint> ()
  ((label :init-keyword :label)
   (popup :init-keyword :popup)
   (bgobj :init-keyword :bgobj)
   (bd    :init-keyword :bd)))

(define (show-hint border labelstring) ;; TODO: nameit?
  (let ((w (make <Evas_Coord>))
        (h (make <Evas_Coord>)))
   (let* ((p (e_popup_new (~ border'zone) 0 0 1 1))
          (o (edje_object_add (~ p'evas))))
     (edje_object_file_set o *edj* "modules/switch-window/popup")
     (edje_object_part_text_set o "e.textblock.message" labelstring)
     (edje_object_size_min_calc o (ptr w) (ptr h))
     (evas_object_move o 0 0)
     (evas_object_resize o w h)
     (evas_object_show o)
     (e_popup_edje_bg_object_set p o)
     (e_popup_move_resize p
                          (+ (- (+ (~ border'x) (~ border'fx'x)) (~ p'zone'x))
                             (truncate->exact (/. (- (~ border'w) w) 2)))
                          (+ (- (+ (~ border'y) (~ border'fx'y)) (~ p'zone'y))
                             (truncate->exact (/. (- (~ border'h) h) 2)))
                          w
                          h)
     (e_popup_show p)
     (edje_object_signal_emit o "e,state,selected" "e")
     (make <hint> :label labelstring :popup p :bgobj o :bd border))))

(define (del-hint h)
  (match-let1 (@ <hint> (popup p) (bgobj o)) h
    (edje_object_signal_emit o "e,state,unselected" "e")
    (e_popup_hide p)
    (evas_object_del o)
    (e_object_del (E_OBJECT p))))

(define *labels* '(#\A #\O #\E #\U #\I))

(define (n->label n labels)
  (define xchar->number (.$ string->number x->string))

  (string-ec (: c (number->string n (length labels)))
             (~ labels (xchar->number c))))

(define (n->labels n :optional (labels *labels*))
  (list-ec (: i n) (n->label i labels)))

(define (hintable? curdesk border)
  (or (equal? (~ border'desk) curdesk)
      (= (ew_border_sticky_get border) 1)))

(define (desk-current)
  (e_desk_current_get (e_util_zone_current_get (e_manager_current_get))))

(define (show-hints)
  (define (hintablify b a)
    (let1 bd (cast <c-ptr:c-struct:_E_Border> b)
      (if (hintable? (desk-current) bd)
        (cons bd a)
        a)))
  (define (middle b)
    (+ (- (+ (~ b'x) (~ b'fx'x)) (~ b'zone'x))
       (truncate->exact (/. (~ b'w) 2))))

  (map show-hint
       #1=(sort-by (fold hintablify '() (e_border_focus_stack_get))
                   middle
                   <)
       (n->labels (length #1#))))

(define (show-hints!)
  (let1 hs (show-hints)
    (if (not (null? hs))
      (set! *hints* hs)
      (hide))))

(define (del-hints!)
  (when *hints*
    (for-each del-hint *hints*)
    (set! *hints* #f)))

#|
;; 最初は動くんだけれども、ちょっと時間が経つと、
;; segvしたり`show'が呼ばれなくなっちゃったりします＞＜
(define (show obj param) (%show zone))

(define-constant +action-name+ "egauche/switch-window")

(define *action*
  (and-let* ((a (e_action_add +action-name+)))
    (begin0 a
      (set! (~ a'func'go) show)
      (e_action_predef_name_set "EGauche switch-window"
                                "Switch window"
                                "egauche/switch-window"
                                "" NULL 0)
      (update! *shutdowns*
        (pa$ cons
             (^ ()
                (e_action_predef_name_del "EGauche switch-window"
                                          "switch window")
                (e_action_del +action-name+)))))))
|#