Дипломная работа: Проектирование и разработка сетевых броузеров на основе теоретико-графовых моделей

begin

SubItems.Add(IntToStr(Size div 1024));

SubItems[0] := SubItems[0] + 'KB';

end

else

SubItems.Add(Size);

end

else

SubItems.Add('');

if Attributes = '1' then

begin

SubItems.Add('File Folder');

ImageIndex := 3;

end

else

begin

Ext := ExtractFileExt(FileName);

ShGetFileInfo(PChar('c:\*' + Ext), 0, SHFileInfo, SizeOf(SHFileInfo),

SHGFI_SMALLICON or SHGFI_SYSICONINDEX or SHGFI_TYPENAME);

if Length(SHFileInfo.szTypeName) = 0 then

begin

if Length(Ext) > 0 then

begin

System.Delete(Ext, 1, 1);

SubItems.Add(Ext + ' File');

end

else

SubItems.Add('File');

end

else

SubItems.Add(SHFileInfo.szTypeName);

ImageIndex := SHFileInfo.iIcon;

end;

SubItems.Add(Date);

end;

procedure TMyFtp.Disconnect;

begin

FTP.Quit;

Application.ProcessMessages;

end;

procedure TMyFtp.FormCreate(Sender: TObject);

var

SHFileInfo: TSHFileInfo;

begin

with DirTree do

begin

DirTree.Images := SmallImages;

SmallImages.ResourceLoad(rtBitmap, 'IMAGES', clOlive);

end;

with FileList do

begin

mallImages := TImageList.CreateSize(16,16);

SmallImages.ShareImages := True;

SmallImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,

SizeOf(SHFileInfo), SHGFI_SMALLICON or SHGFI_ICON or SHGFI_SYSICONINDEX);

LargeImages := TImageList.Create(nil);

LargeImages.ShareImages := True;

LargeImages.Handle := ShGetFileInfo('*.*', 0, SHFileInfo,

SizeOf(SHFileInfo), SHGFI_LARGEICON or SHGFI_ICON or SHGFI_SYSICONINDEX);

end;

procedure TMyFtp.FTPBusy(Sender: TObject; isBusy: Wordbool);

begin

if isBusy then

begin

Screen.Cursor := crHourGlass;

FileList.Items.BeginUpdate;

FileList.Items.Clear;

end

else

begin

Screen.Cursor := crDefault;

FileList.Items.EndUpdate;

end;

function TMyFtp.NodePath(Node: TTreeNode): String;

begin

if Node = Root then

Result := '.'

else

Result := NodePath(Node.Parent) + '/' + Node.Text;

end;

procedure TMyFtp.DirTreeChange(Sender: TObject; Node: TTreeNode);

var

NP: String;

begin

if (FTP.State <> prcConnected) or FTP.Busy then exit;

if Node <> nil then

begin

NP := NodePath(DirTree.Selected);

FTP.List(NP);

Label2.Caption := Format('Contents of: ''%s/''',[NP]);

end;

procedure TMyFtp.RefreshBtnClick(Sender: TObject);

begin

FTP.List(NodePath(DirTree.Selected));

end;

procedure TMyFtp.DirTreeChanging(Sender: TObject; Node: TTreeNode;

var AllowChange: Boolean);

begin

AllowChange := not FTP.Busy;

end;

procedure TMyFtp.FTPStateChanged(Sender: TObject; State: Smallint);

begin

with FTP, Statusbar.Panels[0] do

case State of

prcConnecting : Text := 'Connecting';

prcResolvingHost: Text := 'Connecting';

prcHostResolved : Text := 'Host resolved';

prcConnected :

begin

Text := 'Connected to: ' + RemoteHost;

ConnectBtn.Hint := 'Disconnect';

FileNewItem.Enabled := True;

ViewLargeItem.Enabled := True;

ViewSmallItem.Enabled := True;

ViewListItem.Enabled := True;

ViewDetailsItem.Enabled := True;

ViewRefreshItem.Enabled := True;

ToolsDisconnectItem.Enabled := True;

LargeBtn.Enabled := True;

SmallBtn.Enabled := True;

ListBtn.Enabled := True;

DetailsBtn.Enabled := True;

RefreshBtn.Enabled := True;

end;

prcDisconnecting: Text := 'Disconnecting';

prcDisconnected :

begin

Text := 'Disconnected';

ConnectBtn.Hint := 'Connect';

DirTree.Items.Clear;

FileNewItem.Enabled := False;

ViewLargeItem.Enabled := False;

ViewSmallItem.Enabled := False;

ViewListItem.Enabled := False;

ViewDetailsItem.Enabled := False;

ViewRefreshItem.Enabled := False;

ToolsDisconnectItem.Enabled := False;

LargeBtn.Enabled := False;

SmallBtn.Enabled := False;

ListBtn.Enabled := False;

DetailsBtn.Enabled := False;

RefreshBtn.Enabled := False;

end;

procedure TMyFtp.Open1Click(Sender: TObject);

begin

FTP.Quit;

DirTree.Items.BeginUpdate;

try

DirTree.Items.Clear;

finally

DirTree.Items.EndUpdate;

end;

procedure TMyFtp.FileExitItemClick(Sender: TObject);

begin

Close;

end;

procedure TMyFtp.FormResize(Sender: TObject);

begin

Statusbar.Panels[0].Width := Width - 150;

end;

procedure TMyFtp.ViewLargeItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsIcon;

end;

procedure TMyFtp.ViewSmallItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsSmallIcon;

end;

procedure TMyFtp.ViewListItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsList;

end;

procedure TMyFtp.ViewDetailsItemClick(Sender: TObject);

begin

FileList.ViewStyle := vsReport;

end;

procedure TMyFtp.ViewRefreshItemClick(Sender: TObject);

begin

DirTreeChange(nil, DirTree.Selected);

end;

procedure TMyFtp.CopyItemClick(Sender: TObject);

begin

SaveDialog1.FileName := FileList.Selected.Caption;

if SaveDialog1.Execute then

FTP.GetFile(NodePath(DirTree.Selected) + '/' + FileList.Selected.Caption,

SaveDialog1.FileName);

end;

procedure TMyFtp.ToolsDisconnectItemClick(Sender: TObject);

begin

DisConnect;

end;

procedure TMyFtp.FileNewItemClick(Sender: TObject);

var

DirName: String;

begin

if InputQuery('Input Box', 'Prompt', DirName) then

FTP.CreateDir(NodePath(DirTree.Selected) + '/' + DirName);

end;

procedure TMyFtp.DeleteItemClick(Sender: TObject);

begin

if ActiveControl = DirTree then

FTP.DeleteDir(NodePath(DirTree.Selected));

if ActiveControl = FileList then

FTP.DeleteFile(NodePath(DirTree.Selected) + '/' + FileList.Selected.Caption);

end;

procedure TMyFtp.PasteFromItemClick(Sender: TObject);

begin

if OpenDialog1.Execute then

FTP.PutFile(OpenDialog1.FileName, NodePath(DirTree.Selected));

end;

procedure TMyFtp.FilePopupPopup(Sender: TObject);

begin

CopyItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

PasteFromItem.Enabled := (ActiveControl = DirTree) and (DirTree.Selected <> nil);

DeleteItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

RenameItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

end;

procedure TMyFtp.FileMenuClick(Sender: TObject);

begin

FileCopyItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

FileDeleteItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

FileRenameItem.Enabled := (ActiveControl = FileList) and (FileList.Selected <> nil);

end;

procedure TMyFtp.FileDeleteItemClick(Sender: TObject);

begin

if (DirTree.Selected <> nil) and (FileList.Selected <> nil) then

FTP.DeleteFile(FileList.Selected.Caption);

end;

procedure TMyFtp.FTPListItem(Sender: TObject; const Item: FTPDirItem);

var

Node: TTreeNode;

begin

CreateItem(Item.FileName, Item.Attributes, Item.Size, Item.Date);

if Item.Attributes = 1 then

if DirTree.Selected <> nil then

begin

if DirTree.Selected <> nil then

Node := DirTree.Selected.GetFirstChild

else

Node := nil;

while Node <> nil do

if AnsiCompareFileName(Node.Text, Item.FileName) = 0 then

exit

else

Node := DirTree.Selected.GetNextChild(Node);

if Node = nil then

begin

Node := DirTree.Items.AddChild(DirTree.Selected,

Item.FileName);

Node.ImageIndex := Folder;

Node.SelectedIndex := OpenFolder;

end;

end

else

DirTree.Items.AddChild(Root, Item.FileName);

end;

end.

файл nntp.pas

unit nntp;

interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

Menus, OleCtrls, StdCtrls, ComCtrls, ExtCtrls, Buttons, ActiveX, isp3;

const

efListGroups = 0;

efGetArticleHeaders = 1;

efGetArticleNumbers = 2;

efGetArticle = 3;

type

TNewsForm = class(TForm)

NNTP1: TNNTP;

MainMenu1: TMainMenu;

File1: TMenuItem;

Exit1: TMenuItem;

N1: TMenuItem;

FileDisconnectItem: TMenuItem;

FileConnectItem: TMenuItem;

Panel1: TPanel;

Bevel1: TBevel;

StatusBar: TStatusBar;

SmallImages: TImageList;

Panel2: TPanel;

NewsGroups: TTreeView;

Bevel2: TBevel;

Panel3: TPanel;

Memo1: TMemo;

Panel5: TPanel;

Panel4: TPanel;

ConnectBtn: TSpeedButton;

RefreshBtn: TSpeedButton;

Bevel3: TBevel;

MsgHeaders: TListBox;

Label1: TLabel;

Label2: TLabel;

procedure FileConnectItemClick(Sender: TObject);

procedure NNTP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

procedure NNTP1StateChanged(Sender: TObject; State: Smallint);

procedure Exit1Click(Sender: TObject);

procedure MsgHeadersDblClick(Sender: TObject);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure NewsGroupsChange(Sender: TObject; Node: TTreeNode);

procedure RefreshBtnClick(Sender: TObject);

procedure FileDisconnectItemClick(Sender: TObject);

procedure NNTP1Banner(Sender: TObject; const Banner: WideString);

procedure NNTP1DocOutput(Sender: TObject; const DocOutput: DocOutput);

procedure NNTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

procedure NNTP1SelectGroup(Sender: TObject;

const groupName: WideString; firstMessage, lastMessage,

msgCount: Integer);

private

EventFlag: Integer;

function NodePath(Node: TTreeNode): String;

public

Data: String;

end;

var

NewsForm: TNewsForm;

Remainder: String;

Nodes: TStringList;

CurrentGroup: String;

GroupCount: Integer;

implementation

uses Connect;

{$R *.DFM}

{ TParser }

type

TToken = (etEnd, etSymbol, etName, etLiteral);

TParser = class

private

FFlags: Integer;

FText: string;

FSourcePtr: PChar;

FSourceLine: Integer;

FTokenPtr: PChar;

FTokenString: string;

FToken: TToken;

procedure SkipBlanks;

procedure NextToken;

public

constructor Create(const Text: string; Groups: Boolean);

end;

const

sfAllowSpaces = 1;

constructor TParser.Create(const Text: string; Groups: Boolean);

begin

FText := Text;

FSourceLine := 1;

FSourcePtr := PChar(Text);

if Groups then

FFlags := sfAllowSpaces

else

FFlags := 0;

NextToken;

end;

procedure TParser.SkipBlanks;

begin

while True do

begin

case FSourcePtr^ of

#0:

begin

if FSourcePtr^ = #0 then Exit;

Continue;

end;

#10:

Inc(FSourceLine);

#33..#255:

Exit;

end;

Inc(FSourcePtr);

end;

procedure TParser.NextToken;

var

P, TokenStart: PChar;

begin

SkipBlanks;

FTokenString := '';

P := FSourcePtr;

while (P^ <> #0) and (P^ <= ' ') do Inc(P);

FTokenPtr := P;

case P^ of

'0'..'9':

begin

TokenStart := P;

Inc(P);

while P^ in ['0'..'9'] do Inc(P);

SetString(FTokenString, TokenStart, P - TokenStart);

FToken := etLiteral;

end;

#13: Inc(FSourceLine);

#0:

FToken := etEnd;

else

begin

TokenStart := P;

Inc(P);

if FFlags = sfAllowSpaces then

while not (P^ in [#0, #13, ' ']) do Inc(P)

else

while not (P^ in [#0, #13]) do Inc(P);

SetString(FTokenString, TokenStart, P - TokenStart);

FToken := etSymbol;

end;

FSourcePtr := P;

end;

function FirstItem(var ItemList: ShortString): ShortString;

var

P: Integer;

begin

P := AnsiPos('.', ItemList);

if P = 0 then

begin

Result := ItemList;

P := Length(ItemList);

end

else

Result := Copy(ItemList, 1, P - 1);

Delete(ItemList, 1, P);

end;

procedure AddItem(GroupName: ShortString);

var

Index, i: Integer;

Groups: Integer;

Item: ShortString;

TheNodes: TStringList;

begin

Groups := 1;

for i := 0 to Length(GroupName) do

if GroupName[i] = '.' then

Inc(Groups);

TheNodes := Nodes;

for i := 0 to Groups - 1 do

begin

Item := FirstItem(GroupName);

Index := TheNodes.IndexOf(Item);

if Index = -1 then

begin

Index := TheNodes.AddObject(Item, TStringList.Create);

TheNodes := TStringList(TheNodes.Objects[Index]);

TheNodes.Sorted := True;

end

else

TheNodes := TStringList(TheNodes.Objects[Index]);

end;

Inc(GroupCount);

end;

procedure ParseGroups(Data: String);

var

Parser: TParser;

OldSrcLine: Integer;

begin

Parser := TParser.Create(Data, True);

OldSrcLine := 0;

while Parser.FToken <> etEnd do

begin

if Parser.FSourceLine <> OldSrcLine then

begin

AddItem(Parser.FTokenString);

OldSrcLine := Parser.FSourceLine;

end;

Parser.NextToken;

end;

procedure ParseHeaders(Data: String);

var

Parser: TParser;

MsgNo: LongInt;

Header: String;

OldSrcLine: Integer;

begin

Parser := TParser.Create(Data, False);

while Parser.FToken <> etEnd do

begin

MsgNo := StrToInt(Parser.FTokenString);

OldSrcLine := Parser.FSourceLine;

Parser.NextToken;

Header := '';

while (OldSrcLine = Parser.FSourceLine) do

begin

Header := Header + ' ' + Parser.FTokenString;

Parser.NextToken;

if Parser.FToken = etEnd then

Break;

end;

NewsForm.MsgHeaders.Items.AddObject(Header, Pointer(MsgNo));

end;

procedure DestroyList(AList: TStringList);

var

i: Integer;

begin

for i := 0 to AList.Count - 1 do

if AList.Objects[i] <> nil then

DestroyList(TStringList(AList.Objects[i]));

AList.Free;

end;

procedure BuildTree(Parent: TTreeNode; List: TStrings);

var

i: Integer;

Node: TTreeNode;

begin

for i := 0 to List.Count - 1 do

if List.Objects[i] <> nil then

begin

Node := NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);

Node.ImageIndex := 0;

Node.SelectedIndex := 1;

BuildTree(Node, TStrings(List.Objects[i]));

end

else

NewsForm.NewsGroups.Items.AddChild(Parent, List[i]);

end;

function TNewsForm.NodePath(Node: TTreeNode): String;

begin

if Node.Parent = nil then

Result := Node.Text

else

Result := NodePath(Node.Parent) + '.' + Node.Text;

end;

procedure TNewsForm.FileConnectItemClick(Sender: TObject);

begin

ConnectDlg := TConnectDlg.Create(Self);

try

if ConnectDlg.ShowModal = mrOk then

with NNTP1 do

Connect(ConnectDlg.ServerEdit.Text, RemotePort);

finally

ConnectDlg.Free;

end;

procedure TNewsForm.NNTP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

begin

case ProtocolState of

nntpBase: ;

nntpTransaction:

begin

EventFlag := efListGroups;

Nodes := TStringList.Create;

Nodes.Sorted := True;

NNTP1.ListGroups;

end;

procedure TNewsForm.NNTP1StateChanged(Sender: TObject; State: Smallint);

begin

with Memo1.Lines do

case NNTP1.State of

prcConnecting : Add('Connecting');

prcResolvingHost: Add('Resolving Host: ' + NNTP1.RemoteHost);

prcHostResolved : Add('Host resolved');

prcConnected :

begin

Add('Connected to: ' + NNTP1.RemoteHost);

Statusbar.Panels[0].Text := 'Connected to: ' + NNTP1.RemoteHost;

ConnectBtn.Enabled := False;

FileConnectItem.Enabled := False;

RefreshBtn.Enabled := True;

end;

prcDisconnecting: Text := NNTP1.ReplyString;

prcDisconnected :

begin

Statusbar.Panels[0].Text := 'Disconnected';

Caption := 'News Reader';

Label1.Caption := '';

ConnectBtn.Enabled := True;

FileConnectItem.Enabled := True;

RefreshBtn.Enabled := False;

end;

procedure TNewsForm.Exit1Click(Sender: TObject);

begin

if NNTP1.State <> prcDisconnected then

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.State <> prcDisconnected do

Application.ProcessMessages;

end;

Close;

end;

procedure TNewsForm.MsgHeadersDblClick(Sender: TObject);

var

Article: Integer;

begin

if NNTP1.Busy then exit;

EventFlag := efGetArticle;

Memo1.Clear;

if MsgHeaders.ItemIndex = -1 then exit;

Caption := 'News Reader: ' + MsgHeaders.Items[MsgHeaders.ItemIndex];

Article := Integer(MsgHeaders.Items.Objects[MsgHeaders.ItemIndex]);

NNTP1.GetArticlebyArticleNumber(Article);

end;

procedure TNewsForm.FormClose(Sender: TObject; var Action: TCloseAction);

begin

if NNTP1.State <> prcDisconnected then

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.State <> prcDisconnected do

Application.ProcessMessages;

end;

procedure TNewsForm.NewsGroupsChange(Sender: TObject; Node: TTreeNode);

var

NP: String;

begin

if (NNTP1.State = prcConnected) and not NNTP1.Busy then

with MsgHeaders do

begin

Items.BeginUpdate;

try

Items.Clear;

Memo1.Lines.Clear;

NP := NodePath(NewsGroups.Selected);

Statusbar.Panels[2].Text := 'Bytes: 0';

Statusbar.Panels[1].Text := '0 Article(s)';

if NNTP1.Busy then

NNTP1.Cancel;

NNTP1.SelectGroup(NP);

Label1.Caption := 'Contents of ''' + NP + '''';

finally

Items.EndUpdate;

end;

procedure TNewsForm.RefreshBtnClick(Sender: TObject);

begin

if NewsGroups.Selected <> nil then

NewsGroupsChange(nil, NewsGroups.Selected);

end;

procedure TNewsForm.FileDisconnectItemClick(Sender: TObject);

begin

if NNTP1.Busy then NNTP1.Cancel;

NNTP1.Quit;

while NNTP1.Busy do

Application.ProcessMessages;

with NewsGroups.Items do

begin

BeginUpdate;

Clear;

EndUpdate;

end;

MsgHeaders.Items.Clear;

Memo1.Lines.Clear;

end;

procedure TNewsForm.NNTP1Banner(Sender: TObject; const Banner: WideString);

begin

Memo1.Lines.Add(Banner);

end;

procedure TNewsForm.NNTP1DocOutput(Sender: TObject;

const DocOutput: DocOutput);

begin

Statusbar.Panels[2].Text := Format('Bytes: %d',[DocOutput.BytesTransferred]);

case DocOutput.State of

icDocBegin:

begin

if EventFlag = efListGroups then

Memo1.Lines.Add('Retrieving news groups...');

Data := '';

GroupCount := 0;

end;

icDocData:

begin

Data := Data + DocOutput.DataString;

if EventFlag = efGetArticle then

Memo1.Lines.Add(Data);

end;

icDocEnd:

begin

case EventFlag of

efListGroups:

begin

ParseGroups(Data);

Memo1.Lines.Add('Done.'#13#10'Building news group tree...');

NewsGroups.Items.BeginUpdate;

try

BuildTree(nil, Nodes);

DestroyList(Nodes);

Statusbar.Panels[1].Text := Format('%d Groups',[GroupCount]);

finally

NewsGroups.Items.EndUpdate;

Memo1.Lines.Add('Done.');

end;

efGetArticleHeaders: ParseHeaders(Data);

efGetArticle:

begin

Memo1.SelStart := 0;

SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);

end;

SetLength(Data, 0);

end;

Refresh;

end;

procedure TNewsForm.NNTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);

begin

// MessageDlg(Description, mtError, [mbOk], 0);

end;

procedure TNewsForm.NNTP1SelectGroup(Sender: TObject;

const groupName: WideString; firstMessage, lastMessage,

msgCount: Integer);

begin

EventFlag := efGetArticleHeaders;

Statusbar.Panels[1].Text := Format('%d Article(s)',[msgCount]);

NNTP1.GetArticleHeaders('subject', FirstMessage, lastMessage);

end;

end.

файл smtp.pas

unit Smtp;

interface

uses Windows, SysUtils, Classes, Graphics, Forms, Controls, Menus,

StdCtrls, Dialogs, Buttons, Messages, ExtCtrls, ComCtrls, OleCtrls,

ISP3;

type

TMail = class(TForm)

OpenDialog: TOpenDialog;

SMTP1: TSMTP;

POP1: TPOP;

PageControl1: TPageControl;

SendPage: TTabSheet;

RecvPage: TTabSheet;

ConPage: TTabSheet;

Panel1: TPanel;

Label1: TLabel;

Label3: TLabel;

Label2: TLabel;

eTo: TEdit;

eCC: TEdit;

eSubject: TEdit;

SendBtn: TButton;

ClearBtn: TButton;

reMessageText: TRichEdit;

SMTPStatus: TStatusBar;

Panel3: TPanel;

mReadMessage: TMemo;

POPStatus: TStatusBar;

cbSendFile: TCheckBox;

GroupBox1: TGroupBox;

ePOPServer: TEdit;

Label6: TLabel;

Label5: TLabel;

eUserName: TEdit;

ePassword: TEdit;

Label4: TLabel;

GroupBox2: TGroupBox;

Label7: TLabel;

eSMTPServer: TEdit;

SMTPConnectBtn: TButton;

POPConnectBtn: TButton;

eHomeAddr: TEdit;

Label8: TLabel;

Panel2: TPanel;

Label9: TLabel;

lMessageCount: TLabel;

Label10: TLabel;

eCurMessage: TEdit;

udCurMessage: TUpDown;

ConnectStatus: TStatusBar;

procedure FormCreate(Sender: TObject);

procedure POP1StateChanged(Sender: TObject; State: Smallint);

procedure FormClose(Sender: TObject; var Action: TCloseAction);

procedure SMTP1StateChanged(Sender: TObject; State: Smallint);

procedure FormResize(Sender: TObject);

procedure ClearBtnClick(Sender: TObject);

procedure SMTP1Verify(Sender: TObject);

procedure SendBtnClick(Sender: TObject);

procedure POP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

procedure SMTPConnectBtnClick(Sender: TObject);

procedure POPConnectBtnClick(Sender: TObject);

procedure eSMTPServerChange(Sender: TObject);

procedure ePOPServerChange(Sender: TObject);

procedure cbSendFileClick(Sender: TObject);

procedure udCurMessageClick(Sender: TObject; Button: TUDBtnType);

procedure POP1RefreshMessageCount(Sender: TObject; Number: Integer);

procedure POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);

procedure POP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

procedure SMTP1DocInput(Sender: TObject; const DocInput: DocInput);

procedure SMTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer;

var CancelDisplay: WordBool);

private

RecvVerified,

SMTPError,

POPError: Boolean;

FMessageCount: Integer;

procedure SendFile(Filename: string);

procedure SendMessage;

procedure CreateHeaders;

end;

var

Mail: TMail;

implementation

{$R *.DFM}

const

icDocBegin = 1;

icDocHeaders = 2;

icDocData = 3;

icDocEnd = 5;

{When calling a component method which maps onto an OLE call, NoParam substitutes

for an optional parameter. As an alternative to calling the component method, you

may access the component's OLEObject directly -

i.e., Component.OLEObject.MethodName(,Foo,,Bar)}

function NoParam: Variant;

begin

TVarData(Result).VType := varError;

TVarData(Result).VError := DISP_E_PARAMNOTFOUND;

end;

procedure TMail.FormCreate(Sender: TObject);

begin

SMTPError := False;

POPError := False;

FMessageCount := 0;

end;

procedure TMail.FormClose(Sender: TObject; var Action: TCloseAction);

begin

if POP1.State = prcConnected then POP1.Quit;

if SMTP1.State = prcConnected then SMTP1.Quit;

end;

procedure TMail.FormResize(Sender: TObject);

begin

SendBtn.Left := ClientWidth - SendBtn.Width - 10;

ClearBtn.Left := ClientWidth - ClearBtn.Width - 10;

cbSendFile.Left := ClientWidth - cbSendFile.Width - 10;

eTo.Width := SendBtn.Left - eTo.Left - 10;

eCC.Width := SendBtn.Left - eCC.Left - 10;

eSubject.Width := SendBtn.Left - eSubject.Left - 10;

end;

procedure TMail.ClearBtnClick(Sender: TObject);

begin

eTo.Text := '';

eCC.Text := '';

eSubject.Text := '';

OpenDialog.Filename := '';

reMessageText.Lines.Clear;

end;

procedure TMail.eSMTPServerChange(Sender: TObject);

begin

SMTPConnectBtn.Enabled := (eSMTPServer.Text <> '') and (eHomeAddr.Text <> '');

end;

procedure TMail.ePOPServerChange(Sender: TObject);

begin

POPConnectBtn.Enabled := (ePOPServer.Text <> '') and (eUsername.Text <> '')

and (ePassword.Text <> '');

end;

procedure TMail.cbSendFileClick(Sender: TObject);

begin

if cbSendFile.Checked then

begin

if OpenDialog.Execute then

cbSendFile.Caption := cbSendFile.Caption + ': '+OpenDialog.Filename

else

cbSendFile.Checked := False;

end else

cbSendFile.Caption := '&Attach Text File';

end;

{Clear and repopulate MIME headers, using the component's DocInput property. A

separate DocInput OLE object could also be used. See RFC1521/1522 for complete

information on MIME types.}

procedure TMail.CreateHeaders;

begin

with SMTP1 do

begin

DocInput.Headers.Clear;

DocInput.Headers.Add('To', eTo.Text);

DocInput.Headers.Add('From', eHomeAddr.Text);

DocInput.Headers.Add('CC', eCC.Text);

DocInput.Headers.Add('Subject', eSubject.Text);

DocInput.Headers.Add('Message-Id', Format('%s_%s_%s', [Application.Title,

DateTimeToStr(Now), eHomeAddr.Text]));

DocInput.Headers.Add('Content-Type', 'TEXT/PLAIN charset=US-ASCII');

end;

{Send a simple mail message}

procedure TMail.SendMessage;

begin

CreateHeaders;

with SMTP1 do

SendDoc(NoParam, DocInput.Headers, reMessageText.Text, '', '');

end;

{Send a disk file. Leave SendDoc's InputData parameter blank and

specify a filename for InputFile to send the contents of a disk file. You can

use the DocInput event and GetData methods to do custom encoding (Base64, UUEncode, etc.) }

procedure TMail.SendFile(Filename: string);

begin

CreateHeaders;

with SMTP1 do

begin

DocInput.Filename := FileName;

SendDoc(NoParam, DocInput.Headers, NoParam, DocInput.FileName, '');

end;

{Set global flag indicating recipients are addressable (this only ensures that the

address is in the correct format, not that it exists and is deliverable), then

send the text part of the message}

procedure TMail.SMTP1Verify(Sender: TObject);

begin

SendMessage;

RecvVerified := True;

end;

{Verify addressees, send text message in the Verify event, and if an attachment is

specified, send it}

procedure TMail.SendBtnClick(Sender: TObject);

var

Addressees: string;

begin

if SMTP1.State = prcConnected then

begin

RecvVerified := False;

SMTPError := False;

Addressees := eTo.Text;

if eCC.Text <> '' then

Addressees := Addressees + ', '+ eCC.Text;

SMTP1.Verify(Addressees);

{wait for completion of Verify-Text message send}

while SMTP1.Busy do

Application.ProcessMessages;

{Check global flag indicating addresses are in the correct format - if true,

the text part of the message has been sent}

if not RecvVerified then

begin

MessageDlg('Incorrect address format', mtError, [mbOK], 0);

Exit;

end

else

if cbSendFile.Checked then

SendFile(OpenDialog.Filename);

end

else

MessageDlg('Not connected to SMTP server', mtError, [mbOK], 0);

end;

{SMTP component will call this event every time its connection state changes}

procedure TMail.SMTP1StateChanged(Sender: TObject; State: Smallint);

begin

case State of

prcConnecting:

ConnectStatus.SimpleText := 'Connecting to SMTP server: '+SMTP1.RemoteHost+'...';

prcResolvingHost:

ConnectStatus.SimpleText := 'Resolving Host';

prcHostResolved:

ConnectStatus.SimpleText := 'Host Resolved';

prcConnected:

begin

ConnectStatus.SimpleText := 'Connected to SMTP server: '+SMTP1.RemoteHost;

SMTPConnectBtn.Caption := 'Disconnect';

end;

prcDisconnecting:

ConnectStatus.SimpleText := 'Disconnecting from SMTP server: '+SMTP1.RemoteHost+'...';

prcDisconnected:

begin

ConnectStatus.SimpleText := 'Disconnected from SMTP server: '+SMTP1.RemoteHost;

SMTPConnectBtn.Caption := 'Connect';

end;

eSMTPServer.Enabled := not (State = prcConnected);

eHomeAddr.Enabled := not (State = prcConnected);

end;

{The DocInput event is called each time the DocInput state changes during a mail transfer.

DocInput holds all the information about the current transfer, including the headers, the

number of bytes transferred, and the message data itself. Although not shown in this example,

you may call DocInput's SetData method if DocInput.State = icDocData to encode the data before

each block is sent.}

procedure TMail.SMTP1DocInput(Sender: TObject;

const DocInput: DocInput);

begin

case DocInput.State of

icDocBegin:

SMTPStatus.SimpleText := 'Initiating document transfer';

icDocHeaders:

SMTPStatus.SimpleText := 'Sending headers';

icDocData:

if DocInput.BytesTotal > 0 then

SMTPStatus.SimpleText := Format('Sending data: %d of %d bytes (%d%%)',

[Trunc(DocInput.BytesTransferred), Trunc(DocInput.BytesTotal),

Trunc(DocInput.BytesTransferred/DocInput.BytesTotal*100)])

else

SMTPStatus.SimpleText := 'Sending...';

icDocEnd:

if SMTPError then

SMTPStatus.SimpleText := 'Transfer aborted'

else

SMTPStatus.SimpleText := Format('Mail sent to %s (%d bytes data)', [eTo.Text,

Trunc(DocInput.BytesTransferred)]);

end;

SMTPStatus.Update;

end;

{The Error event is called whenever an error occurs in the background processing. In

addition to providing an error code and brief description, you can also access the SMTP

component's Errors property (of type icErrors, an OLE object) to get more detailed

information}

procedure TMail.SMTP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);

var

I: Integer;

ErrorStr: string;

begin

SMTPError := True;

CancelDisplay := True;

{Get extended error information}

for I := 1 to SMTP1.Errors.Count do

ErrorStr := Format(#13'(%s)', [SMTP1.Errors.Item(I).Description]);

{Display error code, short and long error description}

MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);

end;

{Unlike POP, SMTP does not require a user account on the host machine, so no user

authorization is necessary}

procedure TMail.SMTPConnectBtnClick(Sender: TObject);

begin

if SMTP1.State = prcConnected then

SMTP1.Quit

else

if SMTP1.State = prcDisconnected then

begin

SMTP1.RemoteHost := eSMTPServer.Text;

SMTPError := False;

SMTP1.Connect(NoParam, NoParam);

end;

{Unlike SMTP, users must be authorized on the POP server. The component defines

a special protocol state, popAuthorization, when it requests authorization. If

authorization is successful, the protocol state changes to popTransaction and

POP commands can be issued. Note that server connection is independent of the

authorization state.}

procedure TMail.POP1ProtocolStateChanged(Sender: TObject;

ProtocolState: Smallint);

begin

case ProtocolState of

popAuthorization:

POP1.Authenticate(POP1.UserID, POP1.Password);

popTransaction:

ConnectStatus.SimpleText := Format('User %s authorized on server %s', [eUsername.Text,

ePOPServer.Text]);

end;

{This event is called every time the connection status of the POP server changes}

procedure TMail.POP1StateChanged(Sender: TObject; State: Smallint);

begin

case State of

prcConnecting:

ConnectStatus.SimpleText := 'Connecting to POP server: '+POP1.RemoteHost+'...';

prcResolvingHost:

ConnectStatus.SimpleText := 'Resolving Host';

prcHostResolved:

ConnectStatus.SimpleText := 'Host Resolved';

prcConnected:

begin

ConnectStatus.SimpleText := 'Connected to POP server: '+POP1.RemoteHost;

POPConnectBtn.Caption := 'Disconnect';

end;

prcDisconnecting:

ConnectStatus.SimpleText := 'Disconnecting from POP server: '+POP1.RemoteHost+'...';

prcDisconnected:

begin

ConnectStatus.SimpleText := 'Disconnected from POP server: '+POP1.RemoteHost;

POPConnectBtn.Caption := 'Connect';

end;

ePOPServer.Enabled := not (State = prcConnected);

eUsername.Enabled := not (State = prcConnected);

ePassword.Enabled := not (State = prcConnected);

end;

{The Error event is called whenever an error occurs in the background processing. In

addition to providing an error code and brief description, you can also access the POP

component's Errors property (of type icErrors, an OLE object) to get more detailed

information}

procedure TMail.POP1Error(Sender: TObject; Number: Smallint;

var Description: WideString; Scode: Integer; const Source,

HelpFile: WideString; HelpContext: Integer; var CancelDisplay: WordBool);

var

I: Integer;

ErrorStr: string;

begin

POPError := True;

CancelDisplay := True;

if POP1.ProtocolState = popAuthorization then

ConnectStatus.SimpleText := 'Authorization error';

{Get extended error information}

for I := 1 to POP1.Errors.Count do

ErrorStr := Format(#13'(%s)', [POP1.Errors.Item(I).Description]);

{Display error code, short and long error description}

MessageDlg(Format('%d - %s%s', [Number, Description, Trim(ErrorStr)]), mtError, [mbOK], 0);

end;

{POP requires a valid user account on the host machine}

procedure TMail.POPConnectBtnClick(Sender: TObject);

begin

if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction)

and not POP1.Busy then

begin

mReadMessage.Lines.Clear;

POP1.Quit;

end

else

if POP1.State = prcDisconnected then

begin

POP1.RemoteHost := ePOPServer.Text;

POP1.UserID := eUserName.Text;

POP1.Password := ePassword.Text;

POP1.Connect(NoParam, NoParam);

end;

{The DocOutput event is the just like the DocInput event in 'reverse'. It is called each time

the component's DocOutput state changes during retrieval of mail from the server. When the

state = icDocData, you can call DocOutput.GetData to decode each data block based on the MIME

content type specified in the headers.}

procedure TMail.POP1DocOutput(Sender: TObject; const DocOutput: DocOutput);

var

Buffer: WideString;

I: Integer;

begin

case DocOutput.State of

icDocBegin:

POPStatus.SimpleText := 'Initiating document transfer';

icDocHeaders:

begin

POPStatus.SimpleText := 'Retrieving headers';

for I := 1 to DocOutput.Headers.Count do

mReadMessage.Lines.Add(DocOutput.Headers.Item(I).Name+': '+

DocOutput.Headers.Item(I).Value);

end;

icDocData:

begin

POPStatus.SimpleText := Format('Retrieving data - %d bytes',

[Trunc(DocOutput.BytesTransferred)]);

Buffer := DocOutput.DataString;

mReadMessage.Text := mReadMessage.Text + Buffer;

end;

icDocEnd:

if POPError then

POPStatus.SimpleText := 'Transfer aborted'

else

POPStatus.SimpleText := Format('Retrieval complete (%d bytes data)',

[Trunc(DocOutput.BytesTransferred)]);

end;

POPStatus.Update;

end;

{Retrieve message from the server}

procedure TMail.udCurMessageClick(Sender: TObject; Button: TUDBtnType);

begin

if (POP1.State = prcConnected) and (POP1.ProtocolState = popTransaction) then

begin

POPError := False;

mReadMessage.Lines.Clear;

POP1.RetrieveMessage(udCurMessage.Position);

end;

{The RefreshMessageCount event is called whenever the RefreshMessageCount method is

called, and also when a connection to the POP server is first made}

procedure TMail.POP1RefreshMessageCount(Sender: TObject;

Number: Integer);

begin

FMessageCount := Number;

udCurMessage.Max := Number;

udCurMessage.Enabled := Number <> 0;

lMessageCount.Caption := IntToStr(Number);

if Number > 0 then

begin

udCurMessage.Min := 1;

udCurMessage.Position := 1;

POP1.RetrieveMessage(udCurMessage.Position);

end;

end.

файл webbrows.dpr

program Webbrows;

uses

Forms,

main in 'Main.pas' {MainForm},

SMTP in 'Smtp.pas', {Mail}

FTP in 'ftp.pas', {MyFtp}

NNTP in 'nntp.pas', {NewsForm}

CHAT in 'chat.pas'; {ChatForm}

{$R *.RES}

begin

Application.Initialize;

Application.CreateForm(TMainForm, MainForm);

Application.CreateForm(TDocSourceFrm, DocSourceFrm);

Application.run;

end.

Приложение 1. Исходный текст модели корпоративной сети

uses crt,dos,graph;

CONST VertexQuantity=7;

DelayInDomain=1000;

DelaySendToRouter=1000;

DelayRouterReceive=1000;

AdjacencyMatrix : array[1..VertexQuantity,1..VertexQuantity] of byte =(

(0,1,0,1,0,0,0),

(1,0,1,0,1,0,1),

(0,1,0,1,0,0,0),

(1,0,1,0,1,0,0),

(0,1,0,1,0,1,0),

(0,0,0,0,1,0,1),

(0,1,0,0,0,1,0) );

TYPE TAddr = record {address format}

router:byte;

domain:byte;

comp :byte;

END;

TYPE TBatch = record {batch format}

from:TAddr;

to_ :TAddr;

data:string;

path:array[1..20] of byte; {path is chain of router numbers}

END;

TYPE TComp = object {terminal}

addr:TAddr; {adress}

mem :TBatch; {memory}

Procedure Send2Router(batch:TBatch);{send batch}

Procedure Send(batch:TBatch);{send batch into domain}

Procedure Receive(batch:TBatch;byRouter:boolean); {receive batch}

END;

TYPE TRouter = object

num :byte;

x,y :integer;

memory :Tbatch;

state :boolean; {active or inactive}

Procedure Receive(routerNum:byte;batch:TBatch);

Procedure Send2Comp(batch:TBatch);

Procedure CalcMinPath(sender,target:byte);

Procedure Send2NextRouter(batch:TBatch;currentRouter:byte);

END;

VAR computers : array[1..38] of TComp; {all computers in the global net}

routers : array[1..7] of TRouter;{all routers in the global net}

OptimalPath : array[1..49] of byte;{1--> [1,2,3,4,5]}

OptPathPtr : byte;

type TMark = record

delta : integer;

prevPtr : byte;

end;

type vertex = record

mark : TMark;

marked : boolean;

end;

AdjacencyRec = record

link :byte;

weight:integer;

end;

VAR AMatr : array[1..7,1..7] of AdjacencyRec;

vertexArr : array [1..7] of vertex;

PROCEDURE HiddenCursor;assembler;

asm

mov ah,01

mov ch,20

mov cl,18

int 10h

end;

PROCEDURE NormalCursor;assembler;

asm

mov ah,01

mov ch,9

mov cl,10

int 10h

end;

Procedure Push(num:byte);

Begin

OptimalPath[OptPathPtr+1]:=num;inc(OptPathPtr);

End;

Procedure Pop;

Begin

OptimalPath[OptPathPtr]:=0;dec(OptPathPtr);

End;

Procedure ShowGraphics(second:boolean);

Var grDr,grMode:integer;

i :integer;

Begin

grDr:=vga;grMode:=2;

InitGraph(grDr,grMode,'d:\lang\tp\bgi');

SetTextStyle(DefaultFont,HorizDir,2);SetColor(lightRed);

OutTextXY(10,20,'Arrangement scheme of routers');

SetColor(white);Rectangle(5,15,480,40);

Rectangle(5,48,480,70);SetTextStyle(DefaultFont,HorizDir,1);setcolor(lightgreen);

OutTextXY(10,55,'Main address : Router.Domain.Computer (for ex., 4.2.4)');

setcolor(white);setFillStyle(7,lightblue);floodfill(5,5,white);

setlinestyle(0,0,3);

rectangle(0,0,getmaxX-20,getmaxY-20);

setFillStyle(9,lightgray);

floodfill(getmaxX,getmaxY,white);

setlinestyle(0,0,NormWidth);

SetFillStyle(1,red);

{-------------------router circles-----------------------}

Circle(routers[1].x,routers[1].y,10);FloodFill(routers[1].x,routers[1].y,white);

Circle(routers[2].x,routers[2].y,10);FloodFill(routers[2].x,routers[2].y,white);

Circle(routers[3].x,routers[3].y,10);FloodFill(routers[3].x,routers[3].y,white);

Circle(routers[4].x,routers[4].y,10);FloodFill(routers[4].x,routers[4].y,white);

Circle(routers[5].x,routers[5].y,10);FloodFill(routers[5].x,routers[5].y,white);

Circle(routers[6].x,routers[6].y,10);FloodFill(routers[6].x,routers[6].y,white);

Circle(routers[7].x,routers[7].y,10);FloodFill(routers[7].x,routers[7].y,white);

SetFillStyle(1,yellow);

SetColor(red);{-------------------router lines-------------------------}

Line(routers[1].x,routers[1].y-10,routers[2].x-2,routers[2].y+10);

Line(routers[1].x,routers[1].y+10,routers[4].x-10,routers[4].y-6);

Line(routers[3].x,routers[3].y-10,routers[2].x+2,routers[2].y+10);

Line(routers[3].x,routers[3].y+10,routers[4].x,routers[4].y-10);

Line(routers[2].x+4,routers[2].y+10,routers[5].x-2,routers[5].y-10);

Line(routers[2].x+10,routers[2].y,routers[7].x-10,routers[7].y);

Line(routers[5].x+2,routers[5].y-10,routers[6].x,routers[6].y+10);

Line(routers[6].x,routers[6].y-10,routers[7].x,routers[7].y+10);

Line(routers[4].x+10,routers[4].y,routers[5].x-10,routers[5].y);

{domains} {-------------domain 1.1----------------------------------}

SetTextStyle(DefaultFont,HorizDir,1);SetColor(white);

Rectangle(routers[1].x-50,routers[1].y-50,routers[1].x-30,routers[1].y-20 );

FloodFill(routers[1].x-48,routers[1].y-48,white);

Circle(20,routers[1].y-30,8);FloodFill(20,routers[1].y-30,white);

Circle(40,routers[1].y-30,8);FloodFill(40,routers[1].y-30,white);

Circle(60,routers[1].y-30,8);FloodFill(60,routers[1].y-30,white);

SetColor(white);

Line(routers[1].x-5,routers[1].y-10,routers[1].x-20,routers[1].y-30);

Line(routers[1].x-20,routers[1].y-30,routers[1].x-110,routers[1].y-30);

{-------------domain 1.2----------------------------------}

Rectangle(routers[1].x-30,routers[1].y+80,routers[1].x-5,routers[1].y+92);

FloodFill(routers[1].x-28,routers[1].y+82,white);

Line(routers[1].x-2,routers[1].y+10,routers[1].x-20,routers[1].y+80);

Circle(routers[1].x-48,routers[1].y+62,9);

FloodFill(routers[1].x-48,routers[1].y+62,white);

Line(routers[1].x-28,routers[1].y+82,routers[1].x-52,routers[1].y+62);

Circle(routers[1].x+10,routers[1].y+62,8);

FloodFill(routers[1].x+10,routers[1].y+62,white);

Line(routers[1].x-5,routers[1].y+82,routers[1].x+10,routers[1].y+62);

Circle(routers[1].x-48,routers[1].y+92,8);

FloodFill(routers[1].x-48,routers[1].y+92,white);

Line(routers[1].x-28,routers[1].y+90,routers[1].x-48,routers[1].y+92);

Circle(routers[1].x-43,routers[1].y+115,8);

FloodFill(routers[1].x-43,routers[1].y+115,white);

Line(routers[1].x-23,routers[1].y+90,routers[1].x-48,routers[1].y+115);

Circle(routers[1].x-18,routers[1].y+115,8);

FloodFill(routers[1].x-18,routers[1].y+115,white);

Line(routers[1].x-18,routers[1].y+90,routers[1].x-18,routers[1].y+115);

Circle(routers[1].x+13,routers[1].y+113,8);

FloodFill(routers[1].x+13,routers[1].y+113,white);

Line(routers[1].x-5,routers[1].y+92,routers[1].x+13,routers[1].y+113);

{-------------domain 2.1----------------------------------}

Rectangle(routers[2].x-25,routers[2].y+70,routers[2].x+16,routers[2].y+79);

FloodFill(routers[2].x-24,routers[2].y+72,white);

Line(routers[2].x,routers[2].y+10,routers[2].x-5,routers[2].y+70);

Circle(routers[2].x-24,routers[2].y+100,8);

FloodFill(routers[2].x-24,routers[2].y+100,white);

Line(routers[2].x,routers[2].y+72,routers[2].x-24,routers[2].y+100);

{-------------domain 2.2----------------------------------}

Rectangle(routers[2].x-80,routers[2].y+10,routers[2].x-60,routers[2].y+37);

FloodFill(routers[2].x-78,routers[2].y+12,white);

Line(routers[2].x-10,routers[2].y,routers[2].x-70,routers[2].y+20);

Circle(routers[2].x-110,routers[2].y+20,8);

FloodFill(routers[2].x-110,routers[2].y+20,white);

Circle(routers[2].x-140,routers[2].y+20,8);

FloodFill(routers[2].x-140,routers[2].y+20,white);

Line(routers[2].x-70,routers[2].y+20,routers[2].x-150,routers[2].y+20);

{-------------domain 3.1----------------------------------}

Rectangle(routers[3].x-45,routers[3].y-47,routers[3].x-25,routers[3].y-20);

FloodFill(routers[3].x-43,routers[3].y-45,white);

Circle(routers[3].x-60,routers[3].y-37,8);

FloodFill(routers[3].x-60,routers[3].y-37,white);

Circle(routers[3].x-80,routers[3].y-37,8);

FloodFill(routers[3].x-80,routers[3].y-37,white);

Line(routers[3].x-7,routers[3].y-8,routers[3].x-35,routers[3].y-37);

Line(routers[3].x-35,routers[3].y-37,routers[3].x-90,routers[3].y-37);

{-------------domain 4.1----------------------------------}

Rectangle(routers[4].x-39,routers[4].y-82,routers[4].x-13,routers[4].y-70);

FloodFill(routers[4].x-37,routers[4].y-81,white);

Line(routers[4].x-4,routers[4].y-10,routers[4].x-25,routers[4].y-70);

Circle(routers[4].x-40,routers[4].y-105,8);

FloodFill(routers[4].x-40,routers[4].y-105,white);

Line(routers[4].x-25,routers[4].y-75,routers[4].x-40,routers[4].y-105);

Circle(routers[4].x-60,routers[4].y-70,8);

FloodFill(routers[4].x-60,routers[4].y-70,white);

Line(routers[4].x-25,routers[4].y-75,routers[4].x-60,routers[4].y-70);

Circle(routers[4].x-40,routers[4].y-50,8);

FloodFill(routers[4].x-40,routers[4].y-50,white);

Line(routers[4].x-25,routers[4].y-75,routers[4].x-40,routers[4].y-50);

{-------------domain 4.2----------------------------------}

Rectangle(routers[4].x+25,routers[4].y-35,routers[4].x+45,routers[4].y-5);

FloodFill(routers[4].x+27,routers[4].y-33,white);

Circle(routers[4].x+57,routers[4].y-25,8);

FloodFill(routers[4].x+57,routers[4].y-25,white);

Circle(routers[4].x+77,routers[4].y-25,8);

FloodFill(routers[4].x+77,routers[4].y-25,white);

Circle(routers[4].x+97,routers[4].y-25,8);

FloodFill(routers[4].x+97,routers[4].y-25,white);

Circle(routers[4].x+117,routers[4].y-25,8);

FloodFill(routers[4].x+117,routers[4].y-25,white);

Line(routers[4].x+9,routers[4].y-7,routers[4].x+20,routers[4].y-25);

Line(routers[4].x+20,routers[4].y-25,routers[4].x+127,routers[4].y-25);

{-------------domain 5.1----------------------------------}

Rectangle(routers[5].x-30,routers[5].y-130,routers[5].x-10,routers[5].y-100);

FloodFill(routers[5].x-25,routers[5].y-128,white);

Line(routers[5].x,routers[5].y-10,routers[5].x-20,routers[5].y-120);

Circle(routers[5].x-48,routers[5].y-90,8);

FloodFill(routers[5].x-48,routers[5].y-120+30,white);

Line(routers[5].x-20,routers[5].y-120,routers[5].x-48,routers[5].y-90);

Circle(routers[5].x-50,routers[5].y-120,8);

FloodFill(routers[5].x-50,routers[5].y-120,white);

Line(routers[5].x-20,routers[5].y-120,routers[5].x-50,routers[5].y-120);

Circle(routers[5].x-25,routers[5].y-150,8);

FloodFill(routers[5].x-25,routers[5].y-150,white);

Line(routers[5].x-20,routers[5].y-120,routers[5].x-25,routers[5].y-150);

Circle(routers[5].x+2,routers[5].y-150,8);

FloodFill(routers[5].x+2,routers[5].y-150,white);

Line(routers[5].x-20,routers[5].y-120,routers[5].x+2,routers[5].y-150);

{-------------domain 6.1----------------------------------}

Rectangle(routers[6].x-30,routers[6].y-10,routers[6].x-14,routers[6].y+14);

FloodFill(routers[6].x-28,routers[6].y-8,white);

Circle(routers[6].x-42,routers[6].y,8);

FloodFill(routers[6].x-42,routers[6].y,white);

Circle(routers[6].x-62,routers[6].y,8);

FloodFill(routers[6].x-62,routers[6].y,white);

Circle(routers[6].x-82,routers[6].y,8);

FloodFill(routers[6].x-82,routers[6].y,white);

Line(routers[6].x-10,routers[6].y,routers[6].x-92,routers[6].y);

{-------------domain 7.1----------------------------------}

Rectangle(routers[7].x-10,routers[7].y-50,routers[7].x+10,routers[7].y-25);

FloodFill(routers[7].x-8,routers[7].y-48,white);

Line(routers[7].x,routers[7].y-10,routers[7].x,routers[7].y-50);

Circle(routers[7].x-35,routers[7].y-20,8);

FloodFill(routers[7].x-35,routers[7].y-20,white);

Line(routers[7].x,routers[7].y-50,routers[7].x-35,routers[7].y-20);

Circle(routers[7].x-35,routers[7].y-60,8);

FloodFill(routers[7].x-35,routers[7].y-60,white);

Circle(routers[7].x+15,routers[7].y-70,8);

FloodFill(routers[7].x+15,routers[7].y-70,white);

Line(routers[7].x,routers[7].y-50,routers[7].x+15,routers[7].y-70);

Line(routers[7].x,routers[7].y-50,routers[7].x-35,routers[7].y-60);

SetColor(cyan);

OuttextXY(18,routers[1].y-32,'4');

OuttextXY(38,routers[1].y-32,'3');OuttextXY(58,routers[1].y-32,'2');

OutTextXY(routers[1].x-48,routers[1].y-48,'FS');

OuttextXY(78,routers[1].y-32,'1');

OutTextXY(routers[1].x+8,routers[1].y+60,'1');

OutTextXY(routers[1].x-50,routers[1].y+60,'6');

OutTextXY(routers[1].x-50,routers[1].y+89,'5');

OutTextXY(routers[1].x-45,routers[1].y+113,'4');

OutTextXY(routers[1].x-20,routers[1].y+112,'3');

OutTextXY(routers[1].x-28,routers[1].y+82,'hub');

OutTextXY(routers[1].x+11,routers[1].y+111,'2');

OutTextXY(routers[2].x-24,routers[2].y+72,'modem');

OutTextXY(routers[2].x-26,routers[2].y+98,'1');

OutTextXY(routers[2].x-78,routers[2].y+12,'FS');

OutTextXY(routers[2].x-73,routers[2].y+24,'1');

OutTextXY(routers[2].x-112,routers[2].y+18,'2');

OutTextXY(routers[2].x-142,routers[2].y+18,'3');

OutTextXY(routers[3].x-42,routers[3].y-45,'FS');

OutTextXY(routers[3].x-38,routers[3].y-30,'1');

OutTextXY(routers[3].x-62,routers[3].y-40,'2');

OutTextXY(routers[3].x-82,routers[3].y-40,'3');

OutTextXY(routers[4].x-37,routers[4].y-80,'hub');

OutTextXY(routers[4].x-42,routers[4].y-107,'1');

OutTextXY(routers[4].x-62,routers[4].y-73,'2');

OutTextXY(routers[4].x-42,routers[4].y-53,'3');

OutTextXY(routers[4].x+28,routers[4].y-33,'FS');

OutTextXY(routers[4].x+33,routers[4].y-20,'1');

OutTextXY(routers[4].x+55,routers[4].y-27,'2');

OutTextXY(routers[4].x+75,routers[4].y-27,'3');

OutTextXY(routers[4].x+95,routers[4].y-27,'4');

OutTextXY(routers[4].x+115,routers[4].y-27,'5');

OutTextXY(routers[5].x-27,routers[5].y-127,'FS');

OutTextXY(routers[5].x-21,routers[5].y-110,'1');

OutTextXY(routers[5].x-51,routers[5].y-92,'2');

OutTextXY(routers[5].x-51,routers[5].y-122,'3');

OutTextXY(routers[5].x-27,routers[5].y-152,'4');

OutTextXY(routers[5].x,routers[5].y-152,'5');

OutTextXY(routers[6].x-29,routers[6].y-8,'FS');

OutTextXY(routers[6].x-25,routers[6].y+4,'1');

OutTextXY(routers[6].x-44,routers[6].y-2,'2');

OutTextXY(routers[6].x-64,routers[6].y-2,'3');

OutTextXY(routers[6].x-84,routers[6].y-2,'4');

OutTextXY(routers[7].x-7,routers[7].y-48,'FS');

OutTextXY(routers[7].x-2,routers[7].y-35,'1');

OutTextXY(routers[7].x-37,routers[7].y-22,'2');

OutTextXY(routers[7].x-37,routers[7].y-62,'3');

OutTextXY(routers[7].x+12,routers[7].y-72,'4');

SetColor(white);

OutTextXY(10,230,'Domain 1.1');OutTextXY(10,338,'Domain 1.2');

OutTextXY(200,220,'Domain 2.1');OutTextXY(110,150,'Domain 2.2');

OutTextXY(210,240,'Domain 3.1');

OutTextXY(170,320,'Domain 4.1');OutTextXY(330,370,'Domain 4.2');

OutTextXY(430,250,'Domain 5.1');

OutTextXY(450,175,'Domain 6.1');

{-------------router numbers-------------------------}

SetColor(black);

OutTextXY(routers[1].x-2,routers[1].y-2,'1');

OutTextXY(routers[2].x-2,routers[2].y-2,'2');

OutTextXY(routers[3].x-2,routers[3].y-2,'3');

OutTextXY(routers[4].x-2,routers[4].y-2,'4');

OutTextXY(routers[5].x-2,routers[5].y-2,'5');

OutTextXY(routers[6].x-2,routers[6].y-2,'6');

OutTextXY(routers[7].x-2,routers[7].y-2,'7');

if second then begin

setlinestyle(0,0,3);

setcolor({white}green);

for i:=1 to OptPathPtr-2 do

Line(routers[OptimalPath[i]].x,routers[OptimalPath[i]].y,

routers[OptimalPath[i+1]].x,routers[OptimalPath[i+1]].y);

while not keypressed do

for i:=1 to 63 do SetRGBPalette(green,0,i,0);

end;

if not second then while not keypressed do

for i:=1 to 63 do SetRGBPalette(red,i,0,0);

End;

Procedure ShowTime(x,y :integer);

VAR h, m, s, hund : Word;

Function LeadingZero(w : Word) : String;

var s : String;

begin

Str(w:0,s);

if Length(s) = 1 then s := '0' + s;

LeadingZero := s;

end;

Begin

GetTime(h,m,s,hund);TextColor(Green);GotoXY(x,y);Write(LeadingZero(h),':',

LeadingZero(m),':',LeadingZero(s),'.',LeadingZero(hund));

End;

Function Dist (x1,y1,x2,y2:longint):longint;

var temp:longint;

Begin

temp:=sqr(x2-x1)+sqr(y2-y1);

temp:=trunc((sqrt(temp)));

Dist:=temp;

End;

{-----------------objects implementation part-----------------}

{---------------Computer procedures---------------}

Procedure TComp.Send2Router(batch:TBatch);{send batch to it's router}

VAR i:byte;tmpFrom:TAddr;

Begin

Delay(DelaySendToRouter);

tmpFrom:=batch.from;

i:=batch.from.router;

routers[i].memory:=batch;{router receive data from his domain's computer}

showtime(wherex,wherey);

writeln('> ',tmpFrom.router,'.',tmpFrom.domain,'.',tmpFrom.comp,

' says : I send data ','"',batch.data,'"',' for ',batch.to_.router,'.',batch.to_.domain,'.',

batch.to_.comp,' to router',i);

for i:=1 to 38 do if

(computers[i].addr.router=tmpFrom.router) AND (computers[i].addr.domain=tmpFrom.domain)

AND (computers[i].addr.comp=tmpFrom.comp) then break;

computers[i].mem.data:='';{clear memory}

End;

Procedure TComp.Send(batch:TBatch);{into domain}

VAR i:byte;tmpTo,tmpFrom:TAddr;

Begin

Delay(DelayInDomain);

tmpTo:=batch.to_;tmpFrom:=batch.from;

for i:=1 to 38 do if

(computers[i].addr.router=tmpTo.router) AND (computers[i].addr.domain=tmpTo.domain)

AND (computers[i].addr.comp=tmpTo.comp) then break;

computers[i].mem:=batch; {Send !}

showtime(wherex,wherey);

writeln('> ',tmpFrom.router,'.',tmpFrom.domain,'.',tmpFrom.comp,

' says : I send data ','"',batch.data,'"',' to ',batch.to_.router,'.',batch.to_.domain,'.',

batch.to_.comp);

for i:=1 to 38 do if

(computers[i].addr.router=tmpFrom.router) AND (computers[i].addr.domain=tmpFrom.domain)

AND (computers[i].addr.comp=tmpFrom.comp) then break;

computers[i].mem.data:='';{clear memory}

End;

Procedure TComp.Receive(batch:TBatch;byRouter:boolean);{computer receive data from his domain's router}

VAR tmpTo:TAddr;

Begin

Delay(DelayInDomain);

tmpTo:=batch.to_;

showtime(wherex,wherey);

write('> ',tmpTo.router,'.',tmpTo.domain,'.',tmpTo.comp,

' says : I receive data ','"',batch.data,'"',' from ',batch.from.router,'.',batch.from.domain,'.',

batch.from.comp);

if byRouter then writeln(' by router',tmpTo.router);

End;

{-------------Router procedures-------------------}

Procedure TRouter.CalcMinPath(sender,target:byte);

VAR i,j:byte;

k:byte;

AllVertexMarked:boolean;

Begin

{----------------------- Initialization --------------------------}

for i:=1 to 7 do

for j:=1 to 7 do if AdjacencyMatrix[i,j]=1 then AMatr[i,j].link:=1

else AMatr[i,j].link:=0;

for i:=1 to 7 do for j:=1 to 7 do AMatr[i,j].weight:=0;

Randomize;

For j:=2 to7 do for i:=1 to j-1 do AMatr[i,j].weight:=random(50);

for i:=1 to 7 do vertexArr[i].marked:=false;

{-------------------------- Make marks -----------------------------}

{---- mark last vertex ----}

vertexArr[target].mark.delta:=0;vertexArr[target].mark.prevPtr:=target;

vertexArr[target].marked:=true;

AllVertexMarked:=false;

While not AllVertexMarked do BEGIN

For j:=1 to 7 do

For i:=1 to 7 do begin {j--->i}

if (AMatr[i,j].link<>0) AND (vertexArr[j].marked)

AND (not vertexArr[i].marked) then begin

if not ((vertexArr[j].marked) AND (j=sender)) then begin

vertexArr[i].mark.delta:=vertexArr[j].mark.delta+AMatr[j,i].weight;

vertexArr[i].mark.prevPtr:=j;

vertexArr[i].marked:=true;

end;

End;

AllVertexMarked:=true;

for i:=1 to 7 do if vertexArr[i].marked=false then AllVertexMarked:=false;

END;{While not AllVertexMarked}

{-------------------------- Main test -----------------------------}

for i:=1 to 49 do OptimalPath[i]:=0;

For i:=1 to 7 do vertexArr[i].marked:=false;

vertexArr[sender].marked:=true;

For j:=1 to 7 do

For i:=1 to 7 do begin {---- deltaA-deltaB > d(AB) then change mark}

{} if (vertexArr[j].marked) AND (not(vertexArr[i].marked)) then begin

vertexArr[i].marked:=true;

for k:=1 to 7 do if (AMatr[k,j].link=1) then begin

if vertexArr[j].mark.delta-vertexArr[k].mark.delta>AMatr[k,j].weight

then begin

vertexArr[j].mark.prevPtr:=k;

vertexArr[j].mark.delta:=vertexArr[k].mark.delta+AMatr[k,j].weight;

vertexArr[k].marked:=true;

end {else vertexArr[k].marked:=true};

end;

{} end; {if adjacency vertex found}

push(sender);

k:=vertexArr[sender].mark.prevPtr;

push(k);

While k<>target do begin

push(vertexArr[k].mark.PrevPtr);

k:=vertexArr[k].mark.PrevPtr;

End;

Procedure TRouter.Send2NextRouter(batch:TBatch;currentRouter:byte);

Begin

Delay(DelayRouterReceive+AMatr[currentRouter,OptimalPath[OptPathPtr]].link);

showtime(wherex,wherey);

writeln('> router',currentRouter,

' says : I send data ','"',batch.data,'"',' from ',batch.from.router,'.',batch.from.domain,'.',

batch.from.comp,' to router',OptimalPath[OptPathPtr]);

routers[OptimalPath[OptPathPtr]].memory:=batch;

inc(OptPathPtr);

routers[currentRouter].memory.data:=''{clear memory}

End;

Procedure TRouter.receive(routerNum:byte;batch:TBatch);

Begin

Delay(DelayRouterReceive);

showtime(wherex,wherey);

writeln('> router',routerNum,

' says : I receive data ','"',batch.data,'"',' from ',batch.from.router,'.',batch.from.domain,'.',

batch.from.comp);

End;

Procedure TRouter.send2comp(batch:TBatch);

VAR i:byte;tmpTo,tmpFrom:TAddr;

Begin

Delay(DelayInDomain);

tmpTo:=batch.to_;tmpFrom:=batch.from;

for i:=1 to 38 do if

(computers[i].addr.router=tmpTo.router) AND (computers[i].addr.domain=tmpTo.domain)

AND (computers[i].addr.comp=tmpTo.comp) then break;

computers[i].mem:=batch; {Send !}

showtime(wherex,wherey);

writeln('> router',tmpTo.router,

' says : I send data ','"',batch.data,'"',' to ',batch.to_.router,'.',batch.to_.domain,'.',

batch.to_.comp);

routers[tmpTo.router].memory.data:='';{clear memory}

End;

Procedure Initialization;

VAR i,j:integer;

Begin

{------------- INITIALIZATION PART -------------}

FOR i:=1 to 7 do begin {routers initialization}

routers[i].num:=i;routers[i].state:=true;

routers[i].memory.data:='';

for j:=1 to 20 do routers[i].memory.path[j]:=0;

END;

routers[1].x:=120;routers[1].y:=300;

routers[2].x:=250;routers[2].y:=100;

routers[3].x:=320;routers[3].y:=300;

routers[4].x:=300;routers[4].y:=420;

routers[5].x:=500;routers[5].y:=420;

routers[6].x:=540;routers[6].y:=200;

routers[7].x:=550;routers[7].y:=100;

FOR i:=1 to 38 do computers[i].mem.data:='';{computers initialization}

j:=1;

for i:=1 to 4 do begin {router 1, domain 1}

computers[i].addr.router:=1;computers[i].addr.domain:=1;