├── .github └── workflows │ ├── ci-linux.yml │ ├── ci-macos-fw.yml │ ├── ci-macos-hb.yml │ ├── ci-macos-mp.yml │ └── ci-windows.yaml ├── .gitignore ├── LICENCE ├── README.md ├── alire.toml ├── build └── gnat │ ├── gen │ └── src │ │ └── .keep │ ├── makefile │ ├── sdlada.gpr │ ├── sdlada_common.gpr │ ├── tests_image.gpr │ ├── tests_mixer.gpr │ ├── tools.gpr │ └── unit_tests.gpr ├── screenshots ├── stream2.png ├── surface.png └── ttf.png ├── src ├── android │ └── sdl-platform-get.adb ├── audio │ ├── sdl-audio-devices.adb │ ├── sdl-audio-devices.ads │ ├── sdl-audio-sample_formats.ads │ ├── sdl-audio.adb │ └── sdl-audio.ads ├── bsd │ └── sdl-platform-get.adb ├── events │ ├── sdl-events-controllers.ads │ ├── sdl-events-events.adb │ ├── sdl-events-events.ads │ ├── sdl-events-files.ads │ ├── sdl-events-joysticks-game_controllers.adb │ ├── sdl-events-joysticks-game_controllers.ads │ ├── sdl-events-joysticks.adb │ ├── sdl-events-joysticks.ads │ ├── sdl-events-keyboards.adb │ ├── sdl-events-mice.ads │ ├── sdl-events-touches.ads │ ├── sdl-events-windows.ads │ └── sdl-events.ads ├── inputs │ ├── sdl-inputs-joysticks-game_controllers-makers.adb │ ├── sdl-inputs-joysticks-game_controllers-makers.ads │ ├── sdl-inputs-joysticks-game_controllers.adb │ ├── sdl-inputs-joysticks-game_controllers.ads │ ├── sdl-inputs-joysticks-makers.adb │ ├── sdl-inputs-joysticks-makers.ads │ ├── sdl-inputs-joysticks.adb │ ├── sdl-inputs-joysticks.ads │ ├── sdl-inputs-keyboards.adb │ ├── sdl-inputs-keyboards.ads │ ├── sdl-inputs-mice-cursors.adb │ ├── sdl-inputs-mice-cursors.ads │ ├── sdl-inputs-mice.adb │ ├── sdl-inputs-mice.ads │ └── sdl-inputs.ads ├── ios │ └── sdl-platform-get.adb ├── link │ ├── macosx │ │ └── sdl_linker.ads │ └── nix │ │ └── sdl_linker.ads ├── linux │ └── sdl-platform-get.adb ├── macosx │ └── sdl-platform-get.adb ├── rwops │ ├── sdl-rwops-streams.adb │ ├── sdl-rwops-streams.ads │ ├── sdl-rwops.adb │ └── sdl-rwops.ads ├── sdl-c_pointers.ads ├── sdl-clipboard.adb ├── sdl-clipboard.ads ├── sdl-cpus.adb ├── sdl-cpus.ads ├── sdl-error.adb ├── sdl-error.ads ├── sdl-filesystems.adb ├── sdl-filesystems.ads ├── sdl-hints.adb ├── sdl-hints.ads ├── sdl-libraries.adb ├── sdl-libraries.ads ├── sdl-log.adb ├── sdl-log.ads ├── sdl-platform.adb ├── sdl-platform.ads ├── sdl-power.adb ├── sdl-power.ads ├── sdl-timers.adb ├── sdl-timers.ads ├── sdl-versions.adb ├── sdl-versions.ads ├── sdl.adb ├── sdl.ads ├── version.c ├── video │ ├── sdl-video-displays.adb │ ├── sdl-video-displays.ads │ ├── sdl-video-gl.adb │ ├── sdl-video-gl.ads │ ├── sdl-video-palettes.adb │ ├── sdl-video-palettes.ads │ ├── sdl-video-pixel_formats.adb │ ├── sdl-video-pixel_formats.ads │ ├── sdl-video-pixels.ads │ ├── sdl-video-rectangles.adb │ ├── sdl-video-rectangles.ads │ ├── sdl-video-renderers-makers.adb │ ├── sdl-video-renderers-makers.ads │ ├── sdl-video-renderers.adb │ ├── sdl-video-renderers.ads │ ├── sdl-video-surfaces-makers.adb │ ├── sdl-video-surfaces-makers.ads │ ├── sdl-video-surfaces.adb │ ├── sdl-video-surfaces.ads │ ├── sdl-video-textures-makers.adb │ ├── sdl-video-textures-makers.ads │ ├── sdl-video-textures.adb │ ├── sdl-video-textures.ads │ ├── sdl-video-vulkan.adb │ ├── sdl-video-vulkan.ads │ ├── sdl-video-windows-makers.adb │ ├── sdl-video-windows-makers.ads │ ├── sdl-video-windows-manager.adb │ ├── sdl-video-windows-manager.ads │ ├── sdl-video-windows.adb │ ├── sdl-video-windows.ads │ ├── sdl-video.adb │ └── sdl-video.ads └── windows │ └── sdl-platform-get.adb ├── test ├── alire.toml ├── src │ ├── colour.c │ ├── colour_test_cases.adb │ ├── colour_test_cases.ads │ ├── pixel_format_test_cases.adb │ ├── pixel_format_test_cases.ads │ ├── pixel_formats.c │ ├── sdl_suites.adb │ ├── sdl_suites.ads │ └── test.adb └── test.gpr └── tools ├── gen_keyboard.adb ├── scancodes.ads ├── utils.adb └── utils.ads /.github/workflows/ci-linux.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI Linux 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on linux 12 | 13 | runs-on: ubuntu-latest 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v4 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v3 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive settings --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --select gnat_native 27 | alr --non-interactive toolchain --select gprbuild 28 | - 29 | name: Build and run 30 | run: | 31 | alr --non-interactive build 32 | -------------------------------------------------------------------------------- /.github/workflows/ci-macos-fw.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI macOS (Frameworks) 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on macOS (Frameworks) 12 | 13 | runs-on: macos-12 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v4 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v3 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive settings --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --select gnat_native 27 | alr --non-interactive toolchain --select gprbuild 28 | - 29 | name: Disable Homebrew 30 | run: rm -f $(which brew) 31 | shell: bash 32 | - 33 | name: Install SDL2.framework to ~/Library/Frameworks 34 | uses: BrettDong/setup-sdl2-frameworks@main 35 | - 36 | name: Copy SDL2.framework to /Library/Frameworks 37 | run: sudo cp -pR ~/Library/Frameworks/SDL2.framework /Library/Frameworks 38 | shell: bash 39 | - 40 | name: Build and run 41 | run: | 42 | alr --non-interactive build 43 | -------------------------------------------------------------------------------- /.github/workflows/ci-macos-hb.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI macOS (Homebrew) 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on macOS (Homebrew) 12 | 13 | runs-on: macos-12 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v4 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v3 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive settings --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --select gnat_native 27 | alr --non-interactive toolchain --select gprbuild 28 | - 29 | name: Install SDL2 components 30 | run: | 31 | brew install sdl2 32 | brew install sdl2_image 33 | brew install sdl2_mixer 34 | brew install sdl2_ttf 35 | - 36 | name: Build and run 37 | run: | 38 | eval $(brew shellenv) 39 | export C_INCLUDE_PATH=$HOMEBREW_PREFIX/include 40 | export CPP_INCLUDE_PATH=$HOMEBREW_PREFIX/include 41 | export LIBRARY_PATH=$HOMEBREW_PREFIX/lib 42 | alr --non-interactive build 43 | -------------------------------------------------------------------------------- /.github/workflows/ci-macos-mp.yml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI macOS (Macports) 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on macOS (Macports) 12 | 13 | runs-on: macos-12 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v4 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v3 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive settings --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --select gnat_native 27 | alr --non-interactive toolchain --select gprbuild 28 | - 29 | name: Disable Homebrew 30 | run: rm -f $(which brew) 31 | shell: bash 32 | - 33 | name: Install MacPorts 34 | uses: melusina-org/setup-macports@v1 35 | - 36 | name: Build and run 37 | run: | 38 | alr --non-interactive build 39 | -------------------------------------------------------------------------------- /.github/workflows/ci-windows.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | name: CI Windows 4 | 5 | on: 6 | workflow_dispatch: 7 | pull_request: 8 | 9 | jobs: 10 | build: 11 | name: CI on windows 12 | 13 | runs-on: windows-latest 14 | 15 | steps: 16 | - 17 | name: Checkout 18 | uses: actions/checkout@v4 19 | - 20 | name: alire-project/setup-alire 21 | uses: alire-project/setup-alire@v3 22 | - 23 | name: Install toolchain 24 | run: | 25 | alr --non-interactive settings --global --set toolchain.assistant false 26 | alr --non-interactive toolchain --select gnat_native 27 | alr --non-interactive toolchain --select gprbuild 28 | - 29 | name: Build and run 30 | run: | 31 | alr --non-interactive build 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | design_briefs 3 | wiki 4 | *.bak 5 | *.sh 6 | *.patch 7 | .gitignore 8 | thirdparty 9 | build/ 10 | alire/ 11 | config/ 12 | -------------------------------------------------------------------------------- /LICENCE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013-2024, Luke A. Guest et al. 2 | 3 | This software is provided 'as-is', without any express or implied 4 | warranty. In no event will the authors be held liable for any damages 5 | arising from the use of this software. 6 | 7 | Permission is granted to anyone to use this software for any purpose, 8 | including commercial applications, and to alter it and redistribute it 9 | freely, subject to the following restrictions: 10 | 11 | 1. The origin of this software must not be misrepresented; you must not 12 | claim that you wrote the original software. If you use this software 13 | in a product, an acknowledgment in the product documentation would be 14 | appreciated but is not required. 15 | 16 | 2. Altered source versions must be plainly marked as such, and must not be 17 | misrepresented as being the original software. 18 | 19 | 3. This notice may not be removed or altered from any source 20 | distribution. 21 | -------------------------------------------------------------------------------- /alire.toml: -------------------------------------------------------------------------------- 1 | name = "sdlada" 2 | description = "Ada 2012 SDL 2.x bindings." 3 | version = "2.5.124" 4 | 5 | authors = ["Luke A. Guest"] 6 | maintainers = ["Luke A. Guest "] 7 | maintainers-logins = ["Lucretia"] 8 | licenses = "Zlib" 9 | website = "https://github.com/ada-game-framework" 10 | tags = ["gamedev", "games", "portable", "cross-platform"] 11 | 12 | # project-files = ["build/gnat/tools.gpr", "build/gnat/sdlada.gpr"] #, "build/gnat/"] 13 | project-files = ["build/gnat/sdlada.gpr"] #, "build/gnat/"] 14 | 15 | [gpr-externals] 16 | SDL_PLATFORM = ["linux", "bsd", "windows", "macosx", "macos_homebrew", "macos_ports", "ios", "android"] 17 | SDL_MODE = ["debug", "release"] 18 | 19 | # [gpr-set-externals] 20 | # BUILD_MODE = "release" 21 | 22 | [gpr-set-externals.'case(os)'] 23 | linux = { SDL_PLATFORM = "linux" } 24 | windows = { SDL_PLATFORM = "windows" } 25 | [gpr-set-externals.'case(os)'.macos.'case(distribution)'] 26 | homebrew = { SDL_PLATFORM = "macos_homebrew" } 27 | macports = { SDL_PLATFORM = "macos_ports" } 28 | '...' = { SDL_PLATFORM = "macosx" } 29 | 30 | [[actions]] 31 | type = "pre-build" 32 | command = ["make", "-C", "./build/gnat", "tools"] 33 | 34 | [[depends-on]] 35 | libsdl2 = "^2.0.0" 36 | make = "*" # Required for post-fetch actions 37 | 38 | [environment.'case(distribution)'.msys2.C_INCLUDE_PATH] 39 | # sdlada expects SDL2 headers to be in the C_INCLUDE_PATH but the option 40 | # used in the project file ("-I/usr/include/SDL2") doesn't work with msys2 41 | append = "${DISTRIB_ROOT}/mingw64/include/SDL2" 42 | -------------------------------------------------------------------------------- /build/gnat/gen/src/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ada-game-framework/sdlada/2709d3d8949c65d6b34ea8174fa4d6402e5a4cca/build/gnat/gen/src/.keep -------------------------------------------------------------------------------- /build/gnat/makefile: -------------------------------------------------------------------------------- 1 | DESTDIR ?= /opt 2 | 3 | GPRMAKE = gprbuild 4 | GPRINSTALL = gprinstall 5 | GPRCLEAN = gprclean 6 | INSTALL = install 7 | 8 | SDL_MODE ?= debug 9 | SDL_PLATFORM ?= linux 10 | 11 | SRC_DIR = ../.. 12 | 13 | SRCS = src/sdl.ads 14 | 15 | GEN_KB = gen/src/sdl-events-keyboards.ads 16 | 17 | ifeq (,$(filter $(SDL_PLATFORM), "linux" "windows" "bsd" "android")) 18 | SDL2_CONFIG = -cargs `sdl2-config --cflags` -largs `sdl2-config --libs` -lSDL2_ttf -lSDL2_image -lSDL2_mixer 19 | else ifeq ($(SDL_PLATFORM),macosx) 20 | SDL2_CONFIG = 21 | endif 22 | 23 | # With GNAT, all static libs end with .a 24 | LIB_NAME = lib/libadasdl.a 25 | 26 | .PHONY: sdlada.gpr test_maths_build.gpr test.gpr tools.gpr 27 | 28 | all: tools $(LIB_NAME) 29 | 30 | # TODO: Fix the compiler so we actually get shared libs! 31 | # 32 | 33 | ##################################################################################### 34 | # SDL library 35 | 36 | $(LIB_NAME): sdlada.gpr $(GEN_KB) 37 | $(GPRMAKE) -p -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) \ 38 | -Psdlada.gpr 39 | 40 | .PHONY: clean-lib 41 | 42 | clean-lib: 43 | $(GPRCLEAN) -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) \ 44 | -Psdlada.gpr 45 | 46 | 47 | ##################################################################################### 48 | # Tools 49 | 50 | tools: mk_dirs $(GEN_KB) 51 | 52 | .PHONY: gen/src 53 | 54 | mk_dirs: gen/src 55 | mkdir -p gen/src/ 56 | 57 | $(GEN_KB): gen/$(SDL_MODE)/tools/gen_keyboard 58 | ./gen/$(SDL_MODE)/tools/gen_keyboard > $@ 59 | 60 | gen/$(SDL_MODE)/tools/gen_keyboard: 61 | $(GPRMAKE) -p -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) \ 62 | -Ptools.gpr 63 | 64 | .PHONY: clean-kb clean-tools 65 | 66 | clean-kb: 67 | -rm $(GEN_KB) 68 | 69 | clean-tools: 70 | 71 | $(GPRCLEAN) -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) -Ptools.gpr 72 | 73 | ##################################################################################### 74 | # Unit tests 75 | 76 | unit_tests: $(LIB_NAME) build_unit_tests/unit_tests 77 | 78 | build_unit_tests/unit_tests: 79 | $(GPRMAKE) -p -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) \ 80 | -Punit_tests.gpr ${SDL2_CONFIG} 81 | 82 | .PHONY: clean-unit_tests 83 | 84 | clean-unit_tests: 85 | -$(GPRCLEAN) -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) -Punit_tests.gpr 86 | 87 | ##################################################################################### 88 | .PHONY: install 89 | 90 | install: all 91 | $(GPRINSTALL) --prefix=$(DESTDIR) --build-name=$(SDL_MODE) -p -f \ 92 | -XSDL_MODE=$(SDL_MODE) -XSDL_PLATFORM=$(SDL_PLATFORM) \ 93 | -Psdlada.gpr 94 | 95 | ##################################################################################### 96 | 97 | .PHONY: clean 98 | 99 | clean: clean-kb clean-tools clean-unit_tests clean-lib 100 | -------------------------------------------------------------------------------- /build/gnat/sdlada.gpr: -------------------------------------------------------------------------------- 1 | library project SDLAda is 2 | type Platform_Type is ("linux", "bsd", "windows", "macosx", "macos_homebrew", "macos_ports", "ios", "android"); 3 | type Mode_Type is ("debug", "release"); 4 | 5 | Platform : Platform_Type := external ("SDL_PLATFORM", "linux"); 6 | Mode : Mode_Type := external ("SDL_MODE", "debug"); 7 | 8 | Source_Platform := ""; 9 | 10 | case Platform is 11 | when "macos_homebrew" | "macos_ports" => 12 | Source_Platform := "../../src/macosx"; 13 | 14 | when others => 15 | Source_Platform := "../../src/" & Platform; 16 | end case; 17 | 18 | Source_Platform_Linker := ""; 19 | 20 | case Platform is 21 | when "macosx" => 22 | Source_Platform_Linker := "../../src/link/macosx"; 23 | 24 | when others => 25 | Source_Platform_Linker := "../../src/link/nix"; 26 | end case; 27 | 28 | for Languages use ("Ada", "C"); 29 | for Source_Dirs use ("../../src", 30 | "../../src/audio", 31 | "../../src/events", 32 | "../../src/inputs", 33 | "../../src/rwops", 34 | "../../src/video", 35 | "gen/src/", 36 | Source_Platform, 37 | Source_Platform_Linker); 38 | 39 | for Library_Name use "sdlada"; 40 | for Object_Dir use "gen/" & Mode & "/lib/.obj"; 41 | for Library_Dir use "gen/" & Mode & "/lib"; 42 | for Library_Kind use "static"; 43 | 44 | package Compiler is 45 | Common_Switches := ("-ffunction-sections", "-fdata-sections"); 46 | C_Switches := (); 47 | Ada_Switches := ("-gnat2022", "-gnata", "-gnato", "-gnatwa", "-gnatwaJ", "-gnaty", "-gnaty-s", "-gnatyO", 48 | "-gnatyM120", "-gnatyx"); 49 | 50 | case Mode is 51 | when "debug" => 52 | Common_Switches := Common_Switches & ("-O0", "-g", "-ggdb"); 53 | 54 | when "release" => 55 | Common_Switches := Common_Switches & ("-O2"); 56 | end case; 57 | 58 | -- All GCC releases up to & including 13.2 give errors when 59 | -- using SDK 15, because Apple have used a new macro 60 | -- unsupported by GCC. 61 | case Platform is 62 | when "macosx" | "macos_homebrew" | "macos_ports" => 63 | for Driver ("C") use "clang"; 64 | 65 | when others => 66 | null; 67 | end case; 68 | 69 | -- These flags require checking on all platforms as they're taken directly from sdl2-config. 70 | case Platform is 71 | when "linux" | "bsd" | "android" | "windows" => 72 | C_Switches := C_Switches & ("-I/usr/include/SDL2", "-D_REENTRANT"); 73 | 74 | when "macos_homebrew" => 75 | C_Switches := C_Switches & ("-DSDL_HOMEBREW", 76 | "-I" 77 | & external ("HOMEBREW_PREFIX") 78 | & "/include", 79 | "-D_REENTRANT"); 80 | 81 | when "macos_ports" => 82 | C_Switches := C_Switches & ("-DSDL_MACPORTS", 83 | "-I/opt/local/include", 84 | "-D_REENTRANT"); 85 | 86 | when "macosx" => 87 | C_Switches := C_Switches & ("-F/Library/Frameworks", 88 | "-D_THREAD_SAFE"); 89 | 90 | when others => 91 | null; 92 | end case; 93 | 94 | for Default_Switches ("C") use Common_Switches & C_Switches; 95 | for Default_Switches ("Ada") use Common_Switches & Ada_Switches; 96 | end Compiler; 97 | end SDLAda; 98 | -------------------------------------------------------------------------------- /build/gnat/sdlada_common.gpr: -------------------------------------------------------------------------------- 1 | project SDLAda_Common is 2 | 3 | type Platform_Type is ("linux", 4 | "bsd", 5 | "windows", 6 | "macosx", 7 | "ios", 8 | "android"); 9 | 10 | type Mode_Type is ("debug", 11 | "release"); 12 | 13 | Platform : Platform_Type := external ("SDL_PLATFORM", "linux"); 14 | Mode : Mode_Type := external ("SDL_MODE", "debug"); 15 | 16 | for Languages use ("Ada", "C"); 17 | for Source_Dirs use ("../../src", 18 | "../../src/" & Platform, 19 | "gen/src/"); 20 | 21 | for Object_Dir use "gen/" & Mode & "/lib/.obj"; 22 | for Library_Dir use "gen/" & Mode & "/lib"; 23 | 24 | package Compiler is 25 | Common_Switches := ("-ffunction-sections", "-fdata-sections"); 26 | C_Switches := (); 27 | Ada_Switches := ("-gnat2012", "-gnata", "-gnato", "-gnatE", 28 | "-gnaty", "-gnaty-s", "-gnatyO", "-gnatyM120", "-gnatyx"); 29 | 30 | case Mode is 31 | when "debug" => 32 | Common_Switches := Common_Switches & ("-O0", "-g", "-ggdb"); 33 | 34 | when "release" => 35 | Common_Switches := Common_Switches & ("-O2"); 36 | end case; 37 | 38 | -- These flags require checking on all platforms as they're taken directly from sdl2-config. 39 | case Platform is 40 | 41 | when "linux" | "bsd" | "android" | "windows" => 42 | C_Switches := C_Switches & ("-I/usr/include/SDL2", 43 | "-D_REENTRANT"); 44 | 45 | when "macosx" => 46 | null; 47 | 48 | when others => 49 | null; 50 | 51 | end case; 52 | 53 | for Default_Switches ("C") use Common_Switches & C_Switches; 54 | for Default_Switches ("Ada") use Common_Switches & Ada_Switches; 55 | 56 | end Compiler; 57 | 58 | end SDLAda_Common; 59 | -------------------------------------------------------------------------------- /build/gnat/tests_image.gpr: -------------------------------------------------------------------------------- 1 | with "sdlada.gpr"; 2 | with "sdlada_image.gpr"; 3 | 4 | project Tests_Image is 5 | for Source_Dirs use ("../../test"); 6 | for Object_Dir use "gen/" & SDLAda.Build & "." & SDLAda.Mode & "/lib/test/.obj"; 7 | for Exec_Dir use "gen/" & SDLAda.Build & "." & SDLAda.Mode & "/lib/test"; 8 | for Main use ("load_surface.adb"); 9 | 10 | package Compiler renames SDLAda.Compiler; 11 | 12 | -- package Builder is 13 | -- for Default_Switches ("Ada") use ("-gnat2012", "-gnata"); --, "-gnatG"); 14 | -- end Builder; 15 | end Tests_Image; 16 | -------------------------------------------------------------------------------- /build/gnat/tests_mixer.gpr: -------------------------------------------------------------------------------- 1 | with "sdlada_common.gpr"; 2 | with "sdlada_mixer.gpr"; 3 | 4 | project Tests_Mixer is 5 | 6 | for Source_Dirs use ("../../test/mixer/"); 7 | for Object_Dir use "gen/" & SDLAda_Common.Mode & "/test/mixer/.obj"; 8 | for Exec_Dir use "gen/" & SDLAda_Common.Mode & "/test/mixer/"; 9 | for Main use ("mix_inspection.adb", 10 | "play_channels.adb", 11 | "play_group.adb", 12 | "play_music.adb"); 13 | 14 | for Create_Missing_Dirs use "True"; 15 | 16 | Global_Switches := (); 17 | 18 | case SDLAda_Common.Platform is 19 | 20 | when "macosx" => 21 | Global_Switches := Global_Switches & ("-framework", "SDL2", 22 | "-framework", "SDL2_mixer"); 23 | when others => null; 24 | 25 | end case; 26 | 27 | package Builder is 28 | 29 | for Global_Compilation_Switches ("Ada") use Global_Switches; 30 | for Global_Compilation_Switches ("C") use Global_Switches; 31 | 32 | for Default_Switches ("Ada") use 33 | ("-g", 34 | "-gnateE", 35 | "-gnatf", 36 | "-gnatwa", 37 | "-gnatwj", 38 | "-gnatw.x", 39 | "-gnaty", 40 | "-gnatyM99" 41 | ); 42 | end Builder; 43 | 44 | package Linker is 45 | for Default_Switches ("Ada") use Global_Switches; 46 | for Default_Switches ("C") use Global_Switches; 47 | end Linker; 48 | 49 | end Tests_Mixer; 50 | -------------------------------------------------------------------------------- /build/gnat/tools.gpr: -------------------------------------------------------------------------------- 1 | project Tools is 2 | type Mode_Type is ("debug", "release"); 3 | 4 | Mode : Mode_Type := external ("SDL_MODE", "debug"); 5 | 6 | for Source_Dirs use ("../../tools"); 7 | for Object_Dir use "gen/" & Mode & "/tools/.obj"; 8 | for Exec_Dir use "gen/" & Mode & "/tools"; 9 | for Main use ("gen_keyboard.adb"); 10 | 11 | package Compiler is 12 | C_Switches := ("-ffunction-sections", "-fdata-sections"); 13 | Ada_Switches := ("-ffunction-sections", "-fdata-sections", 14 | "-gnat2022", "-gnata", "-gnato", "-gnatwa", "-gnatwaJ", 15 | "-gnaty", "-gnaty-s", "-gnatyO", "-gnatyM120", "-gnatyO"); 16 | 17 | case Mode is 18 | when "debug" => 19 | C_Switches := C_Switches & ("-O0", "-g"); 20 | Ada_Switches := Ada_Switches & ("-O0", "-g"); 21 | 22 | when "release" => 23 | C_Switches := C_Switches & ("-O2"); 24 | Ada_Switches := Ada_Switches & ("-O2"); 25 | end case; 26 | 27 | for Default_Switches ("C") use C_Switches; 28 | for Default_Switches ("Ada") use Ada_Switches; 29 | end Compiler; 30 | 31 | -- package Builder is 32 | -- for Default_Switches ("Ada") use ("-gnat2012", "-gnata"); --, "-gnatG"); 33 | -- end Builder; 34 | end Tools; 35 | -------------------------------------------------------------------------------- /build/gnat/unit_tests.gpr: -------------------------------------------------------------------------------- 1 | with "sdlada"; 2 | with "aunit"; 3 | 4 | project Unit_Tests is 5 | for Languages use ("Ada", "C"); 6 | for Source_Dirs use ("../../unit_tests"); 7 | for Object_Dir use "gen/" & SDLAda.Mode & "/unit_tests/.obj"; 8 | for Exec_Dir use "gen/" & SDLAda.Mode & "/unit_tests"; 9 | for Main use ("unit_tests.adb"); 10 | 11 | -- package Ide is 12 | -- for Gnat use "/home/laguest/opt/tinyada/bin/gnat"; 13 | -- for Gnatlist use "/home/laguest/opt/tinyada/bin/gnatls"; 14 | -- for Debugger_Command use ""; 15 | -- for Compiler_Command ("ada") use "/home/laguest/opt/tinyada/bin/gnatmake"; 16 | -- for Compiler_Command ("c") use "/home/laguest/opt/tinyada/bin/c++"; 17 | -- end Ide; 18 | 19 | package Compiler renames SDLAda.Compiler; 20 | end Unit_Tests; 21 | -------------------------------------------------------------------------------- /screenshots/stream2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ada-game-framework/sdlada/2709d3d8949c65d6b34ea8174fa4d6402e5a4cca/screenshots/stream2.png -------------------------------------------------------------------------------- /screenshots/surface.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ada-game-framework/sdlada/2709d3d8949c65d6b34ea8174fa4d6402e5a4cca/screenshots/surface.png -------------------------------------------------------------------------------- /screenshots/ttf.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ada-game-framework/sdlada/2709d3d8949c65d6b34ea8174fa4d6402e5a4cca/screenshots/ttf.png -------------------------------------------------------------------------------- /src/android/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Android implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return Android; 10 | end Get; 11 | -------------------------------------------------------------------------------- /src/audio/sdl-audio-sample_formats.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Audio.Frame_Formats 5 | -- 6 | -- Access to audio sample data. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with System; 9 | 10 | package SDL.Audio.Sample_Formats is 11 | type Sample_Bit_Size is mod 2 ** 8 with 12 | Convention => C; 13 | 14 | type Sample_Endianness is (Little_Endian, Big_Endian) with 15 | Convention => C; 16 | 17 | use type System.Bit_Order; 18 | 19 | System_Endianness : constant Sample_Endianness := 20 | (if System.Default_Bit_Order = System.High_Order_First 21 | then Big_Endian 22 | else Little_Endian); 23 | 24 | type Sample_Format is record 25 | Bit_Size : Sample_Bit_Size; 26 | Float : Boolean; 27 | Endianness : Sample_Endianness := Little_Endian; 28 | Signed : Boolean; 29 | end record with 30 | Convention => C, 31 | Size => 16; 32 | 33 | for Sample_Format use record 34 | Bit_Size at 0 range 0 .. 7; 35 | Float at 1 range 0 .. 0; 36 | Endianness at 1 range 4 .. 4; 37 | Signed at 1 range 7 .. 7; 38 | end record; 39 | 40 | -- 41 | -- Audio format flags 42 | -- 43 | -- Defaults to LSB byte order. 44 | -- 45 | 46 | -- Unsigned 8-bit samples 47 | Sample_Format_U8 : constant Sample_Format := 48 | (Bit_Size => 8, 49 | Float => False, 50 | Endianness => Little_Endian, 51 | Signed => False); 52 | 53 | -- Signed 8-bit samples 54 | Sample_Format_S8 : constant Sample_Format := 55 | (Bit_Size => 8, 56 | Float => False, 57 | Endianness => Little_Endian, 58 | Signed => True); 59 | 60 | -- Unsigned 16-bit samples 61 | Sample_Format_U16LSB : constant Sample_Format := 62 | (Bit_Size => 16, 63 | Float => False, 64 | Endianness => Little_Endian, 65 | Signed => False); 66 | 67 | -- Signed 16-bit samples 68 | Sample_Format_S16LSB : constant Sample_Format := 69 | (Bit_Size => 16, 70 | Float => False, 71 | Endianness => Little_Endian, 72 | Signed => True); 73 | 74 | -- As above, but big-endian byte order 75 | Sample_Format_U16MSB : constant Sample_Format := 76 | (Bit_Size => 16, 77 | Float => False, 78 | Endianness => Big_Endian, 79 | Signed => False); 80 | 81 | -- As above, but big-endian byte order 82 | Sample_Format_S16MSB : constant Sample_Format := 83 | (Bit_Size => 16, 84 | Float => False, 85 | Endianness => Big_Endian, 86 | Signed => True); 87 | 88 | Sample_Format_U16 : constant Sample_Format := Sample_Format_U16LSB; 89 | Sample_Format_S16 : constant Sample_Format := Sample_Format_S16LSB; 90 | 91 | -- 92 | -- int32 support 93 | -- 94 | 95 | -- 32-bit integer samples 96 | Sample_Format_S32LSB : constant Sample_Format := 97 | (Bit_Size => 32, 98 | Float => False, 99 | Endianness => Little_Endian, 100 | Signed => False); 101 | 102 | -- As above, but big-endian byte order 103 | Sample_Format_S32MSB : constant Sample_Format := 104 | (Bit_Size => 32, 105 | Float => False, 106 | Endianness => Big_Endian, 107 | Signed => True); 108 | 109 | Sample_Format_S32 : constant Sample_Format := Sample_Format_S32LSB; 110 | 111 | -- 112 | -- float32 support 113 | -- 114 | 115 | -- 32-bit floating point samples 116 | Sample_Format_F32LSB : constant Sample_Format := 117 | (Bit_Size => 32, 118 | Float => True, 119 | Endianness => Little_Endian, 120 | Signed => True); 121 | 122 | -- As above, but big-endian byte order 123 | Sample_Format_F32MSB : constant Sample_Format := 124 | (Bit_Size => 32, 125 | Float => True, 126 | Endianness => Big_Endian, 127 | Signed => True); 128 | 129 | -- 130 | -- Native audio byte ordering 131 | -- 132 | Sample_Format_U16SYS : constant Sample_Format := 133 | (Bit_Size => 16, 134 | Float => False, 135 | Endianness => System_Endianness, 136 | Signed => False); 137 | 138 | Sample_Format_S16SYS : constant Sample_Format := 139 | (Bit_Size => 16, 140 | Float => False, 141 | Endianness => System_Endianness, 142 | Signed => True); 143 | 144 | Sample_Format_U32SYS : constant Sample_Format := 145 | (Bit_Size => 32, 146 | Float => False, 147 | Endianness => System_Endianness, 148 | Signed => False); 149 | 150 | Sample_Format_S32SYS : constant Sample_Format := 151 | (Bit_Size => 32, 152 | Float => False, 153 | Endianness => System_Endianness, 154 | Signed => True); 155 | end SDL.Audio.Sample_Formats; 156 | -------------------------------------------------------------------------------- /src/audio/sdl-audio.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C.Strings; 5 | with SDL.Error; 6 | 7 | package body SDL.Audio is 8 | function Initialise (Name : in String := "") return Boolean is 9 | function SDL_Audio_Init (C_Name : in C.Strings.chars_ptr) return C.int with 10 | Import => True, 11 | Convention => C, 12 | External_Name => "SDL_AudioInit"; 13 | 14 | function SDL_Audio_Init (C_Name : in C.char_array) return C.int with 15 | Import => True, 16 | Convention => C, 17 | External_Name => "SDL_AudioInit"; 18 | begin 19 | return ((if Name /= "" 20 | then SDL_Audio_Init (C.To_C (Name)) 21 | else SDL_Audio_Init (C_Name => C.Strings.Null_Ptr)) = Success); 22 | end Initialise; 23 | 24 | 25 | function Total_Drivers return Positive is 26 | function SDL_Get_Num_Audio_Drivers return C.int with 27 | Import => True, 28 | Convention => C, 29 | External_Name => "SDL_GetNumAudioDrivers"; 30 | 31 | Num : constant C.int := SDL_Get_Num_Audio_Drivers; 32 | begin 33 | if Num < 0 then 34 | raise Audio_Error with SDL.Error.Get; 35 | end if; 36 | 37 | return Positive (Num); 38 | end Total_Drivers; 39 | 40 | 41 | function Driver_Name (Index : in Positive) return String is 42 | function SDL_Get_Audio_Driver (I : in C.int) return C.Strings.chars_ptr with 43 | Import => True, 44 | Convention => C, 45 | External_Name => "SDL_GetAudioDriver"; 46 | 47 | begin 48 | -- Index is zero based, so need to subtract 1 to correct it. 49 | return C.Strings.Value (SDL_Get_Audio_Driver (C.int (Index) - 1)); 50 | end Driver_Name; 51 | 52 | 53 | function Current_Driver_Name return String is 54 | function SDL_Get_Current_Audio_Driver return C.Strings.chars_ptr with 55 | Import => True, 56 | Convention => C, 57 | External_Name => "SDL_GetCurrentAudioDriver"; 58 | 59 | C_Str : constant C.Strings.chars_ptr := SDL_Get_Current_Audio_Driver; 60 | 61 | use type C.Strings.chars_ptr; 62 | begin 63 | if C_Str = C.Strings.Null_Ptr then 64 | raise Audio_Error with SDL.Error.Get; 65 | end if; 66 | 67 | return C.Strings.Value (C_Str); 68 | end Current_Driver_Name; 69 | end SDL.Audio; 70 | -------------------------------------------------------------------------------- /src/audio/sdl-audio.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Audio 5 | -- 6 | -- Common audio mixer and driver functionality. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces.C; 9 | 10 | package SDL.Audio is 11 | pragma Preelaborate; 12 | 13 | package C renames Interfaces.C; 14 | 15 | Audio_Error : exception; 16 | 17 | -- Audio drivers. 18 | -- TODO: SDL3 - Removes Initialise/Finalise 19 | function Initialise (Name : in String := "") return Boolean; 20 | 21 | procedure Finalise with 22 | Import => True, 23 | Convention => C, 24 | External_Name => "SDL_AudioQuit"; 25 | 26 | function Total_Drivers return Positive; 27 | 28 | function Driver_Name (Index : in Positive) return String; 29 | 30 | function Current_Driver_Name return String; 31 | end SDL.Audio; 32 | -------------------------------------------------------------------------------- /src/bsd/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- BSD implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return BSD; 10 | end Get; 11 | -------------------------------------------------------------------------------- /src/events/sdl-events-controllers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events.Controllers 5 | -- 6 | -- Game controller specific events. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with SDL.Events.Joysticks; 9 | 10 | package SDL.Events.Controllers is 11 | pragma Pure; 12 | 13 | -- Game controller events. 14 | Axis_Motion : constant Event_Types := 16#0000_0650#; 15 | Button_Down : constant Event_Types := Axis_Motion + 1; 16 | Button_Up : constant Event_Types := Axis_Motion + 2; 17 | Device_Added : constant Event_Types := Axis_Motion + 3; 18 | Device_Removed : constant Event_Types := Axis_Motion + 4; 19 | Device_Remapped : constant Event_Types := Axis_Motion + 5; 20 | 21 | type Axes is (Invalid, 22 | Left_X, 23 | Left_Y, 24 | Right_X, 25 | Right_Y, 26 | Left_Trigger, 27 | Right_Trigger) with 28 | Convention => C; 29 | 30 | for Axes use (Invalid => -1, 31 | Left_X => 0, 32 | Left_Y => 1, 33 | Right_X => 2, 34 | Right_Y => 3, 35 | Left_Trigger => 4, 36 | Right_Trigger => 5); 37 | 38 | type Axes_Values is range -32768 .. 32767 with 39 | Convention => C, 40 | Size => 16; 41 | 42 | type Axis_Events is 43 | record 44 | Event_Type : Event_Types; -- Will be set to Axis_Motion. 45 | Time_Stamp : Time_Stamps; 46 | 47 | Which : SDL.Events.Joysticks.IDs; 48 | Axis : Axes; 49 | Padding_1 : Padding_8; 50 | Padding_2 : Padding_8; 51 | Padding_3 : Padding_8; 52 | Value : Axes_Values; 53 | Padding_4 : Padding_16; 54 | end record with 55 | Convention => C; 56 | 57 | type Buttons is (Invalid, 58 | A, 59 | B, 60 | X, 61 | Y, 62 | Back, 63 | Guide, 64 | Start, 65 | Left_Stick, 66 | Right_Stick, 67 | Left_Shoulder, 68 | Right_Shoulder, 69 | Pad_Up, -- Direction pad buttons. 70 | Pad_Down, 71 | Pad_Left, 72 | Pad_Right) with 73 | Convention => C; 74 | 75 | for Buttons use (Invalid => -1, 76 | A => 0, 77 | B => 1, 78 | X => 2, 79 | Y => 3, 80 | Back => 4, 81 | Guide => 5, 82 | Start => 6, 83 | Left_Stick => 7, 84 | Right_Stick => 8, 85 | Left_Shoulder => 9, 86 | Right_Shoulder => 10, 87 | Pad_Up => 11, 88 | Pad_Down => 12, 89 | Pad_Left => 13, 90 | Pad_Right => 14); 91 | 92 | type Button_Events is 93 | record 94 | Event_Type : Event_Types; -- Will be set to Button_Down or Button_Up. 95 | Time_Stamp : Time_Stamps; 96 | 97 | Which : SDL.Events.Joysticks.IDs; 98 | Button : Buttons; 99 | State : Button_State; 100 | Padding_1 : Padding_8; 101 | Padding_2 : Padding_8; 102 | end record with 103 | Convention => C; 104 | 105 | type Device_Events is 106 | record 107 | Event_Type : Event_Types; -- Will be set to Device_Added, Device_Removed or Device_Remapped. 108 | Time_Stamp : Time_Stamps; 109 | 110 | Which : SDL.Events.Joysticks.IDs; 111 | end record with 112 | Convention => C; 113 | private 114 | for Axis_Events use 115 | record 116 | Event_Type at 0 * SDL.Word range 0 .. 31; 117 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 118 | 119 | Which at 2 * SDL.Word range 0 .. 31; 120 | Axis at 3 * SDL.Word range 0 .. 7; 121 | Padding_1 at 3 * SDL.Word range 8 .. 15; 122 | Padding_2 at 3 * SDL.Word range 16 .. 23; 123 | Padding_3 at 3 * SDL.Word range 24 .. 31; 124 | Value at 4 * SDL.Word range 0 .. 15; 125 | Padding_4 at 4 * SDL.Word range 16 .. 31; 126 | end record; 127 | 128 | for Button_Events use 129 | record 130 | Event_Type at 0 * SDL.Word range 0 .. 31; 131 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 132 | 133 | Which at 2 * SDL.Word range 0 .. 31; 134 | Button at 3 * SDL.Word range 0 .. 7; 135 | State at 3 * SDL.Word range 8 .. 15; 136 | Padding_1 at 3 * SDL.Word range 16 .. 23; 137 | Padding_2 at 3 * SDL.Word range 24 .. 31; 138 | end record; 139 | 140 | for Device_Events use 141 | record 142 | Event_Type at 0 * SDL.Word range 0 .. 31; 143 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 144 | 145 | Which at 2 * SDL.Word range 0 .. 31; 146 | end record; 147 | end SDL.Events.Controllers; 148 | -------------------------------------------------------------------------------- /src/events/sdl-events-events.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | with SDL.Error; 6 | 7 | package body SDL.Events.Events is 8 | 9 | function Poll (Event : out Events) return Boolean is 10 | function SDL_Poll_Event (Event : out Events) return Interfaces.C.int with 11 | Import => True, 12 | Convention => C, 13 | External_Name => "SDL_PollEvent"; 14 | begin 15 | return SDL_Poll_Event (Event) = 1; 16 | end Poll; 17 | 18 | procedure Wait (Event : out Events) is 19 | function SDL_Wait_Event (Event : out Events) return Interfaces.C.int with 20 | Import => True, 21 | Convention => C, 22 | External_Name => "SDL_WaitEvent"; 23 | begin 24 | if SDL_Wait_Event (Event) = 0 then 25 | raise Event_Error with SDL.Error.Get; 26 | end if; 27 | end Wait; 28 | end SDL.Events.Events; 29 | -------------------------------------------------------------------------------- /src/events/sdl-events-events.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events.Events 5 | -- 6 | -- Combines all of the various event types into a single variant record to match the union in the SDL library. Not 7 | -- the nicest of names for the package, but it works. 8 | -------------------------------------------------------------------------------------------------------------------- 9 | with SDL.Events.Windows; 10 | with SDL.Events.Keyboards; 11 | with SDL.Events.Mice; 12 | with SDL.Events.Joysticks; 13 | with SDL.Events.Controllers; 14 | with SDL.Events.Touches; 15 | with SDL.Events.Files; 16 | 17 | package SDL.Events.Events is 18 | pragma Preelaborate; 19 | 20 | type Event_Selector is (Is_Event, 21 | Is_Window_Event, 22 | Is_Keyboard_Event, 23 | Is_Text_Editing_Event, 24 | Is_Text_Input_Event, 25 | Is_Mouse_Motion_Event, 26 | Is_Mouse_Button_Event, 27 | Is_Mouse_Wheel_Event, 28 | Is_Joystick_Axis_Event, 29 | Is_Joystick_Ball_Event, 30 | Is_Joystick_Hat_Event, 31 | Is_Joystick_Button_Event, 32 | Is_Joystick_Device_Event, 33 | Is_Controller_Axis_Event, 34 | Is_Controller_Button_Event, 35 | Is_Controller_Device_Event, 36 | Is_Touch_Finger_Event, 37 | Is_Touch_Multi_Gesture_Event, 38 | Is_Touch_Dollar_Gesture, 39 | Is_Drop_Event); 40 | 41 | type Events (Event_Type : Event_Selector := Is_Event) is 42 | record 43 | case Event_Type is 44 | when Is_Window_Event => 45 | Window : SDL.Events.Windows.Window_Events; 46 | 47 | when Is_Keyboard_Event => 48 | Keyboard : SDL.Events.Keyboards.Keyboard_Events; 49 | 50 | when Is_Text_Editing_Event => 51 | Text_Editing : SDL.Events.Keyboards.Text_Editing_Events; 52 | 53 | when Is_Text_Input_Event => 54 | Text_Input : SDL.Events.Keyboards.Text_Input_Events; 55 | 56 | when Is_Mouse_Motion_Event => 57 | Mouse_Motion : SDL.Events.Mice.Motion_Events; 58 | 59 | when Is_Mouse_Button_Event => 60 | Mouse_Button : SDL.Events.Mice.Button_Events; 61 | 62 | when Is_Mouse_Wheel_Event => 63 | Mouse_Wheel : SDL.Events.Mice.Wheel_Events; 64 | 65 | when Is_Joystick_Axis_Event => 66 | Joystick_Axis : SDL.Events.Joysticks.Axis_Events; 67 | 68 | when Is_Joystick_Ball_Event => 69 | Joystick_Ball : SDL.Events.Joysticks.Ball_Events; 70 | 71 | when Is_Joystick_Hat_Event => 72 | Joystick_Hat : SDL.Events.Joysticks.Hat_Events; 73 | 74 | when Is_Joystick_Button_Event => 75 | Joystick_Button : SDL.Events.Joysticks.Button_Events; 76 | 77 | when Is_Joystick_Device_Event => 78 | Joystick_Device : SDL.Events.Joysticks.Device_Events; 79 | 80 | when Is_Controller_Axis_Event => 81 | Controller_Axis : SDL.Events.Controllers.Axis_Events; 82 | 83 | when Is_Controller_Button_Event => 84 | Controller_Button : SDL.Events.Controllers.Button_Events; 85 | 86 | when Is_Controller_Device_Event => 87 | Controller_Device : SDL.Events.Controllers.Device_Events; 88 | 89 | when Is_Touch_Finger_Event => 90 | Touch_Finger : SDL.Events.Touches.Finger_Events; 91 | 92 | when Is_Touch_Multi_Gesture_Event => 93 | Touch_Multi_Gesture : SDL.Events.Touches.Multi_Gesture_Events; 94 | 95 | when Is_Touch_Dollar_Gesture => 96 | Touch_Dollar_Gesture : SDL.Events.Touches.Dollar_Events; 97 | 98 | when Is_Drop_Event => 99 | Drop : SDL.Events.Files.Drop_Events; 100 | 101 | when others => 102 | Common : Common_Events; 103 | end case; 104 | end record with 105 | Unchecked_Union, 106 | Convention => C; 107 | 108 | -- Some error occurred while polling/waiting for events. 109 | Event_Error : exception; 110 | 111 | -- Poll for currently pending events. 112 | -- 113 | -- If the are any pending events, the next event is removed from the queue 114 | -- and stored in Event, and then this returns True. Otherwise, this does 115 | -- nothing and returns False. 116 | function Poll (Event : out Events) return Boolean with 117 | Inline => True; 118 | 119 | -- Wait until an event is pending. 120 | -- 121 | -- If there are any pending events, the next event is removed from 122 | -- the queue and stored in Event. 123 | procedure Wait (Event : out Events); 124 | 125 | end SDL.Events.Events; 126 | -------------------------------------------------------------------------------- /src/events/sdl-events-files.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events.Files 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with Interfaces.C.Strings; 7 | with System; 8 | 9 | package SDL.Events.Files is 10 | pragma Preelaborate; 11 | 12 | -- Drag and drop events. 13 | Drop_File : constant Event_Types := 16#0000_1000#; 14 | 15 | type Drop_Events is 16 | record 17 | Event_Type : Event_Types; -- Will be set to Drop_File. 18 | Time_Stamp : Time_Stamps; 19 | 20 | File_Name : Interfaces.C.Strings.chars_ptr; -- User *must* call Free on this. 21 | end record with 22 | Convention => C; 23 | private 24 | for Drop_Events use 25 | record 26 | Event_Type at 0 * SDL.Word range 0 .. 31; 27 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 28 | 29 | File_Name at 2 * SDL.Word range 0 .. System.Word_Size - 1; -- This will depend on platform. 30 | end record; 31 | end SDL.Events.Files; 32 | -------------------------------------------------------------------------------- /src/events/sdl-events-joysticks-game_controllers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | 5 | with Interfaces.C; 6 | with Interfaces; 7 | 8 | package body SDL.Events.Joysticks.Game_Controllers is 9 | package C renames Interfaces.C; 10 | 11 | Query : constant C.int := -1; 12 | Ignore : constant C.int := 0; 13 | Enable : constant C.int := 1; 14 | 15 | function SDL_Game_Controller_Event_State (State : in C.int) return C.int with 16 | Import => True, 17 | Convention => C, 18 | External_Name => "SDL_GameControllerEventState"; 19 | 20 | procedure SDL_Game_Controller_Event_State (State : in C.int) with 21 | Import => True, 22 | Convention => C, 23 | External_Name => "SDL_GameControllerEventState"; 24 | 25 | function Is_Polling_Enabled return Boolean is 26 | begin 27 | return SDL_Game_Controller_Event_State (Query) = Enable; 28 | end Is_Polling_Enabled; 29 | 30 | procedure Enable_Polling is 31 | begin 32 | SDL_Game_Controller_Event_State (Enable); 33 | end Enable_Polling; 34 | 35 | procedure Disable_Polling is 36 | begin 37 | SDL_Game_Controller_Event_State (Ignore); 38 | end Disable_Polling; 39 | end SDL.Events.Joysticks.Game_Controllers; 40 | -------------------------------------------------------------------------------- /src/events/sdl-events-joysticks-game_controllers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events.Joysticks.Game_Controllers 5 | -- 6 | -- Game controller specific events. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | 9 | package SDL.Events.Joysticks.Game_Controllers is 10 | pragma Pure; 11 | 12 | type Axes is (Invalid, 13 | Left_X, 14 | Left_Y, 15 | Right_X, 16 | Right_Y, 17 | Trigger_Left, 18 | Trigger_Right) with 19 | Convention => C; 20 | 21 | for Axes use (Invalid => -1, 22 | Left_X => 0, 23 | Left_Y => 1, 24 | Right_X => 2, 25 | Right_Y => 3, 26 | Trigger_Left => 4, 27 | Trigger_Right => 5); 28 | 29 | subtype LR_Axes is Axes range Left_X .. Right_Y; 30 | subtype Trigger_Axes is Axes range Trigger_Left .. Trigger_Right; 31 | 32 | type LR_Axes_Values is range -32768 .. 32767 with 33 | Convention => C, 34 | Size => 16; 35 | 36 | type Trigger_Axes_Values is range 0 .. 32767 with 37 | Convention => C, 38 | Size => 16; 39 | 40 | type Buttons is (Invalid, 41 | A, 42 | B, 43 | X, 44 | Y, 45 | Back, 46 | Guide, 47 | Start, 48 | Left_Stick, 49 | Right_Stick, 50 | Left_Shoulder, 51 | Right_Shoulder, 52 | D_Pad_Up, 53 | D_Pad_Down, 54 | D_Pad_Left, 55 | D_Pad_Right) with 56 | Convention => C; 57 | 58 | for Buttons use (Invalid => -1, 59 | A => 0, 60 | B => 1, 61 | X => 2, 62 | Y => 3, 63 | Back => 4, 64 | Guide => 5, 65 | Start => 6, 66 | Left_Stick => 7, 67 | Right_Stick => 8, 68 | Left_Shoulder => 9, 69 | Right_Shoulder => 10, 70 | D_Pad_Up => 11, 71 | D_Pad_Down => 12, 72 | D_Pad_Left => 13, 73 | D_Pad_Right => 14); 74 | 75 | -- Update the game controller event data. This is called by the event loop. 76 | procedure Update with 77 | Import => True, 78 | Convention => C, 79 | External_Name => "SDL_GameControllerUpdate"; 80 | 81 | function Is_Polling_Enabled return Boolean with 82 | Inline => True; 83 | 84 | procedure Enable_Polling with 85 | Inline => True; 86 | 87 | procedure Disable_Polling with 88 | Inline => True; 89 | end SDL.Events.Joysticks.Game_Controllers; 90 | -------------------------------------------------------------------------------- /src/events/sdl-events-joysticks.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | 6 | package body SDL.Events.Joysticks is 7 | package C renames Interfaces.C; 8 | 9 | Query : constant C.int := -1; 10 | Ignore : constant C.int := 0; 11 | Enable : constant C.int := 1; 12 | 13 | function SDL_Joystick_Event_State (State : in C.int) return C.int with 14 | Import => True, 15 | Convention => C, 16 | External_Name => "SDL_JoystickEventState"; 17 | 18 | procedure SDL_Joystick_Event_State (State : in C.int) with 19 | Import => True, 20 | Convention => C, 21 | External_Name => "SDL_JoystickEventState"; 22 | 23 | function Is_Polling_Enabled return Boolean is 24 | begin 25 | return SDL_Joystick_Event_State (Query) = Enable; 26 | end Is_Polling_Enabled; 27 | 28 | procedure Enable_Polling is 29 | begin 30 | SDL_Joystick_Event_State (Enable); 31 | end Enable_Polling; 32 | 33 | procedure Disable_Polling is 34 | begin 35 | SDL_Joystick_Event_State (Ignore); 36 | end Disable_Polling; 37 | end SDL.Events.Joysticks; 38 | -------------------------------------------------------------------------------- /src/events/sdl-events-keyboards.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C.Strings; 5 | 6 | package body SDL.Events.Keyboards is 7 | package C renames Interfaces.C; 8 | 9 | function Value (Name : in String) return SDL.Events.Keyboards.Scan_Codes is 10 | function SDL_Get_Scan_Code_From_Name (Name : in C.char_array) return SDL.Events.Keyboards.Scan_Codes with 11 | Import => True, 12 | Convention => C, 13 | External_Name => "SDL_GetScancodeFromName"; 14 | begin 15 | return SDL_Get_Scan_Code_From_Name (C.To_C (Name)); 16 | end Value; 17 | 18 | function Image (Scan_Code : in SDL.Events.Keyboards.Scan_Codes) return String is 19 | function SDL_Get_Scan_Code_Name (Scan_Code : in SDL.Events.Keyboards.Scan_Codes) return C.Strings.chars_ptr with 20 | Import => True, 21 | Convention => C, 22 | External_Name => "SDL_GetScancodeName"; 23 | begin 24 | return C.Strings.Value (SDL_Get_Scan_Code_Name (Scan_Code)); 25 | end Image; 26 | 27 | function Value (Name : in String) return SDL.Events.Keyboards.Key_Codes is 28 | function SDL_Get_Key_From_Name (Name : in C.char_array) return SDL.Events.Keyboards.Key_Codes with 29 | Import => True, 30 | Convention => C, 31 | External_Name => "SDL_GetKeyFromName"; 32 | begin 33 | return SDL_Get_Key_From_Name (C.To_C (Name)); 34 | end Value; 35 | 36 | function Image (Key_Code : in SDL.Events.Keyboards.Key_Codes) return String is 37 | function SDL_Get_Key_Name (Key_Code : in SDL.Events.Keyboards.Key_Codes) return C.Strings.chars_ptr with 38 | Import => True, 39 | Convention => C, 40 | External_Name => "SDL_GetKeyName"; 41 | begin 42 | return C.Strings.Value (SDL_Get_Key_Name (Key_Code)); 43 | end Image; 44 | 45 | function To_Key_Code (Scan_Code : in SDL.Events.Keyboards.Scan_Codes) return SDL.Events.Keyboards.Key_Codes is 46 | function SDL_Get_Key_From_Scan_Code (Scan_Code : in SDL.Events.Keyboards.Scan_Codes) 47 | return SDL.Events.Keyboards.Key_Codes with 48 | Import => True, 49 | Convention => C, 50 | External_Name => "SDL_GetKeyFromScancode"; 51 | begin 52 | return SDL_Get_Key_From_Scan_Code (Scan_Code); 53 | end To_Key_Code; 54 | 55 | function To_Scan_Code (Key_Code : in SDL.Events.Keyboards.Key_Codes) return SDL.Events.Keyboards.Scan_Codes is 56 | function SDL_Get_Scan_Code_From_Key (Key_Code : in SDL.Events.Keyboards.Key_Codes) 57 | return SDL.Events.Keyboards.Scan_Codes with 58 | Import => True, 59 | Convention => C, 60 | External_Name => "SDL_GetScancodeFromKey"; 61 | begin 62 | return SDL_Get_Scan_Code_From_Key (Key_Code); 63 | end To_Scan_Code; 64 | end SDL.Events.Keyboards; 65 | -------------------------------------------------------------------------------- /src/events/sdl-events-windows.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events.Windows 5 | -- 6 | -- Window specific events. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with SDL.Video.Windows; 9 | 10 | package SDL.Events.Windows is 11 | pragma Preelaborate; 12 | 13 | -- Window events. 14 | Window : constant Event_Types := 16#0000_0200#; 15 | System_Window_Manager : constant Event_Types := Window + 1; 16 | 17 | type Window_Event_ID is 18 | (None, 19 | Shown, 20 | Hidden, 21 | Exposed, 22 | Moved, 23 | Resized, 24 | Size_Changed, 25 | Minimised, 26 | Maximised, 27 | Restored, 28 | Enter, 29 | Leave, 30 | Focus_Gained, 31 | Focus_Lost, 32 | Close, 33 | Take_Focus, 34 | Hit_Test) with 35 | Convention => C; 36 | 37 | type Window_Events is 38 | record 39 | Event_Type : Event_Types; -- Will be set to Window. 40 | Time_Stamp : Time_Stamps; 41 | 42 | ID : SDL.Video.Windows.ID; 43 | Event_ID : Window_Event_ID; 44 | Padding_1 : Padding_8; 45 | Padding_2 : Padding_8; 46 | Padding_3 : Padding_8; 47 | Data_1 : Interfaces.Integer_32; 48 | Data_2 : Interfaces.Integer_32; 49 | end record with 50 | Convention => C; 51 | private 52 | for Window_Events use 53 | record 54 | Event_Type at 0 * SDL.Word range 0 .. 31; 55 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 56 | 57 | ID at 2 * SDL.Word range 0 .. 31; 58 | Event_ID at 3 * SDL.Word range 0 .. 7; 59 | Padding_1 at 3 * SDL.Word range 8 .. 15; 60 | Padding_2 at 3 * SDL.Word range 16 .. 23; 61 | Padding_3 at 3 * SDL.Word range 24 .. 31; 62 | Data_1 at 4 * SDL.Word range 0 .. 31; 63 | Data_2 at 5 * SDL.Word range 0 .. 31; 64 | end record; 65 | end SDL.Events.Windows; 66 | -------------------------------------------------------------------------------- /src/events/sdl-events.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Events 5 | -- 6 | -- Mapping to the underlying event handling system. 7 | -- 8 | -- WARNING!!!! 9 | -- I wanted to experiment with the event system and possibly hide all this and create an abstraction in another 10 | -- task so as to separate out the events from the main window. This could change. I really don't know yet. 11 | -------------------------------------------------------------------------------------------------------------------- 12 | package SDL.Events is 13 | pragma Pure; 14 | 15 | type Event_Types is mod 2 ** 32 with 16 | Convention => C; 17 | 18 | type Button_State is (Released, Pressed) with 19 | Convention => C; 20 | 21 | for Button_State use (Released => 0, Pressed => 1); 22 | 23 | ----------------------------------------------------------------------------------------------------------------- 24 | -- Event types. 25 | ----------------------------------------------------------------------------------------------------------------- 26 | 27 | -- Handled via 'First attribute. 28 | First_Event : constant Event_Types := 16#0000_0000#; 29 | 30 | -- Application events. 31 | Quit : constant Event_Types := 16#0000_0100#; 32 | 33 | -- Mobile events. 34 | App_Terminating : constant Event_Types := Quit + 1; 35 | App_Low_Memory : constant Event_Types := Quit + 2; 36 | App_Will_Enter_Background : constant Event_Types := Quit + 3; 37 | App_Did_Enter_Background : constant Event_Types := Quit + 4; 38 | App_Will_Enter_Foreground : constant Event_Types := Quit + 5; 39 | App_Did_Enter_Foreground : constant Event_Types := Quit + 6; 40 | 41 | -- Clipboard events. 42 | Clipboard_Update : constant Event_Types := 16#0000_0900#; 43 | 44 | -- TODO: Audio hot plug events for 2.0.4 45 | 46 | -- User events. 47 | User : constant Event_Types := 16#0000_8000#; 48 | 49 | Last_Event : constant Event_Types := 16#0000_FFFF#; 50 | 51 | type Padding_8 is mod 2 ** 8 with 52 | Convention => C, 53 | Size => 8; 54 | 55 | type Padding_16 is mod 2 ** 16 with 56 | Convention => C, 57 | Size => 16; 58 | 59 | type Time_Stamps is mod 2 ** 32 with 60 | Convention => C; 61 | 62 | type Common_Events is 63 | record 64 | Event_Type : Event_Types; 65 | Time_Stamp : Time_Stamps; 66 | end record with 67 | Convention => C; 68 | 69 | ----------------------------------------------------------------------------------------------------------------- 70 | -- TODO: Touch finger events 71 | ----------------------------------------------------------------------------------------------------------------- 72 | 73 | ----------------------------------------------------------------------------------------------------------------- 74 | -- TODO: Multi gesture events 75 | ----------------------------------------------------------------------------------------------------------------- 76 | 77 | ----------------------------------------------------------------------------------------------------------------- 78 | -- TODO: Dollar gesture events 79 | ----------------------------------------------------------------------------------------------------------------- 80 | 81 | ----------------------------------------------------------------------------------------------------------------- 82 | -- TODO: Drop events 83 | ----------------------------------------------------------------------------------------------------------------- 84 | 85 | ----------------------------------------------------------------------------------------------------------------- 86 | -- TODO: User events 87 | ----------------------------------------------------------------------------------------------------------------- 88 | 89 | ----------------------------------------------------------------------------------------------------------------- 90 | -- TODO: System window manager events 91 | ----------------------------------------------------------------------------------------------------------------- 92 | 93 | ----------------------------------------------------------------------------------------------------------------- 94 | -- TODO: Audio events - 2.0.4 95 | ----------------------------------------------------------------------------------------------------------------- 96 | 97 | private 98 | for Common_Events use 99 | record 100 | Event_Type at 0 * SDL.Word range 0 .. 31; 101 | Time_Stamp at 1 * SDL.Word range 0 .. 31; 102 | end record; 103 | 104 | -- for Text_Editing_Events use 105 | -- record 106 | -- Event_Type at 0 * SDL.Word range 0 .. 31; 107 | -- Time_Stamp at 1 * SDL.Word range 0 .. 31; 108 | -- 109 | -- ID at 2 * SDL.Word range 0 .. 31; 110 | -- State at 3 * SDL.Word range 0 .. 7; 111 | -- Repeat at 3 * SDL.Word range 8 .. 15; 112 | -- Padding_2 at 3 * SDL.Word range 16 .. 23; 113 | -- Padding_3 at 3 * SDL.Word range 24 .. 31; 114 | -- end record; 115 | end SDL.Events; 116 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks-game_controllers-makers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | private with SDL.C_Pointers; 6 | 7 | package body SDL.Inputs.Joysticks.Game_Controllers.Makers is 8 | package C renames Interfaces.C; 9 | 10 | function SDL_Game_Controller_Open (Device : in C.int) return SDL.C_Pointers.Game_Controller_Pointer with 11 | Import => True, 12 | Convention => C, 13 | External_Name => "SDL_GameControllerOpen"; 14 | 15 | function Create (Device : in Devices) return Game_Controller is 16 | begin 17 | return J : constant Game_Controller := (Ada.Finalization.Limited_Controlled with 18 | Internal => SDL_Game_Controller_Open (C.int (Device) - 1), Owns => True) 19 | do 20 | null; 21 | end return; 22 | end Create; 23 | 24 | procedure Create (Device : in Devices; Actual_Controller : out Game_Controller) is 25 | begin 26 | Actual_Controller.Internal := SDL_Game_Controller_Open (C.int (Device) - 1); 27 | end Create; 28 | end SDL.Inputs.Joysticks.Game_Controllers.Makers; 29 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks-game_controllers-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Joysticks.Game_Controllers.Makers 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package SDL.Inputs.Joysticks.Game_Controllers.Makers is 7 | pragma Preelaborate; 8 | 9 | function Create (Device : in Devices) return Game_Controller; 10 | procedure Create (Device : in Devices; Actual_Controller : out Game_Controller); 11 | end SDL.Inputs.Joysticks.Game_Controllers.Makers; 12 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks-game_controllers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Joysticks.Game_Controllers 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with SDL.Events.Joysticks.Game_Controllers; 7 | 8 | package SDL.Inputs.Joysticks.Game_Controllers is 9 | pragma Preelaborate; 10 | 11 | type Bind_Types is (None, Button, Axis, Hat) with 12 | Convention => C; 13 | 14 | type Hat_Bindings is 15 | record 16 | Hat : SDL.Events.Joysticks.Hats; 17 | Mask : SDL.Events.Joysticks.Hat_Positions; 18 | end record with 19 | Convention => C; 20 | 21 | type Binding_Values (Which : Bind_Types := None) is 22 | record 23 | case Which is 24 | when None => 25 | null; 26 | 27 | when Button => 28 | Button : SDL.Events.Joysticks.Game_Controllers.Buttons; 29 | 30 | when Axis => 31 | Axis : SDL.Events.Joysticks.Game_Controllers.Axes; 32 | 33 | when Hat => 34 | Hat : Hat_Bindings; 35 | end case; 36 | end record with 37 | Unchecked_Union; 38 | 39 | type Bindings is 40 | record 41 | Which : Bind_Types; 42 | Value : Binding_Values (None); 43 | end record with 44 | Convention => C; 45 | 46 | Mapping_Error : exception; 47 | 48 | type Game_Controller is new Ada.Finalization.Limited_Controlled with private; 49 | 50 | Null_Game_Controller : constant Game_Controller; 51 | 52 | subtype Uint16 is Interfaces.Unsigned_16; 53 | subtype Uint32 is Interfaces.Unsigned_32; 54 | 55 | procedure Add_Mapping (Data : in String; Updated_Existing : out Boolean); 56 | procedure Add_Mappings_From_File (Database_Filename : in String; Number_Added : out Natural); 57 | 58 | function Axis_Value (Self : in Game_Controller; 59 | Axis : in SDL.Events.Joysticks.Game_Controllers.LR_Axes) 60 | return SDL.Events.Joysticks.Game_Controllers.LR_Axes_Values; 61 | 62 | function Axis_Value (Self : in Game_Controller; 63 | Axis : in SDL.Events.Joysticks.Game_Controllers.Trigger_Axes) 64 | return SDL.Events.Joysticks.Game_Controllers.Trigger_Axes_Values; 65 | 66 | procedure Close (Self : in out Game_Controller); 67 | 68 | function Get_Axis (Axis : in String) return SDL.Events.Joysticks.Game_Controllers.Axes; 69 | 70 | function Get_Binding (Self : in Game_Controller; Axis : in SDL.Events.Joysticks.Game_Controllers.Axes) 71 | return Bindings; 72 | 73 | function Get_Binding (Self : in Game_Controller; Button : in SDL.Events.Joysticks.Game_Controllers.Buttons) 74 | return Bindings; 75 | 76 | function Get_Button (Button_Name : in String) return SDL.Events.Joysticks.Game_Controllers.Buttons; 77 | 78 | function Get_Joystick (Self : in Game_Controller) return Joystick; 79 | 80 | function Get_Mapping (Self : in Game_Controller) return String; 81 | function Get_Mapping (Controller : in GUIDs) return String; 82 | 83 | function Get_Name (Self : in Game_Controller) return String; 84 | function Get_Name (Device : in Devices) return String; 85 | 86 | function Image (Axis : in SDL.Events.Joysticks.Game_Controllers.Axes) return String; 87 | function Image (Button : in SDL.Events.Joysticks.Game_Controllers.Buttons) return String; 88 | 89 | function Is_Attached (Self : in Game_Controller) return Boolean with 90 | Inline => True; 91 | 92 | function Is_Button_Pressed (Self : in Game_Controller; Button : in SDL.Events.Joysticks.Buttons) 93 | return SDL.Events.Button_State with 94 | Inline => True; 95 | 96 | function Is_Game_Controller (Device : in Devices) return Boolean with 97 | Inline => True; 98 | 99 | function Has_Rumble (Self : in Game_Controller) return Boolean with 100 | Inline => True; 101 | 102 | function Rumble (Self : in Game_Controller; 103 | Low_Frequency : in Uint16; 104 | High_Frequency : in Uint16; 105 | Duration : in Uint32) return Integer with 106 | Inline => True; 107 | private 108 | type Game_Controller is new Ada.Finalization.Limited_Controlled with 109 | record 110 | Internal : SDL.C_Pointers.Game_Controller_Pointer := null; 111 | Owns : Boolean := True; 112 | end record; 113 | 114 | Null_Game_Controller : constant Game_Controller := (Ada.Finalization.Limited_Controlled with 115 | Internal => null, 116 | Owns => True); 117 | end SDL.Inputs.Joysticks.Game_Controllers; 118 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks-makers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Joysticks.Makers 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with Interfaces.C; 7 | private with SDL.C_Pointers; 8 | 9 | package body SDL.Inputs.Joysticks.Makers is 10 | package C renames Interfaces.C; 11 | 12 | function SDL_Joystick_Open (Device : in C.int) return SDL.C_Pointers.Joystick_Pointer with 13 | Import => True, 14 | Convention => C, 15 | External_Name => "SDL_JoystickOpen"; 16 | 17 | function Create (Device : in Devices) return Joystick is 18 | begin 19 | return J : constant Joystick := (Ada.Finalization.Limited_Controlled with 20 | Internal => SDL_Joystick_Open (C.int (Device) - 1), Owns => True) do 21 | null; 22 | end return; 23 | end Create; 24 | 25 | procedure Create (Device : in Devices; Actual_Stick : out Joystick) is 26 | begin 27 | Actual_Stick.Internal := SDL_Joystick_Open (C.int (Device) - 1); 28 | end Create; 29 | end SDL.Inputs.Joysticks.Makers; 30 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Joysticks.Makers 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package SDL.Inputs.Joysticks.Makers is 7 | pragma Preelaborate; 8 | 9 | function Create (Device : in Devices) return Joystick; 10 | procedure Create (Device : in Devices; Actual_Stick : out Joystick); 11 | end SDL.Inputs.Joysticks.Makers; 12 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-joysticks.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Joysticks 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with Ada.Finalization; 7 | private with SDL.C_Pointers; 8 | with SDL.Events.Joysticks; 9 | 10 | package SDL.Inputs.Joysticks is 11 | pragma Preelaborate; 12 | 13 | Joystick_Error : exception; 14 | 15 | -- Use to determine whether there are no joysticks. 16 | type All_Devices is range 0 .. 2 ** 31 - 1 with 17 | Convention => C, 18 | Size => 32; 19 | 20 | -- This range is the range of all connected joysticks. 21 | subtype Devices is All_Devices range All_Devices'First + 1 .. All_Devices'Last; 22 | 23 | -- SDL_Joystick_ID = instance ID. 24 | type Instances is range 0 .. 2 ** 31 - 1 with 25 | Convention => C, 26 | Size => 32; 27 | 28 | type GUID_Element is range 0 .. 255 with 29 | convention => C, 30 | Size => 8; 31 | 32 | type GUID_Array is array (1 .. 16) of aliased GUID_Element with 33 | Convention => C; 34 | -- Pack => True; 35 | 36 | type GUIDs is 37 | record 38 | Data : GUID_Array; 39 | end record with 40 | Convention => C; 41 | 42 | -- Device specific information. 43 | function Total return All_Devices; 44 | function Name (Device : in Devices) return String; 45 | function GUID (Device : in Devices) return GUIDs; 46 | 47 | -- GUID utilities. 48 | function Image (GUID : in GUIDs) return String; 49 | function Value (GUID : in String) return GUIDs; 50 | 51 | -- Joysticks. 52 | type Joystick is new Ada.Finalization.Limited_Controlled with private; 53 | 54 | Null_Joystick : constant Joystick; 55 | 56 | -- not overriding 57 | function "=" (Left, Right : in Joystick) return Boolean with 58 | Inline => True; 59 | 60 | procedure Close (Self : in out Joystick); 61 | 62 | -- Information. 63 | function Axes (Self : in Joystick) return SDL.Events.Joysticks.Axes; 64 | function Balls (Self : in Joystick) return SDL.Events.Joysticks.Balls; 65 | function Buttons (Self : in Joystick) return SDL.Events.Joysticks.Buttons; 66 | function Hats (Self : in Joystick) return SDL.Events.Joysticks.Hats; 67 | function Name (Self : in Joystick) return String; 68 | function Is_Haptic (Self : in Joystick) return Boolean; 69 | 70 | function Is_Attached (Self : in Joystick) return Boolean with 71 | Inline => True; 72 | 73 | function GUID (Self : in Joystick) return GUIDs with 74 | Inline => True; 75 | 76 | function Instance (Self : in Joystick) return Instances; 77 | 78 | -- Data. 79 | function Axis_Value (Self : in Joystick; 80 | Axis : in SDL.Events.Joysticks.Axes) return SDL.Events.Joysticks.Axes_Values; 81 | 82 | procedure Ball_Value (Self : in Joystick; 83 | Ball : in SDL.Events.Joysticks.Balls; 84 | Delta_X, Delta_Y : out SDL.Events.Joysticks.Ball_Values); 85 | 86 | function Hat_Value (Self : in Joystick; 87 | Hat : in SDL.Events.Joysticks.Hats) return SDL.Events.Joysticks.Hat_Positions; 88 | 89 | function Is_Button_Pressed (Self : in Joystick; Button : in SDL.Events.Joysticks.Buttons) 90 | return SDL.Events.Button_State; 91 | private 92 | type Joystick is new Ada.Finalization.Limited_Controlled with 93 | record 94 | Internal : SDL.C_Pointers.Joystick_Pointer := null; 95 | Owns : Boolean := True; 96 | end record; 97 | 98 | Null_Joystick : constant Joystick := (Ada.Finalization.Limited_Controlled with Internal => null, Owns => True); 99 | end SDL.Inputs.Joysticks; 100 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-keyboards.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | private with SDL.C_Pointers; 5 | 6 | package body SDL.Inputs.Keyboards is 7 | function Get_Focus return SDL.Video.Windows.ID is 8 | function SDL_Get_Window_ID (W : in SDL.C_Pointers.Windows_Pointer) return SDL.Video.Windows.ID with 9 | Import => True, 10 | Convention => C, 11 | External_Name => "SDL_GetWindowID"; 12 | 13 | function SDL_Get_Keyboard_Focus return SDL.C_Pointers.Windows_Pointer with 14 | Import => True, 15 | Convention => C, 16 | External_Name => "SDL_GetKeyboardFocus"; 17 | begin 18 | return SDL_Get_Window_ID (SDL_Get_Keyboard_Focus); 19 | end Get_Focus; 20 | 21 | 22 | function Get_State return Key_State_Access is 23 | function SDL_Get_Keyboard_State (Num_Keys : SDL.Events.Keyboards.Scan_Codes) return Key_State_Access with 24 | Import => True, 25 | Convention => C, 26 | External_Name => "SDL_GetKeyboardState"; 27 | begin 28 | return SDL_Get_Keyboard_State (0); 29 | end Get_State; 30 | 31 | 32 | function Supports_Screen_Keyboard return Boolean is 33 | function SDL_Has_Screen_Keyboard_Support return SDL_Bool with 34 | Import => True, 35 | Convention => C, 36 | External_Name => "SDL_HasScreenKeyboardSupport"; 37 | begin 38 | return To_Boolean (SDL_Has_Screen_Keyboard_Support); 39 | end Supports_Screen_Keyboard; 40 | 41 | 42 | function Is_Screen_Keyboard_Visible (Window : in SDL.Video.Windows.Window) return Boolean is 43 | function Get_Internal_Window (Self : in SDL.Video.Windows.Window) return SDL.C_Pointers.Windows_Pointer with 44 | Convention => Ada, 45 | Import => True; 46 | 47 | function SDL_Screen_Keyboard_Shown (Window : in SDL.C_Pointers.Windows_Pointer) return SDL_Bool with 48 | Import => True, 49 | Convention => C, 50 | External_Name => "SDL_IsScreenKeyboardShown"; 51 | begin 52 | return To_Boolean (SDL_Screen_Keyboard_Shown (Get_Internal_Window (Window))); 53 | end Is_Screen_Keyboard_Visible; 54 | 55 | 56 | function Is_Text_Input_Enabled return Boolean is 57 | function SDL_Is_Text_Input_Active return SDL_Bool with 58 | Import => True, 59 | Convention => C, 60 | External_Name => "SDL_IsTextInputActive"; 61 | begin 62 | return To_Boolean (SDL_Is_Text_Input_Active); 63 | end Is_Text_Input_Enabled; 64 | 65 | 66 | function Is_Text_Input_Shown return Boolean is 67 | function Is_Text_Input_Shown return SDL_Bool with 68 | Import => True, 69 | Convention => C, 70 | External_Name => "SDL_IsTextInputShown"; 71 | begin 72 | return To_Boolean (Is_Text_Input_Shown); 73 | end Is_Text_Input_Shown; 74 | end SDL.Inputs.Keyboards; 75 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-keyboards.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Keyboards 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with SDL.Events.Keyboards; 7 | with SDL.Video.Rectangles; 8 | with SDL.Video.Windows; 9 | 10 | package SDL.Inputs.Keyboards is 11 | pragma Preelaborate; 12 | 13 | procedure Clear_Composition with 14 | Import => True, 15 | Convention => C, 16 | External_Name => "SDL_ClearComposition"; 17 | 18 | function Get_Focus return SDL.Video.Windows.ID with 19 | Inline => True; 20 | 21 | type Key_State_Array is array (SDL.Events.Keyboards.Scan_Codes) of Boolean with 22 | Convention => C; 23 | 24 | type Key_State_Access is access constant Key_State_Array with 25 | Convention => C; 26 | 27 | function Get_State return Key_State_Access; 28 | 29 | function Get_Modifiers return SDL.Events.Keyboards.Key_Modifiers with 30 | Import => True, 31 | Convention => C, 32 | External_Name => "SDL_GetModState"; 33 | 34 | procedure Set_Modifiers (Modifiers : in SDL.Events.Keyboards.Key_Modifiers) with 35 | Import => True, 36 | Convention => C, 37 | External_Name => "SDL_SetModState"; 38 | 39 | -- Screen keyboard. 40 | function Supports_Screen_Keyboard return Boolean with 41 | Inline => True; 42 | 43 | function Is_Screen_Keyboard_Visible (Window : in SDL.Video.Windows.Window) return Boolean with 44 | Inline => True; 45 | 46 | -- Text input. 47 | function Is_Text_Input_Enabled return Boolean with 48 | Inline => True; 49 | 50 | function Is_Text_Input_Shown return Boolean with 51 | Inline => True; 52 | 53 | procedure Reset_Keyboard with 54 | Import => True, 55 | Convention => C, 56 | External_Name => "SDL_ResetKeyboard"; 57 | 58 | procedure Set_Text_Input_Rectangle (Rectangle : in SDL.Video.Rectangles.Rectangle) with 59 | Import => True, 60 | Convention => C, 61 | External_Name => "SDL_SetTextInputRect"; 62 | 63 | procedure Start_Text_Input with 64 | Import => True, 65 | Convention => C, 66 | External_Name => "SDL_StartTextInput"; 67 | 68 | procedure Stop_Text_Input with 69 | Import => True, 70 | Convention => C, 71 | External_Name => "SDL_StopTextInput"; 72 | end SDL.Inputs.Keyboards; 73 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-mice-cursors.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | 5 | package body SDL.Inputs.Mice.Cursors is 6 | use type SDL.C_Pointers.Cursor_Pointer; 7 | 8 | procedure Create_System_Cursor (Self : in out Cursor; Cursor_Name : System_Cursors) is 9 | function SDL_Create_System_Cursor (Cursor_Name : in System_Cursors) return SDL.C_Pointers.Cursor_Pointer with 10 | Import => True, 11 | Convention => C, 12 | External_Name => "SDL_CreateSystemCursor"; 13 | begin 14 | Self.Internal := SDL_Create_System_Cursor (Cursor_Name); 15 | Self.Owns := True; 16 | end Create_System_Cursor; 17 | 18 | procedure Get_Cursor (Self : in out Cursor) is 19 | function SDL_Get_Cursor return SDL.C_Pointers.Cursor_Pointer with 20 | Import => True, 21 | Convention => C, 22 | External_Name => "SDL_GetCursor"; 23 | begin 24 | Self.Internal := SDL_Get_Cursor; 25 | Self.Owns := False; 26 | end Get_Cursor; 27 | 28 | procedure Set_Cursor (Self : in Cursor) is 29 | procedure SDL_Set_Cursor (C : in SDL.C_Pointers.Cursor_Pointer) with 30 | Import => True, 31 | Convention => C, 32 | External_Name => "SDL_SetCursor"; 33 | begin 34 | SDL_Set_Cursor (Self.Internal); 35 | end Set_Cursor; 36 | 37 | overriding 38 | procedure Finalize (Self : in out Cursor) is 39 | procedure SDL_Free_Cursor (C : in SDL.C_Pointers.Cursor_Pointer) with 40 | Import => True, 41 | Convention => C, 42 | External_Name => "SDL_FreeCursor"; 43 | begin 44 | if Self.Internal /= null and then Self.Owns then 45 | SDL_Free_Cursor (Self.Internal); 46 | end if; 47 | end Finalize; 48 | end SDL.Inputs.Mice.Cursors; 49 | 50 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-mice-cursors.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Mice.Cursors 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with Ada.Finalization; 7 | private with SDL.C_Pointers; 8 | 9 | package SDL.Inputs.Mice.Cursors is 10 | pragma Preelaborate; 11 | 12 | -- Don't confuse this package with any type of Ada iterator, this is for visual mouse cursors. 13 | 14 | type Cursor is new Ada.Finalization.Limited_Controlled with private; 15 | 16 | overriding 17 | procedure Finalize (Self : in out Cursor); 18 | 19 | type System_Cursors is 20 | (Arrow, 21 | I_Beam, 22 | Wait, 23 | Cross_Hair, 24 | Wait_Arrow, 25 | Size_NWSE, 26 | Size_NESW, 27 | Size_WE, 28 | size_NS, 29 | Size_All, 30 | No, 31 | Hand) with 32 | Convention => C; 33 | 34 | -- SDL_CreateColorCursor 35 | -- SDL_CreateCursor 36 | 37 | procedure Create_System_Cursor (Self : in out Cursor; Cursor_Name : System_Cursors); 38 | 39 | procedure Get_Cursor (Self : in out Cursor); 40 | 41 | procedure Set_Cursor (Self : in Cursor); 42 | private 43 | type Cursor is new Ada.Finalization.Limited_Controlled with 44 | record 45 | Internal : SDL.C_Pointers.Cursor_Pointer := null; 46 | Owns : Boolean := True; 47 | end record; 48 | end SDL.Inputs.Mice.Cursors; 49 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs-mice.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs.Mice 5 | -------------------------------------------------------------------------------------------------------------------- 6 | 7 | with SDL.Events.Mice; 8 | with SDL.Video.Windows; 9 | 10 | package SDL.Inputs.Mice is 11 | pragma Preelaborate; 12 | 13 | Mice_Error : exception; 14 | 15 | type Cursor_Toggles is (Off, On); 16 | 17 | for Cursor_Toggles use (Off => 0, On => 1); 18 | 19 | type Supported is (Yes, No); 20 | 21 | function Capture (Enabled : in Boolean) return Supported with 22 | Inline; 23 | 24 | function Get_Global_State (X_Relative, Y_Relative : out SDL.Events.Mice.Movement_Values) return 25 | SDL.Events.Mice.Button_Masks; 26 | 27 | -- SDL_GetMouseFocus 28 | 29 | function Get_State (X_Relative, Y_Relative : out SDL.Events.Mice.Movement_Values) return 30 | SDL.Events.Mice.Button_Masks; 31 | 32 | function In_Relative_Mode return Boolean with 33 | Inline; 34 | 35 | function Get_Relative_State (X_Relative, Y_Relative : out SDL.Events.Mice.Movement_Values) return 36 | SDL.Events.Mice.Button_Masks; 37 | 38 | -- SDL_SetCursor 39 | 40 | procedure Set_Relative_Mode (Enable : in Boolean := True) with 41 | Inline; 42 | 43 | procedure Show_Cursor (Enable : in Boolean := True) with 44 | Inline; 45 | 46 | function Is_Cursor_Shown return Boolean; 47 | 48 | -- Move the mouse to (x, y) on the screen. 49 | -- If in relative mode, the co-ordinates can be negative. 50 | procedure Warp (To : in SDL.Coordinates); 51 | -- 52 | -- Move the mouse to (x, y) in the specified window. 53 | procedure Warp (Window : in SDL.Video.Windows.Window; To : in SDL.Coordinates); 54 | end SDL.Inputs.Mice; 55 | -------------------------------------------------------------------------------- /src/inputs/sdl-inputs.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Inputs 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package SDL.Inputs is 7 | pragma Pure; 8 | end SDL.Inputs; 9 | -------------------------------------------------------------------------------- /src/ios/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- iOS implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return iOS; 10 | end Get; 11 | -------------------------------------------------------------------------------- /src/link/macosx/sdl_linker.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL_Linker 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package SDL_Linker is 7 | pragma Pure; 8 | 9 | Options : constant String := "-Wl,-F/Library/Frameworks,-framework,SDL2"; 10 | end SDL_Linker; 11 | -------------------------------------------------------------------------------- /src/link/nix/sdl_linker.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL_Linker 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package SDL_Linker is 7 | pragma Pure; 8 | 9 | Options : constant String := "-lSDL2"; 10 | end SDL_Linker; 11 | -------------------------------------------------------------------------------- /src/linux/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Linux implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return Linux; 10 | end Get; 11 | -------------------------------------------------------------------------------- /src/macosx/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Mac OS X implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return Mac_OS_X; 10 | end Get; 11 | -------------------------------------------------------------------------------- /src/rwops/sdl-rwops-streams.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with SDL.Error; 5 | 6 | package body SDL.RWops.Streams is 7 | use type Interfaces.C.unsigned_long; 8 | 9 | function Open (Op : in RWops) return RWops_Stream is 10 | begin 11 | return (Ada.Streams.Root_Stream_Type with Context => Op); 12 | end Open; 13 | 14 | procedure Open (Op : in RWops; Stream : out RWops_Stream) is 15 | begin 16 | Stream.Context := Op; 17 | end Open; 18 | 19 | procedure Close (Stream : in RWops_Stream) is 20 | begin 21 | Close (Stream.Context); 22 | end Close; 23 | 24 | overriding 25 | procedure Read (Stream : in out RWops_Stream; 26 | Item : out Ada.Streams.Stream_Element_Array; 27 | Last : out Ada.Streams.Stream_Element_Offset) 28 | is 29 | Objects_Read : Interfaces.C.unsigned_long := 0; 30 | begin 31 | -- Re-implemented c-macro: 32 | -- #define SDL_RWread(ctx, ptr, size, n) (ctx)->read(ctx, ptr, size, n) 33 | 34 | -- Read : access function 35 | -- (context : RWops_Pointer; 36 | -- ptr : System.Address; 37 | -- size : Interfaces.C.unsigned_long; 38 | -- maxnum : Interfaces.C.unsigned_long) return Interfaces.C.unsigned_long; 39 | 40 | Objects_Read := Stream.Context.Read 41 | (Context => RWops_Pointer (Stream.Context), 42 | Ptr => Item'Address, 43 | Size => Item'Length, 44 | Max_Num => 1); 45 | 46 | if Objects_Read = 0 then 47 | raise RWops_Error with SDL.Error.Get; 48 | end if; 49 | 50 | Last := Item'Length; 51 | end Read; 52 | 53 | overriding 54 | procedure Write (Stream : in out RWops_Stream; Item : Ada.Streams.Stream_Element_Array) 55 | is 56 | Objects_Written : Interfaces.C.unsigned_long := 0; 57 | begin 58 | -- Re-implemented c-macro: 59 | -- #define SDL_RWwrite(ctx, ptr, size, n) (ctx)->write(ctx, ptr, size, n) 60 | 61 | -- Write : access function 62 | -- (Context : RWops_Pointer; 63 | -- Ptr : System.Address; 64 | -- Size : Interfaces.C.unsigned_long; 65 | -- Num : Interfaces.C.unsigned_long) return Interfaces.C.unsigned_long; 66 | 67 | Objects_Written := Stream.Context.Write 68 | (Context => RWops_Pointer (Stream.Context), 69 | Ptr => Item'Address, 70 | Size => Item'Length, 71 | Num => 1); 72 | 73 | if Objects_Written = 0 then 74 | raise RWops_Error with SDL.Error.Get; 75 | end if; 76 | end Write; 77 | end SDL.RWops.Streams; 78 | -------------------------------------------------------------------------------- /src/rwops/sdl-rwops-streams.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.RWops.Streams 5 | -- 6 | -- Ada stream interface to SDL's Read/Write operations. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Streams; 9 | 10 | package SDL.RWops.Streams is 11 | pragma Preelaborate; 12 | 13 | type RWops_Stream is new Ada.Streams.Root_Stream_Type with private; 14 | 15 | function Open (Op : in RWops) return RWops_Stream; 16 | procedure Open (Op : in RWops; Stream : out RWops_Stream); 17 | 18 | procedure Close (Stream : in RWops_Stream); 19 | 20 | overriding 21 | procedure Read (Stream : in out RWops_Stream; 22 | Item : out Ada.Streams.Stream_Element_Array; 23 | Last : out Ada.Streams.Stream_Element_Offset); 24 | 25 | overriding 26 | procedure Write (Stream : in out RWops_Stream; Item : Ada.Streams.Stream_Element_Array); 27 | private 28 | type RWops_Stream is new Ada.Streams.Root_Stream_Type with 29 | record 30 | Context : RWops; 31 | end record; 32 | end SDL.RWops.Streams; 33 | -------------------------------------------------------------------------------- /src/sdl-c_pointers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.C_Pointers 5 | -- 6 | -- This private package contains all the types representing the internal C pointers for various objects. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | -- private 9 | package SDL.C_Pointers is 10 | pragma Preelaborate; 11 | 12 | type Windows is null record; 13 | type Windows_Pointer is access all Windows with 14 | Convention => C; 15 | 16 | type Renderers is null record; 17 | type Renderer_Pointer is access all Renderers with 18 | Convention => C; 19 | 20 | type Textures is null record; 21 | type Texture_Pointer is access all Textures with 22 | Convention => C; 23 | 24 | type GL_Contexts is null record; 25 | type GL_Context_Pointer is access all GL_Contexts with 26 | Convention => C; 27 | 28 | type Joysticks is null record; 29 | type Joystick_Pointer is access all Joysticks with 30 | Convention => C; 31 | 32 | type Game_Controller is null record; 33 | type Game_Controller_Pointer is access all Game_Controller with 34 | Convention => C; 35 | 36 | type Cursors is null record; 37 | type Cursor_Pointer is access all Cursors with 38 | Convention => C; 39 | end SDL.C_Pointers; 40 | -------------------------------------------------------------------------------- /src/sdl-clipboard.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C.Strings; 5 | 6 | with SDL.Error; 7 | with SDL.Video.Windows; 8 | 9 | package body SDL.Clipboard is 10 | package C renames Interfaces.C; 11 | 12 | procedure Check_For_Window is 13 | Init_Value : constant SDL.Init_Flags := SDL.Was_Initialised and SDL.Enable_Screen; 14 | begin 15 | if Init_Value /= SDL.Enable_Screen then 16 | raise Clipboard_Error with "SDL screen subsystem has not been initialised."; 17 | end if; 18 | 19 | if SDL.Video.Windows.Exist = False then 20 | raise Clipboard_Error with "No windows have been created."; 21 | end if; 22 | end Check_For_Window; 23 | 24 | function Get return Ada.Strings.UTF_Encoding.UTF_8_String is 25 | function SDL_Get_Clipboard_Text return C.Strings.chars_ptr with 26 | Import => True, 27 | Convention => C, 28 | External_Name => "SDL_GetClipboardText"; 29 | begin 30 | Check_For_Window; 31 | 32 | return C.Strings.Value (SDL_Get_Clipboard_Text); 33 | end Get; 34 | 35 | function Is_Empty return Boolean is 36 | function SDL_Has_Clipboard_Text return SDL_Bool with 37 | Import => True, 38 | Convention => C, 39 | External_Name => "SDL_HasClipboardText"; 40 | begin 41 | Check_For_Window; 42 | 43 | return To_Boolean (SDL_Has_Clipboard_Text); 44 | end Is_Empty; 45 | 46 | procedure Set (Text : in Ada.Strings.UTF_Encoding.UTF_8_String) is 47 | function SDL_Set_Clipboard_Text (C_Str : in C.char_array) return C.int with 48 | Import => True, 49 | Convention => C, 50 | External_Name => "SDL_SetClipboardText"; 51 | begin 52 | Check_For_Window; 53 | 54 | if SDL_Set_Clipboard_Text (C.To_C (Text)) /= Success then 55 | raise Clipboard_Error with SDL.Error.Get; 56 | end if; 57 | end Set; 58 | end SDL.Clipboard; 59 | -------------------------------------------------------------------------------- /src/sdl-clipboard.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Clipboard 5 | -- 6 | -- Functions to access the clipboard. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Strings.UTF_Encoding; 9 | 10 | package SDL.Clipboard is 11 | pragma Preelaborate; 12 | 13 | Clipboard_Error : exception; 14 | 15 | function Get return Ada.Strings.UTF_Encoding.UTF_8_String; 16 | function Is_Empty return Boolean; 17 | procedure Set (Text : in Ada.Strings.UTF_Encoding.UTF_8_String); 18 | end SDL.Clipboard; 19 | -------------------------------------------------------------------------------- /src/sdl-cpus.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | 6 | package body SDL.CPUS is 7 | package C renames Interfaces.C; 8 | 9 | function Count return Positive is 10 | function SDL_Get_CPU_Count return C.int with 11 | Import => True, 12 | Convention => C, 13 | External_Name => "SDL_GetCPUCount"; 14 | begin 15 | return Positive (SDL_Get_CPU_Count); 16 | end Count; 17 | 18 | function Cache_Line_Size return Positive is 19 | function SDL_Cache_Line_Size return C.int with 20 | Import => True, 21 | Convention => C, 22 | External_Name => "SDL_GetCPUCacheLineSize"; 23 | begin 24 | return Positive (SDL_Cache_Line_Size); 25 | end Cache_Line_Size; 26 | 27 | function Has_3DNow return Boolean is 28 | function SDL_Has_3DNow return C.int with 29 | Import => True, 30 | Convention => C, 31 | External_Name => "SDL_Has3DNow"; 32 | begin 33 | return (if SDL_Has_3DNow = 1 then True else False); 34 | end Has_3DNow; 35 | 36 | function Has_AltiVec return Boolean is 37 | function SDL_Has_AltiVec return C.int with 38 | Import => True, 39 | Convention => C, 40 | External_Name => "SDL_HasAltiVec"; 41 | begin 42 | return (if SDL_Has_AltiVec = 1 then True else False); 43 | end Has_AltiVec; 44 | 45 | function Has_MMX return Boolean is 46 | function SDL_Has_MMX return C.int with 47 | Import => True, 48 | Convention => C, 49 | External_Name => "SDL_HasMMX"; 50 | begin 51 | return (if SDL_Has_MMX = 1 then True else False); 52 | end Has_MMX; 53 | 54 | function Has_RDTSC return Boolean is 55 | function SDL_Has_RDTSC return C.int with 56 | Import => True, 57 | Convention => C, 58 | External_Name => "SDL_HasRDTSC"; 59 | begin 60 | return (if SDL_Has_RDTSC = 1 then True else False); 61 | end Has_RDTSC; 62 | 63 | function Has_SSE return Boolean is 64 | function SDL_Has_SSE return C.int with 65 | Import => True, 66 | Convention => C, 67 | External_Name => "SDL_HasSSE"; 68 | begin 69 | return (if SDL_Has_SSE = 1 then True else False); 70 | end Has_SSE; 71 | 72 | function Has_SSE_2 return Boolean is 73 | function SDL_Has_SSE_2 return C.int with 74 | Import => True, 75 | Convention => C, 76 | External_Name => "SDL_HasSSE2"; 77 | begin 78 | return (if SDL_Has_SSE_2 = 1 then True else False); 79 | end Has_SSE_2; 80 | 81 | function Has_SSE_3 return Boolean is 82 | function SDL_Has_SSE_3 return C.int with 83 | Import => True, 84 | Convention => C, 85 | External_Name => "SDL_HasSSE3"; 86 | begin 87 | return (if SDL_Has_SSE_3 = 1 then True else False); 88 | end Has_SSE_3; 89 | 90 | function Has_SSE_4_1 return Boolean is 91 | function SDL_Has_SSE_4_1 return C.int with 92 | Import => True, 93 | Convention => C, 94 | External_Name => "SDL_HasSSE41"; 95 | begin 96 | return (if SDL_Has_SSE_4_1 = 1 then True else False); 97 | end Has_SSE_4_1; 98 | 99 | function Has_SSE_4_2 return Boolean is 100 | function SDL_Has_SSE_4_2 return C.int with 101 | Import => True, 102 | Convention => C, 103 | External_Name => "SDL_HasSSE42"; 104 | begin 105 | return (if SDL_Has_SSE_4_2 = 1 then True else False); 106 | end Has_SSE_4_2; 107 | end SDL.CPUS; 108 | -------------------------------------------------------------------------------- /src/sdl-cpus.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.CPUS 5 | -- 6 | -- Platform CPU information retrieval. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.CPUS is 9 | pragma Pure; 10 | 11 | -- TODO: Add a subprogram to return CPU architecture as not all platforms will have the same one, i.e. 12 | -- Android on ARM, MIPS, x86. 13 | 14 | function Count return Positive; 15 | 16 | function Cache_Line_Size return Positive with 17 | Inline => True; 18 | 19 | function Has_3DNow return Boolean with 20 | Inline => True; 21 | 22 | function Has_AltiVec return Boolean with 23 | Inline => True; 24 | 25 | function Has_MMX return Boolean with 26 | Inline => True; 27 | 28 | function Has_RDTSC return Boolean with 29 | Inline => True; 30 | 31 | function Has_SSE return Boolean with 32 | Inline => True; 33 | 34 | function Has_SSE_2 return Boolean with 35 | Inline => True; 36 | 37 | function Has_SSE_3 return Boolean with 38 | Inline => True; 39 | 40 | function Has_SSE_4_1 return Boolean with 41 | Inline => True; 42 | 43 | function Has_SSE_4_2 return Boolean with 44 | Inline => True; 45 | end SDL.CPUS; 46 | -------------------------------------------------------------------------------- /src/sdl-error.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | with Interfaces.C.Strings; 6 | 7 | package body SDL.Error is 8 | package C renames Interfaces.C; 9 | 10 | procedure Set (S : in String) is 11 | procedure SDL_Set_Error (Fmt_Str, C_Str : in C.char_array) with 12 | Import => True, 13 | Convention => C_Variadic_1, 14 | External_Name => "SDL_SetError"; 15 | begin 16 | SDL_Set_Error (C.To_C ("%s"), C.To_C (S)); 17 | end Set; 18 | 19 | 20 | function Get return String is 21 | function SDL_Get_Error return C.Strings.chars_ptr with 22 | Import => True, 23 | Convention => C, 24 | External_Name => "SDL_GetError"; 25 | begin 26 | return C.Strings.Value (SDL_Get_Error); 27 | end Get; 28 | 29 | 30 | procedure Get (Buffer : in out String) is 31 | function SDL_Get_Error_Msg (C_Str : in C.char_array; Max_Length : in C.int) return C.Strings.chars_ptr with 32 | Import => True, 33 | Convention => C, 34 | External_Name => "SDL_GetErrorMsg"; 35 | 36 | Buffer_Ptr : constant C.Strings.chars_ptr := SDL_Get_Error_Msg (C.To_C (Buffer), Buffer'Length); 37 | begin 38 | Buffer := C.Strings.Value (Buffer_Ptr); -- Warning! 2 Copies here. 39 | end Get; 40 | end SDL.Error; 41 | -------------------------------------------------------------------------------- /src/sdl-error.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Error 5 | -- 6 | -- Error message handling. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.Error is 9 | pragma Preelaborate; 10 | 11 | procedure Clear with 12 | Import => True, 13 | Convention => C, 14 | External_Name => "SDL_ClearError"; 15 | 16 | procedure Set (S : in String) with 17 | Inline; 18 | 19 | function Get return String with 20 | Inline; 21 | 22 | -- Warning! This function does 3 copies of the string. 23 | procedure Get (Buffer : in out String) with 24 | Inline; 25 | end SDL.Error; 26 | -------------------------------------------------------------------------------- /src/sdl-filesystems.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C.Strings; 5 | with SDL.Error; 6 | package body SDL.Filesystems is 7 | package C renames Interfaces.C; 8 | 9 | procedure SDL_Free (Mem : in C.Strings.chars_ptr) with 10 | Import => True, 11 | Convention => C, 12 | External_Name => "SDL_free"; 13 | 14 | 15 | function Base_Path return UTF_Strings.UTF_String is 16 | function SDL_Get_Base_Path return C.Strings.chars_ptr with 17 | Import => True, 18 | Convention => C, 19 | External_Name => "SDL_GetBasePath"; 20 | 21 | C_Path : constant C.Strings.chars_ptr := SDL_Get_Base_Path; 22 | 23 | use type C.Strings.chars_ptr; 24 | begin 25 | if C_Path = C.Strings.Null_Ptr then 26 | raise Filesystems_Error with SDL.Error.Get; 27 | end if; 28 | 29 | declare 30 | Ada_Path : constant UTF_Strings.UTF_String := C.Strings.Value (C_Path); 31 | begin 32 | SDL_Free (C_Path); 33 | 34 | return Ada_Path; 35 | end; 36 | end Base_Path; 37 | 38 | 39 | function Preferences_Path (Organisation : in UTF_Strings.UTF_String; 40 | Application : in UTF_Strings.UTF_String) return UTF_Strings.UTF_String 41 | is 42 | function SDL_Get_Pref_Path (Organisation : in C.char_array; 43 | Application : in C.char_array) return C.Strings.chars_ptr with 44 | Import => True, 45 | Convention => C, 46 | External_Name => "SDL_GetPrefPath"; 47 | 48 | C_Path : C.Strings.chars_ptr; 49 | 50 | use type C.Strings.chars_ptr; 51 | begin 52 | C_Path := SDL_Get_Pref_Path (Organisation => C.To_C (Organisation), 53 | Application => C.To_C (Application)); 54 | 55 | if C_Path = C.Strings.Null_Ptr then 56 | raise Filesystems_Error with SDL.Error.Get; 57 | end if; 58 | 59 | declare 60 | Ada_Path : constant UTF_Strings.UTF_String := C.Strings.Value (C_Path); 61 | begin 62 | SDL_Free (C_Path); 63 | 64 | return Ada_Path; 65 | end; 66 | end Preferences_Path; 67 | end SDL.Filesystems; 68 | -------------------------------------------------------------------------------- /src/sdl-filesystems.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.RWops 5 | -- 6 | -- Read/Write operations, i.e. file related machinery. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Strings.UTF_Encoding; 9 | 10 | package SDL.Filesystems is 11 | package UTF_Strings renames Ada.Strings.UTF_Encoding; 12 | 13 | Filesystems_Error : exception; 14 | 15 | function Base_Path return UTF_Strings.UTF_String; 16 | 17 | function Preferences_Path (Organisation : in UTF_Strings.UTF_String; 18 | Application : in UTF_Strings.UTF_String) return UTF_Strings.UTF_String; 19 | end SDL.Filesystems; 20 | -------------------------------------------------------------------------------- /src/sdl-libraries.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Ada.Unchecked_Conversion; 5 | -- with Interfaces.C.Strings; 6 | with SDL.Error; 7 | with System; 8 | 9 | package body SDL.Libraries is 10 | package C renames Interfaces.C; 11 | 12 | procedure Load (Self : out Handles; Name : in String) is 13 | function SDL_Load_Object (C_Str : in C.char_array) return Internal_Handle_Access with 14 | Import => True, 15 | Convention => C, 16 | External_Name => "SDL_LoadObject"; 17 | begin 18 | Self.Internal := SDL_Load_Object (C.To_C (Name)); 19 | 20 | if Self.Internal = null then 21 | raise Library_Error with SDL.Error.Get; 22 | end if; 23 | end Load; 24 | 25 | procedure Unload (Self : in out Handles) is 26 | procedure SDL_Unload_Object (H : in Internal_Handle_Access) with 27 | Import => True, 28 | Convention => C, 29 | External_Name => "SDL_UnloadObject"; 30 | begin 31 | SDL_Unload_Object (Self.Internal); 32 | 33 | Self.Internal := null; 34 | end Unload; 35 | 36 | function Load_Sub_Program (From_Library : in Handles) return Access_To_Sub_Program is 37 | -- TODO: How can I get rid of this Address use? 38 | function To_Sub_Program is new Ada.Unchecked_Conversion 39 | (Source => System.Address, Target => Access_To_Sub_Program); 40 | 41 | function SDL_Load_Function (H : in Internal_Handle_Access; N : in C.char_array) 42 | return System.Address with 43 | Import => True, 44 | Convention => C, 45 | External_Name => "SDL_LoadFunction"; 46 | 47 | Func_Ptr : constant System.Address := SDL_Load_Function (From_Library.Internal, C.To_C (Name)); 48 | 49 | use type System.Address; 50 | begin 51 | if Func_Ptr = System.Null_Address then 52 | raise Library_Error with SDL.Error.Get; 53 | end if; 54 | 55 | return To_Sub_Program (Func_Ptr); 56 | end Load_Sub_Program; 57 | 58 | overriding 59 | procedure Finalize (Self : in out Handles) is 60 | begin 61 | -- In case the user has already called Unload or Finalize on a derived type. 62 | if Self.Internal /= null then 63 | Unload (Self); 64 | end if; 65 | end Finalize; 66 | end SDL.Libraries; 67 | -------------------------------------------------------------------------------- /src/sdl-libraries.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Libraries 5 | -- 6 | -- Mechanism for accessing shared objects (libraries). 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Finalization; 9 | 10 | package SDL.Libraries is 11 | pragma Preelaborate; 12 | 13 | Library_Error : exception; 14 | 15 | type Handles is new Ada.Finalization.Limited_Controlled with private; 16 | 17 | Null_Handle : constant Handles; 18 | 19 | procedure Load (Self : out Handles; Name : in String); 20 | procedure Unload (Self : in out Handles); -- with 21 | -- Static_Predicate => Handle /= Null_Handle; 22 | 23 | generic 24 | type Access_To_Sub_Program is private; 25 | 26 | Name : String; 27 | function Load_Sub_Program (From_Library : in Handles) return Access_To_Sub_Program; 28 | private 29 | type Internal_Handle is null record with 30 | Convention => C; 31 | 32 | type Internal_Handle_Access is access all Internal_Handle with 33 | Convention => C; 34 | 35 | type Handles is new Ada.Finalization.Limited_Controlled with 36 | record 37 | Internal : Internal_Handle_Access; 38 | end record; 39 | 40 | overriding 41 | procedure Finalize (Self : in out Handles); 42 | 43 | Null_Handle : constant Handles := (Ada.Finalization.Limited_Controlled with Internal => null); 44 | end SDL.Libraries; 45 | -------------------------------------------------------------------------------- /src/sdl-log.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | with Interfaces.C.Strings; 6 | 7 | package body SDL.Log is 8 | package C renames Interfaces.C; 9 | 10 | procedure Put (Message : in String) is 11 | procedure SDL_Log (C_Fmt, C_Message : in C.char_array) with 12 | Import => True, 13 | Convention => C_Variadic_1, 14 | External_Name => "SDL_Log"; 15 | begin 16 | SDL_Log (C.To_C ("%s"), C.To_C (Message)); 17 | end Put; 18 | 19 | 20 | procedure Put (Message : in String; Category : in Categories; Priority : in Priorities) is 21 | procedure SDL_Log_Message 22 | (Category : in Categories; 23 | Priority : in Priorities; 24 | C_Fmt, 25 | C_Message : in C.char_array) with 26 | Import => True, 27 | Convention => C_Variadic_1, 28 | External_Name => "SDL_LogMessage"; 29 | begin 30 | SDL_Log_Message (Category, Priority, C.To_C ("%s"), C.To_C (Message)); 31 | end Put; 32 | 33 | 34 | procedure Put_Critical (Message : in String; Category : in Categories := Application) is 35 | procedure SDL_Log_Critical (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 36 | Import => True, 37 | Convention => C_Variadic_1, 38 | External_Name => "SDL_LogCritical"; 39 | begin 40 | SDL_Log_Critical (Category, C.To_C ("%s"), C.To_C (Message)); 41 | end Put_Critical; 42 | 43 | 44 | procedure Put_Debug (Message : in String; Category : in Categories := Application) is 45 | procedure SDL_Log_Debug (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 46 | Import => True, 47 | Convention => C_Variadic_1, 48 | External_Name => "SDL_LogDebug"; 49 | begin 50 | SDL_Log_Debug (Category, C.To_C ("%s"), C.To_C (Message)); 51 | end Put_Debug; 52 | 53 | 54 | procedure Put_Error (Message : in String; Category : in Categories := Application) is 55 | procedure SDL_Log_Error (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 56 | Import => True, 57 | Convention => C_Variadic_1, 58 | External_Name => "SDL_LogError"; 59 | begin 60 | SDL_Log_Error (Category, C.To_C ("%s"), C.To_C (Message)); 61 | end Put_Error; 62 | 63 | 64 | procedure Put_Info (Message : in String; Category : in Categories := Application) is 65 | procedure SDL_Log_Info (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 66 | Import => True, 67 | Convention => C_Variadic_1, 68 | External_Name => "SDL_LogInfo"; 69 | begin 70 | SDL_Log_Info (Category, C.To_C ("%s"), C.To_C (Message)); 71 | end Put_Info; 72 | 73 | 74 | procedure Put_Verbose (Message : in String; Category : in Categories := Application) is 75 | procedure SDL_Log_Verbose (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 76 | Import => True, 77 | Convention => C_Variadic_1, 78 | External_Name => "SDL_LogVerbose"; 79 | begin 80 | SDL_Log_Verbose (Category, C.To_C ("%s"), C.To_C (Message)); 81 | end Put_Verbose; 82 | 83 | 84 | procedure Put_Warn (Message : in String; Category : in Categories := Application) is 85 | procedure SDL_Log_Warn (Category : in Categories; C_Fmt, C_Message : in C.char_array) with 86 | Import => True, 87 | Convention => C_Variadic_1, 88 | External_Name => "SDL_LogWarn"; 89 | begin 90 | SDL_Log_Warn (Category, C.To_C ("%s"), C.To_C (Message)); 91 | end Put_Warn; 92 | 93 | 94 | -- Logging. 95 | -- TODO: Fix this. 96 | -- A local record type which gets initialised with an access to callback 97 | -- and a copy to the actual user data. 98 | type Local_User_Data is 99 | record 100 | Callback : Output_Callback; 101 | Data : Root_User_Data; 102 | end record with 103 | Convention => C; 104 | 105 | procedure Log_Output_Function 106 | (User_Data : in Local_User_Data; 107 | Category : in Categories; 108 | Priority : in Priorities; 109 | Message : in C.Strings.chars_ptr) with 110 | Convention => C; 111 | 112 | procedure Log_Output_Function 113 | (User_Data : in Local_User_Data; 114 | Category : in Categories; 115 | Priority : in Priorities; 116 | Message : in C.Strings.chars_ptr) is 117 | begin 118 | -- Call the Ada callback now. 119 | User_Data.Callback (User_Data.Data, 120 | Category, 121 | Priority, 122 | C.Strings.Value (Message)); 123 | end Log_Output_Function; 124 | 125 | procedure Local_Callback 126 | (User_Data : in Local_User_Data; 127 | Category : in Categories; 128 | Priority : in Priorities; 129 | Message : in C.Strings.chars_ptr) renames Log_Output_Function with -- Deprecated. 130 | Unreferenced; 131 | end SDL.Log; 132 | -------------------------------------------------------------------------------- /src/sdl-log.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Log 5 | -- 6 | -- Message logging. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.Log is 9 | pragma Preelaborate; 10 | 11 | -- Messages longer than Max_Length will be truncated. 12 | -- TODO: Import this from a C constant set from SDL_MAX_LOG_MESSAGE. 13 | Max_Length : constant Integer := 4096; 14 | 15 | -- Had to make this into a type with constants due to the abuse of 16 | -- the C enumeration. 17 | type Categories is range 0 .. 2 ** 32 with 18 | Convention => C; 19 | 20 | Application : constant Categories := 0; 21 | Errors : constant Categories := 1; 22 | Assert : constant Categories := 2; 23 | System : constant Categories := 3; 24 | Audio : constant Categories := 4; 25 | Video : constant Categories := 5; 26 | Render : constant Categories := 6; 27 | Input : constant Categories := 7; 28 | Test : constant Categories := 8; 29 | 30 | -- Reserved categories. 31 | Reserved_First : constant Categories := 9; 32 | Reserved_Last : constant Categories := 18; 33 | 34 | -- Custom categories. 35 | Custom_Category : constant Categories := 19; 36 | 37 | subtype Custom_Categories is Categories range Custom_Category .. Categories'Last; 38 | 39 | type Priorities is (Verbose, Debug, Info, Warn, Error, Critical) with 40 | Convention => C; 41 | 42 | for Priorities use 43 | (Verbose => 1, 44 | Debug => 2, 45 | Info => 3, 46 | Warn => 4, 47 | Error => 5, 48 | Critical => 6); 49 | 50 | -- Log a message with Category: Application and Priority: Info. 51 | procedure Put (Message : in String) with 52 | Inline => True; 53 | 54 | procedure Put (Message : in String; Category : in Categories; Priority : in Priorities) with 55 | Inline => True; 56 | 57 | -- Log a message with Priority: Critical. 58 | procedure Put_Critical (Message : in String; Category : in Categories := Application) with 59 | Inline => True; 60 | 61 | -- Log a message with Priority: Debug. 62 | procedure Put_Debug (Message : in String; Category : in Categories := Application) with 63 | Inline => True; 64 | 65 | -- Log a message with Priority: Error. 66 | procedure Put_Error (Message : in String; Category : in Categories := Application) with 67 | Inline => True; 68 | 69 | -- Log a message with Priority: Info. 70 | procedure Put_Info (Message : in String; Category : in Categories := Application) with 71 | Inline => True; 72 | 73 | -- Log a message with Priority: Verbose. 74 | procedure Put_Verbose (Message : in String; Category : in Categories := Application) with 75 | Inline => True; 76 | 77 | -- Log a message with Priority: Warn. 78 | procedure Put_Warn (Message : in String; Category : in Categories := Application) with 79 | Inline => True; 80 | 81 | -- 82 | procedure Reset_Priorities with 83 | Import => True, 84 | Convention => C, 85 | External_Name => "SDL_LogResetPriorities"; 86 | 87 | -- Set the priority of all the log categories to the given Priority. 88 | procedure Set_All_Priorities (Priority : in Priorities) with 89 | Import => True, 90 | Convention => C, 91 | External_Name => "SDL_LogSetAllPriority"; 92 | 93 | procedure Set (Priority : in Priorities) renames Set_All_Priorities; -- Deprecated 94 | 95 | -- Set the the given log Category to the given Priority. 96 | procedure Set_Priority (Category : in Categories; Priority : in Priorities) with 97 | Import => True, 98 | Convention => C, 99 | External_Name => "SDL_LogSetPriority"; 100 | 101 | procedure Set (Category : in Categories; Priority : in Priorities) renames Set_Priority; -- Deprecated 102 | 103 | -- Logging callbacks. 104 | -- TODO: complete this. 105 | -- I think this will require a bit more work. I think we will have to allocate a record 106 | -- and store this in a container which gets destroyed on application shutdown before SDL quits. 107 | type Root_User_Data is tagged null record; 108 | 109 | type Output_Callback is access procedure 110 | (User_Data : in Root_User_Data'Class; 111 | Category : in Categories; 112 | Priority : in Priorities; 113 | Message : in String); 114 | end SDL.Log; 115 | -------------------------------------------------------------------------------- /src/sdl-platform.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | package body SDL.Platform is 5 | -- Bring in the platform specific version for each build of the library. It's also defined as inline so 6 | -- that the compiler can eliminate redundant code in the static expressions that use this function. 7 | function Get return Platforms is separate; 8 | end SDL.Platform; 9 | -------------------------------------------------------------------------------- /src/sdl-platform.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Platform 5 | -- 6 | -- Determine which platform we are running on. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.Platform is 9 | pragma Pure; 10 | 11 | type Platforms is (Windows, Mac_OS_X, Linux, BSD, iOS, Android); 12 | 13 | function Get return Platforms with 14 | Inline => True; 15 | end SDL.Platform; 16 | -------------------------------------------------------------------------------- /src/sdl-power.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | 6 | package body SDL.Power is 7 | package C renames Interfaces.C; 8 | 9 | procedure Info (Data : in out Battery_Info) is 10 | function SDL_GetPowerInfo (Seconds, Percent : out C.int) return State with 11 | Import => True, 12 | Convention => C, 13 | External_Name => "SDL_GetPowerInfo"; 14 | 15 | Seconds, Percent : C.int; 16 | 17 | begin 18 | Data.Power_State := SDL_GetPowerInfo (Seconds, Percent); 19 | 20 | if Seconds = -1 then 21 | Data.Time_Valid := False; 22 | else 23 | Data.Time_Valid := True; 24 | Data.Time := SDL.Power.Seconds (Seconds); 25 | end if; 26 | 27 | if Percent = -1 then 28 | Data.Percentage_Valid := False; 29 | else 30 | Data.Percentage_Valid := True; 31 | Data.Percent := Percentage (Percent); 32 | end if; 33 | end Info; 34 | end SDL.Power; 35 | -------------------------------------------------------------------------------- /src/sdl-power.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Power 5 | -- 6 | -- Battery access on the target platform. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.Power is 9 | pragma Pure; 10 | 11 | type State is 12 | (Unknown, -- Cannot determine power status. 13 | Battery, -- Not plugged in, running on the battery. 14 | No_Battery, -- Plugged in, no battery available. 15 | Charging, -- Plugged in, charging battery. 16 | Charged -- Plugged in, battery charged. 17 | ) with 18 | Convention => C; 19 | 20 | type Seconds is range 0 .. Integer'Last; 21 | type Percentage is range 0 .. 100; 22 | 23 | type Battery_Info is 24 | record 25 | Power_State : State; 26 | 27 | Time_Valid : Boolean; 28 | Time : Seconds; 29 | 30 | Percentage_Valid : Boolean; 31 | Percent : Percentage; 32 | end record; 33 | 34 | procedure Info (Data : in out Battery_Info); 35 | end SDL.Power; 36 | -------------------------------------------------------------------------------- /src/sdl-timers.adb: -------------------------------------------------------------------------------- 1 | package body SDL.Timers is 2 | procedure Wait_Delay (MS : Milliseconds_Long) is 3 | begin 4 | Wait_Delay (Milliseconds (MS)); 5 | end Wait_Delay; 6 | end SDL.Timers; 7 | -------------------------------------------------------------------------------- /src/sdl-timers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Timers 5 | -- 6 | -- SDL time management routines and data types. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces; 9 | 10 | package SDL.Timers is 11 | pragma Pure; 12 | 13 | type Milliseconds_Long is new Interfaces.Unsigned_64; 14 | type Milliseconds is new Interfaces.Unsigned_32; 15 | 16 | -- Return the number of milliseconds since the SDL library initialization. 17 | function Ticks return Milliseconds with 18 | Import => True, 19 | Convention => C, 20 | External_Name => "SDL_GetTicks", 21 | Obsolescent; 22 | 23 | function Ticks return Milliseconds_Long with 24 | Import => True, 25 | Convention => C, 26 | External_Name => "SDL_GetTicks64"; 27 | 28 | -- Wait a specified number of milliseconds before returning. 29 | procedure Wait_Delay (MS : Milliseconds) with 30 | Import => True, 31 | Convention => C, 32 | External_Name => "SDL_Delay"; 33 | 34 | procedure Wait_Delay (MS : Milliseconds_Long) with 35 | Inline; 36 | 37 | package Performance is 38 | type Counts is new Interfaces.Unsigned_64; 39 | type Frequencies is new Interfaces.Unsigned_64; 40 | 41 | function Get_Counter return Counts with 42 | Import => True, 43 | Convention => C, 44 | External_Name => "SDL_GetPerformanceCounter"; 45 | 46 | function Get_Frequency return Frequencies with 47 | Import => True, 48 | Convention => C, 49 | External_Name => "SDL_GetPerformanceFrequency"; 50 | end Performance; 51 | end SDL.Timers; 52 | -------------------------------------------------------------------------------- /src/sdl-versions.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | with Interfaces.C.Strings; 6 | 7 | package body SDL.Versions is 8 | package C renames Interfaces.C; 9 | 10 | 11 | function Revision return String is 12 | function SDL_Get_Revision return C.Strings.chars_ptr with 13 | Import => True, 14 | Convention => C, 15 | External_Name => "SDL_GetRevision"; 16 | begin 17 | return C.Strings.Value (SDL_Get_Revision); 18 | end Revision; 19 | 20 | 21 | function Revision return Revision_Level is 22 | function SDL_Get_Revision_Number return C.int with 23 | Import => True, 24 | Convention => C, 25 | External_Name => "SDL_GetRevisionNumber"; 26 | begin 27 | return Revision_Level (SDL_Get_Revision_Number); 28 | end Revision; 29 | 30 | 31 | procedure Linked_With (Info : in out Version) is 32 | procedure SDL_Get_Version (V : in out Version) with 33 | Import => True, 34 | Convention => C, 35 | External_Name => "SDL_GetVersion"; 36 | begin 37 | SDL_Get_Version (Info); 38 | end Linked_With; 39 | end SDL.Versions; 40 | -------------------------------------------------------------------------------- /src/sdl-versions.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Versions 5 | -- 6 | -- Library version information. 7 | -- 8 | -- **IMPORTANT** DO NOT REMOVE THESE FUNCTIONS, they are very important. They allow the running application to see 9 | -- what version of the libraries are installed on the system. This allows the running application 10 | -- to modify it's behaviour if certain functionality from a certain version is missing. 11 | -- i.e. Steam controls it's libs and whilst they are usually up to date, there is no guarantee that 12 | -- the version you built against has the same functionality as that installed on the user's machine. 13 | -------------------------------------------------------------------------------------------------------------------- 14 | package SDL.Versions is 15 | pragma Preelaborate; 16 | 17 | type Version_Level is mod 2 ** 8 with 18 | Size => 8, 19 | Convention => C; 20 | 21 | -- TODO: Check this against the library, as they use an int. 22 | -- Deprecated: DO NOT USE. 23 | type Revision_Level is mod 2 ** 32; 24 | 25 | type Version is 26 | record 27 | Major : Version_Level; 28 | Minor : Version_Level; 29 | Patch : Version_Level; 30 | end record with 31 | Convention => C; 32 | 33 | -- These allow the user to determine which version of SDLAda they compiled with. 34 | Compiled_Major : constant Version_Level with 35 | Import => True, 36 | Convention => C, 37 | External_Name => "SDL_Ada_Major_Version"; 38 | 39 | Compiled_Minor : constant Version_Level with 40 | Import => True, 41 | Convention => C, 42 | External_Name => "SDL_Ada_Minor_Version"; 43 | 44 | Compiled_Patch : constant Version_Level with 45 | Import => True, 46 | Convention => C, 47 | External_Name => "SDL_Ada_Patch_Version"; 48 | 49 | function Compiled return Version is 50 | (Major => Compiled_Major, 51 | Minor => Compiled_Minor, 52 | Patch => Compiled_Patch) 53 | with Inline => True; 54 | 55 | function Revision return String with 56 | Inline => True; 57 | 58 | function Revision return Revision_Level; -- Deprecated. 59 | 60 | procedure Linked_With (Info : in out Version) with 61 | Inline => True; 62 | end SDL.Versions; 63 | -------------------------------------------------------------------------------- /src/sdl.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | package body SDL is 5 | function Initialise (Flags : in Init_Flags := Enable_Everything) return Boolean is 6 | function SDL_Init (Flags : in Init_Flags := Enable_Everything) return C.int with 7 | Import => True, 8 | Convention => C, 9 | External_Name => "SDL_Init"; 10 | begin 11 | return (SDL_Init (Flags) = Success); 12 | end Initialise; 13 | 14 | 15 | function Initialise_Sub_System (Flags : in Init_Flags) return Boolean is 16 | function SDL_Init_Sub_System (Flags : in Init_Flags) return C.int with 17 | Import => True, 18 | Convention => C, 19 | External_Name => "SDL_InitSubSystem"; 20 | begin 21 | return (SDL_Init_Sub_System (Flags) = Success); 22 | end Initialise_Sub_System; 23 | 24 | 25 | function SDL_Was_Initialised (Flags : in Init_Flags := Null_Init_Flags) return Init_Flags with 26 | Import => True, 27 | Convention => C, 28 | External_Name => "SDL_WasInit"; 29 | 30 | 31 | function What_Was_Initialised return Init_Flags is 32 | begin 33 | return SDL_Was_Initialised; 34 | end What_Was_Initialised; 35 | 36 | 37 | function Was_Initialised (Flags : in Init_Flags) return Boolean is 38 | begin 39 | return (SDL_Was_Initialised (Flags) = Flags); 40 | end Was_Initialised; 41 | end SDL; 42 | -------------------------------------------------------------------------------- /src/version.c: -------------------------------------------------------------------------------- 1 | /*********************************************************************************************************************** 2 | * This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | **********************************************************************************************************************/ 4 | #include 5 | 6 | /* We need to define some constants here so we can get access to the values that in #define form from Ada. 7 | */ 8 | const Uint8 SDL_Ada_Major_Version = SDL_MAJOR_VERSION; 9 | const Uint8 SDL_Ada_Minor_Version = SDL_MINOR_VERSION; 10 | const Uint8 SDL_Ada_Patch_Version = SDL_PATCHLEVEL; 11 | -------------------------------------------------------------------------------- /src/video/sdl-video-displays.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Displays 5 | -- 6 | -- Access to display information including video displays and resolutions. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces.C; 9 | with SDL.Video.Pixel_Formats; 10 | with SDL.Video.Rectangles; 11 | with System; 12 | 13 | package SDL.Video.Displays is 14 | pragma Preelaborate; 15 | 16 | package C renames Interfaces.C; 17 | 18 | type Refresh_Rates is range 0 .. 400 with 19 | Size => C.int'Size, 20 | Convention => C; 21 | 22 | type Mode is 23 | record 24 | Format : SDL.Video.Pixel_Formats.Pixel_Format_Names; 25 | Width : C.int; 26 | Height : C.int; 27 | Refresh_Rate : Refresh_Rates; 28 | Driver_Data : System.Address; -- TODO: Somehow make this a real type. 29 | end record with 30 | Convention => C; 31 | 32 | type Access_Mode is access all Mode with 33 | Convention => C; 34 | 35 | -- Video displays. 36 | type Display_Indices is new Positive; 37 | 38 | type Display_Orientations is 39 | (Orientation_Unknown, 40 | Orientation_Landscape, 41 | Orientation_Landscape_Flipped, 42 | Orientation_Portrait, 43 | Orientation_Portrait_Flipped) 44 | with Convention => C; 45 | 46 | 47 | function Total return Display_Indices; 48 | 49 | function Get_Display_Name (Display : Display_Indices) return String; 50 | 51 | function Closest_Mode (Display : in Display_Indices; Wanted : in Mode; Target : out Mode) return Boolean; 52 | 53 | function Get_Display_Index_From_Point (Point : in Rectangles.Point) return Display_Indices; 54 | 55 | function Current_Mode (Display : in Display_Indices; Target : out Mode) return Boolean; 56 | 57 | function Desktop_Mode (Display : in Display_Indices; Target : out Mode) return Boolean; 58 | 59 | function Display_Mode (Display : in Display_Indices; Index : in Natural; Target : out Mode) return Boolean; 60 | 61 | function Total_Display_Modes (Display : in Display_Indices; Total : out Positive) return Boolean; 62 | function Total_Display_Modes (Display : in Display_Indices) return Positive; 63 | 64 | function Display_Bounds (Display : in Display_Indices; Bounds : out Rectangles.Rectangle) return Boolean with 65 | Obsolescent; 66 | 67 | function Get_Bounds (Display : in Display_Indices; Bounds : out Rectangles.Rectangle) return Boolean 68 | renames Display_Bounds; 69 | function Get_Usable_Bounds (Display : Display_Indices; Bounds : out Rectangles.Rectangle) return Boolean; 70 | 71 | procedure Get_Display_DPI (Display : Display_Indices; Diagonal, Horizontal, Vertical : out Float); 72 | procedure Get_Display_DPI (Display : Display_Indices; Horizontal, Vertical : out Float); 73 | function Get_Display_Horizontal_DPI (Display : Display_Indices) return Float; 74 | function Get_Display_Vertical_DPI (Display : Display_Indices) return Float; 75 | 76 | function Get_Orientation (Display : Display_Indices) return Display_Orientations; 77 | end SDL.Video.Displays; 78 | -------------------------------------------------------------------------------- /src/video/sdl-video-palettes.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Ada.Finalization; use Ada.Finalization; 5 | 6 | package body SDL.Video.Palettes is 7 | -- function Element_Value (Container : in Palette_array; Pos : in Palette_Cursor) return Colour is 8 | -- begin 9 | -- return Pos.Current.all; 10 | -- end Element_Value; 11 | 12 | -- function Has_Element (Pos : in Palette_Cursor) return Boolean is 13 | -- begin 14 | -- -- if Pos.Index < Positive (Pos.Container.Internal.Total) then 15 | -- if Pos.Index < Pos.Total then 16 | -- return True; 17 | -- end if; 18 | 19 | -- return False; 20 | -- end Has_Element; 21 | 22 | -- function Iterate (Container : not null access Palette_Array) return Palette_Iterators'Class is 23 | -- begin 24 | -- return It : constant Palette_Iterators := Palette_Iterators'(Container => Palette_Access (Container)) do 25 | -- null; 26 | -- end return; 27 | -- end Iterate; 28 | 29 | -- function First (Object : in Palette_Iterators) return Palette_Cursor is 30 | -- begin 31 | -- return Palette_Cursor' 32 | -- (-- Container => Object.Internal, 33 | -- Index => Positive'First, 34 | -- Total => Positive (Object.Container.Internal.Total), 35 | -- Current => Object.Container.Internal.Colours); 36 | -- end First; 37 | 38 | -- function Next (Object : in Palette_Iterators; Position : in Palette_Cursor) return Palette_Cursor is 39 | -- Curr : Colour_Array_Pointer.Pointer := Position.Current; 40 | -- begin 41 | -- Colour_Array_Pointer.Increment (Curr); 42 | 43 | -- return Palette_Cursor' 44 | -- (-- Container => Object.Internal, 45 | -- Index => Position.Index + 1, 46 | -- Total => Position.Total, 47 | -- Current => Curr); 48 | -- end Next; 49 | 50 | type Iterator (Container : access constant Palette'Class) is new Limited_Controlled and 51 | Palette_Iterator_Interfaces.Forward_Iterator with 52 | record 53 | Index : Natural; 54 | end record; 55 | 56 | overriding 57 | function First (Object : Iterator) return Cursor; 58 | 59 | overriding 60 | function Next (Object : Iterator; Position : Cursor) return Cursor; 61 | 62 | function Element (Position : in Cursor) return Colour is 63 | begin 64 | -- return Position.Container.Data.Colours (Position.Index); 65 | return Colour_Array_Pointer.Value (Position.Current) (0); 66 | end Element; 67 | 68 | function Has_Element (Position : in Cursor) return Boolean is 69 | begin 70 | return Position.Index <= Natural (Position.Container.Data.Total); 71 | end Has_Element; 72 | 73 | function Constant_Reference 74 | (Container : aliased Palette; 75 | Position : Cursor) return Colour is 76 | pragma Unreferenced (Container); -- TODO: Fix me! 77 | begin 78 | -- Put_Line ("Constant_Reference" & Natural'Image (Position.Index)); 79 | 80 | -- return Position.Container.Data.Colours (Position.Index); 81 | return Colour_Array_Pointer.Value (Position.Current) (0); 82 | end Constant_Reference; 83 | 84 | function Iterate (Container : Palette) return 85 | Palette_Iterator_Interfaces.Forward_Iterator'Class is 86 | begin 87 | -- Put_Line ("Iterate"); 88 | 89 | return It : constant Iterator := 90 | (Limited_Controlled with 91 | Container => Container'Access, Index => Natural'First + 1) 92 | do 93 | -- Put_Line (" index = " & Natural'Image(It.Index)); 94 | null; 95 | end return; 96 | end Iterate; 97 | 98 | function Create (Total_Colours : in Positive) return Palette is 99 | function SDL_Alloc_Palette (Ncolors : in C.int) return Internal_Palette_Access with 100 | Import => True, 101 | Convention => C, 102 | External_Name => "SDL_AllocPalette"; 103 | begin 104 | return P : constant Palette := 105 | (Data => SDL_Alloc_Palette (C.int (Total_Colours))) 106 | do 107 | null; 108 | end return; 109 | end Create; 110 | 111 | procedure Free (Container : in out Palette) is 112 | procedure SDL_Free_Palette (Self : in Internal_Palette_Access) with 113 | Import => True, 114 | Convention => C, 115 | External_Name => "SDL_FreePalette"; 116 | begin 117 | SDL_Free_Palette (Container.Data); 118 | 119 | Container.Data := null; 120 | end Free; 121 | 122 | overriding 123 | function First (Object : Iterator) return Cursor is 124 | begin 125 | -- Put_Line ("First -> Index = " & Natural'Image (Object.Index)); 126 | 127 | return Cursor'(Container => Object.Container, 128 | Index => Object.Index, 129 | Current => Object.Container.Data.Colours); 130 | end First; 131 | 132 | overriding 133 | function Next (Object : Iterator; Position : Cursor) return Cursor is 134 | Next_Ptr : Colour_Array_Pointer.Pointer := Position.Current; 135 | begin 136 | Colour_Array_Pointer.Increment (Next_Ptr); 137 | 138 | -- Put_Line ("Next"); 139 | 140 | -- if Object.Container /= Position.Container then 141 | -- raise Program_Error with "Wrong containers"; 142 | -- end if; 143 | 144 | return Cursor'(Container => Object.Container, 145 | Index => Position.Index + 1, 146 | Current => Next_Ptr); 147 | end Next; 148 | end SDL.Video.Palettes; 149 | -------------------------------------------------------------------------------- /src/video/sdl-video-palettes.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Palettes 5 | -- 6 | -- Palettes, colours and various conversions. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | 9 | with Ada.Iterator_Interfaces; 10 | with Interfaces.C.Pointers; 11 | 12 | package SDL.Video.Palettes is 13 | pragma Preelaborate; 14 | 15 | package C renames Interfaces.C; 16 | 17 | type Colour_Component is range 0 .. 255 with 18 | Size => 8, 19 | Convention => C; 20 | 21 | type Colour is 22 | record 23 | Red : Colour_Component := Colour_Component'First; 24 | Green : Colour_Component := Colour_Component'First; 25 | Blue : Colour_Component := Colour_Component'First; 26 | Alpha : Colour_Component := Colour_Component'First; 27 | end record with 28 | Convention => C, 29 | Size => Colour_Component'Size * 4; 30 | 31 | Null_Colour : constant Colour := (others => <>); 32 | 33 | pragma Warnings (Off, "8 bits of ""RGB_Colour"" unused"); -- Unused on purpose 34 | type RGB_Colour is 35 | record 36 | Red : Colour_Component := Colour_Component'First; 37 | Green : Colour_Component := Colour_Component'First; 38 | Blue : Colour_Component := Colour_Component'First; 39 | end record with 40 | Convention => C, 41 | Size => Colour_Component'Size * 4; 42 | pragma Warnings (On, "8 bits of ""RGB_Colour"" unused"); 43 | 44 | Null_RGB_Colour : constant RGB_Colour := (others => <>); 45 | 46 | -- Cursor type for our iterator. 47 | type Cursor is private; 48 | 49 | No_Element : constant Cursor; 50 | 51 | function Element (Position : in Cursor) return Colour; 52 | 53 | function Has_Element (Position : in Cursor) return Boolean with 54 | Inline; 55 | 56 | -- Create the iterator interface package. 57 | package Palette_Iterator_Interfaces is new 58 | Ada.Iterator_Interfaces (Cursor, Has_Element); 59 | 60 | type Palette is tagged limited private with 61 | Default_Iterator => Iterate, 62 | Iterator_Element => Colour, 63 | Constant_Indexing => Constant_Reference; 64 | 65 | type Palette_Access is access Palette; 66 | 67 | function Constant_Reference 68 | (Container : aliased Palette; 69 | Position : Cursor) return Colour; 70 | 71 | function Iterate (Container : Palette) 72 | return Palette_Iterator_Interfaces.Forward_Iterator'Class; 73 | 74 | function Create (Total_Colours : in Positive) return Palette; 75 | 76 | procedure Free (Container : in out Palette); 77 | 78 | Empty_Palette : constant Palette; 79 | private 80 | 81 | type Colour_Array is array (C.size_t range <>) of aliased Colour with 82 | Convention => C; 83 | 84 | package Colour_Array_Pointer is new Interfaces.C.Pointers 85 | (Index => C.size_t, 86 | Element => Colour, 87 | Element_Array => Colour_Array, 88 | Default_Terminator => (others => Colour_Component'First)); 89 | 90 | type Internal_Palette is 91 | record 92 | Total : C.int; 93 | Colours : Colour_Array_Pointer.Pointer; 94 | Version : Interfaces.Unsigned_32; 95 | Ref_Count : C.int; 96 | end record with 97 | Convention => C; 98 | 99 | type Internal_Palette_Access is access Internal_Palette with 100 | Convention => C; 101 | 102 | type Palette is tagged limited 103 | record 104 | Data : Internal_Palette_Access; 105 | end record; 106 | 107 | type Palette_Constant_Access is access constant Palette'Class; 108 | 109 | type Cursor is 110 | record 111 | Container : Palette_Constant_Access; 112 | Index : Natural; 113 | Current : Colour_Array_Pointer.Pointer; 114 | end record; 115 | 116 | No_Element : constant Cursor := Cursor'(Container => null, 117 | Index => Natural'First, 118 | Current => null); 119 | 120 | Empty_Palette : constant Palette := Palette'(Data => null); 121 | end SDL.Video.Palettes; 122 | -------------------------------------------------------------------------------- /src/video/sdl-video-pixel_formats.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C.Strings; 5 | 6 | package body SDL.Video.Pixel_Formats is 7 | -- TODO: SDL_SetPixelFormatPalette Check this as the first parameter is a pointer. 8 | function Image (Format : in Pixel_Format_Names) return String is 9 | function SDL_Get_Pixel_Format_Name (Format : in Pixel_Format_Names) return C.Strings.chars_ptr with 10 | Import => True, 11 | Convention => C, 12 | External_Name => "SDL_GetPixelFormatName"; 13 | begin 14 | return C.Strings.Value (SDL_Get_Pixel_Format_Name (Format)); 15 | end Image; 16 | 17 | 18 | function To_Colour (Pixel : in Interfaces.Unsigned_32; Format : in Pixel_Format_Access) return Palettes.Colour is 19 | C : Palettes.Colour; 20 | begin 21 | To_Components (Pixel => Pixel, 22 | Format => Format, 23 | Red => C.Red, 24 | Green => C.Green, 25 | Blue => C.Blue, 26 | Alpha => C.Alpha); 27 | 28 | return C; 29 | end To_Colour; 30 | 31 | function To_Pixel (Colour : in Palettes.Colour; Format : in Pixel_Format_Access) return Interfaces.Unsigned_32 is 32 | begin 33 | return To_Pixel (Format => Format, 34 | Red => Colour.Red, 35 | Green => Colour.Green, 36 | Blue => Colour.Blue, 37 | Alpha => Colour.Alpha); 38 | end To_Pixel; 39 | 40 | function To_Masks 41 | (Format : in Pixel_Format_Names; 42 | Bits : out Bits_Per_Pixels; 43 | Red_Mask : out Colour_Mask; 44 | Green_Mask : out Colour_Mask; 45 | Blue_Mask : out Colour_Mask; 46 | Alpha_Mask : out Colour_Mask) return Boolean is 47 | 48 | function SDL_Pixel_Format_Enum_To_Masks 49 | (Format : in Pixel_Format_Names; 50 | Bits : out Bits_Per_Pixels; 51 | Red_Mask : out Colour_Mask; 52 | Green_Mask : out Colour_Mask; 53 | Blue_Mask : out Colour_Mask; 54 | Alpha_Mask : out Colour_Mask) return C.int with 55 | Import => True, 56 | Convention => C, 57 | External_Name => "SDL_PixelFormatEnumToMasks"; 58 | 59 | Error : constant C.int := SDL_Pixel_Format_Enum_To_Masks 60 | (Format, 61 | Bits, 62 | Red_Mask, 63 | Green_Mask, 64 | Blue_Mask, 65 | Alpha_Mask); 66 | begin 67 | return Error = 1; 68 | -- TODO: This causes http://gcc.gnu.org/bugzilla/show_bug.cgi?id=58573 69 | -- 70 | -- return (if SDL_Pixel_Format_Enum_To_Masks 71 | -- (Format, 72 | -- Bits, 73 | -- Red_Mask, 74 | -- Green_Mask, 75 | -- Blue_Mask, 76 | -- Alpha_Mask) = 1 then True else False); 77 | -- or: 78 | -- return (SDL_Pixel_Format_Enum_To_Masks 79 | -- (Format, 80 | -- Bits, 81 | -- Red_Mask, 82 | -- Green_Mask, 83 | -- Blue_Mask, 84 | -- Alpha_Mask) = 1); 85 | end To_Masks; 86 | end SDL.Video.Pixel_Formats; 87 | -------------------------------------------------------------------------------- /src/video/sdl-video-pixels.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Pixels 5 | -- 6 | -- Access to pixel data. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces; 9 | with Interfaces.C; 10 | with Interfaces.C.Pointers; 11 | with SDL.Video.Palettes; 12 | 13 | package SDL.Video.Pixels is 14 | pragma Preelaborate; 15 | 16 | package C renames Interfaces.C; 17 | 18 | -- Define pixel data access. Each pixel can be of any pixel format type. 19 | -- A bitmap returned, say from Textures.Lock is an array of pixels. 20 | Pixels_Error : exception; 21 | 22 | -- These give access to the pitch data returned by locking a texture. 23 | type Pitches is new C.int with 24 | Size => 32, 25 | Convention => C; 26 | 27 | -- ARGB8888 pixels. 28 | -- These give access to a texture's/surface's (TODO??) pixel data in the above format. 29 | type ARGB_8888 is 30 | record 31 | Alpha : SDL.Video.Palettes.Colour_Component; 32 | Red : SDL.Video.Palettes.Colour_Component; 33 | Green : SDL.Video.Palettes.Colour_Component; 34 | Blue : SDL.Video.Palettes.Colour_Component; 35 | end record with 36 | Size => 32, 37 | Convention => C; 38 | 39 | for ARGB_8888 use 40 | record 41 | Blue at 0 range 0 .. 7; 42 | Green at 0 range 8 .. 15; 43 | Red at 0 range 16 .. 23; 44 | Alpha at 0 range 24 .. 31; 45 | end record; 46 | 47 | type ARGB_8888_Array is array (SDL.Dimension range <>) of aliased ARGB_8888; 48 | 49 | package ARGB_8888_Access is new Interfaces.C.Pointers 50 | (Index => SDL.Dimension, 51 | Element => ARGB_8888, 52 | Element_Array => ARGB_8888_Array, 53 | Default_Terminator => ARGB_8888'(others => SDL.Video.Palettes.Colour_Component'First)); 54 | 55 | generic 56 | type Index is (<>); 57 | type Element is private; 58 | type Element_Array_1D is array (Index range <>) of aliased Element; 59 | pragma Warnings (Off, """Element_Array_2D"" is not referenced"); -- This attribute is deprecated 60 | type Element_Array_2D is array (Index range <>, Index range <>) of aliased Element; 61 | pragma Warnings (On, """Element_Array_2D"" is not referenced"); -- This attribute is deprecated 62 | 63 | Default_Terminator : Element; 64 | package Texture_Data is 65 | package Texture_Data_1D is new Interfaces.C.Pointers (Index => Index, 66 | Element => Element, 67 | Element_Array => Element_Array_1D, 68 | Default_Terminator => Default_Terminator); 69 | 70 | subtype Pointer is Texture_Data_1D.Pointer; 71 | end Texture_Data; 72 | end SDL.Video.Pixels; 73 | -------------------------------------------------------------------------------- /src/video/sdl-video-rectangles.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Rectangles 5 | -- 6 | -- Rectangle bounding areas. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces.C; 9 | 10 | package SDL.Video.Rectangles is 11 | pragma Preelaborate; 12 | 13 | package C renames Interfaces.C; 14 | 15 | Rectangle_Error : exception; 16 | 17 | type Size_Arrays is array (C.size_t range <>) of aliased SDL.Sizes with 18 | Convention => C; 19 | 20 | subtype Point is SDL.Coordinates; 21 | 22 | type Point_Arrays is array (C.size_t range <>) of aliased Point with 23 | Convention => C; 24 | 25 | type Float_Point is 26 | record 27 | X : Float; 28 | Y : Float; 29 | end record with 30 | Convention => C; 31 | 32 | type Float_Point_Arrays is array (C.size_t range <>) of aliased Float_Point with 33 | Convention => C; 34 | 35 | type Line_Segment is 36 | record 37 | Start : SDL.Coordinates; 38 | Finish : SDL.Coordinates; 39 | end record with 40 | Convention => C; 41 | 42 | type Line_Arrays is array (C.size_t range <>) of aliased Line_Segment with 43 | Convention => C; 44 | 45 | type Float_Line_Segment is 46 | record 47 | Start : Float_Point; 48 | Finish : Float_Point; 49 | end record with 50 | Convention => C; 51 | 52 | type Float_Line_Arrays is array (C.size_t range <>) of aliased Float_Line_Segment with 53 | Convention => C; 54 | 55 | -- TODO: Replace with Point and Sizes? 56 | type Rectangle is 57 | record 58 | X : SDL.Coordinate; 59 | Y : SDL.Coordinate; 60 | Width : SDL.Natural_Dimension; 61 | Height : SDL.Natural_Dimension; 62 | end record with 63 | Convention => C; 64 | 65 | Null_Rectangle : constant Rectangle := (others => 0); 66 | 67 | type Rectangle_Arrays is array (C.size_t range <>) of aliased Rectangle with 68 | Convention => C; 69 | 70 | type Rectangle_Access is access all Rectangle with 71 | Convention => C; 72 | 73 | type Float_Rectangle is 74 | record 75 | X : Float; 76 | Y : Float; 77 | Width : Float; 78 | Height : Float; 79 | end record with 80 | Convention => C; 81 | 82 | type Float_Rectangle_Arrays is array (C.size_t range <>) of aliased Float_Rectangle with 83 | Convention => C; 84 | 85 | type Float_Rectangle_Access is access all Float_Rectangle with 86 | Convention => C; 87 | 88 | -- SDL_PointInRect. 89 | function Inside (P : Point; R : Rectangle) return Boolean is 90 | (P.X >= R.X and P.X < R.X + R.Width and 91 | P.Y >= R.Y and P.Y < R.Y + R.Height); 92 | 93 | -- SDL_RectEmpty. 94 | function Is_Empty (R : Rectangle) return Boolean is 95 | (R.Width = SDL.Natural_Dimension'First or -- First = 0, so can never be < 0. 96 | R.Height = SDL.Natural_Dimension'First); 97 | 98 | -- SDL_RectEquals, not required, = is implicitly defined. 99 | 100 | function Has_Intersected (A, B : in Rectangle) return Boolean; 101 | function Intersects (A, B : in Rectangle; Intersection : out Rectangle) return Boolean; 102 | 103 | function Union (A, B : in Rectangle) return Rectangle; 104 | 105 | function Enclose (Points : in Point_Arrays; Clip : in Rectangle; Enclosed : out Rectangle) return Boolean; 106 | procedure Enclose (Points : in Point_Arrays; Enclosed : out Rectangle); 107 | 108 | function Clip_To (Clip_Area : in Rectangle; Line : in out Line_Segment) return Boolean; 109 | function Intersects (Clip_Area : in Rectangle; Line : in out Line_Segment) return Boolean renames Clip_To; 110 | 111 | -- SDL_PointInFRect. 112 | function Inside (P : Float_Point; R : Float_Rectangle) return Boolean is 113 | (P.X >= R.X and P.X < R.X + R.Width and 114 | P.Y >= R.Y and P.Y < R.Y + R.Height); 115 | 116 | -- SDL_FRectEmpty. 117 | function Is_Empty (R : Float_Rectangle) return Boolean is (R.Width <= 0.0 or R.Height <= 0.0); 118 | 119 | function Absolute (Value : Float) return Float is (if Value < 0.0 then -Value else Value); 120 | 121 | -- SDL_FRectEqualsEpsilon. 122 | function Equals (Left, Right : Float_Rectangle; Epsilon : Float := Float'Model_Epsilon) return Boolean is 123 | ((Left = Right) or 124 | ((Absolute (Left.X - Right.X) <= Epsilon) and 125 | (Absolute (Left.Y - Right.Y) <= Epsilon) and 126 | (Absolute (Left.Width - Right.Width) <= Epsilon) and 127 | (Absolute (Left.Height - Right.Height) <= Epsilon))); 128 | 129 | -- SDL_FRectEquals. 130 | overriding 131 | function "=" (Left, Right : Float_Rectangle) return Boolean is (Equals (Left, Right, Float'Model_Epsilon)); 132 | 133 | function Has_Intersected (A, B : in Float_Rectangle) return Boolean; 134 | function Intersects (A, B : in Float_Rectangle; Intersection : out Float_Rectangle) return Boolean; 135 | 136 | function Union (A, B : in Float_Rectangle) return Float_Rectangle; 137 | 138 | function Enclose (Points : in Point_Arrays; Clip : in Float_Rectangle; Enclosed : out Float_Rectangle) 139 | return Boolean; 140 | procedure Enclose (Points : in Point_Arrays; Enclosed : out Float_Rectangle); 141 | 142 | function Clip_To (Clip_Area : in Float_Rectangle; Line : in out Line_Segment) return Boolean; 143 | function Intersects (Clip_Area : in Float_Rectangle; Line : in out Line_Segment) return Boolean renames Clip_To; 144 | end SDL.Video.Rectangles; 145 | -------------------------------------------------------------------------------- /src/video/sdl-video-renderers-makers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | private with SDL.C_Pointers; 6 | 7 | package body SDL.Video.Renderers.Makers is 8 | package C renames Interfaces.C; 9 | 10 | function Get_Internal_Window (Self : in SDL.Video.Windows.Window) return SDL.C_Pointers.Windows_Pointer with 11 | Convention => Ada, 12 | Import => True; 13 | 14 | function Get_Internal_Surface (Self : in SDL.Video.Surfaces.Surface) 15 | return SDL.Video.Surfaces.Internal_Surface_Pointer with 16 | Import => True, 17 | Convention => Ada; 18 | 19 | procedure Create 20 | (Rend : in out Renderer; 21 | Window : in out SDL.Video.Windows.Window; 22 | Driver : in Driver_Indices; 23 | Flags : in Renderer_Flags := Default_Renderer_Flags) is 24 | 25 | function SDL_Create_Renderer (W : in SDL.C_Pointers.Windows_Pointer; Index : in C.int; Flags : in Renderer_Flags) 26 | return SDL.C_Pointers.Renderer_Pointer with 27 | Import => True, 28 | Convention => C, 29 | External_Name => "SDL_CreateRenderer"; 30 | begin 31 | Rend.Internal := SDL_Create_Renderer (Get_Internal_Window (Window), C.int (Driver), Flags); 32 | end Create; 33 | 34 | procedure Create 35 | (Rend : in out Renderer; 36 | Window : in out SDL.Video.Windows.Window; 37 | Flags : in Renderer_Flags := Default_Renderer_Flags) is 38 | 39 | function SDL_Create_Renderer (W : in SDL.C_Pointers.Windows_Pointer; Index : in C.int; Flags : in Renderer_Flags) 40 | return SDL.C_Pointers.Renderer_Pointer with 41 | Import => True, 42 | Convention => C, 43 | External_Name => "SDL_CreateRenderer"; 44 | begin 45 | Rend.Internal := SDL_Create_Renderer (Get_Internal_Window (Window), -1, Flags); 46 | Rend.Owns := True; 47 | end Create; 48 | 49 | procedure Create 50 | (Rend : in out Renderer; 51 | Surface : in SDL.Video.Surfaces.Surface) is 52 | 53 | function SDL_Create_Software_Renderer (S : in SDL.Video.Surfaces.Internal_Surface_Pointer) 54 | return SDL.C_Pointers.Renderer_Pointer with 55 | Import => True, 56 | Convention => C, 57 | External_Name => "SDL_CreateSoftwareRenderer"; 58 | begin 59 | Rend.Internal := SDL_Create_Software_Renderer (Get_Internal_Surface (Surface)); 60 | Rend.Owns := True; 61 | end Create; 62 | end SDL.Video.Renderers.Makers; 63 | -------------------------------------------------------------------------------- /src/video/sdl-video-renderers-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Renderers.Makers 5 | -- 6 | -- Constructor subprograms for Renderers. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with SDL.Video.Surfaces; 9 | 10 | package SDL.Video.Renderers.Makers is 11 | pragma Preelaborate; 12 | 13 | procedure Create 14 | (Rend : in out Renderer; 15 | Window : in out SDL.Video.Windows.Window; 16 | Driver : in Driver_Indices; 17 | Flags : in Renderer_Flags := Default_Renderer_Flags); 18 | 19 | -- Specifically create a renderer using the first available driver. 20 | procedure Create 21 | (Rend : in out Renderer; 22 | Window : in out SDL.Video.Windows.Window; 23 | Flags : in Renderer_Flags := Default_Renderer_Flags); 24 | 25 | -- Create a software renderer using a surface. 26 | procedure Create 27 | (Rend : in out Renderer; 28 | Surface : in SDL.Video.Surfaces.Surface); 29 | 30 | -- SDL_CreateWindowAndRenderer 31 | end SDL.Video.Renderers.Makers; 32 | -------------------------------------------------------------------------------- /src/video/sdl-video-surfaces-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Surfaces.Makers 5 | -- 6 | -- Functions to create surface objects. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with System.Storage_Elements; 9 | with Ada.Strings.UTF_Encoding; 10 | 11 | package SDL.Video.Surfaces.Makers is 12 | pragma Preelaborate; 13 | 14 | package UTF_Strings renames Ada.Strings.UTF_Encoding; 15 | 16 | procedure Create (Self : in out Surface; 17 | Size : in SDL.Sizes; 18 | BPP : in Pixel_Depths; 19 | Red_Mask : in Colour_Masks; 20 | Blue_Mask : in Colour_Masks; 21 | Green_Mask : in Colour_Masks; 22 | Alpha_Mask : in Colour_Masks); 23 | 24 | generic 25 | type Element is private; 26 | type Element_Pointer is access all Element; 27 | procedure Create_From (Self : in out Surface; 28 | Pixels : in Element_Pointer; 29 | Size : in SDL.Sizes; 30 | BPP : in Pixel_Depths := Element'Size; 31 | Pitch : in System.Storage_Elements.Storage_Offset; 32 | Red_Mask : in Colour_Masks; 33 | Green_Mask : in Colour_Masks; 34 | Blue_Mask : in Colour_Masks; 35 | Alpha_Mask : in Colour_Masks); 36 | 37 | generic 38 | type Element is private; 39 | type Index is (<>); 40 | type Element_Array is array (Index range <>, Index range <>) of Element; 41 | procedure Create_From_Array (Self : in out Surface; 42 | Pixels : access Element_Array; 43 | Red_Mask : in Colour_Masks; 44 | Green_Mask : in Colour_Masks; 45 | Blue_Mask : in Colour_Masks; 46 | Alpha_Mask : in Colour_Masks); 47 | -- Note: I'm unsure what happen when packed (1- or -4bit) arrays are used here. 48 | -- So, at least check that they have whole number of bytes per row 49 | -- (E. g. even width in 4-bit) 50 | -- Note: There may be issue with 24-bit pixels (does SDL imply 4-byte alignment in this case?) 51 | 52 | -- TODO: This is likely a temporary place for this. It's likely I will add a Streams package. 53 | -- procedure Create (Self : in out Surface; File_Name : in String); 54 | 55 | procedure Create (Self : in out Surface; 56 | File_Name : in UTF_Strings.UTF_String); 57 | 58 | procedure Convert (Self : in out Surface; 59 | Src : SDL.Video.Surfaces.Surface; 60 | Pixel_Format : SDL.Video.Pixel_Formats.Pixel_Format_Access); 61 | private 62 | function Get_Internal_Surface (Self : in Surface) return Internal_Surface_Pointer with 63 | Export => True, 64 | Convention => Ada; 65 | 66 | -- Create a surface from an internal pointer, this pointer will be owned by something else, so we don't delete it. 67 | function Make_Surface_From_Pointer (S : in Internal_Surface_Pointer; Owns : in Boolean := False) return Surface with 68 | Export => True, 69 | Convention => Ada; 70 | 71 | -- TODO: SDL_ConvertSurfaceFormat 72 | -- TODO: SDL_CreateRGBSurfaceFrom 73 | end SDL.Video.Surfaces.Makers; 74 | -------------------------------------------------------------------------------- /src/video/sdl-video-textures-makers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Ada.Unchecked_Conversion; 5 | with Interfaces.C; 6 | private with SDL.C_Pointers; 7 | with SDL.Error; 8 | 9 | package body SDL.Video.Textures.Makers is 10 | package C renames Interfaces.C; 11 | 12 | use type SDL.C_Pointers.Texture_Pointer; 13 | 14 | function Get_Internal_Surface (Self : in SDL.Video.Surfaces.Surface) 15 | return SDL.Video.Surfaces.Internal_Surface_Pointer with 16 | Import => True, 17 | Convention => Ada; 18 | 19 | function Get_Internal_Renderer (Self : in SDL.Video.Renderers.Renderer) return SDL.C_Pointers.Renderer_Pointer with 20 | Import => True, 21 | Convention => Ada; 22 | 23 | procedure Create 24 | (Tex : in out Texture; 25 | Renderer : in SDL.Video.Renderers.Renderer; 26 | Format : in SDL.Video.Pixel_Formats.Pixel_Format_Names; 27 | Kind : in Kinds; 28 | Size : in SDL.Positive_Sizes) is 29 | 30 | -- Convert the Pixel_Format_Name to an Unsigned_32 because the compiler is changing the value somewhere along 31 | -- the lines from the start of this procedure to calling SDL_Create_Texture. 32 | function To_Unsigned32 is new Ada.Unchecked_Conversion (Source => SDL.Video.Pixel_Formats.Pixel_Format_Names, 33 | Target => Interfaces.Unsigned_32); 34 | 35 | function SDL_Create_Texture 36 | (R : in SDL.C_Pointers.Renderer_Pointer; 37 | Format : in Interfaces.Unsigned_32; 38 | Kind : in Kinds; 39 | W, H : in C.int) return SDL.C_Pointers.Texture_Pointer with 40 | Import => True, 41 | Convention => C, 42 | External_Name => "SDL_CreateTexture"; 43 | 44 | begin 45 | Tex.Internal := SDL_Create_Texture (Get_Internal_Renderer (Renderer), 46 | To_Unsigned32 (Format), 47 | Kind, 48 | Size.Width, 49 | Size.Height); 50 | 51 | if Tex.Internal = null then 52 | raise Texture_Error with SDL.Error.Get; 53 | end if; 54 | 55 | Tex.Size := Size; 56 | Tex.Pixel_Format := Format; 57 | end Create; 58 | 59 | procedure Create 60 | (Tex : in out Texture; 61 | Renderer : in SDL.Video.Renderers.Renderer; 62 | Surface : in SDL.Video.Surfaces.Surface) is 63 | 64 | function SDL_Create_Texture_From_Surface (R : in SDL.C_Pointers.Renderer_Pointer; 65 | S : in SDL.Video.Surfaces.Internal_Surface_Pointer) 66 | return SDL.C_Pointers.Texture_Pointer with 67 | Import => True, 68 | Convention => C, 69 | External_Name => "SDL_CreateTextureFromSurface"; 70 | begin 71 | Tex.Internal := SDL_Create_Texture_From_Surface (Get_Internal_Renderer (Renderer), 72 | Get_Internal_Surface (Surface)); 73 | 74 | if Tex.Internal = null then 75 | raise Texture_Error with SDL.Error.Get; 76 | end if; 77 | end Create; 78 | end SDL.Video.Textures.Makers; 79 | -------------------------------------------------------------------------------- /src/video/sdl-video-textures-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Surfaces.Textures 5 | -- 6 | -- Functions to create Texture objects. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with SDL.Video.Surfaces; 9 | with SDL.Video.Renderers; 10 | 11 | package SDL.Video.Textures.Makers is 12 | pragma Preelaborate; 13 | 14 | procedure Create 15 | (Tex : in out Texture; 16 | Renderer : in SDL.Video.Renderers.Renderer; 17 | Format : in SDL.Video.Pixel_Formats.Pixel_Format_Names; 18 | Kind : in Kinds; 19 | Size : in SDL.Positive_Sizes); 20 | 21 | procedure Create 22 | (Tex : in out Texture; 23 | Renderer : in SDL.Video.Renderers.Renderer; 24 | Surface : in SDL.Video.Surfaces.Surface); 25 | end SDL.Video.Textures.Makers; 26 | -------------------------------------------------------------------------------- /src/video/sdl-video-textures.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Textures 5 | -- 6 | -- Texture abstraction. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Finalization; 9 | private with SDL.C_Pointers; 10 | with SDL.Video.Palettes; 11 | with SDL.Video.Pixel_Formats; 12 | with SDL.Video.Pixels; 13 | with SDL.Video.Rectangles; 14 | 15 | package SDL.Video.Textures is 16 | pragma Preelaborate; 17 | 18 | Texture_Error : exception; 19 | 20 | -- Was SDL_TextureAccess. 21 | type Kinds is (Static, Streaming, Target) with 22 | Convention => C; 23 | 24 | type Scale_Modes is (Nearest, Linear, Best) with 25 | Convention => C; 26 | 27 | type Texture is new Ada.Finalization.Limited_Controlled with private; 28 | 29 | function Null_Texture return Texture; 30 | 31 | procedure Destroy (Self : in out Texture); 32 | 33 | -- Get the alpha value to be multiplied (modulated) into render copy operations. 34 | function Get_Alpha (Self : in Texture) return SDL.Video.Palettes.Colour_Component; 35 | procedure Set_Alpha (Self : in out Texture; Alpha : in SDL.Video.Palettes.Colour_Component); 36 | 37 | function Get_Blend_Mode (Self : in Texture) return Blend_Modes; 38 | procedure Set_Blend_Mode (Self : in out Texture; Mode : in Blend_Modes); 39 | 40 | function Get_Modulate_Colour (Self : in Texture) return SDL.Video.Palettes.RGB_Colour; 41 | procedure Set_Modulate_Colour (Self : in out Texture; Colour : in SDL.Video.Palettes.RGB_Colour); 42 | 43 | function Get_Scale_Mode (Self : in Texture) return Scale_Modes; 44 | procedure Set_Scale_Mode (Self : in out Texture; Scale_Mode : in Scale_Modes); 45 | 46 | -- TODO: SDL_GetTextureUserData 47 | 48 | -- TODO: Fix this. 49 | -- Lock returns access to pixel data as write-only. 50 | -- function Lock (Self : in out Texture; Pixel_Data : out SDL.Video.Pixels.Pixel) return Boolean with 51 | -- function Lock (Self : in out Texture; Area : in SDL.Video.Rectangles.Rectangle; 52 | -- Pixel_Data : out SDL.Video.Pixels.Pixel) return Boolean with 53 | -- Pre => Self.Locked = False, 54 | -- Post => Result = True and then Self.Locked = True; 55 | -- 56 | -- Lock should return an object representing the bitmap data. We should be able to access it like an array, 57 | -- e.g. (x, y) and also using an iterator, which traverses, top -> bottom, left -> right, 1 pixel at a time. We 58 | -- need to be able to do subimage copies using Ada's slices, e.g. bm1 (x .. x2, y .. y2) := bm2 (x .. x2, y .. y2) 59 | -- 60 | -- For YV12 format: 61 | -- 62 | 63 | -- package ARGB_8888_Array is new SDL.Video.Pixels.Texture_Data (Width => , Height => , Element => ); 64 | -- procedure Lock_Texture (Self : in out Texture; 65 | -- Pixels : out SDL.Video.Pixels.Pixel_ARGB_8888_Array_Access); 66 | 67 | -- Lock 68 | -- 69 | -- Lock the entire texture data. 70 | -- 71 | -- There will be multiple pixel formats, there should only be one Lock sub-program to handle them all. 72 | generic 73 | type Pixel_Pointer_Type is private; 74 | procedure Lock (Self : in out Texture; 75 | Pixels : out Pixel_Pointer_Type); 76 | 77 | -- Lock 78 | -- 79 | -- Lock a particular area of the texture data. 80 | generic 81 | type Pixel_Pointer_Type is private; 82 | procedure Lock_Area (Self : in out Texture; 83 | Area : in SDL.Video.Rectangles.Rectangle; 84 | Pixels : out Pixel_Pointer_Type; 85 | Pitch : out SDL.Video.Pixels.Pitches); 86 | 87 | procedure Unlock (Self : in out Texture); 88 | 89 | procedure Query (Self : in Texture; 90 | Pixel_Format_Name : out SDL.Video.Pixel_Formats.Pixel_Format_Names; 91 | Kind : out Kinds; 92 | Size : out SDL.Sizes); 93 | 94 | function Get_Pixel_Format (Self : in Texture) return SDL.Video.Pixel_Formats.Pixel_Format_Names; 95 | function Get_Kind (Self : in Texture) return Kinds; 96 | function Get_Size (Self : in Texture) return SDL.Sizes; 97 | 98 | -- SDL_UpdateTexture 99 | -- SDL_UpdateYUVTexture 100 | private 101 | type Texture is new Ada.Finalization.Limited_Controlled with 102 | record 103 | Internal : SDL.C_Pointers.Texture_Pointer := null; 104 | Owns : Boolean := True; 105 | Locked : Boolean := False; 106 | Size : SDL.Sizes := SDL.Zero_Size; 107 | Pixel_Format : SDL.Video.Pixel_Formats.Pixel_Format_Names := SDL.Video.Pixel_Formats.Pixel_Format_Unknown; 108 | end record; 109 | 110 | overriding 111 | procedure Finalize (Self : in out Texture); 112 | 113 | function Get_Internal_Texture (Self : in Texture) return SDL.C_Pointers.Texture_Pointer with 114 | Export => True, 115 | Convention => Ada; 116 | 117 | function Null_Texture return Texture is (Texture'(Ada.Finalization.Limited_Controlled with 118 | Internal => null, 119 | Owns => True, 120 | Size => SDL.Zero_Size, 121 | Pixel_Format => Pixel_Formats.Pixel_Format_Unknown, 122 | Locked => False)); 123 | end SDL.Video.Textures; 124 | -------------------------------------------------------------------------------- /src/video/sdl-video-vulkan.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Vulkan 5 | -- 6 | -- Vulkan functionality. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Ada.Strings.Unbounded; 9 | -- with Interfaces.C; 10 | 11 | with SDL.Video.Windows; 12 | 13 | generic 14 | -- These need to be the base C types from your Vulkan bindings. 15 | type Instance_Address_Type is private; 16 | 17 | Instance_Null : Instance_Address_Type; 18 | 19 | type Surface_Type is private; 20 | package SDL.Video.Vulkan is 21 | pragma Preelaborate; 22 | 23 | -- package C renames Interfaces.C; 24 | 25 | SDL_Vulkan_Error : exception; 26 | 27 | type Extension_Name_Arrays is array (Positive range <>) of Ada.Strings.Unbounded.Unbounded_String; 28 | 29 | Null_Extension_Name_Array : constant Extension_Name_Arrays (1 .. 1) := 30 | (others => Ada.Strings.Unbounded.Null_Unbounded_String); 31 | 32 | procedure Create_Surface (Window : in SDL.Video.Windows.Window; 33 | Instance : in Instance_Address_Type; 34 | Surface : out Surface_Type); 35 | 36 | procedure Get_Drawable_Size (Window : in SDL.Video.Windows.Window; Width, Height : out SDL.Natural_Dimension); 37 | 38 | function Get_Instance_Extensions (Window : in SDL.Video.Windows.Window) return Extension_Name_Arrays; 39 | 40 | function Get_Instance_Procedure_Address return Instance_Address_Type; 41 | 42 | procedure Load_Library; 43 | procedure Load_Library (Path : in String); 44 | procedure Unload_Library with 45 | Inline => True; 46 | end SDL.Video.Vulkan; 47 | -------------------------------------------------------------------------------- /src/video/sdl-video-windows-makers.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Interfaces.C; 5 | with Interfaces.C.Strings; 6 | private with SDL.C_Pointers; 7 | with SDL.Error; 8 | 9 | package body SDL.Video.Windows.Makers is 10 | package C renames Interfaces.C; 11 | 12 | use type SDL.C_Pointers.Windows_Pointer; 13 | 14 | procedure Create 15 | (Win : in out Window; 16 | Title : in Ada.Strings.UTF_Encoding.UTF_8_String; 17 | Position : in SDL.Natural_Coordinates; 18 | Size : in SDL.Positive_Sizes; 19 | Flags : in Window_Flags := OpenGL) is 20 | 21 | function SDL_Create 22 | (Title : C.Strings.chars_ptr; 23 | X, Y, W, H : in C.int; 24 | F : in Window_Flags) return SDL.C_Pointers.Windows_Pointer with 25 | Import => True, 26 | Convention => C, 27 | External_Name => "SDL_CreateWindow"; 28 | 29 | C_Title_Str : C.Strings.chars_ptr := C.Strings.New_String (Title); 30 | begin 31 | Win.Internal := SDL_Create (C_Title_Str, Position.X, Position.Y, Size.Width, Size.Height, Flags); 32 | 33 | C.Strings.Free (C_Title_Str); 34 | 35 | if Win.Internal = null then 36 | raise Window_Error with SDL.Error.Get; 37 | end if; 38 | 39 | Increment_Windows; 40 | end Create; 41 | 42 | procedure Create 43 | (Win : in out Window; 44 | Title : in Ada.Strings.UTF_Encoding.UTF_8_String; 45 | X : in SDL.Natural_Coordinate; 46 | Y : in SDL.Natural_Coordinate; 47 | Width : in SDL.Positive_Dimension; 48 | Height : in SDL.Positive_Dimension; 49 | Flags : in Window_Flags := OpenGL) is 50 | begin 51 | Create (Win, Title, SDL.Natural_Coordinates'(X, Y), SDL.Positive_Sizes'(Width, Height), Flags); 52 | end Create; 53 | 54 | procedure Create (Win : in out Window; Native : in Native_Window) is 55 | function SDL_Create_Window_From (Native : Native_Window) return SDL.C_Pointers.Windows_Pointer with 56 | Import => True, 57 | Convention => C, 58 | External_Name => "SDL_CreateWindowFrom"; 59 | begin 60 | Win.Internal := SDL_Create_Window_From (Native); 61 | Win.Owns := True; 62 | 63 | if Win.Internal = null then 64 | raise Window_Error with SDL.Error.Get; 65 | end if; 66 | 67 | Increment_Windows; 68 | end Create; 69 | end SDL.Video.Windows.Makers; 70 | -------------------------------------------------------------------------------- /src/video/sdl-video-windows-makers.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Windows.Makers 5 | -- 6 | -- Constructor subprograms which don't dispatch for Window types. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | package SDL.Video.Windows.Makers is 9 | pragma Preelaborate; 10 | 11 | -- Create a window with the specified title, position, dimensions and 12 | -- flags. Put the result in Win. 13 | -- 14 | -- Raise a SDL.Video.Windows.Window_Error if window creation failed. 15 | procedure Create 16 | (Win : in out Window; 17 | Title : in Ada.Strings.UTF_Encoding.UTF_8_String; 18 | Position : in SDL.Natural_Coordinates; 19 | Size : in SDL.Positive_Sizes; 20 | Flags : in Window_Flags := OpenGL); 21 | 22 | -- A small wrapper around the above procedure. 23 | procedure Create 24 | (Win : in out Window; 25 | Title : in Ada.Strings.UTF_Encoding.UTF_8_String; 26 | X : in SDL.Natural_Coordinate; 27 | Y : in SDL.Natural_Coordinate; 28 | Width : in SDL.Positive_Dimension; 29 | Height : in SDL.Positive_Dimension; 30 | Flags : in Window_Flags := OpenGL) with 31 | Inline => True; 32 | 33 | -- Create a window from an existing window created in some other way. 34 | -- See: https://github.com/Lucretia/sdlada/issues/16#issuecomment-364142941 35 | procedure Create (Win : in out Window; Native : in Native_Window) with 36 | Inline => True; 37 | 38 | end SDL.Video.Windows.Makers; 39 | -------------------------------------------------------------------------------- /src/video/sdl-video-windows-manager.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | package body SDL.Video.Windows.Manager is 5 | function Get_WM_Info (Win : in Window; Info : out WM_Info) return Boolean is 6 | function SDL_Get_Window_WM_Info (W : in SDL.C_Pointers.Windows_Pointer; Info : out WM_Info) return SDL_Bool with 7 | Import => True, 8 | Convention => C, 9 | External_Name => "SDL_GetWindowWMInfo"; 10 | begin 11 | return To_Boolean (SDL_Get_Window_WM_Info (Win.Internal, Info)); 12 | end Get_WM_Info; 13 | end SDL.Video.Windows.Manager; 14 | -------------------------------------------------------------------------------- /src/video/sdl-video-windows-manager.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video.Windows.Manager 5 | -- 6 | -- Access to the underlying window system. 7 | -- 8 | -- Due to the nature of free OSes like Linux, one user may be using X11, another XCB, another Wayland and another 9 | -- using Mir. We don't want to use build specific data for all these three, that makes sense for the varying OSes, 10 | -- such as Linux, Windows, MacOS X, etc. So, if building on Windows, the compiler should only allow access to the 11 | -- Windows/WinRT specific stuff, Linux, then X11/Wayland/Mir, etc. 12 | -------------------------------------------------------------------------------------------------------------------- 13 | with Interfaces.C; 14 | with SDL.Versions; 15 | 16 | package SDL.Video.Windows.Manager is 17 | pragma Preelaborate; 18 | 19 | type WM_Types is (WM_Unknown, 20 | WM_Windows, 21 | WM_X11, 22 | WM_Direct_FB, 23 | WM_Cocoa, 24 | WM_UI_Kit, 25 | WM_Wayland, 26 | WM_Mir, 27 | WM_Win_RT, 28 | WM_Android) with 29 | Convention => C; 30 | 31 | type C_Address is access all Interfaces.Unsigned_32 with 32 | Convention => C; 33 | 34 | -- These are dummy types that (should) match what a real binding would provide so that the end user can 35 | -- convert these using Unchecked_Conversion to pass into any other API's. 36 | package Windows is 37 | type HWNDs is new C_Address; 38 | type HDCs is new C_Address; 39 | end Windows; 40 | 41 | -- WinRT only available since version 2.0.3. 42 | package Win_RT is 43 | type Inspectable is new C_Address; 44 | end Win_RT; 45 | 46 | package X11 is 47 | type Display is new C_Address; 48 | type Window is new Interfaces.Unsigned_32; 49 | end X11; 50 | 51 | package Direct_FB is 52 | type Direct_FB is new C_Address; 53 | type Direct_FB_Window is new C_Address; 54 | type Direct_FB_Surface is new C_Address; 55 | end Direct_FB; 56 | 57 | package Cocoa is 58 | type NS_Window is new C_Address; 59 | end Cocoa; 60 | 61 | package UI_Kit is 62 | package C renames Interfaces.C; 63 | 64 | type Window is new C_Address; 65 | 66 | Frame_Buffer : C.unsigned; 67 | Colour_Buffer : C.unsigned; 68 | Resolve_Frame_Buffer : C.unsigned; 69 | end UI_Kit; 70 | 71 | -- Wayland only available since version 2.0.2. 72 | package Wayland is 73 | type Display is new C_Address; 74 | type Surface is new C_Address; 75 | type Shell_Surface is new C_Address; 76 | end Wayland; 77 | 78 | -- Mir only available since version 2.0.2. 79 | package Mir is 80 | type Connection is new C_Address; 81 | type Surface is new C_Address; 82 | end Mir; 83 | 84 | -- Android only available since version 2.0.4. 85 | package Android is 86 | type Native_Window is new C_Address; 87 | type EGL_Surface is new C_Address; 88 | end Android; 89 | 90 | type Information (WM : WM_Types) is 91 | record 92 | case WM is 93 | when WM_Unknown => 94 | null; 95 | when WM_Windows => 96 | HWND : Windows.HWNDs; 97 | HDC : Windows.HDCs; 98 | when WM_Win_RT => 99 | RT_Inspectable : Win_RT.Inspectable; 100 | when WM_X11 => 101 | X11_Display : X11.Display; 102 | X11_Window : X11.Window; 103 | when WM_Direct_FB => 104 | DFB_Main_Interface : Direct_FB.Direct_FB; 105 | DFB_Window : Direct_FB.Direct_FB_Window; 106 | DFB_Surface : Direct_FB.Direct_FB_Surface; 107 | when WM_Cocoa => 108 | Cocoa_Window : Cocoa.NS_Window; 109 | when WM_UI_Kit => 110 | UIK_Window : UI_Kit.Window; 111 | UIK_Frame_Buffer : UI_Kit.Window; 112 | UIK_Colour_Buffer : UI_Kit.Window; 113 | UIK_Resolve_Frame_Buffer : UI_Kit.Window; 114 | when WM_Wayland => 115 | Wayland_Display : Wayland.Display; 116 | Wayland_Surface : Wayland.Surface; 117 | Wayland_Shell_Surface : Wayland.Shell_Surface; 118 | when WM_Mir => 119 | Mir_Connection : Mir.Connection; 120 | Mir_Surface : Mir.Surface; 121 | when WM_Android => 122 | Android_Window : Android.Native_Window; 123 | Android_Surface : Android.EGL_Surface; 124 | end case; 125 | end record with 126 | Unchecked_Union; 127 | 128 | type WM_Info is 129 | record 130 | Version : SDL.Versions.Version; 131 | Sub_System : WM_Types; 132 | Info : Information (WM => WM_Unknown); 133 | end record with 134 | Convention => C; 135 | 136 | function Get_WM_Info (Win : in Window; Info : out WM_Info) return Boolean with 137 | Inline => True; 138 | end SDL.Video.Windows.Manager; 139 | -------------------------------------------------------------------------------- /src/video/sdl-video.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | 5 | with Interfaces.C.Strings; 6 | with SDL.Error; 7 | 8 | package body SDL.Video is 9 | 10 | function Is_Screen_Saver_Enabled return Boolean is 11 | function SDL_Is_Screen_Saver_Enabled return C.int with 12 | Import => True, 13 | Convention => C, 14 | External_Name => "SDL_IsScreenSaverEnabled"; 15 | begin 16 | return (if SDL_Is_Screen_Saver_Enabled = 1 then True else False); 17 | end Is_Screen_Saver_Enabled; 18 | 19 | function Initialise (Name : in String) return Boolean is 20 | function SDL_Video_Init (C_Name : in C.Strings.chars_ptr) return C.int with 21 | Import => True, 22 | Convention => C, 23 | External_Name => "SDL_VideoInit"; 24 | 25 | function SDL_Video_Init (C_Name : in C.char_array) return C.int with 26 | Import => True, 27 | Convention => C, 28 | External_Name => "SDL_VideoInit"; 29 | 30 | Result : C.int; 31 | begin 32 | if Name /= "" then 33 | Result := SDL_Video_Init (C.To_C (Name)); 34 | else 35 | Result := SDL_Video_Init (C_Name => C.Strings.Null_Ptr); 36 | end if; 37 | 38 | return (Result = Success); 39 | end Initialise; 40 | 41 | function Total_Drivers return Positive is 42 | function SDL_Get_Num_Video_Drivers return C.int with 43 | Import => True, 44 | Convention => C, 45 | External_Name => "SDL_GetNumVideoDrivers"; 46 | 47 | Num : constant C.int := SDL_Get_Num_Video_Drivers; 48 | begin 49 | if Num < 0 then 50 | raise Video_Error with SDL.Error.Get; 51 | end if; 52 | 53 | return Positive (Num); 54 | end Total_Drivers; 55 | 56 | function Driver_Name (Index : in Positive) return String is 57 | function SDL_Get_Video_Driver (I : in C.int) return C.Strings.chars_ptr with 58 | Import => True, 59 | Convention => C, 60 | External_Name => "SDL_GetVideoDriver"; 61 | 62 | -- Index is zero based, so need to subtract 1 to correct it. 63 | C_Str : constant C.Strings.chars_ptr := SDL_Get_Video_Driver (C.int (Index) - 1); 64 | begin 65 | return C.Strings.Value (C_Str); 66 | end Driver_Name; 67 | 68 | function Current_Driver_Name return String is 69 | function SDL_Get_Current_Video_Driver return C.Strings.chars_ptr with 70 | Import => True, 71 | Convention => C, 72 | External_Name => "SDL_GetCurrentVideoDriver"; 73 | 74 | C_Str : constant C.Strings.chars_ptr := SDL_Get_Current_Video_Driver; 75 | 76 | use type C.Strings.chars_ptr; 77 | begin 78 | if C_Str = C.Strings.Null_Ptr then 79 | raise Video_Error with SDL.Error.Get; 80 | end if; 81 | 82 | return C.Strings.Value (C_Str); 83 | end Current_Driver_Name; 84 | end SDL.Video; 85 | -------------------------------------------------------------------------------- /src/video/sdl-video.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL.Video 5 | -- 6 | -- Common display and video driver functionality. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with Interfaces.C; 9 | 10 | package SDL.Video is 11 | pragma Preelaborate; 12 | 13 | package C renames Interfaces.C; 14 | 15 | Video_Error : exception; 16 | 17 | -- subtype Coordinate is C.int; 18 | 19 | type Blend_Modes is (None, Alpha_Blend, Additive, Colour_Modulate, Multiply) with 20 | Convention => C; 21 | 22 | for Blend_Modes use 23 | (None => 16#0000_0000#, 24 | Alpha_Blend => 16#0000_0001#, 25 | Additive => 16#0000_0002#, 26 | Colour_Modulate => 16#0000_0004#, 27 | Multiply => 16#0000_0008#); 28 | 29 | -- Screen saver information. 30 | procedure Enable_Screen_Saver with 31 | Import => True, 32 | Convention => C, 33 | External_Name => "SDL_EnableScreenSaver"; 34 | 35 | procedure Disable_Screen_Saver with 36 | Import => True, 37 | Convention => C, 38 | External_Name => "SDL_DisableScreenSaver"; 39 | 40 | function Is_Screen_Saver_Enabled return Boolean with 41 | Inline => True; 42 | 43 | -- Video drivers. 44 | function Initialise (Name : in String) return Boolean; 45 | 46 | procedure Finalise with 47 | Import => True, 48 | Convention => C, 49 | External_Name => "SDL_VideoQuit"; 50 | 51 | function Total_Drivers return Positive; 52 | 53 | function Driver_Name (Index : in Positive) return String; 54 | 55 | function Current_Driver_Name return String; 56 | end SDL.Video; 57 | -------------------------------------------------------------------------------- /src/windows/sdl-platform-get.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Windows implementation. 5 | -------------------------------------------------------------------------------------------------------------------- 6 | separate (SDL.Platform) 7 | function Get return Platforms is 8 | begin 9 | return Windows; 10 | end Get; 11 | -------------------------------------------------------------------------------- /test/alire.toml: -------------------------------------------------------------------------------- 1 | name = "test" 2 | description = "Test suite for SDLAda." 3 | version = "0.1.0-dev" 4 | 5 | authors = ["Luke A. Guest"] 6 | maintainers = ["Luke A. Guest "] 7 | maintainers-logins = ["Lucretia"] 8 | licenses = "Zlib" 9 | website = "https://github.com/ada-game-framework" 10 | tags = ["tests", "sdl"] 11 | 12 | executables = ["test"] 13 | 14 | [[depends-on]] 15 | aunit = "^24.0.0" 16 | sdlada = "^2.3.1" 17 | 18 | [[pins]] 19 | sdlada = { path='..' } 20 | -------------------------------------------------------------------------------- /test/src/colour.c: -------------------------------------------------------------------------------- 1 | /*********************************************************************************************************************** 2 | * This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | **********************************************************************************************************************/ 4 | #include 5 | 6 | SDL_Color test_colour = { 0xff, 0xdd, 0xaa, 0x88 }; 7 | -------------------------------------------------------------------------------- /test/src/colour_test_cases.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Colour_Test_Cases 5 | -------------------------------------------------------------------------------------------------------------------- 6 | with AUnit.Assertions; use AUnit.Assertions; 7 | 8 | package body Colour_Test_Cases is 9 | overriding 10 | function Name (Test : Colour_Test_Case) return Message_String is 11 | pragma Unreferenced (Test); -- TODO: Fix me! 12 | begin 13 | return Format ("Colour test"); 14 | end Name; 15 | 16 | overriding 17 | procedure Run_Test (Test : in out Colour_Test_Case) is 18 | pragma Unreferenced (Test); -- TODO: Fix me! 19 | 20 | use type SDL.Video.Palettes.Colour_Component; 21 | 22 | Colour : constant SDL.Video.Palettes.Colour := (Red => 16#FF#, Green => 16#DD#, Blue => 16#AA#, Alpha => 16#88#); 23 | begin 24 | Assert (Colour.Red = C_Test.Red, "Red values do not match"); 25 | Assert (Colour.Green = C_Test.Green, "Green values do not match"); 26 | Assert (Colour.Blue = C_Test.Blue, "Blue values do not match"); 27 | Assert (Colour.Alpha = C_Test.Alpha, "Alpha values do not match"); 28 | end Run_Test; 29 | end Colour_Test_Cases; 30 | -------------------------------------------------------------------------------- /test/src/colour_test_cases.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Colour_Test_Cases 5 | -- 6 | -- Tests to check whether the memory layout of the pixel formats is correct. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with AUnit; use AUnit; 9 | with AUnit.Simple_Test_Cases; 10 | with SDL.Video.Palettes; 11 | 12 | package Colour_Test_Cases is 13 | type Colour_Test_Case is new AUnit.Simple_Test_Cases.Test_Case with null record; 14 | 15 | overriding 16 | function Name (Test : Colour_Test_Case) return Message_String; 17 | 18 | overriding 19 | procedure Run_Test (Test : in out Colour_Test_Case); 20 | private 21 | C_Test : constant SDL.Video.Palettes.Colour with 22 | Import => True, 23 | Convention => C, 24 | External_Name => "test_colour"; 25 | end Colour_Test_Cases; 26 | -------------------------------------------------------------------------------- /test/src/pixel_formats.c: -------------------------------------------------------------------------------- 1 | /*********************************************************************************************************************** 2 | * This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | **********************************************************************************************************************/ 4 | #include 5 | 6 | const int c_unknown = SDL_PIXELFORMAT_UNKNOWN; 7 | const int c_index1lsb = SDL_PIXELFORMAT_INDEX1LSB; 8 | const int c_index1msb = SDL_PIXELFORMAT_INDEX1MSB; 9 | const int c_index4lsb = SDL_PIXELFORMAT_INDEX4LSB; 10 | const int c_index4msb = SDL_PIXELFORMAT_INDEX4MSB; 11 | const int c_index8 = SDL_PIXELFORMAT_INDEX8; 12 | const int c_rgb332 = SDL_PIXELFORMAT_RGB332; 13 | const int c_rgb444 = SDL_PIXELFORMAT_RGB444; 14 | const int c_rgb555 = SDL_PIXELFORMAT_RGB555; 15 | const int c_bgr555 = SDL_PIXELFORMAT_BGR555; 16 | const int c_argb4444 = SDL_PIXELFORMAT_ARGB4444; 17 | const int c_rgba4444 = SDL_PIXELFORMAT_RGBA4444; 18 | const int c_abgr4444 = SDL_PIXELFORMAT_ABGR4444; 19 | const int c_bgra4444 = SDL_PIXELFORMAT_BGRA4444; 20 | const int c_argb1555 = SDL_PIXELFORMAT_ARGB1555; 21 | const int c_rgba5551 = SDL_PIXELFORMAT_RGBA5551; 22 | const int c_abgr1555 = SDL_PIXELFORMAT_ABGR1555; 23 | const int c_bgra5551 = SDL_PIXELFORMAT_BGRA5551; 24 | const int c_rgb565 = SDL_PIXELFORMAT_RGB565; 25 | const int c_bgr565 = SDL_PIXELFORMAT_BGR565; 26 | const int c_rgb24 = SDL_PIXELFORMAT_RGB24; 27 | const int c_bgr24 = SDL_PIXELFORMAT_BGR24; 28 | const int c_rgb888 = SDL_PIXELFORMAT_RGB888; 29 | const int c_rgbx8888 = SDL_PIXELFORMAT_RGBX8888; 30 | const int c_bgr888 = SDL_PIXELFORMAT_BGR888; 31 | const int c_bgrx8888 = SDL_PIXELFORMAT_BGRX8888; 32 | const int c_argb8888 = SDL_PIXELFORMAT_ARGB8888; 33 | const int c_rgba8888 = SDL_PIXELFORMAT_RGBA8888; 34 | const int c_abgr8888 = SDL_PIXELFORMAT_ABGR8888; 35 | const int c_bgra8888 = SDL_PIXELFORMAT_BGRA8888; 36 | const int c_argb2101010 = SDL_PIXELFORMAT_ARGB2101010; 37 | const int c_yv12 = SDL_PIXELFORMAT_YV12; 38 | const int c_iyuv = SDL_PIXELFORMAT_IYUV; 39 | const int c_yuy2 = SDL_PIXELFORMAT_YUY2; 40 | const int c_uyvy = SDL_PIXELFORMAT_UYVY; 41 | const int c_yvyu = SDL_PIXELFORMAT_YVYU; 42 | -------------------------------------------------------------------------------- /test/src/sdl_suites.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL_Suites 5 | -- 6 | -- Tests to check the Ada 2012 bindings for correctness. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with AUnit; use AUnit; 9 | with Pixel_Format_Test_Cases; 10 | with Colour_Test_Cases; 11 | 12 | package body SDL_Suites is 13 | use Test_Suites; 14 | 15 | Pixel_Tests : aliased Pixel_Format_Test_Cases.Pixel_Format_Test_Case; 16 | Colour_Tests : aliased Colour_Test_Cases.Colour_Test_Case; 17 | 18 | function Suite return Access_Test_Suite is 19 | Result : constant Access_Test_Suite := AUnit.Test_Suites.New_Suite; 20 | begin 21 | Result.Add_Test (Pixel_Tests'Access); 22 | Result.Add_Test (Colour_Tests'Access); 23 | 24 | return Result; 25 | end Suite; 26 | end SDL_Suites; 27 | -------------------------------------------------------------------------------- /test/src/sdl_suites.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- SDL_Suites 5 | -- 6 | -- Tests to check the Ada 2012 bindings for correctness. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with AUnit.Test_Suites; 9 | 10 | package SDL_Suites is 11 | function Suite return AUnit.Test_Suites.Access_Test_Suite; 12 | end SDL_Suites; 13 | -------------------------------------------------------------------------------- /test/src/test.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Unit_Tests 5 | -- 6 | -- Test runner. 7 | -------------------------------------------------------------------------------------------------------------------- 8 | with AUnit.Run; 9 | with AUnit.Reporter.Text; 10 | with SDL_Suites; 11 | 12 | procedure Test is 13 | procedure Run is new AUnit.Run.Test_Runner (SDL_Suites.Suite); 14 | 15 | Reporter : AUnit.Reporter.Text.Text_Reporter; 16 | begin 17 | Reporter.Set_Use_ANSI_Colors (True); 18 | 19 | Run (Reporter); 20 | end Test; 21 | -------------------------------------------------------------------------------- /test/test.gpr: -------------------------------------------------------------------------------- 1 | with "config/test_config.gpr"; 2 | 3 | project Test is 4 | for Languages use ("Ada", "C"); 5 | for Source_Dirs use ("src/", "config/"); 6 | for Object_Dir use "obj/" & Test_Config.Build_Profile; 7 | for Create_Missing_Dirs use "True"; 8 | for Exec_Dir use "bin"; 9 | for Main use ("test.adb"); 10 | 11 | package Compiler is 12 | for Default_Switches ("Ada") use Test_Config.Ada_Compiler_Switches & 13 | ("-gnat2022", "-gnatyM120", "-gnatyx"); 14 | end Compiler; 15 | 16 | package Binder is 17 | for Switches ("Ada") use ("-Es"); -- Symbolic traceback 18 | end Binder; 19 | 20 | package Install is 21 | for Artifacts (".") use ("share"); 22 | end Install; 23 | end Test; 24 | -------------------------------------------------------------------------------- /tools/utils.adb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | with Ada.Text_IO; use Ada.Text_IO; 5 | 6 | package body Utils is 7 | procedure Comment_Dash (Total : in Positive; Indent : in Natural := 0; New_Line : Boolean := True) is 8 | begin 9 | if Indent > 0 then 10 | for Index in 1 .. Indent loop 11 | Put (' '); 12 | end loop; 13 | end if; 14 | 15 | for Index in 1 .. Total loop 16 | Put ('-'); 17 | end loop; 18 | 19 | if New_Line then 20 | Ada.Text_IO.New_Line; 21 | end if; 22 | end Comment_Dash; 23 | 24 | procedure Comment (Indent : in Natural; Text : in String; New_Line : in Boolean := True) is 25 | begin 26 | if Indent > 0 then 27 | for Index in 1 .. Indent loop 28 | Put (' '); 29 | end loop; 30 | end if; 31 | 32 | if Text = "" then 33 | Put ("--"); 34 | else 35 | Put ("-- " & Text); 36 | end if; 37 | 38 | if New_Line then 39 | Ada.Text_IO.New_Line; 40 | end if; 41 | end Comment; 42 | 43 | procedure Output_Field (Text : in String; 44 | Width : in Integer; 45 | Indent : in Natural; 46 | Separator : in String := " "; 47 | Truncate : in Boolean := False) is 48 | Field_Index : constant Positive_Count := Col; 49 | begin 50 | if Indent > 0 then 51 | for Index in 1 .. Indent loop 52 | Put (' '); 53 | end loop; 54 | end if; 55 | 56 | if Text'Length + Indent > Width and Truncate then 57 | Put (Text (Text'First .. Width) & Separator); 58 | else 59 | Put (Text & Separator); 60 | end if; 61 | 62 | Set_Col (Field_Index + Positive_Count (Width + Indent)); 63 | end Output_Field; 64 | end Utils; 65 | -------------------------------------------------------------------------------- /tools/utils.ads: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------------------------------------------- 2 | -- This source code is subject to the Zlib license, see the LICENCE file in the root of this directory. 3 | -------------------------------------------------------------------------------------------------------------------- 4 | -- Utils 5 | -------------------------------------------------------------------------------------------------------------------- 6 | package Utils is 7 | procedure Comment_Dash (Total : in Positive; Indent : in Natural := 0; New_Line : Boolean := True); 8 | 9 | procedure Comment (Indent : in Natural; Text : in String; New_Line : in Boolean := True); 10 | 11 | procedure Output_Field (Text : in String; 12 | Width : in Integer; 13 | Indent : in Natural; 14 | Separator : in String := " "; 15 | Truncate : in Boolean := False); 16 | end Utils; 17 | --------------------------------------------------------------------------------