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