chiark - git - mdw - clg/blob - gdk/gdk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2005 Espen S. Johnsen <espen@users@sf.net>
   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: gdk.lisp,v 1.14 2005-02-26 18:53:09 espen Exp $
  19
  20
  21 (in-package "GDK")
  22
  23 ;;; Initialization
  24
  25 (defbinding (gdk-init "gdk_parse_args") () nil
  26   "Initializes the library without opening the display."
  27   (nil null)
  28   (nil null))
  29
  30
  31
  32 ;;; Display
  33
  34 (defbinding %display-open () display
  35   (display-name (or null string)))
  36
  37 (defun display-open (&optional display-name)
  38   (let ((display (%display-open display-name)))
  39     (unless (display-get-default)
  40       (display-set-default display))
  41     display))
  42
  43 (defbinding %display-get-n-screens () int
  44   (display display))
  45
  46 (defbinding %display-get-screen () screen
  47   (display display)
  48   (screen-num int))
  49
  50 (defun display-screens (&optional (display (display-get-default)))
  51   (loop
  52    for i from 0 below (%display-get-n-screens display)
  53    collect (%display-get-screen display i)))
  54
  55 (defbinding display-get-default-screen
  56     (&optional (display (display-get-default))) screen
  57   (display display))
  58
  59 (defbinding display-beep (&optional (display (display-get-default))) nil
  60   (display display))
  61
  62 (defbinding display-sync (&optional (display (display-get-default))) nil
  63   (display display))
  64
  65 (defbinding display-flush (&optional (display (display-get-default))) nil
  66   (display display))
  67
  68 (defbinding display-close (&optional (display (display-get-default))) nil
  69   (display display))
  70
  71 (defbinding display-get-event
  72     (&optional (display (display-get-default))) event
  73   (display display))
  74
  75 (defbinding display-peek-event
  76     (&optional (display (display-get-default))) event
  77   (display display))
  78
  79 (defbinding display-put-event
  80     (event &optional (display (display-get-default))) event
  81   (display display)
  82   (event event))
  83
  84 (defbinding (display-connection-number "clg_gdk_connection_number")
  85     (&optional (display (display-get-default))) int
  86   (display display))
  87
  88
  89
  90 ;;; Display manager
  91
  92 (defbinding display-get-default () display)
  93
  94 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
  95
  96 (defbinding (display-set-default "gdk_display_manager_set_default_display")
  97     (display) nil
  98   ((display-manager) display-manager)
  99   (display display))
 100
 101
 102
 103 ;;; Events
 104
 105 (defbinding (events-pending-p "gdk_events_pending") () boolean)
 106
 107 (defbinding event-get () event)
 108
 109 (defbinding event-peek () event)
 110
 111 (defbinding event-get-graphics-expose () event
 112   (window window))
 113
 114 (defbinding event-put () event
 115   (event event))
 116
 117 ;(defbinding event-handler-set () ...)
 118
 119 (defbinding set-show-events () nil
 120   (show-events boolean))
 121
 122 (defbinding get-show-events () boolean)
 123
 124
 125 ;;; Miscellaneous functions
 126
 127 (defbinding screen-width () int)
 128 (defbinding screen-height () int)
 129
 130 (defbinding screen-width-mm () int)
 131 (defbinding screen-height-mm () int)
 132
 133 (defun %grab-time (time-or-event)
 134   (etypecase time-or-event
 135     (null 0)
 136     (timed-event (event-time time-or-event))
 137     (integer time-or-event)))
 138
 139 (defbinding pointer-grab
 140     (window &key owner-events events confine-to cursor time) grab-status
 141   (window window)
 142   (owner-events boolean)
 143   (events event-mask)
 144   (confine-to (or null window))
 145   (cursor (or null cursor))
 146   ((%grab-time time) (unsigned 32)))
 147
 148 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
 149     (&optional (display (display-get-default) time)) nil
 150   (display display)
 151   ((%grab-time time) (unsigned 32)))
 152
 153 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
 154     (&optional (display (display-get-default))) boolean)
 155
 156 (defbinding keyboard-grab (window &key owner-events time) grab-status
 157   (window window)
 158   (owner-events boolean)
 159   ((%grab-time time) (unsigned 32)))
 160
 161 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
 162     (&optional (display (display-get-default) time)) nil
 163   (display display)
 164   ((%grab-time time) (unsigned 32)))
 165
 166
 167
 168 (defbinding atom-intern (atom-name &optional only-if-exists) atom
 169   ((string atom-name) string)
 170   (only-if-exists boolean))
 171
 172 (defbinding atom-name () string
 173   (atom atom))
 174
 175
 176
 177 ;;; Visuals
 178
 179 (defbinding visual-get-best-depth () int)
 180
 181 (defbinding visual-get-best-type () visual-type)
 182
 183 (defbinding visual-get-system () visual)
 184
 185
 186 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 187
 188 (defbinding %visual-get-best-with-depth () visual
 189   (depth int))
 190
 191 (defbinding %visual-get-best-with-type () visual
 192   (type visual-type))
 193
 194 (defbinding %visual-get-best-with-both () visual
 195   (depth int)
 196   (type visual-type))
 197
 198 (defun visual-get-best (&key depth type)
 199   (cond
 200    ((and depth type) (%visual-get-best-with-both depth type))
 201    (depth (%visual-get-best-with-depth depth))
 202    (type (%visual-get-best-with-type type))
 203    (t (%visual-get-best-with-nothing))))
 204
 205 ;(defbinding query-depths ..)
 206
 207 ;(defbinding query-visual-types ..)
 208
 209 (defbinding list-visuals () (glist visual))
 210
 211
 212 ;;; Windows
 213
 214 (defbinding window-destroy () nil
 215   (window window))
 216
 217
 218 (defbinding window-at-pointer () window
 219   (x int :out)
 220   (y int :out))
 221
 222 (defbinding window-show () nil
 223   (window window))
 224
 225 (defbinding window-show-unraised () nil
 226   (window window))
 227
 228 (defbinding window-hide () nil
 229   (window window))
 230
 231 (defbinding window-is-visible-p () boolean
 232   (window window))
 233
 234 (defbinding window-is-viewable-p () boolean
 235   (window window))
 236
 237 (defbinding window-withdraw () nil
 238   (window window))
 239
 240 (defbinding window-iconify () nil
 241   (window window))
 242
 243 (defbinding window-deiconify () nil
 244   (window window))
 245
 246 (defbinding window-stick () nil
 247   (window window))
 248
 249 (defbinding window-unstick () nil
 250   (window window))
 251
 252 (defbinding window-maximize () nil
 253   (window window))
 254
 255 (defbinding window-unmaximize () nil
 256   (window window))
 257
 258 (defbinding window-fullscreen () nil
 259   (window window))
 260
 261 (defbinding window-unfullscreen () nil
 262   (window window))
 263
 264 (defbinding window-set-keep-above () nil
 265   (window window)
 266   (setting boolean))
 267
 268 (defbinding window-set-keep-below () nil
 269   (window window)
 270   (setting boolean))
 271
 272 (defbinding window-move () nil
 273   (window window)
 274   (x int)
 275   (y int))
 276
 277 (defbinding window-resize () nil
 278   (window window)
 279   (width int)
 280   (height int))
 281
 282 (defbinding window-move-resize () nil
 283   (window window)
 284   (x int)
 285   (y int)
 286   (width int)
 287   (height int))
 288
 289 (defbinding window-scroll () nil
 290   (window window)
 291   (dx int)
 292   (dy int))
 293
 294 (defbinding window-reparent () nil
 295   (window window)
 296   (new-parent window)
 297   (x int)
 298   (y int))
 299
 300 (defbinding window-clear () nil
 301   (window window))
 302
 303 (defbinding %window-clear-area () nil
 304   (window window)
 305   (x int) (y int) (width int) (height int))
 306
 307 (defbinding %window-clear-area-e () nil
 308   (window window)
 309   (x int) (y int) (width int) (height int))
 310
 311 (defun window-clear-area (window x y width height &optional expose)
 312   (if expose
 313       (%window-clear-area-e window x y width height)
 314     (%window-clear-area window x y width height)))
 315
 316 (defbinding window-raise () nil
 317   (window window))
 318
 319 (defbinding window-lower () nil
 320   (window window))
 321
 322 (defbinding window-focus () nil
 323   (window window)
 324   (timestamp unsigned-int))
 325
 326 (defbinding window-register-dnd () nil
 327   (window window))
 328
 329 (defbinding window-begin-resize-drag () nil
 330   (window window)
 331   (edge window-edge)
 332   (button int)
 333   (root-x int)
 334   (root-y int)
 335   (timestamp unsigned-int))
 336
 337 (defbinding window-begin-move-drag () nil
 338   (window window)
 339   (button int)
 340   (root-x int)
 341   (root-y int)
 342   (timestamp unsigned-int))
 343
 344 ;; komplett så langt
 345
 346 (defbinding window-set-user-data () nil
 347   (window window)
 348   (user-data pointer))
 349
 350 (defbinding window-set-override-redirect () nil
 351   (window window)
 352   (override-redirect boolean))
 353
 354 ; (defbinding window-add-filter () nil
 355
 356 ; (defbinding window-remove-filter () nil
 357
 358 (defbinding window-shape-combine-mask () nil
 359   (window window)
 360   (shape-mask bitmap)
 361   (offset-x int)
 362   (offset-y int))
 363
 364 (defbinding window-set-child-shapes () nil
 365   (window window))
 366
 367 (defbinding window-merge-child-shapes () nil
 368   (window window))
 369
 370
 371 (defbinding window-set-static-gravities () boolean
 372   (window window)
 373   (use-static boolean))
 374
 375 ; (defbinding add-client-message-filter ...
 376
 377 (defbinding window-set-cursor () nil
 378   (window window)
 379   (cursor (or null cursor)))
 380
 381 (defbinding window-get-pointer () window
 382   (window window)
 383   (x int :out)
 384   (y int :out)
 385   (mask modifier-type :out))
 386
 387 (defbinding %window-get-toplevels () (glist window))
 388
 389 (defun window-get-toplevels (&optional screen)
 390   (if screen
 391       (error "Not implemented")
 392     (%window-get-toplevels)))
 393
 394 (defbinding %get-default-root-window () window)
 395
 396 (defun get-root-window (&optional display)
 397   (if display
 398       (error "Not implemented")
 399     (%get-default-root-window)))
 400
 401
 402
 403 ;;; Drag and Drop
 404
 405 ;; Destination side
 406
 407 (defbinding drag-status () nil
 408   (context drag-context)
 409   (action drag-action)
 410   (time (unsigned 32)))
 411
 412
 413
 414
 415
 416
 417 ;;
 418
 419 (defbinding rgb-init () nil)
 420
 421
 422
 423
 424 ;;; Cursor
 425
 426 (defmethod initialize-instance ((cursor cursor) &key type mask fg bg
 427                                 (x 0) (y 0) (display (display-get-default)))
 428   (setf
 429    (slot-value cursor 'location)
 430    (etypecase type
 431      (keyword (%cursor-new-for-display display type))
 432      (pixbuf (%cursor-new-from-pixbuf display type x y))
 433      (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))))
 434
 435
 436 (defbinding %cursor-new-for-display () pointer
 437   (display display)
 438   (cursor-type cursor-type))
 439
 440 (defbinding %cursor-new-from-pixmap () pointer
 441   (source pixmap)
 442   (mask bitmap)
 443   (foreground color)
 444   (background color)
 445   (x int) (y int))
 446
 447 (defbinding %cursor-new-from-pixbuf () pointer
 448   (display display)
 449   (pixbuf pixbuf)
 450   (x int) (y int))
 451
 452 (defbinding %cursor-ref () pointer
 453   (location pointer))
 454
 455 (defbinding %cursor-unref () nil
 456   (location pointer))
 457
 458 (defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
 459   (declare (ignore class))
 460   (%cursor-ref location))
 461
 462 (defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
 463   (declare (ignore class))
 464   (%cursor-unref location))
 465
 466
 467 ;;; Pixmaps
 468
 469 (defbinding pixmap-new (width height depth &key window) pixmap
 470   (width int)
 471   (height int)
 472   (depth int)
 473   (window (or null window)))
 474
 475 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 476   (window (or null window))
 477   (colormap (or null colormap))
 478   (mask bitmap :out)
 479   (color (or null color))
 480   (filename string))
 481
 482 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 483   (window (or null window))
 484   (colormap (or null colormap))
 485   (mask bitmap :out)
 486   (color (or null color))
 487   (data (vector string)))
 488
 489 (defun pixmap-create (source &key color window colormap)
 490   (let ((window
 491          (if (not (or window colormap))
 492              (get-root-window)
 493            window)))
 494     (multiple-value-bind (pixmap mask)
 495         (etypecase source
 496           ((or string pathname)
 497            (%pixmap-colormap-create-from-xpm
 498             window colormap color (namestring (truename source))))
 499           ((vector string)
 500            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 501 ;;       (unreference-instance pixmap)
 502 ;;       (unreference-instance mask)
 503       (values pixmap mask))))
 504
 505
 506
 507 ;;; Color
 508
 509 (defun %scale-value (value)
 510   (etypecase value
 511     (integer value)
 512     (float (truncate (* value 65535)))))
 513
 514 (defmethod initialize-instance ((color color) &rest initargs
 515                                 &key red green blue)
 516   (declare (ignore initargs))
 517   (call-next-method)
 518   (with-slots ((%red red) (%green green) (%blue blue)) color
 519     (setf
 520      %red (%scale-value red)
 521      %green (%scale-value green)
 522      %blue (%scale-value blue))))
 523
 524 (defun ensure-color (color)
 525   (etypecase color
 526     (null nil)
 527     (color color)
 528     (vector
 529      (make-instance
 530       'color :red (svref color 0) :green (svref color 1)
 531       :blue (svref color 2)))))
 532
 533
 534
 535 ;;; Drawable
 536
 537 (defbinding drawable-get-size () nil
 538   (drawable drawable)
 539   (width int :out)
 540   (height int :out))
 541
 542 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 543   (drawable drawable)
 544   (width int :out)
 545   (nil null))
 546
 547 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 548   (drawable drawable)
 549   (nil null)
 550   (height int :out))
 551
 552 ;; (defbinding drawable-get-clip-region () region
 553 ;;   (drawable drawable))
 554
 555 ;; (defbinding drawable-get-visible-region () region
 556 ;;   (drawable drawable))
 557
 558 (defbinding draw-point () nil
 559   (drawable drawable) (gc gc)
 560   (x int) (y int))
 561
 562 (defbinding %draw-points () nil
 563   (drawable drawable) (gc gc)
 564   (points pointer)
 565   (n-points int))
 566
 567 ;; (defun draw-points (drawable gc &rest points)
 568
 569 ;;   )
 570
 571 (defbinding draw-line () nil
 572   (drawable drawable) (gc gc)
 573   (x1 int) (y1 int)
 574   (x2 int) (y2 int))
 575
 576 ;; (defbinding draw-lines (drawable gc &rest points) nil
 577 ;;   (drawable drawable) (gc gc)
 578 ;;   (points (vector point))
 579 ;;   ((length points) int))
 580
 581 (defbinding draw-pixbuf
 582     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 583      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 584   (drawable drawable) (gc (or null gc))
 585   (pixbuf pixbuf)
 586   (src-x int) (src-y int)
 587   (dest-x int) (dest-y int)
 588   ((or width -1) int) ((or height -1) int)
 589   (dither rgb-dither)
 590   (x-dither int) (y-dither int))
 591
 592 ;; (defbinding draw-segments (drawable gc &rest points) nil
 593 ;;   (drawable drawable) (gc gc)
 594 ;;   (segments (vector segments))
 595 ;;   ((length segments) int))
 596
 597 (defbinding draw-rectangle () nil
 598   (drawable drawable) (gc gc)
 599   (filled boolean)
 600   (x int) (y int)
 601   (width int) (height int))
 602
 603 (defbinding draw-arc () nil
 604   (drawable drawable) (gc gc)
 605   (filled boolean)
 606   (x int) (y int)
 607   (width int) (height int)
 608   (angle1 int) (angle2 int))
 609
 610 ;; (defbinding draw-polygon (drawable gc &rest points) nil
 611 ;;   (drawable drawable) (gc gc)
 612 ;;   (points (vector point))
 613 ;;   ((length points) int))
 614
 615 ;; (defbinding draw-trapezoid (drawable gc &rest points) nil
 616 ;;   (drawable drawable) (gc gc)
 617 ;;   (points (vector point))
 618 ;;   ((length points) int))
 619
 620 ;; (defbinding %draw-layout-line () nil
 621 ;;   (drawable drawable) (gc gc)
 622 ;;   (font pango:font)
 623 ;;   (x int) (y int)
 624 ;;   (line pango:layout-line))
 625
 626 ;; (defbinding %draw-layout-line-with-colors () nil
 627 ;;   (drawable drawable) (gc gc)
 628 ;;   (font pango:font)
 629 ;;   (x int) (y int)
 630 ;;   (line pango:layout-line)
 631 ;;   (foreground (or null color))
 632 ;;   (background (or null color)))
 633
 634 ;; (defun draw-layout-line (drawable gc font x y line &optional foreground background)
 635 ;;   (if (or foreground background)
 636 ;;       (%draw-layout-line-with-colors drawable gc font x y line foreground background)
 637 ;;     (%draw-layout-line drawable gc font x y line)))
 638
 639 (defbinding %draw-layout () nil
 640   (drawable drawable) (gc gc)
 641   (font pango:font)
 642   (x int) (y int)
 643   (layout pango:layout))
 644
 645 (defbinding %draw-layout-with-colors () nil
 646   (drawable drawable) (gc gc)
 647   (font pango:font)
 648   (x int) (y int)
 649   (layout pango:layout)
 650   (foreground (or null color))
 651   (background (or null color)))
 652
 653 (defun draw-layout (drawable gc font x y layout &optional foreground background)
 654   (if (or foreground background)
 655       (%draw-layout-with-colors drawable gc font x y layout foreground background)
 656     (%draw-layout drawable gc font x y layout)))
 657
 658 (defbinding draw-drawable
 659     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
 660   (drawable drawable) (gc gc)
 661   (src drawable)
 662   (src-x int) (src-y int)
 663   (dest-x int) (dest-y int)
 664   ((or width -1) int) ((or height -1) int))
 665
 666 (defbinding draw-image
 667     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
 668   (drawable drawable) (gc gc)
 669   (image image)
 670   (src-x int) (src-y int)
 671   (dest-x int) (dest-y int)
 672   ((or width -1) int) ((or height -1) int))
 673
 674 (defbinding drawable-get-image () image
 675   (drawable drawable)
 676   (x int) (y int)
 677   (width int) (height int))
 678
 679 (defbinding drawable-copy-to-image
 680     (drawable src-x src-y width height &optional image dest-x dest-y) image
 681   (drawable drawable)
 682   (image (or null image))
 683   (src-x int) (src-y int)
 684   ((if image dest-x 0) int)
 685   ((if image dest-y 0) int)
 686   (width int) (height int))
 687
 688
 689 ;;; Key values
 690
 691 (defbinding keyval-name () string
 692   (keyval unsigned-int))
 693
 694 (defbinding keyval-from-name () unsigned-int
 695   (name string))
 696
 697 (defbinding keyval-to-upper () unsigned-int
 698   (keyval unsigned-int))
 699
 700 (defbinding keyval-to-lower () unsigned-int
 701   (keyval unsigned-int))
 702
 703 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 704   (keyval unsigned-int))
 705
 706 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 707   (keyval unsigned-int))
 708