469 lines
16 KiB
Scheme
469 lines
16 KiB
Scheme
(import (scheme)
|
|
(chicken base)
|
|
(chicken foreign))
|
|
(import-for-syntax (sdl3 internal utilities))
|
|
|
|
(foreign-declare "#include <SDL3/SDL_video.h>")
|
|
|
|
;;; Types
|
|
|
|
(define-foreign-type SDL_DisplayID unsigned-int32)
|
|
(define-foreign-type SDL_WindowID unsigned-int32)
|
|
(define-foreign-type SDL_EGLAttrib size_t)
|
|
(define-foreign-type SDL_EGLAttribArrayCallback
|
|
(function SDL_EGLAttrib () "SDLCALL"))
|
|
(define-foreign-type SDL_EGLDisplay c-pointer)
|
|
(define-foreign-type SDL_GLContext (struct "SDL_GLContext"))
|
|
(define-foreign-type SDL_HitTest
|
|
(function SDL_HitTestResult ((c-pointer SDL_Window) (c-pointer SDL_Point) c-pointer)))
|
|
(define-foreign-type SDL_Window (struct "SDL_Window"))
|
|
(define-foreign-type SDL_DisplayMode (struct "SDL_DisplayMode"))
|
|
|
|
;;; Constants
|
|
|
|
(define-foreign-type SDL_DisplayOrientation (enum "SDL_DisplayOrientation"))
|
|
(define-sdl-const-values
|
|
orientation SDL_DisplayOrientation
|
|
(unknown landscape landscape-flipped portrait portrait-flipped))
|
|
|
|
(define-foreign-type SDL_FlashOperation (enum "SDL_FlashOperation"))
|
|
(define-sdl-const-values
|
|
flash SDL_FlashOperation
|
|
(cancel briefly until-focused))
|
|
|
|
(define-foreign-type SDL_GLattr (enum "SDL_GLattr"))
|
|
(define-sdl-const-values
|
|
(gl SDL_GLattr
|
|
red-size green-size blue-size alpha-size buffer-size doublebuffer depth-size
|
|
stencil-size accum-red-size accum-green-size accum-blue-size accum-alpha-size
|
|
stereo multisamplebuffers multisamplesamples accelerated-visual retained-backing
|
|
context-major-version context-minor-version context-flags context-profile-mask
|
|
share-with-current-context framebuffer-srgb-capable context-release-behavior
|
|
context-reset-notification context-no-error floatbuffers egl-platform))
|
|
|
|
(define-foreign-type SDL_GLcontextFlag (enum "SDL_GLcontextFlag"))
|
|
(define-sdl-const-values
|
|
gl-context SDL_GLcontextFlag
|
|
(debug-flag forward-compatible-flag robust-access-flag reset-isolation-flag))
|
|
|
|
(define-foreign-type SDL_GLcontextReleaseFlag (enum "SDL_GLcontextReleaseFlag"))
|
|
(define-sdl-const-values
|
|
gl-context-release-behavior SDL_GLcontestReleaseFlag
|
|
(none flush))
|
|
|
|
(define-foreign-type SDL_GLContextResetNotification (enum "SDL_GLContextResetNotification"))
|
|
(define-sdl-const-values
|
|
gl-context-reset SDL_GLContextResetNotification
|
|
(no-notification lose-context))
|
|
|
|
(define-foreign-type SDL_GLprofile (enum "SDL_GLprofile"))
|
|
(define-sdl-const-values
|
|
gl-context-profile SDL_GLprofile
|
|
(core compatibility es))
|
|
|
|
(define-foreign-type SDL_HitTestResult (enum "SDL_HitTestResult"))
|
|
(define-sdl-const-values
|
|
hittest SDL_HitTestResult
|
|
(normal draggable resize-topleft resize-top resize-topright resize-right
|
|
resize-bottomright resize-bottom resize-bottomleft resize-left))
|
|
|
|
(define-foreign-type SDL_SystemTheme (enum "SDL_SystemTheme"))
|
|
(define-sdl-const-values
|
|
system-theme SDL_SystemTheme
|
|
(unknown light dark))
|
|
|
|
(define-foreign-type SDL_WindowFlags unsigned-int64)
|
|
(define-sdl-const-values
|
|
window SDL_WindowFlags
|
|
(fullscreen opengl occluded hidden borderless resizable minimized maximized
|
|
mouse-grabbed input-focus mouse-focus external modal high-pixel-density
|
|
mouse-capture mouse-relative-mode always-on-top utility tooltip popup-menu
|
|
keyboard-grabbed vulkan metal transparent not-focusable))
|
|
|
|
;; These are weird string properties for CreateWindowWithProperties
|
|
(define-sdl-const-values
|
|
prop-window-create c-string
|
|
(always-on-top-boolean borderless-boolean external-graphics-context-boolean
|
|
focusable-boolean fullscreen-boolean height-number hidden-boolean
|
|
high-pixel-density-boolean maximized-boolean menu-boolean
|
|
metal-boolean minimized-boolean modal-boolean
|
|
mouse-grabbed-boolean opengl-boolean parent-pointer
|
|
resizable-boolean title-string transparent-boolean tooltip-boolean
|
|
utility-boolean vulkan-boolean width-number x-number y-number
|
|
cocoa-window-pointer cocoa-view-pointer
|
|
wayland-surface-role-custom-boolean
|
|
wayland-create-egl-window-boolean wayland-wl-surface-pointer
|
|
win32-hwnd-pointer win32-pixel-format-hwnd-pointer
|
|
x11-window-number))
|
|
|
|
(define-sdl-const-values
|
|
pixelformat unsigned-int32
|
|
(unknown index1lsb index1msb index2lsb index2msb index4lsb index4msb index8 rgb332
|
|
xrgb4444 xbgr4444 xrgb1555 xbgr1555 argb4444 rgba4444 abgr4444 bgra4444 argb1555
|
|
rgba5551 abgr1555 bgra5551 rgb565 bgr565 rgb24 bgr24 xrgb8888 rgbx8888
|
|
pixelformat-xbgr8888 pbgrx8888 pargb8888 prgba8888 pabgr8888 pbgra8888
|
|
pxrgb2101010 pxbgr2101010 pargb2101010 pabgr2101010 prgb48 pbgr48 prgba64
|
|
pargb64 pbgra64 pabgr64 prgb48-float pbgr48-float prgba64-float pargb64-float
|
|
pbgra64-float pabgr64-float prgb96-float pbgr96-float prgba128-float
|
|
pargb128-float pbgra128-float pabgr128-float pyv12 piyuv pyuy2 puyvy pyvyu pnv12
|
|
pnv21 pp010 external-oes rgba32 argb32 bgra32 abgr32 rgbx32 xrgb32 bgrx32
|
|
xbgr32))
|
|
|
|
;;; Procedures
|
|
|
|
(define (create-popup-window parent offset-x offset-y w h #!rest flags)
|
|
((foreign-lambda (c-pointer SDL_Window) "SDL_CreatePopupWindow"
|
|
(struct SDL_Window) int int int int unsigned-int64)
|
|
parent offset-x offset-y w h (foldl-uint-flags flags)))
|
|
|
|
(define (create-window title w h #!rest flags)
|
|
((foreign-lambda (c-pointer SDL_Window) "SDL_CreateWindow"
|
|
c-string int int unsigned-int32)
|
|
title w h (foldl-uint-flags flags)))
|
|
|
|
;; TODO: SDL_CreateWindowWithProperties
|
|
|
|
(define destroy-window
|
|
(call-c void SDL_DestroyWindow ((c-pointer SDL_Window))))
|
|
|
|
(define destroy-window-surface
|
|
(foreign-lambda bool "SDL_DestroyWindowSurface" (c-pointer SDL_Window)))
|
|
|
|
(define disable-screen-saver
|
|
(foreign-lambda bool "SDL_DisableScreenSaver"))
|
|
|
|
(define egl-get-current-config
|
|
(foreign-lambda c-pointer "SDL_EGL_GetCurrentConfig"))
|
|
|
|
(define egl-get-current-display
|
|
(foreign-lambda c-pointer "SDL_EGL_GetCurrentDisplay"))
|
|
|
|
(define egl-get-proc-address
|
|
(foreign-lambda c-pointer "SDL_EGL_GetProcAddress" c-string))
|
|
|
|
(define egl-get-window-surface
|
|
(foreign-lambda c-pointer "SDL_EGL_GetWindowSurface" (c-pointer SDL_Window)))
|
|
|
|
;; TODO: SDL_EGL_SetAttributeCallbacks
|
|
|
|
(define enable-screen-saver
|
|
(foreign-lambda bool "SDL_EnableScreenSaver"))
|
|
|
|
(define flash-window
|
|
(foreign-lambda bool "SDL_FlashWindow" (c-pointer SDL_Window) SDL_FlashOperation))
|
|
|
|
(define get-closest-fullscreen-display-mode
|
|
(foreign-lambda bool "SDL_GetClosestFullscreenDisplayMode"
|
|
SDL_DisplayID int int float bool (c-pointer SDL_DisplayMode)))
|
|
|
|
(define get-current-display-mode
|
|
(foreign-lambda (c-pointer SDL_DisplayMode) "SDL_DisplayMode" SDL_DisplayID))
|
|
|
|
(define get-current-display-orientation
|
|
(foreign-lambda SDL_DisplayOrientation "SDL_GetCurrentDisplayOrientation"
|
|
SDL_DisplayID))
|
|
|
|
(define get-current-video-driver
|
|
(foreign-lambda c-string "SDL_GetCurrentVideoDriver"))
|
|
|
|
(define get-desktop-display-mode
|
|
(foreign-lambda (c-pointer SDL_DisplayMode) "SDL_GetDesktopDisplayMode"
|
|
SDL_DisplayID))
|
|
|
|
(define get-display-bounds
|
|
(foreign-lambda bool "SDL_GetDisplayBounds"
|
|
unsigned-int32 (c-pointer (struct "SDL_Rect"))))
|
|
|
|
(define get-display-content-scale
|
|
(foreign-lambda float "SDL_GetDisplayContentScale" unsigned-int32))
|
|
|
|
(define get-display-for-point
|
|
(foreign-lambda unsigned-int32 "SDL_GetDisplayForPoint"
|
|
(c-pointer (struct "SDL_Point"))))
|
|
|
|
(define get-display-for-rect
|
|
(foreign-lambda unsigned-int32 "SDL_GetDisplayForRect"
|
|
(c-pointer (struct "SDL_Rect"))))
|
|
|
|
(define get-display-for-window
|
|
(foreign-lambda unsigned-int32 "SDL_GetDisplayForWindow"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-display-name
|
|
(foreign-lambda c-string "SDL_GetDisplayName" unsigned-int32))
|
|
|
|
(define get-display-properties
|
|
(foreign-lambda unsigned-int32 "SDL_GetDisplayProperties" unsigned-int32))
|
|
|
|
;; TODO: SDL_GetDisplays
|
|
|
|
(define get-display-usable-bounds
|
|
(foreign-lambda bool "SDL_GetDisplayUsableBounds"
|
|
unsigned-int32 (c-pointer (struct "SDL_Rect"))))
|
|
|
|
;; TODO: SDL_GetFullscreenDisplayModes
|
|
|
|
(define get-grabbed-window
|
|
(foreign-lambda (c-pointer (struct "SDL_Window")) "SDL_GetGrabbedWindow"))
|
|
|
|
(define get-natural-display-orientation
|
|
(foreign-lambda (enum "SDL_DisplayOrientation" unsigned-int32)))
|
|
|
|
(define get-num-video-drivers
|
|
(foreign-lambda int "SDL_GetNumVideoDrivers"))
|
|
|
|
(define get-primary-display
|
|
(foreign-lambda unsigned-int22 "SDL_GetPrimaryDisplay"))
|
|
|
|
(define-sdl-const-values
|
|
system-theme int
|
|
(unknown light dark))
|
|
|
|
(define get-system-theme
|
|
(foreign-lambda (enum "SDL_SystemTheme") "SDL_GetSystemTheme"))
|
|
|
|
(define get-video-driver
|
|
(foreign-lambda c-string "SDL_GetVideoDriver" int))
|
|
|
|
;; TODO: SDL_GetWindowAspectRatio
|
|
|
|
;; TODO: SDL_GetWindowBordersSize
|
|
|
|
(define get-window-display-scale
|
|
(foreign-lambda float "SDL_GetWindowDisplayScale" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-flags
|
|
(foreign-lambda unsigned-int32 "SDL_GetWindowFlags" (c-pointer (c-struct "SDL_Window"))))
|
|
|
|
(define get-window-from-id
|
|
(foreign-lambda (c-pointer (struct "SDL_Window")) "SDL_GetWindowFromID" unsigned-int32))
|
|
|
|
(define get-window-fullscreen-mode
|
|
(foreign-lambda (c-pointer (struct "SDL_DisplayMode")) "SDL_GetWindowFullscreenMode"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_GetWindowICCProfile
|
|
|
|
(define get-window-id
|
|
(foreign-lambda unsigned-int32 "SDL_GetWindowID" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-keyboard-grab
|
|
(foreign-lambda bool "SDL_GetWindowKeywordGrab" (c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_GetWindowMaximumSize
|
|
|
|
;; TODO: SDL_GetWindowMinimumSize
|
|
|
|
(define get-window-mouse-grab
|
|
(foreign-lambda bool "SDL_GetWindowMouseGrab" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-mouse-rect
|
|
(foreign-lambda (c-pointer (struct "SDL_Rect")) "SDL_GetWindowMouseRect"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-opacity
|
|
(foreign-lambda float "SDL_GetWindowOpacity" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-parent
|
|
(foreign-lambda (c-pointer (struct "SDL_Window")) "SDL_GetWindowParent"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-pixel-density
|
|
(foreign-lambda float "SDL_GetWindowPixelDensity" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define get-window-pixel-format
|
|
(foreign-lambda (enum "SDL_PixelFormat") "SDL_GetWindowPixelFormat"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_GetWindowPosition
|
|
|
|
(define get-window-properties
|
|
(foreign-lambda unsigned-int32 "SDL_GetWindowProperties"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_GetWindows
|
|
|
|
;; TODO: SDL_GetWindowSafeArea
|
|
|
|
;; TODO: SDL_GetWindowSize
|
|
|
|
;; TODO: SDL_GetWindowSizeInPixels
|
|
|
|
(define get-window-surface
|
|
(foreign-lambda (c-pointer (struct "SDL_Surface")) "SDL_GetWindowSurface"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_GetWindowSurfaceVSync
|
|
|
|
(define get-window-title
|
|
(foreign-lambda c-string "SDL_GetWindowTitle" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define gl-create-context
|
|
(foreign-lambda (struct "SDL_GLContext") "SDL_GL_CreateContext"
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define gl-destroy-context
|
|
(foreign-lambda bool "SDL_GL_DestroyContext" (struct "SDL_GLContext")))
|
|
|
|
(define gl-extension-supported
|
|
(foreign-lambda bool "SDL_GL_ExtensionSupported" c-string))
|
|
|
|
;; TODO: SDL_GL_GetAttribute
|
|
|
|
(define gl-get-current-context
|
|
(foreign-lambda (struct "SDL_GLContext") "SDL_GL_GetCurrentContext"))
|
|
|
|
(define gl-get-current-window
|
|
(foreign-lambda (c-pointer (struct "SDL_Window")) "SDL_GL_GetCurrentWindow"))
|
|
|
|
(define gl-get-proc-address
|
|
(foreign-lambda c-pointer "SDL_GL_GetProcAddress" c-string))
|
|
|
|
;; TODO: SDL_GL_GetSwapInterval
|
|
|
|
(define gl-load-library
|
|
(foreign-lambda bool "SDL_GL_LoadLibrary" c-string))
|
|
|
|
(define gl-make-current
|
|
(foreign-lambda bool "SDL_GL_MakeCurrent"
|
|
(c-pointer (struct "SDL_Window")) (struct "SDL_GLContext")))
|
|
|
|
(define gl-reset-attributes
|
|
(foreign-lambda void "SDL_GL_ResetAttributes"))
|
|
|
|
(define gl-set-attribute
|
|
(foreign-lambda bool "SDL_GL_SetAttribute" (enum "SDL_GLattr") int))
|
|
|
|
(define gl-set-swap-interval
|
|
(foreign-lambda bool "SDL_GL_SetSwapInterval" int))
|
|
|
|
(define gl-swap-window
|
|
(foreign-lambda bool "SDL_GL_SwapWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define gl-unload-library
|
|
(foreign-lambda void "SDL_GL_UnloadLibrary"))
|
|
|
|
(define hide-window
|
|
(foreign-lambda bool "SDL_HideWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define maximize-window
|
|
(foreign-lambda bool "SDL_MaximizeWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define minimize-window
|
|
(foreign-lambda bool "SDL_MinimizeWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define raise-window
|
|
(foreign-lambda bool "SDL_RaiseWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define restore-window
|
|
(foreign-lambda bool "SDL_RestoreWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define screen-saver-enabled
|
|
(foreign-lambda bool "SDL_ScreenSaverEnabled"))
|
|
|
|
(define set-window-always-on-top
|
|
(foreign-lambda bool "SDL_SetWindowAlwaysOnTop" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-aspect-ratio
|
|
(foreign-lambda bool "SDL_SetWindowAspectRatio"
|
|
(c-pointer (struct "SDL_Window")) float float))
|
|
|
|
(define set-window-bordered
|
|
(foreign-lambda bool "SDL_SetWindowBordered" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-focusable
|
|
(foreign-lambda bool "SDL_SetWindowFocusable" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-fullscreen
|
|
(foreign-lambda bool "SDL_SetWindowFullscreen" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-fullscreen-mode
|
|
(foreign-lambda bool "SDL_SetWindowFullscreenMode"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_DisplayMode"))))
|
|
|
|
;; TODO: SDL_SetWindowHitTest
|
|
|
|
(define set-window-icon
|
|
(foreign-lambda bool "SDL_SetWindowIcon"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_Surface"))))
|
|
|
|
(define set-window-keyboard-grab
|
|
(foreign-lambda bool "SDL_SetWindowKeyboardGrab"
|
|
(c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-maximum-size
|
|
(foreign-lambda bool "SDL_SetWindowMaximumSize"
|
|
(c-pointer (struct "SDL_Window")) int int))
|
|
|
|
(define set-window-minimum-size
|
|
(foreign-lambda bool "SDL_SetWindowMinimumSize"
|
|
(c-pointer (struct "SDL_Window")) int int))
|
|
|
|
(define set-window-modal
|
|
(foreign-lambda bool "SDL_SetWindowModal" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-modal-for
|
|
(foreign-lambda bool "SDL_SetWindowModalFor"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define set-window-mouse-grab
|
|
(foreign-lambda bool "SDL_SetWindowMouseGrab"
|
|
(c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-mouse-rect
|
|
(foreign-lambda bool "SDL_SetWindowMouseRect"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_Rect"))))
|
|
|
|
(define set-window-opacity
|
|
(foreign-lambda bool "SDL_SetWindowOpacity"
|
|
(c-pointer (struct "SDL_Window")) float))
|
|
|
|
(define set-window-parent
|
|
(foreign-lambda bool "SDL_SetWindowParent"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_Window"))))
|
|
|
|
(define set-window-position
|
|
(foreign-lambda bool "SDL_SetWindowPosition"
|
|
(c-pointer (struct "SDL_Window")) int int))
|
|
|
|
(define set-window-resizable
|
|
(foreign-lambda bool "SDL_SetWindowResizable" (c-pointer (struct "SDL_Window")) bool))
|
|
|
|
(define set-window-shape
|
|
(foreign-lambda bool "SDL_SetWindowShape"
|
|
(c-pointer (struct "SDL_Window"))
|
|
(c-pointer (struct "SDL_Surface"))))
|
|
|
|
(define set-window-size
|
|
(foreign-lambda bool "SDL_SetWindowSize" (c-pointer (struct "SDL_Window")) int int))
|
|
|
|
(define set-window-surface-vsync
|
|
(foreign-lambda bool "SDL_SetWindowSurfaceVSync"
|
|
(c-pointer (struct "SDL_Window")) int))
|
|
|
|
(define set-window-title
|
|
(foreign-lambda bool "SDL_SetWindowTitle"
|
|
(c-pointer (struct "SDL_Window")) c-string))
|
|
|
|
(define show-window
|
|
(foreign-lambda bool "SDL_ShowWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define show-window-system-menu
|
|
(foreign-lambda bool "SDL_ShowWindowSystemMenu"
|
|
(c-pointer (struct "SDL_Window")) int int))
|
|
|
|
(define sync-window
|
|
(foreign-lambda bool "SDL_SyncWindow" (c-pointer (struct "SDL_Window"))))
|
|
|
|
(define update-window-surface
|
|
(foreign-lambda bool "SDL_UpdateWindowSurface" (c-pointer (struct "SDL_Window"))))
|
|
|
|
;; TODO: SDL_UpdateWindowSurfaceRects
|
|
|
|
(define window-has-surface
|
|
(foreign-lambda bool "SDL_WindowHasSurface" (c-pointer (struct "SDL_Window"))))
|