blob: c57f6f9b4d4f3ee22018db5711674a7fbb3c783d (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
#| -*-Scheme-*-
$Id: $
|#
(declare (usual-integrations))
(load "ghelper.scm")
(load "discovery.scm")
(load-option 'FFI)
(C-include "prhello")
(load "generic-string-opers.scm")
(define get-vals car)
(define (get-proc-symbols input) (map car (cdr input)))
(define (apply-ith-thunk input i) ((cadr (list-ref (cdr input) i))))
(define (thing-to-string thing)
(let ((buff (open-output-string)))
(display thing buff)
(get-output-string buff)))
(define (discover-gui . input)
;(display (discover:named-opers-for 1))
(C-call "gtk_init" 0 null-alien)
(let* ((discovered-opers (apply discover:thunklist-for input))
(window (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_window_new" alien
(C-enum "GTK_WINDOW_TOPLEVEL"))
(if (alien-null? alien) (error "Could not create window."))
alien))
(hbox (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_hbox_new" alien 0 20)
(if (alien-null? alien) (error "Could not create hbox."))
alien))
(combo (let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_combo_box_new_text" alien)
(if (alien-null? alien) (error "Could not create combo."))
alien))
(labels (map (lambda (val)
(let ((alien (make-alien '|GtkWidget|)))
(C-call "gtk_label_new" alien (thing-to-string val))
(if (alien-null? alien) (error "Could not create label."))
alien))
(get-vals discovered-opers))))
(for-each (lambda (proc-symbol)
(C-call "gtk_combo_box_append_text" combo (thing-to-string proc-symbol)))
(get-proc-symbols discovered-opers))
(for-each (lambda (label) (C-call "gtk_container_add" hbox label)) labels)
(C-call "gtk_container_add" hbox combo)
(C-call "gtk_container_add" window hbox)
(C-call "gtk_window_set_title" window "Generic Operator Discovery")
(C-call "gtk_container_set_border_width" window 10)
(C-call "gtk_window_resize" window 250 20)
(C-call "g_signal_connect" combo "changed"
(C-callback "changed") ;trampoline
(C-callback ;callback ID
(lambda (w)
(let ((i (C-call "gtk_combo_box_get_active" combo)))
(discover-gui (apply-ith-thunk discovered-opers i))))))
(C-call "g_signal_connect" window "delete_event"
(C-callback "delete_event") ;trampoline
(C-callback ;callback ID
(lambda (w e)
(begin
(C-call "gtk_main_quit")
0))))
(C-call "gtk_widget_show_all" window)
(C-call "gtk_main")
window))
|
