unit Sierp1F;
//*******************************************************
// Example program demonstrating 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;

type
  TSierp1Form = 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 SierpA(depth, dist : Integer);
    procedure SierpB(depth, dist : Integer);
    procedure SierpC(depth, dist : Integer);
    procedure SierpD(depth, dist : Integer);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Sierp1Form: TSierp1Form;

implementation

var
    loops : Longint;

{$R *.DFM}

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

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

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

// Draw the curve.
procedure TSierp1Form.DrawCurve;
var
    depth, gaps, dist, margin : Integer;
    rect                      : TRect;
begin
    LoopsLabel.Caption := '';

    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);

    LoopsLabel.Caption := IntToStr(loops);
    Screen.Cursor := crDefault;
end;

// Draw and connect type B, C, D, and A subcurves to
// make the complete Sierpinski curve.
procedure TSierp1Form.DrawSierp(depth, dist : Integer);
begin
    loops := 1; // This the first call, sort of.

    with DrawArea.Canvas do
    begin
        SierpB(depth, dist);
        LineTo(PenPos.X + dist, PenPos.Y + dist);
        SierpC(depth, dist);
        LineTo(PenPos.X + dist, PenPos.Y - dist);
        SierpD(depth, dist);
        LineTo(PenPos.X - dist, PenPos.Y - dist);
        SierpA(depth, dist);
        LineTo(PenPos.X - dist, PenPos.Y + dist);
    end;
end;

// Below are the Sierpinski subcurve drawing routines.
// 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

// Draw a type A curve across the top.
procedure TSierp1Form.SierpA(depth, dist : Integer);
begin
    loops := loops + 1;

    with DrawArea.Canvas do
    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);
        end else begin
            SierpA(depth - 1, dist);
            LineTo(PenPos.X - dist, PenPos.Y + dist);
            SierpB(depth - 1, dist);
            LineTo(PenPos.X - dist, PenPos.Y + 0   );
            SierpD(depth - 1, dist);
            LineTo(PenPos.X - dist, PenPos.Y - dist);
            SierpA(depth - 1, dist);
        end;
    end;
end;

// Draw a type B curve down the left side.
procedure TSierp1Form.SierpB(depth, dist : Integer);
begin
    loops := loops + 1;

    with DrawArea.Canvas do
    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);
        end else begin
            SierpB(depth - 1, dist);
            LineTo(PenPos.X + dist, PenPos.Y + dist);
            SierpC(depth - 1, dist);
            LineTo(PenPos.X + 0   , PenPos.Y + dist);
            SierpA(depth - 1, dist);
            LineTo(PenPos.X - dist, PenPos.Y + dist);
            SierpB(depth - 1, dist);
        end;
    end;
end;

// Draw a type C curve across the bottom.
procedure TSierp1Form.SierpC(depth, dist : Integer);
begin
    loops := loops + 1;

    with DrawArea.Canvas do
    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);
        end else begin
            SierpC(depth - 1, dist);
            LineTo(PenPos.X + dist, PenPos.Y - dist);
            SierpD(depth - 1, dist);
            LineTo(PenPos.X + dist, PenPos.Y + 0   );
            SierpB(depth - 1, dist);
            LineTo(PenPos.X + dist, PenPos.Y + dist);
            SierpC(depth - 1, dist);
        end;
    end;
end;

// Draw a type D curve up the right side.
procedure TSierp1Form.SierpD(depth, dist : Integer);
begin
    loops := loops + 1;

    with DrawArea.Canvas do
    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);
        end else begin
            SierpD(depth - 1, dist);
            LineTo(PenPos.X - dist, PenPos.Y - dist);
            SierpA(depth - 1, dist);
            LineTo(PenPos.X + 0   , PenPos.Y - dist);
            SierpC(depth - 1, dist);
            LineTo(PenPos.X + dist, PenPos.Y - dist);
            SierpD(depth - 1, dist);
        end;
    end;
end;

end.
