unit a3dge;
(*<Engine core classes.
*)
(* Copyright (c) 2012, 2025 Guillermo Martínez J.
This software is provided 'as-is', without any express or implied
warranty. In no event will the authors be held liable for any damages
arising from the use of this software.
Permission is granted to anyone to use this software for any purpose,
including commercial applications, and to alter it and redistribute it
freely, subject to the following restrictions:
1. The origin of this software must not be misrepresented; you must not
claim that you wrote the original software. If you use this software
in a product, an acknowledgment in the product documentation would be
appreciated but is not required.
2. Altered source versions must be plainly marked as such, and must not be
misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
*)
{$Include a3dge.cfg}
interface
uses
allegro5, al5base, al5font,
Classes, CustApp, sysutils,
a3dge.Classes;
const
(* Version identification. @seealso(CopyStr) *)
VersionStr = '1.0#94';
(* Copyright string. *)
CopyStr = Concat ('A3DGE ', VersionStr, ' (c) 2012, 2025 Guillermo Martínez J.');
(* Logs debug and error events. *)
etDbg = [etWarning, etError, etDebug];
(* To log all events. *)
etAll = [etCustom, etInfo, etWarning, etError, etDebug];
(* To deactivate log. *)
etNone = [];
(* Default log value. *)
etDefault = [etError, etWarning];
(* Game speed in Ticks Per Second. *)
FPS = 50;
(* @exclude keyboard buffer size. Should be power of two. *)
_KbdBufLen = 32;
type
(* Manages a log file. *)
TLog = class (TObject)
private
fLevel: TEventTypes;
fLogFile: TFileStream;
public
(* Constructor. *)
constructor Create; virtual;
(* Destructor. *)
destructor Destroy; override;
(* Send given message to the log file. *)
procedure Trace (const aEventType: TEventType; const aMessage: AnsiString);
(* Send given message to the log file. *)
procedure TraceFmt (
const aEventType: TEventType;
const aFmt: AnsiString;
aParams: array of const
);
(* Sets the log level. By default it is @link(etDefault). *)
property Level: TEventTypes read fLevel write fLevel;
end;
(* Handles configuration files. *)
TConfigurationFile = class (TObject)
private
fFileName: AnsiString;
fConfigFile: ALLEGRO_CONFIGptr;
procedure SetFilename (const aValue: AnsiString);
function BoolToString (const aValue: Boolean): AnsiString; inline;
function StringToBool (const aValue: AnsiString): Boolean; inline;
public
(* Constructor. *)
constructor Create; virtual;
(* Destructor. *)
destructor Destroy; override;
(* (Re)loads configuration file. *)
procedure Load;
(* Get a configuration value. *)
function GetValue (const aSection, aKey, aDefault: AnsiString): String;
(* Get an integer configuration value. *)
function GetIntValue (
const aSection, aKey: AnsiString;
aDefault: Integer
): Integer;
(* Get a boolean configuration value. *)
function GetBoolValue (
const aSection, aKey: AnsiString;
aDefault: Boolean
): Boolean;
(* Set a configuration value. *)
procedure SetValue (const aSection, aKey, aValue: AnsiString);
(* Set an integer configuration value. *)
procedure SetIntValue (const aSection, aKey: AnsiString; aValue: Integer);
(* Set a boolean configuration value. *)
procedure SetBoolValue (const aSection, aKey: AnsiString; aValue: Boolean);
(* Save current configuration to file. *)
procedure Save;
(* Configuration file name, including path. *)
property FileName: AnsiString read fFileName write fFileName;
end;
(* Default display. *)
TDisplay = class (TObject)
private
fTitle: String;
fDisplay: ALLEGRO_DISPLAYptr;
fCenterX, fCenterY, fWidth, fHeight: Integer;
fOnClose, fOnOpen: TNotifyEvent;
procedure SetTitle (const aValue: String);
procedure EventHandler (aEvent: ALLEGRO_DISPLAY_EVENT);
protected
(* Return flags to be applied to the display. *)
function GetDisplayFlags: AL_INT;
(* Get default window size for windowed mode. *)
procedure GetWindowSize (out aWidth, aHeight: Integer);
(* Close and release all used resources. *)
procedure Close;
public
(* Constructor. *)
constructor Create;
(* Destructor. *)
destructor Destroy; override;
(* Open the display. *)
procedure Open;
(* Check if display is open. *)
function IsOpen: Boolean;
(* Set orthogonal projection for full display. *)
procedure SetOrthographicProjection;
(* Set display as target for rendering. *)
procedure SetAsTarget;
(* Do the apropiate operation so that what has been drawn previously on the
display become visible on screen. *)
procedure FlipDisplay;
(* Window title. *)
property Title: String read fTitle write SetTitle;
(* Display center X. *)
property CenterX: Integer read fCenterX;
(* Display center Y. *)
property CenterY: Integer read fCenterY;
(* Display width. *)
property Width: Integer read fWidth;
(* Display height. *)
property Height: Integer read fHeight;
(* Notifies when display opens *)
property OnOpen: TNotifyEvent read fOnOpen;
(* Notifies when display is going to close. *)
property OnClose: TNotifyEvent read fOnClose;
end;
(* Key event notification. *)
TKeyboardEvent = procedure (aKeyCode: Integer) of object;
(* Encapsulates keyboard input. *)
TKeyboard = CLASS (TObject)
private type
TKeyBuffer = record
Current, Top: Integer;
KeyBuf: array [0.._KbdBufLen - 1] of record
KeyCode, UniChar, Modifiers: LongInt
end;
procedure Clear;
procedure KeyPunch (const aEvent: ALLEGRO_KEYBOARD_EVENT);
function Readkey: LongInt;
function UReadkey (out aScancode: LongInt): LongInt;
function KeyModifiers: LongInt;
end;
private
fKey: array [0..ALLEGRO_KEY_MAX] of Boolean;
fKeyBuffer: TKeyBuffer;
fOnKeyDown, fOnKeyUp: TKeyboardEvent;
function GetKeyState (const aKeyCode: Integer): Boolean; inline;
procedure SetKeyState (const aKeyCode: Integer; const aState: Boolean);
inline;
procedure EventHandler (aEvent: ALLEGRO_KEYBOARD_EVENT);
public
(* Clear keyboard state and key buffer. *)
procedure Clear;
(* Check if one or more keys where pressed. *)
function Keypressed: Boolean; inline;
(* Read next key input. *)
function Readkey: LongInt;
(* Read next UNICODE key input. *)
function UReadkey (out aScancode: LongInt): LongInt;
(* Read key modifiers state. *)
function KeyModifiers: LongInt; inline;
(* Access to key states. *)
property KeyState[KeyCode: Integer]: Boolean
read GetKeyState write SetKeyState;
(* Event triggered when a key is pressed. *)
property OnKeyDown: TKeyboardEvent read fOnKeyDown write fOnKeyDown;
(* Event triggered when a key is released. *)
property OnKeyUp: TKeyboardEvent read fOnKeyUp write fOnKeyUp;
end;
(* Mouse event. *)
TMouseNotifyEvent = procedure (const aX, aY, aZ, aB: Integer) of object;
(* Encapsulates mouse input. *)
TMouse = class (TObject)
private
fInDisplay: Boolean;
fCursor: ALLEGRO_MOUSE_CURSORptr;
fOnButtonClick, fOnButtonUp, fOnMove: TMouseNotifyEvent;
fOnInDisplay, fOnOutDisplay: TNotifyEvent;
function GetNumButtons: Integer; inline;
procedure EventHandler (aEvent: ALLEGRO_MOUSE_EVENT);
public
(* Constructor. *)
constructor Create;
(* Destructor. *)
DESTRUCTOR Destroy; override;
(* Show mouse cursor. *)
procedure ShowCursor; inline;
(* Hide mouse cursor. *)
procedure HideCursor; inline;
(* Returns current mouse state. *)
function GetState: ALLEGRO_MOUSE_STATE; inline;
(* Get current mouse coordinates. *)
procedure GetCursorPos (out aX, aY: Integer); inline;
(* Set cursor bitmap. *)
procedure SetCursor (
aCursor: ALLEGRO_BITMAPptr;
aXFocus, aYFocus: Integer
);
(* Set cursor position. *)
procedure SetCursorPos (const aX, aY: Integer); inline;
(* Moves cursor to display center. *)
procedure WarpMouse; inline;
(* How many buttons has the mouse. *)
property NumButtons: Integer read GetNumButtons;
(* Is mouse cursor inside the display. *)
property InDisplay: Boolean read fInDisplay;
(* Event triggered when a mouse button is pressed. *)
property OnButtonClick: TMouseNotifyEvent
read fOnButtonClick write fOnButtonClick;
(* Event triggered when a mouse button is released. *)
property OnButtonUp: TMouseNotifyEvent
read fOnButtonUp write fOnButtonUp;
(* Event triggered when mouse moved. *)
property OnMove: TMouseNotifyEvent read fOnMove write fOnMove;
(* Event triggered when mouse moves out of the display. *)
property OnOutDisplay: TNotifyEvent
read fOnOutDisplay write fOnOutDisplay;
(* Event triggered when mouse moves inside of the display. *)
property OnInDisplay: TNotifyEvent
read fOnInDisplay write fOnInDisplay;
end;
(* Base class for game states. *)
TGameState = class (TState)
public
(* Executed when entering the state. *)
procedure Enter (aEntity: TObject); override;
(* Render the game state. *)
procedure Render; virtual; abstract;
end;
(* Manages game states. *)
TGameStateManager = class (TStateMachine)
private
function GetCurrentState: TGameState;
procedure SetCurrentState (aState: TGameState);
function GetGlobalState: TGameState;
procedure SetGlobalState (aState: TGameState);
public
(* Render current game state. *)
procedure Render;
(* Current state. *)
property Current: TGameState read GetCurrentState write SetCurrentState;
(* If assigned, it will be executed in every game tick along with
@link(Current).
*)
property Global: TGameState read GetGlobalState write SetGlobalState;
end;
(* Base for all A3DGE applications. *)
TA3DGEApplication = class (TCustomApplication)
private
{ Components. }
fConfigurationFile: TConfigurationFile;
fLog: TLog;
fDisplay: TDisplay;
fKeyboard: TKeyboard;
fMouse: TMouse;
{ Game states. }
fGameStateList: array of TGameState;
fGameState: TGameStateManager;
{ Execution data. }
fEventQueue: ALLEGRO_EVENT_QUEUEptr;
fTimer: ALLEGRO_TIMERptr; fTicksPerSecond: Integer;
{ Data. }
fSystemTextFont: ALLEGRO_FONTptr;
procedure SetTicksPerSecond (const aValue: Integer);
protected
(* Print command line options. *)
procedure PrintCommandLineOptions; virtual;
(* Parse command line options. *)
procedure ParseCommandLineOptions; virtual;
(* @exclude Execute the game. *)
procedure DoRun; override;
public
(* Create the application object. *)
constructor Create (aOwner: TComponent); override;
(* Destructor. *)
destructor Destroy; override;
(* Show an error message on screen. *)
procedure ShowErrorMessage (const aMessage: AnsiString);
(* Initialize the application. *)
procedure Initialize; override;
(* Adds a @italic(game state), that will be owned by @link(Application). *)
procedure AddGameState (
aGameState: TGameState;
const aName: AnsiString = ''
);
(* Search for an owned state by name. *)
function FindGameState (aName: AnsiString): TGameState;
(* Pause game updates. *)
procedure PauseUpdates;
(* Resume game updates. *)
procedure ResumeUpdates;
(* Drops all events in system queue and clears keyboard.. *)
procedure ClearEventQueue;
(* Access to the log subsystem. *)
property Log: TLog read fLog;
(* Access to the configuration. *)
property Configuration: TConfigurationFile read fConfigurationFile;
(* Access to display. *)
property Display: TDisplay read fDisplay;
(* How many times to call current state's @code(Update) method each second.
*)
property TicksPerSecond: Integer
read fTicksPerSecond write SetTicksPerSecond;
(* Access to keyboard. *)
property Keyboard: TKeyboard read fKeyboard;
(* Access to mouse. *)
property Mouse: TMouse read fMouse;
(* System text font. *)
property SysFont: ALLEGRO_FONTptr read fSystemTextFont;
(* Manage the current game state. *)
property Gamestate: TGameStateManager read fGameState;
end;
var
(* Global reference to the A3DGE application object. *)
Application: TA3DGEApplication;
implementation
uses
{$IfDef FPC}
GL,
{$Else}
OpenGL,
{$EndIf}
al5acodec, al5audio, al5image, al5primitives, al5strings, al5ttf;
var
fPrivateApplicationReference: TA3DGEApplication;
(*
* TLog
************************************************************************)
constructor TLog.Create;
begin
inherited Create;
fLevel := etDefault
end;
destructor TLog.Destroy;
begin
fLogFile.Free;
inherited Destroy
end;
procedure TLog.Trace (
const aEventType: TEventType;
const aMessage: AnsiString
);
var
lLogText: AnsiString;
lChar: AnsiChar;
begin
{ Check if event type is requested. }
if aEventType in fLevel then
{ Log message. }
case aEventType of
etDebug:
lLogText := Concat ('[dbg] ', aMessage, LineEnding);
etInfo:
lLogText := Concat ('[ i ] ', aMessage, LineEnding);
etWarning:
lLogText := Concat (' /!\ ', aMessage, LineEnding);
etError:
lLogText := Concat ('[ERR] ', aMessage, LineEnding);
{$IfDef FPC}otherwise{$Else}else{$EndIf}
lLogText := Concat (' ', aMessage, LineEnding);
end
else
{ No log message. }
Exit;
{ Open file if didn't yet. }
if not Assigned (fLogFile) then
begin
try
fLogFile := TFileStream.Create (
Concat ({$IfDef Windows}GetUserDir, {$EndIF} ApplicationName, '.log'),
fmCreate
)
except
fLogFile := Nil;
end;
if not Assigned (fLogFile) then { TODO: Ignore (ATM). };
end;
{ Write the message. }
for lChar in lLogText do fLogFile.WriteByte (Ord (lChar))
end;
procedure TLog.TraceFmt (
const aEventType: TEventType;
const aFmt: AnsiString;
aParams: array of const
);
begin
if aEventType in fLevel then
Self.Trace (aEventType, Format (aFmt, aParams))
end;
(*
* TConfigurationFile
************************************************************************)
procedure TConfigurationFile.SetFilename (const aValue: AnsiString);
begin
if aValue = fFileName then Exit;
if Assigned (fConfigFile) then Self.Load
end;
function TConfigurationFile.BoolToString (const aValue: Boolean): AnsiString;
inline;
begin
if aValue then Result := 'true' else Result := 'false'
end;
function TConfigurationFile.StringToBool (const aValue: AnsiString): Boolean;
inline;
begin
Result := LowerCase (aValue) = 'true'
end;
constructor TConfigurationFile.Create;
begin
inherited Create;
fFileName := GetAppConfigFile (False, False);
end;
destructor TConfigurationFile.Destroy;
begin
if Assigned (fConfigFile) then al_destroy_config (fConfigFile);
inherited Destroy
end;
procedure TConfigurationFile.Load;
begin
{ Close the configuration file if opened. }
if Assigned (fConfigFile) then al_destroy_config (fConfigFile);
{ Open the ini file (if exists). }
if FileExists (fFileName) then
fConfigFile := al_load_config_file (al_string_to_str (fFileName))
else
fConfigFile := al_create_config;
if not Assigned (fConfigFile) then
raise A3DGEException.CreateFmt (
'Couldn''t load configuration file "%s".',
[fFileName]
)
end;
function TConfigurationFile.GetValue (
const aSection, aKey, aDefault: AnsiString
): String;
var
lValue: AL_STRptr;
begin
lValue := al_get_config_value (
fConfigFile,
al_string_to_str (aSection),
al_string_to_str (aKey)
);
if Assigned (lValue) then
Result := al_str_to_string (lValue)
else
Result := aDefault
end;
function TConfigurationFile.GetIntValue (
const aSection, aKey: AnsiString;
aDefault: Integer
): Integer;
begin
Result := StrToInt (Self.GetValue (aSection, aKey, IntToStr (aDefault)))
end;
function TConfigurationFile.GetBoolValue (
const aSection, aKey: AnsiString;
aDefault: Boolean
): Boolean;
begin
Result := Self.StringToBool (
Self.GetValue (aSection, aKey, Self.BoolToString (aDefault))
)
end;
procedure TConfigurationFile.SetValue (
const aSection, aKey, aValue: AnsiString
);
begin
al_set_config_value (
fConfigFile,
al_string_to_str (aSection),
al_string_to_str (aKey),
al_string_to_str (aValue)
)
end;
procedure TConfigurationFile.SetIntValue (
const aSection, aKey: AnsiString;
aValue: Integer
);
begin
Self.SetValue (aSection, aKey, IntToStr (aValue))
end;
procedure TConfigurationFile.SetBoolValue (
const aSection, aKey: AnsiString;
aValue: Boolean
);
begin
Self.SetValue (aSection, aKey, Self.BoolToString (aValue))
end;
procedure TConfigurationFile.Save;
var
lConfigurationDirectory: AnsiString;
begin
{ Be sure the directory exists. }
lConfigurationDirectory := ExtractFileDir (fFileName);
if not DirectoryExists (lConfigurationDirectory) then
if not CreateDir (lConfigurationDirectory) then
{ Changed this to avoid problems with bad encoded file names
(i.e. Windows). Now just put it down in to the log file.
RAISE mngConfigException.CreateFmt (COULDNT_SAVE_CFG_FILE, [fFileName]);
}
Application.Log.Trace (
etWarning,
Format ('Couldn''t save configuration file "%s".', [fFileName])
);
{ Save the file. }
if not al_save_config_file (fFileName, fConfigFile) then
{ See previous long comment.
RAISE mngConfigException.CreateFmt (COULDNT_SAVE_CFG_FILE, [fFileName]);
}
Application.Log.Trace (
etWarning,
Format ('Couldn''t save configuration file "%s".', [fFileName])
)
end;
(*
* TDisplay
************************************************************************)
procedure TDisplay.SetTitle (const aValue: String);
begin
if fTitle <> aValue then
begin
fTitle := aValue;
if Assigned (fDisplay) then
al_set_window_title (fDisplay, al_string_to_str (fTitle))
end
end;
procedure TDisplay.EventHandler (aEvent: ALLEGRO_DISPLAY_EVENT);
begin
case aEvent.ftype of
ALLEGRO_EVENT_DISPLAY_CLOSE:
Application.Terminate;
end
end;
function TDisplay.GetDisplayFlags: AL_INT;
begin
Result := 0
end;
procedure TDisplay.GetWindowSize (out aWidth, aHeight: Integer);
const
MarginFactor = 3/4;
var
lMonitorInfo: ALLEGRO_MONITOR_INFO;
lMonitorWidth, lMonitorHeight: Single;
lScale: Integer;
begin
al_get_monitor_info (0, lMonitorInfo);
lMonitorWidth := MarginFactor * (lMonitorInfo.x2 - lMonitorInfo.x1);
lMonitorHeight := MarginFactor * (lMonitorInfo.y2 - lMonitorInfo.y1);
lScale := 1;
aWidth := 16 * 20; aHeight := 9 * 20;
while True do
if lMonitorHeight > aHeight * lScale then
Inc (lScale)
else begin
repeat
Dec (lScale)
until lMonitorWidth > aWidth * lScale;
Application.Log.Trace (etInfo, Format (
'Optimal window size: %d, %d.',
[aWidth * lScale, aHeight * lScale]
));
aWidth := aWidth * lScale;
aHeight := aHeight * lScale;
{ Very unlikely but may be there are some small SVGA monitors out there. }
if (aWidth < 800) then
begin
aWidth := 800;
aHeight := Trunc ((aWidth * 9) / 16) { Keep 16:9 ratio. }
end;
Exit
end
end;
procedure TDisplay.Close;
begin
if Assigned (fDisplay) then
begin
if Assigned (fOnClose) then fOnClose (Self);
Application.Log.Trace (etDebug, 'Closing display.');
al_destroy_display (fDisplay);
fDisplay := Nil;
Application.Log.Trace (etInfo, 'Display closed.')
end
end;
constructor TDisplay.Create;
begin
inherited Create;
fOnOpen := Nil;
fOnClose := Nil;
fTitle := ''
end;
destructor TDisplay.Destroy;
begin
Self.Close;
inherited Destroy
end;
procedure TDisplay.Open;
const
zBuffSize = 32;
NotDisplayFlags = not (
ALLEGRO_FULLSCREEN or ALLEGRO_WINDOWED or ALLEGRO_FULLSCREEN_WINDOW or
ALLEGRO_RESIZABLE or ALLEGRO_MAXIMIZED or ALLEGRO_DIRECT3D_INTERNAL or
ALLEGRO_GENERATE_EXPOSE_EVENTS
);
FullScreenDisplayFlags = ALLEGRO_OPENGL or ALLEGRO_FULLSCREEN;
WindowedDisplayFlags = ALLEGRO_OPENGL or ALLEGRO_WINDOWED;
var
lDisplayFlags: AL_INT;
lWidth, lHeight: Integer;
begin
if Assigned (fDisplay) then Self.Close;
Application.Log.Trace (etInfo, 'Getting display options...');
lDisplayFlags := Self.GetDisplayFlags and NotDisplayFlags;
{ At the moment, only windowed.
if fFullScreen then
begin
lDisplayFlags := lDisplayFlags or FullScreenDisplayFlags;
Self.GetDisplaySize (lWidth, lHeight)
end
else
}
begin
lDisplayFlags := lDisplayFlags or WindowedDisplayFlags;
Self.GetWindowSize (lWidth, lHeight)
end;
{ Set new display options. }
al_set_new_display_flags (lDisplayFlags);
al_set_new_display_option (ALLEGRO_DEPTH_SIZE, zBuffSize, ALLEGRO_SUGGEST);
al_set_new_display_option (ALLEGRO_VSYNC, 2, ALLEGRO_SUGGEST);
Application.Log.Trace (etDebug, Format (
'Creating display of %dx%d.',
[lWidth, lHeight]
));
{ Create. }
fDisplay := al_create_display (lWidth, lHeight);
if not Assigned (fDisplay) then
raise A3DGEException.Create ('Can''t start OpenGL context.');
{ Display magnitude. }
fWidth := al_get_display_width (fDisplay);
fHeight := al_get_display_height (fDisplay);
fCenterX := fWidth div 2;
fCenterY := fHeight div 2;
{ Default title. }
if fTitle = '' then fTitle := Concat (ApplicationName, ' - A3DGE');
al_set_window_title (fDisplay, al_string_to_str (fTitle));
Self.SetAsTarget;
Application.Log.Trace (etCustom, 'Display created [OK]');
{ Notify observers. }
if Assigned (fOnOpen) then fOnOpen (Self)
end;
function TDisplay.IsOpen: Boolean;
begin
Result := Assigned (fDisplay)
end;
procedure TDisplay.SetOrthographicProjection;
begin
glViewport (
0, 0,
Self.Width, Self.Height
);
glMatrixMode (GL_PROJECTION);
glLoadIdentity;
glOrtho (
0, Self.Width,
Self.Height, 0,
-1, 1
);
glMatrixMode (GL_MODELVIEW);
glLoadIdentity
end;
procedure TDisplay.SetAsTarget;
begin
al_set_target_backbuffer (fDisplay)
end;
procedure TDisplay.FlipDisplay;
begin
al_flip_display
end;
(*
* TKeyBuffer
************************************************************************)
procedure TKeyboard.TKeyBuffer.Clear;
begin
Self.Current := 0;
Self.Top := 0
end;
procedure TKeyboard.TKeyBuffer.KeyPunch (const aEvent: ALLEGRO_KEYBOARD_EVENT);
inline;
begin
{ Add the key in the buffer. }
Self.KeyBuf[Self.Top].KeyCode := aEvent.keycode;
Self.KeyBuf[Self.Top].UniChar := aEvent.unichar;
Self.KeyBuf[Self.Top].Modifiers := aEvent.modifiers;
Self.Top := (Self.Top + 1) and (_KbdBufLen - 1);
{ Manage buffer overflow. }
if Self.Top = Self.Current then
Self.Current := (Self.Current +1) and (_KbdBufLen - 1)
end;
function TKeyboard.TKeyBuffer.Readkey: LongInt; inline;
begin
if Self.Current <> Self.Top then
begin
if Self.KeyBuf[Self.Current].UniChar < $FF then
Result := (Self.KeyBuf[Self.Current].UniChar and $000000FF)
or (Self.KeyBuf[Self.Current].KeyCode shl 8)
else
Result := Ord ('^') or (Self.KeyBuf[Self.Current].KeyCode shl 8);
Self.Current := (Self.Current + 1) and (_KbdBufLen - 1)
end
else
Result := 0
end;
function TKeyboard.TKeyBuffer.UReadkey (out aScancode: LongInt): LongInt; inline;
begin
if Self.Current <> Self.Top then
begin
aScancode := Self.KeyBuf[Self.Current].KeyCode;
Result := Self.KeyBuf[Self.Current].UniChar;
Self.Current := (Self.Current + 1) AND (_KbdBufLen - 1)
end
else
Result := 0;
end;
function TKeyboard.TKeyBuffer.KeyModifiers: LongInt; inline;
begin
Result := Self.KeyBuf[Self.Current].Modifiers
end;
(*
* TKeyboard
************************************************************************)
function TKeyboard.GetKeyState (const aKeyCode: Integer): Boolean;
begin
Result := fKey[aKeyCode]
end;
procedure TKeyboard.SetKeyState (
const aKeyCode: Integer;
const aState: Boolean
);
begin
fKey[aKeyCode] := aState
end;
procedure TKeyboard.EventHandler (aEvent: ALLEGRO_KEYBOARD_EVENT);
begin
case aEvent.ftype of
ALLEGRO_EVENT_KEY_DOWN:
begin
fKey[aEvent.keycode] := True;
if Assigned (fOnKeyDown) then fOnKeyDown (aEvent.keycode)
end;
ALLEGRO_EVENT_KEY_UP:
begin
fKey[aEvent.keycode] := False;
if Assigned (fOnKeyUp) then fOnKeyUp (aEvent.keycode)
end;
ALLEGRO_EVENT_KEY_CHAR:
{ This is a security test. If it didn't updated keyboard status then it
just ignores the key_char event that follows to the key_down event. }
if fKey[aEvent.KeyCode] then
fKeyBuffer.KeyPunch (aEvent);
end
end;
procedure TKeyboard.Clear;
var
lCode: Integer;
begin
for lCode := Low (fKey) to High (fKey) do fKey[lCode] := False;
fKeyBuffer.Clear
end;
function TKeyboard.Keypressed: Boolean;
begin
Result := fKeyBuffer.Current <> fKeyBuffer.Top
end;
function TKeyboard.Readkey: LongInt;
begin
Result := fKeyBuffer.Readkey
end;
function TKeyboard.UReadkey(out aScancode: LongInt): LongInt;
begin
Result := fKeyBuffer.UReadkey (aScancode)
end;
function TKeyboard.KeyModifiers: LongInt;
begin
Result := fKeyBuffer.KeyModifiers
end;
(*
* TGameState
************************************************************************)
procedure TGameState.Enter (aEntity: TObject);
var
lApplication: TA3DGEApplication absolute aEntity;
begin
lApplication.Log.Trace (
etDebug,
Format ('Entering game state "%s".', [Self.Name])
)
end;
(*
* TMouse
************************************************************************)
function TMouse.GetNumButtons: Integer;
begin
Result := al_get_mouse_num_buttons
end;
procedure TMouse.EventHandler (aEvent: ALLEGRO_MOUSE_EVENT);
begin
case aEvent.ftype of
ALLEGRO_EVENT_MOUSE_BUTTON_DOWN:
if Assigned (fOnButtonClick) then
fOnButtonClick (aEvent.x, aEvent.y, aEvent.z, aEvent.button);
ALLEGRO_EVENT_MOUSE_BUTTON_UP:
if Assigned (fOnButtonUp) then
fOnButtonUp (aEvent.x, aEvent.y, aEvent.z, aEvent.button);
ALLEGRO_EVENT_MOUSE_AXES:
if Assigned (fOnMove) then
fOnMove (aEvent.dx, aEvent.dy, aEvent.dz, aEvent.button);
ALLEGRO_EVENT_MOUSE_ENTER_DISPLAY:
begin
fInDisplay := True;
if Assigned (fOnInDisplay) then fOnInDisplay (Self)
end;
ALLEGRO_EVENT_MOUSE_LEAVE_DISPLAY:
begin
fInDisplay := False;
if Assigned (fOnOutDisplay) then fOnOutDisplay (Self)
end;
end
end;
constructor TMouse.Create;
begin
inherited Create;
fInDisplay := True
end;
destructor TMouse.Destroy;
begin
if Assigned (fCursor) then al_destroy_mouse_cursor (fCursor);
inherited Destroy
end;
procedure TMouse.ShowCursor;
begin
al_show_mouse_cursor (a3dge.Application.Display.fDisplay)
end;
procedure TMouse.HideCursor;
begin
al_hide_mouse_cursor (a3dge.Application.Display.fDisplay)
end;
function TMouse.GetState: ALLEGRO_MOUSE_STATE;
begin
al_get_mouse_state (Result)
end;
procedure TMouse.GetCursorPos (out aX, aY: Integer);
var
lState: ALLEGRO_MOUSE_STATE;
begin
al_get_mouse_state (lState);
aX := lState.X; aY := lState.Y
end;
procedure TMouse.SetCursor (
aCursor: ALLEGRO_BITMAPptr;
aXFocus, aYFocus: Integer
);
begin
if Assigned (fCursor) then al_destroy_mouse_cursor (fCursor);
fCursor :=al_create_mouse_cursor (aCursor,aXFocus, aYFocus);
if Assigned (fCursor) then
al_set_mouse_cursor (a3dge.Application.Display.fDisplay, fCursor)
else
a3dge.Application.Log.Trace (etError, 'Couldn''t set mouse cursor.')
end;
procedure TMouse.SetCursorPos (const aX, aY: Integer);
begin
al_set_mouse_xy (a3dge.Application.Display.fDisplay, aX, aY)
end;
procedure TMouse.WarpMouse;
begin
al_set_mouse_xy (
a3dge.Application.Display.fDisplay,
a3dge.Application.Display.CenterX,
a3dge.Application.Display.CenterY
)
end;
(*
* TGameStateManager
************************************************************************)
function TGameStateManager.GetCurrentState: TGameState;
begin
Result := TGameState (inherited Current)
end;
procedure TGameStateManager.SetCurrentState (aState: TGameState);
begin
inherited Current := aState
end;
function TGameStateManager.GetGlobalState: TGameState;
begin
Result := TGameState (inherited Global)
end;
procedure TGameStateManager.SetGlobalState (aState: TGameState);
begin
if Assigned (aState) then
Application.Log.Trace (
etDebug,
Format ('Setting global game state to "%s".', [aState.Name])
)
else
Application.Log.Trace (etDebug, 'Removing global game state.');
inherited Global := aState
end;
procedure TGameStateManager.Render;
var
lGlobalState: TGameState;
begin
TGameState (inherited Current).Render;
lGlobalState := TGameState (inherited Global);
if Assigned (lGlobalState) then lGlobalState.Render;
a3dge.Application.Display.FlipDisplay
end;
(*
* TA3DGEApplication
************************************************************************)
procedure TA3DGEApplication.SetTicksPerSecond (const aValue: Integer);
var
lSource: ALLEGRO_EVENT_SOURCEptr;
begin
if aValue = fTicksPerSecond then Exit;
if aValue < 1 then
raise A3DGEException.CreateFmt ('Invalid game speed "%d".', [aValue]);
if Assigned (fTimer) then
begin
lSource := al_get_timer_event_source (fTimer);
al_unregister_event_source (fEventQueue, lSource);
al_destroy_timer (fTimer);
fTimer := al_create_timer (ALLEGRO_BPS_TO_SECS (aValue));
al_register_event_source (fEventQueue, lSource)
end;
fTicksPerSecond := aValue
end;
procedure TA3DGEApplication.PrintCommandLineOptions;
begin
WriteLn ('Usage: ', ApplicationName, ' [OPTION]');
WriteLn;
WriteLn ('Options:');
WriteLn (' --log=LVL Sets log level. LVL can be:');
WriteLn (' default: Logs error and warnings only.');
WriteLn (' debug: Logs debug and error only.');
WriteLn (' all: Logs all messages.');
WriteLn (' none: Do not log anything.');
WriteLn (' -h, --help Shows this help.')
end;
procedure TA3DGEApplication.ParseCommandLineOptions;
begin
;
end;
procedure TA3DGEApplication.DoRun;
var
lEvent: ALLEGRO_EVENT;
begin
if Self.Terminated then Exit;
inherited DoRun; { Not sure if I should keep this. }
fLog.Trace (etDebug, 'Main loop start.');
fKeyboard.Clear;
al_start_timer (fTimer);
try
try
{ Method "Update" not only executes the state but also initializes it if
it wasn't. So Update here to be sure it will be initialized before it
tries to Render. Otherwise it may try to render without initializing
because an event other than ALLEGRO_EVENT_TIMER may trigger it.
}
fGameState.Update (Self);
repeat
repeat
al_wait_for_event (fEventQueue, @lEvent);
case lEvent.ftype of
ALLEGRO_EVENT_DISPLAY_EXPOSE..ALLEGRO_EVENT_DISPLAY_RESUME_DRAWING:
fDisplay.EventHandler (lEvent.display);
ALLEGRO_EVENT_KEY_DOWN..ALLEGRO_EVENT_KEY_UP:
fKeyboard.EventHandler (lEvent.keyboard);
ALLEGRO_EVENT_MOUSE_AXES..ALLEGRO_EVENT_MOUSE_WARPED:
fMouse.EventHandler (lEvent.mouse);
ALLEGRO_EVENT_TIMER:
fGameState.Update (Self);
end
until al_is_event_queue_empty (fEventQueue);
fGameState.Render
until Self.Terminated
finally
al_stop_timer (fTimer)
end
except
on Error: A3DGEException do
begin
Self.ShowErrorMessage (Error.Message);
Self.Terminate
end;
on Error: Exception do
begin
Self.Log.Trace (etError, Concat ('Exception "', Error.Message, '".'));
Self.ShowErrorMessage (Error.Message);
Self.Terminate
end
end;
fLog.Trace (etDebug, 'Main loop end.')
end;
constructor TA3DGEApplication.Create (aOwner: TComponent);
begin
{ It's a singleton. }
if Assigned (fPrivateApplicationReference) then
raise Exception.Create (
'Only one TA3DGEApplication object should be created.'
);
inherited Create (aOwner);
fPrivateApplicationReference := Self;
Application := Self;
fTicksPerSecond := FPS;
fDisplay := TDisplay.Create;
fLog := TLog.Create;
fConfigurationFile := TConfigurationFile.Create;
fGameState := TGameStateManager.Create;
fKeyboard := TKeyboard.Create;
fMouse := TMouse.Create
end;
destructor TA3DGEApplication.Destroy;
{***
Be careful adding things here as destruction order is important.
***}
procedure DestroyComponents;
begin
fLog.Trace (etDebug, 'Destroying components...');
{ First, remove "standard" components. }
Self.DestroyComponents;
{ Now, the A3DGE components. }
fGameState.Free;
if Assigned (fTimer) then al_destroy_timer (fTimer);
if Assigned (fSystemTextFont) then al_destroy_font (fSystemTextFont);
fMouse.Free;
fKeyboard.Free;
fDisplay.Free;
fConfigurationFile.Free
end;
procedure DestroyStates;
var
lState: TGameState;
begin
fLog.Trace (etDebug, 'Destroying game states...');
for lState in fGameStateList do lState.Free
end;
procedure ShutdownAllegro; inline;
begin
fLog.Trace (etDebug, 'Shutting down Allegro...');
if Assigned (fEventQueue) then al_destroy_event_queue (fEventQueue);
al_uninstall_system
end;
begin
DestroyStates;
DestroyComponents;
ShutdownAllegro;
fLog.Trace (etDebug, 'Destroying application object... bye*');
fLog.Free;
fPrivateApplicationReference := Nil;
Application := Nil;
inherited Destroy
end;
procedure TA3DGEApplication.ShowErrorMessage (const aMessage: AnsiString);
procedure DrawItOnScreen; inline;
var
lColor: ALLEGRO_COLOR;
lHeight, lWidth: Integer;
begin
lHeight := fDisplay.Height;
lWidth := fDisplay.Width;
fDisplay.SetOrthographicProjection;
{ Draw a red box. }
al_draw_filled_rectangle (
1, lHeight div 3,
lWidth - 1, (lHeight div 3) * 2,
al_map_rgb_f (0.7, 0, 0)
);
{ Informative text. }
lColor := al_map_rgb_f (0.7, 0.7, 0.7);
al_draw_text (
fSystemTextFont, lColor,
lWidth div 2, (lHeight div 3) + 50, ALLEGRO_ALIGN_CENTER,
'An error was catched by the system.'
);
al_draw_text (
fSystemTextFont, lColor,
lWidth div 2, ((lHeight div 3) * 2) - 50, ALLEGRO_ALIGN_CENTER,
'Press [C] to continue...'
);
{ The error message. }
lColor := al_map_rgb_f (1, 1, 1);
al_draw_rectangle (
1, lHeight div 3, lWidth - 1, (lHeight div 3) * 2,
lColor, 1
);
al_draw_text (
fSystemTextFont, lColor,
lWidth div 2, lHeight div 2, ALLEGRO_ALIGN_CENTER,
al_string_to_str (aMessage)
);
fDisplay.FlipDisplay
end;
procedure WaitUserResponse;
var
lEvent: ALLEGRO_EVENT;
lEndLoop: Boolean;
begin
Self.PauseUpdates;
Self.ClearEventQueue;
try
lEndLoop := False;
repeat
al_wait_for_event (fEventQueue, @lEvent);
case lEvent.ftype of
ALLEGRO_EVENT_DISPLAY_CLOSE:
lEndLoop := True;
ALLEGRO_EVENT_KEY_DOWN:
if lEvent.keyboard.keycode in [ALLEGRO_KEY_ESCAPE, ALLEGRO_KEY_C] then
lEndLoop := True;
end
until lEndLoop
finally
Self.ClearEventQueue;
Self.ResumeUpdates
end
end;
begin
Self.Log.Trace (etInfo, Format ('Showing error message: "%s".',[aMessage]));
if fDisplay.IsOpen then
begin
fMouse.HideCursor;
DrawItOnScreen;
WaitUserResponse
end
else
WriteLn ('[Error] ', aMessage)
end;
procedure TA3DGEApplication.Initialize;
function LoadConfiguration: Boolean;
procedure ParseCommandLineOptions;
begin
{ Parse default command line options. }
if Self.HasOption ('h', 'help') then
begin
Self.PrintCommandLineOptions;
Self.Terminate;
Exit
end;
if Self.HasOption ('log') then
fConfigurationFile.SetValue ('engine', 'log', Self.GetOptionValue ('log'));
{ Parse game-spacific command line options. }
Self.ParseCommandLineOptions
end;
var
lStrValue: AnsiString;
begin
{ Open and load configuration. }
fConfigurationFile.Load;
ParseCommandLineOptions;
{ Configure. }
lStrValue := fConfigurationFile.GetValue ('engine', 'log', '');
if lStrValue <> '' then
begin
if lStrValue = 'all' then
fLog.Level := etAll
else if lStrValue = 'default' then
fLog.Level := etDefault
else if lStrValue = 'debug' then
fLog.Level := etDbg
else if lStrValue = 'none' then
fLog.Level := etNone
{ else invalid log value? }
end;
Result := not Self.Terminated
end;
function SetUpAllegro: Boolean; inline;
const
DefaultBitmapFlags = ALLEGRO_MIN_LINEAR or ALLEGRO_MAG_LINEAR or
ALLEGRO_MIPMAP or ALLEGRO_VIDEO_BITMAP;
begin
Result := al_init and al_install_keyboard and al_install_mouse and
al_init_image_addon and al_init_primitives_addon and
al_init_font_addon and al_init_ttf_addon and
al_init_acodec_addon;
if Result then
al_set_new_bitmap_flags (DefaultBitmapFlags)
end;
begin
inherited Initialize;
{$IfDef DEBUG} fLog.Level := etDbg; {$EndIf}
{ Needed for text based file formats.
That will make formatting decimal number would look different than standard
or locale, but also will unify output despite the system. It also avoids
silly bugs like this one: https://youtube.com/watch/?v=UJzI9XmI6RU
Of course, if programmer changes it somewhere it will ruin the loaders...
}
DefaultFormatSettings.DecimalSeparator := '.';
DefaultFormatSettings.ThousandSeparator := ','; { How to deactivate? }
if not LoadConfiguration then Exit;
fLog.Trace (etDebug, Concat ('A3DGE version: ', VersionStr));
{ Setup Allegro. }
fLog.Trace (etDebug, 'Initializing Allegro...');
if not SetUpAllegro then
begin
fLog.Trace (etError, 'Can''t initialize Allegro!');
fLog.Trace (etInfo, 'Be sure your Allegro version is 5.2.6 or compatible.');
raise Exception.Create ('Can''t initialize Allegro!')
end;
{ Setup engine. }
fEventQueue := al_create_event_queue;
if not Assigned (fEventQueue) then
raise A3DGEException.Create ('Cannot create event queue!?!?!');
fTimer := al_create_timer (ALLEGRO_BPS_TO_SECS (fTicksPerSecond));
al_register_event_source (fEventQueue, al_get_timer_event_source (fTimer));
fDisplay.Open;
al_register_event_source (fEventQueue, al_get_keyboard_event_source);
al_register_event_source (fEventQueue, al_get_mouse_event_source);
al_register_event_source (
fEventQueue,
al_get_display_event_source (fDisplay.fDisplay)
);
fSystemTextFont := al_create_builtin_font
end;
procedure TA3DGEApplication.AddGameState (
aGameState: TGameState;
const aName: AnsiString
);
var
lIndex: Integer;
begin
if aName <> EmptyStr then aGameState.Name := aName;
lIndex := Length (fGameStateList);
SetLength (fGameStateList, lIndex + 1);
fGameStateList[lIndex] := aGameState;
fLog.Trace (etDebug, Format ('Added game state "%s".', [aGameState.Name]));
if lIndex = 0 then fGameState.Current := aGameState
end;
function TA3DGEApplication.FindGameState (aName: AnsiString): TGameState;
begin
aName := LowerCase (aName);
for Result in fGameStateList do
if LowerCase (Result.Name) = aName then
Exit;
Result := Nil
end;
procedure TA3DGEApplication.PauseUpdates;
begin
fLog.Trace (etDebug, 'Updates paused!');
al_stop_timer (fTimer)
end;
procedure TA3DGEApplication.ResumeUpdates;
begin
fLog.Trace (etDebug, 'Updates resumed.');
al_resume_timer (fTimer)
end;
procedure TA3DGEApplication.ClearEventQueue;
begin
al_flush_event_queue (fEventQueue);
fKeyboard.Clear
end;
initialization
; { IIRC Delphi forces to have initialization if there's finalization. }
finalization
Application.Destroy
end.
