chiark - git - mdw - 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.12 2004-12-20 00:32:15 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
 131
 132 ;;; Visuals
 133
 134 (defbinding visual-get-best-depth () int)
 135
 136 (defbinding visual-get-best-type () visual-type)
 137
 138 (defbinding visual-get-system () visual)
 139
 140
 141 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 142
 143 (defbinding %visual-get-best-with-depth () visual
 144   (depth int))
 145
 146 (defbinding %visual-get-best-with-type () visual
 147   (type visual-type))
 148
 149 (defbinding %visual-get-best-with-both () visual
 150   (depth int)
 151   (type visual-type))
 152
 153 (defun visual-get-best (&key depth type)
 154   (cond
 155    ((and depth type) (%visual-get-best-with-both depth type))
 156    (depth (%visual-get-best-with-depth depth))
 157    (type (%visual-get-best-with-type type))
 158    (t (%visual-get-best-with-nothing))))
 159
 160 ;(defbinding query-depths ..)
 161
 162 ;(defbinding query-visual-types ..)
 163
 164 (defbinding list-visuals () (glist visual))
 165
 166
 167 ;;; Windows
 168
 169 (defbinding window-destroy () nil
 170   (window window))
 171
 172
 173 (defbinding window-at-pointer () window
 174   (x int :out)
 175   (y int :out))
 176
 177 (defbinding window-show () nil
 178   (window window))
 179
 180 (defbinding window-show-unraised () nil
 181   (window window))
 182
 183 (defbinding window-hide () nil
 184   (window window))
 185
 186 (defbinding window-is-visible-p () boolean
 187   (window window))
 188
 189 (defbinding window-is-viewable-p () boolean
 190   (window window))
 191
 192 (defbinding window-withdraw () nil
 193   (window window))
 194
 195 (defbinding window-iconify () nil
 196   (window window))
 197
 198 (defbinding window-deiconify () nil
 199   (window window))
 200
 201 (defbinding window-stick () nil
 202   (window window))
 203
 204 (defbinding window-unstick () nil
 205   (window window))
 206
 207 (defbinding window-maximize () nil
 208   (window window))
 209
 210 (defbinding window-unmaximize () nil
 211   (window window))
 212
 213 (defbinding window-fullscreen () nil
 214   (window window))
 215
 216 (defbinding window-unfullscreen () nil
 217   (window window))
 218
 219 (defbinding window-set-keep-above () nil
 220   (window window)
 221   (setting boolean))
 222
 223 (defbinding window-set-keep-below () nil
 224   (window window)
 225   (setting boolean))
 226
 227 (defbinding window-move () nil
 228   (window window)
 229   (x int)
 230   (y int))
 231
 232 (defbinding window-resize () nil
 233   (window window)
 234   (width int)
 235   (height int))
 236
 237 (defbinding window-move-resize () nil
 238   (window window)
 239   (x int)
 240   (y int)
 241   (width int)
 242   (height int))
 243
 244 (defbinding window-scroll () nil
 245   (window window)
 246   (dx int)
 247   (dy int))
 248
 249 (defbinding window-reparent () nil
 250   (window window)
 251   (new-parent window)
 252   (x int)
 253   (y int))
 254
 255 (defbinding window-clear () nil
 256   (window window))
 257
 258 (defbinding %window-clear-area () nil
 259   (window window)
 260   (x int) (y int) (width int) (height int))
 261
 262 (defbinding %window-clear-area-e () nil
 263   (window window)
 264   (x int) (y int) (width int) (height int))
 265
 266 (defun window-clear-area (window x y width height &optional expose)
 267   (if expose
 268       (%window-clear-area-e window x y width height)
 269     (%window-clear-area window x y width height)))
 270
 271 (defbinding window-raise () nil
 272   (window window))
 273
 274 (defbinding window-lower () nil
 275   (window window))
 276
 277 (defbinding window-focus () nil
 278   (window window)
 279   (timestamp unsigned-int))
 280
 281 (defbinding window-register-dnd () nil
 282   (window window))
 283
 284 (defbinding window-begin-resize-drag () nil
 285   (window window)
 286   (edge window-edge)
 287   (button int)
 288   (root-x int)
 289   (root-y int)
 290   (timestamp unsigned-int))
 291
 292 (defbinding window-begin-move-drag () nil
 293   (window window)
 294   (button int)
 295   (root-x int)
 296   (root-y int)
 297   (timestamp unsigned-int))
 298
 299 ;; komplett så langt
 300
 301 (defbinding window-set-user-data () nil
 302   (window window)
 303   (user-data pointer))
 304
 305 (defbinding window-set-override-redirect () nil
 306   (window window)
 307   (override-redirect boolean))
 308
 309 ; (defbinding window-add-filter () nil
 310
 311 ; (defbinding window-remove-filter () nil
 312
 313 (defbinding window-shape-combine-mask () nil
 314   (window window)
 315   (shape-mask bitmap)
 316   (offset-x int)
 317   (offset-y int))
 318
 319 (defbinding window-set-child-shapes () nil
 320   (window window))
 321
 322 (defbinding window-merge-child-shapes () nil
 323   (window window))
 324
 325
 326 (defbinding window-set-static-gravities () boolean
 327   (window window)
 328   (use-static boolean))
 329
 330 ; (defbinding add-client-message-filter ...
 331
 332 (defbinding window-set-cursor () nil
 333   (window window)
 334   (cursor (or null cursor)))
 335
 336 (defbinding window-get-pointer () window
 337   (window window)
 338   (x int :out)
 339   (y int :out)
 340   (mask modifier-type :out))
 341
 342 (defbinding %window-get-toplevels () (glist window))
 343
 344 (defun window-get-toplevels (&optional screen)
 345   (if screen
 346       (error "Not implemented")
 347     (%window-get-toplevels)))
 348
 349 (defbinding %get-default-root-window () window)
 350
 351 (defun get-root-window (&optional display)
 352   (if display
 353       (error "Not implemented")
 354     (%get-default-root-window)))
 355
 356
 357
 358 ;;; Drag and Drop
 359
 360 ;; Destination side
 361
 362 (defbinding drag-status () nil
 363   (context drag-context)
 364   (action drag-action)
 365   (time (unsigned 32)))
 366
 367
 368
 369
 370
 371
 372 ;;
 373
 374 (defbinding rgb-init () nil)
 375
 376
 377
 378
 379 ;;; Cursor
 380
 381 (defmethod initialize-instance ((cursor cursor) &key type mask fg bg
 382                                 (x 0) (y 0) (display (display-get-default)))
 383   (setf
 384    (slot-value cursor 'location)
 385    (etypecase type
 386      (keyword (%cursor-new-for-display display type))
 387      (pixbuf (%cursor-new-from-pixbuf display type x y))
 388      (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))))
 389
 390
 391 (defbinding %cursor-new-for-display () pointer
 392   (display display)
 393   (cursor-type cursor-type))
 394
 395 (defbinding %cursor-new-from-pixmap () pointer
 396   (source pixmap)
 397   (mask bitmap)
 398   (foreground color)
 399   (background color)
 400   (x int) (y int))
 401
 402 (defbinding %cursor-new-from-pixbuf () pointer
 403   (display display)
 404   (pixbuf pixbuf)
 405   (x int) (y int))
 406
 407 (defbinding %cursor-ref () pointer
 408   (location pointer))
 409
 410 (defbinding %cursor-unref () nil
 411   (location pointer))
 412
 413 (defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
 414   (declare (ignore class))
 415   (%cursor-ref location))
 416
 417 (defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
 418   (declare (ignore class))
 419   (%cursor-unref location))
 420
 421
 422 ;;; Pixmaps
 423
 424 (defbinding pixmap-new (width height depth &key window) pixmap
 425   (width int)
 426   (height int)
 427   (depth int)
 428   (window (or null window)))
 429
 430 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 431   (window (or null window))
 432   (colormap (or null colormap))
 433   (mask bitmap :out)
 434   (color (or null color))
 435   (filename string))
 436
 437 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 438   (window (or null window))
 439   (colormap (or null colormap))
 440   (mask bitmap :out)
 441   (color (or null color))
 442   (data (vector string)))
 443
 444 (defun pixmap-create (source &key color window colormap)
 445   (let ((window
 446          (if (not (or window colormap))
 447              (get-root-window)
 448            window)))
 449     (multiple-value-bind (pixmap mask)
 450         (etypecase source
 451           ((or string pathname)
 452            (%pixmap-colormap-create-from-xpm
 453             window colormap color (namestring (truename source))))
 454           ((vector string)
 455            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 456 ;;       (unreference-instance pixmap)
 457 ;;       (unreference-instance mask)
 458       (values pixmap mask))))
 459
 460
 461
 462 ;;; Color
 463
 464 (defun %scale-value (value)
 465   (etypecase value
 466     (integer value)
 467     (float (truncate (* value 65535)))))
 468
 469 (defmethod initialize-instance ((color color) &rest initargs
 470                                 &key red green blue)
 471   (declare (ignore initargs))
 472   (call-next-method)
 473   (with-slots ((%red red) (%green green) (%blue blue)) color
 474     (setf
 475      %red (%scale-value red)
 476      %green (%scale-value green)
 477      %blue (%scale-value blue))))
 478
 479 (defun ensure-color (color)
 480   (etypecase color
 481     (null nil)
 482     (color color)
 483     (vector
 484      (make-instance
 485       'color :red (svref color 0) :green (svref color 1)
 486       :blue (svref color 2)))))
 487
 488
 489
 490 ;;; Drawable
 491
 492 (defbinding drawable-get-size () nil
 493   (drawable drawable)
 494   (width int :out)
 495   (height int :out))
 496
 497 (defbinding (drawable-width "gdk_drawable_get_size") () nil
 498   (drawable drawable)
 499   (width int :out)
 500   (nil null))
 501
 502 (defbinding (drawable-height "gdk_drawable_get_size") () nil
 503   (drawable drawable)
 504   (nil null)
 505   (height int :out))
 506
 507 ;; (defbinding drawable-get-clip-region () region
 508 ;;   (drawable drawable))
 509
 510 ;; (defbinding drawable-get-visible-region () region
 511 ;;   (drawable drawable))
 512
 513 (defbinding draw-point () nil
 514   (drawable drawable) (gc gc)
 515   (x int) (y int))
 516
 517 (defbinding %draw-points () nil
 518   (drawable drawable) (gc gc)
 519   (points pointer)
 520   (n-points int))
 521
 522 ;; (defun draw-points (drawable gc &rest points)
 523
 524 ;;   )
 525
 526 (defbinding draw-line () nil
 527   (drawable drawable) (gc gc)
 528   (x1 int) (y1 int)
 529   (x2 int) (y2 int))
 530
 531 ;; (defbinding draw-lines (drawable gc &rest points) nil
 532 ;;   (drawable drawable) (gc gc)
 533 ;;   (points (vector point))
 534 ;;   ((length points) int))
 535
 536 (defbinding draw-pixbuf
 537     (drawable gc pixbuf src-x src-y dest-x dest-y &optional
 538      width height (dither :none) (x-dither 0) (y-dither 0)) nil
 539   (drawable drawable) (gc (or null gc))
 540   (pixbuf pixbuf)
 541   (src-x int) (src-y int)
 542   (dest-x int) (dest-y int)
 543   ((or width -1) int) ((or height -1) int)
 544   (dither rgb-dither)
 545   (x-dither int) (y-dither int))
 546
 547 ;; (defbinding draw-segments (drawable gc &rest points) nil
 548 ;;   (drawable drawable) (gc gc)
 549 ;;   (segments (vector segments))
 550 ;;   ((length segments) int))
 551
 552 (defbinding draw-rectangle () nil
 553   (drawable drawable) (gc gc)
 554   (filled boolean)
 555   (x int) (y int)
 556   (width int) (height int))
 557
 558 (defbinding draw-arc () nil
 559   (drawable drawable) (gc gc)
 560   (filled boolean)
 561   (x int) (y int)
 562   (width int) (height int)
 563   (angle1 int) (angle2 int))
 564
 565 ;; (defbinding draw-polygon (drawable gc &rest points) nil
 566 ;;   (drawable drawable) (gc gc)
 567 ;;   (points (vector point))
 568 ;;   ((length points) int))
 569
 570 ;; (defbinding draw-trapezoid (drawable gc &rest points) nil
 571 ;;   (drawable drawable) (gc gc)
 572 ;;   (points (vector point))
 573 ;;   ((length points) int))
 574
 575 ;; (defbinding %draw-layout-line () nil
 576 ;;   (drawable drawable) (gc gc)
 577 ;;   (font pango:font)
 578 ;;   (x int) (y int)
 579 ;;   (line pango:layout-line))
 580
 581 ;; (defbinding %draw-layout-line-with-colors () nil
 582 ;;   (drawable drawable) (gc gc)
 583 ;;   (font pango:font)
 584 ;;   (x int) (y int)
 585 ;;   (line pango:layout-line)
 586 ;;   (foreground (or null color))
 587 ;;   (background (or null color)))
 588
 589 ;; (defun draw-layout-line (drawable gc font x y line &optional foreground background)
 590 ;;   (if (or foreground background)
 591 ;;       (%draw-layout-line-with-colors drawable gc font x y line foreground background)
 592 ;;     (%draw-layout-line drawable gc font x y line)))
 593
 594 (defbinding %draw-layout () nil
 595   (drawable drawable) (gc gc)
 596   (font pango:font)
 597   (x int) (y int)
 598   (layout pango:layout))
 599
 600 (defbinding %draw-layout-with-colors () nil
 601   (drawable drawable) (gc gc)
 602   (font pango:font)
 603   (x int) (y int)
 604   (layout pango:layout)
 605   (foreground (or null color))
 606   (background (or null color)))
 607
 608 (defun draw-layout (drawable gc font x y layout &optional foreground background)
 609   (if (or foreground background)
 610       (%draw-layout-with-colors drawable gc font x y layout foreground background)
 611     (%draw-layout drawable gc font x y layout)))
 612
 613 (defbinding draw-drawable
 614     (drawable gc src src-x src-y dest-x dest-y &optional width height) nil
 615   (drawable drawable) (gc gc)
 616   (src drawable)
 617   (src-x int) (src-y int)
 618   (dest-x int) (dest-y int)
 619   ((or width -1) int) ((or height -1) int))
 620
 621 (defbinding draw-image
 622     (drawable gc image src-x src-y dest-x dest-y &optional width height) nil
 623   (drawable drawable) (gc gc)
 624   (image image)
 625   (src-x int) (src-y int)
 626   (dest-x int) (dest-y int)
 627   ((or width -1) int) ((or height -1) int))
 628
 629 (defbinding drawable-get-image () image
 630   (drawable drawable)
 631   (x int) (y int)
 632   (width int) (height int))
 633
 634 (defbinding drawable-copy-to-image
 635     (drawable src-x src-y width height &optional image dest-x dest-y) image
 636   (drawable drawable)
 637   (image (or null image))
 638   (src-x int) (src-y int)
 639   ((if image dest-x 0) int)
 640   ((if image dest-y 0) int)
 641   (width int) (height int))
 642
 643
 644 ;;; Key values
 645
 646 (defbinding keyval-name () string
 647   (keyval unsigned-int))
 648
 649 (defbinding keyval-from-name () unsigned-int
 650   (name string))
 651
 652 (defbinding keyval-to-upper () unsigned-int
 653   (keyval unsigned-int))
 654
 655 (defbinding keyval-to-lower ()unsigned-int
 656   (keyval unsigned-int))
 657
 658 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 659   (keyval unsigned-int))
 660
 661 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 662   (keyval unsigned-int))
 663