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