Simple space game in racket using hdtp2/universe

gistfile1.txt

#lang racket
(require 
 2htdp/image
 2htdp/universe)

; World constants
(define WIDTH 600)
(define HEIGHT 400)
(define BKG-IMG (rectangle WIDTH HEIGHT "solid" "black"))

; General utilities
(define (with-chance n proc . args) (if (zero? (random n)) (apply proc args) (last args)))
(define (any-equal? test? base . args) (ormap (λ (x) (test? base x)) args))
(define (<* x y z) (and (< x y) (< y z)))
(define (>* x y z) (and (> x y) (> y z)))

; World utilities
(define (filter-inworld key w) (hash-update w key (curry filter-bounds 0 WIDTH 0 HEIGHT)))

; Point utilities (Point: (List Real Real))
(define (move dx dy v) (list (+ (first v) dx) (+ (second v) dy)))
(define (move* dx dy v) (map (curry move dx dy) v))
(define (draw-at v img bkg) (place-image img (first v) (second v) bkg))
(define (bounded x1 x2 y1 y2 v) (and (<* x1 (first v) x2) (<* y1 (second v) y2)))
(define (filter-bounds x1 x2 y1 y2 vs) (filter (curry bounded x1 x2 y1 y2) vs))

; Keyboard utilities
(define (keyhash . args)
  (make-immutable-hash (map (λ (key) (cons key #f)) args)))

(define (key-move point speed keys)
  (move (+ (if (hash-ref keys "left") (- speed) 0) (if (hash-ref keys "right") speed 0))
        (+ (if (hash-ref keys "up") (- speed) 0) (if (hash-ref keys "down") speed 0))
        point))

(define (update-key keys a-key) (hash-set keys a-key #t))
(define (update-release keys a-key) (hash-set keys a-key #f))

; Player auxilary constants and functions
(define PLAYER-START-X 100)
(define PLAYER-START-Y (/ HEIGHT 2))
(define PLAYER-SPEED 2)
(define PLAYER-START (list PLAYER-START-X PLAYER-START-Y (keyhash "left" "right" "up" "down")))
(define PLAYER-IMG (square 16 "solid" "red"))

; Player world functions
(define (player-draw w bkg) (place-image PLAYER-IMG (first (hash-ref w 'player)) (second (hash-ref w 'player)) bkg))
(define (player-tick w) (hash-update w 'player (λ (p) (append (key-move (take p 2) PLAYER-SPEED (third p)) (drop p 2)))))
(define (player-key w a-key) (hash-update w 'player (λ (p) (list (first p) (second p) (update-key (third p) a-key)))))
(define (player-release w a-key) (hash-update w 'player (λ (p) (list (first p) (second p) (update-release (third p) a-key)))))
(define (player-x w) (first (hash-ref w 'player)))
(define (player-y w) (second (hash-ref w 'player)))

; Star auxilary constants and funtions
(define STAR-IMG (square 3 "solid" "white"))
(define STAR-SPD -8)
(define STAR-RATE 5)
(define (add-star x y w) (hash-update w 'stars (curry cons (list x y))))
(define (move-stars dx dy w) (hash-update w 'stars (curry map (curry move dx dy))))
(define (filter-stars w) (hash-update w 'stars (curry filter-bounds 0 WIDTH 0 HEIGHT)))

; Star world functions
(define (stars-tick w) (filter-inworld 'stars (move-stars STAR-SPD 0 (with-chance STAR-RATE add-star WIDTH (random HEIGHT) w))))
(define (star-draw v bkg) (draw-at v STAR-IMG bkg))
(define (stars-draw w bkg) (foldl star-draw bkg (hash-ref w 'stars)))

(define BULLET-IMG (square 4 "solid" "gray"))
(define BULLET-SPD 10)
(define (bullets-move w) (hash-update w 'bullets (curry move* BULLET-SPD 0)))
(define (bullets-release w a-key) (if (key=? a-key "z") (hash-update w 'bullets (λ (v) (list* (list (player-x w) (player-y w)) v))) w))
(define (bullet-draw v bkg) (place-image BULLET-IMG (first v) (second v) bkg))
(define (bullets-draw w bkg) (foldl bullet-draw bkg (hash-ref w 'bullets)))
(define (bullets-tick w) (filter-inworld 'bullets (bullets-move w)))

(big-bang
 (hash 'stars '() 'player PLAYER-START 'bullets '())
 (to-draw (λ (w) (player-draw w (bullets-draw w (stars-draw w BKG-IMG)))))
 (on-tick (λ (w) (player-tick (stars-tick (bullets-tick w)))))
 (on-key (λ (w a-key) (player-key w a-key)))
 (on-release (λ (w a-key) (bullets-release (player-release w a-key) a-key))))