May 2005 - cells-gtk-cvs@common-lisp.net - mailman3.common-lisp.net

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv9071/gtk-ffi Modified Files: gtk-ffi.lisp Log Message: New method to load foreign libraries. Date: Sun May 29 23:19:58 2005 Author: pdenno Index: root/gtk-ffi/gtk-ffi.lisp diff -u root/gtk-ffi/gtk-ffi.lisp:1.11 root/gtk-ffi/gtk-ffi.lisp:1.12 --- root/gtk-ffi/gtk-ffi.lisp:1.11 Thu May 5 16:20:51 2005 +++ root/gtk-ffi/gtk-ffi.lisp Sun May 29 23:19:58 2005 @@ -47,85 +47,67 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (export '(c-null c-null-int int-slot-indexed)) + (export '(c-null c-null-int int-slot-indexed load-gtk-libs)) (defun gtk-function-name (lisp-name) (substitute #\_ #\- lisp-name)) - - (defun libname (lib) - #+(or win32 mswindows) - (concatenate 'string - "/Program Files/Common Files/GTK/2.0/bin/" - (ecase lib - (:gobject "libgobject-2.0-0.dll") - (:glib "libglib-2.0-0.dll") - (:gthread "libgthread-2.0-0.dll") - (:gdk "libgdk-win32-2.0-0.dll") - (:gtk "libgtk-win32-2.0-0.dll") - (:cgtk "libcellsgtk"))) - #+macosx - (concatenate 'string - "/sw/lib/" - (ecase lib - (:gobject "libgobject-2.0.0.dylib") - (:glib "libglib-2.0.0.dylib") - (:gthread "libgthread-2.0.0.dylib") - (:gdk "libgdk-x11-2.0.0.dylib") - (:gtk "libgtk-x11-2.0.0.dylib") - (:cgtk "libcellsgtk.dylib"))) - #-(or macosx win32 mswindows) - (ecase lib - (:gobject "libgobject-2.0") - (:glib "libglib-2.0") - (:gthread "libgthread-2.0") - (:gdk "libgdk-x11-2.0") - (:gtk "libgtk-x11-2.0") - (:cgtk "libcellsgtk"))) - - - - #+cmu - (loop for lib in '(:gthread :glib :gobject :gdk :gtk #+libcellsgtk :cgtk) - with libpath = (cond ((directory "/usr/lib/libgtk*") "/usr/lib/") - ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/") - ((find :mswindows *features*) nil) - (t (error "Cannot find a path containing libgtk"))) - do (assert (uffi:load-foreign-library ;;simon - (hic:find-foreign-library (gtk-ffi::libname lib) libpath) - :force-load nil - :module (string lib)))) - - #-libcellsgtk - (warn "libcellsgtk.so not found. Just a few capabilities will be unavailable.") - + (defun load-gtk-libs () + (macrolet ((loadit (libname module) + `(uffi:load-foreign-library + (concatenate 'string cl-user::*gtk-lib-path* ,libname) + :force-load #+lispworks t #-lispworks nil + :module ,(string module)))) + #+(or win32 mswindows) + (progn + (loadit "libgobject-2.0-0.dll" :gobject) + (loadit "libglib-2.0-0.dll" :glib) + (loadit "libgthread-2.0-0.dll" :gthread) + (loadit "libgdk-win32-2.0-0.dll" :gdk) + (loadit "libgtk-win32-2.0-0.dll" :gtk) + #+libcellsgtk(loadit "libcellsgtk.dll" :cgtk)) + #+macosx + (progn + (loadit "libgobject-2.0-0.dynlib" :gobject) + (loadit "libglib-2.0-0.dynlib" :glib) + (loadit "libgthread-2.0-0.dynlib" :gthread) + (loadit "libgdk-win32-2.0-0.dynlib" :gdk) + (loadit "libgtk-win32-2.0-0.dynlib" :gtk) + #+libcellsgtk(loadit "libcellsgtk.dynlib" :cgtk)) + #-(or macosx win32 mswindows) + (progn + (loadit "libgobject-2.0.so" :gobject) + (loadit "libglib-2.0.so" :glib) + (loadit "libgthread-2.0.so" :gthread) + (loadit "libgdk-x11-2.0.so" :gdk) + (loadit "libgtk-x11-2.0.so" :gtk) + #+libcellsgtk(loadit "libcellsgtk.so" :cgtk)))) + #+cmu(load-gtk-libs) (defun ffi-to-uffi-type (clisp-type) #+clisp clisp-type #-clisp (if (consp clisp-type) (mapcar 'ffi-to-uffi-type clisp-type) - (case clisp-type - ((nil) :void) - (uint :UNSIGNED-INT) - (c-pointer :pointer-void) - (c-ptr-null '*) - (c-array-ptr '*) - (c-ptr '*) - (c-string :cstring) - (sint32 :int) - (uint32 :unsigned-int) - (uint8 :unsigned-byte) - (uint16 :short) ; no signed/unsigned types? - (boolean :unsigned-int) - (ulong :unsigned-long) - (int :int) - (long :long) - (single-float :float) - (double-float :double) - (otherwise clisp-type)))) - + (case clisp-type + ((nil) :void) + (uint :UNSIGNED-INT) + (c-pointer :pointer-void) + (c-ptr-null '*) + (c-array-ptr '*) + (c-ptr '*) + (c-string :cstring) + (sint32 :int) + (uint32 :unsigned-int) + (uint8 :unsigned-byte) + (uint16 :short) ; no signed/unsigned types? + (boolean :unsigned-int) + (ulong :unsigned-long) + (int :int) + (long :long) + (single-float :float) + (double-float :double) + (otherwise clisp-type)))) #-clisp (defun ffi-to-native-type (ffi-type) (uffi::convert-from-uffi-type - (ffi-to-uffi-type ffi-type) :type))) - + (ffi-to-uffi-type ffi-type) :type))) ;; END eval-when (defmacro def-gtk-function (library name &key arguments return-type (return-type-allocation :none) @@ -312,13 +294,10 @@ (32 :window_state) (33 :setting))) - - #-clisp (uffi:def-struct list-boolean (value :unsigned-int) (end :pointer-void)) - (defmacro with-gtk-string ((var string) &rest body) `(let ((,var ,string))

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-ffi.asd
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv9046/gtk-ffi Modified Files: gtk-ffi.asd Log Message: New procedure for finding libraries: set the path once, in here. Unfortunately it seems that we /still/ need the path for cmu. Reason to be investigated. Date: Sun May 29 23:18:24 2005 Author: pdenno Index: root/gtk-ffi/gtk-ffi.asd diff -u root/gtk-ffi/gtk-ffi.asd:1.5 root/gtk-ffi/gtk-ffi.asd:1.6 --- root/gtk-ffi/gtk-ffi.asd:1.5 Tue Dec 14 05:02:05 2004 +++ root/gtk-ffi/gtk-ffi.asd Sun May 29 23:18:24 2005 @@ -1,3 +1,28 @@ + +(in-package "CL-USER") +;;;--------------------- +;;; Two steps: +;;;--------------------- + +(defvar *gtk-lib-path* nil) + +;;; Step 1 -- If you are not using Linux nor BSD and the GTK libs are not +;;; in the places specified below, adjust these. + +#+macosx (setf *gtk-lib-path* "/sw/lib/") +#+(or win32 mswindows) (setf *gtk-lib-path* "C:/Program Files/Common Files/GTK/2.0/bin/") + +;;; This need not be specified for cmucl (leave as a null string). +#+cmu(setf *gtk-lib-path* "/usr/lib/") +;#+cmu(setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine + +;;; Specify for Lispworks. +#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/usr/lib/") +;#-(or macosx win32 mswindows cmu) (setf *gtk-lib-path* "/opt/gnome/lib/") ; For my Suse machine + +;;; Step 2 -- If you built libcellsgtk.so, uncomment the next line. +;(pushnew :libcellsgtk *features*) + (asdf:defsystem :gtk-ffi :name "gtk-ffi" :depends-on (:cells :hello-c)

1 0

[cells-gtk-cvs] CVS update: root/gtk-ffi/gtk-adds.c
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/gtk-ffi In directory common-lisp.net:/tmp/cvs-serv9019/gtk-ffi Modified Files: gtk-adds.c Log Message: New function gtk_adds_tree_iter_new , used by TreeModel-type ComboBoxes Date: Sun May 29 23:16:56 2005 Author: pdenno Index: root/gtk-ffi/gtk-adds.c diff -u root/gtk-ffi/gtk-adds.c:1.2 root/gtk-ffi/gtk-adds.c:1.3 --- root/gtk-ffi/gtk-adds.c:1.2 Sun Mar 6 18:04:02 2005 +++ root/gtk-ffi/gtk-adds.c Sun May 29 23:16:56 2005 @@ -30,3 +30,13 @@ return gtk_text_iter_copy(&example); } +/* C programmers allocate iters on the stack. We use this. + Free it with gtk-tree-iter-free */ +GtkTreeIter * +gtk_adds_tree_iter_new () +{ + GtkTreeIter example; + return gtk_tree_iter_copy(&example); +} + +

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/widgets.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8997/cells-gtk Modified Files: widgets.lisp Log Message: Better error reporting on assert in the def-widget/def-gtk macro. Thanks to Kenny Tilton and Fred Gilham. Date: Sun May 29 23:15:51 2005 Author: pdenno Index: root/cells-gtk/widgets.lisp diff -u root/cells-gtk/widgets.lisp:1.12 root/cells-gtk/widgets.lisp:1.13 --- root/cells-gtk/widgets.lisp:1.12 Sun Mar 6 18:01:09 2005 +++ root/cells-gtk/widgets.lisp Sun May 29 23:15:51 2005 @@ -182,7 +182,7 @@ ,(intern (string signal-slot) :keyword) new-value) (let ((cb (cdr (assoc ',signal-slot *widget-callbacks*)))) - (assert cb) + (assert cb () "Callback ~a not defined in *widget-callbacks*" ',signal-slot) #+shhtk (trc nil "in def-c-output gtk-signal-connect pcb:" cb ',slot-name (id self)) (gtk-signal-connect (id self)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/tree-view.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8145/cells-gtk Modified Files: tree-view.lisp Log Message: New ability: :expand-p allows tree to come up fully expanded. Moved code iter recording code from cells-gtk.lisp to here. Date: Sun May 29 23:13:06 2005 Author: pdenno Index: root/cells-gtk/tree-view.lisp diff -u root/cells-gtk/tree-view.lisp:1.10 root/cells-gtk/tree-view.lisp:1.11 --- root/cells-gtk/tree-view.lisp:1.10 Sat Feb 26 23:30:39 2005 +++ root/cells-gtk/tree-view.lisp Sun May 29 23:13:06 2005 @@ -16,6 +16,9 @@ |# +;;; Todo: separate tree-model/tree-store stuff into another file (used by combo box too). +;;; BTW Tree-store implements the tree-model interface, among other things. + (in-package :cgtk) (def-object list-store () @@ -56,6 +59,7 @@ (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil)) (selected-items-cache :cell nil :accessor selected-items-cache :initform nil) (selection-mode :accessor selection-mode :initarg :selection-mode :initform :single) + (expand-all :accessor expand-all :initarg :expand-all :initform nil) (on-select :accessor on-select :initarg :on-select :initform nil) (tree-model :accessor tree-model :initarg :tree-model :initform nil)) () ; gtk-slots @@ -68,11 +72,16 @@ (when new-value (gtk-tree-view-set-model (id self) (id (to-be new-value))))) +(def-c-output expand-all ((self tree-view)) + (when new-value + (gtk-tree-view-expand-all (id self)))) + (defun item-from-path (child-fn roots path) (loop for index in path for node = (nth index roots) then (nth index (funcall child-fn node)) finally (return node))) +;;; Used by combo-box also, when it is using a tree model. (ff-defun-callable :cdecl :void tree-view-items-selector ((model :pointer-void) (path :pointer-void) (iter :pointer-void) (data :pointer-void)) (declare (ignore path data)) @@ -161,8 +170,8 @@ (defmodel treebox (tree-view) () (:default-initargs - :tree-model (c? (make-instance 'tree-store - :item-types (append (column-types self) (list :string)))))) + :tree-model (c? (mk-tree-store + :item-types (append (column-types self) (list :string)))))) (defun mk-treebox (&rest inits) (let ((self (apply 'make-instance 'treebox inits))) @@ -182,7 +191,24 @@ for index from 0 do (gtk-tree-store-set-kids (id (tree-model self)) root c-null index (append (column-types self) (list :string)) - (print-fn self) (children-fn self))))) + (print-fn self) (children-fn self))) + (when (expand-all self) + (gtk-tree-view-expand-all (id self))))) + +;;; These look like ("Trimmed Text" "(0 0 )") for example where menu structure is "Text --> Trimmed Text" +;;; Column-types is a list of :string, :float etc. used to reference g-value-set-string etc. +(defun gtk-tree-store-set-kids (model val-tree parent-iter index column-types print-fn children-fn &optional path) + (with-tree-iter (iter) + (gtk-tree-store-append model iter parent-iter) ; sets iter + (gtk-tree-store-set model iter ; Not a gtk function! + column-types + (append + (funcall print-fn val-tree) + (list (format nil "(~{~d ~})" (reverse (cons index path)))))) + (loop for sub-tree in (funcall children-fn val-tree) + for pos from 0 do + (gtk-tree-store-set-kids model sub-tree iter + pos column-types print-fn children-fn (cons index path))))) (ff-defun-callable :cdecl :int tree-view-render-cell-callback ((tree-column :pointer-void) (cell-renderer :pointer-void)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/menus.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8110/cells-gtk Modified Files: menus.lisp Log Message: New code for TreeModel ComboBoxes. Requires libcellsgtk.so Date: Sun May 29 23:09:40 2005 Author: pdenno Index: root/cells-gtk/menus.lisp diff -u root/cells-gtk/menus.lisp:1.9 root/cells-gtk/menus.lisp:1.10 --- root/cells-gtk/menus.lisp:1.9 Sat Feb 26 23:28:08 2005 +++ root/cells-gtk/menus.lisp Sun May 29 23:09:40 2005 @@ -18,20 +18,68 @@ (in-package :cgtk) +(defmacro with-tree-iters (vars &body body) + `(let (,@(loop for var in vars collect `(,var (gtk-adds-tree-iter-new)))) + (unwind-protect + (progn ,@body) + ,@(loop for var in vars collect `(gtk-tree-iter-free ,var))))) + +;;; ============= Combo-box ============================ +;;; User should specify exactly one of :items or :roots +;;; If specify :roots, specify :children-fn too. (def-widget combo-box () ((items :accessor items :initarg :items :initform nil) (print-fn :accessor print-fn :initarg :print-fn - :initform #'(lambda (item) (format nil "~a" item))) - (init :accessor init :initarg :init :initform nil)) + :initform #'(lambda (item) (format nil "~a" item))) ; see below if :roots + (init :accessor init :initarg :init :initform nil) + (roots :accessor roots :initarg :roots :initform nil) + (children-fn :accessor children-fn :initarg :children-fn :initform #'(lambda (x) (declare (ignore x)) nil)) + (tree-model :cell nil :accessor tree-model :initform nil)) (active) (changed) :new-tail '-text - :on-changed (callback (widget event data) - (trc nil "combo-box onchanged cb" widget event data (id self)) - (let ((pos (gtk-combo-box-get-active (id self)))) - (trc nil "combo-box pos" pos) - (setf (md-value self) (and (not (= pos -1)) - (nth pos (items self))))))) + :on-changed + (callback (widget event data) + (trc nil "combo-box onchanged cb" widget event data (id self)) + (if (items self) + ;; flat model (:items specified) + (let ((pos (gtk-combo-box-get-active (id self)))) + ;;(trc nil "combo-box pos" pos) + (setf (md-value self) (and (not (= pos -1)) + (nth pos (items self))))) + ;; non-flat tree-model (:roots specified) + (with-tree-iters (iter) + (when (gtk-combo-box-get-active-iter (id self) iter) + (setf (md-value self) + (item-from-path + (children-fn self) + (roots self) + (read-from-string + (gtk-tree-model-get-cell (id (tree-model self)) iter 1 :string))))))))) + +;;; When user specifies :roots, he is using a tree-model. +;;; POD There is probably no reason he has to use :strings for the "columns" +(def-c-output roots ((self combo-box)) + (when old-value + (gtk-tree-store-clear (id (tree-model self)))) + (when new-value + (unless (tree-model self) + (let ((model (mk-tree-store :item-types '(:string :string)))) + (setf (tree-model self) model) + (setf (of-tree model) self) + (gtk-combo-box-set-model (id self) (id (to-be model))))) + (let* ((user-print-fn (print-fn self)) ; because he shouldn't need to know this detail. + (pfunc #'(lambda (x) (list (funcall user-print-fn x))))) + (loop for root in new-value + for index from 0 do + (gtk-tree-store-set-kids (id (tree-model self)) root c-null index + '(:string :string) pfunc (children-fn self))) + ;; Spec says iter must correspond to a path of depth one. Hence no point in set-active-iter. + ;; init should just be the index of the depth one item you want displayed. + (bwhen (item-index (init self)) + (gtk-combo-box-set-active (id self) item-index) + (let ((item (item-from-path (children-fn self) (roots self) (list item-index)))) + (setf (md-value self) item)))))) (def-c-output items ((self combo-box)) (when old-value @@ -45,7 +93,8 @@ (when index (gtk-combo-box-set-active (id self) index) (setf (md-value self) (init self))))))) - + +;;; ============= Toolbar/Toolbutton ============================ (def-object tooltips () () () ()) @@ -126,6 +175,7 @@ (when new-value (setf (stock-id self) (string-downcase (format nil "gtk-~a" new-value))))) +;;; ============= Menu ============================ (def-widget menu-shell () () () () :padding 0)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/layout.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8082/cells-gtk Modified Files: layout.lisp Log Message: Not sure of this, but new arguments to gtk-box-pack-start. Date: Sun May 29 23:08:22 2005 Author: pdenno Index: root/cells-gtk/layout.lisp diff -u root/cells-gtk/layout.lisp:1.4 root/cells-gtk/layout.lisp:1.5 --- root/cells-gtk/layout.lisp:1.4 Sat Feb 12 15:52:10 2005 +++ root/cells-gtk/layout.lisp Sun May 29 23:08:22 2005 @@ -29,8 +29,8 @@ (def-c-output .kids ((self box)) (when new-value (dolist (kid new-value) - (gtk-box-pack-start (id self) (id kid) - (expand? kid) (fill? kid) (padding? kid))) + (gtk-box-pack-start (id self) (id kid) + (expand? kid) (fill? kid) (padding? kid))) #+clisp (call-next-method))) (def-widget hbox (box)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/gtk-app.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8059/cells-gtk Modified Files: gtk-app.lisp Log Message: Moved duplicated foreign loading code (substantially cleaned up) into gtk-ffi/gtk-ffi.lisp Date: Sun May 29 23:06:47 2005 Author: pdenno Index: root/cells-gtk/gtk-app.lisp diff -u root/cells-gtk/gtk-app.lisp:1.13 root/cells-gtk/gtk-app.lisp:1.14 --- root/cells-gtk/gtk-app.lisp:1.13 Sat Feb 26 23:26:09 2005 +++ root/cells-gtk/gtk-app.lisp Sun May 29 23:06:47 2005 @@ -137,23 +137,11 @@ (funcall (aref *gtk-global-callbacks* n))) (defun cells-gtk-init () - (gtk-reset) #-cmu (unless *gtk-loaded* - (loop for lib in '(:gthread :glib :gobject :gdk :gtk #+libcellsgtk :cgtk) - for libname = (gtk-ffi::libname lib) - with libpath = (cond ((directory "/usr/lib/libgtk*") "/usr/lib/") - ((directory "/opt/gnome/lib/libgtk*") "/opt/gnome/lib/") - ((find :mswindows *features*) nil) - (t (error "Cannot find a path containing libgtk"))) - do #-mswindows ;; probably have to refine this for diff implementations - (setq libname (uffi:find-foreign-library (gtk-ffi::libname lib) libpath)) - (assert (or (uffi:load-foreign-library libname - :force-load #+lispworks t #-lispworks nil - :module (string lib)) - (eql lib :cgtk))) - finally (setf *gtk-loaded* t)) - #-libcellsgtk(warn "libcellsgtk.so not found. Just a few capabilities will be unavailable."))) + (gtk-ffi:load-gtk-libs) + (setf *gtk-loaded* t)) + (gtk-reset)) ;;; Implements quits other than through destroy. (let (quit)

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.lisp
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8031/cells-gtk Removed Files: cells-gtk.lisp Log Message: Renamed cells-gtk.lisp to packages.lisp and moved some stuff in it to treeview.lisp Date: Sun May 29 23:04:12 2005 Author: pdenno

1 0

[cells-gtk-cvs] CVS update: root/cells-gtk/cells-gtk.asd
by pdenno＠common-lisp.net 29 May '05

29 May '05

Update of /project/cells-gtk/cvsroot/root/cells-gtk In directory common-lisp.net:/tmp/cvs-serv8014/cells-gtk Modified Files: cells-gtk.asd Log Message: Renamed cells-gtk.lisp to packages.lisp and moved some stuff in it to treeview.lisp Date: Sun May 29 23:03:43 2005 Author: pdenno Index: root/cells-gtk/cells-gtk.asd diff -u root/cells-gtk/cells-gtk.asd:1.3 root/cells-gtk/cells-gtk.asd:1.4 --- root/cells-gtk/cells-gtk.asd:1.3 Sat Feb 12 15:44:41 2005 +++ root/cells-gtk/cells-gtk.asd Sun May 29 23:03:43 2005 @@ -1,9 +1,11 @@ + + (asdf:defsystem :cells-gtk :name "cells-gtk" :depends-on (:cells :gtk-ffi) :serial t :components - ((:file "cells-gtk") + ((:file "packages") (:file "conditions") (:file "compat") (:file "widgets" :depends-on ("conditions"))

1 0