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_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 put ("["); -- case status is when failure => terminal (red, bold); put ("Failure"); terminal; when warning => terminal (yellow, bold); put ("Warning"); terminal; when success => terminal (green, bold); put ("Success"); terminal; when comment => terminal (grey, bold); put ("Comment"); terminal; end case; -- put_line ("] " & message); -- if status = failure then dash; echo (comment, "Immediately terminating the program, no memory management clean-up."); dash; end if; 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, (255, 60, 60, 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; ------------------------------------------------------------------------------------------ procedure initialize is begin 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); -- set_trace_log_level (log_none); open_window (1800, 900, "Chads of Might & Magic"); open_audio_device; -- 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); end initialize; ------------------------------------------------------------------------------------------ procedure deinitialize is begin engine_active := false; -- 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; -- close_audio_device; close_window; 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 ((60, 255, 50, 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; ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ end core;