[clg] / gtk / gtktree.lisp

;; Common Lisp bindings for GTK+ v2.0
;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
;; License as published by the Free Software Foundation; either
;; version 2 of the License, or (at your option) any later version.
;;
;; This library 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 GNU
;; Lesser General Public License for more details.
;;
;; You should have received a copy of the GNU Lesser General Public
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; $Id: gtktree.lisp,v 1.2 2004-11-15 19:24:03 espen Exp $


(in-package "GTK")


;;;; Cell Layout

(defbinding cell-layout-pack-start () nil
  (cell-layout cell-layout)
  (cell cell-renderer)
  (expand boolean))

(defbinding cell-layout-pack-end () nil
  (cell-layout cell-layout)
  (cell cell-renderer)
  (expand boolean))

(defun cell-layout-pack (layout cell &key end expand)
  (if end
      (cell-layout-pack-end layout cell expand)
    (cell-layout-pack-start layout cell expand)))


(defbinding cell-layout-reorder () nil
  (cell-layout cell-layout)
  (cell cell-renderer)
  (position int))

(defbinding cell-layout-clear () nil
  (cell-layout cell-layout))

(defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
  (cell-layout cell-layout)
  (cell cell-renderer)
  ((string-downcase attribute) string)
  (column int))

(def-callback-marshal %cell-layout-data-func 
    (nil cell-layout cell-renderer tree-model tree-iter))

(defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
  (cell-layout cell-layout)
  (cell cell-renderer)
  ((callback %cell-layout-data-func) pointer)
  ((register-callback-function function) unsigned-int)
  ((callback %destroy-user-data) pointer))

(defbinding cell-layout-clear-attributes () nil
  (cell-layout cell-layout)
  (cell cell-renderer))


;;;; List Store

(defmethod initialize-instance ((list-store list-store) &key column-types
				column-names initial-content)
  (call-next-method)
  (%list-store-set-column-types list-store column-types)
  (when column-names
    (setf (object-data list-store 'column-names) column-names))
  (when initial-content
    (loop
     with iter = (make-instance 'tree-iter)
     for row in initial-content
     do (list-store-append list-store row iter))))


(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
  (list-store list-store)
  (tree-iter tree-iter))

(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))
  iter)

(defbinding %list-store-insert-before () nil
  (list-store list-store)
  (tree-iter tree-iter)
  (sibling (or null tree-iter)))

(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))
  iter)

(defbinding %list-store-insert-after 
    (list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil
  (list-store list-store)
  (tree-iter tree-iter)
  (sibling (or null tree-iter)))

(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))
  iter)

(defbinding %list-store-prepend () nil
  (list-store list-store)
  (tree-iter tree-iter))

(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))
  iter)

(defbinding %list-store-append () nil
  (list-store list-store)
  (tree-iter tree-iter))

(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))
  iter)

(defbinding list-store-clear () nil
  (list-store list-store))

(defbinding list-store-reorder () nil
  (list-store list-store)
  (new-order (vector int)))

(defbinding list-store-swap () nil
  (list-store list-store)
  (a tree-iter)
  (b tree-iter))

(defbinding list-store-move-before () nil
  (list-store list-store)
  (iter tree-iter)
  (psoition (or null tree-iter)))

(defbinding list-store-move-after () nil
  (list-store list-store)
  (iter tree-iter)
  (psoition tree-iter))


;;; Tree Model

(defbinding %tree-path-free () nil
  (location pointer))

(defbinding %tree-path-get-indices () pointer
  (location pointer))

(defbinding %tree-path-get-depth () int
  (location pointer))

(defun %make-tree-path (path)
  (let ((c-vector (make-c-vector 'int (length path) path))
	(location (allocate-memory (+ (size-of 'int) (size-of 'pointer)))))
    (funcall (writer-function 'int) (length path) location)
    (funcall (writer-function 'pointer) c-vector location (size-of 'int))
    location))

(defun %tree-path-to-vector (location &optional (destroy-p t))
  (prog1
      (map-c-vector 'vector #'identity (%tree-path-get-indices location)
		    'int (%tree-path-get-depth location))
    (when destroy-p
      (%tree-path-free location))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmethod alien-type ((type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    (alien-type 'pointer))
  
  (defmethod size-of ((type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    (size-of 'pointer))
  
  (defmethod to-alien-form (path (type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    `(%make-tree-path ,path))
  
  (defmethod to-alien-function ((type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    #'%make-tree-path)
  
  (defmethod from-alien-form (location (type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    `(%tree-path-to-vector ,location))
  
  (defmethod from-alien-function ((type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    #'%tree-path-to-vector)
  
  (defmethod cleanup-form (location (type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    `(%tree-path-free ,location))
  
  (defmethod cleanup-function ((type (eql 'tree-path)) &rest args)
    (declare (ignore type args))
    #'%tree-path-free))


(defbinding %tree-row-reference-new () pointer
  (model tree-model)
  (path tree-path))

(defmethod initialize-instance ((reference tree-row-reference) &key model path)
  (declare (ignore initargs))
  (setf
   (slot-value reference 'location)
   (%tree-row-reference-new model path))
  (call-next-method))

(defbinding tree-row-reference-get-path () 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 () type-number
  (tree-model tree-model)
  (index int))

(defbinding tree-model-get-iter 
    (model path &optional (iter (make-instance 'tree-iter))) boolean
  (model tree-model)
  (iter tree-iter :return)
  (path tree-path))
 
(defbinding tree-model-get-path () tree-path
  (tree-model tree-model)
  (iter tree-iter))

(defbinding %tree-model-get-value () nil
  (tree-model tree-model)
  (iter tree-iter)
  (column int)
  (gvalue gvalue))

(defun tree-model-get-column-value (model iter column)
  (let ((index (column-index model column)))
    (with-gvalue (gvalue (tree-model-get-column-type model index))
      (%tree-model-get-value model iter index gvalue))))

(defbinding tree-model-iter-next () boolean
  (tree-model tree-model)
  (iter tree-iter :return))

(defbinding tree-model-iter-children 
    (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
  (tree-model tree-model)
  (iter tree-iter :return)
  (parent (or null tree-iter)))

(defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child") 
    () boolean
  (tree-model tree-model)
  (iter tree-iter))

(defbinding tree-model-iter-n-children () int
  (tree-model tree-model)
  (iter tree-iter))

(defbinding tree-model-iter-nth-child
    (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
  (tree-model tree-model)
  (iter tree-iter :return)
  (parent (or null tree-iter))
  (n int))

(defbinding tree-model-iter-parent
    (tree-model child &optional (iter (make-instance 'tree-iter))) boolean
  (tree-model tree-model)
  (iter tree-iter :return)
  (child tree-iter))

(defbinding tree-model-get-string-from-iter () string
  (tree-model tree-model)
  (iter tree-iter))

(def-callback-marshal %tree-model-foreach-func 
  (boolean tree-model tree-path tree-iter))

(defbinding %tree-model-foreach () nil
  (tree-model tree-model)
  ((callback %tree-model-foreach-func) pointer)
  (callback-id unsigned-int))

(defun tree-model-foreach (model function)
  (with-callback-function (id function)
    (%tree-model-foreach model id)))

(defbinding tree-model-row-changed () nil
  (tree-model tree-model)
  (path tree-path)
  (iter tree-iter))

(defbinding tree-model-row-inserted () nil
  (tree-model tree-model)
  (path tree-path)
  (iter tree-iter))

(defbinding tree-model-row-has-child-toggled () nil
  (tree-model tree-model)
  (path tree-path)
  (iter tree-iter))

(defbinding tree-model-row-deleted () nil
  (tree-model tree-model)
  (path tree-path)
  (iter tree-iter))

(defbinding tree-model-rows-reordered () nil
  (tree-model tree-model)
  (path tree-path)
  (iter tree-iter)
  (new-order int))


(defun column-types (model columns)
  (map 'vector 
       #'(lambda (column)
	   (find-type-number (first (mklist column))))
       columns))
	       
(defun column-index (model column)
  (or
   (etypecase column
     (number column)
     (symbol (position column (object-data model 'column-names)))
     (string (position column (object-data model 'column-names)
		   :test #'string=)))
   (error "~A has no column ~S" model column)))

(defun tree-model-column-value-setter (model column)
  (let ((setters (or
		  (object-data model 'column-setters)
		  (setf 
		   (object-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
	      (type-from-number (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 
   (object-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 (object-data model 'column-setters)))
       (setf    
	(object-data model 'row-setter)
	#'(lambda (row iter)
	    (map nil #'(lambda (value setter)
			 (funcall setter value iter))
		 row setters)))))))

(defun (setf tree-model-column-value) (value model iter column)
  (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)
  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-column-value model iter column) value)
      while rest))))


;;; Tree Store

(defbinding %tree-store-set-column-types () nil
  (tree-store tree-store)
  ((length columns) unsigned-int)
  (columns (vector gtype)))

(defmethod initialize-instance ((tree-store tree-store) &key column-types
				column-names)
  (call-next-method)
  (%tree-store-set-column-types tree-store column-types)
  (when column-names
    (setf (object-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-remove () boolean
  (tree-store tree-store)
  (tree-iter tree-iter))

(defbinding %tree-store-insert () nil
  (tree-store tree-store)
  (tree-iter tree-iter)
  (parent (or null tree-iter))
  (position int))

(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))
  iter)

(defbinding %tree-store-insert-before () nil
  (tree-store tree-store)
  (tree-iter tree-iter)
  (parent (or null tree-iter))
  (sibling (or null tree-iter)))

(defun tree-store-insert-after 
    (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))
  iter)

(defbinding %tree-store-insert-after () nil
  (tree-store tree-store)
  (tree-iter tree-iter)
  (parent (or null tree-iter))
  (sibling (or null tree-iter)))

(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))
  iter)

(defbinding %tree-store-prepend () nil
  (tree-store tree-store)
  (tree-iter tree-iter)
  (parent (or null tree-iter)))

(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))
  iter)

(defbinding %tree-store-append () nil
  (tree-store tree-store)
  (tree-iter tree-iter)
  (parent (or null tree-iter)))

(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))
  iter)

(defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
  (tree-store tree-store)
  (tree-iter tree-iter)
  (descendant tree-iter))

(defbinding tree-store-iter-depth () int
  (tree-store tree-store)
  (tree-iter tree-iter))

(defbinding tree-store-clear () nil
  (tree-store tree-store))

(defbinding tree-store-reorder () nil
  (tree-store tree-store)
  (parent tree-iter)
  (new-order (vector int)))

(defbinding tree-store-swap () nil
  (tree-store tree-store)
  (a tree-iter)
  (b tree-iter))

(defbinding tree-store-move-before () nil
  (tree-store tree-store)
  (iter tree-iter)
  (psoition (or null tree-iter)))


(defbinding tree-store-move-after () nil
  (tree-store tree-store)
  (iter tree-iter)
  (psoition tree-iter))


;;; Tree View

(defmethod initialize-instance ((tree-view tree-view) &key column)
  (call-next-method)
  (mapc #'(lambda (column)
	    (tree-view-append-column tree-view column))
	(get-all initargs :column)))


(defbinding tree-view-get-selection () tree-selection
  (tree-view tree-view))

(defbinding tree-view-columns-autosize () nil
  (tree-view tree-view))

(defbinding tree-view-append-column () int
  (tree-view tree-view)
  (tree-view-column tree-view-column))

(defbinding tree-view-remove-column () int
  (tree-view tree-view)
  (tree-view-column tree-view-column))

(defbinding tree-view-insert-column (view columnd position) int
  (view tree-view)
  (column tree-view-column)
  ((if (eq position :end) -1 position) int))

(defbinding tree-view-get-column () tree-view-column
  (tree-view tree-view)
  (position int))

(defbinding tree-view-move-column-after () nil
  (tree-view tree-view)
  (column tree-view-column)
  (base-column (or null tree-view-column)))

;;(defbinding tree-view-set-column drag-function ...)

(defbinding tree-view-scroll-to-point () nil
  (tree-view tree-view)
  (tree-x int)
  (tree-y int))

(defbinding tree-view-scroll-to-cell () nil
  (tree-view tree-view)
  (path (or null tree-path))
  (column (or null tree-view-column))
  (use-align boolean)
  (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
  (tree-view tree-view)
  (path tree-path)
  (focus-column (or null tree-view-column))
  (focus-cell (or null cell-renderer))
  (start-editing boolean))

(defbinding tree-view-get-cursor () nil
  (tree-view tree-view)
  (path tree-path :out )
  (focus-column tree-view-column :out))

(defbinding tree-view-row-activated () nil
  (tree-view tree-view)
  (path tree-path )
  (column tree-view-column))

(defbinding tree-view-expand-all () nil
  (tree-view tree-view))

(defbinding tree-view-collapse-all () nil
  (tree-view tree-view))

(defbinding tree-view-expand-to-path () nil
  (tree-view tree-view)
  (path tree-path))

(defbinding tree-view-expand-row () nil
  (tree-view tree-view)
  (path tree-path)
  (open-all boolean))

(defbinding tree-view-collapse-row () nil
  (tree-view tree-view)
  (path tree-path))

(def-callback-marshal %tree-view-mapping-func (nil tree-view tree-path))

(defbinding %tree-view-map-expanded-rows () nil
  (tree-view tree-view)
  ((callback %tree-view-mapping-func) pointer)
  (callback-id unsigned-int))

(defun map-expanded-rows (function tree-view)
  (with-callback-function (id function)
    (%tree-view-map-expanded-rows tree-view id)))

(defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
  (tree-view tree-view)
  (path tree-path))

(defbinding tree-view-get-path-at-pos 
    (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
  (tree-view tree-view)
  (x int)
  (y int)
  (path tree-path :out)
  (column tree-view-column :out)
  (cell-x int)
  (cell-y int))

(defbinding tree-view-get-cell-area () nil
  (tree-view tree-view)
  (path (or null tree-path))
  (column (or null tree-view-column))
  ((make-instance 'gdk:rectangle) gdk:rectangle :return))

(defbinding tree-view-get-background-area () nil
  (tree-view tree-view)
  (path (or null tree-path))
  (column (or null tree-view-column))
  ((make-instance 'gdk:rectangle) gdk:rectangle :return))

(defbinding tree-view-get-visible-rect () nil
  (tree-view tree-view)
  ((make-instance 'gdk:rectangle) gdk:rectangle :return))

;; and many more functions which we'll add later


;;; Tree View Column
Commit	Line	Data
167450a3	1	;; Common Lisp bindings for GTK+ v2.0
	2	;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
	3	;;
	4	;; This library is free software; you can redistribute it and/or
	5	;; modify it under the terms of the GNU Lesser General Public
	6	;; License as published by the Free Software Foundation; either
	7	;; version 2 of the License, or (at your option) any later version.
	8	;;
	9	;; This library is distributed in the hope that it will be useful,
	10	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	11	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	12	;; Lesser General Public License for more details.
	13	;;
	14	;; You should have received a copy of the GNU Lesser General Public
	15	;; License along with this library; if not, write to the Free Software
	16	;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	17
2a8752b0	18	;; $Id: gtktree.lisp,v 1.2 2004-11-15 19:24:03 espen Exp $
167450a3	19
	20
	21	(in-package "GTK")
	22
	23
	24	;;;; Cell Layout
	25
	26	(defbinding cell-layout-pack-start () nil
	27	(cell-layout cell-layout)
	28	(cell cell-renderer)
	29	(expand boolean))
	30
	31	(defbinding cell-layout-pack-end () nil
	32	(cell-layout cell-layout)
	33	(cell cell-renderer)
	34	(expand boolean))
	35
	36	(defun cell-layout-pack (layout cell &key end expand)
	37	(if end
	38	(cell-layout-pack-end layout cell expand)
	39	(cell-layout-pack-start layout cell expand)))
	40
2a8752b0	41
167450a3	42	(defbinding cell-layout-reorder () nil
	43	(cell-layout cell-layout)
	44	(cell cell-renderer)
	45	(position int))
	46
	47	(defbinding cell-layout-clear () nil
	48	(cell-layout cell-layout))
	49
	50	(defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
	51	(cell-layout cell-layout)
	52	(cell cell-renderer)
	53	((string-downcase attribute) string)
	54	(column int))
	55
	56	(def-callback-marshal %cell-layout-data-func
	57	(nil cell-layout cell-renderer tree-model tree-iter))
	58
	59	(defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
	60	(cell-layout cell-layout)
	61	(cell cell-renderer)
	62	((callback %cell-layout-data-func) pointer)
	63	((register-callback-function function) unsigned-int)
	64	((callback %destroy-user-data) pointer))
	65
	66	(defbinding cell-layout-clear-attributes () nil
	67	(cell-layout cell-layout)
	68	(cell cell-renderer))
	69
	70
	71
	72	;;;; List Store
	73
2a8752b0	74	(defmethod initialize-instance ((list-store list-store) &key column-types
2a8752b0	75	column-names initial-content)
167450a3	76	(call-next-method)
2a8752b0	77	(%list-store-set-column-types list-store column-types)
	78	(when column-names
	79	(setf (object-data list-store 'column-names) column-names))
	80	(when initial-content
	81	(loop
	82	with iter = (make-instance 'tree-iter)
	83	for row in initial-content
	84	do (list-store-append list-store row iter))))
167450a3	85
167450a3	86
2a8752b0	87	(defmethod column-setter-name ((list-store list-store))
	88	(declare (ignore list-store))
	89	"gtk_list_store_set")
167450a3	90
2a8752b0	91	(defbinding %list-store-set-column-types () nil
167450a3	92	(list-store list-store)
2a8752b0	93	((length columns) unsigned-int)
2a8752b0	94	(columns (vector gtype)))
167450a3	95
	96	(defbinding list-store-remove () boolean
	97	(list-store list-store)
	98	(tree-iter tree-iter))
	99
2a8752b0	100	(defbinding %list-store-insert () nil
167450a3	101	(list-store list-store)
2a8752b0	102	(tree-iter tree-iter)
167450a3	103	(position int))
167450a3	104
2a8752b0	105	(defun list-store-insert
	106	(store position &optional data (iter (make-instance 'tree-iter)))
	107	(%list-store-insert store iter position)
	108	(when data (%tree-model-set store iter data))
	109	iter)
	110
	111	(defbinding %list-store-insert-before () nil
167450a3	112	(list-store list-store)
2a8752b0	113	(tree-iter tree-iter)
167450a3	114	(sibling (or null tree-iter)))
167450a3	115
2a8752b0	116	(defun list-store-insert-before
	117	(store sibling &optional data (iter (make-instance 'tree-iter)))
	118	(%list-store-insert-before store iter sibling)
	119	(when data (%tree-model-set store iter data))
	120	iter)
	121
	122	(defbinding %list-store-insert-after
	123	(list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil
167450a3	124	(list-store list-store)
2a8752b0	125	(tree-iter tree-iter)
167450a3	126	(sibling (or null tree-iter)))
167450a3	127
2a8752b0	128	(defun list-store-insert-after
	129	(store sibling &optional data (iter (make-instance 'tree-iter)))
	130	(%list-store-insert-after store iter sibling)
	131	(when data (%tree-model-set store iter data))
	132	iter)
	133
	134	(defbinding %list-store-prepend () nil
167450a3	135	(list-store list-store)
2a8752b0	136	(tree-iter tree-iter))
	137
	138	(defun list-store-prepend
	139	(store &optional data (iter (make-instance 'tree-iter)))
	140	(%list-store-prepend store iter)
	141	(when data (%tree-model-set store iter data))
	142	iter)
167450a3	143
2a8752b0	144	(defbinding %list-store-append () nil
167450a3	145	(list-store list-store)
2a8752b0	146	(tree-iter tree-iter))
	147
	148	(defun list-store-append
	149	(store &optional data (iter (make-instance 'tree-iter)))
	150	(%list-store-append store iter)
	151	(when data (%tree-model-set store iter data))
	152	iter)
167450a3	153
	154	(defbinding list-store-clear () nil
	155	(list-store list-store))
	156
	157	(defbinding list-store-reorder () nil
	158	(list-store list-store)
	159	(new-order (vector int)))
	160
	161	(defbinding list-store-swap () nil
	162	(list-store list-store)
	163	(a tree-iter)
	164	(b tree-iter))
	165
	166	(defbinding list-store-move-before () nil
	167	(list-store list-store)
	168	(iter tree-iter)
	169	(psoition (or null tree-iter)))
	170
167450a3	171	(defbinding list-store-move-after () nil
	172	(list-store list-store)
	173	(iter tree-iter)
	174	(psoition tree-iter))
	175
	176
	177	;;; Tree Model
	178
2a8752b0	179	(defbinding %tree-path-free () nil
	180	(location pointer))
	181
	182	(defbinding %tree-path-get-indices () pointer
	183	(location pointer))
	184
	185	(defbinding %tree-path-get-depth () int
	186	(location pointer))
	187
	188	(defun %make-tree-path (path)
	189	(let ((c-vector (make-c-vector 'int (length path) path))
	190	(location (allocate-memory (+ (size-of 'int) (size-of 'pointer)))))
	191	(funcall (writer-function 'int) (length path) location)
	192	(funcall (writer-function 'pointer) c-vector location (size-of 'int))
	193	location))
	194
	195	(defun %tree-path-to-vector (location &optional (destroy-p t))
	196	(prog1
	197	(map-c-vector 'vector #'identity (%tree-path-get-indices location)
	198	'int (%tree-path-get-depth location))
	199	(when destroy-p
	200	(%tree-path-free location))))
	201
	202	(eval-when (:compile-toplevel :load-toplevel :execute)
	203	(defmethod alien-type ((type (eql 'tree-path)) &rest args)
	204	(declare (ignore type args))
	205	(alien-type 'pointer))
	206
	207	(defmethod size-of ((type (eql 'tree-path)) &rest args)
	208	(declare (ignore type args))
	209	(size-of 'pointer))
	210
	211	(defmethod to-alien-form (path (type (eql 'tree-path)) &rest args)
	212	(declare (ignore type args))
	213	`(%make-tree-path ,path))
	214
	215	(defmethod to-alien-function ((type (eql 'tree-path)) &rest args)
	216	(declare (ignore type args))
	217	#'%make-tree-path)
	218
	219	(defmethod from-alien-form (location (type (eql 'tree-path)) &rest args)
	220	(declare (ignore type args))
	221	`(%tree-path-to-vector ,location))
	222
	223	(defmethod from-alien-function ((type (eql 'tree-path)) &rest args)
	224	(declare (ignore type args))
	225	#'%tree-path-to-vector)
	226
	227	(defmethod cleanup-form (location (type (eql 'tree-path)) &rest args)
	228	(declare (ignore type args))
	229	`(%tree-path-free ,location))
	230
	231	(defmethod cleanup-function ((type (eql 'tree-path)) &rest args)
	232	(declare (ignore type args))
	233	#'%tree-path-free))
	234
	235
	236	(defbinding %tree-row-reference-new () pointer
	237	(model tree-model)
	238	(path tree-path))
	239
	240	(defmethod initialize-instance ((reference tree-row-reference) &key model path)
	241	(declare (ignore initargs))
	242	(setf
243	(slot-value reference 'location)
244	(%tree-row-reference-new model path))
245	(call-next-method))
246
247	(defbinding tree-row-reference-get-path () tree-path
248	(reference tree-row-reference))
249
250	(defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean
251	(reference tree-row-reference))
252
253
254	(defbinding tree-model-get-column-type () type-number
255	(tree-model tree-model)
256	(index int))
257
258	(defbinding tree-model-get-iter
259	(model path &optional (iter (make-instance 'tree-iter))) boolean
260	(model tree-model)
261	(iter tree-iter :return)
262	(path tree-path))
263
264	(defbinding tree-model-get-path () tree-path
265	(tree-model tree-model)
266	(iter tree-iter))
267
268	(defbinding %tree-model-get-value () nil
269	(tree-model tree-model)
270	(iter tree-iter)
271	(column int)
272	(gvalue gvalue))
273
274	(defun tree-model-get-column-value (model iter column)
275	(let ((index (column-index model column)))
276	(with-gvalue (gvalue (tree-model-get-column-type model index))
277	(%tree-model-get-value model iter index gvalue))))
278
279	(defbinding tree-model-iter-next () boolean
280	(tree-model tree-model)
281	(iter tree-iter :return))
282
283	(defbinding tree-model-iter-children
284	(tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
285	(tree-model tree-model)
286	(iter tree-iter :return)
287	(parent (or null tree-iter)))
288
289	(defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child")
290	() boolean
291	(tree-model tree-model)
292	(iter tree-iter))
293
294	(defbinding tree-model-iter-n-children () int
295	(tree-model tree-model)
296	(iter tree-iter))
297
298	(defbinding tree-model-iter-nth-child
299	(tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
300	(tree-model tree-model)
301	(iter tree-iter :return)
302	(parent (or null tree-iter))
303	(n int))
304
305	(defbinding tree-model-iter-parent
306	(tree-model child &optional (iter (make-instance 'tree-iter))) boolean
307	(tree-model tree-model)
308	(iter tree-iter :return)
309	(child tree-iter))
310
311	(defbinding tree-model-get-string-from-iter () string
312	(tree-model tree-model)
313	(iter tree-iter))
314
315	(def-callback-marshal %tree-model-foreach-func
316	(boolean tree-model tree-path tree-iter))
317
318	(defbinding %tree-model-foreach () nil
319	(tree-model tree-model)
320	((callback %tree-model-foreach-func) pointer)
321	(callback-id unsigned-int))
322
323	(defun tree-model-foreach (model function)
324	(with-callback-function (id function)
325	(%tree-model-foreach model id)))
326
327	(defbinding tree-model-row-changed () nil
328	(tree-model tree-model)
329	(path tree-path)
330	(iter tree-iter))
331
332	(defbinding tree-model-row-inserted () nil
333	(tree-model tree-model)
334	(path tree-path)
335	(iter tree-iter))
336
337	(defbinding tree-model-row-has-child-toggled () nil
338	(tree-model tree-model)
339	(path tree-path)
340	(iter tree-iter))
341
342	(defbinding tree-model-row-deleted () nil
343	(tree-model tree-model)
344	(path tree-path)
345	(iter tree-iter))
346
347	(defbinding tree-model-rows-reordered () nil
348	(tree-model tree-model)
349	(path tree-path)
350	(iter tree-iter)
351	(new-order int))
352
353
354	(defun column-types (model columns)
355	(map 'vector
356	#'(lambda (column)
357	(find-type-number (first (mklist column))))
358	columns))
359
360	(defun column-index (model column)
361	(or
362	(etypecase column
363	(number column)
364	(symbol (position column (object-data model 'column-names)))
365	(string (position column (object-data model 'column-names)
366	:test #'string=)))
367	(error "~A has no column ~S" model column)))
368
369	(defun tree-model-column-value-setter (model column)
370	(let ((setters (or
371	(object-data model 'column-setters)
372	(setf
373	(object-data model 'column-setters)
374	(make-array (tree-model-n-columns model)
375	:initial-element nil)))))
376	(let ((index (column-index model column)))
377	(or
378	(svref setters index)
379	(setf
380	(svref setters index)
381	(let ((setter
382	(mkbinding (column-setter-name model)
383	nil (type-of model) 'tree-iter 'int
384	(type-from-number (tree-model-get-column-type model index))
385	'int)))
386	#'(lambda (value iter)
387	(funcall setter model iter index value -1))))))))
388
389	(defun tree-model-row-setter (model)
390	(or
391	(object-data model 'row-setter)
392	(progn
393	;; This will create any missing column setter
394	(loop
395	for i from 0 below (tree-model-n-columns model)
396	do (tree-model-column-value-setter model i))
397	(let ((setters (object-data model 'column-setters)))
398	(setf
399	(object-data model 'row-setter)
400	#'(lambda (row iter)
401	(map nil #'(lambda (value setter)
402	(funcall setter value iter))
403	row setters)))))))
404
405	(defun (setf tree-model-column-value) (value model iter column)
406	(funcall (tree-model-column-value-setter model column) value iter)
407	value)
408
409	(defun (setf tree-model-row-data) (data model iter)
410	(funcall (tree-model-row-setter model) data iter)
411	data)
412
413	(defun %tree-model-set (model iter data)
414	(etypecase data
415	(vector (setf (tree-model-row-data model iter) data))
416	(cons
417	(loop
418	as (column value . rest) = data then rest
419	do (setf (tree-model-column-value model iter column) value)
420	while rest))))
167450a3	421
	422
	423	;;; Tree Store
	424
	425	(defbinding %tree-store-set-column-types () nil
	426	(tree-store tree-store)
2a8752b0	427	((length columns) unsigned-int)
2a8752b0	428	(columns (vector gtype)))
167450a3	429
2a8752b0	430	(defmethod initialize-instance ((tree-store tree-store) &key column-types
2a8752b0	431	column-names)
167450a3	432	(call-next-method)
2a8752b0	433	(%tree-store-set-column-types tree-store column-types)
	434	(when column-names
	435	(setf (object-data tree-store 'column-names) column-names)))
167450a3	436
2a8752b0	437	(defmethod column-setter-name ((tree-store tree-store))
	438	(declare (ignore tree-store))
	439	"gtk_tree_store_set")
167450a3	440
	441	(defbinding tree-store-remove () boolean
	442	(tree-store tree-store)
	443	(tree-iter tree-iter))
	444
2a8752b0	445	(defbinding %tree-store-insert () nil
167450a3	446	(tree-store tree-store)
2a8752b0	447	(tree-iter tree-iter)
167450a3	448	(parent (or null tree-iter))
	449	(position int))
	450
2a8752b0	451	(defun tree-store-insert
	452	(store parent position &optional data (iter (make-instance 'tree-iter)))
	453	(%tree-store-insert store iter parent position)
	454	(when data (%tree-model-set store iter data))
	455	iter)
	456
	457	(defbinding %tree-store-insert-before () nil
167450a3	458	(tree-store tree-store)
2a8752b0	459	(tree-iter tree-iter)
167450a3	460	(parent (or null tree-iter))
	461	(sibling (or null tree-iter)))
	462
2a8752b0	463	(defun tree-store-insert-after
	464	(store parent sibling &optional data (iter (make-instance 'tree-iter)))
	465	(%tree-store-insert-before store iter parent sibling)
	466	(when data (%tree-model-set store iter data))
	467	iter)
	468
	469	(defbinding %tree-store-insert-after () nil
167450a3	470	(tree-store tree-store)
2a8752b0	471	(tree-iter tree-iter)
167450a3	472	(parent (or null tree-iter))
	473	(sibling (or null tree-iter)))
	474
2a8752b0	475	(defun tree-store-insert-after
	476	(store parent sibling &optional data (iter (make-instance 'tree-iter)))
	477	(%tree-store-insert-after store iter parent sibling)
	478	(when data (%tree-model-set store iter data))
	479	iter)
	480
	481	(defbinding %tree-store-prepend () nil
167450a3	482	(tree-store tree-store)
2a8752b0	483	(tree-iter tree-iter)
167450a3	484	(parent (or null tree-iter)))
167450a3	485
2a8752b0	486	(defun tree-store-prepend
	487	(store parent &optional data (iter (make-instance 'tree-iter)))
	488	(%tree-store-prepend store iter parent)
	489	(when data (%tree-model-set store iter data))
	490	iter)
	491
	492	(defbinding %tree-store-append () nil
167450a3	493	(tree-store tree-store)
2a8752b0	494	(tree-iter tree-iter)
167450a3	495	(parent (or null tree-iter)))
167450a3	496
2a8752b0	497	(defun tree-store-append
	498	(store parent &optional data (iter (make-instance 'tree-iter)))
	499	(%tree-store-append store iter parent)
	500	(when data (%tree-model-set store iter data))
	501	iter)
	502
167450a3	503	(defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
	504	(tree-store tree-store)
	505	(tree-iter tree-iter)
	506	(descendant tree-iter))
	507
	508	(defbinding tree-store-iter-depth () int
	509	(tree-store tree-store)
	510	(tree-iter tree-iter))
	511
	512	(defbinding tree-store-clear () nil
	513	(tree-store tree-store))
	514
	515	(defbinding tree-store-reorder () nil
	516	(tree-store tree-store)
	517	(parent tree-iter)
	518	(new-order (vector int)))
	519
	520	(defbinding tree-store-swap () nil
	521	(tree-store tree-store)
	522	(a tree-iter)
	523	(b tree-iter))
	524
	525	(defbinding tree-store-move-before () nil
	526	(tree-store tree-store)
	527	(iter tree-iter)
	528	(psoition (or null tree-iter)))
	529
	530
	531	(defbinding tree-store-move-after () nil
	532	(tree-store tree-store)
	533	(iter tree-iter)
	534	(psoition tree-iter))
	535
	536
	537
	538	;;; Tree View
	539
2a8752b0	540	(defmethod initialize-instance ((tree-view tree-view) &key column)
	541	(call-next-method)
	542	(mapc #'(lambda (column)
	543	(tree-view-append-column tree-view column))
	544	(get-all initargs :column)))
	545
	546
167450a3	547	(defbinding tree-view-get-selection () tree-selection
	548	(tree-view tree-view))
	549
	550	(defbinding tree-view-columns-autosize () nil
	551	(tree-view tree-view))
	552
	553	(defbinding tree-view-append-column () int
	554	(tree-view tree-view)
	555	(tree-view-column tree-view-column))
	556
	557	(defbinding tree-view-remove-column () int
	558	(tree-view tree-view)
	559	(tree-view-column tree-view-column))
	560
	561	(defbinding tree-view-insert-column (view columnd position) int
	562	(view tree-view)
	563	(column tree-view-column)
	564	((if (eq position :end) -1 position) int))
	565
	566	(defbinding tree-view-get-column () tree-view-column
	567	(tree-view tree-view)
	568	(position int))
	569
	570	(defbinding tree-view-move-column-after () nil
	571	(tree-view tree-view)
	572	(column tree-view-column)
	573	(base-column (or null tree-view-column)))
	574
	575	;;(defbinding tree-view-set-column drag-function ...)
	576
	577	(defbinding tree-view-scroll-to-point () nil
	578	(tree-view tree-view)
	579	(tree-x int)
	580	(tree-y int))
	581
	582	(defbinding tree-view-scroll-to-cell () nil
	583	(tree-view tree-view)
	584	(path (or null tree-path))
	585	(column (or null tree-view-column))
	586	(use-align boolean)
	587	(row-align single-float)
	588	(col-align single-float))
	589
	590	(defbinding tree-view-set-cursor () nil
	591	(tree-view tree-view)
	592	(path tree-path)
	593	(focus-column tree-view-column)
	594	(start-editing boolean))
	595
	596	(defbinding tree-view-set-cursor-on-cell () nil
	597	(tree-view tree-view)
	598	(path tree-path)
	599	(focus-column (or null tree-view-column))
	600	(focus-cell (or null cell-renderer))
	601	(start-editing boolean))
	602
	603	(defbinding tree-view-get-cursor () nil
	604	(tree-view tree-view)
	605	(path tree-path :out )
	606	(focus-column tree-view-column :out))
	607
	608	(defbinding tree-view-row-activated () nil
	609	(tree-view tree-view)
	610	(path tree-path )
611	(column tree-view-column))
612
613	(defbinding tree-view-expand-all () nil
614	(tree-view tree-view))
615
616	(defbinding tree-view-collapse-all () nil
617	(tree-view tree-view))
618
619	(defbinding tree-view-expand-to-path () nil
620	(tree-view tree-view)
621	(path tree-path))
622
623	(defbinding tree-view-expand-row () nil
624	(tree-view tree-view)
625	(path tree-path)
626	(open-all boolean))
627
628	(defbinding tree-view-collapse-row () nil
629	(tree-view tree-view)
630	(path tree-path))
631
632	(def-callback-marshal %tree-view-mapping-func (nil tree-view tree-path))
633
634	(defbinding %tree-view-map-expanded-rows () nil
635	(tree-view tree-view)
636	((callback %tree-view-mapping-func) pointer)
637	(callback-id unsigned-int))
638
639	(defun map-expanded-rows (function tree-view)
640	(with-callback-function (id function)
641	(%tree-view-map-expanded-rows tree-view id)))
642
643	(defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
644	(tree-view tree-view)
645	(path tree-path))
646
647	(defbinding tree-view-get-path-at-pos
648	(tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
649	(tree-view tree-view)
650	(x int)
651	(y int)
652	(path tree-path :out)
653	(column tree-view-column :out)
654	(cell-x int)
655	(cell-y int))
656
657	(defbinding tree-view-get-cell-area () nil
658	(tree-view tree-view)
659	(path (or null tree-path))
660	(column (or null tree-view-column))
2a8752b0	661	((make-instance 'gdk:rectangle) gdk:rectangle :return))
167450a3	662
	663	(defbinding tree-view-get-background-area () nil
	664	(tree-view tree-view)
	665	(path (or null tree-path))
	666	(column (or null tree-view-column))
2a8752b0	667	((make-instance 'gdk:rectangle) gdk:rectangle :return))
167450a3	668
	669	(defbinding tree-view-get-visible-rect () nil
	670	(tree-view tree-view)
2a8752b0	671	((make-instance 'gdk:rectangle) gdk:rectangle :return))
167450a3	672
	673	;; and many more functions which we'll add later
	674
2a8752b0	675
	676	;;; Tree View Column
	677