X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/b6d4ac86c7f32c64e5a0debea5ad93f2f00672e7..6b8476ec8e59cd6b469a97a220379e6aae76897b:/gtk/gtktree.lisp diff --git a/gtk/gtktree.lisp b/gtk/gtktree.lisp index 503b5c5..d884dd0 100644 --- a/gtk/gtktree.lisp +++ b/gtk/gtktree.lisp @@ -20,7 +20,7 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gtktree.lisp,v 1.19 2006-04-26 12:13:38 espen Exp $ +;; $Id: gtktree.lisp,v 1.34 2008-04-11 20:53:32 espen Exp $ (in-package "GTK") @@ -73,6 +73,14 @@ (defbinding cell-layout-clear-attributes () nil (cell cell-renderer)) +;;;; Cell Renderer + +(defmethod compute-signal-function ((gobject cell-renderer-toggle) (signal (eql 'toggled)) function object args) + (declare (ignore gobject signal function object args)) + (let ((function (call-next-method))) + #'(lambda (object path) + (funcall function object (ensure-tree-path path))))) + ;;;; List Store @@ -90,46 +98,76 @@ (defmethod initialize-instance ((list-store list-store) &key column-types for row in initial-content do (list-store-append list-store row iter)))) -(defgeneric column-setter-name (store)) - -(defmethod column-setter-name ((list-store list-store)) - (declare (ignore list-store)) - "gtk_list_store_set") (defbinding %list-store-set-column-types () nil (list-store list-store) ((length columns) unsigned-int) (columns (vector gtype))) -(defbinding %list-store-remove () boolean +(defbinding list-store-remove (store row) boolean + (store list-store) + ((ensure-tree-iter store row) tree-iter)) + +(defbinding %list-store-set-value () nil (list-store list-store) - (tree-iter tree-iter)) + (tree-iter tree-iter) + (column int) + (gvalue gvalue)) -(defun list-store-remove (store row) - (etypecase row - (tree-iter - (%list-store-remove store row)) - (tree-path - (multiple-value-bind (valid iter) (tree-model-get-iter store row) - (if valid - (%list-store-remove store iter) - (error "~A not poiniting to a valid iterator in ~A" row store)))) - (tree-row-reference - (let ((path (tree-row-reference-get-path row))) - (if path - (list-store-remove store path) - (error "~A not valid" row)))))) +(defmethod (setf tree-model-value) (value (store list-store) row column) + (let* ((index (tree-model-column-index store column)) + (type (tree-model-get-column-type store index))) + (with-gvalue (gvalue type value) + (%list-store-set-value store (ensure-tree-iter store row) index gvalue))) + value) +(defbinding %list-store-insert-with-valuesv () nil + (list-store list-store) + (tree-iter tree-iter) + (position int) + (columns (vector int)) + (gvalues pointer) + ((length columns) int)) (defbinding %list-store-insert () nil (list-store list-store) (tree-iter tree-iter) (position int)) -(defun list-store-insert - (store position &optional data (iter (make-instance 'tree-iter))) - (%list-store-insert store iter position) - (when data (%tree-model-set store iter data)) +(defun list-store-insert (store position &optional data (iter (make-instance 'tree-iter))) + (etypecase data + (null (%list-store-insert store iter position)) + + (list (with-memory (gvalues (* (/ (length data) 2) +gvalue-size+)) + (let ((columns + (loop + for (column value) on data by #'cddr + as index = (tree-model-column-index store column) + as type = (tree-model-get-column-type store index) + as gvalue = gvalues then (pointer+ gvalue +gvalue-size+) + do (gvalue-init gvalue type value) + collect index))) + (unwind-protect + (%list-store-insert-with-valuesv store iter position columns gvalues) + (loop + repeat (length columns) + as gvalue = gvalues then (pointer+ gvalue +gvalue-size+) + do (gvalue-unset gvalue)))))) + + (vector (with-memory (gvalues (* (length data) +gvalue-size+)) + (let ((columns + (loop + for index below (length data) + as type = (tree-model-get-column-type store index) + as gvalue = gvalues then (pointer+ gvalue +gvalue-size+) + do (gvalue-init gvalue type (aref data index)) + collect index))) + (unwind-protect + (%list-store-insert-with-valuesv store iter position columns gvalues)) + (loop + repeat (length data) + as gvalue = gvalues then (pointer+ gvalue +gvalue-size+) + do (gvalue-unset gvalue)))))) iter) (defbinding %list-store-insert-before () nil @@ -140,11 +178,10 @@ (defbinding %list-store-insert-before () nil (defun list-store-insert-before (store sibling &optional data (iter (make-instance 'tree-iter))) (%list-store-insert-before store iter sibling) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) -(defbinding %list-store-insert-after - (list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil +(defbinding %list-store-insert-after () nil (list-store list-store) (tree-iter tree-iter) (sibling (or null tree-iter))) @@ -152,7 +189,7 @@ (defbinding %list-store-insert-after (defun list-store-insert-after (store sibling &optional data (iter (make-instance 'tree-iter))) (%list-store-insert-after store iter sibling) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %list-store-prepend () nil @@ -162,7 +199,7 @@ (defbinding %list-store-prepend () nil (defun list-store-prepend (store &optional data (iter (make-instance 'tree-iter))) (%list-store-prepend store iter) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %list-store-append () nil @@ -172,7 +209,7 @@ (defbinding %list-store-append () nil (defun list-store-append (store &optional data (iter (make-instance 'tree-iter))) (%list-store-append store iter) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding list-store-clear () nil @@ -198,7 +235,7 @@ (defbinding list-store-move-after () nil (psoition tree-iter)) -;;; Tree Model +;;; Tree Path (defbinding %tree-path-free () nil (location pointer)) @@ -210,24 +247,27 @@ (defbinding %tree-path-get-depth () int (location pointer)) (defun %make-tree-path (path) - (let ((c-vector (make-c-vector 'int (length path) :content path)) - (location (allocate-memory (+ (size-of 'int) (size-of 'pointer))))) + (let* ((c-vector (make-c-vector 'int (length path) :content path)) + (pointer-offset (adjust-offset (size-of 'int) 'pointer)) + (location (allocate-memory (+ pointer-offset (size-of 'pointer))))) (funcall (writer-function 'int) (length path) location) - (funcall (writer-function 'pointer) c-vector location (size-of 'int)) + (funcall (writer-function 'pointer) c-vector location pointer-offset) location)) (defun %tree-path-to-vector (location) - (let ((indices (%tree-path-get-indices location)) - (depth (%tree-path-get-depth location))) - (if (null-pointer-p indices) - #() - (map-c-vector 'vector #'identity indices 'int depth)))) + (unless (null-pointer-p location) + (let ((indices (%tree-path-get-indices location)) + (depth (%tree-path-get-depth location))) + (if (null-pointer-p indices) + #() + (map-c-vector 'vector #'identity indices 'int depth))))) (defmacro %with-tree-path ((var path) &body body) - (let ((vector-offset (+ (size-of 'int) (size-of 'pointer)))) - `(with-memory (,var (+ ,(size-of 'int) ,(size-of 'pointer) (* ,(size-of 'int) (length ,path)))) + (let* ((pointer-offset (adjust-offset (size-of 'int) 'pointer)) + (vector-offset (adjust-offset (+ pointer-offset (size-of 'pointer)) 'int))) + `(with-memory (,var (+ ,vector-offset (* ,(size-of 'int) (length ,path)))) (funcall (writer-function 'int) (length ,path) ,var) - (setf (ref-pointer ,var ,(size-of 'int)) (pointer+ ,var ,vector-offset)) + (setf (ref-pointer ,var ,pointer-offset) (pointer+ ,var ,vector-offset)) (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset)) ,@body))) @@ -306,6 +346,22 @@ (define-type-method destroy-function ((type tree-path) &key temp inlined) #'(lambda (location &optional (offset 0)) (%tree-path-free (ref-pointer location offset)))) +(defun ensure-tree-path (path) + (etypecase path + (string (map 'vector #'parse-integer + (clg-utils:split-string path :delimiter #\:))) + (vector path))) + + +;;; Tree Model + +(defgeneric tree-model-value (model row column)) +(defgeneric (setf tree-model-value) (value model row column)) +(defgeneric tree-model-row-data (model row)) +(defgeneric (setf tree-model-row-data) (data model row)) +(defgeneric tree-model-column-index (model column)) +(defgeneric tree-model-column-name (model index)) + (defbinding %tree-row-reference-new () pointer (model tree-model) @@ -314,23 +370,42 @@ (defbinding %tree-row-reference-new () pointer (defmethod allocate-foreign ((reference tree-row-reference) &key model path) (%tree-row-reference-new model path)) -(defbinding tree-row-reference-get-path () tree-path +(defbinding tree-row-reference-get-path () (or null tree-path) (reference tree-row-reference)) (defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean (reference tree-row-reference)) -(defbinding tree-model-get-column-type () gtype ;type-number +(defbinding tree-model-get-column-type () gtype (tree-model tree-model) (index int)) -(defbinding tree-model-get-iter - (model path &optional (iter (make-instance 'tree-iter))) boolean +(defbinding tree-model-get-iter (model path &optional (iter (make-instance 'tree-iter))) boolean (model tree-model) (iter tree-iter :in/return) - (path tree-path)) + ((ensure-tree-path path) tree-path)) + +#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0") +(defmethod allocate-foreign ((tree-iter tree-iter) &rest initargs) + (declare (ignore initargs)) + (let ((size (foreign-size (class-of tree-iter)))) + (slice-alloc size))) +(defun ensure-tree-iter (model row) + (etypecase row + (tree-iter row) + ((or tree-path string) + (multiple-value-bind (valid-p iter) (tree-model-get-iter model row) + (if valid-p + iter + (error "Invalid tree path for ~A: ~A" model row)))) + (tree-row-reference + (let ((path (tree-row-reference-get-path row))) + (if path + (ensure-tree-iter model path) + (error "~A not valid" row)))))) + (defbinding tree-model-get-path () tree-path (tree-model tree-model) (iter tree-iter)) @@ -341,19 +416,19 @@ (defbinding %tree-model-get-value () nil (column int) (gvalue gvalue)) -(defgeneric tree-model-value (model row column)) - (defmethod tree-model-value ((model tree-model) row column) - (let ((index (column-index model column)) - (iter (etypecase row - (tree-iter row) - (tree-path (multiple-value-bind (valid iter) - (tree-model-get-iter model row) - (if valid - iter - (error "Invalid tree path: ~A" row))))))) + (let ((index (tree-model-column-index model column))) (with-gvalue (gvalue) - (%tree-model-get-value model iter index gvalue)))) + (%tree-model-get-value model (ensure-tree-iter model row) index gvalue)))) + +(defmethod tree-model-row-data ((model tree-model) row) + (coerce + (loop + with iter = (ensure-tree-iter model row) + for index from 0 below (tree-model-n-columns model) + collect (tree-model-value model iter index)) + 'vector)) + (defbinding tree-model-iter-next () boolean (tree-model tree-model) @@ -370,9 +445,9 @@ (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child") (tree-model tree-model) (iter tree-iter)) -(defbinding tree-model-iter-n-children () int +(defbinding tree-model-iter-n-children (tree-model &optional iter) int (tree-model tree-model) - (iter tree-iter)) + (iter (or null tree-iter))) (defbinding tree-model-iter-nth-child (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean @@ -425,87 +500,31 @@ (defbinding tree-model-rows-reordered () nil (iter tree-iter) (new-order int)) - -(defun column-types (model columns) - (declare (ignore model)) - (map 'vector - #'(lambda (column) - (find-type-number (first (mklist column)))) - columns)) - -(defun column-index (model column) +(defmethod tree-model-column-index ((model tree-model) column) (or (etypecase column (number column) - (symbol (position column (user-data model 'column-names))) - (string (position column (user-data model 'column-names) - :test #'string=))) + (string (position column (user-data model 'column-names) :test #'string=)) + (symbol (position column (user-data model 'column-names)))) (error "~A has no column ~S" model column))) -(defun column-name (model index) +(defmethod tree-model-column-name ((model tree-model) index) (svref (user-data model 'column-names) index)) -(defun tree-model-column-value-setter (model column) - (let ((setters (or - (user-data model 'column-setters) - (setf - (user-data model 'column-setters) - (make-array (tree-model-n-columns model) - :initial-element nil))))) - (let ((index (column-index model column))) - (or - (svref setters index) - (setf - (svref setters index) - (let ((setter - (mkbinding (column-setter-name model) - nil (type-of model) 'tree-iter 'int - (tree-model-get-column-type model index) - 'int))) - #'(lambda (value iter) - (funcall setter model iter index value -1)))))))) - -(defun tree-model-row-setter (model) - (or - (user-data model 'row-setter) - (progn - ;; This will create any missing column setter - (loop - for i from 0 below (tree-model-n-columns model) - do (tree-model-column-value-setter model i)) - (let ((setters (user-data model 'column-setters))) - (setf - (user-data model 'row-setter) - #'(lambda (row iter) - (map nil #'(lambda (value setter) - (funcall setter value iter)) - row setters))))))) -(defgeneric (setf tree-model-value) (value model row column)) - -(defmethod (setf tree-model-value) (value (model tree-model) row column) - (let ((iter (etypecase row - (tree-iter row) - (tree-path (multiple-value-bind (valid iter) - (tree-model-get-iter model row) - (if valid - iter - (error "Invalid tree path: ~A" row))))))) - (funcall (tree-model-column-value-setter model column) value iter) - value)) - -(defun (setf tree-model-row-data) (data model iter) - (funcall (tree-model-row-setter model) data iter) +(defmethod (setf tree-model-row-data) ((data list) (model tree-model) (iter tree-iter)) + (loop + for (column value) on data by #'cddr + do (setf (tree-model-value model iter column) value)) data) -(defun %tree-model-set (model iter data) - (etypecase data - (vector (setf (tree-model-row-data model iter) data)) - (cons - (loop - as (column value . rest) = data then rest - do (setf (tree-model-value model iter column) value) - while rest)))) +(defmethod (setf tree-model-row-data) ((data vector) (model tree-model) row) + (loop + with iter = (ensure-tree-iter model row) + for index from 0 + for value across data + do (setf (tree-model-value model iter index) value)) + data) ;;; Tree Selection @@ -557,15 +576,15 @@ (defbinding %tree-selection-path-is-selected () boolean (defbinding %tree-selection-select-iter () nil (tree-selection tree-selection) - (tree-path tree-path)) + (tree-iter tree-iter)) (defbinding %tree-selection-unselect-iter () nil (tree-selection tree-selection) - (tree-path tree-path)) + (tree-iter tree-iter)) (defbinding %tree-selection-iter-is-selected () boolean (tree-selection tree-selection) - (tree-path tree-path)) + (tree-iter tree-iter)) (defun tree-selection-select (selection row) (etypecase row @@ -623,7 +642,7 @@ (defun tree-sortable-get-sort-column (sortable) (values (if special-p (int-to-sort-order column) - (column-name sortable column)) + (tree-model-column-name sortable column)) order))) (defbinding (tree-sortable-set-sort-column @@ -632,13 +651,13 @@ (defbinding (tree-sortable-set-sort-column (sortable tree-sortable) ((etypecase column ((or integer sort-column) column) - (symbol (column-index sortable column))) + (symbol (tree-model-column-index sortable column))) (or sort-column int)) (order sort-type)) (defbinding %tree-sortable-set-sort-func (sortable column function) nil (sortable tree-sortable) - ((column-index sortable column) int) + ((tree-model-column-index sortable column) int) (%tree-iter-compare-callback callback) ((register-callback-function function) unsigned-int) (user-data-destroy-callback callback)) @@ -681,9 +700,20 @@ (defmethod initialize-instance ((tree-store tree-store) &key column-types (when column-names (setf (user-data tree-store 'column-names) column-names))) -(defmethod column-setter-name ((tree-store tree-store)) - (declare (ignore tree-store)) - "gtk_tree_store_set") + +(defbinding %tree-store-set-value () nil + (tree-store tree-store) + (tree-iter tree-iter) + (column int) + (gvalue gvalue)) + +(defmethod (setf tree-model-value) (value (store tree-store) row column) + (let* ((index (tree-model-column-index store column)) + (type (tree-model-get-column-type store index))) + (with-gvalue (gvalue type value) + (%tree-store-set-value store (ensure-tree-iter store row) index gvalue))) + value) + (defbinding tree-store-remove () boolean (tree-store tree-store) @@ -698,7 +728,7 @@ (defbinding %tree-store-insert () nil (defun tree-store-insert (store parent position &optional data (iter (make-instance 'tree-iter))) (%tree-store-insert store iter parent position) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %tree-store-insert-before () nil @@ -710,7 +740,7 @@ (defbinding %tree-store-insert-before () nil (defun tree-store-insert-before (store parent sibling &optional data (iter (make-instance 'tree-iter))) (%tree-store-insert-before store iter parent sibling) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %tree-store-insert-after () nil @@ -722,7 +752,7 @@ (defbinding %tree-store-insert-after () nil (defun tree-store-insert-after (store parent sibling &optional data (iter (make-instance 'tree-iter))) (%tree-store-insert-after store iter parent sibling) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %tree-store-prepend () nil @@ -733,7 +763,7 @@ (defbinding %tree-store-prepend () nil (defun tree-store-prepend (store parent &optional data (iter (make-instance 'tree-iter))) (%tree-store-prepend store iter parent) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding %tree-store-append () nil @@ -744,7 +774,7 @@ (defbinding %tree-store-append () nil (defun tree-store-append (store parent &optional data (iter (make-instance 'tree-iter))) (%tree-store-append store iter parent) - (when data (%tree-model-set store iter data)) + (when data (setf (tree-model-row-data store iter) data)) iter) (defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean @@ -818,7 +848,11 @@ (defbinding tree-view-move-column-after () nil (column tree-view-column) (base-column (or null tree-view-column))) -;;(defbinding tree-view-set-column drag-function ...) +#+(or) +(define-callback-setter tree-view-set-column-drag-function tree-view boolean + (column tree-view-column) + (prev tree-view-column) + (next tree-view-column)) (defbinding tree-view-scroll-to-point () nil (tree-view tree-view) @@ -833,13 +867,8 @@ (defbinding tree-view-scroll-to-cell () nil (row-align single-float) (col-align single-float)) -(defbinding tree-view-set-cursor () nil - (tree-view tree-view) - (path tree-path) - (focus-column tree-view-column) - (start-editing boolean)) - -(defbinding tree-view-set-cursor-on-cell () nil +(defbinding (tree-view-set-cursor "gtk_tree_view_set_cursor_on_cell") + (tree-view path &key focus-column focus-cell start-editing) nil (tree-view tree-view) (path tree-path) (focus-column (or null tree-view-column)) @@ -967,19 +996,55 @@ (defbinding %icon-view-set-text-column (column icon-view) nil (icon-view icon-view) ((if (integerp column) column - (column-index (icon-view-model icon-view) column)) int)) + (tree-model-column-index (icon-view-model icon-view) column)) int)) + + (defbinding %%icon-view-get-text-column () int + (icon-view icon-view)) + + (defun %icon-view-get-text-column (icon-view) + (tree-model-column-index + (icon-view-model icon-view) + (%%icon-view-get-text-column icon-view))) + + (defun %icon-view-text-column-boundp (icon-view) + (not (eql (%%icon-view-get-text-column icon-view) -1))) + (defbinding %icon-view-set-markup-column (column icon-view) nil (icon-view icon-view) ((if (integerp column) column - (column-index (icon-view-model icon-view) column)) int)) + (tree-model-column-index (icon-view-model icon-view) column)) int)) + + (defbinding %%icon-view-get-markup-column () int + (icon-view icon-view)) + + (defun %icon-view-get-markup-column (icon-view) + (tree-model-column-index + (icon-view-model icon-view) + (%%icon-view-get-markup-column icon-view))) + + (defun %icon-view-markup-column-boundp (icon-view) + (not (eql (%%icon-view-get-markup-column icon-view) -1))) + (defbinding %icon-view-set-pixbuf-column (column icon-view) nil (icon-view icon-view) ((if (integerp column) column - (column-index (icon-view-model icon-view) column)) int))) + (tree-model-column-index (icon-view-model icon-view) column)) int))) + + (defbinding %%icon-view-get-pixbuf-column () int + (icon-view icon-view)) + + (defun %icon-view-get-pixbuf-column (icon-view) + (tree-model-column-index + (icon-view-model icon-view) + (%%icon-view-get-pixbuf-column icon-view))) + + (defun %icon-view-pixbuf-column-boundp (icon-view) + (not (eql (%%icon-view-get-pixbuf-column icon-view) -1))) + #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0") (progn @@ -1024,18 +1089,18 @@ (defbinding icon-view-get-visible-range () boolean (start-path tree-path :out) (end-path tree-path :out)) -;; (defbinding icon-view-enable-model-drag-source () nil -;; (icon-view icon-view) -;; (start-button-mask gdk:modifier-type) -;; (targets (vector target-entry)) -;; ((length targets) unsigned-int) -;; (actions gdk:drag-action)) - -;; (defbinding icon-view-enable-model-drag-dest () nil -;; (icon-view icon-view) -;; (targets (vector target-entry)) -;; ((length targets) unsigned-int) -;; (actions gdk:drag-action)) + (defbinding icon-view-enable-model-drag-source () nil + (icon-view icon-view) + (start-button-mask gdk:modifier-type) + (targets (vector (inlined target-entry))) + ((length targets) unsigned-int) + (actions gdk:drag-action)) + + (defbinding icon-view-enable-model-drag-dest () nil + (icon-view icon-view) + (targets (vector (inlined target-entry))) + ((length targets) unsigned-int) + (actions gdk:drag-action)) (defbinding icon-view-unset-model-drag-source () nil (icon-view icon-view))