schemelib/bindings/sdl.scm
2020-07-02 17:53:16 +02:00

229 lines
5.1 KiB
Scheme

(load-shared-object "libSDL2-2.0.so.0")
(load-shared-object "libSDL2_image-2.0.so.0")
; A quick example:
; https://stackoverflow.com/questions/20579658/how-to-draw-pixels-in-sdl-2-0
;
; Header files to write bindings:
; https://github.com/SDL-mirror/SDL/tree/master/include
; https://github.com/SDL-mirror/SDL_image/blob/master/SDL_image.h
;--- binding utils
(define (check-err out)
(assert (= 0 out)))
;--- SDL.h
(define (SDL_INIT-flag->int flag)
(case flag
((VIDEO) #x00000020)
))
(define (SDL_Init flag)
(check-err ((foreign-procedure "SDL_Init" (unsigned-32) int) (SDL_INIT-flag->int flag))))
(define (SDL_Quit)
((foreign-procedure "SDL_Quit" () void)))
;--- SDL_video.h
(define (SDL_WINDOW-flag->int flag)
(case flag
((SHOW) #x00000004)
((FOREIGN) #x00000800)
((HIDDEN) #x00000008)
))
(define (SDL_CreateWindow name x y w h flags)
(let*
[(fx (foreign-procedure
"SDL_CreateWindow"
(string int int int int unsigned-32)
void*))
(win (fx name x y w h (SDL_WINDOW-flag->int flags)))]
(assert (> win 0))
win))
(define (SDL_SetWindowSize win w h)
((foreign-procedure
"SDL_SetWindowSize"
(void* int int)
void) win w h))
(define (SDL_DestroyWindow window)
((foreign-procedure
"SDL_DestroyWindow"
(void*)
void) window))
;--- SDL_render.h
(define-ftype
[SdlRect
(struct
(x int) (y int)
(w int) (h int)
)])
(define (SDL_Rect x y w h)
(let [
(rect
(make-ftype-pointer
SdlRect
(foreign-alloc (ftype-sizeof SdlRect))))]
(ftype-set! SdlRect (x) rect x)
(ftype-set! SdlRect (y) rect y)
(ftype-set! SdlRect (w) rect w)
(ftype-set! SdlRect (h) rect h)
rect
))
(define (SDL_RenderSetLogicalSize rend w h)
(check-err
((foreign-procedure
"SDL_RenderSetLogicalSize"
(void* int int)
int) rend w h)))
(define (SDL_RenderSetScale rend scaleX scaleY)
(check-err
((foreign-procedure
"SDL_RenderSetScale"
(void* float float)
int) rend scaleX scaleY)))
(define (SDL_RENDERER-flag->int flag)
(case flag
((SOFTWARE) #x00000001)
((ACCELERATED) #x00000002)
))
(define (SDL_CreateRenderer window index flags)
(let*
[(fx (foreign-procedure
"SDL_CreateRenderer"
(void* int unsigned-32)
void*))
(rend (fx window index (SDL_RENDERER-flag->int flags)))]
(assert (> rend 0))
rend))
(define (SDL_RenderReadPixels rend rect format pix pitch)
(check-err
((foreign-procedure
"SDL_RenderReadPixels"
(void* (* SdlRect) unsigned-32 void* int)
int) rend rect format pix pitch)))
(define (SDL_SetRenderDrawColor rend r g b a)
(check-err
((foreign-procedure
"SDL_SetRenderDrawColor"
(void* unsigned-8 unsigned-8 unsigned-8 unsigned-8)
int) rend r g b a)))
(define (SDL_RenderGetViewport rend rect)
((foreign-procedure
"SDL_RenderGetViewport"
(void* (* SdlRect))
void) rend rect))
(define (SDL_RenderClear rend)
(check-err
((foreign-procedure
"SDL_RenderClear"
(void*)
int) rend)))
(define (SDL_RenderDrawPoint rend x y)
(check-err
((foreign-procedure
"SDL_RenderDrawPoint"
(void* int int)
int) rend x y)))
(define (SDL_RenderPresent rend)
((foreign-procedure
"SDL_RenderPresent"
(void*)
void) rend))
(define (SDL_DestroyRenderer rend)
((foreign-procedure
"SDL_DestroyRenderer"
(void*)
void) rend))
;--- SDL_surface.h
(define-ftype
[SdlPixelFormat
(struct
(format unsigned-32)
;-- not safe to allocate, missing fields
)]
[SdlSurface
(struct
(flags unsigned-32)
(format (* SdlPixelFormat))
(w int)
(h int)
(pitch int)
(pixels void*)
;-- not safe to allocate, missing fields
)])
(define (SDL_CreateRGBSurface flags w h depth Rm Gm Bm Am)
((foreign-procedure
"SDL_CreateRGBSurface"
(unsigned-32 int int int unsigned-32 unsigned-32 unsigned-32 unsigned-32)
(* SdlSurface)) flags w h depth Rm Gm Bm Am))
; inspired by https://stackoverflow.com/a/20070273
(define (SDLb_SetPixel surface x y r g b a)
(map
(lambda (e)
(let [(color (car e)) (intensity (cadr e))]
(foreign-set!
'unsigned-8
(ftype-ref SdlSurface (pixels) surface)
(+
(* y (ftype-ref SdlSurface (pitch) surface))
(* x (ftype-sizeof unsigned-32))
color)
intensity
)))
`((0 ,b) (1 ,g) (2 ,r) (3 ,a))
))
;--- SDL_events.h
(define-ftype
[SdlEvent
(union
(type unsigned-32)
(padding (array 56 unsigned-8)))]
)
(define (SDL_Event)
(make-ftype-pointer
SdlEvent
(foreign-alloc (ftype-sizeof SdlEvent))))
(define (SDL_PollEvent event)
((foreign-procedure
"SDL_PollEvent"
((* SdlEvent))
int) event))
(define (SDL_EVENT-int->flag i)
(case i
((#x100) 'QUIT)
))
;--- SDL_image.h
(define (IMG_SavePNG surface file)
(check-err
((foreign-procedure
"IMG_SavePNG"
((* SdlSurface) string)
int) surface file)))