demostuff.tl


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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122

(defun letter-to-type (ch)
  (caseql ch
    (#\v 'void)
    (#\x 'cptr)
    (#\i 'int)
    (#\l 'long)
    (#\f 'float)
    (#\d 'double)
    (#\s 'str)
    (#\y 'closure)))

(defmacro df (name sig)
  (let ((si (list-str (symbol-name sig))))
    ^(deffi ,name ,(symbol-name name) ,(letter-to-type (car si))
       ,[mapcar letter-to-type (cdr si)])))

(with-dyn-lib "libgtk-3.so.0"
  (df gtk_application_window_new  xx)
  (df gtk_window_set_title        vxs)
  (df gtk_window_set_default_size vxii)
  (df gtk_button_box_new          xi)
  (df gtk_size_group_new          xi)
  (df gtk_bin_get_child           xx)
  #;(df gtk_label_set_xalign        vxf)
  (df gtk_container_add           vxx)
  (df gtk_label_new               xs)
  (df gtk_label_set_text          vxs)
  (df gtk_button_set_label        vxs)
  (df gtk_button_get_label        sx)
  (df gtk_button_new_with_label   xs)
  (df gtk_widget_destroy          xx)
  (df gtk_application_new         xsi)
  (df g_application_run           ixix)
  (df g_object_unref              vx)
  (df gtk_widget_show_all         vx)
  (df g_signal_connect_data       lxsyxxi))

(deffi-cb button-cb void (cptr cptr))

(deffi-cb app-cb void (cptr cptr))

(defsymacro null cptr-null)

(defun callbackname (object)
  (make-sym `@object-cb`))

; window establishes a Gtk window object.
; The arguments are, what window object to establish, what
; application the window is used in, the window title, and
; the width and height of the window.
(defmacro window (awin app title wid ht)
  ^(progn
     (defparm ,awin (gtk_application_window_new ,app))
     (gtk_window_set_title ,awin ,title)
     (gtk_window_set_default_size ,awin ,wid ,ht)))

; box establishes a box object.  The arguments are, whether the box
; contents are organized horizontally or vertically (h or v), what
; box is to be established, and what object to place the box in.
(defmacro box (hv abox placement)
  (let ((horizvert (caseql hv
                     (h 0) (v 1)
                     (t (error "The first argument to box should \
                               \ be h or v, not ~a" hv)))))
    ^(progn
       (defparm ,abox nil)
       (progn
         (set ,abox (gtk_button_box_new ,horizvert))
         (gtk_container_add ,placement ,abox)))))

; button establishes a Gtk button object.  The arguments are,
; the name of the button object, the text shown on the button,
; what object to place the button in, and the action of the
; button, which can be any sequence of code.
(defmacro button (abutton buttonlabel placement . body)
  (let ((cb (callbackname abutton)))
    ^(progn
       (defparm ,abutton nil)
       (defun ,cb (a b)
         ,*body)
       (set ,abutton (gtk_button_new_with_label ,buttonlabel))
       (g_signal_connect_data ,abutton "clicked" [button-cb ,cb]
                              null null 0)
       (gtk_container_add ,placement ,abutton))))

; mbutton is like button, except that the button label text will be
; left aligned instead of centered, to make it neater in a column of
; buttons, such as for a menu.
(defmacro mbutton (abutton buttonlabel placement . body)
  ^(progn
     (button ,abutton ,buttonlabel ,placement ,*body)
     (let ((thelabel (gtk_bin_get_child ,abutton)))
       #;(gtk_label_set_xalign thelabel 0.0))))

; text establishes a Gtk "label" object which is actually a text
; display object.  The arguments are, what text object to
; establish, the initial text to display, and what object to
; place this text object in.
(defmacro text (atext text0 placement)
  ^(progn
     (defparm ,atext (gtk_label_new ,text0))
     (gtk_container_add ,placement ,atext)))

; xtext changes the text in a text object.
(defun xtext (textobject newtext)
  (gtk_label_set_text textobject newtext))

; xlabel changes the text label on a button.
(defun xlabel (button newtext)
  (gtk_button_set_label button newtext))

; gapp establishes a Gtk application.  The arguments are,
; the name of the application object, and the code to be
; executed by the application.
(defmacro gapp (theapp . body)
  (let ((cb (callbackname theapp)))
    ^(progn
       (defparm ,theapp nil)
       (defun ,cb (a b)
         ,*body)
       (set ,theapp (gtk_application_new nil 0))
       (g_signal_connect_data ,theapp "activate" [app-cb ,cb] null null 0))))