#lang s-exp "../lang/wescheme.rkt"
(require (lib "world.ss" "htdp")
(lib "prim.ss" "lang")
lang/prim
htdp/world
(except-in htdp/testing test)
(for-syntax scheme/base))
(provide circle triangle rectangle ellipse star line text EXAMPLE)
(provide-higher-order-primitive start (rocket-height))
(provide start)
(define WIDTH 200)
(define HEIGHT 600)
(define IMAGE0 (empty-scene WIDTH HEIGHT))
(define source
(open-image-url "http://www.wescheme.org/images/teachpacks/rocket.png"))
(define ROCKET (put-pinhole source (/ (image-width source) 2) (image-height source)))
(define-struct world (current-height rocket-height))
(define (draw-world w)
(text-add ((world-rocket-height w) (world-current-height w)) (rocket-add w IMAGE0)))
(define (text-add height IMAGE0)
(place-image (text (string-append "Height: " (number->string height)) 14 'black)
60
0
IMAGE0))
(define (rocket-add w IMAGE0)
(cond
[(>= (image-height ROCKET) (- HEIGHT ((world-rocket-height w) (world-current-height w))))
(place-image ROCKET 100 200 IMAGE0)]
[else (place-image ROCKET 100 (- HEIGHT ((world-rocket-height w) (world-current-height w))) IMAGE0)]))
(define (tock w ke)
(make-world (+ 1 (world-current-height w))
(world-rocket-height w)))
(define (start rocket-height)
(big-bang (make-world 0 rocket-height)
(on-key tock)
(to-draw draw-world)))
(require (for-syntax syntax/kerncase))
(define-syntax (EXAMPLE stx)
(syntax-case stx ()
[(_ x ...)
(with-handlers ([exn? (lambda (e)
(raise (make-exn
(regexp-replace*
#rx"check-expect"
(exn-message e)
"test")
(exn-continuation-marks e))))])
(local-expand (syntax/loc stx (check-expect x ...))
(syntax-local-context)
(kernel-form-identifier-list)))]))