chiark - git - mdw - clg/blob - gtk/gtk.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: gtk.lisp,v 1.6 2001-10-21 23:22:04 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Gtk version
  24
  25 (defbinding check-version () string
  26   (required-major unsigned-int)
  27   (required-minor unsigned-int)
  28   (required-micro unsigned-int))
  29
  30 (defbinding query-version () nil
  31   (major unsigned-int :out)
  32   (minor unsigned-int :out)
  33   (micro unsigned-int :out))
  34
  35 (defun gtk-version ()
  36   (multiple-value-bind (major minor micro)
  37       (query-version)
  38     (if (zerop micro)
  39         (format nil "Gtk+ v~A.~A" major minor)
  40       (format nil "Gtk+ v~A.~A.~A" major minor micro))))
  41
  42
  43
  44 ;;; Label
  45
  46 (defbinding label-select-region () nil
  47   (label label)
  48   (start int)
  49   (end int))
  50
  51
  52
  53 ;;; Acccel label
  54
  55 (defbinding accel-label-refetch () boolean
  56   (accel-label accel-label))
  57
  58
  59
  60 ;;; Bin
  61
  62 (defbinding (bin-child "gtk_bin_get_child") () widget
  63   (bin bin))
  64
  65 (defun (setf bin-child) (child bin)
  66   (let ((old-child (bin-child bin)))
  67     (when old-child
  68       (container-remove bin old-child)))
  69   (container-add bin child)
  70   child)
  71
  72
  73 ;;; Button
  74
  75 (defbinding button-pressed () nil
  76   (button button))
  77
  78 (defbinding button-released () nil
  79   (button button))
  80
  81 (defbinding button-clicked () nil
  82   (button button))
  83
  84 (defbinding button-enter () nil
  85   (button button))
  86
  87 (defbinding button-leave () nil
  88   (button button))
  89
  90
  91
  92 ;;; Toggle button
  93
  94 (defbinding toggle-button-toggled () nil
  95   (toggle-button toggle-button))
  96
  97
  98
  99 ;;; Check button
 100
 101 (defmethod (setf button-label) ((label string) (button check-button))
 102   (call-next-method)
 103   (setf (misc-xalign (bin-child button)) 0.0)
 104   label)
 105
 106
 107
 108 ;;; Radio button
 109
 110 (defbinding %radio-button-get-group () pointer
 111   (radio-button radio-button))
 112
 113 (defbinding %radio-button-set-group () nil
 114   (radio-button radio-button)
 115   (group pointer))
 116
 117 (defun radio-button-add-to-group (button1 button2)
 118   "Add BUTTON1 to the group which BUTTON2 belongs to."
 119   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 120
 121
 122 (defmethod initialize-instance ((button radio-button)
 123                                 &rest initargs &key group-with)
 124   (declare (ignore initargs))
 125   (call-next-method)
 126   (when group-with
 127     (radio-button-add-to-group item group-with)))
 128
 129
 130 ;;; Option menu
 131
 132 (defbinding %option-menu-set-menu () nil
 133   (option-menu option-menu)
 134   (menu widget))
 135
 136 (defbinding %option-menu-remove-menu () nil
 137   (option-menu option-menu))
 138
 139 (defun (setf option-menu-menu) (menu option-menu)
 140   (if (not menu)
 141       (%option-menu-remove-menu option-menu)
 142     (%option-menu-set-menu option-menu menu))
 143   menu)
 144
 145
 146
 147 ;;; Item
 148
 149 (defbinding item-select () nil
 150   (item item))
 151
 152 (defbinding item-deselect () nil
 153   (item item))
 154
 155 (defbinding item-toggle () nil
 156   (item item))
 157
 158
 159
 160 ;;; Menu item
 161
 162 (defun (setf menu-item-label) (label menu-item)
 163   (make-instance 'accel-label
 164    :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
 165    :visible t :parent menu-item)
 166   label)
 167
 168 (defbinding %menu-item-set-submenu () nil
 169   (menu-item menu-item)
 170   (submenu menu))
 171
 172 (defbinding %menu-item-remove-submenu () nil
 173   (menu-item menu-item))
 174
 175 (defun (setf menu-item-submenu) (submenu menu-item)
 176   (if (not submenu)
 177       (%menu-item-remove-submenu menu-item)
 178     (%menu-item-set-submenu menu-item submenu))
 179   submenu)
 180
 181 (defbinding menu-item-select () nil
 182   (menu-item menu-item))
 183
 184 (defbinding menu-item-deselect () nil
 185   (menu-item menu-item))
 186
 187 (defbinding menu-item-activate () nil
 188   (menu-item menu-item))
 189
 190
 191
 192 ;;; Check menu item
 193
 194 (defbinding check-menu-item-toggled () nil
 195   (check-menu-item check-menu-item))
 196
 197
 198
 199 ;;; Radio menu item
 200
 201 (defbinding %radio-menu-item-get-group () pointer
 202   (radio-menu-item radio-menu-item))
 203
 204 (defbinding %radio-menu-item-set-group () nil
 205   (radio-menu-item radio-menu-item)
 206   (group pointer))
 207
 208 (defun radio-menu-item-add-to-group (item1 item2)
 209   "Add ITEM1 to the group which ITEM2 belongs to."
 210   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 211
 212 (defmethod initialize-instance ((item radio-menu-item)
 213                                 &rest initargs &key group-with)
 214   (declare (ignore initargs))
 215   (call-next-method)
 216   (when group-with
 217     (radio-menu-item-add-to-group item group-with)))
 218
 219
 220
 221 ;;; Window
 222
 223 (defbinding %window-set-wmclass () nil
 224   (window window)
 225   (wmclass-name string)
 226   (wmclass-class string))
 227
 228 (defun (setf window-wmclass) (wmclass window)
 229   (%window-set-wmclass window (svref wmclass 0) (svref wmclass 1))
 230   (values (svref wmclass 0) (svref wmclass 1)))
 231
 232 ;; gtkglue.c
 233 (defbinding window-wmclass () nil
 234   (window window)
 235   (wmclass-name string :out)
 236   (wmclass-class string :out))
 237
 238 (defbinding window-add-accel-group () nil
 239   (window window)
 240   (accel-group accel-group))
 241
 242 (defbinding window-remove-accel-group () nil
 243   (window window)
 244   (accel-group accel-group))
 245
 246 (defbinding window-activate-focus () int
 247   (window window))
 248
 249 (defbinding window-activate-default () int
 250   (window window))
 251
 252 (defbinding window-set-transient-for () nil
 253   (window window)
 254   (parent window))
 255
 256 ;(defbinding window-set-geometry-hints)
 257
 258
 259
 260 ;;; File selection
 261
 262 (defbinding file-selection-complete () nil
 263   (file-selection file-selection)
 264   (pattern string))
 265
 266
 267
 268 ;;; Scrolled window
 269
 270 (defun (setf scrolled-window-scrollbar-policy) (policy window)
 271   (setf (scrolled-window-hscrollbar-policy window) policy)
 272   (setf (scrolled-window-vscrollbar-policy window) policy))
 273
 274 (defbinding scrolled-window-add-with-viewport () nil
 275    (scrolled-window scrolled-window)
 276    (child widget))
 277
 278
 279
 280 ;;; Box
 281
 282 (defbinding box-pack-start () nil
 283   (box box)
 284   (child widget)
 285   (expand boolean)
 286   (fill boolean)
 287   (padding unsigned-int))
 288
 289 (defbinding box-pack-end () nil
 290   (box box)
 291   (child widget)
 292   (expand boolean)
 293   (fill boolean)
 294   (padding unsigned-int))
 295
 296 (defun box-pack (box child &key (pack :start) (expand t) (fill t) (padding 0))
 297   (if (eq pack :start)
 298       (box-pack-start box child expand fill padding)
 299     (box-pack-end box child expand fill padding)))
 300
 301 (defbinding box-reorder-child () nil
 302   (box box)
 303   (child widget)
 304   (position int))
 305
 306 (defbinding box-query-child-packing () nil
 307   (box box)
 308   (child widget :out)
 309   (expand boolean :out)
 310   (fill boolean :out)
 311   (padding unsigned-int :out)
 312   (pack-type pack-type :out))
 313
 314 (defbinding box-set-child-packing () nil
 315   (box box)
 316   (child widget)
 317   (expand boolean)
 318   (fill boolean)
 319   (padding unsigned-int)
 320   (pack-type pack-type))
 321
 322
 323
 324 ;;; Button box
 325
 326 (defbinding button-box-get-child-size () nil
 327   (button-box button-box)
 328   (min-width int :out)
 329   (min-height int :out))
 330
 331 (defbinding button-box-set-child-size () nil
 332   (button-box button-box)
 333   (min-width int)
 334   (min-height int))
 335
 336 (defbinding button-box-get-child-ipadding () nil
 337   (button-box button-box)
 338   (ipad-x int :out)
 339   (ipad-y int :out))
 340
 341 (defbinding button-box-set-child-ipadding () nil
 342   (button-box button-box)
 343   (ipad-x int)
 344   (ipad-y int))
 345
 346
 347
 348 ;;; Color selection
 349
 350 ; (defbinding %color-selection-get-previous-color () nil
 351 ;   (colorsel color-selection)
 352 ;   (color pointer))
 353
 354 ; (defun color-selection-previous-color (colorsel)
 355 ;   (let ((color (allocate-memory (* (size-of 'double-float) 4))))
 356 ;     (%color-selection-get-previous-color colorsel color)
 357 ;     (funcall (get-from-alien-function '(vector double-float 4)) color)))
 358
 359 ; (defbinding %color-selection-set-previous-color () nil
 360 ;   (colorsel color-selection)
 361 ;   (color (vector double-float 4)))
 362
 363 ; (defun (setf color-selection-previous-color) (color colorsel)
 364 ;   (%color-selection-set-previous-color colorsel color)
 365 ;   color)
 366
 367 (defbinding (color-selection-is-adjusting-p
 368              "gtk_color_selection_is_adjusting") () boolean
 369   (colorsel color-selection))
 370
 371
 372
 373 ;;; Combo
 374
 375 (defbinding combo-set-value-in-list () nil
 376   (combo combo)
 377   (val boolean)
 378   (ok-if-empty boolean))
 379
 380 ; (defbinding ("gtk_combo_set_item_string" (setf combo-item-string)) () nil
 381 ;   (combo combo)
 382 ;   (item item)
 383 ;   (item-value string))
 384
 385 (defbinding %combo-set-popdown-strings () nil
 386   (combo combo)
 387   (strings (glist string)))
 388
 389 (defun (setf combo-popdown-strings) (strings combo)
 390   (%combo-set-popdown-strings combo strings)
 391   strings)
 392
 393 (defbinding combo-disable-activate () nil
 394   (combo combo))
 395
 396
 397
 398 ;;; Statusbar
 399
 400 (defbinding (statusbar-context-id "gtk_statusbar_get_context_id")
 401     () unsigned-int
 402   (statusbar statusbar)
 403   (context-description string))
 404
 405 (defbinding statusbar-push () unsigned-int
 406   (statusbar statusbar)
 407   (context-id unsigned-int)
 408   (text string))
 409
 410 (defbinding statusbar-pop () nil
 411   (statusbar statusbar)
 412   (context-id unsigned-int))
 413
 414 (defbinding statusbar-remove () nil
 415   (statusbar statusbar)
 416   (context-id unsigned-int)
 417   (message-id unsigned-int))
 418
 419
 420
 421 ;;; Fixed
 422
 423 (defbinding fixed-put () nil
 424   (fixed fixed)
 425   (widget widget)
 426   (x (signed 16))
 427   (y (signed 16)))
 428
 429 (defbinding fixed-move () nil
 430   (fixed fixed)
 431   (widget widget)
 432   (x (signed 16))
 433   (y (signed 16)))
 434
 435
 436
 437 ;;; Notebook
 438
 439 (defbinding (notebook-insert-page "gtk_notebook_insert_page_menu")
 440     (notebook position child tab-label &optional menu-label) nil
 441   (notebook notebook)
 442   (child widget)
 443   ((if (stringp tab-label)
 444        (label-new tab-label)
 445      tab-label) widget)
 446   ((if (stringp menu-label)
 447        (label-new menu-label)
 448      menu-label) (or null widget))
 449   (position int))
 450
 451 (defun notebook-append-page (notebook child tab-label &optional menu-label)
 452   (notebook-insert-page notebook -1 child tab-label menu-label))
 453
 454 (defun notebook-prepend-page (notebook child tab-label &optional menu-label)
 455   (notebook-insert-page notebook 0 child tab-label menu-label))
 456
 457 (defbinding notebook-remove-page () nil
 458   (notebook notebook)
 459   (page-num int))
 460
 461 ; (defun notebook-current-page-num (notebook)
 462 ;   (let ((page-num (notebook-current-page notebook)))
 463 ;     (if (= page-num -1)
 464 ;       nil
 465 ;       page-num)))
 466
 467 (defbinding (notebook-nth-page-child "gtk_notebook_get_nth_page") () widget
 468   (notebook notebook)
 469   (page-num int))
 470
 471 (defun notebook-page-child (notebook)
 472   (notebook-nth-page-child notebook (notebook-page notebook)))
 473
 474 (defbinding %notebook-page-num () int
 475   (notebook notebook)
 476   (child widget))
 477
 478 (defun notebook-child-num (notebook child)
 479   (let ((page-num (%notebook-page-num notebook child)))
 480     (if (= page-num -1)
 481         nil
 482       page-num)))
 483
 484 (defbinding notebook-next-page () nil
 485   (notebook notebook))
 486
 487 (defbinding notebook-prev-page () nil
 488   (notebook notebook))
 489
 490 (defbinding notebook-popup-enable () nil
 491   (notebook notebook))
 492
 493 (defbinding notebook-popup-disable () nil
 494   (notebook notebook))
 495
 496 ; (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
 497 ;     (notebook ref) widget
 498 ;   (notebook notebook)
 499 ;   ((if (typep ref 'widget)
 500 ;        ref
 501 ;      (notebook-nth-page-child notebook ref))
 502 ;    widget))
 503
 504 ; (defbinding %notebook-set-tab-label () nil
 505 ;   (notebook notebook)
 506 ;   (reference widget)
 507 ;   (tab-label widget))
 508
 509 ; (defun (setf notebook-tab-label) (tab-label notebook reference)
 510 ;   (let ((tab-label-widget (if (stringp tab-label)
 511 ;                             (label-new tab-label)
 512 ;                           tab-label)))
 513 ;     (%notebook-set-tab-label
 514 ;      notebook
 515 ;      (if (typep reference 'widget)
 516 ;        reference
 517 ;        (notebook-nth-page-child notebook reference))
 518 ;      tab-label-widget)
 519 ;     tab-label-widget))
 520
 521 ; (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
 522 ;     (notebook ref) widget
 523 ;   (notebook notebook)
 524 ;   ((if (typep ref 'widget)
 525 ;        ref
 526 ;      (notebook-nth-page-child notebook ref))
 527 ;    widget))
 528
 529 ; (defbinding %notebook-set-menu-label () nil
 530 ;   (notebook notebook)
 531 ;   (reference widget)
 532 ;   (menu-label widget))
 533
 534 ; (defun (setf notebook-menu-label) (menu-label notebook reference)
 535 ;   (let ((menu-label-widget (if (stringp menu-label)
 536 ;                             (label-new menu-label)
 537 ;                           menu-label)))
 538 ;     (%notebook-set-menu-label
 539 ;      notebook
 540 ;      (if (typep reference 'widget)
 541 ;        reference
 542 ;        (notebook-nth-page-child notebook reference))
 543 ;      menu-label-widget)
 544 ;     menu-label-widget))
 545
 546 (defbinding notebook-query-tab-label-packing (notebook ref) nil
 547   (notebook notebook)
 548   ((if (typep ref 'widget)
 549        ref
 550      (notebook-nth-page-child notebook ref))
 551    widget)
 552   (expand boolean :out)
 553   (fill boolean :out)
 554   (pack-type pack-type :out))
 555
 556 (defbinding
 557     notebook-set-tab-label-packing (notebook ref expand fill pack-type) nil
 558   (notebook notebook)
 559   ((if (typep ref 'widget)
 560        ref
 561      (notebook-nth-page-child notebook ref))
 562    widget)
 563   (expand boolean)
 564   (fill boolean)
 565   (pack-type pack-type))
 566
 567 (defbinding notebook-reorder-child () nil
 568   (notebook notebook)
 569   (child widget)
 570   (position int))
 571
 572
 573
 574 ;;; Paned
 575
 576 (defbinding paned-pack1 () nil
 577   (paned paned)
 578   (child widget)
 579   (resize boolean)
 580   (shrink boolean))
 581
 582 (defbinding paned-pack2 () nil
 583   (paned paned)
 584   (child widget)
 585   (resize boolean)
 586   (shrink boolean))
 587
 588 ;; gtkglue.c
 589 (defbinding paned-child1 () widget
 590   (paned paned)
 591   (resize boolean :out)
 592   (shrink boolean :out))
 593
 594 ;; gtkglue.c
 595 (defbinding paned-child2 () widget
 596   (paned paned)
 597   (resize boolean :out)
 598   (shrink boolean :out))
 599
 600 (defun (setf paned-child1) (child paned)
 601   (paned-pack1 paned child nil t))
 602
 603 (defun (setf paned-child2) (child paned)
 604   (paned-pack2 paned child t t))
 605
 606
 607
 608 ;;; Layout
 609
 610 (defbinding layout-put () nil
 611   (layout layout)
 612   (widget widget)
 613   (x int)
 614   (y int))
 615
 616 (defbinding layout-move () nil
 617   (layout layout)
 618   (widget widget)
 619   (x int)
 620   (y int))
 621
 622 (defbinding layout-set-size () nil
 623   (layout layout)
 624   (width int)
 625   (height int))
 626
 627 (defbinding layout-get-size () nil
 628   (layout layout)
 629   (width int :out)
 630   (height int :out))
 631
 632
 633
 634 ;;; Menu shell
 635
 636 (defbinding menu-shell-insert () nil
 637   (menu-shell menu-shell)
 638   (menu-item menu-item)
 639   (position int))
 640
 641 (defun menu-shell-append (menu-shell menu-item)
 642   (menu-shell-insert menu-shell menu-item -1))
 643
 644 (defun menu-shell-prepend (menu-shell menu-item)
 645   (menu-shell-insert menu-shell menu-item 0))
 646
 647 (defbinding menu-shell-deactivate () nil
 648   (menu-shell menu-shell))
 649
 650 (defbinding menu-shell-select-item () nil
 651   (menu-shell menu-shell)
 652   (menu-item menu-item))
 653
 654 (defbinding menu-shell-deselect () nil
 655   (menu-shell menu-shell))
 656
 657 (defbinding menu-shell-activate-item () nil
 658   (menu-shell menu-shell)
 659   (menu-item menu-item)
 660   (fore-deactivate boolean))
 661
 662
 663
 664 ; ;;; Menu bar
 665
 666 ; (defbinding menu-bar-insert () nil
 667 ;   (menu-bar menu-bar)
 668 ;   (menu menu)
 669 ;   (position int))
 670
 671 ; (defun menu-bar-append (menu-bar menu)
 672 ;   (menu-bar-insert menu-bar menu -1))
 673
 674 ; (defun menu-bar-prepend (menu-bar menu)
 675 ;   (menu-bar-insert menu-bar menu 0))
 676
 677
 678
 679 ; ;;; Menu
 680
 681 ;(defun menu-popup ...)
 682
 683 (defbinding menu-reposition () nil
 684   (menu menu))
 685
 686 (defbinding menu-popdown () nil
 687   (menu menu))
 688
 689 (defbinding %menu-set-active () nil
 690   (menu menu)
 691   (index unsigned-int))
 692
 693 (defun (setf menu-active) (menu index)
 694   (%menu-set-active menu index))
 695
 696 (defbinding menu-reorder-child () nil
 697   (menu menu)
 698   (menu-item menu-item)
 699   (position int))
 700
 701
 702 ;;; Table
 703
 704 (defbinding table-resize () nil
 705   (table table)
 706   (rows unsigned-int)
 707   (columns unsigned-int))
 708
 709 (defbinding table-attach (table child left right top bottom
 710                                &key (x-options '(:expand :fill))
 711                                     (y-options '(:expand :fill))
 712                                     (x-padding 0) (y-padding 0)) nil
 713   (table table)
 714   (child widget)
 715   (left unsigned-int)
 716   (right unsigned-int)
 717   (top unsigned-int)
 718   (bottom unsigned-int)
 719   (x-options attach-options)
 720   (y-options attach-options)
 721   (x-padding unsigned-int)
 722   (y-padding unsigned-int))
 723
 724
 725 (defbinding %table-set-row-spacing () nil
 726   (table table)
 727   (row unsigned-int)
 728   (spacing unsigned-int))
 729
 730 (defbinding %table-set-row-spacings () nil
 731   (table table)
 732   (spacing unsigned-int))
 733
 734 (defun (setf table-row-spacing) (spacing table &optional row)
 735   (if row
 736       (%table-set-row-spacing table row spacing)
 737     (%table-set-row-spacings table spacing))
 738   spacing)
 739
 740 (defbinding %table-get-row-spacing () unsigned-int
 741   (table table)
 742   (row unsigned-int))
 743
 744 (defbinding %table-get-default-row-spacing () unsigned-int
 745   (table table))
 746
 747 (defun table-row-spacing (table &optional row)
 748   (if row
 749       (%table-get-row-spacing table row)
 750     (%table-get-default-row-spacing table)))
 751
 752
 753 (defbinding %table-set-col-spacing () nil
 754   (table table)
 755   (col unsigned-int)
 756   (spacing unsigned-int))
 757
 758 (defbinding %table-set-col-spacings () nil
 759   (table table)
 760   (spacing unsigned-int))
 761
 762 (defun (setf table-col-spacing) (spacing table &optional col)
 763   (if col
 764       (%table-set-col-spacing table col spacing)
 765     (%table-set-col-spacings table spacing))
 766   spacing)
 767
 768 (defbinding %table-get-col-spacing () unsigned-int
 769   (table table)
 770   (col unsigned-int))
 771
 772 (defbinding %table-get-default-col-spacing () unsigned-int
 773   (table table))
 774
 775 (defun table-col-spacing (table &optional col)
 776   (if col
 777       (%table-get-col-spacing table col)
 778     (%table-get-default-col-spacing table)))
 779
 780
 781 ;;; Dialog
 782
 783 (defmethod initialize-instance ((dialog dialog) &rest initargs)
 784   (apply #'call-next-method dialog (plist-remove initargs :child))
 785   (dolist (button-definition (get-all initargs :button))
 786     (apply #'dialog-add-button dialog button-definition))
 787   (dolist (child (get-all initargs :child))
 788     (apply #'dialog-add-child dialog (mklist child))))
 789
 790
 791 (defvar %*response-id-key* (gensym))
 792
 793 (defun %dialog-find-response-id-num (dialog response-id create-p)
 794   (or
 795    (cadr (assoc response-id (rest (type-expand-1 'response-type))))
 796    (let* ((response-ids (object-data dialog %*response-id-key*))
 797           (response-id-num (position response-id response-ids)))
 798     (cond
 799      (response-id-num)
 800      (create-p
 801       (cond
 802        (response-ids
 803         (setf (cdr (last response-ids)) (list response-id))
 804         (1- (length response-ids)))
 805        (t
 806         (setf (object-data dialog %*response-id-key*) (list response-id))
 807         0)))
 808      (t
 809       (error "Invalid response id: ~A" response-id))))))
 810
 811 (defun %dialog-find-response-id (dialog response-id-num)
 812   (if (< response-id-num 0)
 813       (car
 814        (rassoc
 815         (list response-id-num)
 816         (rest (type-expand-1 'response-type)) :test #'equalp))
 817     (nth response-id-num (object-data dialog %*response-id-key*))))
 818
 819
 820 (defmethod signal-connect ((dialog dialog) signal function &key object)
 821   (case signal
 822     (response
 823      #'(lambda (dialog response-id-num)
 824          (let ((response-id (%dialog-find-response-id dialog response-id-num)))
 825            (cond
 826             ((eq object t)  (funcall function dialog response-id))
 827             (object (funcall function object response-id))
 828             (t (funcall function response-id))))))
 829     (t
 830      (call-next-method))))
 831
 832
 833 (defbinding dialog-response (dialog response-id) nil
 834   (dialog dialog)
 835   ((%dialog-find-response-id-num dialog response-id nil) int))
 836
 837 (defbinding %dialog-set-default-response () nil
 838   (dialog dialog)
 839   (response-id-num int))
 840
 841 (defun dialog-set-default-response (dialog response-id)
 842   (%dialog-set-default-response
 843    dialog (%dialog-find-response-id-num dialog response-id nil)))
 844
 845 (defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil
 846   (dialog dialog)
 847   ((%dialog-find-response-id-num dialog response-id nil) int)
 848   (sensitive boolean))
 849
 850
 851 (defbinding %dialog-add-button () button
 852   (dialog dialog)
 853   (text string)
 854   (response-id-num int))
 855
 856 (defun dialog-add-button (dialog label &optional response-id default-p)
 857   (let* ((response-id-num
 858           (if response-id
 859               (%dialog-find-response-id-num dialog response-id t)
 860             (length (object-data dialog %*response-id-key*))))
 861          (button (%dialog-add-button dialog label response-id-num)))
 862     (unless response-id
 863       (%dialog-find-response-id-num dialog button t))
 864     (when default-p
 865       (%dialog-set-default-response dialog response-id-num))
 866     button))
 867
 868
 869 (defbinding %dialog-add-action-widget () button
 870   (dialog dialog)
 871   (action-widget widget)
 872   (response-id-num int))
 873
 874 (defun dialog-add-action-widget (dialog widget &optional (response-id widget)
 875                                  default-p)
 876   (let ((response-id-num (%dialog-find-response-id-num dialog response-id t)))
 877     (%dialog-add-action-widget dialog widget response-id-num)
 878     (when default-p
 879       (%dialog-set-default-response dialog response-id-num))
 880     widget))
 881
 882
 883 (defun dialog-add-child (dialog child &rest args)
 884   (apply #'container-add (slot-value dialog 'vbox) child args))
 885
 886 (defmethod container-children ((dialog dialog))
 887   (container-children (dialog-vbox dialog)))
 888
 889 (defmethod (setf container-children) (children (dialog dialog))
 890   (setf (container-children (dialog-vbox dialog)) children))
 891
 892
 893
 894 ;;; Toolbar
 895
 896 ;; gtkglue.c
 897 (defbinding toolbar-num-children () int
 898   (toolbar toolbar))
 899
 900 (defun %toolbar-position-num (toolbar position)
 901   (case position
 902     (:prepend 0)
 903     (:append (toolbar-num-children toolbar))
 904     (t
 905      (assert (and (>= position 0) (< position (toolbar-num-children toolbar))))
 906      position)))
 907
 908 (defbinding %toolbar-insert-element () widget
 909   (toolbar toolbar)
 910   (type toolbar-child-type)
 911   (widget (or null widget))
 912   (text string)
 913   (tooltip-text string)
 914   (tooltip-private-text string)
 915   (icon (or null widget))
 916   (nil null)
 917   (nil null)
 918   (position int))
 919
 920 (defun toolbar-insert-element (toolbar position
 921                                &key tooltip-text tooltip-private-text
 922                                type widget icon text callback)
 923   (let* ((icon-widget (typecase icon
 924                        ((or null widget) icon)
 925                        (t (pixmap-new icon))))
 926          (toolbar-child
 927           (%toolbar-insert-element
 928            toolbar (or type (and widget :widget) :button)
 929            widget text tooltip-text tooltip-private-text icon-widget
 930            (%toolbar-position-num toolbar position))))
 931     (when callback
 932       (signal-connect toolbar-child 'clicked callback))
 933     toolbar-child))
 934
 935 (defun toolbar-append-element (toolbar &key tooltip-text tooltip-private-text
 936                                type widget icon text callback)
 937   (toolbar-insert-element
 938    toolbar :append :type type :widget widget :icon icon :text text
 939    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
 940    :callback callback))
 941
 942 (defun toolbar-prepend-element (toolbar &key tooltip-text tooltip-private-text
 943                                 type widget icon text callback)
 944   (toolbar-insert-element
 945    toolbar :prepend :type type :widget widget :icon icon :text text
 946    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
 947    :callback callback))
 948
 949 (defun toolbar-insert-space (toolbar position)
 950   (toolbar-insert-element toolbar position :type :space))
 951
 952 (defun toolbar-append-space (toolbar)
 953   (toolbar-insert-space toolbar :append))
 954
 955 (defun toolbar-prepend-space (toolbar)
 956   (toolbar-insert-space toolbar :prepend))
 957
 958 (defun toolbar-insert-widget (toolbar widget position &key tooltip-text
 959                               tooltip-private-text callback)
 960   (toolbar-insert-element
 961    toolbar position :widget widget :tooltip-text tooltip-text
 962    :tooltip-private-text tooltip-private-text :callback callback))
 963
 964 (defun toolbar-append-widget (toolbar widget &key tooltip-text
 965                               tooltip-private-text callback)
 966   (toolbar-insert-widget
 967    toolbar widget :append :tooltip-text tooltip-text
 968    :tooltip-private-text tooltip-private-text :callback callback))
 969
 970 (defun toolbar-prepend-widget (toolbar widget &key tooltip-text
 971                                tooltip-private-text callback)
 972   (toolbar-insert-widget
 973    toolbar widget :prepend :tooltip-text tooltip-text
 974    :tooltip-private-text tooltip-private-text :callback callback))
 975
 976 (defun toolbar-insert-item (toolbar text icon position &key tooltip-text
 977                             tooltip-private-text callback)
 978   (toolbar-insert-element
 979    toolbar position :text text :icon icon :callback callback
 980    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
 981
 982 (defun toolbar-append-item (toolbar text icon &key tooltip-text
 983                             tooltip-private-text callback)
 984   (toolbar-insert-item
 985    toolbar text icon :append :callback callback
 986    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
 987
 988
 989 (defun toolbar-prepend-item (toolbar text icon &key tooltip-text
 990                              tooltip-private-text callback)
 991   (toolbar-insert-item
 992    toolbar text icon :prepend :callback callback
 993    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
 994
 995 (defun toolbar-enable-tooltips (toolbar)
 996   (setf (toolbar-tooltips-p toolbar) t))
 997
 998 (defun toolbar-disable-tooltips (toolbar)
 999   (setf (toolbar-tooltips-p toolbar) nil))
1000
1001
1002
1003 ;;; Calendar
1004
1005 (defbinding calendar-select-month () int
1006   (calendar calendar)
1007   (month unsigned-int)
1008   (year unsigned-int))
1009
1010 (defbinding calendar-select-day () nil
1011   (calendar calendar)
1012   (day unsigned-int))
1013
1014 (defbinding calendar-mark-day () int
1015   (calendar calendar)
1016   (day unsigned-int))
1017
1018 (defbinding calendar-unmark-day () int
1019   (calendar calendar)
1020   (day unsigned-int))
1021
1022 (defbinding calendar-clear-marks () nil
1023   (calendar calendar))
1024
1025 (defbinding calendar-display-options () nil
1026   (calendar calendar)
1027   (options calendar-display-options))
1028
1029 (defbinding (calendar-date "gtk_calendar_get_date") () nil
1030   (calendar calendar)
1031   (year unsigned-int :out)
1032   (month unsigned-int :out)
1033   (day unsigned-int :out))
1034
1035 (defbinding calendar-freeze () nil
1036   (calendar calendar))
1037
1038 (defbinding calendar-thaw () nil
1039   (calendar calendar))
1040
1041
1042
1043 ;;; Drawing area
1044
1045
1046 ; (defbinding ("gtk_drawing_area_size" %drawing-area-set-size) () nil
1047 ;   (drawing-area drawing-area)
1048 ;   (width int)
1049 ;   (height int))
1050
1051 ; (defun (setf drawing-area-size) (size drawing-area)
1052 ;   (%drawing-area-set-size drawing-area (svref size 0) (svref size 1))
1053 ;   (values (svref size 0) (svref size 1)))
1054
1055 ; ;; gtkglue.c
1056 ; (defbinding ("gtk_drawing_area_get_size" drawing-area-size) () nil
1057 ;   (drawing-area drawing-area)
1058 ;   (width int :out)
1059 ;   (height int :out))
1060
1061
1062
1063 ;;; Editable
1064 #|
1065 (defbinding editable-select-region (editable &optional (start 0) end) nil
1066   (editable editable)
1067   (start int)
1068   ((or end -1) int))
1069
1070 (defbinding editable-insert-text
1071     (editable text &optional (position 0)) nil
1072   (editable editable)
1073   (text string)
1074   ((length text) int)
1075   ((or position -1) int :in-out))
1076
1077 (defun editable-append-text (editable text)
1078   (editable-insert-text editable text nil))
1079
1080 (defun editable-prepend-text (editable text)
1081   (editable-insert-text editable text 0))
1082
1083 (defbinding editable-delete-text (editable &optional (start 0) end) nil
1084   (editable editable)
1085   (start int)
1086   ((or end -1) int))
1087
1088 (defbinding (editable-text "gtk_editable_get_chars")
1089     (editable &optional (start 0) end) string
1090   (editable editable)
1091   (start int)
1092   ((or end -1) int))
1093
1094 (defun (setf editable-text) (text editable)
1095   (if text
1096       (editable-delete-text
1097        editable
1098        (editable-insert-text editable text))
1099     (editable-delete-text editable))
1100   text)
1101
1102 (defbinding editable-cut-clipboard () nil
1103   (editable editable))
1104
1105 (defbinding editable-copy-clipboard () nil
1106   (editable editable))
1107
1108 (defbinding editable-paste-clipboard () nil
1109   (editable editable))
1110
1111 ; (defbinding editable-claim-selection () nil
1112 ;   (editable editable)
1113 ;   (claim boolean)
1114 ;   (time unsigned-int))
1115
1116 (defbinding editable-delete-selection () nil
1117   (editable editable))
1118
1119 ; (defbinding editable-changed () nil
1120 ;   (editable editable))
1121 |#
1122
1123
1124 ;;; Spin button
1125
1126 (defun spin-button-value-as-int (spin-button)
1127   (round (spin-button-value spin-button)))
1128
1129 (defbinding spin-button-spin () nil
1130   (spin-button spin-button)
1131   (direction spin-type)
1132   (increment single-float))
1133
1134 (defbinding spin-button-update () nil
1135   (spin-button spin-button))
1136
1137
1138
1139 ; ;;; Ruler
1140
1141 (defbinding ruler-set-range () nil
1142   (ruler ruler)
1143   (lower single-float)
1144   (upper single-float)
1145   (position single-float)
1146   (max-size single-float))
1147
1148 (defbinding ruler-draw-ticks () nil
1149   (ruler ruler))
1150
1151 (defbinding ruler-draw-pos () nil
1152   (ruler ruler))
1153
1154
1155
1156 ;;; Range
1157 #|
1158 (defbinding range-draw-background () nil
1159   (range range))
1160
1161 (defbinding range-clear-background () nil
1162   (range range))
1163
1164 (defbinding range-draw-trough () nil
1165   (range range))
1166
1167 (defbinding range-draw-slider () nil
1168   (range range))
1169
1170 (defbinding range-draw-step-forw () nil
1171   (range range))
1172
1173 (defbinding range-slider-update () nil
1174   (range range))
1175
1176 (defbinding range-trough-click () int
1177   (range range)
1178   (x int)
1179   (y int)
1180   (jump-perc single-float :out))
1181
1182 (defbinding range-default-hslider-update () nil
1183   (range range))
1184
1185 (defbinding range-default-vslider-update () nil
1186   (range range))
1187
1188 (defbinding range-default-htrough-click () int
1189   (range range)
1190   (x int)
1191   (y int)
1192   (jump-perc single-float :out))
1193
1194 (defbinding range-default-vtrough-click () int
1195   (range range)
1196   (x int)
1197   (y int)
1198   (jump-perc single-float :out))
1199
1200 (defbinding range-default-hmotion () int
1201   (range range)
1202   (x-delta int)
1203   (y-delta int))
1204
1205 (defbinding range-default-vmotion () int
1206   (range range)
1207   (x-delta int)
1208   (y-delta int))
1209 |#
1210
1211
1212 ;;; Scale
1213
1214 ; (defbinding scale-draw-value () nil
1215 ;   (scale scale))
1216
1217
1218
1219 ;;; Progress bar
1220
1221 (defbinding progress-bar-pulse () nil
1222   (progress-bar progress-bar))
1223
1224
1225
1226 ;;; Adjustment
1227
1228 (defbinding adjustment-changed () nil
1229   (adjustment adjustment))
1230
1231 (defbinding adjustment-value-changed () nil
1232   (adjustment adjustment))
1233
1234 (defbinding adjustment-clamp-page () nil
1235   (adjustment adjustment)
1236   (lower single-float)
1237   (upper single-float))
1238
1239
1240
1241 ;;; Tooltips
1242
1243 (defbinding tooltips-enable () nil
1244   (tooltips tooltips))
1245
1246 (defbinding tooltips-disable () nil
1247   (tooltips tooltips))
1248
1249 (defun (setf tooltips-enabled-p) (enable tooltips)
1250   (if enable
1251       (tooltips-enable tooltips)
1252     (tooltips-disable tooltips)))
1253
1254 (defbinding tooltips-set-tip () nil
1255   (tooltips tooltips)
1256   (widget widget)
1257   (tip-text string)
1258   (tip-private string))
1259
1260 (defbinding tooltips-force-window () nil
1261   (tooltips tooltips))
1262
1263
1264
1265 ;;; Rc
1266
1267 (defbinding rc-add-default-file (filename) nil
1268   ((namestring (truename filename)) string))
1269
1270 (defbinding rc-parse (filename) nil
1271   ((namestring (truename filename)) string))
1272
1273 (defbinding rc-parse-string () nil
1274   (rc-string string))
1275
1276 (defbinding rc-reparse-all () nil)
1277
1278 (defbinding rc-get-style () style
1279   (widget widget))
1280
1281
1282
1283 ;;; Accelerator Groups
1284 #|
1285 (defbinding accel-group-get-default () accel-group)
1286
1287 (deftype-method alien-ref accel-group (type-spec)
1288   (declare (ignore type-spec))
1289   '%accel-group-ref)
1290
1291 (deftype-method alien-unref accel-group (type-spec)
1292   (declare (ignore type-spec))
1293   '%accel-group-unref)
1294
1295 (defbinding %accel-group-ref () accel-group
1296   (accel-group (or accel-group pointer)))
1297
1298 (defbinding %accel-group-unref () nil
1299   (accel-group (or accel-group pointer)))
1300
1301 (defbinding accel-group-activate (accel-group key modifiers) boolean
1302   (accel-group accel-group)
1303   ((gdk:keyval-from-name key) unsigned-int)
1304   (modifiers gdk:modifier-type))
1305
1306 (defbinding accel-groups-activate (object key modifiers) boolean
1307   (object object)
1308   ((gdk:keyval-from-name key) unsigned-int)
1309   (modifiers gdk:modifier-type))
1310
1311 (defbinding accel-group-attach () nil
1312   (accel-group accel-group)
1313   (object object))
1314
1315 (defbinding accel-group-detach () nil
1316   (accel-group accel-group)
1317   (object object))
1318
1319 (defbinding accel-group-lock () nil
1320   (accel-group accel-group))
1321
1322 (defbinding accel-group-unlock () nil
1323   (accel-group accel-group))
1324
1325
1326 ;;; Accelerator Groups Entries
1327
1328 (defbinding accel-group-get-entry (accel-group key modifiers) accel-entry
1329   (accel-group accel-group)
1330   ((gdk:keyval-from-name key) unsigned-int)
1331   (modifiers gdk:modifier-type))
1332
1333 (defbinding accel-group-lock-entry (accel-group key modifiers) nil
1334   (accel-group accel-group)
1335   ((gdk:keyval-from-name key) unsigned-int)
1336   (modifiers gdk:modifier-type))
1337
1338 (defbinding accel-group-unlock-entry (accel-group key modifiers) nil
1339   (accel-group accel-group)
1340   ((gdk:keyval-from-name key) unsigned-int)
1341   (modifiers gdk:modifier-type))
1342
1343 (defbinding accel-group-add
1344     (accel-group key modifiers flags object signal) nil
1345   (accel-group accel-group)
1346   ((gdk:keyval-from-name key) unsigned-int)
1347   (modifiers gdk:modifier-type)
1348   (flags accel-flags)
1349   (object object)
1350   ((name-to-string signal) string))
1351
1352 (defbinding accel-group-add (accel-group key modifiers object) nil
1353   (accel-group accel-group)
1354   ((gdk:keyval-from-name key) unsigned-int)
1355   (modifiers gdk:modifier-type)
1356   (object object))
1357
1358
1359 ;;; Accelerator Signals
1360
1361 (defbinding accel-group-handle-add
1362     (object signal-id accel-group key modifiers flags) nil
1363   (object object)
1364   (signal-id unsigned-int)
1365   (accel-group accel-group)
1366   ((gdk:keyval-from-name key) unsigned-int)
1367   (modifiers gdk:modifier-type)
1368   (flags accel-flags))
1369
1370 (defbinding accel-group-handle-remove
1371     (object accel-group key modifiers) nil
1372   (object object)
1373   (accel-group accel-group)
1374   ((gdk:keyval-from-name key) unsigned-int)
1375   (modifiers gdk:modifier-type))
1376 |#