Объектно-ориентированное программирование

Как написать объектно-ориентированную программу в среде FreePascal

Более правильный вариант. Во FreePascal следует включить режим компиляции objfpc и подключить модуль Classes.

//{$ifdef fpc}
{$mode objfpc}
//{$endif}
//{$ifdef MSWINDOWS}{$apptype console}{$endif}
uses Classes;
type myclass = class(TObject)
private
    a,b: byte;
public
    procedure print;
    constructor create(c,d:byte);
end;
 
constructor myclass.create(c,d:byte);
begin
   //inherited Create;
   a:=c; b:=d
end;
 
procedure myclass.print;
begin  writeln(a); writeln(b) end;
 
var obj: myclass;
 
begin
     obj:=MyClass.Create(8,29);
     obj.b := 200;
     obj.print;
     obj.a := 100;
     writeln(obj.a);
     obj.free;
 
readln;
end.

Другой вариант - через указатель. Менее предпочтительный но описывается в большинстве учебников.

type
    pmyclass = ^myclass;
    myclass = object
        a,b: byte;
        procedure print;
        constructor Init(c,d:byte);
    end;
 
constructor myclass.Init(c,d:byte);
begin a:=c; b:=d end;
 
procedure myclass.print;
begin writeln(a); writeln(b) end;
 
var obj: pmyclass;
 
begin
    obj := new(pmyclass,Init(10,30));
    obj^.print;
    dispose(obj);
 
readln;
end.

Пример класса "Комплексные числа"

Пример был взят из учебника Free Pascal и Lazarus (Е.Р. Алексеев, О.В. Чеснокова, Т.В. Кучер), где он описан для среды Lazarus и с графическим интерфейсом.

Здесь приводится для IDE Free Pascal.

Вариант без параметров:

{$mode objfpc}
 
uses Classes;
 
type TComplex = class(TObject)
    private
        x,y: real;
    public
        constructor Create;
        function Modul(): real;
        function Argument(): real;
        //function ComplexToStr(): string;
end;
 
constructor TComplex.Create;
    begin
        x := 0; y := 0;
        inherited Create;
    end;
function TComplex.Modul(): real;
    begin
        Modul := sqrt(x*x + y*y);
    end;
function TComplex.Argument(): real;
    begin
        Argument := arctan(y/x)*180/PI;
    end;
 
var num: TComplex;
 
begin
    num := TComplex.Create;
    write('num.x := '); readln(num.x);
    write('num.y := '); readln(num.y);
    writeln('Modulus of the num: ', num.Modul():10:3);
    writeln('Argument of the num: ', num.Argument():9:3);
 
readln;
end.

С параметрами:

...
 
type TComplex = class(TObject)
    private
        x,y: real;
    public
        constructor Create(a,b: real);
        ...
end;
 
constructor TComplex.Create(a,b: real);
    begin
        x := a; y := b;
        inherited Create;
    end;
...
 
var num: TComplex;
    x,y: real;
 
begin
    write('x := '); readln(x);
    write('y := '); readln(y);
    num := TComplex.Create(x,y);
 
    ...

Инкапсуляция

private
    <поля и методы, доступные только в пределах модуля>
protected
    <поля и методы, доступные только в классах потомках>
public
    <поля и методы, доступные из других модулей>
published
    <поля и методы, видимые в инспекторе объектов>

Пример был взят из учебника Free Pascal и Lazarus (Е.Р. Алексеев, О.В. Чеснокова, Т.В. Кучер), где он описан для среды Lazarus и с графическим интерфейсом.

Здесь приводится для IDE Free Pascal.

{$mode objfpc}
 
uses Classes;
 
type TPolygon = class(TObject)
    private
        k: integer;
        p: array of real;
    public
        constructor Create;
        function Perimeter(): real;
    {    function Show(): string; }
    protected
        procedure Set_Input(m: integer);
    published
        Property n: integer read K write Set_Input;
end;
 
constructor TPolygon.Create;
    var i: integer;
    begin
        k := 50;
        setLength(p,k);
        for i := 0 to k-1 do p[i] := 0;
        inherited Create;
    end;
function TPolygon.Perimeter(): real;
    var sum: real;
        i: integer;
    begin
        sum := 0;
        for i:=1 to k-1 do
            sum := sum + p[i];
        Perimeter := sum;
    end;
procedure TPolygon.Set_Input(m: integer);
    begin
        if m > 1 then K:=m else K:=50;
    end;
 
var figure: TPolygon;
    m: integer;
 
begin
    figure := TPolygon.Create;
    write('Number of sides: '); readln(m);
    figure.Set_Input(m);
    writeln('Number of sides: ', figure.n);
    writeln('Number of sides: ', figure.k);
    for m:=0 to figure.k-1 do figure.p[m] := random(50);
    writeln('Perimeter: ',figure.Perimeter():15:2);
 
readln;
end.

В данном случае нет наглядности, что здесь защищается от несанкционированного доступа. Получить значение k можно непосредственно, так и с помощью чтения свойства n.

Также в основной ветке программы без труда можно записать непосредственно в k без использования метода Set_Input():

figure.k := 3;

Видимо, это связано с тем, что обращения осуществляются в одном модуле.

Наследование

В зависимости от того, какие действия происходят при вызове, методы делятся на следующие группы:

По умолчанию все методы статические. Эти методы полностью перекрываются в классах-потомках при их переопределении. При этом можно полностью изменять объявление метода (например, тип и количество параметров).
Виртуальные и динамические методы имеют в базовом и производном классе те же имена и типы. В классах наследниках эти методы перегружены.
Разница между виртуальными и динамическими - способ их вызова... Использование виртуальных методов требует больший расход памяти..., зато они вызываются быстрее.

Пример был взят из учебника Free Pascal и Lazarus (Е.Р. Алексеев, О.В. Чеснокова, Т.В. Кучер), где он описан для среды Lazarus и с графическим интерфейсом.

Здесь приводится для IDE Free Pascal.

program project1;
 
{$mode objfpc}{$H+}
 
uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes
  { you can add units after this };
 
type TTriangle = class
  Private
    x,y: array[0..2] of real;
  Public
    constructor Create;
    procedure Set_Tr(a,b: array of real);
    function a():real;
    function b():real;
    function c():real;
    function Proverka():boolean; virtual;
    function Perimetr():real;
    function Square():real;
    procedure Show(); virtual;
end;
type R_TTriangle = class(TTriangle)
  Public
    function Proverka():boolean; override;
    procedure Show(); override;
end;
constructor TTriangle.Create;
  var i: integer;
  begin
    for i:=0 to 2 do begin
      x[i]:=0; y[i]:=0;
    end;
  end;
procedure TTriangle.Set_Tr(a,b: array of real);
  var i: integer;
  begin
    for i:=0 to 2 do begin
      x[i]:=a[i]; y[i]:=b[i];
    end;
  end;
function TTriangle.a():real;
  begin
    a := sqrt(sqr(x[1]-x[0]) + sqr(y[1]-y[0]));
  end;
function TTriangle.b():real;
  begin
    b := sqrt(sqr(x[2]-x[1]) + sqr(y[2]-y[1]));
  end;
function TTriangle.c():real;
  begin
    c := sqrt(sqr(x[0]-x[2]) + sqr(y[0]-y[2]));
  end;
function TTriangle.Perimetr():real;
  begin
    Perimetr := a() + b() + c();
  end;
function TTriangle.Square():real;
  var p: real;
  begin
    p := Perimetr()/2;
    Square := sqrt((p-a()) * (p-b()) * (p-c()));
  end;
function TTriangle.Proverka():boolean;
  begin
    if (x[0]-x[1])/(x[0]-x[2])= (y[0]-y[1])/(y[0]-y[2]) then
      Proverka := false
    else Proverka := true;
  end;
procedure TTriangle.Show();
  begin
    if Proverka() then begin
      writeln('a=',a(),', b=',b(),', c=',c());
      writeln('P=',Perimetr(),', S=',Square());
    end;
  end;
function R_TTriangle.Proverka():boolean;
  begin
    if (a()=b()) and (c()=b()) then
      Proverka := false
    else Proverka := true;
  end;
procedure R_TTriangle.Show();
  begin
    if Proverka() then begin
      writeln('a=',a());
      writeln('P=',Perimetr(),', S=',Square());
    end;
  end;
var
  figura1: TTriangle;
  figura2: R_TTriangle;
  var x1,y1,x2,y2: array[1..3] of real;
begin
  write('1 coords: '); readln(x1[1],y1[1]);
  write('2 coords: '); readln(x1[2],y1[2]);
  write('3 coords: '); readln(x1[3],y1[3]);
  write('1 coords: '); readln(x2[1],y2[1]);
  write('2 coords: '); readln(x2[2],y2[2]);
  write('3 coords: '); readln(x2[3],y2[3]);
  figura1 := TTriangle.Create;
  figura2 := R_TTriangle.Create;
  figura1.Set_Tr(x1,y1);
  figura2.Set_Tr(x2,y2);
  figura1.Show();
  figura2.Show();
  figura1.Free;
  figura2.Free;
readln;
end.

Вторая программа с демонстрацией наследования:

program project1;
 
{$mode objfpc}{$H+}
 
uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  Classes
  { you can add units after this };
 
type TFigure = class
  private
    n: integer; // количество сторон
    p: array of real; // массив длин сторон
  public
    // абстрактные подпрограммы
    // в каждом производном классе будут перегружаться
    constructor Create; virtual; abstract;
    function Perimeter(): real;
    function Square(): real; virtual; abstract;
    procedure Show(); virtual; abstract;
end;
type TCircle = class(TFigure)
  public
    constructor Create; override;
    function Perimeter(): real;
    function Square(): real; override;
    procedure Show(); override;
end;
type TRectangle = class(TFigure)
  public
    constructor Create; override;
    function Square(): real; override;
    procedure Show(); override;
end;
function TFigure.Perimeter(): real;
  var i: integer;
      s: real;
  begin
    s := 0;
    for i:=0 to n-1 do
        s := s + p[i] + p[i];
    Perimeter := s;
  end;
 
constructor TCircle.Create;
  begin
    n := 1;
    SetLength(p,n); // выделяем память под 1 элемент массива
    p[0] := 5; // радиус окружности
  end;
function TCircle.Perimeter(): real;
  begin
    Perimeter := 2 * PI * p[0]; // длина окружности
  end;
function TCircle.Square(): real;
  begin
    Square := PI * sqr(p[0]);
  end;
procedure TCircle.Show();
  begin
    writeln('r=',p[0]:4:2,' P=',Perimeter():4:2, ' S=', Square():4:2);
  end;
 
constructor TRectangle.Create;
  begin
    n := 2;
    SetLength(p,n); // выделяем память под 2 элемента
    p[0] := 4; p[1] := 2;
  end;
function TRectangle.Square(): real;
  begin
    Square := p[0] * p[1];
  end;
procedure TRectangle.Show();
  begin
    writeln('a=',p[0]:4:2,' b=',p[1]:4:2,' P=',Perimeter():4:2, ' S=', Square():4:2);
  end;
 
var
    figura1: TCircle;
    figura2: TRectangle;
begin
  figura1 := TCircle.Create;
  figura2 := TRectangle.Create;
  figura1.Show();
  figura2.Show();
readln
end.

Перегрузка операций

Перегрузка операций + и - для комплексных чисел.

type
  TComplex = class
    private
      x,y: real; //действительная и мнимая части
    public
      constructor Create;
      function Modul(): real;
      function Argument(): real;
      procedure Printer();
  end;
constructor TComplex.Create;
  begin
    x := 0; y := 0;
    inherited Create;
  end;
function TComplex.Modul(): real;
  begin
    modul := sqrt(x*x + y*y);
  end;
function TComplex.Argument(): real;
  begin
    argument := arctan(y/x) * 180/pi;
  end;
procedure TComplex.Printer();
  begin
    if y >= 0 then
      writeln(x:3:1,'+',y:3:1,'i')
    else
      writeln(x:3:1,y:3:1,'i');
  end;
 
operator +(const a,b: TComplex)r: TComplex;
  begin
    r := TComplex.Create;
    r.x := a.x + b.x;
    r.y := a.y + b.y;
  end;
operator -(const a,b: TComplex)r: TComplex;
  begin
    r := TComplex.Create;
    r.x := a.x - b.x;
    r.y := a.y - b.y;
  end;
 
var
  c1, c2, c3, c4: TComplex;
  a, b: real;
begin
  c1 := TComplex.Create;
  c2 := TComplex.Create;
  c3 := TComplex.Create;
  c4 := TComplex.Create;
  write('real and imag of the FIRST number: ');
  readln(c1.x, c1.y);
  write('real and imag of the SECOND number: ');
  readln(c2.x, c2.y);
  c3 := c1 + c2;
  c4 := c1 - c2;
  c3.printer();
  c4.printer();
readln;
end.

В примере реализуется возможность сложения и перемножения двух матриц, добавление к элементам матрицы любого числа или умножение на любое число.

type
  TMatrix = class
    private
        x: array[0..5,0..5] of real;
    public
        constructor Create;
        procedure printer();
        function uniq(): boolean; // является ли матрица единичной
  end;
 
  constructor TMatrix.Create;
    var i,j: integer;
    begin
      for i:=0 to 4 do
        for j:=0 to 4 do
          x[i,j] := Random(10);
      inherited Create;
    end;
 
  function TMatrix.uniq(): boolean;
    var i,j: integer;
    begin
      result := true;
      for i:=0 to 4 do
        for j:=0 to 4 do
          if ((i=j) and (x[i,j]<>1)) or ((i<>j) and (x[i,j]<>0)) then begin
            result := false;
            break;
          end;
    end;
 
  operator +(const a,b: TMatrix)r: TMatrix;
    var i,j: integer;
    begin
      r := TMatrix.Create;
      for i:=0 to 4 do
        for j:=0 to 4 do
          r.x[i,j] := a.x[i,j] + b.x[i,j];
    end;
  operator +(const a: TMatrix; b: real)r: TMatrix;
    var i,j: integer;
    begin
      r := TMatrix.Create;
      for i:=0 to 4 do
        for j:=0 to 4 do
          r.x[i,j] := a.x[i,j] + b;
    end;
  operator *(const a,b: TMatrix)r: TMatrix;
    var i,j: integer;
    begin
      r := TMatrix.Create;
      for i:=0 to 4 do
        for j:=0 to 4 do
          r.x[i,j] := a.x[i,j] * b.x[i,j];
    end;
  operator *(const a: TMatrix; b: real)r: TMatrix;
    var i,j: integer;
    begin
      r := TMatrix.Create;
      for i:=0 to 4 do
        for j:=0 to 4 do
          r.x[i,j] := a.x[i,j] * b;
    end;
 
  procedure TMatrix.printer();
    var i,j: integer;
    begin
      for i:=0 to 4 do begin
        for j:=0 to 4 do
          write(x[i,j]:5:0);
        writeln;
      end;
    end;
 
var
    m1,m2,m3,m4,m5,m6: TMatrix;
begin
  m1 := TMatrix.Create;
  m2 := TMatrix.Create;
  m3 := TMatrix.Create;
  m4 := TMatrix.Create;
  m5 := TMatrix.Create;
  m6 := TMatrix.Create;
  m1.printer; writeln('--------------------------');
  m2.printer; writeln('--------------------------');
  m3 := m1 + m2;
  m3.printer; writeln('--------------------------');
  m4 := m1 * m2;
  m4.printer; writeln('--------------------------');
  m5 := m1 + 10;
  m5.printer; writeln('--------------------------');
  m6 := m2 * 5;
  m6.printer; writeln('--------------------------');
  writeln(m1.uniq());
readln;
end.

Пример перегрузки операций < и >.

type
  TFraction = class
    private
      num,den: integer; // числитель и знаменатель
    public
      constructor Create(a,b: integer);
      procedure printer();
  end;
constructor TFraction.Create(a,b: integer);
  begin
    num := a; den := b;
    inherited Create;
  end;
operator <(const a,b: TFraction)r: boolean;
  begin
    if a.num * b.den < b.num * a.den then
        r := true
    else r := false;
  end;
operator >(const a,b: TFraction)r: boolean;
  begin
    if a.num * b.den > b.num * a.den then
        r := true
    else r := false;
  end;
procedure TFraction.printer();
  begin
    if den <> 0 then
        if num <> 0 then
            write(num,'/',den)
        else
            writeln(0)
    else
        writeln('Dividing by a zero');
  end;
var
  f1, f2: TFraction;
  a, b: integer;
begin
  write('Numerator and denominator of the FIRST fraction: ');
  readln(a,b);
  f1 := TFraction.Create(a,b);
  write('Numerator and denominator of the SECOND fraction: ');
  readln(a,b);
  f2 := TFraction.Create(a,b);
 
  f1.printer();
  write(' < ');
  f2.printer();
  writeln(' is ', f1<f2);
 
  f1.printer();
  write(' > ');
  f2.printer();
  writeln(' is ', f1>f2);
readln;
end.

Пример описания класса и подкласса (отрезок времени)

type TTime = class
  protected
    hour,min,sec: byte;
    function total_sec: integer;   // возвращает полное число секунд
    procedure timefromsec(tsec: integer);  // перевод сек. в ч.м.с
  public
    procedure settime(h,m,s: byte);
 // присваивание полям, исправление аргументов
    procedure print; // вывод значений полей
    procedure plus(first,second: ttime);
    procedure minus(first,second: ttime);
    procedure mult(first: ttime; second:byte);
    procedure divide(first: ttime; second:byte);
end;
function TTime.total_sec: integer; begin
    total_sec := hour*3600 + min*60 + sec;
end;
procedure TTime.timefromsec(tsec: integer); begin
    hour := tsec div 3600;
    min := tsec mod 3600 div 60;
    sec := tsec mod 3600 mod 60;
end;
procedure TTime.settime(h,m,s: byte); begin
    hour:=h; min:=m; sec:=s;
    if sec > 59 then begin
      min := min + sec div 60;
      sec := sec mod 60;
    end;
    if min > 59 then begin
      hour := hour + min div 60;
      min := min mod 60;
    end;
end;
procedure TTime.print; begin
    writeln(hour,':',min,':',sec);
end;
procedure TTime.plus(first,second: ttime); begin
    timefromsec(first.total_sec + second.total_sec);
end;
procedure TTime.minus(first,second: ttime); begin
    if first.total_sec > second.total_sec then
        timefromsec(first.total_sec - second.total_sec);
end;
procedure TTime.mult(first: ttime; second:byte); begin
    timefromsec(first.total_sec * second);
end;
procedure TTime.divide(first: ttime; second:byte); begin
    if second <> 0 then
       timefromsec(first.total_sec div second);
end;
 
type TLTime = class(TTime)
  protected
    days: byte;
    function total_sec: integer;
    procedure timefromsec(tsec: integer);
  public
    procedure settime(d,h,m,s: byte);
    procedure print;
end;
 
function TLTime.total_sec: integer; begin
    total_sec := days*24*3600 + hour*3600 + min*60 + sec;
end;
procedure TLTime.timefromsec(tsec: integer);
var time: integer;
begin
    days := tsec div (24*3600);
    time := tsec mod (24*3600);
    inherited timefromsec(time);
end;
procedure TLTime.settime(d,h,m,s: byte); begin
    inherited settime(h,m,s);
    days := d;
    if hour > 23 then begin
      days := days + hour div 24;
      hour := hour mod 24
    end;
end;
procedure TLTime.print; begin
      writeln(days,' days; ',hour,':',min,':',sec);
end;
 
var a,b,c: TTime;
  aa,bb: TLTime;
begin
    begin
        a := TTime.Create;
        b := TTime.Create;
        c := TTime.Create;
        a.settime(4,30,0);
        b.settime(12,55,70);
        a.print;
        b.print;
        c.plus(a,b);
        c.print;
        c.minus(b,a);
        c.print;
        c.mult(a,3);
        c.print;
        c.divide(a,2);
        c.print;
        writeln;
    end;
    aa := TLTime.Create;
    bb := TLTime.Create;
    aa.settime(5,34,12,35);
    bb.settime(12,20,0,0);
    aa.print;
    bb.print;
readln;
end.