Commit 3c6b2878 authored by Filip Polbratt's avatar Filip Polbratt
Browse files

Merge branch 'master' of https://git.lysator.liu.se/hugo/wolf3d

parents 048b367c daf6ac75
(define-module (class)
:use-module (oop goops)
:use-module (util)
:export (vector-length v3 make-player))
(define-class <v3> ()
(x #:accessor x #:init-keyword #:x)
(y #:accessor y #:init-keyword #:y)
(z #:accessor z #:init-keyword #:z))
(export x y z)
(define* (v3 #:optional (x 0) (y 0) (z 0))
(make <v3> #:x x #:y y #:z z))
(define-method (+ (v <v3>) (u <v3>))
(v3 (+ (x v) (x u))
(+ (y v) (y u))
(+ (z v) (z u))))
(define-method (* (a <number>) (v <v3>))
(v3 (* a (x v))
(* a (y v))
(* a (z v))))
(define (vector-length v)
(sqrt (+ (* (x v) (x v))
(* (y v) (y v))
(* (z v) (z v)))))
(define-class <player> ()
(pos #:accessor p #:init-form (v3 1 1))
(angle #:accessor a #:init-value 0)
(feild-of-view #:accessor fov #:init-value (/ tau 6)))
(export p a fov)
(define (make-player x y a)
(make <player> #:x x #:y y #:a a))
(define-module (draw)
:use-module (util)
:use-module (sdl2 render)
:use-module (sdl2 rect)
:replace (fill-rect)
:export (set-draw-color)
)
(define-public current-renderer (make-parameter #f))
(define-public current-tile-size (make-parameter 50))
(define-public (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-public (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-public (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-public (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-public (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-public (clear)
(clear-renderer (current-renderer)))
(define-public (present)
(present-renderer (current-renderer)))
(add-to-load-path "/usr/local/share/guile/site/2.2/") (add-to-load-path "/usr/local/share/guile/site/2.2/")
(add-to-load-path (dirname (current-filename)))
(use-modules (srfi srfi-1) (use-modules (srfi srfi-1)
(srfi srfi-9)
(ice-9 threads)
(oop goops)
(sdl2) (sdl2)
(sdl2 ttf) (sdl2 ttf)
(sdl2 video) (sdl2 video)
(sdl2 image)
(sdl2 rect) (sdl2 rect)
(sdl2 render) (sdl2 render)
(sdl2 surface) (sdl2 surface)
(sdl2 events) (sdl2 events)
(util)
(map)
(class)
(draw)
) )
(define-public *unspecified* ((@ (guile) if) #f #f)) (define brick-texture #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 (signum x)
(cond ((zero? x) 0)
((positive? x) 1)
(else -1)))
(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)
((#\:) 'grass)
((#\;) 'teleporter)
((#\*) 'window)
((#) 'entrance))))
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 pi 3.141592653589793)
(define tau (* 2 pi))
(define-class <v3> ()
(x #:accessor x #:init-keyword #:x)
(y #:accessor y #:init-keyword #:y)
(z #:accessor z #:init-keyword #:z))
(define* (v3 #:optional (x 0) (y 0) (z 0))
(make <v3> #:x x #:y y #:z z))
(define-method (+ (v <v3>) (u <v3>))
(v3 (+ (x v) (x u))
(+ (y v) (y u))
(+ (z v) (z u))))
(define-method (* (a <number>) (v <v3>))
(v3 (* a (x v))
(* a (y v))
(* a (z v))))
(define (vector-length v)
(sqrt (+ (* (x v) (x v))
(* (y v) (y v))
(* (z v) (z v)))))
(define-class <player> ()
(pos #:accessor p #:init-form (v3 1 1))
(angle #:accessor a #:init-value 0)
(feild-of-view #:accessor fov #:init-value (/ tau 6)))
(define (get-t) (define (get-t)
(define t (gettimeofday)) (define t (gettimeofday))
(+ (cdr t) (* 1000000 (car t)))) (+ (cdr t) (* 1000000 (car t))))
(define current-tile-size (make-parameter 50)) (define player (make-player 1 1 0))
(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 ray-count 64) (define ray-count 64)
...@@ -228,7 +76,7 @@ ...@@ -228,7 +76,7 @@
#f (keys-down)))) #f (keys-down))))
(unless cached-rays (unless cached-rays
(set! cached-rays (ray-trace player ray-count))) (set! cached-rays (ray-trace player (1+ ray-count))))
ret) ret)
) )
...@@ -248,8 +96,8 @@ ...@@ -248,8 +96,8 @@
(<= 0 ny board-height))) (<= 0 ny board-height)))
(eq? 'wall (array-ref game-map iy ix))) (eq? 'wall (array-ref game-map iy ix)))
(cons (cons
(min (- dx (round dx)) (min (- dx (floor dx))
(- dy (round dy))) (- dy (floor dy)))
(v3 dx dy)) (v3 dx dy))
(loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a))))))))) (loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a)))))))))
(iota ray-count (- (a player) (/ (fov player) 2)) (iota ray-count (- (a player) (/ (fov player) 2))
...@@ -323,14 +171,26 @@ ...@@ -323,14 +171,26 @@
(set-draw-color 0 #xEE #xEE) (set-draw-color 0 #xEE #xEE)
(for-each (lambda (i p) (for-each (lambda (i r r+)
(let ((pos-on-wall (car p)) (let ((pos-on-wall (car r))
(ray (cdr p))) (ray (cdr r)))
(let* ((l (vector-length ray)) (let* ((l (vector-length ray))
(segment-height (- 480 (* 70 l)))) (segment-height (- 480 (* 70 l))))
(set-draw-color 0 (set-draw-color 0
(int (min #xFF (- #x100 (* #x100 (/ l 7))))) (int (min #xFF (- #x100 (* #x100 (/ l 7)))))
(int (min #xFF (- #x100 (* #x100 (/ l 7)))))) (int (min #xFF (- #x100 (* #x100 (/ l 7))))))
(render-copy
(current-renderer)
brick-texture
#:dstrect (list (int (* i (/ 640 ray-count)))
(int (/ (- 480 segment-height) 2))
(int (1+ (/ 640 ray-count)))
(int segment-height))
#:srcrect (list (inexact->exact (round (* 56 (car r+)))) 0
(inexact->exact (round (* 56 (car r)))) 56)
)
#;
(render-fill-rect (render-fill-rect
(current-renderer) (current-renderer)
(make-rect (int (* i (/ 640 ray-count))) (make-rect (int (* i (/ 640 ray-count)))
...@@ -338,7 +198,9 @@ ...@@ -338,7 +198,9 @@
(int (1+ (/ 640 ray-count))) (int (1+ (/ 640 ray-count)))
(int segment-height)))))) (int segment-height))))))
(iota ray-count) (iota ray-count)
cached-rays) cached-rays
(cdr cached-rays)
)
) )
...@@ -389,6 +251,8 @@ ...@@ -389,6 +251,8 @@
(define (main-loop window) (define (main-loop window)
(define rend (make-renderer window '(accelerated #; vsync texture))) (define rend (make-renderer window '(accelerated #; vsync texture)))
(define last-t (get-t)) (define last-t (get-t))
(set! brick-texture (surface->texture rend (load-image "./purplebrick.png")))
(let loop ((counter 0)) (let loop ((counter 0))
;; (usleep (int (/ 1000000 (* 60 60)))) ;; (usleep (int (/ 1000000 (* 60 60))))
......
(define-module (map)
:export (game-map board-height board-width))
(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)
((#\:) 'grass)
((#\;) 'teleporter)
((#\*) 'window)
((#) 'entrance))))
arr))
(define game-map
(parse-map
'(
" ###### "
" # ¤ # "
" # ####################"
" # ¤ #"
" # #############¤#¤##"
" # # # # #"
" # ¤ # # #"
" # #######****#**#**#"
"###¤¤###:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
"::* *:::::::::::::::::"
" # ###**#*#**#**#**#**#"
" # ¤ # # # # # # #"
" # ### # # # # # #"
" # ####¤#¤##¤##¤#¤##¤##"
" # ¤ "
" ########################")))
(define-values (board-height board-width)
(apply values (array-dimensions game-map)))
(define-module (util)
:export (*unspecified* signum cross-product pi tau int)
:replace (set!)
:use-module (srfi srfi-1)
)
(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 (signum x)
(cond ((zero? x) 0)
((positive? x) 1)
(else -1)))
(define (cross-product l1 l2)
(concatenate
(map (lambda (a)
(map (lambda (b) (list a b))
l2))
l1)))
(define pi 3.141592653589793)
(define tau (* 2 pi))
(define int (compose inexact->exact floor))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment