chiark - git - mdw - clg/blob - gdk/gdk.lisp

   1 ;; Common Lisp bindings for GTK+ v1.2.x
   2 ;; Copyright (C) 1999 Espen S. Johnsen <espejohn@online.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.5 2000-10-05 17:19:26 espen Exp $
  19
  20
  21 (in-package "GDK")
  22
  23
  24 ;;; Events
  25
  26 ; (defmethod initialize-instance ((event event) &rest initargs &key)
  27 ;   (declare (ignore initargs))
  28 ;   (call-next-method)
  29 ;   )
  30
  31 (defun find-event-class (event-type)
  32   (find-class
  33    (ecase event-type
  34      (:delete 'delete-event)
  35      (:destroy  'destroy-event)
  36      (:expose 'expose-event)
  37      (:motion-notify 'motion-notify-event)
  38      (:button-press 'button-press-event)
  39      (:2button-press '2-button-press-event)
  40      (:3button-press '3-button-press-event)
  41      (:button-release 'button-release-event)
  42      (:key-press 'key-press-event)
  43      (:key-release 'key-release-event)
  44      (:enter-notify 'enter-notify-event)
  45      (:leave-notify 'leave-notify-event)
  46      (:focus-change 'focus-change-event)
  47      (:configure 'configure-event)
  48      (:map 'map-event)
  49      (:unmap 'unmap-event)
  50      (:property-notify 'property-notify-event)
  51      (:selection-clear 'selection-clear-event)
  52      (:selection-request 'selection-request-event)
  53      (:selection-notify 'selection-notify-event)
  54      (:proximity-in 'proximity-in-event)
  55      (:proximity-out 'proximity-out-event)
  56      (:drag-enter 'drag-enter-event)
  57      (:drag-leave 'drag-leave-event)
  58      (:drag-motion 'drag-motion-event)
  59      (:drag-status 'drag-status-event)
  60      (:drop-start 'drop-start-event)
  61      (:drop-finished 'drop-finished-event)
  62      (:client-event 'client-event-event)
  63      (:visibility-notify 'visibility-notify-event)
  64      (:no-expose 'no-expose-event)
  65      (:scroll 'scroll-event))))
  66
  67
  68 (deftype-method alien-copier event (type-spec)
  69   (declare (ignore type-spec))
  70   '%event-copy)
  71
  72 (deftype-method alien-deallocator event (type-spec)
  73   (declare (ignore type-spec))
  74   '%event-free)
  75
  76 (deftype-method translate-from-alien
  77     event (type-spec location &optional (alloc :reference))
  78   `(let ((location ,location))
  79      (unless (null-pointer-p location)
  80        (let ((event-class
  81               (find-event-class
  82                (funcall (get-reader-function 'event-type) location 0))))
  83          ,(ecase alloc
  84             (:copy '(ensure-alien-instance event-class location))
  85             (:static '(ensure-alien-instance event-class location :static t))
  86             (:reference '(ensure-alien-instance
  87                           event-class (%event-copy location))))))))
  88
  89
  90 (define-foreign event-poll-fd () int)
  91
  92 (define-foreign ("gdk_events_pending" events-pending-p) () boolean)
  93
  94 (define-foreign event-get () event)
  95
  96 (define-foreign event-peek () event)
  97
  98 (define-foreign event-get-graphics-expose () event
  99   (window window))
 100
 101 (define-foreign event-put () event
 102   (event event))
 103
 104 (define-foreign %event-copy (event &optional size) pointer
 105   (event (or event pointer)))
 106
 107 (define-foreign %event-free () nil
 108   (event (or event pointer)))
 109
 110 (define-foreign event-get-time () (unsigned 32)
 111   (event event))
 112
 113 ;(define-foreign event-handler-set () ...)
 114
 115 (define-foreign set-show-events () nil
 116   (show-events boolean))
 117
 118 ;;; Misc
 119
 120 (define-foreign set-use-xshm () nil
 121   (use-xshm boolean))
 122
 123 (define-foreign get-show-events () boolean)
 124
 125 (define-foreign get-use-xshm () boolean)
 126
 127 (define-foreign get-display () string)
 128
 129 ; (define-foreign time-get () (unsigned 32))
 130
 131 ; (define-foreign timer-get () (unsigned 32))
 132
 133 ; (define-foreign timer-set () nil
 134 ;   (milliseconds (unsigned 32)))
 135
 136 ; (define-foreign timer-enable () nil)
 137
 138 ; (define-foreign timer-disable () nil)
 139
 140 ; input ...
 141
 142 (define-foreign pointer-grab () int
 143   (window window)
 144   (owner-events boolean)
 145   (event-mask event-mask)
 146   (confine-to (or null window))
 147   (cursor (or null cursor))
 148   (time (unsigned 32)))
 149
 150 (define-foreign pointer-ungrab () nil
 151   (time (unsigned 32)))
 152
 153 (define-foreign keyboard-grab () int
 154   (window window)
 155   (owner-events boolean)
 156   (time (unsigned 32)))
 157
 158 (define-foreign keyboard-ungrab () nil
 159   (time (unsigned 32)))
 160
 161 (define-foreign ("gdk_pointer_is_grabbed" pointer-is-grabbed-p) () boolean)
 162
 163 (define-foreign screen-width () int)
 164 (define-foreign screen-height () int)
 165
 166 (define-foreign screen-width-mm () int)
 167 (define-foreign screen-height-mm () int)
 168
 169 (define-foreign flush () nil)
 170 (define-foreign beep () nil)
 171
 172 (define-foreign key-repeat-disable () nil)
 173 (define-foreign key-repeat-restore () nil)
 174
 175
 176
 177 ;;; Visuals
 178
 179 (define-foreign visual-get-best-depth () int)
 180
 181 (define-foreign visual-get-best-type () visual-type)
 182
 183 (define-foreign visual-get-system () visual)
 184
 185
 186 (define-foreign
 187   ("gdk_visual_get_best" %visual-get-best-with-nothing) () visual)
 188
 189 (define-foreign %visual-get-best-with-depth () visual
 190   (depth int))
 191
 192 (define-foreign %visual-get-best-with-type () visual
 193   (type visual-type))
 194
 195 (define-foreign %visual-get-best-with-both () visual
 196   (depth int)
 197   (type visual-type))
 198
 199 (defun visual-get-best (&key depth type)
 200   (cond
 201    ((and depth type) (%visual-get-best-with-both depth type))
 202    (depth (%visual-get-best-with-depth depth))
 203    (type (%visual-get-best-with-type type))
 204    (t (%visual-get-best-with-nothing))))
 205
 206 ;(define-foreign query-depths ..)
 207
 208 ;(define-foreign query-visual-types ..)
 209
 210 (define-foreign list-visuals () (glist visual))
 211
 212
 213 ;;; Windows
 214
 215 ; (define-foreign window-new ... )
 216
 217 (define-foreign window-destroy () nil
 218   (window window))
 219
 220
 221 ; (define-foreign window-at-pointer () window
 222 ;   (window window)
 223 ;   (x int :in-out)
 224 ;   (y int :in-out))
 225
 226 (define-foreign window-show () nil
 227   (window window))
 228
 229 (define-foreign window-hide () nil
 230   (window window))
 231
 232 (define-foreign window-withdraw () nil
 233   (window window))
 234
 235 (define-foreign window-move () nil
 236   (window window)
 237   (x int)
 238   (y int))
 239
 240 (define-foreign window-resize () nil
 241   (window window)
 242   (width int)
 243   (height int))
 244
 245 (define-foreign window-move-resize () nil
 246   (window window)
 247   (x int)
 248   (y int)
 249   (width int)
 250   (height int))
 251
 252 (define-foreign window-reparent () nil
 253   (window window)
 254   (new-parent window)
 255   (x int)
 256   (y int))
 257
 258 (define-foreign window-clear () nil
 259   (window window))
 260
 261 (unexport
 262  '(window-clear-area-no-e window-clear-area-e))
 263
 264 (define-foreign ("gdk_window_clear_area" window-clear-area-no-e) () nil
 265   (window window)
 266   (x int) (y int) (width int) (height int))
 267
 268 (define-foreign window-clear-area-e () nil
 269   (window window)
 270   (x int) (y int) (width int) (height int))
 271
 272 (defun window-clear-area (window x y width height &optional expose)
 273   (if expose
 274       (window-clear-area-e window x y width height)
 275     (window-clear-area-no-e window x y width height)))
 276
 277 ; (define-foreign window-copy-area () nil
 278 ;   (window window)
 279 ;   (gc gc)
 280 ;   (x int)
 281 ;   (y int)
 282 ;   (source-window window)
 283 ;   (source-x int)
 284 ;   (source-y int)
 285 ;   (width int)
 286 ;   (height int))
 287
 288 (define-foreign window-raise () nil
 289   (window window))
 290
 291 (define-foreign window-lower () nil
 292   (window window))
 293
 294 ; (define-foreign window-set-user-data () nil
 295
 296 (define-foreign window-set-override-redirect () nil
 297   (window window)
 298   (override-redirect boolean))
 299
 300 ; (define-foreign window-add-filter () nil
 301
 302 ; (define-foreign window-remove-filter () nil
 303
 304 (define-foreign window-shape-combine-mask () nil
 305   (window window)
 306   (shape-mask bitmap)
 307   (offset-x int)
 308   (offset-y int))
 309
 310 (define-foreign window-set-child-shapes () nil
 311   (window window))
 312
 313 (define-foreign window-merge-child-shapes () nil
 314   (window window))
 315
 316 (define-foreign ("gdk_window_is_visible" window-is-visible-p) () boolean
 317   (window window))
 318
 319 (define-foreign ("gdk_window_is_viewable" window-is-viewable-p) () boolean
 320   (window window))
 321
 322 (define-foreign window-set-static-gravities () boolean
 323   (window window)
 324   (use-static boolean))
 325
 326 ; (define-foreign add-client-message-filter ...
 327
 328
 329 ;;; Drag and Drop
 330
 331 (define-foreign drag-context-new () drag-context)
 332
 333 (define-foreign drag-context-ref () nil
 334   (context drag-context))
 335
 336 (define-foreign drag-context-unref () nil
 337   (context drag-context))
 338
 339 ;; Destination side
 340
 341 (define-foreign drag-status () nil
 342   (context drag-context)
 343   (action drag-action)
 344   (time (unsigned 32)))
 345
 346
 347
 348
 349 (define-foreign window-set-cursor () nil
 350   (window window)
 351   (cursor cursor))
 352
 353 (define-foreign window-get-pointer () window
 354   (window window)
 355   (x int :out)
 356   (y int :out)
 357   (mask modifier-type :out))
 358
 359 (define-foreign get-root-window () window)
 360
 361
 362
 363 ;;
 364
 365 (define-foreign rgb-init () nil)
 366
 367
 368
 369
 370 ;;; Cursor
 371
 372 (deftype-method alien-ref cursor (type-spec)
 373   (declare (ignore type-spec))
 374   '%cursor-ref)
 375
 376 (deftype-method alien-unref cursor (type-spec)
 377   (declare (ignore type-spec))
 378   '%cursor-unref)
 379
 380
 381 (define-foreign cursor-new () cursor
 382   (cursor-type cursor-type))
 383
 384 (define-foreign cursor-new-from-pixmap () cursor
 385   (source pixmap)
 386   (mask bitmap)
 387   (foreground color)
 388   (background color)
 389   (x int) (y int))
 390
 391 (define-foreign %cursor-ref () pointer
 392   (cursor (or cursor pointer)))
 393
 394 (define-foreign %cursor-unref () nil
 395   (cursor (or cursor pointer)))
 396
 397
 398
 399 ;;; Pixmaps
 400
 401 ;; See the class definition for an explanation of this
 402 (deftype-method alien-ref bitmap (type-spec)
 403   (declare (ignore type-spec))
 404   '%drawable-ref)
 405
 406 (deftype-method alien-unref bitmap (type-spec)
 407   (declare (ignore type-spec))
 408   '%drawable-unref)
 409
 410 (define-foreign %drawable-ref () pointer
 411   (object (or bitmap pointer)))
 412
 413 (define-foreign %drawable-unref () nil
 414   (object (or bitmap pointer)))
 415
 416
 417 (define-foreign pixmap-new (width height depth &key window) pixmap
 418   (width int)
 419   (height int)
 420   (depth int)
 421   (window (or null window)))
 422
 423 (define-foreign %pixmap-colormap-create-from-xpm () pixmap
 424   (window (or null window))
 425   (colormap (or null colormap))
 426   (mask bitmap :out)
 427   (color (or null color))
 428   (filename string))
 429
 430 (define-foreign %pixmap-colormap-create-from-xpm-d () pixmap
 431   (window (or null window))
 432   (colormap (or null colormap))
 433   (mask bitmap :out)
 434   (color (or null color))
 435   (data (vector string)))
 436
 437 (defun pixmap-create (source &key color window colormap)
 438   (let ((window
 439          (if (not (or window colormap))
 440              (get-root-window)
 441            window)))
 442     (multiple-value-bind (pixmap mask)
 443         (etypecase source
 444           ((or string pathname)
 445            (%pixmap-colormap-create-from-xpm
 446             window colormap color (namestring (truename source))))
 447           ((vector string)
 448            (%pixmap-colormap-create-from-xpm-d window colormap color source)))
 449       (unreference-instance pixmap)
 450       (unreference-instance mask)
 451       (values pixmap mask))))
 452
 453
 454
 455 ;;; Color
 456
 457 (defun %scale-value (value)
 458   (etypecase value
 459     (integer value)
 460     (float (truncate (* value 65535)))))
 461
 462 (defmethod initialize-instance ((color color) &rest initargs
 463                                 &key red green blue)
 464   (declare (ignore initargs))
 465   (call-next-method)
 466   (with-slots ((%red red) (%green green) (%blue blue)) color
 467     (setf
 468      %red (%scale-value red)
 469      %green (%scale-value green)
 470      %blue (%scale-value blue))))
 471
 472
 473 (defun ensure-color (color)
 474   (etypecase color
 475     (null nil)
 476     (color color)
 477     (vector
 478      (make-instance
 479       'color :red (svref color 0) :green (svref color 1)
 480       :blue (svref color 2)))))
 481
 482
 483
 484 ;;; Fonts
 485
 486 (define-foreign font-load () font
 487   (font-name string))
 488
 489 (defun ensure-font (font)
 490   (etypecase font
 491     (null nil)
 492     (font font)
 493     (string (font-load font))))
 494
 495 (define-foreign fontset-load () font
 496   (fontset-name string))
 497
 498 (define-foreign font-ref () font
 499   (font font))
 500
 501 (define-foreign font-unref () nil
 502   (font font))
 503
 504 (defun font-maybe-unref (font1 font2)
 505   (unless (eq font1 font2)
 506     (font-unref font1)))
 507
 508 (define-foreign font-id () int
 509   (font font))
 510
 511 (define-foreign ("gdk_font_equal" font-equalp) () boolean
 512   (font-a font)
 513   (font-b font))
 514
 515 (define-foreign string-width () int
 516   (font font)
 517   (string string))
 518
 519 (define-foreign text-width
 520     (font text &aux (length (length text))) int
 521   (font font)
 522   (text string)
 523   (length int))
 524
 525 ; (define-foreign ("gdk_text_width_wc" text-width-wc)
 526 ;     (font text &aux (length (length text))) int
 527 ;   (font font)
 528 ;   (text string)
 529 ;   (length int))
 530
 531 (define-foreign char-width () int
 532   (font font)
 533   (char char))
 534
 535 ; (define-foreign ("gdk_char_width_wc" char-width-wc) () int
 536 ;   (font font)
 537 ;   (char char))
 538
 539
 540 (define-foreign string-measure () int
 541   (font font)
 542   (string string))
 543
 544 (define-foreign text-measure
 545     (font text &aux (length (length text))) int
 546   (font font)
 547   (text string)
 548   (length int))
 549
 550 (define-foreign char-measure () int
 551   (font font)
 552   (char char))
 553
 554 (define-foreign string-height () int
 555   (font font)
 556   (string string))
 557
 558 (define-foreign text-height
 559     (font text &aux (length (length text))) int
 560   (font font)
 561   (text string)
 562   (length int))
 563
 564 (define-foreign char-height () int
 565   (font font)
 566   (char char))
 567
 568
 569 ;;; Drawing functions
 570
 571 (define-foreign draw-rectangle () nil
 572   (drawable (or window pixmap bitmap))
 573   (gc gc) (filled boolean)
 574   (x int) (y int) (width int) (height int))
 575
 576
 577 ;;; Key values
 578
 579 (define-foreign keyval-name () string
 580   (keyval unsigned-int))
 581
 582 (define-foreign keyval-from-name () unsigned-int
 583   (name string))
 584
 585 (define-foreign keyval-to-upper () unsigned-int
 586   (keyval unsigned-int))
 587
 588 (define-foreign keyval-to-lower ()unsigned-int
 589   (keyval unsigned-int))
 590
 591 (define-foreign ("gdk_keyval_is_upper" keyval-is-upper-p) () boolean
 592   (keyval unsigned-int))
 593
 594 (define-foreign ("gdk_keyval_is_lower" keyval-is-lower-p) () boolean
 595   (keyval unsigned-int))
 596