[cells-gtk-cvs] CVS update: root/cells-gtk/test-gtk/test-textview.lisp

[Peter Denno]

Update of /project/cells-gtk/cvsroot/root/cells-gtk/test-gtk
In directory common-lisp.net:/tmp/cvs-serv22930/root/cells-gtk/test-gtk

Modified Files:
	test-textview.lisp 
Log Message:
Demonstrate text-buffer tags and markup (requires libcellsgtk.so)
Date: Sun Mar  6 18:02:44 2005
Author: pdenno

Index: root/cells-gtk/test-gtk/test-textview.lisp
diff -u root/cells-gtk/test-gtk/test-textview.lisp:1.2 root/cells-gtk/test-gtk/test-textview.lisp:1.3
--- root/cells-gtk/test-gtk/test-textview.lisp:1.2	Sat Feb 26 23:20:19 2005
+++ root/cells-gtk/test-gtk/test-textview.lisp	Sun Mar  6 18:02:44 2005
@@ -1,23 +1,82 @@
 (in-package :test-gtk)
 
+;;; The details of the tag-table and markup slots are, for the time being, 
+;;; not defined by cells-gtk. The demo give an idea how they might be used.
+
 (defmodel test-textview (vbox)
   ((buffer :accessor buffer :initarg :buffer 
 	   :initform (mk-text-buffer 
-		      :text (format nil "~{~a~%~}" (loop for i below 100 collect (format nil "Text view Line ~a" i))))))
+		      :text (format nil "~{~a~%~}" 
+                                    (loop for i below 100 collect (format nil "Text view Line ~a" i)))
+                      :on-modified-changed 
+                      (callback (w e d)
+                        (show-message "Text buffer modified"))
+                      :tag-table (c? (xtv-create-tag-table self)))))
   (:default-initargs
       :kids (list
 	     (mk-scrolled-window 
 	      :kids (list
 		     (mk-text-view 	      
 		      :buffer (c? (buffer (upper self test-textview)))
-                      #+libcellsgtk :populate-popup
-                      #+libcellsgtk 
-                      (c?
-                        (def-populate-adds
-                          (:menu-item :label "My menu item"
-                                      :owner self
-                                      :on-activate 
-                                      (callback (w e d)
-                                        (show-message (format nil "My menu item says = ~A" 
-                                                              (owner self)))))))))))))
+                       #+libcellsgtk :populate-popup
+                       #+libcellsgtk 
+                       (c?
+                         (def-populate-adds
+                           (:menu-item :label "Mark something yellow"
+                                       :owner self
+                                       :on-activate 
+                                       (callback (w e d)
+                                         (let ((buf (buffer (owner self))))
+                                           (setf (markup buf) ; implementation idea... ;^)
+                                                   (list 
+                                                    (make-instance 'color-tag :start 10 :end 20
+                                                                   :name :yellow-background)))
+                                           (apply-markup (first (markup buf)) buf))))))))))))
+                                         
+(defmethod xtv-create-tag-table ((self text-buffer))
+  (let ((ht (make-hash-table)))
+    (flet ((create-tag (name)
+             (setf (gethash name ht)
+                     (gtk-text-buffer-create-tag 
+                      (cgtk::id self)
+                      (string-downcase (symbol-name (gensym)))
+                      (string-downcase (subseq (string name) (1+ (position #\- (string name)))))
+                      (string-downcase (subseq (string name) 0 (position #\- (string name))))
+                      c-null))))
+      (loop for name in '(:red-foreground :red-background :yellow-foreground :yellow-background)
+         do (create-tag name)))
+    ht))
+
+;;; In a real application you might use an xml parser on marked up text 
+;;; by creating 'mark objects' like these. In the demo we just do it in a 
+;;; menu item cb.  
+
+;;; We won't even use this one here, but marks are useful ;^)
+(defclass mark ()
+  ((type :initarg :type)
+   (pos :initarg :pos)
+   (len :initarg :len)
+   (c-ptr :accessor c-ptr :initform nil)))
+
+(defclass color-tag ()
+  ((name :initarg :name)
+   (start :initarg :start)
+   (end :initarg :end)))
+
+(defmethod apply-markup ((tag color-tag) buffer)
+  (with-slots (start end name) tag
+    (assert (gethash name (tag-table buffer)))
+    (let ((buf (cgtk::id buffer)))
+      (with-text-iters (start-iter end-iter)
+        (gtk-text-buffer-get-iter-at-offset buf start-iter start)
+        (gtk-text-buffer-get-iter-at-offset buf end-iter end)
+        (gtk-text-buffer-apply-tag buf (gethash name (tag-table buffer)) start-iter end-iter)))))
+
+(defmethod apply-markup ((mark mark) buffer)
+  (with-slots (pos c-ptr) mark
+    (let ((buf (cgtk::id buffer)))
+      (with-text-iters (iter)
+        (gtk-text-buffer-get-iter-at-offset buf iter pos)
+        (setf c-ptr (gtk-text-buffer-create-mark buf (symbol-name (gensym)) iter t))))))
+