main.scm 11.9 KB
Newer Older
Hugo Hörnquist's avatar
Hugo Hörnquist committed
1
(add-to-load-path "/usr/local/share/guile/site/2.2/")
2
(add-to-load-path (dirname (current-filename)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
3

4 5 6
(define (media str)
  (string-append (dirname (current-filename)) str))

Hugo Hörnquist's avatar
Hugo Hörnquist committed
7 8 9
(use-modules (srfi srfi-1)

             (sdl2)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
10
             (sdl2 ttf)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
11
             (sdl2 video)
12
             (sdl2 image)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
13 14 15 16
             (sdl2 rect)
             (sdl2 render)
             (sdl2 surface)
             (sdl2 events)
17

18 19 20 21

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

22 23 24 25
             (util)
             (map)
             (class)
             (draw)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
26 27
             )

28 29 30 31 32 33
(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
34 35

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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
37
(define player (make-player 5 13 0))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
38

Hugo Hörnquist's avatar
huh?  
Hugo Hörnquist committed
39
(define ray-count 64)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
40

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

43 44
(define update
  (let ((keys-down '()))
45
    (lambda (dt)                             ; dt in ms
46

47 48
      (let ((ev (poll-event)))
        (cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings
49 50 51 52

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

53
         [(keyboard-up-event? ev)
54
          (set! keys-down (delv (keyboard-event-scancode ev) keys-down))]
55

56
         [(quit-event? ev) (raise SIGINT)]))
57

58 59 60 61
      (for-each
       (lambda (key)
         (case key
           ((x q) (raise SIGINT))
62
           ((w s) (set! (p player)
63
                        = (+ (* dt 6e-3 (if (eq? key 'w) 1 -1)
64 65 66
                                (v3 (cos (a player))
                                    (sin (a player))))))
            (wake))
67
           ((j) (set! (a player) = (- (* dt 4e-3)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
68 69
            (when (> 0 (a player))
              (set! (a player) tau))
70
            (wake))
71

72
           ((p) (set! (a player) = (+ (* dt 4e-3)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
73 74
            (when (< tau (a player))
              (set! (a player) 0))
75
            (wake))
76 77
           ))
       keys-down))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
78

Hugo Hörnquist's avatar
Hugo Hörnquist committed
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
;; (define (ray-trace player ray-count)
;;   (let ((x (x (p player)))
;;         (y (y (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)
;;                                                 (<= 0 ny board-height)))
;;                                       #f (array-ref game-map iy ix))
;;                            #:hitf (v3 nx ny)
;;                            #:hit (v3 ix iy))
;;                  (loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a)))))))))
;;      (iota ray-count (- (a player) (/ (fov player) 2))
;;            (/ (fov player) ray-count)))))


(define (pow x y)
  (let ((xd (abs (decimals x)))
        (yd (abs (decimals y))))
    (min (max xd yd)
         (max (- 1 xd) (- 1 yd)))))

(define (decimals x)
  (- x (truncate x)))

(define (cot a)
  (/ (tan a)))

(define sgn signum)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
120
(define (ray-trace player ray-count)
121
  (let ((p (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
122 123 124 125 126 127 128 129 130 131 132 133 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 190 191 192 193 194 195 196 197
    (let ((px (x p))
          (py (y p)))
     (map (lambda (a)
            (let loop ((x px)
                       (y py))

              (cond [(not (and (<= 0 x board-width)
                               (<= 0 y board-height)))
                     ;; outside board
                     (make-ray #:a a
                               #:v (v3 (- x px) (- y py))
                               #:type #f
                               #:hitf (v3 x y)) ]

                    [(array-ref game-map (int y) (int x))
                     (lambda (s) (memv s '(wall window)))
                     => (lambda (tile)
                          ;; hit wall
                          (make-ray #:a a
                                    #:v (v3 (- x px) (- y py))
                                    #:type tile
                                    #:hitf (v3 x y)))]
                    [else
                     ;; follow ray
                     (cond [(< (abs (decimals x)) 0.01)
                            ;; hit wall from left or right

                            (let ((p (- (round (pow x y)) (pow x y))))
                              (cond
                               [(= a 0) (loop (+ x (sgn (cos a))) y)]
                               ;; enter x, leave x
                               [(< 0 (abs (sin a)) (sin (/ tau 8)))
                                (cond [(= p 0)
                                       (loop (+ x (* 0.01 (cos a)))
                                             (+ y (* 0.01 (sin a))))]
                                      [(<= p (tan a))
                                       (loop (+ x (sgn (cos a)))
                                             (+ y (tan a)))]
                                      [else
                                       (loop (+ x (* 0.01 (cos a)))
                                             (+ y (* 0.01 (sin a))))
                                       #;
                                       (let ((dy (* (sgn (sin a))
                                                    (if (= 1 (sgn (sin a)))
                                                        (- 1 (pow x y))
                                                        (pow x y)))))
                                         (loop (+ x (* dy (cot a)))
                                               (+ y dy)))])]

                               ;; enter x, leave y
                               [else
                                (loop (+ x (* 0.01 (cos a)))
                                      (+ y (* 0.01 (sin a))))
 #;
                                (if (= p 0)
                                    (loop (+ x (* 0.01 (cos a)))
                                          (+ y (* 0.01 (sin a))))
                                    (let ((dy (* (- 1 p) (sgn (sin a)))))
                                      (loop (+ x (* dy (cot a)))
                                            (+ y dy) ))
                                    )]))]

                           [(< (abs (decimals y)) 0.01)
                            ;; hit wall from top or bottom
                            (loop (+ x (* 0.01 (cos a)))
                                  (+ y (* 0.01 (sin a))))]

                           [else
                            ;; Middle of square
                            (loop (+ x (* 0.01 (cos a)))
                                  (+ y (* 0.01 (sin a))))]

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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
199
(define (draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
200
  (set-draw-color #xFF #xFF #xFF)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
201 202
  (clear)

203
  ;; draw level
Hugo Hörnquist's avatar
Hugo Hörnquist committed
204 205
  (for-each
   (lambda (pt)
206 207 208 209 210 211 212
     (apply set-draw-color
      (case (array-ref game-map (y pt) (x pt))
        ((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
213 214
   (map (lambda (p) (apply v3 p))
        (cross-product (iota board-width) (iota board-height))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
215

216 217
  ;; draw raycast
  (set-draw-color #xFF 0 0)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
218

Hugo Hörnquist's avatar
Hugo Hörnquist committed
219
  (let ((pp (p player)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
220 221
   (for-each (lambda (ray)
               (let ((v (+ pp (vec ray))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
222 223
                 (draw-line (x pp) (y pp)
                            (x v)  (y v))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
224
             (atomic-box-ref rays)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
225
  )
Hugo Hörnquist's avatar
Hugo Hörnquist committed
226

Hugo Hörnquist's avatar
Hugo Hörnquist committed
227
(define (draw-first-person-perspective)
228
  (set-draw-color #xBB #xBB #xFF)       ; light blue
Hugo Hörnquist's avatar
Hugo Hörnquist committed
229 230
  (clear)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
231
  ;; floor
Hugo Hörnquist's avatar
Hugo Hörnquist committed
232 233 234 235
  (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
236
  (let ((rays (atomic-box-ref rays)))
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262
    (unless (null? rays)
      (for-each
       (lambda (i 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)))))))
       (iota ray-count)
       rays
       ))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
263 264


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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
266 267 268

(define color (make-parameter (make-color 0 0 0 #xFF)))
(define* (render-text str #:key (line 0))
269
  (let ((surf (render-font-blended (current-font) str (color))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
270 271
    (render-copy (current-renderer)
                 (surface->texture (current-renderer) surf)
272
                 #:dstrect (list 5 (+ 1 (* line (+ 1 (font-height (current-font)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
273 274 275
                                 (surface-width surf)
                                 (surface-height surf)))))

276 277


Hugo Hörnquist's avatar
Hugo Hörnquist committed
278 279 280 281 282
(define (with-render-target target thunk)
  (dynamic-wind (lambda () (set-render-target! (current-renderer) target))
                thunk
                (lambda () (set-render-target! (current-renderer) #f))))

283
(define (make-fps-counter)
284
  (let ((last-time (sdl-ticks)))
285
    (lambda ()
286
      (let ((new-time (sdl-ticks)))
287 288 289 290 291 292 293 294
        (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))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
295

296 297 298 299 300
        ;; minimap
        (let ((texture (make-texture rend 'rgba8888 'target
                                     (* board-width  (current-tile-size))
                                     (* board-height (current-tile-size)))))
          (with-render-target texture draw-map)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
301

302 303
          ;; Camera
          (draw-first-person-perspective)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
304

305 306 307
          (render-copy rend texture
                       #:dstrect (list 0 (- 480 100)
                                       100 100))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
308

309
          (delete-texture! texture))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
310

311 312
        ;; Text overlay
        (parameterize ((color (make-color 0 0 0 #xFF)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
313

314
          ;; FPS counter
315
          (render-text (format #f "FPS: ~,2f" (/ 1000 (fps-counter))) #:line 0)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
316

317 318 319 320
          (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
321

322
        (present)))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
323 324

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

Hugo Hörnquist's avatar
Hugo Hörnquist committed
328 329 330 331 332
  (begin-thread
   (while
       #t (let ((rays-next (ray-trace player (1+ ray-count))))
            (atomic-box-set! rays rays-next)
            (wait))))
333

334
  ;; load textures
Hugo Hörnquist's avatar
Hugo Hörnquist committed
335 336 337 338 339
  (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
340

341 342
  (let ((counter 0))
    (while #t
343
           (sigaction SIGINT (lambda (sig) (break)))
344 345 346

           (if (= counter 1)
               (begin (draw window rend) (set! counter 0))
347
               (let ((dt (fps-counter)))
348
                 (update dt)
349
                 (usleep (max 0 (floor/ (- 1000 dt) 360)))
350
                 (set! counter = (+ 1)))))))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
351 352

(sdl-init)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
353 354
(ttf-init)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
355 356 357
(define current-font
  (make-parameter
   (load-font (media "/font.otf") 20)))
Hugo Hörnquist's avatar
Hugo Hörnquist committed
358

359 360 361 362
;; (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
363 364 365 366 367 368 369

(call-with-window
    (make-window
     #:title "Wolf 3D"
     #:size '(640 480))
  main-loop)

Hugo Hörnquist's avatar
Hugo Hörnquist committed
370
(ttf-quit)
Hugo Hörnquist's avatar
Hugo Hörnquist committed
371
(sdl-quit)