400 lines
18 KiB
Scheme
400 lines
18 KiB
Scheme
(define spite-inited? #f)
|
|
(define started? #f)
|
|
(define exit? #f)
|
|
(define scale-x 1.0)
|
|
(define scale-y 1.0)
|
|
(define events '())
|
|
(define current-bitmap-font #f)
|
|
(define current-line-size 1)
|
|
(define draw-color-r 0)
|
|
(define draw-color-g 0)
|
|
(define draw-color-b 0)
|
|
(define draw-color-a 255)
|
|
(define window* #f)
|
|
(define renderer* #f)
|
|
(define event* (make-c-bytevector 4000))
|
|
(define draw-rect* (make-c-bytevector (* (c-type-size 'int) 4)))
|
|
(define draw-slice-rect* (make-c-bytevector (* (c-type-size 'int) 4)))
|
|
(define fill-triangle-vertex-size 1024
|
|
;; FIXME
|
|
;(+ (* (c-type-size 'int) 6) (* (c-type-size 'float) 2))
|
|
)
|
|
(define fill-triangle-vertex1* (make-c-bytevector fill-triangle-vertex-size 0))
|
|
(define fill-triangle-vertex2* (make-c-bytevector fill-triangle-vertex-size 0))
|
|
(define fill-triangle-vertex3* (make-c-bytevector fill-triangle-vertex-size 0))
|
|
(define fill-triangle-vertexes* (make-c-bytevector (* fill-triangle-vertex-size 3 0)))
|
|
|
|
(define main-loop-start-time 0)
|
|
(define delta-time 0)
|
|
(define (main-loop update-procedure draw-procedure)
|
|
(set! main-loop-start-time (SDL_GetTicks))
|
|
(sdl2-events-get)
|
|
(update-procedure delta-time (poll-events!))
|
|
(render-clear)
|
|
(draw-procedure)
|
|
(render-present)
|
|
(set! delta-time (- (SDL_GetTicks) main-loop-start-time))
|
|
(unless exit? (main-loop update-procedure draw-procedure)))
|
|
|
|
(define sdl2-event->spite-event
|
|
(lambda (event)
|
|
(let ((type (c-bytevector-ref event 'int 0)))
|
|
(cond
|
|
((= type 256)
|
|
(let ((type 'quit))
|
|
(list (cons 'type type))))
|
|
((or (= type 768) (= type 769))
|
|
(let*
|
|
((type (if (= type 768) 'key-down 'key-up))
|
|
(scancode (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'int) 3)
|
|
(* (c-type-size 'u8) 4))))
|
|
(keycode (SDL_GetKeyFromScancode scancode))
|
|
(key (c-bytevector->string (SDL_GetKeyName keycode)))
|
|
(repeat? (= (c-bytevector-ref
|
|
event
|
|
'u8
|
|
(+ (* (c-type-size 'int) 3)
|
|
(c-type-size 'u8)))
|
|
1)))
|
|
(list (cons 'type type)
|
|
(cons 'key key)
|
|
(cons 'scancode scancode)
|
|
(cons 'repeat? repeat?))))
|
|
((= type 1024)
|
|
(let ((type 'mouse-motion)
|
|
(x (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'int) 5))
|
|
))
|
|
(y (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'int) 6)))))
|
|
(list (cons 'type type)
|
|
(cons 'x x)
|
|
(cons 'y y))))
|
|
((or (= type 1025) (= type 1026))
|
|
(let ((type (if (= type 1025) 'mouse-button-down 'mouse-button-up))
|
|
(x (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'int) 4)
|
|
(* (c-type-size 'u8) 4))))
|
|
(y (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'int) 4)
|
|
(* (c-type-size 'u8) 4)
|
|
(c-type-size 'int))))
|
|
(button (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'u32) 4))))
|
|
(clicks (c-bytevector-ref event
|
|
'int
|
|
(+ (* (c-type-size 'u32) 4)
|
|
(* (c-type-size 'u8) 2)))))
|
|
(list (cons 'type type)
|
|
(cons 'x x)
|
|
(cons 'y y)
|
|
(cons 'button button)
|
|
(cons 'clicks clicks))))
|
|
(else
|
|
(list (cons 'type 'sdl2-event)
|
|
(cons 'sdl2-type-number type)))))))
|
|
|
|
(define sdl2-events-get
|
|
(lambda ()
|
|
(let ((poll-result (SDL_PollEvent event*)))
|
|
(cond
|
|
((= poll-result 1)
|
|
(let ((event (sdl2-event->spite-event event*)))
|
|
|
|
(cond ((equal? (cdr (assoc 'type event)) 'quit) (set! exit? #t)))
|
|
(push-event event)
|
|
(sdl2-events-get)))))))
|
|
|
|
(define render-clear
|
|
(lambda ()
|
|
(SDL_SetRenderDrawColor renderer* 255 255 255 255)
|
|
(SDL_RenderClear renderer*)))
|
|
|
|
(define render-present
|
|
(lambda ()
|
|
(SDL_RenderPresent renderer*)))
|
|
|
|
(define-record-type image
|
|
(make-image pointer path)
|
|
image?
|
|
(pointer image-pointer)
|
|
(path image-path))
|
|
|
|
(define load-image
|
|
(lambda (path)
|
|
(when (not spite-inited?) (error "Can not load images until spite is inited." path))
|
|
(when (not (string? path)) (error "load-image: path must be string" path))
|
|
(when (not (file-exists? path)) (error (string-append "load-image: no such file: " path)))
|
|
(make-image (IMG_LoadTexture renderer* (string->c-bytevector path)) path)))
|
|
|
|
(define draw-image
|
|
(lambda (image x y width height)
|
|
(when (not (exact-integer? x)) (error "draw-image: x must be exact integer"))
|
|
(when (not (exact-integer? y)) (error "draw-image: y must be exact integer"))
|
|
(when (not (exact-integer? width)) (error "draw-image: width must be exact integer"))
|
|
(when (not (exact-integer? height)) (error "draw-image: width must be exact integer"))
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
|
|
(SDL_RenderCopy renderer* (image-pointer image) (c-bytevector-null) draw-rect*)))
|
|
|
|
(define draw-image-slice
|
|
(lambda (image x y width height slice-x slice-y slice-width slice-height)
|
|
(when (not (exact-integer? x)) (error "draw-image: x must be exact integer"))
|
|
(when (not (exact-integer? y)) (error "draw-image: y must be exact integer"))
|
|
(when (not (exact-integer? width)) (error "draw-image: width must be exact integer"))
|
|
(when (not (exact-integer? height)) (error "draw-image: width must be exact integer"))
|
|
(when (not (exact-integer? slice-x)) (error "draw-image: slice-x must be exact integer"))
|
|
(when (not (exact-integer? slice-y)) (error "draw-image: slice-y must be exact integer"))
|
|
(when (not (exact-integer? slice-width)) (error "draw-image: slice-width must be exact integer"))
|
|
(when (not (exact-integer? slice-height)) (error "draw-image: slice-width must be exact integer"))
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
|
|
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 0) slice-x)
|
|
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 1) slice-y)
|
|
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 2) slice-width)
|
|
(c-bytevector-set! draw-slice-rect* 'int (* (c-type-size 'int) 3) slice-height)
|
|
(SDL_RenderCopy renderer* (image-pointer image) draw-slice-rect* draw-rect*)))
|
|
|
|
(define (set-draw-color r g b . a)
|
|
(when (not (exact-integer? r)) (error "set-draw-color: r must be exact integer"))
|
|
(when (not (exact-integer? g)) (error "set-draw-color: g must be exact integer"))
|
|
(when (not (exact-integer? b)) (error "set-draw-color: b must be exact integer"))
|
|
(when (and (not (null? a)) (not (exact-integer? (car a)))) (error "set-draw-color: a must be exact integer"))
|
|
(set! draw-color-r r)
|
|
(set! draw-color-g g)
|
|
(set! draw-color-b b)
|
|
(set! draw-color-a (if (null? a) 255 a))
|
|
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 2) draw-color-r)
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 3) draw-color-g)
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 4) draw-color-b)
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 5) draw-color-b)
|
|
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 2) draw-color-r)
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 3) draw-color-g)
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 4) draw-color-b)
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 5) draw-color-b)
|
|
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 2) draw-color-r)
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 3) draw-color-g)
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 4) draw-color-b)
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 5) draw-color-b)
|
|
|
|
(SDL_SetRenderDrawColor renderer* r g b draw-color-a))
|
|
|
|
(define (set-line-size size)
|
|
(when (not (exact-integer? size)) (error "set-line-size: size must be exact integer"))
|
|
(set! current-line-size size)
|
|
(SDL_RenderSetScale renderer* (inexact (/ size 1)) (inexact (/ size 1))))
|
|
|
|
(define (draw-point x y)
|
|
(when (not (exact-integer? x)) (error "draw-point: x must be exact integer"))
|
|
(when (not (exact-integer? y)) (error "draw-point: y must be exact integer"))
|
|
(SDL_RenderDrawLine renderer*
|
|
(exact (round (/ x current-line-size)))
|
|
(exact (round (/ y current-line-size)))
|
|
(exact (round (/ x current-line-size)))
|
|
(exact (round (/ y current-line-size)))))
|
|
|
|
(define (draw-line x1 y1 x2 y2)
|
|
(when (not (exact-integer? x1)) (error "draw-line: x1 must be exact integer"))
|
|
(when (not (exact-integer? y1)) (error "draw-line: y1 must be exact integer"))
|
|
(when (not (exact-integer? x2)) (error "draw-line: x2 must be exact integer"))
|
|
(when (not (exact-integer? y2)) (error "draw-line: y2 must be exact integer"))
|
|
(SDL_RenderDrawLine renderer*
|
|
(exact (round (/ x1 current-line-size)))
|
|
(exact (round (/ y1 current-line-size)))
|
|
(exact (round (/ x2 current-line-size)))
|
|
(exact (round (/ y2 current-line-size)))))
|
|
|
|
(define (draw-rectangle x y width height)
|
|
(when (not (exact-integer? x)) (error "draw-rectangle: x must be exact integer"))
|
|
(when (not (exact-integer? y)) (error "draw-rectangle: y must be exact integer"))
|
|
(when (not (exact-integer? width)) (error "draw-rectangle: width must be exact integer"))
|
|
(when (not (exact-integer? height)) (error "draw-rectangle: width must be exact integer"))
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
|
|
(SDL_RenderDrawRect renderer* draw-rect*))
|
|
|
|
(define (fill-rectangle x y width height)
|
|
(when (not (exact-integer? x)) (error "fill-rectangle: x must be exact integer"))
|
|
(when (not (exact-integer? y)) (error "fill-rectangle: y must be exact integer"))
|
|
(when (not (exact-integer? width)) (error "fill-rectangle: width must be exact integer"))
|
|
(when (not (exact-integer? height)) (error "fill-rectangle: width must be exact integer"))
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 0) x)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 1) y)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 2) width)
|
|
(c-bytevector-set! draw-rect* 'int (* (c-type-size 'int) 3) height)
|
|
(SDL_RenderFillRect renderer* draw-rect*))
|
|
|
|
(define (draw-triangle x1 y1 x2 y2 x3 y3)
|
|
(when (not (exact-integer? x1)) (error "draw-triangle: x1 must be exact integer"))
|
|
(when (not (exact-integer? y1)) (error "draw-triangle: y1 must be exact integer"))
|
|
(when (not (exact-integer? x2)) (error "draw-triangle: x2 must be exact integer"))
|
|
(when (not (exact-integer? y2)) (error "draw-triangle: y2 must be exact integer"))
|
|
(when (not (exact-integer? x3)) (error "draw-triangle: x3 must be exact integer"))
|
|
(when (not (exact-integer? y3)) (error "draw-triangle: y3 must be exact integer"))
|
|
(draw-line x1 y1 x2 y2)
|
|
(draw-line x2 y2 x3 y3)
|
|
(draw-line x3 y3 x1 y1))
|
|
|
|
;; FIXME
|
|
#;(define (fill-triangle x1 y1 x2 y2 x3 y3)
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 0) x1)
|
|
(c-bytevector-set! fill-triangle-vertex1* 'int (* (c-type-size 'int) 1) y1)
|
|
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 0) x2)
|
|
(c-bytevector-set! fill-triangle-vertex2* 'int (* (c-type-size 'int) 1) y2)
|
|
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 0) x3)
|
|
(c-bytevector-set! fill-triangle-vertex3* 'int (* (c-type-size 'int) 1) y3)
|
|
|
|
(SDL_RenderGeometry renderer* (c-bytevector-null) fill-triangle-vertexes* 3 (c-bytevector-null) 0))
|
|
|
|
(define (spite-option-set! name . value)
|
|
(cond
|
|
((equal? name 'allow-window-resizing)
|
|
(cond
|
|
((equal? value '(#t))
|
|
(SDL_SetWindowResizable window* 1))
|
|
((equal? value '(#f))
|
|
(SDL_SetWindowResizable window* 0))
|
|
(else (error "Wrong option value for 'allow-window-resizing, must be #t or #f"
|
|
value))))
|
|
((equal? name 'renderer-size)
|
|
(if (and (= (length value) 2)
|
|
(number? (car value))
|
|
(number? (cadr value)))
|
|
(SDL_RenderSetLogicalSize renderer* (car value) (cadr value))
|
|
(error "Wrong option value for renderer-size, must be two numbers")))
|
|
(else (error "No such option!" name))))
|
|
|
|
;; TODO Move to options, add spite-option-get
|
|
(define spite-renderer-scale-get
|
|
(lambda ()
|
|
(let ((x (make-c-bytevector (c-type-size 'float)))
|
|
(y (make-c-bytevector (c-type-size 'float))))
|
|
(SDL_RenderGetScale renderer* x y)
|
|
(list (cons 'x (c-bytevector-ref x 'float 0))
|
|
(cons 'y (c-bytevector-ref y 'float 0))))))
|
|
|
|
(define spite-start
|
|
(lambda (update-procedure draw-procedure)
|
|
(when (not (procedure? update-procedure)) (error "spite-start: update-procedure must be procedure"))
|
|
(when (not (procedure? draw-procedure)) (error "spite-start: draw-procedure must be procedure"))
|
|
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 0) fill-triangle-vertex1*)
|
|
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 1) fill-triangle-vertex2*)
|
|
(c-bytevector-set! fill-triangle-vertexes* 'pointer (* fill-triangle-vertex-size 2) fill-triangle-vertex3*)
|
|
(cond
|
|
((not started?)
|
|
(set! started? #t)
|
|
(main-loop update-procedure draw-procedure)))))
|
|
|
|
(define spite-init
|
|
(lambda (title width height)
|
|
(when (not (exact-integer? width)) (error "spite-init: width must be exact integer"))
|
|
(when (not (exact-integer? height)) (error "spite-init: height must be exact integer"))
|
|
(cond
|
|
((not started?)
|
|
(SDL_Init 32)
|
|
(set! window* (SDL_CreateWindow (string->c-bytevector title) 0 0 width height 4))
|
|
(set! renderer* (SDL_CreateRenderer window* -1 2))
|
|
(SDL_RenderSetLogicalSize renderer* width height)
|
|
(SDL_RenderSetIntegerScale renderer* 1)
|
|
(render-clear)
|
|
(render-present)
|
|
(set! spite-inited? #t)))))
|
|
|
|
(define poll-events!
|
|
(lambda ()
|
|
(let ((events-copy (list-copy events)))
|
|
(set! events (list))
|
|
events-copy)))
|
|
|
|
(define wait-for-event!
|
|
(lambda ()
|
|
(if (not (= (length events) 0))
|
|
(poll-events!)
|
|
(wait-for-event!))))
|
|
|
|
(define push-event
|
|
(lambda (event)
|
|
(set! events (append events (list event)))))
|
|
|
|
(define clear-events!
|
|
(lambda ()
|
|
(set! events (list))))
|
|
|
|
(define-record-type <bitmap-font>
|
|
(internal-make-bitmap-font image draw-width draw-height character-width character-height lookup-table)
|
|
bitmap-font?
|
|
(image bitmap-font-image)
|
|
(draw-width bitmap-font-draw-width)
|
|
(draw-height bitmap-font-draw-height)
|
|
(character-width bitmap-font-character-width)
|
|
(character-height bitmap-font-character-height)
|
|
(lookup-table bitmap-font-lookup-table))
|
|
|
|
(define (make-bitmap-font image character-width character-height draw-width draw-height character-lists)
|
|
(let* ((line-index -1)
|
|
(character-index -1)
|
|
(lookup-table (make-vector 0)))
|
|
(for-each
|
|
(lambda (line)
|
|
(set! line-index (+ line-index 1))
|
|
(set! character-index -1)
|
|
(for-each
|
|
(lambda (character)
|
|
(set! character-index (+ character-index 1))
|
|
(let ((c-int (char->integer character)))
|
|
(when (<= (vector-length lookup-table) c-int)
|
|
(set! lookup-table
|
|
(vector-append
|
|
lookup-table
|
|
(make-vector (+ (- c-int (vector-length lookup-table)) 1) #f))))
|
|
(vector-set! lookup-table
|
|
c-int
|
|
(vector character
|
|
(* character-index character-width)
|
|
(* line-index character-height)))))
|
|
line))
|
|
character-lists)
|
|
(internal-make-bitmap-font image draw-width draw-height character-width character-height lookup-table)))
|
|
|
|
(define (set-bitmap-font font) (set! current-bitmap-font font))
|
|
|
|
(define draw-bitmap-text
|
|
(lambda (text x y)
|
|
(when (not current-bitmap-font)
|
|
(error "Current bitmap font not set, use make-bitmap-font and set-bitmap-font"))
|
|
(let ((offset-x x)
|
|
(lookup-table (bitmap-font-lookup-table current-bitmap-font)))
|
|
(for-each
|
|
(lambda (character)
|
|
(let ((char-data (vector-ref lookup-table (char->integer character))))
|
|
(draw-image-slice (bitmap-font-image current-bitmap-font)
|
|
offset-x
|
|
y
|
|
(bitmap-font-draw-width current-bitmap-font)
|
|
(bitmap-font-draw-height current-bitmap-font)
|
|
(vector-ref char-data 1)
|
|
(vector-ref char-data 2)
|
|
(bitmap-font-character-width current-bitmap-font)
|
|
(bitmap-font-character-height current-bitmap-font))
|
|
(set! offset-x (+ offset-x 14))))
|
|
(string->list text)))))
|
|
|