簡単なタートルグラフィックス

簡単なタートルグラフィックスを描くミニ言語を作成してみましょう。ここでは、次のコマンドを使用できるようにします。

このコマンドを以下のように使用します。

east 100  // ペンを東へ 100 移動
south 100 // ペンを南へ 100 移動
down      // ペンを下ろす
pen 2     // ペンの色を選択
east 60   // ペンを東へ 60 移動（ペンを下ろしたので、キャンバスに線が描かれる)
south 30  // ペンを南へ 30 移動
west 30   // ペンを西へ 30 移動
north 60  // ペンを北へ 60 移動
west 30   // ペンを西へ 30 移動
south 30  // ペンを南へ 30 移動 

上記のコマンドを実行すると、キャンバスに次のような図形が描かれます。

サンプルプログラムは、次のようになります。

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    Image1: TImage;
    Memo1: TMemo;
    Button1: TButton;
    Bevel1: TBevel;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
  private
    { Private 宣言 }
    procedure CanvasInit;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

procedure SelectPen(C: string; b: Integer);
procedure PenUp(C: string; b: Integer);
procedure PenDown(C: string; b: Integer);
procedure PenDir(C: string; b: Integer);

implementation

{$R *.dfm}

type
  TDrawProc = procedure(C: string; B: Integer);

  TCommand = record
    Cmd: string;         // コマンド文字
    HasArg: Boolean;     // 引数があるかどうか
    DrawProc: TDrawProc; // 呼び出しルーチン
  end;

const
  ARG    = true;
  NO_ARG = false;

  Cmds: array[0..6] of TCommand = (
    (Cmd: 'pen';   HasArg: ARG;    DrawProc: SelectPen),
    (Cmd: 'up';    HasArg: NO_ARG; DrawProc: PenUp),
    (Cmd: 'down';  HasArg: NO_ARG; DrawProc: PenDown),
    (Cmd: 'north'; HasArg: ARG;    DrawProc: PenDir),
    (Cmd: 'east';  HasArg: ARG;    DrawProc: PenDir),
    (Cmd: 'south'; HasArg: ARG;    DrawProc: PenDir),
    (Cmd: 'west';  HasArg: ARG;    DrawProc: PenDir)
  );

var
  PenPos: TPoint;
  Drawing: Boolean;
  
procedure SelectPen(C: string; B: Integer);
begin
  case B of
    1: Form1.Image1.Canvas.Pen.Color := clBlack;
    2: Form1.Image1.Canvas.Pen.Color := clRed;
    3: Form1.Image1.Canvas.Pen.Color := clBlue;
    4: Form1.Image1.Canvas.Pen.Color := clTeal;
    else
      Form1.Image1.Canvas.Pen.Color := clYellow;
  end;
end;

procedure PenUp(C: string; b : Integer);
begin
  Drawing := false;
end;

procedure PenDown(C: string; b: Integer);
begin
  Drawing := true;
end;

procedure PenDir(C: string; B: Integer);
var
  Diff: TPoint;
begin
  if C = 'north' then begin
    Diff.X := 0;
    Diff.Y := -B;
  end
  else if C = 'east' then begin
    Diff.X := B;
    Diff.Y := 0;
  end
  else if C = 'south' then begin
    Diff.X := 0;
    Diff.Y := B;
  end
  else if C = 'west' then begin
    Diff.X := -B;
    Diff.Y := 0;
  end
  else Assert(false);

  PenPos.X := PenPos.X+Diff.X;
  PenPos.Y := PenPos.Y+Diff.Y;

  if Drawing then
    Form1.Image1.Canvas.LineTo(PenPos.X, PenPos.Y)
  else
    Form1.Image1.Canvas.MoveTo(PenPos.X, PenPos.Y);
end;

function FindCommand(C: string): TCommand;
var
  i: Integer;
begin
  for i := 0 to High(Cmds) do begin
    if Cmds[i].Cmd = C then begin
      Result := Cmds[i];
      exit;
    end;
  end;
  raise Exception.Create(Format('無効コマンド %s', [C]));
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  arg: Integer;
  Cmd: TCommand;
  i: Integer;
  sl: TStringList;
begin
  CanvasInit;
  PenPos.X := 0; PenPos.Y := 0;
  Drawing := false;

  sl := TStringList.Create;
  try
    for i := 0 to Memo1.Lines.Count-1 do begin
      if Memo1.Lines[i] = '' then continue;
      sl.CommaText := Memo1.Lines[i];
      Cmd := FindCommand(sl[0]);
      if Cmd.HasArg then begin
        if (sl.Count < 2) or not TryStrToInt(sl[1], arg) then
          raise Exception.Create(Format('%s には引数が必要です', [sl[0]]));
      end;
      Cmd.DrawProc(sl[0], arg);
    end;
  finally
    sl.Free;
  end;
end;

procedure TForm1.CanvasInit;
begin
  Image1.Canvas.FillRect(Image1.ClientRect);
  Image1.Canvas.Pen.Color := clBlack;
end;

end.

up next
Last update: 2003/10/25