Перейти к содержанию

Книга программиста/Задачи на графику в PascalABC.Net

Добавить ссылки
Материал из Викиучебника — открытых книг для открытого мира

К оглавлению | Назад | Вперёд

Все программы, код которых выложен здесь, являются работоспособными. На момент написания программ использовалась среда PascalABC.Net 3.0.

Построение графиков

[править]

График погоды

[править]

Пример входного файла: 

9,3
8,5
8,8
8,0
9,9
11,3
12,2
11,4

uses GraphABC;
const
  Path = 'C:\Ilya\AlgoРитмы\Sankt-Peterburg.txt';
  DisplacementX = 10;
  DisplacementY = -10;

begin
  SetWindowIsFixedSize(true);
  
  var H := Window.Height;
  
  var A := ReadAllText(Path).Replace(',', '.').ToReals();
  var StepX := Window.Width / (A.Count - 1);
  var Min := Abs(A.Min);
  var Max := A.Max() + Min;
  var B := A.Select((x, i) -> (x, Round(StepX * i), Round(H - (A[i] + Min) / Max * H))).ToList();
  
  for var i := 0 to B.Count - 2 do
  begin
    var c := Round(255 - (B[i].Item3 + B[i].Item3) * 0.5 / H * 255);
    SetPenColor(RGB(0, c, c));
    SetBrushColor(RGB(0, c, c));
    Polygon(Arr(new Point(B[i].Item2, H), new Point(B[i].Item2, B[i].Item3),
                new Point(B[i + 1].Item2, B[i + 1].Item3), new Point(B[i + 1].Item2, H)));
  end;
  SetFontColor(clBlack);
  SetBrushColor(ARGB(200, 255, 255, 255));
  for var i := 0 to B.Count - 1 do
    TextOut(B[i].Item2 + DisplacementX, B[i].Item3 + DisplacementY, FloatToStr(B[i].Item1));
end.

Круговая диаграмма

[править]
uses GraphABC;
const
  N = 5;
  R = 150;
  K = 0.7;

var
  A: array of integer;
  Angle: real;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(500, 500);
  var W := Window.Width div 2;
  var H := Window.Height div 2;
  
  SetLength(A, N);
  for var i := 0 to N - 1 do
    Readln(A[i]);
  
  var Sum := A.Sum();
  
  SetPenWidth(2);
  var R2 := R * K;
  for var i := 0 to N - 1 do
  begin
    var ang := Round(A[i] / Sum * 360);
    SetBrushColor(clRandom());
    Pie(W, H, R, Round(Angle), Round(Angle - ang));
    var ang2 := DegToRad(360 - Angle + ang / 2);
    SetBrushColor(clWhite);
    TextOut(Round(W + R2 * Cos(ang2)), Round(H + R2 * Sin(ang2)), Format('{0} [~{1}%]', A[i], Round(A[i] / Sum * 100)));
    Angle -= ang;
  end;
end.

Простая графика

[править]

Перемещение игрока в консоли

[править]
uses Crt;
const
  W = 40;
  H = 20;
  MapChar = '-';

var
  PlayerX, PlayerY: byte;

procedure RedrawMap();
begin
  TextColor(White);
  GotoXY(PlayerX, PlayerY);
  Write(MapChar);
end;

procedure RedrawPlayer();
begin
  TextColor(LightGreen);
  GotoXY(PlayerX, PlayerY);
  Write('X');
end;

begin
  HideCursor();
  TextColor(White);
  for var i := 0 to H - 1 do
  begin
    for var j := 0 to W - 1 do
      Write(MapChar);
    Writeln();
  end;
  
  PlayerX := W div 2;
  PlayerY := H div 2;
  RedrawPlayer();
  
  while true do
  begin
    var key := readkey;
    var codekey := Ord(key);
    case codekey of
      38: begin RedrawMap();if PlayerY > 1 then PlayerY := PlayerY - 1 else PlayerY := H;RedrawPlayer(); end; 
      40: begin RedrawMap();if PlayerY < H then PlayerY := PlayerY + 1 else PlayerY := 1;RedrawPlayer(); end; 
      37: begin RedrawMap();if PlayerX > 1 then PlayerX := PlayerX - 1 else PlayerX := W;RedrawPlayer(); end;
      39: begin RedrawMap();if PlayerX < W then PlayerX := PlayerX + 1 else PlayerX := 1;RedrawPlayer(); end;
    end;
  end;
end.

Квадраты

[править]
uses GraphABC;
const
  DisplacementX = 10;
  DisplacementY = 10;
  Size = 100;
  DistX = 10;
  DistY = 10;
  Rows = 2;
  Cols = 5;

begin
  for var i := 0 to Rows - 1 do
    for var j := 0 to Cols - 1 do
    begin
      var cx := Size + DistX;
      var cy := Size + DistY;
      DrawRectangle(DisplacementX + j * cx, DisplacementY + i * cy, DisplacementX + (j + 1) * cx - DistX, DisplacementY + (i + 1) * cy - DistY);
    end;
end.

Анимация

[править]

Управление движением шарика

[править]
uses GraphABC;
const
  Speed = 0.1;

var
  Moving: boolean;

procedure KeyDown(key: integer);
begin
  case key of
    VK_Space: Moving := not Moving;
  end;
end;

begin
  var X := 0.0;
  SetBrushColor(clRed);
  
  OnKeyDown := KeyDown;
  
  Moving := true;
  LockDrawing();
  while true do
  begin
    while Moving do
    begin
      ClearWindow();
      Circle(Round(X), 100, 10);
      X += MillisecondsDelta() / 1.0 * Speed;
      Redraw();
    end;
    MillisecondsDelta();
  end;
end.

Планеты

[править]
uses GraphABC; 
const
  R1 = 120; 
  R2 = 50;

var
  Rotation: real;

begin
  SetWindowIsFixedSize(true); 
  SetWindowSize(400, 400);
  LockDrawing();
  
  var CX := Window.Width div 2; 
  var CY := Window.Height div 2; 
  
  while true do 
  begin
    for var angle := 0 to 359 do 
    begin
      ClearWindow(clBlack); 
      SetPenColor(clGray); 
      SetPenWidth(3); 
      SetPenStyle(GraphABC.DashStyle.DashDot); 
      DrawCircle(CX, CY, R1); 
      
      var angle2 := DegToRad(angle);
      var x := Trunc(CX + R1 * Cos(angle2)); 
      var y := Trunc(CY + R1 * Sin(angle2)); 
      
      SetPenColor(clRed); 
      SetPenWidth(2); 
      SetPenStyle(GraphABC.DashStyle.Solid); 
      SetBrushColor(clYellow); 
      FillCircle(x, y, 10); 
      DrawCircle(x, y, 10); 
      
      SetPenColor(clGray); 
      SetPenWidth(3); 
      SetPenStyle(GraphABC.DashStyle.DashDot); 
      DrawCircle(x, y, R2); 
      
      angle2 := DegToRad(Rotation);
      x := Trunc(x + R2 * Cos(angle2)); 
      y := Trunc(y + R2 * Sin(angle2)); 
      
      SetPenColor(clLightCyan); 
      SetPenWidth(2); 
      SetPenStyle(GraphABC.DashStyle.Solid); 
      SetBrushColor(clCyan); 
      FillCircle(x, y, 6); 
      DrawCircle(x, y, 6); 
      
      if Rotation + 5 < 360 then Rotation := Rotation + 5 else Rotation := 0; 
      
      Redraw(); 
      Sleep(1); 
    end; 
  end; 
end.

Перемещение строк матрицы

[править]
uses GraphABC, ABCObjects;
const
  N = 5;
  M = 10;
  MoveI = 0;
  MoveI2 = 3;
  DisplacementX = 10;
  DisplacementY = 10;
  Size = 50;
  DistanceX = 10;
  DistanceY = 10;
  ShiftX = 10;
  ShiftY = 10;

var
  A: array [0..N - 1, 0..M - 1] of SquareABC;

procedure SwapPair(j: integer);
begin
  var targetY := A[MoveI2, j].Position.Y;
  while A[MoveI, j].Position.Y <> targetY do
  begin
    A[MoveI, j].Position := new Point(A[MoveI, j].Position.X, A[MoveI, j].Position.Y + 1);
    A[MoveI2, j].Position := new Point(A[MoveI2, j].Position.X, A[MoveI2, j].Position.Y - 1);
  end;
end;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(DisplacementY + (Size + DistanceY) * M + ShiftY - DistanceY,
                DisplacementX + (Size + DistanceX) * N + ShiftX - DistanceX);
  
  for var i := 0 to N - 1 do
    for var j := 0 to M - 1 do
    begin
      A[i, j] := new SquareABC(DisplacementY + (Size + DistanceY) * j,
                               DisplacementX + (Size + DistanceX) * i,
                               Size, (i = MoveI) or (i = MoveI2) ? clGreenYellow : clYellow);
      A[i, j].Text := Format('{0} {1}', i, j);
    end;
  
  for var j := 0 to M - 1 do
    SwapPair(j);
end.

Визуализация сортировок

[править]

Анимация сортировки пузырьком

[править]
uses GraphABC, ABCObjects;
const
  N = 10;
  DisplacementX = 10;
  DisplacementY = 10;
  Size = 30;
  DistanceX = 10;
  ShiftX = 10;
  ShiftY = 10;
  NormalColor = clYellow;
  SelectedColor = ARGB(100, clOrange.R, clOrange.G, clOrange.B);

var
  A: array [0..N - 1] of SquareABC;

procedure SwapPair(i, j: integer);
begin
  A[i].Color := SelectedColor;
  A[j].Color := SelectedColor;
  var targetX := A[j].Position.X;
  while A[i].Position.X <> targetX do
  begin
    A[i].Position := new Point(A[i].Position.X + 1, DisplacementY);
    A[j].Position := new Point(A[j].Position.X - 1, DisplacementY);
    Sleep(15);
  end;
  A[i].Color := NormalColor;
  A[j].Color := NormalColor;
  Swap(A[i], A[j]);
end;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(DisplacementX + (Size + DistanceX) * N + ShiftX - DistanceX, DisplacementY + Size + ShiftY);
  CenterWindow();
  for var i := 0 to N - 1 do
  begin
    A[i] := new SquareABC(DisplacementX + (Size + DistanceX) * i, DisplacementY, Size, NormalColor);
    A[i].Number := Random(30);
  end;
  
  for var i := N - 1 downto 0 do
    for var j := 0 to i - 1 do
      if A[j].Number > A[j + 1].Number then
        SwapPair(j, j + 1);
end.

Анимация сортировки выбором

[править]
uses GraphABC, ABCObjects;
const
  N = 8;
  DisplacementX = 10;
  DisplacementY = 10;
  Size = 50;
  DistanceX = 10;
  ShiftX = 10;
  ShiftY = 10;
  NormalColor = clYellow;
  SelectedColor = ARGB(100, clOrange.R, clOrange.G, clOrange.B);

var
  A: array [0..N - 1] of SquareABC;

procedure SwapPair(i, j: integer);
begin
  A[i].Color := SelectedColor;
  A[j].Color := SelectedColor;
  var targetX := A[j].Position.X;
  while A[i].Position.X <> targetX do
  begin
    A[i].Position := new Point(A[i].Position.X + 1, DisplacementY);
    A[j].Position := new Point(A[j].Position.X - 1, DisplacementY);
    Sleep(15);
  end;
  A[i].Color := NormalColor;
  A[j].Color := NormalColor;
  Swap(A[i], A[j]);
end;

begin
  SetWindowIsFixedSize(true);
  SetWindowSize(DisplacementX + (Size + DistanceX) * N + ShiftX - DistanceX, DisplacementY + Size + ShiftY);
  for var i := 0 to N - 1 do
  begin
    A[i] := new SquareABC(DisplacementX + (Size + DistanceX) * i, DisplacementY, Size, NormalColor);
    A[i].Number := Random(30);
  end;
  
  for var i := 0 to N - 1 do
    for var j := i + 1 to N - 1 do
      if A[i].Number > A[j].Number then
        SwapPair(i, j);
end.

Веселые точки

[править]
uses GraphABC;
const
  DisplacementX = 50;
  DisplacementY = 50;
  Distance = 60;
  CountX = 9;
  CountY = 7;
  MinR = 10;
  MaxR = 40;
  MaxW = 15;
  MinW = 1;
  C1 = clRed;
  C2 = clCyan;
  C3 = clOrange;

var
  D: integer := Distance div 2;
  Colors1: array [0..2] of Color := (C3, C1, C2);
  Colors2: array [0..2] of Color := (C2, C3, C1);
  Percent: real;
  R: integer;
  K: integer;
  MinR2:integer:=MinR - MaxW;

function Interpolation(a, b, p: real) := a + (b - a) * p;

procedure Draw();
var
  c: Color;
begin
  for var i := 0 to CountY - 1 do
    for var j := 0 to CountX - 1 do
    begin
      var x := DisplacementX + j * Distance;
      var y := DisplacementY + i * Distance;
      
      if i mod 2 = 0 then
        c := Colors1[j mod 3]
      else
      begin
        c := Colors2[j mod 3];
        Inc(x, D);
      end;
      
      SetBrushColor(c);
      SetPenColor(c);
      
      if c = Colors1[K mod 3] then
        DrawCircle(x, y, R);
      
      FillCircle(x, y, MinR);
    end;
end;

begin
  SetWindowIsFixedSize(true);
  
  LockDrawing();
  while true do
  begin
    SetPenWidth(Round(Interpolation(MaxW, MinW, Percent)));
    R := Round(Interpolation(MinR2, MaxR, Percent));
    
    ClearWindow(clBlack);
    Draw();
    Redraw();
    
    Percent += 0.03;
    if Percent > 1.0 then
    begin
      Percent := 0;
      Inc(K);
    end;
    Sleep(5);
  end;
end.

Действия с объектами

[править]

Перемещение объекта мышкой

[править]
uses ABCObjects, GraphABC;
const
  Size = 100;

var
  A: RoundSquareABC;
  Dx, Dy: integer;
  Move: boolean;

procedure MouseUp(x, y, mb: integer);
begin
  if mb = 1 then Move := false;
end;

procedure MouseMove(x, y, mb: integer);
begin
  if mb = 1 then
  begin
    if not Move then
    begin
      if A.PtInside(x, y) then Move := true;
      Dx := A.Position.X - x;
      Dy := A.Position.Y - y;
    end
    else
      A.Position := new Point(x + Dx, y + Dy);
  end;
end;

begin
  var Size2 := Size div 2;
  A := new RoundSquareABC(Window.Width div 2 - Size2, Window.Height div 2 - Size2, Size, 10, clYellow);
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end.

Изменение размера объекта

[править]
uses ABCObjects, GraphABC;
const
  Width = 200;
  Height = 100;

var
  A: RoundRectABC;
  Dx, Dy: integer;
  Move: boolean;
  Resize: boolean;

procedure MouseUp(x, y, mb: integer);
begin
  if mb = 1 then Move := false;
  if mb = 2 then Resize := false;
end;

procedure MouseMove(x, y, mb: integer);
begin
  if mb = 1 then
  begin
    if not Move then
    begin
      if A.PtInside(x, y) then Move := true;
      Dx := A.Position.X - x;
      Dy := A.Position.Y - y;
    end
    else
      A.Position := new Point(x + Dx, y + Dy);
  end
  else if mb = 2 then
  begin
    if not Resize then
    begin
      if A.PtInside(x, y) then Resize := true;
      Dx := A.Position.X + A.Width - x;
      Dy := A.Position.Y + A.Height - y;
    end
    else
    if (x > A.Position.X) and (y > A.Position.Y) then
    begin
      A.Width := x + Dx - A.Position.X;
      A.Height := y + Dy - A.Position.Y;
    end;
  end;
end;

begin
  A := new RoundRectABC(Window.Width div 2 - Width div 2, Window.Height div 2 - Height div 2, Width, Height, 10, clYellow);
  
  Move := false;
  OnMouseMove := MouseMove;
  OnMouseUp := MouseUp;
end.

Простой Paint

[править]
uses ABCObjects, GraphABC;

var
  DrawBorder: RectangleABC;
  DrawRectangles: boolean;
  Drawn: boolean;
  X1, Y1, X2, Y2: integer;
  
  Move: boolean;
  Obj: ObjectABC;
  Dx, Dy: integer;

procedure MouseUp(x, y, mb: integer);
begin
  if mb = 1 then
  begin
    if DrawRectangles then
      new RectangleABC(X1, Y1, Abs(X2 - X1), Abs(Y2 - Y1), clRandom())
    else
      new EllipseABC(X1, Y1, Abs(X2 - X1), Abs(Y2 - Y1), clRandom());
    Drawn := false;
  end;
  
  if mb = 2 then Move := false;
end;

procedure MouseMove(x, y, mb: integer);
begin
  if mb = 1 then
  begin
    DrawBorder.Visible := true;
    if not Drawn then
    begin
      X1 := x;
      Y1 := y;
      Drawn := true;
      DrawBorder.Position := new Point(X1, Y1);
      DrawBorder.ToFront();
      RedrawObjects();
    end
    else
    begin
      X2 := x;
      Y2 := y;
      DrawBorder.Width := Abs(X2 - X1);
      DrawBorder.Height := Abs(Y2 - Y1);
    end;
  end
  else if mb = 2 then
  begin
    DrawBorder.Visible := false;
    if not Move then
    begin
      for var i := 0 to Objects.Count - 1 do
        if (Objects[i] <> DrawBorder) and Objects[i].PtInside(x, y) then
        begin
          if Objects[i] is RectangleABC then
            Obj := Objects[i] as RectangleABC
          else
            Obj := Objects[i] as EllipseABC;
          
          Dx := Obj.Position.X - x;
          Dy := Obj.Position.Y - y;
          
          Move := true;
          break;
        end;
    end
    else
    begin
      Obj.Position := new Point(x + Dx, y + Dy);
      Obj.ToFront();
    end;
  end;
end;

procedure KeyDown(key: integer);
begin
  case key of
    VK_A: DrawRectangles := not DrawRectangles;
  end;
  if DrawRectangles then SetWindowCaption('Rectangles') else SetWindowCaption('Ellipses');
end;

begin
  DrawBorder := new RectangleABC(1, 1, 1, 1, ARGB(100, 0, 0, 0));
  Drawn := false;
  DrawRectangles := true;
  Move := false;
  
  KeyDown(0);
  
  OnMouseUp := MouseUp;
  OnMouseMove := MouseMove;
  OnKeyDown := KeyDown;
end.

Графики

[править]

Окружность

[править]
uses GraphABC;
const
  MaxV = 2 * Pi;
  K = 40;
  Speed = 0.01;

var
  A: real := Speed;

begin
  SetCoordinateOrigin(Window.Width div 2, Window.Height div 2);
  
  while A <= MaxV do
  begin
    var pA := A - Speed;
    Line(Round(Cos(pA) * K), Round(Sin(pA) * K),
         Round(Cos(A) * K), Round(Sin(A) * K));
    A += Speed;
  end;
end.

Спираль

[править]
uses GraphABC;
const
  MaxV = 5 * Pi;
  K = 10;
  Speed = 0.01;

var
  A: real := Speed;

begin
  SetCoordinateOrigin(Window.Width div 2, Window.Height div 2);
  
  while A <= MaxV do
  begin
    var pA := A - Speed;
    Line(Round(pA * Sin(pA) * K), Round(pA * Cos(pA) * K),
         Round(A * Sin(A) * K), Round(A * Cos(A) * K));
    A += Speed;
  end;
end.

Дельтоида

[править]
uses GraphABC;
const
  MaxV = 2 * Pi;
  K = 40;
  Speed = 0.01;

var
  A: real;

procedure Draw(angle: real);
begin
  A := Speed;
  
  while A <= MaxV do
  begin
    var pA := A - Speed - angle;
    var pA2 := (pA + angle) * 2 - angle;
    var A1 := A - angle;
    var A2 := A * 2 - angle;
    Line(Round((2 * Cos(pA) + Cos(pA2)) * K), Round((2 * Sin(pA) - Sin(pA2)) * K),
         Round((2 * Cos(A1) + Cos(A2)) * K), Round((2 * Sin(A1) - Sin(A2)) * K));
    A += Speed;
  end;
end;

begin
  SetCoordinateOrigin(Window.Width div 2, Window.Height div 2);
  
  LockDrawing();
  while true do
    for var i := 0 to 359 do
    begin
      ClearWindow();
      Draw(DegToRad(i));
      Redraw();
    end;
end.
Источник — https://ru.wikibooks.org/w/index.php?title=Книга_программиста/Задачи_на_графику_в_PascalABC.Net&oldid=163473