chiark - git - mdw - clg/blob - gtk/gtktree.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gtktree.lisp,v 1.21 2006/06/23 12:25:37 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28
  29 ;;;; Cell Layout
  30
  31 (defbinding cell-layout-pack-start () nil
  32   (cell-layout cell-layout)
  33   (cell cell-renderer)
  34   (expand boolean))
  35
  36 (defbinding cell-layout-pack-end () nil
  37   (cell-layout cell-layout)
  38   (cell cell-renderer)
  39   (expand boolean))
  40
  41 (defun cell-layout-pack (layout cell &key end expand)
  42   (if end
  43       (cell-layout-pack-end layout cell expand)
  44     (cell-layout-pack-start layout cell expand)))
  45
  46
  47 (defbinding cell-layout-reorder () nil
  48   (cell-layout cell-layout)
  49   (cell cell-renderer)
  50   (position int))
  51
  52 (defbinding cell-layout-clear () nil
  53   (cell-layout cell-layout))
  54
  55 (defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
  56   (cell-layout cell-layout)
  57   (cell cell-renderer)
  58   ((string-downcase attribute) string)
  59   (column int))
  60
  61 (define-callback-marshal %cell-layout-data-callback nil
  62   (cell-layout cell-renderer tree-model tree-iter))
  63
  64 (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
  65   (cell-layout cell-layout)
  66   (cell cell-renderer)
  67   (%cell-layout-data-callback callback)
  68   ((register-callback-function function) unsigned-int)
  69   (user-data-destroy-callback callback))
  70
  71 (defbinding cell-layout-clear-attributes () nil
  72   (cell-layout cell-layout)
  73   (cell cell-renderer))
  74
  75
  76
  77 ;;;; List Store
  78
  79 (defmethod initialize-instance ((list-store list-store) &key column-types
  80                                 column-names initial-content)
  81   (call-next-method)
  82   (%list-store-set-column-types list-store column-types)
  83   (when column-names
  84     (setf
  85      (user-data list-store 'column-names)
  86      (coerce column-names 'vector)))
  87   (when initial-content
  88     (loop
  89      with iter = (make-instance 'tree-iter)
  90      for row in initial-content
  91      do (list-store-append list-store row iter))))
  92
  93 (defgeneric column-setter-name (store))
  94
  95 (defmethod column-setter-name ((list-store list-store))
  96   (declare (ignore list-store))
  97   "gtk_list_store_set")
  98
  99 (defbinding %list-store-set-column-types () nil
 100   (list-store list-store)
 101   ((length columns) unsigned-int)
 102   (columns (vector gtype)))
 103
 104 (defbinding %list-store-remove () boolean
 105   (list-store list-store)
 106   (tree-iter tree-iter))
 107
 108 (defun list-store-remove (store row)
 109   (etypecase row
 110     (tree-iter
 111      (%list-store-remove store row))
 112     (tree-path
 113      (multiple-value-bind (valid iter) (tree-model-get-iter store row)
 114        (if valid
 115            (%list-store-remove store iter)
 116            (error "~A not poiniting to a valid iterator in ~A" row store))))
 117     (tree-row-reference
 118      (let ((path (tree-row-reference-get-path row)))
 119        (if path
 120            (list-store-remove store path)
 121          (error "~A not valid" row))))))
 122
 123
 124 (defbinding %list-store-insert () nil
 125   (list-store list-store)
 126   (tree-iter tree-iter)
 127   (position int))
 128
 129 (defun list-store-insert
 130     (store position &optional data (iter (make-instance 'tree-iter)))
 131   (%list-store-insert store iter position)
 132   (when data (%tree-model-set store iter data))
 133   iter)
 134
 135 (defbinding %list-store-insert-before () nil
 136   (list-store list-store)
 137   (tree-iter tree-iter)
 138   (sibling (or null tree-iter)))
 139
 140 (defun list-store-insert-before
 141     (store sibling &optional data (iter (make-instance 'tree-iter)))
 142   (%list-store-insert-before store iter sibling)
 143   (when data (%tree-model-set store iter data))
 144   iter)
 145
 146 (defbinding %list-store-insert-after
 147     (list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil
 148   (list-store list-store)
 149   (tree-iter tree-iter)
 150   (sibling (or null tree-iter)))
 151
 152 (defun list-store-insert-after
 153     (store sibling &optional data (iter (make-instance 'tree-iter)))
 154   (%list-store-insert-after store iter sibling)
 155   (when data (%tree-model-set store iter data))
 156   iter)
 157
 158 (defbinding %list-store-prepend () nil
 159   (list-store list-store)
 160   (tree-iter tree-iter))
 161
 162 (defun list-store-prepend
 163     (store &optional data (iter (make-instance 'tree-iter)))
 164   (%list-store-prepend store iter)
 165   (when data (%tree-model-set store iter data))
 166   iter)
 167
 168 (defbinding %list-store-append () nil
 169   (list-store list-store)
 170   (tree-iter tree-iter))
 171
 172 (defun list-store-append
 173     (store &optional data (iter (make-instance 'tree-iter)))
 174   (%list-store-append store iter)
 175   (when data (%tree-model-set store iter data))
 176   iter)
 177
 178 (defbinding list-store-clear () nil
 179   (list-store list-store))
 180
 181 (defbinding list-store-reorder () nil
 182   (list-store list-store)
 183   (new-order (vector int)))
 184
 185 (defbinding list-store-swap () nil
 186   (list-store list-store)
 187   (a tree-iter)
 188   (b tree-iter))
 189
 190 (defbinding list-store-move-before () nil
 191   (list-store list-store)
 192   (iter tree-iter)
 193   (psoition (or null tree-iter)))
 194
 195 (defbinding list-store-move-after () nil
 196   (list-store list-store)
 197   (iter tree-iter)
 198   (psoition tree-iter))
 199
 200
 201 ;;; Tree Model
 202
 203 (defbinding %tree-path-free () nil
 204   (location pointer))
 205
 206 (defbinding %tree-path-get-indices () pointer
 207   (location pointer))
 208
 209 (defbinding %tree-path-get-depth () int
 210   (location pointer))
 211
 212 (defun %make-tree-path (path)
 213   (let* ((c-vector (make-c-vector 'int (length path) :content path))
 214          (pointer-offset (adjust-offset (size-of 'int) 'pointer))
 215          (location (allocate-memory (+ pointer-offset (size-of 'pointer)))))
 216     (funcall (writer-function 'int) (length path) location)
 217     (funcall (writer-function 'pointer) c-vector location pointer-offset)
 218     location))
 219
 220 (defun %tree-path-to-vector (location)
 221   (let ((indices (%tree-path-get-indices location))
 222         (depth (%tree-path-get-depth location)))
 223     (if (null-pointer-p indices)
 224         #()
 225       (map-c-vector 'vector #'identity indices 'int depth))))
 226
 227 (defmacro %with-tree-path ((var path) &body body)
 228   (let* ((pointer-offset (adjust-offset (size-of 'int) 'pointer))
 229          (vector-offset (adjust-offset (+ pointer-offset (size-of 'pointer)) 'int)))
 230     `(with-memory (,var (+ ,vector-offset (* ,(size-of 'int) (length ,path))))
 231       (funcall (writer-function 'int) (length ,path) ,var)
 232       (setf (ref-pointer ,var ,pointer-offset) (pointer+ ,var ,vector-offset))
 233       (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset))
 234       ,@body)))
 235
 236 (eval-when (:compile-toplevel :load-toplevel :execute)
 237   (define-type-method alien-type ((type tree-path))
 238     (declare (ignore type))
 239     (alien-type 'pointer))
 240
 241   (define-type-method size-of ((type tree-path) &key inlined)
 242     (assert-not-inlined type inlined)
 243     (size-of 'pointer))
 244
 245   (define-type-method alien-arg-wrapper ((type tree-path) var path style form &optional copy-in-p)
 246     (declare (ignore type))
 247     (cond
 248      ((and (in-arg-p style) copy-in-p)
 249       `(with-pointer (,var (%make-tree-path ,path))
 250          ,form))
 251      ((and (in-arg-p style) (not (out-arg-p style)))
 252       `(%with-tree-path (,var ,path)
 253          ,form))
 254      ((and (in-arg-p style) (out-arg-p style))
 255       (let ((tree-path (make-symbol "SYMBOL")))
 256         `(%with-tree-path (,tree-path ,path)
 257            (with-pointer (,var ,tree-path)
 258              ,form))))
 259      ((and (out-arg-p style) (not (in-arg-p style)))
 260       `(with-pointer (,var)
 261          ,form))))
 262
 263   (define-type-method to-alien-form ((type tree-path) path &optional copy-p)
 264     (declare (ignore type copy-p))
 265     `(%make-tree-path ,path))
 266
 267   (define-type-method from-alien-form ((type tree-path) location &key (ref :free))
 268     (declare (ignore type))
 269     `(prog1
 270          (%tree-path-to-vector ,location)
 271        ,(when (eq ref :free)
 272           `(%tree-path-free ,location)))))
 273
 274 (define-type-method to-alien-function ((type tree-path) &optional copy-p)
 275   (declare (ignore type))
 276   #'%make-tree-path
 277   (unless copy-p
 278     #'(lambda (tree-path location)
 279         (declare (ignore tree-path))
 280         (%tree-path-free location))))
 281
 282 (define-type-method from-alien-function ((type tree-path) &key (ref :free))
 283   (declare (ignore type))
 284   (if (eq ref :free)
 285       #'(lambda (location)
 286           (prog1
 287               (%tree-path-to-vector location)
 288             (%tree-path-free location)))
 289     #'(lambda (location)
 290         (%tree-path-to-vector location))))
 291
 292 (define-type-method writer-function ((type tree-path) &key temp inlined)
 293   (declare (ignore temp))
 294   (assert-not-inlined type inlined)
 295   (let ((writer (writer-function 'pointer)))
 296     #'(lambda (path location &optional (offset 0))
 297         (funcall writer (%make-tree-path path) location offset))))
 298
 299 (define-type-method reader-function ((type tree-path) &key ref inlined)
 300   (declare (ignore ref))
 301   (assert-not-inlined type inlined)
 302   #'(lambda (location &optional (offset 0))
 303       (%tree-path-to-vector (ref-pointer location offset))))
 304
 305 (define-type-method destroy-function ((type tree-path) &key temp inlined)
 306   (declare (ignore temp))
 307   (assert-not-inlined type inlined)
 308   #'(lambda (location &optional (offset 0))
 309       (%tree-path-free (ref-pointer location offset))))
 310
 311
 312 (defbinding %tree-row-reference-new () pointer
 313   (model tree-model)
 314   (path tree-path))
 315
 316 (defmethod allocate-foreign ((reference tree-row-reference) &key model path)
 317   (%tree-row-reference-new model path))
 318
 319 (defbinding tree-row-reference-get-path () tree-path
 320   (reference tree-row-reference))
 321
 322 (defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean
 323   (reference tree-row-reference))
 324
 325
 326 (defbinding tree-model-get-column-type () gtype ;type-number
 327   (tree-model tree-model)
 328   (index int))
 329
 330 (defbinding tree-model-get-iter
 331     (model path &optional (iter (make-instance 'tree-iter))) boolean
 332   (model tree-model)
 333   (iter tree-iter :in/return)
 334   (path tree-path))
 335
 336 (defbinding tree-model-get-path () tree-path
 337   (tree-model tree-model)
 338   (iter tree-iter))
 339
 340 (defbinding %tree-model-get-value () nil
 341   (tree-model tree-model)
 342   (iter tree-iter)
 343   (column int)
 344   (gvalue gvalue))
 345
 346 (defgeneric tree-model-value (model row column))
 347
 348 (defmethod tree-model-value ((model tree-model) row column)
 349   (let ((index (column-index model column))
 350         (iter (etypecase row
 351                 (tree-iter row)
 352                 (tree-path (multiple-value-bind (valid iter)
 353                                (tree-model-get-iter model row)
 354                              (if valid
 355                                  iter
 356                                (error "Invalid tree path: ~A" row)))))))
 357     (with-gvalue (gvalue)
 358       (%tree-model-get-value model iter index gvalue))))
 359
 360 (defbinding tree-model-iter-next () boolean
 361   (tree-model tree-model)
 362   (iter tree-iter :in/return))
 363
 364 (defbinding tree-model-iter-children
 365     (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
 366   (tree-model tree-model)
 367   (iter tree-iter :in/return)
 368   (parent (or null tree-iter)))
 369
 370 (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child")
 371     () boolean
 372   (tree-model tree-model)
 373   (iter tree-iter))
 374
 375 (defbinding tree-model-iter-n-children () int
 376   (tree-model tree-model)
 377   (iter tree-iter))
 378
 379 (defbinding tree-model-iter-nth-child
 380     (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean
 381   (tree-model tree-model)
 382   (iter tree-iter :in/return)
 383   (parent (or null tree-iter))
 384   (n int))
 385
 386 (defbinding tree-model-iter-parent
 387     (tree-model child &optional (iter (make-instance 'tree-iter))) boolean
 388   (tree-model tree-model)
 389   (iter tree-iter :in/return)
 390   (child tree-iter))
 391
 392 (define-callback-marshal %tree-model-foreach-callback boolean
 393   (tree-model tree-path tree-iter))
 394
 395 (defbinding %tree-model-foreach (tree-model callback-id) nil
 396   (tree-model tree-model)
 397   (%tree-model-foreach-callback callback)
 398   (callback-id unsigned-int))
 399
 400 (defun tree-model-foreach (model function)
 401   (with-callback-function (id function)
 402     (%tree-model-foreach model id)))
 403
 404 (defbinding tree-model-row-changed () nil
 405   (tree-model tree-model)
 406   (path tree-path)
 407   (iter tree-iter))
 408
 409 (defbinding tree-model-row-inserted () nil
 410   (tree-model tree-model)
 411   (path tree-path)
 412   (iter tree-iter))
 413
 414 (defbinding tree-model-row-has-child-toggled () nil
 415   (tree-model tree-model)
 416   (path tree-path)
 417   (iter tree-iter))
 418
 419 (defbinding tree-model-row-deleted () nil
 420   (tree-model tree-model)
 421   (path tree-path)
 422   (iter tree-iter))
 423
 424 (defbinding tree-model-rows-reordered () nil
 425   (tree-model tree-model)
 426   (path tree-path)
 427   (iter tree-iter)
 428   (new-order int))
 429
 430
 431 (defun column-types (model columns)
 432   (declare (ignore model))
 433   (map 'vector
 434        #'(lambda (column)
 435            (find-type-number (first (mklist column))))
 436        columns))
 437
 438 (defun column-index (model column)
 439   (or
 440    (etypecase column
 441      (number column)
 442      (symbol (position column (user-data model 'column-names)))
 443      (string (position column (user-data model 'column-names)
 444                    :test #'string=)))
 445    (error "~A has no column ~S" model column)))
 446
 447 (defun column-name (model index)
 448   (svref (user-data model 'column-names) index))
 449
 450 (defun tree-model-column-value-setter (model column)
 451   (let ((setters (or
 452                   (user-data model 'column-setters)
 453                   (setf
 454                    (user-data model 'column-setters)
 455                    (make-array (tree-model-n-columns model)
 456                     :initial-element nil)))))
 457     (let ((index (column-index model column)))
 458     (or
 459      (svref setters index)
 460      (setf
 461       (svref setters index)
 462       (let ((setter
 463              (mkbinding (column-setter-name model)
 464               nil (type-of model) 'tree-iter 'int
 465               (tree-model-get-column-type model index)
 466               'int)))
 467         #'(lambda (value iter)
 468             (funcall setter model iter index value -1))))))))
 469
 470 (defun tree-model-row-setter (model)
 471   (or
 472    (user-data model 'row-setter)
 473    (progn
 474      ;; This will create any missing column setter
 475      (loop
 476       for i from 0 below (tree-model-n-columns model)
 477       do (tree-model-column-value-setter model i))
 478      (let ((setters (user-data model 'column-setters)))
 479        (setf
 480         (user-data model 'row-setter)
 481         #'(lambda (row iter)
 482             (map nil #'(lambda (value setter)
 483                          (funcall setter value iter))
 484                  row setters)))))))
 485
 486 (defgeneric (setf tree-model-value) (value model row column))
 487
 488 (defmethod (setf tree-model-value) (value (model tree-model) row column)
 489   (let ((iter (etypecase row
 490                 (tree-iter row)
 491                 (tree-path (multiple-value-bind (valid iter)
 492                                (tree-model-get-iter model row)
 493                              (if valid
 494                                  iter
 495                                (error "Invalid tree path: ~A" row)))))))
 496     (funcall (tree-model-column-value-setter model column) value iter)
 497     value))
 498
 499 (defun (setf tree-model-row-data) (data model iter)
 500   (funcall (tree-model-row-setter model) data iter)
 501   data)
 502
 503 (defun %tree-model-set (model iter data)
 504   (etypecase data
 505     (vector (setf (tree-model-row-data model iter) data))
 506     (cons
 507      (loop
 508       as (column value . rest) = data then rest
 509       do (setf (tree-model-value model iter column) value)
 510       while rest))))
 511
 512
 513 ;;; Tree Selection
 514
 515 (define-callback-marshal %tree-selection-callback boolean
 516   (tree-selection tree-model tree-path (path-currently-selected boolean)))
 517
 518 (defbinding tree-selection-set-select-function (selection function) nil
 519   (selection tree-selection)
 520   (%tree-selection-callback callback)
 521   ((register-callback-function function) unsigned-int)
 522   (user-data-destroy-callback callback))
 523
 524 (defbinding tree-selection-get-selected
 525     (selection &optional (iter (make-instance 'tree-iter))) boolean
 526   (selection tree-selection)
 527   (nil null)
 528   (iter tree-iter :in/return))
 529
 530 (define-callback-marshal %tree-selection-foreach-callback nil (tree-model tree-path tree-iter))
 531
 532 (defbinding %tree-selection-selected-foreach (tree-selection callback-id) nil
 533   (tree-selection tree-selection)
 534   (%tree-selection-foreach-callback callback)
 535   (callback-id unsigned-int))
 536
 537 (defun tree-selection-selected-foreach (selection function)
 538   (with-callback-function (id function)
 539     (%tree-selection-selected-foreach selection id)))
 540
 541 (defbinding tree-selection-get-selected-rows () (glist tree-path)
 542   (tree-selection tree-selection)
 543   (nil null))
 544
 545 (defbinding tree-selection-count-selected-rows () int
 546   (tree-selection tree-selection))
 547
 548 (defbinding %tree-selection-select-path () nil
 549   (tree-selection tree-selection)
 550   (tree-path tree-path))
 551
 552 (defbinding %tree-selection-unselect-path () nil
 553   (tree-selection tree-selection)
 554   (tree-path tree-path))
 555
 556 (defbinding %tree-selection-path-is-selected () boolean
 557   (tree-selection tree-selection)
 558   (tree-path tree-path))
 559
 560 (defbinding %tree-selection-select-iter () nil
 561   (tree-selection tree-selection)
 562   (tree-path tree-path))
 563
 564 (defbinding %tree-selection-unselect-iter () nil
 565   (tree-selection tree-selection)
 566   (tree-path tree-path))
 567
 568 (defbinding %tree-selection-iter-is-selected () boolean
 569   (tree-selection tree-selection)
 570   (tree-path tree-path))
 571
 572 (defun tree-selection-select (selection row)
 573   (etypecase row
 574     (tree-path (%tree-selection-select-path selection row))
 575     (tree-iter (%tree-selection-select-iter selection row))))
 576
 577 (defun tree-selection-unselect (selection row)
 578   (etypecase row
 579     (tree-path (%tree-selection-unselect-path selection row))
 580     (tree-iter (%tree-selection-unselect-iter selection row))))
 581
 582 (defun tree-selection-is-selected-p (selection row)
 583   (etypecase row
 584     (tree-path (%tree-selection-path-is-selected selection row))
 585     (tree-iter (%tree-selection-iter-is-selected selection row))))
 586
 587 (defbinding tree-selection-select-all () nil
 588   (tree-selection tree-selection))
 589
 590 (defbinding tree-selection-unselect-all () nil
 591   (tree-selection tree-selection))
 592
 593 (defbinding tree-selection-select-range () nil
 594   (tree-selection tree-selection)
 595   (start tree-path)
 596   (end tree-path))
 597
 598 (defbinding tree-selection-unselect-range () nil
 599   (tree-selection tree-selection)
 600   (start tree-path)
 601   (end tree-path))
 602
 603
 604 ;;; Tree Sortable
 605
 606 (eval-when (:compile-toplevel :load-toplevel :execute)
 607   (define-enum-type sort-column (:default -1) (:unsorted -2))
 608   (define-enum-type sort-order (:before -1) (:equal 0) (:after 1)))
 609
 610
 611 (define-callback-marshal %tree-iter-compare-callback (or int sort-order)
 612   (tree-model (a tree-iter) (b tree-iter)))
 613
 614 (defbinding tree-sortable-sort-column-changed () nil
 615   (sortable tree-sortable))
 616
 617 (defbinding %tree-sortable-get-sort-column-id () boolean
 618   (sortable tree-sortable)
 619   (column int :out)
 620   (order sort-type :out))
 621
 622 (defun tree-sortable-get-sort-column (sortable)
 623   (multiple-value-bind (special-p column order)
 624       (%tree-sortable-get-sort-column-id sortable)
 625     (values
 626      (if special-p
 627          (int-to-sort-order column)
 628        (column-name sortable column))
 629      order)))
 630
 631 (defbinding (tree-sortable-set-sort-column
 632              "gtk_tree_sortable_set_sort_column_id")
 633     (sortable column order) nil
 634   (sortable tree-sortable)
 635   ((etypecase column
 636      ((or integer sort-column) column)
 637      (symbol (column-index sortable column)))
 638    (or sort-column int))
 639   (order sort-type))
 640
 641 (defbinding %tree-sortable-set-sort-func (sortable column function) nil
 642   (sortable tree-sortable)
 643   ((column-index sortable column) int)
 644   (%tree-iter-compare-callback callback)
 645   ((register-callback-function function) unsigned-int)
 646   (user-data-destroy-callback callback))
 647
 648 (defbinding %tree-sortable-set-default-sort-func () nil
 649   (sortable tree-sortable)
 650   (compare-func (or null callback))
 651   (callback-id unsigned-int)
 652   (destroy-func (or null callback)))
 653
 654 (defun tree-sortable-set-sort-func (sortable column function)
 655   "Sets the comparison function used when sorting to be FUNCTION. If
 656 the current sort column of SORTABLE is the same as COLUMN,
 657 then the model will sort using this function."
 658   (cond
 659    ((and (eq column :default) (not function))
 660     (%tree-sortable-set-default-sort-func sortable nil 0 nil))
 661    ((eq column :default)
 662     (%tree-sortable-set-default-sort-func sortable
 663      %tree-iter-compare-callback
 664      (register-callback-function function)
 665      user-data-destroy-callback))
 666    ((%tree-sortable-set-sort-func sortable column function))))
 667
 668 (defbinding tree-sortable-has-default-sort-func-p () boolean
 669   (sortable tree-sortable))
 670
 671
 672 ;;; Tree Store
 673
 674 (defbinding %tree-store-set-column-types () nil
 675   (tree-store tree-store)
 676   ((length columns) unsigned-int)
 677   (columns (vector gtype)))
 678
 679 (defmethod initialize-instance ((tree-store tree-store) &key column-types
 680                                 column-names)
 681   (call-next-method)
 682   (%tree-store-set-column-types tree-store column-types)
 683   (when column-names
 684     (setf (user-data tree-store 'column-names) column-names)))
 685
 686 (defmethod column-setter-name ((tree-store tree-store))
 687   (declare (ignore tree-store))
 688   "gtk_tree_store_set")
 689
 690 (defbinding tree-store-remove () boolean
 691   (tree-store tree-store)
 692   (tree-iter tree-iter))
 693
 694 (defbinding %tree-store-insert () nil
 695   (tree-store tree-store)
 696   (tree-iter tree-iter)
 697   (parent (or null tree-iter))
 698   (position int))
 699
 700 (defun tree-store-insert
 701     (store parent position &optional data (iter (make-instance 'tree-iter)))
 702   (%tree-store-insert store iter parent position)
 703   (when data (%tree-model-set store iter data))
 704   iter)
 705
 706 (defbinding %tree-store-insert-before () nil
 707   (tree-store tree-store)
 708   (tree-iter tree-iter)
 709   (parent (or null tree-iter))
 710   (sibling (or null tree-iter)))
 711
 712 (defun tree-store-insert-before
 713     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 714   (%tree-store-insert-before store iter parent sibling)
 715   (when data (%tree-model-set store iter data))
 716   iter)
 717
 718 (defbinding %tree-store-insert-after () nil
 719   (tree-store tree-store)
 720   (tree-iter tree-iter)
 721   (parent (or null tree-iter))
 722   (sibling (or null tree-iter)))
 723
 724 (defun tree-store-insert-after
 725     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 726   (%tree-store-insert-after store iter parent sibling)
 727   (when data (%tree-model-set store iter data))
 728   iter)
 729
 730 (defbinding %tree-store-prepend () nil
 731   (tree-store tree-store)
 732   (tree-iter tree-iter)
 733   (parent (or null tree-iter)))
 734
 735 (defun tree-store-prepend
 736     (store parent &optional data (iter (make-instance 'tree-iter)))
 737   (%tree-store-prepend store iter parent)
 738   (when data (%tree-model-set store iter data))
 739   iter)
 740
 741 (defbinding %tree-store-append () nil
 742   (tree-store tree-store)
 743   (tree-iter tree-iter)
 744   (parent (or null tree-iter)))
 745
 746 (defun tree-store-append
 747     (store parent &optional data (iter (make-instance 'tree-iter)))
 748   (%tree-store-append store iter parent)
 749   (when data (%tree-model-set store iter data))
 750   iter)
 751
 752 (defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
 753   (tree-store tree-store)
 754   (tree-iter tree-iter)
 755   (descendant tree-iter))
 756
 757 (defbinding tree-store-iter-depth () int
 758   (tree-store tree-store)
 759   (tree-iter tree-iter))
 760
 761 (defbinding tree-store-clear () nil
 762   (tree-store tree-store))
 763
 764 (defbinding tree-store-reorder () nil
 765   (tree-store tree-store)
 766   (parent tree-iter)
 767   (new-order (vector int)))
 768
 769 (defbinding tree-store-swap () nil
 770   (tree-store tree-store)
 771   (a tree-iter)
 772   (b tree-iter))
 773
 774 (defbinding tree-store-move-before () nil
 775   (tree-store tree-store)
 776   (iter tree-iter)
 777   (psoition (or null tree-iter)))
 778
 779
 780 (defbinding tree-store-move-after () nil
 781   (tree-store tree-store)
 782   (iter tree-iter)
 783   (psoition tree-iter))
 784
 785
 786
 787 ;;; Tree View
 788
 789 (defmethod initialize-instance ((tree-view tree-view) &rest initargs
 790                                 &key column)
 791   (declare (ignore column))
 792   (call-next-method)
 793   (mapc #'(lambda (column)
 794             (tree-view-append-column tree-view column))
 795         (get-all initargs :column)))
 796
 797
 798 (defbinding tree-view-columns-autosize () nil
 799   (tree-view tree-view))
 800
 801 (defbinding tree-view-append-column () int
 802   (tree-view tree-view)
 803   (tree-view-column tree-view-column))
 804
 805 (defbinding tree-view-remove-column () int
 806   (tree-view tree-view)
 807   (tree-view-column tree-view-column))
 808
 809 (defbinding tree-view-insert-column (view column position) int
 810   (view tree-view)
 811   (column tree-view-column)
 812   ((if (eq position :end) -1 position) int))
 813
 814 (defbinding tree-view-get-column () tree-view-column
 815   (tree-view tree-view)
 816   (position int))
 817
 818 (defbinding tree-view-move-column-after () nil
 819   (tree-view tree-view)
 820   (column tree-view-column)
 821   (base-column (or null tree-view-column)))
 822
 823 ;;(defbinding tree-view-set-column drag-function ...)
 824
 825 (defbinding tree-view-scroll-to-point () nil
 826   (tree-view tree-view)
 827   (tree-x int)
 828   (tree-y int))
 829
 830 (defbinding tree-view-scroll-to-cell () nil
 831   (tree-view tree-view)
 832   (path (or null tree-path))
 833   (column (or null tree-view-column))
 834   (use-align boolean)
 835   (row-align single-float)
 836   (col-align single-float))
 837
 838 (defbinding tree-view-set-cursor () nil
 839   (tree-view tree-view)
 840   (path tree-path)
 841   (focus-column tree-view-column)
 842   (start-editing boolean))
 843
 844 (defbinding tree-view-set-cursor-on-cell () nil
 845   (tree-view tree-view)
 846   (path tree-path)
 847   (focus-column (or null tree-view-column))
 848   (focus-cell (or null cell-renderer))
 849   (start-editing boolean))
 850
 851 (defbinding tree-view-get-cursor () nil
 852   (tree-view tree-view)
 853   (path tree-path :out )
 854   (focus-column tree-view-column :out))
 855
 856 (defbinding tree-view-row-activated () nil
 857   (tree-view tree-view)
 858   (path tree-path )
 859   (column tree-view-column))
 860
 861 (defbinding tree-view-expand-all () nil
 862   (tree-view tree-view))
 863
 864 (defbinding tree-view-collapse-all () nil
 865   (tree-view tree-view))
 866
 867 (defbinding tree-view-expand-to-path () nil
 868   (tree-view tree-view)
 869   (path tree-path))
 870
 871 (defbinding tree-view-expand-row () nil
 872   (tree-view tree-view)
 873   (path tree-path)
 874   (open-all boolean))
 875
 876 (defbinding tree-view-collapse-row () nil
 877   (tree-view tree-view)
 878   (path tree-path))
 879
 880 (define-callback-marshal %tree-view-mapping-callback nil (tree-view tree-path))
 881
 882 (defbinding %tree-view-map-expanded-rows (tree-view callback-id) nil
 883   (tree-view tree-view)
 884   (%tree-view-mapping-callback callback)
 885   (callback-id unsigned-int))
 886
 887 (defun map-expanded-rows (function tree-view)
 888   (with-callback-function (id function)
 889     (%tree-view-map-expanded-rows tree-view id)))
 890
 891 (defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
 892   (tree-view tree-view)
 893   (path tree-path))
 894
 895 (defbinding tree-view-get-path-at-pos
 896     (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
 897   (tree-view tree-view)
 898   (x int)
 899   (y int)
 900   (path tree-path :out)
 901   (column tree-view-column :out)
 902   (cell-x int)
 903   (cell-y int))
 904
 905 (defbinding tree-view-get-cell-area () nil
 906   (tree-view tree-view)
 907   (path (or null tree-path))
 908   (column (or null tree-view-column))
 909   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 910
 911 (defbinding tree-view-get-background-area () nil
 912   (tree-view tree-view)
 913   (path (or null tree-path))
 914   (column (or null tree-view-column))
 915   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 916
 917 (defbinding tree-view-get-visible-rect () nil
 918   (tree-view tree-view)
 919   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 920
 921 ;; and many more functions which we'll add later
 922
 923
 924 ;;;; Icon View
 925
 926 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 927 (progn
 928   (defbinding icon-view-get-path-at-pos () tree-path
 929     (icon-view icon-view)
 930     (x int) (y int))
 931
 932   (define-callback-marshal %icon-view-foreach-callback nil (icon-view tree-path))
 933
 934   (defbinding %icon-view-selected-foreach (icon-view callback-id) tree-path
 935     (icon-view icon-view)
 936     (%icon-view-foreach-callback callback)
 937     (callback-id unsigned-int))
 938
 939   (defun icon-view-foreach (icon-view function)
 940     (with-callback-function (id function)
 941       (%icon-view-selected-foreach icon-view id)))
 942
 943   (defbinding icon-view-select-path () nil
 944     (icon-view icon-view)
 945     (path tree-path))
 946
 947   (defbinding icon-view-unselect-path () nil
 948     (icon-view icon-view)
 949     (path tree-path))
 950
 951   (defbinding icon-view-path-is-selected-p () boolean
 952     (icon-view icon-view)
 953     (path tree-path))
 954
 955   (defbinding icon-view-get-selected-items () (glist tree-path)
 956     (icon-view icon-view))
 957
 958   (defbinding icon-view-select-all () nil
 959     (icon-view icon-view))
 960
 961   (defbinding icon-view-unselect-all () nil
 962     (icon-view icon-view))
 963
 964   (defbinding icon-view-item-activated () nil
 965     (icon-view icon-view)
 966     (path tree-path))
 967
 968   (defbinding %icon-view-set-text-column (column icon-view) nil
 969     (icon-view icon-view)
 970     ((if (integerp column)
 971          column
 972        (column-index (icon-view-model icon-view) column)) int))
 973
 974   (defbinding %%icon-view-get-text-column () int
 975     (icon-view icon-view))
 976
 977   (defun %icon-view-get-text-column (icon-view)
 978     (column-index
 979      (icon-view-model icon-view)
 980      (%%icon-view-get-text-column icon-view)))
 981
 982   (defun %icon-view-text-column-boundp (icon-view)
 983     (not (eql (%%icon-view-get-text-column icon-view) -1)))
 984
 985
 986   (defbinding %icon-view-set-markup-column (column icon-view) nil
 987     (icon-view icon-view)
 988     ((if (integerp column)
 989          column
 990        (column-index (icon-view-model icon-view) column)) int))
 991
 992   (defbinding %%icon-view-get-markup-column () int
 993     (icon-view icon-view))
 994
 995   (defun %icon-view-get-markup-column (icon-view)
 996     (column-index
 997      (icon-view-model icon-view)
 998      (%%icon-view-get-markup-column icon-view)))
 999
1000   (defun %icon-view-markup-column-boundp (icon-view)
1001     (not (eql (%%icon-view-get-markup-column icon-view) -1)))
1002
1003
1004   (defbinding %icon-view-set-pixbuf-column (column icon-view) nil
1005     (icon-view icon-view)
1006     ((if (integerp column)
1007          column
1008        (column-index (icon-view-model icon-view) column)) int)))
1009
1010   (defbinding %%icon-view-get-pixbuf-column () int
1011     (icon-view icon-view))
1012
1013   (defun %icon-view-get-pixbuf-column (icon-view)
1014     (column-index
1015      (icon-view-model icon-view)
1016      (%%icon-view-get-pixbuf-column icon-view)))
1017
1018   (defun %icon-view-pixbuf-column-boundp (icon-view)
1019     (not (eql (%%icon-view-get-pixbuf-column icon-view) -1)))
1020
1021
1022 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1023 (progn
1024   (defbinding icon-view-get-item-at-pos () boolean
1025     (icon-view icon-view)
1026     (x int)
1027     (y int)
1028     (tree-path tree-path :out)
1029     (cell cell-renderer :out))
1030
1031   (defbinding icon-view-set-cursor (icon-view path &key cell start-editing) nil
1032     (icon-view icon-view)
1033     (path tree-path)
1034     (cell (or null cell-renderer))
1035     (start-editing boolean))
1036
1037   (defbinding icon-view-get-cursor () boolean
1038     (icon-view icon-view)
1039     (path tree-path :out)
1040     (cell cell-renderer :out))
1041
1042   (defbinding icon-view-get-dest-item-at-pos () boolean
1043     (icon-view icon-view)
1044     (drag-x int)
1045     (drag-y int)
1046     (tree-path tree-path :out)
1047     (pos drop-position :out))
1048
1049   (defbinding icon-view-create-drag-icon () gdk:pixmap
1050     (icon-view icon-view)
1051     (tree-path tree-path))
1052
1053   (defbinding icon-view-scroll-to-path (icon-view tree-path &key row-align column-align) nil
1054     (icon-view icon-view)
1055     (tree-path tree-path)
1056     ((or row-align column-align) boolean)
1057     (row-align single-float)
1058     (column-align single-float))
1059
1060   (defbinding icon-view-get-visible-range () boolean
1061     (icon-view icon-view)
1062     (start-path tree-path :out)
1063     (end-path tree-path :out))
1064
1065 ;;   (defbinding icon-view-enable-model-drag-source () nil
1066 ;;     (icon-view icon-view)
1067 ;;     (start-button-mask gdk:modifier-type)
1068 ;;     (targets (vector target-entry))
1069 ;;     ((length targets) unsigned-int)
1070 ;;     (actions gdk:drag-action))
1071
1072 ;;   (defbinding icon-view-enable-model-drag-dest () nil
1073 ;;     (icon-view icon-view)
1074 ;;     (targets (vector target-entry))
1075 ;;     ((length targets) unsigned-int)
1076 ;;     (actions gdk:drag-action))
1077
1078   (defbinding icon-view-unset-model-drag-source () nil
1079     (icon-view icon-view))
1080
1081   (defbinding icon-view-unset-model-drag-dest () nil
1082     (icon-view icon-view)))