[cells-cvs] CVS cells-gtk3/cells-gtk
phildebrandt
phildebrandt at common-lisp.net
Sun Apr 13 10:59:20 UTC 2008
Update of /project/cells/cvsroot/cells-gtk3/cells-gtk
In directory clnet:/tmp/cvs-serv5005/cells-gtk
Added Files:
#cells-gtk.asd# #tree-view.lisp# actions.lisp addon.lisp
buttons.lisp cairo-drawing-area.lisp callback.lisp
cells-gtk.asd cells-gtk.lpr cells3-porting-notes.lisp
compat.lisp conditions.lisp dialogs.lisp display.lisp
drawing-area.lisp drawing.lisp entry.lisp gl-drawing-area.lisp
gtk-app.lisp layout.lisp menus.lisp packages.lisp
textview.lisp tree-view.lisp widgets.lisp
Log Message:
cells-gtk3 initial.
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#cells-gtk.asd# 2008/04/13 10:59:18 1.1
(in-package :common-lisp-user)
(defpackage #:cells-gtk-asd
(:use :cl :asdf))
(in-package :cells-gtk-asd)
;;;
;;; features
;;;
;;; run gtk in its own thread (requires bordeaux-threads)
b(pushnew :cells-gtk-threads *features*)
;;; drawing-area widget using cairo (requires cl-cairo2)
(pushnew :cells-gtk-cairo *features*)
;;; drawing-area widget using OpenGL (requires libgtkglext1)
;(pushnew :cells-gtk-opengl *features*)
(asdf:defsystem :cells-gtk
:name "cells-gtk"
:depends-on (:cells
:utils-kt
:pod-utils
:gtk-ffi
:ph-maths
#+cells-gtk-cairo :cl-cairo2
#+cells-gtk-threads :bordeaux-threads)
:serial t
:components
((:file "packages")
(:file "conditions")
(:file "compat")
(:file "cells3-porting-notes" :depends-on ("packages"))
(:file "widgets" :depends-on ("conditions"))
(:file "layout" :depends-on ("widgets"))
(:file "display" :depends-on ("widgets"))
(:file "drawing-area" :depends-on ("widgets"))
#+cells-gtk-cairo (:file "cairo-drawing-area" :depends-on ("widgets"))
#+cells-gtk-opengl (:file "gl-drawing-area" :depends-on ("widgets"))
(:file "buttons" :depends-on ("widgets"))
(:file "entry" :depends-on ("widgets"))
(:file "tree-view" :depends-on ("widgets"))
(:file "menus" :depends-on ("widgets"))
(:file "dialogs" :depends-on ("widgets"))
(:file "textview" :depends-on ("widgets"))
(:file "addon" :depends-on ("widgets"))
(:file "gtk-app")
))
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/#tree-view.lisp# 2008/04/13 10:59:18 1.1
#|
Cells Gtk
Copyright (c) 2004 by Vasilis Margioulas <vasilism at sch.gr>
You have the right to distribute and use this software as governed by
the terms of the Lisp Lesser GNU Public License (LLGPL):
(http://opensource.franz.com/preamble.html)
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
Lisp Lesser GNU Public License for more details.
|#
;;; 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 ()
((item-types :accessor item-types :initarg :item-types :initform nil)
(of-tree :accessor of-tree :initform (c-in nil)))
()
()
:new-args (c_1 (list (item-types self))))
(def-object tree-store ()
((item-types :accessor item-types :initarg :item-types :initform nil)
(of-tree :accessor of-tree :initform (c-in nil)))
()
()
:new-args (c_1 (list (item-types self))))
(defun tv-fail (&rest args) (declare (ignore args)))
(defgeneric get-selection (none))
(def-widget tree-view (container)
((columns-def :accessor columns-def :initarg :columns :initform nil)
(column-types :accessor column-types :initform (c? (mapcar #'first (columns-def self))))
(column-inits :accessor column-inits :initform (c? (mapcar #'second (columns-def self))))
(column-render :accessor column-render
:initform (c? (loop for col-def in (columns-def self)
for pos from 0 append
(when (third col-def)
(list pos (third col-def))))))
(node-render :accessor node-render
:initform (c? (loop for col-def in (columns-def self)
for pos from 0 append
(when (fourth col-def)
(list pos (fourth col-def))))))
(columns :accessor columns
:initform (c? (mapcar #'(lambda (col-init)
(apply #'make-be 'tree-view-column
:container self
col-init))
(column-inits self))))
(select-if :unchanged-if #'tv-fail
:accessor select-if :initarg :select-if :initform (c-in nil))
(roots :accessor roots :initarg :roots :initform nil)
(print-fn :accessor print-fn :initarg :print-fn :initform #'identity)
(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 (c-in nil))
(on-select :accessor on-select :initarg :on-select :initform nil)
(on-edit :accessor on-edit :initarg :on-edit :initform nil)
(tree-model :owning t :accessor tree-model :initarg :tree-model :initform nil))
() ; gtk-slots
() ; signal-slots
:on-select (lambda (self widget event data)
(declare (ignore widget event data))
(with-integrity (:change 'tree-view-select-cb)
(setf (value self) (get-selection self)))))
(defobserver tree-model ((self tree-view))
(when new-value
(gtk-tree-view-set-model (id self) (id new-value))
(with-integrity (:change 'tv-tree-model)
(setf (of-tree new-value) self))))
(defobserver expand-all ((self tree-view))
(when new-value
(gtk-tree-view-expand-all (id self))))
;;; Used by combo-box also, when it is using a tree model.
(cffi:defcallback tree-view-items-selector :void
((model :pointer) (path :pointer) (iter :pointer) (data :pointer))
(declare (ignore path data))
(let ((tree (of-tree (gtk-object-find model))))
(push (item-from-path (children-fn tree)
(roots tree)
(read-from-string
(gtk-tree-model-get-cell model iter (length (column-types tree)) :string)))
(selected-items-cache tree)))
0)
(defmethod get-selection ((self tree-view))
(let ((selection (gtk-tree-view-get-selection (id self)))
(cb (cffi:get-callback 'tree-view-items-selector)))
(setf (selected-items-cache self) nil)
(gtk-tree-selection-selected-foreach selection cb +c-null+)
(if (equal (gtk-tree-selection-get-mode selection) 3) ;;multiple
(copy-list (selected-items-cache self))
(first (selected-items-cache self)))))
(defobserver selection-mode ((self tree-view))
(when new-value
(let ((sel (gtk-tree-view-get-selection (id self))))
(gtk-tree-selection-set-mode sel
(ecase (selection-mode self)
(:none 0)
(:single 1)
(:browse 2)
(:multiple 3))))))
(cffi:defcallback tree-view-select-handler :void
((column-widget :pointer) (event :pointer) (data :pointer))
(if-bind (tree-view (gtk-object-find column-widget))
(let ((cb (callback-recover tree-view :on-select)))
(funcall cb tree-view column-widget event data))
(trc "Clean up old widgets after runs" column-widget))
0)
;;; The check that previously was performed here (for a clos object) caused the handler
;;; not to be registered (a problem of execution ordering?). Anyway, do we need such a check?
(defobserver on-select ((self tree-view))
(when new-value
(let ((selected-widget (gtk-tree-view-get-selection (id self))))
(gtk-object-store selected-widget self) ;; tie column widget to clos tree-view
(callback-register self :on-select new-value)
(let ((cb (cffi:get-callback 'tree-view-select-handler)))
;(trc nil "tree-view on-select pcb:" cb selected-widget "changed")
(gtk-signal-connect selected-widget "changed" cb)))))
;;;
;;; Listbox submodel
;;;
(defmodel listbox (tree-view)
((roots :initarg :items)) ; alternate initarg for inherited slot
(:default-initargs
:tree-model (c? (make-instance 'list-store
:item-types (append (column-types self) (list :string))))))
(defmethod items ((self listbox))
(roots self))
(defmethod (setf items) (val (self listbox))
(setf (roots self) val))
(defun mk-listbox (&rest inits)
(assert *parent*)
(let ((self (apply 'make-instance 'listbox (append inits (list :fm-parent *parent*)))))
(with-integrity (:change 'mk-listbox-of-tree)
(setf (of-tree (tree-model self)) self))
self))
(defobserver select-if ((self listbox))
(when new-value
(with-integrity (:change 'listbox-select-if-observer)
(setf (value self) (remove-if-not new-value (roots self))))))
(defobserver roots ((self listbox))
(when old-value
(gtk-list-store-clear (id (tree-model self))))
(when new-value
(gtk-list-store-set-items
(id (tree-model self))
(append (column-types self) (list :string))
(loop for item in new-value
for index from 0
collect (let ((i (funcall (print-fn self) item)))
;(ukt:trc nil "items output: old,new" item i)
(append i
(list (format nil "(~d)" index))))))))
;;;
;;; Treebox submodel
;;;
(defmodel treebox (tree-view)
()
(:default-initargs
:tree-model (c? (mk-tree-store
:item-types (append (column-types self) (list :string))))))
(defun mk-treebox (&rest inits)
(assert *parent*)
(let ((self (apply 'make-instance 'treebox (append inits (list :fm-parent *parent*)))))
(with-integrity (:change 'mk-treebox-of-tree)
(setf (of-tree (tree-model self)) self))
self))
(defobserver select-if ((self treebox))
(when new-value
(with-integrity (:change 'treebox-obs-select-if)
(setf (value self) (mapcan (lambda (item) (fm-collect-if item new-value))
(roots self))))))
(defobserver roots ((self treebox))
(when old-value
(gtk-tree-store-clear (id (tree-model self))))
(when new-value
(loop for root in new-value
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)))
(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)))))
;;;
;;; Cell rendering
;;;
(cffi:defcallback tree-view-render-cell-callback :int
((tree-column :pointer) (cell-renderer :pointer) (tree-model :pointer)
(iter :pointer) (data :pointer))
(if-bind (self (gtk-object-find tree-column))
(let ((cb (callback-recover self :render-cell)))
(assert cb nil "no :render-cell callback for ~a" self)
(funcall cb tree-column cell-renderer tree-model iter data))
(trc nil "Clean up old widgets from prior runs." tree-column))
1)
(defun item-from-path (child-fn roots path)
(loop for index in path
for node = (nth index roots) then (nth index (if node (funcall child-fn node) (return nil)))
finally (return node)))
(declaim (optimize (debug 3)))
(defun gtk-tree-view-render-cell (col col-type cell-attrib-f &optional node-attrib-f)
(trc nil "gtv-render-cell> creating callback" col col-type cell-attrib-f)
(flet ((node-from-iter (model iter)
(when-bind* ((tree-model (gtk-object-find model))
(tree-view (of-tree tree-model))
(path (gtk-tree-model-get-cell model iter (length (column-types tree-view)) :string)))
(item-from-path (children-fn tree-view)
(roots tree-view)
(read-from-string path)))))
(lambda (tree-column cell-renderer model iter data)
(DECLARE (ignorable tree-column data))
(trc nil "gtv-render-cell (callback)> entry"
tree-column cell-renderer model iter data)
(let ((item-value (gtk-tree-model-get-typed-item-value model
iter
col
col-type))
(node (node-from-iter model iter)))
(trc nil "gtv-render-cell (callback)> rendering value"
col col-type ret$ item-value)
(apply #'gtk-object-set-property cell-renderer
(case col-type
(:boolean (list "active" 'boolean item-value))
(:icon (list "stock-id" 'c-string
(string-downcase (format nil "gtk-~a" item-value))))
(t (list "text" 'c-string
(case col-type
(:date (multiple-value-bind (sec min hour day month year)
(decode-universal-time (truncate item-value))
(format nil "~2,'0D/~2,'0D/~D ~2,'0D:~2,'0D:~2,'0D"
day month year hour min sec)))
(:string (if item-value (get-gtk-string item-value) ""))
(otherwise (format nil "~a" item-value)))))))
(when cell-attrib-f
(gtk-cell-renderer-set-attribs cell-renderer (funcall cell-attrib-f item-value)))
(when (and node node-attrib-f)
(gtk-cell-renderer-set-attribs cell-renderer (funcall node-attrib-f node))))
1)))
;;;
;;; Editable cells
;;;
(defstruct renderer
tree-view col)
;;; a hash table to keep track of the renderer objects
(let ((renderers (make-hash-table)))
(defun register-renderer-data (renderer data)
(setf (gethash (cffi-sys:pointer-address renderer) renderers) data))
(defun recover-renderer-data (renderer)
(gethash (cffi-sys:pointer-address renderer) renderers)))
;;; generic callback -- update treestore and call on-edit func
(defun gtk-path-to-list (path)
"converts \"1:2\" to (1 2)"
(read-from-string (format nil "(~a)" (map 'string #'(lambda (c) (if (eql c #\:) #\space c)) path))))
(defun tree-view-edit-cell-callback (renderer path new-value)
(if-bind (data (recover-renderer-data renderer))
(let* ((tree (renderer-tree-view data))
(model (id (tree-model tree)))
(col (renderer-col data))
(col-type (nth col (column-types tree)))
(fn (on-edit tree))
(path (cffi:foreign-string-to-lisp path))
(node (item-from-path #'kids (roots tree) (gtk-path-to-list path))))
#+msg (format t "~&Edited path ~a --> node ~a~%" (gtk-path-to-list path) (when node (md-name node)))
(when node
(with-tree-iter (iter)
(gtk-tree-model-get-iter-from-string (id (tree-model tree)) iter path)
(let ((new-val (case col-type
(:boolean (= 0 (gtk-tree-model-get-cell model iter col :boolean))) ; toggle boolean cell,
(t new-value))))
#+msg (format t "~&Setting value for ~a to ~a ..." node new-val)
(gtk-tree-store-set-cell model iter col col-type new-val)
(funcall fn node col new-val))) ; call setf function
#+msg (format t " done.~%")
(force-output)))
(warn (format nil "No callback registered "))))
;;; a tribute to static typing
(cffi:defcallback tree-view-edit-cell-callback-string :int
((renderer :pointer) (path :pointer) (new-value :gtk-string))
(tree-view-edit-cell-callback renderer path new-value)
1)
[423 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/actions.lisp 2008/04/13 10:59:18 1.1
[504 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/addon.lisp 2008/04/13 10:59:18 1.1
[578 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/buttons.lisp 2008/04/13 10:59:18 1.1
[681 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cairo-drawing-area.lisp 2008/04/13 10:59:18 1.1
[1459 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/callback.lisp 2008/04/13 10:59:18 1.1
[1498 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.asd 2008/04/13 10:59:18 1.1
[1550 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells-gtk.lpr 2008/04/13 10:59:19 1.1
[1597 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/cells3-porting-notes.lisp 2008/04/13 10:59:19 1.1
[1631 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/compat.lisp 2008/04/13 10:59:19 1.1
[1675 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/conditions.lisp 2008/04/13 10:59:19 1.1
[1713 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/dialogs.lisp 2008/04/13 10:59:19 1.1
[1881 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/display.lisp 2008/04/13 10:59:19 1.1
[2036 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing-area.lisp 2008/04/13 10:59:19 1.1
[2168 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/drawing.lisp 2008/04/13 10:59:19 1.1
[2389 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/entry.lisp 2008/04/13 10:59:20 1.1
[2542 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gl-drawing-area.lisp 2008/04/13 10:59:20 1.1
[2552 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/gtk-app.lisp 2008/04/13 10:59:20 1.1
[2897 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/layout.lisp 2008/04/13 10:59:20 1.1
[3205 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/menus.lisp 2008/04/13 10:59:20 1.1
[3525 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/packages.lisp 2008/04/13 10:59:20 1.1
[3670 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/textview.lisp 2008/04/13 10:59:20 1.1
[3843 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/tree-view.lisp 2008/04/13 10:59:20 1.1
[4614 lines skipped]
--- /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 NONE
+++ /project/cells/cvsroot/cells-gtk3/cells-gtk/widgets.lisp 2008/04/13 10:59:20 1.1
[5078 lines skipped]
More information about the Cells-cvs
mailing list