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