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