136 lines
2.9 KiB
Scheme
136 lines
2.9 KiB
Scheme
#!r6rs
|
|
; main thing i'd like to do is be compatible with these:
|
|
; https://www.mzrg.com/mines/msx/index.html
|
|
; let's do about the minimum to do what i want
|
|
|
|
(load-shared-object "libraylib.so")
|
|
|
|
; color
|
|
(define-ftype Color
|
|
(struct
|
|
[r unsigned-8]
|
|
[g unsigned-8]
|
|
[b unsigned-8]
|
|
[a unsigned-8]))
|
|
|
|
(define (set-color-r! color r) (ftype-set! Color (r) color r))
|
|
(define (set-color-g! color g) (ftype-set! Color (g) color g))
|
|
(define (set-color-b! color b) (ftype-set! Color (b) color b))
|
|
(define (set-color-a! color a) (ftype-set! Color (a) color a))
|
|
|
|
(define (color-r color) (ftype-ref Color (r) color))
|
|
(define (color-g color) (ftype-ref Color (g) color))
|
|
(define (color-b color) (ftype-ref Color (b) color))
|
|
(define (color-a color) (ftype-ref Color (a) color))
|
|
|
|
(define (color-components c) (list (color-r c) (color-g c) (color-b c) (color-a c)))
|
|
|
|
(define color
|
|
(case-lambda
|
|
[(r g b) (color r g b 255)]
|
|
[(r g b a)
|
|
(define c (make-ftype-pointer Color (foreign-alloc (ftype-sizeof Color))))
|
|
(set-color-r! c r)
|
|
(set-color-g! c g)
|
|
(set-color-b! c b)
|
|
(set-color-a! c a)
|
|
c]))
|
|
|
|
;; (define c (color 1 2 3 4))
|
|
;; (display (list (color-r c) (color-g c) (color-b c) (color-a c)))
|
|
|
|
; window
|
|
(define init-window
|
|
(foreign-procedure #f "InitWindow" (int int string) void))
|
|
|
|
(define close-window
|
|
(foreign-procedure #f "CloseWindow" () void))
|
|
|
|
(define window-should-close?
|
|
(foreign-procedure #f "WindowShouldClose" () boolean))
|
|
|
|
; drawing
|
|
(define clear-background
|
|
(foreign-procedure #f "ClearBackground" ((& Color)) void))
|
|
|
|
(define begin-drawing
|
|
(foreign-procedure #f "BeginDrawing" () void))
|
|
|
|
(define end-drawing
|
|
(foreign-procedure #f "EndDrawing" () void))
|
|
|
|
; timing
|
|
(define set-target-fps
|
|
(foreign-procedure #f "SetTargetFPS" (int) void))
|
|
|
|
(define get-frame-time
|
|
(foreign-procedure #f "GetFrameTime" () float))
|
|
|
|
(define get-time
|
|
(foreign-procedure #f "GetTime" () double))
|
|
|
|
(define get-fps
|
|
(foreign-procedure #f "GetFPS" () int))
|
|
|
|
; text
|
|
|
|
(define draw-fps
|
|
(foreign-procedure #f "DrawFPS" (int int) void))
|
|
|
|
(define draw-text
|
|
(foreign-procedure #f "DrawText" (string int int int (& Color)) void))
|
|
|
|
; texture
|
|
|
|
(define-ftype Image
|
|
(struct
|
|
[data void*]
|
|
[width int]
|
|
[height int]
|
|
[mipmaps int]
|
|
[format int]))
|
|
|
|
(define load-image
|
|
(foreign-procedure #f "LoadImage" (string) (& Image)))
|
|
|
|
; scheme magicks
|
|
|
|
(define-syntax with-draw
|
|
(syntax-rules ()
|
|
[(_ body ...)
|
|
(begin (begin-drawing)
|
|
body ...
|
|
(end-drawing))]))
|
|
|
|
(define-syntax while
|
|
(syntax-rules ()
|
|
[(_ test body ...)
|
|
(do []
|
|
[(not test) #f]
|
|
body ...)]))
|
|
|
|
(define-syntax until
|
|
(syntax-rules ()
|
|
[(_ test body ...)
|
|
(do []
|
|
[test #f]
|
|
body ...)]))
|
|
|
|
; my stuff :]
|
|
|
|
(define (main)
|
|
(init-window 100 100 "hello")
|
|
(set-target-fps 120)
|
|
|
|
(until (window-should-close?)
|
|
(with-draw
|
|
(clear-background (color 245 245 245 255))
|
|
(draw-fps 0 0)
|
|
(draw-text "wow awesome" 0 20 20 (color 0 0 0))))
|
|
|
|
(close-window))
|
|
|
|
(main)
|
|
|
|
|