Реферат: Проектирование и разработка сетевых броузеров на основе теоретико-графовых моделей
МИНИСТЕРСТВО ОБРАЗОВАНИЯ И НАУКИ УКРАИНЫ
ТАВРИЧЕСКИЙ НАЦИОНАЛЬНЫЙ УНИВЕРСИТЕТ
им. В.И.Вернандского
МАТЕМАТИЧЕСКИЙ ФАКУЛЬТЕТ
КАФЕДРА ИНФОРМАТИКИ
ДИПЛОМНАЯ РАБОТА
Проектирование и разработка
сетевых броузеров
на основе теоретико-графовых моделей
Выполнилстудент 5 курса
специальности «информатика»
_________________Поляков Т.И.
Симферополь
2000 г.
Содержание
Введение 2
Глава I. Теоретико-графовые модели организации сетевых структур 3
1.1. Основные понятия теории графов 3
1.2. Графовые алгоритмы 5
Глава II. Сетевые структуры на базе теоретико-графовых моделей 11
2.1. Методы построения сетевых структур 11
2.2. Классификация существующих методов организации сетей 12
2.3. Глобальная сеть Internet 16
2.4. Основы сетевой маршрутизации 20
2.5. Алгоритмы маршрутизации 24
Глава III. Сетевые броузеры 33
3.1. Описание стандартного броузера 33
3.2. Характеристика существующих систем поиска 33
3.3. Особенности создания броузеров в визуальных средах
программирования 40
Глава IÑ. Программная реализация 44
4.1. Архитектура системы “броузер” 44
4.2. Основные процедуры броузера 45
4.3. Архитектура имитационной модели глобальной сети 47
4.4. Основные процедуры имитационной модели 48
Заключение 50
Список литературы 51
Приложение 1 – исходный текст программы “броузер” 52
Приложение 2 – исходный текст модели корпоративной сети 91
Введение
Актуальность
В связи с расширением глобальной сети Internet возрастает необходимость
внедрения новых оптимизационныхалгоритмов, связанных со скоростью обмена данных
между компьютерами в единой сети. Компьютерные сети завоевывают мир. Системы из
маленьких компьютеровпревращаются в огромные хранилища данных, доступные всему
миру. Любая современная фирма, любой офис оснащен хотя бы простейшей сетью. Не
выходя издома, сотни тысяч людей работают на персональных компьютерах, принося
пользу всему миру. В основном для работы в Internet
используютсяпрограммы-броузеры. Эти программы позволяют легко обмениваться
текстовой, графической и звуковой информацией, используяпопулярную, простую в
обращении мультемедийную службу ИНТЕРНЕТ World Wide Web.
Цель
Цель данной работы заключается в следующем :
- разработка математической модели сетевого броузера и корпоративной среды;
- создание имитационной модели распределении информации в глобальных сетях.
Для достижения данной цели были решены следующие задачи:
1.) Проведен анализ существующих броузеров;
2.) Рассмотрены основные топологии существующих корпоративных сетей;
3.) Разработан алгоритм определения оптимального маршрута передачи
информации по глобальной сети.
1.Теоретико – графовые модели
организации сетевых структур
1.1. Основные понятия теории графов
Определение. Множество Х=и набор U неупорядоченных пар объектов () из Х
называется графом Г. Объекты множества Х называютсявершинами графа, а наборы
объекта U – ребрами графа. Про ребра будем говорить, что они соединяют вершины и
.В случае, если множество Х и набор U состоят из конечного числа объектов и пар,
то граф Гназывается конечным.
Пусть и - произвольные вершины графа Г.
Определение. Система ребер графа Г называется путем, соединяющим
вершины и .
Определение.Путь , не проходящий дважды одно ребро, называется циклом,если =. В
частности, цикл будем называть петлей.
Определение. Граф Г называется связным, если для любых двух различных
вершин и графа Г существует путь, соединяющий эти вершины.
Рис. 1
Легко видеть, что граф из примера 1 является конечным, несвязным и содержащим
петли.
Определение. графы Г и Г` называются изоморфными, если существует
взаимнооднозначное соответствие между их вершинами и ребрами такое, что
соответствующие ребра соединяют соответствующие вершины.
Определение. Граф Г` называется подграфом Г, если его вершины иребра принадлежат
графу Г.
Длиной пути в графе называют сумму длин входящих в этот путь ребер.
Определение. Деревом называется конечный связный граф свыделенной вершиной,
именуемой корнем, не содержащий циклов.
Если в графе можно выделить более одного дерева, которые не связны между собой,
то такой граф называют лесом.
Рис 2. Лес, имеющий две компоненты связности (2 дерева).
Будем далее обозначать через Х – множество вершин и U – множество ребер графа, а
сам граф, определяемый этойпарой объектов, будем обозначать ;
x ÎX, u ÎU. Обозначим длину дуги u=(x,y) через d(u). Кратчайшую длину пути изх
в
z обозначим D(x,z).
Очевидно, если кратчайший путь из x в z существует и проходит через
промежуточную вершину w, то D(x,z) = D(x,w) + D(w,z). Эта формула справедлива
для любой промежуточнойвершины w рассматриваемого пути, в том числе и для
последней, смежной с конечной вершиной w. Поэтому кратчайший путь можно
отыскать,последовательно переходя от конечной вершины z в ближайшую смежную и
запоминая цепочку построенныхвершин (конечно, при условии, что хотя бы один путь
между вершинами x и z существует и граф не содержит циклов. Эта идея и
является в сущности принципом Р.Беллмана.
1.2. Графовые алгоритмы
Алгоритм Беллмана поиска кратчайшего пути между двумя вершинами связного графа,
не имеющегоциклов с неотрицательными длинами ребер. Его описание приводится ниже
при помощи алгоритмической схемы.
Идентификаторы :
D[w] – рабочий массив, при вычислениях интерпретируется как кратчайшая длина из
вершины w в вершину z.
wÎX.
d[s,t] – массив длин ребер графа для каждой пары вершин s,t ÎX. Если некоторое
реброотсутствует, то в элементе этого массива полагается записанным некоторое
достаточно большое число, превышающее сумму длин всех реберграфа.
Stack – последовательность вершин, определяющая кратчайший путь из x в z.
Begin
Stack:=’’; // Очистить Stack.
Stack
w:=z; // Запомнить первую пройденную вершину.
D[z]:=0; // Обнуление длины пути из вершины z внее же.
While w=/=x do // Пока не будет достигнута начальная вершина, выполнять
// перебор вершин графа
p:= вершина, для которой величина D[p] = d[p,w]+D[w] минимальна. Если таких
вершин несколько и среди нихимеется вершина x, то p:=x, если же среди них нет
вершины x – взятьлюбую из доставляющих минимум сумме.
Stack
w:=p; // и взять ее для построения следующего шага.
End;
End.
Пусть число вершин графа X=n, а число ребер U=m. Оценим сложность этого
алгоритма как число шаговвыполнения алгоритмической схемы, считая одним шагом
выполнение ровно одного выполнимого оператора, каковые представлены только
строками 2,3,4,5,6,8,9. В худшем случае выбор вершины в строке 8 (по
минимумурасстояния) произойдет в результате просмотра всех n вершин, а цикл с
заголовком в строке 6 повторится длявсех вершин, поэтому сложность алгоритма
можно оценить как C*n^2, где С –некоторая константа, учитывающая реализацию
алгоритма в произвольной вычислительной среде.
Следующий алгоритм обеспечивает нахождение кратчайших расстояний от
фиксированной вершины х, называемой источником, довсех остальных вершин графа с
ограничением, предполагающим отсутствие в графе контуров отрицательной длины
(сумма длин ребер, входящих в любой контур,неотрицательна).
Алгоритм Форда-Беллмана
Идентификаторы : d[s,t] – массив длин ребер графа для каждой пары вершин
s,t ÎX. Если ребра нет, тосоответствующий элемент этого массива
содержит достаточно большое число.
х – вершина-источник графа .
n=X - число вершин графа.
u,w,k – рабочие переменные.
D[w] – массив, в котором к концу работы алгоритма будут содержаться кратчайшие
длины путей из х в w для всех вершин
wÎX.
Begin
D[x]:=0; // Длина пути из источника x.
For w ÎX do D[w]:=d[x,w]; // Инициализация матрицы расстояний
For k:=1 to n-2 do // Повторять n-2 раз
For w Î{X{x}} do // Цикл по всем вершинам,кроме источника.
For u ÎX do D[w]:=min(D[w],D[u]+d[u,w]); // выбор минимума.
End.
Этот алгоритм также основан на соотношении (принципе оптимальности) Беллмана.
Всякий раз, когда находится путь через транзитную вершину u, который короче
найденного пути из х в w, он заменяется на более короткий путь. Это
соотношениедолжно проверяться для любой возможной из n-2 транзитных вершин при
оценке пути в каждую вершину,поэтому в алгоритме имеется цикл, определенный в
строке 4.
Алгоритм Дейкстры нахождения кратчайших расстояний от источника до всехостальных
вершин применим только тогда, когда граф не имеет контуров или когда веса всех
ребер неотрицательны.
Идентификаторы :
d[s,t] – массив длин ребер графа для каждой пары вершин
s,t ÎX. Если ребра нет, то соответствующий элемент этого массива
содержитдостаточно большое число.
х – вершина-источник графа .
n=X - число вершин графа.
u,w – рабочие переменные.
D[w] – массив, в котором к концу работы алгоритма будут содержаться кратчайшие
длины путей из x в w для всех вершин w ÎX.
BEGIN
D[x]:=0;
For w ÎX do D[w]:=d[x,w];
T:={X{x}};
While T== do
Begin
w:=вершина r из T такая, что D[r]=min{D[p]:p из T};
T:={T{w}};
For u ÎT do D[w]:=min[D[w],D[u]+d[u,w]];
End
END
Алгоритм Форда-Фалкерсона нахождения максимального потока в сети.
Многие задачи исследования операций сводятся к анализу потоков, маршрутов,
последовательностей событий, протекающих со времени, идругих процессов, которые
можно представить в виде множества взаимосвязанных элементов. Для
математического представления таких процессов удобно их заданиев виде графов.
Рассмотрим конечный ориентированный граф Г=(X,u), в котором
Х={x1,...,xn}-множество вершин,U – множество дуг.
Пусть x ÎX. Обозначим E+(x) – множество дуг графа, входящих в х, E-(x) –
выходящихиз х.
Множества начальных вершин дуг из Е+(х) и множество конечных вершин дуг из Е-(х)
обозначим соответственно S+(x) и S-(x).
E+(x) E-(x)
y x
y
S+(x)
S-(x)
Рис. 3. Окрестность вершины графа.
Граф Г называют транспортнойсетью, если каждой дуге u соответствует целое число
c(u)>=0 и найдутся x0 и z из Х такие, что Е+(х0)=
Е-(z)= . Вершина х0 называется истоком, z-стоком, c(u) – пропускной
способностью дуги. Потоком в транспортной сети называют целочисленную функцию
ф(u), удовлетворяющую следующим условиям :
1) 0= 0) and (HistoryIndex < HistoryList.Count - 1) then>
while HistoryList.Count > HistoryIndex do
HistoryList.Delete(HistoryIndex);
HistoryIndex := HistoryList.Add(URL);
end
else
HistoryIndex := NewIndex;
if HistoryList.Count > 0 then
begin
ForwardBtn.Enabled := HistoryIndex < HistoryList.Count - 1;>
BackBtn.Enabled := HistoryIndex > 0;
end
else
begin
ForwardBtn.Enabled := False;
BackBtn.Enabled := False;
end;
if UpdateCombo then
begin
UpdateCombo := False;
NewIndex := URLs.Items.IndexOf(URL);
if NewIndex = -1 then
URLs.Items.Insert(0, URL)
else
URLs.Items.Move(NewIndex, 0);
end;
URLs.Text := URL;
Statusbar1.Panels[0].Text := URL;
end;
procedure TMainForm.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Shift = [ssAlt] then
if (Key = VK_RIGHT) and ForwardBtn.Enabled then
ForwardBtn.Click
else if (Key = VK_LEFT) and BackBtn.Enabled then
BackBtn.Click;
end;
procedure TMainForm.Toolbar3Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
Coolbar1.Visible := Checked;
end;
end;
procedure TMainForm.Statusbar2Click(Sender: TObject);
begin
with Sender as TMenuItem do
begin
Checked := not Checked;
StatusBar1.Visible := Checked;
end;
end;
procedure TMainForm.HomePageRequest(var Message: TMessage);
begin
URLs.Text := 'http://www.altavista.com';
UpdateCombo := True;
FindAddress;
end;
procedure TMainForm.FormCreate(Sender: TObject);
begin
HistoryIndex := -1;
HistoryList := TStringList.Create;
{ Load the animation from the AVI file in the startup directory. An
alternative to this would be to create a .RES file including the cool.avi
as an AVI resource and use the ResName or ResId properties of Animate1 to
point to it. }
Animate1.FileName := ExtractFilePath(Application.ExeName) + 'cool.avi';
{ Find the home page - needs to be posted because HTML control hasn't been
registered yet. }
PostMessage(Handle, CM_HOMEPAGEREQUEST, 0, 0);
end;
procedure TMainForm.FormDestroy(Sender: TObject);
begin
HistoryList.Free;
end;
procedure TMainForm.ToolButton2Click(Sender: TObject);
begin
TMail.create(Application).showmodal;
end;
procedure TMainForm.ToolButton3Click(Sender: TObject);
begin
TMyFtp.create(Application).showmodal;
end;
procedure TMainForm.ToolButton4Click(Sender: TObject);
begin
TNewsForm.create(Application).showmodal;
end;
procedure TMainForm.ToolButton9Click(Sender: TObject);
begin
TChatForm.create(Application).showmodal;
end;
end.
файл chat.pas
unit chat;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, StdCtrls, Buttons, ScktComp, ExtCtrls, ComCtrls;
type
TChatForm = class(TForm)
MainMenu1: TMainMenu;
File1: TMenuItem;
Exit1: TMenuItem;
FileConnectItem: TMenuItem;
FileListenItem: TMenuItem;
StatusBar1: TStatusBar;
Bevel1: TBevel;
Panel1: TPanel;
Memo1: TMemo;
Memo2: TMemo;
N1: TMenuItem;
SpeedButton1: TSpeedButton;
Disconnect1: TMenuItem;
ServerSocket: TServerSocket;
ClientSocket: TClientSocket;
procedure FileListenItemClick(Sender: TObject);
procedure FileConnectItemClick(Sender: TObject);
procedure Exit1Click(Sender: TObject);
procedure Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure FormCreate(Sender: TObject);
procedure ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source,
HelpFile: string; HelpContext: Integer; var CancelDisplay: Wordbool);
procedure Disconnect1Click(Sender: TObject);
procedure ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketRead(Sender: TObject; Socket: TCustomWinSocket);
procedure ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
procedure ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
procedure ClientSocketError(Sender: TObject; Socket: TCustomWinSocket;
ErrorEvent: TErrorEvent; var ErrorCode: Integer);
procedure ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
protected
IsServer: Boolean;
end;
var
ChatForm: TChatForm;
Server: String;
implementation
{$R *.DFM}
procedure TChatForm.FileListenItemClick(Sender: TObject);
begin
FileListenItem.Checked := not FileListenItem.Checked;
if FileListenItem.Checked then
begin
ClientSocket.Active := False;
ServerSocket.Active := True;
Statusbar1.Panels[0].Text := 'Listening...'
end
else
begin
if ServerSocket.Active then
ServerSocket.Active := False;
Statusbar1.Panels[0].Text := '';
end;
end;
procedure TChatForm.FileConnectItemClick(Sender: TObject);
begin
if ClientSocket.Active then ClientSocket.Active := False;
if InputQuery('Computer to connect to', 'Address Name:', Server) then
if Length(Server) > 0 then
with ClientSocket do
begin
Host := Server;
Active := True;
end;
end;
procedure TChatForm.Exit1Click(Sender: TObject);
begin
ServerSocket.Close;
ClientSocket.Close;
Close;
end;
procedure TChatForm.Memo1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = VK_Return then
if IsServer then
ServerSocket.Socket.Connections[0].SendText(Memo1.Lines[Memo1.Lines.Count-
1])
else
ClientSocket.Socket.SendText(Memo1.Lines[Memo1.Lines.Count - 1]);
end;
procedure TChatForm.FormCreate(Sender: TObject);
begin
FileListenItemClick(nil);
end;
procedure TChatForm.ServerSocketError(Sender: TObject; Number: Smallint;
var Description: string; Scode: Integer; const Source, HelpFile: string;
HelpContext: Integer; var CancelDisplay: Wordbool);
begin
ShowMessage(Description);
end;
procedure TChatForm.Disconnect1Click(Sender: TObject);
begin
ClientSocket.Close;
FileListenItemClick(nil);
end;
procedure TChatForm.ClientSocketConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Statusbar1.Panels[0].Text := 'Connected to: ' + Socket.RemoteHost;
end;
procedure TChatForm.ClientSocketRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure TChatForm.ServerSocketClientRead(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Add(Socket.ReceiveText);
end;
procedure TChatForm.ServerSocketAccept(Sender: TObject;
Socket: TCustomWinSocket);
begin
IsServer := True;
Statusbar1.Panels[0].Text := 'Connectedto: ' + Socket.RemoteAddress;
end;
procedure TChatForm.ServerSocketClientConnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
Memo2.Lines.Clear;
end;
procedure TChatForm.ClientSocketDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
FileListenItemClick(nil);
end;
procedure TChatForm.ClientSocketError(Sender: TObject;
Socket: TCustomWinSocket; ErrorEvent: TErrorEvent;
var ErrorCode: Integer);
begin
Memo2.Lines.Add('Error connecting to : ' + Server);
ErrorCode := 0;
end;
procedure TChatForm.ServerSocketClientDisconnect(Sender: TObject;
Socket: TCustomWinSocket);
begin
ServerSocket.Active := False;
FileListenItem.Checked := not FileListenItem.Checked;
FileListenItemClick(nil);
end;
end.
файл ftp.pas
unit ftp;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls, ComCtrls, OleCtrls, Menus, ExtCtrls, isp3;
const
FTPServer = 0;
Folder = 1;
OpenFolder = 2;
type
TMyFtp = class(TForm)
Bevel1: TBevel;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
StatusBar: TStatusBar;
FileList: TListView;
DirTree: TTreeView;
ConnectBtn: TSpeedButton;
FTP: TFTP;
RefreshBtn: TSpeedButton;
MainMenu1: TMainMenu;
FileMenu: TMenuItem;
FileNewItem: TMenuItem;
FileDeleteItem: TMenuItem;
FileRenameItem: TMenuItem;
N2: TMenuItem;
FileExitItem: TMenuItem;
View1: TMenuItem;
ViewLargeItem: TMenuItem;
ViewSmallItem: TMenuItem;
ViewListItem:TMenuItem;
ViewDetailsItem: TMenuItem;
N1: TMenuItem;
ViewRefreshItem: TMenuItem;
FilePopup: TPopupMenu;
DeleteItem: TMenuItem;
RenameItem: TMenuItem;
CopyItem: TMenuItem;
Bevel2: TBevel;
Label1: TLabel;
Bevel3: TBevel;
Bevel5: TBevel;
Label2: TLabel;
SaveDialog1: TSaveDialog;
CopyButton: TSpeedButton;
LargeBtn: TSpeedButton;
SmallBtn: TSpeedButton;
ListBtn: TSpeedButton;
DetailsBtn: TSpeedButton;
Tools1: TMenuItem;
ToolsConnectItem: TMenuItem;
ToolsDisconnectItem: TMenuItem;
FileCopyItem: TMenuItem;
PasteFromItem: TMenuItem;
OpenDialog1: TOpenDialog;
SmallImages: TImageList;
procedure ConnectBtnClick(Sender: TObject);
procedure FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure FTPBusy(Sender: TObject; isBusy: Wordbool);
procedure DirTreeChange(Sender: TObject; Node: TTreeNode);
procedure RefreshBtnClick(Sender: TObject);
procedure DirTreeChanging(Sender: TObject; Node: TTreeNode;
var AllowChange: Boolean);
procedure FTPStateChanged(Sender: TObject; State: Smallint);
procedure Open1Click(Sender: TObject);
procedure FileExitItemClick(Sender: TObject);
procedure FormResize(Sender: TObject);
procedure ViewLargeItemClick(Sender: TObject);
procedure ViewSmallItemClick(Sender: TObject);
procedure ViewListItemClick(Sender: TObject);
procedure ViewDetailsItemClick(Sender: TObject);
procedure ViewRefreshItemClick(Sender: TObject);
procedure CopyItemClick(Sender: TObject);
procedure ToolsDisconnectItemClick(Sender: TObject);
procedure FileNewItemClick(Sender: TObject);
procedure DeleteItemClick(Sender: TObject);
procedure PasteFromItemClick(Sender: TObject);
procedure FilePopupPopup(Sender: TObject);
procedure FileMenuClick(Sender: TObject);
procedure FileDeleteItemClick(Sender: TObject);
procedure FTPListItem(Sender: TObject; const Item: FTPDirItem);
private
Root: TTreeNode;
function CreateItem(const FileName, Attributes, Size, Date: Variant):
TListItem;
procedure Disconnect;
public
function NodePath(Node: TTreeNode): String;
end;
var
Myftp: TMyFtp;
UserName,
Pwd: String;
implementation
{$R *.DFM}
uses ShellAPI, UsrInfo;
function FixCase(Path: String): String;
var
OrdValue: byte;
begin
if Length(Path) = 0 then exit;
OrdValue := Ord(Path[1]);
if (OrdValue >= Ord('a')) and (OrdValue
Result := Path
else
begin
Result := AnsiLowerCaseFileName(Path);
Result[1] := UpCase(Result[1]);
end;
end;
procedure TMyFtp.ConnectBtnClick(Sender: TObject);
begin
if FTP.State = prcConnected then
Disconnect;
ConnectForm := TConnectForm.Create(Self);
try
if ConnectForm.ShowModal = mrOk then
with FTP, ConnectForm do
begin
UserName := UserNameEdit.Text;
Pwd := PasswordEdit.Text;
RemoteHost := RemoteHostEdit.Text;
RemotePort := StrToInt(RemotePortEdit.Text);
Connect(RemoteHost, RemotePort);
Root := DirTree.Items.AddChild(nil, RemoteHost);
Root.ImageIndex := FTPServer;
Root.SelectedIndex := FTPServer;
DirTree.Selected := Root;
end;
finally
ConnectForm.Free;
end;
end;
procedure TMyFtp.FTPProtocolStateChanged(Sender: TObject;
ProtocolState: Smallint);
begin
case ProtocolState of
ftpAuthentication: FTP.Authenticate(UserName, Pwd);
ftpTransaction: FTP.List('/');
end;
end;
procedure TMyFtp.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if FTP.Busy then
begin
FTP.Cancel;
FTP.Quit;
while FTP.Busy do
Application.ProcessMessages;
end;
end;
function TMyFtp.CreateItem(const FileName, Attributes, Size, Date: Variant):
TListItem;
var
Ext: String;
ShFileInfo: TSHFILEINFO;
begin
Result := FileList.Items.Add;
with Result do
begin
Caption := FixCase(Trim(FileName));
if Size > 0 then
begin
if Size div 1024 0 then
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;
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
SmallImages := 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;
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;
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;
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;
end;
end;
procedure TMyFtp.Open1Click(Sender: TObject);
begin
FTP.Quit;
DirTree.Items.BeginUpdate;
try
DirTree.Items.Clear;
finally
DirTree.Items.EndUpdate;
end;
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;
end;
procedure TParser.NextToken;
var
P, TokenStart: PChar;
begin
SkipBlanks;
FTokenString := '';
P := FSourcePtr;
while (P^ #0) and (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;
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;
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;
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;
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;
end;
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;
end;
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;
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;
end;
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;
end;
efGetArticleHeaders: ParseHeaders(Data);
efGetArticle:
begin
Memo1.SelStart := 0;
SendMessage(Memo1.Handle, EM_ScrollCaret, 0, 0);
end;
end;
SetLength(Data, 0);
end;
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;
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;
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;
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 databefore
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 errorcode, 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;
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;
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;
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;
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;
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;
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] ofbyte =(
(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:langtpbgi');
SetTextStyle(DefaultFont,HorizDir,2);SetColor(lightRed);
OutTextXY(10,20,'Arrangement scheme of routers');
SetColor(white);Rectangle(5,15,480,40);
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 hisdomain'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].link0) 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;
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;
{} end; {if adjacency vertex found}
push(sender);
k:=vertexArr[sender].mark.prevPtr;
push(k);
While ktarget do begin
push(vertexArr[k].mark.PrevPtr);
k:=vertexArr[k].mark.PrevPtr;
End;
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;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=5 to 10 do begin {router 1, domain 2}
computers[i].addr.router:=1;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end; {router 2, domain 1}
computers[11].addr.router:=2;computers[11].addr.domain:=1;computers[11].addr.comp:=1;
j:=1;
for i:=12 to 14 do begin {router 2, domain 2}
computers[i].addr.router:=2;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=15 to 17 do begin {router 3, domain 1}
computers[i].addr.router:=3;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=18 to 20 do begin {router 4, domain 1}
computers[i].addr.router:=4;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=21 to 25 do begin {router 4, domain 2}
computers[i].addr.router:=4;computers[i].addr.domain:=2;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=26 to 30 do begin {router 5, domain 1}
computers[i].addr.router:=5;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=31 to 34 do begin {router 6, domain 1}
computers[i].addr.router:=6;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
j:=1;
for i:=35 to 38 do begin {router 7, domain 1}
computers[i].addr.router:=7;computers[i].addr.domain:=1;
computers[i].addr.comp:=j;inc(j);
end;
{------------- END OF INITIALIZATION PART -------------}
End;
Procedure Error(ErrorNum:byte);
Begin
textcolor(lightred);
writeln(' Error !');
case ErrorNum of
1: writeln(' One (or two) of above addresses are not exist');
2: writeln(' FROM and TO are same');
end;
readln;halt;
End;
VAR tmpStr :string;
tmpFrom :TAddr;
tmpTo :TAddr;
tmpData :string;
i,j :integer;
tmpX,tmpY:integer;
FromNum,ToNum:byte; {index FROM and TO computers in array}
BEGIN {------------- MAIN PROGRAM ---------------}
Initialization;
ShowGraphics(false);readln;CloseGraph;
ClrScr;TextColor(LightGreen);
write(' Global Network Emulation ');ShowTime(70,1);writeln;
{------------- ADDRESS AND DATA REQUEST ---------------}
Write(' Enter FROM address (X.X.X) : ');readln(tmpStr);{FROM request-------}
Val(tmpStr[1],tmpFrom.router,i);Val(tmpStr[3],tmpFrom.domain,i);
Val(tmpStr[5],tmpFrom.comp,i);{target request-----------------------------}
Write(' Enter TO address (X.X.X) : ');readln(tmpStr);
Val(tmpStr[1],tmpTo.router,i);Val(tmpStr[3],tmpTo.domain,i);
Val(tmpStr[5],tmpTo.comp,i);
Write(' Enter string-type DATA : ');readln(tmpData);
{------------- SEARCH 'FROM' TERMINAL -------------------}
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 FromNum:=i;
{------------- SEARCH 'TO' TERMINAL ----------------------}
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 ToNum:=i;
if (FromNum=0) OR (ToNum=0) then Error(1);
if FromNum=ToNum then Error(2);{computer cannotsend batch to itself}
{------------- FILL 'ADDRESS' FIELDS-----------------------}
computers[FromNum].mem.to_.router:=tmpTo.router;
computers[FromNum].mem.to_.domain:=tmpTo.domain;
computers[FromNum].mem.to_.comp:=tmpTo.comp;
computers[FromNum].mem.from.router:=tmpFrom.router;
computers[FromNum].mem.from.domain:=tmpFrom.domain;
computers[FromNum].mem.from.comp:=tmpFrom.comp;
{------------- FILL DATA FIELDS-----------------------}
computers[FromNum].mem.data:=tmpData;
writeln;
OptPathPtr:=0;
if computers[FromNum].mem.from.routercomputers[FromNum].mem.to_.router
then routers[tmpFrom.router].CalcMinPath(tmpFrom.router,tmpTo.router);
OptPathPtr:=2;
WHILE TRUE DO BEGIN {-------------- GLOBAL NET SCANNING ------------------}
for i:=1 to 38 do {------scanning terminals for data for sending --------}
{} if computers[i].mem.data'' then begin
if (computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
AND (computers[i].addr.compcomputers[i].mem.to_.comp)
then begin
computers[i].send(computers[i].mem);{into domain sending}
break;
end else if (computers[i].addr.routercomputers[i].mem.to_.router)
OR (computers[i].addr.domaincomputers[i].mem.to_.domain)
then computers[i].Send2Router(computers[i].mem); {send to router}
{} end;{if data for sending found}
for i:=1 to 7 do {------scanning routers for receiving data}
if routers[i].memory.data'' then begin
routers[i].receive(i,routers[i].memory);
if routers[i].memory.to_.router=i then begin {if send into domain}
routers[i].send2comp(routers[i].memory);
break;
end else begin
routers[i].send2nextRouter(routers[i].memory,i);
break;
end;
end; {-------------------------------}
for i:=1 to 38 do {------scanning terminals for receiving data}
if computers[i].mem.data'' then begin
if (computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
then begin {into domain receiving}
computers[i].receive(computers[i].mem,false);
break;
end; {---------------------}
computers[i].receive(computers[i].mem,true);{receiving from router}
break;
end;{if receive data found}
for i:=1 to 38 do
if (computers[i].mem.data'')
AND(computers[i].addr.router=computers[i].mem.to_.router)
AND (computers[i].addr.domain=computers[i].mem.to_.domain)
AND (computers[i].addr.comp=computers[i].mem.to_.comp)
then while true do begin {---------Batch received !---------}
HiddenCursor;
tmpX:=wherex;tmpY:=whereY;
ShowTime(70,1);
gotoXY(tmpX,tmpY);
if keypressed then begin
readkey;
ShowGraphics(true);
readln;
CloseGraph;
NormVideo;
NormalCursor;
halt;
end;
end;
tmpX:=wherex;tmpY:=whereY;
ShowTime(70,1);
gotoXY(tmpX,tmpY);
END;{-------------- END OF GLOBAL NET SCANNING ---------------------------}
END.