{$MODE OBJFPC} { -*- delphi -*- }
{$INCLUDE settings.inc}
unit navbits;

interface

uses
   rpc, actors, facilities, callbacks;

type
   TNavigationTower = class(TFacility) // @RegisterFacilityClass
     public
      procedure Init(Actor: TAbstractActor); override;
     published
      procedure AncestorLostParent(var Arguments: TLostParentArguments); // @RegisterMethod
      procedure AncestorGainedParent(var Arguments: TGainedParentArguments); // @RegisterMethod
      procedure HandleCrash(var Arguments: TCrashArguments); // @RegisterMethod
   end;

implementation

uses
   exceptions, methodregistry, gravity;

procedure TNavigationTower.Init(Actor: TAbstractActor);
var
   Ancestor: TAbstractTreeNode;
begin
   Assert(Actor is TPhysicalActor);
   inherited;
   Ancestor := Parent;
   while (Assigned(Ancestor)) do
   begin
      if (not Assigned(Ancestor.Parent)) then
      begin
         // got to top of tree without finding a gravitational system
         // top of tree better still be physical and better not be a facility
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@AncestorGainedParent));
         Break;
      end
      else
      if (Ancestor.Parent is TGravitationalSystem) then
      begin
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@HandleCrash));
         Break;
      end
      else
      begin
         if (Ancestor is TPhysicalActor) then
            (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@AncestorLostParent));
         Ancestor := Ancestor.Parent;
      end;
   end;
end;

procedure TNavigationTower.AncestorLostParent(var Arguments: TLostParentArguments);
var
   Ancestor: TAbstractTreeNode;
begin
   Ancestor := Arguments.Child;
   while (Assigned(Ancestor)) do
   begin
      if (not Assigned(Ancestor.Parent)) then
      begin
         // got to top of tree without finding a gravitational system
         // top of tree better still be physical and better not be a facility
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).UnregisterCallback(TActorCallbackMethod(@AncestorGainedParent));
         Break;
      end
      else
      if (Ancestor.Parent is TGravitationalSystem) then
      begin
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).UnregisterCallback(TActorCallbackMethod(@HandleCrash));
         Break;
      end
      else
      begin
         if (Ancestor is TPhysicalActor) then
            (Ancestor as TPhysicalActor).UnregisterCallback(TActorCallbackMethod(@AncestorLostParent));
         Ancestor := Ancestor.Parent;
      end;
   end;
end;

procedure TNavigationTower.AncestorGainedParent(var Arguments: TGainedParentArguments);
var
   Ancestor: TAbstractTreeNode;
begin
   Ancestor := Arguments.Child;
   Assert(Ancestor is TPhysicalActor); // because we only set this callback on TPhysicalActors
   (Ancestor as TPhysicalActor).UnregisterCallback(TActorCallbackMethod(@AncestorGainedParent));
   while (Assigned(Ancestor)) do
   begin
      if (not Assigned(Ancestor.Parent)) then
      begin
         // got to top of tree without finding a gravitational system
         // top of tree better still be physical and better not be a facility
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@AncestorGainedParent));
         Break;
      end
      else
      if (Ancestor.Parent is TGravitationalSystem) then
      begin
         Assert(Ancestor is TPhysicalActor);
         (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@HandleCrash));
         Break;
      end
      else
      begin
         if (Ancestor is TPhysicalActor) then
            (Ancestor as TPhysicalActor).RegisterCallback(TActorCallbackMethod(@AncestorLostParent));
         Ancestor := Ancestor.Parent;
      end;
   end;
end;

procedure TNavigationTower.HandleCrash(var Arguments: TCrashArguments);
begin
   Assert(Arguments.Victim is TPhysicalActor); // because only TPhysicalActors can crash
   Assert(Parent is TPhysicalActor); // because this Facility is only allowed on TPhysicalActors
   Writeln((Parent as TPhysicalActor).Name, ': Failed to avert crash!');
end;

initialization
{$INCLUDE registrations/navbits.inc}
end.