Commit daf6ac75 authored by Hugo Hörnquist's avatar Hugo Hörnquist

Split project into multiple files.

parent 698634d8
(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 (dirname (current-filename)))
(use-modules (srfi srfi-1)
(srfi srfi-9)
(ice-9 threads)
(oop goops)
(sdl2)
(sdl2 ttf)
(sdl2 video)
(sdl2 image)
(sdl2 rect)
(sdl2 render)
(sdl2 surface)
(sdl2 events)
(util)
(map)
(class)
(draw)
)
(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 (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 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 brick-texture #f)
(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 player (make-player 1 1 0))
(define ray-count 64)
......@@ -195,7 +76,7 @@
#f (keys-down))))
(unless cached-rays
(set! cached-rays (ray-trace player ray-count)))
(set! cached-rays (ray-trace player (1+ ray-count))))
ret)
)
......@@ -215,8 +96,8 @@
(<= 0 ny board-height)))
(eq? 'wall (array-ref game-map iy ix)))
(cons
(min (- dx (round dx))
(- dy (round dy)))
(min (- dx (floor dx))
(- dy (floor dy)))
(v3 dx dy))
(loop (+ dx (* 0.1 (cos a))) (+ dy (* 0.1 (sin a)))))))))
(iota ray-count (- (a player) (/ (fov player) 2))
......@@ -290,14 +171,26 @@
(set-draw-color 0 #xEE #xEE)
(for-each (lambda (i p)
(let ((pos-on-wall (car p))
(ray (cdr p)))
(for-each (lambda (i r r+)
(let ((pos-on-wall (car r))
(ray (cdr r)))
(let* ((l (vector-length ray))
(segment-height (- 480 (* 70 l))))
(set-draw-color 0
(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
(current-renderer)
(make-rect (int (* i (/ 640 ray-count)))
......@@ -305,7 +198,9 @@
(int (1+ (/ 640 ray-count)))
(int segment-height))))))
(iota ray-count)
cached-rays)
cached-rays
(cdr cached-rays)
)
)
......@@ -356,6 +251,8 @@
(define (main-loop window)
(define rend (make-renderer window '(accelerated #; vsync texture)))
(define last-t (get-t))
(set! brick-texture (surface->texture rend (load-image "./purplebrick.png")))
(let loop ((counter 0))
;; (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))))
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