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.6 2001-05-11 16:19:07 espen Exp $
  19
  20
  21 (in-package "GDK")
  22
  23
  24 ;;; Events
  25
  26 (defbinding event-poll-fd () 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-root-window () window)
 275
 276
 277
 278 ;;
 279
 280 (defbinding rgb-init () nil)
 281
 282
 283
 284
 285 ;;; Cursor
 286
 287 (deftype-method alien-ref cursor (type-spec)
 288   (declare (ignore type-spec))
 289   '%cursor-ref)
 290
 291 (deftype-method alien-unref cursor (type-spec)
 292   (declare (ignore type-spec))
 293   '%cursor-unref)
 294
 295
 296 (defbinding cursor-new () cursor
 297   (cursor-type cursor-type))
 298
 299 (defbinding cursor-new-from-pixmap () cursor
 300   (source pixmap)
 301   (mask bitmap)
 302   (foreground color)
 303   (background color)
 304   (x int) (y int))
 305
 306 (defbinding %cursor-ref () pointer
 307   (cursor (or cursor pointer)))
 308
 309 (defbinding %cursor-unref () nil
 310   (cursor (or cursor pointer)))
 311
 312
 313
 314 ;;; Pixmaps
 315 #|
 316 (defbinding pixmap-new (width height depth &key window) pixmap
 317   (width int)
 318   (height int)
 319   (depth int)
 320   (window (or null window)))
 321
 322 (defbinding %pixmap-colormap-create-from-xpm () pixmap
 323   (window (or null window))
 324   (colormap (or null colormap))
 325   (mask bitmap :out)
 326   (color (or null color))
 327   (filename string))
 328
 329 (defbinding %pixmap-colormap-create-from-xpm-d () pixmap
 330   (window (or null window))
 331   (colormap (or null colormap))
 332   (mask bitmap :out)
 333   (color (or null color))
 334   (data (vector string)))
 335
 336 (defun pixmap-create (source &key color window colormap)
 337   (let ((window
 338          (if (not (or window colormap))
 339              (get-root-window)
 340            window)))
 341     (multiple-value-bind (pixmap mask)
 342         (etypecase source
 343           ((or string pathname)
 344            (%pixmap-colormap-create-from-xpm
 345             window colormap color (namestring (truename source))))
 346           ((vector string)
 347            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 348       (unreference-instance pixmap)
 349       (unreference-instance mask)
 350       (values pixmap mask))))
 351 |#
 352
 353
 354 ;;; Color
 355
 356 (defun %scale-value (value)
 357   (etypecase value
 358     (integer value)
 359     (float (truncate (* value 65535)))))
 360
 361 (defmethod initialize-instance ((color color) &rest initargs
 362                                 &key red green blue)
 363   (declare (ignore initargs))
 364   (call-next-method)
 365   (with-slots ((%red red) (%green green) (%blue blue)) color
 366     (setf
 367      %red (%scale-value red)
 368      %green (%scale-value green)
 369      %blue (%scale-value blue))))
 370
 371 (defun ensure-color (color)
 372   (etypecase color
 373     (null nil)
 374     (color color)
 375     (vector
 376      (make-instance
 377       'color :red (svref color 0) :green (svref color 1)
 378       :blue (svref color 2)))))
 379
 380
 381
 382 ;;; Drawing functions
 383
 384 (defbinding draw-rectangle () nil
 385   (drawable (or window pixmap bitmap))
 386   (gc gc) (filled boolean)
 387   (x int) (y int) (width int) (height int))
 388
 389
 390 ;;; Key values
 391
 392 (defbinding keyval-name () string
 393   (keyval unsigned-int))
 394
 395 (defbinding keyval-from-name () unsigned-int
 396   (name string))
 397
 398 (defbinding keyval-to-upper () unsigned-int
 399   (keyval unsigned-int))
 400
 401 (defbinding keyval-to-lower ()unsigned-int
 402   (keyval unsigned-int))
 403
 404 (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 405   (keyval unsigned-int))
 406
 407 (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean
 408   (keyval unsigned-int))
 409