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