Solid foundation.

main.scm

+(add-to-load-path "/usr/local/share/guile/site/2.2/")
+
+(use-modules (srfi srfi-1)
+             (srfi srfi-9)
+
+             (ice-9 threads)
+             (oop goops)
+
+             (sdl2)
+             (sdl2 video)
+             (sdl2 rect)
+             (sdl2 render)
+             (sdl2 surface)
+             (sdl2 events)
+             )
+
+(define-public *unspecified* ((@ (guile) if) #f #f))
+
+(define-syntax set!
+  (syntax-rules (=)
+    ((_) *unspecified*)
+
+    ((_ field = (op args ...) rest ...)
+     (begin ((@ (guile) set!) field (op field args ...))
+            (set! rest ...)))
+
+    ((_ field proc)
+     ((@ (guile) set!) field proc))
+
+    ((_ field proc rest ...)
+     (begin ((@ (guile) set!) field proc) (set! rest ...)))))
+
+
+(define (parse-map spec)
+  (let ((arr (make-array #f (length spec) (string-length (car spec)))))
+    (array-index-map! arr
+                      (lambda (i j)
+                        (case (string-ref (list-ref spec i) j)
+                          ((#\space) 'space)
+                          ((#\#) 'wall))))
+    arr))
+
+(define game-map
+  (parse-map
+   '("########"
+     "#      #"
+     "#  ### #"
+     "#  #   #"
+     "########")))
+
+(define-values (board-height board-width)
+  (apply values (array-dimensions game-map)))
+
+(define (cross-product l1 l2)
+  (concatenate
+   (map (lambda (a)
+          (map (lambda (b) (list a b))
+               l2))
+        l1)))
+
+
+(define-class <point> ()
+  (x #:accessor x
+     #:init-keyword #:x
+     #:init-value 0)
+  (y #:accessor y
+     #:init-keyword #:y
+     #:init-value 0))
+
+(define (make-point x y)
+  (make <point> #:x x #:y y))
+
+(define-class <player> (<point>)
+  (angle #:accessor a #:init-value 0))
+
+(define (get-t)
+  (define t (gettimeofday))
+  (+ (cdr t) (* 1000000 (car t))))
+
+
+(define current-tile-size (make-parameter 50))
+(define current-renderer (make-parameter #f))
+
+(define int (compose inexact->exact floor))
+
+(define (draw-line x1 y1 x2 y2)
+  (render-draw-line
+   (current-renderer)
+   (int (* (current-tile-size) x1)) (int (* (current-tile-size) y1))
+   (int (* (current-tile-size) x2)) (int (* (current-tile-size) y2))))
+
+(define (fill-rect x y w h)
+ (render-fill-rect
+  (current-renderer)
+  (make-rect (int (* (current-tile-size) x))
+             (int (* (current-tile-size) y))
+             (int (* (current-tile-size) w))
+             (int (* (current-tile-size) h)))))
+
+(define (draw-line x1 y1 x2 y2)
+  (render-draw-line
+   (current-renderer)
+   (int (* x1 (current-tile-size))) (int (* y1 (current-tile-size)))
+   (int (* x2 (current-tile-size))) (int (* y2 (current-tile-size)))))
+
+(define (make-rect* x y w h)
+  (make-rect (int (* x (current-tile-size)))
+             (int (* y (current-tile-size)))
+             (int (* w (current-tile-size)))
+             (int (* h (current-tile-size)))))
+
+(define (fill-rects rects)
+  (render-fill-rects (current-renderer) rects))
+
+(define* (set-draw-color r g b #:optional (a #xFF))
+  (set-render-draw-color (current-renderer) r g b a))
+
+(define (clear)
+  (clear-renderer (current-renderer)))
+
+(define (present)
+  (present-renderer (current-renderer)))
+
+(define player (make <player> #:x 1 #:y 1 #:a 0))
+(define keys-down (make-parameter '()))
+
+(define (update dt)
+
+    (let ((ev (poll-event)))
+      (cond #; [(keyboard-event-repeat? ev) #f] ;; TODO implement in bindings
+       [(keyboard-down-event? ev)
+        (keys-down (cons (keyboard-event-scancode ev)
+                         (keys-down)))]
+       [(keyboard-up-event? ev)
+        (keys-down (delv (keyboard-event-scancode ev)
+                         (keys-down)))]))
+
+
+    (fold (lambda (key ret)
+            (case key
+              ((x q) 'game-end)
+              ;; Det här börjar vara fånigt...
+              ((w) (set! (y player) = (- (* dt 0.000003))) ret)
+              ((s) (set! (y player) = (+ (* dt 0.000003))) ret)
+              ((a) (set! (x player) = (- (* dt 0.000003))) ret)
+              ((d) (set! (x player) = (+ (* dt 0.000003))) ret)
+              ((j) (set! (a player) = (- (* dt 0.000001))) ret)
+              ((p) (set! (a player) = (+ (* dt 0.000001))) ret)
+              (else ret)
+              ))
+          #f (keys-down))
+
+  )
+
+
+
+(define (draw)
+
+  (set-draw-color #xFF #xFF #xFF)
+  (clear)
+
+  (set-draw-color 0 0 #xFF)
+
+  (fill-rects
+   (filter-map
+    (lambda (pt)
+      (if (eq? 'wall (array-ref game-map (y pt) (x pt)))
+          (make-rect* (x pt) (y pt)
+                      1 1)
+          #f))
+    (map (lambda (p) (apply make-point p))
+         (cross-product (iota board-width) (iota board-height)))))
+
+  (set-draw-color 0 0 0)
+
+  (for-each (lambda (i) (draw-line
+                    0 i
+                    board-width i))
+            (iota board-height))
+
+  (for-each (lambda (i) (draw-line
+                    i 0
+                    i board-height))
+            (iota board-width))
+
+
+  (set-draw-color #xFF 0 0)
+
+  (fill-rect
+   (- (x player) 0.25)
+   (- (y player) 0.25)
+   0.5 0.5)
+
+  (set-draw-color 0 #xFF 0)
+
+  (draw-line
+   (x player) (y player)
+   (+ (cos (a player)) (x player))
+   (+ (sin (a player)) (y player)))
+
+  (present))
+
+
+(define (main-loop window)
+  (define rend (make-renderer window))
+
+  (define last-t (get-t))
+
+  (parameterize ((current-renderer rend)
+                 (current-tile-size 16))
+    (let loop ((counter 0))
+      (usleep (int (/ 1000000 (* 60 60))))
+      ;; (sigaction SIGINT (lambda (sig) (set! looping #f)))
+
+      (if (= counter 60)
+          (begin (draw) (loop 0))
+          (begin (let ((dt (let ((t (get-t)))
+                             (let ((dt (- t last-t)))
+                               (set! last-t t)
+                               dt))))
+                   (format #t "Δr = ~a~%" dt)
+                   (if (update dt)
+                       'return
+                       (loop (1+ counter)))))))))
+
+(sdl-init)
+
+(call-with-window
+    (make-window
+     #:title "Wolf 3D"
+     #:size '(640 480))
+  main-loop)
+
+(sdl-quit)