f42356da3f
The main advantage of GTK+ 3 is better support for HiDPI displays. If GTK+ 3 libraries are not available or if the `PLT_GTK2` environment variable is defined, GTK+ 2 is used as before.
168 lines
4.3 KiB
Racket
168 lines
4.3 KiB
Racket
#lang racket/base
|
|
(require ffi/unsafe
|
|
"../../syntax.rkt"
|
|
"../../lock.rkt"
|
|
racket/class
|
|
racket/draw
|
|
"filedialog.rkt"
|
|
"colordialog.rkt"
|
|
"types.rkt"
|
|
"utils.rkt"
|
|
"style.rkt"
|
|
"widget.rkt"
|
|
"window.rkt"
|
|
"frame.rkt"
|
|
"dc.rkt"
|
|
"queue.rkt"
|
|
"printer-dc.rkt"
|
|
"gl-context.rkt"
|
|
"keycode.rkt"
|
|
"../common/default-procs.rkt"
|
|
"../common/handlers.rkt")
|
|
|
|
(provide
|
|
(protect-out
|
|
color-from-user-platform-mode
|
|
get-font-from-user
|
|
font-from-user-platform-mode
|
|
play-sound
|
|
find-graphical-system-path
|
|
register-collecting-blit
|
|
unregister-collecting-blit
|
|
shortcut-visible-in-label?
|
|
get-double-click-time
|
|
get-control-font-face
|
|
get-control-font-size
|
|
get-control-font-size-in-pixels?
|
|
cancel-quit
|
|
bell
|
|
hide-cursor
|
|
get-display-depth
|
|
is-color-display?
|
|
id-to-menu-item
|
|
can-show-print-setup?
|
|
get-highlight-background-color
|
|
get-highlight-text-color
|
|
check-for-break)
|
|
file-selector
|
|
show-print-setup
|
|
display-origin
|
|
display-size
|
|
display-bitmap-resolution
|
|
flush-display
|
|
location->window
|
|
make-screen-bitmap
|
|
make-gl-bitmap
|
|
file-creator-and-type
|
|
special-control-key
|
|
special-option-key
|
|
get-panel-background
|
|
fill-private-color
|
|
get-color-from-user
|
|
key-symbol-to-menu-key
|
|
needs-grow-box-spacer?
|
|
graphical-system-type)
|
|
|
|
(define (find-graphical-system-path what)
|
|
(case what
|
|
[(x-display) (string->path x11-display)]
|
|
[else #f]))
|
|
|
|
(define (cancel-quit) (void))
|
|
|
|
(define-unimplemented play-sound)
|
|
|
|
(define (color-from-user-platform-mode)
|
|
(and (color-dialog-works?)
|
|
'dialog))
|
|
|
|
(define (font-from-user-platform-mode) #f)
|
|
(define-unimplemented get-font-from-user)
|
|
|
|
(define (register-collecting-blit canvas x y w h on off on-x on-y off-x off-y)
|
|
(send canvas register-collecting-blit x y w h on off on-x on-y off-x off-y))
|
|
(define (unregister-collecting-blit canvas)
|
|
(send canvas unregister-collecting-blits))
|
|
(define (shortcut-visible-in-label? [mbar? #f]) #t)
|
|
|
|
(define _GtkSettings (_cpointer 'GtkSettings))
|
|
(define-gtk gtk_settings_get_default (_fun -> _GtkSettings))
|
|
(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f)
|
|
-> _void
|
|
-> r)
|
|
#:c-id g_object_get)
|
|
(define-gobj g_object_get/string (_fun _GtkSettings _string (r : (_ptr o _pointer)) (_pointer = #f)
|
|
-> _void
|
|
-> r)
|
|
#:c-id g_object_get)
|
|
|
|
(define (get-double-click-time)
|
|
(let ([s (gtk_settings_get_default)])
|
|
(if s
|
|
(g_object_get/int s "gtk-double-click-time")
|
|
250)))
|
|
(define (get-control-font proc default)
|
|
(or
|
|
(let ([s (gtk_settings_get_default)])
|
|
(and s
|
|
(let ([f (g_object_get/string s "gtk-font-name")])
|
|
(and f
|
|
(begin0
|
|
(cond
|
|
[(regexp-match #rx"^(.*) ([0-9]+)$" (cast f _pointer _string))
|
|
=> (lambda (m) (proc (cdr m)))]
|
|
[else #f])
|
|
(g_free f))))))
|
|
default))
|
|
(define (get-control-font-size)
|
|
(get-control-font (lambda (m) (string->number (cadr m)))
|
|
10))
|
|
(define (get-control-font-face)
|
|
(get-control-font (lambda (m) (car m))
|
|
"Sans"))
|
|
(define (get-control-font-size-in-pixels?) #f)
|
|
|
|
(define (get-display-depth) 32)
|
|
|
|
(define-gdk gdk_display_beep (_fun _GdkDisplay -> _void))
|
|
(define (bell) (gdk_display_beep (gdk_display_get_default)))
|
|
|
|
(define (hide-cursor) (void))
|
|
|
|
(define (is-color-display?) #t)
|
|
|
|
(define (id-to-menu-item i) i)
|
|
(define (can-show-print-setup?) #t)
|
|
|
|
(define (get-highlight-background-color)
|
|
(let-values ([(r g b) (get-selected-background-color)])
|
|
(make-object color% r g b)))
|
|
|
|
(define (get-highlight-text-color)
|
|
(let-values ([(r g b) (get-selected-text-color)])
|
|
(if (and (zero? r) (zero? g) (zero? b))
|
|
#f
|
|
(make-object color% r g b))))
|
|
|
|
(define/top (make-screen-bitmap [exact-positive-integer? w]
|
|
[exact-positive-integer? h])
|
|
(if (eq? 'unix (system-type))
|
|
(make-object x11-bitmap% w h #f)
|
|
(make-object bitmap% w h #f #t)))
|
|
|
|
(define/top (make-gl-bitmap [exact-positive-integer? w]
|
|
[exact-positive-integer? h]
|
|
[gl-config% c])
|
|
(let ([bm (make-object x11-bitmap% w h #f)])
|
|
(create-and-install-gl-context bm c)
|
|
bm))
|
|
|
|
(define (check-for-break) #f)
|
|
|
|
(define (needs-grow-box-spacer?) #f)
|
|
|
|
(define (graphical-system-type)
|
|
(cond
|
|
[gtk3? 'gtk3]
|
|
[else 'gtk2]))
|