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@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]