Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- #lang racket/gui
- (require racket/math
- ;racket/flonum
- ;racket/fixnum)
- racket/require (for-syntax racket/base)
- (filtered-in
- (lambda (name) (regexp-replace #rx"unsafe-" name ""))
- racket/unsafe/ops)
- (only-in racket/flonum make-flvector))
- (define *width* 160)
- (define *height* 120)
- (define *scale* 4)
- (define (make-trig-lookup-table fn)
- ((lambda ()
- (let ((lookup (make-flvector 2000)))
- (begin
- (let loop
- ((i -1000.0))
- (when (fl< i 1000.0)
- (flvector-set! lookup (fl->fx (flfloor (fl+ i 1000.0))) (fn (fl* pi (fl/ i 1000.0))))
- (loop (fl+ 1.0 i))))
- (lambda (x)
- (flvector-ref
- lookup
- (fxremainder
- (fl->fx (flfloor (fl+ (fl* 1000.0 (fl/ x pi)) 1000.0)))
- 2000))))))))
- (define :sin (make-trig-lookup-table flsin))
- (define :cos (make-trig-lookup-table flcos))
- (define screen%
- (class object%
- (init w h)
- (define width w)
- (define height h)
- (define width.0 (fx->fl w))
- (define height.0 (fx->fl h))
- (define z-buffer (make-flvector (* width height) 10000.0))
- (define z-buffer-wall (make-flvector width))
- (define texture
- (bytes-append #"\377\311\311\310\377\277\300\277\377\266\267\266\377\255\255"
- #"\256\377\244\244\244\377\233\233\232\377\221\221\222\377\210"
- #"\211\210\377\277\275\275\377\266\265\265\377\254\254\254\377"
- #"\242\242\242\377\230\232\231\377\217\220\217\377\206\206\205"
- #"\377}|{\377\263\263\262\377\251\251\252\377\241\240\240\377"
- #"\226\227\226\377\216\215\216\377\202\202\204\377yzz\377ooq"
- #"\377\250\250\250\377\236\237\235\377\225\225\224\377\213\213"
- #"\213\377\202\201\201\377wxw\377non\377ecd\377\235\233\234\377"
- #"\223\222\223\377\211\211\211\377~\200\200\377vuu\377klk\377bc"
- #"b\377XZX\377\220\220\217\377\206\207\206\377}}}\377str\377jij"
- #"\377``a\377VVV\377LMM\377\205\204\204\377zzy\377qpq\377ggg\377"
- #"^^^\377STU\377KJJ\377CCC\377wxx\377ono\377eee\377[\\[\377RRS"
- #"\377HII\377AA?\377877"))
- (define viewport (make-object bitmap% width height))
- (define vbytes (make-bytes (fx* 4 (fx* width height))))
- (define/public (render game)
- (begin (render-floor game)
- (post-process)
- (send viewport set-argb-pixels 0 0 width height vbytes)))
- (define/private (render-floor game)
- (let* ((rot (send game get-rot))
- (x-cam (fl- (send game get-px)
- (fl* 0.3 (:sin rot))))
- (y-cam (fl- (send game get-py)
- (fl* 0.3 (:cos rot))))
- (z-cam 0.0)
- (r-cos (:cos rot))
- (r-sin (:sin rot)))
- (for ([y (in-range (- height 1) -1 -1)])
- (let* ((yd (fl/ (fl- (fl+ (fx->fl y) 0.5) (fl/ height.0 2.0)) height.0))
- (zd (if (fl>= yd 0.0)
- (fl/ (fl+ 4.0 (fl* z-cam 8.0)) yd)
- (fl/ (fl- 4.0 (fl* z-cam 8.0))
- (fl- 0.0 yd)))))
- (for ([x (in-range (- width 1) -1 -1)])
- (let* ((xd (fl* (fl/ (fl- (fx->fl x) (fl/ width.0 2.0)) height.0) zd))
- (xx (fxand
- (fl->fx (flfloor (fl+ x-cam
- (fl+ (fl* xd r-cos)
- (fl* zd r-sin)))))
- 7))
- (yy (fxand
- (fl->fx (flfloor
- (fl+ y-cam
- (fl- (fl* zd r-cos)
- (fl* xd r-sin)))))
- 7))
- (st (fx+ xx (fx* yy 8))))
- (begin
- (flvector-set! z-buffer (fx+ x (fx* y width)) zd)
- (bytes-copy! vbytes
- (fx* 4 (fx+ x (fx* y width)))
- (subbytes texture (fx* st 4) (fx* (fx+ st 1) 4))))))))))
- (define/private (post-process)
- (for ([i (in-range (fx- (fx* width height) 1) -1 -1)])
- (let ((r (bytes-ref vbytes (fx+ 1 (fx* 4 i))))
- (g (bytes-ref vbytes (fx+ 2 (fx* 4 i))))
- (b (bytes-ref vbytes (fx+ 3 (fx* 4 i)))))
- (let* ((br (fl->fx (flfloor (fl/ 60000.0
- ((lambda (x) (fl* x x))
- (flvector-ref z-buffer i))))))
- (br (if (fx< br 0) 0 br))
- (br (if (fx> br 255) 255 br)))
- (let ((r (fxquotient (fx* r br) 255))
- (g (fxquotient (fx* g br) 255))
- (b (fxquotient (fx* b br) 255)))
- (begin
- (bytes-set! vbytes (fx+ 1 (fx* 4 i)) r)
- (bytes-set! vbytes (fx+ 2 (fx* 4 i)) g)
- (bytes-set! vbytes (fx+ 3 (fx* 4 i)) b)))))))
- (define/public get-bitmap
- (lambda () viewport))
- (super-new)))
- (define game%
- (class object%
- (define px 4.0)
- (define py 0.0)
- (define rot 0.0)
- (define/public (tick)
- (begin
- (set! rot (fl+ 0.05 rot))
- (set! py (fl+ 0.3 py))))
- (define/public (get-px) px)
- (define/public (get-py) py)
- (define/public (get-rot) rot)
- (super-new)))
- (define game-canvas%
- (class canvas%
- (inherit get-dc refresh)
- (define bmp (make-object bitmap% *width* *height*))
- (define game (make-object game%))
- (define screen (make-object screen% *width* *height*))
- (define tick? #f)
- (define/override (on-paint)
- (let ((thedc (get-dc)))
- (copy-screen-bitmap)
- (send thedc draw-bitmap bmp 0 0))
- (when tick?
- (set! tick? #f)
- (queue-callback (lambda x (send this run)) #f)))
- (define/private (copy-screen-bitmap)
- (send
- (make-object bitmap-dc% bmp)
- draw-bitmap
- (send screen get-bitmap)
- 0 0))
- (define/public (run)
- (begin
- (send game tick)
- (send screen render game)
- (set! tick? #t)
- (refresh)))
- (super-new [style '(no-autoclear)])
- (send (get-dc) set-scale *scale* *scale*)))
- (define (main)
- (let* ((sphore (make-semaphore 0))
- (frame
- (make-object
- (class frame%
- (define/augment on-close
- (lambda ()
- (semaphore-post sphore)
- (inner (void) on-close)))
- (super-new)) "092311"))
- (canvas (make-object game-canvas% frame)))
- (begin
- (send canvas min-width (* *width* *scale*))
- (send canvas min-height (* *height* *scale*))
- (send frame show #t)
- (send canvas run)
- (void (yield sphore)))))
- (main)
Add Comment
Please, Sign In to add comment