Skip to content
Snippets Groups Projects
Commit 3c59d986 authored by Hugo Hörnquist's avatar Hugo Hörnquist
Browse files

Solid foundation.

parents
No related branches found
No related tags found
No related merge requests found
main.scm 0 → 100644
(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)
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment