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