[PATCH 4/4] Add model-view-control example showing synthesised (keypress) events.

[Jan Nieuwenhuizen]

        * gtk/examples/mvc.scm: Add.
---
 gtk/examples/mvc.scm | 176 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 176 insertions(+)
 create mode 100755 gtk/examples/mvc.scm

diff --git a/gtk/examples/mvc.scm b/gtk/examples/mvc.scm
new file mode 100755
index 0000000..d2777b0
--- /dev/null
+++ b/gtk/examples/mvc.scm
@@ -0,0 +1,176 @@
+#! /bin/sh
+# -*- scheme -*-
+exec guile-gnome-2 -e test $0 "$@"
+!#
+
+;; guile-gnome
+;; Copyright (C) 2013,2014 Jan Nieuwenhuizen <address@hidden>
+
+;; 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
+
+
+;; This example shows how to use Guile Gnome in a model-view-contol
+;; setup.
+
+(read-set! keywords 'prefix)
+
+(define (test . args)
+  (eval '(test (command-line)) (resolve-module '(mvc))))
+
+(define-module (mvc)
+  ;; base
+  :use-module (ice-9 and-let-star)
+  ;; oops
+  :duplicates (merge-generics last)
+  :use-module (oop goops)
+  ;; gtk
+  :use-module (gnome gobject)
+  :use-module (gnome glib)
+  :use-module (gnome gtk gdk-event)
+  :use-module (gnome gtk))
+
+(define-class <text-model> (<gobject>)
+  (buffer :accessor .buffer :init-value (make <gtk-text-buffer>))
+  (text :accessor .text :init-value #f :init-keyword :text)
+
+  :gsignal '(quit #f)
+  :gsignal '(space #f))
+
+(define-method (initialize (o <text-model>) . initargs)
+  (next-method)
+  (let ((buffer (.buffer o))
+        (text (.text o)))
+    (if text (set-text buffer text)))
+  ;; Key signals
+  (connect o 'space (lambda (m) (space o)))
+  (connect o 'quit (lambda (m) (q o))))
+
+
+;;;; Signal handlers
+(define-method (key-press-handler (o <text-model>) bindings)
+  (lambda (w event)
+    (and-let* ((keyval (gdk-event-key:keyval event))
+               ((format (current-error-port) "key pressed: ~a\n" keyval))
+               (mods (gdk-event-key:modifiers event))
+               (-mod2-mods (filter (negate (lambda (x) (eq? x 'mod2-mask))) 
mods))
+               ((format (current-error-port) "modifiers: ~a\n" -mod2-mods))
+               (key (cons keyval (list -mod2-mods)))
+               (args (assoc-ref bindings key)))
+              (apply emit (cons* o args))
+              #t)))
+
+(define* (make-key-press-event :key
+                              (window #f)
+                              (send #f)
+                              (time 0)
+                              (state 0)
+                              (key 0)
+                              (hwkey 0)
+                              (group 0))
+  (let ((type (make <gdk-event-type> :value 'key-press)))
+    (list->vector (list type window send time state key hwkey group))))
+
+(define-method (space (o <text-model>))
+  (format (current-error-port) "<space>\n"))
+
+(define-method (q (o <text-model>))
+  (format (current-error-port) "<quit>\n")
+  (gtk-main-quit))
+
+
+
+;;; GNOME view
+(define-class <gnome-text-view> (<text-model>)
+  (model :accessor .model :init-value #f :init-keyword :model)
+  (widget :accessor .widget :init-value (make <gtk-scrolled-window>))
+  (view  :accessor .view :init-value #f))
+
+(define-method (initialize (o <gnome-text-view>) . initargs)
+  (next-method)
+  (let* ((widget (.widget o))
+         (model (.model o))
+         (buffer (.buffer model))
+         (view  (make <gtk-text-view> :buffer buffer :editable #f))
+       (bindings
+        `(((,gdk:space ()) . (space))
+          ((,gdk:Q ()) . (quit)) ;; Shh... don't tell, we synthesise this
+          ((,gdk:q (control-mask)) . (quit))
+          ((,gdk:w (control-mask)) . (quit)))))
+    (set! (.view o) view)
+    (connect view 'key-press-event (key-press-handler o bindings))
+    (add widget view))
+  (show-all o)
+  o)
+
+;; This is a somewhat contrived example to show the operation of
+;; make-key-press-event.  Of course, synthesising events will
+;; typically be done by non-GNOME views, e.g., a Web view.
+(define-method (space (o <gnome-text-view>))
+  (next-method)
+  (format (current-error-port) "synthesising: Q\n")
+  (let* ((view (.view o))
+         (widget (get-parent (get-window view)))
+         (event (make-key-press-event :key gdk:Q :window widget)))
+  (emit view 'key-press-event event)))
+
+
+;;; gtk-widget wrappers
+(define-method (pack-start (w <gtk-container>) (o <gnome-text-view>) . rest) 
(apply pack-start (cons* w (.widget o) rest)))
+(define-method (show-all (o <gnome-text-view>)) (show-all (.widget o)))
+
+
+;;; Web view -- implementation left as an exercise for the reader
+
+(define-class <web-window> (<gdk-window>)
+  :gsignal (list 'expose-event #f <gdk-event-expose>)
+  :gsignal (list 'headless-expose-event #f <gdk-rectangle>)
+  :gsignal (list 'key-press-event #f <gdk-event-key>)
+  :gsignal (list 'button-press-event #f <gdk-event-button>)
+  :gsignal (list 'button-release-event #f <gdk-event-button>)
+  :gsignal (list 'scroll-event #f <gdk-event-scroll>))
+
+(define-class <web-scrolled-window> (<web-window>)
+  (offset :accessor .offset :init-form (list 0 0)))
+
+(define-class <web-text-view> (<text-model>)
+  (model :accessor .model :init-value #f :init-keyword :model)
+  (widget :accessor .widget :init-value (make <web-scrolled-window>))
+  (view  :accessor .view :init-value #f))
+
+
+
+;;;; Test
+(define (test . args)
+  (let* ((main-window (make <gtk-window>
+                       :title "MVC Event-synthesise Demo"
+                       :type 'toplevel))
+        (text "
+
+    <SPC>  synthesise event
+    C-q    quit
+
+")
+         (model (make <text-model> :text text))
+        (view (make <gnome-text-view> :model model))
+        (vbox (make <gtk-vbox>)))
+    (add main-window vbox)
+    (pack-start vbox view #t #t 0)
+    (set-default-size main-window 300 200)
+    (connect main-window 'delete-event (lambda (w e) (gtk-main-quit) #f))
+    (show-all main-window))
+  (gtk-main))
-- 
Jan Nieuwenhuizen <address@hidden> | GNU LilyPond http://lilypond.org
Freelance IT http://JoyofSource.com | Avatar®  http://AvatarAcademy.nl