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.