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