{$MODE OBJFPC} { -*- delphi -*- } {$INCLUDE settings.inc} unit actors; interface uses storable, autostorable, stringstream, tokenutils, hashtable, hashfunctions, rpc, callbacks, properties; type TActorSettings = class(TAutoStorable) // @RegisterStorableClass private FName: UTF8String; published property Name: UTF8String read FName write FName; end; {$TYPEINFO ON} TActor = class abstract (TAbstractActor) private FSubscribers: TMessageWebSocketHashSet; procedure HandleGet(var Message: TMessage); message 'get'; procedure Setup(); protected FID: TActorID; FName: UTF8String; FFacilities: array of TAbstractFacility; function GetRendererClass(): UTF8String; virtual; abstract; function GetID(): TActorID; override; {$IFDEF DEBUG} function GetName(): UTF8String; override; {$ENDIF} procedure FacilitiesUpdated(); virtual; class function CreateSettings(): TAutoStorable; virtual; public Game: TAbstractGame; static; constructor Create(AName: UTF8String); overload; constructor Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); override; overload; destructor Destroy(); override; constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; class function ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; override; class function GetImage(Settings: TAutoStorable): UTF8String; override; class function GetEnvironment(Settings: TAutoStorable): UTF8String; override; procedure AddFacility(Facility: TAbstractFacility); override; procedure MarkDirty(DirtyFlags: TDirtyFlags); override; procedure AutoSubscribe(Connection: TMessageWebSocket); override; procedure Subscribe(Connection: TMessageWebSocket); override; procedure Unsubscribe(Connection: TMessageWebSocket); override; procedure DefaultHandlerStr(var Message); override; procedure ReportChanges(); override; procedure ReportDeath(); override; procedure KillChildren(); override; procedure ReportIdentity(Stream: TStringStreamWriter); override; procedure ReportState(Dynasty: TAbstractDynasty; Stream: TStringStreamWriter); override; function ParseLocationFromMessage(Stream: TStringStreamReader): TAbstractLocation; override; // returns nil; procedure Tick(Interval: TDateTime); override; published property Name: UTF8String read FName; end; {$TYPEINFO OFF} TChildActor = class; TActorCallbackMethod = procedure (var CallbackData) of object; PCallbackList = ^TCallbackList; TCallbackList = record Callback: TActorCallbackMethod; Next: PCallbackList; end; TActorCallbackListHashTable = class(specialize THashTable) public constructor Create(PredictedCount: THashTableSizeInt = 8); end; TPhysicalActor = class abstract (TActor) private FCallbacks: TActorCallbackListHashTable; FParent: TAbstractTreeNode; FCachedDescendantMass: TGravitationalSystemValue; // not stored FIndependent: Boolean; // If we ever let this change at runtime, make sure to send dfPhysicalPropertiesChanged to parent FPhysicalProperties: TPhysicalProperties; // not stored FPhysicalPropertiesDirty, FFacilitiesHavePhysicalProperties: Boolean; // not stored procedure RegisterMasses(); protected FSelfMass: TGravitationalSystemValue; function GetParent(): TAbstractTreeNode; override; procedure SetParent(const NewParent: TAbstractTreeNode); override; function GetParentActor(): TActor; procedure FacilitiesUpdated(); override; function GetRadius(): TGravitationalSystemValue; virtual; abstract; function GetMass(): TGravitationalSystemValue; virtual; procedure NotifyParentOfMassChange(Delta: TGravitationalSystemValue); virtual; procedure AddPhysicalProperties(Target: PPhysicalProperties); virtual; public constructor Create(AName: UTF8String; AnIndependent: Boolean); overload; // for genesis, mainly constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; destructor Destroy(); override; procedure MarkDirty(DirtyFlags: TDirtyFlags); override; procedure UpdatePhysicalProperties(); override; procedure ApplyPhysicalProperties(Target: PPhysicalProperties); virtual; procedure AdjustDescendantMass(Delta: TGravitationalSystemValue); virtual; procedure AdjustSelfMass(Delta: TGravitationalSystemValue); virtual; procedure Crash(Victim: TChildActor; Location: TAbstractLocation); virtual; // Victim crashed into us procedure RegisterCallback(const CallbackMethod: TActorCallbackMethod); procedure UnregisterCallback(const CallbackMethod: TActorCallbackMethod); procedure RunCallbacks(var CallbackData); published property Radius: TGravitationalSystemValue read GetRadius; // Radius is not implemented in TPhysicalActor // It should be implemented in the subclass, either as an intrinsic value (e.g. for planets) or as a derived value based // on other properties (e.g. a solar system's radius depends on the configuration of its bodies). property Mass: TGravitationalSystemValue read GetMass; property ParentActor: TActor read GetParentActor; property Independent: Boolean read FIndependent; end; TChildActorSettings = class(TActorSettings) // @RegisterStorableClass private FIndependent: Boolean; FImage: UTF8String; FEnvironment: UTF8String; published property Independent: Boolean read FIndependent write FIndependent; property Image: UTF8String read FImage write FImage; property Environment: UTF8String read FEnvironment write FEnvironment; end; // TODO(ianh): rename this TBuildableActor TChildActor = class(TPhysicalActor) // @RegisterActorClass protected FImage: UTF8String; class function CreateSettings(): TAutoStorable; override; function GetPhysicalProperties(): PPhysicalProperties; public constructor Create(AName, AnImage: UTF8String; AnIndependent: Boolean); overload; // for genesis, mainly constructor Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); override; overload; constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; class function ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; override; // GetImage and GetEnvironment are used by the tech tree when describing to the client what available actors can be built class function GetImage(Settings: TAutoStorable): UTF8String; override; class function GetEnvironment(Settings: TAutoStorable): UTF8String; override; function GetRendererClass(): UTF8String; override; procedure Crashed(CrashSite: TPhysicalActor; Location: TAbstractLocation); virtual; // we crashed into CrashSite, caller will reset our parent and free us property PhysicalProperties: PPhysicalProperties read GetPhysicalProperties; published property Image: UTF8String read FImage; end; TMassiveActorSettings = class(TChildActorSettings) // @RegisterStorableClass private FRadius, FDensity: TGravitationalSystemValue; published property Radius: TGravitationalSystemValue read FRadius write FRadius; property Density: TGravitationalSystemValue read FDensity write FDensity; end; TMassiveActor = class(TChildActor) // @RegisterActorClass // Objects with intrinsic own size (like rocks) // (as opposed to objects whose size is determined by its contents, like balloons and solar systems) private FRadius: TGravitationalSystemValue; procedure SetDensity(ADensity: TGravitationalSystemValue); // only for use during initialisation protected class function CreateSettings(): TAutoStorable; override; function GetRadius(): TGravitationalSystemValue; override; public constructor Create(AName, AnImage: UTF8String; AnIndependent: Boolean; ARadius, ADensity: TGravitationalSystemValue); overload; // for genesis, mainly constructor Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); override; overload; constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; class function ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; override; end; TOwnableActor = class(TMassiveActor) // @RegisterActorClass protected FCurrentDynasty: TAbstractDynasty; procedure Init(); public constructor Create(AName, AnImage: UTF8String; AnIndependent: Boolean; ARadius, ADensity: TGravitationalSystemValue; Dynasty: TAbstractDynasty); overload; deprecated 'for genesis, mainly'; constructor Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); override; overload; destructor Destroy(); override; constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; // XXX methods to update the dynasty which notify all the facilities, etc procedure Crashed(CrashSite: TPhysicalActor; Location: TAbstractLocation); override; published property CurrentOwnerDynasty: TAbstractDynasty read FCurrentDynasty; end; TNewsActor = class(TActor) // @RegisterActorClass private FKind, FBody: UTF8String; protected function GetParent(): TAbstractTreeNode; override; procedure SetParent(const NewParent: TAbstractTreeNode); override; public constructor Create(AName, AKind, ABody: UTF8String); overload; constructor Read(Stream: TReadStream); override; procedure Write(Stream: TWriteStream); override; function GetRendererClass(): UTF8String; override; published property NewsKind: UTF8String read FKind; property NewsBody: UTF8String read FBody; end; procedure RegisterActorClass(AClass: TAbstractActorClass); function GetActorClass(AName: UTF8String): TAbstractActorClass; implementation uses exceptions, typinfo, sysutils, stringutils, methodregistry; type TActorClassesHashTable = specialize THashTable; var ActorClasses: TActorClassesHashTable; procedure RegisterActorClass(AClass: TAbstractActorClass); begin Assert(not ActorClasses.Has(AClass.ClassName), AClass.ClassName + ' registered twice'); ActorClasses[AClass.ClassName] := AClass; RegisterStorableClass(AClass); end; function GetActorClass(AName: UTF8String): TAbstractActorClass; begin Result := ActorClasses[AName]; end; constructor TActor.Create(AName: UTF8String); begin inherited Create(); FName := AName; Setup(); end; constructor TActor.Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); begin inherited; Assert(Settings is TActorSettings); Assert(Assigned(Dynasty)); // how else can we get here? if (Assigned(Dynasty)) then FName := Dynasty.Name + ' ' + (Settings as TActorSettings).Name; // XXX should find a better way of doing this, for sure //else // FName := (Settings as TActorSettings).Name; Setup(); end; procedure TActor.Setup(); begin Assert(Assigned(Game)); FID := Game.GetID(); Game.Register(Self); end; destructor TActor.Destroy(); var Connection: TMessageWebSocket; Index: Cardinal; begin if (Assigned(FSubscribers)) then begin for Connection in FSubscribers do Connection.Unsubscribe(Self); FSubscribers.Free(); end; if (Length(FFacilities) > 0) then for Index := Low(FFacilities) to High(FFacilities) do FFacilities[Index].Free(); inherited; end; constructor TActor.Read(Stream: TReadStream); var Index: Cardinal; begin inherited; Assert(Assigned(Game)); FID := Stream.ReadCardinal(); Game.Register(Self); FName := Stream.ReadString(); SetLength(FFacilities, Stream.ReadCardinal()); if (Length(FFacilities) > 0) then begin for Index := Low(FFacilities) to High(FFacilities) do // $R- FFacilities[Index] := Stream.ReadObject() as TAbstractFacility; FacilitiesUpdated(); end; end; procedure TActor.Write(Stream: TWriteStream); var Index: Cardinal; begin inherited; Stream.WriteCardinal(FID); Stream.WriteString(FName); Stream.WriteCardinal(Length(FFacilities)); if (Length(FFacilities) > 0) then for Index := Low(FFacilities) to High(FFacilities) do Stream.WriteObject(FFacilities[Index]); end; class function TActor.CreateSettings(): TAutoStorable; begin Result := TActorSettings.Create(); end; class function TActor.ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; begin Result := CreateSettings(); Assert(Result is TActorSettings); Assert(Length(Tokens) > Index); Assert(Tokens[Index].TokenType = ttString); (Result as TActorSettings).Name := Tokens[Index].StringValue^; Inc(Index); ErrorMessage := ''; end; class function TActor.GetImage(Settings: TAutoStorable): UTF8String; begin Result := ''; end; class function TActor.GetEnvironment(Settings: TAutoStorable): UTF8String; begin Result := ''; end; procedure TActor.AddFacility(Facility: TAbstractFacility); begin Assert(Assigned(Facility)); Assert(Facility.Parent = Self); SetLength(FFacilities, Length(FFacilities)+1); FFacilities[High(FFacilities)] := Facility; FacilitiesUpdated(); end; procedure TActor.FacilitiesUpdated(); begin end; procedure TActor.DefaultHandlerStr(var Message); var Index: Cardinal; begin Index := Low(FFacilities); while ((Index <= High(FFacilities)) and (not TMessage(Message).Handled)) do begin FFacilities[Index].DispatchStr(Message); Inc(Index); end; end; function TActor.GetID(): TActorID; begin Result := FID; end; {$IFDEF DEBUG} function TActor.GetName(): UTF8String; begin Result := FName; end; {$ENDIF} procedure TActor.ReportIdentity(Stream: TStringStreamWriter); begin Stream.WriteString(GetRendererClass()); Stream.WriteCardinal(FID); end; procedure TActor.MarkDirty(DirtyFlags: TDirtyFlags); begin Game.MarkDirty(Self, DirtyFlags); end; procedure TActor.AutoSubscribe(Connection: TMessageWebSocket); begin Subscribe(Connection); Connection.ReportChange(Self); end; procedure TActor.Subscribe(Connection: TMessageWebSocket); begin if (not Assigned(FSubscribers)) then FSubscribers := TMessageWebSocketHashSet.Create(); Assert(not FSubscribers.Has(Connection)); FSubscribers.Add(Connection); Assert(not Connection.IsSubscribed(Self)); end; procedure TActor.Unsubscribe(Connection: TMessageWebSocket); begin Assert(Connection.IsSubscribed(Self)); FSubscribers.Remove(Connection); if (FSubscribers.Count = 0) then begin FSubscribers.Free(); FSubscribers := nil; end; end; procedure TActor.ReportChanges(); var Socket: TMessageWebSocket; begin if (Assigned(FSubscribers) and (FSubscribers.Count > 0)) then begin for Socket in FSubscribers do Socket.ReportChange(Self); end; end; procedure TActor.ReportDeath(); var Socket: TMessageWebSocket; begin if (Assigned(FSubscribers) and (FSubscribers.Count > 0)) then begin for Socket in FSubscribers do Socket.ReportDeath(Self); end; end; procedure TActor.KillChildren(); var Index: Cardinal; begin if (Length(FFacilities) > 0) then for Index := Low(FFacilities) to High(FFacilities) do FFacilities[Index].KillChildren(Game); end; procedure TActor.ReportState(Dynasty: TAbstractDynasty; Stream: TStringStreamWriter); procedure ReportProperty(Host: TObject; PropInfo: PPropInfo); type TUTF8StringArray = array of UTF8String; var TypeData: PTypeData; StringArray: TUTF8StringArray; Index: Cardinal; AClass: TClass; AnObject: TObject; begin Stream.WriteString(PropInfo^.Name); case PropInfo^.PropType^.Kind of tkInteger: begin Stream.WriteString('integer'); TypeData := GetTypeData(PropInfo^.PropType); Assert(TypeData^.OrdType = otULong, 'Only Cardinal integers are currently supported'); // next three are redundant, in theory Assert(TypeData^.MinValue >= 0, 'Negative values are not yet supported'); Assert(TypeData^.MaxValue < High(Cardinal), 'Values more than 32bit are not yet supported'); Assert(GetOrdProp(Host, PropInfo) >= 0, 'ReportState() doesn''t support negative values yet'); Stream.WriteCardinal(GetOrdProp(Host, PropInfo)); // $R- end; tkFloat: begin Stream.WriteString('float'); Stream.WriteDouble(GetFloatProp(Host, PropInfo)); // XXX what if it's out of range of Double? end; tkChar: begin Stream.WriteString('string'); Stream.WriteString(Char(GetOrdProp(Host, PropInfo))); end; tkSString, tkAString: begin Stream.WriteString('string'); Stream.WriteString(GetStrProp(Host, PropInfo)); end; tkBool: begin Stream.WriteString('boolean'); if (GetOrdProp(Host, PropInfo) > 0) then Stream.WriteString('T') else Stream.WriteString('F'); end; tkEnumeration: begin Stream.WriteString('string'); Stream.WriteString(GetEnumProp(Host, PropInfo)); // consider stripping off the leading lowercase characters end; tkDynArray: begin Stream.WriteString('array'); TypeData := GetTypeData(PropInfo^.PropType); case (TypeData^.elType2^.Kind) of tkAString: begin Stream.WriteString('string'); StringArray := GetDynArrayProp(Host, PropInfo); Assert(Length(StringArray) < High(Cardinal)); // More than that many entries suggests memory corruption or errors in the RTTI code Stream.WriteCardinal(Length(StringArray)); if (Length(StringArray) > 0) then for Index := Low(StringArray) to High(StringArray) do Stream.WriteString(StringArray[Index]); end; else Assert(False, 'Property ' + PropInfo^.Name + ' uses a type (array of ' + GetEnumName(TypeInfo(TTypeKind), Ord(TypeData^.elType2^.Kind)) + ') for which we do not yet implement array serialisation'); end; end; tkClass: begin AClass := GetTypeData(PropInfo^.PropType)^.ClassType; AnObject := GetObjectProp(Host, PropInfo); if (AClass.InheritsFrom(TAbstractActor)) then begin if (Assigned(AnObject)) then begin Stream.WriteString('actor'); Assert(AnObject is TAbstractActor, PropInfo^.Name + ' is ' + AnObject.ClassName); (AnObject as TActor).ReportIdentity(Stream); end else begin Stream.WriteString('actor-nil'); end; end else if (AClass.InheritsFrom(TAbstractDynasty)) then begin if (Assigned(AnObject)) then begin Stream.WriteString('dynasty'); Assert(AnObject is TAbstractDynasty, PropInfo^.Name + ' is ' + AnObject.ClassName); Stream.WriteString((AnObject as TAbstractDynasty).Name); end else begin Stream.WriteString('dynasty-nil'); end; end else Assert(False, 'Unsupported class property: ' + AClass.ClassName); end; else Assert(False, 'Property ' + PropInfo^.Name + ' uses a type (' + GetEnumName(TypeInfo(TTypeKind), Ord(PropInfo^.PropType^.Kind)) + ') for which we do not yet implement serialisation'); end; end; procedure ReportPropertyList(Host: TObject); var TypeInfo: PTypeInfo; TypeData: PTypeData; PropertyList: PPropList; PropIndex: Cardinal; begin TypeInfo := Host.ClassInfo(); TypeData := GetTypeData(TypeInfo); Assert(TypeData^.PropCount < 1024, 'Woah, that''s a lot of properties'); // if we hit this, we should reconsider what we're doing here (e.g. the GetMem() call below will crash if we get too high, since GetMem can only allocate so much at once) if (TypeData^.PropCount > 0) then begin GetMem(PropertyList, TypeData^.PropCount * SizeOf(Pointer)); // $R- Assert(Assigned(PropertyList)); GetPropInfos(TypeInfo, PropertyList); Assert(Assigned(TypeInfo)); for PropIndex := 0 to TypeData^.PropCount-1 do {BOGUS Warning: Type size mismatch, possible loss of data / range check error} // since we check that the count is > 0 above ReportProperty(Host, PropertyList^[PropIndex]); FreeMem(PropertyList); end; end; function GetCount(Host: TObject): Cardinal; var TypeInfo: PTypeInfo; TypeData: PTypeData; begin TypeInfo := Host.ClassInfo(); Assert(TypeInfo^.Kind = tkClass); Assert(TypeInfo^.Name = Host.ClassName); TypeData := GetTypeData(TypeInfo); Assert(TypeData^.ClassType = Host.ClassType); Assert(TypeData^.PropCount >= 0); // can't really be negative, but just in case... Result := TypeData^.PropCount; // {BOGUS Warning: Type size mismatch, possible loss of data / range check error} end; var FacilityIndex, Count: Cardinal; begin Count := GetCount(Self); if (Length(FFacilities) > 0) then for FacilityIndex := Low(FFacilities) to High(FFacilities) do Inc(Count, GetCount(FFacilities[FacilityIndex])); Stream.WriteCardinal(Count); ReportPropertyList(Self); if (Length(FFacilities) > 0) then for FacilityIndex := Low(FFacilities) to High(FFacilities) do ReportPropertyList(FFacilities[FacilityIndex]); end; function TActor.ParseLocationFromMessage(Stream: TStringStreamReader): TAbstractLocation; begin Result := nil; end; procedure TActor.Tick(Interval: TDateTime); var Index: Cardinal; begin if (Length(FFacilities) > 0) then for Index := Low(FFacilities) to High(FFacilities) do FFacilities[Index].Tick(Interval); end; procedure TActor.HandleGet(var Message: TMessage); var Response: TStringStreamWriter; begin if (Message.Stream.ReadEnd()) then // the message should not contain anything interesting begin Message.Subscribe(Self); Response := Message.Reply(True); ReportState(Message.Dynasty, Response); Response.Close(); end; end; constructor TActorCallbackListHashTable.Create(PredictedCount: THashTableSizeInt = 8); begin inherited Create(THashFunction( {$IF SIZEOF(TActorCallbackType) = SIZEOF(DWord)} @Integer32Hash32 {$ELSEIF SIZEOF(TActorCallbackType) = SIZEOF(QWord)} @Integer64Hash32 {$ELSE} {$ERROR No suitable hashing function available for TActorCallbackType on this platform} {$ENDIF} ), PredictedCount); end; constructor TPhysicalActor.Create(AName: UTF8String; AnIndependent: Boolean); begin inherited Create(AName); FIndependent := AnIndependent; end; constructor TPhysicalActor.Read(Stream: TReadStream); var Count, Index, SubCount, SubIndex: Cardinal; Entry, PreviousEntry: PCallbackList; CallbackType: TActorCallbackType; begin inherited; Stream.ReadReference(@Pointer(FParent)); FSelfMass := Stream.ReadDouble(); Stream.AddFinalFixer(@RegisterMasses); FIndependent := Stream.ReadBoolean(); // callbacks Count := Stream.ReadCardinal(); if (Count > 0) then begin FCallbacks := TActorCallbackListHashTable.Create(Count); // XXX what if Count is bigger than High(THashTableSizeInt) ? for Index := 1 to Count do begin SubCount := Stream.ReadCardinal(); Assert(SubCount > 0); CallbackType := TActorCallbackType(Stream.ReadCardinal()); PreviousEntry := nil; Entry := nil; // only needed for the assert below for SubIndex := 1 to SubCount do begin New(Entry); Stream.ReadMethod(@TMethod(Entry^.Callback)); if (Assigned(PreviousEntry)) then begin PreviousEntry^.Next := Entry; end else begin FCallbacks[CallbackType] := Entry; end; PreviousEntry := Entry; end; Assert(Assigned(Entry)); Entry^.Next := nil; end; end; end; procedure TPhysicalActor.RegisterMasses(); begin NotifyParentOfMassChange(+FSelfMass); end; procedure TPhysicalActor.Write(Stream: TWriteStream); var CallbackType: TActorCallbackType; FirstEntry, Entry: PCallbackList; Count: Cardinal; begin inherited; Stream.WriteReference(FParent); Stream.WriteDouble(FSelfMass); Stream.WriteBoolean(FIndependent); // callbacks if (Assigned(FCallbacks) and (FCallbacks.Count > 0)) then begin Stream.WriteCardinal(FCallbacks.Count); for CallbackType in FCallbacks do begin Stream.WriteCardinal(Cardinal(CallbackType)); FirstEntry := FCallbacks[CallbackType]; Entry := FirstEntry; Count := 0; while (Assigned(Entry)) do begin Inc(Count); Entry := Entry^.Next; end; Assert(Count > 0); Stream.WriteCardinal(Count); Entry := FirstEntry; while (Assigned(Entry)) do begin Stream.WriteMethod(TMethod(Entry^.Callback)); Entry := Entry^.Next; end; end; end else begin Stream.WriteCardinal(0); end; end; destructor TPhysicalActor.Destroy(); var FirstEntry, NextEntry, CurrentEntry: PCallbackList; begin if (Assigned(FCallbacks)) then begin if (FCallbacks.Count > 0) then for FirstEntry in FCallbacks.Values do begin CurrentEntry := FirstEntry; while (Assigned(CurrentEntry)) do begin NextEntry := CurrentEntry^.Next; Dispose(CurrentEntry); CurrentEntry := NextEntry; end; end; FCallbacks.Free(); end; inherited; end; function TPhysicalActor.GetParent(): TAbstractTreeNode; begin Result := FParent; end; procedure TPhysicalActor.SetParent(const NewParent: TAbstractTreeNode); var LostParentArguments: TLostParentArguments; GainedParentArguments: TGainedParentArguments; begin if (Assigned(FParent)) then begin LostParentArguments.Signature := ctLostParent; LostParentArguments.Parent := Parent; LostParentArguments.Child := Self; RunCallbacks(LostParentArguments); NotifyParentOfMassChange(-GetMass()); end; FParent := NewParent; if (Assigned(FParent)) then begin NotifyParentOfMassChange(+GetMass()); GainedParentArguments.Signature := ctGainedParent; GainedParentArguments.Parent := Parent; GainedParentArguments.Child := Self; RunCallbacks(GainedParentArguments); end; MarkDirty([dfNeedSave, dfNeedNotifications]); end; function TPhysicalActor.GetParentActor(): TActor; var Candidate: TAbstractTreeNode; begin Candidate := Parent; while (Assigned(Candidate)) do begin if (Candidate is TActor) then begin Result := Candidate as TActor; Exit; end; Candidate := Candidate.Parent; end; Result := nil; end; procedure TPhysicalActor.FacilitiesUpdated(); var Index: Cardinal; begin inherited; if (FFacilitiesHavePhysicalProperties) then Exit; Assert(Length(FFacilities) > 0); for Index := Low(FFacilities) to High(FFacilities) do // $R- begin if (FFacilities[Index].HasPhysicalProperty) then begin FFacilitiesHavePhysicalProperties := True; MarkDirty([dfPhysicalPropertiesChanged]); Exit; end; end; end; procedure TPhysicalActor.MarkDirty(DirtyFlags: TDirtyFlags); begin inherited MarkDirty(DirtyFlags); if ((dfPhysicalPropertiesChanged in DirtyFlags) and (not FPhysicalPropertiesDirty)) then begin FPhysicalPropertiesDirty := True; if (not FIndependent) then begin Assert(FParent is TAbstractActor); TAbstractActor(FParent).MarkDirty([dfPhysicalPropertiesChanged]); end; end; end; procedure TPhysicalActor.ApplyPhysicalProperties(Target: PPhysicalProperties); begin UpdatePhysicalProperties(); FPhysicalProperties.AddTo(Target); Assert(Assigned(Target)); end; procedure TPhysicalActor.UpdatePhysicalProperties(); begin if (FPhysicalPropertiesDirty) then begin FPhysicalProperties.Reset(); AddPhysicalProperties(@FPhysicalProperties); FPhysicalPropertiesDirty := False; end; end; procedure TPhysicalActor.AddPhysicalProperties(Target: PPhysicalProperties); var Facility: TAbstractFacility; Index: Cardinal; begin if (FFacilitiesHavePhysicalProperties and (Length(FFacilities) > 0)) then begin for Index := Low(FFacilities) to High(FFacilities) do // $R- begin Facility := FFacilities[Index]; if (Facility.HasPhysicalProperty()) then Facility.ApplyPhysicalProperties(Target); end; end; end; procedure TPhysicalActor.AdjustDescendantMass(Delta: TGravitationalSystemValue); begin FCachedDescendantMass := FCachedDescendantMass + Delta; NotifyParentOfMassChange(Delta); end; procedure TPhysicalActor.AdjustSelfMass(Delta: TGravitationalSystemValue); begin FSelfMass := FSelfMass + Delta; NotifyParentOfMassChange(Delta); end; procedure TPhysicalActor.NotifyParentOfMassChange(Delta: TGravitationalSystemValue); var Ancestor, Penultimate: TAbstractTreeNode; begin if (Assigned(FParent) and FindAncestor(TPhysicalActor, Ancestor, Penultimate)) then (Ancestor as TPhysicalActor).AdjustDescendantMass(Delta); end; function TPhysicalActor.GetMass(): TGravitationalSystemValue; begin Result := FSelfMass + FCachedDescendantMass; end; function AlignToPtr(P: Pointer): Pointer; inline; begin {$IFDEF FPC_REQUIRES_PROPER_ALIGNMENT} Result := Align(P,SizeOf(P)); {$ELSE FPC_REQUIRES_PROPER_ALIGNMENT} Result := P; {$ENDIF FPC_REQUIRES_PROPER_ALIGNMENT} end; function GetCallbackTypeFromMethod(const CallbackMethod: TActorCallbackMethod): TActorCallbackType; var Signature: PTypeData; ArgumentsTypeInfo, CallbackTypeTypeInfo: PTypeInfo; ArgumentsTypeData, CallbackTypeTypeData: PTypeData; ManagedField: ^TManagedField; P: Pointer; begin {$IFOPT C+} AssertMethodRegistered(@CallbackMethod); {$ENDIF} Assert(TObject(TMethod(CallbackMethod).Data).MethodName(TMethod(CallbackMethod).Code) <> ''); Assert(GetTypeInfo(@CallbackMethod)^.Kind = tkMethod); Signature := GetTypeData(GetTypeInfo(@CallbackMethod)); Assert(Signature^.MethodKind = mkProcedure); Assert(Signature^.ParamCount = 1); Assert(TParamFlags(Pointer(@Signature^.ParamList)^) = [pfVar]); P := AlignToPtr(Pointer(@Signature^.ParamList)+SizeOf(TParamFlags)); // skip past parameter flags P := AlignToPtr(P+Length(PShortString(P)^)+1); // skip past parameter name P := AlignToPtr(P+Length(PShortString(P)^)+1); // skip past parameter type name Assert(TCallConv(P^) = ccReg); P := AlignToPtr(P+SizeOf(TCallConv)); ArgumentsTypeInfo := PPTypeInfo(P)^; Assert(ArgumentsTypeInfo^.Kind = tkRecord); ArgumentsTypeData := GetTypeData(ArgumentsTypeInfo); Assert(ArgumentsTypeData^.RecSize >= SizeOf(TActorCallbackType)); Assert(ArgumentsTypeData^.TotalFieldCount >= 1); ManagedField := AlignToPtr(Pointer(@ArgumentsTypeData^.TotalFieldCount) + SizeOf(ArgumentsTypeData^.TotalFieldCount)); Assert(ManagedField^.FldOffset = 0); CallbackTypeTypeInfo := ManagedField^.TypeRef; Assert(CallbackTypeTypeInfo^.Kind = tkEnumeration); CallbackTypeTypeData := GetTypeData(CallbackTypeTypeInfo); Assert(CallbackTypeTypeData^.OrdType = otULong); Assert(CallbackTypeTypeData^.BaseType = TypeInfo(TActorCallbackType)); Assert(CallbackTypeTypeData^.MinValue = CallbackTypeTypeData^.MaxValue); Result := TActorCallbackType(CallbackTypeTypeData^.MinValue); end; procedure TPhysicalActor.RegisterCallback(const CallbackMethod: TActorCallbackMethod); var Entry: PCallbackList; CallbackType: TActorCallbackType; begin CallbackType := GetCallbackTypeFromMethod(CallbackMethod); New(Entry); Entry^.Callback := CallbackMethod; if (not Assigned(FCallbacks)) then begin FCallbacks := TActorCallbackListHashTable.Create(2); Entry^.Next := nil; end else begin Entry^.Next := FCallbacks[CallbackType]; end; FCallbacks[CallbackType] := Entry; end; procedure TPhysicalActor.UnregisterCallback(const CallbackMethod: TActorCallbackMethod); var Entry: PCallbackList; LastEntry: PCallbackList; CallbackType: TActorCallbackType; begin CallbackType := GetCallbackTypeFromMethod(CallbackMethod); Assert(Assigned(FCallbacks)); LastEntry := nil; Entry := FCallbacks[CallbackType]; Assert(Assigned(Entry)); while (Entry^.Callback <> CallbackMethod) do begin LastEntry := Entry; Entry := Entry^.Next; Assert(Assigned(Entry)); end; if (Assigned(LastEntry)) then begin // just splice this entry out LastEntry^.Next := Entry^.Next; end else if (Assigned(Entry^.Next)) then begin // update hash table to point to next entry FCallbacks[CallbackType] := Entry^.Next; end else begin // remove entry from hash table FCallbacks.Remove(CallbackType); end; Dispose(Entry); end; procedure TPhysicalActor.RunCallbacks(var CallbackData); var Entry: PCallbackList; begin if (Assigned(FCallbacks)) then begin Assert(TActorCallbackType(CallbackData) in [Low(TActorCallbackType)..High(TActorCallbackType)]); Entry := FCallbacks[TActorCallbackType(CallbackData)]; while (Assigned(Entry)) do begin Entry^.Callback(CallbackData); Entry := Entry^.Next; end; end; end; procedure TPhysicalActor.Crash(Victim: TChildActor; Location: TAbstractLocation); begin Victim.Crashed(Self, Location); AdjustSelfMass(Victim.Mass); Victim.Parent.RemoveChild(Victim); Game.Kill(Victim); MarkDirty([dfNeedSave, dfNeedNotifications]); end; constructor TChildActor.Create(AName, AnImage: UTF8String; AnIndependent: Boolean); begin inherited Create(AName, AnIndependent); FImage := AnImage; end; constructor TChildActor.Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); begin inherited; Assert(Settings is TChildActorSettings); FImage := (Settings as TChildActorSettings).Image; FIndependent := (Settings as TChildActorSettings).Independent; end; constructor TChildActor.Read(Stream: TReadStream); begin inherited; FImage := Stream.ReadString(); end; procedure TChildActor.Write(Stream: TWriteStream); begin inherited; Stream.WriteString(FImage); end; class function TChildActor.CreateSettings(): TAutoStorable; begin Result := TChildActorSettings.Create(); end; class function TChildActor.ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; begin Result := inherited; if (Assigned(Result)) then begin Assert(ErrorMessage = ''); if (Index >= Length(Tokens)) then begin ErrorMessage := 'Missing image URL setting'; end else if (Tokens[Index].TokenType <> ttString) then begin ErrorMessage := 'Image URL setting value must be a string'; end else begin Assert(Result is TChildActorSettings); (Result as TChildActorSettings).Image := Tokens[Index].StringValue^; Inc(Index); end; if (ErrorMessage = '') then begin if (Index >= Length(Tokens)) then begin ErrorMessage := 'Missing environment setting'; end else if (Tokens[Index].TokenType <> ttString) then begin ErrorMessage := 'Environment setting value must be a string'; end else begin Assert(Result is TChildActorSettings); (Result as TChildActorSettings).Environment := Tokens[Index].StringValue^; Inc(Index); end; end; if (ErrorMessage <> '') then begin Result.Free(); Result := nil; end; end else Assert(ErrorMessage <> ''); end; class function TChildActor.GetImage(Settings: TAutoStorable): UTF8String; begin Assert(Assigned(Settings), 'Unexpectedly nil Settings; ClassName=' + ClassName); Assert(Settings is TChildActorSettings); Result := (Settings as TChildActorSettings).Image; end; class function TChildActor.GetEnvironment(Settings: TAutoStorable): UTF8String; begin Assert(Assigned(Settings), 'Unexpectedly nil Settings; ClassName=' + ClassName); Assert(Settings is TChildActorSettings); Result := (Settings as TChildActorSettings).Environment; end; function TChildActor.GetPhysicalProperties(): PPhysicalProperties; begin Result := @FPhysicalProperties; end; function TChildActor.GetRendererClass(): UTF8String; begin Result := 'child'; end; procedure TChildActor.Crashed(CrashSite: TPhysicalActor; Location: TAbstractLocation); begin Writeln('Lost ', FName, ' at ', CrashSite.Name); end; constructor TMassiveActor.Create(AName, AnImage: UTF8String; AnIndependent: Boolean; ARadius, ADensity: TGravitationalSystemValue); begin inherited Create(AName, AnImage, AnIndependent); FRadius := ARadius; SetDensity(ADensity); end; constructor TMassiveActor.Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); begin inherited; Assert(Settings is TMassiveActorSettings); FRadius := (Settings as TMassiveActorSettings).Radius; SetDensity((Settings as TMassiveActorSettings).Density); Assert(GetMass > 0, 'Massless particles cannot use TMassiveActor'); end; constructor TMassiveActor.Read(Stream: TReadStream); begin inherited; FRadius := Stream.ReadDouble(); end; procedure TMassiveActor.Write(Stream: TWriteStream); begin inherited; Stream.WriteDouble(FRadius); end; class function TMassiveActor.CreateSettings(): TAutoStorable; begin Result := TMassiveActorSettings.Create(); end; class function TMassiveActor.ParseSettings(Tokens: TTokenArray; var Index: Cardinal; var ErrorMessage: TErrorString): TAutoStorable; // XXX mostly duplicate code function GetDim(SettingName: UTF8String): Integer; begin Result := 0; if (Index >= Length(Tokens)) then begin ErrorMessage := 'Missing ' + SettingName + ' setting'; end else if (Tokens[Index].TokenType <> ttInteger) then begin ErrorMessage := 'Non-numeric ' + SettingName + ' setting'; end else begin Result := Tokens[Index].IntegerValue; Inc(Index); end; end; // XXX mostly duplicate code begin Result := inherited; if (Assigned(Result)) then begin Assert(ErrorMessage = ''); Assert(Result is TMassiveActorSettings); (Result as TMassiveActorSettings).Radius := GetDim('radius (meters)'); if (ErrorMessage = '') then (Result as TMassiveActorSettings).Density := GetDim('density (kg/m^3)'); if (ErrorMessage <> '') then begin Result.Free(); Result := nil; end; end else Assert(ErrorMessage <> ''); end; procedure TMassiveActor.SetDensity(ADensity: TGravitationalSystemValue); const kFourThirds = 4.0 / 3.0; begin Assert(FSelfMass = 0.0); AdjustSelfMass(kFourThirds * Pi * FRadius * FRadius * FRadius * ADensity); // XXX I guess this could overflow... end; function TMassiveActor.GetRadius(): TGravitationalSystemValue; begin Result := FRadius; end; constructor TOwnableActor.Create(AName, AnImage: UTF8String; AnIndependent: Boolean; ARadius, ADensity: TGravitationalSystemValue; Dynasty: TAbstractDynasty); begin inherited Create(AName, AnImage, AnIndependent, ARadius, ADensity); FCurrentDynasty := Dynasty; Init(); end; constructor TOwnableActor.Create(Dynasty: TAbstractDynasty; Settings: TAutoStorable); begin inherited; FCurrentDynasty := Dynasty; Init(); end; destructor TOwnableActor.Destroy(); begin if (Assigned(FCurrentDynasty)) then FCurrentDynasty.Divorce(Self); inherited; end; constructor TOwnableActor.Read(Stream: TReadStream); begin inherited; Stream.ReadReference(@Pointer(FCurrentDynasty)); Stream.AddFinalFixer(@Init); end; procedure TOwnableActor.Write(Stream: TWriteStream); begin inherited; Stream.WriteReference(FCurrentDynasty); end; procedure TOwnableActor.Init(); begin if (Assigned(FCurrentDynasty)) then FCurrentDynasty.Adopt(Self); end; procedure TOwnableActor.Crashed(CrashSite: TPhysicalActor; Location: TAbstractLocation); begin inherited; // XXX report to dynasty that we were lost // "On Tuesday at 23:44 UTC, contact was lost with a Frog Warrior ship at ." end; constructor TNewsActor.Create(AName, AKind, ABody: UTF8String); begin inherited Create(AName); FKind := AKind; FBody := ABody; end; constructor TNewsActor.Read(Stream: TReadStream); begin inherited; FKind := Stream.ReadString(); FBody := Stream.ReadString(); end; procedure TNewsActor.Write(Stream: TWriteStream); begin inherited; Stream.WriteString(FKind); Stream.WriteString(FBody); end; function TNewsActor.GetParent(): TAbstractTreeNode; begin Result := nil; end; procedure TNewsActor.SetParent(const NewParent: TAbstractTreeNode); begin Assert(not Assigned(NewParent), ClassName + ' actors cannot have parents'); end; function TNewsActor.GetRendererClass(): UTF8String; begin Result := 'news'; end; initialization ActorClasses := TActorClassesHashTable.Create(@UTF8StringHash32); {$INCLUDE registrations/actors.inc} finalization ActorClasses.Free(); end.