聪明二休-程序结构.txt

用AIML语言开发的一款中文自动聊天软件

  Chat: TChat;

implementation
Uses
  UPatternMatcher,UTemplateProcessor,UVariables,ULogging,LibXMLParser;

  Procedure TChat.Add(s:string);
    begin
      RichEdit1.Lines.Add(s);
      RichEdit1.SelStart:=Length(RichEdit1.TExt);
      SendMessage(RichEdit1.Handle,EM_SCROLLCARET,0,0);
    end;
  Procedure TChat.AddUserInput(s:string);
    var name:string;
    begin

      RichEdit1.SelStart:=Length(RichEdit1.TExt);
      with RichEdit1.SelAttributes do begin
          Color := clMaroon;
          Style := [];
      end;
      Add('> '+s);
      name:=Memory.getVar('name');
      if name='' then name:='用户';
      Log.chatlog(name,s);
    end;
  Procedure TChat.AddBotReply(s:string);
    begin
      if s='' then exit;
      RichEdit1.SelStart:=Length(RichEdit1.TExt);
      with RichEdit1.SelAttributes do begin
          Color := clBlack;
          Style := [];
      end;
      Add(s);
      Log.Chatlog(Memory.GetProp('name'),s);

    end;
  Procedure TChat.AddLogMessage(s:string);
    begin
      RichEdit1.SelStart:=Length(RichEdit1.TExt);
      with RichEdit1.SelAttributes do begin
          Color := clBlue;
          Style := [];
      end;
      Add(s);
    end;
{$R *.DFM}

procedure TChat.Button1Click(Sender: TObject);
var
  reply:string;
  Match:TMatch;
  input:String;
  i:integer;
begin
  input:=Memo1.Text;
  AddUserInput(input);
  Memory.setVar('input',input);
  input:=Trim(ConvertWS(Preprocessor.process(' '+input+' '),true));

  _SentenceSplitter.SetDelimiter(SentenceSplitterChars); {update, if we're still loading}
  _SentenceSplitter.Tokenize(input);

  for i:=0 to _SentenceSplitter._count-1 do begin
    input:=Trim(_SentenceSplitter._tokens[i]);
    Match:=PatternMatcher.MatchInput(input);
    reply:=TemplateProcessor.Process(match);
    match.free;
  end;

  AddBotReply(reply);
  //AddLogMessage('Nodes traversed: '+inttostr(PatternMatcher._matchfault));
  Add('');
  reply:=PreProcessor.process(reply);
  _SentenceSplitter.SetDelimiter(SentenceSplitterChars);
  _SentenceSplitter.Tokenize(reply);

  Memory.setVar('that',_SentenceSplitter.GetLast);
  Memo1.Clear;
end;

procedure TChat.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Application.TErminate;
end;

procedure TChat.FormCreate(Sender: TObject);
begin
  Log.Log('正在启动 Operator Chat...');
  Log.Flush;
  _LoaderThread:=TBotLoaderThread.Create(true);
  //BotLoader.load('startup.xml');
  _LoaderThread.Resume;
  _SentenceSplitter:=TStringTokenizer.Create(SentenceSplitterChars);
end;

procedure TChat.RichEdit1MouseWheel(Sender: TObject; Shift: TShiftState;
  WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
begin
  SendMessage(RichEdit1.Handle,EM_LINESCROLL,0,-(WheelDelta div 120)*Mouse.WheelScrollLines);
  handled:=true;
end;

end.

-------------------------------------------------------------------------------

unit UBotLoader;

interface
uses LibXMLParser,UAIMLLoader,classes, UPAtternMatcher;
type
  TBotloaderThread=class(TThread)
    procedure Execute;override;
  end;
  TBotLoader=class
    loaded:boolean;
    parser:TXmlParser;

    procedure load(filename:string);
    Function BotElement:boolean;
    function SentenceSplitters:boolean;
    function InputSubstitutions:boolean;
    Function PropertyElement:boolean;
    Function LearnElement:boolean;
  end;
var
  Botloader:TBotLoader;
implementation
  uses SysUtils,UVariables,ULogging,UUtils;
  procedure TBotLoaderThread.Execute;
    begin
      FreeOnTerminate:=true;
      BotLoader.load('startup.xml');
    end;
  function TBotLoader.PropertyElement:boolean;
    var
      prop,val:string;
    begin
      result:=true;
      prop:=Parser.CurAttr.Value('name');
      val:=Parser.CurAttr.Value('value');

      if (prop='') or (val ='') then
        result:=false
      else begin
        Memory.setProp(prop,val);
        //log.Log('botloader','机器人属性 '+prop+'="'+val+'"');
      end;
      SkipElement(Parser);
    end;
  function TBotLoader.LearnElement:boolean;
    begin
      While parser.scan do
        if (parser.CurPartType=ptEndTag)and(parser.Curname='learn') then
          break;
      if Parser.CurContent<>'' then begin
        AIMLLoader.load(Parser.CurContent);
        loaded:=true;
        result:=true;
      end else
        result:=false;

    end;
  function TBotLoader.BotElement:boolean;
    var
      numprops:integer;
      bot_ID:string;
    begin
      result:=true;
      numprops:=0;
      bot_ID:=Parser.CurAttr.Value('id');
      if AnsiSameStr(Parser.CurAttr.Value('enabled'),'false') then Begin
        Log.Log('botloader','机器人 '''+bot_id+''' 已不可用。');
        skipElement(parser);
        exit;
      end;
      Log.Log('botloader','加载机器人 '''+bot_id+'''');
      Log.OpenChatLog(bot_ID);
      Memory.bot_ID:=bot_ID;
      Memory.Load;
      while (parser.scan) do
        case Parser.CurPartType of
          ptStartTag,
          ptEmptyTag:begin
                       if parser.CurName='property' then begin
                         if PropertyElement then inc(numprops);
                       end else
                       if parser.CurName='learn' then
                         LearnElement;
                     end;
          ptEndTag:if parser.curname='bot' then break;
        end;
      Log.log('botloader','共加载 '+inttostr(numprops)+ ' 个属性。');
    end;
  function TBotLoader.SentenceSplitters:boolean;
    var
      val:string;
      count:integer;
    begin
      count:=0;
      result:=true;
      if parser.CurPartType=ptEmptyTag then exit;
      while Parser.Scan do
        case Parser.CurPartType of
          ptStartTag,
          ptEmptyTag:if parser.Curname='splitter' then begin
                       val:=Parser.CurAttr.Value('value');
                       if val<>'' then SentenceSplitterChars:=SentenceSplitterChars+val;
                       inc(count);
                     end;
          ptEndTag:if parser.CurName='sentence-splitters' then break;
        end;
      Log.Log('botloader','共加载 '+inttostr(count)+' 个句子过滤。');
    end;
  function TBotLoader.InputSubstitutions:boolean;
    var
      _from,_to:string;
      count:integer;
    begin
      count:=0;
      result:=true;
      if parser.CurPartType=ptEmptyTag then exit;
      while Parser.Scan do
        case Parser.CurPartType of
          ptStartTag,
          ptEmptyTag:if parser.Curname='substitute' then begin
                       _from:=Parser.CurAttr.Value('find');
                       _to:=Parser.CurAttr.Value('replace');
                       Preprocessor.add(_from,_to);
                       inc(count);
                     end;
          ptEndTag:if parser.CurName='input' then break;
        end;
      Log.Log('botloader','共加载 '+inttostr(count)+' 个输入替换。');
    end;

  procedure TBotLoader.load(filename:string);
    begin
      if loaded then Begin
        Log.Log('botloader','已经加载了一个机器人。');
        exit; {不能在同一时间加载两个机器人}
      end;
      Log.Log('botloader','加载 '+filename+'...');
      parser:=TXmlParser.Create;
      parser.Normalize:=true;
      parser.LoadFromFile(filename);
      parser.startscan;
      while parser.Scan do
        case parser.CurPartType of
          ptStartTag:if parser.CurName='bot' then BotElement else
                     if parser.CurName='sentence-splitters' then SentenceSplitters else
                     if parser.CurName='input' then InputSubstitutions;
        end;
      parser.clear;
      parser.free;
      Log.Log('botloader','完成。');
      Log.Log('botloader',inttostr(Nodecount));
    end;

end.

--------------------------------------------------------------------------

unit ULogging;

interface
uses classes;
type
  TLog=class
    _Disabled:TStringList;
    _LogCache:TStringList;
    _ChatlogFile:System.Text;
    _writechatlog:boolean;
    constructor create;
    procedure OpenChatLog(bot_id:string);
    Procedure Disable(kind:string);
    procedure Enable(kind:string);
    Procedure Log(s:string);overload;
    Procedure Log(kind:string;s:string);overload;
    procedure Flush;
    Procedure ChatLog(who,what:string);
    destructor destroy;override;
  end;
var
  Log:TLog;
implementation
uses UChat,SysUtils;
  constructor TLog.create;
    begin
      inherited Create;
      _LogCache:=TStringList.Create;
      _Disabled:=TStringList.Create;
      _Disabled.Duplicates:=dupIgnore;
      _writechatlog:=false;
    end;
  destructor TLog.Destroy;
    begin
      _Disabled.Free;
      _LogCache.Free;
      if _writechatlog then
        closefile(_chatlogfile);
      inherited destroy;
    end;
  procedure TLog.OpenChatLog(bot_id:string);
    begin
      try
        AssignFile(_ChatlogFile,bot_id+'.chatlog');
        if FileExists(bot_id+'.chatlog') then
          Append(_ChatLogFile)
        else
          rewrite(_ChatLogFile);
        Writeln(_ChatLogFile);
        Writeln(_ChatLogFile,DateTimeToStr(now));

        _writechatlog:=true;
        Log('log','聊天日志将被存储为文件 '+bot_id+'.chatlog');
      except
        _writechatlog:=false;
        Log('log','无法写聊天日志文件，聊天日志功能将被禁用。');
      end;
    end;
  procedure Tlog.Disable(kind:string);
    begin
      _Disabled.Add(kind);
    end;
  procedure Tlog.Enable(kind:string);
    var
      i:integer;
    begin
      i:=_Disabled.Indexof(kind);
      if i>=0 then
        _Disabled.Delete(i);
    end;
  procedure TLog.Flush;
    var i:integer;
    begin
      if assigned(chat) then begin
        for i:=0 to _LogCache.count-1 do
          Chat.AddLogMessage(_LogCache.Strings[i]);
        _LogCache.Clear;
      end;
    end;
  Procedure TLog.Log(kind:string;s:string);
    begin
      if _Disabled.indexof(kind)=-1 then
        Log(kind+': '+s)
    end;
  Procedure TLog.Log(s:string);
    begin
      if assigned(chat) then
        Chat.AddLogMessage(s)
      else
        _LogCache.Add(s);
    end;
  Procedure TLog.ChatLog(who,what:string);
    begin
      if _writechatlog then
        Writeln(_chatlogfile,Who,'> ',what);
    end;
end.

-----------------------------------------------------------------------------
unit UUtils;
{general utility methods for parsing strings and TXMLParser elements}
interface
uses
  classes,LibXMLParser;
type
  TStringTokenizer=class
    _tokens:TStringList;
    _count:integer;
    _delim:string;
    _string:string;
    constructor Create(delimiter:String);
    procedure SetDelimiter(delimiter:String);
    procedure Tokenize(s:string);
    function getFirst:string;
    function getLast:string;
    function get(i:integer):string;

  end;

  TSimpleSubstituter=class
    _substFrom,
    _substTo:TStringlist;
    constructor create;
    destructor destroy;override;
    procedure add(_from,_to:string);
    function process(s:string):string;
  end;

procedure WrFile(fname:string;s:string);
procedure SkipElement(Name:string;Parser:TXMLParser);overload;
procedure SkipElement(Parser:TXMLParser);overload;
function  GetElementContents(Parser:TXMLParser):string;

Var
  SentenceSplitterChars:string;
  Preprocessor:TSimpleSubstituter;
implementation
  Uses SysUtils;
  procedure WrFile(fname:string;s:string);
    var
      t:System.text;
    begin
      assignfile(t,fname);
      if FileExists(fname) then
        append(t)
      else
        rewrite(t);
      writeln(t,s);
      flush(t);
      closefile(t);
    end;

  procedure SkipElement(Parser:TXMLParser);
    begin
      SkipElement(parser.CurName,parser);
    end;
  procedure SkipElement(Name:string;Parser:TXMLParser);
    var
      nested:integer;
    begin
      with parser do begin
        if (CurPartType=ptEmptyTag) and (CurName=name)then exit;
        nested:=0;
        while scan do
          case curparttype of
            ptstarttag:if CurName=name then inc(nested);
            ptEndTag:if Curname=name then
                       if nested=0 then break
                       else dec(nested);
          end;
      end;
  end;

  function GetElementContents(Parser:TXMLParser):string;