How i can extract the file name from a Download Link using Delphi
Example
http://pj-mirror01.mozilla.org/pub/mozilla.org/firefox/releases/3.6/win32/es-CL/Firefox%20Setup%203.6.exe
The result must be
Firefox Setup 3.6.exe
Try this
function GetURLFilename(const FilePath:String;Const Delimiter:String='/'):String;
var I: Integer;
begin
I := LastDelimiter(Delimiter, FILEPATH);
Result := Copy(FILEPATH, I + 1, MaxInt);
Result := UrlDecode(Result);
end;
URlDecode was copied from http://www.torry.net/dpfl/dzurl.html and looks like
function UrlDecode(const EncodedStr: String): String;
var
I: Integer;
begin
Result := '';
if Length(EncodedStr) > 0 then
begin
I := 1;
while I <= Length(EncodedStr) do
begin
if EncodedStr[I] = '%' then
begin
Result := Result + Chr(HexToInt(EncodedStr[I+1]
+ EncodedStr[I+2]));
I := Succ(Succ(I));
end
else if EncodedStr[I] = '+' then
Result := Result + ' '
else
Result := Result + EncodedStr[I];
I := Succ(I);
end;
end;
end;
function HexToInt(HexStr: String): Int64;
var RetVar : Int64;
i : byte;
begin
HexStr := UpperCase(HexStr);
if HexStr[length(HexStr)] = 'H' then
Delete(HexStr,length(HexStr),1);
RetVar := 0;
for i := 1 to length(HexStr) do begin
RetVar := RetVar shl 4;
if HexStr[i] in ['0'..'9'] then
RetVar := RetVar + (byte(HexStr[i]) - 48)
else
if HexStr[i] in ['A'..'F'] then
RetVar := RetVar + (byte(HexStr[i]) - 55)
else begin
Retvar := 0;
break;
end;
end;
Result := RetVar;
end;
Related
I created a procedure to update an SQLite DB. The procedure runs in a loop until the list is finished. The problem is, when I run the procedure, the program stops responding
How can I run this procedure in the background, without crashing the program?
procedure TForm1.domainupdate;
var
I, J, K, svr: integer ;
domain1, domain2: string ;
expiry: string;
sl: TStringList;
fs: TFormatSettings;
s: string;
dt: TDatetime;
ds : TFormatSettings;
memo : tmemo;
begin
DM.Qdomains.First;
while not DM.Qdomains.Eof do begin
for J := Length (DM.Qdomains.FieldByName('domain').AsString) downto 2 do begin
if DM.Qdomains.FieldByName('domain').AsString [J] = '.' then begin // search host.co.uk
if domain1 = '' then
domain1 := Copy (DM.Qdomains.FieldByName('domain').AsString, J + 1, 99) + IcsSpace
// found uk
else begin
domain2 := Copy (DM.Qdomains.FieldByName('domain').AsString, J + 1, 99) + IcsSpace ;
// found co.uk
Break ;
end;
end;
end;
FWhoisServers := TStringList.Create;
for I := 0 to Length(WhoisNames) - 1 do
FWhoisServers.add(WhoisNames[I]);
FHost := 'whois.ripe.net' ;
K := -1 ;
if FWhoisServers.Count > 0 then begin
for I := 0 to FWhoisServers.Count - 1 do
begin
if (Pos (domain1, FWhoisServers [I]) = 1) then K := I ;
if (Pos (domain2, FWhoisServers [I]) = 1) then
begin
K := I ;
break ;
end ;
end;
if K >= 0 then begin
J := Pos (IcsSpace, FWhoisServers [K]) ;
end;
end;
if K < 0 then begin
end;
IdWhois1.host := Copy (FWhoisServers [K], J + 1, 99) ;
Memo:=TMemo.Create(nil);
Memo.Visible:=false;
memo.Lines.text := IdWhois1.WhoIs(DM.Qdomains.FieldByName('domain').AsString);
begin
sl := TStringList.Create;
try
sl.Assign(Memo.Lines);
for I := 0 to sl.Count-1 do begin
sl[I] := TrimLeft(sl[I]);
end;
sl.NameValueSeparator := ':';
for I := Low(FieldNames) to High(FieldNames) do begin
expiry := Trim(sl.Values[FieldNames[I]]);
if expiry <> '' then
Break;
end;
finally
sl.Free;
end;
if expiry = '' then
exit
else
s := expiry;
fs := TFormatSettings.Create;
fs.DateSeparator := '-';
fs.TimeSeparator := ':';
fs.shortdateformat := 'yyyy-mm-dd';
fs.ShortTimeFormat := 'hh:nn:ss';
dt := StrToDatetime(s, fs);
ds.DateSeparator := '/';
ds.TimeSeparator := ':';
ds.ShortDateFormat := 'dd/mm/yyyy';
ds.longtimeFormat := 'hh:mm:ss';
end;
end;
//********************************************************
//********************************************************
//if edit1.text <> '' then DM.Qdomains.Open;
DM.Qdomains.Edit;
DM.Qdomains.FieldByName('domain').AsString :=
DM.Qdomains.FieldByName('domain').AsString;
DM.Qdomains.FieldByName('expiry').AsString := datetimetostr(dt, ds);
DM.Qdomains.FieldByName('whois').AsString :=
IdWhois1.WhoIs(DM.Qdomains.FieldByName('domain').AsString);
DM.Qdomains.FieldByName('update').AsString := DatetimeToStr(now);
DM.Qdomains.Post;
DM.Qdomains.Next;
end;
Move the logic into a separate worker thread, synchronizing with the main UI thread only when absolutely needed (ie, to show the results). You need to do this anyway if you ever plan on running this code on Android, since you can't perform network operations on the main UI thread.
Also, get rid of the TMemo that the code is creating, it is not needed at all. All you are using it for is to parse the Whois result into a TStringList, which you can do directly. And, you are leaking the TMemo and never showing it to the user anyway.
Try something more like this:
procedure TForm1.DomainUpdate;
var
I, J, K: Integer;
domain, domain1, domain2, host, whois, expiry: string;
sl: TStringList;
fs, ds: TFormatSettings;
dt: TDatetime;
begin
// TODO: perform the DB query here instead of in the main thread...
DM.Qdomains.First;
while not DM.Qdomains.Eof do begin
domain := DM.Qdomains.FieldByName('domain').AsString;
domain1 := '';
domain2 := '';
for J := Length(domain) downto 2 do begin
if domain[J] = '.' then begin // search host.co.uk
if domain1 = '' then
domain1 := Copy(domain, J + 1, MaxInt) + IcsSpace
// found uk
else begin
domain2 := Copy(domain, J + 1, MaxInt) + IcsSpace;
// found co.uk
Break;
end;
end;
end;
FWhoisServers := TStringList.Create;
try
for I := 0 to Length(WhoisNames) - 1 do
FWhoisServers.Add(WhoisNames[I]);
host := 'whois.ripe.net';
K := -1;
if FWhoisServers.Count > 0 then begin
for I := 0 to FWhoisServers.Count - 1 do
begin
if (Pos(domain1, FWhoisServers[I]) = 1) then K := I;
if (Pos(domain2, FWhoisServers[I]) = 1) then
begin
K := I;
Break;
end;
end;
if K >= 0 then begin
J := Pos(IcsSpace, FWhoisServers[K]);
host := Copy(FWhoisServers[K], J + 1, MaxInt);
end;
end;
IdWhois1.Host := host;
finally
FWhoisServers.Free;
end;
expiry := '';
sl := TStringList.Create;
try
whois := IdWhois1.WhoIs(domain);
sl.Text := whois;
for I := 0 to sl.Count-1 do begin
sl[I] := TrimLeft(sl[I]);
end;
sl.NameValueSeparator := ':';
for I := Low(FieldNames) to High(FieldNames) do begin
expiry := Trim(sl.Values[FieldNames[I]]);
if expiry <> '' then
Break;
end;
finally
sl.Free;
end;
if expiry <> '' then begin
fs := TFormatSettings.Create;
fs.DateSeparator := '-';
fs.TimeSeparator := ':';
fs.ShortDateFormat := 'yyyy-mm-dd';
fs.ShortTimeFormat := 'hh:nn:ss';
dt := StrToDateTime(expiry, fs);
ds := TFormatSettings.Create;
ds.DateSeparator := '/';
ds.TimeSeparator := ':';
ds.ShortDateFormat := 'dd/mm/yyyy';
ds.LongTimeFormat := 'hh:mm:ss';
DM.Qdomains.Edit;
try
DM.Qdomains.FieldByName('domain').AsString := domain;
DM.Qdomains.FieldByName('expiry').AsString := DateTimeToStr(dt, ds);
DM.Qdomains.FieldByName('whois').AsString := whois;
DM.Qdomains.FieldByName('update').AsString := DateTimeToStr(Now);
DM.Qdomains.Post;
except
DM.Qdomains.Cancel;
raise;
end;
end;
DM.Qdomains.Next;
end;
end;
...
TThread.CreateAnonymousThread(DomainUpdate).Start;
Printing using Epson codes in Delphi Tokyo.
Function PrintRawData (built in to Winapi.Winspool library) appears to misread codes like 'ESC C' or 'ESC #' and prints 'C' and '#' instead of the prompts associated with said codes (Select page length & Initialise Printer).
procedure TFrmPrint.PageLen(hPrn : THandle); // Page length in Inches
var
Commalist : Array[1..20] of SmallInt;
istart, icomma, i : SmallInt;
ss, cr : UTF8String;
def : UTF8String;
Data : Array [0..255] of AnsiChar;
begin
ss := '';
cr := ' ';
cr[1] := #13; cr[2] := #10;
if not DM2.Q_PRNGen.Locate('PrAction','PAGELENIN',[loCaseInsensitive]) then
begin
ShowMessage('PAGELENIN Action not coded for Printer');
exit;
end;
ss := Trim(DM2.Q_PRNGen.Fields.FieldByName('ESCCODE').AsString);
icomma := 0;
istart := 1;
for i:=1 to Length(ss) do
begin
if ss[i] = ',' then
begin
inc(icomma);
Commalist[icomma] := StrToIntDef(Copy(ss,istart,i-istart),0);
istart := i + 1;
end;
end;
inc(icomma);
i := Length(ss);
Commalist[icomma] := StrToIntDef(Copy(ss,istart,i-istart+1),0);
def := '';
for i:=1 to icomma do
begin
def := def + ' ';
def[i] := AnsiChar(CommaList[i]);
// def := Def + IntToHex(CommaList[i],1);
end;
// ss := def + cr;
ss := def;
for i:=1 to Length(ss) do Data[i-1] := AnsiChar(ss[i]);
if frmPrint.PrintRawData(hPrn,#Data,Length(ss)) < 0 then
begin
ShowMessage('PrintRawData Failed');
frmPrint.EndRawPrintPage(hPrn);
frmPrint.EndRawPrintJob(hPrn);
exit;
end;
end;
It is under my assumption that the error lies within PrintRawData.
PrintRawData is listed here:
function TFrmPrint.PrintRawData(hPrn : THandle; Buffer : pointer; NumBytes : SpoolInt) : integer;
var
BytesWritten : DWORD;
begin
if NumBytes = 0 then
begin
Result := 1;
exit;
end;
if not WritePrinter(hPrn, Buffer, NumBytes, BytesWritten) then
begin
Result := -1;
exit;
end;
if NumBytes <> BytesWritten then
begin
Result := -1;
exit;
end;
Result := 1;
end;
I would like to know how I can get all the driver files for a particular device just like the Device Manager does?
I have the following code:
procedure TdlgMain.Test(const DeviceIndex: Integer);
var
PnPHandle: HDEVINFO;
DevData: TSPDevInfoData;
DeviceInterfaceData: TSPDeviceInterfaceData;
FunctionClassDeviceData: PSPDeviceInterfaceDetailData;
Success: LongBool;
Devn: Integer;
BytesReturned: DWORD;
SerialGUID: TGUID;
begin
ZeroMemory(#DevData, SizeOf(SP_DEVINFO_DATA));
DevData.cbSize := SizeOf(SP_DEVINFO_DATA);
ZeroMemory(#DeviceInterfaceData, SizeOf(TSPDeviceInterfaceData));
DeviceInterfaceData.cbSize := SizeOf(TSPDeviceInterfaceData);
if not SetupDiEnumDeviceInfo(hAllDevices,
DeviceIndex, DevData) then Exit;
SerialGUID := DevData.ClassGuid;
PnPHandle := SetupDiGetClassDevs(#SerialGUID, nil, 0, DIGCF_PRESENT or DIGCF_DEVICEINTERFACE);
if PnPHandle = Pointer(INVALID_HANDLE_VALUE) then
Exit;
Devn := 0;
repeat
DeviceInterfaceData.cbSize := SizeOf(TSPDeviceInterfaceData);
Success := SetupDiEnumDeviceInterfaces(PnPHandle, nil, SerialGUID, Devn, DeviceInterfaceData);
if Success then
begin
DevData.cbSize := SizeOf(DevData);
BytesReturned := 0;
// get size required for call
SetupDiGetDeviceInterfaceDetail(PnPHandle, #DeviceInterfaceData, nil, 0, BytesReturned, #DevData);
if (BytesReturned <> 0) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
// allocate buffer and initialize it for call
FunctionClassDeviceData := AllocMem(BytesReturned);
FunctionClassDeviceData.cbSize := SizeOf(TSPDeviceInterfaceDetailData);
//FunctionClassDeviceData.cbSize := BytesReturned;
if SetupDiGetDeviceInterfaceDetail(PnPHandle, #DeviceInterfaceData,
FunctionClassDeviceData, BytesReturned, BytesReturned, #DevData) then
begin
ShowMessage(FunctionClassDeviceData.DevicePath);
end else
RaiseLastOSError();
FreeMem(FunctionClassDeviceData);
end;
end;
Inc(Devn);
until not Success;
SetupDiDestroyDeviceInfoList(PnPHandle);
But the ShowMessage() is either not called at all or returns \. How do I get the files properly?
I had a look at devcon from the WinDDK, but it does not return the files either.
Thank you.
I figured it out. There's no API to do it for you, you need to parse the INF files to achieve the result. Here's a quick-n-dirty solution for all of you, who are interested.
procedure TdlgMain.Test(const DeviceIndex: Integer);
var
Paths: TStringList;
I: Integer;
function GetWinDir: string; inline;
var
dir: array [0 .. MAX_PATH] of Char;
begin
GetWindowsDirectory(dir, MAX_PATH);
Result := IncludeTrailingBackslash(StrPas(dir));
end;
function GetSpecialFolderPath(const folder: Integer): string; inline;
const
SHGFP_TYPE_CURRENT = 0;
var
path: array [0 .. MAX_PATH] of Char;
begin
if SUCCEEDED(SHGetFolderPath(0, folder, 0, SHGFP_TYPE_CURRENT, #path[0]))
then
Result := IncludeTrailingBackslash(path)
else
Result := '';
end;
function LocateInfFile(const F: String): String; inline;
var
T: String;
begin
Result := '';
if (Pos(SysUtils.PathDelim, F) > 0) then
begin
Result := F;
Exit;
end;
T := GetWinDir();
if (FileExists(T + 'inf\' + F)) then
Result := T + 'inf\' + F
else if (FileExists(T + 'system32\' + F)) then
Result := T + 'system32\' + F;
end;
procedure ReadSectionNoKeys(const AFile, ASection: String;
const SL: TStringList);
var
TheFile: TStringList;
Line: String;
TrimEnd: Boolean;
Idx, Tmp: Integer;
begin
TrimEnd := False;
TheFile := TStringList.Create();
try
TheFile.LoadFromFile(AFile);
Idx := TheFile.IndexOf('[' + ASection + ']');
if (Idx <> -1) then
begin
Idx := Idx + 1;
while True do
begin
Line := Trim(TheFile[Idx]);
Inc(Idx);
if (Pos(';', Line) = 1) then
continue;
if (Pos('[', Line) > 0) then
Break;
Tmp := Pos(',', Line);
if (Tmp > 0) then
TrimEnd := True
else
begin
Tmp := PosEx(';', Line, 3);
if (Tmp > 0) then
TrimEnd := True;
end;
if (Line <> '') then
begin
if (TrimEnd) then
begin
Line := Trim(Copy(Line, 1, Tmp - 1));
TrimEnd := False;
end;
SL.Add(Line);
end;
if (Idx = (TheFile.Count - 1)) then
Break;
end;
end;
finally
TheFile.Free();
end;
end;
function IniReadStr(const Ini: TIniFile; const S, L, D: String): String;
var
T: Integer;
begin
Result := Ini.ReadString(S, L, D);
T := Pos(';', Result);
if (T > 0) then
Result := Trim(Copy(Result, 1, T - 1));
end;
procedure ParseInfFile(const InfFile, SectionName: String);
var
I: TIniFile;
SL, FilesList: TStringList;
X, Y, Tmp: Integer;
Pth, S, S1: String;
begin
I := TIniFile.Create(InfFile);
try
if (SectionName <> '') and (I.SectionExists(SectionName)) then
begin
// Check if the section has a value called "CopyFiles".
if (I.ValueExists(SectionName, 'CopyFiles')) then
begin
// It has. Read it to a string and separate by commas.
SL := TStringList.Create();
try
SL.CommaText := IniReadStr(I, SectionName, 'CopyFiles', '');
// Now, every line of the string list is a section name. Check
// the destination directory of each.
if (I.SectionExists('DestinationDirs')) then
for X := 0 to SL.Count - 1 do
begin
S := IniReadStr(I, 'DestinationDirs', SL[X], '');
if (S = '') then
S := IniReadStr(I, 'DestinationDirs', 'DefaultDestDir', '');
if (S <> '') then
begin
// Split the path by comma, if any.
Tmp := Pos(',', S);
S1 := '';
if (Tmp > 0) then
begin
S1 := Trim(Copy(S, Tmp + 1, Length(S)));
S := Trim(Copy(S, 1, Tmp - 1));
end;
// Convert the numeric value of S to a proper directory.
Pth := '';
if (S = '10') then
Pth := GetWinDir();
if (S = '11') then
Pth := GetWinDir() + 'system32\';
if (S = '12') then
Pth := GetWinDir() + 'system32\drivers\';
if (S = '50') then
Pth := GetWinDir() + 'system\';
if (S = '30') then
Pth := ExtractFileDrive(GetWinDir());
if (StrToInt(S) >= 16384) then
Pth := GetSpecialFolderPath(StrToInt(S));
if (S1 <> '') then
Pth := IncludeTrailingBackslash(Pth + S1);
// If we got the path, read the files.
if (Pth <> '') then
begin
FilesList := TStringList.Create();
try
ReadSectionNoKeys(InfFile, SL[X], FilesList);
for Y := 0 to FilesList.Count - 1 do
if (Paths.IndexOf(Pth + FilesList[Y]) = -1) then
Paths.Add(Pth + FilesList[Y]);
finally
FilesList.Free();
end;
end;
end;
end;
finally
SL.Free();
end;
end;
// Check if there're "Include" and "Needs" values.
if ((I.ValueExists(SectionName, 'Include')) and
(I.ValueExists(SectionName, 'Needs'))) then
begin
// Split both by comma.
SL := TStringList.Create();
FilesList := TStringList.Create();
try
SL.CommaText := IniReadStr(I, SectionName, 'Include', '');
FilesList.CommaText := IniReadStr(I, SectionName, 'Needs', '');
if (SL.Text <> '') and (FilesList.Text <> '') then
for X := 0 to SL.Count - 1 do
for Y := 0 to FilesList.Count - 1 do
ParseInfFile(LocateInfFile(SL[X]), FilesList[Y]);
finally
FilesList.Free();
SL.Free();
end;
end;
end;
finally
I.Free();
end;
end;
begin
Paths := TStringList.Create();
try
ParseInfFile(LocateInfFile(DeviceHelper.InfName), DeviceHelper.InfSection);
Paths.Sort();
ListView_InsertGroup(lvAdvancedInfo.Handle, 'Driver Files', 2);
for I := 0 to Paths.Count - 1 do
ListView_AddItemsInGroup(lvAdvancedInfo, '', Paths[I], 2);
finally
Paths.Free();
end;
end;
How can I convert bin to string?
For example:
string:='s';----------->bin:='0011';
How do I convert it reverse?
My stringtobin code is:
function StrToBinStr( aString: string ): string;
var
i : integer;
begin
for i := 1 to Length( aString ) do
result := IntToBin( byte(aString[i]), 4 );
end;
function IntToBin(aValue, Bits: integer): string;
var
i : integer;
begin
for i := Bits-1 downto 0 do
result := result + Copy( '10', Word(((1 shl i) and AValue) = 0)+1, 1 );
end;
This may help:
function IntToBin( const Value: LongInt; Digits: Byte;
const Spaces: Boolean ): AnsiString;
begin
if Digits > 32 then
Digits := 32;
SetLength( Result, Digits );
Result := '';
while Digits > 0 do
begin
if (Spaces) and ((Digits mod 8) = 0) then
Result := Result + #32;
Dec(Digits, 1);
Result := Result + IntToStr((Value shr Digits) and 1);
end;
end;
function BinToInt( Value: AnsiString ): LongInt;
var
cTmp: AnsiChar;
liCtr, liLen: LongInt;
begin
Value := AnsiString(StringReplace(Value, #32, '', [rfReplaceAll]));
liLen := Length(Value);
cTmp := Value[liLen];
Dec(liLen);
Result := StrToInt(cTmp);
liCtr := 1;
while liLen > 0 do
begin
cTmp := Value[liLen];
Dec( liLen );
Result := Result + (StrToInt(cTmp) shl liCtr );
Inc(liCtr);
end;
end;
Sample use:
procedure TForm1.FormShow(Sender: TObject);
var
TestStr: AnsiString;
i: Integer;
Temp: AnsiString;
begin
TestStr := 'ABC';
Temp := '';
for i := 1 to Length(TestStr) do
Temp := Temp + IntToBin(Ord(AnsiChar(TestStr[i])), 8, False);
ShowMessage('Temp = ' + Temp);
TestStr := '';
i := 1;
while i < Length(Temp) do
begin
TestStr := TestStr + AnsiChar(BinToInt(Copy(Temp, i, 8)));
Inc(i, 8);
end;
ShowMessage('TestStr = ' + TestStr);
end;
As I said in my comment to your original question, I think this is a terrible idea, but these work.
function _ConvertHexToWideString(AHex: AnsiString): WideString;
var wBinaryStream: TMemoryStream;
begin
try
wBinaryStream := TMemoryStream.Create;
try
wBinaryStream.Size := Length(AHex) div 2;
if wBinaryStream.Size > 0 then
HexToBin(PAnsiChar(AHex), wBinaryStream.Memory, wBinaryStream.Size);
except
end;
SetString(Result, PWideChar(wBinaryStream.Memory), wBinaryStream.Size div SizeOf(WideChar));
finally
FreeAndNil(wBinaryStream);
end;
end;
I have been working on an algorithm to rearranging the letters of a word, but it takes much time to find the correct word.
var
Form1: TForm1;
DictionaryArray : array[0..2000] of string;
const Numbrs : string = '123456789';
implementation
{$R *.dfm}
function GenerateSequence(CPoint : String; L : Integer): String;
var
Increaser : array[1..8] of Integer;
i : Integer;
AnagramSequence : String;
begin
FillChar(Increaser, SizeOf(Increaser), 0);
for i := 1 to Length(CPoint) do
Increaser[9 - i] := StrToInt(CPoint[L + 1 - i]);
//==========================================//
if Increaser[8] <= L then
Increaser[8] := Increaser[8] + 1;
if Increaser[8] > L then
begin
Increaser[8] := 1;
Increaser[7] := Increaser[7] + 1;
end;
if (Increaser[7] > L - 1) and (L > 3) then
begin
Increaser[8] := 1;
Increaser[7] := 1;
Increaser[6] := Increaser[6] + 1;
end;
if (Increaser[6] > L - 2) and (L > 4) then
begin
Increaser[8] := 1;
Increaser[7] := 1;
Increaser[6] := 1;
Increaser[5] := Increaser[5] + 1;
end;
if (Increaser[5] > L - 3) and (L > 5) then
begin
Increaser[8] := 1;
Increaser[7] := 1;
Increaser[6] := 1;
Increaser[5] := 1;
Increaser[4] := Increaser[4] + 1;
end;
if (Increaser[4] > L - 4) and (L > 6) then
begin
Increaser[8] := 1;
Increaser[7] := 1;
Increaser[6] := 1;
Increaser[5] := 1;
Increaser[4] := 1;
Increaser[3] := Increaser[3] + 1;
end;
if (Increaser[3] > L - 5) and (L > 7) then
begin
Increaser[8] := 1;
Increaser[7] := 1;
Increaser[6] := 1;
Increaser[5] := 1;
Increaser[4] := 1;
Increaser[3] := 1;
Increaser[2] := Increaser[2] + 1;
end;
//==========================================//
AnagramSequence := IntToStr(Increaser[1]) + IntToStr(Increaser[2]) + IntToStr(Increaser[3]) + IntToStr(Increaser[4]) + IntToStr(Increaser[5]) + IntToStr(Increaser[6]) + IntToStr(Increaser[7]) + IntToStr(Increaser[8]);
Result := AnsiReplaceStr(AnagramSequence, '0', '')
end;
procedure LoadDictionary(DictionaryPath : String);
var
F : TextFile;
i : Integer;
begin
i := 0;
AssignFile(F, DictionaryPath);
Reset(F);
while not Eof(F) do
begin
Readln(F, DictionaryArray[i]);
Inc(i);
end;
CloseFile(F);
end;
function CheckInDictionary(RandedWord : String): Boolean;
begin
if (AnsiIndexText(RandedWord, DictionaryArray) = -1) then
Result := False
else
Result := True;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
LoadDictionary('wordlist.txt');
Label1.Caption := 'Dictionary: Loaded.';
Label1.Font.Color := clGreen;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
FRand, MRand, RandedWord, AnagramSequence : String;
RandedIndex, i : Integer;
begin
FRand := Edit1.Text;
MRand := FRand;
RandedWord := MRand;
AnagramSequence := StringOfChar('1', Length(FRand));
while CheckInDictionary(RandedWord) = False do
begin
MRand := FRand;
RandedWord := '';
AnagramSequence := GenerateSequence(AnagramSequence, Length(FRand));
for i := Length(AnagramSequence) downto 1 do
begin
Application.ProcessMessages;
RandedIndex := StrToInt(AnagramSequence[i]);
RandedWord := RandedWord + MRand[RandedIndex];
Delete(MRand, RandedIndex, 1);
end;
end;
Edit2.Text := RandedWord;
end;
How can i improve this algorithm?
If what you are doing is checking if an anagram of the letters given is in the dictionairy you might do the following:
(this can be precomputed) for each word in the dictionary sort the letters eg store (aht=hat). and sort the dictionairy on the name (TStringlist can do this with name value pairs)
sort the letters in the string (eg hello -> ehllo)
in the dictionairy search for the items that have the name equal to the sorted letter string.