Add initial prototype.

.gitignore

@@ -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/
+

0-floor/lace_shared/alire.toml

@@ -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"

0-floor/lace_shared/debug.pra

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

0-floor/lace_shared/lace_shared.gpr

@@ -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;

1-base/lace/Overview

@@ -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.
+   

1-base/lace/alire.toml

@@ -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"

1-base/lace/applet/demo/event/distributed/builder.sh

@@ -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

1-base/lace/applet/demo/event/distributed/launch_simple_chat_client.adb

@@ -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;

1-base/lace/applet/demo/event/distributed/launch_simple_chat_registrar.adb

@@ -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;

1-base/lace/applet/demo/event/distributed/simple_chat.dsa

@@ -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;

1-base/lace/applet/demo/event/distributed/simple_chat.gpr

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat-client-local.adb

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat-client-local.ads

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat-client.ads

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat-registrar.adb

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat-registrar.ads

@@ -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;

1-base/lace/applet/demo/event/distributed/source/chat.ads

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

1-base/lace/applet/demo/event/distributed/test/lan/README

@@ -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
+
+

1-base/lace/applet/demo/event/distributed/test/lan/client_1/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/distributed/test/lan/client_1/test.sh

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

1-base/lace/applet/demo/event/distributed/test/lan/client_2/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/distributed/test/lan/client_2/test.sh

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

1-base/lace/applet/demo/event/distributed/test/lan/po_namer/polyorb.conf

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

1-base/lace/applet/demo/event/distributed/test/lan/po_namer/test.sh

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

1-base/lace/applet/demo/event/distributed/test/lan/registrar/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/distributed/test/lan/registrar/test.sh

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

1-base/lace/applet/demo/event/distributed/test/wan/client_1/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/distributed/test/wan/client_2/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/distributed/test/wan/po_namer/polyorb.conf

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

1-base/lace/applet/demo/event/distributed/test/wan/registrar/polyorb.conf

@@ -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

1-base/lace/applet/demo/event/simple/deferred/lace_simple_deferred_events_demo.gpr

@@ -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;

1-base/lace/applet/demo/event/simple/deferred/launch_simple_deferred_events_demo.adb

@@ -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;

1-base/lace/applet/demo/event/simple/instant/lace_simple_instant_events_demo.gpr

@@ -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;

1-base/lace/applet/demo/event/simple/instant/launch_simple_instant_events_demo.adb

@@ -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;

1-base/lace/applet/demo/event/simple/lace_demo.gpr

@@ -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;

1-base/lace/applet/demo/event/simple/lace_demo_events.ads

@@ -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;

1-base/lace/applet/demo/event/simple/lace_demo_keyboard.adb

@@ -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;
+

1-base/lace/applet/demo/event/simple/lace_demo_keyboard.ads

@@ -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;

1-base/lace/applet/demo/strings/launch_strings_demo.adb

@@ -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;

1-base/lace/applet/demo/strings/strings_demo.gpr

@@ -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;

1-base/lace/applet/test/dice/test_dice.adb

@@ -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;

1-base/lace/applet/test/dice/test_dice.gpr

@@ -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;

1-base/lace/applet/test/environ/compression/test_environ_compression.adb

@@ -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;

1-base/lace/applet/test/environ/compression/test_environ_compression.gpr

@@ -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;

1-base/lace/applet/test/environ/general/test_environ_general.adb

@@ -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;

1-base/lace/applet/test/environ/general/test_environ_general.gpr

@@ -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-base/lace/applet/test/environ/paths/data/digits.txt

@@ -0,0 +1 @@
+0123456789

1-base/lace/applet/test/environ/paths/test_environ_paths.adb

@@ -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;

1-base/lace/applet/test/environ/paths/test_environ_paths.gpr

@@ -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;

1-base/lace/applet/test/text/test_text.gpr

@@ -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;

1-base/lace/applet/test/text/test_text_replace.adb

@@ -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;

1-base/lace/document/events/Overview

@@ -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'
+

1-base/lace/document/events/requirements

@@ -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.

1-base/lace/document/events/tasking

@@ -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)
+

1-base/lace/library/lace.gpr

@@ -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;

1-base/lace/source/containers/lace-containers-shuffle_vector.adb

@@ -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;

1-base/lace/source/containers/lace-containers-shuffle_vector.ads

@@ -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);

1-base/lace/source/containers/lace-containers.ads

@@ -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;

1-base/lace/source/dice/lace-dice-any.adb

@@ -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;

1-base/lace/source/dice/lace-dice-any.ads

@@ -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;
+

1-base/lace/source/dice/lace-dice-d6.adb

@@ -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;

1-base/lace/source/dice/lace-dice-d6.ads

@@ -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;
+

1-base/lace/source/dice/lace-dice.adb

@@ -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;
+

1-base/lace/source/dice/lace-dice.ads

@@ -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;
+

1-base/lace/source/environ/lace-environ-os_commands.adb

@@ -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;

1-base/lace/source/environ/lace-environ-os_commands.ads

@@ -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;

1-base/lace/source/environ/lace-environ-paths.ads

@@ -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;

1-base/lace/source/environ/lace-environ-users.adb

@@ -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;

1-base/lace/source/environ/lace-environ-users.ads

@@ -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;

1-base/lace/source/environ/lace-environ.adb

@@ -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;

1-base/lace/source/environ/lace-environ.ads

@@ -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;

1-base/lace/source/events/concrete/lace-observer-deferred.adb

@@ -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;

1-base/lace/source/events/concrete/lace-observer-deferred.ads

@@ -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;

1-base/lace/source/events/concrete/lace-observer-instant.adb

@@ -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;

1-base/lace/source/events/concrete/lace-observer-instant.ads

@@ -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;

1-base/lace/source/events/concrete/lace-subject-local.adb

@@ -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;

1-base/lace/source/events/concrete/lace-subject-local.ads

@@ -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;

1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.adb

@@ -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;

1-base/lace/source/events/concrete/lace-subject_and_deferred_observer.ads

@@ -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;

1-base/lace/source/events/concrete/lace-subject_and_instant_observer.adb

@@ -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;

1-base/lace/source/events/concrete/lace-subject_and_instant_observer.ads

@@ -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;

1-base/lace/source/events/interface/lace-observer.adb

@@ -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;

1-base/lace/source/events/interface/lace-observer.ads

@@ -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;

1-base/lace/source/events/interface/lace-response.adb

@@ -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;

1-base/lace/source/events/interface/lace-response.ads

@@ -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;

1-base/lace/source/events/interface/lace-subject.adb

@@ -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;

1-base/lace/source/events/interface/lace-subject.ads

@@ -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;

1-base/lace/source/events/lace-event.adb

@@ -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;

1-base/lace/source/events/lace-event.ads

@@ -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;

1-base/lace/source/events/mixin/lace-make_observer.adb

@@ -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;

1-base/lace/source/events/mixin/lace-make_observer.ads

@@ -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;

1-base/lace/source/events/mixin/lace-make_subject.adb

@@ -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;

1-base/lace/source/events/mixin/lace-make_subject.ads

@@ -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;