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