Add fading effect.

class.scm

@@ -28,13 +28,15 @@
            (* (z v) (z v)))))
 
 (define-class <player> ()
-  (pos #:accessor p #:init-form (v3 1 1))
-  (angle #:accessor a #:init-value 0)
+  (pos #:accessor p
+       #:init-form (v3 1 1)
+       #:init-keyword #:p)
+  (angle #:accessor a #:init-value 0 #:init-keyword #:a)
   (feild-of-view #:accessor fov #:init-value (/ tau 8)))
 (export p a fov)
 
 (define (make-player x y a)
-   (make <player> #:x x #:y y #:a a))
+   (make <player> #:p (v3 x y) #:a a))
 
 
 (define-class <ray> ()

main.scm

@@ -38,11 +38,10 @@
   (define t (gettimeofday))
   (+ (cdr t) (* 1000000 (car t))))
 
-(define player (make-player 1 1 0))
+(define player (make-player 5 13 -2))
 
 (define ray-count 64)
 
-(define current-font (make-parameter #f))
 
 (define rays (make-atomic-box '()))
 
@@ -167,89 +166,104 @@
   (set-draw-color #xBB #xBB #xFF)
   (clear)
 
+  ;; floor
   (set-draw-color #x33 #x33 #x33)
   (render-fill-rect (current-renderer)
                     (make-rect 0 240 640 240))
 
-  (set-draw-color 0 #xEE #xEE)
-
-  (for-each (lambda (i r r+)
-              (when (hashq-ref texture-map (type r))
-               (let* ((l (length r))
-                      (segment-height (- 480 (* 70 l))))
-                 (render-copy
-                  (current-renderer)
-                  (hashq-ref texture-map (type r))
-                  #:dstrect (list (int (* i (/ 640 ray-count)))
-                                  (int (/ (- 480 segment-height) 2))
-                                  (int (+ 0 (/ 640 ray-count)))
-                                  (int segment-height))
-
-
-                  #:srcrect
-                  (list (int (* 16 (pos-on-wall r))) 0
-                        1 16)))))
-            (iota ray-count)
-            (atomic-box-ref rays)
-            (cdr (atomic-box-ref rays))
-            )
+
+  (let ((rays (atomic-box-ref rays)))
+   (unless (null? rays)
+     (for-each (lambda (i r r+)
+                 (when (hashq-ref texture-map (type r))
+                   (let* ((l (length r))
+                          (segment-height (- 480 (* 30 l) 40))
+                          (texture (hashq-ref texture-map (type r))))
+
+                     (let ((c (max 0 (int (- #xFF (* l 20))))))
+                       (set-texture-color-mod! texture 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))
+
+
+                      #:srcrect
+                      (list (int (* 16 (pos-on-wall r))) 0
+                            1 16)))))
+               (iota ray-count)
+               rays (cdr rays)
+               )))
 
   )
 
-(define texture #f)
 
-(define (draw window rend)
+
+(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))))
+    (render-copy (current-renderer)
+                 (surface->texture (current-renderer) surf)
+                 #:dstrect (list 1 (+ 1 (* line (+ 3 (font-height (current-font)))))
+                                 (surface-width surf)
+                                 (surface-height 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 (draw window rend)
   (parameterize ((current-renderer rend))
-    (set-draw-color #xFF #xFF #xFF)
-    (clear)
 
+    ;; minimap
     (let ((texture (make-texture rend 'rgba8888 'target
-                                   (* board-width  (current-tile-size))
-                                   (* board-height (current-tile-size)))))
-      (set-render-target! rend texture)
-      (draw-map)
-      (set-render-target! rend #f)
+                                 (* board-width  (current-tile-size))
+                                 (* board-height (current-tile-size)))))
+      (with-render-target texture draw-map)
 
       ;; Camera
       (draw-first-person-perspective)
 
-      ;; minimap
       (render-copy rend texture
                    #:dstrect (list 0 (- 480 100)
                                    100 100))
 
       (delete-texture! texture))
 
-    ;; FPS counter
-    (let ((nt (get-t)))
-      (let ((surf (render-font-solid
-                   (current-font)
-                   (format #f "FPS: ~,2f" (/ 1000000 (- nt fps-time)))
-                   (make-color 0 0 0 #xFF))))
-        (render-copy (current-renderer)
-                     (surface->texture (current-renderer) surf)
-                     #:dstrect (list 1 1
-                                     (surface-width surf)
-                                     (surface-height surf))))
+    ;; Text overlay
+    (parameterize ((color (make-color 0 0 0 #xFF)))
 
-      (set! fps-time nt))
+      ;; FPS counter
+      (let ((nt (get-t)))
+        (render-text (format #f "FPS: ~,2f" (/ 1000000 (- nt fps-time)))
+                     #:line 0)
+        (set! fps-time nt))
 
-    (present)
+      (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 last-t (get-t))
 
-  (call-with-new-thread
-   (lambda ()
-     (while
-      #t (let ((rays-next (ray-trace player (1+ ray-count))))
-           (atomic-box-set! rays rays-next)
-           (wait)))))
+  (begin-thread
+   (while
+       #t (let ((rays-next (ray-trace player (1+ ray-count))))
+            (atomic-box-set! rays rays-next)
+            (wait))))
 
   (for-each
    (lambda (type)
@@ -275,9 +289,14 @@
 (sdl-init)
 (ttf-init)
 
-(current-font (load-font (media "/font.otf") 12))
+(define current-font
+  (make-parameter
+   (load-font (media "/font.otf") 20)))
 
-(format #t "Loaded font ~a~%" (current-font))
+(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