{$mode delphi}

program Test;
uses
  Windows, Messages, sysutils, math;

const
  winName = 'MainWClass';
  BTN_START_ID = 110;

var
  hwndMain: HWND;

const
  HLSMAX = 240;
  RGBMAX = 255;
  UNDEFINED = (HLSMAX*2) div 3;

procedure HLStoRGB(H, L, S: integer; var R, G, B: integer);
var
  Magic1, Magic2: single;

  function HueToRGB(n1, n2, hue: single): single;
  begin
    if (hue < 0) then
      hue := hue+HLSMAX;
    if (hue > HLSMAX) then
      hue:=hue - HLSMAX;
    if (hue < (HLSMAX/6)) then
      result:= ( n1 + (((n2-n1)*hue+(HLSMAX/12))/(HLSMAX/6)) )
    else
    if (hue < (HLSMAX/2)) then
      result:=n2
    else
    if (hue < ((HLSMAX*2)/3)) then
      result:= ( n1 + (((n2-n1)*(((HLSMAX*2)/3)-hue)+(HLSMAX/12))/(HLSMAX/6)))
    else
      result:= ( n1 );
  end;

begin
  if (S = 0) then begin
    B:=round( (L*RGBMAX)/HLSMAX ); R:=B; G:=B;
  end
  else begin
    if (L <= (HLSMAX/2)) then
      Magic2 := (L*(HLSMAX + S) + (HLSMAX/2))/HLSMAX
    else
      Magic2 := L + S - ((L*S) + (HLSMAX/2))/HLSMAX;

    Magic1 := 2*L-Magic2;
    R := round( (HueToRGB(Magic1,Magic2,H+(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );
    G := round( (HueToRGB(Magic1,Magic2,H)*RGBMAX + (HLSMAX/2)) / HLSMAX );
    B := round( (HueToRGB(Magic1,Magic2,H-(HLSMAX/3))*RGBMAX + (HLSMAX/2))/HLSMAX );

  end;
  if R<0 then R:=0;
  if R>RGBMAX then R:=RGBMAX;

  if G<0 then G:=0;
  if G>RGBMAX then G:=RGBMAX;

  if B<0 then B:=0;
  if B>RGBMAX then B:=RGBMAX;
end;


function F1(A, R: double):double;
begin
  F1 := 1 / (abs(cos(7*(A/2) - sqr(sqr(R)) * 0.3)) + (0.005 / R));
end;

function F2(A, R: double): double;
begin
  F2 :=
    8 *
    (sqr(sin(7*(A/2))) / (sqr(R / (abs(sin(A/2)))) * 10 + 1)) /
    (
      abs(
        sin((R - ((arccos(cos((A+pi) * 7 - sqr(sqr(R)) * 0.3)) + 2 * R * sqr(arccos(cos((A+pi) * 7 - sqr(sqr(R)) * 0.3)))) / 20)) * 8*pi)
      ) + 0.1 + sqr(cos(7*(A/2) - sqr(sqr(R)) * 0.3))
    );
end;

function F3(A, R: double): double;
begin
  F3 := 3 / (sqr(100*R) + 0.1);
end;

function F4(A, R: double): double;
begin
  F4 := abs(sin(A/2)) - sqr(R);
end;

function F5(A, R: double): double;
begin
  F5 := abs(sin(A/2));
end;

function F6(A, R: double): double;
begin
  F6 :=
    1 +
    (
      0.01 /
      (
        sqr(
	  sin(R*cos(A)*100 + 10*cos(R*sin(A) * 40))
	  +
	  sin(R*sin(A)*100 + 10 * sin(R*cos(A) * 40))
	) + 0.01
      )
    );
end;

function F7(A, R: double): double;
begin
  F7 := (R + 0.2) * 0.0002 / (sqr(A - R * 0.1) + 0.0001);
end;


function F(A, R: double): double;
begin
  F := ((F1(A, R) + F2(A, R) + F3(A, R)) * F4(A, R) - F5(A, R)) * F6(A, R) + F7(A, R);
end;

procedure DrawIt(myDC: HDC; const Rec: TRect);
var
  center_x, center_y, scanR: Integer;
const
  step_phi = pi / 1700;

  procedure put_polar(L: double; R, phi: double);
  var
    X, Y: integer;
    vR, vG, vB: integer;
  begin
    X := center_x + trunc(r * cos(phi));
    Y := center_y - trunc(r * sin(phi));
    HLStoRGB(80, trunc(8.5 * (ln(L) + 15)), 240, vR, vG, vB);

    SetPixel(myDC, X, Y, RGB(vR, vG, vB));
  end;

  procedure scan_line(phi: double);
  var
    ROPModeOld: Integer;
    ahead: double;
  begin
    ahead := phi + 15 * step_phi;

    ROPModeOld := GetROP2(myDC);
    SetROP2(myDC, R2_XORPEN);

    MoveToEx(myDC, center_x, center_y, nil);
    LineTo(myDC, center_x + trunc(scanR * cos(ahead)),
                 center_y - trunc(scanR * sin(ahead)));
    SetROP2(myDC, ROPModeOld);
  end;

var
  phi, ff: double;
  R: integer;

  myGreenPen, old_pen: HPEN;
begin
  myGreenPen := CreatePen(PS_SOLID, 1, RGB(0, 255, 0));
  old_pen := SelectObject(myDC, myGreenPen);

  center_x := Rec.Left + ((Rec.Right - Rec.Left) div 2); // wid div 2;
  center_y := Rec.Top + ((Rec.Bottom - Rec.Top) div 2); // hei div 2;

  scanR := min(center_x, center_y);

  phi := step_phi;
  while phi < 2 * pi do begin

    scan_line(phi);
    for R := 1 to max(center_x, center_y) do begin

      ff := f(phi, R/500);
      if (ff >= 0) and (ff < 24) then begin
        put_polar(ff, R, phi);
      end;

    end;
    scan_line(phi);

    phi := phi + step_phi;
  end;

  SelectObject(myDC, old_pen);
  DeleteObject(myGreenPen);
end;


function MainWndProc(myWindow: HWND; myMessage: UINT;
                     myWParam: WPARAM; myLParam: LPARAM): INT_PTR; stdcall;
var
  hMyDC: HDC;
  Rect: TRect;

begin
  Result := 0;
  case myMessage of

    WM_COMMAND:
    begin
      case LOWORD(myWParam) of
        BTN_START_ID:
        begin
          hMyDC := getdc(myWindow);
          GetClientRect(myWindow, Rect);
          DrawIt(hMyDC, Rect);
          ReleaseDC(myWindow, hmydc);
        end;
      end;
    end;

    WM_DESTROY:
    begin
      PostQuitMessage(0); Exit
    end;

  end;
  Result := DefWindowProc(myWindow, myMessage, myWParam, myLParam);
end;

function InitApplication: Boolean;
var
  wcx: TWndClass;
begin
  wcx.style := CS_HREDRAW or CS_VREDRAW;
  wcx.lpfnWndProc := @MainWndProc;
  wcx.cbClsExtra := 0;
  wcx.cbWndExtra := 0;
  wcx.hInstance := hInstance;
  wcx.hIcon := LoadIcon(0, IDI_APPLICATION);
  wcx.hCursor := LoadCursor(0, IDC_ARROW);
  wcx.hbrBackground := GetStockObject(BLACK_BRUSH);
  wcx.lpszMenuName := nil;
  wcx.lpszClassName := PChar(WinName);
  Result := RegisterClass(wcx) <> 0;
end;

function InitInstance: HWND;
begin
  Result := CreateWindow(
    PChar(WinName),
    'Test program',
    WS_OVERLAPPEDWINDOW,
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
    0,
    0,
    hInstance,
    nil
  );
end;

var
  btnStart: HWND;
  myFont: HFONT;
  AMessage: msg;

begin
  if (not InitApplication) then
    MessageBox(0, 'Error at class registration', nil, mb_Ok)
  else begin
    hwndMain := InitInstance;
    if (hwndMain = 0) then
      MessageBox(0, 'Error at window creation', nil, mb_Ok)
    else begin

      ShowWindow(hwndMain, SW_SHOWMAXIMIZED);
      btnStart := CreateWindowEx(0, 'BUTTON', 'Draw Me',
        WS_CHILD or WS_VISIBLE or BS_PUSHBUTTON,
        10, 10, 175, 21, hWndMain, BTN_START_ID, hInstance, nil);

      myFont := CreateFont(-11, 0, 0, 0, FW_NORMAL, 0, 0, 0,
        DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS,
        DEFAULT_QUALITY, DEFAULT_PITCH or FF_DONTCARE, 'MS Sans Serif');
      if myFont <> 0 then begin
        SendMessage(btnStart, WM_SETFONT, WPARAM(myFont), 0);
      end;

      UpdateWindow(hwndMain);
      while GetMessage(AMessage, 0, 0, 0) do begin
        TranslateMessage(AMessage);
        DispatchMessage(AMessage);
      end;
    end;
  end;
end.