|
Proteus 5.0
Source Code Release
unit pb50;
(*
Proteus Engine v5.0, Copyright 2003,2004 Artificial Ingenuity, LLC. All
Rights Reserved.
We are pleased to provide free licensure for educational and personal
use. Please keep us informed of the uses you find for the Proteus
Engine, and feel free to forward any enhancement requests.
This software and documentation is being provided to you, the LICENSEE, by
Artificial Ingenuity under the following license. By obtaining, using
and/or copying this software and database, you agree that you have
read, understood, and will comply with these terms and conditions.:
Permission to use, copy, and distribute this software and
documentation for any NON COMMERCIAL purpose and without fee or royalty
is hereby granted, provided that you agree to comply with the following
copyright notice and statements, including the disclaimer, and that the
same appear on ALL copies of the software, database and documentation,
including modifications that you make for internal use or for
distribution.
Proteus Engine v5.0, Copyright 2003,2004 Artificial Ingenuity, LLC. All
Rights Reserved.
LICENSE FOR USE OF THIS SOFTWARE AND DOCUMENTATION IS FOR
EDUCATIONAL AND PERSONAL USE ONLY. ANY "FOR PROFIT"
VENTURE OR ACTIVITY REQUIRES A COMMERCIAL LICENSE AND MUST
BE NEGOTIATED DIRECTLY WITH ARTIFICIAL INGENUITY.
THIS SOFTWARE AND DATABASE IS PROVIDED "AS IS" AND ARTIFICIAL
INGENUITY MAKES NO REPRESENTATIONS OR WARRANTIES, EXPRESS OR
IMPLIED. BY WAY OF EXAMPLE, BUT NOT LIMITATION, ARTIFICIAL
INGENUITY MAKES NO REPRESENTATIONS OR WARRANTIES OF MERCHANT-
ABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR THAT THE USE
OF THE LICENSED SOFTWARE, DATABASE OR DOCUMENTATION WILL NOT
INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR
OTHER RIGHTS.
Title to copyright in this software, database and
any associated documentation shall at all times remain with
Artificial Ingenuity and LICENSEE agrees to preserve same.
for any questions, please contact:
info@ArtificialIngenuity.com
Artificial Ingenuity, LLC
PMB#129
20701 N. Scottsdale Rd., Ste 107
Scottsdale, AZ 85255-6499
USA
(480) 539-4917
*)
interface
uses
Classes, Contnrs, ExtCtrls;
type
BrainClass = Class; //forward class declaration
PatternClass = Class; //ditto
KnowledgeClass = class; //ditto ditto
StepPatternClass = class; //ditto ditto ditto
ThresholdClass = class;
StateClass = class;
FragmentRelations = (fr_NoRelation, fr_AND, fr_OR, fr_NOT, fr_CUSTOM, fr_DataMatch, fr_External, fr_StateMatch, fr_InCollection,
fr_Volition, fr_OutMatch, fr_CUSTOMSub, fr_InCollectionSub, fr_Initialization, fr_Finalization); //what does this fragment mean if it exists
WordFragmentClass = class (TObject) //fragments that you match to
MyName : string;
WordFrag: string;
Relation: FragmentRelations;
Bonus,
Penalty : integer; //for custom and datamatch
TheName : string; //for data match, gives variable name
TheValue: string; //the value for datamatch
MyOwner : TObject; //owning patternclass
public
constructor Create;
function FindMyBrain: BrainClass;
function MyValueIs(InStr: string): integer;
function FindMyPattern: PatternClass;
function FindMyStepPattern: StepPatternClass;
end;
ResponseTypes = (rt_None, rt_justText, rt_ModeChange, rt_Nester, rt_Assignment, rt_Action, rt_resetHits, rt_StateChange, rt_resetState,
rt_TaskList, rt_resetKMhits, rt_resetBhits, rt_AddToCollection, rt_OutOfCollection, rt_SubmitThis, rt_LogThis,
rt_StartProc, rt_GotoStep, rt_HaltProc, rt_OpenMind, rt_CallProc, rt_ProcReturn, rt_SelfModify, rt_LoadCollection,
rt_SaveCollection, rt_ClearCollection, rt_ParseToCollection, rt_DeleteObject, rt_MakeCode, rt_MergeCollection,
rt_DoResponseFor, rt_WordsToCollection, rt_AutoPattern, rt_AddResponse, rt_AddFragment); //what do you do if this response is selected
TaskClass = class(TObject)
MyName : string;
ResponseType: ResponseTypes;
OutText : string; //the text to display
TheName : string; //the name of the mode, fact, state, or action
TheValue : string; //the new fact, new mode, or parameters for external action
MyOwner : TObject; //owning ResponseClass object
public
constructor Create;
end;
ResponseClass = class(TObject) //how to respond to a matched clause
MyName : string;
ResponseType: ResponseTypes;
OutText : string; //the text to display
TheName : string; //the name of the mode, fact, state, or action
TheValue : string; //the new fact, new mode, or parameters for external action
Knowledge : TObject; //nested knowledge
Tasks : TObjectList; //collection of TaskClass objects
MyOwner : TObject; //owning patternclass or threshold class or state class
public
constructor Create;
destructor Destroy; override;
function FindMyBrain: BrainClass;
function FindMyPattern: PatternClass;
function FindMyStepPattern: StepPatternClass;
function FindMyKnowMode: KnowledgeClass;
function FindMyThreshold: ThresholdClass;
function FindMyState: StateClass;
procedure DoMyTasks(InStr: string);
procedure AddTask(Task: TaskClass);
function ResolveFactsInto(TheStr: string; InStr: string): string; //replaces fact tokens with facts
procedure ResolveToStringAndDo(InStr: string); //this invokes appropriate action based upon type and returns string
end;
ThresholdClass = class(TObject) //special case behavior based upon clause selection frequency
MyName : string;
ThreshFrom, //threshold true range
ThreshTo : integer;
Responses : TObjectList; //ResponseClass collection
MyOwner : TObject; //owning patternclass
public
constructor Create;
destructor Destroy; override;
procedure SetLevels(TFrom,TTo: integer);
procedure AddResponse(response: ResponseClass);
end;
StateClass = class (TObject)
MyName : string;
State : string;
Responses: TObjectList; //ResponseClass collection to use if in this state
MyOwner : TObject; //owning PatternClass
public
constructor Create;
destructor Destroy; override;
procedure SetState(StateName: string);
procedure AddResponse(response: ResponseClass);
end;
PatternClass = class(TObject) //The clauses
MyName : string;
WordFragments: TObjectList; //the fragments to match input to (WordFragmentClass)
Responses : TObjectList; //the default responses if clause is selected (ResponseClass)
Thresholds : TObjectList; //the threshold behaviors (ThresholdClass)
States : TObjectList; //the altered state behaviors (StateClass)
HitCount : integer; //how often I have been selected
MyOwner : TObject; //owning knowledge class
HasVolition : boolean;
VolitionWhen : double;
LastVolition : double;
HasInit : boolean;
HasFinal : boolean;
public
constructor Create;
destructor Destroy; override;
function FindMyBrain: BrainClass;
procedure AddFragment(WordFrag: WordFragmentClass);
procedure AddResponse(response: ResponseClass);
procedure AddThreshold(Threshold: ThresholdClass);
procedure AddState(State: StateClass);
function MatchValue(InStr: string): integer;
procedure PickResponseAndDo(InStr: string); //invokes full scan of thresholds and evaluates down to response and/or actions
function GetResponseList(InStr: string; var ROwner: TObject): TObjectList;
procedure ShowVolition;
procedure ResetVCounter;
function RemoveFragmentsFrom(InStr: string): string;
procedure DoInitializes;
procedure DoFinalizes;
end;
KnowledgeClass = class(Tobject) //a collection of clauses representing a complex behavior
MyName : string;
MyMode : string;
Patterns : TObjectList;
MyOwner : TObject; //owning brainclass or responseclass
HasVolition: boolean;
public
constructor Create;
destructor Destroy; override;
function FindMyBrain: BrainClass;
procedure AddPattern(Pattern: PatternClass);
procedure RespondTo(InStr: string);
procedure ResetMyHits;
function GetPatternFor(InStr: string): PatternClass;
procedure ShowVolition;
procedure ResetVCounters;
procedure DoInitializes;
procedure DoFinalizes;
end;
DataCollectionClass = class (Tobject)
MyName : string;
TheName : string;
TheData : TStringList;
MyOwner : TObject;
LastMember : string;
LastMWhen : TDateTime; //These 4 fields are used to cache the member function
LastMemberS: string; //This means only searching for a member once per fragment eval.
LastMSWhen : TDateTime;
public
constructor Create;
destructor Destroy; override;
function IsMember(InStr: string): boolean;
function IsMemberSub(InStr: string): boolean;
function TheMemberIs(InStr: string): string;
function TheMemberIsSub(InStr: string): string;
function TheMemberList(InStr: string): string;
function PickMember(InStr: string): string;
procedure AddData(TheStr: string);
procedure DelData(TheStr: string);
procedure LoadCollection(FileName: string);
procedure SaveCollection(FileName: string);
procedure ClearCollection;
end;
StepPatternClass = class(TObject)
MyName : string;
WordFragments: TObjectList; //the fragments to match input to (WordFragmentClass)
Responses : TObjectList; //the default responses if clause is selected (ResponseClass)
MyOwner : TObject;
public
constructor Create;
destructor Destroy; override;
procedure AddFragment(Fragment: WordFragmentClass);
procedure AddResponse(Response: ResponseClass);
function MatchValue(InStr: string): integer;
procedure PickResponseAndDo(InStr: string);
function FindMyBrain: BrainClass;
function RemoveFragmentsFrom(InStr: string): string;
end;
StepClass = class(TObject)
MyName : string;
TheName : string;
ThePrompt : string;
StepPatterns : TObjectList;
MyOwner : TObject;
public
constructor Create;
destructor Destroy; override;
procedure AddStepPattern(StepPattern: StepPatternClass);
function FindMyBrain: BrainClass;
procedure PickResponseAndDo(InStr: string);
end;
ProcClass = class(TObject)
MyName : string;
TheName : string;
CurrentStep: string;
StartStep : string;
Steps : TObjectList; //list of steps
StepList : TStringList;
MyOwner : TObject;
public
constructor Create;
destructor Destroy; override;
procedure ProcessInput(InStr: string);
procedure BeginProc;
procedure AddStep(StepName: string; Step: StepClass);
function FindMyBrain: BrainClass;
function CurrentPrompt: string;
end;
PBrainOutputEvent = procedure (var Output: string);
BrainClass = class(TObject) //the actual AI object containing the complex behaviors for each mode (or mood), and known facts
MyName : string;
CurrentMode : integer; //The current mode index
CurrentState : integer; //The current state index
CurrentProc : integer; //The current procedure index
Procs : TStringList;
TheProcs : TObjectList;
Modes : TStringList; //List of mode names
KnowledgeModes : TObjectList; //List of knowledge structures for each mode
FactNames : TStringList; //List of fact names
Facts : TStringList; //List of facts
States : TStringList; //List of State names
MyCallBack : PBrainOutputEvent; //gets called when the brain wants to say something DO NOT CALL DIRECTLY!
DataColNames : TStringList; //names of the data collections 9/3/03 AND objects!
HasVolition : boolean;
LastInput : TDateTime;
VolitionTimer : TTimer;
ShowBlankOutput: boolean;
NamedObjects : TStringList;
LastPat : string;
LastSPat : string;
LastFrag : string;
LastResp : string;
LastTask : string;
LastKnow : string;
private
TmpSource : TStrings;
TmpSourceIdx : integer;
ProcStack : TStringList;
StepStack : TStringList;
InputStack : TStringList;
OutputStack : TStringList;
ImmedResponse : TStringList;
procedure SendOutput(OutStr: string);
procedure PushProc;
procedure PopProc;
procedure OnVTimer(Sender: TObject);
public
constructor Create(CallBack: PBrainOutputEvent);
destructor Destroy; override;
procedure AddKnowledgeMode(ModeName: string; KnowMode: KnowledgeClass);
procedure AddFact(FactName, Fact: string);
procedure AddState(StateName: string);
procedure AddDataCollection(Name: string; DataCollection: DataCollectionClass);
procedure AddProc(ProcName: string; NewProc: ProcClass);
procedure SwitchModeTo(ModeName: string);
function GetCurrentMode: string;
procedure SwitchStateTo(StateName: string);
function GetCurrentState: string;
procedure ClearState; //reset to no current state
procedure ActivateProc(ProcName: string);
procedure GotoProcStep(StepName: string);
procedure HaltProc;
function GetFact(FactName: string): string;
function GetSysFact(FactName: string): string;
procedure AddMember(CollectionName: string; Value: string);
function GetMember(CollectionName: string; InStr: string): string;
function GetMemberSub(CollectionName: string; InStr: string): string;
procedure RemoveMember(CollectionName: string; Value: string);
function GetMemberList(CollectionName: string; InStr: string): string; //returns full list of members separated by commas
function PickMember(CollectionName: string; InStr: string): string; //randomly picks from list of members
function ResolveFactsFor(TheStr: string; InStr: string; Pattern: PatternClass; StepPattern: StepPatternClass): string; //inserts any facts referenced in string
function IsInDataCollection(CollectionName: string; InStr: string): boolean; //is work in data collection in InStr?
function IsInDataCollectionSub(CollectionName: string; InStr: string): boolean; //is work in data collection in InStr?
procedure RequestResponseFor(InStr: string); //drills down to appropriate kenowledge class call
function ReturnResponseFor(InStr: string): string; //immediately returns response if no callback defined
procedure ResetAllHits;
function GetMatchingPatternFor(InStr: string): PatternClass;
procedure Wakeup;
procedure Sleep;
procedure LogThis(FileSpec: string; TheStr: string);
procedure ModifyNamedObject(Name, Field, NewValue: string);
procedure LoadCollection(Name, FileName: string);
procedure SaveCollection(Name, FileName: string);
procedure ClearCollection(Name: string);
procedure ParseToCollection(SourceCollection, DestCollection, InStr: string);
procedure DoInitializes;
procedure DoFinalizes;
procedure MergeCollections(SourceCollection, DestCollection: string);
procedure WordsToCollection(InStr, DestCollection: string);
procedure MakeCodeFrom(SourceCollection: string);
procedure DeleteObject(ObjName: string);
procedure DoResponseFor(ObjName: string);
procedure AddToInputStack(InStr: string);
procedure AddToOutputStack(OutStr: string);
function FromInputStack(num: string): string;
function FromOutputStack(num: string): string;
function GenerateAutoName: string;
procedure CreateAutoPattern(InStr, Bonus, Response: string);
procedure AddOnResponse(Response: string);
procedure AddOnFragment(Fragment, Bonus: string);
end;
const
InOutStackSize = 100;
StartFactToken = '^Fact{';
EndFactToken = '}';
StartSysFactToken = '^SysFact{';
EndSysFactToken = '}';
StateToken = '^State{}';
StartMemberToken = '^Member{';
EndMemberToken = '}';
StartMemberSubToken = '^MemberSub{';
EndMemberSubToken = '}';
StartMemberListToken = '^Members{';
EndMemberListToken = '}';
StartPickMemberToken = '^MemberX{';
EndPickMemberToken = '}';
RemainToken = '^Remain{}';
StartInputToken = '^Input{';
EndInputToken = '}';
StartLastOutToken = '^LastOut{';
EndLastOutToken = '}';
LastPatToken = '^LastPat{}';
LastSPatToken = '^LastSPat{}';
LastFragToken = '^LastFrag{}';
LastRespToken = '^LastResp{}';
LastTaskToken = '^LastTask{}';
LastKnowToken = '^LastKnow{}';
AutoNameToken = '^AutoName{}';
function FragRelationIs(InStr: string): FragmentRelations;
function FragRelationAs(FragRel: FragmentRelations): string;
function RespTypeAs(RespType: ResponseTypes): string;
function RespTypeIs(InStr: string): ResponseTypes;
{------------Support----------------}
function Str2Int(s: string): integer;
function Int2Str(i: integer): string;
function Str2Dbl(s: string; default: double): double;
procedure ParseString(s: string; Strs: TStrings);
implementation
uses
SysUtils, Dialogs, Windows, OpenMindU, ProtLangU, FStr;
function RPos(const Substr: string; const S: string): Integer;
begin
if (S = '') or (Substr = '') then begin
result := 0;
exit;
end;
result := FastPosBackNoCase(S, Substr, Length(S), Length(Substr), 0);
end;
function xPos(const Substr: string; const S: string): Integer;
begin
if (S = '') or (Substr = '') then begin
result := 0;
exit;
end;
result := FastPosNoCase(S, Substr, Length(S), Length(Substr), 1);
end;
function xCopy(const aSourceString : String; aStart, aLength : Integer) : String;
begin
if aLength = 0 then begin
result := '';
exit;
end;
result := CopyStr(aSourceString, aStart, aLength);
end;
function PosFrom(const Substr: string; const S: string; Start: integer): Integer;
begin
if (S = '') or (Substr = '') then begin
result := 0;
exit;
end;
result := FastPosNoCase(S, Substr, Length(S), Length(Substr), Start);
end;
//this procedure breaks s into words and places them in Strs
procedure ParseString(s: string; Strs: TStrings);
var
tmp: string;
begin
if s = '' then exit;
s := uppercase(s);
repeat
tmp := '';
while (length(s) > 0) and (s[1] in ['A'..'Z']) do begin
tmp := tmp + s[1];
delete(s, 1, 1);
end;
if tmp <> '' then
Strs.Add(tmp);
if s <> '' then
delete(s, 1, 1);
until s = '';
end;
//this function is to facilitate a word-match only function rather than the inclusive Pos function
//That way the name "Ted" does not "match" the word "farTED"...
function WordIsIn(word,sentence: string): boolean;
var
done : boolean;
ThePos: integer;
function SpaceFor(c: char): integer;
begin
if c in ['A'..'Z'] then
result := 1
else
result := 0
end;
begin
result := false;
done := false;
word := trim(Uppercase(word));
if length(word) = 0 then exit;
sentence := Uppercase(sentence);
if word = sentence then begin
result := true;
exit;
end;
while not done do begin
ThePos := xPos(word, sentence);
if ThePos = 0 then begin //not there at all, so exit
result := false;
exit;
end;
if ThePos = 1 then begin //at beginning of sentence
if not (sentence[length(word)+SpaceFor(sentence[length(word)])] in ['A'..'Z']) then begin //is a word, so match
result := true;
exit;
end
end
else if ThePos + length(word) > length(sentence) then begin //at end of sentence
if not (sentence[ThePos-SpaceFor(sentence[ThePos])] in ['A'..'Z']) then begin //is a word, so match
result := true;
exit;
end
end
else begin //in middle of sentence
if (not (sentence[ThePos-SpaceFor(sentence[ThePos])] in ['A'..'Z'])) and (not (sentence[ThePos+length(word)+(1-SpaceFor(word[length(word)]))] in ['A'..'Z'])) then begin //not part of other word
result := true;
exit;
end
end;
delete(sentence, ThePos, length(word)); //not a word match, so just get rid of it.
end;
end;
procedure DefaultCallback(var Output: string);
begin
ShowMessage(Output);
end;
{=================WordFragmentClass==================}
constructor WordFragmentClass.Create;
begin
inherited;
Self.MyName := '';
Self.WordFrag := '';
Self.Relation := fr_NoRelation;
Self.Bonus := 0;
Self.Penalty := 0;
Self.TheName := '';
Self.TheValue := '';
Self.MyOwner := nil;
end;
function WordFragmentClass.FindMyPattern: PatternClass;
begin
if Self.MyOwner is PatternClass then
result := Self.MyOwner as PatternClass
else
result := nil;
end;
function WordFragmentClass.FindMyStepPattern: StepPatternClass;
begin
if Self.MyOwner is StepPatternClass then
result := Self.MyOwner as StepPatternClass
else
result := nil;
end;
function WordFragmentClass.FindMyBrain: BrainClass;
begin
if Self.FindMyPattern <> nil then
result := Self.FindMyPattern.FindMyBrain
else if Self.MyOwner is StepPatternClass then
result := (Self.MyOwner as StepPatternClass).FindMyBrain
else
result := nil;
end;
function WordFragmentClass.MyValueIs(InStr: string): integer;
begin
result := 0;
if Self.Relation in [fr_AND, fr_OR, fr_NOT, fr_CUSTOM] then begin
if WordIsIn(UpperCase(Self.FindMyBrain.ResolveFactsFor(Self.WordFrag, InStr, Self.FindMyPattern, Self.FindMyStepPattern)), UpperCase(Self.FindMyBrain.ResolveFactsFor(InStr, InStr, Self.FindMyPattern, Self.FindMyStepPattern))) then begin //if word fragment in InStr then
case Self.Relation of
fr_AND : result := 100;
fr_OR : result := 50;
fr_NOT : result := -100;
fr_CUSTOM : result := Self.Bonus;
else
end; {case}
end
else begin //if word fragment NOT in InStr then
case Self.Relation of
fr_AND : result := -100;
fr_OR : result := 0; //no penalty
fr_NOT : result := 100;
fr_CUSTOM : result := -Self.Penalty;
else
end; {case}
end
end
else if Self.Relation = fr_DataMatch then begin
if UpperCase(Self.FindMyBrain.ResolveFactsFor(Self.TheValue, InStr, Self.FindMyPattern, Self.FindMyStepPattern)) = UpperCase(Self.FindMyBrain.GetFact(Self.TheName)) then //if the variable is set to this, then
result := Self.Bonus //return bonus
else
result := -Self.Penalty; //return penalty
end
else if Self.Relation = fr_External then begin
//need to add this functionality when we figure out what it should do..
end
else if Self.Relation = fr_StateMatch then begin
if UpperCase(Self.FindMyBrain.ResolveFactsFor(Self.TheName, InStr, Self.FindMyPattern, Self.FindMyStepPattern)) = UpperCase(Self.FindMyBrain.GetCurrentState) then //if the current state is this, then
result := Self.Bonus //return bonus
else
result := -Self.Penalty; //return penalty
end
else if Self.Relation = fr_InCollection then begin
if Self.FindMyBrain.IsInDataCollection(Self.TheName, InStr) then
result := Self.Bonus //return bonus
else
result := -Self.Penalty; //return penalty
end
else if Self.Relation = fr_Volition then begin
result := 0; //does not impact whether or not selected based upon normal criteria
end
else if Self.Relation = fr_OutMatch then begin
if WordIsIn(UpperCase(Self.FindMyBrain.ResolveFactsFor(Self.WordFrag, InStr, Self.FindMyPattern, Self.FindMyStepPattern)), UpperCase(Self.FindMyBrain.FromOutputStack(Self.WordFrag))) then //if the last output is this, then
result := Self.Bonus //return bonus
else
result := -Self.Penalty; //return penalty
end
else if Self.Relation = fr_CUSTOMSub then begin
if xPos(UpperCase(Self.FindMyBrain.ResolveFactsFor(Self.WordFrag, InStr, Self.FindMyPattern, Self.FindMyStepPattern)), UpperCase(Self.FindMyBrain.ResolveFactsFor(InStr, InStr, Self.FindMyPattern, Self.FindMyStepPattern))) <> 0 then
result := Self.Bonus
else
result := -Self.Penalty;
end
else if Self.Relation = fr_InCollectionSub then begin
if Self.FindMyBrain.IsInDataCollectionSub(Self.TheName, InStr) then
result := Self.Bonus //return bonus
else
result := -Self.Penalty; //return penalty
end
else if Self.Relation = fr_Initialization then begin
result := 0; //does not impact whether or not selected based upon normal criteria
end
else if Self.Relation = fr_Finalization then begin
result := 0; //does not impact whether or not selected based upon normal criteria
end;
Self.FindMyBrain.LastFrag := Self.MyName;
end;
{=================TaskClass==================}
constructor TaskClass.Create;
begin
inherited;
Self.MyName := '';
Self.ResponseType := rt_None;
Self.OutText := '';
Self.TheName := '';
Self.TheValue := '';
Self.MyOwner := nil;
end;
{=================ResponseClass==================}
constructor ResponseClass.Create;
begin
Inherited;
Self.MyName := '';
Self.Tasks := TObjectList.Create(true);
Self.ResponseType := rt_None;
Self.OutText := '';
Self.TheName := '';
Self.TheValue := '';
Self.Knowledge := nil;
Self.MyOwner := nil;
end;
destructor ResponseClass.Destroy;
begin
Self.Tasks.Free;
inherited;
end;
function ResponseClass.FindMyStepPattern: StepPatternClass;
begin
if Self.MyOwner is StepPatternClass then
result := Self.MyOwner as StepPatternClass
else
result := nil;
end;
function ResponseClass.FindMyPattern: PatternClass; //this needs to change if hierarchy changes
var
myPattern: PatternClass;
begin
if (Self.MyOwner is PatternClass) then
myPattern := Self.MyOwner as PatternClass
else if (Self.MyOwner is StateClass) then
myPattern := (Self.MyOwner as StateClass).MyOwner as PatternClass
else if Self.MyOwner is StepPatternClass then
myPattern := nil
else //ASSUMES that only other possible owner is ThresholdClass!
myPattern := (Self.MyOwner as ThresholdClass).MyOwner as PatternClass;
result := MyPattern;
end;
function ResponseClass.FindMyBrain: BrainClass; //this needs to change if hierarchy changes
begin
if Self.FindMyPattern <> nil then
result := Self.FindMyPattern.FindMyBrain
else
result := Self.FindMyStepPattern.FindMyBrain
end;
function ResponseClass.FindMyKnowMode: KnowledgeClass;
begin
if Self.FindMyPattern <> nil then
result := Self.FindMyPattern.MyOwner as KnowledgeClass
else
result := nil;
end;
function ResponseClass.FindMyThreshold: ThresholdClass;
begin
if Self.MyOwner is ThresholdClass then
result := Self.MyOwner as ThresholdClass
else
result := nil
end;
function ResponseClass.FindMyState: StateClass;
begin
if Self.MyOwner is StateClass then
result := Self.MyOwner as StateClass
else
result := nil
end;
function ResponseClass.ResolveFactsInto(TheStr: string; InStr: string): string; //replaces fact tokens with facts
begin
result := Self.FindMyBrain.ResolveFactsFor(TheStr, InStr, Self.FindMyPattern, Self.FindMyStepPattern);
end;
procedure ResponseClass.DoMyTasks(InStr: string);
var
i : integer;
TheTask: TaskClass;
s : string;
begin
for i := 0 to Self.Tasks.Count - 1 do begin
TheTask := Self.Tasks.Items[i] as TaskClass;
s := Self.ResolveFactsInto(TheTask.OutText, InStr);
case TheTask.ResponseType of
rt_None : ; //NA
rt_justText : (TheTask.MyOwner as ResponseClass).FindMyBrain.SendOutput(s);
rt_ModeChange : (TheTask.MyOwner as ResponseClass).FindMyBrain.SwitchModeTo(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_Nester : ; //NA
rt_Assignment : (TheTask.MyOwner as ResponseClass).FindMyBrain.AddFact(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_Action : WinExec(PChar(TheTask.TheName), SW_SHOWNORMAL); //need to add action when we figure out what it is
rt_resetHits : if (TheTask.MyOwner as ResponseClass).FindMyPattern <> nil then (TheTask.MyOwner as ResponseClass).FindMyPattern.HitCount := 0;
rt_StateChange : (TheTask.MyOwner as ResponseClass).FindMyBrain.SwitchStateTo(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_resetState : (TheTask.MyOwner as ResponseClass).FindMyBrain.ClearState;
rt_TaskList : ; //NA
rt_resetKMhits : if (TheTask.MyOwner as ResponseClass).FindMyKnowMode <> nil then (TheTask.MyOwner as ResponseClass).FindMyKnowMode.ResetMyHits;
rt_resetBhits : (TheTask.MyOwner as ResponseClass).FindMyBrain.ResetAllHits;
rt_AddToCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.AddMember(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_OutOfCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.RemoveMember(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_SubmitThis : (TheTask.MyOwner as ResponseClass).FindMyBrain.RequestResponseFor(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_LogThis : (TheTask.MyOwner as ResponseClass).FindMyBrain.LogThis(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_StartProc : (TheTask.MyOwner as ResponseClass).FindMyBrain.ActivateProc(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_GotoStep : (TheTask.MyOwner as ResponseClass).FindMyBrain.GotoProcStep(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_HaltProc : (TheTask.MyOwner as ResponseClass).FindMyBrain.HaltProc;
rt_OpenMind :begin
s := AskOpenMind(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
(TheTask.MyOwner as ResponseClass).FindMyBrain.SendOutput(s);
end;
rt_CallProc :begin
(TheTask.MyOwner as ResponseClass).FindMyBrain.PushProc;
(TheTask.MyOwner as ResponseClass).FindMyBrain.ActivateProc(Self.ResolveFactsInto(TheTask.TheName, InStr));
end;
rt_ProcReturn : (TheTask.MyOwner as ResponseClass).FindMyBrain.PopProc;
rt_SelfModify : (TheTask.MyOwner as ResponseClass).FindMyBrain.ModifyNamedObject(Self.ResolveFactsInto(TheTask.OutText, InStr), Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_LoadCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.LoadCollection(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_SaveCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.SaveCollection(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_ClearCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.ClearCollection(Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_ParseToCollection: (TheTask.MyOwner as ResponseClass).FindMyBrain.ParseToCollection(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr), Self.ResolveFactsInto(TheTask.OutText, InStr));
rt_DeleteObject : (TheTask.MyOwner as ResponseClass).FindMyBrain.DeleteObject(Self.ResolveFactsInto(TheTask.OutText, InStr));
rt_MakeCode : (TheTask.MyOwner as ResponseClass).FindMyBrain.MakeCodeFrom(Self.ResolveFactsInto(TheTask.OutText, InStr));
rt_MergeCollection : (TheTask.MyOwner as ResponseClass).FindMyBrain.MergeCollections(Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_DoResponseFor : (TheTask.MyOwner as ResponseClass).FindMyBrain.DoResponseFor(Self.ResolveFactsInto(TheTask.OutText, InStr));
rt_WordsToCollection: (TheTask.MyOwner as ResponseClass).FindMyBrain.WordsToCollection(Self.ResolveFactsInto(TheTask.OutText, InStr), Self.ResolveFactsInto(TheTask.TheName, InStr));
rt_AutoPattern : (TheTask.MyOwner as ResponseClass).FindMyBrain.CreateAutoPattern(Self.ResolveFactsInto(TheTask.OutText, InStr), Self.ResolveFactsInto(TheTask.TheName, InStr), Self.ResolveFactsInto(TheTask.TheValue, InStr));
rt_AddResponse : (TheTask.MyOwner as ResponseClass).FindMyBrain.AddOnResponse(Self.ResolveFactsInto(TheTask.OutText, InStr));
rt_AddFragment : (TheTask.MyOwner as ResponseClass).FindMyBrain.AddOnFragment(Self.ResolveFactsInto(TheTask.OutText, InStr), Self.ResolveFactsInto(TheTask.TheName, InStr));
else
end; {case}
Self.FindMyBrain.LastTask := TheTask.MyName;
end
end;
procedure ResponseClass.AddTask(Task: TaskClass);
begin
Task.MyOwner := Self;
Self.Tasks.Add(Task);
Self.FindMyBrain.LastTask := Task.MyName;
if Task.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Task.MyName, Task);
end;
procedure ResponseClass.ResolveToStringAndDo(InStr: string); //this invokes appropriate action based upon type and returns string
var
result: string;
begin
if not (Self.ResponseType in [rt_SelfModify, rt_ParseToCollection, rt_WordsToCollection, rt_AutoPattern, rt_AddResponse, rt_AddFragment]) then //no output if self-modify or ParseToCollection
result := Self.ResolveFactsInto(Self.OutText, InStr)
else
result := '';
case Self.ResponseType of
rt_None : result := '';
rt_justText : ; //don't need to do anything
rt_ModeChange : Self.FindMyBrain.SwitchModeTo(Self.ResolveFactsInto(Self.TheName, InStr));
rt_Nester : (Self.Knowledge as KnowledgeClass).RespondTo(InStr);
rt_Assignment : Self.FindMyBrain.AddFact(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_Action : WinExec(PChar(Self.TheName), SW_SHOWNORMAL); //need to add action when we figure out what it is
rt_resetHits : if Self.FindMyPattern <> nil then Self.FindMyPattern.HitCount := 0;
rt_StateChange : Self.FindMyBrain.SwitchStateTo(Self.ResolveFactsInto(Self.TheName, InStr));
rt_resetState : Self.FindMyBrain.ClearState;
rt_TaskList : Self.DoMyTasks(InStr);
rt_resetKMhits : if Self.FindMyKnowMode <> nil then Self.FindMyKnowMode.ResetMyHits;
rt_resetBhits : Self.FindMyBrain.ResetAllHits;
rt_AddToCollection : Self.FindMyBrain.AddMember(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_OutOfCollection : Self.FindMyBrain.RemoveMember(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_SubmitThis : Self.FindMyBrain.RequestResponseFor(Self.ResolveFactsInto(Self.TheName, InStr));
rt_LogThis : Self.FindMyBrain.LogThis(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_StartProc : Self.FindMyBrain.ActivateProc(Self.ResolveFactsInto(Self.TheName, InStr));
rt_GotoStep : Self.FindMyBrain.GotoProcStep(Self.ResolveFactsInto(Self.TheName, InStr));
rt_HaltProc : Self.FindMyBrain.HaltProc;
rt_OpenMind : result := AskOpenMind(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_CallProc :begin
Self.FindMyBrain.PushProc;
Self.FindMyBrain.ActivateProc(Self.ResolveFactsInto(Self.TheName, InStr));
end;
rt_ProcReturn : Self.FindMyBrain.PopProc;
rt_SelfModify : Self.FindMyBrain.ModifyNamedObject(Self.ResolveFactsInto(Self.OutText, InStr), Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_LoadCollection : Self.FindMyBrain.LoadCollection(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_SaveCollection : Self.FindMyBrain.SaveCollection(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_ClearCollection : Self.FindMyBrain.ClearCollection(Self.ResolveFactsInto(Self.TheName, InStr));
rt_ParseToCollection: Self.FindMyBrain.ParseToCollection(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr), Self.ResolveFactsInto(Self.OutText, InStr));
rt_DeleteObject : Self.FindMyBrain.DeleteObject(Self.ResolveFactsInto(Self.OutText, InStr));
rt_MakeCode : Self.FindMyBrain.MakeCodeFrom(Self.ResolveFactsInto(Self.OutText, InStr));
rt_MergeCollection : Self.FindMyBrain.MergeCollections(Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_DoResponseFor : Self.FindMyBrain.DoResponseFor(Self.ResolveFactsInto(Self.OutText, InStr));
rt_WordsToCollection: Self.FindMyBrain.WordsToCollection(Self.ResolveFactsInto(Self.OutText, InStr), Self.ResolveFactsInto(Self.TheName, InStr));
rt_AutoPattern : Self.FindMyBrain.CreateAutoPattern(Self.ResolveFactsInto(Self.OutText, InStr), Self.ResolveFactsInto(Self.TheName, InStr), Self.ResolveFactsInto(Self.TheValue, InStr));
rt_AddResponse : Self.FindMyBrain.AddOnResponse(Self.ResolveFactsInto(Self.OutText, InStr));
rt_AddFragment : Self.FindMyBrain.AddOnFragment(Self.ResolveFactsInto(Self.OutText, InStr), Self.ResolveFactsInto(Self.TheName, InStr));
else {case}
result := 'UNKNOWN RESPONSE TYPE! [ResponseClass.ResolveToString]';
end; {case}
Self.FindMyBrain.SendOutput(result);
Self.FindMyBrain.LastResp := Self.MyName;
end;
{=================ThresholdClass==================}
constructor ThresholdClass.Create;
begin
inherited;
Self.MyName := '';
Self.Responses := TObjectList.Create(true);
Self.ThreshFrom := 0;
Self.ThreshTo := 0;
Self.MyOwner := nil;
end;
destructor ThresholdClass.Destroy;
begin
Self.Responses.Free;
inherited;
end;
procedure ThresholdClass.SetLevels(TFrom,TTo: integer);
begin
Self.ThreshFrom := TFrom;
Self.ThreshTo := TTo;
end;
procedure ThresholdClass.AddResponse(response: ResponseClass);
begin
response.MyOwner := Self;
Self.Responses.Add(response);
if response.MyName <> '' then
response.FindMyBrain.NamedObjects.AddObject(response.MyName, response);
end;
{=================StateClass==================}
constructor StateClass.Create;
begin
inherited;
Self.MyName := '';
Self.Responses := TObjectList.Create(true);
Self.State := '';
Self.MyOwner := nil;
end;
destructor StateClass.Destroy;
begin
Self.Responses.Free;
inherited;
end;
procedure StateClass.SetState(StateName: string);
begin
Self.State := StateName;
end;
procedure StateClass.AddResponse(response: ResponseClass);
begin
response.MyOwner := Self;
Self.Responses.Add(response);
if response.MyName <> '' then
response.FindMyBrain.NamedObjects.AddObject(response.MyName, response);
end;
{=================PatternClass==================}
constructor PatternClass.Create;
begin
inherited;
Self.MyName := '';
Self.WordFragments := TObjectList.Create(true);
Self.Responses := TObjectList.Create(true);
Self.Thresholds := TObjectList.Create(true);
Self.States := TObjectList.Create(true);
Self.HitCount := 0;
Self.MyOwner := nil;
Self.HasVolition := false;
Self.VolitionWhen := 0.0;
Self.LastVolition := 0.0;
Self.HasInit := false;
Self.HasFinal := false;
end;
destructor PatternClass.Destroy;
begin
Self.States.Free;
Self.Thresholds.Free;
Self.Responses.Free;
Self.WordFragments.Free;
inherited;
end;
function PatternClass.FindMyBrain: BrainClass;
var
myBrain: BrainClass;
begin
if (Self.MyOwner as KnowledgeClass).MyOwner is BrainClass then
myBrain := (Self.MyOwner as KnowledgeClass).MyOwner as BrainClass
else //ASSUMES that if KnowledgeClass is not owned by BrainClass is must belong to a ResponseClass with nesting
myBrain := ((Self.MyOwner as KnowledgeClass).MyOwner as ResponseClass).FindMyBrain; //find owning response's brain
result := myBrain;
end;
procedure PatternClass.AddFragment(WordFrag: WordFragmentClass);
begin
WordFrag.MyOwner := Self;
Self.WordFragments.Add(WordFrag);
Self.HasInit := Self.HasInit or (WordFrag.Relation = fr_Initialization);
Self.HasFinal := Self.HasFinal or (WordFrag.Relation = fr_Finalization);
Self.HasVolition := Self.HasVolition or (WordFrag.Relation = fr_Volition);
if WordFrag.Relation = fr_Volition then begin
if Self.MyOwner <> nil then begin
Self.FindMyBrain.HasVolition := true;
(Self.MyOwner as KnowledgeClass).HasVolition := true;
end;
try
Self.VolitionWhen := StrToFloat(trim(WordFrag.WordFrag))
except
Self.VolitionWhen := 9999999.99;
end; {try}
end;
Self.FindMyBrain.LastFrag := WordFrag.MyName;
if WordFrag.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(WordFrag.MyName, WordFrag);
end;
procedure PatternClass.AddResponse(response: ResponseClass);
begin
response.MyOwner := Self;
Self.Responses.Add(response);
Self.FindMyBrain.LastResp := response.MyName;
if response.MyName <> '' then
response.FindMyBrain.NamedObjects.AddObject(response.MyName, response);
end;
procedure PatternClass.AddThreshold(Threshold: ThresholdClass);
begin
Threshold.MyOwner := Self;
Self.Thresholds.Add(Threshold);
if Threshold.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Threshold.MyName, Threshold);
end;
procedure PatternClass.AddState(State: StateClass);
begin
State.MyOwner := Self;
Self.States.Add(State);
if State.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(State.MyName, State);
end;
function PatternClass.MatchValue(InStr: string): integer;
var
i: integer;
begin
result := 0;
InStr := Self.FindMyBrain.ResolveFactsFor(InStr, InStr, Self, nil); //can match to a fact also
for i := 0 to Self.WordFragments.Count - 1 do begin
result := result + (Self.WordFragments.Items[i] as WordFragmentClass).MyValueIs(InStr);
end;
end;
procedure PatternClass.PickResponseAndDo(InStr: string); //invokes full scan of thresholds and evaluates down to response and/or actions
var
i : integer;
TheseResponses: TObjectList; //the responses to use, normal, threshold, or state..
begin //note that threshold takes precedence over default, and state takes precedence over threshold
inc(Self.HitCount);
TheseResponses := Self.Responses; //the default responses
for i := 0 to Self.Thresholds.Count -1 do //if HitCount within a threshold then use those responses instead
if (Self.HitCount >= (Self.Thresholds.Items[i] as ThresholdClass).ThreshFrom) and (Self.HitCount <= (Self.Thresholds.Items[i] as ThresholdClass).ThreshTo) then
TheseResponses := (Self.Thresholds.Items[i] as ThresholdClass).Responses;
for i := 0 to Self.States.Count -1 do //if a special state behavior is defined then use those responses instead
if ((Self.MyOwner as KnowledgeClass).MyOwner as BrainClass).GetCurrentState = (Self.States.Items[i] as StateClass).State then
TheseResponses := (Self.States.Items[i] as StateClass).Responses;
if TheseResponses.Count = 0 then exit;
(TheseResponses.Items[Random(TheseResponses.Count)] as ResponseClass).ResolveToStringAndDo(InStr);
Self.FindMyBrain.LastPat := Self.MyName;
end;
function PatternClass.GetResponseList(InStr: string; var ROwner: TObject): TObjectList;
var
i : integer;
begin
result := Self.Responses; //the default responses
ROwner := Self;
for i := 0 to Self.Thresholds.Count -1 do //if HitCount within a threshold then use those responses instead
if (Self.HitCount >= (Self.Thresholds.Items[i] as ThresholdClass).ThreshFrom) and (Self.HitCount <= (Self.Thresholds.Items[i] as ThresholdClass).ThreshTo) then begin
result := (Self.Thresholds.Items[i] as ThresholdClass).Responses;
ROwner := Self.Thresholds.Items[i] as ThresholdClass;
end;
for i := 0 to Self.States.Count -1 do //if a special state behavior is defined then use those responses instead
if ((Self.MyOwner as KnowledgeClass).MyOwner as BrainClass).GetCurrentState = (Self.States.Items[i] as StateClass).State then begin
result := (Self.States.Items[i] as StateClass).Responses;
ROwner := Self.States.Items[i] as StateClass;
end;
end;
procedure PatternClass.ShowVolition;
begin
if not Self.HasVolition then exit;
if Self.LastVolition = 0.0 then begin
if Now - Self.FindMyBrain.LastInput >= Self.VolitionWhen then begin
Self.LastVolition := now;
if MatchValue('') >= 0 then //if is not suppressed by fact or state criteria do it.
PickResponseAndDo('');
end;
end
else if Now - Self.LastVolition >= Self.VolitionWhen then begin
Self.LastVolition := now;
if MatchValue('') >= 0 then //if is not suppressed by fact or state criteria do it.
PickResponseAndDo('');
end;
end;
procedure PatternClass.ResetVCounter;
begin
Self.LastVolition := 0.0;
end;
function PatternClass.RemoveFragmentsFrom(InStr: string): string;
var
i : integer;
wfc : WordFragmentClass;
resFrag: string;
begin
for i := 0 to Self.WordFragments.Count - 1 do begin
wfc := Self.WordFragments.Items[i] as WordFragmentClass;
if wfc.Relation in [fr_AND, fr_OR, fr_NOT, fr_CUSTOM, fr_CUSTOMSub] then begin
resFrag := UpperCase(Self.FindMyBrain.ResolveFactsFor(wfc.WordFrag, Self.FindMyBrain.ResolveFactsFor(InStr, InStr, Self, nil), Self, nil));
if xPos(resFrag, UpperCase(InStr)) > 0 then begin
Delete(InStr, xPos(resFrag, UpperCase(InStr)), length(resFrag));
end
end
end;
result := InStr;
end;
procedure PatternClass.DoInitializes;
begin
if Self.HasInit then
Self.PickResponseAndDo('')
end;
procedure PatternClass.DoFinalizes;
begin
if Self.HasFinal then
Self.PickResponseAndDo('')
end;
{=================KnowledgeClass==================}
constructor KnowledgeClass.Create;
begin
inherited;
Self.MyName := '';
Self.Patterns := TObjectList.Create(true);
Self.MyOwner := nil;
Self.HasVolition := false;
end;
destructor KnowledgeClass.Destroy;
begin
Self.Patterns.Free;
inherited;
end;
procedure KnowledgeClass.AddPattern(Pattern: PatternClass);
begin
Pattern.MyOwner := Self;
Self.Patterns.Add(Pattern);
Self.HasVolition := Self.HasVolition or Pattern.HasVolition;
if (Self.MyOwner <> nil) and Self.HasVolition then
(Self.MyOwner as BrainClass).HasVolition := true;
Self.FindMyBrain.LastPat := Pattern.MyName;
if Pattern.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Pattern.MyName, Pattern);
end;
function KnowledgeClass.FindMyBrain: BrainClass;
begin
if Self.MyOwner is BrainClass then
result := Self.MyOwner as BrainClass
else
result := (Self.MyOwner as ResponseClass).FindMyBrain;
end;
procedure KnowledgeClass.RespondTo(InStr: string);
var
i, tmp, hival, node: integer;
s: string;
begin
s := 'Sorry, I can''t answer you because I don''t know anything at all yet...';
hival := -30000; node := -1;
for i := 0 to Self.Patterns.Count - 1 do begin
tmp := (Self.Patterns.Items[i] as PatternClass).MatchValue(InStr);
if tmp > hival then begin
hival := tmp;
node := i;
end
end;
if node = -1 then
Self.FindMyBrain.SendOutput(s)
else
(Self.Patterns.Items[node] as PatternClass).PickResponseAndDo(InStr);
Self.ResetVCounters;
Self.FindMyBrain.LastKnow := Self.MyName;
end;
procedure KnowledgeClass.ResetMyHits;
var
i : integer;
pat: PatternClass;
begin
for i := 0 to Self.Patterns.Count -1 do begin
pat := Self.Patterns.Items[i] as PatternClass;
pat.HitCount := 0;
end
end;
function KnowledgeClass.GetPatternFor(InStr: string): PatternClass;
var
i, tmp, hival, node: integer;
begin
result := nil;
hival := -30000; node := -1;
for i := 0 to Self.Patterns.Count - 1 do begin
tmp := (Self.Patterns.Items[i] as PatternClass).MatchValue(InStr);
if tmp > hival then begin
hival := tmp;
node := i;
end
end;
if node <> -1 then
result := Self.Patterns.Items[node] as PatternClass;
end;
procedure KnowledgeClass.ShowVolition;
var
i: integer;
begin
for i := 0 to Self.Patterns.Count - 1 do
(Self.Patterns.Items[i] as PatternClass).ShowVolition;
end;
procedure KnowledgeClass.ResetVCounters;
var
i: integer;
begin
for i := 0 to Self.Patterns.Count - 1 do
(Self.Patterns.Items[i] as PatternClass).ResetVCounter;
end;
procedure KnowledgeClass.DoInitializes;
var
i: integer;
begin
for i := 0 to Self.Patterns.Count - 1 do
(Self.Patterns.Items[i] as PatternClass).DoInitializes;
end;
procedure KnowledgeClass.DoFinalizes;
var
i: integer;
begin
for i := 0 to Self.Patterns.Count - 1 do
(Self.Patterns.Items[i] as PatternClass).DoFinalizes;
end;
{=================DataCollectionClass==================}
constructor DataCollectionClass.Create;
begin
inherited;
Self.MyName := '';
Self.TheName := '';
Self.TheData := TStringList.Create;
// Self.TheData.Sorted := false;
Self.TheData.Sorted := true; //see if this speeds up searches **will cause problems with PL code in collections!
Self.MyOwner := nil;
Self.LastMember := '';
Self.LastMWhen := 0.0;
Self.LastMemberS := '';
Self.LastMSWhen := 0.0;
end;
destructor DataCollectionClass.Destroy;
begin
Self.TheData.Free;
inherited;
end;
function DataCollectionClass.IsMember(InStr: string): boolean;
var
i: integer;
begin
result := false;
if InStr = '' then exit;
for i := 0 to Self.TheData.Count -1 do begin
result := result or (WordIsIn(UpperCase(Self.TheData.Strings[i]), UpperCase(InStr)));
end;
end;
function DataCollectionClass.IsMemberSub(InStr: string): boolean;
var
i: integer;
begin
result := false;
if InStr = '' then exit;
for i := 0 to Self.TheData.Count -1 do begin
result := result or (xPos(UpperCase(Self.TheData.Strings[i]), UpperCase(InStr)) > 0);
end;
end;
function DataCollectionClass.TheMemberIs(InStr: string): string;
var
i: integer;
begin
result := '~';
if InStr = '' then exit;
for i := 0 to Self.TheData.Count -1 do begin
if WordIsIn(UpperCase(Self.TheData.Strings[i]), UpperCase(InStr)) then begin
result := Self.TheData.Strings[i];
exit;
end
end;
end;
function DataCollectionClass.TheMemberIsSub(InStr: string): string;
var
i: integer;
begin
result := '~';
if InStr = '' then exit;
for i := 0 to Self.TheData.Count -1 do begin
if xPos(UpperCase(Self.TheData.Strings[i]), UpperCase(InStr)) > 0 then begin
result := Self.TheData.Strings[i];
exit;
end
end;
end;
function DataCollectionClass.TheMemberList(InStr: string): string;
var
i: integer;
begin
result := '';
if InStr = '' then exit;
for i := 0 to Self.TheData.Count -1 do begin
if result <> '' then
result := result + ', ' + Self.TheData.Strings[i]
else
result := Self.TheData.Strings[i];
end;
end;
function DataCollectionClass.PickMember(InStr: string): string;
var
i: integer;
begin
result := '';
if InStr = '' then exit;
if Self.TheData.Count = 0 then exit;
i := Random(Self.TheData.Count);
result := Self.TheData.Strings[i];
end;
procedure DataCollectionClass.AddData(TheStr: string);
begin
if TheStr = '' then exit;
TheStr := Trim(TheStr);
if Self.TheData.IndexOf(TheStr) = -1 then
Self.TheData.Add(TheStr);
end;
procedure DataCollectionClass.DelData(TheStr: string);
begin
if TheStr = '' then exit;
TheStr := Trim(TheStr);
if Self.TheData.IndexOf(TheStr) <> -1 then
Self.TheData.Delete(Self.TheData.IndexOf(TheStr));
end;
procedure DataCollectionClass.LoadCollection(FileName: string);
begin
try
Self.TheData.LoadFromFile(FileName);
except
end; {try}
end;
procedure DataCollectionClass.SaveCollection(FileName: string);
begin
try
Self.TheData.SaveToFile(FileName);
except
end; {try}
end;
procedure DataCollectionClass.ClearCollection;
begin
Self.TheData.Clear;
end;
{=================StepPatternClass==================}
constructor StepPatternClass.Create;
begin
inherited;
Self.MyName := '';
Self.MyOwner := nil;
Self.WordFragments := TObjectList.Create(true);
Self.Responses := TObjectList.Create(true);
end;
destructor StepPatternClass.Destroy;
begin
Self.Responses.Free;
Self.WordFragments.Free;
inherited;
end;
procedure StepPatternClass.AddFragment(Fragment: WordFragmentClass);
begin
Fragment.MyOwner := Self;
Self.WordFragments.Add(Fragment);
Self.FindMyBrain.LastFrag := Fragment.MyName;
if Fragment.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Fragment.MyName, Fragment);
end;
procedure StepPatternClass.AddResponse(Response: ResponseClass);
begin
Response.MyOwner := Self;
Self.Responses.Add(Response);
Self.FindMyBrain.LastResp := Response.MyName;
if Response.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Response.MyName, Response);
end;
function StepPatternClass.MatchValue(InStr: string): integer;
var
i: integer;
begin
result := 0;
InStr := Self.FindMyBrain.ResolveFactsFor(InStr, InStr, nil, self); //can match to a fact also
for i := 0 to Self.WordFragments.Count - 1 do begin
result := result + (Self.WordFragments.Items[i] as WordFragmentClass).MyValueIs(InStr);
end;
end;
procedure StepPatternClass.PickResponseAndDo(InStr: string); //select from within responses for this StepPattern and do
begin
if Self.Responses.Count = 0 then exit;
(Self.Responses.Items[Random(Self.Responses.Count)] as ResponseClass).ResolveToStringAndDo(InStr);
Self.FindMyBrain.LastSPat := Self.MyName;
end;
function StepPatternClass.FindMyBrain: BrainClass;
begin
result := (Self.MyOwner as StepClass).FindMyBrain;
end;
function StepPatternClass.RemoveFragmentsFrom(InStr: string): string;
var
i : integer;
wfc : WordFragmentClass;
resFrag: string;
begin
for i := 0 to Self.WordFragments.Count - 1 do begin
wfc := Self.WordFragments.Items[i] as WordFragmentClass;
if wfc.Relation in [fr_AND, fr_OR, fr_NOT, fr_CUSTOM] then begin
resFrag := UpperCase(Self.FindMyBrain.ResolveFactsFor(wfc.WordFrag, Self.FindMyBrain.ResolveFactsFor(InStr, InStr, nil, Self), nil, Self));
if xPos(resFrag, UpperCase(InStr)) > 0 then begin
Delete(InStr, xPos(resFrag, UpperCase(InStr)), length(resFrag));
end
end
end;
result := InStr;
end;
{=================StepClass==================}
constructor StepClass.Create;
begin
inherited;
Self.MyName := '';
Self.TheName := '';
Self.ThePrompt := '';
Self.MyOwner := nil;
Self.StepPatterns := TObjectList.Create(true);
end;
destructor StepClass.Destroy;
begin
Self.StepPatterns.Free;
inherited;
end;
procedure StepClass.AddStepPattern(StepPattern: StepPatternClass);
begin
StepPattern.MyOwner := self;
Self.StepPatterns.Add(StepPattern);
Self.FindMyBrain.LastSPat := StepPattern.MyName;
if StepPattern.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(StepPattern.MyName, StepPattern);
end;
function StepClass.FindMyBrain: BrainClass;
begin
result := (Self.MyOwner as ProcClass).FindMyBrain;
end;
procedure StepClass.PickResponseAndDo(InStr: string); //find pattern if exists, otherwise restate step
var
i, tmp, hival, node: integer;
s: string;
begin
s := 'There are no patterns for this procedure step! I can not proceed!';
hival := -30000; node := -1;
for i := 0 to Self.StepPatterns.Count - 1 do begin
tmp := (Self.StepPatterns.Items[i] as StepPatternClass).MatchValue(InStr);
if tmp > hival then begin
hival := tmp;
node := i;
end
end;
if node = -1 then
Self.FindMyBrain.SendOutput(s)
else
(Self.StepPatterns.Items[node] as StepPatternClass).PickResponseAndDo(InStr);
end;
{=================ProcClass==================}
constructor ProcClass.Create;
begin
inherited;
Self.MyName := '';
Self.TheName := '';
Self.CurrentStep := '';
Self.StartStep := '';
Self.Steps := TObjectList.Create(true);
Self.StepList := TStringList.Create;
Self.MyOwner := nil;
end;
destructor ProcClass.Destroy;
begin
Self.StepList.Free;
Self.Steps.Free;
inherited;
end;
procedure ProcClass.ProcessInput(InStr: string);
var
s: string;
begin
s := 'There is a problem with the procedure '+Self.TheName+'. There is not a current step!';
If Self.StepList.IndexOf(Self.CurrentStep) <> -1 then
(Self.Steps.Items[Self.StepList.IndexOf(Self.CurrentStep)] as StepClass).PickResponseAndDo(InStr)
else
Self.FindMyBrain.SendOutput(s);
if Self.FindMyBrain.CurrentProc = Self.FindMyBrain.Procs.IndexOf(Self.TheName) then begin //make sure is still this procedure
s := Self.CurrentPrompt;
Self.FindMyBrain.SendOutput(s);
end;
end;
procedure ProcClass.BeginProc;
var
s: string;
begin
if Self.StepList.IndexOf(Self.StartStep) <> -1 then
Self.CurrentStep := Self.StartStep
else
Self.CurrentStep := '';
if Self.CurrentStep = '' then
s := ''
else
s := Self.CurrentPrompt;
Self.FindMyBrain.SendOutput(s);
end;
procedure ProcClass.AddStep(StepName: string; Step: StepClass);
begin
if StepName = '' then exit;
if Self.StepList.IndexOf(StepName) = -1 then begin
Step.MyOwner := Self;
Step.TheName := StepName;
Self.Steps.Add(Step);
Self.StepList.Add(StepName);
if Self.Steps.Count = 1 then
Self.StartStep := StepName;
end
else begin
Self.Steps.Items[Self.StepList.IndexOf(StepName)] := Step;
end;
if Step.MyName <> '' then
Self.FindMyBrain.NamedObjects.AddObject(Step.MyName, Step);
end;
function ProcClass.FindMyBrain: BrainClass;
begin
result := Self.MyOwner as BrainClass;
end;
function ProcClass.CurrentPrompt: string;
var
sc : StepClass;
spc: StepPatternClass;
s : string;
begin
result := '';
if Self.StepList.IndexOf(Self.CurrentStep) = -1 then exit;
if self.FindMyBrain.InputStack.Count > 0 then
s := self.FindMyBrain.InputStack.Strings[0]
else
s := '';
sc := Self.Steps.Items[Self.StepList.IndexOf(Self.CurrentStep)] as StepClass;
spc := sc.StepPatterns[self.StepList.IndexOf(self.CurrentStep)] as StepPatternClass;
result := Self.FindMyBrain.ResolveFactsFor(sc.ThePrompt,s,nil,spc)
end;
{=================BrainClass==================}
constructor BrainClass.Create(CallBack: PBrainOutputEvent);
var
tmpKnowMode: KnowledgeClass;
begin
inherited Create;
Self.MyName := '';
Self.CurrentMode := -1;
Self.CurrentState := -1;
Self.CurrentProc := -1;
Self.Procs := TStringList.Create;
Self.TheProcs := TObjectList.Create(true);
Self.Modes := TStringList.Create;
Self.KnowledgeModes := TObjectList.Create(true);
Self.FactNames := TStringList.Create;
Self.Facts := TStringList.Create;
Self.States := TStringList.Create;
tmpKnowMode := KnowledgeClass.Create;
Self.AddKnowledgeMode('Default', tmpKnowMode);
Self.AddState('Normal');
Self.MyCallBack := CallBack;
Self.DataColNames := TStringList.Create;
Self.DataColNames.Sorted := true;
// Self.DataCollections := TObjectList.Create(true);
Self.TmpSource := nil;
Self.TmpSourceIdx := 0;
Self.HasVolition := false;
Self.LastInput := Now;
Self.VolitionTimer := nil;
Self.ShowBlankOutput := false;
Self.ProcStack := TStringList.Create;
Self.ProcStack.Sorted := false;
Self.StepStack := TStringList.Create;
Self.StepStack.Sorted := false;
Self.MyName := 'MyBrain';
Self.NamedObjects := TStringList.Create;
Self.NamedObjects.AddObject(Self.MyName, Self);
Self.VolitionTimer := TTimer.Create(nil);
Self.VolitionTimer.Enabled := false;
Self.LastPat := '';
Self.LastSPat := '';
Self.LastFrag := '';
Self.LastResp := '';
Self.LastTask := '';
Self.LastKnow := '';
Self.InputStack := TStringList.Create;
Self.InputStack.Sorted := false;
Self.OutputStack := TStringList.Create;
Self.OutputStack.Sorted := false;
Self.ImmedResponse := TStringList.Create;
Self.ImmedResponse.Sorted := false;
Randomize; //let's do this once, here because otherwise you get too many repeats
end;
destructor BrainClass.Destroy;
begin
Self.ImmedResponse.Free;
Self.InputStack.Free;
Self.OutputStack.Free;
Self.NamedObjects.Free;
Self.StepStack.Free;
Self.ProcStack.Free;
// Self.DataCollections.Free;
Self.DataColNames.Free;
Self.States.Free;
Self.Facts.Free;
Self.FactNames.Free;
Self.KnowledgeModes.Free;
Self.Modes.Free;
Self.TheProcs.Free;
Self.Procs.Free;
inherited;
end;
procedure BrainClass.SendOutput(OutStr: string);
begin
Self.AddToOutputStack(OutStr);
if @Self.MyCallBack <> nil then
Self.MyCallBack(OutStr)
else
Self.ImmedResponse.Add(OutStr);
end;
procedure BrainClass.PushProc;
var
tPC: ProcClass;
begin
if Self.CurrentProc <> -1 then begin
tPC := Self.TheProcs.Items[Self.CurrentProc] as ProcClass;
Self.ProcStack.Add(tPC.TheName);
Self.StepStack.Add(tPC.CurrentStep);
end;
end;
procedure BrainClass.PopProc;
var
tPC: ProcClass;
tSC: StepClass;
TheP,
TheS: string;
begin
if Self.ProcStack.Count > 0 then begin
TheP := Self.ProcStack.Strings[Self.ProcStack.Count-1];
Self.ProcStack.Delete(Self.ProcStack.Count-1);
TheS := Self.StepStack.Strings[Self.StepStack.Count-1];
Self.StepStack.Delete(Self.StepStack.Count-1);
Self.CurrentProc := Self.Procs.IndexOf(TheP);
tPC := Self.TheProcs.Items[Self.CurrentProc] as ProcClass;
tPC.CurrentStep := TheS;
tSC := tPC.Steps.Items[tPC.StepList.IndexOf(tPC.CurrentStep)] as StepClass;
Self.SendOutput(tSC.ThePrompt);
end;
end;
procedure BrainClass.AddKnowledgeMode(ModeName: string; KnowMode: KnowledgeClass);
begin
Self.HasVolition := Self.HasVolition or KnowMode.HasVolition;
KnowMode.MyMode := ModeName;
KnowMode.MyOwner := Self;
if Self.Modes.IndexOf(ModeName) <> -1 then begin
Self.KnowledgeModes.Items[Self.Modes.IndexOf(ModeName)] := KnowMode; //already exists, so just re-set the know structure for this mode
end
else begin //new, so just add. Name and know structures should always be aligned
Self.Modes.Add(ModeName);
Self.KnowledgeModes.Add(KnowMode);
end;
if Self.KnowledgeModes.Count = 1 then //this is the first mode added, so set as default mode
Self.CurrentMode := 0;
Self.LastKnow := KnowMode.MyName;
if KnowMode.MyName <> '' then
Self.NamedObjects.AddObject(KnowMode.MyName, KnowMode);
end;
procedure BrainClass.AddFact(FactName, Fact: string);
begin
if Self.FactNames.IndexOf(FactName) <> -1 then begin //already exists
Self.Facts.Strings[Self.FactNames.IndexOf(FactName)] := Fact;
end
else begin //new
Self.FactNames.Add(FactName);
Self.Facts.Add(Fact);
end
end;
procedure BrainClass.AddState(StateName: string);
begin
if Self.States.IndexOf(StateName) = -1 then
Self.States.Add(StateName);
if Self.States.Count = 1 then
Self.CurrentState := 0;
end;
procedure BrainClass.AddDataCollection(Name: string; DataCollection: DataCollectionClass);
begin
if Name = '' then exit;
DataCollection.TheName := Name;
DataCollection.MyOwner := Self;
if Self.DataColNames.IndexOf(Name) <> -1 then begin
Self.DataColNames.Objects[Self.DataColNames.IndexOf(Name)] := DataCollection;
end
else begin //new, so just add.
Self.DataColNames.Add(Name);
Self.DataColNames.Objects[Self.DataColNames.IndexOf(Name)] := DataCollection;
end;
if DataCollection.MyName <> '' then
Self.NamedObjects.AddObject(DataCollection.MyName, DataCollection);
end;
procedure BrainClass.AddProc(ProcName: string; NewProc: ProcClass);
begin
if ProcName = '' then exit;
NewProc.TheName := ProcName;
NewProc.MyOwner := self;
if Self.Procs.IndexOf(ProcName) <> -1 then begin
Self.TheProcs.Items[Self.Procs.IndexOf(ProcName)] := NewProc;
end
else begin
Self.Procs.Add(ProcName);
Self.TheProcs.Add(NewProc);
end;
if NewProc.MyName <> '' then
Self.NamedObjects.AddObject(NewProc.MyName, NewProc);
end;
procedure BrainClass.SwitchModeTo(ModeName: string);
begin
if Self.Modes.IndexOf(ModeName) <> -1 then begin //if mode exists
Self.CurrentMode := Self.Modes.IndexOf(ModeName); //make current mode
end;
end;
function BrainClass.GetCurrentMode: string;
begin
result := '';
if Self.CurrentMode <> -1 then
result := Self.Modes.Strings[Self.CurrentMode];
end;
procedure BrainClass.SwitchStateTo(StateName: string);
begin
if Self.States.IndexOf(StateName) <> -1 then
Self.CurrentState := Self.States.IndexOf(StateName)
else begin //doesn't exist so just add it and recurse (should only ever be 2 deep)
Self.AddState(StateName);
Self.SwitchStateTo(StateName)
end;
end;
function BrainClass.GetCurrentState: string;
begin
result := '';
if Self.CurrentState <> -1 then
result := Self.States.Strings[Self.CurrentState];
end;
procedure BrainClass.ClearState; //reset to no current state
begin
Self.CurrentState := -1;
end;
procedure BrainClass.ActivateProc(ProcName: string);
begin
Self.CurrentProc := Self.Procs.IndexOf(ProcName);
if Self.CurrentProc = -1 then exit;
(Self.TheProcs.Items[Self.CurrentProc] as ProcClass).BeginProc;
end;
procedure BrainClass.GotoProcStep(StepName: string);
begin
if Self.CurrentProc = -1 then exit;
if (Self.TheProcs.Items[Self.CurrentProc] as ProcClass).StepList.IndexOf(StepName) <> -1 then
(Self.TheProcs.Items[Self.CurrentProc] as ProcClass).CurrentStep := StepName;
end;
procedure BrainClass.HaltProc;
begin
Self.CurrentProc := -1;
end;
function BrainClass.GetFact(FactName: string): string;
begin
result := '#';
if Self.FactNames.IndexOf(FactName) <> -1 then
result := Self.Facts.Strings[Self.FactNames.IndexOf(FactName)];
end;
function BrainClass.GetSysFact(FactName: string): string;
begin
result := '*';
if UpperCase(FactName) = 'TIME' then begin
result := TimeToStr(Now)
end
else if UpperCase(FactName) = 'DATE' then begin
result := DateToStr(Now)
end
else if UpperCase(FactName) = 'AGE' then begin
result := IntToStr(Trunc(Now - StrToDate('10/02/2002')));
end
end;
procedure BrainClass.AddMember(CollectionName: string; Value: string);
var
tDC: DataCollectionClass;
ix: integer;
begin
ix := Self.DataColNames.IndexOf(CollectionName); //only get index once for speed
if ix = -1 then begin
tDC := DataCollectionClass.Create;
tDC.TheName := CollectionName;
Self.AddDataCollection(CollectionName, tDC);
tDC.AddData(Value);
end
else begin
tDC := Self.DataColNames.Objects[ix] as DataCollectionClass;
tDC.AddData(Value);
end
end;
procedure BrainClass.RemoveMember(CollectionName: string; Value: string);
var
tDC: DataCollectionClass;
ix: integer;
begin
ix := Self.DataColNames.IndexOf(CollectionName); //only get index once for speed
if ix <> -1 then begin
tDC := Self.DataColNames.Objects[ix] as DataCollectionClass;
tDC.DelData(Value);
end
end;
function BrainClass.GetMember(CollectionName: string; InStr: string): string;
var
tDC: DataCollectionClass;
ix: integer;
begin
result := '';
ix := Self.DataColNames.IndexOf(CollectionName); //only get index once for speed
if ix <> -1 then begin
tDC := Self.DataColNames.Objects[ix] as DataCollectionClass;
if tDC.LastMWhen = Self.LastInput then begin //has member already been looked up?
result := tDC.LastMember;
exit;
end;
result := tDC.TheMemberIs(InStr);
tDC.LastMember := result; //ok, save for next time
tDC.LastMWhen := Self.LastInput;
end
end;
function BrainClass.GetMemberSub(CollectionName: string; InStr: string): string;
var
tDC: DataCollectionClass;
ix: integer;
begin
result := '';
ix := Self.DataColNames.IndexOf(CollectionName); //only get index once for speed
if ix <> -1 then begin
tDC := Self.DataColNames.Objects[ix] as DataCollectionClass;
if tDC.LastMSWhen = Self.LastInput then begin //has member already been looked up?
result := tDC.LastMemberS;
exit;
end;
result := tDC.TheMemberIsSub(InStr);
tDC.LastMemberS := result; //ok, save for next time
tDC.LastMSWhen := Self.LastInput;
end
end;
function BrainClass.GetMemberList(CollectionName: string; InStr: string): string; //returns full list of members separated by commas
var
tDC: DataCollectionClass;
ix: integer;
begin
result := '';
ix := Self.DataColNames.IndexOf(CollectionName); //only get index once for speed
if ix <> -1 then begin
tDC := Self.DataColNames.Objects[ix] as DataCollectionClass;
result := tDC.TheMemberList(InStr);
end
end;
function BrainClass.PickMember(CollectionName: string; InStr: string): string; //randomly picks from list of members
var
tDC: DataCollectionClass;
begin
result := '';
if Self.DataColNames.IndexOf(CollectionName) <> -1 then begin
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(CollectionName)] as DataCollectionClass;
result := tDC.PickMember(InStr);
end
end;
function BrainClass.ResolveFactsFor(TheStr: string; InStr: string; Pattern: PatternClass; StepPattern: StepPatternClass): string; //inserts any facts referenced in string, and states as well
var
StartP, EndP: integer;
begin
while xPos(UpperCase(StartFactToken), UpperCase(TheStr)) <> 0 do begin //resolve all facts
StartP := xPos(UpperCase(StartFactToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndFactToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetFact(xCopy(TheStr, StartP + length(StartFactToken), EndP - (StartP + length(StartFactToken)))) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartSysFactToken), UpperCase(TheStr)) <> 0 do begin //resolve all facts
StartP := xPos(UpperCase(StartSysFactToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndSysFactToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetSysFact(xCopy(TheStr, StartP + length(StartSysFactToken), EndP - (StartP + length(StartSysFactToken)))) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartMemberToken), UpperCase(TheStr)) <> 0 do begin //resolve all members
StartP := xPos(UpperCase(StartMemberToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndMemberToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetMember(xCopy(TheStr, StartP + length(StartMemberToken), EndP - (StartP + length(StartMemberToken))), InStr) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartMemberSubToken), UpperCase(TheStr)) <> 0 do begin //resolve all members
StartP := xPos(UpperCase(StartMemberSubToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndMemberSubToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetMemberSub(xCopy(TheStr, StartP + length(StartMemberSubToken), EndP - (StartP + length(StartMemberSubToken))), InStr) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartMemberListToken), UpperCase(TheStr)) <> 0 do begin //resolve all members
StartP := xPos(UpperCase(StartMemberListToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndMemberListToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetMemberList(xCopy(TheStr, StartP + length(StartMemberListToken), EndP - (StartP + length(StartMemberListToken))), InStr) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartPickMemberToken), UpperCase(TheStr)) <> 0 do begin //resolve all members
StartP := xPos(UpperCase(StartPickMemberToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndPickMemberToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.PickMember(xCopy(TheStr, StartP + length(StartPickMemberToken), EndP - (StartP + length(StartPickMemberToken))), InStr) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StateToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(StateToken), UpperCase(TheStr));
EndP := StartP + Length(StateToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GetCurrentState +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
if Pattern <> nil then begin
while xPos(UpperCase(RemainToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(RemainToken), UpperCase(TheStr));
EndP := StartP + Length(RemainToken);
if Pattern <> nil then
TheStr := xCopy(TheStr, 1, StartP - 1) +
Pattern.RemoveFragmentsFrom(InStr) +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1)
else
TheStr := xCopy(TheStr, 1, StartP - 1) +
StepPattern.RemoveFragmentsFrom(InStr) +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1)
end;
end;
while xPos(UpperCase(StartInputToken), UpperCase(TheStr)) <> 0 do begin //resolve all facts
StartP := xPos(UpperCase(StartInputToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndInputToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.FromInputStack(xCopy(TheStr, StartP + length(StartInputToken), EndP - (StartP + length(StartInputToken)))) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(StartLastOutToken), UpperCase(TheStr)) <> 0 do begin //resolve all facts
StartP := xPos(UpperCase(StartLastOutToken), UpperCase(TheStr));
EndP := posFrom(UpperCase(EndLastOutToken), UpperCase(TheStr), StartP);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.FromOutputStack(xCopy(TheStr, StartP + length(StartLastOutToken), EndP - (StartP + length(StartLastOutToken)))) +
xCopy(TheStr, EndP + 1, length(TheStr) - EndP);
end;
while xPos(UpperCase(LastPatToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastPatToken), UpperCase(TheStr));
EndP := StartP + Length(LastPatToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastPat +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(LastSPatToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastSPatToken), UpperCase(TheStr));
EndP := StartP + Length(LastSPatToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastSPat +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(LastFragToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastFragToken), UpperCase(TheStr));
EndP := StartP + Length(LastFragToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastFrag +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(LastRespToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastRespToken), UpperCase(TheStr));
EndP := StartP + Length(LastRespToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastResp +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(LastTaskToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastTaskToken), UpperCase(TheStr));
EndP := StartP + Length(LastTaskToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastTask +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(LastKnowToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(LastKnowToken), UpperCase(TheStr));
EndP := StartP + Length(LastKnowToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.LastKnow +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
while xPos(UpperCase(AutoNameToken), UpperCase(TheStr)) <> 0 do begin //resolve all states
StartP := xPos(UpperCase(AutoNameToken), UpperCase(TheStr));
EndP := StartP + Length(AutoNameToken);
TheStr := xCopy(TheStr, 1, StartP - 1) +
Self.GenerateAutoName +
xCopy(TheStr, EndP, (length(TheStr) - EndP) + 1);
end;
result := TheStr;
end;
function BrainClass.IsInDataCollection(CollectionName: string; InStr: string): boolean; //is work in data collection in InStr?
var
tDC: DataCollectionClass;
begin
result := false;
if Self.DataColNames.IndexOf(CollectionName) = -1 then exit; //not there
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(CollectionName)] as DataCollectionClass;
result := tDC.IsMember(InStr);
end;
function BrainClass.IsInDataCollectionSub(CollectionName: string; InStr: string): boolean; //is work in data collection in InStr?
var
tDC: DataCollectionClass;
begin
result := false;
if Self.DataColNames.IndexOf(CollectionName) = -1 then exit; //not there
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(CollectionName)] as DataCollectionClass;
result := tDC.IsMemberSub(InStr);
end;
procedure BrainClass.RequestResponseFor(InStr: string); //drills down to appropriate knowledge class call
var
s: string;
begin
Self.LastInput := Now;
Self.AddToInputStack(InStr);
s := 'Sorry, I do not know anything at all yet!';
if Self.CurrentProc <> -1 then begin
(Self.TheProcs.Items[Self.CurrentProc] as ProcClass).ProcessInput(InStr);
exit;
end;
if Self.CurrentMode = -1 then
Self.SendOutput(s)
else
(Self.KnowledgeModes.Items[Self.CurrentMode] as KnowledgeClass).RespondTo(InStr);
end;
function BrainClass.ReturnResponseFor(InStr: string): string;
var
s: string;
i: integer;
begin
result := '';
Self.LastInput := Now;
Self.AddToInputStack(InStr);
s := 'Sorry, I do not know anything at all yet!';
if Self.CurrentProc <> -1 then begin
(Self.TheProcs.Items[Self.CurrentProc] as ProcClass).ProcessInput(InStr);
for i := 0 to Self.ImmedResponse.Count -1 do begin
if result = '' then
result := Self.ImmedResponse.Strings[i]
else
result := result + ' ' + Self.ImmedResponse.Strings[i];
end;
Self.ImmedResponse.Clear;
exit;
end;
if Self.CurrentMode = -1 then
Self.SendOutput(s)
else
(Self.KnowledgeModes.Items[Self.CurrentMode] as KnowledgeClass).RespondTo(InStr);
for i := 0 to Self.ImmedResponse.Count -1 do begin
if result = '' then
result := Self.ImmedResponse.Strings[i]
else
result := result + ' ' + Self.ImmedResponse.Strings[i];
end;
Self.ImmedResponse.Clear;
end;
procedure BrainClass.ResetAllHits;
var
i : integer;
km: KnowledgeClass;
begin
for i := 0 to Self.KnowledgeModes.Count -1 do begin
km := Self.KnowledgeModes.Items[i] as KnowledgeClass;
km.ResetMyHits;
end;
end;
function BrainClass.GetMatchingPatternFor(InStr: string): PatternClass;
begin
if Self.CurrentMode = -1 then
result := nil
else
result := (Self.KnowledgeModes.Items[Self.CurrentMode] as KnowledgeClass).GetPatternFor(InStr);
end;
procedure BrainClass.OnVTimer(Sender: TObject);
var
TheKClass: KnowledgeClass;
begin
TheKClass := Self.KnowledgeModes.Items[Self.CurrentMode] as KnowledgeClass;
if not TheKClass.HasVolition then exit; //no volition
TheKClass.ShowVolition; //if it is time, then do something
end;
procedure BrainClass.Wakeup;
begin
if not Self.HasVolition then exit;
Self.LastInput := Now;
Self.VolitionTimer.Enabled := false;
Self.VolitionTimer.Interval := 10000;
Self.VolitionTimer.OnTimer := Self.OnVTimer;
Self.VolitionTimer.Enabled := true;
end;
procedure BrainClass.Sleep;
begin
if not Self.HasVolition then exit;
Self.VolitionTimer.Enabled := false;
Self.VolitionTimer.Interval := 0;
end;
procedure BrainClass.LogThis(FileSpec: string; TheStr: string);
var
F: Text;
begin
Assign(F, FileSpec);
{$i-} Append(F); {$i+}
if ioresult <> 0 then begin
{$i-} Rewrite(F); {$i+}
if ioresult <> 0 then exit;
end;
{$i-} Writeln(F, TheStr); {$i+}
if ioresult <> 0 then ;
{$i-} Close(F); {$i+}
if ioresult <> 0 then ;
end;
procedure BrainClass.ModifyNamedObject(Name, Field, NewValue: string);
var
TheObj: TObject;
begin
if Self.NamedObjects.IndexOf(Name) <> -1 then begin
Field := UpperCase(Field);
TheObj := Self.NamedObjects.Objects[Self.NamedObjects.IndexOf(Name)];
if TheObj is WordFragmentClass then begin
if Field = 'WORDFRAG' then begin
(TheObj as WordFragmentClass).WordFrag := NewValue;
end
else if Field = 'RELATION' then begin
(TheObj as WordFragmentClass).Relation := FragRelationIs(NewValue);
end
else if Field = 'BONUS' then begin
(TheObj as WordFragmentClass).Bonus := StrToIntDef(NewValue,0);
end
else if Field = 'PENALTY' then begin
(TheObj as WordFragmentClass).Penalty := StrToIntDef(NewValue,0);
end
else if Field = 'THENAME' then begin
(TheObj as WordFragmentClass).TheName := NewValue;
end
else if Field = 'THEVALUE' then begin
(TheObj as WordFragmentClass).TheValue := NewValue;
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is TaskClass then begin
if Field = 'RESPONSETYPE' then begin
(TheObj as TaskClass).ResponseType := RespTypeIs(NewValue);
end
else if Field = 'OUTTEXT' then begin
(TheObj as TaskClass).OutText := NewValue;
end
else if Field = 'THENAME' then begin
(TheObj as TaskClass).TheName := NewValue;
end
else if Field = 'THEVALUE' then begin
(TheObj as TaskClass).TheValue := NewValue;
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is ResponseClass then begin
if Field = 'RESPONSETYPE' then begin
(TheObj as ResponseClass).ResponseType := RespTypeIs(NewValue);
end
else if Field = 'OUTTEXT' then begin
(TheObj as ResponseClass).OutText := NewValue;
end
else if Field = 'THENAME' then begin
(TheObj as ResponseClass).TheName := NewValue;
end
else if Field = 'THEVALUE' then begin
(TheObj as ResponseClass).TheValue := NewValue;
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is ThresholdClass then begin
if Field = 'THRESHFROM' then begin
(TheObj as ThresholdClass).ThreshFrom := StrToIntDef(NewValue,0);
end
else if Field = 'THRESHTO' then begin
(TheObj as ThresholdClass).ThreshTo := StrToIntDef(NewValue,0);
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is StateClass then begin
if Field = 'STATE' then begin
(TheObj as StateClass).State := NewValue
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is PatternClass then begin
if Field = 'HITCOUNT' then begin
(TheObj as PatternClass).HitCount := StrToIntDef(NewValue,0);
end
else if Field = 'HASVOLITION' then begin
(TheObj as PatternClass).HasVolition := (UpperCase(NewValue) = 'YES') or (UpperCase(NewValue) = 'Y') or (UpperCase(NewValue) = 'TRUE');
end
else if Field = 'LASTVOLITION' then begin
(TheObj as PatternClass).LastVolition := Str2Dbl(NewValue, Now);
end
else if Field = 'VOLITIONWHEN' then begin
(TheObj as PatternClass).VolitionWhen := Str2Dbl(NewValue, 9999999.99);
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is KnowledgeClass then begin
if Field = 'HASVOLITION' then begin
(TheObj as KnowledgeClass).HasVolition := (UpperCase(NewValue) = 'YES') or (UpperCase(NewValue) = 'Y') or (UpperCase(NewValue) = 'TRUE');
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is DataCollectionClass then begin //currently cant change anything in a DataCollection
if Field = '' then begin
end
else if Field = '' then begin
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is StepPatternClass then begin //Currently nothing to change in a StepPatternClass
if Field = '' then begin
end
else if Field = '' then begin
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is StepClass then begin
if Field = 'THENAME' then begin
(TheObj as StepClass).TheName := NewValue;
end
else if Field = 'THEPROMPT' then begin
(TheObj as StepClass).ThePrompt := NewValue;
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is ProcClass then begin
if Field = 'THENAME' then begin
(TheObj as ProcClass).TheName := NewValue;
end
else if Field = 'CURRENTSTEP' then begin
(TheObj as ProcClass).CurrentStep := NewValue;
end
else if Field = 'STARTSTEP' then begin
(TheObj as ProcClass).StartStep := NewValue;
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else if TheObj is BrainClass then begin
if Field = 'MYNAME' then begin
(TheObj as BrainClass).MyName := NewValue;
end
else if Field = 'CURRENTMODE' then begin
(TheObj as BrainClass).CurrentMode := StrToIntDef(NewValue,0);
end
else if Field = 'CURRENTSTATE' then begin
(TheObj as BrainClass).CurrentState := StrToIntDef(NewValue,0);
end
else if Field = 'CURRENTPROC' then begin
(TheObj as BrainClass).CurrentProc := StrToIntDef(NewValue,0);
end
else if Field = 'HASVOLITION' then begin
(TheObj as BrainClass).HasVolition := (UpperCase(NewValue) = 'YES') or (UpperCase(NewValue) = 'Y') or (UpperCase(NewValue) = 'TRUE');
end
else if Field = 'LASTINPUT' then begin
(TheObj as BrainClass).LastInput := Now;
end
else if Field = 'SHOWBLANKOUTPUT' then begin
(TheObj as BrainClass).ShowBlankOutput := (UpperCase(NewValue) = 'YES') or (UpperCase(NewValue) = 'Y') or (UpperCase(NewValue) = 'TRUE');
end
else if Field = 'LASTOUTPUT' then begin
(TheObj as BrainClass).AddToOutputStack(NewValue);
end
else begin //unknown field type
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class Field: '+Name+' '+Field);
end;
end
else begin //unknown class
Self.SendOutput('Proteus Internal Error. Unknown Named Object Class: '+Name);
end;
end;
end;
procedure BrainClass.LoadCollection(Name, FileName: string);
var
tDC: DataCollectionClass;
begin
if Self.DataColNames.IndexOf(Name) = -1 then begin //if it isn't there, then create it
tDC := DataCollectionClass.Create;
tDC.TheName := Name;
Self.AddDataCollection(Name, tDC);
tDC.LoadCollection(FileName);
end
else begin
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(Name)] as DataCollectionClass;
tDC.LoadCollection(FileName);
end
end;
procedure BrainClass.SaveCollection(Name, FileName: string);
var
tDC: DataCollectionClass;
begin
if Self.DataColNames.IndexOf(Name) = -1 then exit; //not there
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(Name)] as DataCollectionClass;
tDC.SaveCollection(FileName);
end;
procedure BrainClass.ClearCollection(Name: string);
var
tDC: DataCollectionClass;
begin
if Self.DataColNames.IndexOf(Name) = -1 then exit; //not there
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(Name)] as DataCollectionClass;
tDC.ClearCollection;
end;
procedure BrainClass.ParseToCollection(SourceCollection, DestCollection, InStr: string);
var
tDC : DataCollectionClass;
tDC2: DataCollectionClass;
i : integer;
s : string;
begin
if Self.DataColNames.IndexOf(SourceCollection) = -1 then exit; //not there so nothing to do
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(SourceCollection)] as DataCollectionClass;
if Self.DataColNames.IndexOf(DestCollection) = -1 then begin //if it isn't there, then create it
tDC2 := DataCollectionClass.Create;
tDC2.TheName := DestCollection;
Self.AddDataCollection(DestCollection, tDC2);
end
else
tDC2 := Self.DataColNames.Objects[Self.DataColNames.IndexOf(DestCollection)] as DataCollectionClass;
for i := 0 to tDC.TheData.Count -1 do begin
s := tDC.TheData.Strings[i];
if WordIsIn(s, InStr) then
tDC2.AddData(s);
end;
end;
procedure BrainClass.DoInitializes;
var
tKM: KnowledgeClass;
begin
tKM := Self.KnowledgeModes.Items[0] as KnowledgeClass;
tKM.DoInitializes;
end;
procedure BrainClass.DoFinalizes;
var
tKM: KnowledgeClass;
begin
tKM := Self.KnowledgeModes.Items[0] as KnowledgeClass;
tKM.DoFinalizes;
end;
procedure BrainClass.MergeCollections(SourceCollection, DestCollection: string);
var
tDC : DataCollectionClass;
tDC2: DataCollectionClass;
begin
if Self.DataColNames.IndexOf(SourceCollection) = -1 then exit; //not there so nothing to do
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(SourceCollection)] as DataCollectionClass;
if Self.DataColNames.IndexOf(DestCollection) = -1 then begin //if it isn't there, then create it
tDC2 := DataCollectionClass.Create;
tDC2.TheName := DestCollection;
Self.AddDataCollection(DestCollection, tDC2);
end
else
tDC2 := Self.DataColNames.Objects[Self.DataColNames.IndexOf(DestCollection)] as DataCollectionClass;
tDC2.TheData.AddStrings(tDC.TheData);
end;
procedure BrainClass.WordsToCollection(InStr, DestCollection: string);
var
tDC2 : DataCollectionClass;
Strs : TStringList;
begin
if Self.DataColNames.IndexOf(DestCollection) = -1 then begin //if it isn't there, then create it
tDC2 := DataCollectionClass.Create;
tDC2.TheName := DestCollection;
Self.AddDataCollection(DestCollection, tDC2);
end
else
tDC2 := Self.DataColNames.Objects[Self.DataColNames.IndexOf(DestCollection)] as DataCollectionClass;
Strs := TStringList.Create;
ParseString(InStr, Strs);
tDC2.TheData.AddStrings(Strs);
Strs.Free;
end;
procedure BrainClass.MakeCodeFrom(SourceCollection: string);
var
tDC: DataCollectionClass;
begin
if Self.DataColNames.IndexOf(SourceCollection) = -1 then exit; //not there so nothing to do
tDC := Self.DataColNames.Objects[Self.DataColNames.IndexOf(SourceCollection)] as DataCollectionClass;
LoadLangStrings(Self, tDC.TheData);
end;
procedure BrainClass.DeleteObject(ObjName: string);
var
theObj : TObject;
TheProc : ProcClass;
TheStep : StepClass;
DataCollection: DataCollectionClass;
Pattern : PatternClass;
StepPattern : StepPatternClass;
Know : KnowledgeClass;
Thresh : ThresholdClass;
StateC : StateClass;
Response : ResponseClass;
WF : WordFragmentClass;
TC : TaskClass;
begin
if Self.NamedObjects.IndexOf(ObjName) = -1 then exit; //not there so exit
theObj := Self.NamedObjects.Objects[Self.NamedObjects.IndexOf(ObjName)];
Self.NamedObjects.Delete(Self.NamedObjects.IndexOf(ObjName)); //remove from named object list
if TheObj is WordFragmentClass then begin
WF := TheObj as WordFragmentClass;
Pattern := WF.FindMyPattern;
StepPattern := WF.FindMyStepPattern;
if Pattern <> nil then begin //if is a pattern fragment
Pattern.WordFragments.Remove(WF);
end
else begin //if is steppattern
StepPattern.WordFragments.Remove(WF);
end
end
else if TheObj is TaskClass then begin
TC := TheObj as TaskClass;
Response := TC.MyOwner as ResponseClass;
Response.Tasks.Remove(TC);
end
else if TheObj is ResponseClass then begin
Response := TheObj as ResponseClass;
Pattern := Response.FindMyPattern;
StepPattern := Response.FindMyStepPattern;
Thresh := Response.FindMyThreshold;
StateC := Response.FindMyState;
//note that the order of testing is important!
if StateC <> nil then
StateC.Responses.Remove(Response)
else if Thresh <> nil then
Thresh.Responses.Remove(Response)
else if StepPattern <> nil then
StepPattern.Responses.Remove(Response)
else
Pattern.Responses.Remove(Response);
end
else if TheObj is ThresholdClass then begin
Thresh := TheObj as ThresholdClass;
Pattern := Thresh.MyOwner as PatternClass;
Pattern.Thresholds.Remove(Thresh);
end
else if TheObj is StateClass then begin
StateC := TheObj as StateClass;
Pattern := StateC.MyOwner as PatternClass;
Pattern.States.Remove(StateC);
end
else if TheObj is PatternClass then begin
Pattern := TheObj as PatternClass;
Know := Pattern.MyOwner as KnowledgeClass;
Know.Patterns.Remove(Pattern);
end
else if TheObj is KnowledgeClass then begin
Know := TheObj as KnowledgeClass;
if Self.Modes.IndexOf(Know.MyMode) <> -1 then
Self.Modes.Delete(Self.Modes.IndexOf(Know.MyMode));
Self.KnowledgeModes.Remove(Know);
end
else if TheObj is DataCollectionClass then begin
DataCollection := TheObj as DataCollectionClass;
if Self.DataColNames.IndexOf(DataCollection.TheName) <> -1 then
Self.DataColNames.Delete(Self.DataColNames.IndexOf(DataCollection.TheName));
end
else if TheObj is StepPatternClass then begin
StepPattern := TheObj as StepPatternClass;
TheStep := StepPattern.MyOwner as StepClass;
TheStep.StepPatterns.Remove(StepPattern);
end
else if TheObj is StepClass then begin
TheStep := TheObj as StepClass;
TheProc := TheStep.MyOwner as ProcClass;
TheProc.Steps.Remove(TheStep);
end
else if TheObj is ProcClass then begin
TheProc := TheObj as ProcClass;
if Self.Procs.IndexOf(TheProc.TheName) <> -1 then
Self.Procs.Delete(Self.Procs.IndexOf(TheProc.TheName));
Self.TheProcs.Remove(TheProc);
end
else if TheObj is BrainClass then begin //can't delete your own brain!!!
end
else begin //unknown class
end;
end;
procedure BrainClass.DoResponseFor(ObjName: string);
var
theObj: TObject;
PatC : PatternClass;
SPatC : StepPatternClass;
begin
if Self.NamedObjects.IndexOf(ObjName) = -1 then exit; //not there so exit
theObj := Self.NamedObjects.Objects[Self.NamedObjects.IndexOf(ObjName)];
if theObj is PatternClass then begin
PatC := theObj as PatternClass;
PatC.PickResponseAndDo('');
end
else if theObj is StepPatternClass then begin
SPatC := theObj as StepPatternClass;
SPatC.PickResponseAndDo('');
end;
end;
procedure BrainClass.AddToInputStack(InStr: string);
begin
if Self.InputStack.Count = 0 then begin
Self.InputStack.Add(InStr)
end
else begin
Self.InputStack.Insert(0, InStr);
if Self.InputStack.Count > InOutStackSize then
Self.InputStack.Delete(Self.InputStack.Count-1);
end;
end;
procedure BrainClass.AddToOutputStack(OutStr: string);
begin
if Self.OutputStack.Count = 0 then begin
Self.OutputStack.Add(OutStr)
end
else begin
Self.OutputStack.Insert(0, OutStr);
if Self.OutputStack.Count > InOutStackSize then
Self.OutputStack.Delete(Self.OutputStack.Count-1);
end;
end;
function BrainClass.FromInputStack(num: string): string;
var
i: integer;
begin
result := '';
if Self.InputStack.Count = 0 then exit; //no previous input
i := StrToIntDef(num, 0);
if (i > InOutStackSize) or (i < 0) or (i > Self.InputStack.Count - 1) then exit;
result := Self.InputStack.Strings[i];
end;
function BrainClass.FromOutputStack(num: string): string;
var
i: integer;
begin
result := '';
if Self.OutputStack.Count = 0 then exit; //no previous input
i := StrToIntDef(num,0);
if (i > InOutStackSize) or (i < 0) or (i > Self.OutputStack.Count - 1) then exit;
result := Self.OutputStack.Strings[i];
end;
function BrainClass.GenerateAutoName: string;
function RandLet: char;
begin
result := char(Random(25)+65);
end;
var
i: integer;
s: string;
begin
repeat
s := 'Auto-';
for i := 1 to 10 do
s := s + RandLet;
until Self.NamedObjects.IndexOf(s) = -1;
result := s;
end;
procedure BrainClass.CreateAutoPattern(InStr, Bonus, Response: string);
var
i : integer;
Strs : TStringList;
tKC : KnowledgeClass;
tPC : PatternClass;
tWF : WordFragmentClass;
tRC : ResponseClass;
begin
if InStr = '' then exit;
Strs := TStringList.Create;
ParseString(InStr, Strs);
if Strs.Count = 0 then begin
Strs.Free;
exit;
end;
tKC := Self.KnowledgeModes.Items[Self.CurrentMode] as KnowledgeClass;
tPC := PatternClass.Create;
tPC.MyName := Self.GenerateAutoName;
tKC.AddPattern(tPC);
tRC := ResponseClass.Create;
tRC.ResponseType := rt_JustText;
tRC.OutText := Response;
tRC.MyName := Self.GenerateAutoName;
tPC.AddResponse(tRC);
for i := 0 to Strs.Count -1 do begin
tWF := WordFragmentClass.Create;
tWF.WordFrag := Strs.Strings[i];
tWF.Relation := fr_CUSTOM;
tWF.Bonus := StrToIntDef(Bonus,0);
tPC.AddFragment(tWF);
end;
Strs.Free;
end;
procedure BrainClass.AddOnResponse(Response: string);
var
TheObj: TObject;
tRC : ResponseClass;
tPC : PatternClass;
begin
if Response = '' then exit;
if Self.LastPat = '' then exit;
if Self.NamedObjects.IndexOf(Self.LastPat) <> -1 then begin
TheObj := Self.NamedObjects.Objects[Self.NamedObjects.IndexOf(Self.LastPat)];
if TheObj is PatternClass then begin
tPC := TheObj as PatternClass;
tRC := ResponseClass.Create;
tRC.ResponseType := rt_JustText;
tRC.MyName := Self.GenerateAutoName;
tRC.OutText := Response;
tPC.AddResponse(tRC);
end
end;
end;
procedure BrainClass.AddOnFragment(Fragment, Bonus: string);
var
TheObj: TObject;
tFC : WordFragmentClass;
tPC : PatternClass;
begin
if Fragment = '' then exit;
if Self.LastPat = '' then exit;
if Self.NamedObjects.IndexOf(Self.LastPat) <> -1 then begin
TheObj := Self.NamedObjects.Objects[Self.NamedObjects.IndexOf(Self.LastPat)];
if TheObj is PatternClass then begin
tPC := TheObj as PatternClass;
tFC := WordFragmentClass.Create;
tFC.WordFrag := Fragment;
tFC.Relation := fr_CUSTOM;
tFC.Bonus := StrToIntDef(Bonus,0);
tFC.MyName := Self.GenerateAutoName;
tPC.AddFragment(tFC);
end
end;
end;
{=================Support routines==================}
const
FragRelationText: array [Low(FragmentRelations)..High(FragmentRelations)]
of string [18] = ('None','AND','OR','NOT','CUSTOM','Data-Match','External','State-Match', 'In Collection', 'Volition', 'Out-Match',
'CUSTOM-Sub', 'In Collection-Sub', 'Initialize', 'Finalize');
RespTypeText: array [Low(ResponseTypes)..High(ResponseTypes)]
of string [24] = ('None','Just Text','Mode Change','Nested','Assignment','Action','Reset Hits','State Change','Reset State',
'Task List', 'Reset KM Hits', 'Reset Brain Hits', 'Add To Collection', 'Remove From Collection',
'Submit This', 'Log This', 'Start Proc', 'Goto Step', 'Halt Proc', 'Ask OpenMind', 'Call Proc', 'Proc Return',
'Self Modify', 'Load Collection', 'Save Collection', 'Clear Collection', 'Parse Collection', 'Delete Object',
'Make Code', 'Merge Collection', 'Do Response For', 'Words To Collection', 'Create AutoPattern',
'Add Response', 'Add Fragment');
function RespTypeAs(RespType: ResponseTypes): string;
begin
result := RespTypeText[RespType];
end;
function RespTypeIs(InStr: string): ResponseTypes;
var
i: ResponseTypes;
begin
result := rt_None;
for i := Low(ResponseTypes) to High(ResponseTypes) do
if UpperCase(Trim(InStr)) = UpperCase(Trim(RespTypeText[i])) then begin
result := i;
exit;
end;
end;
function FragRelationAs(FragRel: FragmentRelations): string;
begin
result := FragRelationText[FragRel];
end;
function FragRelationIs(InStr: string): FragmentRelations;
var
i: FragmentRelations;
begin
result := fr_NoRelation;
for i := Low(FragmentRelations) to High(FragmentRelations) do
if UpperCase(Trim(InStr)) = UpperCase(Trim(FragRelationText[i])) then begin
result := i;
exit;
end;
end;
function Str2Int(s: string): integer;
begin
try
result := StrToIntDef(trim(s),0);
except
result := 0;
end;
end;
function Int2Str(i: integer): string;
begin
try
result := IntToStr(i);
except
result := '0';
end;
end;
function Str2Dbl(s: string; default: double): double;
begin
try
result := StrToFloat(trim(s))
except
result := default;
end; {try}
end;
end.
View Online Proteus Documentation
Return
to Proteus Research
Contact info@artificialingenuity.com
Copyright © 2005 Artificial Ingenuity, LLC
Last modified: June 11, 2005
Initial design by Webinizer, LLC