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.33 2007-01-14 23:24:11 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 ;;; Primitive graphics structures (points, rectangles and regions)
 108
 109 (defbinding %rectangle-intersect () boolean
 110   (src1 rectangle)
 111   (src2 rectangle)
 112   (dest rectangle))
 113
 114 (defun rectangle-intersect (src1 src2 &optional (dest (make-instance 'rectangle)))
 115   "Calculates the intersection of two rectangles. It is allowed for DEST to be the same as either SRC1 or SRC2. DEST is returned if the to rectangles intersect, otherwise NIL"
 116   (when (%rectangle-intersect src1 src2 dest)
 117     dest))
 118
 119 (defbinding rectangle-union (src1 src2 &optional (dest (make-instance 'rectangle))) nil
 120   "Calculates the union of two rectangles. The union of rectangles SRC1 and SRC2 is the smallest rectangle which includes both SRC1 and SRC2 within it. It is allowed for DEST to be the same as either SRC1 or SRC2."
 121   (src1 rectangle)
 122   (src2 rectangle)
 123   (dest rectangle :in/return))
 124
 125 (defun ensure-rectangle (rectangle)
 126   (etypecase rectangle
 127     (rectangle rectangle)
 128     (vector (make-instance 'rectangle
 129              :x (aref rectangle 0) :y (aref rectangle 1)
 130              :width (aref rectangle 2) :height (aref rectangle 3)))))
 131
 132
 133 (defbinding %region-new () pointer)
 134
 135 (defbinding %region-polygon () pointer
 136   (points (vector (inlined point)))
 137   (n-points int)
 138   (fill-rule fill-rule))
 139
 140 (defbinding %region-rectangle () pointer
 141   (rectangle rectangle))
 142
 143 (defbinding %region-copy () pointer
 144   (location pointer))
 145
 146 (defbinding %region-destroy () nil
 147   (location pointer))
 148
 149 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
 150   (declare (ignore initargs))
 151   (cond
 152    ((and rectangle polygon)
 153     (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
 154    (rectangle (%region-rectangle (ensure-rectangle rectangle)))
 155    (polygon (%region-polygon polygon (length polygon) fill-rule))
 156    ((%region-new))))
 157
 158 (defun ensure-region (region)
 159   (etypecase region
 160     (region region)
 161     ((or rectangle vector)
 162      (make-instance 'region :rectangle (ensure-rectangle region)))))
 163
 164 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
 165   (region region)
 166   (rectangle rectangle :in/return))
 167
 168 (defbinding %region-get-rectangles () nil
 169   (region region)
 170   (rectangles pointer :out)
 171   (n-rectangles int :out))
 172
 173 (defun region-get-rectangles (region)
 174   "Obtains the area covered by the region as a list of rectangles."
 175   (multiple-value-bind (location length) (%region-get-rectangles region)
 176     (prog1
 177         (map-c-vector 'list #'identity location 'point length :get)
 178       (deallocate-memory location))))
 179
 180 (defbinding region-empty-p () boolean
 181   (region region))
 182
 183 (defbinding region-equal-p () boolean
 184   (region1 region)
 185   (region2 region))
 186
 187 (defbinding region-point-in-p () boolean
 188   (region region)
 189   (x int)
 190   (y int))
 191
 192 (defbinding region-rect-in (region rectangle) overlap-type
 193   (region region)
 194   ((ensure-rectangle rectangle) rectangle))
 195
 196 (defbinding region-offset () nil
 197   (region region)
 198   (dx int)
 199   (dy int))
 200
 201 (defbinding region-shrink () nil
 202   (region region)
 203   (dx int)
 204   (dy int))
 205
 206 (defbinding region-intersect (source1 source2) nil
 207   (source1 region)
 208   ((ensure-region source2) region))
 209
 210 (defbinding region-union (source1 source2) nil
 211   (source1 region)
 212   ((ensure-region source2) region))
 213
 214 (defbinding region-subtract (source1 source2) nil
 215   (source1 region)
 216   ((ensure-region source2) region))
 217
 218 (defbinding region-xor (source1 source2) nil
 219   (source1 region)
 220   ((ensure-region source2) region))
 221
 222
 223 ;;; Events
 224
 225 (defbinding (events-pending-p "gdk_events_pending") () boolean)
 226
 227 (defbinding event-get () event)
 228
 229 (defbinding event-peek () event)
 230
 231 (defbinding event-get-graphics-expose () event
 232   (window window))
 233
 234 (defbinding event-put () event
 235   (event event))
 236
 237 ;(defbinding event-handler-set () ...)
 238
 239 (defbinding set-show-events () nil
 240   (show-events boolean))
 241
 242 (defbinding get-show-events () boolean)
 243
 244
 245 ;;; Miscellaneous functions
 246
 247 (defbinding screen-width () int
 248   (screen screen))
 249
 250 (defbinding screen-height () int
 251   (screen screen))
 252
 253 (defbinding screen-width-mm () int
 254   (screen screen))
 255
 256 (defbinding screen-height-mm () int
 257   (screen screen))
 258
 259
 260 (defbinding pointer-grab
 261     (window &key owner-events events confine-to cursor time) grab-status
 262   (window window)
 263   (owner-events boolean)
 264   (events event-mask)
 265   (confine-to (or null window))
 266   (cursor (or null cursor))
 267   ((or time 0) (unsigned 32)))
 268
 269 (defbinding (pointer-ungrab "gdk_display_pointer_ungrab")
 270     (&optional time (display (display-get-default))) nil
 271   (display display)
 272   ((or time 0) (unsigned 32)))
 273
 274 (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed")
 275     (&optional (display (display-get-default))) boolean
 276   (display display))
 277
 278 (defbinding keyboard-grab (window &key owner-events time) grab-status
 279   (window window)
 280   (owner-events boolean)
 281   ((or time 0) (unsigned 32)))
 282
 283 (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab")
 284     (&optional time (display (display-get-default))) nil
 285   (display display)
 286   ((or time 0) (unsigned 32)))
 287
 288
 289
 290 (defbinding atom-intern (atom-name &optional only-if-exists) atom
 291   ((string atom-name) string)
 292   (only-if-exists boolean))
 293
 294 (defbinding atom-name () string
 295   (atom atom))
 296
 297
 298
 299 ;;; Visuals
 300
 301 (defbinding visual-get-best-depth () int)
 302
 303 (defbinding visual-get-best-type () visual-type)
 304
 305 (defbinding visual-get-system () visual)
 306
 307
 308 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 309
 310 (defbinding %visual-get-best-with-depth () visual
 311   (depth int))
 312
 313 (defbinding %visual-get-best-with-type () visual
 314   (type visual-type))
 315
 316 (defbinding %visual-get-best-with-both () visual
 317   (depth int)
 318   (type visual-type))
 319
 320 (defun visual-get-best (&key depth type)
 321   (cond
 322    ((and depth type) (%visual-get-best-with-both depth type))
 323    (depth (%visual-get-best-with-depth depth))
 324    (type (%visual-get-best-with-type type))
 325    (t (%visual-get-best-with-nothing))))
 326
 327 ;(defbinding query-depths ..)
 328
 329 ;(defbinding query-visual-types ..)
 330
 331 (defbinding list-visuals () (glist visual))
 332
 333
 334 ;;; Windows
 335
 336 (defbinding window-destroy () nil
 337   (window window))
 338
 339 (defbinding window-at-pointer () window
 340   (x int :out)
 341   (y int :out))
 342
 343 (defbinding window-show () nil
 344   (window window))
 345
 346 (defbinding window-show-unraised () nil
 347   (window window))
 348
 349 (defbinding window-hide () nil
 350   (window window))
 351
 352 (defbinding window-is-visible-p () boolean
 353   (window window))
 354
 355 (defbinding window-is-viewable-p () boolean
 356   (window window))
 357
 358 (defbinding window-withdraw () nil
 359   (window window))
 360
 361 (defbinding window-iconify () nil
 362   (window window))
 363
 364 (defbinding window-deiconify () nil
 365   (window window))
 366
 367 (defbinding window-stick () nil
 368   (window window))
 369
 370 (defbinding window-unstick () nil
 371   (window window))
 372
 373 (defbinding window-maximize () nil
 374   (window window))
 375
 376 (defbinding window-unmaximize () nil
 377   (window window))
 378
 379 (defbinding window-fullscreen () nil
 380   (window window))
 381
 382 (defbinding window-unfullscreen () nil
 383   (window window))
 384
 385 (defbinding window-set-keep-above () nil
 386   (window window)
 387   (setting boolean))
 388
 389 (defbinding window-set-keep-below () nil
 390   (window window)
 391   (setting boolean))
 392
 393 (defbinding window-move () nil
 394   (window window)
 395   (x int)
 396   (y int))
 397
 398 (defbinding window-resize () nil
 399   (window window)
 400   (width int)
 401   (height int))
 402
 403 (defbinding window-move-resize () nil
 404   (window window)
 405   (x int)
 406   (y int)
 407   (width int)
 408   (height int))
 409
 410 (defbinding window-scroll () nil
 411   (window window)
 412   (dx int)
 413   (dy int))
 414
 415 (defbinding window-reparent () nil
 416   (window window)
 417   (new-parent window)
 418   (x int)
 419   (y int))
 420
 421 (defbinding window-clear () nil
 422   (window window))
 423
 424 (defbinding %window-clear-area () nil
 425   (window window)
 426   (x int) (y int) (width int) (height int))
 427
 428 (defbinding %window-clear-area-e () nil
 429   (window window)
 430   (x int) (y int) (width int) (height int))
 431
 432 (defun window-clear-area (window x y width height &optional expose)
 433   (if expose
 434       (%window-clear-area-e window x y width height)
 435     (%window-clear-area window x y width height)))
 436
 437 (defbinding window-raise () nil
 438   (window window))
 439
 440 (defbinding window-lower () nil
 441   (window window))
 442
 443 (defbinding window-focus () nil
 444   (window window)
 445   (timestamp unsigned-int))
 446
 447 (defbinding window-register-dnd () nil
 448   (window window))
 449
 450 (defbinding window-begin-resize-drag () nil
 451   (window window)
 452   (edge window-edge)
 453   (button int)
 454   (root-x int)
 455   (root-y int)
 456   (timestamp unsigned-int))
 457
 458 (defbinding window-begin-move-drag () nil
 459   (window window)
 460   (button int)
 461   (root-x int)
 462   (root-y int)
 463   (timestamp unsigned-int))
 464
 465 ;; Probably not needed
 466 ;; (defbinding window-constrain-size () nil ..
 467
 468 (defbinding window-begin-paint-region (window region) nil
 469   (window window)
 470   ((ensure-region region) region))
 471
 472 (defbinding window-end-paint () nil
 473   (window window))
 474
 475 (defmacro with-window-paint ((window region) &body body)
 476   `(progn
 477      (window-begin-paint-region ,window ,region)
 478      (unwind-protect
 479          (progn ,@body)
 480        (window-end-paint ,window))))
 481
 482 ;; TODO: create wrapper function and use gdk_window_invalidate_maybe_recurse
 483 ;; if last arg is a function
 484 (defbinding window-invalidate-region (window region invalidate-children-p) nil
 485   (window window)
 486   ((ensure-region region) region)
 487   (invalidate-children-p boolean))
 488
 489 (defbinding window-get-update-area () region
 490   (window window))
 491
 492 (defbinding window-freeze-updates () nil
 493   (window window))
 494
 495 (defbinding window-thaw-updates () nil
 496   (window window))
 497
 498 (defbinding window-process-all-updates () nil)
 499
 500 (defbinding window-process-updates () nil
 501   (window window)
 502   (update-children-p boolean))
 503
 504 (defbinding window-set-debug-updates () nil
 505   (enable-p boolean))
 506
 507 (defbinding window-enable-synchronized-configure () nil
 508   (window window))
 509
 510 (defbinding window-configure-finished () nil
 511   (window window))
 512
 513 ;; Deprecated, use gobject user data mechanism
 514 (defbinding window-set-user-data () nil
 515   (window window)
 516   (user-data pointer))
 517
 518 (defbinding window-set-override-redirect () nil
 519   (window window)
 520   (override-redirect-p boolean))
 521
 522 (defbinding window-set-accept-focus () nil
 523   (window window)
 524   (accept-focus-p boolean))
 525
 526 (defbinding window-set-focus-on-map () nil
 527   (window window)
 528   (focus-on-map-p boolean))
 529
 530 ;; Added if needed
 531 ; (defbinding window-add-filter () nil
 532 ; (defbinding window-remove-filter () nil
 533
 534 ;; New code should use window-shape-combine
 535 (defbinding window-shape-combine-mask () nil
 536   (window window)
 537   (shape-mask bitmap)
 538   (offset-x int)
 539   (offset-y int))
 540
 541 (defbinding %window-shape-combine-region () nil
 542   (window window)
 543   (region (or null region))
 544   (offset-x int)
 545   (offset-y int))
 546
 547 (defun window-shape-combine (window shape offset-x offset-y)
 548   (etypecase shape
 549     (nil (%window-shape-combine-region window nil 0 0)
 550     (region (%window-shape-combine-region window shape offset-x offset-y))
 551     (bitmask (window-shape-combine-mask window shape offset-x offset-y)))))
 552
 553 (defbinding window-set-child-shapes () nil
 554   (window window))
 555
 556 (defbinding window-merge-child-shapes () nil
 557   (window window))
 558
 559 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.10.0")
 560 (progn
 561   (defbinding %window-input-shape-combine-mask () nil
 562     (window window)
 563     (shape-mask bitmap)
 564     (x int)
 565     (y int))
 566
 567   (defbinding %window-input-shape-combine-region () nil
 568     (window window)
 569     (region (or null region))
 570     (x int)
 571     (y int))
 572
 573   (defun window-input-shape-combine (window shape x y)
 574     (etypecase shape
 575       (nil (%window-input-shape-combine-region window nil 0 0)
 576            (region (%window-input-shape-combine-region window shape x y))
 577            (bitmask (%window-input-shape-combine-mask window shape x y)))))
 578
 579   (defbinding window-set-child-input-shapes () nil
 580     (window window))
 581
 582   (defbinding window-merge-child-input-shapes () nil
 583     (window window)))
 584
 585 (defbinding window-set-static-gravities () boolean
 586   (window window)
 587   (use-static-p boolean))
 588
 589 (defbinding window-set-title () nil
 590   (window window)
 591   (title string))
 592
 593 (defbinding window-set-background () nil
 594   (window window)
 595   (color color))
 596
 597 (defbinding window-set-back-pixmap (window pixmap &optional parent-relative-p) nil
 598   (window window)
 599   (pixmap (or null pixmap))
 600   (parent-relative-p boolean))
 601
 602 (defbinding window-set-cursor () nil
 603   (window window)
 604   (cursor (or null cursor)))
 605
 606 (defbinding window-get-geometry () nil
 607   (window window)
 608   (x int :out)
 609   (y int :out)
 610   (width int :out)
 611   (height int :out)
 612   (depth int :out))
 613
 614 ;(defbinding window-set-geometry-hints () nil
 615
 616 (defbinding window-set-icon-list () nil
 617   (window window)
 618   (icons (glist pixbufs)))
 619
 620 (defbinding window-set-skip-taskbar-hint () nil
 621   (window window)
 622   (skip-taskbar-p boolean))
 623
 624 (defbinding window-set-skip-pager-hint () nil
 625   (window window)
 626   (skip-pager-p boolean))
 627
 628 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 629 (defbinding window-set-urgency-hint () nil
 630   (window window)
 631   (urgent-p boolean))
 632
 633 (defbinding window-get-position () nil
 634   (window window)
 635   (x int :out)
 636   (y int :out))
 637
 638 (defbinding window-get-root-origin () nil
 639   (window window)
 640   (x int :out)
 641   (y int :out))
 642
 643 (defbinding window-get-frame-extents (window &optional (extents (make-instance 'rect))) nil
 644   (window window)
 645   (extents rectangle :in/return))
 646
 647 (defbinding window-get-origin () nil ; this may not work as
 648   (window window)                    ; an int is actually returned
 649   (x int :out)
 650   (y int :out))
 651
 652 (defbinding window-get-pointer () window
 653   (window window)
 654   (x int :out)
 655   (y int :out)
 656   (mask modifier-type :out))
 657
 658 ;(defbinding window-set-icon () nil
 659
 660 (defbinding window-set-icon-name () nil
 661   (window window)
 662   (icon-name string))
 663
 664 (defbinding window-set-transient-for () nil
 665   (window window)
 666   (parent window))
 667
 668 (defbinding window-set-role () nil
 669   (window window)
 670   (role string))
 671
 672 (defbinding %window-get-decorations () boolean
 673   (window window)
 674   (decorations wm-decoration :out))
 675
 676 (defun %window-decorations-getter (window)
 677   (nth-value 1 (%window-get-decorations window)))
 678
 679 (defun %window-decorations-boundp (window)
 680   (%window-get-decorations window))
 681
 682 (defbinding %window-get-toplevels () (glist window))
 683
 684 (defun window-get-toplevels (&optional screen)
 685   (if screen
 686       (error "Not implemented")
 687     (%window-get-toplevels)))
 688
 689 (defbinding %get-default-root-window () window)
 690
 691 (defun get-root-window (&optional display)
 692   (if display
 693       (error "Not implemented")
 694     (%get-default-root-window)))
 695
 696
 697
 698 ;;; Drag and Drop
 699
 700 ;; Destination side
 701
 702 (defbinding drag-status () nil
 703   (context drag-context)
 704   (action drag-action)
 705   (time (unsigned 32)))
 706
 707
 708
 709
 710
 711
 712 ;;
 713
 714 (defbinding rgb-init () nil)
 715
 716
 717
 718
 719 ;;; Cursor
 720
 721 (defmethod allocate-foreign ((cursor cursor) &key source mask fg bg
 722                              (x 0) (y 0) (display (display-get-default)))
 723   (etypecase source
 724     (keyword (%cursor-new-for-display display source))
 725     (pixbuf (%cursor-new-from-pixbuf display source x y))
 726     (pixmap (%cursor-new-from-pixmap source mask
 727              (or fg (ensure-color #(0.0 0.0 0.0)))
 728              (or bg (ensure-color #(1.0 1.0 1.0))) x y))
 729     (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y))))
 730
 731 (defun ensure-cursor (cursor &rest args)
 732   (if (typep cursor 'cursor)
 733       cursor
 734     (apply #'make-instance 'cursor :source cursor args)))
 735
 736 (defbinding %cursor-new-for-display () pointer
 737   (display display)
 738   (cursor-type cursor-type))
 739
 740 (defbinding %cursor-new-from-pixmap () pointer
 741   (source pixmap)
 742   (mask bitmap)
 743   (foreground color)
 744   (background color)
 745   (x int) (y int))
 746
 747 (defbinding %cursor-new-from-pixbuf () pointer
 748   (display display)
 749   (pixbuf pixbuf)
 750   (x int) (y int))
 751
 752 (defbinding %cursor-ref () pointer
 753   (location pointer))
 754
 755 (defbinding %cursor-unref () nil
 756   (location pointer))
 757
 758
 759 ;;; Pixmaps
 760
 761 (defbinding %pixmap-new () pointer
 762   (window (or null window))
 763   (width int)
 764   (height int)
 765   (depth int))
 766
 767 (defmethod allocate-foreign ((pximap pixmap) &key width height depth window)
 768   (%pixmap-new window width height depth))
 769
 770 (defun pixmap-new (width height depth &key window)
 771   (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead")
 772   (make-instance 'pixmap :width width :height height :depth depth :window window))
 773
 774 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 775   (window (or null window))
 776   (colormap (or null colormap))
 777   (mask bitmap :out)
 778   (color (or null color))
 779   (filename pathname))
 780
 781 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 782   (window (or null window))
 783   (colormap (or null colormap))
 784   (mask bitmap :out)
 785   (color (or null color))
 786   (data (vector string)))
 787
 788 ;; Deprecated, use pixbufs instead
 789 (defun pixmap-create (source &key color window colormap)
 790   (let ((window
 791          (if (not (or window colormap))
 792              (get-root-window)
 793            window)))
 794     (multiple-value-bind (pixmap mask)
 795         (etypecase source
 796           ((or string pathname)
 797            (%pixmap-colormap-create-from-xpm window colormap color  source))
 798           ((vector string)
 799            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 800       (values pixmap mask))))
 801
 802
 803 ;;; Color
 804
 805 (defbinding colormap-get-system () colormap)
 806
 807 (defbinding %color-copy () pointer
 808   (location pointer))
 809
 810 (defmethod allocate-foreign ((color color)  &rest initargs)
 811   (declare (ignore color initargs))
 812   ;; Color structs are allocated as memory chunks by gdk, and since
 813   ;; there is no gdk_color_new we have to use this hack to get a new
 814   ;; color chunk
 815   (with-memory (location #.(foreign-size (find-class 'color)))
 816     (%color-copy location)))
 817
 818 (defun %scale-value (value)
 819   (etypecase value
 820     (integer value)
 821     (float (truncate (* value 65535)))))
 822
 823 (defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0))
 824   (call-next-method)
 825   (with-slots ((%red red) (%green green) (%blue blue)) color
 826     (setf
 827      %red (%scale-value red)
 828      %green (%scale-value green)
 829      %blue (%scale-value blue))))
 830
 831 (defbinding %color-parse () boolean
 832   (spec string)
 833   (color color :in/return))
 834
 835 (defun color-parse (spec &optional (color (make-instance 'color)))
 836   (multiple-value-bind (succeeded-p color) (%color-parse spec color)
 837     (if succeeded-p
 838         color
 839       (error "Parsing color specification ~S failed." spec))))
 840
 841 (defun ensure-color (color)
 842   (etypecase color
 843     (null nil)
 844     (color color)
 845     (string (color-parse color))
 846     (vector
 847      (make-instance 'color
 848       :red (svref color 0) :green (svref color 1) :blue (svref color 2)))))
 849
 850
 851
 852 ;;; Drawable -- all the draw- functions are deprecated and will be
 853 ;;; removed, use cairo for drawing instead.
 854
 855 (defbinding drawable-get-size () nil
 856   (drawable drawable)
 857   (width int :out)
 858   (height int :out))
 859
 860 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 861   (drawable drawable)
 862   (width int :out)
 863   (nil null))
 864
 865 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 866   (drawable drawable)
 867   (nil null)
 868   (height int :out))
 869
 870 ;; (defbinding drawable-get-clip-region () region
 871 ;;   (drawable drawable))
 872
 873 ;; (defbinding drawable-get-visible-region () region
 874 ;;   (drawable drawable))
 875
 876 (defbinding draw-point () nil
 877   (drawable drawable) (gc gc)
 878   (x int) (y int))
 879
 880 (defbinding %draw-points () nil
 881   (drawable drawable) (gc gc)
 882   (points pointer)
 883   (n-points int))
 884
 885 (defbinding draw-line () nil
 886   (drawable drawable) (gc gc)
 887   (x1 int) (y1 int)
 888   (x2 int) (y2 int))
 889
 890 (defbinding draw-pixbuf
 891     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 892      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 893   (drawable drawable) (gc (or null gc))
 894   (pixbuf pixbuf)
 895   (src-x int) (src-y int)
 896   (dest-x int) (dest-y int)
 897   ((or width -1) int) ((or height -1) int)
 898   (dither rgb-dither)
 899   (x-dither int) (y-dither int))
 900
 901 (defbinding draw-rectangle () nil
 902   (drawable drawable) (gc gc)
 903   (filled boolean)
 904   (x int) (y int)
 905   (width int) (height int))
 906
 907 (defbinding draw-arc () nil
 908   (drawable drawable) (gc gc)
 909   (filled boolean)
 910   (x int) (y int)
 911   (width int) (height int)
 912   (angle1 int) (angle2 int))
 913
 914 (defbinding %draw-layout () nil
 915   (drawable drawable) (gc gc)
 916   (font pango:font)
 917   (x int) (y int)
 918   (layout pango:layout))
 919
 920 (defbinding %draw-layout-with-colors () nil
 921   (drawable drawable) (gc gc)
 922   (font pango:font)
 923   (x int) (y int)
 924   (layout pango:layout)
 925   (foreground (or null color))
 926   (background (or null color)))
 927
 928 (defun draw-layout (drawable gc font x y layout &optional foreground background)
 929   (if (or foreground background)
 930       (%draw-layout-with-colors drawable gc font x y layout foreground background)
 931     (%draw-layout drawable gc font x y layout)))
 932
 933 (defbinding draw-drawable
 934     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
 935   (drawable drawable) (gc gc)
 936   (src drawable)
 937   (src-x int) (src-y int)
 938   (dest-x int) (dest-y int)
 939   ((or width -1) int) ((or height -1) int))
 940
 941 (defbinding draw-image
 942     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
 943   (drawable drawable) (gc gc)
 944   (image image)
 945   (src-x int) (src-y int)
 946   (dest-x int) (dest-y int)
 947   ((or width -1) int) ((or height -1) int))
 948
 949 (defbinding drawable-get-image () image
 950   (drawable drawable)
 951   (x int) (y int)
 952   (width int) (height int))
 953
 954 (defbinding drawable-copy-to-image
 955     (drawable src-x src-y width height &optional image dest-x dest-y) image
 956   (drawable drawable)
 957   (image (or null image))
 958   (src-x int) (src-y int)
 959   ((if image dest-x 0) int)
 960   ((if image dest-y 0) int)
 961   (width int) (height int))
 962
 963
 964 ;;; Key values
 965
 966 (defbinding keyval-name () string
 967   (keyval unsigned-int))
 968
 969 (defbinding %keyval-from-name () unsigned-int
 970   (name string))
 971
 972 (defun keyval-from-name (name)
 973   "Returns the keysym value for the given key name or NIL if it is not a valid name."
 974   (let ((keyval (%keyval-from-name name)))
 975     (unless (zerop keyval)
 976       keyval)))
 977
 978 (defbinding keyval-to-upper () unsigned-int
 979   (keyval unsigned-int))
 980
 981 (defbinding keyval-to-lower () unsigned-int
 982   (keyval unsigned-int))
 983
 984 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 985   (keyval unsigned-int))
 986
 987 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 988   (keyval unsigned-int))
 989
 990 ;;; Cairo interaction
 991
 992 #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
 993 (progn
 994   (defbinding cairo-create () cairo:context
 995     (drawable drawable))
 996
 997   (defmacro with-cairo-context ((cr drawable) &body body)
 998     `(let ((,cr (cairo-create ,drawable)))
 999        (unwind-protect
1000            (progn ,@body)
1001          (invalidate-instance ,cr t))))
1002
1003   (defbinding cairo-set-source-color () nil
1004     (cr cairo:context)
1005     (color color))
1006
1007   (defbinding cairo-set-source-pixbuf () nil
1008     (cr cairo:context)
1009     (pixbuf pixbuf)
1010     (x double-float)
1011     (y double-float))
1012
1013   (defbinding cairo-rectangle () nil
1014     (cr cairo:context)
1015     (rectangle rectangle))
1016
1017 ;;   (defbinding cairo-region () nil
1018 ;;     (cr cairo:context)
1019 ;;     (region region))
1020 )
1021
1022
1023
1024 ;;; Multi-threading support
1025
1026 #+sbcl
1027 (progn
1028   (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
1029   (let ((recursive-level 0))
1030     (defun threads-enter ()
1031       (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
1032           (incf recursive-level)
1033         (sb-thread:get-mutex *global-lock*)))
1034
1035     (defun threads-leave (&optional flush-p)
1036       (cond
1037        ((zerop recursive-level)
1038         (when flush-p
1039           (display-flush))
1040         (sb-thread:release-mutex *global-lock*))
1041        (t (decf recursive-level)))))
1042
1043   (define-callback %enter-fn nil ()
1044     (threads-enter))
1045
1046   (define-callback %leave-fn nil ()
1047     (threads-leave))
1048
1049   (defbinding threads-set-lock-functions (&optional) nil
1050     (%enter-fn callback)
1051     (%leave-fn callback))
1052
1053   (defmacro with-global-lock (&body body)
1054     `(progn
1055        (threads-enter)
1056        (unwind-protect
1057            ,@body
1058          (threads-leave t)))))