[racket-dev] multiple key-press

I have finally taken the time to design a controller for an object that 
allows the use of multiple arrow keys. Two insights: it is doable and it 
is a truly insightful exercise on state machines. Most of the 'bullet' 
points at the top of the program came about because I designed and explored. 
BUT, the program is quite complex. If you think about it for a moment, 
that's no surprise however. It is working with nine possible states: 
 no arrow pressed, one of four cardinal arrows pressed, two keys 
 pressed simultaneously. 

I think "Brown" kids should be able to design this kind of function 
w/o a problem. For "non-Brown" kids, I suspect we would have to wait 
until they have a solid handle of a lot of design ideas. 

QUESTION: should I incorporate this into the docs? Into HtDP/2e (part 1
is already extremely long). 

-- Matthias



(require 2htdp/universe)
(require 2htdp/image)

;; -----------------------------------------------------------------------------
;; PROGRAM PURPOSE: move a red circle while one or two arrow keys are pressed 
;; -----------------------------------------------------------------------------

;; move only when one or two arrow keys are pressed 
;; when a third arrow key is pressed, ignore it 
;; when a single arrow key is pressed and a contradictory arrow is pressed, 
;;   ignore it too 
;; This program is a nine-state state machine with respect to the direction
;; in which the object is moving. 

;; Boolean -> World 
(define (move-by-arrows debug?)
  (big-bang WORLD0
            (on-key key-handler)
            (on-release release-handler)
            (on-tick move)
            (to-draw render) 
            (state debug?)))

;; -----------------------------------------------------------------------------
;; Data Definitions & Constant Definitions 

;; Cardinal is one of: 
;; -- "left"
;; -- "right"
;; -- "up" 
;; -- "down"
;; interpretation: the four cardinal directions as strings and keyevents 

(define-struct world (dir posn))
;; World is: (world Direction Posn)
;; the current direction and the current position of the circle 

;; Direction is one of:  (Yes, I mean these 10 definitions)
(define BLANK (make-posn 0 0))
(define LEFT (make-posn -1 0))
(define RIGHT (make-posn +1 0))
(define UP (make-posn 0 -1))
(define DOWN (make-posn 0 +1))
(define DOWNLEFT (make-posn -1 +1))
(define DOWNRIGHT (make-posn +1 +1))
(define UPLEFT (make-posn -1 -1))
(define UPRIGHT (make-posn +1 -1))
;; the direction as determined by a sequence of 0, 1, or 2 keys held down 

;; physical constants 
(define SIZE 300)
(define MID  (/ SIZE 2))
(define WORLD0 (make-world BLANK (make-posn MID MID)))

;; graphical constants 
(define DOT  (circle 3 "solid" "red"))
(define MT   (empty-scene SIZE SIZE))

;; -----------------------------------------------------------------------------
;; World KeyEvent -> World
; combine current direction and KeyEvent to create new direction 

(check-expect (key-handler (make-world UP (make-posn 0 0)) "left")
              (make-world UPLEFT (make-posn 0 0)))
(check-expect (key-handler (make-world DOWNRIGHT (make-posn 0 0)) "left") 
              (make-world DOWNRIGHT (make-posn 0 0)))

(check-expect (key-handler (make-world UP (make-posn 0 0)) "down")
              (make-world UP (make-posn 0 0)))
(check-expect (key-handler (make-world DOWNRIGHT (make-posn 0 0)) "down") 
              (make-world DOWNRIGHT (make-posn 0 0)))

(define (key-handler ws key)
  (if (cardinal? key)
      (make-world (key-proper (world-dir ws) key) (world-posn ws))
      ws))

;; KeyEvent -> Boolean 
(define (cardinal? key)
  (cond
    [(string=? "left" key) true]
    [(string=? "right" key) true]
    [(string=? "up"  key) true]
    [(string=? "down" key) true]
    [else false]))

;; Direction Cardinal -> Direction 

(check-expect (key-proper UP "left") UPLEFT)
(check-expect (key-proper DOWNRIGHT "left") DOWNRIGHT)
(check-expect (key-proper RIGHT "up") UPRIGHT)

;; Direction Cardinal -> Direction 
(define (key-proper ws key)
  (cond
    [(equal? BLANK ws) 
     (cond
       [(string=? "left" key) LEFT]
       [(string=? "right" key) RIGHT] ;; arbitrary decision 
       [(string=? "up"  key) UP] 
       [(string=? "down" key) DOWN])]
    [(equal? LEFT ws) 
     (cond
       [(string=? "left" key) ws]
       [(string=? "right" key) ws] ;; arbitrary decision 
       [(string=? "up"  key) UPLEFT] ;; (string-append key ws) wouldn't be typable 
       [(string=? "down" key) DOWNLEFT])]
    [(equal? RIGHT ws) 
     (cond
       [(string=? "left" key) ws] ;; arbitrary decision 
       [(string=? "right" key) ws] 
       [(string=? "up"  key) UPRIGHT] 
       [(string=? "down" key) DOWNRIGHT])]
    [(equal? UP  ws) 
     (cond
       [(string=? "left" key) UPLEFT]
       [(string=? "right" key) UPRIGHT] 
       [(string=? "up"  key) ws]
       [(string=? "down" key) ws])]  ;; arbitrary decision 
    [(equal? DOWN ws) 
     (cond
       [(string=? "left" key) DOWNLEFT]
       [(string=? "right" key) DOWNRIGHT] 
       [(string=? "up"  key) ws]
       [(string=? "down" key) ws])]
    [(equal? UPLEFT ws) ws]
    [(equal? UPRIGHT ws) ws]
    [(equal? DOWNLEFT ws) ws]
    [(equal? DOWNRIGHT ws) ws]))

;; -----------------------------------------------------------------------------
;; World KeyEvent -> World

(check-expect (release-handler (make-world UP (make-posn 0 0)) "left")
             (make-world UP (make-posn 0 0)))
(check-expect (release-handler (make-world LEFT (make-posn 0 0)) "left")
              (make-world BLANK (make-posn 0 0)))
(check-expect (release-handler (make-world DOWNRIGHT (make-posn 0 0)) "down")
              (make-world RIGHT (make-posn 0 0)))

(define (release-handler ws key)
  (if (cardinal? key)
      (make-world (release-proper (world-dir ws) key) (world-posn ws))
      ws))

;; Direction Cardinal -> Direction 
(define (release-proper ws card)
  (cond
    [(equal? BLANK ws) ws] ;; IF hold down several keys, release in some order
    [(equal? LEFT ws) (if (string=? "left" card) BLANK ws)]
    [(equal? RIGHT ws) (if (string=? "right" card) BLANK ws)]
    [(equal? UP  ws) (if (string=? "up" card) BLANK ws)] 
    [(equal? DOWN ws) (if (string=? "down" card) BLANK ws)]
    [(equal? UPLEFT ws) 
     (cond
       [(string=? "left" card)  UP]
       [(string=? "right" card) ws]
       [(string=? "up"  card)   LEFT]
       [(string=? "down" card)  ws])]
    [(equal? UPRIGHT ws) 
     (cond
       [(string=? "left" card)  ws]
       [(string=? "right" card) UP]
       [(string=? "up"  card)   RIGHT]
       [(string=? "down" card)  ws])]
    [(equal? DOWNLEFT ws) 
     (cond
       [(string=? "left" card)  DOWN]
       [(string=? "right" card) ws]
       [(string=? "up"  card)   ws]
       [(string=? "down" card)  LEFT])]
    [(equal? DOWNRIGHT ws) 
     (cond
       [(string=? "left" card)  ws]
       [(string=? "right" card) DOWN]
       [(string=? "up"  card)   ws]
       [(string=? "down" card)  RIGHT])]))

;; -----------------------------------------------------------------------------
;; World -> World 
(check-expect (move WORLD0) WORLD0)

(define (move ws)
  (make-world (world-dir ws) (posn+ (world-posn ws) (world-dir ws))))

;; -----------------------------------------------------------------------------
;; Posn Posn -> Posn 
(define (posn+ p q)
  (make-posn (+ (posn-x p) (posn-x q)) (+ (posn-y p) (posn-y q))))

;; -----------------------------------------------------------------------------
; World -> Image 
(define (render ws)
  (place-image DOT (posn-x (world-posn ws)) (posn-y (world-posn ws)) MT))