#!/usr/bin/env bash
# -*- mode: scheme -*-
export GUILE_LOAD_PATH=$HOME/.local/share/guile/site/2.2
export GUILE_LOAD_COMPILED_PATH=$HOME/.local/lib/guile/2.2/site-ccache
exec guile -q -e main -s $0
!#
;; (add-to-load-path "/usr/local/share/guile/site/2.2/")
(add-to-load-path (dirname (current-filename)))
(define (media str)
(string-append (dirname (current-filename)) str))
(use-modules (srfi srfi-1)
(srfi srfi-27)
(sdl2)
(sdl2 ttf)
(sdl2 video)
(sdl2 image)
(sdl2 rect)
(sdl2 render)
(sdl2 surface)
(sdl2 events)
(rnrs base)
(ice-9 threads)
(ice-9 atomic)
(util)
(map)
(class)
(draw)
)
(define-values (wait wake)
(let ((mutex (make-mutex))
(condvar (make-condition-variable)))
(values
(lambda () (with-mutex mutex (wait-condition-variable condvar mutex)))
(lambda () (broadcast-condition-variable condvar)))))
(define texture-map (make-hash-table))
(define ray-count 64)
(define rays (make-atomic-box '()))
(define game-map (call-with-input-file "b-huset.map" (compose parse-map read-map)))
(define player (make-player (+ 1/2 (car (board-spawn game-map)))
(+ 1/2 (cadr (board-spawn game-map)))
0.1))
(define update
(let ((keys-down '()))
(lambda (dt) ; dt in ms
(let ((ev (poll-event)))
(cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings
[(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)]))
(for-each
(lambda (key)
(case key
((x q) (raise SIGINT))
((w s) (set! (p player)
= (+ (* dt 6e-3 (if (eq? key 'w) 1 -1)
(v3 (cos (a player))
(sin (a player))))))
(wake))
((j) (set! (a player) = (- (* dt 4e-3)))
(when (> 0 (a player))
(set! (a player) tau))
(wake))
((p) (set! (a player) = (+ (* dt 4e-3)))
(when (< tau (a player))
(set! (a player) 0))
(wake))
((a d) (set! (p player)
= (+ (* dt 3e-3 (if (eq? key 'a) 1 -1)
(v3 (sin (a player))
(- (cos (a player)))))))
(wake))
))
keys-down))))
(define (find-next-edge x y a callback)
(let ((dx-ampl (mod (* -1 (sgn (cos a)) (decimals x)) 1))
(dy-ampl (mod (* -1 (sgn (sin a)) (decimals y)) 1)))
(let* ((dx (* 1.01 dx-ampl (sgn (cos a))))
(dy (* dx (tan a))))
(if (<= (abs dy) dy-ampl)
(callback (+ x dx) (+ y dy) 'x)
(let* ((dy (* 1.01 dy-ampl (sgn (sin a))))
(dx (* dy (cot a))))
(callback (+ x dx) (+ y dy) 'y))))))
(define (ray-trace player ray-count)
(let ((p (p player)))
(let ((px (x p))
(py (y p)))
(map (lambda (a)
(let loop ((x px) (y py) (dir 'x))
(cond [(or (not (and (<= 0 x) (< x (board-width game-map))
(<= 0 y) (< y (board-height game-map))))
(< 15 (sqrt (+ (expt (- x px) 2)
(expt (- y py) 2)))))
;; outside board
(list (make-ray #:a a #:type #f
#:v (v3 (- x px) (- y py))
#:hitf (v3 x y))) ]
;; hit wall
[(array-ref (board-data game-map) (int y) (int x))
(lambda (tile) (memv tile '(wall)))
=> (lambda (tile)
(format #t "start!!!~%")
(list (make-ray #:a a #:type tile
#:v (v3 (- x px) (- y py))
#:hitf (v3 x y)
#:htw
;; (random-integer 5)
;; för a > 0:
(let loop ((htl 1)
(x (- x (* 0.1 (sgn (cos a)))))
(y (- y (* 0.1 (sgn (sin a)))))
(a (case dir
((x) (mod (- a) tau))
((y) (mod (- pi a) tau)))))
(find-next-edge
x y a
(lambda (x y dir)
;; (format #t "x = ~a, y = ~a, a = ~a~%"
;; x y a)
(cond
[(or (not (and (<= 0 x) (< x (board-width game-map))
(<= 0 y) (< y (board-height game-map))))
#;
(< 15 (sqrt (+ (expt (- x px) 2) ;
(expt (- y py) 2)))))
-1
]
[(eq? 'lamp
(array-ref (board-data game-map)
(int y) (int x)))
htl]
[(> htl 10)
-1]
[(array-ref (board-data game-map) (int y) (int x))
(lambda (tile) (memv tile '(wall)))
=> (lambda _
(loop (1+ htl)
(- x (* 0.1 (sgn (cos a))))
(- y (* 0.1 (sgn (sin a))))
(case dir
((x) (mod (- a) tau))
((y) (mod (- pi a) tau)))))]
[else
(loop htl
x y a
#; (mod (+ pi a) tau)
)]))))))
)]
[(array-ref (board-data game-map) (int y) (int x))
(lambda (tile) (memv tile '(lamp)))
=> (lambda (tile)
(list (make-ray #:a a #:type tile
#:v (v3 (- x px) (- y py))
#:htw 0
#:hitf (v3 x y))))]
;; hit window
[(array-ref (board-data game-map) (int y) (int x))
(lambda (tile) (memv tile '(window)))
=> (lambda (tile)
(cons (make-ray #:a a #:type tile
#:v (v3 (- x px) (- y py))
#:hitf (v3 x y))
(find-next-edge x y a loop)))]
;; follow ray
[else (find-next-edge x y a loop)])))
(iota ray-count (- (a player) (/ (fov player) 2))
(/ (fov player) ray-count)))))
)
(define (draw-map)
(set-draw-color #xFF #xFF #xFF)
(clear)
;; draw level
(for-each
(lambda (pt)
(apply set-draw-color
(case (array-ref (board-data game-map) (y pt) (x pt))
((wall) '(#xBB #xBB #xBB))
((window) '(#x10 #x10 #xFF))
((lamp) '(#xFF #xFF #x0))
((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 game-map)) (iota (board-height game-map)))))
;; draw raycast
(set-draw-color #xFF 0 0)
(let ((pp (p player)))
(for-each
(lambda (rays)
(for-each
(lambda (ray)
(let ((v (+ pp (vec ray))))
(draw-line (x pp) (y pp)
(x v) (y v))))
rays))
(atomic-box-ref rays)))
)
(define (draw-first-person-perspective)
(set-draw-color #xBB #xBB #xFF) ; light blue
(clear)
;; floor
(set-draw-color #x33 #x33 #x33)
(render-fill-rect (current-renderer)
(make-rect 0 240 640 240))
(let ((rays (atomic-box-ref rays)))
(unless (null? rays)
(for-each
(lambda (i rays)
(for-each
(lambda (r)
(cond ((hashq-ref texture-map (type r))
=> (lambda (texture)
(let* ((l (length r))
(segment-height (int (- 480 (* 30 l) 40))))
;; 0, 5
;; (format #t "HTL = ~a~%" (hits-to-wall r))
(when (= -1 (hits-to-wall r))
(let ((c 0))
;; add light effect
(set-texture-color-mod! texture c c c)))
(when (< 0 (hits-to-wall r))
(let ((c (max 0 (int (- #xFF (* (/ (hits-to-wall r)) l 10))))))
;; add light effect
(set-texture-color-mod! texture c c c)))
(render-copy
(current-renderer)
texture
#: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)))))))
rays))
(iota ray-count)
rays
))))
(define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0))
(let ((surf (render-font-blended (current-font) str (color))))
(render-copy (current-renderer)
(surface->texture (current-renderer) surf)
#:dstrect (list 5 (+ 1 (* line (+ 1 (font-height (current-font)))))
(surface-width surf)
(surface-height surf)))
(delete-surface! 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 (make-fps-counter)
(let ((last-time (sdl-ticks)))
(lambda ()
;; TODO this only ticks when sdl is active, which is NOT when
;; the window is unmapped
(let ((new-time (sdl-ticks)))
(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)
(current-tile-size (/ 480 (board-height game-map))))
;; minimap
(let ((texture (make-texture rend 'rgba8888 'target
(int (* (board-width game-map) (current-tile-size)))
(* (board-height game-map) (current-tile-size)))))
(with-render-target texture draw-map)
;; Camera
(draw-first-person-perspective)
(render-copy rend texture
#:dstrect
(let ((map-size 100))
(list 0 (- 480 map-size)
map-size map-size)))
(delete-texture! texture))
;; Text overlay
(parameterize ((color (make-color 0 0 0 #xFF)))
;; FPS counter
(render-text (format #f "FPS: ~,2f" (/ 1000 (1+ (fps-counter)))) #:line 0)
(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 fps-counter (make-fps-counter))
(begin-thread
(while
#t (let ((rays-next (ray-trace player ray-count)))
(atomic-box-set! rays rays-next)
(wait))))
;; load textures
(for-each
(lambda (type)
(hashq-set! texture-map type
(surface->texture rend (load-image (media (format #f "/textures/~a.png" type))))))
'(wall window))
(parameterize ((current-renderer rend))
(let ((lamp-text (make-texture rend 'rgba8888 'target 16 16)))
(format #t "lamp = ~a~%" lamp-text)
(with-render-target
lamp-text
(lambda ()
(set-draw-color #xFF #xFF #x0)
(clear)))
(hashq-set! texture-map 'lamp lamp-text)))
(let ((counter 0))
(while #t
(sigaction SIGINT (lambda (sig) (break)))
(if (= counter 1)
(begin (draw window rend) (set! counter 0))
(let ((dt (fps-counter)))
(update dt)
(usleep (max 0 (floor/ (- 1000 dt) 360)))
(set! counter = (+ 1)))))))
(define current-font (make-parameter #f))
(define (main args)
(sdl-init)
(ttf-init)
(current-font (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)))
(call-with-window
(make-window
#:title "Wolf 3D"
#:size '(640 480))
main-loop)
(ttf-quit)
(sdl-quit))