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