Artifact b2ab4d1a14bf131c3ab9e04a92127f21b3bb7b15:
- File gui.scm — part of check-in [ae6dbecf17] at 2011-05-01 23:05:22 on branch trunk — Importing 1.0.1 version of megatest, (nb// work in progress, please wait for next release) (user: matt size: 1982)
0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20 0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew 0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;; 0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i 0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available 0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G 0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o 0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S 0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany 0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING 00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;; 00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr 00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute 00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA 00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without 00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp 0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of 0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY 0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR 0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;; 0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 28 64 PURPOSE...;; (d 0150: 65 66 69 6e 65 20 28 63 65 6c 73 69 75 73 2d 3e efine (celsius-> 0160: 66 61 68 72 65 6e 68 65 69 74 20 69 74 65 6d 29 fahrenheit item) 0170: 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6e 75 6d .;; (let ((num 0180: 62 65 72 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ber (string->num 0190: 62 65 72 20 69 74 65 6d 29 29 29 0a 3b 3b 20 20 ber item))).;; 01a0: 20 20 20 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 (if (number? 01b0: 6e 75 6d 62 65 72 29 0a 3b 3b 20 09 28 2b 20 28 number).;; .(+ ( 01c0: 2a 20 6e 75 6d 62 65 72 20 39 2f 35 29 20 33 32 * number 9/5) 32 01d0: 29 0a 3b 3b 20 09 30 2e 30 29 29 29 0a 0a 3b 3b ).;; .0.0)))..;; 01e0: 20 28 64 65 66 69 6e 65 20 28 6d 65 67 61 74 65 (define (megate 01f0: 73 74 2d 67 75 69 2d 31 29 0a 3b 3b 20 20 20 28 st-gui-1).;; ( 0200: 75 73 65 20 70 73 74 6b 29 0a 3b 3b 20 20 20 28 use pstk).;; ( 0210: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception 0220: 73 0a 3b 3b 20 20 20 20 65 78 6e 0a 3b 3b 20 20 s.;; exn.;; 0230: 20 20 28 74 6b 2d 65 6e 64 29 20 20 3b 20 6d 61 (tk-end) ; ma 0240: 6b 65 20 73 75 72 65 20 74 6b 20 69 73 20 63 6c ke sure tk is cl 0250: 6f 73 65 64 20 69 6e 20 65 76 65 6e 74 20 6f 66 osed in event of 0260: 20 61 6e 79 20 65 72 72 6f 72 0a 3b 3b 20 0a 3b any error.;; .; 0270: 3b 20 20 20 20 28 74 6b 2d 73 74 61 72 74 29 0a ; (tk-start). 0280: 3b 3b 20 20 20 20 28 74 6b 2f 77 6d 20 27 74 69 ;; (tk/wm 'ti 0290: 74 6c 65 20 74 6b 20 22 43 65 6c 73 69 75 73 20 tle tk "Celsius 02a0: 74 6f 20 46 61 68 72 65 6e 68 65 69 74 22 29 0a to Fahrenheit"). 02b0: 3b 3b 20 20 20 20 28 6c 65 74 2a 20 28 28 63 65 ;; (let* ((ce 02c0: 6c 73 69 75 73 20 28 74 6b 20 27 63 72 65 61 74 lsius (tk 'creat 02d0: 65 2d 77 69 64 67 65 74 20 27 65 6e 74 72 79 29 e-widget 'entry) 02e0: 29 0a 3b 3b 20 09 20 20 28 6c 61 62 65 6c 20 28 ).;; . (label ( 02f0: 74 6b 20 27 63 72 65 61 74 65 2d 77 69 64 67 65 tk 'create-widge 0300: 74 20 27 6c 61 62 65 6c 29 29 0a 3b 3b 20 09 20 t 'label)).;; . 0310: 20 28 62 75 74 74 6f 6e 20 28 74 6b 20 27 63 72 (button (tk 'cr 0320: 65 61 74 65 2d 77 69 64 67 65 74 20 27 62 75 74 eate-widget 'but 0330: 74 6f 6e 0a 3b 3b 20 09 09 20 20 20 20 20 20 27 ton.;; .. ' 0340: 74 65 78 74 3a 20 27 43 61 6c 63 75 6c 61 74 65 text: 'Calculate 0350: 0a 3b 3b 20 09 09 20 20 20 20 20 20 27 63 6f 6d .;; .. 'com 0360: 6d 61 6e 64 3a 20 28 6c 61 6d 62 64 61 20 28 29 mand: (lambda () 0370: 20 0a 3b 3b 20 09 09 09 09 20 20 28 6c 61 62 65 .;; .... (labe 0380: 6c 20 27 63 6f 6e 66 69 67 75 72 65 20 0a 3b 3b l 'configure .;; 0390: 20 09 09 09 09 09 20 27 74 65 78 74 3a 20 28 6e ..... 'text: (n 03a0: 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 28 63 umber->string (c 03b0: 65 6c 73 69 75 73 2d 3e 66 61 68 72 65 6e 68 65 elsius->fahrenhe 03c0: 69 74 20 28 63 65 6c 73 69 75 73 20 27 67 65 74 it (celsius 'get 03d0: 29 29 29 29 29 29 29 29 0a 3b 3b 20 09 09 09 09 )))))))).;; .... 03e0: 09 3b 20 6c 61 79 6f 75 74 20 77 69 64 67 65 74 .; layout widget 03f0: 73 20 69 6e 20 61 20 67 72 69 64 0a 3b 3b 20 20 s in a grid.;; 0400: 20 20 20 20 28 74 6b 2f 67 72 69 64 20 63 65 6c (tk/grid cel 0410: 73 69 75 73 20 27 63 6f 6c 75 6d 6e 3a 20 32 20 sius 'column: 2 0420: 27 72 6f 77 3a 20 31 20 27 73 74 69 63 6b 79 3a 'row: 1 'sticky: 0430: 20 27 77 65 20 27 70 61 64 78 3a 20 35 20 27 70 'we 'padx: 5 'p 0440: 61 64 79 3a 20 35 29 0a 3b 3b 20 20 20 20 20 20 ady: 5).;; 0450: 28 74 6b 2f 67 72 69 64 20 6c 61 62 65 6c 20 27 (tk/grid label ' 0460: 63 6f 6c 75 6d 6e 3a 20 32 20 27 72 6f 77 3a 20 column: 2 'row: 0470: 32 20 27 73 74 69 63 6b 79 3a 20 27 77 65 20 27 2 'sticky: 'we ' 0480: 70 61 64 78 3a 20 35 20 27 70 61 64 79 3a 20 35 padx: 5 'pady: 5 0490: 29 0a 3b 3b 20 20 20 20 20 20 28 74 6b 2f 67 72 ).;; (tk/gr 04a0: 69 64 20 62 75 74 74 6f 6e 20 27 63 6f 6c 75 6d id button 'colum 04b0: 6e 3a 20 32 20 27 72 6f 77 3a 20 33 20 27 73 74 n: 2 'row: 3 'st 04c0: 69 63 6b 79 3a 20 27 77 65 20 27 70 61 64 78 3a icky: 'we 'padx: 04d0: 20 35 20 27 70 61 64 79 3a 20 35 29 0a 3b 3b 20 5 'pady: 5).;; 04e0: 20 20 20 20 20 28 74 6b 2f 67 72 69 64 20 28 74 (tk/grid (t 04f0: 6b 20 27 63 72 65 61 74 65 2d 77 69 64 67 65 74 k 'create-widget 0500: 20 27 6c 61 62 65 6c 20 27 74 65 78 74 3a 20 22 'label 'text: " 0510: 63 65 6c 73 69 75 73 22 29 20 0a 3b 3b 20 09 20 celsius") .;; . 0520: 20 20 20 20 20 27 63 6f 6c 75 6d 6e 3a 20 33 20 'column: 3 0530: 27 72 6f 77 3a 20 31 20 27 73 74 69 63 6b 79 3a 'row: 1 'sticky: 0540: 20 27 77 20 27 70 61 64 78 3a 20 35 20 27 70 61 'w 'padx: 5 'pa 0550: 64 79 3a 20 35 29 0a 3b 3b 20 20 20 20 20 20 28 dy: 5).;; ( 0560: 74 6b 2f 67 72 69 64 20 28 74 6b 20 27 63 72 65 tk/grid (tk 'cre 0570: 61 74 65 2d 77 69 64 67 65 74 20 27 6c 61 62 65 ate-widget 'labe 0580: 6c 20 27 74 65 78 74 3a 20 22 69 73 22 29 20 0a l 'text: "is") . 0590: 3b 3b 20 09 20 20 20 20 20 20 27 63 6f 6c 75 6d ;; . 'colum 05a0: 6e 3a 20 31 20 27 72 6f 77 3a 20 32 20 27 73 74 n: 1 'row: 2 'st 05b0: 69 63 6b 79 3a 20 27 65 20 27 70 61 64 78 3a 20 icky: 'e 'padx: 05c0: 35 20 27 70 61 64 79 3a 20 35 29 0a 3b 3b 20 20 5 'pady: 5).;; 05d0: 20 20 20 20 28 74 6b 2f 67 72 69 64 20 28 74 6b (tk/grid (tk 05e0: 20 27 63 72 65 61 74 65 2d 77 69 64 67 65 74 20 'create-widget 05f0: 27 6c 61 62 65 6c 20 27 74 65 78 74 3a 20 22 66 'label 'text: "f 0600: 61 68 72 65 6e 68 65 69 74 22 29 20 0a 3b 3b 20 ahrenheit") .;; 0610: 09 20 20 20 20 20 20 27 63 6f 6c 75 6d 6e 3a 20 . 'column: 0620: 33 20 27 72 6f 77 3a 20 32 20 27 73 74 69 63 6b 3 'row: 2 'stick 0630: 79 3a 20 27 77 20 27 70 61 64 78 3a 20 35 20 27 y: 'w 'padx: 5 ' 0640: 70 61 64 79 3a 20 35 29 20 09 09 09 09 09 3b 20 pady: 5) .....; 0650: 62 65 67 69 6e 20 70 72 6f 67 72 61 6d 0a 3b 3b begin program.;; 0660: 20 09 09 09 09 09 3b 20 72 65 73 74 20 6f 66 20 .....; rest of 0670: 20 67 75 69 20 73 65 74 75 70 0a 3b 3b 20 20 20 gui setup.;; 0680: 20 20 20 28 74 6b 2d 65 76 65 6e 74 2d 6c 6f 6f (tk-event-loo 0690: 70 29 29 0a 3b 3b 20 20 20 20 29 29 0a 0a 28 64 p)).;; ))..(d 06a0: 65 66 69 6e 65 20 28 69 6e 69 74 2d 64 69 61 6c efine (init-dial 06b0: 6f 67 29 0a 20 20 3b 3b 20 28 6c 65 74 20 28 28 og). ;; (let (( 06c0: 63 6f 6e 74 72 6f 6c 73 2d 66 72 61 6d 65 20 28 controls-frame ( 06d0: 69 75 70 3a 66 72 61 6d 65 0a 20 20 3b 3b 09 09 iup:frame. ;;.. 06e0: 09 20 28 69 75 70 3a 68 62 6f 78 0a 20 20 23 74 . (iup:hbox. #t 06f0: 29 09 09 09 20 20 0a 20 20 0a 3b 3b 20 46 6f 72 )... . .;; For 0700: 20 6e 6f 77 20 74 68 65 20 67 75 69 20 77 6f 72 now the gui wor 0710: 6b 20 77 69 6c 6c 20 62 65 20 64 6f 6e 65 20 69 k will be done i 0720: 6e 20 64 61 73 68 62 6f 61 72 64 2e 73 63 6d 0a n dashboard.scm. 0730: 0a 3b 3b 28 64 65 66 69 6e 65 20 28 6d 65 67 61 .;;(define (mega 0740: 74 65 73 74 2d 67 75 69 29 0a 3b 3b 20 20 28 72 test-gui).;; (r 0750: 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 69 equire-library i 0760: 75 70 29 0a 3b 3b 20 20 28 69 6d 70 6f 72 74 20 up).;; (import 0770: 28 70 72 65 66 69 78 20 69 75 70 20 69 75 70 3a (prefix iup iup: 0780: 29 29 0a 3b 3b 20 20 28 75 73 65 20 63 61 6e 76 )).;; (use canv 0790: 61 73 2d 64 72 61 77 20 63 61 6e 76 61 73 2d 64 as-draw canvas-d 07a0: 72 61 77 2d 69 75 70 29 0a 3b 3b 20 20 28 75 73 raw-iup).;; (us 07b0: 65 20 73 72 66 69 2d 34 29 29 0a 20 20 0a e srfi-4)). .