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