chiark - git - mdw - clg/blob - gtk/gtktree.lisp

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2004-2005 Espen S. Johnsen <espen@users.sf.net>
   3 ;;
   4 ;; Permission is hereby granted, free of charge, to any person obtaining
   5 ;; a copy of this software and associated documentation files (the
   6 ;; "Software"), to deal in the Software without restriction, including
   7 ;; without limitation the rights to use, copy, modify, merge, publish,
   8 ;; distribute, sublicense, and/or sell copies of the Software, and to
   9 ;; permit persons to whom the Software is furnished to do so, subject to
  10 ;; the following conditions:
  11 ;;
  12 ;; The above copyright notice and this permission notice shall be
  13 ;; included in all copies or substantial portions of the Software.
  14 ;;
  15 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  16 ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  17 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
  18 ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
  19 ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
  20 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
  21 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
  22
  23 ;; $Id: gtktree.lisp,v 1.34 2008-04-11 20:53:32 espen Exp $
  24
  25
  26 (in-package "GTK")
  27
  28
  29 ;;;; Cell Layout
  30
  31 (defbinding cell-layout-pack-start () nil
  32   (cell-layout cell-layout)
  33   (cell cell-renderer)
  34   (expand boolean))
  35
  36 (defbinding cell-layout-pack-end () nil
  37   (cell-layout cell-layout)
  38   (cell cell-renderer)
  39   (expand boolean))
  40
  41 (defun cell-layout-pack (layout cell &key end expand)
  42   (if end
  43       (cell-layout-pack-end layout cell expand)
  44     (cell-layout-pack-start layout cell expand)))
  45
  46
  47 (defbinding cell-layout-reorder () nil
  48   (cell-layout cell-layout)
  49   (cell cell-renderer)
  50   (position int))
  51
  52 (defbinding cell-layout-clear () nil
  53   (cell-layout cell-layout))
  54
  55 (defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
  56   (cell-layout cell-layout)
  57   (cell cell-renderer)
  58   ((string-downcase attribute) string)
  59   (column int))
  60
  61 (define-callback-marshal %cell-layout-data-callback nil
  62   (cell-layout cell-renderer tree-model tree-iter))
  63
  64 (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
  65   (cell-layout cell-layout)
  66   (cell cell-renderer)
  67   (%cell-layout-data-callback callback)
  68   ((register-callback-function function) unsigned-int)
  69   (user-data-destroy-callback callback))
  70
  71 (defbinding cell-layout-clear-attributes () nil
  72   (cell-layout cell-layout)
  73   (cell cell-renderer))
  74
  75
  76 ;;;; Cell Renderer
  77
  78 (defmethod compute-signal-function ((gobject cell-renderer-toggle) (signal (eql 'toggled)) function object args)
  79   (declare (ignore gobject signal function object args))
  80   (let ((function (call-next-method)))
  81     #'(lambda (object path)
  82         (funcall function object (ensure-tree-path path)))))
  83
  84
  85 ;;;; List Store
  86
  87 (defmethod initialize-instance ((list-store list-store) &key column-types
  88                                 column-names initial-content)
  89   (call-next-method)
  90   (%list-store-set-column-types list-store column-types)
  91   (when column-names
  92     (setf
  93      (user-data list-store 'column-names)
  94      (coerce column-names 'vector)))
  95   (when initial-content
  96     (loop
  97      with iter = (make-instance 'tree-iter)
  98      for row in initial-content
  99      do (list-store-append list-store row iter))))
 100
 101
 102 (defbinding %list-store-set-column-types () nil
 103   (list-store list-store)
 104   ((length columns) unsigned-int)
 105   (columns (vector gtype)))
 106
 107 (defbinding list-store-remove (store row) boolean
 108   (store list-store)
 109   ((ensure-tree-iter store row) tree-iter))
 110
 111 (defbinding %list-store-set-value () nil
 112   (list-store list-store)
 113   (tree-iter tree-iter)
 114   (column int)
 115   (gvalue gvalue))
 116
 117 (defmethod (setf tree-model-value) (value (store list-store) row column)
 118   (let* ((index (tree-model-column-index store column))
 119          (type (tree-model-get-column-type store index)))
 120     (with-gvalue (gvalue type value)
 121       (%list-store-set-value store (ensure-tree-iter store row) index gvalue)))
 122   value)
 123
 124 (defbinding %list-store-insert-with-valuesv () nil
 125   (list-store list-store)
 126   (tree-iter tree-iter)
 127   (position int)
 128   (columns (vector int))
 129   (gvalues pointer)
 130   ((length columns) int))
 131
 132 (defbinding %list-store-insert () nil
 133   (list-store list-store)
 134   (tree-iter tree-iter)
 135   (position int))
 136
 137 (defun list-store-insert (store position &optional data (iter (make-instance 'tree-iter)))
 138   (etypecase data
 139     (null (%list-store-insert store iter position))
 140
 141     (list (with-memory (gvalues (* (/ (length data) 2) +gvalue-size+))
 142             (let ((columns
 143                    (loop
 144                     for (column value) on data by #'cddr
 145                     as index = (tree-model-column-index store column)
 146                     as type = (tree-model-get-column-type store index)
 147                     as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
 148                     do (gvalue-init gvalue type value)
 149                     collect index)))
 150                 (unwind-protect
 151                     (%list-store-insert-with-valuesv store iter position columns gvalues)
 152                   (loop
 153                    repeat (length columns)
 154                    as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
 155                    do (gvalue-unset gvalue))))))
 156
 157     (vector (with-memory (gvalues (* (length data) +gvalue-size+))
 158               (let ((columns
 159                      (loop
 160                       for index below (length data)
 161                       as type = (tree-model-get-column-type store index)
 162                       as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
 163                       do (gvalue-init gvalue type (aref data index))
 164                       collect index)))
 165                 (unwind-protect
 166                     (%list-store-insert-with-valuesv store iter position columns gvalues))
 167                 (loop
 168                  repeat (length data)
 169                  as gvalue = gvalues then (pointer+ gvalue  +gvalue-size+)
 170                  do (gvalue-unset gvalue))))))
 171   iter)
 172
 173 (defbinding %list-store-insert-before () nil
 174   (list-store list-store)
 175   (tree-iter tree-iter)
 176   (sibling (or null tree-iter)))
 177
 178 (defun list-store-insert-before
 179     (store sibling &optional data (iter (make-instance 'tree-iter)))
 180   (%list-store-insert-before store iter sibling)
 181   (when data (setf (tree-model-row-data store iter) data))
 182   iter)
 183
 184 (defbinding %list-store-insert-after () nil
 185   (list-store list-store)
 186   (tree-iter tree-iter)
 187   (sibling (or null tree-iter)))
 188
 189 (defun list-store-insert-after
 190     (store sibling &optional data (iter (make-instance 'tree-iter)))
 191   (%list-store-insert-after store iter sibling)
 192   (when data (setf (tree-model-row-data store iter) data))
 193   iter)
 194
 195 (defbinding %list-store-prepend () nil
 196   (list-store list-store)
 197   (tree-iter tree-iter))
 198
 199 (defun list-store-prepend
 200     (store &optional data (iter (make-instance 'tree-iter)))
 201   (%list-store-prepend store iter)
 202   (when data (setf (tree-model-row-data store iter) data))
 203   iter)
 204
 205 (defbinding %list-store-append () nil
 206   (list-store list-store)
 207   (tree-iter tree-iter))
 208
 209 (defun list-store-append
 210     (store &optional data (iter (make-instance 'tree-iter)))
 211   (%list-store-append store iter)
 212   (when data (setf (tree-model-row-data store iter) data))
 213   iter)
 214
 215 (defbinding list-store-clear () nil
 216   (list-store list-store))
 217
 218 (defbinding list-store-reorder () nil
 219   (list-store list-store)
 220   (new-order (vector int)))
 221
 222 (defbinding list-store-swap () nil
 223   (list-store list-store)
 224   (a tree-iter)
 225   (b tree-iter))
 226
 227 (defbinding list-store-move-before () nil
 228   (list-store list-store)
 229   (iter tree-iter)
 230   (psoition (or null tree-iter)))
 231
 232 (defbinding list-store-move-after () nil
 233   (list-store list-store)
 234   (iter tree-iter)
 235   (psoition tree-iter))
 236
 237
 238 ;;; Tree Path
 239
 240 (defbinding %tree-path-free () nil
 241   (location pointer))
 242
 243 (defbinding %tree-path-get-indices () pointer
 244   (location pointer))
 245
 246 (defbinding %tree-path-get-depth () int
 247   (location pointer))
 248
 249 (defun %make-tree-path (path)
 250   (let* ((c-vector (make-c-vector 'int (length path) :content path))
 251          (pointer-offset (adjust-offset (size-of 'int) 'pointer))
 252          (location (allocate-memory (+ pointer-offset (size-of 'pointer)))))
 253     (funcall (writer-function 'int) (length path) location)
 254     (funcall (writer-function 'pointer) c-vector location pointer-offset)
 255     location))
 256
 257 (defun %tree-path-to-vector (location)
 258   (unless (null-pointer-p location)
 259     (let ((indices (%tree-path-get-indices location))
 260           (depth (%tree-path-get-depth location)))
 261       (if (null-pointer-p indices)
 262           #()
 263         (map-c-vector 'vector #'identity indices 'int depth)))))
 264
 265 (defmacro %with-tree-path ((var path) &body body)
 266   (let* ((pointer-offset (adjust-offset (size-of 'int) 'pointer))
 267          (vector-offset (adjust-offset (+ pointer-offset (size-of 'pointer)) 'int)))
 268     `(with-memory (,var (+ ,vector-offset (* ,(size-of 'int) (length ,path))))
 269       (funcall (writer-function 'int) (length ,path) ,var)
 270       (setf (ref-pointer ,var ,pointer-offset) (pointer+ ,var ,vector-offset))
 271       (make-c-vector 'int (length ,path) :content ,path :location (pointer+ ,var ,vector-offset))
 272       ,@body)))
 273
 274 (eval-when (:compile-toplevel :load-toplevel :execute)
 275   (define-type-method alien-type ((type tree-path))
 276     (declare (ignore type))
 277     (alien-type 'pointer))
 278
 279   (define-type-method size-of ((type tree-path) &key inlined)
 280     (assert-not-inlined type inlined)
 281     (size-of 'pointer))
 282
 283   (define-type-method alien-arg-wrapper ((type tree-path) var path style form &optional copy-in-p)
 284     (declare (ignore type))
 285     (cond
 286      ((and (in-arg-p style) copy-in-p)
 287       `(with-pointer (,var (%make-tree-path ,path))
 288          ,form))
 289      ((and (in-arg-p style) (not (out-arg-p style)))
 290       `(%with-tree-path (,var ,path)
 291          ,form))
 292      ((and (in-arg-p style) (out-arg-p style))
 293       (let ((tree-path (make-symbol "SYMBOL")))
 294         `(%with-tree-path (,tree-path ,path)
 295            (with-pointer (,var ,tree-path)
 296              ,form))))
 297      ((and (out-arg-p style) (not (in-arg-p style)))
 298       `(with-pointer (,var)
 299          ,form))))
 300
 301   (define-type-method to-alien-form ((type tree-path) path &optional copy-p)
 302     (declare (ignore type copy-p))
 303     `(%make-tree-path ,path))
 304
 305   (define-type-method from-alien-form ((type tree-path) location &key (ref :free))
 306     (declare (ignore type))
 307     `(prog1
 308          (%tree-path-to-vector ,location)
 309        ,(when (eq ref :free)
 310           `(%tree-path-free ,location)))))
 311
 312 (define-type-method to-alien-function ((type tree-path) &optional copy-p)
 313   (declare (ignore type))
 314   #'%make-tree-path
 315   (unless copy-p
 316     #'(lambda (tree-path location)
 317         (declare (ignore tree-path))
 318         (%tree-path-free location))))
 319
 320 (define-type-method from-alien-function ((type tree-path) &key (ref :free))
 321   (declare (ignore type))
 322   (if (eq ref :free)
 323       #'(lambda (location)
 324           (prog1
 325               (%tree-path-to-vector location)
 326             (%tree-path-free location)))
 327     #'(lambda (location)
 328         (%tree-path-to-vector location))))
 329
 330 (define-type-method writer-function ((type tree-path) &key temp inlined)
 331   (declare (ignore temp))
 332   (assert-not-inlined type inlined)
 333   (let ((writer (writer-function 'pointer)))
 334     #'(lambda (path location &optional (offset 0))
 335         (funcall writer (%make-tree-path path) location offset))))
 336
 337 (define-type-method reader-function ((type tree-path) &key ref inlined)
 338   (declare (ignore ref))
 339   (assert-not-inlined type inlined)
 340   #'(lambda (location &optional (offset 0))
 341       (%tree-path-to-vector (ref-pointer location offset))))
 342
 343 (define-type-method destroy-function ((type tree-path) &key temp inlined)
 344   (declare (ignore temp))
 345   (assert-not-inlined type inlined)
 346   #'(lambda (location &optional (offset 0))
 347       (%tree-path-free (ref-pointer location offset))))
 348
 349 (defun ensure-tree-path (path)
 350   (etypecase path
 351     (string (map 'vector #'parse-integer
 352                  (clg-utils:split-string path :delimiter #\:)))
 353     (vector path)))
 354
 355
 356 ;;; Tree Model
 357
 358 (defgeneric tree-model-value (model row column))
 359 (defgeneric (setf tree-model-value) (value model row column))
 360 (defgeneric tree-model-row-data (model row))
 361 (defgeneric (setf tree-model-row-data) (data model row))
 362 (defgeneric tree-model-column-index (model column))
 363 (defgeneric tree-model-column-name (model index))
 364
 365
 366 (defbinding %tree-row-reference-new () pointer
 367   (model tree-model)
 368   (path tree-path))
 369
 370 (defmethod allocate-foreign ((reference tree-row-reference) &key model path)
 371   (%tree-row-reference-new model path))
 372
 373 (defbinding tree-row-reference-get-path () (or null tree-path)
 374   (reference tree-row-reference))
 375
 376 (defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean
 377   (reference tree-row-reference))
 378
 379
 380 (defbinding tree-model-get-column-type () gtype
 381   (tree-model tree-model)
 382   (index int))
 383
 384 (defbinding tree-model-get-iter (model path &optional (iter (make-instance 'tree-iter))) boolean
 385   (model tree-model)
 386   (iter tree-iter :in/return)
 387   ((ensure-tree-path path) tree-path))
 388
 389 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.12.0")
 390 (defmethod allocate-foreign ((tree-iter tree-iter) &rest initargs)
 391   (declare (ignore initargs))
 392   (let ((size (foreign-size (class-of tree-iter))))
 393     (slice-alloc size)))
 394
 395 (defun ensure-tree-iter (model row)
 396   (etypecase row
 397     (tree-iter row)
 398     ((or tree-path string)
 399      (multiple-value-bind (valid-p iter) (tree-model-get-iter model row)
 400        (if valid-p
 401            iter
 402          (error "Invalid tree path for ~A: ~A" model row))))
 403     (tree-row-reference
 404      (let ((path (tree-row-reference-get-path row)))
 405        (if path
 406            (ensure-tree-iter model path)
 407          (error "~A not valid" row))))))
 408
 409 (defbinding tree-model-get-path () tree-path
 410   (tree-model tree-model)
 411   (iter tree-iter))
 412
 413 (defbinding %tree-model-get-value () nil
 414   (tree-model tree-model)
 415   (iter tree-iter)
 416   (column int)
 417   (gvalue gvalue))
 418
 419 (defmethod tree-model-value ((model tree-model) row column)
 420   (let ((index (tree-model-column-index model column)))
 421     (with-gvalue (gvalue)
 422       (%tree-model-get-value model (ensure-tree-iter model row) index gvalue))))
 423
 424 (defmethod tree-model-row-data ((model tree-model) row)
 425   (coerce
 426    (loop
 427     with iter = (ensure-tree-iter model row)
 428     for index from 0 below (tree-model-n-columns model)
 429     collect (tree-model-value model iter index))
 430    'vector))
 431
 432
 433 (defbinding tree-model-iter-next () boolean
 434   (tree-model tree-model)
 435   (iter tree-iter :in/return))
 436
 437 (defbinding tree-model-iter-children
 438     (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
 439   (tree-model tree-model)
 440   (iter tree-iter :in/return)
 441   (parent (or null tree-iter)))
 442
 443 (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child")
 444     () boolean
 445   (tree-model tree-model)
 446   (iter tree-iter))
 447
 448 (defbinding tree-model-iter-n-children (tree-model &optional iter) int
 449   (tree-model tree-model)
 450   (iter (or null tree-iter)))
 451
 452 (defbinding tree-model-iter-nth-child
 453     (tree-model parent n &optional (iter (make-instance 'tree-iter))) boolean
 454   (tree-model tree-model)
 455   (iter tree-iter :in/return)
 456   (parent (or null tree-iter))
 457   (n int))
 458
 459 (defbinding tree-model-iter-parent
 460     (tree-model child &optional (iter (make-instance 'tree-iter))) boolean
 461   (tree-model tree-model)
 462   (iter tree-iter :in/return)
 463   (child tree-iter))
 464
 465 (define-callback-marshal %tree-model-foreach-callback boolean
 466   (tree-model tree-path tree-iter))
 467
 468 (defbinding %tree-model-foreach (tree-model callback-id) nil
 469   (tree-model tree-model)
 470   (%tree-model-foreach-callback callback)
 471   (callback-id unsigned-int))
 472
 473 (defun tree-model-foreach (model function)
 474   (with-callback-function (id function)
 475     (%tree-model-foreach model id)))
 476
 477 (defbinding tree-model-row-changed () nil
 478   (tree-model tree-model)
 479   (path tree-path)
 480   (iter tree-iter))
 481
 482 (defbinding tree-model-row-inserted () nil
 483   (tree-model tree-model)
 484   (path tree-path)
 485   (iter tree-iter))
 486
 487 (defbinding tree-model-row-has-child-toggled () nil
 488   (tree-model tree-model)
 489   (path tree-path)
 490   (iter tree-iter))
 491
 492 (defbinding tree-model-row-deleted () nil
 493   (tree-model tree-model)
 494   (path tree-path)
 495   (iter tree-iter))
 496
 497 (defbinding tree-model-rows-reordered () nil
 498   (tree-model tree-model)
 499   (path tree-path)
 500   (iter tree-iter)
 501   (new-order int))
 502
 503 (defmethod tree-model-column-index ((model tree-model) column)
 504   (or
 505    (etypecase column
 506      (number column)
 507      (string (position column (user-data model 'column-names) :test #'string=))
 508      (symbol (position column (user-data model 'column-names))))
 509    (error "~A has no column ~S" model column)))
 510
 511 (defmethod tree-model-column-name ((model tree-model) index)
 512   (svref (user-data model 'column-names) index))
 513
 514
 515 (defmethod (setf tree-model-row-data) ((data list) (model tree-model) (iter tree-iter))
 516   (loop
 517    for (column value) on data by #'cddr
 518    do (setf (tree-model-value model iter column) value))
 519   data)
 520
 521 (defmethod (setf tree-model-row-data) ((data vector) (model tree-model) row)
 522   (loop
 523    with iter = (ensure-tree-iter model row)
 524    for index from 0
 525    for value across data
 526    do (setf (tree-model-value model iter index) value))
 527   data)
 528
 529
 530 ;;; Tree Selection
 531
 532 (define-callback-marshal %tree-selection-callback boolean
 533   (tree-selection tree-model tree-path (path-currently-selected boolean)))
 534
 535 (defbinding tree-selection-set-select-function (selection function) nil
 536   (selection tree-selection)
 537   (%tree-selection-callback callback)
 538   ((register-callback-function function) unsigned-int)
 539   (user-data-destroy-callback callback))
 540
 541 (defbinding tree-selection-get-selected
 542     (selection &optional (iter (make-instance 'tree-iter))) boolean
 543   (selection tree-selection)
 544   (nil null)
 545   (iter tree-iter :in/return))
 546
 547 (define-callback-marshal %tree-selection-foreach-callback nil (tree-model tree-path tree-iter))
 548
 549 (defbinding %tree-selection-selected-foreach (tree-selection callback-id) nil
 550   (tree-selection tree-selection)
 551   (%tree-selection-foreach-callback callback)
 552   (callback-id unsigned-int))
 553
 554 (defun tree-selection-selected-foreach (selection function)
 555   (with-callback-function (id function)
 556     (%tree-selection-selected-foreach selection id)))
 557
 558 (defbinding tree-selection-get-selected-rows () (glist tree-path)
 559   (tree-selection tree-selection)
 560   (nil null))
 561
 562 (defbinding tree-selection-count-selected-rows () int
 563   (tree-selection tree-selection))
 564
 565 (defbinding %tree-selection-select-path () nil
 566   (tree-selection tree-selection)
 567   (tree-path tree-path))
 568
 569 (defbinding %tree-selection-unselect-path () nil
 570   (tree-selection tree-selection)
 571   (tree-path tree-path))
 572
 573 (defbinding %tree-selection-path-is-selected () boolean
 574   (tree-selection tree-selection)
 575   (tree-path tree-path))
 576
 577 (defbinding %tree-selection-select-iter () nil
 578   (tree-selection tree-selection)
 579   (tree-iter tree-iter))
 580
 581 (defbinding %tree-selection-unselect-iter () nil
 582   (tree-selection tree-selection)
 583   (tree-iter tree-iter))
 584
 585 (defbinding %tree-selection-iter-is-selected () boolean
 586   (tree-selection tree-selection)
 587   (tree-iter tree-iter))
 588
 589 (defun tree-selection-select (selection row)
 590   (etypecase row
 591     (tree-path (%tree-selection-select-path selection row))
 592     (tree-iter (%tree-selection-select-iter selection row))))
 593
 594 (defun tree-selection-unselect (selection row)
 595   (etypecase row
 596     (tree-path (%tree-selection-unselect-path selection row))
 597     (tree-iter (%tree-selection-unselect-iter selection row))))
 598
 599 (defun tree-selection-is-selected-p (selection row)
 600   (etypecase row
 601     (tree-path (%tree-selection-path-is-selected selection row))
 602     (tree-iter (%tree-selection-iter-is-selected selection row))))
 603
 604 (defbinding tree-selection-select-all () nil
 605   (tree-selection tree-selection))
 606
 607 (defbinding tree-selection-unselect-all () nil
 608   (tree-selection tree-selection))
 609
 610 (defbinding tree-selection-select-range () nil
 611   (tree-selection tree-selection)
 612   (start tree-path)
 613   (end tree-path))
 614
 615 (defbinding tree-selection-unselect-range () nil
 616   (tree-selection tree-selection)
 617   (start tree-path)
 618   (end tree-path))
 619
 620
 621 ;;; Tree Sortable
 622
 623 (eval-when (:compile-toplevel :load-toplevel :execute)
 624   (define-enum-type sort-column (:default -1) (:unsorted -2))
 625   (define-enum-type sort-order (:before -1) (:equal 0) (:after 1)))
 626
 627
 628 (define-callback-marshal %tree-iter-compare-callback (or int sort-order)
 629   (tree-model (a tree-iter) (b tree-iter)))
 630
 631 (defbinding tree-sortable-sort-column-changed () nil
 632   (sortable tree-sortable))
 633
 634 (defbinding %tree-sortable-get-sort-column-id () boolean
 635   (sortable tree-sortable)
 636   (column int :out)
 637   (order sort-type :out))
 638
 639 (defun tree-sortable-get-sort-column (sortable)
 640   (multiple-value-bind (special-p column order)
 641       (%tree-sortable-get-sort-column-id sortable)
 642     (values
 643      (if special-p
 644          (int-to-sort-order column)
 645        (tree-model-column-name sortable column))
 646      order)))
 647
 648 (defbinding (tree-sortable-set-sort-column
 649              "gtk_tree_sortable_set_sort_column_id")
 650     (sortable column order) nil
 651   (sortable tree-sortable)
 652   ((etypecase column
 653      ((or integer sort-column) column)
 654      (symbol (tree-model-column-index sortable column)))
 655    (or sort-column int))
 656   (order sort-type))
 657
 658 (defbinding %tree-sortable-set-sort-func (sortable column function) nil
 659   (sortable tree-sortable)
 660   ((tree-model-column-index sortable column) int)
 661   (%tree-iter-compare-callback callback)
 662   ((register-callback-function function) unsigned-int)
 663   (user-data-destroy-callback callback))
 664
 665 (defbinding %tree-sortable-set-default-sort-func () nil
 666   (sortable tree-sortable)
 667   (compare-func (or null callback))
 668   (callback-id unsigned-int)
 669   (destroy-func (or null callback)))
 670
 671 (defun tree-sortable-set-sort-func (sortable column function)
 672   "Sets the comparison function used when sorting to be FUNCTION. If
 673 the current sort column of SORTABLE is the same as COLUMN,
 674 then the model will sort using this function."
 675   (cond
 676    ((and (eq column :default) (not function))
 677     (%tree-sortable-set-default-sort-func sortable nil 0 nil))
 678    ((eq column :default)
 679     (%tree-sortable-set-default-sort-func sortable
 680      %tree-iter-compare-callback
 681      (register-callback-function function)
 682      user-data-destroy-callback))
 683    ((%tree-sortable-set-sort-func sortable column function))))
 684
 685 (defbinding tree-sortable-has-default-sort-func-p () boolean
 686   (sortable tree-sortable))
 687
 688
 689 ;;; Tree Store
 690
 691 (defbinding %tree-store-set-column-types () nil
 692   (tree-store tree-store)
 693   ((length columns) unsigned-int)
 694   (columns (vector gtype)))
 695
 696 (defmethod initialize-instance ((tree-store tree-store) &key column-types
 697                                 column-names)
 698   (call-next-method)
 699   (%tree-store-set-column-types tree-store column-types)
 700   (when column-names
 701     (setf (user-data tree-store 'column-names) column-names)))
 702
 703
 704 (defbinding %tree-store-set-value () nil
 705   (tree-store tree-store)
 706   (tree-iter tree-iter)
 707   (column int)
 708   (gvalue gvalue))
 709
 710 (defmethod (setf tree-model-value) (value (store tree-store) row column)
 711   (let* ((index (tree-model-column-index store column))
 712          (type (tree-model-get-column-type store index)))
 713     (with-gvalue (gvalue type value)
 714       (%tree-store-set-value store (ensure-tree-iter store row) index gvalue)))
 715   value)
 716
 717
 718 (defbinding tree-store-remove () boolean
 719   (tree-store tree-store)
 720   (tree-iter tree-iter))
 721
 722 (defbinding %tree-store-insert () nil
 723   (tree-store tree-store)
 724   (tree-iter tree-iter)
 725   (parent (or null tree-iter))
 726   (position int))
 727
 728 (defun tree-store-insert
 729     (store parent position &optional data (iter (make-instance 'tree-iter)))
 730   (%tree-store-insert store iter parent position)
 731   (when data (setf (tree-model-row-data store iter) data))
 732   iter)
 733
 734 (defbinding %tree-store-insert-before () nil
 735   (tree-store tree-store)
 736   (tree-iter tree-iter)
 737   (parent (or null tree-iter))
 738   (sibling (or null tree-iter)))
 739
 740 (defun tree-store-insert-before
 741     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 742   (%tree-store-insert-before store iter parent sibling)
 743   (when data (setf (tree-model-row-data store iter) data))
 744   iter)
 745
 746 (defbinding %tree-store-insert-after () nil
 747   (tree-store tree-store)
 748   (tree-iter tree-iter)
 749   (parent (or null tree-iter))
 750   (sibling (or null tree-iter)))
 751
 752 (defun tree-store-insert-after
 753     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 754   (%tree-store-insert-after store iter parent sibling)
 755   (when data (setf (tree-model-row-data store iter) data))
 756   iter)
 757
 758 (defbinding %tree-store-prepend () nil
 759   (tree-store tree-store)
 760   (tree-iter tree-iter)
 761   (parent (or null tree-iter)))
 762
 763 (defun tree-store-prepend
 764     (store parent &optional data (iter (make-instance 'tree-iter)))
 765   (%tree-store-prepend store iter parent)
 766   (when data (setf (tree-model-row-data store iter) data))
 767   iter)
 768
 769 (defbinding %tree-store-append () nil
 770   (tree-store tree-store)
 771   (tree-iter tree-iter)
 772   (parent (or null tree-iter)))
 773
 774 (defun tree-store-append
 775     (store parent &optional data (iter (make-instance 'tree-iter)))
 776   (%tree-store-append store iter parent)
 777   (when data (setf (tree-model-row-data store iter) data))
 778   iter)
 779
 780 (defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
 781   (tree-store tree-store)
 782   (tree-iter tree-iter)
 783   (descendant tree-iter))
 784
 785 (defbinding tree-store-iter-depth () int
 786   (tree-store tree-store)
 787   (tree-iter tree-iter))
 788
 789 (defbinding tree-store-clear () nil
 790   (tree-store tree-store))
 791
 792 (defbinding tree-store-reorder () nil
 793   (tree-store tree-store)
 794   (parent tree-iter)
 795   (new-order (vector int)))
 796
 797 (defbinding tree-store-swap () nil
 798   (tree-store tree-store)
 799   (a tree-iter)
 800   (b tree-iter))
 801
 802 (defbinding tree-store-move-before () nil
 803   (tree-store tree-store)
 804   (iter tree-iter)
 805   (psoition (or null tree-iter)))
 806
 807
 808 (defbinding tree-store-move-after () nil
 809   (tree-store tree-store)
 810   (iter tree-iter)
 811   (psoition tree-iter))
 812
 813
 814
 815 ;;; Tree View
 816
 817 (defmethod initialize-instance ((tree-view tree-view) &rest initargs
 818                                 &key column)
 819   (declare (ignore column))
 820   (call-next-method)
 821   (mapc #'(lambda (column)
 822             (tree-view-append-column tree-view column))
 823         (get-all initargs :column)))
 824
 825
 826 (defbinding tree-view-columns-autosize () nil
 827   (tree-view tree-view))
 828
 829 (defbinding tree-view-append-column () int
 830   (tree-view tree-view)
 831   (tree-view-column tree-view-column))
 832
 833 (defbinding tree-view-remove-column () int
 834   (tree-view tree-view)
 835   (tree-view-column tree-view-column))
 836
 837 (defbinding tree-view-insert-column (view column position) int
 838   (view tree-view)
 839   (column tree-view-column)
 840   ((if (eq position :end) -1 position) int))
 841
 842 (defbinding tree-view-get-column () tree-view-column
 843   (tree-view tree-view)
 844   (position int))
 845
 846 (defbinding tree-view-move-column-after () nil
 847   (tree-view tree-view)
 848   (column tree-view-column)
 849   (base-column (or null tree-view-column)))
 850
 851 #+(or)
 852 (define-callback-setter tree-view-set-column-drag-function tree-view boolean
 853   (column tree-view-column)
 854   (prev tree-view-column)
 855   (next tree-view-column))
 856
 857 (defbinding tree-view-scroll-to-point () nil
 858   (tree-view tree-view)
 859   (tree-x int)
 860   (tree-y int))
 861
 862 (defbinding tree-view-scroll-to-cell () nil
 863   (tree-view tree-view)
 864   (path (or null tree-path))
 865   (column (or null tree-view-column))
 866   (use-align boolean)
 867   (row-align single-float)
 868   (col-align single-float))
 869
 870 (defbinding (tree-view-set-cursor "gtk_tree_view_set_cursor_on_cell")
 871     (tree-view path &key focus-column focus-cell start-editing) nil
 872   (tree-view tree-view)
 873   (path tree-path)
 874   (focus-column (or null tree-view-column))
 875   (focus-cell (or null cell-renderer))
 876   (start-editing boolean))
 877
 878 (defbinding tree-view-get-cursor () nil
 879   (tree-view tree-view)
 880   (path tree-path :out )
 881   (focus-column tree-view-column :out))
 882
 883 (defbinding tree-view-row-activated () nil
 884   (tree-view tree-view)
 885   (path tree-path )
 886   (column tree-view-column))
 887
 888 (defbinding tree-view-expand-all () nil
 889   (tree-view tree-view))
 890
 891 (defbinding tree-view-collapse-all () nil
 892   (tree-view tree-view))
 893
 894 (defbinding tree-view-expand-to-path () nil
 895   (tree-view tree-view)
 896   (path tree-path))
 897
 898 (defbinding tree-view-expand-row () nil
 899   (tree-view tree-view)
 900   (path tree-path)
 901   (open-all boolean))
 902
 903 (defbinding tree-view-collapse-row () nil
 904   (tree-view tree-view)
 905   (path tree-path))
 906
 907 (define-callback-marshal %tree-view-mapping-callback nil (tree-view tree-path))
 908
 909 (defbinding %tree-view-map-expanded-rows (tree-view callback-id) nil
 910   (tree-view tree-view)
 911   (%tree-view-mapping-callback callback)
 912   (callback-id unsigned-int))
 913
 914 (defun map-expanded-rows (function tree-view)
 915   (with-callback-function (id function)
 916     (%tree-view-map-expanded-rows tree-view id)))
 917
 918 (defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
 919   (tree-view tree-view)
 920   (path tree-path))
 921
 922 (defbinding tree-view-get-path-at-pos
 923     (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
 924   (tree-view tree-view)
 925   (x int)
 926   (y int)
 927   (path tree-path :out)
 928   (column tree-view-column :out)
 929   (cell-x int)
 930   (cell-y int))
 931
 932 (defbinding tree-view-get-cell-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-background-area () nil
 939   (tree-view tree-view)
 940   (path (or null tree-path))
 941   (column (or null tree-view-column))
 942   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 943
 944 (defbinding tree-view-get-visible-rect () nil
 945   (tree-view tree-view)
 946   ((make-instance 'gdk:rectangle) gdk:rectangle :in/return))
 947
 948 ;; and many more functions which we'll add later
 949
 950
 951 ;;;; Icon View
 952
 953 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.6.0")
 954 (progn
 955   (defbinding icon-view-get-path-at-pos () tree-path
 956     (icon-view icon-view)
 957     (x int) (y int))
 958
 959   (define-callback-marshal %icon-view-foreach-callback nil (icon-view tree-path))
 960
 961   (defbinding %icon-view-selected-foreach (icon-view callback-id) tree-path
 962     (icon-view icon-view)
 963     (%icon-view-foreach-callback callback)
 964     (callback-id unsigned-int))
 965
 966   (defun icon-view-foreach (icon-view function)
 967     (with-callback-function (id function)
 968       (%icon-view-selected-foreach icon-view id)))
 969
 970   (defbinding icon-view-select-path () nil
 971     (icon-view icon-view)
 972     (path tree-path))
 973
 974   (defbinding icon-view-unselect-path () nil
 975     (icon-view icon-view)
 976     (path tree-path))
 977
 978   (defbinding icon-view-path-is-selected-p () boolean
 979     (icon-view icon-view)
 980     (path tree-path))
 981
 982   (defbinding icon-view-get-selected-items () (glist tree-path)
 983     (icon-view icon-view))
 984
 985   (defbinding icon-view-select-all () nil
 986     (icon-view icon-view))
 987
 988   (defbinding icon-view-unselect-all () nil
 989     (icon-view icon-view))
 990
 991   (defbinding icon-view-item-activated () nil
 992     (icon-view icon-view)
 993     (path tree-path))
 994
 995   (defbinding %icon-view-set-text-column (column icon-view) nil
 996     (icon-view icon-view)
 997     ((if (integerp column)
 998          column
 999        (tree-model-column-index (icon-view-model icon-view) column)) int))
1000
1001   (defbinding %%icon-view-get-text-column () int
1002     (icon-view icon-view))
1003
1004   (defun %icon-view-get-text-column (icon-view)
1005     (tree-model-column-index
1006      (icon-view-model icon-view)
1007      (%%icon-view-get-text-column icon-view)))
1008
1009   (defun %icon-view-text-column-boundp (icon-view)
1010     (not (eql (%%icon-view-get-text-column icon-view) -1)))
1011
1012
1013   (defbinding %icon-view-set-markup-column (column icon-view) nil
1014     (icon-view icon-view)
1015     ((if (integerp column)
1016          column
1017        (tree-model-column-index (icon-view-model icon-view) column)) int))
1018
1019   (defbinding %%icon-view-get-markup-column () int
1020     (icon-view icon-view))
1021
1022   (defun %icon-view-get-markup-column (icon-view)
1023     (tree-model-column-index
1024      (icon-view-model icon-view)
1025      (%%icon-view-get-markup-column icon-view)))
1026
1027   (defun %icon-view-markup-column-boundp (icon-view)
1028     (not (eql (%%icon-view-get-markup-column icon-view) -1)))
1029
1030
1031   (defbinding %icon-view-set-pixbuf-column (column icon-view) nil
1032     (icon-view icon-view)
1033     ((if (integerp column)
1034          column
1035        (tree-model-column-index (icon-view-model icon-view) column)) int)))
1036
1037   (defbinding %%icon-view-get-pixbuf-column () int
1038     (icon-view icon-view))
1039
1040   (defun %icon-view-get-pixbuf-column (icon-view)
1041     (tree-model-column-index
1042      (icon-view-model icon-view)
1043      (%%icon-view-get-pixbuf-column icon-view)))
1044
1045   (defun %icon-view-pixbuf-column-boundp (icon-view)
1046     (not (eql (%%icon-view-get-pixbuf-column icon-view) -1)))
1047
1048
1049 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
1050 (progn
1051   (defbinding icon-view-get-item-at-pos () boolean
1052     (icon-view icon-view)
1053     (x int)
1054     (y int)
1055     (tree-path tree-path :out)
1056     (cell cell-renderer :out))
1057
1058   (defbinding icon-view-set-cursor (icon-view path &key cell start-editing) nil
1059     (icon-view icon-view)
1060     (path tree-path)
1061     (cell (or null cell-renderer))
1062     (start-editing boolean))
1063
1064   (defbinding icon-view-get-cursor () boolean
1065     (icon-view icon-view)
1066     (path tree-path :out)
1067     (cell cell-renderer :out))
1068
1069   (defbinding icon-view-get-dest-item-at-pos () boolean
1070     (icon-view icon-view)
1071     (drag-x int)
1072     (drag-y int)
1073     (tree-path tree-path :out)
1074     (pos drop-position :out))
1075
1076   (defbinding icon-view-create-drag-icon () gdk:pixmap
1077     (icon-view icon-view)
1078     (tree-path tree-path))
1079
1080   (defbinding icon-view-scroll-to-path (icon-view tree-path &key row-align column-align) nil
1081     (icon-view icon-view)
1082     (tree-path tree-path)
1083     ((or row-align column-align) boolean)
1084     (row-align single-float)
1085     (column-align single-float))
1086
1087   (defbinding icon-view-get-visible-range () boolean
1088     (icon-view icon-view)
1089     (start-path tree-path :out)
1090     (end-path tree-path :out))
1091
1092   (defbinding icon-view-enable-model-drag-source () nil
1093     (icon-view icon-view)
1094     (start-button-mask gdk:modifier-type)
1095     (targets (vector (inlined target-entry)))
1096     ((length targets) unsigned-int)
1097     (actions gdk:drag-action))
1098
1099   (defbinding icon-view-enable-model-drag-dest () nil
1100     (icon-view icon-view)
1101     (targets (vector (inlined target-entry)))
1102     ((length targets) unsigned-int)
1103     (actions gdk:drag-action))
1104
1105   (defbinding icon-view-unset-model-drag-source () nil
1106     (icon-view icon-view))
1107
1108   (defbinding icon-view-unset-model-drag-dest () nil
1109     (icon-view icon-view)))