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