#lang racket
(require
ffi/unsafe
ffi/unsafe/define
ffi/cvector
ffi/unsafe/cvector
"./structs.rkt")
(provide (all-defined-out))
(provide make-sdl-rect)
(provide make-sdl-color)
(define *flags*
'((SDL_INIT_TIMER #x00000001)
(SDL_INIT_AUDIO #x00000010)
(SDL_INIT_VIDEO #x00000020)
(SDL_INIT_CDROM #x00000100)
(SDL_INIT_JOYSTICK #x00000200)
(SDL_INIT_NOPARACHUTE #x00100000)
(SDL_INIT_EVENTTHREAD #x01000000)
(SDL_INIT_EVERYTHING #x0000FFFF)
(SDL_SWSURFACE #x00000000)
(SDL_HWSURFACE #x00000001)
(SDL_ASYNCBLIT #x00000004)
(SDL_ANYFORMAT #x10000000)
(SDL_HWPALETTE #x20000000)
(SDL_DOUBLEBUF #x40000000)
(SDL_FULLSCREEN #x80000000)
(SDL_OPENGL #x00000002)
(SDL_OPENGLBLIT #x0000000A)
(SDL_RESIZABLE #x00000010)
(SDL_NOFRAME #x00000020)
(SDL_HWACCEL #x00000100)
(SDL_SRCCOLORKEY #x00001000)
(SDL_RLEACCELOK #x00002000)
(SDL_SRCALPHA #x00010000)
(SDL_PREALLOC #x01000000)))
(define SDL_GRAB_QUERY -1)
(define SDL_GRAB_OFF 0)
(define SDL_GRAB_ON 1)
(define SDL_ADDEVENT 0)
(define SDL_PEEKEVENT 1)
(define SDL_GETEVENT 2)
(define SDL_ALLEVENTS #xFFFFFFFF)
(define *event-states*
'((SDL_QUERY -1)
(SDL_IGNORE 0)
(SDL_DISABLE 0)
(SDL_ENABLE 1)))
(define (sdl-get-lib)
(let ((type (system-type 'os)))
(case type
((unix) "libSDL")
((windows) "SDL")
((macosx) "libSDL")
(else (error "Platform not supported: " type)))))
(define (sdl-image-get-lib)
(let ((type (system-type 'os)))
(case type
((unix) "libSDL_image")
((windows) "libSDL_image")
((macosx) "libSDL_image")
(else (error "Platform not supported: " type)))))
(define-ffi-definer define-sdl (ffi-lib (sdl-get-lib) #f))
(define img-load
(lambda (dummy) (error "img-load: SDL_image not available.")))
(with-handlers
((exn:fail?
(lambda (ex)
(printf "Failed to load optional dependency: SDL_image: ~a" ex))))
(begin
(define-ffi-definer define-img (ffi-lib (sdl-image-get-lib) #f))
(define-img IMG_Load (_fun _bytes -> _sdl-surface-pointer))
(set! img-load (lambda (path)
(IMG_Load (string->bytes/locale path))))))
(define (merge-flags flags flag-map)
(let ((vals (map (lambda (flag) (cadr (assoc flag flag-map))) flags)))
(foldl (lambda (a b) (bitwise-ior a b)) 0 vals)))
(define (assert condition value who)
(if condition
value
(error who "failed with " value)))
(define-syntax-rule (handle-msg-error msg)
(error "Unknown message: " msg))
(define (sdl-get-endianness)
(if (system-big-endian?)
'BIG
'LITTLE))
(define sdl-make-rect make-sdl-rect)
(define sdl-make-color make-sdl-color)
(define (sdl-default-mask type)
(if (eqv? 'BIG (sdl-get-endianness))
(cond ((eqv? type 'R) #xFF000000)
((eqv? type 'G) #x00FF0000)
((eqv? type 'B) #x0000FF00)
((eqv? type 'A) #x000000FF)
(else (error "Not a valid mask descriptor: " type)))
(cond ((eqv? type 'R) #x000000FF)
((eqv? type 'G) #x0000FF00)
((eqv? type 'B) #x00FF0000)
((eqv? type 'A) #xFF000000)
(else (error "Not a valid mask descriptor: " type)))))
(define-sdl SDL_Init
(_fun _uint32
-> (r : _int)
-> (assert (= r 0) r 'sdl-init)))
(define (sdl-init flags)
(SDL_Init (merge-flags flags *flags*)))
(define-sdl SDL_Quit
(_fun
-> _void))
(define (sdl-quit)
(SDL_Quit))
(define-sdl SDL_GetError
(_fun
-> _bytes))
(define (sdl-get-error)
(SDL_GetError))
(define-sdl SDL_GetVideoSurface
(_fun
-> _sdl-surface-pointer))
(define (sdl-get-video-surface)
(SDL_GetVideoSurface))
(define-sdl SDL_GetVideoInfo
(_fun
-> _sdl-video-info-pointer))
(define (sdl-get-video-info)
(SDL_GetVideoInfo))
(define-sdl SDL_VideoDriverName
(_fun _bytes _int
-> _pointer))
(define (sdl-video-driver-name)
(let* ((buffer (make-bytes 12))
(p (SDL_VideoDriverName buffer 12)))
(if (not (ptr-equal? p #f))
(make-sized-byte-string buffer 12)
(error "Failed to get video driver name. sdl initialized?"))))
(define-sdl SDL_VideoModeOK
(_fun _int _int _int _uint32
-> _int))
(define (sdl-video-mode-ok width height bpp flags)
(let ((bpp (SDL_VideoModeOK width height bpp (merge-flags flags *flags*))))
(cons (> bpp 0) bpp)))
(define (sdl-update-rects screen rects)
(define (iter item list)
(if (null? list)
(SDL_UpdateRect screen
(sdl-rect-x item)
(sdl-rect-y item)
(sdl-rect-w item)
(sdl-rect-h item))
(iter (car list) (cdr list))))
(iter (car rects) (cdr rects)))
(define-sdl SDL_SetColors
(_fun _sdl-surface-pointer _pointer _int _int
-> _int))
(define (sdl-set-colors surface colors)
(let ((vector (list->cvector colors _sdl-color-pointer)))
(SDL_SetColors surface (cvector-ptr vector) 0 (length colors))))
(define-sdl SDL_SetPalette
(_fun _sdl-surface-pointer _int _pointer _int _int
-> _int))
(define (sdl-set-palette surface flags colors)
(let ((flags-value (merge-flags flags *flags*))
(vector (list->cvector colors _sdl-color-pointer)))
(SDL_SetPalette
surface
flags-value
(cvector-ptr vector)
0
(length colors))))
(define-sdl SDL_SetGamma
(_fun _float _float _float
-> (r : _int)
-> (assert (>= r 0) r 'sdl-set-gamma)))
(define (sdl-set-gamma r g b)
(SDL_SetGamma r g b))
(define-sdl SDL_GetGammaRamp
(_fun _pointer _pointer _pointer
-> (r : _int)
-> (assert (>= r 0) r 'sdl-get-gamma-ramp)))
(define (sdl-get-gamma-ramp)
(let ((r (make-cvector _uint16 256))
(g (make-cvector _uint16 256))
(b (make-cvector _uint16 256)))
(begin
(assert
(>= 0
(SDL_GetGammaRamp
(cvector-ptr r)
(cvector-ptr g)
(cvector-ptr b))) 0 'sdl-get-gamma-ramp)
(list (cvector->list r) (cvector->list g) (cvector->list b)))))
(define-sdl SDL_SetGammaRamp
(_fun _pointer _pointer _pointer
-> (r : _int)
-> (assert (>= r 0) r 'sdl-set-gamma-ramp)))
(define (sdl-set-gamma-ramp r g b)
(let ((rvector (list->cvector r _uint16))
(gvector (list->cvector g _uint16))
(bvector (list->cvector b _uint16)))
(SDL_SetGammaRamp
(cvector-ptr rvector)
(cvector-ptr gvector)
(cvector-ptr bvector))))
(define-sdl SDL_CreateRGBSurface
(_fun _uint32 _int _int _int _uint32 _uint32 _uint32 _uint32
-> _sdl-surface-pointer))
(define (sdl-create-rgb-surface flags w h bpp rmask gmask bmask amask)
(SDL_CreateRGBSurface
(merge-flags flags *flags*)
w
h
bpp
rmask
gmask
bmask
amask))
(define-sdl SDL_CreateRGBSurfaceFrom
(_fun _pointer _int _int _int _int _uint32 _uint32 _uint32 _uint32
-> _sdl-surface-pointer))
(define (sdl-create-rgb-surface-from pixels w h depth pitch rmask gmask bmask amask)
(SDL_CreateRGBSurfaceFrom
pixels
w
h
depth
pitch
rmask
gmask
bmask
amask))
(define-sdl SDL_LockSurface
(_fun _sdl-surface-pointer
-> (r : _int)
-> (assert (= r 0) r 'sdl-lock-surface)))
(define (sdl-lock-surface surface)
(SDL_LockSurface surface))
(define-sdl SDL_UnlockSurface
(_fun _sdl-surface-pointer
-> _void))
(define (sdl-unlock-surface surface)
(SDL_UnlockSurface surface))
(define-sdl SDL_ConvertSurface
(_fun _sdl-surface-pointer _sdl-pixel-format-pointer _uint32
-> _sdl-surface-pointer))
(define (sdl-convert-surface source format flags)
(SDL_ConvertSurface source format (merge-flags flags *flags*)))
(define-sdl SDL_RWFromFile
(_fun _bytes _bytes
-> _pointer))
(define (sdl-rw-from-file path mode)
(SDL_RWFromFile
(string->bytes/locale path)
(string->bytes/locale mode)))
(define-sdl SDL_LoadBMP_RW
(_fun _pointer _int
-> _sdl-surface-pointer))
(define (sdl-load-bmp path)
(SDL_LoadBMP_RW (sdl-rw-from-file path "r") 1))
(define-sdl SDL_SaveBMP_RW
(_fun _sdl-surface-pointer _pointer _int
-> (r : _int)
-> (assert (= 0 r) r 'sdl-save-bmp)))
(define (sdl-save-bmp surface path)
(SDL_SaveBMP_RW surface (sdl-rw-from-file path "wb") 1))
(define-sdl SDL_SetColorKey
(_fun _sdl-surface-pointer _uint32 _uint32
-> (r : _int)
-> (assert (= 0 r) r 'sdl-set-color-key)))
(define (sdl-set-color-key surface flag key)
(SDL_SetColorKey surface (merge-flags flag *flags*) key))
(define-sdl SDL_SetAlpha
(_fun _sdl-surface-pointer _uint32 _uint8
-> (r : _int)
-> (assert (= 0 r) r 'sdl-set-alpha)))
(define (sdl-set-alpha surface flags alpha)
(SDL_SetAlpha surface (merge-flags flags *flags*) alpha))
(define-sdl SDL_SetClipRect
(_fun _sdl-surface-pointer _sdl-rect-pointer
-> _void))
(define (sdl-set-clip-rect surface rect)
(SDL_SetClipRect surface rect))
(define-sdl SDL_GetClipRect
(_fun _sdl-surface-pointer _sdl-rect-pointer
-> _void))
(define (sdl-get-clip-rect surface)
(let ((rect (make-sdl-rect 0 0 0 0)))
(begin
(SDL_GetClipRect surface rect)
rect)))
(define-sdl SDL_FillRect
(_fun _sdl-surface-pointer _sdl-rect-pointer _uint32
-> (r : _int)
-> (assert (= r 0) r 'sdl-fill-rect)))
(define (sdl-fill-rect surface rect color)
(SDL_FillRect surface rect color))
(define-sdl SDL_SetVideoMode
(_fun _int _int _int _uint32
-> _sdl-surface-pointer))
(define (sdl-set-video-mode width height bpp flags)
(SDL_SetVideoMode width height bpp (merge-flags flags *flags*)))
(define-sdl SDL_UpperBlit
(_fun
_sdl-surface-pointer
_sdl-rect-pointer
_sdl-surface-pointer
_sdl-rect-pointer
-> (r : _int)
-> (assert (= r 0) r 'sdl-blit-surface)))
(define (sdl-blit-surface s srect d drect)
(SDL_UpperBlit s srect d drect))
(define-sdl SDL_UpdateRect
(_fun _sdl-surface-pointer _sint32 _sint32 _sint32 _sint32
-> _void))
(define (sdl-update-rect screen x y w h)
(SDL_UpdateRect screen x y w h))
(define-sdl SDL_FreeSurface
(_fun _sdl-surface-pointer
-> _void))
(define (sdl-free-surface surface)
(SDL_FreeSurface surface))
(define-sdl SDL_Flip
(_fun _sdl-surface-pointer
-> _void))
(define (sdl-flip surface)
(SDL_Flip surface))
(define-sdl SDL_DisplayFormat
(_fun _sdl-surface-pointer
-> _sdl-surface-pointer))
(define (sdl-display-format surface)
(SDL_DisplayFormat surface))
(define-sdl SDL_DisplayFormatAlpha
(_fun _sdl-surface-pointer
-> _sdl-surface-pointer))
(define (sdl-display-format-alpha surface)
(SDL_DisplayFormatAlpha surface))
(define-sdl SDL_WM_SetCaption
(_fun _bytes _bytes
-> _void))
(define (sdl-wm-set-caption title icon)
(SDL_WM_SetCaption
(string->bytes/locale title)
(string->bytes/locale icon)))
(define-sdl SDL_WM_SetIcon
(_fun _sdl-surface-pointer _uint8
-> _void))
(define (sdl-wm-set-icon surface mask)
(SDL_WM_SetIcon surface mask))
(define-sdl SDL_WM_IconifyWindow
(_fun
-> _int))
(define (sdl-wm-iconify-window)
(SDL_WM_IconifyWindow))
(define-sdl SDL_WM_ToggleFullScreen
(_fun _sdl-surface-pointer
-> _int))
(define (sdl-wm-toggle-fullscreen surface)
(SDL_WM_ToggleFullScreen surface))
(define-sdl SDL_WM_GrabInput
(_fun _int
-> _int))
(define (sdl-wm-grab-input mode)
(SDL_WM_GrabInput mode))
(define-sdl SDL_GetTicks
(_fun
-> _uint32))
(define (sdl-get-ticks) (SDL_GetTicks))
(define-sdl SDL_Delay
(_fun _uint32
-> _void))
(define (sdl-delay milliseconds) (SDL_Delay milliseconds))
(define-sdl SDL_WarpMouse
(_fun _uint16 _uint16
-> _void))
(define (sdl-warp-mouse x y) (SDL_WarpMouse x y))
(define-sdl SDL_ShowCursor
(_fun _int
-> _int))
(define (sdl-show-cursor toggle)
(SDL_ShowCursor (cadr (assoc toggle *event-states*))))
(define-sdl SDL_PumpEvents
(_fun
-> _void))
(define (sdl-pump-events)
(SDL_PumpEvents))
(define-sdl SDL_PeepEvents
(_fun _pointer _int _uint8 _uint32
-> (r : _int)
-> (assert (>= r 0) r 'sdl-wait-events)))
(define (sdl-peep-events events action mask)
(let ((pointers
(list->cvector
(map (lambda (event) (event 'POINTER)) events) _pointer)))
(SDL_PeepEvents
(cvector-ptr pointers)
(length events)
action
mask)))
(define-sdl SDL_PollEvent
(_fun _sdl-event-pointer
-> _int))
(define (sdl-poll-event event)
(SDL_PollEvent event))
(define-sdl SDL_WaitEvent
(_fun _sdl-event-pointer
-> (r : _int)
-> (assert (= 1 r) r 'sdl-wait-events)))
(define (sdl-wait-event event)
(SDL_WaitEvent event))
(define-sdl SDL_EventState
(_fun _sdl-event-type _int
-> _uint8))
(define (sdl-event-state type state)
(SDL_EventState type (cadr (assoc state *event-states*))))
(define-sdl SDL_GetKeyState
(_fun _pointer
-> _pointer))
(define (sdl-get-key-state)
(let* ((numkeys (malloc (ctype-sizeof _int)))
(result (SDL_GetKeyState numkeys))
(length (ptr-ref numkeys _int))
(vector (make-cvector* result _uint8 length)))
(cvector->list vector)))
(define-sdl SDL_GetModState
(_fun
-> _sdl-mod))
(define (sdl-get-mod-state) (SDL_GetModState))
(define-sdl SDL_SetModState
(_fun _sdl-mod
-> _void))
(define (sdl-set-mod-state state)
(SDL_SetModState state))
(define-sdl SDL_EnableUNICODE
(_fun _int
-> _int))
(define (sdl-enable-unicode enable)
(SDL_EnableUNICODE enable))
(define-sdl SDL_EnableKeyRepeat
(_fun _int _int
-> (r : _int)
-> (assert (= r 0) r 'sdl-enable-key-repeat)))
(define (sdl-enable-key-repeat delay interval)
(SDL_EnableKeyRepeat delay interval))
(define-sdl SDL_GetMouseState
(_fun _pointer _pointer
-> _uint8))
(define (sdl-get-mouse-state)
(let* ((x (malloc (ctype-sizeof _int)))
(y (malloc (ctype-sizeof _int)))
(r (SDL_GetMouseState x y)))
(begin
(list
r
(ptr-ref x _int)
(ptr-ref y _int)))))
(define-sdl SDL_GetRelativeMouseState
(_fun _pointer _pointer
-> _uint8))
(define (sdl-get-relative-mouse-state)
(let* ((x (malloc (ctype-sizeof _int)))
(y (malloc (ctype-sizeof _int)))
(r (SDL_GetRelativeMouseState x y)))
(begin
(list
r
(ptr-ref x _int)
(ptr-ref y _int)))))
(define-sdl SDL_GetAppState
(_fun
-> _uint8))
(define (sdl-get-app-state) (SDL_GetAppState))
(define-sdl SDL_JoystickEventState
(_fun _int
-> _int))
(define (sdl-joystick-event-state state)
(SDL_JoystickEventState (cadr (assoc state *event-states*))))
(define (sdl-active-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-active-event)))
(lambda (msg)
(case msg
((TYPE) type)
((GAIN) (sdl-active-event-gain event))
((STATE) (sdl-active-event-state event))
(else (handle-msg-error msg))))))
(define (sdl-mouse-motion-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-mouse-motion-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-mouse-motion-event-which event))
((STATE) (sdl-mouse-motion-event-state event))
((X) (sdl-mouse-motion-event-x event))
((Y) (sdl-mouse-motion-event-y event))
((XREL) (sdl-mouse-motion-event-xrel event))
((YREL) (sdl-mouse-motion-event-yrel event))
(else (handle-msg-error msg))))))
(define (sdl-keyboard-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-keyboard-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-keyboard-event-which event))
((STATE) (sdl-keyboard-event-state event))
((KEYSYM) (sdl-keysym-constructor (sdl-keyboard-event-keysym event)))
(else (handle-msg-error msg))))))
(define (sdl-keysym-constructor keysym)
(lambda (msg)
(case msg
((SCANCODE) (sdl-keysym-scancode keysym))
((SYM) (sdl-keysym-sym keysym))
((MOD) (sdl-keysym-mod keysym))
((UNICODE) (sdl-keysym-unicode keysym))
(else (handle-msg-error msg)))))
(define (sdl-mouse-button-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-mouse-button-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-mouse-button-event-which event))
((BUTTON) (sdl-mouse-button-event-button event))
((STATE) (sdl-mouse-button-event-state event))
((X) (sdl-mouse-button-event-x event))
((Y) (sdl-mouse-button-event-y event))
(else (handle-msg-error msg))))))
(define (sdl-joy-axis-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-joy-axis-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-joy-axis-event-which event))
((AXIS) (sdl-joy-axis-event-axis event))
((VALUE) (sdl-joy-axis-event-value event))
(else (handle-msg-error msg))))))
(define (sdl-joy-ball-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-joy-ball-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-joy-ball-event-which event))
((BALL) (sdl-joy-ball-event-ball event))
((XREL) (sdl-joy-ball-event-xrel event))
((YREL) (sdl-joy-ball-event-yrel event))
(else (handle-msg-error msg))))))
(define (sdl-joy-hat-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-joy-hat-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-joy-hat-event-which event))
((HAT) (sdl-joy-hat-event-hat event))
((VALUE) (sdl-joy-hat-event-value event))
(else (handle-msg-error msg))))))
(define (sdl-joy-button-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-joy-button-event)))
(lambda (msg)
(case msg
((TYPE) type)
((WHICH) (sdl-joy-button-event-which event))
((BUTTON) (sdl-joy-button-event-button event))
((STATE) (sdl-joy-button-event-state event))
(else (handle-msg-error msg))))))
(define (sdl-resize-constructor raw-pointer type)
(let ((event (ptr-ref raw-pointer _sdl-resize-event)))
(lambda (msg)
(case msg
((TYPE) type)
((W) (sdl-resize-event-w event))
((H) (sdl-resize-event-h event))
(else (handle-msg-error msg))))))
(define (sdl-expose-constructor type)
(lambda (msg)
(case msg
((TYPE) type)
(else (handle-msg-error msg)))))
(define (sdl-quit-constructor type)
(lambda (msg)
(case msg
((TYPE) type)
(else (handle-msg-error msg)))))
(define (sdl-make-event)
(let ((event (malloc 128)))
(begin
(cpointer-push-tag! event sdl-event-tag)
(lambda (msg)
(case msg
((POINTER) event)
((TYPE) (sdl-event-type event))
((EVENT)
(case (sdl-event-type event)
((SDL_ACTIVEEVENT) (sdl-active-constructor event 'SDL_ACTIVEEVENT))
((SDL_MOUSEMOTION) (sdl-mouse-motion-constructor event 'SDL_MOUSEMOTION))
((SDL_KEYDOWN) (sdl-keyboard-constructor event 'SDL_KEYDOWN))
((SDL_KEYUP) (sdl-keyboard-constructor event 'SDL_KEYUP))
((SDL_MOUSEBUTTONDOWN) (sdl-mouse-button-constructor event 'SDL_MOUSEBUTTONDOWN))
((SDL_MOUSEBUTTONUP) (sdl-mouse-button-constructor event 'SDL_MOUSEBUTTONUP))
((SDL_JOYAXISMOTION) (sdl-joy-axis-constructor event 'SDL_JOYAXISMOTION))
((SDL_JOYBALLMOTION) (sdl-joy-ball-constructor event 'SDL_JOYBALLMOTION))
((SDL_JOYHATMOTION) (sdl-joy-hat-constructor event 'SDL_JOYHATMOTION))
((SDL_JOYBUTTONDOWN) (sdl-joy-button-constructor event 'SDL_JOYBUTTONDOWN))
((SDL_JOYBUTTONUP) (sdl-joy-button-constructor event 'SDL_JOYBUTTONUP))
((SDL_VIDEORESIZE) (sdl-resize-constructor event 'SDL_VIDEORESIZE))
((SDL_VIDEOEXPOSE) (sdl-expose-constructor 'SDL_VIDEOEXPOSE))
((SDL_QUIT) (sdl-quit-constructor 'SDL_QUIT))
(else (error "Unkown event type:" msg)))))))))