新未名空间

此帖转自 guvest 在 葵花宝典（Programming） 的帖子：pascal Agent程序

AI改改，比我原来的强。一共 6个tool。 可读性可维护性好多了。

function ToolRead(AArgs: TJSONObject): string;
function ToolWrite(AArgs: TJSONObject): string;
function ToolEdit(AArgs: TJSONObject): string;
function ToolGlob(AArgs: TJSONObject): string;
function ToolGrep(AArgs: TJSONObject): string;
function ToolBash(AArgs: TJSONObject): string;

openrouter免费一个model,直接可以用来测试。速度其实也不是慢到不能用。
FModel := 'openrouter/free';

目前上下文全部累计。没有高级上下文管理的逻辑。没有挂internet search，RAG 等高级tool。

如果让我说这个代码哪行，哪块干什么的，肯定没有AI说的好。

unit MainForm;

{$mode objfpc}{$H+}

interface

uses
Classes, SysUtils, Math, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtCtrls,
ComCtrls, fpjson, jsonparser, fphttpclient, opensslsockets, RegExpr,
Process, FileUtil, LazFileUtils;

type
TToolDef = record
Name: string;
Description: string;
Params: string; // JSON-like definition
end;

{ TFormMain }

TFormMain = class(TForm)
btnSend: TButton;
btnClear: TButton;
btnExecute: TButton;
btnReject: TButton;
edtInput: TMemo;
lblStatus: TLabel;
memoChat: TMemo;
memoToolPreview: TMemo;
pnlInput: TPanel;
pnlToolConfirm: TPanel;
splitter: TSplitter;
procedure btnClearClick(Sender: TObject);
procedure btnExecuteClick(Sender: TObject);
procedure btnRejectClick(Sender: TObject);
procedure btnSendClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FMessages: TJSONArray;
FPendingToolCalls: TJSONArray;
FCurrentToolIndex: Integer;
FAPI_URL: string;
FAPI_KEY: string;
FModel: string;
FSystemPrompt: string;
procedure AddChatLine(const AText: string; AColor: TColor = clBlack);
procedure CallAPI;
procedure ProcessResponse(AResponse: TJSONObject);
procedure ShowNextToolConfirmation;
procedure ExecuteCurrentTool;
function RunTool(const AName: string; AArgs: TJSONObject): string;
function MakeSchema: TJSONArray;
// Tool implementations
function ToolRead(AArgs: TJSONObject): string;
function ToolWrite(AArgs: TJSONObject): string;
function ToolEdit(AArgs: TJSONObject): string;
function ToolGlob(AArgs: TJSONObject): string;
function ToolGrep(AArgs: TJSONObject): string;
function ToolBash(AArgs: TJSONObject): string;
public
end;

var
FormMain: TFormMain;

implementation

{$R *.lfm}

const
OPENROUTER_KEY =
OPENROUTER_SITE_URL = '';
OPENROUTER_SITE_NAME = '';

{ TFormMain }

procedure TFormMain.FormCreate(Sender: TObject);
begin
FMessages := TJSONArray.Create;
FPendingToolCalls := nil;
FCurrentToolIndex := 0;

if OPENROUTER_KEY <> '' then
begin
FAPI_URL := 'https://openrouter.ai/api/v1/messages';
FAPI_KEY := OPENROUTER_KEY;
FModel := 'openrouter/free';
end;

FSystemPrompt := 'Concise coding assistant. cwd: ' + GetCurrentDir;

pnlToolConfirm.Visible := False;
lblStatus.Caption := 'Model: ' + FModel + ' | ' + GetCurrentDir;

AddChatLine('Code Agent initialized. Enter your request below.', clGray);
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
FMessages.Free;
if Assigned(FPendingToolCalls) then
FPendingToolCalls.Free;
end;

procedure TFormMain.AddChatLine(const AText: string; AColor: TColor);
begin
memoChat.Lines.Add(AText);
memoChat.SelStart := Length(memoChat.Text);
end;

procedure TFormMain.btnSendClick(Sender: TObject);
var
UserText: string;
UserMsg: TJSONObject;
begin
UserText := Trim(edtInput.Text);
if UserText = '' then Exit;

AddChatLine('----------------------------------------', clSilver);
AddChatLine('You: ' + UserText, clNavy);
AddChatLine('----------------------------------------', clSilver);

UserMsg := TJSONObject.Create;
UserMsg.Add('role', 'user');
UserMsg.Add('content', UserText);
FMessages.Add(UserMsg);

edtInput.Clear;
btnSend.Enabled := False;
lblStatus.Caption := 'Calling API...';
Application.ProcessMessages;

try
CallAPI;
finally
btnSend.Enabled := True;
lblStatus.Caption := 'Ready';
end;
end;

procedure TFormMain.btnClearClick(Sender: TObject);
begin
FMessages.Free;
FMessages := TJSONArray.Create;
memoChat.Clear;
AddChatLine('Conversation cleared.', clGray);
end;

procedure TFormMain.btnExecuteClick(Sender: TObject);
begin
ExecuteCurrentTool;
Inc(FCurrentToolIndex);
ShowNextToolConfirmation;
end;

procedure TFormMain.btnRejectClick(Sender: TObject);
var
ToolBlock: TJSONObject;
ToolResults: TJSONArray;
ResultObj: TJSONObject;
UserMsg: TJSONObject;
i: Integer;
begin
// Reject remaining tools
ToolResults := TJSONArray.Create;
for i := FCurrentToolIndex to FPendingToolCalls.Count - 1 do
begin
ToolBlock := FPendingToolCalls.Objects;
ResultObj := TJSONObject.Create;
ResultObj.Add('type', 'tool_result');
ResultObj.Add('tool_use_id', ToolBlock.Strings['id']);
ResultObj.Add('content', 'Tool execution rejected by user');
ToolResults.Add(ResultObj);
AddChatLine(' [X] Rejected: ' + ToolBlock.Strings['name'], clRed);
end;

if ToolResults.Count > 0 then
begin
UserMsg := TJSONObject.Create;
UserMsg.Add('role', 'user');
UserMsg.Add('content', ToolResults);
FMessages.Add(UserMsg);
end
else
ToolResults.Free;

FreeAndNil(FPendingToolCalls);
pnlToolConfirm.Visible := False;
btnSend.Enabled := True;
end;

procedure TFormMain.CallAPI;
var
HTTP: TFPHTTPClient;
RequestBody: TJSONObject;
ResponseStr: string;
ResponseJSON: TJSONObject;
ReqStream: TStringStream;
RespStream: TMemoryStream;
begin
HTTP := TFPHTTPClient.Create(nil);
try
HTTP.AddHeader('Content-Type', 'application/json');
HTTP.AddHeader('anthropic-version', '2023-06-01');
if OPENROUTER_KEY <> '' then
begin
HTTP.AddHeader('Authorization', 'Bearer ' + FAPI_KEY);
if OPENROUTER_SITE_URL <> '' then
HTTP.AddHeader('HTTP-Referer', OPENROUTER_SITE_URL);
if OPENROUTER_SITE_NAME <> '' then
HTTP.AddHeader('X-OpenRouter-Title', OPENROUTER_SITE_NAME);
end
else
HTTP.AddHeader('x-api-key', FAPI_KEY);

RequestBody := TJSONObject.Create;
try
  RequestBody.Add('model', FModel);
  RequestBody.Add('max_tokens', 8192);
  RequestBody.Add('system', FSystemPrompt);
  RequestBody.Add('messages', FMessages.Clone);
  RequestBody.Add('tools', MakeSchema);

  ReqStream := TStringStream.Create(RequestBody.AsJSON);
  RespStream := TMemoryStream.Create;
  try
    HTTP.RequestBody := ReqStream;
    HTTP.Post(FAPI_URL, RespStream);
    RespStream.Position := 0;
    SetLength(ResponseStr, RespStream.Size);
    RespStream.Read(ResponseStr[1], RespStream.Size);
  finally
    ReqStream.Free;
    RespStream.Free;
  end;
finally
  RequestBody.Free;
end;

ResponseJSON := GetJSON(ResponseStr) as TJSONObject;
try
  ProcessResponse(ResponseJSON);
finally
  ResponseJSON.Free;
end;

except
on E: Exception do
AddChatLine('Error: ' + E.Message, clRed);
end;
HTTP.Free;
end;

procedure TFormMain.ProcessResponse(AResponse: TJSONObject);
var
ErrorData: TJSONData;
ErrorObj: TJSONObject;
ErrorMsg: string;
ContentData: TJSONData;
ContentBlocks: TJSONArray;
Block: TJSONObject;
i: Integer;
AssistantMsg: TJSONObject;
begin
// OpenRouter/OpenAI error shape: { "error": { "message": "..." } }
ErrorData := AResponse.Find('error');
if (ErrorData <> nil) and (ErrorData is TJSONObject) then
begin
ErrorObj := TJSONObject(ErrorData);
ErrorMsg := ErrorObj.Get('message', ErrorObj.AsJSON);
AddChatLine('API Error: ' + ErrorMsg, clRed);
Exit;
end;

// Anthropic/OpenRouter messages response shape -> content[]
ContentData := AResponse.Find('content');
if (ContentData <> nil) and (ContentData is TJSONArray) then
begin
ContentBlocks := TJSONArray(ContentData);
end
else
begin
AddChatLine('Error: Unexpected response shape: ' + AResponse.AsJSON, clRed);
Exit;
end;

// Store assistant message
AssistantMsg := TJSONObject.Create;
AssistantMsg.Add('role', 'assistant');
AssistantMsg.Add('content', ContentBlocks.Clone);
FMessages.Add(AssistantMsg);

// Collect tool calls
if Assigned(FPendingToolCalls) then
FPendingToolCalls.Free;
FPendingToolCalls := TJSONArray.Create;
FCurrentToolIndex := 0;

for i := 0 to ContentBlocks.Count - 1 do
begin
Block := ContentBlocks.Objects;
if Block = nil then
Continue;

if Block.Get('type', '') = 'text' then
begin
  AddChatLine('');
  AddChatLine('Assistant: ' + Block.Get('text', ''), clTeal);
end
else if Block.Get('type', '') = 'tool_use' then
  FPendingToolCalls.Add(Block.Clone);

end;

// Show tool confirmation if needed
if FPendingToolCalls.Count > 0 then
ShowNextToolConfirmation
else
begin
FreeAndNil(FPendingToolCalls);
btnSend.Enabled := True;
end;
end;

procedure TFormMain.ShowNextToolConfirmation;
var
ToolBlock: TJSONObject;
ToolName: string;
ToolArgs: TJSONObject;
begin
if (FPendingToolCalls = nil) or (FCurrentToolIndex >= FPendingToolCalls.Count) then
begin
// All tools processed, continue conversation
pnlToolConfirm.Visible := False;

// Send tool results and call API again
if Assigned(FPendingToolCalls) and (FPendingToolCalls.Count > 0) then
begin
  lblStatus.Caption := 'Continuing...';
  Application.ProcessMessages;
  CallAPI;
end;

FreeAndNil(FPendingToolCalls);
btnSend.Enabled := True;
lblStatus.Caption := 'Ready';
Exit;

end;

ToolBlock := FPendingToolCalls.Objects[FCurrentToolIndex];
ToolName := ToolBlock.Strings['name'];
ToolArgs := ToolBlock.Objects['input'];

memoToolPreview.Clear;
memoToolPreview.Lines.Add('Tool: ' + ToolName);
memoToolPreview.Lines.Add('');
memoToolPreview.Lines.Add('Arguments:');
memoToolPreview.Lines.Add(ToolArgs.FormatJSON);

pnlToolConfirm.Visible := True;
btnSend.Enabled := False;
lblStatus.Caption := Format('Tool %d of %d: %s', [FCurrentToolIndex + 1, FPendingToolCalls.Count, ToolName]);
end;

procedure TFormMain.ExecuteCurrentTool;
var
ToolBlock: TJSONObject;
ToolName: string;
ToolArgs: TJSONObject;
ToolResult: string;
ResultObj: TJSONObject;
UserMsg: TJSONObject;
ExistingContent: TJSONData;
ToolResults: TJSONArray;
begin
ToolBlock := FPendingToolCalls.Objects[FCurrentToolIndex];
ToolName := ToolBlock.Strings['name'];
ToolArgs := ToolBlock.Objects['input'];

AddChatLine('');
AddChatLine('[>] ' + ToolName + '(' + ToolArgs.AsJSON + ')', clGreen);

ToolResult := RunTool(ToolName, ToolArgs);

// Show preview of result
if Length(ToolResult) > 200 then
AddChatLine(' -> ' + Copy(ToolResult, 1, 200) + '...', clGray)
else
AddChatLine(' -> ' + ToolResult, clGray);

// Add tool result to messages
// Check if last message is already a user message with tool_results
if (FMessages.Count > 0) and
(FMessages.Objects[FMessages.Count - 1].Strings['role'] = 'user') then
begin
ExistingContent := FMessages.Objects[FMessages.Count - 1].Find('content');
if (ExistingContent <> nil) and (ExistingContent is TJSONArray) then
begin
ResultObj := TJSONObject.Create;
ResultObj.Add('type', 'tool_result');
ResultObj.Add('tool_use_id', ToolBlock.Strings['id']);
ResultObj.Add('content', ToolResult);
TJSONArray(ExistingContent).Add(ResultObj);
Exit;
end;
end;

// Create new user message with tool result
ToolResults := TJSONArray.Create;
ResultObj := TJSONObject.Create;
ResultObj.Add('type', 'tool_result');
ResultObj.Add('tool_use_id', ToolBlock.Strings['id']);
ResultObj.Add('content', ToolResult);
ToolResults.Add(ResultObj);

UserMsg := TJSONObject.Create;
UserMsg.Add('role', 'user');
UserMsg.Add('content', ToolResults);
FMessages.Add(UserMsg);
end;

function TFormMain.RunTool(const AName: string; AArgs: TJSONObject): string;
begin
try
if AName = 'read' then Result := ToolRead(AArgs)
else if AName = 'write' then Result := ToolWrite(AArgs)
else if AName = 'edit' then Result := ToolEdit(AArgs)
else if AName = 'glob' then Result := ToolGlob(AArgs)
else if AName = 'grep' then Result := ToolGrep(AArgs)
else if AName = 'bash' then Result := ToolBash(AArgs)
else Result := 'error: unknown tool ' + AName;
except
on E: Exception do
Result := 'error: ' + E.Message;
end;
end;

function TFormMain.MakeSchema: TJSONArray;

function MakeTool(const AName, ADesc: string; AProps: TJSONObject; ARequired: TJSONArray): TJSONObject;
var
Schema: TJSONObject;
begin
Result := TJSONObject.Create;
Result.Add('name', AName);
Result.Add('description', ADesc);
Schema := TJSONObject.Create;
Schema.Add('type', 'object');
Schema.Add('properties', AProps);
Schema.Add('required', ARequired);
Result.Add('input_schema', Schema);
end;

var
Props: TJSONObject;
Req: TJSONArray;
begin
Result := TJSONArray.Create;

// read
Props := TJSONObject.Create;
Props.Add('path', TJSONObject.Create(['type', 'string']));
Props.Add('offset', TJSONObject.Create(['type', 'integer']));
Props.Add('limit', TJSONObject.Create(['type', 'integer']));
Req := TJSONArray.Create;
Req.Add('path');
Result.Add(MakeTool('read', 'Read file with line numbers (file path, not directory)', Props, Req));

// write
Props := TJSONObject.Create;
Props.Add('path', TJSONObject.Create(['type', 'string']));
Props.Add('content', TJSONObject.Create(['type', 'string']));
Req := TJSONArray.Create;
Req.Add('path');
Req.Add('content');
Result.Add(MakeTool('write', 'Write content to file', Props, Req));

// edit
Props := TJSONObject.Create;
Props.Add('path', TJSONObject.Create(['type', 'string']));
Props.Add('old', TJSONObject.Create(['type', 'string']));
Props.Add('new', TJSONObject.Create(['type', 'string']));
Props.Add('all', TJSONObject.Create(['type', 'boolean']));
Req := TJSONArray.Create;
Req.Add('path');
Req.Add('old');
Req.Add('new');
Result.Add(MakeTool('edit', 'Replace old with new in file (old must be unique unless all=true)', Props, Req));

// glob
Props := TJSONObject.Create;
Props.Add('pat', TJSONObject.Create(['type', 'string']));
Props.Add('path', TJSONObject.Create(['type', 'string']));
Req := TJSONArray.Create;
Req.Add('pat');
Result.Add(MakeTool('glob', 'Find files by pattern, sorted by mtime', Props, Req));

// grep
Props := TJSONObject.Create;
Props.Add('pat', TJSONObject.Create(['type', 'string']));
Props.Add('path', TJSONObject.Create(['type', 'string']));
Req := TJSONArray.Create;
Req.Add('pat');
Result.Add(MakeTool('grep', 'Search files for regex pattern', Props, Req));

// bash
Props := TJSONObject.Create;
Props.Add('cmd', TJSONObject.Create(['type', 'string']));
Req := TJSONArray.Create;
Req.Add('cmd');
Result.Add(MakeTool('bash', 'Run shell command', Props, Req));
end;

function TFormMain.ToolRead(AArgs: TJSONObject): string;
var
SL: TStringList;
FilePath: string;
Offset, Limit, i: Integer;
begin
FilePath := AArgs.Strings['path'];
if not FileExists(FilePath) then
Exit('error: file not found');

SL := TStringList.Create;
try
SL.LoadFromFile(FilePath);
Offset := AArgs.Get('offset', 0);
Limit := AArgs.Get('limit', SL.Count);

Result := '';
for i := Offset to Min(Offset + Limit - 1, SL.Count - 1) do
  Result := Result + Format('%4d| %s' + LineEnding, [i + 1, SL[i]]);

if Result = '' then
  Result := '(empty file)';

finally
SL.Free;
end;
end;

function TFormMain.ToolWrite(AArgs: TJSONObject): string;
var
SL: TStringList;
begin
SL := TStringList.Create;
try
SL.Text := AArgs.Strings['content'];
SL.SaveToFile(AArgs.Strings['path']);
Result := 'ok';
finally
SL.Free;
end;
end;

function TFormMain.ToolEdit(AArgs: TJSONObject): string;
var
SL: TStringList;
Content, OldStr, NewStr: string;
Count, i: Integer;
DoAll: Boolean;
begin
if not FileExists(AArgs.Strings['path']) then
Exit('error: file not found');

SL := TStringList.Create;
try
SL.LoadFromFile(AArgs.Strings['path']);
Content := SL.Text;
OldStr := AArgs.Strings['old'];
NewStr := AArgs.Strings['new'];
DoAll := AArgs.Get('all', False);

if Pos(OldStr, Content) = 0 then
  Exit('error: old_string not found');

// Count occurrences
Count := 0;
i := 1;
while i <= Length(Content) do
begin
  if Copy(Content, i, Length(OldStr)) = OldStr then
  begin
    Inc(Count);
    i := i + Length(OldStr);
  end
  else
    Inc(i);
end;

if (not DoAll) and (Count > 1) then
  Exit(Format('error: old_string appears %d times, must be unique (use all=true)', [Count]));

if DoAll then
  Content := StringReplace(Content, OldStr, NewStr, [rfReplaceAll])
else
  Content := StringReplace(Content, OldStr, NewStr, []);

SL.Text := Content;
SL.SaveToFile(AArgs.Strings['path']);
Result := 'ok';

finally
SL.Free;
end;
end;

function TFormMain.ToolGlob(AArgs: TJSONObject): string;
var
Pattern, BasePath: string;
Files: TStringList;
begin
Pattern := AArgs.Strings['pat'];
BasePath := AArgs.Get('path', '.');

Files := TStringList.Create;
try
FindAllFiles(Files, BasePath, Pattern, True);
if Files.Count = 0 then
Result := 'none'
else
Result := Files.Text;
finally
Files.Free;
end;
end;

function TFormMain.ToolGrep(AArgs: TJSONObject): string;
var
Pattern, BasePath: string;
Regex: TRegExpr;
Files, Hits: TStringList;
SL: TStringList;
i, j: Integer;
begin
Pattern := AArgs.Strings['pat'];
BasePath := AArgs.Get('path', '.');

Regex := TRegExpr.Create(Pattern);
Files := TStringList.Create;
Hits := TStringList.Create;
SL := TStringList.Create;
try
FindAllFiles(Files, BasePath, '*', True);

for i := 0 to Files.Count - 1 do
begin
  if Hits.Count >= 50 then Break;
  try
    SL.LoadFromFile(Files[i]);
    for j := 0 to SL.Count - 1 do
    begin
      if Regex.Exec(SL[j]) then
      begin
        Hits.Add(Format('%s:%d:%s', [Files[i], j + 1, SL[j]]));
        if Hits.Count >= 50 then Break;
      end;
    end;
  except
    // Skip files that can't be read
  end;
end;

if Hits.Count = 0 then
  Result := 'none'
else
  Result := Hits.Text;

finally
SL.Free;
Hits.Free;
Files.Free;
Regex.Free;
end;
end;

function TFormMain.ToolBash(AArgs: TJSONObject): string;
var
Proc: TProcess;
OutputStream: TMemoryStream;
BytesRead: LongInt;
Buffer: array[0..4095] of Byte;
begin
Proc := TProcess.Create(nil);
OutputStream := TMemoryStream.Create;
try
{$IFDEF WINDOWS}
Proc.Executable := 'cmd.exe';
Proc.Parameters.Add('/c');
Proc.Parameters.Add(AArgs.Strings['cmd']);
{$ELSE}
Proc.Executable := '/bin/sh';
Proc.Parameters.Add('-c');
Proc.Parameters.Add(AArgs.Strings['cmd']);
{$ENDIF}
Proc.Options := [poUsePipes, poStderrToOutPut, poWaitOnExit];
Proc.Execute;

// Read all output
repeat
  BytesRead := Proc.Output.Read(Buffer, SizeOf(Buffer));
  if BytesRead > 0 then
    OutputStream.Write(Buffer, BytesRead);
until BytesRead = 0;

if OutputStream.Size = 0 then
  Result := '(empty)'
else
begin
  SetLength(Result, OutputStream.Size);
  OutputStream.Position := 0;
  OutputStream.Read(Result[1], OutputStream.Size);
end;

finally
OutputStream.Free;
Proc.Free;
end;
end;

end.

五十三来玩玩。数据结构绿皮书，用pascal的。应该不少人学过。