134 lines
4.6 KiB
Racket
134 lines
4.6 KiB
Racket
#lang scheme/gui
|
|
|
|
(require htdp/error
|
|
htdp/big-draw
|
|
lang/prim
|
|
mzlib/etc
|
|
mzlib/class)
|
|
|
|
(provide
|
|
control
|
|
control-up-down
|
|
control-left-right
|
|
)
|
|
|
|
(define-higher-order-primitive control-up-down control-up-down/proc
|
|
(_ _ up-down draw))
|
|
|
|
(define-higher-order-primitive control-left-right control-left-right/proc
|
|
(_ _ left-right draw))
|
|
|
|
(define-higher-order-primitive control control/proc
|
|
(_ _ left-right up-down draw))
|
|
|
|
|
|
;; CONSTANTS ---------------------------------------------------------------
|
|
(define MY-ICONS "/home/matthias/icons/")
|
|
(define TITLE "Controller")
|
|
|
|
(define (mk-image-constant kind)
|
|
(make-object bitmap%
|
|
(build-path (collection-path "icons") (format "arrow.~a.gif" kind)) 'gif))
|
|
|
|
;(define LEFT-ARROW (mk-image-constant "marble.left"))
|
|
;(define RIGHT-ARROW (mk-image-constant "marble.right"))
|
|
;(define UP-ARROW (mk-image-constant "marble.up"))
|
|
;(define DOWN-ARROW (mk-image-constant "marble.down"))
|
|
|
|
(define LEFT-ARROW (mk-image-constant "blue.left"))
|
|
(define RIGHT-ARROW (mk-image-constant "blue.right"))
|
|
(define UP-ARROW (mk-image-constant "blue.up"))
|
|
(define DOWN-ARROW (mk-image-constant "blue.down"))
|
|
|
|
;; LAYOUT ------------------------------------------------------------------
|
|
|
|
;; layout = (listof (listof (union #f bitmap%)))
|
|
|
|
(define FOUR
|
|
`( (,#f ,UP-ARROW ,#f)
|
|
(,LEFT-ARROW ,#f ,RIGHT-ARROW)
|
|
(,#f ,DOWN-ARROW ,#f) ))
|
|
|
|
(define UP-DOWN
|
|
`( (,UP-ARROW )
|
|
(,DOWN-ARROW ) ))
|
|
|
|
(define LEFT-RIGHT
|
|
`( (,LEFT-ARROW ,RIGHT-ARROW ) ))
|
|
|
|
;; make-button-table :
|
|
;; panel% layout (bitmap% -> (_ _ -> X))
|
|
;; ->
|
|
;; (listof (listof (union panel% button%)))
|
|
;; to translate a layout table into a button table
|
|
;; each button is controlled by (control a-bitmap)
|
|
(define (make-button-table panel control layout)
|
|
(define (make-row a-row)
|
|
(define row-panel (make-object horizontal-panel% panel))
|
|
(define (make-item an-item)
|
|
(if an-item
|
|
(make-object button% an-item row-panel (control an-item))
|
|
(let ([panel (make-object horizontal-panel% row-panel)])
|
|
(send panel min-width 30))))
|
|
;; ---
|
|
(map make-item a-row))
|
|
;; ---
|
|
(map make-row layout))
|
|
|
|
;; GUI ---------------------------------------------------------------------
|
|
|
|
;; make-controller :
|
|
;; symbol layout number X (number X -> true) (number X -> true) (X -> true)-> void
|
|
;; effect: create a left-right controller that invokes move on delta
|
|
(define (make-controller tag layout shape delta left-right-action up-down-action draw-shape)
|
|
(check-arg tag
|
|
(and (number? delta) (integer? delta) (>= delta 1))
|
|
"positive integer"
|
|
'2nd
|
|
delta)
|
|
(check-proc tag left-right-action 2 "move-left-right" "two arguments")
|
|
(check-proc tag up-down-action 2 "move-up-down" "two arguments")
|
|
(check-proc tag draw-shape 1 "draw" "one argument")
|
|
;; ---
|
|
(local ((define frame (make-object frame% TITLE #f 10 10))
|
|
(define panel (make-object vertical-panel% frame))
|
|
;; control : bitmap% -> (_ _ -> void)
|
|
;; to check which button was clicked
|
|
(define (control an-item)
|
|
(lambda (x y)
|
|
;; DESIGN DECISION:
|
|
;; by handing over the number first, nesting the moves becomes easier
|
|
(evcase an-item
|
|
(UP-ARROW
|
|
(set! shape (up-down-action (- delta) shape)))
|
|
(DOWN-ARROW
|
|
(set! shape (up-down-action delta shape)))
|
|
(LEFT-ARROW
|
|
(set! shape (left-right-action (- delta) shape)))
|
|
(RIGHT-ARROW
|
|
(set! shape (left-right-action delta shape))))
|
|
(draw-shape shape))))
|
|
(make-button-table panel control layout)
|
|
(send frame show #t)
|
|
#t))
|
|
|
|
;; EXPORTS:
|
|
|
|
(define (void2 x y) (void))
|
|
|
|
;; control-left-right/proc : XShape number (number XShape -> XShape) (XShape -> true) -> true
|
|
;; effect: create a window from which a user can control L/R moves
|
|
(define (control-left-right/proc shape delta lr draw)
|
|
(make-controller 'control-left-right LEFT-RIGHT shape delta lr void2 draw))
|
|
|
|
;; control-up-down : X number (number X -> true) (X -> true) -> true
|
|
;; effect: create a window from which a user can control U/D moves
|
|
(define (control-up-down/proc shape delta ud draw)
|
|
(make-controller 'control-up-down UP-DOWN shape delta void2 ud draw))
|
|
|
|
;; control/proc : X number (number X -> true) (number X -> true) (X -> true) -> true
|
|
;; effect: create a window from which a user can control moves
|
|
(define (control/proc shape delta lr ud draw)
|
|
(make-controller 'control FOUR shape delta lr ud draw))
|
|
|