1#lang scheme/gui
2
3(require htdp/error
4         htdp/big-draw
5         lang/prim
6         mzlib/etc
7         mzlib/class)
8
9(provide
10 control ; modelT modelT modelT modelT -> true
11 view    ; X -> true
12 connect ; -> Symbol
13 )
14
15(define-higher-order-primitive connect connect/proc (left right up down))
16(define-primitive control control/proc)
17(define-primitive view view/proc)
18
19;; CONSTANTS ---------------------------------------------------------------
20(define MY-ICONS "/home/matthias/icons/")
21(define TITLE "Controller")
22(define COLLECT (collection-path "icons"))
23(define ARR "arrow.blue.~a.gif")
24
25;; LAYOUT CONSTRUCTION ----------------------------------------------------
26
27
28;; mk-image-constant : str (button% event% -> true) -> (panel% -> button%)
29;; to create a panel-parameterized button with a picture and a specific call-back
30(define (mk-image-constant kind model)
31  (local ([define an-item
32            (make-object bitmap% (build-path COLLECT (format ARR kind)) 'gif)])
33    (lambda (panel)
34      (make-object button% an-item panel model))))
35
36;; make-button-table :
37;;   panel% layout -> (listof (listof (union panel% button%)))
38;; to translate a layout table into a button table
39;;   each button is controlled by (control a-bitmap)
40(define (make-button-table panel layout)
41  (local ((define (make-row a-row)
42            (local ((define row-panel (make-object horizontal-panel% panel))
43                    (define (make-item an-item)
44                      (if an-item (an-item row-panel)
45                          (let ([panel (make-object horizontal-panel% row-panel)])
46                            (send panel min-width 30)))))
47              (map make-item a-row))))
48    (map make-row layout)))
49
50(define frame (make-object frame% TITLE #f 10 10))
51(define panel (make-object vertical-panel% frame))
52(define hor (make-object horizontal-panel% panel '(border)))
53(define lab (make-object message% "Going where?" hor))
54(define msg (make-object message% "Nowhere" hor))
55
56;; X -> true
57;; to display s in the msg panel
58(define (view/proc s)
59  (send msg set-label (format "~a" s))
60  true)
61
62;; WIRING THINGS UP    ----------------------------------------------------
63;; -> symbol
64;; to read out the current state of the msg field
65(define (control/proc)
66  (string->symbol (send msg get-label)))
67
68;; modelT = (button% event% -> true)
69;; connect/proc : modelT modelT modelT modelT -> true
70(define (connect/proc left right up down)
71  (check-proc 'connect left 2 "'left' argument" "two arguments")
72  (check-proc 'connect right 2 "'right' argument" "two arguments")
73  (check-proc 'connect up 2 "'up' argument" "two arguments")
74  (check-proc 'connect down 2 "'down' argument" "two arguments")
75  (local ((define LEFT-ARROW  (mk-image-constant "left"  left))
76          (define RIGHT-ARROW (mk-image-constant "right" right))
77          (define UP-ARROW    (mk-image-constant "up"    up))
78          (define DOWN-ARROW  (mk-image-constant "down"  down))
79          (define FOUR
80            `( (,#f         ,UP-ARROW   ,#f)
81               (,LEFT-ARROW ,#f         ,RIGHT-ARROW)
82               (,#f         ,DOWN-ARROW ,#f) ))
83          (define layout (make-button-table frame FOUR)))
84    (send frame show true)
85    true))
86