169102 (595713), страница 8

Просмтор этого файла доступен только зарегистрированным пользователям. Но у нас супер быстрая регистрация: достаточно только электронной почты!

Текст из файла (страница 8)

//поиск файла по маске

procedure FindFiles(StartFolder, Mask: string; List: TStrings;

ScanSubFolders: Boolean = True);

var

SearchRec: TSearchRec;

FindResult: Integer;

begin

List.BeginUpdate;

try

StartFolder := IncludeTrailingBackslash(StartFolder);

FindResult := FindFirst(StartFolder + '*.*', faAnyFile, SearchRec);

try

while FindResult = 0 do

with SearchRec do

begin

if (Attr and faDirectory) <> 0 then

begin

if ScanSubFolders and (Name <> '.') and (Name <> '..') then

FindFiles(StartFolder + Name, Mask, List, ScanSubFolders);

end

else

begin

if MatchesMask(Name, Mask) then begin

List.Add(copy(Name,5,4));

//showmessage(StartFolder + Name);

end;

end;

FindResult := FindNext(SearchRec);

end;

finally

FindClose(SearchRec);

end;

finally

List.EndUpdate;

end;

end;

procedure TForm1.FormCreate(Sender: TObject);

begin

DecimalSeparator:=MyDecimalSeparator;

end;

procedure TForm1.FormActivate(Sender: TObject);

begin

dir_path:=ReadIni;

edit1.Text:=dir_path;

{--}

end;

procedure TForm1.BitBtn1Click(Sender: TObject);

var

h,h2:textfile;

i,j,k,n:integer;

s_temp:string;

s: array of array of string;

begin

dir_path:=edit1.Text;

checklistbox1.Items.Clear;

i:=0;

AssignFile(h,dir_path+'\WORK\activ2.txt');

reset(h);

//readln(h,s_temp);

while not EOF(h) do begin//чтение файла (установка размера массива)

readln(h,s_temp);

inc(i);

end;

closefile(h);

setlength(s,i,2);

AssignFile(h2,dir_path+'\WORK\activ2.txt');

reset(h2);

for j:=0 to i-1 do begin

readln(h2,s_temp);

s[j,0]:=copy(s_temp,24,4);

s[j,1]:=copy(s_temp,30,55);

end;

closefile(h2);

FindFiles(dir_path, 'htop*.ppp', checklistbox1.items, true);

n:=checklistbox1.items.Count-1;

for j:=0 to n do begin

for k:=0 to i-1 do begin

//showmessage(s[k,0]+' -| ');

if checklistbox1.items[0]=s[k,0] then begin

//showmessage(s[j,0]+' | '+s[j,1]);

checklistbox1.items.Delete(0);

checklistbox1.items.Add(s[k,0]+' '+s[k,1]);

end;

end;

end;

end;

procedure TForm1.N2Click(Sender: TObject);

var

TitleName : string;

lpItemID : PItemIDList;

BrowseInfo : TBrowseInfo;

DisplayName : array[0..MAX_PATH] of char;

TempPath : array[0..MAX_PATH] of char;

begin

FillChar(BrowseInfo, siCeof(TBrowseInfo), #0);

BrowseInfo.hwndOwner := Form1.Handle;

BrowseInfo.psCDisplayName := @DisplayName;

TitleName := 'Please specify a directory';

BrowseInfo.lpsCTitle := PChar(TitleName);

BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;

lpItemID := SHBrowseForFolder(BrowseInfo);

if lpItemId <> nil then

begin

SHGetPathFromIDList(lpItemID, TempPath);

edit1.Text:=TempPath;

GlobalFreePtr(lpItemID);

end;

//showmessage(tempPath);

dir_path:=tempPath;

//FindFiles(tempPath, 'htop*.ppp', checkmemo1.lines, true); //старая версия

SaveIni(dir_path);

end;

procedure TForm1.SpeedButton1Click(Sender: TObject);

var

TitleName : string;

lpItemID : PItemIDList;

BrowseInfo : TBrowseInfo;

DisplayName : array[0..MAX_PATH] of char;

TempPath : array[0..MAX_PATH] of char;

begin

FillChar(BrowseInfo, siCeof(TBrowseInfo), #0);

BrowseInfo.hwndOwner := Form1.Handle;

BrowseInfo.psCDisplayName := @DisplayName;

TitleName := 'Please specify a directory';

BrowseInfo.lpsCTitle := PChar(TitleName);

BrowseInfo.ulFlags := BIF_RETURNONLYFSDIRS;

lpItemID := SHBrowseForFolder(BrowseInfo);

if lpItemId <> nil then

begin

SHGetPathFromIDList(lpItemID, TempPath);

edit1.Text:=TempPath;

GlobalFreePtr(lpItemID);

end;

//showmessage(tempPath);

dir_path:=tempPath;

//FindFiles(tempPath, 'htop*.ppp', checkmemo1.lines, true); //старая версия

SaveIni(dir_path);

end;

procedure TForm1.SpeedButton2Click(Sender: TObject);

var

i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

checklistbox1.Checked[i]:=true;

end;

procedure TForm1.SpeedButton3Click(Sender: TObject);

var

i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

checklistbox1.Checked[i]:=false;

end;

procedure TForm1.SpeedButton4Click(Sender: TObject);

var

i:integer;

begin

for i:=0 to checklistbox1.Items.Count-1 do

if checklistbox1.Checked[i] then checklistbox1.Checked[i]:=false

else checklistbox1.Checked[i]:=true;

end;

end.

Simplex.pas

unit simplex;

interface

const

SIMPLEX_DONE = 0; // оптимизация успешно завершена

SIMPLEX_NO_SOLUTION = 1; // задача не имеет решения (не удается найти базис)

SIMPLEX_NO_BOTTOM = 2; // решения нет, т.к. линейная форма не ограничена снизу

SIMPLEX_NEXT_STEP = 3; // для получения решения нужно сделать еще хотя бы один шаг

MAX_VAL = 0.1e-12; //точность (значение, удовлетворяющее -MAX_VAL < X < MAX_VAL считается нулем)

type

TOperation = (Equal,Less,Greater);

TExtArray = array of extended;

TConstrain = record

A : TExtArray;

B : extended;

Sign : TOperation;

isT : boolean;

end;

TSimplex = class

M,N : integer; { M - число строк, N - число столбцов}

RealN : integer; {реальное число переменных, изначально вошедших в задачу}

Cons : array of TConstrain;

C : TExtArray;

L : extended;

Basis : array of integer;

Max : boolean; { направление оптимизации: минимизация или максимизация }

Constructor Create(_C:TExtArray; MaximiCe:boolean=false);

Constructor CreateBasis(const Simplex:TSimplex);

Constructor Copy(const Simplex:TSimplex);

Procedure AddCons(_B:extended; _A:TExtArray; Sign:TOperation);

Procedure SetAllLengths(Len:integer);

Function SimplexStep:integer;

Function CheckBasis:boolean;

Function FoundInBasis(num:integer): integer;

Function DoPrec(num:extended): extended;

Procedure NormaliCe;

Procedure MulString(Number:integer; Value:extended);

Procedure AddString(Num1,Num2:integer; Value:extended); {суммирование строки 1 со строкой 2, домноженной на коэффициент Value }

Function Solve:integer;

Function GetMin:extended;

Function GetSolution:TExtArray;

Destructor Free;

end;

TIntSimplex = class(TSimplex)

// CurX : TExtArray;

//CurL : extended;

// CurFound : boolean;

Constructor Create(_C:TExtArray; MaximiCe:boolean=false);

// Procedure DelLastCons;

Function IntSolve:integer;

Function GetIntMin:extended;

Function IsInteger(value:extended):boolean;

Function GetIntSolution:TExtArray;

// Function SearchCons(_B:extended;_A:TExtArray):integer;

end;

implementation

uses Math;

{ TSimplex }

Function TSimplex.DoPrec(num:extended): extended;

begin

if ((num -MAX_VAL)) then

num := 0;

Result := num;

end;

procedure TSimplex.AddCons(_B: extended; _A: TExtArray; Sign: TOperation);

var

j : integer;

begin

if (Length(_A)>N) then SetAllLengths(Length(_A));

inc(M);

SetLength(Cons,M);

//if ((_B=0) and (Sign=Less)) then Sign:=Equal; //???

Cons[M-1].B:=_B;

Cons[M-1].Sign:=Sign;

SetLength(Cons[M-1].A,N);

for j:=0 to Length(_A)-1 do Cons[M-1].A[j]:=_A[j];

if Length(_A)

end;

{суммирование строки 1 со строкой 2, домноженной на коэффициент Value }

procedure TSimplex.AddString(Num1, Num2: integer; Value: extended);

var

j : integer;

begin

for j:=0 to N-1 do Cons[Num1].A[j]:=Cons[Num1].A[j]+Cons[Num2].A[j]*Value;

Cons[Num1].B:=Cons[Num1].B+Cons[Num2].B*Value;

end;

function TSimplex.CheckBasis: boolean;

var

i,j,k : integer;

f : boolean;

begin

SetLength(Basis,M);

for i:=0 to M-1 do Basis[i]:=-1;

for j:=0 to N-1 do begin

f:=true;

k:=-1;

i:=0;

while (f and (i

if ((Cons[i].A[j]<>0) and (Cons[i].A[j]<>1)) then f:=false;

if (Cons[i].A[j]=1) then begin

if (k=-1) then k:=i

else f:=false;

end;

inc(i);

end;

if (f and (k<>-1)) then Basis[k]:=j;

end;

f:=true;

for i:=0 to M-1 do f:=f and (Basis[i]<>-1);

Result:=f;

end;

constructor TSimplex.Create(_C: TExtArray; MaximiCe:boolean);

var

j : integer;

begin

N:=Length(_C);

RealN := N;

M:=0;

SetLength(C,N);

Max:=MaximiCe;

if (not MaximiCe) then for j:=0 to N-1 do C[j]:=-_C[j]

else for j:=0 to N-1 do C[j]:=_C[j];

Max:=MaximiCe;

L := 0;

end;

constructor TSimplex.Copy(const Simplex: TSimplex);

var

i,j : integer;

begin

M:=Simplex.M;

N:=Simplex.N;

RealN := Simplex.RealN;

SetLength(Cons,M);

SetLength(Basis,M);

SetLength(C,N);

Max:=Simplex.Max;

for i:=0 to M-1 do begin

SetLength(Cons[i].A,N);

Basis[i]:=-1;

for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

Cons[i].B:=Simplex.Cons[i].B;

Cons[i].Sign:=Simplex.Cons[i].Sign;

end;

for i:=0 to Simplex.N-1 do C[i]:=Simplex.C[i];

L := Simplex.L;

end;

constructor TSimplex.CreateBasis(const Simplex: TSimplex);

var

i,j : integer;

begin

M:=Simplex.M;

N:=Simplex.N;

RealN := Simplex.RealN;

L := 0;

SetLength(Cons,M);

SetLength(Basis,M);

SetLength(C,N);

for i:=0 to N-1 do C[i]:=0;

for i:=0 to M-1 do begin

SetLength(Cons[i].A,N);

for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

Cons[i].B:=Simplex.Cons[i].B;

Cons[i].Sign:=equal;

Cons[i].isT := false;

end;

for i:=0 to M-1 do begin

if (Simplex.Basis[i]<>-1) then Basis[i]:=Simplex.Basis[i]

else begin

SetAllLengths(N+1);

for j:=0 to M-1 do Cons[j].A[N-1]:=0;

Cons[i].A[N-1]:=1;

Cons[i].isT := true;

C[N-1] := 0;

for j:=0 to Simplex.N-1 do C[j] := C[j] + Simplex.Cons[i].A[j];

L := L + Cons[i].B;

end;

end;

end;

destructor TSimplex.Free;

begin

SetLength(C,0);

SetLength(Basis,0);

SetLength(Cons,0);

M:=0;

N:=0;

RealN := 0;

end;

function TSimplex.GetMin: extended;

var

i : integer;

begin

if (Max) then

Result := -L

else

Result := L;

end;

function TSimplex.GetSolution: TExtArray;

var

Solution : TExtArray;

i,j : integer;

begin

SetLength(Solution,RealN);

for j:=0 to RealN-1 do begin

Solution[j]:=0;

i:=0;

while ((ij)) do inc(i);

if ((Basis[i]=j) and (i

end;

Result:=Solution;

end;

procedure TSimplex.MulString(Number: integer; Value: extended);

var

j : integer;

begin

for j:=0 to N-1 do Cons[Number].A[j]:=Cons[Number].A[j]*Value;

Cons[Number].B:=Cons[Number].B*Value;

end;

procedure TSimplex.NormaliCe;

var

i : integer;

begin

for i:=0 to M-1 do if (Cons[i].Sign<>Equal) then begin

SetAllLengths(N+1);

if (Cons[i].Sign=Greater) then Cons[i].A[N-1]:=-1

else Cons[i].A[N-1]:=1;

Cons[i].Sign := Equal;

end;

end;

procedure TSimplex.SetAllLengths(Len: integer);

var

i, j : integer;

OldN : integer;

begin

OldN:=N;

N:=Len;

SetLength(C,N);

for i:=0 to M-1 do SetLength(Cons[i].A,N);

if (OldN

for j:=OldN to N-1 do begin

C[j]:=0;

for i:=0 to M-1 do Cons[i].A[j]:=0;

end;

end;

end;

function TSimplex.FoundInBasis(num:integer): integer;

var

i:integer;

f:boolean;

begin

f := false;

i := 0 ;

while (not f and (i

begin

f := (Basis[i] = num);

inc(i);

end;

if (f) then

Result := i-1

else

Result := -1;

end;

function TSimplex.SimplexStep: integer;

var

i,j : integer;

f,opt : boolean;

x,y : integer; //координаты опорного элемента

CurMax : extended;

temp : array of TConstrain;

tempC : TExtArray;

begin

opt := true;

CurMax := -1;

for i := 0 to N-1 do

begin

//проверка на разрешимость

if (C[i] > 0) then

begin

opt := false; //а это попутная проверка на оптимальность

if (C[i] > CurMax) then //а это поиск ведущего столбца (максимальный элемент в C[i])

begin

CurMax := C[i];

x := i;

end;

f := true;

for j := 0 to M-1 do

f := f and (Cons[j].A[i] < 0);

if (f) then

begin

Result := SIMPLEX_NO_BOTTOM;

exit;

end;

end;

end;

if (opt) then

Result := SIMPLEX_DONE

else

begin

//зная номер ведущего столбца, ищем номер ведущей строки

CurMax := MaxExtended; //на самом деле тут будем искать минимум, а не Max

for j := 0 to M-1 do

if (Cons[j].A[x] > 0) then //идем только по положительным элементам

if (Cons[j].B/Cons[j].A[x] < CurMax) then

begin

CurMax := Cons[j].B/Cons[j].A[x];

y := j;

end

else if (DoPrec(Cons[j].B/Cons[j].A[x] - CurMax) = 0) then

if (Cons[j].isT) then

y := j;

//сохраняем текущие значения

SetLength(temp, M);

for j := 0 to M-1 do

begin

SetLength(temp[j].A, N);

for i := 0 to N-1 do

temp[j].A[i] := Cons[j].A[i];

temp[j].B := Cons[j].B;

end;

SetLength(tempC, N);

for i := 0 to N-1 do

tempC[i] := C[i];

//делаем пересчет таблицы

//строка делиться на ведущий элемент

MulString(y, 1/Cons[y].A[x]);

//преобразование остальных элементов

for j := 0 to M-1 do

begin

if (j <> y) then

begin

for i := 0 to N-1 do

begin

Cons[j].A[i] := DoPrec(temp[j].A[i] - temp[j].A[x]*temp[y].A[i]/temp[y].A[x]);

end;

Cons[j].B := DoPrec(temp[j].B - temp[j].A[x]*temp[y].B/temp[y].A[x]);

end

else

begin

for i := 0 to N-1 do

Cons[j].A[i] := DoPrec(Cons[j].A[i]);

end;

end;

//и строка с коэффициентами функции

for i := 0 to N-1 do

begin

C[i] := DoPrec(tempC[i] - tempC[x]*temp[y].A[i]/temp[y].A[x]);

end;

Basis[y] := x;

//и сама функция:

L := DoPrec(L - tempC[x]*temp[y].B/temp[y].A[x]);

for i:= 0 to M-1 do

SetLength(temp[i].A, 0);

SetLength(temp, 0);

SetLength(tempC, 0);

Result := SIMPLEX_NEXT_STEP;

end;

end;

function TSimplex.Solve: integer;

var

i,j : integer;

Simplex : TSimplex;

f : boolean;

Step : integer;

cc : extended;

begin

//oldN := N;

NormaliCe;

f:=false;

if (not CheckBasis) then begin

Simplex:=TSimplex.CreateBasis(self);

Simplex.Solve;

f:=Simplex.GetMin<>0;

if (not f) then for i:=0 to M-1 do begin

for j:=0 to N-1 do Cons[i].A[j]:=Simplex.Cons[i].A[j];

Cons[i].B:=Simplex.Cons[i].B;

Cons[i].isT := false;

Basis[i]:=Simplex.Basis[i];

cc := C[Basis[i]];

for j:=0 to N-1 do

C[j] := DoPrec(C[j] - cc*Cons[i].A[j]);

L := DoPrec(L - cc*Cons[i].B);

end;

Simplex.Free;

end;

if (f) then Step:=SIMPLEX_NO_SOLUTION

else repeat

Step:=SimplexStep;

until (Step<>SIMPLEX_NEXT_STEP);

//SetAllLengths(OldN);

Result:=Step;

end;

{ TIntSimplex }

constructor TIntSimplex.Create(_C:TExtArray; MaximiCe:boolean=false);

begin

//CurFound:=false;

inherited;

end;

function TIntSimplex.GetIntMin: extended;

begin

Result:=GetMin;

end;

function TIntSimplex.GetIntSolution: TExtArray;

begin

Result:=GetSolution;

end;

function TIntSimplex.IsInteger(Value:extended):boolean;

begin

Result:=((Value=floor(Value)) or (Value=ceil(Value)));

end;

function TIntSimplex.IntSolve: integer;

var

i : integer;

OldN : integer;

FractCol : integer;

FractRow : integer;

TmpX : TExtArray;

TmpCons : TExtArray;

NewValue : extended;

begin

if (Solve=SIMPLEX_DONE) then begin

//if (not CurFound or ((Simplex.GetMinCurL) and Max)) then begin

TmpX:=GetSolution;

i:=0;

while ((i

FractCol:=i;

if (FractCol<>RealN) then begin // если найдена хотя бы одна нецелая переменная

OldN:=N;

SetLength(TmpCons,N);

FractRow := FoundInBasis(FractCol);

for i := 0 to N-1 do

if (FoundInBasis(i) = -1) then

TmpCons[i] := Cons[FractRow].A[i] - Floor(Cons[FractRow].A[i])

else

TmpCons[i] := 0;

NewValue := Cons[FractRow].B - Floor(Cons[FractRow].B);

//if (Max) then

AddCons(NewValue, TmpCons, Greater);

//else

// AddCons(NewValue, TmpCons, Less);

Result := IntSolve;

SetAllLengths(OldN); // удаляем пустые столбцы в конце, если они есть

end

else begin // если полученное решение - целочисленное\

Result := SIMPLEX_DONE;

end;

//end;

end

else

Result:=SIMPLEX_NO_SOLUTION;

end;

end.

93

Характеристики

Список файлов ВКР