TestSuite/CompilationSamples/Turtle.pas - master - n-dimens/pascalabcnet

TestSuite/CompilationSamples/Turtle.pas
381 строка10 KB
Mikhalkovich Stanislav
interface у Turtle.pas
04 авг 2025, 12:51
04 авг 2025, 12:51bf3ba7d
/// Исполнитель Черепаха
unit Turtle;

interface

uses GraphWPFBase;
uses GraphWPF;

type 
  Colors = GraphWPF.Colors;

// Переменные для Черепашки
var 
  tp: Point;   // текущая точка Черепахи (экранная, но сделаем её логической)
  angle: real; // Угол поворота Черепахи
  dr := False; // Опущен хвост Черепахи или нет
  
function Window: WindowTypeWPF;
  
/// Продвигает Черепаху вперед на расстояние r
procedure Forw(r: real);

/// Продвигает Черепаху назад на расстояние r
procedure Back(r: real);

/// Поворачивает Черепаху на угол da по часовой стрелке
procedure Turn(da: real);

/// Поворачивает Черепаху на угол da по часовой стрелке
procedure TurnRight(da: real);

/// Поворачивает Черепаху на угол da против часовой стрелки
procedure TurnLeft(da: real);

/// Опускает хвост Черепахи
procedure Down;

/// Поднимает хвост Черепахи
procedure Up;

/// Перемещает Черепаху в точку (x,y)
procedure ToPoint(x,y: real);

/// Рисует окружность указанного радиуса
procedure Circle(r: real);
  
/// Рисует окружность указанного радиуса и цвета 
procedure Circle(r: real; color: GColor);

/// Рисует точку заданным цветом заданного размера
procedure DrawPoint(x,y: real; color: GColor := Colors.Black; PointRadius: real := 2);

/// Рисует точки заданным цветом заданного размера
procedure DrawPoints(points: array of Point; color: GColor; PointRadius: real := -1);

/// Рисует точки следующим цветом в палитре цветов
procedure DrawPoints(points: array of Point; PointRadius: real := -1);

/// Рисует точки заданным цветом
procedure DrawPoints(xx,yy: array of real; color: GColor; PointRadius: real := -1);

/// Рисует точки следующим цветом в палитре цветов
procedure DrawPoints(xx,yy: array of real; PointRadius: real := -1);

/// Устанавливает ширину линии Черепахи
procedure SetWidth(w: real);

/// Устанавливает цвет линии Черепахи
procedure SetColor(c: GColor);

/// Устанавливает положение начала координат 
procedure SetOrigin(x,y: real);

{$endregion}


implementation

uses System.Threading.Tasks;
uses Coords;

procedure MoveToReal(x,y: real);
begin
  MoveTo(fso.RealToScreenX(x),fso.RealToScreenY(y));
end;

  
{$region Команды Черепахи при "проигрывании"}

// Сделаем свои команды ForwPlay, TurnPlay, CirclePlay и т.д.

/// Продвигает Черепаху вперёд на расстояние r
procedure ForwPlay(dc: DrawingContext; r: real);
begin
  tp += r * Vect(Cos(DegToRad(angle)),Sin(DegToRad(angle)));
  if dr then 
    dc.DrawLine(CurrentPen,Pnt(Pen.X,Pen.Y),fso.RealToScreen(tp));
  MoveToReal(tp.X,tp.Y)
end;

procedure TurnPlay(da: real);
begin
  angle -= da;
end;

procedure DownPlay;
begin
  dr := True;
end;  

procedure UpPlay;
begin
  dr := False;
end;  

procedure ToPointPlay(x,y: real);
begin
  tp := Pnt(x,y);
  MoveToReal(tp.X,tp.Y);
end;

procedure CirclePenPosPlay(dc: DrawingContext; r: real; color: GColor);
begin
  dc.DrawEllipse(ColorBrush(color),ColorPen(Pen.Color,1),fso.RealToScreen(tp),r * Scale,r * Scale);
end;  

procedure SetWidthPlay(r: real);
begin
  CurrentPen := ColorPen(CurrentPenColor,r);
end;  

procedure SetColorPlay(c: GColor);
begin
  CurrentPen := ColorPen(c,CurrentPen.Thickness);
end;  

{$endregion}
  
type
  ForwC = auto class(Command)
    r: real;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      ForwPlay(dc,r);
    end;
  end;
  TurnC = auto class(Command)
    da: real;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      TurnPlay(da)
    end;
  end;
  UpC = auto class(Command)
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      UpPlay
    end;
  end;
  DownC = auto class(Command)
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      DownPlay
    end;
  end;
  ToPointC = auto class(Command)
    x,y: real;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      ToPointPlay(x,y);
    end;
  end;
  CircleC = auto class(Command)
    r: real;
    c: Color;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      CirclePenPosPlay(dc,r,c);
    end;
  end;
  SetWidthC = auto class(Command)
    w: real;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      SetWidthPlay(w);
    end;
  end;
  SetColorC = auto class(Command)
    c: Color;
  public  
    procedure Play(dc: DrawingContext); override;
    begin
      SetColorPlay(c);
    end;
  end;
  

{$endregion}

function Window := GraphWPF.Window;

// fso - глобальная и всегда инициализированная!!!
// tp - в логических (это точка Черепахи)

// Вспомогательные для Circle
procedure CirclePenPosReal(r: real); 
begin
  var w := Pen.Width;
  Pen.Width := 1;
  GraphWPF.Circle(Pen.X,Pen.Y,fso.Scale * r);
  Pen.Width := w;
end;

procedure CirclePenPosReal(r: real; c: Color);
begin
  var w := Pen.Width;
  Pen.Width := 1;
  GraphWPF.Circle(Pen.X,Pen.Y,fso.Scale * r,c);
  Pen.Width := w;
end;


{$region Команды Черепахи}

/// Продвигает Черепаху вперёд на расстояние r
procedure Forw(r: real);
begin
  AddCommand(new ForwC(r));
  tp += r * Vect(Cos(DegToRad(angle)),Sin(DegToRad(angle)));
  var p1 := Pnt(Pen.X,Pen.Y);
  var p2 := fso.RealToScreen(tp);
  //var p1r := fso.ScreenToReal(p1);
  //var b1 := fso.PointInside(p1r);
  //var b2 := fso.PointInside(tp);
  if dr {and (b1 or b2)} then 
  begin
    FastDraw(dc -> begin
      dc.DrawLine(CurrentPen,p1,p2);
    end  
    );
  end; 
  MoveToReal(tp.X,tp.Y)
end;

/// Продвигает Черепаху назад на расстояние r
procedure Back(r: real) := Forw(-r);

/// Поворачивает Черепаху на угол da по часовой стрелке
procedure Turn(da: real);
begin
  angle -= da;
  AddCommand(new TurnC(da));
end;

/// Поворачивает Черепаху на угол da по часовой стрелке
procedure TurnRight(da: real) := Turn(da);

/// Поворачивает Черепаху на угол da против часовой стрелки
procedure TurnLeft(da: real) := Turn(-da);

/// Опускает хвост Черепахи
procedure Down;
begin
  AddCommand(new DownC);
  dr := True;
end;  

/// Поднимает хвост Черепахи
procedure Up;
begin
  AddCommand(new UpC);
  dr := False;
end;  

/// Перемещает Черепаху в точку (x,y)
procedure ToPoint(x,y: real);
begin
  AddCommand(new ToPointC(x,y));
  tp := Pnt(x,y);
  MoveToReal(tp.X,tp.Y);
end;

// Это в Turtle добавление
/// Рисует окружность указанного радиуса
procedure Circle(r: real);
begin
  CirclePenPosReal(r);
  AddCommand(new CircleC(r,Colors.White));
end;
  
/// Рисует окружность указанного радиуса и цвета 
procedure Circle(r: real; color: GColor);
begin
  CirclePenPosReal(r,color);
  AddCommand(new CircleC(r,color));
end;  

/// Рисует точку заданным цветом
procedure DrawPoint(x,y: real; color: GColor; PointRadius: real) := Coords.DrawPoint(x,y,color,PointRadius);

/// Рисует точки заданным цветом
procedure DrawPoints(points: array of Point; color: GColor; PointRadius: real) := Coords.DrawPoints(points,color,PointRadius);

/// Рисует точки следующим цветом в палитре цветов
procedure DrawPoints(points: array of Point; PointRadius: real) := Coords.DrawPoints(points,PointRadius);

/// Рисует точки заданным цветом
procedure DrawPoints(xx,yy: array of real; color: GColor; PointRadius: real) := Coords.DrawPoints(xx,yy,color,PointRadius);

/// Рисует точки следующим цветом в палитре цветов
procedure DrawPoints(xx,yy: array of real; PointRadius: real) := Coords.DrawPoints(xx,yy,PointRadius);

/// Устанавливает ширину линии Черепахи
procedure SetWidth(w: real);
begin
  AddCommand(new SetWidthC(w));
  CurrentPen := ColorPen(Pen.Color,w);
  Pen.Width := w;
end;  

/// Устанавливает цвет линии Черепахи
procedure SetColor(c: GColor);
begin
  AddCommand(new SetColorC(c));
  CurrentPen := ColorPen(c,Pen.Width);
  Pen.Color := c;
end;  

{$endregion}

/// Установка положения начала координат 
procedure SetOrigin(x,y: real);
begin
  Coords.SetOrigin(x,y);
  Up;
  ToPoint(x,y);
end;

procedure InitTurtle;
begin
  tp := (0,0);
  angle := 90;
  MoveToReal(tp.X,tp.Y);
  CurrentPen := ColorPen(Colors.Black,InitialPenWidth);
  dr := False;
end;

procedure InitOnce; // Это тоже относится к Черепахе
begin
  Window.Title := 'Исполнитель Черепаха';
  Font.Size := 14;
  Pen.RoundCap := True;
end;

procedure KeyDown(k: Key);
begin
  case k of
    key.Space: 
    begin
      DrawCoords += 1;
      if DrawCoords > 2 then
        DrawCoords := 0;
      Redraw;
    end;  
  end;
end;

initialization
  InitProc := InitTurtle;
  InitTurtle;
  InitOnce;
finalization  
  OnKeyDown := KeyDown;
end.