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