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