nyuuzyou/wikis huggingface dataset:
Как преобразовать цвет в оттенки серого

== RGB в Gray ==
Следующий пример показывает, как преобразовать RGB цвет в аналогичный оттенок серого, наподобие того, как это делает чёрно-белый телевизор:
function RgbToGray(RGBColor: TColor): TColor;
var
 Gray: Byte;
begin
 Gray := Round((0.30 * GetRValue(RGBColor)) +
 (0.59 * GetGValue(RGBColor)) +
 (0.11 * GetBValue(RGBColor )));
 Result := RGB(Gray, Gray, Gray);
end;
Пример
procedure TForm1.FormCreate(Sender: TObject);
begin
 Shape1.Brush.Color := RGB(255, 64, 64);
 Shape2.Brush.Color := RgbToGray(Shape1.Brush.Color);
end;
// Используется функция преобразования изображения в оттенки серого
// взятая из UBPFD - http://delphibase.endimus.com/
// автор: Николай Федоровских - mailto: chook_nu@uraltc.ru
procedure ModColors(Bitmap: TBitmap; Color: TColor);
 // извлечение красного
 function GetR(const Color: TColor): Byte;
 begin
 Result := Lo(Color);
 end;
 // извлечение зелёного
 function GetG(const Color: TColor): Byte;
 begin
 Result := Lo(Color shr 8);
 end;
 // извлечение синего
 function GetB(const Color: TColor): Byte;
 begin
 Result := Lo((Color shr 8) shr 8);
 end;
 function BLimit(B: Integer): Byte;
 begin
 if B < 0 then
 Result := 0
 else if B > 255 then
 Result := 255
 else
 Result := B;
 end;
type
 TRGB = record
 B, G, R: Byte;
 end;
 pRGB = ^TRGB;
var
 r1, g1, b1: Byte;
 x, y: Integer;
 Dest: pRGB;
 A: Double;
begin
 Bitmap.PixelFormat := pf24Bit;
 r1 := Round(255 / 100 * GetR(Color));
 g1 := Round(255 / 100 * GetG(Color));
 b1 := Round(255 / 100 * GetB(Color));
 for y := 0 to Bitmap.Height - 1 do
 begin
 Dest := Bitmap.ScanLine[y];
 for x := 0 to Bitmap.Width - 1 do
 begin
 with Dest^ do
 begin
 A := (r + b + g) / 300;
 with Dest^ do
 begin
 R := BLimit(Round(r1 * A));
 G := BLimit(Round(g1 * A));
 B := BLimit(Round(b1 * A));
 // Небольшая поправка к оригинальной функции
 if (R=255) and (G=255) and (B=255) then
 begin
 R := 216;
 G := 212;
 B := 240;
 end;
 end;
 end;
 Inc(Dest);
 end;
 end;
end;
пример использования:
ModColors(BitMap, RGB(150, 150, 150));
Author: Rouse_
Source: http://forum.sources.ru
ID: 03674
ID: 03869
Category:Графика
Category:Bitmap
Category:Цвета и палитры
Как преобразовать цвета RGB в CMYK и обратно

Следующие функции RGBtoCMYK() и CMYKtoRGB() демонстрируют, как преобразовать цвета между цветовыми пространствами RGB и CMYK.
Примечание: Между цветами RGB и CMY есть прямая связь. В CMY оттенки серого получаются при смешивании равного объема Cyan (голубых), Magenta (пурпурных), and Yellow (желтых) чернил. Черный цвет в CMY получается за счет уменьшения значений C, M, Y до минимума и подстановки чисто черного цвета, что позволяет получить более четкий цвет и экономить чернила. На случай высоких значений C, M, Y - есть функция ColorCorrectCMYK(), которая дает такой же цвет, но с меньшим C, M, Y и большим K.
Example:
procedure RGBtoCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
begin
 C := 255 - R;
 M := 255 - G;
 Y := 255 - B;
 if C < M then
 K := C
 else
 K := M;
 if Y < K then
 K := Y;
 if k > 0 then
 begin
 c := c - k;
 m := m - k;
 y := y - k;
 end;
end;
procedure CMYKtoRGB(C, M, Y, K: Byte; var R, G, B: Byte);
begin
 if (Integer(C) + Integer(K)) < 255 then
 R := 255 - (C + K)
 else
 R := 0;
 if (Integer(M) + Integer(K)) < 255 then
 G := 255 - (M + K)
 else
 G := 0;
 if (Integer(Y) + Integer(K)) < 255 then
 B := 255 - (Y + K)
 else
 B := 0;
end;
procedure ColorCorrectCMYK(var C, M, Y, K: Byte);
var
 MinColor: Byte;
begin
 if C < M then
 MinColor := C
 else
 MinColor := M;
 if Y < MinColor then
 MinColor := Y;
 if MinColor + K > 255 then
 MinColor := 255 - K;
 C := C - MinColor;
 M := M - MinColor;
 Y := Y - MinColor;
 K := K + MinColor;
end;
Author: p0s0l
ID: 03680
ID: 04105
ID: 04106
Category:Алгоритмы
Category:Графика
Category:Цвета и палитры
Как преобразовать шестнадцатиричный цвет HTML в TColor

допустим, мы имеем переменную:
 const BGCOLOR = '#003366';
и нам необходимо связать её с фоновым цветом memo либо любого другого TColor.
Мы можем это сделать простым вызовом функции и использовать возвращённое значение:
procedure TForm1.Button1Click(Sender: TObject);
begin
 Memo.Color := ConvertHtmlHexToTColor(BGCOLOR);
end;
Ниже приведён исходник этой функции, а так же код функции CheckHexForHash.
unit colours;
interface
uses Windows, Sysutils, Graphics;
function ConvertHtmlHexToTColor(Color: string): TColor;
function CheckHexForHash(col: string): string;
implementation
////////////////////////////////////////////////////////////////////////////////
// ConvertHtmlHexToTColor
//
function ConvertHtmlHexToTColor(Color: string): TColor;
var
 rColor: TColor;
begin
 Color := CheckHexForHash(Color);
 if (length(color) >= 6) then
 begin
 { не забудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок }
 color := '$00' + Copy(color, 5, 2) + Copy(color, 3, 2) + Copy(color, 1, 2);
 rColor := StrToInt(color);
 end;
 Result := rColor;
end;
////////////////////////////////////////////////////////////////////////////////
// CheckHexForHash:
// Просто проверяет первый символ строки на наличие '#' и удаляет его, если он найден
function CheckHexForHash(col: string): string;
begin
 if col[1] = '#' then
 col := StringReplace(col, '#', , [rfReplaceAll]);
 Result := col;
end;
end.
Source: Взято из http://forum.sources.ru
ID: 03533
== См. также ==
* Как получить цвет строки в HTML формате
Category:Графика
Category:Цвета и палитры
Как преобразовать шестнадцатиричный цвет HTML в TColor?

допустим, мы имеем переменную:
const BGCOLOR = '#003366';
и нам необходимо связать её с фоновым цветом memo либо любого другого TColor. Мы можем это сделать простым вызовом функции и использовать возвращённое значение:
procedure TForm1.Button1Click(Sender: TObject);
begin
 Memo.Color := ConvertHtmlHexToTColor(BGCOLOR);
end;
Ниже приведён исходник этой функции, а так же код функции CheckHexForHash.
unit colours;
interface
uses Windows, Sysutils, Graphics;
function ConvertHtmlHexToTColor(Color: string): TColor;
function CheckHexForHash(col: string): string;
implementation
////////////////////////////////////////////////////////////////////////////////
// ConvertHtmlHexToTColor
//
function ConvertHtmlHexToTColor(Color: string): TColor;
var
 rColor: TColor;
begin
 Color := CheckHexForHash(Color);
 if (length(color) >= 6) then
 begin
 { не забудьте, что TColor это bgr, а не rgb: поэтому необходимо изменить порядок }
 color := '$00' + Copy(color, 5, 2) + Copy(color, 3, 2) + Copy(color, 1, 2);
 rColor := StrToInt(color);
 end;
 Result := rColor;
end;
////////////////////////////////////////////////////////////////////////////////
// CheckHexForHash:
// Просто проверяет первый символ строки на наличие '#' и удаляет его, если он найден
function CheckHexForHash(col: string): string;
begin
 if col[1] = '#' then
 col := StringReplace(col, '#', , [rfReplaceAll]);
 Result := col;
end;
end.
Source: http://forum.sources.ru
ID: 03533
Category:Связь
Category:Web
Как прервать печать и заставить печатать свой файл?

uses
 printers;
{$R *.DFM}
procedure StartPrintToFile(filename: string);
var
 CTitle: array[0..31] of Char;
 DocInfo: TDocInfo;
begin
 with Printer do
 begin
 BeginDoc;
 { Abort job just started on API level. }
 EndPage(Canvas.handle);
 Windows.AbortDoc(Canvas.handle);
 { Restart it with a print file as destination. }
 StrPLCopy(CTitle, Title, SizeOf(CTitle) - 1);
 FillChar(DocInfo, SizeOf(DocInfo), 0);
 with DocInfo do
 begin
 cbSize := SizeOf(DocInfo);
 lpszDocName := CTitle;
 lpszOutput := PChar(filename);
 end;
 StartDoc(Canvas.handle, DocInfo);
 StartPage(Canvas.handle);
 end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 StartPrintToFile('C:\temp\temp.prn');
 try
 Printer.Canvas.TextOut(100, 100, 'Hello World.');
 finally
 Printer.EndDoc;
 end;
end;
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 03229
Category:Принтер
Как привязать файлы помощи в Delphi

Вот как это делаю я:
# Сначала создайте файл помощи. Откройте меню "Project/Options...", щелкните на закладке "Application" и введите путь к файлу помощи в строке "Help File". Или же вы можете сделать это непосредственно во время выполнения приложения, указав соответственное значение свойству Application.HelpFile.
# Затем вам необходимо присвоить значения свойству "HelpContext" у необходимых элементов управления. В нашем случае необходимо задать значение свойству "HelpContext" у кнопки "Help", обычно расположенной на вспомогательных окнах или диалогах.
# Наконец, в обработчике события нажатия на кнопку вызовите метод Application.HelpContext. Для нашей кнопки "Help" обработчик события OnClick мог бы выглядеть примерно так:
procedure TForm1.btnHelpClick(Sender: TObject);
begin
 Application.HelpContext(TButton(Sender).HelpContext);
end;
Это все!
Вы также можете вызывать другие методы Application для вывода файлов помощи, такие, как Application.HelpCommand и Application.HelpJump.
Source: http://delphiworld.narod.ru
ID: 04553
Category:Разработка приложений
Category:Справочная система
Как прикрепить свою форму к другому приложению?

=== Как прикрепить свою форму к другому приложению? ===
Для этого Вам понадобится переопределить процедуру CreateParams у желаемой формы. А в ней установить params.WndParent в дескриптор окна, к которому Вы хотите прикрепить форму.
 TForm2 = class(TForm) 
 protected 
 procedure CreateParams(var params: TCreateParams); override; 
implementation
procedure TForm2.CreateParams(var params: TCreateParams); 
var 
 aHWnd: HWND; 
begin 
 inherited; 
 { как-нибудь получаем существующий дескриптор }
 ahWnd := GetForegroundWindow; 
 { а теперь: }
 params.WndParent := ahWnd; 
end; 
Source: Взято из http://forum.sources.ru
ID: 00507
Как приложение оставить свёрнутым в иконку?

=== Как приложение оставить свёрнутым в иконку? ===
Для этого необходимо обработать сообщение WMQUERYOPEN. Однако обработчик сообщения необходимо поместить в секции private - т.е. в объявлении TForm.
procedure WMQueryOpen(var Msg: TWMQueryOpen); message WM_QUERYOPEN; 
// Реализация будет выглядеть следующим образом:
procedure WMQueryOpen(var Msg: TWMQueryOpen); 
begin 
 Msg.Result := 0; 
end;
ID: 00409
Как принимать перетаскиваемые файлы из проводника?

=== Как принимать перетаскиваемые файлы из проводника? ===
Вот пример с TListbox на форме:
type 
 TForm1 = class(TForm) 
 ListBox1: TListBox; 
 procedure FormCreate(Sender: TObject); 
 protected 
 procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES; 
 private 
 public 
 end; 
var 
 Form1: TForm1; 
implementation 
uses shellapi; 
{$R *.DFM} 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
 DragAcceptFiles(Form1.Handle, true); 
end; 
procedure TForm1.WMDROPFILES (var Msg: TMessage); 
var 
 i, 
 amount, 
 size: integer; 
 Filename: PChar; 
begin 
 inherited; 
 Amount := DragQueryFile(Msg.WParam, $FFFFFFFF, Filename, 255); 
 for i := 0 to (Amount - 1) do 
 begin 
 size := DragQueryFile(Msg.WParam, i , nil, 0) + 1; 
 Filename := StrAlloc(size); 
 DragQueryFile(Msg.WParam,i , Filename, size); 
 listbox1.Items.Add(StrPas(Filename)); 
 StrDispose(Filename); 
 end; 
 DragFinish(Msg.WParam); 
end;
Source: Взято из http://forum.sources.ru
ID: 00654
Как принимать ярлыки при перетягивании их на контрол

=== Как принимать ярлыки при перетягивании их на контрол ===
 TForm1 = class(TForm)
 private
 { Private declarations }
 procedure WMDropFiles(var M: TWMDropFiles); message WM_DROPFILES;
 end;
end;
var
 Form1: TForm1;
implementation
uses
 StrUtils, ShellAPI, ComObj, ShlObj, ActiveX;
procedure TForm1.FormCreate(Sender: TObject);
begin
 DragAcceptFiles(Handle, True);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
 DragAcceptFiles(Handle, False);
end;
procedure TForm1.WMDropFiles(var M: TWMDropFiles);
var
 hDrop: Cardinal;
 n: Integer;
 s: string;
begin
 hDrop := M.Drop;
 n := DragQueryFile(hDrop, 0, nil, 0);
 SetLength(s, n);
 DragQueryFile(hDrop, 0, PChar(s), n + 1);
 DragFinish(hDrop);
 M.Result := 0;
 FileOpen(s);
end;
procedure TForm1.FileOpen(FileName: string);
begin
 if CompareText(ExtractFileExt(FileName), '.lnk') = 0 then
 FileName := ResolveShortcut(Application.Handle, FileName);
 DocName := ExtractFileName(FileName);
 Caption := Application.Title + ' - ' + DocName;
 {...}
end;
function ResolveShortcut(Wnd: HWND; ShortcutPath: string): string;
var
 obj: IUnknown;
 isl: IShellLink;
 ipf: IPersistFile;
 pfd: TWin32FindDataA;
begin
 Result := ;
 obj := CreateComObject(CLSID_ShellLink);
 isl := obj as IShellLink;
 ipf := obj as IPersistFile;
 ipf.Load(PWChar(WideString(ShortcutPath)), STGM_READ);
 with isl do
 begin
 Resolve(Wnd, SLR_ANY_MATCH);
 SetLength(Result, MAX_PATH);
 GetPath(PChar(Result), Length(Result), pfd, SLGP_UNCPRIORITY);
 Result := PChar(Result);
 end;
end;
Source: Взято с http://delphiworld.narod.ru
ID: 00366
Category:VCL
Category:DragAndDrop
Category:Файлы
Как присвоить все значения полей одного класса, другому такому же классу?

=== Как присвоить все значения полей одного класса, другому такому же классу? ===
How can I assign all property values (or if it's not possible only published property values, or some of them) of one class (TComponent) to another instance of the same class? What I want to do is:
MyComponent1.{property1} := MyComponent2.{property1};
{...}
MyComponent2.{propertyN} := MyComponent2.{propertyN};
Is there a better and shorter way to do this? I tried this: MyComponent1 := MyComponent2; But it doesn't work. Why not? Can I point to the second component ?
Answer 1:
MyComponent2 and MyComponent1 are pointers to your components, and this kind of assigment leads to MyComponent1 pointing to MyComponent2. But it will not copy its property values.
A better way is to override the assign method of your control, do all property assignment there and call it when you need to copy component attributes. Here's example:
procedure TMyComponent.Assign(Source: TPersistent);
begin
 if Source is TMyComponent then
 begin
 property1 := TMyComponent(Source).property1;
 { ... }
 end
 else
 inherited Assign(Source);
end;
To assign properties you'll need to set this line in the code:
 MyComponent1.Assign(MyComponent2);
Author: Serge Gubenko
ID: 00280
----
procedure EqualClassProperties(AClass1, AClass2: TObject);
var
 PropList: PPropList;
 ClassTypeInfo: PTypeInfo;
 ClassTypeData: PTypeData;
 i: integer;
 NumProps: Integer;
 APersistent : TPersistent;
begin
 if AClass1.ClassInfo <> AClass2.ClassInfo then
 exit;
 ClassTypeInfo := AClass1.ClassInfo;
 ClassTypeData := GetTypeData(ClassTypeInfo);
 if ClassTypeData.PropCount <> 0 then
 begin
 GetMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
 try
 GetPropInfos(AClass1.ClassInfo, PropList);
 for i := 0 to ClassTypeData.PropCount - 1 do
 if not (PropList[i]^.PropType^.Kind = tkMethod) then
 {if Class1,2 is TControl/TWinControl on same form, its names must be unique}
 if PropList[i]^.Name <> 'Name' then
 if (PropList[i]^.PropType^.Kind = tkClass) then
 begin
 APersistent := TPersistent(GetObjectProp(AClass1, PropList[i]^.Name, TPersistent));
 if APersistent <> nil then
 APersistent.Assign(TPersistent(GetObjectProp(AClass2, PropList[i]^.Name, TPersistent)))
 end
 else
 SetPropValue(AClass1, PropList[i]^.Name, GetPropValue(AClass2, PropList[i]^.Name));
 finally
 FreeMem(PropList, SizeOf(PPropInfo) * ClassTypeData.PropCount);
 end;
 end;
end;
Note that this code skips object properties inherited other than TPersistent.
Author: Gokhan Ersumer
Source: Взято из http://www.lmc-mediaagentur.de/dpool
ID: 00281
Как присвоить значение свойству selected в ListBox?

=== Как присвоить значение свойству selected в ListBox? ===
Свойство "selected" компонента TListBox может быть использовано только если свойство MultiSelect установлено в True. Если Вы работаете с ListBox'ом у которого MultiSelect=false то используйте свойство ItemIndex.
procedure TForm1.Button1Click(Sender: TObject);
begin
 ListBox1.Items.Add('1');
 ListBox1.Items.Add('2');
 { This will fail on a single selection ListBox }
 // ListBox1.Selected[1] := true;
 ListBox1.ItemIndex := 1; { This is ok }
end;
Source: Взято из http://forum.sources.ru
ID: 00652
Как присвоить событие в run-time?

=== Как присвоить событие в run-time? ===
Пример стандартного присвоения события в run-time:
type
 TForm1 = class(TForm)
 Button1: TButton;
 procedure FormCreate(Sender: TObject);
 private
 procedure Click(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
procedure TForm1.Click(Sender: TObject);
begin
 // do something
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 Button1.OnClick := Click;
end;
end.
Author: Vit (www.delphist.com, www.drkb.ru, www.unihighlighter.com, www.nevzorov.org)
Source: http://forum.vingrad.ru
ID: 00099
----
А как сделать чтобы "procedure Click" была не методом класса, а отдельно стоящей функцией?
procedure Click(Self: TObject; Sender: TObject);
begin
 //...
end;
var EvHandler: TNotifyEvent;
TMethod(EvHandler).Code := @Click;
TMethod(EvHandler).Data := nil;
Button1.OnClick := EvHandler;
Без извращений можно так:
 TDummy = class
 class procedure Click(Sender: TObject);
 end;
 Button1.OnClick := TDummy.Click;
Author: Le Taon
Source: http://forum.vingrad.ru
ID: 00100
----
По идее, при вызове OnClick первым параметром будет запихнут указатель на экземпляр того класса который в этом OnClick хранится . Я в низкоуровневой реализации не силен, но кажись, так как параметры в процедурах в Delphi передаются через регистры, то ничего страшного не произойдет. 
procedure Click(Self: Pointer; Sender: TObject);
begin
 TButton(Sender).Caption := 'ee';
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 @Button1.OnClick := @Click;
end;
Self тут у нас будет равен nil, а Sender как раз и получается Sender'ом. 
Author: Fantasist
Source: http://forum.vingrad.ru
ID: 00101
Как проверить, включён ли ActiveDesktop?

=== Как проверить, включён ли ActiveDesktop? ===
function IsActiveDeskTopOn: Boolean; 
var 
 h: hWnd; 
begin 
 h := FindWindow('Progman', nil); 
 h := FindWindowEx(h, 0, 'SHELLDLL_DefView', nil); 
 h := FindWindowEx(h, 0, 'Internet Explorer_Server', nil); 
 Result := h <> 0; 
end; 
Source: Взято из http://forum.sources.ru
ID: 01819
----
uses
 ComObj, ShlObj, ActiveX;
// Check if Active Desktop is enabled (2)
function IsActiveDesktopEnable: Boolean;
const
 CLSID_ActiveDesktop: TGUID = '{75048700-EF1F-11D0-9888-006097DEACF9}';
var
 ActiveDesk: IActiveDesktop;
 ComponentsOpt: TComponentsOpt;
 hr: HRESULT;
 dwReserved: DWORD;
begin
 ZeroMemory(@ComponentsOpt, SizeOf(TComponentsOpt));
 ComponentsOpt.dwSize := SizeOf(TComponentsOpt);
 hr := CoCreateInstance(CLSID_ActiveDesktop, nil, CLSCTX_INPROC_SERVER, CLSID_ActiveDesktop, ActiveDesk);
 if SUCCEEDED(hr) then
 begin
 hr := ActiveDesk.GetDesktopItemOptions(ComponentsOpt, dwReserved);
 // ActiveDesk._Release;
 end;
 Result := ComponentsOpt.fActiveDesktop;
end;
Source: http://delphiworld.narod.ru/
ID: 01820
Как проверить, имеем ли мы административные привилегии в системе?

=== Как проверить, имеем ли мы административные привилегии в системе? ===
type
 PTOKEN_GROUPS = TOKEN_GROUPS^;
function RunningAsAdministrator(): Boolean;
var
 SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
 psidAdmin: PSID;
 ptg: PTOKEN_GROUPS = nil;
 htkThread: Integer; { HANDLE }
 cbTokenGroups: Longint; { DWORD }
 iGroup: Longint; { DWORD }
 bAdmin: Boolean;
begin
 Result := false;
 if not OpenThreadToken(GetCurrentThread(), // get security token
 TOKEN_QUERY, FALSE, htkThread) then
 if GetLastError() = ERROR_NO_TOKEN then
 begin
 if not OpenProcessToken(GetCurrentProcess(),
 TOKEN_QUERY, htkThread) then
 Exit;
 end
 else
 Exit;
 if GetTokenInformation(htkThread, // get #of groups
 TokenGroups, nil, 0, cbTokenGroups) then
 Exit;
 if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
 Exit;
 ptg := PTOKEN_GROUPS(getmem(cbTokenGroups));
 if not Assigned(ptg) then
 Exit;
 if not GetTokenInformation(htkThread, // get groups
 TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then
 Exit;
 if not AllocateAndInitializeSid(SystemSidAuthority,
 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
 0, 0, 0, 0, 0, 0, psidAdmin) then
 Exit;
 iGroup := 0;
 while iGroup < ptg^.GroupCount do // check administrator group
 begin
 if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
 begin
 Result := TRUE;
 break;
 end;
 Inc(iGroup);
 end;
 FreeSid(psidAdmin);
end;
Source: Взято с http://delphiworld.narod.ru
ID: 01720
Как проверить, является ли число простым?

// test if N is prime, do some small Strong Pseudo Prime test in certain bounds
// copyright (c) 2000 Hagen Reddmann, don't remove
function IsPrime(N: Cardinal): Boolean; register;
asm
 TEST EAX,1 { Odd(N) ?? }
 JNZ @@1
 CMP EAX,2 { N == 2 ?? }
 SETE AL
 RET
@@1: CMP EAX,73 { N JB @@C }
 JE @@E { N == 73 ?? }
 PUSH ESI
 PUSH EDI
 PUSH EBX
 PUSH EBP
 PUSH EAX { save N as Param for @@5 }
 LEA EBP,[EAX - 1] { M == N -1, Exponent }
 MOV ECX,32 { calc remaining Bits of M and shift M' }
 MOV ESI,EBP
@@2: DEC ECX
 SHL ESI,1
 JNC @@2
 PUSH ECX { save Bits as Param for @@5 }
 PUSH ESI { save M' as Param for @@5 }
 CMP EAX,08A8D7Fh { N = 9080191 ?? }
 JAE @@3
 // now if (N MOV EAX,31
 CALL @@5 { 31^((N-1)(2^s)) mod N }
 JC @@4
 MOV EAX,73 { 73^((N-1)(2^s)) mod N }
 PUSH OFFSET @@4
 JMP @@5
 // now if (N @@3: MOV EAX,2
 CALL @@5
 JC @@4
 MOV EAX,7
 CALL @@5
 JC @@4
 MOV EAX,61
 CALL @@5
@@4: SETNC AL
 ADD ESP,4 * 3
 POP EBP
 POP EBX
 POP EDI
 POP ESI
 RET
// do a Strong Pseudo Prime Test
@@5: MOV EBX,[ESP + 12] { N on stack }
 MOV ECX,[ESP + 8] { remaining Bits }
 MOV ESI,[ESP + 4] { M' }
 MOV EDI,EAX { T = b, temp. Base }
@@6: DEC ECX
 MUL EAX
 DIV EBX
 MOV EAX,EDX
 SHL ESI,1
 JNC @@7
 MUL EDI
 DIV EBX
 AND ESI,ESI
 MOV EAX,EDX
@@7: JNZ @@6
 CMP EAX,1 { b^((N -1)(2^s)) mod N == 1 mod N ?? }
 JE @@A
@@8: CMP EAX,EBP { b^((N -1)(2^s)) mod N == -1 mod N ?? , EBP = N -1 }
 JE @@A
 DEC ECX { second part to 2^s }
 JNG @@9
 MUL EAX
 DIV EBX
 CMP EDX,1
 MOV EAX,EDX
 JNE @@8
@@9: STC
@@A: RET
@@B: DB 3,5,7,11,13,17,19,23,29,31,37,41,43,47,53,59,61,67,71
@@C: MOV EDX,OFFSET @@B
 MOV ECX,18
@@D: CMP AL,[EDX + ECX]
 JE @@E
 DEC ECX
 JNL @@D
@@E: SETE AL
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
 if IsPrime(3453451) then
 ShowMessage('yes');
end;
{**** Another function ***}
function IsPrime(Prim: Longint): Boolean;
var
 Z: Real;
 Max: LongInt;
 Divisor: LongInt;
begin
 Prime := False;
 if (Prim and 1) = 0 then Exit;
 Z := Sqrt(Prim);
 Max := Trunc(Z) + 1;
 Divisor := 3;
 while Max > Divisor do
 begin
 if (Prim mod Divisor) = 0 then Exit;
 Inc(Divisor, 2);
 if (Prim mod Divisor) = 0 then Exit;
 Inc(Divisor, 4);
 end;
 Prime := True;
end;
Author: Hagen Reddmann
Source: http://www.swissdelphicenter.ch/en/tipsindex.php
ID: 04086
Category:Алгоритмы
Category:Математика