nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

154
.gitignore vendored Normal file
View File

@@ -0,0 +1,154 @@
## Gnat build artifacts
#
*.o
*.ali
*-loc.xml
gnatinspect.db
*~
auto.cgpr
*.stderr
*.stdout
*.a
*.log
.clang-format
.clangd
.#*
*.deps
*.d
.travis.yml
## Build folders
#
build
**/dsa/x86_64-unknown-linux-gnu
bin
## Source
#
2-low/neural/source/attic
2-low/neural/source/attic2
2-low/neural/implement
2-low/neural/applet/test/learn_linear/velocity.net
3-mid/impact/contrib
3-mid/physics/implement/impact/*
3-mid/physics/implement/vox/*
#3-mid/physics/implement/box2d/contrib
4-high/gel/source/platform/sdl/attic
## Assets
#
#**/assets/opengl
#**/assets/gel
**/assets/attic
3-mid/opengl/applet/demo/models/render_hex_grid/document
3-mid/opengl/applet/demo/models/render_hex_grid/assets
## Binaries
#
box2d_HelloWorld
launch_box_rig_1_bone_demo
launch_diffuse_light
launch_simple_instant_events_demo
launch_simple_deferred_events_demo
launch_simple_chat_client
launch_simple_chat_registrar
launch_outline
launch_parse_box
launch_learn_linear
launch_pong
launch_core_test
launch_opengl_model
launch_large_terrain_demo
launch_math_testsuite
launch_many_boxes_demo
launch_model_scaling
launch_modeller_test
launch_mouse_selection
launch_render_arrows
launch_render_asteroids
launch_render_billboards
launch_render_boxes
launch_render_screenshot
launch_render_text
launch_two_cameras_demo
launch_egl_linkage_test
generate_gl_types_spec
launch_freetype_linkage_test
launch_hello_physics_interface_2d_demo
launch_hello_physics_interface_3d_demo
launch_drop_ball_on_box
launch_drop_box_on_box
launch_gel_fused
launch_hello_gel
launch_human_rig_demo
launch_chains_2d
launch_hinged_box
launch_human_model
launch_human_model_v1
launch_mixed_joints
launch_mixed_joints_2d
launch_mixed_shapes
launch_text_sprite_demo
launch_impact_hello_3d_demo
launch_camera_demo
launch_render_lighting
launch_render_capsules
launch_rig_demo
launch_crunch
launch_render_models
launch_simple_animation
launch_full_demo
launch_hello_physics_interface_demo
launch_test_engine
launch_strings_demo
launch_add_rid
launch_add_rid_sprite_test
launch_pong_tute
build_all_lace
test_environ_paths
test_environ_compression
test_text_replace
test_environ_general
HelloWorld*
5-all/applet/build_all/build_all
test_dice
launch_hexagon_test
launch_render_hex_grid
## Old Code
#
*-old
*-orig
old-events
## Misc
#
*.ogv
*.project
opengl-series
attic
coding_style.txt
## Alire
#
obj/
lib/
alire/
config/
## Projects
#
2-low/neural/
3-mid/impact/

10
0-floor/lace_shared/alire.toml Normal file
View File

@@ -0,0 +1,10 @@
name = "lace_shared"
description = "Default settings for GPR files in the Lace project."
version = "0.1.1"
authors = ["Rod Kay"]
maintainers = ["Rod Kay <rodakay5@gmail.com>"]
maintainers-logins = ["charlie5"]
licenses = "ISC"
website = "https://github.com/charlie5/lace-alire"

3
0-floor/lace_shared/debug.pra Normal file
View File

@@ -0,0 +1,3 @@
pragma Initialize_Scalars;
-- pragma Normalize_Scalars; -- For all units!

167
0-floor/lace_shared/lace_shared.gpr Normal file
View File

@@ -0,0 +1,167 @@
abstract
project Lace_shared
is
-- Scenario Variables
--
type Os_Type is
("Windows_NT", "Linux", "MacOSX");
lace_OS : Os_Type := external ("Lace_OS", "Linux");
type Restrictions_Type is
("xgc", "ravenscar");
lace_Restrictions : Restrictions_Type := external ("Lace_Restrictions", "xgc");
type Build_Mode_Type is
("debug", "fast", "small");
lace_Build_Mode : Build_Mode_Type := external ("Lace_Build_Mode", "debug");
-- Declare various options.
--
Binder_Options := ();
Style_Options := ("-gnatyk", -- Check casings: a:attribute, k:keywords, n:package Standard identifiers, p:pragma, r:identifier references.
"-gnatybfhi", -- Check b:no blanks at end of lines, f:no ff/vtabs, h: no htabs, i:if-then layout, u:no unnecessary blank lines.
"-gnatyO", -- Check that overriding subprograms are explicitly marked as such.
"-gnatye", -- Check that labels on end statements (ending subprograms), and on exit statements (exiting named loops), are present.
"-gnatyx"); -- Check x:no extra parens.
Compiler_Options := ("-gnat2022",
"-gnatwa",
"-fno-strict-aliasing")
& Style_Options;
Fast_Options := ("-O2",
"-gnatn",
"-gnatp",
"-funroll-loops",
"-fpeel-loops",
"-ftracer",
"-funswitch-loops",
"-fweb",
"-frename-registers");
Small_Options := ("-Os",
"-gnatp",
"-fno-inline",
"-march=i386",
"-ffunction-sections",
"-falign-jumps=0",
"-falign-loops=0",
"-falign-functions=0",
"-mpreferred-stack-boundary=2");
-- Modify options to cater for the build mode.
--
case lace_Build_Mode
is
when "debug" =>
Binder_Options := Binder_Options & "-Es";
Compiler_Options := Compiler_Options & "-O0"
& "-gnato"
& "-fstack-check"
& "-g";
case lace_OS
is
when "Linux" =>
Compiler_Options := Compiler_Options & "-gnatVa";
when "Windows_NT" =>
Compiler_Options := Compiler_Options & "-fno-inline"
& "-gnatVcdeimoprst";
-- & "-gnatVf" -- (2016) turned off floating point validity check, seems to give
-- false positives on a scalar product for collision detection
when "MacOSX" =>
null;
end case;
when "fast" =>
case lace_OS
is
when "Linux" =>
Compiler_Options := Compiler_Options & Fast_Options
& "-fomit-frame-pointer";
when "Windows_NT" =>
Compiler_Options := Compiler_Options & Fast_Options
& "-fipa-cp-clone"
& "-fgcse-after-reload"
& "-ftree-vectorize"
& "-mfpmath=sse"
& "-msse3";
when "MacOSX" =>
null;
end case;
when "small" =>
case lace_OS
is
when "Linux" =>
Compiler_Options := Compiler_Options & Small_Options
& "-fdata-sections";
when "Windows_NT" =>
Compiler_Options := Compiler_Options & Small_Options;
when "MacOSX" =>
null;
end case;
end case;
-- Modify options to cater for the operating system.
--
case lace_OS
is
when "MacOSX" =>
Compiler_Options := Compiler_Options & "-gnatf"
& "-gnatE"
& "-gnatVcfimorst"
& "-gnatyhiknp";
when "Linux" =>
Binder_Options := Binder_Options & "-static";
when "Windows_NT" =>
null;
end case;
-- Define the packages.
--
package Ide is
case lace_OS
is
when "Linux" => for Default_Switches ("adacontrol") use ("-Ftgnat_short");
when "Windows_NT" => for Default_Switches ("adacontrol") use ("-F", "gnat_short");
when "MacOSX" => for Default_Switches ("adacontrol") use ();
end case;
end Ide;
package Builder is
for Default_Switches ("ada") use ("-C", "-j0");
case lace_Build_Mode
is
when "debug" => for Global_Configuration_Pragmas use "debug.pra";
for Default_Switches ("ada") use ("-C", "-j0", "-gnat2022"); -- TODO: Create and use a Builder_Options variable ?
when "fast" => null;
when "small" => null;
end case;
end Builder;
package Compiler is
for Default_Switches ("ada") use Compiler_Options;
end Compiler;
package Binder is
for Default_Switches ("ada") use Binder_Options;
end Binder;
end Lace_shared;

15
1-base/lace/Overview Normal file
View File

@@ -0,0 +1,15 @@
Lace ~ Overview
~~~~~~~~~~~~~~~
General:
- Contains a set of low level re-usable Ada components.
Contains:
- lace.Events : Provides a 'subject/oberver' 'event/response' facility.
- lace.Any : Provides an interface to allow heterogenous containers.
- lace.fast_Pool : Provides a generic which allows fast allocation/deallocation.
- lace.Text : Provides a DSA friendly set of text operations.

18
1-base/lace/alire.toml Normal file
View File

@@ -0,0 +1,18 @@
name = "lace"
description = "Contains a set of low level re-usable Ada components."
version = "0.1.1"
authors = ["Rod Kay"]
maintainers = ["Rod Kay <rodakay5@gmail.com>"]
maintainers-logins = ["charlie5"]
licenses = "ISC"
website = "https://github.com/charlie5/lace-alire"
tags = ["event", "response", "subject", "observer", "pool", "text"]
long-description = "\nContains:\n\n - lace.Events : Provides a 'subject/oberver' 'event/response' facility.\n - lace.Any : Provides an interface to allow heterogenous containers.\n - lace.fast_Pool : Provides a generic which allows fast allocation/deallocation.\n - lace.Text : Provides a DSA friendly set of text operations.\n\n"
project-files = ["library/lace.gpr"]
[[depends-on]]
lace_shared = "~0.1"

14
1-base/lace/applet/demo/event/distributed/builder.sh Executable file
View File

@@ -0,0 +1,14 @@
#!/bin/bash
set -e
export OS=Linux
mkdir -p build
rm -fr dsa
export Build_Mode=debug
po_gnatdist -P simple_chat.gpr simple_chat.dsa -cargs -g -largs -g
#rm -fr build
#rm -fr dsa

47
1-base/lace/applet/demo/event/distributed/launch_simple_chat_client.adb Normal file
View File

@@ -0,0 +1,47 @@
with
chat.Client.local,
lace.Event.utility,
ada.Characters.latin_1,
ada.command_Line,
ada.Text_IO,
ada.Exceptions;
procedure launch_simple_chat_Client
--
-- Starts a chat client.
--
is
use ada.Text_IO;
begin
-- Usage
--
if ada.command_Line.argument_Count /= 1
then
put_Line ("Usage: $ ./launch_simple_chat_Client <nickname>");
return;
end if;
declare
use chat.Client.local;
client_Name : constant String := ada.command_Line.Argument (1);
the_Client : chat.Client.local.item := to_Client (client_Name);
begin
the_Client.start;
end;
exception
when E : others =>
lace.Event.utility.close;
new_Line;
put_Line ("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~");
put_Line ("Unhandled exception, aborting. Please report the following to developer.");
put_Line ("________________________________________________________________________");
put_Line (ada.Exceptions.exception_Information (E));
put (ada.Characters.latin_1.ESC & "[1A"); -- Move cursor up.
put_Line ("________________________________________________________________________");
new_Line;
end launch_simple_chat_Client;

35
1-base/lace/applet/demo/event/distributed/launch_simple_chat_registrar.adb Normal file
View File

@@ -0,0 +1,35 @@
with
chat.Registrar,
ada.Exceptions,
ada.Characters.latin_1,
ada.Text_IO;
procedure launch_simple_chat_Registrar
--
-- Launches the chat registrar.
--
is
use ada.Text_IO;
begin
loop
declare
Command : constant String := get_Line;
begin
exit when Command = "q";
end;
end loop;
put_Line ("Shutting down.");
chat.Registrar.shutdown;
exception
when E : others =>
new_Line;
put_Line ("~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~");
put_Line ("Unhandled exception, aborting. Please report the following to developer.");
put_Line ("________________________________________________________________________");
put_Line (ada.Exceptions.exception_Information (E));
put (ada.Characters.latin_1.ESC & "[1A"); -- Move cursor up.
put_Line ("________________________________________________________________________");
new_Line;
end launch_simple_chat_Registrar;

70
1-base/lace/applet/demo/event/distributed/simple_chat.dsa Normal file
View File

@@ -0,0 +1,70 @@
configuration simple_Chat is
pragma Starter (none);
--
-- Tell 'po_gnatdist' to not create any startup script or launcher.
-- We will launch our Server and Client partitions manually from a console.
-- Server
--
registrar_Partition : partition := (chat.Registrar);
--
-- Declare the Registrar partition and assign the Registrars 'remote call interface' package to this partition.
for registrar_Partition'Termination use Local_Termination;
procedure launch_simple_chat_Registrar is in registrar_Partition;
--
-- Tell po_gnatdist that the 'launch_simple_chat_Registrar' procedure is the the Servers 'main' subprogram or launcher.
-- Client
--
client_Partition : partition;
--
-- Declare the Client partition (which has no remote call interface package associated with it, so no 'initialisation' is required).
procedure launch_simple_chat_Client;
--
-- Declare the Clients 'main' subprogram or launcher.
for client_Partition'Main use launch_simple_chat_Client;
--
-- Tell po_gnatdist to assign the above declared 'launch_simple_chat_Client' procedure as the Clients 'main' subprogram or launcher.
for client_Partition'Termination use Local_Termination;
--
-- Tell po_Gnatdist that Clients may terminate locally (more on this later).
-- Channels
--
-- The zip filter works only on 32 bits machines, don't try it on Digital Unix/Alpha.
--
-- Channel_1 : Channel := (server_Partition, client_Partition);
-- for Channel_1'Filter use "zip";
-- Misc
--
for Partition'Directory use "bin";
--
-- Ask po_gnatdist to place the built Client and Server partition executables in the './bin' sub-folder.
end simple_Chat;

28
1-base/lace/applet/demo/event/distributed/simple_chat.gpr Normal file
View File

@@ -0,0 +1,28 @@
with
"lace",
"lace_shared";
project simple_Chat
is
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
-- for Main use ("launch_simple_chat_client.adb",
-- "launch_simple_chat_registrar.adb");
for Source_Dirs use (".",
"source");
package Dsa is
for Configuration_File use "simple_chat.dsa";
end Dsa;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end simple_Chat;

297
1-base/lace/applet/demo/event/distributed/source/chat-client-local.adb Normal file
View File

@@ -0,0 +1,297 @@
with
chat.Registrar,
lace.Response,
lace.Observer,
lace.Event.utility,
system.RPC,
ada.Exceptions,
ada.Text_IO;
package body chat.Client.local
is
-- Utility
--
function "+" (From : in unbounded_String) return String
renames to_String;
-- Responses
--
type Show is new lace.Response.item with null record;
-- Response is to display the chat message on the users console.
--
overriding
procedure respond (Self : in out Show; to_Event : in lace.Event.item'Class)
is
pragma Unreferenced (Self);
use ada.Text_IO;
the_Message : constant Message := Message (to_Event);
begin
put_Line (the_Message.Text (1 .. the_Message.Length));
end respond;
the_Response : aliased chat.Client.local.show;
-- Forge
--
function to_Client (Name : in String) return Item
is
begin
return Self : Item
do
Self.Name := to_unbounded_String (Name);
end return;
end to_Client;
-- Attributes
--
overriding
function Name (Self : in Item) return String
is
begin
return to_String (Self.Name);
end Name;
overriding
function as_Observer (Self : access Item) return lace.Observer.view
is
begin
return Self;
end as_Observer;
overriding
function as_Subject (Self : access Item) return lace.Subject.view
is
begin
return Self;
end as_Subject;
-- Operations
--
overriding
procedure register_Client (Self : in out Item; other_Client : in Client.view)
is
use lace.Event.utility,
ada.Text_IO;
begin
lace.Event.utility.connect (the_Observer => Self'unchecked_Access,
to_Subject => other_Client.as_Subject,
with_Response => the_Response'Access,
to_Event_Kind => to_Kind (chat.Client.Message'Tag));
put_Line (other_Client.Name & " is here.");
end register_Client;
overriding
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String)
is
use lace.Event.utility,
ada.Text_IO;
begin
begin
Self.as_Subject.deregister (other_Client_as_Observer,
to_Kind (chat.Client.Message'Tag));
exception
when constraint_Error =>
raise unknown_Client with "Other client not known. Deregister is not required.";
end;
Self.as_Observer.rid (the_Response'unchecked_Access,
to_Kind (chat.Client.Message'Tag),
other_Client_Name);
put_Line (other_Client_Name & " leaves.");
end deregister_Client;
overriding
procedure Registrar_has_shutdown (Self : in out Item)
is
use ada.Text_IO;
begin
put_Line ("The Registrar has shutdown. Press <Enter> to exit.");
Self.Registrar_has_shutdown := True;
end Registrar_has_shutdown;
task check_Registrar_lives
is
entry start (Self : in chat.Client.local.view);
entry halt;
end check_Registrar_lives;
task body check_Registrar_lives
is
use ada.Text_IO;
Done : Boolean := False;
Self : chat.Client.local.view;
begin
loop
select
accept start (Self : in chat.Client.local.view)
do
check_Registrar_lives.Self := Self;
end start;
or
accept halt
do
Done := True;
end halt;
or
delay 15.0;
end select;
exit when Done;
begin
chat.Registrar.ping;
exception
when system.RPC.communication_Error =>
put_Line ("The Registrar has died. Press <Enter> to exit.");
Self.Registrar_is_dead := True;
end;
end loop;
exception
when E : others =>
new_Line;
put_Line ("Error in check_Registrar_lives task.");
new_Line;
put_Line (ada.exceptions.exception_Information (E));
end check_Registrar_lives;
procedure start (Self : in out chat.Client.local.item)
is
use ada.Text_IO;
begin
-- Setup
--
begin
chat.Registrar.register (Self'unchecked_Access); -- Register our client with the registrar.
exception
when chat.Registrar.Name_already_used =>
put_Line (+Self.Name & " is already in use.");
check_Registrar_lives.halt;
return;
end;
lace.Event.utility.use_text_Logger ("events");
check_Registrar_lives.start (Self'unchecked_Access);
declare
Peers : constant chat.Client.views := chat.Registrar.all_Clients;
begin
for i in Peers'Range
loop
if Self'unchecked_Access /= Peers (i)
then
begin
Peers (i).register_Client (Self'unchecked_Access); -- Register our client with all other clients.
Self .register_Client (Peers (i)); -- Register all other clients with our client.
exception
when system.RPC.communication_Error
| storage_Error =>
null; -- Peer (i) has died, so ignore it and do nothing.
end;
end if;
end loop;
end;
-- Main loop
--
loop
declare
procedure broadcast (the_Text : in String)
is
the_Message : constant chat.Client.Message := (Length (Self.Name) + 2 + the_Text'Length,
+Self.Name & ": " & the_Text);
begin
Self.emit (the_Message);
end broadcast;
chat_Message : constant String := get_Line;
begin
exit
when chat_Message = "q"
or Self.Registrar_has_shutdown
or Self.Registrar_is_dead;
broadcast (chat_Message);
end;
end loop;
-- Shutdown
--
if not Self.Registrar_has_shutdown
and not Self.Registrar_is_dead
then
begin
chat.Registrar.deregister (Self'unchecked_Access);
exception
when system.RPC.communication_Error =>
Self.Registrar_is_dead := True;
end;
if not Self.Registrar_is_dead
then
declare
Peers : constant chat.Client.views := chat.Registrar.all_Clients;
begin
for i in Peers'Range
loop
if Self'unchecked_Access /= Peers (i)
then
begin
Peers (i).deregister_Client ( Self'unchecked_Access, -- Deregister our client with every other client.
+Self.Name);
exception
when system.RPC.communication_Error
| storage_Error =>
null; -- Peer is dead, so do nothing.
end;
end if;
end loop;
end;
end if;
end if;
check_Registrar_lives.halt;
lace.Event.utility.close;
end start;
-- 'last_chance_Handler' is commented out to avoid multiple definitions
-- of link symbols in 'build_All' test procedure (Tier 5).
--
-- procedure last_chance_Handler (Msg : in system.Address;
-- Line : in Integer);
--
-- pragma Export (C, last_chance_Handler,
-- "__gnat_last_chance_handler");
--
-- procedure last_chance_Handler (Msg : in System.Address;
-- Line : in Integer)
-- is
-- pragma Unreferenced (Msg, Line);
-- use ada.Text_IO;
-- begin
-- put_Line ("The Registrar is not running.");
-- put_Line ("Press Ctrl-C to quit.");
-- check_Registrar_lives.halt;
-- delay Duration'Last;
-- end last_chance_Handler;
end chat.Client.local;

68
1-base/lace/applet/demo/event/distributed/source/chat-client-local.ads Normal file
View File

@@ -0,0 +1,68 @@
with
lace.Any;
private
with
lace.make_Subject,
lace.make_Observer,
ada.Strings.unbounded;
package chat.Client.local
--
-- Provides a local client.
-- Names must be unique.
--
is
type Item is limited new lace.Any.limited_item
and chat.Client .item with private;
type View is access all Item'Class;
-- Forge
--
function to_Client (Name : in String) return Item;
-- Attributes
--
overriding
function Name (Self : in Item) return String;
overriding
function as_Observer (Self : access Item) return lace.Observer.view;
overriding
function as_Subject (Self : access Item) return lace.Subject.view;
-- Operations
--
procedure start (Self : in out chat.Client.local.item);
overriding
procedure register_Client (Self : in out Item; other_Client : in Client.view);
overriding
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String);
overriding
procedure Registrar_has_shutdown (Self : in out Item);
private
package Observer is new lace.make_Observer (lace.Any.limited_item);
package Subject is new lace.make_Subject (Observer .item);
use ada.Strings.unbounded;
type Item is limited new Subject .item
and chat.Client.item with
record
Name : unbounded_String;
Registrar_has_shutdown : Boolean := False;
Registrar_is_dead : Boolean := False;
end record;
end chat.Client.local;

43
1-base/lace/applet/demo/event/distributed/source/chat-client.ads Normal file
View File

@@ -0,0 +1,43 @@
with
lace.Event,
lace.Subject,
lace.Observer;
package chat.Client
--
-- Provides an interface to a chat client.
--
is
pragma remote_Types;
type Item is limited interface
and lace.Subject .item
and lace.Observer.item;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
procedure Registrar_has_shutdown (Self : in out Item) is abstract;
procedure ping (Self : in Item) is null;
procedure register_Client (Self : in out Item; other_Client : in Client.view) is abstract;
procedure deregister_Client (Self : in out Item; other_Client_as_Observer : in lace.Observer.view;
other_Client_Name : in String) is abstract;
--
-- Raises unknown_Client exception when the other_Client is unknown.
function as_Observer (Self : access Item) return lace.Observer.view is abstract;
function as_Subject (Self : access Item) return lace.Subject .view is abstract;
type Message (Length : Natural) is new lace.Event.item with
record
Text : String (1..Length);
end record;
unknown_Client : exception;
end chat.Client;

249
1-base/lace/applet/demo/event/distributed/source/chat-registrar.adb Normal file
View File

@@ -0,0 +1,249 @@
with
lace.Observer,
system.RPC,
ada.Exceptions,
ada.Strings.unbounded,
ada.Text_IO;
package body chat.Registrar
is
use ada.Strings.unbounded;
use type Client.view;
procedure last_chance_Handler (Msg : in system.Address;
Line : in Integer);
pragma Export (C, last_chance_Handler,
"__gnat_last_chance_handler");
procedure last_chance_Handler (Msg : in System.Address;
Line : in Integer)
is
pragma Unreferenced (Msg, Line);
use ada.Text_IO;
begin
put_Line ("Unable to start the Registrar.");
put_Line ("Please ensure the 'po_cos_naming' server is running.");
put_Line ("Press Ctrl-C to quit.");
delay Duration'Last;
end last_chance_Handler;
type client_Info is
record
View : Client.view;
Name : unbounded_String;
as_Observer : lace.Observer.view;
end record;
type client_Info_array is array (Positive range <>) of client_Info;
max_Clients : constant := 5_000;
-- Protection against race conditions.
--
protected safe_Clients
is
procedure add (the_Client : in Client.view);
procedure rid (the_Client : in Client.view);
function all_client_Info return client_Info_array;
private
Clients : client_Info_array (1 .. max_Clients);
end safe_Clients;
protected body safe_Clients
is
procedure add (the_Client : in Client.view)
is
function "+" (From : in String) return unbounded_String
renames to_unbounded_String;
begin
for i in Clients'Range
loop
if Clients (i).View = null then
Clients (i).View := the_Client;
Clients (i).Name := +the_Client.Name;
Clients (i).as_Observer := the_Client.as_Observer;
return;
end if;
end loop;
end add;
procedure rid (the_Client : in Client.view)
is
begin
for i in Clients'Range
loop
if Clients (i).View = the_Client then
Clients (i).View := null;
return;
end if;
end loop;
raise Program_Error with "Unknown client";
end rid;
function all_client_Info return client_Info_array
is
Count : Natural := 0;
Result : client_Info_array (1..max_Clients);
begin
for i in Clients'Range
loop
if Clients (i).View /= null
then
Count := Count + 1;
Result (Count) := Clients (i);
end if;
end loop;
return Result (1..Count);
end all_client_Info;
end safe_Clients;
procedure register (the_Client : in Client.view)
is
Name : constant String := the_Client.Name;
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
begin
for Each of all_Info
loop
if Each.Name = Name
then
raise Name_already_used;
end if;
end loop;
safe_Clients.add (the_Client);
end register;
procedure deregister (the_Client : in Client.view)
is
begin
safe_Clients.rid (the_Client);
end deregister;
function all_Clients return chat.Client.views
is
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
Result : chat.Client.views (all_Info'Range);
begin
for i in Result'Range
loop
Result (i) := all_Info (i).View;
end loop;
return Result;
end all_Clients;
task check_Client_lives
is
entry halt;
end check_Client_lives;
task body check_Client_lives
is
use ada.Text_IO;
Done : Boolean := False;
begin
loop
select
accept halt
do
Done := True;
end halt;
or
delay 15.0;
end select;
exit when Done;
declare
all_Info : constant client_Info_array := safe_Clients.all_client_Info;
Dead : client_Info_array (all_Info'Range);
dead_Count : Natural := 0;
function "+" (From : in unbounded_String) return String
renames to_String;
begin
for Each of all_Info
loop
begin
Each.View.ping;
exception
when system.RPC.communication_Error
| storage_Error =>
put_Line (+Each.Name & " has died.");
deregister (Each.View);
dead_Count := dead_Count + 1;
Dead (dead_Count) := Each;
end;
end loop;
declare
all_Clients : constant Client.views := chat.Registrar.all_Clients;
begin
for Each of all_Clients
loop
for i in 1 .. dead_Count
loop
begin
put_Line ("Ridding " & (+Dead (i).Name) & " from " & Each.Name);
Each.deregister_Client ( Dead (i).as_Observer,
+Dead (i).Name);
exception
when chat.Client.unknown_Client =>
put_Line ("Deregister of " & (+Dead (i).Name) & " from " & Each.Name & " is not needed.");
end;
end loop;
end loop;
end;
end;
end loop;
exception
when E : others =>
new_Line;
put_Line ("Error in check_Client_lives task.");
new_Line;
put_Line (ada.Exceptions.exception_Information (E));
end check_Client_lives;
procedure shutdown
is
all_Clients : constant Client.views := chat.Registrar.all_Clients;
begin
for Each of all_Clients
loop
begin
Each.Registrar_has_shutdown;
exception
when system.RPC.communication_Error =>
null; -- Client has died. No action needed since we are shutting down.
end;
end loop;
check_Client_lives.halt;
end shutdown;
procedure ping is null;
end chat.Registrar;

22
1-base/lace/applet/demo/event/distributed/source/chat-registrar.ads Normal file
View File

@@ -0,0 +1,22 @@
with
chat.Client;
package chat.Registrar
--
-- A singleton providing the central chat registrar.
-- Limited to a maximum of 5_000 chat clients running at once.
--
is
pragma remote_Call_interface;
Name_already_used : exception;
procedure register (the_Client : in Client.view);
procedure deregister (the_Client : in Client.view);
function all_Clients return chat.Client.views;
procedure ping;
procedure shutdown;
end chat.Registrar;

7
1-base/lace/applet/demo/event/distributed/source/chat.ads Normal file
View File

@@ -0,0 +1,7 @@
package Chat
--
-- Provides a namespace for the chat family.
--
is
pragma Pure;
end Chat;

18
1-base/lace/applet/demo/event/distributed/test/lan/README Normal file
View File

@@ -0,0 +1,18 @@
Edit /etc/hosts to force usage of 127.0.0.1 by po_cos_naming.
For instance, given ...
/etc/hostname
foo
/etc/hosts
127.0.0.1 localhost
192.168.1.10 foo.mydomain.org foo
... change to ...
/etc/hosts
127.0.0.1 localhost
# 192.168.1.10 foo.mydomain.org foo

12
1-base/lace/applet/demo/event/distributed/test/lan/client_1/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_1.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5003

5
1-base/lace/applet/demo/event/distributed/test/lan/client_1/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/client_partition rod

12
1-base/lace/applet/demo/event/distributed/test/lan/client_2/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_2.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5004

5
1-base/lace/applet/demo/event/distributed/test/lan/client_2/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/client_partition ian

7
1-base/lace/applet/demo/event/distributed/test/lan/po_namer/polyorb.conf Normal file
View File

@@ -0,0 +1,7 @@
# PolyORB configuration file for polyorb cos name server.
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5001

5
1-base/lace/applet/demo/event/distributed/test/lan/po_namer/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
po_cos_naming

12
1-base/lace/applet/demo/event/distributed/test/lan/registrar/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Registrar server.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5002

5
1-base/lace/applet/demo/event/distributed/test/lan/registrar/test.sh Executable file
View File

@@ -0,0 +1,5 @@
#!/bin/bash
set -e
../../../bin/registrar_partition

12
1-base/lace/applet/demo/event/distributed/test/wan/client_1/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_1.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5003

12
1-base/lace/applet/demo/event/distributed/test/wan/client_2/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Client_2.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5004

7
1-base/lace/applet/demo/event/distributed/test/wan/po_namer/polyorb.conf Normal file
View File

@@ -0,0 +1,7 @@
# PolyORB configuration file for polyorb cos name server.
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5001

12
1-base/lace/applet/demo/event/distributed/test/wan/registrar/polyorb.conf Normal file
View File

@@ -0,0 +1,12 @@
# PolyORB configuration file for the chat Registrar server.
[dsa]
name_service=corbaloc:iiop:1.2@127.0.0.1:5001/NameService/000000024fF0000000080000000
[iiop]
## IIOP default port
#
polyorb.protocols.iiop.default_port=5002

27
1-base/lace/applet/demo/event/simple/deferred/lace_simple_deferred_events_demo.gpr Normal file
View File

@@ -0,0 +1,27 @@
with
"../lace_demo",
"lace",
"lace_shared";
project lace_simple_deferred_Events_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
for Source_Dirs use (".");
for Main use ("launch_simple_deferred_events_demo.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end lace_simple_deferred_Events_Demo;

81
1-base/lace/applet/demo/event/simple/deferred/launch_simple_deferred_events_demo.adb Normal file
View File

@@ -0,0 +1,81 @@
with
lace_demo_Events,
lace_demo_Keyboard,
lace.Observer.deferred,
lace.Subject .local,
lace.Response,
lace.Event.utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
procedure launch_simple_deferred_events_Demo
--
-- A simple demonstration of the Lace deferred event system.
--
is
use lace_demo_Events,
lace.Event,
lace.event.Utility,
Lace,
ada.text_IO,
ada.Strings.unbounded,
ada.real_Time;
-- Key Response
--
type key_Map_of_message is array (Character) of unbounded_String;
type key_Response is new Response.item with
record
key_to_message_Map : key_Map_of_message;
end record;
overriding
procedure respond (Self : in out key_Response; to_Event : in Event.item'Class)
is
the_Event : keyboard_Event renames keyboard_Event (to_Event);
begin
put_Line ( "Message is: " -- Our response is to display the message associated
& to_String (Self.key_to_message_Map (the_Event.Key))); -- with the keyboard event key on the console.
end respond;
--- Globals
--
the_Subject : Subject.local.view;
the_Observer : constant Observer.deferred.view := Observer.deferred.forge.new_Observer ("demo.Observer");
the_Response : aliased key_Response := (Response.item with
key_to_message_Map => ['a' => to_unbounded_String ("'a' was received from demo keyboard."),
'b' => to_unbounded_String ("'b' was received from demo keyboard."),
others => to_unbounded_String ("Unhandled key was received from demo keyboard.")]);
Now : ada.real_Time.Time := ada.real_Time.Clock;
begin
Event.utility.use_text_Logger (log_filename => "events_demo"); -- Enable 'simple text file' event logging.
the_Subject := lace_demo_Keyboard.as_event_Subject; -- Get a reference to the keyboard as an event subject.
Event.utility.connect (the_observer => Observer.view (the_Observer), -- Setup out response to a keyboard event.
to_subject => Subject .view (the_Subject),
with_response => the_Response'unchecked_Access,
to_event_kind => to_Kind (keyboard_Event'Tag));
lace_demo_Keyboard.start;
for Each in 1 .. 5
loop -- Our main loop.
the_Observer.respond; -- Response to any queued events occur here.
Now := Now + to_time_Span (1.0);
delay until Now;
end loop;
lace_demo_Keyboard.stop;
Event.utility.close; -- Ensures event logging is closed (ie saved to log file).
end launch_simple_deferred_events_Demo;

27
1-base/lace/applet/demo/event/simple/instant/lace_simple_instant_events_demo.gpr Normal file
View File

@@ -0,0 +1,27 @@
with
"../lace_demo",
"lace",
"lace_shared";
project lace_simple_instant_Events_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
for Source_Dirs use (".");
for Main use ("launch_simple_instant_events_demo.adb");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end lace_simple_instant_Events_Demo;

80
1-base/lace/applet/demo/event/simple/instant/launch_simple_instant_events_demo.adb Normal file
View File

@@ -0,0 +1,80 @@
with
lace_demo_Events,
lace_demo_Keyboard,
lace.Observer.instant,
lace.Subject .local,
lace.Response,
lace.Event.utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
procedure launch_simple_instant_events_Demo
--
-- A simple demonstration of the Lace event system.
--
is
use lace_demo_Events,
Lace,
lace.Event,
lace.event.Utility,
ada.Text_IO,
ada.Strings.unbounded,
ada.real_Time;
-- key_Response
--
type key_Map_of_message is array (Character) of unbounded_String;
type key_Response is new Response.item with
record
key_to_message_Map : key_Map_of_message;
end record;
overriding
procedure respond (Self : in out key_Response; to_Event : in Event.item'Class)
is
the_Event : keyboard_Event renames keyboard_Event (to_Event);
begin
put_Line ( "Message is: " -- Our response is to display the message associated
& to_String (Self.key_to_message_Map (the_Event.Key))); -- with the keyboard event key on the console.
end respond;
-- Globals
--
the_Subject : Subject.local.view;
the_Observer : constant Observer.instant.view := Observer.instant.forge.new_Observer ("demo.Observer");
the_Response : aliased key_Response := (Response.item with
key_to_message_Map => ['a' => to_unbounded_String ("'a' was received from demo keyboard."),
'b' => to_unbounded_String ("'b' was received from demo keyboard."),
others => to_unbounded_String ("Unhandled key was received from demo keyboard.")]);
Now : ada.real_Time.Time := ada.real_Time.Clock;
begin
event.Utility.use_text_Logger (log_filename => "events_demo"); -- Enable simple text file event logging.
the_Subject := lace_demo_Keyboard.as_event_Subject; -- Get a reference to the keyboard as an event subject.
event.Utility.connect (the_observer => Observer.view (the_Observer), -- Setup our response to a keyboard event.
to_subject => Subject .view (the_Subject),
with_response => the_Response'unchecked_Access,
to_event_kind => to_Kind (keyboard_Event'Tag));
lace_demo_Keyboard.start;
for Each in 1 .. 5
loop -- Our main loop.
Now := Now + to_time_Span (1.0);
delay until Now;
end loop;
lace_demo_Keyboard.stop;
event.Utility.close; -- Ensure event logging is closed (ie saved to log file).
end launch_simple_instant_events_Demo;

24
1-base/lace/applet/demo/event/simple/lace_demo.gpr Normal file
View File

@@ -0,0 +1,24 @@
with
"lace",
"lace_shared";
project lace_Demo
is
type Restrictions is ("xgc", "ravenscar");
Restrictions : Restrictions := external ("restrictions");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Source_Dirs use (".");
package Ide renames Lace_shared.Ide;
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end lace_Demo;

16
1-base/lace/applet/demo/event/simple/lace_demo_events.ads Normal file
View File

@@ -0,0 +1,16 @@
with
lace.Event;
package lace_demo_Events
--
-- Provides a simple derived lace 'event'.
--
is
pragma remote_Types;
type keyboard_Event is new lace.Event.item with
record
Key : Character;
end record;
end lace_demo_Events;

77
1-base/lace/applet/demo/event/simple/lace_demo_keyboard.adb Normal file
View File

@@ -0,0 +1,77 @@
with
lace_demo_Events,
ada.real_Time;
package body lace_demo_Keyboard
is
use lace_demo_Events,
Lace,
ada.real_Time;
--- Simulated Keyboard
--
the_event_Subject : constant Subject.local.view := Subject.local.forge.new_Subject ("demo.Subject");
task type simulated_Keyboard
is
entry start;
entry stop;
end simulated_Keyboard;
task body simulated_Keyboard
is
Count : Natural := 0;
Now : ada.real_Time.Time := ada.real_Time.Clock;
Done : Boolean := False;
begin
accept start;
loop
select
accept stop
do
Done := True;
end stop;
or
delay until Now;
end select;
exit when Done;
if Count mod 3 = 0
then
the_event_Subject.emit (the_Event => keyboard_Event'(key => 'a'));
else
the_event_Subject.emit (the_Event => keyboard_Event'(key => 'b'));
end if;
Count := Count + 1;
Now := Now + to_time_Span (0.5);
end loop;
end simulated_Keyboard;
the_simulated_Keyboard : simulated_Keyboard;
function as_event_Subject return lace.Subject.local.view
is
begin
return the_event_Subject;
end as_event_Subject;
procedure start
is
begin
the_simulated_Keyboard.start;
end start;
procedure stop
is
begin
the_simulated_Keyboard.stop;
end stop;
end lace_demo_Keyboard;

14
1-base/lace/applet/demo/event/simple/lace_demo_keyboard.ads Normal file
View File

@@ -0,0 +1,14 @@
with
lace.Subject.local;
package lace_demo_Keyboard
--
-- Provides a simulated keyboard which periodically emits 'key' events.
--
is
function as_event_Subject return lace.Subject.local.view;
procedure start;
procedure stop;
end lace_demo_Keyboard;

20
1-base/lace/applet/demo/strings/launch_strings_demo.adb Normal file
View File

@@ -0,0 +1,20 @@
with
lace.Strings.bounded,
ada.Text_IO;
procedure launch_strings_Demo
--
-- Displays a string message in a Pure unit.
--
is
use ada.Text_IO;
package Text is new lace.Strings.Bounded.Generic_Bounded_Length (Max => 64);
use Text;
the_String : bounded_String := to_bounded_String ("Howdy ...");
begin
append (the_String, " doody !");
put_Line (to_String (the_String));
end launch_strings_Demo;

25
1-base/lace/applet/demo/strings/strings_demo.gpr Normal file
View File

@@ -0,0 +1,25 @@
with "lace";
project Strings_Demo
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("launch_strings_demo.adb");
package Builder is
for Default_Switches ("ada") use ("-g");
end Builder;
package Compiler is
for Default_Switches ("ada") use ("-gnato", "-fstack-check", "-g", "-gnata", "-gnat2022");
end Compiler;
package Binder is
for Default_Switches ("ada") use ("-E");
end Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end Strings_Demo;

74
1-base/lace/applet/test/dice/test_dice.adb Normal file
View File

@@ -0,0 +1,74 @@
with
lace.Dice.d6,
lace.Dice.any,
ada.Text_IO;
procedure test_Dice
is
procedure log (Message : in String) renames ada.Text_IO.put_Line;
test_Error : exception;
begin
log ("Begin Test");
-- d6x1
--
log ("");
log ("d6x1_less5 Roll:" & lace.Dice.d6.d6x1_less5.Roll'Image);
log ("d6x1_less4 Roll:" & lace.Dice.d6.d6x1_less4.Roll'Image);
log ("d6x1_less3 Roll:" & lace.Dice.d6.d6x1_less3.Roll'Image);
log ("d6x1_less2 Roll:" & lace.Dice.d6.d6x1_less2.Roll'Image);
log ("d6x1_less1 Roll:" & lace.Dice.d6.d6x1_less1.Roll'Image);
log ("d6x1 Roll:" & lace.Dice.d6.d6x1 .Roll'Image);
log ("d6x1_plus1 Roll:" & lace.Dice.d6.d6x1_plus1.Roll'Image);
log ("d6x1_plus2 Roll:" & lace.Dice.d6.d6x1_plus2.Roll'Image);
-- d6x2
--
log ("");
log ("d6x2_less1 Roll:" & lace.Dice.d6.d6x2_less1.Roll'Image);
log ("d6x2 Roll:" & lace.Dice.d6.d6x2 .Roll'Image);
log ("d6x2_plus1 Roll:" & lace.Dice.d6.d6x2_plus1.Roll'Image);
log ("d6x2_plus2 Roll:" & lace.Dice.d6.d6x2_plus2.Roll'Image);
-- any
--
declare
use lace.Dice,
lace.Dice.any;
d100 : constant lace.Dice.any.item := to_Dice (Sides => 100,
Rolls => 1,
Modifier => 0);
the_Roll : Natural;
one_Count : Natural := 0;
hundred_Count : Natural := 0;
begin
for i in 1 .. 1_000
loop
the_Roll := d100.Roll;
case the_Roll
is
when 0 => raise test_Error with "Roll was 0.";
when 1 => one_Count := one_Count + 1;
when 100 => hundred_Count := hundred_Count + 1;
when 101 => raise test_Error with "Roll was 101.";
when others => null;
end case;
end loop;
log ("");
log ("1 rolled" & one_Count'Image & " times.");
log ("100 rolled" & hundred_Count'Image & " times.");
end;
log ("");
log ("End Test");
end test_Dice;

19
1-base/lace/applet/test/dice/test_dice.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Dice
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_dice.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Dice;

67
1-base/lace/applet/test/environ/compression/test_environ_compression.adb Normal file
View File

@@ -0,0 +1,67 @@
with
lace.Environ,
ada.Text_IO;
procedure test_Environ_compression
is
use lace.Environ,
ada.Text_IO;
test_Error : exception;
digits_Text : constant String := "0123456789";
begin
put_Line ("Begin");
verify_Folder ("tmp");
goto_Folder ("tmp");
--- Compress single files.
--
save (digits_Text, "digits.txt-original");
copy_File ("digits.txt-original", "digits.txt");
for Each in compress_Format
loop
compress ("digits.txt", Each);
rid_File ("digits.txt");
decompress ("digits.txt" & format_Suffix (Each));
if load ("digits.txt") /= digits_Text
then
raise test_Error with "'" & load ("digits.txt") & "'";
end if;
rid_File ("digits.txt" & format_Suffix (Each));
end loop;
--- Compress directories.
--
verify_Folder ("archive-original");
move_Files ("*", "archive-original");
copy_Folder ("archive-original", "archive");
for Each in folder_compress_Format
loop
compress ("archive", Each);
rid_Folder ("archive");
decompress ("archive" & format_Suffix (Each));
if load ("archive/digits.txt")
/= load ("archive-original/digits.txt")
then
raise test_Error with "'" & load ("archive/digits.txt") & "'";
end if;
rid_File ("archive" & format_Suffix (Each));
end loop;
--- Tidy up
--
goto_Folder ("..");
rid_Folder ("tmp");
put_Line ("Success");
end test_Environ_compression;

19
1-base/lace/applet/test/environ/compression/test_environ_compression.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_compression
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_compression.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_compression;

0
1-base/lace/applet/test/environ/general/data/glob1.txt Normal file
View File

0
1-base/lace/applet/test/environ/general/data/glob2.txt Normal file
View File

0
1-base/lace/applet/test/environ/general/data/glob3.txt Normal file
View File

27
1-base/lace/applet/test/environ/general/test_environ_general.adb Normal file
View File

@@ -0,0 +1,27 @@
with
lace.Environ,
ada.Text_IO;
procedure test_Environ_general
is
use lace.Environ,
ada.Text_IO;
Error : exception;
begin
put_Line ("Begin");
-- Test GLOB expansion.
--
declare
Output : constant String := expand_GLOB ("data/*.txt");
begin
if Output /= "data/glob1.txt data/glob2.txt data/glob3.txt"
then
raise Error with "expand_GLOB fails: '" & Output & "'";
end if;
end;
put_Line ("Success");
put_Line ("End");
end test_Environ_general;

19
1-base/lace/applet/test/environ/general/test_environ_general.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_general
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_general.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_general;

1
1-base/lace/applet/test/environ/paths/data/digits.txt Normal file
View File

@@ -0,0 +1 @@
0123456789

0
1-base/lace/applet/test/environ/paths/data/empty.txt Normal file
View File

38
1-base/lace/applet/test/environ/paths/test_environ_paths.adb Normal file
View File

@@ -0,0 +1,38 @@
with
lace.Environ.Paths,
ada.Text_IO;
procedure test_Environ_Paths
is
use lace.Environ.Paths,
ada.Text_IO;
Error : exception;
begin
put_Line ("Begin");
-- Test load of an empty file.
--
declare
Output : constant String := to_File ("data/empty.txt").load;
begin
if Output /= ""
then
raise Error with "Loading an empty file fails: '" & Output & "'";
end if;
end;
-- Test load of simple text.
--
declare
Output : constant String := to_File ("data/digits.txt").load;
begin
if Output /= "0123456789"
then
raise Error with "Loading a simple text file fails: '" & Output & "'";
end if;
end;
put_Line ("Success");
put_Line ("End");
end test_Environ_Paths;

19
1-base/lace/applet/test/environ/paths/test_environ_paths.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Environ_Paths
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_environ_paths.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Environ_Paths;

19
1-base/lace/applet/test/text/test_text.gpr Normal file
View File

@@ -0,0 +1,19 @@
with
"lace",
"lace_shared";
project test_Text
is
for Object_Dir use "build";
for Exec_Dir use ".";
for Main use ("test_text_replace.adb");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
package Linker is
for Default_Switches ("ada") use ("-g");
end Linker;
end test_Text;

221
1-base/lace/applet/test/text/test_text_replace.adb Normal file
View File

@@ -0,0 +1,221 @@
with
lace.Text.utility,
ada.Text_IO;
procedure test_Text_replace
is
use lace.Text,
lace.Text.utility,
ada.Text_IO;
test_Error : exception;
begin
put_Line ("Begin Test");
new_Line;
-- Test 'replace' function.
--
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "");
begin
if Final /= ""
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("123<TOKEN>456");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "123Linux456"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("123<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "123Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>456");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux456"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>123<TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "Linux123Linux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN><TOKEN>");
Final : constant String := +replace (Initial, "<TOKEN>", "Linux");
begin
if Final /= "LinuxLinux"
then
raise test_Error with "replace fails: Initial => '" & (+Initial) & "' "
& "Final => '" & Final & "'";
end if;
end;
declare
Initial : aliased constant lace.Text.item := to_Text ("<TOKEN>", capacity => 64);
Final : constant String := +replace (Initial, "<TOKEN>", "Longish String") with Unreferenced;
begin
put_Line ("No capacity error raised, as expected.");
end;
-- Test 'replace' procedure.
--
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "");
if +Text /= ""
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "123<TOKEN>456";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "123Linux456"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "123<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "123Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>456";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux456"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>123<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "Linux123Linux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN><TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Linux");
if +Text /= "LinuxLinux"
then
raise test_Error with "replace fails: Initial => '" & Initial & "' "
& "Final => '" & (+Text) & "'";
end if;
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial);
begin
replace (Text, "<TOKEN>", "Longish String");
exception
when lace.Text.Error =>
put_Line ("Capacity error raised, as expected.");
end;
declare
Initial : constant String := "<TOKEN>";
Text : lace.Text.item := to_Text (Initial, capacity => 64);
begin
replace (Text, "<TOKEN>", "Longish String");
put_Line ("No capacity error raised, as expected.");
end;
new_Line;
put_Line ("Success");
put_Line ("End Test");
end test_Text_replace;

15
1-base/lace/document/events/Overview Normal file
View File

@@ -0,0 +1,15 @@
'Lace ~ Events' Overview
~~~~~~~~~~~~~~~~~~~~~~~~
- Provides an event mechansism for event-driven architectures.
- Contains Subject, Observer, Event and Response abstractions.
- Supports DSA.
- See http://en.wikipedia.org/wiki/Event-driven_architecture
- http://en.wikipedia.org/wiki/Event-driven_programming
- Requirements: 'lace/document/events/requirements'
- Diagram: 'lace/document/events/events.png'
- Code: 'lace/source/events'
- Demo: 'lace/applet/demo/simple'

BIN
1-base/lace/document/events/events.dia Normal file
View File

Binary file not shown.

BIN
1-base/lace/document/events/events.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 29 KiB

38
1-base/lace/document/events/requirements Normal file
View File

@@ -0,0 +1,38 @@
'Lace ~ Event'
System Requirements
~~~~~~~~~~~~~~~~~~~
Overview
~~~~~~~~
- Allow applet entities to communicate and operate by means of 'event/response' and 'subject/observer' objects.
- Subjects and Observers may be remotely distributed.
- Both lossy (unguaranteed) and lossless (guaranteed) event communication must be catered for.
Objects
~~~~~~~
Events:
- Varied event kinds are required.
- Each variant may contain specific data related to the nature of the event.
Responses:
- Varied Response kinds are required.
- Each variant may contain specific data useful for performing the response.
- Each Response may perform a unique program operation.
Subjects:
- Allows an Observer to register interest in an Event of a specific kind.
- Must be able to emit an Event.
- Must notify all Observers (registered for the Event kind) when an Event is emitted.
Observers:
- Able to be configured with a Response to a specific Event (from a specific Subject).
- When notified of an Event, the configured response is performed.
- Must be able to respond to events in a task-safe fashion.

73
1-base/lace/document/events/tasking Normal file
View File

@@ -0,0 +1,73 @@
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Event Responses and Tasking
~~~~~~~~~~~~~~~~~~~~~~~~~~~
Default:
- Responses occur immediately after an event is emitted.
- Responses are performed by the task which asks a Subject to emit an event.
Deferred:
- In some cases, it may be desirable to be able to defer responses so as to free the emitting task from
the burden of performing lengthy responses.
- Such deferred responses would then be performed by another (possibly dedicated) task.
~~~~~~~~~~~~~
Typical Cases
~~~~~~~~~~~~~
- Note: '...' below signifies continued processing.
Single Task
~~~~~~~~~~~
Immediate Response
- Task asks Subject to emit an event.
- Task performs the Observer response immediately.
- ...
Deferred Response
- Task asks the Subject to emit an event.
- Task adds the event to the Observer queue.
- ...
- Task asks the Observer to perform the response.
- ...
- For a single task application, the default 'immediate response' method should be sufficent for most cases.
- The 'deferred response' method may be of use should control over the order in which responses occur be required.
- No concurrency protection is required when performing responses.
Multi Task
~~~~~~~~~~
Immediate Response
- Task 1 asks Subject to emit an event.
- Task 1 performs the Observer response immediately.
- ...
Deferred Response
- Task 1 asks the Subject to emit an event.
- Task 1 adds the event to the Observer queue.
- ...
- Task 2 asks the Observer to perform response for each queued event.
- ...
- For a multi task application, care must be taken to ensure that response actions are task safe.
- Using the 'deferred' method may simplify (or eliminate) concurrency protection issues. (tbd: add examples)

38
1-base/lace/library/lace.gpr Normal file
View File

@@ -0,0 +1,38 @@
with
-- "florist",
"lace_shared";
-- "ashell";
--library
project Lace
is
type Restrictions is ("xgc", "ravenscar");
the_Restrictions : Restrictions := external ("restrictions", "xgc");
for Create_Missing_Dirs use "True";
for Object_Dir use "build";
for Exec_Dir use ".";
for Library_Dir use "lib";
for Library_Ali_Dir use "objects";
-- for Library_Name use "Lace";
for Source_Dirs use ("../source",
"../source/containers",
-- "../source/environ",
"../source/dice",
"../source/events",
"../source/events/concrete",
"../source/events/interface",
"../source/events/mixin",
"../source/events/mixin/" & external ("restrictions", "xgc"),
"../source/events/utility",
"../source/strings",
"../source/text");
package Builder renames Lace_shared.Builder;
package Compiler renames Lace_shared.Compiler;
package Binder renames Lace_shared.Binder;
end Lace;

24
1-base/lace/source/containers/lace-containers-shuffle_vector.adb Normal file
View File

@@ -0,0 +1,24 @@
with
ada.Numerics.discrete_Random;
procedure lace.Containers.shuffle_Vector (the_Vector : in out vectors.Vector)
is
use type vectors.Index_type;
begin
for i in reverse 2 .. vectors.Index_type (the_Vector.Length) -- Start from 2, since swapping the
loop -- first element with itself is useless.
declare
subtype Index is vectors.Index_type range vectors.Index_type'First
.. vectors.Index_type'First + i - 1;
package random_Index is new ada.Numerics.discrete_Random (Index);
use random_Index;
the_Generator : random_Index.Generator;
begin
the_Vector.swap (Random (the_Generator),
Index'Last);
end;
end loop;
end lace.Containers.shuffle_Vector;

8
1-base/lace/source/containers/lace-containers-shuffle_vector.ads Normal file
View File

@@ -0,0 +1,8 @@
with
ada.Containers.Vectors;
generic
with package Vectors is new ada.Containers.Vectors (<>);
procedure lace.Containers.shuffle_Vector (the_Vector : in out vectors.Vector);

12
1-base/lace/source/containers/lace-containers.ads Normal file
View File

@@ -0,0 +1,12 @@
with
ada.Containers;
package lace.Containers
is
pragma Pure;
subtype Hash_Type is ada.Containers.Hash_type;
subtype Count_Type is ada.Containers.Count_type;
end lace.Containers;

69
1-base/lace/source/dice/lace-dice-any.adb Normal file
View File

@@ -0,0 +1,69 @@
with
ada.Numerics.float_Random;
package body lace.Dice.any
is
the_float_Generator : ada.Numerics.float_Random.Generator;
procedure Seed_is (Now : Integer)
is
begin
ada.Numerics.float_Random.reset (the_float_Generator,
Initiator => Now);
end Seed_is;
--------
-- Forge
--
function to_Dice (Sides : in Positive := 6;
Rolls : in Positive := 3;
Modifier : in Integer := 0) return Dice.any.item
is
begin
return (side_Count => Sides,
roll_Count => Rolls,
Modifier => Modifier);
end to_Dice;
-------------
-- Attributes
--
overriding
function side_Count (Self : in Item) return Positive
is
begin
return Self.Side_Count;
end side_Count;
overriding
function Roll (Self : in Item) return Natural
is
use ada.Numerics.float_Random;
the_Roll : Integer := 0;
begin
for Each in 1 .. Self.roll_Count
loop
the_Roll := the_Roll
+ Integer ( Random (the_float_Generator)
* Float (Self.side_Count)
+ 0.5);
end loop;
return the_Roll + self.Modifier;
end Roll;
begin
ada.Numerics.float_Random.reset (the_float_Generator);
end lace.Dice.any;

44
1-base/lace/source/dice/lace-dice-any.ads Normal file
View File

@@ -0,0 +1,44 @@
package lace.Dice.any
--
-- provide a model of many sided dice.
--
is
type Item is new Dice.item with private;
procedure Seed_is (Now : Integer);
--
-- If the seed is not set, a random seed will be used.
--------
-- Forge
--
function to_Dice (Sides : in Positive := 6;
Rolls : in Positive := 3;
Modifier : in Integer := 0) return Dice.any.item;
-------------
-- Attributes
--
overriding
function side_Count (Self : in Item) return Positive;
overriding
function Roll (Self : in Item) return Natural;
private
type Item is new Dice.item with
record
side_Count : Positive;
end record;
end lace.Dice.any;

70
1-base/lace/source/dice/lace-dice-d6.adb Normal file
View File

@@ -0,0 +1,70 @@
with
ada.Numerics.discrete_Random;
package body lace.Dice.d6
is
subtype d6_Range is Positive range 1 .. 6;
package d6_Random is new ada.Numerics.discrete_Random (d6_Range);
the_d6_Generator : d6_Random.Generator;
procedure Seed_is (Now : Integer)
is
begin
d6_Random.reset (the_d6_Generator, Initiator => Now);
end Seed_is;
--------
-- Forge
--
function to_Dice (Rolls : in Positive := 3;
Modifier : in Integer := 0) return Dice.d6.item
is
begin
return (roll_count => Rolls,
modifier => Modifier);
end to_Dice;
-------------
-- Attributes
--
overriding
function side_Count (Self : in Item) return Positive
is
begin
return 6;
end side_Count;
overriding
function Roll (Self : in Item) return Natural
is
use d6_Random;
the_Roll : Integer := 0;
begin
for Each in 1 .. self.roll_Count loop
the_Roll := the_Roll + Random (the_d6_Generator);
end loop;
return Natural'Max (the_Roll + self.Modifier,
0);
end Roll;
begin
d6_Random.reset (the_d6_Generator);
end lace.Dice.d6;

137
1-base/lace/source/dice/lace-dice-d6.ads Normal file
View File

@@ -0,0 +1,137 @@
package lace.Dice.d6
--
-- Models 6 sided dice.
--
is
type Item is new Dice.item with private;
procedure Seed_is (Now : Integer);
--
-- If the seed is not set, a random seed will be used.
-- Forge
--
function to_Dice (Rolls : in Positive := 3;
Modifier : in Integer := 0) return Dice.d6.item;
-- Attributes
--
overriding
function side_Count (Self : in Item) return Positive;
overriding
function Roll (Self : in Item) return Natural;
-- Stock Dice
--
d6x1_less5 : aliased constant d6.Item;
d6x1_less4 : aliased constant d6.Item;
d6x1_less3 : aliased constant d6.Item;
d6x1_less2 : aliased constant d6.Item;
d6x1_less1 : aliased constant d6.Item;
d6x1 : aliased constant d6.Item;
d6x1_plus1 : aliased constant d6.Item;
d6x1_plus2 : aliased constant d6.Item;
d6x2_less1 : aliased constant d6.Item;
d6x2 : aliased constant d6.Item;
d6x2_plus1 : aliased constant d6.Item;
d6x2_plus2 : aliased constant d6.Item;
d6x3_less1 : aliased constant d6.Item;
d6x3 : aliased constant d6.Item;
d6x3_plus1 : aliased constant d6.Item;
d6x3_plus2 : aliased constant d6.Item;
d6x4_less1 : aliased constant d6.Item;
d6x4 : aliased constant d6.Item;
d6x4_plus1 : aliased constant d6.Item;
d6x4_plus2 : aliased constant d6.Item;
d6x5_less1 : aliased constant d6.Item;
d6x5 : aliased constant d6.Item;
d6x5_plus1 : aliased constant d6.Item;
d6x5_plus2 : aliased constant d6.Item;
d6x6_less1 : aliased constant d6.Item;
d6x6 : aliased constant d6.Item;
d6x6_plus1 : aliased constant d6.Item;
d6x6_plus2 : aliased constant d6.Item;
d6x7_less1 : aliased constant d6.Item;
d6x7 : aliased constant d6.Item;
d6x7_plus1 : aliased constant d6.Item;
d6x7_plus2 : aliased constant d6.Item;
d6x8_less1 : aliased constant d6.Item;
d6x8 : aliased constant d6.Item;
d6x8_plus1 : aliased constant d6.Item;
d6x8_plus2 : aliased constant d6.Item;
private
type Item is new Dice.item with
record
null;
end record;
d6x1_less5 : aliased constant d6.Item := (roll_count => 1, modifier => -5);
d6x1_less4 : aliased constant d6.Item := (roll_count => 1, modifier => -4);
d6x1_less3 : aliased constant d6.Item := (roll_count => 1, modifier => -3);
d6x1_less2 : aliased constant d6.Item := (roll_count => 1, modifier => -2);
d6x1_less1 : aliased constant d6.Item := (roll_count => 1, modifier => -1);
d6x1 : aliased constant d6.Item := (roll_count => 1, modifier => 0);
d6x1_plus1 : aliased constant d6.Item := (roll_count => 1, modifier => 1);
d6x1_plus2 : aliased constant d6.Item := (roll_count => 1, modifier => 2);
d6x2_less1 : aliased constant d6.Item := (roll_count => 2, modifier => -1);
d6x2 : aliased constant d6.Item := (roll_count => 2, modifier => 0);
d6x2_plus1 : aliased constant d6.Item := (roll_count => 2, modifier => 1);
d6x2_plus2 : aliased constant d6.Item := (roll_count => 2, modifier => 2);
d6x3_less1 : aliased constant d6.Item := (roll_count => 3, modifier => -1);
d6x3 : aliased constant d6.Item := (roll_count => 3, modifier => 0);
d6x3_plus1 : aliased constant d6.Item := (roll_count => 3, modifier => 1);
d6x3_plus2 : aliased constant d6.Item := (roll_count => 3, modifier => 2);
d6x4_less1 : aliased constant d6.Item := (roll_count => 4, modifier => -1);
d6x4 : aliased constant d6.Item := (roll_count => 4, modifier => 0);
d6x4_plus1 : aliased constant d6.Item := (roll_count => 4, modifier => 1);
d6x4_plus2 : aliased constant d6.Item := (roll_count => 4, modifier => 2);
d6x5_less1 : aliased constant d6.Item := (roll_count => 5, modifier => -1);
d6x5 : aliased constant d6.Item := (roll_count => 5, modifier => 0);
d6x5_plus1 : aliased constant d6.Item := (roll_count => 5, modifier => 1);
d6x5_plus2 : aliased constant d6.Item := (roll_count => 5, modifier => 2);
d6x6_less1 : aliased constant d6.Item := (roll_count => 6, modifier => -1);
d6x6 : aliased constant d6.Item := (roll_count => 6, modifier => 0);
d6x6_plus1 : aliased constant d6.Item := (roll_count => 6, modifier => 1);
d6x6_plus2 : aliased constant d6.Item := (roll_count => 6, modifier => 2);
d6x7_less1 : aliased constant d6.Item := (roll_count => 7, modifier => -1);
d6x7 : aliased constant d6.Item := (roll_count => 7, modifier => 0);
d6x7_plus1 : aliased constant d6.Item := (roll_count => 7, modifier => 1);
d6x7_plus2 : aliased constant d6.Item := (roll_count => 7, modifier => 2);
d6x8_less1 : aliased constant d6.Item := (roll_count => 8, modifier => -1);
d6x8 : aliased constant d6.Item := (roll_count => 8, modifier => 0);
d6x8_plus1 : aliased constant d6.Item := (roll_count => 8, modifier => 1);
d6x8_plus2 : aliased constant d6.Item := (roll_count => 8, modifier => 2);
end lace.Dice.d6;

65
1-base/lace/source/dice/lace-dice.adb Normal file
View File

@@ -0,0 +1,65 @@
package body lace.Dice
is
function Image (Self : in Item'Class) return String
is
roll_count_Image : constant String := Integer'Image (self.roll_Count);
function side_count_Image return String
is
begin
if Self.side_Count = 6 then
return "";
else
declare
the_Image : constant String := Integer'Image (Self.side_Count);
begin
return the_Image (the_Image'First + 1 .. the_Image'Last);
end;
end if;
end side_count_Image;
function modifier_Image return String
is
begin
if self.Modifier = 0 then
return "";
else
declare
the_Image : String := integer'Image (self.Modifier);
begin
if self.Modifier > 0 then
the_Image (the_Image'First) := '+';
end if;
return the_Image;
end;
end if;
end modifier_Image;
begin
return roll_count_Image (roll_count_Image'First + 1 .. roll_count_Image'Last)
& "d"
& side_count_Image
& modifier_Image;
end Image;
function Extent (Self : in Item'Class) return an_Extent
is
begin
return (min => self.roll_Count + self.Modifier,
max => self.roll_Count * self.side_Count + self.Modifier);
end Extent;
end lace.Dice;

34
1-base/lace/source/dice/lace-dice.ads Normal file
View File

@@ -0,0 +1,34 @@
package lace.Dice with Pure
--
-- Provides an abstract model of any sided dice.
--
is
type Item is abstract tagged private;
type an_Extent is
record
Min, Max : Integer;
end record;
-- Attributes
--
function side_Count (Self : in Item) return Positive is abstract;
function Roll (Self : in Item) return Natural is abstract;
function Extent (Self : in Item'Class) return an_Extent;
function Image (Self : in Item'Class) return String;
private
type Item is abstract tagged
record
roll_Count : Positive;
Modifier : Integer;
end record;
end lace.Dice;

98
1-base/lace/source/environ/lace-environ-os_commands.adb Normal file
View File

@@ -0,0 +1,98 @@
with
shell.Commands,
gnat.OS_Lib,
ada.Strings.fixed,
ada.Strings.Maps,
ada.Characters.latin_1,
ada.Exceptions;
package body lace.Environ.OS_Commands
is
use ada.Exceptions;
function Path_to (Command : in String) return Paths.Folder
is
use Paths;
begin
return to_Folder (run_OS ("which " & Command));
end Path_to;
procedure run_OS (command_Line : in String;
Input : in String := "")
is
use Shell;
begin
Commands.run (command_Line, +Input);
exception
when E : Commands.command_Error =>
raise Error with Exception_Message (E);
end run_OS;
function run_OS (command_Line : in String;
Input : in String := "";
add_Errors : in Boolean := True) return String
is
use Shell,
Shell.Commands;
function trim_LF (Source : in String) return String
is
use ada.Strings.fixed,
ada.Strings.Maps,
ada.Characters;
LF_Set : constant Character_Set := to_Set (Latin_1.LF);
begin
return trim (Source, LF_Set, LF_Set);
end trim_LF;
Results : constant Command_Results := run (command_Line, +Input);
Output : constant String := +Output_of (Results);
begin
if add_Errors
then
return trim_LF (Output & (+Errors_of (Results)));
else
return trim_LF (Output);
end if;
exception
when E : command_Error =>
raise Error with Exception_Message (E);
end run_OS;
function run_OS (command_Line : in String;
Input : in String := "") return Data
is
use Shell,
Shell.Commands;
the_Command : Command := Forge.to_Command (command_Line);
begin
return Output_of (run (The_Command, +Input));
exception
when E : command_Error =>
raise Error with Exception_Message (E);
end run_OS;
function Executable_on_Path (Executable : Paths.File) return Boolean
is
use Paths,
gnat.OS_Lib;
File_Path : String_Access := Locate_Exec_On_Path (+Executable);
Found : constant Boolean := File_Path /= null;
begin
free (File_Path);
return Found;
end Executable_on_Path;
end lace.Environ.OS_Commands;

33
1-base/lace/source/environ/lace-environ-os_commands.ads Normal file
View File

@@ -0,0 +1,33 @@
with
lace.Environ.Paths;
package lace.Environ.OS_Commands
--
-- Allows running of operating system commands.
--
is
function Path_to (Command : in String) return Paths.Folder;
procedure run_OS (command_Line : in String;
Input : in String := "");
--
-- Discards any output. Error is raised when the command fails.
function run_OS (command_Line : in String;
Input : in String := "") return Data;
--
-- Returns any output. Error is raised when the command fails.
function run_OS (command_Line : in String;
Input : in String := "";
add_Errors : in Boolean := True) return String;
--
-- Returns any output. Error output is appended if add_Errors is true.
function Executable_on_Path (Executable : Paths.File) return Boolean;
--
-- Returns True if the Executable exists on the environment PATH variable.
end lace.Environ.OS_Commands;

1016
1-base/lace/source/environ/lace-environ-paths.adb Normal file
View File

File diff suppressed because it is too large Load Diff

194
1-base/lace/source/environ/lace-environ-paths.ads Normal file
View File

@@ -0,0 +1,194 @@
with
ada.Calendar;
private
with
ada.Strings.unbounded,
ada.Containers.indefinite_Vectors;
package lace.Environ.Paths
--
-- A singleton which models an operating system environment.
--
is
function expand_GLOB (GLOB : in String) return String;
---------
--- Paths
--
type Path is abstract tagged private;
function to_String (Self : in Path'Class) return String;
function "+" (Self : in Path'Class) return String renames to_String;
procedure change_Mode (Self : in Path; To : in String);
procedure change_Owner (Self : in Path; To : in String);
procedure link (Self : in Path; To : in Path);
function Exists (Self : in Path) return Boolean;
function modify_Time (Self : in Path) return ada.Calendar.Time;
function Name (Self : in Path) return String;
function Simple (Self : in Path) return String;
function is_Folder (Self : in Path) return Boolean;
function is_File (Self : in Path) return Boolean;
function is_Special (Self : in Path) return Boolean;
function is_Absolute (Self : in Path) return Boolean;
function is_Relative (Self : in Path) return Boolean;
-----------
--- Folders
--
type Folder is new Path with private;
no_Folder : constant Folder;
function to_Folder (Name : in String) return Folder;
function "+" (Name : in String) return Folder renames to_Folder;
function "+" (Left : in Folder;
Right : in Folder) return Folder;
function current_Folder return Folder;
procedure go_to_Folder (Self : in Folder;
Lock : in Boolean := False); -- When true, blocks further folder changes until 'unlock_Folder' is called.
procedure unlock_Folder;
procedure rid_Folder (Self : in Folder);
procedure copy_Folder (Self : in Folder; To : in Folder);
procedure move_Folder (Self : in Folder; To : in Folder);
procedure rename_Folder (Self : in Folder; To : in Folder);
procedure ensure_Folder (Self : in Folder); -- Ensure that the folder exists.
function is_Empty (Self : in Folder) return Boolean;
function contents_Count (Self : in Folder; -- Does not include the "." and ".." folders.
Recurse : in Boolean := False) return Natural;
function Parent (Self : in Path'Class) return Folder; -- Returns 'no_Folder' if 'Self' has no parent.
function Relative (Self : in Folder; To : in Folder'Class) return Folder;
-------------------
--- Folder Contexts
--
type folder_Context is limited private;
procedure push_Folder (Context : in out folder_Context;
goto_Folder : in Folder'Class);
--
-- Store the current folder and move to the 'goto_Folder'.
procedure pop_Folder (Context : in out folder_Context);
--
-- Return to the previously pushed folder.
procedure pop_All (Context : in out folder_Context);
--
-- Return to the initial current folder.
---------
--- Files
--
type File is new Path with private;
type File_Extension is new String;
function to_File (Name : in String) return File;
function "+" (Name : in String) return File renames to_File;
function "+" (Left : in Folder'Class;
Right : in File 'Class) return File;
function "+" (Left : in File'Class;
Right : in File_Extension) return File;
function Extension (Self : in File) return File_Extension;
procedure save (Self : in File;
Text : in String;
Binary : in Boolean := False);
procedure save (Self : in File;
Data : in environ.Data);
function load (Self : in File) return String;
function load (Self : in File) return Data;
procedure copy_File (Self : in File; To : in File);
procedure copy_Files (Named : in String; To : in Folder);
--
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure move_File (Self : in File; To : in File);
procedure move_Files (Named : in String; To : in Folder);
--
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure rid_File (Self : in File);
procedure rid_Files (Named : in String);
--
-- 'Named' can contain an asterix GLOB such as "*" or "*.txt".
procedure append (Self : in File; Text : in String);
procedure append_File (Self : in File; To : in File);
procedure touch (Self : in File);
function Relative (Self : in File; To : in Folder'Class) return File;
function rid_Extension (Self : in File) return File;
--- Compression
--
type compress_Format is (Tar, Tar_Bz2, Tar_Gz, Tar_Xz, Bz2, Gz, Xz);
subtype folder_compress_Format is compress_Format range Tar .. Tar_Xz;
type compress_Level is range 1 .. 9; -- Higher levels result in higher compression.
procedure compress (the_Path : in Path'Class;
the_Format : in compress_Format := Tar_Xz;
the_Level : in compress_Level := 6);
procedure decompress (Name : in File);
function format_Suffix (Format : in compress_Format) return String;
private
use ada.Strings.unbounded;
type Path is abstract tagged
record
Name : unbounded_String;
end record;
type Folder is new Path with null record;
type File is new Path with null record;
no_Folder : constant Folder := (Name => null_unbounded_String);
--- Folder Contexts
--
use ada.Containers;
package Folder_Vectors is new indefinite_Vectors (Positive, Folder);
subtype Folder_Vector is Folder_Vectors.Vector;
type folder_Context is limited
record
folder_Stack : Folder_Vector;
end record;
end lace.Environ.Paths;

102
1-base/lace/source/environ/lace-environ-users.adb Normal file
View File

@@ -0,0 +1,102 @@
with
lace.Environ.OS_Commands,
posix.user_Database,
posix.process_Identification;
package body lace.Environ.Users
is
function "+" (Source : in unbounded_String) return String
renames to_String;
function to_User (Name : in String) return User
is
begin
return (Name => to_unbounded_String (Name));
end to_User;
function Name (Self : in User) return String
is
begin
return to_String (Self.Name);
end Name;
procedure add_User (Self : in User;
Super : in Boolean := False)
is
use lace.Environ.OS_Commands;
begin
if Super
then
declare
Output : constant String := run_OS ("useradd " & (+Self.Name) & " -m -G sudo -G root");
begin
if Output /= ""
then
raise Error with Output;
end if;
end;
else
declare
Output : constant String := run_OS ("useradd " & (+Self.Name) & " -m");
begin
if Output /= ""
then
raise Error with Output;
end if;
end;
end if;
end add_User;
procedure rid_User (Self : in User)
is
use lace.Environ.OS_Commands;
Output : constant String := run_OS ("userdel -r " & (+Self.Name));
begin
if Output /= ""
then
raise Error with Output;
end if;
end rid_User;
procedure switch_to (Self : in User)
is
use Posix,
posix.User_Database,
posix.Process_Identification;
User_in_DB : constant User_Database_Item := get_User_Database_Item (to_Posix_String (+Self.Name));
ID : constant User_ID := User_ID_of (User_in_DB);
begin
set_User_ID (ID);
end switch_to;
function current_User return User
is
use Posix,
posix.process_Identification;
begin
return to_User (to_String (get_Login_Name));
end current_User;
function home_Folder (Self : in User := current_User) return Paths.Folder
is
use Paths,
Posix,
posix.User_Database;
User_in_DB : constant User_Database_Item := get_User_Database_Item (to_Posix_String (+Self.Name));
begin
return to_Folder (to_String (initial_Directory_of (User_in_DB)));
end home_Folder;
end lace.Environ.Users;

38
1-base/lace/source/environ/lace-environ-users.ads Normal file
View File

@@ -0,0 +1,38 @@
with
lace.Environ.Paths;
private
with
ada.Strings.unbounded;
package lace.Environ.Users
--
-- Models operating system users.
--
is
type User is private;
function to_User (Name : in String) return User;
function "+" (Name : in String) return User renames to_User;
function Name (Self : in User) return String;
function current_User return User;
function home_Folder (Self : in User := current_User) return Paths.Folder;
procedure add_User (Self : in User;
Super : in Boolean := False);
procedure rid_User (Self : in User);
procedure switch_to (Self : in User);
private
use ada.Strings.unbounded;
type User is
record
Name : unbounded_String;
end record;
end lace.Environ.Users;

40
1-base/lace/source/environ/lace-environ.adb Normal file
View File

@@ -0,0 +1,40 @@
package body lace.Environ
is
function to_octal_Mode (Permissions : in permission_Set) return String
is
function octal_Permissions (Bit_3, Bit_2, Bit_1 : in Boolean) return String
is
begin
if Bit_3 then
if Bit_2 then
if Bit_1 then return "7";
else return "6";
end if;
else
if Bit_1 then return "5";
else return "4";
end if;
end if;
else
if Bit_2 then
if Bit_1 then return "3";
else return "2";
end if;
else
if Bit_1 then return "1";
else return "0";
end if;
end if;
end if;
end octal_Permissions;
begin
return
octal_Permissions (Permissions (set_User_ID), Permissions (set_Group_ID), False)
& octal_Permissions (Permissions (owner_Read), Permissions (owner_Write), Permissions (owner_Execute))
& octal_Permissions (Permissions (group_Read), Permissions (group_Write), Permissions (group_Execute))
& octal_Permissions (Permissions (others_Read), Permissions (others_Write), Permissions (others_Execute));
end to_octal_Mode;
end lace.Environ;

17
1-base/lace/source/environ/lace-environ.ads Normal file
View File

@@ -0,0 +1,17 @@
with
posix.Permissions,
ada.Streams;
package lace.Environ
--
-- Models an operating system environment.
--
is
use posix.Permissions;
function to_octal_Mode (Permissions : in Permission_Set) return String;
subtype Data is ada.Streams.Stream_Element_Array;
Error : exception;
end lace.Environ;

34
1-base/lace/source/events/concrete/lace-observer-deferred.adb Normal file
View File

@@ -0,0 +1,34 @@
package body lace.Observer.deferred
is
package body Forge
is
function to_Observer (Name : in Event.observer_Name) return Item
is
begin
return Self : constant Item := (Deferred.item
with name => to_unbounded_String (Name))
do
null;
end return;
end to_Observer;
function new_Observer (Name : in Event.observer_Name) return View
is
Self : constant View := new Item' (to_Observer (Name));
begin
return Self;
end new_Observer;
end Forge;
overriding
function Name (Self : in Item) return Event.observer_Name
is
begin
return to_String (Self.Name);
end Name;
end lace.Observer.deferred;

44
1-base/lace/source/events/concrete/lace-observer-deferred.ads Normal file
View File

@@ -0,0 +1,44 @@
with
lace.make_Observer.deferred,
lace.Any;
private
with
ada.Strings.unbounded;
package lace.Observer.deferred
--
-- Provides a concrete deferred event observer.
--
is
type Item is limited new Any.limited_item
and Observer .item with private;
type View is access all Item'Class;
package Forge
is
function to_Observer (Name : in Event.observer_Name) return Item;
function new_Observer (Name : in Event.observer_Name) return View;
end Forge;
overriding
function Name (Self : in Item) return Event.observer_Name;
private
use ada.Strings.unbounded;
package Observer is new lace.make_Observer (Any.limited_item);
package Deferred is new Observer.deferred (Observer.item);
type Item is limited new Deferred.item with
record
Name : unbounded_String;
end record;
end lace.Observer.deferred;

23
1-base/lace/source/events/concrete/lace-observer-instant.adb Normal file
View File

@@ -0,0 +1,23 @@
package body lace.Observer.instant
is
package body Forge
is
function new_Observer (Name : in Event.observer_Name) return View
is
Self : constant View := new Item;
begin
Self.Name := to_unbounded_String (Name);
return Self;
end new_Observer;
end Forge;
overriding
function Name (Self : in Item) return Event.observer_Name
is
begin
return to_String (Self.Name);
end Name;
end lace.Observer.instant;

42
1-base/lace/source/events/concrete/lace-observer-instant.ads Normal file
View File

@@ -0,0 +1,42 @@
with
lace.make_Observer,
lace.Any;
private
with
ada.Strings.unbounded;
package lace.Observer.instant
--
-- Provides a concrete instant event observer.
--
is
type Item is limited new Any.limited_item
and Observer .item with private;
type View is access all Item'Class;
package Forge
is
function new_Observer (Name : in Event.observer_Name) return View;
end Forge;
overriding
function Name (Self : in Item) return Event.observer_Name;
private
use ada.Strings.unbounded;
package Observer is new make_Observer (Any.limited_item);
type Item is limited new Observer.item with
record
Name : unbounded_String;
end record;
end lace.Observer.instant;

39
1-base/lace/source/events/concrete/lace-subject-local.adb Normal file
View File

@@ -0,0 +1,39 @@
package body lace.Subject.local
is
package body Forge
is
function to_Subject (Name : in Event.subject_Name) return Item
is
begin
return Self : Item
do
Self.Name := to_unbounded_String (Name);
end return;
end to_Subject;
function new_Subject (Name : in Event.subject_Name) return View
is
Self : constant View := new Item' (to_Subject (Name));
begin
return Self;
end new_Subject;
end Forge;
overriding
procedure destroy (Self : in out Item)
is
begin
Subject.destroy (Subject.item (Self)); -- Destroy base class.
end destroy;
overriding
function Name (Self : in Item) return Event.subject_Name
is
begin
return to_String (Self.Name);
end Name;
end lace.Subject.local;

46
1-base/lace/source/events/concrete/lace-subject-local.ads Normal file
View File

@@ -0,0 +1,46 @@
with
lace.make_Subject,
lace.Any;
private
with
ada.Strings.unbounded;
package lace.Subject.local
--
-- Provides a concrete local event Subject.
--
is
type Item is limited new Any.limited_item
and Subject .item with private;
type View is access all Item'Class;
package Forge
is
function to_Subject (Name : in Event.subject_Name) return Item;
function new_Subject (Name : in Event.subject_Name) return View;
end Forge;
procedure destroy (Self : in out Item);
overriding
function Name (Self : in Item) return Event.subject_Name;
private
use ada.Strings.unbounded;
package Subject is new make_Subject (Any.limited_item);
type Item is limited new Subject.item with
record
Name : unbounded_String;
end record;
end lace.Subject.local;

53
1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.adb Normal file
View File

@@ -0,0 +1,53 @@
with
ada.unchecked_Deallocation;
package body lace.Subject_and_deferred_Observer
is
package body Forge
is
function to_Subject_and_Observer (Name : in String) return Item
is
begin
return Self : Item
do
Self.Name := to_unbounded_String (Name);
end return;
end to_Subject_and_Observer;
function new_Subject_and_Observer (Name : in String) return View
is
begin
return new Item' (to_Subject_and_Observer (Name));
end new_Subject_and_Observer;
end Forge;
overriding
procedure destroy (Self : in out Item)
is
begin
Deferred.destroy (Deferred.item (Self)); -- Destroy base classes.
Subject .destroy (Subject .item (Self));
end destroy;
procedure free (Self : in out View)
is
procedure deallocate is new ada.unchecked_Deallocation (Item'Class, View);
begin
Self.destroy;
deallocate (Self);
end free;
overriding
function Name (Self : in Item) return String
is
begin
return to_String (Self.Name);
end Name;
end lace.Subject_and_deferred_Observer;

51
1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads Normal file
View File

@@ -0,0 +1,51 @@
with
lace.Subject,
lace.Observer,
lace.make_Subject,
lace.make_Observer.deferred,
lace.Any;
private
with
ada.Strings.unbounded;
package lace.Subject_and_deferred_Observer
--
-- Provides a concrete type for a combined event subject and a deferred observer.
--
is
type Item is limited new lace.Any.limited_item
and lace.Subject .item
and lace.Observer .item with private;
type View is access all Item'Class;
package Forge
is
function to_Subject_and_Observer (Name : in String) return Item;
function new_Subject_and_Observer (Name : in String) return View;
end Forge;
procedure destroy (Self : in out Item);
procedure free (Self : in out View);
overriding
function Name (Self : in Item) return String;
private
use ada.Strings.unbounded;
package Subject is new make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item);
package Deferred is new Observer.deferred (Observer .item);
type Item is limited new Deferred.item with
record
Name : unbounded_String;
end record;
end lace.Subject_and_deferred_Observer;

24
1-base/lace/source/events/concrete/lace-subject_and_instant_observer.adb Normal file
View File

@@ -0,0 +1,24 @@
package body lace.Subject_and_instant_Observer
is
package body Forge
is
function to_Subject_and_Observer (Name : in String) return Item
is
begin
return Self : Item
do
Self.Name := to_unbounded_String (Name);
end return;
end to_Subject_and_Observer;
end Forge;
overriding
function Name (Self : in Item) return String
is
begin
return to_String (Self.Name);
end Name;
end lace.Subject_and_instant_Observer;

47
1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads Normal file
View File

@@ -0,0 +1,47 @@
with
lace.make_Subject,
lace.make_Observer,
lace.Any,
lace.Subject,
lace.Observer;
private
with
ada.Strings.unbounded;
package lace.Subject_and_instant_Observer
--
-- Provides a concrete type for a combined event subject and an instant observer.
--
is
type Item is limited new lace.Any.limited_item
and lace.Subject .item
and lace.Observer .item with private;
type View is access all Item'Class;
package Forge
is
function to_Subject_and_Observer (Name : in String) return Item;
end Forge;
overriding
function Name (Self : in Item) return String;
private
use ada.Strings.unbounded;
package Subject is new make_Subject (Any.limited_item);
package Observer is new make_Observer (Subject .item);
type Item is limited new Observer.item with
record
Name : unbounded_String;
end record;
end lace.Subject_and_instant_Observer;

23
1-base/lace/source/events/interface/lace-observer.adb Normal file
View File

@@ -0,0 +1,23 @@
with
lace.Event.Logger;
package body lace.Observer
is
the_Logger : Event.Logger.view;
procedure Logger_is (Now : in Event.Logger.view)
is
begin
the_Logger := Now;
end Logger_is;
function Logger return Event.Logger.view
is
begin
return the_Logger;
end Logger;
end lace.Observer;

69
1-base/lace/source/events/interface/lace-observer.ads Normal file
View File

@@ -0,0 +1,69 @@
with
lace.Event,
lace.Response;
limited
with
lace.Event.Logger;
package lace.Observer
--
-- Provides an interface for an event Observer.
--
is
pragma remote_Types;
type Item is limited interface;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
type fast_View is access all Item'Class with Asynchronous;
type fast_Views is array (Positive range <>) of fast_View;
-------------
-- Attributes
--
function Name (Self : in Item) return event.observer_Name is abstract;
------------
-- Responses
--
procedure add (Self : access Item; the_Response : in Response.view;
to_Kind : in event.Kind;
from_Subject : in event.subject_Name) is abstract;
procedure rid (Self : access Item; the_Response : in Response.view;
to_Kind : in event.Kind;
from_Subject : in event.subject_Name) is abstract;
procedure relay_responseless_Events
(Self : in out Item; To : in Observer.view) is abstract;
-------------
-- Operations
--
procedure receive (Self : access Item; the_Event : in Event.item'Class := event.null_Event;
from_Subject : in event.subject_Name) is abstract;
--
-- Accepts an Event from a Subject.
procedure respond (Self : access Item) is abstract;
--
-- Performs the Response for (and then removes) each pending Event.
----------
-- Logging
--
procedure Logger_is (Now : in Event.Logger.view);
function Logger return Event.Logger.view;
end lace.Observer;

14
1-base/lace/source/events/interface/lace-response.adb Normal file
View File

@@ -0,0 +1,14 @@
with
ada.Tags;
package body lace.Response
is
function Name (Self : in Item) return String
is
begin
return ada.Tags.expanded_Name (Item'Class (Self)'Tag);
end Name;
end lace.Response;

35
1-base/lace/source/events/interface/lace-response.ads Normal file
View File

@@ -0,0 +1,35 @@
with
lace.Event;
package lace.Response
--
-- Provides a base class for all derived event 'response' classes.
--
is
pragma remote_Types;
type Item is abstract tagged limited private;
type View is access all Item'class;
-------------
-- Attributes
--
function Name (Self : in Item) return String;
-------------
-- Operations
--
procedure respond (Self : in out Item; to_Event : in Event.item'Class) is abstract;
private
type Item is abstract tagged limited null record;
end lace.Response;

23
1-base/lace/source/events/interface/lace-subject.adb Normal file
View File

@@ -0,0 +1,23 @@
with
lace.Event.Logger;
package body lace.Subject
is
the_Logger : Event.Logger.view;
procedure Logger_is (Now : in Event.Logger.view)
is
begin
the_Logger := Now;
end Logger_is;
function Logger return Event.Logger.view
is
begin
return the_Logger;
end Logger;
end lace.Subject;

74
1-base/lace/source/events/interface/lace-subject.ads Normal file
View File

@@ -0,0 +1,74 @@
with
lace.Event,
lace.Observer;
limited
with
lace.Event.Logger;
package lace.Subject
--
-- Provides an interface for an event subject.
--
is
pragma remote_Types;
type Item is limited interface;
type View is access all Item'Class;
type Views is array (Positive range <>) of View;
type fast_View is access all Item'Class with Asynchronous;
type fast_Views is array (Positive range <>) of fast_View;
-------------
-- Containers
--
type Observer_views is array (Positive range <>) of Observer.view;
-------------
-- Attributes
--
function Name (Self : in Item) return Event.subject_Name is abstract;
------------
-- Observers
--
procedure register (Self : access Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind) is abstract;
procedure deregister (Self : in out Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind) is abstract;
function Observers (Self : in Item; of_Kind : in Event.Kind) return Observer_views is abstract;
function observer_Count (Self : in Item) return Natural is abstract;
-------------
-- Operations
--
procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event) is abstract;
--
-- Communication errors are ignored.
function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event)
return Observer_views is abstract;
--
-- Observers who cannot be communicated with are returned.
----------
-- Logging
--
procedure Logger_is (Now : in Event.Logger.view);
function Logger return Event.Logger.view;
end lace.Subject;

13
1-base/lace/source/events/lace-event.adb Normal file
View File

@@ -0,0 +1,13 @@
with
ada.Strings.Hash;
package body lace.Event
is
function Hash (the_Kind : in Kind) return ada.Containers.Hash_type
is
begin
return ada.Strings.Hash (String (the_Kind));
end Hash;
end lace.Event;

39
1-base/lace/source/events/lace-event.ads Normal file
View File

@@ -0,0 +1,39 @@
with
ada.Containers;
package lace.Event
--
-- The base class for all derived event types.
--
is
pragma Pure;
type Item is tagged null record;
null_Event : constant Event.item;
subtype subject_Name is String;
subtype observer_Name is String;
procedure destruct (Self : in out Item) is null;
type Kind is new String;
--
-- Uniquely identifies each derived event class.
--
-- Each derived event class will have its own Kind.
--
-- Maps to the extended name of 'ada.Tags.Tag_type' value of each derived
-- event class (see 'Conversions' section in 'lace.Event.utility').
function Hash (the_Kind : in Kind) return ada.Containers.Hash_type;
private
null_Event : constant Event.item := (others => <>);
end lace.Event;

243
1-base/lace/source/events/mixin/lace-make_observer.adb Normal file
View File

@@ -0,0 +1,243 @@
with
lace.Event.Logger,
lace.Event.utility,
ada.unchecked_Conversion,
ada.unchecked_Deallocation;
package body lace.make_Observer
is
use type Event.Logger.view;
procedure destroy (Self : in out Item)
is
begin
Self.Responses.destroy;
end destroy;
------------
-- Responses
--
overriding
procedure add (Self : access Item; the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name)
is
begin
Self.Responses.add (Self, the_Response, to_Kind, from_Subject);
end add;
overriding
procedure rid (Self : access Item; the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name)
is
begin
Self.Responses.rid (Self, the_Response, to_Kind, from_Subject);
end rid;
overriding
procedure relay_responseless_Events (Self : in out Item; To : in Observer.view)
is
begin
Self.Responses.relay_responseless_Events (To);
end relay_responseless_Events;
-------------
-- Operations
--
overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class := Event.null_Event;
from_Subject : in Event.subject_Name)
is
begin
Self.Responses.receive (Self, the_Event, from_Subject);
end receive;
overriding
procedure respond (Self : access Item)
is
begin
null; -- This is a null operation since there can never be any deferred events for an 'instant' observer.
end respond;
-----------------
-- Safe Responses
--
protected
body safe_Responses
is
procedure destroy
is
use subject_Maps_of_event_responses;
procedure free is new ada.unchecked_Deallocation (event_response_Map,
event_response_Map_view);
Cursor : subject_Maps_of_event_responses.Cursor := my_Responses.First;
the_Map : event_response_Map_view;
begin
while has_Element (Cursor)
loop
the_Map := Element (Cursor);
free (the_Map);
next (Cursor);
end loop;
end destroy;
------------
-- Responses
--
procedure add (Self : access Item'Class;
the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name)
is
begin
if not my_Responses.contains (from_Subject)
then
my_Responses.insert (from_Subject,
new event_response_Map);
end if;
my_Responses.Element (from_Subject).insert (to_Kind,
the_Response);
if Observer.Logger /= null
then
Observer.Logger.log_new_Response (the_Response,
Observer.item'Class (Self.all),
to_Kind,
from_Subject);
end if;
end add;
procedure rid (Self : access Item'Class;
the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name)
is
begin
my_Responses.Element (from_Subject).delete (to_Kind);
if Observer.Logger /= null
then
Observer.Logger.log_rid_Response (the_Response,
Observer.item'Class (Self.all),
to_Kind,
from_Subject);
end if;
end rid;
procedure relay_responseless_Events (To : in Observer.view)
is
begin
my_relay_Target := To;
end relay_responseless_Events;
function relay_Target return Observer.view
is
begin
return my_relay_Target;
end relay_Target;
function Contains (Subject : in Event.subject_Name) return Boolean
is
begin
return my_Responses.Contains (Subject);
end Contains;
function Element (Subject : in Event.subject_Name) return event_response_Map
is
begin
return my_Responses.Element (Subject).all;
end Element;
-------------
-- Operations
--
procedure receive (Self : access Item'Class;
the_Event : in Event.item'Class := Event.null_Event;
from_Subject : in Event.subject_Name)
is
use event_response_Maps,
subject_Maps_of_event_responses,
lace.Event.utility,
ada.Containers;
use type lace.Observer.view;
the_Responses : event_response_Map renames my_Responses.Element (from_Subject).all;
the_Response : constant event_response_Maps.Cursor := the_Responses.find (to_Kind (the_Event'Tag));
my_Name : constant String := Observer.item'Class (Self.all).Name;
begin
if has_Element (the_Response)
then
Element (the_Response).respond (the_Event);
if Observer.Logger /= null
then
Observer.Logger.log_Response (Element (the_Response),
Observer.view (Self),
the_Event,
from_Subject);
end if;
elsif relay_Target /= null
then
-- Self.relay_Target.notify (the_Event, from_Subject_Name); -- todo: Re-enable event relays.
if Observer.Logger /= null
then
Observer.Logger.log ("[Warning] ~ Relayed events are currently disabled.");
else
raise program_Error with "Event relaying is currently disabled.";
end if;
else
if Observer.Logger /= null
then
Observer.Logger.log ("[Warning] ~ Observer " & my_Name & " has no response to " & Name_of (the_Event)
& " from " & from_Subject & ".");
Observer.Logger.log (" count of responses =>" & the_Responses.Length'Image);
else
raise program_Error with "Observer " & my_Name & " has no response to " & Name_of (the_Event)
& " from " & from_Subject & ".";
end if;
end if;
exception
when constraint_Error =>
if Observer.Logger /= null
then
Observer.Logger.log (my_Name & " has no responses for events from " & from_Subject & ".");
else
raise Program_Error with my_Name & " has no responses for events from " & from_Subject & ".";
end if;
end receive;
end safe_Responses;
end lace.make_Observer;

138
1-base/lace/source/events/mixin/lace-make_observer.ads Normal file
View File

@@ -0,0 +1,138 @@
with
lace.Event,
lace.Response,
lace.Observer;
private
with
ada.Containers.indefinite_hashed_Maps,
ada.Strings.Hash;
generic
type T is abstract tagged limited private;
package lace.make_Observer
--
-- Makes a user class T into an event Observer.
--
is
pragma remote_Types;
type Item is abstract limited new T
and Observer.item with private;
type View is access all Item'Class;
procedure destroy (Self : in out Item);
------------
-- Responses
--
overriding
procedure add (Self : access Item; the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name);
overriding
procedure rid (Self : access Item; the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name);
overriding
procedure relay_responseless_Events (Self : in out Item; To : in Observer.view);
-------------
-- Operations
--
overriding
procedure receive (Self : access Item; the_Event : in Event.item'Class := event.null_Event;
from_Subject : in Event.subject_Name);
overriding
procedure respond (Self : access Item);
private
----------------------
-- Event response maps
--
use type event.Kind;
use type Response.view;
package event_response_Maps is new ada.Containers.indefinite_hashed_Maps (key_type => Event.Kind,
element_type => Response.view,
hash => Event.Hash,
equivalent_keys => "=");
subtype event_response_Map is event_response_Maps.Map;
type event_response_Map_view is access all event_response_Map;
----------------------------------
-- Subject maps of event responses
--
package subject_Maps_of_event_responses
is new ada.Containers.indefinite_hashed_Maps (key_type => Event.subject_Name,
element_type => event_response_Map_view,
hash => ada.Strings.Hash,
equivalent_keys => "=");
subtype subject_Map_of_event_responses is subject_Maps_of_event_responses.Map;
-----------------
-- Safe Responses
--
protected
type safe_Responses
is
procedure destroy;
------------
-- Responses
--
procedure add (Self : access Item'Class;
the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name);
procedure rid (Self : access Item'Class;
the_Response : in Response.view;
to_Kind : in Event.Kind;
from_Subject : in Event.subject_Name);
procedure relay_responseless_Events (To : in Observer.view);
function relay_Target return Observer.view;
function Contains (Subject : in Event.subject_Name) return Boolean;
function Element (Subject : in Event.subject_Name) return event_response_Map;
-------------
-- Operations
--
procedure receive (Self : access Item'Class;
the_Event : in Event.item'Class := Event.null_Event;
from_Subject : in Event.subject_Name);
private
my_Responses : subject_Map_of_event_responses;
my_relay_Target : Observer.view;
end safe_Responses;
----------------
-- Observer Item
--
type Item is abstract limited new T
and Observer.item
with
record
Responses : safe_Responses;
end record;
end lace.make_Observer;

240
1-base/lace/source/events/mixin/lace-make_subject.adb Normal file
View File

@@ -0,0 +1,240 @@
with
lace.Event.Logger,
lace.Event.utility,
system.RPC,
ada.unchecked_Deallocation;
package body lace.make_Subject
is
use type Event.Logger.view;
procedure destroy (Self : in out Item)
is
begin
Self.safe_Observers.destruct;
end destroy;
-------------
-- Attributes
--
overriding
function Observers (Self : in Item; of_Kind : in Event.Kind) return subject.Observer_views
is
begin
return Self.safe_Observers.fetch_Observers (of_Kind);
end Observers;
overriding
function observer_Count (Self : in Item) return Natural
is
begin
return Self.safe_Observers.observer_Count;
end observer_Count;
-------------
-- Operations
--
overriding
procedure register (Self : access Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind)
is
begin
Self.safe_Observers.add (the_Observer, of_Kind);
if Subject.Logger /= null
then
Subject.Logger.log_Connection (the_Observer,
Subject.view (Self),
of_Kind);
end if;
end register;
overriding
procedure deregister (Self : in out Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind)
is
begin
Self.safe_Observers.rid (the_Observer, of_Kind);
if Subject.Logger /= null
then
Subject.Logger.log_disconnection (the_Observer,
Self'unchecked_Access,
of_Kind);
end if;
end deregister;
overriding
procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event)
is
use lace.Event.utility;
my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
begin
for i in my_Observers'Range
loop
begin
my_Observers (i).receive (the_Event,
from_Subject => Subject.item'Class (Self.all).Name);
if Subject.Logger /= null
then
Subject.Logger.log_Emit (Subject.view (Self),
my_Observers (i),
the_Event);
end if;
exception
when system.RPC.communication_Error
| storage_Error =>
if Subject.Logger /= null
then
Subject.Logger.log_Emit (Subject.view (Self),
my_Observers (i),
the_Event);
end if;
end;
end loop;
end emit;
overriding
function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event)
return subject.Observer_views
is
use lace.Event.utility;
my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
bad_Observers : Subject.Observer_views (my_Observers'Range);
bad_Count : Natural := 0;
begin
for i in my_Observers'Range
loop
begin
my_Observers (i).receive (the_Event,
from_Subject => Subject.item'Class (Self.all).Name);
if Subject.Logger /= null
then
Subject.Logger.log_Emit (Subject.view (Self),
my_Observers (i),
the_Event);
end if;
exception
when system.RPC.communication_Error
| storage_Error =>
bad_Count := bad_Count + 1;
bad_Observers (bad_Count) := my_Observers (i);
end;
end loop;
return bad_Observers (1 .. bad_Count);
end emit;
-----------------
-- Safe Observers
--
protected
body safe_Observers
is
procedure destruct
is
use event_kind_Maps_of_event_observers;
procedure deallocate is new ada.unchecked_Deallocation (event_Observer_Vector,
event_Observer_Vector_view);
Cursor : event_kind_Maps_of_event_observers.Cursor := the_Observers.First;
the_event_Observer_Vector : event_Observer_Vector_view;
begin
while has_Element (Cursor)
loop
the_event_Observer_Vector := Element (Cursor);
deallocate (the_event_Observer_Vector);
next (Cursor);
end loop;
end destruct;
procedure add (the_Observer : in Observer.view;
of_Kind : in Event.Kind)
is
use event_Observer_Vectors,
event_kind_Maps_of_event_observers;
Cursor : constant event_kind_Maps_of_event_observers.Cursor := the_Observers.find (of_Kind);
the_event_Observers : event_Observer_Vector_view;
begin
if has_Element (Cursor)
then
the_event_Observers := Element (Cursor);
else
the_event_Observers := new event_Observer_Vector;
the_Observers.insert (of_Kind,
the_event_Observers);
end if;
the_event_Observers.append (the_Observer);
end add;
procedure rid (the_Observer : in Observer.view;
of_Kind : in Event.Kind)
is
the_event_Observers : event_Observer_Vector renames the_Observers.Element (of_Kind).all;
begin
the_event_Observers.delete (the_event_Observers.find_Index (the_Observer));
end rid;
function fetch_Observers (of_Kind : in Event.Kind) return subject.Observer_views
is
begin
if the_Observers.Contains (of_Kind)
then
declare
the_event_Observers : constant event_Observer_Vector_view := the_Observers.Element (of_Kind);
my_Observers : Subject.Observer_views (1 .. Natural (the_event_Observers.Length));
begin
for i in my_Observers'Range
loop
my_Observers (i) := the_event_Observers.Element (i);
end loop;
return my_Observers;
end;
else
return [1 .. 0 => <>];
end if;
end fetch_Observers;
function observer_Count return Natural
is
use event_kind_Maps_of_event_observers;
Cursor : event_kind_Maps_of_event_observers.Cursor := the_Observers.First;
Count : Natural := 0;
begin
while has_Element (Cursor)
loop
Count := Count + Natural (Element (Cursor).Length);
next (Cursor);
end loop;
return Count;
end observer_Count;
end safe_Observers;
end lace.make_Subject;

114
1-base/lace/source/events/mixin/lace-make_subject.ads Normal file
View File

@@ -0,0 +1,114 @@
with
lace.Event,
lace.Subject,
lace.Observer;
private
with
ada.Containers.Vectors,
ada.Containers.indefinite_hashed_Maps;
generic
type T is abstract tagged limited private;
package lace.make_Subject
--
-- Makes a user class T into an event Subject.
--
is
pragma remote_Types;
type Item is abstract limited new T
and Subject.item with private;
type View is access all Item'Class;
procedure destroy (Self : in out Item);
-------------
-- Attributes
--
overriding
function Observers (Self : in Item; of_Kind : in Event.Kind) return Subject.Observer_views;
overriding
function observer_Count (Self : in Item) return Natural;
-------------
-- Operations
--
overriding
procedure register (Self : access Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind);
overriding
procedure deregister (Self : in out Item; the_Observer : in Observer.view;
of_Kind : in Event.Kind);
overriding
procedure emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event);
overriding
function emit (Self : access Item; the_Event : in Event.item'Class := Event.null_Event)
return subject.Observer_views;
private
-------------------------
-- Event observer vectors
--
use type Observer.view;
package event_Observer_Vectors is new ada.Containers.Vectors (Positive, Observer.view);
subtype event_Observer_Vector is event_Observer_Vectors.Vector;
type event_Observer_Vector_view is access all event_Observer_Vector;
-------------------------------------
-- Event kind Maps of event observers
--
use type Event.Kind;
package event_kind_Maps_of_event_observers is new ada.Containers.indefinite_hashed_Maps (Event.Kind,
event_Observer_Vector_view,
Event.Hash,
"=");
subtype event_kind_Map_of_event_observers is event_kind_Maps_of_event_observers.Map;
-----------------
-- Safe observers
--
protected
type safe_Observers
is
procedure destruct;
procedure add (the_Observer : in Observer.view;
of_Kind : in Event.Kind);
procedure rid (the_Observer : in Observer.view;
of_Kind : in Event.Kind);
function fetch_Observers (of_Kind : in Event.Kind) return Subject.Observer_views;
function observer_Count return Natural;
private
the_Observers : event_kind_Map_of_event_observers;
end safe_Observers;
---------------
-- Subject Item
--
type Item is abstract limited new T
and Subject.item
with
record
safe_Observers : make_Subject.safe_Observers;
end record;
end lace.make_Subject;

Some files were not shown because too many files have changed in this diff Show More