/[lgtk]/lgtk/examples/packing-boxes.lisp
ViewVC logotype

Contents of /lgtk/examples/packing-boxes.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Mon Oct 27 19:14:45 2003 UTC (10 years, 5 months ago) by mmommer
Branch: MAIN, mmommer
CVS Tags: initial_checkin, HEAD
Branch point for: test-branch, sbcl-port
Changes since 1.1: +0 -0 lines
Initial checkin.
1 ;; The example on packing boxes from the gtk tutorial. Almost. The
2 ;; function takes the spacing as an argument (keep it small, this can
3 ;; crash gtk). I did not bother with case 3, since it does not test
4 ;; anything new.
5
6 (use-package :gtk)
7
8 (defun packing-boxes (spc)
9 (declare (optimize (debug 3)))
10 (let (show-list)
11 (labels ((show-later (x) (push x show-list) x)
12
13 (delete-handler (&rest stuff)
14 (declare (ignore stuff))
15 (gtk-main-quit)
16 0)
17
18 (make-box (homogeneous
19 spacing
20 expand
21 fill
22 padding)
23
24 (let ((box (gtk-hbox-new :homogeneous homogeneous
25 :spacing spacing)))
26 ;; Pull off the lispy thang.
27
28 (mapcar
29 #'(lambda (x)
30 (let ((button (gtk-button-new-with-label x)))
31 (gtk-box-pack-start box button
32 :expand expand
33 :fill fill
34 :padding padding)
35 (gtk-widget-show button)))
36 `("(gtk-box-pack" "box" "button"
37 ,(format nil ":expand ~S" expand)
38 ,(format nil ":fill ~S" fill)
39 ,(format nil ":padding ~S)" padding)))
40
41 box)))
42
43 ;; "Main"
44 (let ((window (show-later (gtk-window-new :gtk-window-toplevel)))
45 (vbox (show-later (gtk-vbox-new))))
46
47 (g-signal-connect window gtkdelete-event #'delete-handler)
48 (gtk-container-set-border-width window 10)
49 (gtk-container-add window vbox)
50 (gtk-window-set-title window "packing boxes")
51
52 (dolist (homogeneous '(nil t))
53
54 (let ((label (show-later
55 (gtk-label-new
56 (format nil
57 "(gtk-hbox-new :homogeneous ~a :spacing ~a)"
58 homogeneous spc)))))
59
60 (gtk-misc-set-alignment label 0 0)
61 (gtk-box-pack-start vbox label)
62 (gtk-widget-show label))
63
64 ;; Get lispy!
65 (mapcar
66 #'(lambda (box)
67 (gtk-box-pack-start vbox box)
68 (gtk-widget-show box))
69 (mapcar
70 #'make-box
71 ;; homogeneous
72 (list homogeneous homogeneous homogeneous)
73
74 ;; spacing
75 (list spc spc spc)
76
77 ;; expand
78 '(nil t t)
79
80 ;; fill
81 '(nil nil t)
82
83 ;; padding
84 '(0 0 0)))
85
86 (gtk-box-pack-start vbox
87 (show-later (gtk-hseparator-new))
88 :fill t :padding 5))
89
90 (gtk-box-pack-start vbox
91 (show-later (gtk-hseparator-new))
92 :fill t :padding 5)
93
94 (let ((box (show-later (gtk-hbox-new)))
95 (button (show-later (gtk-button-new-with-label "(quit)"))))
96
97 (gtk-box-pack-start vbox box)
98 (gtk-box-pack-start box button :expand t)
99 (g-signal-connect-swapped button gtkclicked
100 #'(lambda (x)
101 (gtk-widget-destroy window)
102 (gtk-main-quit))))
103
104 (mapcar #'gtk-widget-show show-list)
105
106 (gtk-main)))))

  ViewVC Help
Powered by ViewVC 1.1.5