unit Sierp2F;
//*******************************************************
// Example program demonstrating non-recursive Sierpinski
// curves.
//*******************************************************
// Copyright (C) 1998 John Wiley & Sons, Inc.
// All rights reserved. See additional copyright
// information in Readme.txt.
//*******************************************************

interface

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

const
    STACK_SIZE = 10; // Maximum depth of recursion.

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

var
  SierpinskiForm: TSierpinskiForm;

implementation

{$R *.DFM}

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

procedure TSierpinskiForm.mnuAboutClick(Sender: TObject);
const
    CRCR = #13#10#13#10;
begin
    MessageDlg(
        'This program draws Sierpinski curves non-recursively.' + CRCR +
        'Enter the maximum depth of recursion for the curve (start small) and click the Draw button.'
        , mtInformation, [mbOK], 0);
end;

procedure TSierpinskiForm.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 TSierpinskiForm.CmdDrawClick(Sender: TObject);
begin
    DrawCurve;
end;

// Draw the curve.
procedure TSierpinskiForm.DrawCurve;
var
    depth, gaps, dist, margin : Integer;
    rect                      : TRect;
begin
    if (LevelEdit.Text = '') then exit;
    depth := StrToInt(LevelEdit.Text);
    if ((depth < 1) or (depth > 10)) Then
    begin
        ShowMessage('Level should be between 1 and 10');
        exit;
    end;

    Screen.Cursor := crHourGlass;
    Update;

    // Compute the Dx and Dy distances needed so the
    // curve fits drawing area.
    margin := 5;
    gaps := Round(3 * 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 + dist);

    DrawSierp(depth, dist);

    Screen.Cursor := crDefault;
end;

// Draw and connect type B, C, D, and A subcurves to
// make the complete Sierpinski curve.
procedure TSierpinskiForm.DrawSierp(depth, dist : Integer);
begin
    with DrawArea.Canvas do
    begin
        DrawSubcurve(depth, 21, dist);
        LineTo(PenPos.X + dist, PenPos.Y + dist);
        DrawSubcurve(depth, 31, dist);
        LineTo(PenPos.X + dist, PenPos.Y - dist);
        DrawSubcurve(depth, 41, dist);
        LineTo(PenPos.X - dist, PenPos.Y - dist);
        DrawSubcurve(depth, 11, dist);
        LineTo(PenPos.X - dist, PenPos.Y + dist);
    end;
end;

// Draw a Sierpinski sub-curve.
//
// The subcurves are:
//     A = top    = A + B, left,  D + A
//     B = left   = B + C, down,  A + B
//     C = bottom = C + D, right, B + C
//     D = right  = D + A, up,    C + D
procedure TSierpinskiForm.DrawSubcurve(depth, pc, dist : Integer);
begin
    with DrawArea.Canvas do
    begin
        while (true) do
        begin
            case pc of
            // **********
            // * SierpA *
            // **********
            11:
                begin
                    if (depth <= 1) then
                    begin
                        LineTo(PenPos.X - dist, PenPos.Y + dist);
                        LineTo(PenPos.X - dist, PenPos.Y + 0   );
                        LineTo(PenPos.X - dist, PenPos.Y - dist);
                        pc := 0;
                    end else begin
                        PushValues(12, depth); // Run SierpA
                        depth := depth - 1;
                        pc := 11;
                    end;
                end;
            12:
                begin
                    LineTo(PenPos.X - dist, PenPos.Y + dist);
                    PushValues(13, depth); // Run SierpB
                    depth := depth - 1;
                    pc := 21;
                end;
            13:
                begin
                    LineTo(PenPos.X - dist, PenPos.Y + 0);
                    PushValues(14, depth); // Run SierpD
                    depth := depth - 1;
                    pc := 41;
                end;
            14:
                begin
                    LineTo(PenPos.X - dist, PenPos.Y - dist);
                    PushValues(0, depth); // Run SierpA
                    depth := depth - 1;
                    pc := 11;
                end;
            // **********
            // * SierpB *
            // **********
            21:
                begin
                    if (depth <= 1) then
                    begin
                        LineTo(PenPos.X + dist, PenPos.Y + dist);
                        LineTo(PenPos.X + 0   , PenPos.Y + dist);
                        LineTo(PenPos.X - dist, PenPos.Y + dist);
                        pc := 0;
                    end else begin
                        PushValues(22, depth); // Run SierpB
                        depth := depth - 1;
                        pc := 21;
                    end;
                end;
            22:
                begin
                    LineTo(PenPos.X + dist, PenPos.Y + dist);
                    PushValues(23, depth); // Run SierpC
                    depth := depth - 1;
                    pc := 31;
                end;
            23:
                begin
                    LineTo(PenPos.X + 0, PenPos.Y + dist);
                    PushValues(24, depth); // Run SierpA
                    depth := depth - 1;
                    pc := 11;
                end;
            24:
                begin
                    LineTo(PenPos.X - dist, PenPos.Y + dist);
                    PushValues(0, depth); // Run SierpB
                    depth := depth - 1;
                    pc := 21;
                end;
            // **********
            // * SierpC *
            // **********
            31:
                begin
                    if (depth <= 1) then
                    begin
                        LineTo(PenPos.X + dist, PenPos.Y - dist);
                        LineTo(PenPos.X + dist, PenPos.Y + 0   );
                        LineTo(PenPos.X + dist, PenPos.Y + dist);
                        pc := 0;
                    end else begin
                        PushValues(32, depth); // Run SierpC
                        depth := depth - 1;
                        pc := 31;
                    end;
                end;
            32:
                begin
                    LineTo(PenPos.X + dist, PenPos.Y - dist);
                    PushValues(33, depth); // Run SierpD
                    depth := depth - 1;
                    pc := 41;
                end;
            33:
                begin
                    LineTo(PenPos.X + dist, PenPos.Y + 0);
                    PushValues(34, depth); // Run SierpB
                    depth := depth - 1;
                    pc := 21;
                end;
            34:
                begin
                    LineTo(PenPos.X + dist, PenPos.Y + dist);
                    PushValues(0, depth); // Run SierpC
                    depth := depth - 1;
                    pc := 31;
                end;
            // **********
            // * SierpD *
            // **********
            41:
                begin
                    if (depth <= 1) then
                    begin
                        LineTo(PenPos.X - dist, PenPos.Y - dist);
                        LineTo(PenPos.X + 0   , PenPos.Y - dist);
                        LineTo(PenPos.X + dist, PenPos.Y - dist);
                        pc := 0;
                    end else begin
                        PushValues(42, depth); // Run SierpD
                        depth := depth - 1;
                        pc := 41;
                    end;
                end;
            42:
                begin
                    LineTo(PenPos.X - dist, PenPos.Y - dist);
                    PushValues(43, depth); // Run SierpA
                    depth := depth - 1;
                    pc := 11;
                end;
            43:
                begin
                    LineTo(PenPos.X + 0, PenPos.Y - dist);
                    PushValues(44, depth); // Run SierpC
                    depth := depth - 1;
                    pc := 31;
                end;
            44:
                begin
                    LineTo(PenPos.X + dist, PenPos.Y - dist);
                    PushValues(0, depth); // Run SierpD
                    depth := depth - 1;
                    pc := 41;
                end;
            // *****************
            // * End recursion *
            // *****************
            0:
                begin
                    if (top_of_stack <= 0) then break; // Done.
                    PopValues(pc, depth);
                end;
            end; // case pc of
        end; // while (true) do
    end; // End with DrawArea.Canvas do
end;

// Push values onto the stacks.
procedure TSierpinskiForm.PushValues(pc, depth : Integer);
begin
    top_of_stack := top_of_stack + 1;
    depth_stack[top_of_stack] := depth;
    pc_stack[top_of_stack] := pc;
end;

// Pop values off of the stacks.
procedure TSierpinskiForm.PopValues(var pc, depth : Integer);
begin
    depth := depth_stack[top_of_stack];
    pc := pc_stack[top_of_stack];
    top_of_stack := top_of_stack - 1;
end;

end.
