unit Hilb2F;
//*******************************************************
// Example program demonstrating non-recursive Hilbert
// curves.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//
// Revised (C) 1999 Andrzej Grażyński, Helion Publ.
//
//*******************************************************

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, StdCtrls, ExtCtrls, Math;

const
    STACK_SIZE = 10; // Maksymalna głębokość rekursji

type
  THilb2Form = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    mnuExit: TMenuItem;
    Help1: TMenuItem;
    mnuAbout: TMenuItem;
    Label1: TLabel;
    LevelEdit: TEdit;
    CmdDraw: TButton;
    DrawArea: TImage;
    procedure mnuExitClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure NumbersOnly(Sender: TObject; var Key: Char);
    procedure CmdDrawClick(Sender: TObject);
    procedure DrawCurve;
    procedure DrawHilbert(depth, dx, dy : Integer);
    procedure PushValues(pc, depth, dx, dy : Integer);
    procedure PopValues(var pc, depth, dx, dy : Integer);
  private
    { Private declarations }
    pc_stack, depth_stack : Array[1..STACK_SIZE] of Integer;
    dx_stack, dy_stack    : Array[1..STACK_SIZE] of Integer;
    top_of_stack          : Integer;
  public
    { Public declarations }
  end;

var
  Hilb2Form: THilb2Form;

implementation

{$R *.DFM}

procedure THilb2Form.mnuExitClick(Sender: TObject);
begin
    Close;
end;

procedure THilb2Form.mnuAboutClick(Sender: TObject);
const
    CRCR = #13#10#13#10;
    CR = #13#10;
begin

    MessageDlg(
        'Niniejszy program rysuje krzywą Hilberta określonego stopnia w sposób nierekursywny.' + CRCR +
        'Wprowadź stopień krzywej i kliknij w przycisk "Rysuj".' + CR +
        'UWAGA: czas rysowania rośnie gwałtownie wraz ze stopniem krzywej.'
        , mtInformation, [mbOK], 0);


end;

procedure THilb2Form.NumbersOnly(Sender: TObject; var Key: Char);
begin
    if (Key = #8)
    then
      exit; // Backspace.
    if ((Key >= '0') and (Key <= '9')) then exit;
    Key := #0;
end;

procedure THilb2Form.CmdDrawClick(Sender: TObject);
begin
    DrawCurve;
end;

// Rysuj krzywą
procedure THilb2Form.DrawCurve;
var
    depth, gaps, dist, margin : Integer;
    rect                      : TRect;
begin
    if (LevelEdit.Text = '') then exit;
    depth := StrToInt(LevelEdit.Text);
    if ((depth < 1) or (depth > 9)) Then
    begin
        ShowMessage('Stopień krzywej musi zawierać się pomiędzy 1 a 9');
        exit;
    end;

    Screen.Cursor := crHourGlass;
    Update;

    // Obliczenie rozmiaru segmentu wypełniającego obszar rysowania
    margin := 5;
    gaps := Round(IntPower(2, depth) - 1);
    dist := (DrawArea.ClientWidth - 2 * margin) div gaps;

    rect.Left := 0;
    rect.Right := DrawArea.ClientWidth;
    rect.Top := 0;
    rect.Bottom := DrawArea.ClientWidth;
    DrawArea.Canvas.FillRect(rect);
    DrawArea.Canvas.MoveTo(margin, margin);

    DrawHilbert(depth, dist, 0);

    Screen.Cursor := crDefault;
end;

procedure THilb2Form.DrawHilbert(depth, dx, dy : Integer);
var
    pc, tmp : Integer;
begin
    pc := 1;
    with DrawArea.Canvas do
        while (True) do
        begin
            Case pc of
            1:
                begin
                    if (depth > 1) then // wywołanie rekurencyjne
                    begin
                        // przechowaj bieżące wartości
                        PushValues(2, depth, dx, dy);
                        // przygotowanie do rekurencji
                        depth := depth - 1;
                        tmp := dx;
                        dx := dy;
                        dy := tmp;
                        pc := 1; // idź do początku wywołania rekurencyjnego
                    end else begin  // warunek bazowy
                        // brak wywołania rekurencyjnego
                        // kontynuacja od bloku 2
                        pc := 2;
                    end;
                end;
            2:
                begin
                    LineTo(PenPos.X + dx, PenPos.Y + dy);
                    if (depth > 1) then // wywołanie rekurencyjne
                    begin
                        // przechowaj bieżące wartości
                        PushValues(3, depth, dx, dy);
                        // przygotowanie do rekurencji
                        depth := depth - 1;
                        // dx i dy pozostają takie same
                        pc := 1  // idź do początku wywołania rekurencyjnego
                    end else begin // warunek bazowy
                        // brak wywołania rekurencyjnego
                        // kontynuacja od bloku 3
                        pc := 3;
                    end;
                end;
            3:
                begin
                    LineTo(PenPos.X + dy, PenPos.Y + dx);
                    if (depth > 1) then // wywołanie rekurencyjne
                    begin
                        // przechowaj bieżące wartości
                        PushValues(4, depth, dx, dy);
                        // przygotowanie do rekurencji
                        depth := depth - 1;
                        // dx i dy pozostają takie same
                        pc := 1; // idź do początku wywołania rekurencyjnego
                    end else begin // warunek bazowy
                        // brak wywołania rekurencyjnego
                        // kontynuacja od bloku 4
                        pc := 4;
                    end;
                end;
            4:
                begin
                    LineTo(PenPos.X - dx, PenPos.Y - dy);
                    if (depth > 1) then  // wywołanie rekurencyjne
                    begin
                        // przechowaj bieżące wartości
                        PushValues(0, depth, dx, dy);
                        // przygotowanie do rekurencji
                        depth := depth - 1;
                        tmp := dx;
                        dx := -dy;
                        dy := -tmp;
                        pc := 1; // idź do początku wywołania rekurencyjnego
                    end else begin // warunek bazowy
                        // koniec wywołania rekurencyjnego
                        pc := 0;
                    end;
                end;
            0: // Powrót z rekurencji
                begin
                    if (top_of_stack > 0) then
                        PopValues(pc, depth, dx, dy)
                else
                    // Stos jest pusty - gotowe.
                    break;
            end; // End case pc of
        end; // End while (True)
    end; // End with DrawArea.Canvas do
end;

// Przechowaj na stosie niezbędne elementy
procedure THilb2Form.PushValues(pc, depth, dx, dy : Integer);
begin
    top_of_stack := top_of_stack + 1;
    depth_stack[top_of_stack] := depth;
    dx_stack[top_of_stack] := dx;
    dy_stack[top_of_stack] := dy;
    pc_stack[top_of_stack] := pc;
end;

// Zdejmij ze stosu przechowane elementy
procedure THilb2Form.PopValues(var pc, depth, dx, dy : Integer);
begin
    depth := depth_stack[top_of_stack];
    dx := dx_stack[top_of_stack];
    dy := dy_stack[top_of_stack];
    pc := pc_stack[top_of_stack];
    top_of_stack := top_of_stack - 1;
end;

end.
