-- Copyright (c) 2024 - Ognjen 'xolatile' Milan Robovic -- -- GNU General Public Licence (version 3 or later) with ray; package body core is ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ type terminal_colour is ( grey, red, green, yellow, blue, pink, cyan, white ); type terminal_effect is ( normal, bold, italic, underline, blink, invert ); ------------------------------------------------------------------------------------------ type texture_data_array is array (natural range <>) of ray.texture; type sound_data_array is array (natural range <>) of ray.sound; type font_data_array is array (natural range <>) of ray.font; ------------------------------------------------------------------------------------------ texture_count : integer := 0; sound_count : integer := 0; font_count : integer := 0; texture_array : access texture_data_array; sound_array : access sound_data_array; font_array : access font_data_array; game_icon : ray.image; ------------------------------------------------------------------------------------------ procedure terminal (colour : in terminal_colour := white; effect : in terminal_effect := normal); ------------------------------------------------------------------------------------------ function "=" (a, b : in signal_code) return boolean is begin return natural (signal_code'pos (a)) = natural (signal_code'pos (b)); end "="; function "=" (a, b : in cursor_code) return boolean is begin return natural (cursor_code'pos (a)) = natural (cursor_code'pos (b)); end "="; function "/" (a, b : in signal_code) return boolean is begin return natural (signal_code'pos (a)) /= natural (signal_code'pos (b)); end "/"; function "/" (a, b : in cursor_code) return boolean is begin return natural (cursor_code'pos (a)) /= natural (cursor_code'pos (b)); end "/"; ------------------------------------------------------------------------------------------ function "+" (data : in point; modifier : in natural) return point is this : point := data; begin this.value := (if (this.value + modifier) > this.limit then this.limit else (this.value + modifier)); -- return this; end "+"; ------------------------------------------------------------------------------------------ function "-" (data : in point; modifier : in natural) return point is this : point := data; begin this.value := (if (this.value - modifier) <= 0 then 0 else (this.value - modifier)); -- return this; end "-"; ------------------------------------------------------------------------------------------ function "*" (data : in point; modifier : in natural) return point is this : point := data; begin this.value := (if (this.value * modifier) > this.limit then this.limit else (this.value * modifier)); -- return this; end "*"; ------------------------------------------------------------------------------------------ function "/" (data : in point; modifier : in natural) return point is this : point := data; begin this.value := (if (this.value / modifier) <= 0 then 0 else (this.value / modifier)); -- return this; end "/"; ------------------------------------------------------------------------------------------ procedure echo (status : in echo_status; text : in string) is begin if not echo_mark (status) then return; end if; -- 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; when import => terminal (cyan, bold); put (" <-- "); terminal; when export => terminal (blue, bold); put (" --> "); terminal; end case; put ("] "); -- put_line (text); end echo; ------------------------------------------------------------------------------------------ procedure echo_when (condition : in boolean; status : in echo_status; text : in string) is begin if condition then echo (status, text); end if; end echo_when; ------------------------------------------------------------------------------------------ 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 time return float is begin return float (ray.get_time); end time; ------------------------------------------------------------------------------------------ function compress (data : in address; size : in integer; used : out integer) return address is begin return address (ray.compress (ray.pointer (data), size, used)); end compress; ------------------------------------------------------------------------------------------ function decompress (data : in address; size : in integer; used : out integer) return address is begin return address (ray.decompress (ray.pointer (data), size, used)); end decompress; ------------------------------------------------------------------------------------------ function c_string (ada_string : string) return string is begin return (ada_string & character'val (0)); end c_string; ------------------------------------------------------------------------------------------ function random (minimum, maximum : in integer) return integer is begin return ray.get_random (minimum, maximum); end random; ------------------------------------------------------------------------------------------ procedure clip (value : in out integer; minimum, maximum : in integer) is begin if value < minimum then value := minimum; end if; if value > maximum then value := maximum; end if; end clip; ------------------------------------------------------------------------------------------ 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 window_width return integer is begin return ray.get_screen_width; end window_width; function window_height return integer is begin return ray.get_screen_height; end window_height; ------------------------------------------------------------------------------------------ function center_x (object : in integer) return integer is begin return (window_width - object) / 2; end center_x; function center_y (object : in integer) return integer is begin return (window_height - object) / 2; end center_y; ------------------------------------------------------------------------------------------ function cursor_inside (x, y, width, height : in integer) return boolean is begin return cursor.x > x and cursor.x < x + width * zoom and cursor.y > y and cursor.y < y + height * zoom; end cursor_inside; ------------------------------------------------------------------------------------------ function import_sprite (file_path : in string; frames, states : in integer) return sprite is this : sprite; begin texture_array (texture_count) := ray.load_texture (c_string (file_path)); -- texture_count := texture_count + 1; this.index := texture_count - 1; this.width := texture_array (this.index).width / frames; this.height := texture_array (this.index).height / states; this.frames := frames; this.states := states; -- if this.width = 0 or this.height = 0 then echo (warning, "Sprite not imported: " & file_path); end if; -- return this; end import_sprite; ------------------------------------------------------------------------------------------ function import_font (file_path : in string; scale, space : in integer) return font is this : font; begin font_array (font_count) := ray.load_font (c_string (file_path)); -- font_count := font_count + 1; this.index := font_count - 1; this.scale := scale; this.space := space; -- return this; end import_font; ------------------------------------------------------------------------------------------ function import_song (file_path : in string) return song is this : song; begin sound_array (sound_count) := ray.load_sound (c_string (file_path)); -- sound_count := sound_count + 1; this.index := sound_count - 1; -- return this; end import_song; ------------------------------------------------------------------------------------------ procedure import_text (data : in out string_box_data; file_path : in string) is begin data.text := to_unbounded_string (to_ada (ray.load_text (c_string (file_path)).all)) & character'val (0); end import_text; ------------------------------------------------------------------------------------------ procedure create_image (width, height : in integer) is begin global_image := ray.image_colour (width, height, (0, 0, 0, 255)); end create_image; ------------------------------------------------------------------------------------------ procedure draw_pixel (x, y : in integer; tint : in colour) is new_tint : ray.colour := (ray.colour_range (tint.r), ray.colour_range (tint.g), ray.colour_range (tint.b), ray.colour_range (tint.a)); begin ray.image_pixel (global_image, x, y, new_tint); end draw_pixel; ------------------------------------------------------------------------------------------ procedure render_image (data : in sprite; x, y, u, v, width, height : in integer) is temporary : ray.image; begin temporary := ray.image_import (texture_array (data.index)); -- ray.image_render (data => global_image, copy => temporary, from => (float (u), float (v), float (width), float (height)), to => (float (x), float (y), float (width), float (height))); -- ray.image_delete (temporary); end render_image; ------------------------------------------------------------------------------------------ procedure export_image (file_path : in string) is ignore : integer; begin ignore := ray.image_export (global_image, c_string (file_path)); -- ray.image_delete (global_image); end export_image; ------------------------------------------------------------------------------------------ procedure draw (data : in sprite := (others => 0); x : in integer := 0; y : in integer := 0; u : in integer := 0; v : in integer := 0; width : in integer := 0; height : in integer := 0; ignore : in boolean := false; state : in animation := idle; factor : in integer := zoom; tint : in colour := (others => 255)) is new_width : constant float := float ((if width = 0 then data.width else width)); new_height : constant float := float ((if height = 0 then data.height else height)); -- new_tint : ray.colour := (ray.colour_range (tint.r), ray.colour_range (tint.g), ray.colour_range (tint.b), ray.colour_range (tint.a)); begin ray.draw_texture (data => texture_array (data.index), uv => (x => float (if ignore then u else (animation_time mod data.frames) * data.width), y => float (if ignore then v else (animation'pos (state) mod data.states) * data.height), width => new_width, height => new_height), view => (x => float (x), y => float (y), width => new_width * float (factor), height => new_height * float (factor)), tint => new_tint); end draw; ------------------------------------------------------------------------------------------ procedure draw_horizontally (data : in sprite; x, y, width, factor : in integer; tint : in colour := (others => 255)) is begin for move in 0 .. width / data.width - 1 loop draw (data, x + move * data.width, y, tint => tint, factor => factor); end loop; -- if width mod data.width > 0 then draw (data, x + (width / data.width) * data.width, y, 0, 0, width mod data.width, data.height, tint => tint, factor => factor); end if; end draw_horizontally; ------------------------------------------------------------------------------------------ procedure draw_vertically (data : in sprite; x, y, height, factor : in integer; tint : in colour := (others => 255)) is begin for move in 0 .. height / data.height - 1 loop draw (data, x, y + move * data.height, tint => tint, factor => factor); end loop; -- if height mod data.height > 0 then draw (data, x, y + (height / data.height) * data.height, 0, 0, data.width, height mod data.height, tint => tint, factor => factor); end if; end draw_vertically; ------------------------------------------------------------------------------------------ procedure write (text : in string := ""; x : in integer := 0; y : in integer := 0; tint : in colour := (others => 255); size : in integer := 0; data : in font := (others => 0)) is new_tint : ray.colour := (ray.colour_range (tint.r), ray.colour_range (tint.g), ray.colour_range (tint.b), ray.colour_range (tint.a)); begin ray.draw_text (data => font_array (data.index), text => c_string (text), view => (float (x), float (y)), scale => (if size = 0 then float (font_array (data.index).base) else float (size)), space => float (font_array (data.index).pad), tint => new_tint); end write; ------------------------------------------------------------------------------------------ procedure play (index : in integer) is begin ray.play_sound (sound_array (index)); end play; procedure stop (index : in integer) is begin ray.stop_sound (sound_array (index)); end stop; ------------------------------------------------------------------------------------------ procedure overlay is begin ray.draw_rectangle (0, 0, window_width, window_height, (0, 0, 0, 127)); end overlay; ------------------------------------------------------------------------------------------ function read_help_box return string is begin return to_string (help_box.text); end read_help_box; function read_text_box return string is begin return to_string (text_box.text); end read_text_box; ------------------------------------------------------------------------------------------ procedure write_help_box (text : in string) is begin help_box.text := to_unbounded_string (text); end write_help_box; procedure write_text_box (text : in string) is begin text_box.text := to_unbounded_string (text); end write_text_box; ------------------------------------------------------------------------------------------ procedure save_point (here : in io.file_type; data : in point) is begin core.io.write (here, data.value); core.io.write (here, data.limit); end save_point; ------------------------------------------------------------------------------------------ procedure load_point (here : in core.io.file_type; data : out point) is begin core.io.read (here, data.value); core.io.read (here, data.limit); end load_point; ------------------------------------------------------------------------------------------ procedure increment (value : in out integer; super : in natural := 1) is begin value := value + super; end increment; procedure decrement (value : in out integer; super : in natural := 1) is begin value := value - super; end decrement; ------------------------------------------------------------------------------------------ procedure idle_skip is null; ------------------------------------------------------------------------------------------ procedure toggle_fullscreen is begin ray.toggle_fullscreen; end toggle_fullscreen; ------------------------------------------------------------------------------------------ procedure initialize is begin echo (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 .. 16); -- echo (comment, "-- Setting trace log level to none (ignoring all default Raylib logs)."); ray.set_trace_log_level (ray.log_none); -- ray.set_window_flags (ray.flag_window_resizable); -- echo (comment, "-- Initializing Raylib window data..."); echo (comment, "-- -- Window title : Xorana"); echo (comment, "-- -- Window width : 1800"); echo (comment, "-- -- Window height : 900"); -- ray.open_window (1800, 900, c_string ("Xorana")); ray.hide_cursor; -- ray.set_window_minimal_size (640, 480); ray.set_window_maximal_size (3840, 2160); -- echo (comment, "-- Initializing Raylib audio device data..."); --~ray.open_audio_device; -- game_icon := ray.load_image (c_string (folder & "/ui/game_icon.png")); -- ray.window_icon (game_icon); -- --ray.randomization (19970725); ray.set_target_fps (60); -- echo (success, "Initialized core components."); end initialize; ------------------------------------------------------------------------------------------ procedure deinitialize is begin echo (comment, "Deinitializing core components..."); -- engine_active := false; -- echo (comment, "-- -- Unloading Raylib" & texture_count'image & " textures."); echo (comment, "-- -- Unloading Raylib" & sound_count'image & " sounds."); echo (comment, "-- -- Unloading Raylib" & font_count'image & " fonts."); -- for index in 0 .. texture_count - 1 loop ray.unload_texture (texture_array (index)); end loop; for index in 0 .. sound_count - 1 loop ray.unload_sound (sound_array (index)); end loop; for index in 0 .. font_count - 1 loop ray.unload_font (font_array (index)); end loop; -- echo (comment, "-- Deinitializing Raylib audio device data..."); --~ray.close_audio_device; -- ray.unload_image (game_icon); -- echo (comment, "-- Deinitializing Raylib window data..."); ray.close_window; ray.show_cursor; -- echo (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 (ray.get_fps); signal := ray.get_key_pressed; cursor.x := ray.get_mouse_x; cursor.y := ray.get_mouse_y; wheel := wheel + ray.mouse_wheel_move; end_turn := false; -- ray.end_drawing; -- if ray.exit_key_is_pressed then engine_active := false; end if; -- if ray.mouse_button_is_pressed (ray.mouse_button_left) then cursor_mode := cursor_left; end if; if ray.mouse_button_is_pressed (ray.mouse_button_right) then cursor_mode := cursor_right; end if; if ray.mouse_button_is_pressed (ray.mouse_button_middle) then cursor_mode := cursor_middle; end if; if ray.mouse_button_is_released (ray.mouse_button_left) then cursor_mode := cursor_none; end if; if ray.mouse_button_is_released (ray.mouse_button_right) then cursor_mode := cursor_none; end if; if ray.mouse_button_is_released (ray.mouse_button_middle) then cursor_mode := cursor_none; end if; -- case signal is when 48 .. 57 => signal_mode := signal_code'val (signal - 48 + signal_code'pos (signal_0)); when 65 .. 90 => signal_mode := signal_code'val (signal - 65 + signal_code'pos (signal_a)); when 290 .. 301 => signal_mode := signal_code'val (signal - 290 + signal_code'pos (signal_f1)); when 320 .. 329 => signal_mode := signal_code'val (signal - 320 + signal_code'pos (signal_kp_0)); -- when 0 => signal_mode := signal_none; when 32 => signal_mode := signal_space; when 96 => signal_mode := signal_grave; when 340 => signal_mode := signal_left_shift; when 341 => signal_mode := signal_left_control; when 333 => signal_mode := signal_kp_subtract; when 334 => signal_mode := signal_kp_add; when 256 => signal_mode := signal_escape; when 257 => signal_mode := signal_enter; when 258 => signal_mode := signal_tab; when 259 => signal_mode := signal_backspace; when 262 => signal_mode := signal_right; when 263 => signal_mode := signal_left; when 264 => signal_mode := signal_down; when 265 => signal_mode := signal_up; when others => signal_mode := signal_none; end case; -- ray.begin_drawing; -- ray.clear_background ((0, 0, 0, 255)); end synchronize; ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ 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; ------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------ end core;