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

   1 ;; Common Lisp bindings for GTK+ v2.x
   2 ;; Copyright 2000-2006 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: gdk.lisp,v 1.30 2006-06-07 13:17:24 espen Exp $
  24
  25
  26 (in-package "GDK")
  27
  28 ;;; Initialization
  29
  30 (defbinding (gdk-init "gdk_parse_args") () nil
  31   "Initializes the library without opening the display."
  32   (nil null)
  33   (nil null))
  34
  35
  36
  37 ;;; Display
  38
  39 (defbinding %display-open () display
  40   (display-name (or null string)))
  41
  42 (defun display-open (&optional display-name)
  43   (let ((display (%display-open display-name)))
  44     (unless (display-get-default)
  45       (display-set-default display))
  46     display))
  47
  48 (defbinding %display-get-n-screens () int
  49   (display display))
  50
  51 (defbinding %display-get-screen () screen
  52   (display display)
  53   (screen-num int))
  54
  55 (defun display-screens (&optional (display (display-get-default)))
  56   (loop
  57    for i from 0 below (%display-get-n-screens display)
  58    collect (%display-get-screen display i)))
  59
  60 (defbinding display-get-default-screen
  61     (&optional (display (display-get-default))) screen
  62   (display display))
  63
  64 (defbinding display-beep (&optional (display (display-get-default))) nil
  65   (display display))
  66
  67 (defbinding display-sync (&optional (display (display-get-default))) nil
  68   (display display))
  69
  70 (defbinding display-flush (&optional (display (display-get-default))) nil
  71   (display display))
  72
  73 (defbinding display-close (&optional (display (display-get-default))) nil
  74   (display display))
  75
  76 (defbinding display-get-event
  77     (&optional (display (display-get-default))) event
  78   (display display))
  79
  80 (defbinding display-peek-event
  81     (&optional (display (display-get-default))) event
  82   (display display))
  83
  84 (defbinding display-put-event
  85     (event &optional (display (display-get-default))) event
  86   (display display)
  87   (event event))
  88
  89 (defbinding (display-connection-number "clg_gdk_connection_number")
  90     (&optional (display (display-get-default))) int
  91   (display display))
  92
  93
  94
  95 ;;; Display manager
  96
  97 (defbinding display-get-default () display)
  98
  99 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
 100
 101 (defbinding (display-set-default "gdk_display_manager_set_default_display")
 102     (display) nil
 103   ((display-manager) display-manager)
 104   (display display))
 105
 106
 107
 108 ;;; Events
 109
 110 (defbinding (events-pending-p "gdk_events_pending") () boolean)
 111
 112 (defbinding event-get () event)
 113
 114 (defbinding event-peek () event)
 115
 116 (defbinding event-get-graphics-expose () event
 117   (window window))
 118
 119 (defbinding event-put () event
 120   (event event))
 121
 122 ;(defbinding event-handler-set () ...)
 123
 124 (defbinding set-show-events () nil
 125   (show-events boolean))
 126
 127 (defbinding get-show-events () boolean)
 128
 129
 130 ;;; Miscellaneous functions
 131
 132 (defbinding screen-width () int)
 133 (defbinding screen-height () int)
 134
 135 (defbinding screen-width-mm () int)
 136 (defbinding screen-height-mm () int)
 137
 138 (defbinding pointer-grab
 139     (window &key owner-events events confine-to cursor time) grab-status
 140   (window window)
 141   (owner-events boolean)
 142   (events event-mask)
 143   (confine-to (or null window))
 144   (cursor (or null cursor))
 145   ((or time 0) (unsigned 32)))
 146
 147 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
 148     (&optional time (display (display-get-default))) nil
 149   (display display)
 150   ((or time 0) (unsigned 32)))
 151
 152 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
 153     (&optional (display (display-get-default))) boolean
 154   (display display))
 155
 156 (defbinding keyboard-grab (window &key owner-events time) grab-status
 157   (window window)
 158   (owner-events boolean)
 159   ((or time 0) (unsigned 32)))
 160
 161 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
 162     (&optional time (display (display-get-default))) nil
 163   (display display)
 164   ((or time 0) (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 ;;
 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 allocate-foreign ((cursor cursor) &key source mask fg bg
 427                              (x 0) (y 0) (display (display-get-default)))
 428   (etypecase source
 429     (keyword (%cursor-new-for-display display source))
 430     (pixbuf (%cursor-new-from-pixbuf display source x y))
 431     (pixmap (%cursor-new-from-pixmap source mask
 432              (or fg (ensure-color #(0.0 0.0 0.0)))
 433              (or bg (ensure-color #(1.0 1.0 1.0))) x y))
 434     (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
 435
 436 (defun ensure-cursor (cursor &rest args)
 437   (if (typep cursor 'cursor)
 438       cursor
 439     (apply #'make-instance 'cursor :source cursor args)))
 440
 441 (defbinding %cursor-new-for-display () pointer
 442   (display display)
 443   (cursor-type cursor-type))
 444
 445 (defbinding %cursor-new-from-pixmap () pointer
 446   (source pixmap)
 447   (mask bitmap)
 448   (foreground color)
 449   (background color)
 450   (x int) (y int))
 451
 452 (defbinding %cursor-new-from-pixbuf () pointer
 453   (display display)
 454   (pixbuf pixbuf)
 455   (x int) (y int))
 456
 457 (defbinding %cursor-ref () pointer
 458   (location pointer))
 459
 460 (defbinding %cursor-unref () nil
 461   (location pointer))
 462
 463
 464 ;;; Pixmaps
 465
 466 (defbinding %pixmap-new () pointer
 467   (window (or null window))
 468   (width int)
 469   (height int)
 470   (depth int))
 471
 472 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
 473   (%pixmap-new window width height depth))
 474
 475 (defun pixmap-new (width height depth &key window)
 476   (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
 477   (make-instance 'pixmap :width width :height height :depth depth :window window))
 478
 479 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 480   (window (or null window))
 481   (colormap (or null colormap))
 482   (mask bitmap :out)
 483   (color (or null color))
 484   (filename pathname))
 485
 486 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 487   (window (or null window))
 488   (colormap (or null colormap))
 489   (mask bitmap :out)
 490   (color (or null color))
 491   (data (vector string)))
 492
 493 ;; Deprecated, use pixbufs instead
 494 (defun pixmap-create (source &key color window colormap)
 495   (let ((window
 496          (if (not (or window colormap))
 497              (get-root-window)
 498            window)))
 499     (multiple-value-bind (pixmap mask)
 500         (etypecase source
 501           ((or string pathname)
 502            (%pixmap-colormap-create-from-xpm window colormap color  source))
 503           ((vector string)
 504            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 505       (values pixmap mask))))
 506
 507
 508 ;;; Color
 509
 510 (defbinding colormap-get-system () colormap)
 511
 512 (defbinding %color-copy () pointer
 513   (location pointer))
 514
 515 (defmethod allocate-foreign ((color color)  &rest initargs)
 516   (declare (ignore color initargs))
 517   ;; Color structs are allocated as memory chunks by gdk, and since
 518   ;; there is no gdk_color_new we have to use this hack to get a new
 519   ;; color chunk
 520   (with-memory (location #.(foreign-size (find-class 'color)))
 521     (%color-copy location)))
 522
 523 (defun %scale-value (value)
 524   (etypecase value
 525     (integer value)
 526     (float (truncate (* value 65535)))))
 527
 528 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
 529   (call-next-method)
 530   (with-slots ((%red red) (%green green) (%blue blue)) color
 531     (setf
 532      %red (%scale-value red)
 533      %green (%scale-value green)
 534      %blue (%scale-value blue))))
 535
 536 (defbinding %color-parse () boolean
 537   (spec string)
 538   (color color :in/return))
 539
 540 (defun color-parse (spec &optional (color (make-instance 'color)))
 541   (multiple-value-bind (succeeded-p color) (%color-parse spec color)
 542     (if succeeded-p
 543         color
 544       (error "Parsing color specification ~S failed." spec))))
 545
 546 (defun ensure-color (color)
 547   (etypecase color
 548     (null nil)
 549     (color color)
 550     (string (color-parse color))
 551     (vector
 552      (make-instance 'color
 553       :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
 554
 555
 556
 557 ;;; Drawable -- all the draw- functions are deprecated and will be
 558 ;;; removed, use cairo for drawing instead.
 559
 560 (defbinding drawable-get-size () nil
 561   (drawable drawable)
 562   (width int :out)
 563   (height int :out))
 564
 565 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 566   (drawable drawable)
 567   (width int :out)
 568   (nil null))
 569
 570 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 571   (drawable drawable)
 572   (nil null)
 573   (height int :out))
 574
 575 ;; (defbinding drawable-get-clip-region () region
 576 ;;   (drawable drawable))
 577
 578 ;; (defbinding drawable-get-visible-region () region
 579 ;;   (drawable drawable))
 580
 581 (defbinding draw-point () nil
 582   (drawable drawable) (gc gc)
 583   (x int) (y int))
 584
 585 (defbinding %draw-points () nil
 586   (drawable drawable) (gc gc)
 587   (points pointer)
 588   (n-points int))
 589
 590 (defbinding draw-line () nil
 591   (drawable drawable) (gc gc)
 592   (x1 int) (y1 int)
 593   (x2 int) (y2 int))
 594
 595 (defbinding draw-pixbuf
 596     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 597      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 598   (drawable drawable) (gc (or null gc))
 599   (pixbuf pixbuf)
 600   (src-x int) (src-y int)
 601   (dest-x int) (dest-y int)
 602   ((or width -1) int) ((or height -1) int)
 603   (dither rgb-dither)
 604   (x-dither int) (y-dither int))
 605
 606 (defbinding draw-rectangle () nil
 607   (drawable drawable) (gc gc)
 608   (filled boolean)
 609   (x int) (y int)
 610   (width int) (height int))
 611
 612 (defbinding draw-arc () nil
 613   (drawable drawable) (gc gc)
 614   (filled boolean)
 615   (x int) (y int)
 616   (width int) (height int)
 617   (angle1 int) (angle2 int))
 618
 619 (defbinding %draw-layout () nil
 620   (drawable drawable) (gc gc)
 621   (font pango:font)
 622   (x int) (y int)
 623   (layout pango:layout))
 624
 625 (defbinding %draw-layout-with-colors () nil
 626   (drawable drawable) (gc gc)
 627   (font pango:font)
 628   (x int) (y int)
 629   (layout pango:layout)
 630   (foreground (or null color))
 631   (background (or null color)))
 632
 633 (defun draw-layout (drawable gc font x y layout &optional foreground background)
 634   (if (or foreground background)
 635       (%draw-layout-with-colors drawable gc font x y layout foreground background)
 636     (%draw-layout drawable gc font x y layout)))
 637
 638 (defbinding draw-drawable
 639     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
 640   (drawable drawable) (gc gc)
 641   (src drawable)
 642   (src-x int) (src-y int)
 643   (dest-x int) (dest-y int)
 644   ((or width -1) int) ((or height -1) int))
 645
 646 (defbinding draw-image
 647     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
 648   (drawable drawable) (gc gc)
 649   (image image)
 650   (src-x int) (src-y int)
 651   (dest-x int) (dest-y int)
 652   ((or width -1) int) ((or height -1) int))
 653
 654 (defbinding drawable-get-image () image
 655   (drawable drawable)
 656   (x int) (y int)
 657   (width int) (height int))
 658
 659 (defbinding drawable-copy-to-image
 660     (drawable src-x src-y width height &optional image dest-x dest-y) image
 661   (drawable drawable)
 662   (image (or null image))
 663   (src-x int) (src-y int)
 664   ((if image dest-x 0) int)
 665   ((if image dest-y 0) int)
 666   (width int) (height int))
 667
 668
 669 ;;; Key values
 670
 671 (defbinding keyval-name () string
 672   (keyval unsigned-int))
 673
 674 (defbinding %keyval-from-name () unsigned-int
 675   (name string))
 676
 677 (defun keyval-from-name (name)
 678   "Returns the keysym value for the given key name or NIL if it is not a valid name."
 679   (let ((keyval (%keyval-from-name name)))
 680     (unless (zerop keyval)
 681       keyval)))
 682
 683 (defbinding keyval-to-upper () unsigned-int
 684   (keyval unsigned-int))
 685
 686 (defbinding keyval-to-lower () unsigned-int
 687   (keyval unsigned-int))
 688
 689 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 690   (keyval unsigned-int))
 691
 692 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 693   (keyval unsigned-int))
 694
 695 ;;; Cairo interaction
 696
 697 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 698 (progn
 699   (defbinding cairo-create () cairo:context
 700     (drawable drawable))
 701
 702   (defmacro with-cairo-context ((cr drawable) &body body)
 703     `(let ((,cr (cairo-create ,drawable)))
 704        (unwind-protect
 705            (progn ,@body)
 706          (invalidate-instance ,cr t))))
 707
 708   (defbinding cairo-set-source-color () nil
 709     (cr cairo:context)
 710     (color color))
 711
 712   (defbinding cairo-set-source-pixbuf () nil
 713     (cr cairo:context)
 714     (pixbuf pixbuf)
 715     (x double-float)
 716     (y double-float))
 717
 718   (defbinding cairo-rectangle () nil
 719     (cr cairo:context)
 720     (rectangle rectangle))
 721
 722 ;;   (defbinding cairo-region () nil
 723 ;;     (cr cairo:context)
 724 ;;     (region region))
 725 )
 726
 727
 728
 729 ;;; Multi-threading support
 730
 731 #+sbcl
 732 (progn
 733   (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
 734   (let ((recursive-level 0))
 735     (defun threads-enter ()
 736       (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
 737           (incf recursive-level)
 738         (sb-thread:get-mutex *global-lock*)))
 739
 740     (defun threads-leave (&optional flush-p)
 741       (cond
 742        ((zerop recursive-level)
 743         (when flush-p
 744           (display-flush))
 745         (sb-thread:release-mutex *global-lock*))
 746        (t (decf recursive-level)))))
 747
 748   (define-callback %enter-fn nil ()
 749     (threads-enter))
 750
 751   (define-callback %leave-fn nil ()
 752     (threads-leave))
 753
 754   (defbinding threads-set-lock-functions (&optional) nil
 755     (%enter-fn callback)
 756     (%leave-fn callback))
 757
 758   (defmacro with-global-lock (&body body)
 759     `(progn
 760        (threads-enter)
 761        (unwind-protect
 762            ,@body
 763          (threads-leave t)))))