Commit 263e79c9 authored by Hugo Hörnquist's avatar Hugo Hörnquist
Browse files

Numerous small fixes and improvements.

parent c3ac8699
...@@ -44,16 +44,13 @@ ...@@ -44,16 +44,13 @@
(length #:accessor length #:init-keyword #:length #:init-value #f) (length #:accessor length #:init-keyword #:length #:init-value #f)
(vec #:accessor vec #:init-keyword #:v) (vec #:accessor vec #:init-keyword #:v)
(pos-on-wall #:accessor pos-on-wall) (pos-on-wall #:accessor pos-on-wall)
(hit-coord #:accessor hit #:init-keyword #:hit) (hit-point #:getter hitf #:init-keyword #:hitf)
(hit-float-point #:getter hitf #:init-keyword #:hitf)
(wall-direction #:accessor wall-direction)
(tile-type #:getter type (tile-type #:getter type
#:initial-value 'space #:initial-value #f
#:init-keyword #:type #:init-keyword #:type)
)
) )
(export a length vec pos-on-wall hit hitf local-wall-segment wall-direction type) (export a length vec pos-on-wall hitf type)
(define (decimals x) (define (decimals x)
(- x (truncate x))) (- x (truncate x)))
......
...@@ -42,129 +42,91 @@ ...@@ -42,129 +42,91 @@
(define ray-count 64) (define ray-count 64)
(define rays (make-atomic-box '())) (define rays (make-atomic-box '()))
(define update (define update
(let ((keys-down '())) (let ((keys-down '()))
(lambda (dt) (lambda (dt) ; dt in μs
(let ((ev (poll-event))) (let ((ev (poll-event)))
(cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings (cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings
[(and (keyboard-down-event? ev)
(not (memv (keyboard-event-scancode ev) [(keyboard-down-event? ev)
keys-down))) (set! keys-down (lset-adjoin eq? keys-down (keyboard-event-scancode ev)))]
(set! keys-down (cons (keyboard-event-scancode ev)
keys-down))]
[(keyboard-up-event? ev) [(keyboard-up-event? ev)
(set! keys-down (delv (keyboard-event-scancode ev) (set! keys-down (delv (keyboard-event-scancode ev) keys-down))]
keys-down))]
[(quit-event? ev) (raise SIGINT)]))
[(quit-event? ev) (raise SIGINT)]))
(for-each (for-each
(lambda (key) (lambda (key)
(case key (case key
((x q) (raise SIGINT)) ((x q) (raise SIGINT))
((w) (set! (p player) = (+ (* dt 0.000009 ((w s) (set! (p player)
= (+ (* dt 6e-6 (if (eq? key 'w) 1 -1)
(v3 (cos (a player)) (v3 (cos (a player))
(sin (a player)))))) (sin (a player))))))
(wake) (wake))
) ((j) (set! (a player) = (- (* dt 4e-6)))
((s) (set! (p player) = (+ (* dt 0.000006 -1 (wake))
(v3 (cos (a player)) ((p) (set! (a player) = (+ (* dt 4e-6)))
(sin (a player)))))) (wake))
(wake)
)
;; ((a) (set! (p player) = (+ (* dt 0.000003 -1
;; (v3 (sin (a player))
;; (cos (a player)))))) ret)
;; ((d) (set! (p player) = (+ (* dt 0.000003
;; (v3 (sin (a player))
;; (cos (a player)))))) ret)
((j) (set! (a player) = (- (* dt 0.000004)))
(wake)
)
((p) (set! (a player) = (+ (* dt 0.000004)))
(wake)
)
)) ))
keys-down)))) keys-down))))
(define (ray-trace player ray-count) (define (ray-trace player ray-count)
(let ((x (x (p player))) (let ((p (p player)))
(y (y (p player))))
(map (map
(lambda (a) (lambda (a)
(let loop ((dx 0) (let loop ((dx 0) (dy 0))
(dy 0)) (let ((nx (+ dx (x p)))
(let ((nx (+ x dx)) (ny (+ dy (y p))))
(ny (+ y dy))) (if (not (and (<= 0 nx board-width)
(let ((ix (int nx))
(iy (int ny)))
(if (or (not (and (<= 0 nx board-width)
(<= 0 ny board-height)))
(memv (array-ref game-map iy ix)
'(wall window)))
(make-ray #:a a
#:v (v3 dx dy)
#:type (if (not (and (<= 0 nx board-width)
(<= 0 ny board-height))) (<= 0 ny board-height)))
#f (array-ref game-map iy ix)) (make-ray #:a a #:v (v3 dx dy)
#:hitf (v3 nx ny) #:hitf (v3 nx ny)
#:hit (v3 ix iy)) #:type #f)
(loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a))))))))) (let ((tile (array-ref game-map (int ny) (int nx))))
(if (memv tile '(wall window))
(make-ray #:a a #:v (v3 dx dy)
#:type tile
#:hitf (v3 nx ny))
;; else continue
(loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a))))))))))
(iota ray-count (- (a player) (/ (fov player) 2)) (iota ray-count (- (a player) (/ (fov player) 2))
(/ (fov player) ray-count))))) (/ (fov player) ray-count)))))
(define fps-time (get-t))
(define (draw-map) (define (draw-map)
(set-draw-color #xFF #xFF #xFF) (set-draw-color #xFF #xFF #xFF)
(clear) (clear)
(set-draw-color 0 0 #xFF) ;; draw level
(for-each (for-each
(lambda (pt) (lambda (pt)
(apply set-draw-color
(case (array-ref game-map (y pt) (x pt)) (case (array-ref game-map (y pt) (x pt))
((wall) (set-draw-color #xBB #xBB #xBB)) ((wall) '(#xBB #xBB #xBB))
((window) (set-draw-color #x10 #x10 #xFF)) ((window) '(#x10 #x10 #xFF))
((grass) (set-draw-color 0 #xCC 0)) ((grass) '(0 #xCC 0))
(else (set-draw-color #xFF #xFF #xFF))) (else '(#xFF #xFF #xFF))))
(fill-rect (fill-rect (x pt) (y pt) 1 1))
(x pt) (y pt)
1 1))
(map (lambda (p) (apply v3 p)) (map (lambda (p) (apply v3 p))
(cross-product (iota board-width) (iota board-height)))) (cross-product (iota board-width) (iota board-height))))
(set-draw-color #xFF 0 0)
(fill-rect
(- (x (p player)) 0.1)
(- (y (p player)) 0.1)
0.2 0.2)
(let ((pp (p player))) ;; draw raycast
(for-each (lambda (ray) (set-draw-color #xFF 0 0)
(let ((v (+ pp (vec ray)))) (let ((p (p player)))
(draw-line (x pp) (y pp) (for-each
(lambda (ray)
(let ((v (+ p (vec ray))))
(draw-line (x p) (y p)
(x v) (y v)))) (x v) (y v))))
(atomic-box-ref rays) (atomic-box-ref rays))))
))
(set-draw-color 0 #xFF 0)
(draw-line
(x (p player)) (y (p player))
(+ (cos (a player)) (x (p player)))
(+ (sin (a player)) (y (p player))))
;; (present)
)
(define (draw-first-person-perspective) (define (draw-first-person-perspective)
(set-draw-color #xBB #xBB #xFF) (set-draw-color #xBB #xBB #xFF) ; light blue
(clear) (clear)
;; floor ;; floor
...@@ -175,29 +137,30 @@ ...@@ -175,29 +137,30 @@
(let ((rays (atomic-box-ref rays))) (let ((rays (atomic-box-ref rays)))
(unless (null? rays) (unless (null? rays)
(for-each (lambda (i r r+) (for-each (lambda (i r)
(when (hashq-ref texture-map (type r)) (let ((hit-tile (hashq-ref texture-map (type r))))
(when hit-tile
(let* ((l (length r)) (let* ((l (length r))
(segment-height (- 480 (* 30 l) 40)) (segment-height (int (- 480 (* 30 l) 40))))
(texture (hashq-ref texture-map (type r))))
;; Fade to black when far away
(let ((c (max 0 (int (- #xFF (* l 20)))))) (let ((c (max 0 (int (- #xFF (* l 20))))))
(set-texture-color-mod! texture c c c)) (set-texture-color-mod! hit-tile c c c))
(render-copy (render-copy
(current-renderer) (current-renderer)
texture hit-tile
#:dstrect (list (int (* i (/ 640 ray-count))) #:dstrect (list (floor/ (* i 640) ray-count)
(int (/ (- 480 segment-height) 2)) (floor/ (- 480 segment-height) 2)
(int (+ 0 (/ 640 ray-count))) (floor/ 640 ray-count)
(int segment-height)) segment-height)
#:srcrect #:srcrect
(list (int (* 16 (pos-on-wall r))) 0 (list (int (* 16 (pos-on-wall r))) 0
1 16))))) 1 16))))))
(iota ray-count) (iota ray-count)
rays (cdr rays) rays
))) )))
) )
...@@ -206,10 +169,10 @@ ...@@ -206,10 +169,10 @@
(define color (make-parameter (make-color 0 0 0 #xFF))) (define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0)) (define* (render-text str #:key (line 0))
(let ((surf (render-font-solid (current-font) str (color)))) (let ((surf (render-font-blended (current-font) str (color))))
(render-copy (current-renderer) (render-copy (current-renderer)
(surface->texture (current-renderer) surf) (surface->texture (current-renderer) surf)
#:dstrect (list 1 (+ 1 (* line (+ 3 (font-height (current-font))))) #:dstrect (list 5 (+ 1 (* line (+ 1 (font-height (current-font)))))
(surface-width surf) (surface-width surf)
(surface-height surf))))) (surface-height surf)))))
...@@ -220,7 +183,17 @@ ...@@ -220,7 +183,17 @@
thunk thunk
(lambda () (set-render-target! (current-renderer) #f)))) (lambda () (set-render-target! (current-renderer) #f))))
(define (draw window rend) (define (make-fps-counter)
(let ((last-time (get-t)))
(lambda ()
(let ((new-time (get-t)))
(let ((return (- new-time last-time)))
(set! last-time new-time)
return)))))
(define draw
(let ((fps-counter (make-fps-counter)))
(lambda ( window rend)
(parameterize ((current-renderer rend)) (parameterize ((current-renderer rend))
;; minimap ;; minimap
...@@ -242,23 +215,18 @@ ...@@ -242,23 +215,18 @@
(parameterize ((color (make-color 0 0 0 #xFF))) (parameterize ((color (make-color 0 0 0 #xFF)))
;; FPS counter ;; FPS counter
(let ((nt (get-t))) (render-text (format #f "FPS: ~,2f" (/ 1000000 (fps-counter))) #:line 0)
(render-text (format #f "FPS: ~,2f" (/ 1000000 (- nt fps-time)))
#:line 0)
(set! fps-time nt))
(render-text (render-text
(format #f "x = ~,4f y = ~,4f a = ~,4f" (format #f "x = ~,4f y = ~,4f a = ~,4f"
(x (p player)) (x (p player)) (y (p player)) (a player))
(y (p player))
(a player))
#:line 1)) #:line 1))
(present))) (present)))))
(define (main-loop window) (define (main-loop window)
(define rend (make-renderer window '(accelerated #; vsync texture))) (define rend (make-renderer window '(accelerated #; vsync texture)))
(define last-t (get-t)) (define fps-counter (make-fps-counter))
(begin-thread (begin-thread
(while (while
...@@ -266,6 +234,7 @@ ...@@ -266,6 +234,7 @@
(atomic-box-set! rays rays-next) (atomic-box-set! rays rays-next)
(wait)))) (wait))))
;; load textures
(for-each (for-each
(lambda (type) (lambda (type)
(hashq-set! texture-map type (hashq-set! texture-map type
...@@ -274,17 +243,13 @@ ...@@ -274,17 +243,13 @@
(let ((counter 0)) (let ((counter 0))
(while #t (while #t
;; (usleep (int (/ 1000000 (* 60 60)))) (sigaction SIGINT (lambda (sig) (break)))
(sigaction SIGINT (lambda (sig) (break )))
(if (= counter 1) (if (= counter 1)
(begin (draw window rend) (set! counter 0)) (begin (draw window rend) (set! counter 0))
(let ((dt (let ((t (get-t))) (let ((dt (fps-counter)))
(let ((dt (- t last-t)))
(set! last-t t)
dt))))
(update dt) (update dt)
(usleep (int (/ (- 1000000 dt) 1000))) (usleep (int (/ (- 1000000 dt) 360)))
(set! counter = (+ 1))))))) (set! counter = (+ 1)))))))
(sdl-init) (sdl-init)
...@@ -294,10 +259,10 @@ ...@@ -294,10 +259,10 @@
(make-parameter (make-parameter
(load-font (media "/font.otf") 20))) (load-font (media "/font.otf") 20)))
(let ((sock-path "/tmp/guile-socket")) ;; (let ((sock-path "/tmp/guile-socket"))
(use-modules (system repl server)) ;; (use-modules (system repl server))
(delete-file sock-path) ;; (delete-file sock-path)
(spawn-server (make-unix-domain-server-socket #:path sock-path))) ;; (spawn-server (make-unix-domain-server-socket #:path sock-path)))
(call-with-window (call-with-window
(make-window (make-window
......
...@@ -43,7 +43,7 @@ ...@@ -43,7 +43,7 @@
" # ### # # # # # #" " # ### # # # # # #"
" # ####%#%##%##%#%##%##" " # ####%#%##%##%#%##%##"
" # % " " # % "
" ########################"))) " ## #####################")))
......
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