#lang s-exp "../../moby-lang.ss"
(define (start title background playerImg targetImgs objectImgs
update-player update-target update-object
collide? offscreen?)
(local [
(define-struct being [posn costume])
(define-struct world [objects targets player bg score title timer])
(define score 0)
(define (draw-being being background)
(place-image (being-costume being)
(posn-x (being-posn being)) (posn-y (being-posn being))
background))
(define (draw-all beings background)
(foldl draw-being background beings))
(define (draw-world w)
(let* ((score-string (string-append (world-title w) " score:" (number->string (world-score w))))
(target-layer (draw-all (world-targets w) (world-bg w)))
(object-layer (draw-all (world-objects w) target-layer))
(player (if (> (world-timer w) 0)
(make-being (make-posn (posn-x (being-posn (world-player w)))
(posn-y (being-posn (world-player w))))
(circle (* 1 5 (world-timer w))
"solid"
"gray")
(star 7 (* 1.5 (world-timer w))
(* .25 (world-timer w))
"solid"
"gray"))
(world-player w)))
(player-layer (draw-being player object-layer)))
(place-image (text score-string 20 "white") 10 0 player-layer)))
(define (test-frame title bg playerImg targetImgs objectImgs)
(let* ((targetImgs (if (list? targetImgs) targetImgs (list targetImgs)))
(objectImgs (if (list? objectImgs) objectImgs (list objectImgs)))
(player (make-being (make-posn 320 400) playerImg))
(targets (map (lambda (t) (make-being (make-posn (random 640) (random 480)) t)) targetImgs))
(objects (map (lambda (o) (make-being (make-posn (random 640) (random 480)) o)) objectImgs))
(world (make-world objects targets player
(put-pinhole bg 0 0)
100
title
0)))
(draw-world world)))
(define (update* b update-function)
(let* ((new-loc (if (= (procedure-arity update-function) 1)
(update-function (posn-x (being-posn b)))
(update-function (posn-x (being-posn b)) (posn-y (being-posn b)))))
(new-posn (if (posn? new-loc) new-loc (make-posn new-loc (posn-y (being-posn b))))))
(make-being new-posn (being-costume b))))
(define (move-all beings update-function offscreen?)
(map (lambda (b)
(if (offscreen? (posn-x (being-posn b)) (posn-y (being-posn b)))
(make-being (make-posn (+ 600 (object-spacing)) (random 480)) (being-costume b))
(update* b update-function)))
beings))
(define (object-spacing) (+ (random 150) 40))
(define (char->string c)
(cond [(not (char? c))
(error 'char->string (format "not a character ~s" c))]
[(eq? c #\space) "space"]
[else (string c)]))
(define (keypress w key update-player)
(cond
[(symbol? key) (keypress w (symbol->string key) update-player)]
[(char? key) (keypress w (char->string key) update-player)]
[(not (string? key)) w]
[(member key (list "up" "down" "left" "right"))
(let* ((p (being-posn (world-player w)))
(new-loc (if (= (procedure-arity update-player) 2)
(update-player (posn-y p) key)
(update-player (posn-x p) (posn-y p) key)))
(new-posn (if (posn? new-loc) new-loc (make-posn (posn-x p) new-loc ))))
(make-world (world-objects w)
(world-targets w)
(make-being new-posn (being-costume (world-player w)))
(world-bg w)
(world-score w)
(world-title w)
(world-timer w)))]
[else w]))
(define (any-collide? collide? player beings)
(foldl (lambda (b bool) (or (collide? (posn-x (being-posn player))
(posn-y (being-posn player))
(posn-x (being-posn b))
(posn-y (being-posn b)))
bool))
false
beings))]
(let* ((player (make-being (make-posn 320 400) playerImg))
(targetImgs (if (list? targetImgs) targetImgs (list targetImgs)))
(objectImgs (if (list? objectImgs) objectImgs (list objectImgs)))
(targets (map (lambda (t) (make-being (make-posn (random 640) (random 480)) t)) targetImgs))
(objects (map (lambda (o) (make-being (make-posn (random 640) (random 480)) o)) objectImgs))
(world (make-world objects targets player
(put-pinhole background 0 0)
100
title
0))
(keypress* (lambda (w k) (keypress w k update-player)))
(update-world (lambda (w)
(let* ((objects (move-all (world-objects w) update-object offscreen?))
(targets (move-all (world-targets w) update-target offscreen?))
(score (world-score w))
(player (world-player w))
(bg (put-pinhole (world-bg w) 0 0))
(title (world-title w))
(timer (world-timer w)))
(begin
(set! score (world-score w))
(cond
[(> timer 0)
(make-world objects targets player bg score title (- timer 10))]
[(any-collide? collide? player objects)
(begin
(play-sound "hit.wav" true)
(make-world objects targets player bg (- score 50) title 100))]
[(any-collide? collide? player targets)
(begin
(play-sound "score.wav" true)
(make-world objects targets player bg (+ score 20) title 100))]
[else (make-world objects targets player bg score title timer)]))
))))
(js-big-bang world
(on-redraw draw-world)
(on-tick .1 update-world)
(on-key keypress*)))))
(void)
(provide start)