main.scm 14.6 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
(use-modules (srfi srfi-1)
18
             (srfi srfi-27)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
19 20

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

29
             (rnrs base)
30 31 32 33

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

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

40 41 42 43 44 45
(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
46 47

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

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

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

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

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

59 60
(define update
  (let ((keys-down '()))
61
    (lambda (dt)                             ; dt in ms
62

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

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

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

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

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

88
           ((p) (set! (a player) = (+ (* dt 4e-3)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
89 90
            (when (< tau (a player))
              (set! (a player) 0))
91
            (wake))
Gustav Sörnäs's avatar
Gustav Sörnäs committed
92 93 94 95 96 97 98

           ((a d) (set! (p player)
                      = (+ (* dt 3e-3 (if (eq? key 'a) 1 -1)
                            (v3 (sin (a player))
                                (- (cos (a player)))))))
            (wake))
          ))
99
       keys-down))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
100

101
(define (find-next-edge x y a callback)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
102 103 104 105 106
  (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)
107
          (callback (+ x dx) (+ y dy) 'x)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
108 109
          (let* ((dy (* 1.01 dy-ampl (sgn (sin a))))
                 (dx (* dy (cot a))))
110
            (callback (+ x dx) (+ y dy) 'y))))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
111

Hugo Hörnquist's avatar
Hugo Hörnquist committed
112
(define (ray-trace player ray-count)
113
  (let ((p (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
114 115
    (let ((px (x p))
          (py (y p)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
116
      (map (lambda (a)
117
             (let loop ((x px) (y py) (dir 'x))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
118 119 120 121 122
               (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
123 124 125
                      (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
126 127 128

                     ;; hit wall
                     [(array-ref (board-data game-map) (int y) (int x))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
129 130
                      (lambda (tile) (memv tile '(wall)))
                      => (lambda (tile)
131
                           (format #t "start!!!~%")
Hugo Hörnquist's avatar
Hugo Hörnquist committed
132 133
                           (list (make-ray #:a a #:type tile
                                           #:v (v3 (- x px) (- y py))
134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
                                           #: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
Hugo Hörnquist's avatar
Hugo Hörnquist committed
190 191 192 193 194
                                           #: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
195
                      => (lambda (tile)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
196 197 198
                           (cons (make-ray #:a a #:type tile
                                           #:v (v3 (- x px) (- y py))
                                           #:hitf (v3 x y))
199
                                 (find-next-edge x y a loop)))]
Hugo Hörnquist's avatar
Hugo Hörnquist committed
200 201

                     ;; follow ray
202
                     [else (find-next-edge x y a loop)])))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
203 204 205

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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
208
(define (draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
209
  (set-draw-color #xFF #xFF #xFF)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
210 211
  (clear)

212
  ;; draw level
Hugo Hörnquist's avatar
Hugo Hörnquist committed
213 214
  (for-each
   (lambda (pt)
215
     (apply set-draw-color
216
      (case (array-ref (board-data game-map) (y pt) (x pt))
217 218
        ((wall)   '(#xBB #xBB #xBB))
        ((window) '(#x10 #x10 #xFF))
219
        ((lamp)   '(#xFF #xFF #x0))
220 221 222
        ((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
223
   (map (lambda (p) (apply v3 p))
224
        (cross-product (iota (board-width game-map)) (iota (board-height game-map)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
225

226 227
  ;; draw raycast
  (set-draw-color #xFF 0 0)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
228

Hugo Hörnquist's avatar
Hugo Hörnquist committed
229
  (let ((pp (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
230 231 232 233 234 235 236 237 238
    (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
239
  )
Hugo Hörnquist's avatar
Hugo Hörnquist committed
240

Hugo Hörnquist's avatar
Hugo Hörnquist committed
241
(define (draw-first-person-perspective)
242
  (set-draw-color #xBB #xBB #xFF)       ; light blue
Hugo Hörnquist's avatar
Hugo Hörnquist committed
243 244
  (clear)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
245
  ;; floor
Hugo Hörnquist's avatar
Hugo Hörnquist committed
246 247 248 249
  (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
250
  (let ((rays (atomic-box-ref rays)))
251 252
    (unless (null? rays)
      (for-each
Hugo Hörnquist's avatar
Hugo Hörnquist committed
253 254 255 256 257 258 259 260
       (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))))

261 262 263 264 265 266 267 268 269 270 271 272
                          ;; 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)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
273 274 275 276 277 278 279 280 281 282 283 284 285 286

                          (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))
287 288 289
       (iota ray-count)
       rays
       ))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
290 291


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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
293 294 295

(define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0))
296
  (let ((surf (render-font-blended (current-font) str (color))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
297 298
    (render-copy (current-renderer)
                 (surface->texture (current-renderer) surf)
299
                 #:dstrect (list 5 (+ 1 (* line (+ 1 (font-height (current-font)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
300
                                 (surface-width surf)
301 302
                                 (surface-height surf)))
    (delete-surface! surf)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
303

304 305


Hugo Hörnquist's avatar
Hugo Hörnquist committed
306 307 308 309 310
(define (with-render-target target thunk)
  (dynamic-wind (lambda () (set-render-target! (current-renderer) target))
                thunk
                (lambda () (set-render-target! (current-renderer) #f))))

311
(define (make-fps-counter)
312
  (let ((last-time (sdl-ticks)))
313
    (lambda ()
314 315
      ;; TODO this only ticks when sdl is active, which is NOT when
      ;; the window is unmapped
316
      (let ((new-time (sdl-ticks)))
317 318 319 320 321 322 323
        (let ((return (- new-time last-time)))
          (set! last-time new-time)
          return)))))

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

327 328
        ;; minimap
        (let ((texture (make-texture rend 'rgba8888 'target
Hugo Hörnquist's avatar
Hugo Hörnquist committed
329
                                     (int (* (board-width game-map)  (current-tile-size)))
330
                                     (* (board-height game-map) (current-tile-size)))))
331
          (with-render-target texture draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
332

333
          ;; Camera
Hugo Hörnquist's avatar
Hugo Hörnquist committed
334
          (draw-first-person-perspective)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
335

336
          (render-copy rend texture
337
                       #:dstrect
Hugo Hörnquist's avatar
Hugo Hörnquist committed
338
                       (let ((map-size 100))
339 340
                         (list 0 (- 480 map-size)
                               map-size map-size)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
341

342
          (delete-texture! texture))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
343

344 345
        ;; Text overlay
        (parameterize ((color (make-color 0 0 0 #xFF)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
346

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

350 351 352 353
          (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
354

355
        (present)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
356 357

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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
361 362
  (begin-thread
   (while
363
       #t (let ((rays-next (ray-trace player ray-count)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
364 365
            (atomic-box-set! rays rays-next)
            (wait))))
366

367
  ;; load textures
Hugo Hörnquist's avatar
Hugo Hörnquist committed
368 369 370 371 372
  (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
373

374 375 376 377 378 379 380 381 382 383
  (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)))

384 385
  (let ((counter 0))
    (while #t
386
           (sigaction SIGINT (lambda (sig) (break)))
387 388 389

           (if (= counter 1)
               (begin (draw window rend) (set! counter 0))
390
               (let ((dt (fps-counter)))
391
                 (update dt)
392
                 (usleep (max 0 (floor/ (- 1000 dt) 360)))
393
                 (set! counter = (+ 1)))))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
394

395 396 397 398 399
(define current-font (make-parameter #f))

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

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

403 404 405 406
  ;; (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
407

408 409 410 411 412
  (call-with-window
   (make-window
    #:title "Wolf 3D"
    #:size '(640 480))
   main-loop)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
413

414 415
  (ttf-quit)
  (sdl-quit))