source: project/slang/trunk/slang-examples/smgtest.scm @ 3162

Last change on this file since 3162 was 3162, checked in by Tony Sidaway, 14 years ago

Another example.

File size: 11.5 KB
Line 
1; Copyright (c) 2007 Tony Sidaway <tonysidaway@gmail.com>
2;
3; Permission is hereby granted, free of charge, to any person obtaining
4; a copy of this software and associated documentation files (the
5; "Software"), to deal in the Software without restriction, including without
6; limitation the rights to use, copy, modify, merge, publish, distribute,
7; sublicense, and/or sell copies of the Software, and to permit persons to
8; whom the Software is furnished to do so, subject to the following conditions:
9;
10; The above copyright notice and this permission notice shall be included
11; in all copies or substantial portions of the Software.
12;
13; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
14; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
15; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
16; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
17; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
18; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
19; DEALINGS IN THE SOFTWARE.
20;
21; The code in this demonstration is an adaptation of techniques shown in
22; the pager.c demo distributed with the slang library.
23;
24(use lolevel)
25(use slang)
26(declare (uses demolib))
27
28(define (quit)
29  (demolib-exit #f)
30  (exit 1))
31
32
33(define (write-centered-string str row)
34  (let* ((str (if str (->string str) ""))
35        (row (or row 0))
36        (len (string-length str))
37        (col (if (>= len (sltt-screen-cols)) 0 (fx/ (- (sltt-screen-cols) len) 2))))
38    (SLsmg_gotorc row col)
39    (SLsmg_write_string str)))
40
41(define (call-with-signals-blocked thunk)
42  (SLsig_block_signals)
43  (let ((result (thunk)))
44    (SLsig_unblock_signals)
45    result))
46
47(define (pre-test title)
48  (call-with-signals-blocked
49   (lambda () (SLsmg_cls)(write-centered-string title 0))))
50
51(define (post-test)
52  (write-centered-string "Press any key to return." (- (sltt-screen-rows) 1))
53  (SLsmg_refresh))
54
55(define colors
56  '("black/default" "red" "green" "brown" "blue" "magenta" "cyan" "lightgray" "gray"
57    "brightred" "brightgreen" "yellow" "brightblue" "brightmagenta" "brightcyan" "white"))
58
59(define number-of-colors (length colors))
60
61
62(define (init-colors)
63  (let ((fg "black"))
64    (SLtt_set_color 1 "" fg "default")
65    (SLtt_set_color (+ 1 number-of-colors) "" "default" "fg")
66    (let loop ((i 1))
67      (unless (>= i number-of-colors)
68        (let ((bg (list-ref colors i)))
69          (SLtt_set_color (+ i 1) "" fg bg)
70          (SLtt_set_color (+ i 1 number-of-colors) "" bg fg)
71          (loop (+ i 1)))))))
72
73(define (box-test)
74  (let* ((msg "This is a box with changing background")
75        (dr 8)
76        (dc (+ 4 (string-length msg)))
77        (r (- (/ (sltt-screen-rows) 2) (/ dr 2)))
78        (c (- (/ (sltt-screen-cols) 2) (/ dc 2))))
79    (SLsmg_set_color 1)
80    (SLsmg_set_char_set 1)
81    (SLsmg_fill_region (+ r 1) (+ c 1) (- dr 2) (- dc 2) (char->integer SLSMG_CKBRD_CHAR))
82    (SLsmg_set_char_set 0)
83    (SLsmg_set_color 0)
84    (SLsmg_gotorc (+ r (/ dr 2)) (+ c 2))
85    (SLsmg_write_string msg)
86    (SLsmg_draw_box r c dr dc)
87    (SLsmg_refresh)
88    (let loop ((color 2) (pending (> (SLang_input_pending 10) 0)))
89      (if pending
90        (SLang_getkey)
91        (begin
92          (SLsmg_set_color_in_region color r c dr dc)
93          (SLsmg_refresh)
94          (loop (modulo (+ color 1) number-of-colors) (SLang_input_pending 10)))))))
95
96(define (check-color-support)
97  (or (sltt-use-ansi-colors)
98    (begin
99      (do-test (list "Your terminal does not provide color support" (lambda() #f))) #f)))
100
101(define (bce-color-test)
102  (if (check-color-support)
103    (let ((row (/ (sltt-screen-rows) 2)))
104      (SLtt_set_color 0 "" "lightgray" "blue")
105      (SLsmg_set_color 0)
106      (SLsmg_gotorc row 1)
107      (SLsmg_write_string "The screen background should be blue.")
108      (SLsmg_gotorc (+ 2 row) 1)
109      (SLsmg_write_string "****If the screen update is slow, then your terminal")
110      (SLsmg_gotorc (+ 3 row) 1)
111      (SLsmg_write_string "    does not support background-color-erase.")
112      (SLsmg_set_color 0))))
113
114(define (lr-corner-test)
115  (SLsmg_gotorc (- (sltt-screen-rows) 1) (- (sltt-screen-cols) 1))
116  (SLsmg_write_string "X")
117  (write-centered-string "An 'X' should be in the lower-right corner." (/ (sltt-screen-rows) 2))
118  (SLsmg_refresh)
119  (SLkp_getkey))
120
121(define (color-test)
122  (fprintf (current-error-port) "color-test")
123  (if (check-color-support)
124    (begin
125      (let loop ((row 1) (color 0))
126        (unless (>= row (- (sltt-screen-rows) 1))
127          (SLsmg_gotorc row 0)
128          (SLsmg_set_color (+ 1 color number-of-colors))
129          (SLsmg_write_string (list-ref colors color))
130          (SLsmg_set_color (+ 1 color))
131          (SLsmg_erase_eol)
132          (loop (+ 1 row) (modulo (+ color 1) number-of-colors)))))
133    (SLsmg_set_color 0)))
134
135(define (color-test1)
136  (if (check-color-support)
137    (begin
138      (let* ((r0 1) (r1 (/ (sltt-screen-rows) 2))
139             (dr0 r1) (dr1 (sltt-screen-rows))
140             (c0 0) (c1 (/ (sltt-screen-rows) 2))
141             (dc0 c1) (dc1 (sltt-screen-cols)))
142
143        (let loop ((color 0) (pending #f))
144          (if pending
145            (SLang_getkey)
146            (begin
147              (SLsmg_gotorc r1 0)
148              (SLsmg_set_color color)
149              (set! color (modulo (+ 1 color) number-of-colors))
150              (SLsmg_write_string "                          ")
151              (SLsmg_set_color color)
152              (set! color (modulo (+ 1 color) number-of-colors))
153              (SLsmg_write_string "X")
154              (SLsmg_set_color color)
155              (SLsmg_erase_eol)
156              (SLsmg_refresh)
157              (loop (modulo (+ 1 color) number-of-colors) (> (SLang_input_pending 30) 0)))))
158
159        (SLang_flush_input)
160     
161        (let loop ((color 0)(pending #f))
162          (if pending
163            (SLang_getkey)
164            (begin
165              (SLsmg_set_color color)
166              (set! color (modulo (+ 1 color) number-of-colors))
167              (SLsmg_fill_region r0 c0 dr0 dc0 (char->integer #\space))
168              (SLsmg_set_color color)
169              (set! color (modulo (+ 1 color) number-of-colors))
170              (SLsmg_fill_region r0 c1 dr0 dc1 (char->integer #\space))
171              (SLsmg_set_color color)
172              (set! color (modulo (+ 1 color) number-of-colors))
173              (SLsmg_fill_region r1 c0 dr1 dc0 (char->integer #\space))
174              (SLsmg_set_color color)
175              (set! color (modulo (+ 1 color) number-of-colors))
176              (SLsmg_fill_region r1 c1 dr1 dc1 (char->integer #\space))
177              (SLsmg_refresh)
178              (loop color (> (SLang_input_pending 30) 0)))))
179
180        (SLsmg_set_color 0)))))
181
182(define (alt_char_test)
183  #f)
184
185(define-macro (symbol-entry x) `(list ,x ,(->string x)))
186
187(define symbol-list
188  (list
189   (symbol-entry SLSMG_HLINE_CHAR)
190   (symbol-entry SLSMG_VLINE_CHAR)
191   (symbol-entry SLSMG_ULCORN_CHAR)
192   (symbol-entry SLSMG_URCORN_CHAR)
193   (symbol-entry SLSMG_LLCORN_CHAR)
194   (symbol-entry SLSMG_LRCORN_CHAR)
195   (symbol-entry SLSMG_RTEE_CHAR)
196   (symbol-entry SLSMG_LTEE_CHAR)
197   (symbol-entry SLSMG_UTEE_CHAR)
198   (symbol-entry SLSMG_DTEE_CHAR)
199   (symbol-entry SLSMG_PLUS_CHAR)
200   (symbol-entry SLSMG_CKBRD_CHAR)
201   (symbol-entry SLSMG_DIAMOND_CHAR)
202   (symbol-entry SLSMG_DEGREE_CHAR)
203   (symbol-entry SLSMG_PLMINUS_CHAR)
204   (symbol-entry SLSMG_BULLET_CHAR)
205   (symbol-entry SLSMG_LARROW_CHAR)
206   (symbol-entry SLSMG_RARROW_CHAR)
207   (symbol-entry SLSMG_DARROW_CHAR)
208   (symbol-entry SLSMG_UARROW_CHAR)
209   (symbol-entry SLSMG_BOARD_CHAR)
210   (symbol-entry SLSMG_BLOCK_CHAR)))
211
212(define (draw-symbols-test)
213  (let ((row 3) (col 3))
214    (let loop ((lst symbol-list))
215      (unless (null? lst)
216        (SLsmg_gotorc row col)
217        (SLsmg_set_char_set 1)
218        (SLsmg_write_char (caar lst))
219        (SLsmg_set_char_set 0)
220        (SLsmg_write_string (format ":~A" (cadar lst)))
221        (set! col (+ col 40))
222        (if (>= col 80)
223          (begin
224            (set! col 3)
225            (set! row (+ 1 row))))
226        (loop (cdr lst))))))
227
228(define (not-yet-implemented)
229  (write-centered-string "This test has not been implemented yet.  Press any key to return." (- (sltt-screen-rows) 1))
230  (SLsmg_refresh)
231  (SLkp_getkey)
232  (SLsmg_cls))
233
234(define line-test not-yet-implemented)
235(define do-esc-seq-test  not-yet-implemented)
236(define esc-seq-test  not-yet-implemented)
237(define mouse-test  not-yet-implemented)
238(define mono-test  not-yet-implemented)
239(define low-level-test not-yet-implemented)
240
241(define (wrapped-string-test)
242  (let* ((dc 15) (dr 10)
243        (row (fx/ (- (sltt-screen-rows) dr) 2))
244        (col (fx/ (- (sltt-screen-cols) dc) 2))
245        (str "This is a string that should be wrapped in a 12x15 cell.\nIt even contains a\ncouple of newline chacters\nfor fun."))
246    (SLsmg_fill_region (- row 1) (- col 1) (+ dr 2) (+ dc 2) (char->integer #\.))
247    (SLsmg_draw_box (- row 1) (- col 1) (+ dr 2) (+ dc 2))
248    (SLsmg_write_wrapped_string str row col dr dc 1)
249    (if (SLutf8_is_utf8_mode)
250      (begin
251        (set! str "UTF8: àžžàž£àž°àž›àžà¹€àžàžšàžàž­àž‡àžšàž¹à¹Šàžàž¹à¹‰àž‚àž¶à¹‰àž™à¹ƒàž«àž¡à¹ˆàžªàž­àž‡àž­àž‡àž„à¹Œà¹„àž‹àž£à¹‰à¹‚àž‡à¹ˆà¹€àž‚àž¥àž²à¹€àžšàž²àž›àž±àžàžàž²àžšà¹‰àž²àž™à¹€àž¡àž·àž­àž‡àžˆàž¶àž‡àž§àžŽàž›àž£àžŽàž•à¹€àž›à¹‡àž™àž™àž±àžàž«àž™àž²àž«àž¡àž²àž¢àžˆàž°àž†à¹ˆàž²àž¡àž”àžŠàž±à¹ˆàž§àž•àž±àž§àžªàž³àž„àž±àžàž£àž±àžšàž«àž¡àž²àž›à¹ˆàž²à¹€àž‚à¹‰àž²àž¡àž²à¹€àž¥àž¢àž­àž²àžªàž±àžà¹ƒàžŠà¹‰àžªàž²àž§àž™àž±à¹‰àž™à¹€àž›à¹‡àž™àžŠàž™àž§àž™àžŠàž·à¹ˆàž™àžŠàž§àž™à¹ƒàžˆàžŠà¹ˆàž²àž‡àž­àž²à¹€àžžàžšàžˆàž£àžŽàž‡àž«àž™àž²àžŸà¹‰àž²àž£à¹‰àž­àž‡à¹„àž«à¹‰àž€à¹…àž«àž²à¹ƒàž„àž£àž„à¹‰àž³àžŠàž¹àžàž¹à¹‰àžšàž£àž£àž¥àž±àž‡àžà¹Œ àž¯")
252        (SLsmg_fill_region (- row 1) (- col 1) (+ dr 2) (+ dc 2) (char->integer #\.))
253        (SLsmg_draw_box (- row 1) (- col 1) (+ dr 2) (+ dc 2))
254        (SLsmg_write_wrapped_string str row col dr dc 1)
255        (write-centered-string "Press any key to return." (- (sltt-screen-rows) 1))))))
256
257
258   
259
260(define (do-test test)
261  (call-with-signals-blocked
262   (let ((test test))
263   (lambda ()
264     (pre-test (car test))
265     ((cadr test))
266     (post-test))))
267  (SLkp_getkey))
268
269(define root-menu
270  (list (list "Color Test" color-test)
271    (list "Another Color Test" color-test1)
272    (list "BCE Color Test" bce-color-test)
273;;; (list "Alt charset test" alt-char-test)
274    (list "Drawing Symbols" draw-symbols-test)
275    (list "Key Escape Sequence Report" esc-seq-test)
276;;; (list "ANSI Key Escape Sequence Report" ansi-esc-seq-test)
277    (list "Line Drawing Test" line-test)
278    (list "Test Mouse" mouse-test)
279    (list "Box Test" box-test)
280    (list "Write to Lower Right Corner Test" lr-corner-test)
281    (list "Write Wrapped String Test" wrapped-string-test)
282    (list "Test Low Level Functions" low-level-test)
283    (list "Test monochrome functions" mono-test)
284    (list "Quit" quit)))
285
286(define current-menu root-menu)
287
288(define (print-menu)
289  (call-with-signals-blocked
290   (lambda ()
291     (SLsmg_cls)
292     (SLsmg_gotorc 0 1)
293     (SLsmg_write_string "Choose number:")
294     (let loop ((i 1) (row 2) (menu current-menu))
295       (unless (null? menu)
296         (SLsmg_gotorc row 3)
297         (SLsmg_write_string (format "~X ~A\n" i (caar menu)))
298         (loop (+ i 1) (+ row 1) (cdr menu))))
299     (SLsmg_refresh))))
300
301
302(define (select-menu-item item)
303  (let* ((item (assoc (->string item) '(("1" . 1)("2" . 2)("3" . 3)("4" . 4)
304                                        ("5" . 5)("6" . 6)("7" . 7)("8" . 8)("9" . 9)
305                                        ("a" . 10)("b" . 11)("c" . 12)("d" . 13)("e" . 14)
306                                        ("f" . 15))))
307         (item (and item (cdr item))))
308    (and item (< item (length current-menu)) (do-test (list-ref current-menu (- item 1))))))
309
310(define (menu-loop)
311  (print-menu)
312  (let loop ((ch (char-downcase (integer->char (SLkp_getkey)))))
313    (unless (eq? (char-downcase ch) #\q)
314      (select-menu-item ch)
315      (print-menu)
316      (loop (char-downcase (integer->char (SLkp_getkey)))))))
317
318
319(define (main-program)
320  ; This sets up the terminal, signals, screen management routines, etc...
321  (if (= -1 (demolib-init-terminal 1 1))
322      (begin
323        (fprintf (current-error-port) "Unable to initialize terminal.\n")
324        (exit 1)))
325  (init-colors)
326  (SLtt_set_mouse_mode 1 0)
327  (if (> (length (argv)) 1)
328      (for-each select-menu-item (cdr (argv)))
329      (menu-loop))
330  (quit)
331  (exit 1))
332
333(main-program)
Note: See TracBrowser for help on using the repository browser.