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.27 2007-05-10 20:20: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
 185     (list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil
 186   (list-store list-store)
 187   (tree-iter tree-iter)
 188   (sibling (or null tree-iter)))
 189
 190 (defun list-store-insert-after
 191     (store sibling &optional data (iter (make-instance 'tree-iter)))
 192   (%list-store-insert-after store iter sibling)
 193   (when data (setf (tree-model-row-data store iter) data))
 194   iter)
 195
 196 (defbinding %list-store-prepend () nil
 197   (list-store list-store)
 198   (tree-iter tree-iter))
 199
 200 (defun list-store-prepend
 201     (store &optional data (iter (make-instance 'tree-iter)))
 202   (%list-store-prepend store iter)
 203   (when data (setf (tree-model-row-data store iter) data))
 204   iter)
 205
 206 (defbinding %list-store-append () nil
 207   (list-store list-store)
 208   (tree-iter tree-iter))
 209
 210 (defun list-store-append
 211     (store &optional data (iter (make-instance 'tree-iter)))
 212   (%list-store-append store iter)
 213   (when data (setf (tree-model-row-data store iter) data))
 214   iter)
 215
 216 (defbinding list-store-clear () nil
 217   (list-store list-store))
 218
 219 (defbinding list-store-reorder () nil
 220   (list-store list-store)
 221   (new-order (vector int)))
 222
 223 (defbinding list-store-swap () nil
 224   (list-store list-store)
 225   (a tree-iter)
 226   (b tree-iter))
 227
 228 (defbinding list-store-move-before () nil
 229   (list-store list-store)
 230   (iter tree-iter)
 231   (psoition (or null tree-iter)))
 232
 233 (defbinding list-store-move-after () nil
 234   (list-store list-store)
 235   (iter tree-iter)
 236   (psoition tree-iter))
 237
 238
 239 ;;; Tree Path
 240
 241 (defbinding %tree-path-free () nil
 242   (location pointer))
 243
 244 (defbinding %tree-path-get-indices () pointer
 245   (location pointer))
 246
 247 (defbinding %tree-path-get-depth () int
 248   (location pointer))
 249
 250 (defun %make-tree-path (path)
 251   (let* ((c-vector (make-c-vector 'int (length path) :content path))
 252          (pointer-offset (adjust-offset (size-of 'int) 'pointer))
 253          (location (allocate-memory (+ pointer-offset (size-of 'pointer)))))
 254     (funcall (writer-function 'int) (length path) location)
 255     (funcall (writer-function 'pointer) c-vector location pointer-offset)
 256     location))
 257
 258 (defun %tree-path-to-vector (location)
 259   (let ((indices (%tree-path-get-indices location))
 260         (depth (%tree-path-get-depth location)))
 261     (if (null-pointer-p indices)
 262         #()
 263       (map-c-vector 'vector #'identity indices 'int depth))))
 264
 265 (defmacro %with-tree-path ((var path) &body body)
 266   (let* ((pointer-offset (adjust-offset (size-of 'int) 'pointer))
 267          (vector-offset (adjust-offset (+ pointer-offset (size-of 'pointer)) 'int)))
 268     `(with-memory (,var (+ ,vector-offset (* ,(size-of 'int) (length ,path))))
 269       (funcall (writer-function 'int) (length ,path) ,var)
 270       (setf (ref-pointer ,var ,pointer-offset) (pointer+ ,var ,vector-offset))
 271       (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset))
 272       ,@body)))
 273
 274 (eval-when (:compile-toplevel :load-toplevel :execute)
 275   (define-type-method alien-type ((type tree-path))
 276     (declare (ignore type))
 277     (alien-type 'pointer))
 278
 279   (define-type-method size-of ((type tree-path) &key inlined)
 280     (assert-not-inlined type inlined)
 281     (size-of 'pointer))
 282
 283   (define-type-method alien-arg-wrapper ((type tree-path) var path style form &optional copy-in-p)
 284     (declare (ignore type))
 285     (cond
 286      ((and (in-arg-p style) copy-in-p)
 287       `(with-pointer (,var (%make-tree-path ,path))
 288          ,form))
 289      ((and (in-arg-p style) (not (out-arg-p style)))
 290       `(%with-tree-path (,var ,path)
 291          ,form))
 292      ((and (in-arg-p style) (out-arg-p style))
 293       (let ((tree-path (make-symbol "SYMBOL")))
 294         `(%with-tree-path (,tree-path ,path)
 295            (with-pointer (,var ,tree-path)
 296              ,form))))
 297      ((and (out-arg-p style) (not (in-arg-p style)))
 298       `(with-pointer (,var)
 299          ,form))))
 300
 301   (define-type-method to-alien-form ((type tree-path) path &optional copy-p)
 302     (declare (ignore type copy-p))
 303     `(%make-tree-path ,path))
 304
 305   (define-type-method from-alien-form ((type tree-path) location &key (ref :free))
 306     (declare (ignore type))
 307     `(prog1
 308          (%tree-path-to-vector ,location)
 309        ,(when (eq ref :free)
 310           `(%tree-path-free ,location)))))
 311
 312 (define-type-method to-alien-function ((type tree-path) &optional copy-p)
 313   (declare (ignore type))
 314   #'%make-tree-path
 315   (unless copy-p
 316     #'(lambda (tree-path location)
 317         (declare (ignore tree-path))
 318         (%tree-path-free location))))
 319
 320 (define-type-method from-alien-function ((type tree-path) &key (ref :free))
 321   (declare (ignore type))
 322   (if (eq ref :free)
 323       #'(lambda (location)
 324           (prog1
 325               (%tree-path-to-vector location)
 326             (%tree-path-free location)))
 327     #'(lambda (location)
 328         (%tree-path-to-vector location))))
 329
 330 (define-type-method writer-function ((type tree-path) &key temp inlined)
 331   (declare (ignore temp))
 332   (assert-not-inlined type inlined)
 333   (let ((writer (writer-function 'pointer)))
 334     #'(lambda (path location &optional (offset 0))
 335         (funcall writer (%make-tree-path path) location offset))))
 336
 337 (define-type-method reader-function ((type tree-path) &key ref inlined)
 338   (declare (ignore ref))
 339   (assert-not-inlined type inlined)
 340   #'(lambda (location &optional (offset 0))
 341       (%tree-path-to-vector (ref-pointer location offset))))
 342
 343 (define-type-method destroy-function ((type tree-path) &key temp inlined)
 344   (declare (ignore temp))
 345   (assert-not-inlined type inlined)
 346   #'(lambda (location &optional (offset 0))
 347       (%tree-path-free (ref-pointer location offset))))
 348
 349 (defun ensure-tree-path (path)
 350   (etypecase path
 351     (string (coerce (clg-utils:split-string path :delimiter #\:) 'vector))
 352     (vector path)))
 353
 354
 355 ;;; Tree Model
 356
 357 (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 to (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 ;;(defbinding tree-view-set-column drag-function ...)
 845
 846 (defbinding tree-view-scroll-to-point () nil
 847   (tree-view tree-view)
 848   (tree-x int)
 849   (tree-y int))
 850
 851 (defbinding tree-view-scroll-to-cell () nil
 852   (tree-view tree-view)
 853   (path (or null tree-path))
 854   (column (or null tree-view-column))
 855   (use-align boolean)
 856   (row-align single-float)
 857   (col-align single-float))
 858
 859 (defbinding tree-view-set-cursor () nil
 860   (tree-view tree-view)
 861   (path tree-path)
 862   (focus-column tree-view-column)
 863   (start-editing boolean))
 864
 865 (defbinding tree-view-set-cursor-on-cell () nil
 866   (tree-view tree-view)
 867   (path tree-path)
 868   (focus-column (or null tree-view-column))
 869   (focus-cell (or null cell-renderer))
 870   (start-editing boolean))
 871
 872 (defbinding tree-view-get-cursor () nil
 873   (tree-view tree-view)
 874   (path tree-path :out )
 875   (focus-column tree-view-column :out))
 876
 877 (defbinding tree-view-row-activated () nil
 878   (tree-view tree-view)
 879   (path tree-path )
 880   (column tree-view-column))
 881
 882 (defbinding tree-view-expand-all () nil
 883   (tree-view tree-view))
 884
 885 (defbinding tree-view-collapse-all () nil
 886   (tree-view tree-view))
 887
 888 (defbinding tree-view-expand-to-path () nil
 889   (tree-view tree-view)
 890   (path tree-path))
 891
 892 (defbinding tree-view-expand-row () nil
 893   (tree-view tree-view)
 894   (path tree-path)
 895   (open-all boolean))
 896
 897 (defbinding tree-view-collapse-row () nil
 898   (tree-view tree-view)
 899   (path tree-path))
 900
 901 (define-callback-marshal %tree-view-mapping-callback nil (tree-view tree-path))
 902
 903 (defbinding %tree-view-map-expanded-rows (tree-view callback-id) nil
 904   (tree-view tree-view)
 905   (%tree-view-mapping-callback callback)
 906   (callback-id unsigned-int))
 907
 908 (defun map-expanded-rows (function tree-view)
 909   (with-callback-function (id function)
 910     (%tree-view-map-expanded-rows tree-view id)))
 911
 912 (defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
 913   (tree-view tree-view)
 914   (path tree-path))
 915
 916 (defbinding tree-view-get-path-at-pos
 917     (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
 918   (tree-view tree-view)
 919   (x int)
 920   (y int)
 921   (path tree-path :out)
 922   (column tree-view-column :out)
 923   (cell-x int)
 924   (cell-y int))
 925
 926 (defbinding tree-view-get-cell-area () nil
 927   (tree-view tree-view)
 928   (path (or null tree-path))
 929   (column (or null tree-view-column))
 930   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 931
 932 (defbinding tree-view-get-background-area () nil
 933   (tree-view tree-view)
 934   (path (or null tree-path))
 935   (column (or null tree-view-column))
 936   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 937
 938 (defbinding tree-view-get-visible-rect () nil
 939   (tree-view tree-view)
 940   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 941
 942 ;; and many more functions which we'll add later
 943
 944
 945 ;;;; Icon View
 946
 947 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 948 (progn
 949   (defbinding icon-view-get-path-at-pos () tree-path
 950     (icon-view icon-view)
 951     (x int) (y int))
 952
 953   (define-callback-marshal %icon-view-foreach-callback nil (icon-view tree-path))
 954
 955   (defbinding %icon-view-selected-foreach (icon-view callback-id) tree-path
 956     (icon-view icon-view)
 957     (%icon-view-foreach-callback callback)
 958     (callback-id unsigned-int))
 959
 960   (defun icon-view-foreach (icon-view function)
 961     (with-callback-function (id function)
 962       (%icon-view-selected-foreach icon-view id)))
 963
 964   (defbinding icon-view-select-path () nil
 965     (icon-view icon-view)
 966     (path tree-path))
 967
 968   (defbinding icon-view-unselect-path () nil
 969     (icon-view icon-view)
 970     (path tree-path))
 971
 972   (defbinding icon-view-path-is-selected-p () boolean
 973     (icon-view icon-view)
 974     (path tree-path))
 975
 976   (defbinding icon-view-get-selected-items () (glist tree-path)
 977     (icon-view icon-view))
 978
 979   (defbinding icon-view-select-all () nil
 980     (icon-view icon-view))
 981
 982   (defbinding icon-view-unselect-all () nil
 983     (icon-view icon-view))
 984
 985   (defbinding icon-view-item-activated () nil
 986     (icon-view icon-view)
 987     (path tree-path))
 988
 989   (defbinding %icon-view-set-text-column (column icon-view) nil
 990     (icon-view icon-view)
 991     ((if (integerp column)
 992          column
 993        (tree-model-column-index (icon-view-model icon-view) column)) int))
 994
 995   (defbinding %%icon-view-get-text-column () int
 996     (icon-view icon-view))
 997
 998   (defun %icon-view-get-text-column (icon-view)
 999     (tree-model-column-index
1000      (icon-view-model icon-view)
1001      (%%icon-view-get-text-column icon-view)))
1002
1003   (defun %icon-view-text-column-boundp (icon-view)
1004     (not (eql (%%icon-view-get-text-column icon-view) -1)))
1005
1006
1007   (defbinding %icon-view-set-markup-column (column icon-view) nil
1008     (icon-view icon-view)
1009     ((if (integerp column)
1010          column
1011        (tree-model-column-index (icon-view-model icon-view) column)) int))
1012
1013   (defbinding %%icon-view-get-markup-column () int
1014     (icon-view icon-view))
1015
1016   (defun %icon-view-get-markup-column (icon-view)
1017     (tree-model-column-index
1018      (icon-view-model icon-view)
1019      (%%icon-view-get-markup-column icon-view)))
1020
1021   (defun %icon-view-markup-column-boundp (icon-view)
1022     (not (eql (%%icon-view-get-markup-column icon-view) -1)))
1023
1024
1025   (defbinding %icon-view-set-pixbuf-column (column icon-view) nil
1026     (icon-view icon-view)
1027     ((if (integerp column)
1028          column
1029        (tree-model-column-index (icon-view-model icon-view) column)) int)))
1030
1031   (defbinding %%icon-view-get-pixbuf-column () int
1032     (icon-view icon-view))
1033
1034   (defun %icon-view-get-pixbuf-column (icon-view)
1035     (tree-model-column-index
1036      (icon-view-model icon-view)
1037      (%%icon-view-get-pixbuf-column icon-view)))
1038
1039   (defun %icon-view-pixbuf-column-boundp (icon-view)
1040     (not (eql (%%icon-view-get-pixbuf-column icon-view) -1)))
1041
1042
1043 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1044 (progn
1045   (defbinding icon-view-get-item-at-pos () boolean
1046     (icon-view icon-view)
1047     (x int)
1048     (y int)
1049     (tree-path tree-path :out)
1050     (cell cell-renderer :out))
1051
1052   (defbinding icon-view-set-cursor (icon-view path &key cell start-editing) nil
1053     (icon-view icon-view)
1054     (path tree-path)
1055     (cell (or null cell-renderer))
1056     (start-editing boolean))
1057
1058   (defbinding icon-view-get-cursor () boolean
1059     (icon-view icon-view)
1060     (path tree-path :out)
1061     (cell cell-renderer :out))
1062
1063   (defbinding icon-view-get-dest-item-at-pos () boolean
1064     (icon-view icon-view)
1065     (drag-x int)
1066     (drag-y int)
1067     (tree-path tree-path :out)
1068     (pos drop-position :out))
1069
1070   (defbinding icon-view-create-drag-icon () gdk:pixmap
1071     (icon-view icon-view)
1072     (tree-path tree-path))
1073
1074   (defbinding icon-view-scroll-to-path (icon-view tree-path &key row-align column-align) nil
1075     (icon-view icon-view)
1076     (tree-path tree-path)
1077     ((or row-align column-align) boolean)
1078     (row-align single-float)
1079     (column-align single-float))
1080
1081   (defbinding icon-view-get-visible-range () boolean
1082     (icon-view icon-view)
1083     (start-path tree-path :out)
1084     (end-path tree-path :out))
1085
1086 ;;   (defbinding icon-view-enable-model-drag-source () nil
1087 ;;     (icon-view icon-view)
1088 ;;     (start-button-mask gdk:modifier-type)
1089 ;;     (targets (vector target-entry))
1090 ;;     ((length targets) unsigned-int)
1091 ;;     (actions gdk:drag-action))
1092
1093 ;;   (defbinding icon-view-enable-model-drag-dest () nil
1094 ;;     (icon-view icon-view)
1095 ;;     (targets (vector target-entry))
1096 ;;     ((length targets) unsigned-int)
1097 ;;     (actions gdk:drag-action))
1098
1099   (defbinding icon-view-unset-model-drag-source () nil
1100     (icon-view icon-view))
1101
1102   (defbinding icon-view-unset-model-drag-dest () nil
1103     (icon-view icon-view)))