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

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gtktree.lisp,v 1.2 2004/11/15 19:24:03 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23
  24 ;;;; Cell Layout
  25
  26 (defbinding cell-layout-pack-start () nil
  27   (cell-layout cell-layout)
  28   (cell cell-renderer)
  29   (expand boolean))
  30
  31 (defbinding cell-layout-pack-end () nil
  32   (cell-layout cell-layout)
  33   (cell cell-renderer)
  34   (expand boolean))
  35
  36 (defun cell-layout-pack (layout cell &key end expand)
  37   (if end
  38       (cell-layout-pack-end layout cell expand)
  39     (cell-layout-pack-start layout cell expand)))
  40
  41
  42 (defbinding cell-layout-reorder () nil
  43   (cell-layout cell-layout)
  44   (cell cell-renderer)
  45   (position int))
  46
  47 (defbinding cell-layout-clear () nil
  48   (cell-layout cell-layout))
  49
  50 (defbinding cell-layout-add-attribute (cell-layout cell attribute column) nil
  51   (cell-layout cell-layout)
  52   (cell cell-renderer)
  53   ((string-downcase attribute) string)
  54   (column int))
  55
  56 (def-callback-marshal %cell-layout-data-func
  57     (nil cell-layout cell-renderer tree-model tree-iter))
  58
  59 (defbinding cell-layout-set-cell-data-func (cell-layout cell function) nil
  60   (cell-layout cell-layout)
  61   (cell cell-renderer)
  62   ((callback %cell-layout-data-func) pointer)
  63   ((register-callback-function function) unsigned-int)
  64   ((callback %destroy-user-data) pointer))
  65
  66 (defbinding cell-layout-clear-attributes () nil
  67   (cell-layout cell-layout)
  68   (cell cell-renderer))
  69
  70
  71
  72 ;;;; List Store
  73
  74 (defmethod initialize-instance ((list-store list-store) &key column-types
  75                                 column-names initial-content)
  76   (call-next-method)
  77   (%list-store-set-column-types list-store column-types)
  78   (when column-names
  79     (setf (object-data list-store 'column-names) column-names))
  80   (when initial-content
  81     (loop
  82      with iter = (make-instance 'tree-iter)
  83      for row in initial-content
  84      do (list-store-append list-store row iter))))
  85
  86
  87 (defmethod column-setter-name ((list-store list-store))
  88   (declare (ignore list-store))
  89   "gtk_list_store_set")
  90
  91 (defbinding %list-store-set-column-types () nil
  92   (list-store list-store)
  93   ((length columns) unsigned-int)
  94   (columns (vector gtype)))
  95
  96 (defbinding list-store-remove () boolean
  97   (list-store list-store)
  98   (tree-iter tree-iter))
  99
 100 (defbinding %list-store-insert () nil
 101   (list-store list-store)
 102   (tree-iter tree-iter)
 103   (position int))
 104
 105 (defun list-store-insert
 106     (store position &optional data (iter (make-instance 'tree-iter)))
 107   (%list-store-insert store iter position)
 108   (when data (%tree-model-set store iter data))
 109   iter)
 110
 111 (defbinding %list-store-insert-before () nil
 112   (list-store list-store)
 113   (tree-iter tree-iter)
 114   (sibling (or null tree-iter)))
 115
 116 (defun list-store-insert-before
 117     (store sibling &optional data (iter (make-instance 'tree-iter)))
 118   (%list-store-insert-before store iter sibling)
 119   (when data (%tree-model-set store iter data))
 120   iter)
 121
 122 (defbinding %list-store-insert-after
 123     (list-store &optional sibling (tree-iter (make-instance 'tree-iter))) nil
 124   (list-store list-store)
 125   (tree-iter tree-iter)
 126   (sibling (or null tree-iter)))
 127
 128 (defun list-store-insert-after
 129     (store sibling &optional data (iter (make-instance 'tree-iter)))
 130   (%list-store-insert-after store iter sibling)
 131   (when data (%tree-model-set store iter data))
 132   iter)
 133
 134 (defbinding %list-store-prepend () nil
 135   (list-store list-store)
 136   (tree-iter tree-iter))
 137
 138 (defun list-store-prepend
 139     (store &optional data (iter (make-instance 'tree-iter)))
 140   (%list-store-prepend store iter)
 141   (when data (%tree-model-set store iter data))
 142   iter)
 143
 144 (defbinding %list-store-append () nil
 145   (list-store list-store)
 146   (tree-iter tree-iter))
 147
 148 (defun list-store-append
 149     (store &optional data (iter (make-instance 'tree-iter)))
 150   (%list-store-append store iter)
 151   (when data (%tree-model-set store iter data))
 152   iter)
 153
 154 (defbinding list-store-clear () nil
 155   (list-store list-store))
 156
 157 (defbinding list-store-reorder () nil
 158   (list-store list-store)
 159   (new-order (vector int)))
 160
 161 (defbinding list-store-swap () nil
 162   (list-store list-store)
 163   (a tree-iter)
 164   (b tree-iter))
 165
 166 (defbinding list-store-move-before () nil
 167   (list-store list-store)
 168   (iter tree-iter)
 169   (psoition (or null tree-iter)))
 170
 171 (defbinding list-store-move-after () nil
 172   (list-store list-store)
 173   (iter tree-iter)
 174   (psoition tree-iter))
 175
 176
 177 ;;; Tree Model
 178
 179 (defbinding %tree-path-free () nil
 180   (location pointer))
 181
 182 (defbinding %tree-path-get-indices () pointer
 183   (location pointer))
 184
 185 (defbinding %tree-path-get-depth () int
 186   (location pointer))
 187
 188 (defun %make-tree-path (path)
 189   (let ((c-vector (make-c-vector 'int (length path) path))
 190         (location (allocate-memory (+ (size-of 'int) (size-of 'pointer)))))
 191     (funcall (writer-function 'int) (length path) location)
 192     (funcall (writer-function 'pointer) c-vector location (size-of 'int))
 193     location))
 194
 195 (defun %tree-path-to-vector (location &optional (destroy-p t))
 196   (prog1
 197       (map-c-vector 'vector #'identity (%tree-path-get-indices location)
 198                     'int (%tree-path-get-depth location))
 199     (when destroy-p
 200       (%tree-path-free location))))
 201
 202 (eval-when (:compile-toplevel :load-toplevel :execute)
 203   (defmethod alien-type ((type (eql 'tree-path)) &rest args)
 204     (declare (ignore type args))
 205     (alien-type 'pointer))
 206
 207   (defmethod size-of ((type (eql 'tree-path)) &rest args)
 208     (declare (ignore type args))
 209     (size-of 'pointer))
 210
 211   (defmethod to-alien-form (path (type (eql 'tree-path)) &rest args)
 212     (declare (ignore type args))
 213     `(%make-tree-path ,path))
 214
 215   (defmethod to-alien-function ((type (eql 'tree-path)) &rest args)
 216     (declare (ignore type args))
 217     #'%make-tree-path)
 218
 219   (defmethod from-alien-form (location (type (eql 'tree-path)) &rest args)
 220     (declare (ignore type args))
 221     `(%tree-path-to-vector ,location))
 222
 223   (defmethod from-alien-function ((type (eql 'tree-path)) &rest args)
 224     (declare (ignore type args))
 225     #'%tree-path-to-vector)
 226
 227   (defmethod cleanup-form (location (type (eql 'tree-path)) &rest args)
 228     (declare (ignore type args))
 229     `(%tree-path-free ,location))
 230
 231   (defmethod cleanup-function ((type (eql 'tree-path)) &rest args)
 232     (declare (ignore type args))
 233     #'%tree-path-free))
 234
 235
 236 (defbinding %tree-row-reference-new () pointer
 237   (model tree-model)
 238   (path tree-path))
 239
 240 (defmethod initialize-instance ((reference tree-row-reference) &key model path)
 241   (declare (ignore initargs))
 242   (setf
 243    (slot-value reference 'location)
 244    (%tree-row-reference-new model path))
 245   (call-next-method))
 246
 247 (defbinding tree-row-reference-get-path () tree-path
 248   (reference tree-row-reference))
 249
 250 (defbinding (tree-row-reference-valid-p "gtk_tree_row_reference_valid") () boolean
 251   (reference tree-row-reference))
 252
 253
 254 (defbinding tree-model-get-column-type () type-number
 255   (tree-model tree-model)
 256   (index int))
 257
 258 (defbinding tree-model-get-iter
 259     (model path &optional (iter (make-instance 'tree-iter))) boolean
 260   (model tree-model)
 261   (iter tree-iter :return)
 262   (path tree-path))
 263
 264 (defbinding tree-model-get-path () tree-path
 265   (tree-model tree-model)
 266   (iter tree-iter))
 267
 268 (defbinding %tree-model-get-value () nil
 269   (tree-model tree-model)
 270   (iter tree-iter)
 271   (column int)
 272   (gvalue gvalue))
 273
 274 (defun tree-model-get-column-value (model iter column)
 275   (let ((index (column-index model column)))
 276     (with-gvalue (gvalue (tree-model-get-column-type model index))
 277       (%tree-model-get-value model iter index gvalue))))
 278
 279 (defbinding tree-model-iter-next () boolean
 280   (tree-model tree-model)
 281   (iter tree-iter :return))
 282
 283 (defbinding tree-model-iter-children
 284     (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
 285   (tree-model tree-model)
 286   (iter tree-iter :return)
 287   (parent (or null tree-iter)))
 288
 289 (defbinding (tree-model-iter-has-child-p "gtk_tree_model_iter_has_child")
 290     () boolean
 291   (tree-model tree-model)
 292   (iter tree-iter))
 293
 294 (defbinding tree-model-iter-n-children () int
 295   (tree-model tree-model)
 296   (iter tree-iter))
 297
 298 (defbinding tree-model-iter-nth-child
 299     (tree-model parent &optional (iter (make-instance 'tree-iter))) boolean
 300   (tree-model tree-model)
 301   (iter tree-iter :return)
 302   (parent (or null tree-iter))
 303   (n int))
 304
 305 (defbinding tree-model-iter-parent
 306     (tree-model child &optional (iter (make-instance 'tree-iter))) boolean
 307   (tree-model tree-model)
 308   (iter tree-iter :return)
 309   (child tree-iter))
 310
 311 (defbinding tree-model-get-string-from-iter () string
 312   (tree-model tree-model)
 313   (iter tree-iter))
 314
 315 (def-callback-marshal %tree-model-foreach-func
 316   (boolean tree-model tree-path tree-iter))
 317
 318 (defbinding %tree-model-foreach () nil
 319   (tree-model tree-model)
 320   ((callback %tree-model-foreach-func) pointer)
 321   (callback-id unsigned-int))
 322
 323 (defun tree-model-foreach (model function)
 324   (with-callback-function (id function)
 325     (%tree-model-foreach model id)))
 326
 327 (defbinding tree-model-row-changed () nil
 328   (tree-model tree-model)
 329   (path tree-path)
 330   (iter tree-iter))
 331
 332 (defbinding tree-model-row-inserted () nil
 333   (tree-model tree-model)
 334   (path tree-path)
 335   (iter tree-iter))
 336
 337 (defbinding tree-model-row-has-child-toggled () nil
 338   (tree-model tree-model)
 339   (path tree-path)
 340   (iter tree-iter))
 341
 342 (defbinding tree-model-row-deleted () nil
 343   (tree-model tree-model)
 344   (path tree-path)
 345   (iter tree-iter))
 346
 347 (defbinding tree-model-rows-reordered () nil
 348   (tree-model tree-model)
 349   (path tree-path)
 350   (iter tree-iter)
 351   (new-order int))
 352
 353
 354 (defun column-types (model columns)
 355   (map 'vector
 356        #'(lambda (column)
 357            (find-type-number (first (mklist column))))
 358        columns))
 359
 360 (defun column-index (model column)
 361   (or
 362    (etypecase column
 363      (number column)
 364      (symbol (position column (object-data model 'column-names)))
 365      (string (position column (object-data model 'column-names)
 366                    :test #'string=)))
 367    (error "~A has no column ~S" model column)))
 368
 369 (defun tree-model-column-value-setter (model column)
 370   (let ((setters (or
 371                   (object-data model 'column-setters)
 372                   (setf
 373                    (object-data model 'column-setters)
 374                    (make-array (tree-model-n-columns model)
 375                     :initial-element nil)))))
 376     (let ((index (column-index model column)))
 377     (or
 378      (svref setters index)
 379      (setf
 380       (svref setters index)
 381       (let ((setter
 382              (mkbinding (column-setter-name model)
 383               nil (type-of model) 'tree-iter 'int
 384               (type-from-number (tree-model-get-column-type model index))
 385               'int)))
 386         #'(lambda (value iter)
 387             (funcall setter model iter index value -1))))))))
 388
 389 (defun tree-model-row-setter (model)
 390   (or
 391    (object-data model 'row-setter)
 392    (progn
 393      ;; This will create any missing column setter
 394      (loop
 395       for i from 0 below (tree-model-n-columns model)
 396       do (tree-model-column-value-setter model i))
 397      (let ((setters (object-data model 'column-setters)))
 398        (setf
 399         (object-data model 'row-setter)
 400         #'(lambda (row iter)
 401             (map nil #'(lambda (value setter)
 402                          (funcall setter value iter))
 403                  row setters)))))))
 404
 405 (defun (setf tree-model-column-value) (value model iter column)
 406   (funcall (tree-model-column-value-setter model column) value iter)
 407   value)
 408
 409 (defun (setf tree-model-row-data) (data model iter)
 410   (funcall (tree-model-row-setter model) data iter)
 411   data)
 412
 413 (defun %tree-model-set (model iter data)
 414   (etypecase data
 415     (vector (setf (tree-model-row-data model iter) data))
 416     (cons
 417      (loop
 418       as (column value . rest) = data then rest
 419       do (setf (tree-model-column-value model iter column) value)
 420       while rest))))
 421
 422
 423 ;;; Tree Store
 424
 425 (defbinding %tree-store-set-column-types () nil
 426   (tree-store tree-store)
 427   ((length columns) unsigned-int)
 428   (columns (vector gtype)))
 429
 430 (defmethod initialize-instance ((tree-store tree-store) &key column-types
 431                                 column-names)
 432   (call-next-method)
 433   (%tree-store-set-column-types tree-store column-types)
 434   (when column-names
 435     (setf (object-data tree-store 'column-names) column-names)))
 436
 437 (defmethod column-setter-name ((tree-store tree-store))
 438   (declare (ignore tree-store))
 439   "gtk_tree_store_set")
 440
 441 (defbinding tree-store-remove () boolean
 442   (tree-store tree-store)
 443   (tree-iter tree-iter))
 444
 445 (defbinding %tree-store-insert () nil
 446   (tree-store tree-store)
 447   (tree-iter tree-iter)
 448   (parent (or null tree-iter))
 449   (position int))
 450
 451 (defun tree-store-insert
 452     (store parent position &optional data (iter (make-instance 'tree-iter)))
 453   (%tree-store-insert store iter parent position)
 454   (when data (%tree-model-set store iter data))
 455   iter)
 456
 457 (defbinding %tree-store-insert-before () nil
 458   (tree-store tree-store)
 459   (tree-iter tree-iter)
 460   (parent (or null tree-iter))
 461   (sibling (or null tree-iter)))
 462
 463 (defun tree-store-insert-after
 464     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 465   (%tree-store-insert-before store iter parent sibling)
 466   (when data (%tree-model-set store iter data))
 467   iter)
 468
 469 (defbinding %tree-store-insert-after () nil
 470   (tree-store tree-store)
 471   (tree-iter tree-iter)
 472   (parent (or null tree-iter))
 473   (sibling (or null tree-iter)))
 474
 475 (defun tree-store-insert-after
 476     (store parent sibling &optional data (iter (make-instance 'tree-iter)))
 477   (%tree-store-insert-after store iter parent sibling)
 478   (when data (%tree-model-set store iter data))
 479   iter)
 480
 481 (defbinding %tree-store-prepend () nil
 482   (tree-store tree-store)
 483   (tree-iter tree-iter)
 484   (parent (or null tree-iter)))
 485
 486 (defun tree-store-prepend
 487     (store parent &optional data (iter (make-instance 'tree-iter)))
 488   (%tree-store-prepend store iter parent)
 489   (when data (%tree-model-set store iter data))
 490   iter)
 491
 492 (defbinding %tree-store-append () nil
 493   (tree-store tree-store)
 494   (tree-iter tree-iter)
 495   (parent (or null tree-iter)))
 496
 497 (defun tree-store-append
 498     (store parent &optional data (iter (make-instance 'tree-iter)))
 499   (%tree-store-append store iter parent)
 500   (when data (%tree-model-set store iter data))
 501   iter)
 502
 503 (defbinding (tree-store-is-ancestor-p "gtk_tree_store_is_ancestor") () boolean
 504   (tree-store tree-store)
 505   (tree-iter tree-iter)
 506   (descendant tree-iter))
 507
 508 (defbinding tree-store-iter-depth () int
 509   (tree-store tree-store)
 510   (tree-iter tree-iter))
 511
 512 (defbinding tree-store-clear () nil
 513   (tree-store tree-store))
 514
 515 (defbinding tree-store-reorder () nil
 516   (tree-store tree-store)
 517   (parent tree-iter)
 518   (new-order (vector int)))
 519
 520 (defbinding tree-store-swap () nil
 521   (tree-store tree-store)
 522   (a tree-iter)
 523   (b tree-iter))
 524
 525 (defbinding tree-store-move-before () nil
 526   (tree-store tree-store)
 527   (iter tree-iter)
 528   (psoition (or null tree-iter)))
 529
 530
 531 (defbinding tree-store-move-after () nil
 532   (tree-store tree-store)
 533   (iter tree-iter)
 534   (psoition tree-iter))
 535
 536
 537
 538 ;;; Tree View
 539
 540 (defmethod initialize-instance ((tree-view tree-view) &key column)
 541   (call-next-method)
 542   (mapc #'(lambda (column)
 543             (tree-view-append-column tree-view column))
 544         (get-all initargs :column)))
 545
 546
 547 (defbinding tree-view-get-selection () tree-selection
 548   (tree-view tree-view))
 549
 550 (defbinding tree-view-columns-autosize () nil
 551   (tree-view tree-view))
 552
 553 (defbinding tree-view-append-column () int
 554   (tree-view tree-view)
 555   (tree-view-column tree-view-column))
 556
 557 (defbinding tree-view-remove-column () int
 558   (tree-view tree-view)
 559   (tree-view-column tree-view-column))
 560
 561 (defbinding tree-view-insert-column (view columnd position) int
 562   (view tree-view)
 563   (column tree-view-column)
 564   ((if (eq position :end) -1 position) int))
 565
 566 (defbinding tree-view-get-column () tree-view-column
 567   (tree-view tree-view)
 568   (position int))
 569
 570 (defbinding tree-view-move-column-after () nil
 571   (tree-view tree-view)
 572   (column tree-view-column)
 573   (base-column (or null tree-view-column)))
 574
 575 ;;(defbinding tree-view-set-column drag-function ...)
 576
 577 (defbinding tree-view-scroll-to-point () nil
 578   (tree-view tree-view)
 579   (tree-x int)
 580   (tree-y int))
 581
 582 (defbinding tree-view-scroll-to-cell () nil
 583   (tree-view tree-view)
 584   (path (or null tree-path))
 585   (column (or null tree-view-column))
 586   (use-align boolean)
 587   (row-align single-float)
 588   (col-align single-float))
 589
 590 (defbinding tree-view-set-cursor () nil
 591   (tree-view tree-view)
 592   (path tree-path)
 593   (focus-column tree-view-column)
 594   (start-editing boolean))
 595
 596 (defbinding tree-view-set-cursor-on-cell () nil
 597   (tree-view tree-view)
 598   (path tree-path)
 599   (focus-column (or null tree-view-column))
 600   (focus-cell (or null cell-renderer))
 601   (start-editing boolean))
 602
 603 (defbinding tree-view-get-cursor () nil
 604   (tree-view tree-view)
 605   (path tree-path :out )
 606   (focus-column tree-view-column :out))
 607
 608 (defbinding tree-view-row-activated () nil
 609   (tree-view tree-view)
 610   (path tree-path )
 611   (column tree-view-column))
 612
 613 (defbinding tree-view-expand-all () nil
 614   (tree-view tree-view))
 615
 616 (defbinding tree-view-collapse-all () nil
 617   (tree-view tree-view))
 618
 619 (defbinding tree-view-expand-to-path () nil
 620   (tree-view tree-view)
 621   (path tree-path))
 622
 623 (defbinding tree-view-expand-row () nil
 624   (tree-view tree-view)
 625   (path tree-path)
 626   (open-all boolean))
 627
 628 (defbinding tree-view-collapse-row () nil
 629   (tree-view tree-view)
 630   (path tree-path))
 631
 632 (def-callback-marshal %tree-view-mapping-func (nil tree-view tree-path))
 633
 634 (defbinding %tree-view-map-expanded-rows () nil
 635   (tree-view tree-view)
 636   ((callback %tree-view-mapping-func) pointer)
 637   (callback-id unsigned-int))
 638
 639 (defun map-expanded-rows (function tree-view)
 640   (with-callback-function (id function)
 641     (%tree-view-map-expanded-rows tree-view id)))
 642
 643 (defbinding (tree-view-row-expanded-p "gtk_tree_view_row_expanded") () boolean
 644   (tree-view tree-view)
 645   (path tree-path))
 646
 647 (defbinding tree-view-get-path-at-pos
 648     (tree-view x y &optional (cell-x 0) (cell-y 0)) boolean
 649   (tree-view tree-view)
 650   (x int)
 651   (y int)
 652   (path tree-path :out)
 653   (column tree-view-column :out)
 654   (cell-x int)
 655   (cell-y int))
 656
 657 (defbinding tree-view-get-cell-area () nil
 658   (tree-view tree-view)
 659   (path (or null tree-path))
 660   (column (or null tree-view-column))
 661   ((make-instance 'gdk:rectangle) gdk:rectangle :return))
 662
 663 (defbinding tree-view-get-background-area () nil
 664   (tree-view tree-view)
 665   (path (or null tree-path))
 666   (column (or null tree-view-column))
 667   ((make-instance 'gdk:rectangle) gdk:rectangle :return))
 668
 669 (defbinding tree-view-get-visible-rect () nil
 670   (tree-view tree-view)
 671   ((make-instance 'gdk:rectangle) gdk:rectangle :return))
 672
 673 ;; and many more functions which we'll add later
 674
 675
 676 ;;; Tree View Column
 677