Викиучебник

GraphPlatNet

Открытый код среды рисования GraphPlatNet 
uses
   crt, GraphABC;

var
   IndexFor, IndexFor2, Y: integer;
   f: text;
   FileName: string;
   //Изначальный код
   OCode: array of string;
   OCodeIndex: integer;
   //Полученный код
   Code: array of string;
   CodeIndex: integer;
   
   ///некоторые параметры
   FillFigures: boolean;
   RoundX, RoundY: integer;
   //для процедур
   ///имена
   proceduresnames: array [0..100] of string;
   ///содержание
   procedurescontents: array [0..100, 0..1000] of string;
   proceduresnamesI, procedurescontentsI: integer;
   //для эффекта раскидывания точек
   RandomPoints: boolean;
   PointsMin, PointsMax, pointX, pointY: integer;
   PointsDistMin, PointsDistMax: integer;

procedure RandomPointsEffect();
begin
   var a, sx, sy: integer;
   if (RandomPoints = true) then
   begin
      for a := PointsMin to PointsMax - 1 do
      begin
         Sx := Random(100); Sy := Random(100);
         if (Sx div 2 = 0) then pointX := Pen.X + PointsDistMin + Random(PointsDistMax - PointsDistMin) else
            pointX := Pen.X - (PointsDistMin + Random(PointsDistMax - PointsDistMin));
         if (Sy div 2 = 0) then pointY := Pen.Y + PointsDistMin + Random(PointsDistMax - PointsDistMin) else
            pointY := Pen.Y - (PointsDistMin + Random(PointsDistMax - PointsDistMin));
         PutPixel(pointX, pointY, PenColor);
      end;
   end;
end;

procedure DrawSign(s: string; fs, x, y: integer; fc: Color); forward;

procedure DrawSign(s: string; fs, x, y: integer; fc: Color);
begin
   SetFontColor(fc); SetFontSize(fs); TextOut(x, y, s);
end;

procedure HelloUser();
begin
   var b: integer;
   SetWindowWidth(500); SetWindowHeight(300); SetWindowIsFixedSize(true);
   DrawSign('G', 40, 20, 20, clRed);
   DrawSign('a', 60, 60, 20, clyellow);
   DrawSign('r', 30, 60, 20, clblack);
   DrawSign('P', 35, 100, 20, clgreen);
   DrawSign('H', 44, 130, 20, clblue);
   DrawSign('PlatNet', 70, 170, 10, clpurple);
   DrawSign('Среда рисования', 20, 10, 150, clblack);
   SetPenColor(clGray);
   Line(0, 288, 500, 288);
   DrawSign('PlatNet', 70, 170, 10, clpurple);
   SetPenColor(clBlack);
   Line(0, 100, 500, 100);
   for b := 0 to 500 do
   begin
      PutPixel(b, 288, clCyan);
      Sleep(1);
   end;
   ClearWindow;
   SetWindowIsFixedSize(false);
end;


//////////////////////////////////////////////////

///ПОлучает первое слово в строке
function strtok(var s: string; delims: string): string; forward;

function strtok(var s: string; delims: string): string;
{Функция разбивает строку s на слова, разделенные символами-разделителями,
указанными в строке delims. Функция возвращает первое найденное слово, при 
этом из строки s удаляется начальная часть до следующего слова}
var
   res: string; state: byte; i: integer;
begin
   state := 1;
   res := '';
   if s = '' then
   begin
      result := '';
      exit;
   end;
   while pos(s[state], delims) <> 0 do
   begin
      inc(state);
      if state > length(s) then
      begin
         s := '';
         result := '';
         exit;
      end;
   end;
   while pos(s[state], delims) = 0 do
   begin
      res := res + s[state];
      inc(state);
      if state > length(s) then
      begin
         s := '';
         result := res;
         exit;
      end;
   end;
   while pos(s[state], delims) <> 0 do
   begin
      inc(state);
      if state > length(s) then
      begin
         s := '';
         result := res;
         exit;
      end;
   end;
   delete(s, 1, state - 1);
   result := res;
end;
/////////////////////////////////////////////////
/////////////////////////////////////////////////
procedure TransformCode();
begin
   var a: integer;
   CodeIndex := 0; OCodeIndex := 0;
   for a := 0 to OCode.Length - 1 do
   begin
      //отдельная строка
      while strtok(OCode[OCodeIndex], ' ') <> '' do
      begin
         SetLength(Code, CodeIndex + 1);
         Code[CodeIndex] := strtok(OCode[OCodeIndex], ' ');
         writeln(Code[CodeIndex]);
         Inc(CodeIndex);
      end;
      Inc(OCodeIndex);
   end;
   OCodeIndex := 0; CodeIndex := 0;
end;

begin
   SetWindowCaption('GraphPlatNet');
   crt.SetWindowCaption('GraphPlatNet');
   HelloUser();
   SetFontColor(clBlack); SetFontSize(14);
   SetConsoleIO;
   writeln('Enter a name of file (without .GPN.txt):');
   Readln(FileName);
   FileName := FileName + '.GPN.txt';
   if FileExists(FileName) = true then
   begin
      Assign(f, FileName);
      Reset(f);
      OCode := ReadAllLines(FileName, encoding.ASCII);
      TransformCode();
      ///цикл обработки кода
      for IndexFor := 0 to Code.Length - 1 do
      begin
         try
            //эффект рандомных капель
            if (Code[IndexFor] = 'SetRandomPointsEffect') then
            begin
               if (Code[IndexFor + 1] = 'true') then RandomPoints := true else RandomPoints := false;
            end;
            if (Code[IndexFor] = 'SetRandomPointsParameters') then
            begin
               PointsMin := StrToInt(Code[IndexFor + 1]);
               PointsMax := StrToInt(Code[IndexFor + 2]);
               PointsDistMin := StrToInt(Code[IndexFor + 3]);
               PointsDistMax := StrToInt(Code[IndexFor + 4]);
            end;
            //
            if (Code[IndexFor] = 'SetFillInside') then
            begin
               if (Code[IndexFor + 1] = 'true') then FillFigures := true else FillFigures := false;
            end;
            if (Code[IndexFor] = 'SetSmothing') then
            begin
               RoundX := StrToInt(Code[IndexFor + 1]); RoundY := StrToInt(Code[IndexFor + 2]);
            end;
            if (Code[IndexFor] = 'SetPenColor') then
            begin
               SetPenColor(RGB(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3])));
            end;
            if (Code[IndexFor] = 'SetFontColor') then
            begin
               SetFontColor(RGB(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3])));
            end;
            if (Code[IndexFor] = 'SetPenSize') then
            begin
               SetPenWidth(StrToInt(Code[IndexFor + 1]));
            end;
            if (Code[IndexFor] = 'SetFontSize') then
            begin
               SetFontSize(StrToInt(Code[IndexFor + 1]));
            end;
            ///рисование примитивов
            if (Code[IndexFor] = 'DrawPoint') then
            begin
               SetPixel(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), PenColor());
            end;
            if (Code[IndexFor] = 'DrawLine') then
            begin
               Line(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]), PenColor());
            end;
            if (Code[IndexFor] = 'DrawEllipse') then
            begin
               if (FillFigures = false) then DrawEllipse(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4])) else
               begin
                  DrawEllipse(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]));
                  FillEllipse(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]));
               end;
            end;
            if (Code[IndexFor] = 'DrawCircle') then
            begin
               if (FillFigures = false) then DrawCircle(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3])) else
               begin
                  DrawCircle(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]));
                  FIllCircle(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]));
               end;
            end;
            if (Code[IndexFor] = 'DrawRectangle') then
            begin
               if (FillFigures = false) then DrawRoundRect(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]), RoundX, RoundY) else
               begin
                  DrawRoundRect(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]), RoundX, RoundY);
                  FillRoundRect(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), StrToInt(Code[IndexFor + 3]), StrToInt(Code[IndexFor + 4]), RoundX, RoundY);
               end;
            end;
            if (Code[IndexFor] = 'FillArea') then
            begin
               FloodFill(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), PenColor());
            end;
            if (Code[IndexFor] = 'DrawText') then
            begin
               TextOut(StrToInt(Code[IndexFor + 1]), StrToInt(Code[IndexFor + 2]), Code[IndexFor + 3]);
            end;
            if (Code[IndexFor] = 'ClearWindow') then
            begin
               ClearWindow;
            end;
            //создание процедур
            if (Code[IndexFor] = 'Procedure') then
            begin
               proceduresnames[proceduresnamesI] := Code[IndexFor + 1];
               IndexFor2 := IndexFor;
               while Code[IndexFor2] <> 'End' do
               begin
                  procedurescontents[proceduresnamesI, procedurescontentsI] := Code[IndexFor2];
                  inc(procedurescontentsI); Inc(IndexFor2);
               end;
               procedurescontentsI := 0; inc(proceduresnamesI);
               IndexFor2 := 0;
            end;
            if (Code[IndexFor] = 'RunProcedure') then
            begin
               IndexFor2 := 0;
               //Если не найдена будет выполненная пустая процедура - ничего не выполнено
               while proceduresnames[IndexFor2] <> Code[IndexFor + 1] do Inc(IndexFor2);
               for y := 0 to 999 do
               begin
                  
                  if (procedurescontents[IndexFor2, y] = 'SetRandomPointsEffect') then
                  begin
                     if (procedurescontents[IndexFor2, y + 1] = 'true') then RandomPoints := true else RandomPoints := false;
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetRandomPointsParameters') then
                  begin
                     PointsMin := StrToInt(procedurescontents[IndexFor2, y + 1]);
                     PointsMax := StrToInt(procedurescontents[IndexFor2, y + 2]);
                     PointsDistMin := StrToInt(procedurescontents[IndexFor2, y + 3]);
                     PointsDistMax := StrToInt(procedurescontents[IndexFor2, y + 4]);
                  end;
                  
                  if (procedurescontents[IndexFor2, y] = 'SetFillInside') then
                  begin
                     if (procedurescontents[IndexFor2, y + 1] = 'true') then FillFigures := true else FillFigures := false;
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetSmothing') then
                  begin
                     RoundX := StrToInt(procedurescontents[IndexFor2, y + 1]); RoundY := StrToInt(procedurescontents[IndexFor2, y + 2]);
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetPenColor') then
                  begin
                     SetPenColor(RGB(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3])));
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetFontColor') then
                  begin
                     SetFontColor(RGB(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3])));
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetPenSize') then
                  begin
                     SetPenWidth(StrToInt(procedurescontents[IndexFor2, y + 1]));
                  end;
                  if (procedurescontents[IndexFor2, y] = 'SetFontSize') then
                  begin
                     SetFontSize(StrToInt(procedurescontents[IndexFor2, y + 1]));
                  end;
                  ///рисование примитивов
                  if (procedurescontents[IndexFor2, y] = 'DrawPoint') then
                  begin
                     SetPixel(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), PenColor());
                  end;
                  if (procedurescontents[IndexFor2, y] = 'DrawLine') then
                  begin
                     Line(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]), PenColor());
                  end;
                  if (procedurescontents[IndexFor2, y] = 'DrawEllipse') then
                  begin
                     if (FillFigures = false) then DrawEllipse(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4])) else
                     begin
                        DrawEllipse(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]));
                        FillEllipse(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]));
                     end;
                  end;
                  if (procedurescontents[IndexFor2, y] = 'DrawCircle') then
                  begin
                     if (FillFigures = false) then DrawCircle(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3])) else
                     begin
                        DrawCircle(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]));
                        FIllCircle(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]));
                     end;
                  end;
                  if (procedurescontents[IndexFor2, y] = 'DrawRectangle') then
                  begin
                     if (FillFigures = false) then DrawRoundRect(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]), RoundX, RoundY) else
                     begin
                        DrawRoundRect(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]), RoundX, RoundY);
                        FillRoundRect(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), StrToInt(procedurescontents[IndexFor2, y + 3]), StrToInt(procedurescontents[IndexFor2, y + 4]), RoundX, RoundY);
                     end;
                  end;
                  if (procedurescontents[IndexFor2, y] = 'FillArea') then
                  begin
                     FloodFill(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), PenColor());
                  end;
                  if (Code[IndexFor] = 'DrawText') then
                  begin
                     TextOut(StrToInt(procedurescontents[IndexFor2, y + 1]), StrToInt(procedurescontents[IndexFor2, y + 2]), procedurescontents[IndexFor2, y + 3]);
                  end;
                  if (procedurescontents[IndexFor2, y] = 'ClearWindow') then
                  begin
                     ClearWindow;
                  end;
                  RandomPointsEffect();
               end;
            end;
            RandomPointsEffect();
         except 
            on System.Exception do
            begin
               TextOut(0, 0, 'Error:IndexOutOfRangeException [String: ' + IntToStr(IndexFor) + ']');
            end;
         end;
      end;
   end
   else
   begin
      TextOut(0, 0, 'Error:File does not exit.');
   end;
end.

О проекте править

Проект создан на основе учебного модуля GraphABC. Эта среда дает возможность сконцентрировать свое внимание именно на рисовании, а не программировании в целом. В ней ИСКЛЮЧЕНО использование средств не рисования. То есть нет возможности работать с условиями, циклами и т.д. Но все таки, в нее включена возможность создания процедур на самом примитивном уровне.

Для рисования пишите программу в файле с расширением .GPL.txt. Потом запускайте интерпретатор GraphPlatnet и вводите имя файла без расширения - рисунок автоматически будет нарисован. Если есть ошибки в коде, то среда сообщит Вам об этом.

Команды править

Команда Описание 
SetFontColor
r
g
b
 Устанавливает цвет текста. 
SetPenColor
r
g
b
 Устанавливает цвет пера. 
SetFontSize
r
g
b
 Устанавливает размер текста. 
SetPenSize
r
g
b
 Устанавливает размер пера. 
SetSmothing
x
y
 Устанавливает размер сглаживания углов прямоугольника. 
SetFillInside
true/false
Говорит заливать ли внутренности фигур или нет. 
DrawPoint
x
y
 Заливает пиксель.
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки
Текст ячейки Текст ячейки

Примеры программ править 

# Procedure : A :
#    SetPenColor 100 , 100 , 250
#    DrawLine 100 , 100 , 300 , 300 ;
# End ;
# RunProcedure :
#    A .

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

# Procedure : A :
#    Par : 1 : x : integer , y: integer ;
#    SetPenColor x , 100 , 250
#    inc : x , 100
#    mult : y , 100
#    DrawLine x , 100 , 300 , y ;
# End ;
# RunProcedure :
#    A : with : x = 12 ; with : y = 10 ;
Источник — https://ru.wikibooks.org/w/index.php?title=GraphPlatNet&oldid=163874