Commit 063fab1c authored by Hugo Hörnquist's avatar Hugo Hörnquist

Add fading effect.

parent 192ef961
......@@ -28,13 +28,15 @@
(* (z v) (z v)))))
(define-class <player> ()
(pos #:accessor p #:init-form (v3 1 1))
(angle #:accessor a #:init-value 0)
(pos #:accessor p
#:init-form (v3 1 1)
#:init-keyword #:p)
(angle #:accessor a #:init-value 0 #:init-keyword #:a)
(feild-of-view #:accessor fov #:init-value (/ tau 8)))
(export p a fov)
(define (make-player x y a)
(make <player> #:x x #:y y #:a a))
(make <player> #:p (v3 x y) #:a a))
(define-class <ray> ()
......
......@@ -38,11 +38,10 @@
(define t (gettimeofday))
(+ (cdr t) (* 1000000 (car t))))
(define player (make-player 1 1 0))
(define player (make-player 5 13 -2))
(define ray-count 64)
(define current-font (make-parameter #f))
(define rays (make-atomic-box '()))
......@@ -167,89 +166,104 @@
(set-draw-color #xBB #xBB #xFF)
(clear)
;; floor
(set-draw-color #x33 #x33 #x33)
(render-fill-rect (current-renderer)
(make-rect 0 240 640 240))
(set-draw-color 0 #xEE #xEE)
(for-each (lambda (i r r+)
(when (hashq-ref texture-map (type r))
(let* ((l (length r))
(segment-height (- 480 (* 70 l))))
(render-copy
(current-renderer)
(hashq-ref texture-map (type r))
#:dstrect (list (int (* i (/ 640 ray-count)))
(int (/ (- 480 segment-height) 2))
(int (+ 0 (/ 640 ray-count)))
(int segment-height))
#:srcrect
(list (int (* 16 (pos-on-wall r))) 0
1 16)))))
(iota ray-count)
(atomic-box-ref rays)
(cdr (atomic-box-ref rays))
)
(let ((rays (atomic-box-ref rays)))
(unless (null? rays)
(for-each (lambda (i r r+)
(when (hashq-ref texture-map (type r))
(let* ((l (length r))
(segment-height (- 480 (* 30 l) 40))
(texture (hashq-ref texture-map (type r))))
(let ((c (max 0 (int (- #xFF (* l 20))))))
(set-texture-color-mod! texture c c c))
(render-copy
(current-renderer)
texture
#:dstrect (list (int (* i (/ 640 ray-count)))
(int (/ (- 480 segment-height) 2))
(int (+ 0 (/ 640 ray-count)))
(int segment-height))
#:srcrect
(list (int (* 16 (pos-on-wall r))) 0
1 16)))))
(iota ray-count)
rays (cdr rays)
)))
)
(define texture #f)
(define (draw window rend)
(define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0))
(let ((surf (render-font-solid (current-font) str (color))))
(render-copy (current-renderer)
(surface->texture (current-renderer) surf)
#:dstrect (list 1 (+ 1 (* line (+ 3 (font-height (current-font)))))
(surface-width surf)
(surface-height surf)))))
(define (with-render-target target thunk)
(dynamic-wind (lambda () (set-render-target! (current-renderer) target))
thunk
(lambda () (set-render-target! (current-renderer) #f))))
(define (draw window rend)
(parameterize ((current-renderer rend))
(set-draw-color #xFF #xFF #xFF)
(clear)
;; minimap
(let ((texture (make-texture rend 'rgba8888 'target
(* board-width (current-tile-size))
(* board-height (current-tile-size)))))
(set-render-target! rend texture)
(draw-map)
(set-render-target! rend #f)
(* board-width (current-tile-size))
(* board-height (current-tile-size)))))
(with-render-target texture draw-map)
;; Camera
(draw-first-person-perspective)
;; minimap
(render-copy rend texture
#:dstrect (list 0 (- 480 100)
100 100))
(delete-texture! texture))
;; FPS counter
(let ((nt (get-t)))
(let ((surf (render-font-solid
(current-font)
(format #f "FPS: ~,2f" (/ 1000000 (- nt fps-time)))
(make-color 0 0 0 #xFF))))
(render-copy (current-renderer)
(surface->texture (current-renderer) surf)
#:dstrect (list 1 1
(surface-width surf)
(surface-height surf))))
;; Text overlay
(parameterize ((color (make-color 0 0 0 #xFF)))
(set! fps-time nt))
;; FPS counter
(let ((nt (get-t)))
(render-text (format #f "FPS: ~,2f" (/ 1000000 (- nt fps-time)))
#:line 0)
(set! fps-time nt))
(present)
(render-text
(format #f "x = ~,4f y = ~,4f a = ~,4f"
(x (p player))
(y (p player))
(a player))
#:line 1))
))
(present)))
(define (main-loop window)
(define rend (make-renderer window '(accelerated #; vsync texture)))
(define last-t (get-t))
(call-with-new-thread
(lambda ()
(while
#t (let ((rays-next (ray-trace player (1+ ray-count))))
(atomic-box-set! rays rays-next)
(wait)))))
(begin-thread
(while
#t (let ((rays-next (ray-trace player (1+ ray-count))))
(atomic-box-set! rays rays-next)
(wait))))
(for-each
(lambda (type)
......@@ -275,9 +289,14 @@
(sdl-init)
(ttf-init)
(current-font (load-font (media "/font.otf") 12))
(define current-font
(make-parameter
(load-font (media "/font.otf") 20)))
(format #t "Loaded font ~a~%" (current-font))
(let ((sock-path "/tmp/guile-socket"))
(use-modules (system repl server))
(delete-file sock-path)
(spawn-server (make-unix-domain-server-socket #:path sock-path)))
(call-with-window
(make-window
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment