/[cells]/Celtk/demos.lisp
ViewVC logotype

Contents of /Celtk/demos.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (show annotations)
Mon Jun 16 12:35:56 2008 UTC (5 years, 10 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.27: +1 -1 lines
Notebook.lisp from Andy and random other recent work
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
2 #|
3
4 Celtk -- Cells, Tcl, and Tk
5
6 Copyright (C) 2006 by Kenneth Tilton
7
8 This library is free software; you can redistribute it and/or
9 modify it under the terms of the Lisp Lesser GNU Public License
10 (http://opensource.franz.com/preamble.html), known as the LLGPL.
11
12 This library is distributed WITHOUT ANY WARRANTY; without even
13 the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
14
15 See the Lisp Lesser GNU Public License for more details.
16
17 |#
18
19 (in-package :celtk-user)
20
21
22 (defmodel my-test (window)
23 ((my-mode :accessor my-mode :initform (c? (evenp (selection (fm! :my-selector))))))
24 (:default-initargs
25 :id :my-test-id
26 :kids (c? (the-kids
27 (mk-stack ("stack" :packing (c?pack-self "-side bottom") :relief 'ridge)
28 (mk-entry :id :my-entry
29 :value (c-in "abc"))
30 (mk-row ( "row" #| :packing (c?pack-self "-side bottom") |# :relief 'ridge)
31 (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector)))))
32 (mk-label :text "Labeltext")
33 (mk-button-ex ("Reset" (setf (selection (fm^ :my-selector)) 1)))
34 (mk-stack ((c? (format nil "current selection: ~a" (^selection))) :id :my-selector :selection (c-in 1) :relief 'ridge)
35 (mk-radiobutton-ex ("selection 1" 1))
36 (mk-radiobutton-ex ("selection 2" 2))
37 (mk-radiobutton-ex ("selection 3" 3))
38 (mk-radiobutton-ex ("selection 4" 4)))
39 (mk-label :text (c? (format nil "selection: ~a" (selection (fm^ :my-selector)))))
40 ))))))
41
42 (defobserver my-mode ((self my-test) new-value old-value old-value-bound-p)
43 (format t "~% mode changed from ~a to ~a" old-value new-value))
44
45 (defun ctk::franks-test ()
46 (run-window 'my-test))
47
48 #+test
49 (ctk::franks-test)
50
51 (defun ctk::tk-test () ;; ACL project manager needs a zero-argument function, in project package
52 (test-window
53 ;;'place-test
54 ;; 'one-button-window
55 ;;'ltktest-cells-inside
56 ;;'menu-button-test
57 ;;'spinbox-test
58 'lotsa-widgets
59 ;; Now in Gears project 'gears-demo
60 ))
61
62 (defmodel place-test (window)
63 ()
64 (:default-initargs
65 :kids (c? (the-kids
66 (mk-label :text "hi, Mom"
67 :parent-x 100
68 :py 20)))))
69
70 (defmodel one-button-window (window)
71 ()
72 (:default-initargs
73 :kids (c? (the-kids
74 #+shhhh (mk-menubar
75 :kids (c? (the-kids
76 (mk-menu-entry-cascade-ex (:label "File")
77 (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
78 (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed"))))))
79 (mk-frame-stack
80 :packing (c?pack-self)
81 :kids (c? (the-kids
82 (mk-text-widget
83 :id :my-text
84 :value (c?n "[bzbzbzbz]")
85 :height 8
86 :width 25)
87 (make-instance 'entry
88 :id :entree
89 :fm-parent *parent*
90 :value (c-in "kenzo")))))))))
91
92 (defun one-deep-menubar ()
93 (mk-menubar
94 :id 'mbar
95 :kids (c? (the-kids
96 (mk-menu-entry-cascade-ex (:label "File")
97 (mk-menu-entry-command-ex () "Load" (format t "~&Load pressed"))
98 (mk-menu-entry-command-ex () "Save" (format t "~&Save pressed")))
99 (mk-menu-entry-cascade
100 :id 'editcascade
101 :label "Edit"
102 :kids (c? (the-kids
103 (mk-menu
104 :id 'editmenu
105 :kids (c? (the-kids
106 (mk-menu-radio-group :id :app-font-face
107 :selection (c-in "courier")
108 :kids (c? (the-kids
109 (mk-menu-entry-radiobutton :label "Times" :value "times")
110 (mk-menu-entry-radiobutton :label "Courier" :value "courier")
111 (mk-menu-entry-radiobutton :label "Helvetica" :value "helvetica"))))))))))))))
112
113 (defmodel spinbox-test (window)
114 ()
115 (:default-initargs
116 :kids (c? (the-kids
117 (mk-stack (:packing (c?pack-self))
118 (mk-spinbox
119 :id :spin-pkg
120 :value (c-in "cells") ;;(cells::c?n "cells")
121 :tk-values (mapcar 'down$
122 (sort (mapcar 'package-name
123 (list-all-packages))
124 'string>)))
125 (mk-scrolled-list
126 :id :spinpkg-sym-list
127 :list-height 6
128 :list-item-keys (c? (trc "enter item keys" self (fm^ :spin-pkg))
129 (let* ((spinner (fm^ :spin-pkg))
130 (item (when spinner (value spinner)))
131 (pkg (find-package (string-upcase item))))
132 (when pkg
133 (loop for sym being the symbols in pkg
134 for n below 5
135 counting sym into symct
136 collecting sym into syms
137 finally (return syms)))))
138 :list-item-factory (lambda (sym)
139 (make-instance 'listbox-item
140 :fm-parent *parent*
141 :value sym
142 :item-text (down$ (symbol-name sym)))))
143 (mk-label :text (c? (selection (fm^ :spinpkg-sym-list)))))))))
144
145
146 (defmodel menu-button-test (window)
147 ()
148 (:default-initargs
149 :kids (c? (the-kids
150 (mk-stack ("Style by Widgets" :id :widstyle :packing (c?pack-self))
151 (mk-popup-menubutton
152 :id :font-face
153 :initial-value (c? (second (^entry-values)))
154 :entry-values (c? (subseq (tk-eval-list "font families") 4 10)))
155 (mk-label :text "Four score and seven years ago today, our fathers broguht forth on this continent a new nation..."
156 :wraplength 200
157 :tk-justify 'left
158 :tkfont (c? (list
159 (selection (fm^ :font-face))
160 14))))))))
161
162 (defmodel font-view-2 (window)
163 ()
164 (:default-initargs
165 :kids (c? (the-kids
166 (mk-panedwindow
167 :packing (c?pack-self)
168 :orient 'vertical
169 :kids (c? (the-kids
170 (loop repeat 2
171 collecting (make-instance 'font-view :fm-parent *parent*)))))))))
172
173 (defun mk-font-view ()
174 (make-instance 'font-view))
175
176 (defmodel font-view (frame-stack)
177 ()
178 (:default-initargs
179 :value (c? (tk-eval-list "font families"))
180 :pady 2 :padx 4
181 :packing-side 'left
182 :layout-anchor 'nw
183 :kids (c? (the-kids
184 (mk-spinbox :id :font-face
185 :value (c-in (car (^value)))
186 :tk-values (c? (value .parent)))
187 (mk-scale :id :font-size
188 :value (c-in 14)
189 :tk-label "Font Size"
190 :from 7 :to 24
191 :orient 'horizontal)
192 (mk-label :id :txt
193 :text "Four score seven years ago today"
194 :wraplength 600
195 :tkfont (c? (list ;; format nil "{{~{~a~^ ~}} ~a}" ;; eg, {{wp greek century} 24}
196 (value (fm^ :font-face))
197 (value (fm^ :font-size)))))))))
198
199 #| 06-02-14 following stuff not resurrected after latest revisions to Celtk
200
201 ;;; ---- toplevel --------------------------------
202
203
204
205
206 (defmodel file-open (toplevel)
207 ()
208 (:default-initargs
209 :value (c? (directory "\\windows\\fonts\\*.ttf"))
210 :pady 2 :padx 4
211 :kids (c? (the-kids
212 (mk-spinbox :id :font-face
213 :value (c-in (car (^value)))
214 :tk-values (c? (mapcar 'pathname-name (value .parent))))
215 (mk-button-ex ("Open" (progn
216 (tk-format `(:destroy ,self) "destroy ~a" (path (upper self toplevel)))
217 (not-to-be (upper self toplevel))))
218 :underline 0)))))
219
220 |#

  ViewVC Help
Powered by ViewVC 1.1.5