#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)