main.scm 10.1 KB
Newer Older
1 2 3 4 5 6 7 8
#!/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
9 10
!#

Hugo Hörnquist's avatar
Hugo Hörnquist committed
11
;; (add-to-load-path "/usr/local/share/guile/site/2.2/")
12
(add-to-load-path (dirname (current-filename)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
13

14 15 16
(define (media str)
  (string-append (dirname (current-filename)) str))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
17 18 19
(use-modules (srfi srfi-1)

             (sdl2)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
20
             (sdl2 ttf)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
21
             (sdl2 video)
22
             (sdl2 image)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
23 24 25 26
             (sdl2 rect)
             (sdl2 render)
             (sdl2 surface)
             (sdl2 events)
27

28
             (rnrs base)
29 30 31 32

             (ice-9 threads)
             (ice-9 atomic)

33 34 35 36
             (util)
             (map)
             (class)
             (draw)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
37 38
             )

39 40 41 42 43 44
(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)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
45 46

(define texture-map (make-hash-table))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
47

Hugo Hörnquist's avatar
Hugo Hörnquist committed
48
(define ray-count 64)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
49

50
(define rays (make-atomic-box '()))
Hugo Hörnquist's avatar
huh?  
Hugo Hörnquist committed
51

Hugo Hörnquist's avatar
Hugo Hörnquist committed
52
(define game-map (call-with-input-file "b-huset.map" (compose parse-map read-map)))
53 54 55

(define player (make-player (+ 1/2 (car (board-spawn game-map)))
                            (+ 1/2 (cadr (board-spawn game-map)))
56
                            0.1))
57

58 59
(define update
  (let ((keys-down '()))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
60
    (lambda (dt)                             ; dt in ms
61

62 63
      (let ((ev (poll-event)))
        (cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings
64 65 66 67

         [(keyboard-down-event? ev)
          (set! keys-down (lset-adjoin eq? keys-down (keyboard-event-scancode ev)))]

68
         [(keyboard-up-event? ev)
69
          (set! keys-down (delv (keyboard-event-scancode ev) keys-down))]
70

71
         [(quit-event? ev) (raise SIGINT)]))
72

73 74 75 76
      (for-each
       (lambda (key)
         (case key
           ((x q) (raise SIGINT))
77
           ((w s) (set! (p player)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
78
                        = (+ (* dt 6e-3 (if (eq? key 'w) 1 -1)
79 80 81
                                (v3 (cos (a player))
                                    (sin (a player))))))
            (wake))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
82
           ((j) (set! (a player) = (- (* dt 4e-3)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
83 84
            (when (> 0 (a player))
              (set! (a player) tau))
85
            (wake))
86

Hugo Hörnquist's avatar
Hugo Hörnquist committed
87
           ((p) (set! (a player) = (+ (* dt 4e-3)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
88 89
            (when (< tau (a player))
              (set! (a player) 0))
90
            (wake))
91 92
           ))
       keys-down))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
93

Hugo Hörnquist's avatar
Hugo Hörnquist committed
94 95 96 97 98 99 100 101 102 103
(define (find-next-wall 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))
          (let* ((dy (* 1.01 dy-ampl (sgn (sin a))))
                 (dx (* dy (cot a))))
            (callback (+ x dx) (+ y dy)))))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
104

Hugo Hörnquist's avatar
Hugo Hörnquist committed
105
(define (ray-trace player ray-count)
106
  (let ((p (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
107 108
    (let ((px (x p))
          (py (y p)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
109 110 111 112 113 114 115
      (map (lambda (a)
             (let loop ((x px) (y py))
               (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
Hugo Hörnquist's avatar
Hugo Hörnquist committed
116 117 118
                      (list (make-ray #:a a #:type #f
                                      #:v (v3 (- x px) (- y py))
                                      #:hitf (v3 x y))) ]
Hugo Hörnquist's avatar
Hugo Hörnquist committed
119 120 121

                     ;; hit wall
                     [(array-ref (board-data game-map) (int y) (int x))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
122 123 124 125 126 127 128 129 130
                      (lambda (tile) (memv tile '(wall)))
                      => (lambda (tile)
                           (list (make-ray #:a a #:type tile
                                           #:v (v3 (- x px) (- y py))
                                           #:hitf (v3 x y))))]

                     ;; hit window
                     [(array-ref (board-data game-map) (int y) (int x))
                      (lambda (tile) (memv tile '(window)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
131
                      => (lambda (tile)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
132 133 134 135
                           (cons (make-ray #:a a #:type tile
                                           #:v (v3 (- x px) (- y py))
                                           #:hitf (v3 x y))
                                 (find-next-wall x y a loop)))]
Hugo Hörnquist's avatar
Hugo Hörnquist committed
136 137

                     ;; follow ray
Hugo Hörnquist's avatar
Hugo Hörnquist committed
138
                     [else (find-next-wall x y a loop)])))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
139 140 141

           (iota ray-count (- (a player) (/ (fov player) 2))
                 (/ (fov player) ray-count)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
142
  )
Hugo Hörnquist's avatar
Hugo Hörnquist committed
143

Hugo Hörnquist's avatar
Hugo Hörnquist committed
144
(define (draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
145
  (set-draw-color #xFF #xFF #xFF)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
146 147
  (clear)

148
  ;; draw level
Hugo Hörnquist's avatar
Hugo Hörnquist committed
149 150
  (for-each
   (lambda (pt)
151
     (apply set-draw-color
152
      (case (array-ref (board-data game-map) (y pt) (x pt))
153 154 155 156 157
        ((wall)   '(#xBB #xBB #xBB))
        ((window) '(#x10 #x10 #xFF))
        ((grass)  '(0 #xCC 0))
        (else     '(#xFF #xFF #xFF))))
     (fill-rect (x pt) (y pt) 1 1))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
158
   (map (lambda (p) (apply v3 p))
159
        (cross-product (iota (board-width game-map)) (iota (board-height game-map)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
160

161 162
  ;; draw raycast
  (set-draw-color #xFF 0 0)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
163

Hugo Hörnquist's avatar
Hugo Hörnquist committed
164
  (let ((pp (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
165 166 167 168 169 170 171 172 173
    (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)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
174
  )
Hugo Hörnquist's avatar
Hugo Hörnquist committed
175

Hugo Hörnquist's avatar
Hugo Hörnquist committed
176
(define (draw-first-person-perspective)
177
  (set-draw-color #xBB #xBB #xFF)       ; light blue
Hugo Hörnquist's avatar
Hugo Hörnquist committed
178 179
  (clear)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
180
  ;; floor
Hugo Hörnquist's avatar
Hugo Hörnquist committed
181 182 183 184
  (set-draw-color #x33 #x33 #x33)
  (render-fill-rect (current-renderer)
                    (make-rect 0 240 640 240))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
185
  (let ((rays (atomic-box-ref rays)))
186 187
    (unless (null? rays)
      (for-each
Hugo Hörnquist's avatar
Hugo Hörnquist committed
188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
       (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))))

                          (let ((c (max 0 (int (- #xFF (* l 20))))))
                            (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))
212 213 214
       (iota ray-count)
       rays
       ))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
215 216


Hugo Hörnquist's avatar
Hugo Hörnquist committed
217

Hugo Hörnquist's avatar
Hugo Hörnquist committed
218 219 220

(define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0))
221
  (let ((surf (render-font-blended (current-font) str (color))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
222 223
    (render-copy (current-renderer)
                 (surface->texture (current-renderer) surf)
224
                 #:dstrect (list 5 (+ 1 (* line (+ 1 (font-height (current-font)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
225
                                 (surface-width surf)
226 227
                                 (surface-height surf)))
    (delete-surface! surf)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
228

229 230


Hugo Hörnquist's avatar
Hugo Hörnquist committed
231 232 233 234 235
(define (with-render-target target thunk)
  (dynamic-wind (lambda () (set-render-target! (current-renderer) target))
                thunk
                (lambda () (set-render-target! (current-renderer) #f))))

236
(define (make-fps-counter)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
237
  (let ((last-time (sdl-ticks)))
238
    (lambda ()
239 240
      ;; TODO this only ticks when sdl is active, which is NOT when
      ;; the window is unmapped
Hugo Hörnquist's avatar
Hugo Hörnquist committed
241
      (let ((new-time (sdl-ticks)))
242 243 244 245 246 247 248
        (let ((return (- new-time last-time)))
          (set! last-time new-time)
          return)))))

(define draw
  (let ((fps-counter (make-fps-counter)))
    (lambda ( window rend)
249 250
      (parameterize ((current-renderer rend)
                     (current-tile-size (/ 480 (board-height game-map))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
251

252 253
        ;; minimap
        (let ((texture (make-texture rend 'rgba8888 'target
Hugo Hörnquist's avatar
Hugo Hörnquist committed
254
                                     (int (* (board-width game-map)  (current-tile-size)))
255
                                     (* (board-height game-map) (current-tile-size)))))
256
          (with-render-target texture draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
257

258
          ;; Camera
Hugo Hörnquist's avatar
Hugo Hörnquist committed
259
          (draw-first-person-perspective)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
260

261
          (render-copy rend texture
262
                       #:dstrect
Hugo Hörnquist's avatar
Hugo Hörnquist committed
263
                       (let ((map-size 100))
264 265
                         (list 0 (- 480 map-size)
                               map-size map-size)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
266

267
          (delete-texture! texture))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
268

269 270
        ;; Text overlay
        (parameterize ((color (make-color 0 0 0 #xFF)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
271

272
          ;; FPS counter
Hugo Hörnquist's avatar
Hugo Hörnquist committed
273
          (render-text (format #f "FPS: ~,2f" (/ 1000 (1+ (fps-counter)))) #:line 0)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
274

275 276 277 278
          (render-text
           (format #f "x = ~,4f   y = ~,4f   a = ~,4f"
                   (x (p player)) (y (p player)) (a player))
           #:line 1))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
279

280
        (present)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
281 282

(define (main-loop window)
Hugo Hörnquist's avatar
huh?  
Hugo Hörnquist committed
283
  (define rend (make-renderer window '(accelerated #; vsync texture)))
284
  (define fps-counter (make-fps-counter))
285

Hugo Hörnquist's avatar
Hugo Hörnquist committed
286 287
  (begin-thread
   (while
288
       #t (let ((rays-next (ray-trace player ray-count)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
289 290
            (atomic-box-set! rays rays-next)
            (wait))))
291

292
  ;; load textures
Hugo Hörnquist's avatar
Hugo Hörnquist committed
293 294 295 296 297
  (for-each
   (lambda (type)
     (hashq-set! texture-map type
                 (surface->texture rend (load-image (media (format #f "/textures/~a.png" type))))))
   '(wall window))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
298

299 300
  (let ((counter 0))
    (while #t
301
           (sigaction SIGINT (lambda (sig) (break)))
302 303 304

           (if (= counter 1)
               (begin (draw window rend) (set! counter 0))
305
               (let ((dt (fps-counter)))
306
                 (update dt)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
307
                 (usleep (max 0 (floor/ (- 1000 dt) 360)))
308
                 (set! counter = (+ 1)))))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
309

310 311 312 313 314
(define current-font (make-parameter #f))

(define (main args)
  (sdl-init)
  (ttf-init)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
315

316
  (current-font (load-font (media "/font.otf") 20))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
317

318 319 320 321
  ;; (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)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
322

323 324 325 326 327
  (call-with-window
   (make-window
    #:title "Wolf 3D"
    #:size '(640 480))
   main-loop)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
328

329 330
  (ttf-quit)
  (sdl-quit))