mdw@git.distorted.org.uk Git - clg/blob - gdk/gdk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gdk.lisp,v 1.13 2005-01-30 15:08:03 espen Exp $
  19
  20
  21 (in-package "GDK")
  22
  23 ;;; Initialization
  24
  25 (defbinding (gdk-init "gdk_parse_args") () nil
  26   "Initializes the library without opening the display."
  27   (nil null)
  28   (nil null))
  29
  30
  31 ;;; Display
  32
  33 (defbinding (display-manager "gdk_display_manager_get") () display-manager)
  34
  35
  36 (defbinding (display-set-default "gdk_display_manager_set_default_display")
  37     (display) nil
  38   ((display-manager) display-manager)
  39   (display display))
  40
  41 (defbinding display-get-default () display)
  42
  43 (defbinding %display-open () display
  44   (display-name (or null string)))
  45
  46 (defun display-open (&optional display-name)
  47   (let ((display (%display-open display-name)))
  48     (unless (display-get-default)
  49       (display-set-default display))
  50     display))
  51
  52 (defbinding (display-connection-number "clg_gdk_connection_number")
  53     (&optional (display (display-get-default))) int
  54   (display display))
  55
  56
  57 ;;; Events
  58
  59 (defbinding (events-pending-p "gdk_events_pending") () boolean)
  60
  61 (defbinding event-get () event)
  62
  63 (defbinding event-peek () event)
  64
  65 (defbinding event-get-graphics-expose () event
  66   (window window))
  67
  68 (defbinding event-put () event
  69   (event event))
  70
  71 ;(defbinding event-handler-set () ...)
  72
  73 (defbinding set-show-events () nil
  74   (show-events boolean))
  75
  76 ;;; Misc
  77
  78 (defbinding set-use-xshm () nil
  79   (use-xshm boolean))
  80
  81 (defbinding get-show-events () boolean)
  82
  83 (defbinding get-use-xshm () boolean)
  84
  85 (defbinding get-display () string)
  86
  87 ; (defbinding time-get () (unsigned 32))
  88
  89 ; (defbinding timer-get () (unsigned 32))
  90
  91 ; (defbinding timer-set () nil
  92 ;   (milliseconds (unsigned 32)))
  93
  94 ; (defbinding timer-enable () nil)
  95
  96 ; (defbinding timer-disable () nil)
  97
  98 ; input ...
  99
 100 (defbinding pointer-grab () int
 101   (window window)
 102   (owner-events boolean)
 103   (event-mask event-mask)
 104   (confine-to (or null window))
 105   (cursor (or null cursor))
 106   (time (unsigned 32)))
 107
 108 (defbinding pointer-ungrab () nil
 109   (time (unsigned 32)))
 110
 111 (defbinding keyboard-grab () int
 112   (window window)
 113   (owner-events boolean)
 114   (time (unsigned 32)))
 115
 116 (defbinding keyboard-ungrab () nil
 117   (time (unsigned 32)))
 118
 119 (defbinding (pointer-is-grabbed-p "gdk_pointer_is_grabbed") () boolean)
 120
 121 (defbinding screen-width () int)
 122 (defbinding screen-height () int)
 123
 124 (defbinding screen-width-mm () int)
 125 (defbinding screen-height-mm () int)
 126
 127 (defbinding flush () nil)
 128 (defbinding beep () nil)
 129
 130 (defbinding atom-intern (atom-name &optional only-if-exists) atom
 131   ((string atom-name) string)
 132   (only-if-exists boolean))
 133
 134 (defbinding atom-name () string
 135   (atom atom))
 136
 137
 138
 139 ;;; Visuals
 140
 141 (defbinding visual-get-best-depth () int)
 142
 143 (defbinding visual-get-best-type () visual-type)
 144
 145 (defbinding visual-get-system () visual)
 146
 147
 148 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 149
 150 (defbinding %visual-get-best-with-depth () visual
 151   (depth int))
 152
 153 (defbinding %visual-get-best-with-type () visual
 154   (type visual-type))
 155
 156 (defbinding %visual-get-best-with-both () visual
 157   (depth int)
 158   (type visual-type))
 159
 160 (defun visual-get-best (&key depth type)
 161   (cond
 162    ((and depth type) (%visual-get-best-with-both depth type))
 163    (depth (%visual-get-best-with-depth depth))
 164    (type (%visual-get-best-with-type type))
 165    (t (%visual-get-best-with-nothing))))
 166
 167 ;(defbinding query-depths ..)
 168
 169 ;(defbinding query-visual-types ..)
 170
 171 (defbinding list-visuals () (glist visual))
 172
 173
 174 ;;; Windows
 175
 176 (defbinding window-destroy () nil
 177   (window window))
 178
 179
 180 (defbinding window-at-pointer () window
 181   (x int :out)
 182   (y int :out))
 183
 184 (defbinding window-show () nil
 185   (window window))
 186
 187 (defbinding window-show-unraised () nil
 188   (window window))
 189
 190 (defbinding window-hide () nil
 191   (window window))
 192
 193 (defbinding window-is-visible-p () boolean
 194   (window window))
 195
 196 (defbinding window-is-viewable-p () boolean
 197   (window window))
 198
 199 (defbinding window-withdraw () nil
 200   (window window))
 201
 202 (defbinding window-iconify () nil
 203   (window window))
 204
 205 (defbinding window-deiconify () nil
 206   (window window))
 207
 208 (defbinding window-stick () nil
 209   (window window))
 210
 211 (defbinding window-unstick () nil
 212   (window window))
 213
 214 (defbinding window-maximize () nil
 215   (window window))
 216
 217 (defbinding window-unmaximize () nil
 218   (window window))
 219
 220 (defbinding window-fullscreen () nil
 221   (window window))
 222
 223 (defbinding window-unfullscreen () nil
 224   (window window))
 225
 226 (defbinding window-set-keep-above () nil
 227   (window window)
 228   (setting boolean))
 229
 230 (defbinding window-set-keep-below () nil
 231   (window window)
 232   (setting boolean))
 233
 234 (defbinding window-move () nil
 235   (window window)
 236   (x int)
 237   (y int))
 238
 239 (defbinding window-resize () nil
 240   (window window)
 241   (width int)
 242   (height int))
 243
 244 (defbinding window-move-resize () nil
 245   (window window)
 246   (x int)
 247   (y int)
 248   (width int)
 249   (height int))
 250
 251 (defbinding window-scroll () nil
 252   (window window)
 253   (dx int)
 254   (dy int))
 255
 256 (defbinding window-reparent () nil
 257   (window window)
 258   (new-parent window)
 259   (x int)
 260   (y int))
 261
 262 (defbinding window-clear () nil
 263   (window window))
 264
 265 (defbinding %window-clear-area () nil
 266   (window window)
 267   (x int) (y int) (width int) (height int))
 268
 269 (defbinding %window-clear-area-e () nil
 270   (window window)
 271   (x int) (y int) (width int) (height int))
 272
 273 (defun window-clear-area (window x y width height &optional expose)
 274   (if expose
 275       (%window-clear-area-e window x y width height)
 276     (%window-clear-area window x y width height)))
 277
 278 (defbinding window-raise () nil
 279   (window window))
 280
 281 (defbinding window-lower () nil
 282   (window window))
 283
 284 (defbinding window-focus () nil
 285   (window window)
 286   (timestamp unsigned-int))
 287
 288 (defbinding window-register-dnd () nil
 289   (window window))
 290
 291 (defbinding window-begin-resize-drag () nil
 292   (window window)
 293   (edge window-edge)
 294   (button int)
 295   (root-x int)
 296   (root-y int)
 297   (timestamp unsigned-int))
 298
 299 (defbinding window-begin-move-drag () nil
 300   (window window)
 301   (button int)
 302   (root-x int)
 303   (root-y int)
 304   (timestamp unsigned-int))
 305
 306 ;; komplett så langt
 307
 308 (defbinding window-set-user-data () nil
 309   (window window)
 310   (user-data pointer))
 311
 312 (defbinding window-set-override-redirect () nil
 313   (window window)
 314   (override-redirect boolean))
 315
 316 ; (defbinding window-add-filter () nil
 317
 318 ; (defbinding window-remove-filter () nil
 319
 320 (defbinding window-shape-combine-mask () nil
 321   (window window)
 322   (shape-mask bitmap)
 323   (offset-x int)
 324   (offset-y int))
 325
 326 (defbinding window-set-child-shapes () nil
 327   (window window))
 328
 329 (defbinding window-merge-child-shapes () nil
 330   (window window))
 331
 332
 333 (defbinding window-set-static-gravities () boolean
 334   (window window)
 335   (use-static boolean))
 336
 337 ; (defbinding add-client-message-filter ...
 338
 339 (defbinding window-set-cursor () nil
 340   (window window)
 341   (cursor (or null cursor)))
 342
 343 (defbinding window-get-pointer () window
 344   (window window)
 345   (x int :out)
 346   (y int :out)
 347   (mask modifier-type :out))
 348
 349 (defbinding %window-get-toplevels () (glist window))
 350
 351 (defun window-get-toplevels (&optional screen)
 352   (if screen
 353       (error "Not implemented")
 354     (%window-get-toplevels)))
 355
 356 (defbinding %get-default-root-window () window)
 357
 358 (defun get-root-window (&optional display)
 359   (if display
 360       (error "Not implemented")
 361     (%get-default-root-window)))
 362
 363
 364
 365 ;;; Drag and Drop
 366
 367 ;; Destination side
 368
 369 (defbinding drag-status () nil
 370   (context drag-context)
 371   (action drag-action)
 372   (time (unsigned 32)))
 373
 374
 375
 376
 377
 378
 379 ;;
 380
 381 (defbinding rgb-init () nil)
 382
 383
 384
 385
 386 ;;; Cursor
 387
 388 (defmethod initialize-instance ((cursor cursor) &key type mask fg bg
 389                                 (x 0) (y 0) (display (display-get-default)))
 390   (setf
 391    (slot-value cursor 'location)
 392    (etypecase type
 393      (keyword (%cursor-new-for-display display type))
 394      (pixbuf (%cursor-new-from-pixbuf display type x y))
 395      (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))))
 396
 397
 398 (defbinding %cursor-new-for-display () pointer
 399   (display display)
 400   (cursor-type cursor-type))
 401
 402 (defbinding %cursor-new-from-pixmap () pointer
 403   (source pixmap)
 404   (mask bitmap)
 405   (foreground color)
 406   (background color)
 407   (x int) (y int))
 408
 409 (defbinding %cursor-new-from-pixbuf () pointer
 410   (display display)
 411   (pixbuf pixbuf)
 412   (x int) (y int))
 413
 414 (defbinding %cursor-ref () pointer
 415   (location pointer))
 416
 417 (defbinding %cursor-unref () nil
 418   (location pointer))
 419
 420 (defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
 421   (declare (ignore class))
 422   (%cursor-ref location))
 423
 424 (defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
 425   (declare (ignore class))
 426   (%cursor-unref location))
 427
 428
 429 ;;; Pixmaps
 430
 431 (defbinding pixmap-new (width height depth &key window) pixmap
 432   (width int)
 433   (height int)
 434   (depth int)
 435   (window (or null window)))
 436
 437 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 438   (window (or null window))
 439   (colormap (or null colormap))
 440   (mask bitmap :out)
 441   (color (or null color))
 442   (filename string))
 443
 444 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 445   (window (or null window))
 446   (colormap (or null colormap))
 447   (mask bitmap :out)
 448   (color (or null color))
 449   (data (vector string)))
 450
 451 (defun pixmap-create (source &key color window colormap)
 452   (let ((window
 453          (if (not (or window colormap))
 454              (get-root-window)
 455            window)))
 456     (multiple-value-bind (pixmap mask)
 457         (etypecase source
 458           ((or string pathname)
 459            (%pixmap-colormap-create-from-xpm
 460             window colormap color (namestring (truename source))))
 461           ((vector string)
 462            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 463 ;;       (unreference-instance pixmap)
 464 ;;       (unreference-instance mask)
 465       (values pixmap mask))))
 466
 467
 468
 469 ;;; Color
 470
 471 (defun %scale-value (value)
 472   (etypecase value
 473     (integer value)
 474     (float (truncate (* value 65535)))))
 475
 476 (defmethod initialize-instance ((color color) &rest initargs
 477                                 &key red green blue)
 478   (declare (ignore initargs))
 479   (call-next-method)
 480   (with-slots ((%red red) (%green green) (%blue blue)) color
 481     (setf
 482      %red (%scale-value red)
 483      %green (%scale-value green)
 484      %blue (%scale-value blue))))
 485
 486 (defun ensure-color (color)
 487   (etypecase color
 488     (null nil)
 489     (color color)
 490     (vector
 491      (make-instance
 492       'color :red (svref color 0) :green (svref color 1)
 493       :blue (svref color 2)))))
 494
 495
 496
 497 ;;; Drawable
 498
 499 (defbinding drawable-get-size () nil
 500   (drawable drawable)
 501   (width int :out)
 502   (height int :out))
 503
 504 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 505   (drawable drawable)
 506   (width int :out)
 507   (nil null))
 508
 509 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 510   (drawable drawable)
 511   (nil null)
 512   (height int :out))
 513
 514 ;; (defbinding drawable-get-clip-region () region
 515 ;;   (drawable drawable))
 516
 517 ;; (defbinding drawable-get-visible-region () region
 518 ;;   (drawable drawable))
 519
 520 (defbinding draw-point () nil
 521   (drawable drawable) (gc gc)
 522   (x int) (y int))
 523
 524 (defbinding %draw-points () nil
 525   (drawable drawable) (gc gc)
 526   (points pointer)
 527   (n-points int))
 528
 529 ;; (defun draw-points (drawable gc &rest points)
 530
 531 ;;   )
 532
 533 (defbinding draw-line () nil
 534   (drawable drawable) (gc gc)
 535   (x1 int) (y1 int)
 536   (x2 int) (y2 int))
 537
 538 ;; (defbinding draw-lines (drawable gc &rest points) nil
 539 ;;   (drawable drawable) (gc gc)
 540 ;;   (points (vector point))
 541 ;;   ((length points) int))
 542
 543 (defbinding draw-pixbuf
 544     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 545      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 546   (drawable drawable) (gc (or null gc))
 547   (pixbuf pixbuf)
 548   (src-x int) (src-y int)
 549   (dest-x int) (dest-y int)
 550   ((or width -1) int) ((or height -1) int)
 551   (dither rgb-dither)
 552   (x-dither int) (y-dither int))
 553
 554 ;; (defbinding draw-segments (drawable gc &rest points) nil
 555 ;;   (drawable drawable) (gc gc)
 556 ;;   (segments (vector segments))
 557 ;;   ((length segments) int))
 558
 559 (defbinding draw-rectangle () nil
 560   (drawable drawable) (gc gc)
 561   (filled boolean)
 562   (x int) (y int)
 563   (width int) (height int))
 564
 565 (defbinding draw-arc () nil
 566   (drawable drawable) (gc gc)
 567   (filled boolean)
 568   (x int) (y int)
 569   (width int) (height int)
 570   (angle1 int) (angle2 int))
 571
 572 ;; (defbinding draw-polygon (drawable gc &rest points) nil
 573 ;;   (drawable drawable) (gc gc)
 574 ;;   (points (vector point))
 575 ;;   ((length points) int))
 576
 577 ;; (defbinding draw-trapezoid (drawable gc &rest points) nil
 578 ;;   (drawable drawable) (gc gc)
 579 ;;   (points (vector point))
 580 ;;   ((length points) int))
 581
 582 ;; (defbinding %draw-layout-line () nil
 583 ;;   (drawable drawable) (gc gc)
 584 ;;   (font pango:font)
 585 ;;   (x int) (y int)
 586 ;;   (line pango:layout-line))
 587
 588 ;; (defbinding %draw-layout-line-with-colors () nil
 589 ;;   (drawable drawable) (gc gc)
 590 ;;   (font pango:font)
 591 ;;   (x int) (y int)
 592 ;;   (line pango:layout-line)
 593 ;;   (foreground (or null color))
 594 ;;   (background (or null color)))
 595
 596 ;; (defun draw-layout-line (drawable gc font x y line &optional foreground background)
 597 ;;   (if (or foreground background)
 598 ;;       (%draw-layout-line-with-colors drawable gc font x y line foreground background)
 599 ;;     (%draw-layout-line drawable gc font x y line)))
 600
 601 (defbinding %draw-layout () nil
 602   (drawable drawable) (gc gc)
 603   (font pango:font)
 604   (x int) (y int)
 605   (layout pango:layout))
 606
 607 (defbinding %draw-layout-with-colors () nil
 608   (drawable drawable) (gc gc)
 609   (font pango:font)
 610   (x int) (y int)
 611   (layout pango:layout)
 612   (foreground (or null color))
 613   (background (or null color)))
 614
 615 (defun draw-layout (drawable gc font x y layout &optional foreground background)
 616   (if (or foreground background)
 617       (%draw-layout-with-colors drawable gc font x y layout foreground background)
 618     (%draw-layout drawable gc font x y layout)))
 619
 620 (defbinding draw-drawable
 621     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
 622   (drawable drawable) (gc gc)
 623   (src drawable)
 624   (src-x int) (src-y int)
 625   (dest-x int) (dest-y int)
 626   ((or width -1) int) ((or height -1) int))
 627
 628 (defbinding draw-image
 629     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
 630   (drawable drawable) (gc gc)
 631   (image image)
 632   (src-x int) (src-y int)
 633   (dest-x int) (dest-y int)
 634   ((or width -1) int) ((or height -1) int))
 635
 636 (defbinding drawable-get-image () image
 637   (drawable drawable)
 638   (x int) (y int)
 639   (width int) (height int))
 640
 641 (defbinding drawable-copy-to-image
 642     (drawable src-x src-y width height &optional image dest-x dest-y) image
 643   (drawable drawable)
 644   (image (or null image))
 645   (src-x int) (src-y int)
 646   ((if image dest-x 0) int)
 647   ((if image dest-y 0) int)
 648   (width int) (height int))
 649
 650
 651 ;;; Key values
 652
 653 (defbinding keyval-name () string
 654   (keyval unsigned-int))
 655
 656 (defbinding keyval-from-name () unsigned-int
 657   (name string))
 658
 659 (defbinding keyval-to-upper () unsigned-int
 660   (keyval unsigned-int))
 661
 662 (defbinding keyval-to-lower () unsigned-int
 663   (keyval unsigned-int))
 664
 665 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 666   (keyval unsigned-int))
 667
 668 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 669   (keyval unsigned-int))
 670