gui/gui-lib/mred/private/wx/gtk/radio-box.rkt
Matthew Flatt 5b7bf69a13 HiDPI support on Unix (Gtk2)
Support GUI scaling in much the same way as on Windows, where
the OS setting ("org.gnome.desktop.interface.scaling-factor"
times "...text-scaling-factor") determines the scale that is
used for both graphics and GUI sizing.

As I understand it, a complete solution requires porting to
Gtk3. With Gtk2, the graphical part of a widget doesn't scale.
Text and image labels should scale correctly, though.
2015-08-01 18:06:12 -06:00

132 lines
4.7 KiB
Racket

#lang racket/base
(require racket/class
ffi/unsafe
"../../syntax.rkt"
"item.rkt"
(except-in "utils.rkt" _GSList)
"types.rkt"
"widget.rkt"
"window.rkt"
"pixbuf.rkt"
"message.rkt"
"../common/event.rkt"
"../../lock.rkt")
(provide
(protect-out radio-box%))
;; ----------------------------------------
(define _GSList (_cpointer/null 'GSList))
(define-gtk gtk_radio_button_new_with_mnemonic (_fun _GSList _string -> _GtkWidget))
(define-gtk gtk_radio_button_new (_fun _GSList -> _GtkWidget))
(define-gtk gtk_radio_button_get_group (_fun _GtkWidget -> _GSList))
(define-gtk gtk_radio_button_set_group (_fun _GtkWidget _GSList -> _void))
(define-gtk gtk_toggle_button_set_active (_fun _GtkWidget _gboolean -> _void))
(define-gtk gtk_toggle_button_get_active (_fun _GtkWidget -> _gboolean))
(define-gtk gtk_widget_is_focus (_fun _GtkWidget -> _gboolean))
(define-gtk gtk_bin_get_child (_fun _GtkWidget -> _GtkWidget))
(define-signal-handler connect-clicked "clicked"
(_fun _GtkWidget -> _void)
(lambda (gtk)
(let ([wx (gtk->wx gtk)])
(when wx
(send wx queue-clicked)))))
(defclass radio-box% item%
(init parent cb label
x y w h
labels
val
style
font)
(inherit set-auto-size
on-set-focus)
(define gtk (as-gtk-allocation
(if (memq 'horizontal style)
(gtk_hbox_new #f 0)
(gtk_vbox_new #f 0))))
(define radio-gtks (for/list ([lbl (in-list labels)])
(atomically
(let ([radio-gtk (cond
[(string? lbl)
(gtk_radio_button_new_with_mnemonic #f (mnemonic-string lbl))]
[else
(let ([pixbuf (bitmap->pixbuf lbl (->screen 1.0))])
(let ([radio-gtk (gtk_radio_button_new #f)]
[image-gtk (gtk_image_new_from_pixbuf pixbuf)])
(release-pixbuf pixbuf)
(gtk_container_add radio-gtk image-gtk)
(gtk_widget_show image-gtk)
radio-gtk))])])
(gtk_box_pack_start gtk radio-gtk #t #t 0)
(install-control-font (gtk_bin_get_child radio-gtk) font)
(gtk_widget_show radio-gtk)
radio-gtk))))
(for ([radio-gtk (in-list (cdr radio-gtks))])
(let ([g (gtk_radio_button_get_group (car radio-gtks))])
(gtk_radio_button_set_group radio-gtk g)))
(define dummy-gtk #f)
(super-new [parent parent]
[gtk gtk]
[extra-gtks radio-gtks]
[callback cb]
[no-show? (memq 'deleted style)])
(set-auto-size)
(for ([radio-gtk (in-list radio-gtks)])
(connect-clicked radio-gtk)
(connect-key-and-mouse radio-gtk)
(connect-focus radio-gtk))
(define callback cb)
(define/public (clicked)
(callback this (new control-event%
[event-type 'radio-box]
[time-stamp (current-milliseconds)])))
(define no-clicked? #f)
(define/public (queue-clicked)
(unless no-clicked?
(queue-window-event this (lambda () (clicked)))))
(define/public (button-focus i)
(if (= i -1)
(or (for/or ([radio-gtk (in-list radio-gtks)]
[i (in-naturals)])
(and (gtk_widget_is_focus radio-gtk)
i))
0)
(gtk_widget_grab_focus (list-ref radio-gtks i))))
(define/override (set-focus)
(button-focus (max 0 (get-selection))))
(define/public (set-selection i)
(atomically
(set! no-clicked? #t)
(if (= i -1)
(when (pair? radio-gtks)
(unless dummy-gtk
(set! dummy-gtk (as-gtk-allocation
(gtk_radio_button_new
(gtk_radio_button_get_group (car radio-gtks))))))
(gtk_toggle_button_set_active dummy-gtk #t))
(gtk_toggle_button_set_active (list-ref radio-gtks i) #t))
(set! no-clicked? #f)))
(define/public (get-selection)
(or (for/or ([radio-gtk (in-list radio-gtks)]
[i (in-naturals)])
(and (gtk_toggle_button_get_active radio-gtk)
i))
-1))
(define/public (enable-button i on?)
(gtk_widget_set_sensitive (list-ref radio-gtks i) on?))
(define count (length labels))
(define/public (number) count))