xolatile/xhads
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity
4dfb96e3ad
xhads/source/core.adb
xolatile 76f09c0936 I do not even know...
2024-03-22 00:37:54 -04:00

626 lines
30 KiB
Ada
Raw Blame History

with core;
use core;
package body core is
------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
type color_range is range 0 .. 2 ** 8 - 1;
type logical is new boolean;
--
for logical'size use 32;
for color_range'size use 8;
--
type trace_log_level is (
log_all, log_trace, log_debug, log_info, log_warning, log_error,
log_fatal, log_none
) with convention => c;
--
type mouse_button is (
mouse_button_left, mouse_button_right, mouse_button_middle, mouse_button_side, mouse_button_extra, mouse_button_forward,
mouse_button_back
) with convention => c;
--
type vessel is record x, y : float; end record with convention => c_pass_by_copy;
type color is record r, g, b, a : color_range; end record with convention => c_pass_by_copy;
type rectangle is record x ,y, width, height : float; end record with convention => c_pass_by_copy;
type texture is record id : natural; width, height, mipmaps, format : integer; end record with convention => c_pass_by_copy;
type font is record base, count, pad : integer; data : texture; r : access rectangle; non : access natural; end record with convention => c_pass_by_copy;
type stream is record buffer, processor : access natural; rate, size, channels : natural; end record with convention => c_pass_by_copy;
type sound is record data : stream; frame : natural; end record with convention => c_pass_by_copy;
--
procedure open_window (width, height : integer; title : string) with import => true, convention => c, external_name => "InitWindow";
procedure close_window with import => true, convention => c, external_name => "CloseWindow";
--
procedure open_audio_device with import => true, convention => c, external_name => "InitAudioDevice";
procedure close_audio_device with import => true, convention => c, external_name => "CloseAudioDevice";
--
procedure set_exit_key (key : integer) with import => true, convention => c, external_name => "SetExitKey";
function exit_key_is_pressed return logical with import => true, convention => c, external_name => "WindowShouldClose";
function get_key_pressed return integer with import => true, convention => c, external_name => "GetKeyPressed";
function mouse_button_is_pressed (button : mouse_button) return logical with import => true, convention => c, external_name => "IsMouseButtonPressed";
function mouse_button_is_released (button : mouse_button) return logical with import => true, convention => c, external_name => "IsMouseButtonReleased";
function get_mouse_x return integer with import => true, convention => c, external_name => "GetMouseX";
function get_mouse_y return integer with import => true, convention => c, external_name => "GetMouseY";
function get_mouse_vessel return vessel with import => true, convention => c, external_name => "GetMousePosition";
function get_screen_width return integer with import => true, convention => c, external_name => "GetScreenWidth";
function get_screen_height return integer with import => true, convention => c, external_name => "GetScreenHeight";
--
procedure clear_background (tint : color) with import => true, convention => c, external_name => "ClearBackground";
procedure begin_drawing with import => true, convention => c, external_name => "BeginDrawing";
procedure end_drawing with import => true, convention => c, external_name => "EndDrawing";
--
procedure set_target_fps (fps : integer) with import => true, convention => c, external_name => "SetTargetFPS";
function get_fps return integer with import => true, convention => c, external_name => "GetFPS";
procedure randomization (seed : natural) with import => true, convention => c, external_name => "SetRandomSeed";
function get_random (minimum, maximum : integer) return integer with import => true, convention => c, external_name => "GetRandomValue";
--
procedure take_screenshot (path : string := "screenshot.png") with import => true, convention => c, external_name => "TakeScreenshot";
--
procedure set_trace_log_level (level : trace_log_level) with import => true, convention => c, external_name => "SetTraceLogLevel";
--
function load_texture (path : string) return texture with import => true, convention => c, external_name => "LoadTexture";
function load_sound (path : string) return sound with import => true, convention => c, external_name => "LoadSound";
function load_font (path : string) return font with import => true, convention => c, external_name => "LoadFont";
--
procedure unload_texture (data : texture) with import => true, convention => c, external_name => "UnloadTexture";
procedure unload_sound (data : sound) with import => true, convention => c, external_name => "UnloadSound";
procedure unload_font (data : font) with import => true, convention => c, external_name => "UnloadFont";
--
procedure draw_line (x0, y0, x1, y1 : integer; tint : color) with import => true, convention => c, external_name => "DrawLine";
--
procedure draw_rectangle (x, y, width, height : integer; tint : color) with import => true, convention => c, external_name => "DrawRectangle";
--
procedure draw_image (data : texture; uv : rectangle; view : vessel; tint : color) with import => true, convention => c, external_name => "DrawTextureRec";
--
procedure draw_text (data : font; text : string; view : vessel; size, pad : float; tint : color) with import => true, convention => c, external_name => "DrawTextEx";
--
procedure play_sound (data : sound) with import => true, convention => c, external_name => "PlaySound";
procedure stop_sound (data : sound) with import => true, convention => c, external_name => "StopSound";
procedure pause_sound (data : sound) with import => true, convention => c, external_name => "PauseSound";
procedure resume_sound (data : sound) with import => true, convention => c, external_name => "ResumeSound";
------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
texture_count : integer := 0;
sound_count : integer := 0;
font_count : integer := 0;
type texture_data_array is array (natural range <>) of texture;
type sound_data_array is array (natural range <>) of sound;
type font_data_array is array (natural range <>) of font;
texture_array : access texture_data_array;
sound_array : access sound_data_array;
font_array : access font_data_array;
------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
procedure terminal (colour : in terminal_colour := white; effect : in terminal_effect := normal) is
format : string := character'val (27) & "[" & character'val (terminal_effect'pos (effect) + 48) & ";3" & character'val (terminal_colour'pos (colour) + 48) & "m";
begin
put (format);
end terminal;
------------------------------------------------------------------------------------------
procedure echo (status : in echo_status; message : in string) is
begin
if not echo_mark (status) then
return;
end if;
--
put ("[");
case status is
when failure => terminal (red, bold); put ("Failure");
when warning => terminal (yellow, bold); put ("Warning");
when success => terminal (green, bold); put ("Success");
when comment => terminal (grey, bold); put ("Comment");
when import => terminal (cyan, bold); put (" + ");
when export => terminal (pink, bold); put (" > ");
when deport => terminal (blue, bold); put (" - ");
when ray_ada => terminal (white, bold); put ("Ray-Ada");
end case;
terminal;
put_line ("] " & message);
end echo;
------------------------------------------------------------------------------------------
procedure dash is
begin
terminal (grey, bold);
put ("------------------------------------------------------------------------------------------");
put ("------------------------------------------------------------------------------------------");
terminal;
new_line;
end dash;
------------------------------------------------------------------------------------------
procedure semi_dash is
begin
terminal (grey, bold);
put (" ");
put ("------------------------------------------------------------------------------------------");
terminal;
new_line;
end semi_dash;
------------------------------------------------------------------------------------------
function flip_coin return integer is
begin
return (random_integer (0, 1));
end flip_coin;
------------------------------------------------------------------------------------------
function roll_dice return integer is
begin
return (random_integer (1, 6));
end roll_dice;
------------------------------------------------------------------------------------------
function by_chance (chance : in integer) return integer is
begin
return (random_integer (0, 100) mod chance);
end by_chance;
------------------------------------------------------------------------------------------
function c_string (ada_string : string) return string is
begin
return (ada_string & character'val (0));
end c_string;
------------------------------------------------------------------------------------------
function random_integer (minimum, maximum : in integer) return integer is
begin
return get_random (minimum, maximum);
end random_integer;
------------------------------------------------------------------------------------------
function clip (value, minimum, maximum : in integer) return integer is
begin
if value < minimum then return minimum; end if;
if value > maximum then return maximum; end if;
return value;
end clip;
------------------------------------------------------------------------------------------
function import_sprite (file_path : in string; frames, states : in integer) return sprite is
this : sprite;
begin
texture_array (texture_count) := load_texture (c_string (file_path));
--
texture_count := texture_count + 1;
this.index := texture_count - 1;
this.width := texture_array (this.index).width / states;
this.height := texture_array (this.index).height / frames;
this.frames := frames;
this.states := states;
--
return this;
end import_sprite;
------------------------------------------------------------------------------------------
function import_song (file_path : in string) return integer is
begin
sound_array (sound_count) := load_sound (c_string (file_path));
--
sound_count := sound_count + 1;
--
return sound_count - 1;
end import_song;
------------------------------------------------------------------------------------------
function import_glyphs (file_path : in string; size, pad : in integer) return glyphs is
this : glyphs;
begin
font_array (font_count) := load_font (c_string (file_path));
--
font_count := font_count + 1;
this.index := font_count - 1;
this.size := size;
this.pad := pad;
--
return this;
end import_glyphs;
------------------------------------------------------------------------------------------
procedure crop (data : in sprite; x, y, u, v, width, height : in integer) is
begin
render_sprite (data.index, x, y, u, v, width, height);
end crop;
------------------------------------------------------------------------------------------
procedure view (data : in sprite; x, y, u, v, width, height : in integer) is
--~crop_u, crop_v, crop_width, crop_height : integer;
begin
if x > u + width
or y > v + height
or x < u - data.width
or y < v - data.height then
return;
end if;
--
--~crop_width := data.width - (if x + data.width > u + width then (x + data.width) mod (u + width) else 0);
--~crop_height := data.height - (if y + data.height > v + height then (y + data.height) mod (v + height) else 0);
--
--~crop_u := (if x < u then data.width - u mod (x + data.width) else 0);
--~crop_v := (if y < v then data.height - v mod (y + data.height) else 0);
--~crop_u := (if x < u and x < u - data.width then data.width - (x + data.width) mod u else 0);
--~crop_v := (if y < v and y < v - data.height then data.height - (y + data.height) mod v else 0);
--~crop_u := data.width - (if x < u then (x + data.width) mod u else 0);
--~crop_v := data.height - (if y < v then (y + data.height) mod v else 0);
--~crop_u := data.width - (if x < u then u mod x else 0);
--~crop_v := data.height - (if y < v then v mod y else 0);
--
--~render_sprite (data.index, x, y, crop_u, crop_v, crop_width, crop_height);
render_sprite (data.index, x, y, 0, 0, data.width, data.height);
end view;
------------------------------------------------------------------------------------------
procedure draw (data : in sprite; x, y : in integer) is
begin
render_sprite (data.index, x, y, 0, 0, data.width, data.height);
end draw;
------------------------------------------------------------------------------------------
procedure move (data : in sprite; x, y, frame, state : in integer) is
begin
render_sprite (data.index, x, y, state * data.width, (animation_time mod frame) * data.height, data.width, data.height);
end move;
------------------------------------------------------------------------------------------
procedure line (origin, offset : in vector) is
begin
render_vector (origin.x, origin.y, origin.x + offset.x, origin.y + offset.y);
end line;
------------------------------------------------------------------------------------------
procedure write (text : in string; x, y : in integer; data : in glyphs; colour : in colour_range := 16#FFFFFFFF#) is
begin
render_string (text, x, y, colour, data.index, data.size, data.pad);
end write;
------------------------------------------------------------------------------------------
procedure debug (text : in string) is
begin
put_line ("> " & text);
end debug;
------------------------------------------------------------------------------------------
procedure hexagonal_grid (x, y, width, height : in integer; fill : in boolean) is
crop_width : constant integer := width mod hexagon_grid_sprite.width;
crop_height : constant integer := height mod hexagon_grid_sprite.height;
use_sprite : constant sprite := (if fill then hexagon_fill_sprite else hexagon_grid_sprite);
begin
for move_y in 0 .. height / hexagon_grid_sprite.height - 1
loop
for move_x in 0 .. width / hexagon_grid_sprite.width - 1
loop
draw (use_sprite, x + move_x * hexagon_grid_sprite.width, y + move_y * hexagon_grid_sprite.height);
end loop;
--
crop (use_sprite, x + width - crop_width, y + move_y * hexagon_grid_sprite.height, 0, 0, crop_width, hexagon_grid_sprite.height);
end loop;
--
for move_x in 0 .. width / hexagon_grid_sprite.width - 1
loop
crop (use_sprite, x + move_x * hexagon_grid_sprite.width, y + height - crop_height, 0, 0, hexagon_grid_sprite.width, crop_height);
end loop;
--
crop (use_sprite, x + width - crop_width, y + height - crop_height, 0, 0, crop_width, crop_height);
end hexagonal_grid;
------------------------------------------------------------------------------------------
function lowercase (text : in string) return string is
result : string (1 .. text'length);
begin
for index in text'range
loop
if text (index) in 'A' .. 'Z' then
result (index) := character'val (character'pos (text (index)) + 32);
else
result (index) := text (index);
end if;
end loop;
--
return result;
end lowercase;
------------------------------------------------------------------------------------------
function uppercase (text : in string) return string is
result : string (1 .. text'length);
begin
for index in text'range
loop
if text (index) in 'a' .. 'z' then
result (index) := character'val (character'pos (text (index)) - 32);
else
result (index) := text (index);
end if;
end loop;
--
return result;
end uppercase;
------------------------------------------------------------------------------------------
procedure draw_central_grid (x, y, width, height : in integer) is
begin
render_vector (width / 2 + x, y, width / 2 + x, height + y);
render_vector ( x, height / 2 + y, width + x, height / 2 + y);
end draw_central_grid;
------------------------------------------------------------------------------------------
procedure draw_squared_grid (x, y, width, height : in integer) is
offset : constant vector := (((width - base) / 2) mod base, ((height - base) / 2) mod base);
repeat : constant vector := (2 * (((width - base) / 2) / base) + 1, 2 * (((height - base) / 2) / base) + 1);
begin
for next in 0 .. repeat.y
loop
line ((x, y + offset.y + next * base), (width, 0));
end loop;
--
if repeat.y mod 4 = 1 then
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y ), (0, offset.y)); end loop;
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + height - offset.y), (0, offset.y)); end loop;
--
for step in 0 .. repeat.y / 2 - 1 loop
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + base + offset.y + 2 * step * base), (0, base)); end loop;
end loop;
for step in 0 .. repeat.y / 2 loop
for next in 0 .. repeat.x loop line ((x + offset.x + next * base, y + offset.y + 2 * step * base), (0, base)); end loop;
end loop;
else
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + next * base, y ), (0, offset.y)); end loop;
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + next * base, y + height - offset.y), (0, offset.y)); end loop;
--
for step in 0 .. repeat.y / 2 - 1 loop
for next in 0 .. repeat.x loop line ((x + offset.x + next * base, y + base + offset.y + 2 * step * base), (0, base)); end loop;
end loop;
for step in 0 .. repeat.y / 2 loop
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + offset.y + 2 * step * base), (0, base)); end loop;
end loop;
end if;
end draw_squared_grid;
------------------------------------------------------------------------------------------
procedure draw_hexagon_grid (x, y, width, height : in integer) is
offset : constant vector := (((width - base) / 2) mod base, ((height - base) / 2) mod base);
repeat : constant vector := (2 * (((width - base) / 2) / base) + 1, 2 * (((height - base) / 2) / base) + 1);
begin
for step in 0 .. repeat.y
loop
if step mod 2 = 1 then
for next in 0 .. repeat.x - 1
loop
line ((x + offset.x + base / 2 + next * base, y + offset.y + step * base + base / 4), (-base / 2, -base / 2));
line ((x + offset.x + base / 2 + next * base, y + offset.y + step * base + base / 4), ( base / 2, -base / 2));
end loop;
else
for next in 0 .. repeat.x - 1
loop
line ((x + offset.x + base / 2 + next * base, y + offset.y + step * base - base / 4), (-base / 2, base / 2));
line ((x + offset.x + base / 2 + next * base, y + offset.y + step * base - base / 4), ( base / 2, base / 2));
end loop;
end if;
end loop;
--
if repeat.y mod 4 = 1 then
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y ), (0, offset.y - base / 4)); end loop;
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + base / 4 + height - offset.y), (0, offset.y - base / 4)); end loop;
--
for step in 0 .. repeat.y / 2 - 1 loop
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + 5 * base / 4 + offset.y + 2 * step * base), (0, base / 2)); end loop;
end loop;
for step in 0 .. repeat.y / 2 loop
for next in 0 .. repeat.x loop line ((x + offset.x + next * base, y + base / 4 + offset.y + 2 * step * base), (0, base / 2)); end loop;
end loop;
else
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + next * base, y ), (0, offset.y)); end loop;
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + next * base, y + height - offset.y), (0, offset.y)); end loop;
--
for step in 0 .. repeat.y / 2 - 1 loop
for next in 0 .. repeat.x loop line ((x + offset.x + next * base, y + 5 * base / 4 + offset.y + 2 * step * base), (0, base / 2)); end loop;
end loop;
for step in 0 .. repeat.y / 2 loop
for next in 0 .. repeat.x - 1 loop line ((x + offset.x + base / 2 + next * base, y + base / 4 + offset.y + 2 * step * base), (0, base / 2)); end loop;
end loop;
end if;
end draw_hexagon_grid;
------------------------------------------------------------------------------------------
function read_text_box return string is
begin
return to_string (text_box.data);
end read_text_box;
------------------------------------------------------------------------------------------
procedure write_text_box (text : in string) is
begin
text_box.data := to_unbounded_string (text);
end write_text_box;
------------------------------------------------------------------------------------------
procedure render_sprite (sprite, x, y, u, v, width, height : in integer) is
begin
draw_image (data => texture_array (sprite),
uv => (float (u), float (v), float (width), float (height)),
view => (float (x), float (y)),
tint => (255, 255, 255, 255));
end render_sprite;
------------------------------------------------------------------------------------------
procedure render_string (text : in string; x, y : in integer; colour : in colour_range; index, size, pad : in integer) is
begin
draw_text (data => font_array (index),
text => c_string (text),
view => (float ((32 - size) / 2 + x), float ((32 - size) / 2 + y)),
size => float (size),
pad => float (pad),
tint => (255, 255, 255, 255));
end render_string;
------------------------------------------------------------------------------------------
procedure render_vector (x1, y1, x2, y2 : in integer) is
begin
draw_line (x1, y1, x2, y2, (0, 0, 0, 255));
end render_vector;
function window_width return integer is begin return get_screen_width; end window_width;
function window_height return integer is begin return get_screen_height; end window_height;
------------------------------------------------------------------------------------------
--~base ::= A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z;
procedure initialize is
begin
core.echo (core.comment, "Initializing core components...");
--
engine_active := true;
texture_array := new texture_data_array (0 .. 1600);
sound_array := new sound_data_array (0 .. 4);
font_array := new font_data_array (0 .. 4);
--
core.echo (core.ray_ada, "-- Setting trace log level to none (ignoring all default Raylib logs).");
set_trace_log_level (log_none);
core.echo (core.ray_ada, "-- Initializing Raylib window data...");
core.echo (core.ray_ada, "-- -- Window title : Chads of Might & Magic");
core.echo (core.ray_ada, "-- -- Window width : 1800");
core.echo (core.ray_ada, "-- -- Window height : 900");
open_window (1800, 900, "Chads of Might & Magic");
core.echo (core.ray_ada, "-- Initializing Raylib audio device data...");
open_audio_device;
--
randomization (25071997);
set_target_fps (60);
--
hexagon_grid_sprite := import_sprite ("./sprite/ui/hexagon_grid_tile.png", 1, 1);
hexagon_fill_sprite := import_sprite ("./sprite/ui/hexagon_fill_tile.png", 1, 1);
--
core.echo (core.success, "Initialized core components.");
end initialize;
------------------------------------------------------------------------------------------
procedure deinitialize is
begin
core.echo (core.comment, "Deinitializing core components...");
--
engine_active := false;
--
core.echo (core.deport, "-- -- Unloading Raylib" & integer'image (texture_count) & " textures.");
core.echo (core.deport, "-- -- Unloading Raylib" & integer'image (sound_count) & " sounds.");
core.echo (core.deport, "-- -- Unloading Raylib" & integer'image (font_count) & " fonts.");
--
for index in 0 .. texture_count - 1 loop unload_texture (texture_array (index)); end loop;
for index in 0 .. sound_count - 1 loop unload_sound (sound_array (index)); end loop;
for index in 0 .. font_count - 1 loop unload_font (font_array (index)); end loop;
--
core.echo (core.ray_ada, "-- Deinitializing Raylib audio device data...");
close_audio_device;
--
core.echo (core.ray_ada, "-- Deinitializing Raylib window data...");
close_window;
--
core.echo (core.success, "Deinitialized core components.");
end deinitialize;
------------------------------------------------------------------------------------------
procedure synchronize is
signal : integer := signal_code'pos (signal_none);
begin
global_time := global_time + 1;
global_time := global_time mod (gameplay_framerate * animation_framerate);
gameplay_time := global_time mod (gameplay_framerate);
animation_time := global_time / (gameplay_framerate / animation_framerate);
framerate := integer (get_fps);
signal := get_key_pressed;
cursor.x := get_mouse_x;
cursor.y := get_mouse_y;
--
end_drawing;
--
if exit_key_is_pressed then
engine_active := false;
end if;
--
if mouse_button_is_pressed (mouse_button_left) then cursor_mode := 1; end if;
if mouse_button_is_pressed (mouse_button_right) then cursor_mode := 2; end if;
if mouse_button_is_pressed (mouse_button_middle) then cursor_mode := 3; end if;
if mouse_button_is_released (mouse_button_left) then cursor_mode := 0; end if;
if mouse_button_is_released (mouse_button_right) then cursor_mode := 0; end if;
if mouse_button_is_released (mouse_button_middle) then cursor_mode := 0; end if;
--
case signal is
when 48 .. 57 => signal_mode := signal - 48 + signal_code'pos (signal_0);
when 65 .. 90 => signal_mode := signal - 65 + signal_code'pos (signal_a);
when 320 .. 329 => signal_mode := signal - 320 + signal_code'pos (signal_kp_0);
--
when 0 => signal_mode := signal_code'pos (signal_none);
when 32 => signal_mode := signal_code'pos (signal_space);
when 96 => signal_mode := signal_code'pos (signal_grave);
when 340 => signal_mode := signal_code'pos (signal_left_shift);
when 341 => signal_mode := signal_code'pos (signal_left_control);
when 333 => signal_mode := signal_code'pos (signal_kp_subtract);
when 334 => signal_mode := signal_code'pos (signal_kp_add);
when 256 => signal_mode := signal_code'pos (signal_escape);
when 257 => signal_mode := signal_code'pos (signal_enter);
when 258 => signal_mode := signal_code'pos (signal_tab);
when 259 => signal_mode := signal_code'pos (signal_backspace);
when 262 => signal_mode := signal_code'pos (signal_right);
when 263 => signal_mode := signal_code'pos (signal_left);
when 264 => signal_mode := signal_code'pos (signal_down);
when 265 => signal_mode := signal_code'pos (signal_up);
when others => signal_mode := signal_code'pos (signal_none);
end case;
--
begin_drawing;
--
clear_background ((50, 60, 70, 255));
end synchronize;
------------------------------------------------------------------------------------------
procedure play_song (index : in integer) is begin play_sound (sound_array (index)); end play_song;
procedure stop_song (index : in integer) is begin stop_sound (sound_array (index)); end stop_song;
------------------------------------------------------------------------------------------
procedure overlay is
begin
draw_rectangle (0, 0, window_width, window_height, (0, 0, 0, 100));
end overlay;
------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
end core;
Reference in New Issue View Git Blame Copy Permalink