キルト

『プログラミング言語の概念と構造』の p 28 に Little Quilt というのが紹介されています。これは、キルトと呼ばれる単純な模様が描かれた小片を回転させたり、くっつけたりして、下図のような模様を作り出します。

次の 2 つの基本片があり、それらを a （弓形の模様）と b （帯状の模様）と呼ぶことにします：

a:

b:

基本操作

キルトに対する操作は、次の規則により指定される（p 28 より引用）：

• キルトは一つの基本片であるか、
• キルトを時計回りに 90 度回転させたものか、
• キルトの右側に同じ高さのキルトを縫いつけたものであり、
• それ以外はキルトではない。

基本操作として、

• turn
• sew

がある。turn はキルトを時計回りに 90 度回転させます。

上図の一番右端にある図形は、turn(turn(turn(b))) で作られます。

sew はキルト同士をくっつけます。

unturn と pile

turn, sew 関数から、反時計回りに 90 度回転させる関数 unturn と、キルトを縦にくっつける（sew は横にくっつける）pile 関数を作ります。それぞれ定義は以下のとおり：

unturn(x) = turn(turn(turn(x)))
pile(x, y) = unturn(sew(turn(y), turn(x)))

上図の左端に位置する 2 つのキルトをそれぞれ bb, bb2 と名前を付けたとすると、右端のキルトは

turn(pile(bb, bb2)) 

で得られることになる。(bb が上のキルトで、bb2 が下)

プログラムを作成します。基本片は、回転させたものを含め予め用意しておきます。それぞれの名前は以下のとおり：

l0.bmp	l1.bmp	l2.bmp	l3.bmp
c0.bmp	c1.bmp	c2.bmp	c3.bmp

unit Unit2;

interface

uses SysUtils;

const
  MAX_TABLE_SIZE = 8;

type
  TQuilt = record
    Direction: 0..3;
    Kind: 0..1;
  end;

  TQuiltTable = array[1..MAX_TABLE_SIZE, 1..MAX_TABLE_SIZE] of TQuilt;

  EInvalidSewOperation = class(Exception);
  EOutofBounds = class(Exception);

  TQuiltCanvas = class
  private
    FTable: TQuiltTable;
    FWidth: Integer;
    FHeight: Integer;
    function GetTbl(i, j: Integer): TQuilt;
  public
    constructor Create(Quilt: TQuilt); overload;
    constructor Create(Quilt1, Quilt2: TQuilt); overload;
    constructor Create(QuiltCanvas: TQuiltCanvas); overload;
    function Turn: TQuiltCanvas;
    function Sew(QuiltCanvas: TQuiltCanvas): TQuiltCanvas;
    function Clone: TQuiltCanvas;
    property Height: Integer read FHeight;
    property Width: Integer read FWidth;
    property Table: TQuiltTable read FTable;
    property Tbl[i, j: Integer]: TQuilt read GetTbl; default;
  end;

(*
  以下の関数は、引数に対して破壊的です。
  一度引数として渡したオブジェクトを再び参照してはいけません。

  引数として渡された TQuiltCanvas クラスのインスタンスの解放は、
  関数の中で行いますので、戻り値のオブジェクトに対してだけ Free メソッドを
  呼んで下さい。
*)
   
function Turn(QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
function Turn(Quilt: TQuilt): TQuilt; overload;
function Unturn(QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
function Unturn(Quilt: TQuilt): TQuilt; overload;
function Sew(QuiltCanvas1, QuiltCanvas2: TQuiltCanvas): TQuiltCanvas; overload;
function Sew(Quilt1, Quilt2: TQuilt): TQuiltCanvas; overload;
function Sew(Quilt: TQuilt; QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
function Sew(QuiltCanvas: TQuiltCanvas; Quilt: TQuilt): TQuiltCanvas; overload;
function Pile(QuiltCanvas1, QuiltCanvas2: TQuiltCanvas): TQuiltCanvas; overload;
function Pile(Quilt1, Quilt2: TQuilt): TQuiltCanvas; overload;

implementation

function Turn(QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
begin
  Result := QuiltCanvas.Turn;
end;

function Turn(Quilt: TQuilt): TQuilt; overload;
begin
  Quilt.Direction := (Quilt.Direction+1) mod 4;
  Result := Quilt;
end;

function Unturn(QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
begin
  Result := QuiltCanvas.Turn.Turn.Turn;
end;

function Unturn(Quilt: TQuilt): TQuilt; overload;
begin
  Result := Turn(Turn(Turn(Quilt)));
end;

function Sew(QuiltCanvas1, QuiltCanvas2: TQuiltCanvas): TQuiltCanvas; overload;
var
  Clone: TQuiltCanvas;
begin
  if QuiltCanvas1 = QuiltCanvas2 then begin
    Clone := QuiltCanvas2.Clone;
    Result := QuiltCanvas1.Sew(Clone);
    Clone.Free;
  end
  else begin
    Result := QuiltCanvas1.Sew(QuiltCanvas2);
    QuiltCanvas2.Free;
  end;
end;

function Sew(Quilt1, Quilt2: TQuilt): TQuiltCanvas; overload;
begin
  Result := TQuiltCanvas.Create(Quilt1, Quilt2);
end;

function Sew(Quilt: TQuilt; QuiltCanvas: TQuiltCanvas): TQuiltCanvas; overload;
begin
  Result := TQuiltCanvas.Create(Quilt).Sew(QuiltCanvas);
end;

function Sew(QuiltCanvas: TQuiltCanvas; Quilt: TQuilt): TQuiltCanvas; overload;
begin
  Result := QuiltCanvas.Sew(TQuiltCanvas.Create(Quilt));
end;

function Pile(QuiltCanvas1, QuiltCanvas2: TQuiltCanvas): TQuiltCanvas; overload;
var
  Clone: TQuiltCanvas;
begin
  if QuiltCanvas1 = QuiltCanvas2 then begin
    Clone := QuiltCanvas1.Clone;
    Result := Unturn(Sew(Turn(QuiltCanvas2), Turn(Clone)));
  end
  else
    Result := Unturn(Sew(Turn(QuiltCanvas2), Turn(QuiltCanvas1)));
end;

function Pile(Quilt1, Quilt2: TQuilt): TQuiltCanvas; overload;
begin
  Result := Unturn(Sew(Turn(Quilt2), Turn(Quilt1)));
end;

{ TQuiltCanvas }

constructor TQuiltCanvas.Create(Quilt: TQuilt);
begin
  FTable[1, 1] := Quilt;
  FWidth  := 1;
  FHeight := 1;
end;

constructor TQuiltCanvas.Create(Quilt1, Quilt2: TQuilt);
begin
  FTable[1, 1] := Quilt1;
  FTable[2, 1] := Quilt2;
  FWidth  := 2;
  FHeight := 1;
end;

constructor TQuiltCanvas.Create(QuiltCanvas: TQuiltCanvas);
begin
  FTable  := QuiltCanvas.Table;
  FWidth  := QuiltCanvas.Width;
  FHeight := QuiltCanvas.Height;
end;

function TQuiltCanvas.Clone: TQuiltCanvas;
begin
  Result := TQuiltCanvas.Create(Self);
end;

function TQuiltCanvas.GetTbl(i, j: Integer): TQuilt;
begin
  Result := FTable[i, j];
end;

function TQuiltCanvas.Sew(QuiltCanvas: TQuiltCanvas): TQuiltCanvas;
var
  i, j: Integer;
begin
  if FHeight <> QuiltCanvas.Height then
    raise EInvalidSewOperation.Create('連結画像同士の高さが異なります');
  if (FWidth + QuiltCanvas.Width) > MAX_TABLE_SIZE then
    raise EOutOfBounds.Create('サイズが大きすぎます');

  for i := 1 to QuiltCanvas.Width do
    for j := 1 to QuiltCanvas.Height do
      FTable[FWidth+i, j] := QuiltCanvas[i, j];

  Inc(FWidth, QuiltCanvas.Width);
  Result := Self;
end;

function TQuiltCanvas.Turn: TQuiltCanvas;

  procedure Swap(var x, y: Integer);
  var
    Tmp: Integer;
  begin
    Tmp := x;
    x := y;
    y := Tmp;
  end;

var
  i, j: Integer;
  TmpTable: TQuiltTable;
begin
  for i := 1 to FWidth do
    for j := 1 to FHeight do begin
      FTable[i, j].Direction := (FTable[i, j].Direction+1) mod 4; // 向きを変える
      TmpTable[-j+FHeight+1, i] := FTable[i, j];                  // 座標を移動させる
    end;

  Swap(FWidth, FHeight);
  FTable := TmpTable;
  Result := Self;
end;

end.

基本片であるキルトは、レコード型 TQuilt として定義します。その要素として、

• Direction
• Kind

の 2 つがありますが、Direction はキルトの向きを、Kind は 2 つの基本片のうち、どちらであるかの情報が格納されるようになっています。

画像は最終的に TPaintBox に描画します。その手法は,

• どの位置にどのビットマップを描画するか

ということで、知りたいのは、どのキルトがどの方向を向いていて、どの順序で並んでいるのかということなので、2 次元配列を用意し、その中にキルトの向きと種類の情報をもつ TQuilt 型の値を入れています。キルトの(描画)位置は、その 2 次元配列に格納されているインデックスに対応させます。これを擬似コードで表すと次のような感じになります：

for i := 1 to 横幅(横に並んでいる個数)
  for j := 1 to 縦幅
    キルト := キルトの情報が入っている配列[i, j]
    キルトを描画。その位置は、
      x が i * キルト（画像）の横幅
      y が j * キルト（画像）の縦幅

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Grids, ExtCtrls;

type
  TForm1 = class(TForm)
    PaintBox1: TPaintBox;
    PaintBox2: TPaintBox;
    Button1: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses Unit2;

const
  a: TQuilt = (Direction:0; Kind:0); // 弓形の模様
  b: TQuilt = (Direction:0; Kind:1); // 帯状の模様

var
  LineBmps, CurveBmps: array[0..3] of TBitmap;

function GetQuiltBmp(Direction, Kind: Integer): TBitmap;
begin
  if Kind = 0 then
    Result := CurveBmps[Direction]
  else
    Result := LineBmps[Direction];
end;

procedure DrawQuilt(QuiltCanvas: TQuiltCanvas; Box: TPaintBox);
var
  i, j: Integer;
  Bmp: TBitmap;
  Quilt: TQuilt;
begin
  for i := 1 to QuiltCanvas.Width do
    for j := 1 to QuiltCanvas.Height do begin
      Quilt := QuiltCanvas[i, j];
      Bmp := GetQuiltBmp(Quilt.Direction, Quilt.Kind);
      Box.Canvas.Draw((i-1)*Bmp.Width, (j-1)*Bmp.Height, Bmp);
    end;
end;
  
procedure TForm1.FormCreate(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 3 do begin
    LineBmps[i] := TBitmap.Create;
    LineBmps[i].LoadFromFile(Format('l%d.bmp', [i]));

    CurveBmps[i] := TBitmap.Create;
    CurveBmps[i].LoadFromFile(Format('c%d.bmp', [i]));
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var
  i: Integer;
begin
  for i := 0 to 3 do begin
    LineBmps[i].Free;
    CurveBmps[i].Free;
  end;
end;

end.

定数 a と b が冒頭で名前を付けた 2 つの基本片であるキルト a と b に対応します。

function QuiltEx1: TQuiltCanvas;

  function Parts1: TQuiltCanvas;
  var
    p, q: TQuiltCanvas;
  begin
    p := Sew(Pile(Turn(b), Unturn(b)),
             Pile(Unturn(b), Turn(a)));

    q := Sew(Pile(Turn(Turn(b)), b),
             Pile(a, Turn(Turn(b))));

    Result := Pile(p, q);
  end;

  function Parts2: TQuiltCanvas;
  begin
    Result := Sew(Pile(Turn(a), Unturn(a)),
                  Pile(Turn(Turn(a)), a));
  end;

var
  c: TQuiltCanvas;
begin
  c := Pile(Parts2, Turn(Turn(Parts2)));

  Result := Sew(Parts1,
                Sew(c, Turn(Turn(Parts1))));
end;

function QuiltEx2: TQuiltCanvas;

  function Parts1: TQuiltCanvas;
  begin
    Result := Sew(Pile(Unturn(b), Turn(b)),
                  Pile(a, Turn(Turn(a))));
  end;

  function Parts2: TQuiltCanvas;
  begin
    Result := Pile(Parts1, Turn(Turn(Parts1)));
  end;

begin
  Result := Sew(Parts2, Sew(Parts2, Parts2));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Quilt: TQuiltCanvas;
begin
  Quilt := QuiltEx1;
  DrawQuilt(Quilt, PaintBox1);
  Quilt.Free;

  Quilt := QuiltEx2;
  DrawQuilt(Quilt, PaintBox2);
  Quilt.Free;
end;

これを実行すると、下のような模様が出来上がります。

以下は、『プログラミング言語の概念と構造』p 64 の演習問題 2.1 で紹介されているキルトです。

function Exa: TQuiltCanvas;
var
  p: TQuiltCanvas;
begin
  p := Pile(Sew(Unturn(a), Unturn(a)),
            Sew(Unturn(a), Unturn(a)));
  Result := Pile(p, p);
end;

function Exb: TQuiltCanvas;
var
  p: TQuiltCanvas;
begin
  p := Pile(Sew(Turn(b), Unturn(b)),
            Sew(Turn(b), Unturn(b)));
  Result := Pile(p, p);
end;

function Exc: TQuiltCanvas;
var
  p: TQuiltCanvas;
begin
  p := Pile(Sew(a, Unturn(a)),
            Sew(Turn(a), Turn(Turn(a))));
  Result := Pile(p, p);
end;

function Exd: TQuiltCanvas;
var
  p: TQuiltCanvas;
begin
  p := Pile(Sew(Unturn(b), Turn(b)),
            Sew(Turn(b), Unturn(b)));
  Result := Pile(p, p);
end;

function Exe: TQuiltCanvas;

  function Parts: TQuiltCanvas;
  begin
    Result := Pile(Sew(Turn(a), Turn(Turn(a))),
                   Sew(b, Unturn(b)));
  end;

begin
  Result := Pile(Parts, Turn(Turn(Parts)));
end;

up
Last update: 2004/9/14