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.11 2004-11-06 21:39:58 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-new ... )
 170
 171 (defbinding window-destroy () nil
 172   (window window))
 173
 174
 175 ; (defbinding window-at-pointer () window
 176 ;   (window window)
 177 ;   (x int :in-out)
 178 ;   (y int :in-out))
 179
 180 (defbinding window-show () nil
 181   (window window))
 182
 183 (defbinding window-hide () nil
 184   (window window))
 185
 186 (defbinding window-withdraw () nil
 187   (window window))
 188
 189 (defbinding window-move () nil
 190   (window window)
 191   (x int)
 192   (y int))
 193
 194 (defbinding window-resize () nil
 195   (window window)
 196   (width int)
 197   (height int))
 198
 199 (defbinding window-move-resize () nil
 200   (window window)
 201   (x int)
 202   (y int)
 203   (width int)
 204   (height int))
 205
 206 (defbinding window-reparent () nil
 207   (window window)
 208   (new-parent window)
 209   (x int)
 210   (y int))
 211
 212 (defbinding window-clear () nil
 213   (window window))
 214
 215 (unexport
 216  '(window-clear-area-no-e window-clear-area-e))
 217
 218 (defbinding (window-clear-area-no-e "gdk_window_clear_area") () nil
 219   (window window)
 220   (x int) (y int) (width int) (height int))
 221
 222 (defbinding window-clear-area-e () nil
 223   (window window)
 224   (x int) (y int) (width int) (height int))
 225
 226 (defun window-clear-area (window x y width height &optional expose)
 227   (if expose
 228       (window-clear-area-e window x y width height)
 229     (window-clear-area-no-e window x y width height)))
 230
 231 ; (defbinding window-copy-area () nil
 232 ;   (window window)
 233 ;   (gc gc)
 234 ;   (x int)
 235 ;   (y int)
 236 ;   (source-window window)
 237 ;   (source-x int)
 238 ;   (source-y int)
 239 ;   (width int)
 240 ;   (height int))
 241
 242 (defbinding window-raise () nil
 243   (window window))
 244
 245 (defbinding window-lower () nil
 246   (window window))
 247
 248 ; (defbinding window-set-user-data () nil
 249
 250 (defbinding window-set-override-redirect () nil
 251   (window window)
 252   (override-redirect boolean))
 253
 254 ; (defbinding window-add-filter () nil
 255
 256 ; (defbinding window-remove-filter () nil
 257
 258 (defbinding window-shape-combine-mask () nil
 259   (window window)
 260   (shape-mask bitmap)
 261   (offset-x int)
 262   (offset-y int))
 263
 264 (defbinding window-set-child-shapes () nil
 265   (window window))
 266
 267 (defbinding window-merge-child-shapes () nil
 268   (window window))
 269
 270 (defbinding (window-is-visible-p "gdk_window_is_visible") () boolean
 271   (window window))
 272
 273 (defbinding (window-is-viewable-p "gdk_window_is_viewable") () boolean
 274   (window window))
 275
 276 (defbinding window-set-static-gravities () boolean
 277   (window window)
 278   (use-static boolean))
 279
 280 ; (defbinding add-client-message-filter ...
 281
 282
 283 ;;; Drag and Drop
 284
 285 ;; Destination side
 286
 287 (defbinding drag-status () nil
 288   (context drag-context)
 289   (action drag-action)
 290   (time (unsigned 32)))
 291
 292
 293
 294
 295 (defbinding window-set-cursor () nil
 296   (window window)
 297   (cursor cursor))
 298
 299 (defbinding window-get-pointer () window
 300   (window window)
 301   (x int :out)
 302   (y int :out)
 303   (mask modifier-type :out))
 304
 305 (defbinding %get-default-root-window () window)
 306
 307 (defun get-root-window (&optional display)
 308   (if display
 309       (error "Not implemented")
 310     (%get-default-root-window)))
 311
 312
 313 ;;
 314
 315 (defbinding rgb-init () nil)
 316
 317
 318
 319
 320 ;;; Cursor
 321
 322 (defbinding cursor-new () cursor
 323   (cursor-type cursor-type))
 324
 325 (defbinding cursor-new-from-pixmap () cursor
 326   (source pixmap)
 327   (mask bitmap)
 328   (foreground color)
 329   (background color)
 330   (x int) (y int))
 331
 332 (defbinding %cursor-ref () pointer
 333   (location pointer))
 334
 335 (defbinding %cursor-unref () nil
 336   (location pointer))
 337
 338 (defmethod reference-foreign ((class (eql (find-class 'cursor))) location)
 339   (declare (ignore class))
 340   (%cursor-ref location))
 341
 342 (defmethod unreference-foreign ((class (eql (find-class 'cursor))) location)
 343   (declare (ignore class))
 344   (%cursor-unref location))
 345
 346
 347
 348
 349 ;;; Pixmaps
 350
 351 (defbinding pixmap-new (width height depth &key window) pixmap
 352   (width int)
 353   (height int)
 354   (depth int)
 355   (window (or null window)))
 356
 357 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 358   (window (or null window))
 359   (colormap (or null colormap))
 360   (mask bitmap :out)
 361   (color (or null color))
 362   (filename string))
 363
 364 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 365   (window (or null window))
 366   (colormap (or null colormap))
 367   (mask bitmap :out)
 368   (color (or null color))
 369   (data (vector string)))
 370
 371 (defun pixmap-create (source &key color window colormap)
 372   (let ((window
 373          (if (not (or window colormap))
 374              (get-root-window)
 375            window)))
 376     (multiple-value-bind (pixmap mask)
 377         (etypecase source
 378           ((or string pathname)
 379            (%pixmap-colormap-create-from-xpm
 380             window colormap color (namestring (truename source))))
 381           ((vector string)
 382            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 383 ;;       (unreference-instance pixmap)
 384 ;;       (unreference-instance mask)
 385       (values pixmap mask))))
 386
 387
 388
 389 ;;; Color
 390
 391 (defun %scale-value (value)
 392   (etypecase value
 393     (integer value)
 394     (float (truncate (* value 65535)))))
 395
 396 (defmethod initialize-instance ((color color) &rest initargs
 397                                 &key red green blue)
 398   (declare (ignore initargs))
 399   (call-next-method)
 400   (with-slots ((%red red) (%green green) (%blue blue)) color
 401     (setf
 402      %red (%scale-value red)
 403      %green (%scale-value green)
 404      %blue (%scale-value blue))))
 405
 406 (defun ensure-color (color)
 407   (etypecase color
 408     (null nil)
 409     (color color)
 410     (vector
 411      (make-instance
 412       'color :red (svref color 0) :green (svref color 1)
 413       :blue (svref color 2)))))
 414
 415
 416
 417 ;;; Drawing functions
 418
 419 (defbinding draw-rectangle () nil
 420   (drawable (or window pixmap bitmap))
 421   (gc gc) (filled boolean)
 422   (x int) (y int) (width int) (height int))
 423
 424
 425 ;;; Key values
 426
 427 (defbinding keyval-name () string
 428   (keyval unsigned-int))
 429
 430 (defbinding keyval-from-name () unsigned-int
 431   (name string))
 432
 433 (defbinding keyval-to-upper () unsigned-int
 434   (keyval unsigned-int))
 435
 436 (defbinding keyval-to-lower ()unsigned-int
 437   (keyval unsigned-int))
 438
 439 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 440   (keyval unsigned-int))
 441
 442 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 443   (keyval unsigned-int))
 444