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.10 2004-10-31 11:51:08 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-get () display-manager)
  34
  35 (defbinding (display-set-default "gdk_display_manager_set_default_display")
  36     (display) nil
  37   ((%display-manager-get) display-manager)
  38   (display display))
  39
  40 (defbinding display-get-default () display)
  41
  42 (defbinding %display-open () display
  43   (display-name (or null string)))
  44
  45 (defun display-open (&optional display-name)
  46   (let ((display (%display-open display-name)))
  47     (unless (display-get-default)
  48       (display-set-default display))
  49     display))
  50
  51 (defbinding (display-connection-number "clg_gdk_connection_number")
  52     (&optional (display (display-get-default))) int
  53   (display display))
  54
  55
  56 ;;; Events
  57
  58 (defbinding (events-pending-p "gdk_events_pending") () boolean)
  59
  60 (defbinding event-get () event)
  61
  62 (defbinding event-peek () event)
  63
  64 (defbinding event-get-graphics-expose () event
  65   (window window))
  66
  67 (defbinding event-put () event
  68   (event event))
  69
  70 ;(defbinding event-handler-set () ...)
  71
  72 (defbinding set-show-events () nil
  73   (show-events boolean))
  74
  75 ;;; Misc
  76
  77 (defbinding set-use-xshm () nil
  78   (use-xshm boolean))
  79
  80 (defbinding get-show-events () boolean)
  81
  82 (defbinding get-use-xshm () boolean)
  83
  84 (defbinding get-display () string)
  85
  86 ; (defbinding time-get () (unsigned 32))
  87
  88 ; (defbinding timer-get () (unsigned 32))
  89
  90 ; (defbinding timer-set () nil
  91 ;   (milliseconds (unsigned 32)))
  92
  93 ; (defbinding timer-enable () nil)
  94
  95 ; (defbinding timer-disable () nil)
  96
  97 ; input ...
  98
  99 (defbinding pointer-grab () int
 100   (window window)
 101   (owner-events boolean)
 102   (event-mask event-mask)
 103   (confine-to (or null window))
 104   (cursor (or null cursor))
 105   (time (unsigned 32)))
 106
 107 (defbinding pointer-ungrab () nil
 108   (time (unsigned 32)))
 109
 110 (defbinding keyboard-grab () int
 111   (window window)
 112   (owner-events boolean)
 113   (time (unsigned 32)))
 114
 115 (defbinding keyboard-ungrab () nil
 116   (time (unsigned 32)))
 117
 118 (defbinding (pointer-is-grabbed-p "gdk_pointer_is_grabbed") () boolean)
 119
 120 (defbinding screen-width () int)
 121 (defbinding screen-height () int)
 122
 123 (defbinding screen-width-mm () int)
 124 (defbinding screen-height-mm () int)
 125
 126 (defbinding flush () nil)
 127 (defbinding beep () nil)
 128
 129
 130
 131 ;;; Visuals
 132
 133 (defbinding visual-get-best-depth () int)
 134
 135 (defbinding visual-get-best-type () visual-type)
 136
 137 (defbinding visual-get-system () visual)
 138
 139
 140 (defbinding (%visual-get-best-with-nothing "gdk_visual_get_best") () visual)
 141
 142 (defbinding %visual-get-best-with-depth () visual
 143   (depth int))
 144
 145 (defbinding %visual-get-best-with-type () visual
 146   (type visual-type))
 147
 148 (defbinding %visual-get-best-with-both () visual
 149   (depth int)
 150   (type visual-type))
 151
 152 (defun visual-get-best (&key depth type)
 153   (cond
 154    ((and depth type) (%visual-get-best-with-both depth type))
 155    (depth (%visual-get-best-with-depth depth))
 156    (type (%visual-get-best-with-type type))
 157    (t (%visual-get-best-with-nothing))))
 158
 159 ;(defbinding query-depths ..)
 160
 161 ;(defbinding query-visual-types ..)
 162
 163 (defbinding list-visuals () (glist visual))
 164
 165
 166 ;;; Windows
 167
 168 ; (defbinding window-new ... )
 169
 170 (defbinding window-destroy () nil
 171   (window window))
 172
 173
 174 ; (defbinding window-at-pointer () window
 175 ;   (window window)
 176 ;   (x int :in-out)
 177 ;   (y int :in-out))
 178
 179 (defbinding window-show () nil
 180   (window window))
 181
 182 (defbinding window-hide () nil
 183   (window window))
 184
 185 (defbinding window-withdraw () nil
 186   (window window))
 187
 188 (defbinding window-move () nil
 189   (window window)
 190   (x int)
 191   (y int))
 192
 193 (defbinding window-resize () nil
 194   (window window)
 195   (width int)
 196   (height int))
 197
 198 (defbinding window-move-resize () nil
 199   (window window)
 200   (x int)
 201   (y int)
 202   (width int)
 203   (height int))
 204
 205 (defbinding window-reparent () nil
 206   (window window)
 207   (new-parent window)
 208   (x int)
 209   (y int))
 210
 211 (defbinding window-clear () nil
 212   (window window))
 213
 214 (unexport
 215  '(window-clear-area-no-e window-clear-area-e))
 216
 217 (defbinding (window-clear-area-no-e "gdk_window_clear_area") () nil
 218   (window window)
 219   (x int) (y int) (width int) (height int))
 220
 221 (defbinding window-clear-area-e () nil
 222   (window window)
 223   (x int) (y int) (width int) (height int))
 224
 225 (defun window-clear-area (window x y width height &optional expose)
 226   (if expose
 227       (window-clear-area-e window x y width height)
 228     (window-clear-area-no-e window x y width height)))
 229
 230 ; (defbinding window-copy-area () nil
 231 ;   (window window)
 232 ;   (gc gc)
 233 ;   (x int)
 234 ;   (y int)
 235 ;   (source-window window)
 236 ;   (source-x int)
 237 ;   (source-y int)
 238 ;   (width int)
 239 ;   (height int))
 240
 241 (defbinding window-raise () nil
 242   (window window))
 243
 244 (defbinding window-lower () nil
 245   (window window))
 246
 247 ; (defbinding window-set-user-data () nil
 248
 249 (defbinding window-set-override-redirect () nil
 250   (window window)
 251   (override-redirect boolean))
 252
 253 ; (defbinding window-add-filter () nil
 254
 255 ; (defbinding window-remove-filter () nil
 256
 257 (defbinding window-shape-combine-mask () nil
 258   (window window)
 259   (shape-mask bitmap)
 260   (offset-x int)
 261   (offset-y int))
 262
 263 (defbinding window-set-child-shapes () nil
 264   (window window))
 265
 266 (defbinding window-merge-child-shapes () nil
 267   (window window))
 268
 269 (defbinding (window-is-visible-p "gdk_window_is_visible") () boolean
 270   (window window))
 271
 272 (defbinding (window-is-viewable-p "gdk_window_is_viewable") () boolean
 273   (window window))
 274
 275 (defbinding window-set-static-gravities () boolean
 276   (window window)
 277   (use-static boolean))
 278
 279 ; (defbinding add-client-message-filter ...
 280
 281
 282 ;;; Drag and Drop
 283
 284 ;; Destination side
 285
 286 (defbinding drag-status () nil
 287   (context drag-context)
 288   (action drag-action)
 289   (time (unsigned 32)))
 290
 291
 292
 293
 294 (defbinding window-set-cursor () nil
 295   (window window)
 296   (cursor cursor))
 297
 298 (defbinding window-get-pointer () window
 299   (window window)
 300   (x int :out)
 301   (y int :out)
 302   (mask modifier-type :out))
 303
 304 (defbinding %get-default-root-window () window)
 305
 306 (defun get-root-window (&optional display)
 307   (if display
 308       (error "Not implemented")
 309     (%get-default-root-window)))
 310
 311
 312 ;;
 313
 314 (defbinding rgb-init () nil)
 315
 316
 317
 318
 319 ;;; Cursor
 320
 321 (deftype-method alien-ref cursor (type-spec)
 322   (declare (ignore type-spec))
 323   '%cursor-ref)
 324
 325 (deftype-method alien-unref cursor (type-spec)
 326   (declare (ignore type-spec))
 327   '%cursor-unref)
 328
 329
 330 (defbinding cursor-new () cursor
 331   (cursor-type cursor-type))
 332
 333 (defbinding cursor-new-from-pixmap () cursor
 334   (source pixmap)
 335   (mask bitmap)
 336   (foreground color)
 337   (background color)
 338   (x int) (y int))
 339
 340 (defbinding %cursor-ref () pointer
 341   (cursor (or cursor pointer)))
 342
 343 (defbinding %cursor-unref () nil
 344   (cursor (or cursor pointer)))
 345
 346
 347
 348 ;;; Pixmaps
 349
 350 (defbinding pixmap-new (width height depth &key window) pixmap
 351   (width int)
 352   (height int)
 353   (depth int)
 354   (window (or null window)))
 355
 356 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 357   (window (or null window))
 358   (colormap (or null colormap))
 359   (mask bitmap :out)
 360   (color (or null color))
 361   (filename string))
 362
 363 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 364   (window (or null window))
 365   (colormap (or null colormap))
 366   (mask bitmap :out)
 367   (color (or null color))
 368   (data (vector string)))
 369
 370 (defun pixmap-create (source &key color window colormap)
 371   (let ((window
 372          (if (not (or window colormap))
 373              (get-root-window)
 374            window)))
 375     (multiple-value-bind (pixmap mask)
 376         (etypecase source
 377           ((or string pathname)
 378            (%pixmap-colormap-create-from-xpm
 379             window colormap color (namestring (truename source))))
 380           ((vector string)
 381            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 382 ;;       (unreference-instance pixmap)
 383 ;;       (unreference-instance mask)
 384       (values pixmap mask))))
 385
 386
 387
 388 ;;; Color
 389
 390 (defun %scale-value (value)
 391   (etypecase value
 392     (integer value)
 393     (float (truncate (* value 65535)))))
 394
 395 (defmethod initialize-instance ((color color) &rest initargs
 396                                 &key red green blue)
 397   (declare (ignore initargs))
 398   (call-next-method)
 399   (with-slots ((%red red) (%green green) (%blue blue)) color
 400     (setf
 401      %red (%scale-value red)
 402      %green (%scale-value green)
 403      %blue (%scale-value blue))))
 404
 405 (defun ensure-color (color)
 406   (etypecase color
 407     (null nil)
 408     (color color)
 409     (vector
 410      (make-instance
 411       'color :red (svref color 0) :green (svref color 1)
 412       :blue (svref color 2)))))
 413
 414
 415
 416 ;;; Drawing functions
 417
 418 (defbinding draw-rectangle () nil
 419   (drawable (or window pixmap bitmap))
 420   (gc gc) (filled boolean)
 421   (x int) (y int) (width int) (height int))
 422
 423
 424 ;;; Key values
 425
 426 (defbinding keyval-name () string
 427   (keyval unsigned-int))
 428
 429 (defbinding keyval-from-name () unsigned-int
 430   (name string))
 431
 432 (defbinding keyval-to-upper () unsigned-int
 433   (keyval unsigned-int))
 434
 435 (defbinding keyval-to-lower ()unsigned-int
 436   (keyval unsigned-int))
 437
 438 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 439   (keyval unsigned-int))
 440
 441 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 442   (keyval unsigned-int))
 443