Графика в Турбо Паскаль

program sota;
uses graph;
const
r = 10;
var
gd,gm: integer;
ga: string;
ErrCode: integer;
i, j: integer;
n, m, x, y: integer;
fi: integer;
begin
gd := VGA;
gm := VGAHi;
ga := '../bgi';
initgraph(gd,gm,ga);
ErrCode := GraphResult;
 if ErrCode = GrOk then begin
   x:=0;
   y:=0;
   n:=Round(GetMaxX/r);
   m:=Round(GetMaxY/r);
   for j := 0 to n do begin
    for i := 0 to m do begin
    x :=Round(r*(i*3+1.5*(j mod 2)));
    y := Round(j*r*0.866);
    fi := 0;
    MoveTo(x + Round(r*cos(2*fi*pi/360)), y + Round(r*sin(2*fi*pi/360)));
     repeat
     inc(fi,60);
     LineTo(x + Round(r*cos(2*fi*pi/360)), y + Round(r*sin(2*fi*pi/360)));
     until 360 <= fi;
    end;
    end;
   ReadLn;
 end;
end.

uses crt,graph;
const n=4;
type
Point=record
x,y:integer;
end;
mas=array[1..n] of Point;
procedure Z(x,y:integer;var m:mas;c:byte);
 
var i:byte;
begin
Setcolor(c);
m[1].x:=x;m[1].y:=y;
m[2].x:=x;m[2].y:=y+90;
m[3].x:=x+90;m[3].y:=y+90;
m[4].x:=x;m[4].y:=y;
moveto(m[1].x,m[1].y);
for i:=1 to n do
lineto(m[i].x,m[i].y);
Setfillstyle(1,c);
end;
var gd,gm:integer;
    x,y,x1,y1,i:integer;
    p:mas;
    c1,c2:byte;
    k:char;
    move:boolean;
begin
gd:=VGA;
gm:=VGAHi;
Initgraph(gd,gm,'..\bgi');
Setbkcolor(8);
x:=10;y:=10;
c1:=7;c2:=8;
move:=true;
repeat
if keypressed then
  begin
    k:=readkey;
    if k=#13 then {if enter}
     for i:=1 to 10 do
      begin
        y1:=y;
        x1:=x;
        y:=y+1;
        x:=x+1;
        delay(6000);
        Z(x1,y1,p,c2);
        Z(x,y,p,c1);
        move:=true;
      end;
    end;
if move then
  begin
    Z(x1,y1,p,c2);
    Z(x,y,p,c1);
    move:=false;
  end;
OutTextXY(320,240,'Press Enter to continue');
until k=#27; {until escape}
closegraph;
end.

function timer:real;
var hour,minute,second,sec100:word;
begin
   gettime(hour,minute,second,sec100);
   timer:=(hour*3600.0+minute*60.0+second)*100.0+1.0*sec100;
end;
 
procedure wait_seconds(t:real);
var t1:real;
begin
 t1:=timer;
 repeat until timer>t1+100*t;
end;

Program Rotation and Reflection;
 
uses Crt, Graph;
var
   gd, gm: Integer;
   par: array[1..8, 1..3] of real;
   ribs: array[1..12, 1..2] of integer;
   i: integer;
   ch: char;
   corner : real;
 
procedure draw;
var
   x1, x2, y1, y2: integer;
   ver1, ver2: integer;
begin
   for i := 1 to 12 do begin
   ver1 := ribs[i,1];
   ver2 := ribs[i,2];
   x1 := round(par[ver1,1])+320;
   y1 := 240-round(par[ver1,2]);
   x2 := round(par[ver2,1])+320;
   y2 := 240-round(par[ver2,2]);
   line(x1,y1,x2,y2);
  end;
end;
 
procedure reflection_XOZ_YOZ;
begin
   for i:=1 to 8 do begin
       par[i,2]:=-par[i,2];
       par[i,1]:=-par[i,1];
   end;
end;
 
procedure reflection_XOZ_XOY;
begin
   for i:=1 to 8 do begin
       par[i,2]:=-par[i,2];
       par[i,3]:=-par[i,3];
   end;
end;
 
procedure reflection_XOY_YOZ;
begin
   for i:=1 to 8 do begin
       par[i,3]:=-par[i,3];
       par[i,1]:=-par[i,1];
   end;
end;
 
procedure turnOX(corner: real);
var
   y,z: real;
begin
   for i:=1 to 8 do Begin
       y:=par[i,2];
       z:=par[i,3];
       par[i,2]:=y*cos(corner)-z*sin(corner);
       par[i,3]:=y*sin(corner)+z*cos(corner);
   end;
end;
 
procedure turnOY(corner: real);
var
   x,z: real;
begin
   for i:=1 to 8 do begin
       x:=par[i,1];
       z:=par[i,3];
       par[i,1]:=x*cos(corner)+z*sin(corner);
       par[i,3]:=-x*sin(corner)+z*cos(corner);
   end;
end;
 
procedure turnOZ(corner: real);
var
   x,y: real;
begin
   for i:=1 to 8 do begin
       x:=par[i,1];
       y:=par[i,2];
       par[i,1]:=x*cos(corner)-y*sin(corner);
       par[i,2]:=x*sin(corner)+y*cos(corner);
   end;
end;
 
begin
   par[1,1]:=0;    par[1,2]:=0;    par[1,3]:=0;
   par[2,1]:=0;    par[2,2]:=110;  par[2,3]:=0;
   par[3,1]:=175;  par[3,2]:=110;  par[3,3]:=0;
   par[4,1]:=175;  par[4,2]:=0;    par[4,3]:=0;
   par[5,1]:=0;    par[5,2]:=0;    par[5,3]:=150;
   par[6,1]:=0;    par[6,2]:=110;  par[6,3]:=150;
   par[7,1]:=175;  par[7,2]:=110;  par[7,3]:=150;
   par[8,1]:=175;  par[8,2]:=0;    par[8,3]:=150;
 
   ribs[1,1]:=1;   ribs[1,2]:=2;
   ribs[2,1]:=2;   ribs[2,2]:=3;
   ribs[3,1]:=3;   ribs[3,2]:=4;
   ribs[4,1]:=4;   ribs[4,2]:=1;
   ribs[5,1]:=5;   ribs[5,2]:=6;
   ribs[6,1]:=6;   ribs[6,2]:=7;
   ribs[7,1]:=7;   ribs[7,2]:=8;
   ribs[8,1]:=8;   ribs[8,2]:=5;
   ribs[9,1]:=1;   ribs[9,2]:=5;
   ribs[10,1]:=2;  ribs[10,2]:=6;
   ribs[11,1]:=3;  ribs[11,2]:=7;
   ribs[12,1]:=4;  ribs[12,2]:=8;
 
 
   gd := VGA;
   gm := VGAHi;
   InitGraph(gd, gm, '../bgi');
 
   If GraphResult <> grOk then
      Halt(1);
 
   turnOX(pi/12);
   turnOY(pi/12);
   turnOZ(pi/12);
   While ch<>#27 do begin
      ClearDevice;
      Draw;
      OuttextXY(10,450,'Press <1>-<6> for rotation, <7>-<9> for reflection');
      OuttextXY(10,465,'Press <Esc> to Exit');
      ch:=readkey;
      Case ch Of
         '1': turnOX(pi/15);
         '4': turnOX(-pi/15);
         '2': turnOY(pi/15);
         '5': turnOY(-pi/15);
         '3': turnOZ(pi/15);
         '6': turnOZ(-pi/15);
         '7': reflection_XOZ_YOZ;
         '8': reflection_XOZ_XOY;
         '9': reflection_XOY_YOZ;
      end;
   end;
   closegraph;
end.

program corablik;
uses Graph, Crt;
var
  grDriver: integer;
  grMode: integer;
  ErrCode: integer;
  x,y,y0,a,b: integer;{a,b-переменные для линии моря, чтоб они не зависели от х,у}
procedure more(a,b:integer);
begin
moveto(0,y0);
setcolor(blue);
for a:=0 to 680 do{слева направо рисуем синусоиду синего чвета}
 begin
  b:=y0-round(sin(a*pi/180)*30);{30-коэффициент масштабирования по оси Х, 
чем больше, тем волна круче}
  lineto(a,b);
 end;
end;
begin
  grDriver := Detect;
  InitGraph(grDriver, grMode, '..\BGI');
  ErrCode := GraphResult;
  y0 := 250;
  if ErrCode = grOk then
  begin
    x:=600;
    while x>=0 do{лучше использовать цикл while, можно менять величину шага, 
что тоже влияет на скорость и частоту смены картинки}
     begin
      cleardevice;
      more(a,b);{рисуем волну}
      setcolor(white);{устанавливаем цвет кораблика}
      y:=y0-40-round(sin(x*pi/180)*30);{движемся по волне}
      MoveTo(x - 40, y + 20);
      LineTo(x - 20, y + 40);
      LineTo(x + 20, y + 40);
      LineTo(x + 40, y + 20);
      LineTo(x - 40, y + 20);
      MoveTo(x + 15, y + 20);
      LineTo(x + 15, y - 40);
      LineTo(x - 20, y + 20);
      LineTo(x + 15, y + 20);
      delay(100); {нормальная скорость, если модули *.TPL не глючные как у Вас,
 время должно быть в миллисекундах, а не в каких-нибудь наносекундах} 
      x:=x-2;{шаг движения}
    end;
  end
  else Writeln('Graphics error: ', GraphErrorMsg(ErrCode));
 Settextstyle(0,0,3);{устанавливаем стиль шрифта}
 cleardevice;
 setcolor(red);
 OuttextXY(200,240,'Rejs zavershen!');{выводим надпись}
 readln;
 CloseGraph;
end.

program kv;
uses
    crt, graph;
var
   x, y, dx, dy, w, h, driver, mode: integer;
begin
     initgraph(driver, mode, 'G:/BP/BGI');
     if graphresult<>0 then begin
        writeln('none');
        halt
     end;
     dx:=1;
     dy:=0;
     w:=100;
     h:=10;
repeat
      setfillstyle(1, black);
      bar(x, y, x+w, y+h);
      x:=x+dx;
      y:=y+dy;
      setfillstyle(1, red);
      bar(x, y, x+w, y+h);
      delay(100);
      if (x+w>=getmaxx)and(y<=0) then
      begin
           dx:=0;
           dy:=1;
      end
      else
      if (y+h>=getmaxy)and(x+w>=getmaxx) then
      begin
           dx:=-1;
           dy:=0;
      end
      else
      if (x<=0)and(y+h>=getmaxy) then
      begin
           dx:=0;
           dy:=-1;
      end
      else
      if (y<=0)and(x<=0) then
      begin
           dx:=1;
           dy:=0;
      end;
until keypressed;
closegraph;
end.

Program bugalteria;
Uses crt,graph;
Var gd,gm:integer;
begin
clrscr;
 Detectgraph (gd,gm);
 Initgraph (gd,gm,'C:\tp7');
  {Зарисовка стола}
  Bar (120,330,360,360);
  Bar (180,360,330,480);
  {Зарисовка компьютера}
  Line (180,240,180,330);
  Line (180,270,210,330);
  Line (172,210,202,300);
  Line (180,210,210,300);
  Line (210,300,202,300);
  Line (180,210,172,210);
  Line (270,322,270,330);
  Line (270,322,330,330);
  {Зарисовка стула}
  Bar (420,405,510,420);
  Bar (456,420,480,480);
  {Зарисовка бухгалтера работающего за компьютером}
  Line (510,405,540,300);
  Line (334,480,390,390);
  Line (390,390,510,390);
  Line (360,480,420,405);
  Line (510,390,450,240);
  Line (480,390,420,300);
  Line (420,300,430,240);
  Line (450,270,330,300);
  Line (330,300,310,310);
  Circle (435,195,40);
Readln
end.

uses GraphABC;
 
var xx, yy, xx1, yy1, xx2, yy2, xx3, yy3: real;
    
begin
  var x1:= 50;
  var y1:= 50; 
  var x2:= 70;
  var y2:= 50;
  var x3:= 70;
  var y3:= 70;
  var x4:= 50;
  var y4:= 70;  
  var alfa:=0.5;
  while(true) do
    begin
      ClearWindow;
      {xx:= x1*cos(alfa) + y1*(-sin(alfa)) + (-20)*cos(alfa) + 20*sin(alfa) + 20;
      yy:= x1*sin(alfa) + y1*cos(alfa) + (-20)*sin(alfa) - 20*cos(alfa) + 20;}
      xx1:= x2*cos(alfa) + y2*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy1:= x2*sin(alfa) + y2*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(x1),round(y1),round(xx1),round(yy1));
      
      xx2:= x3*cos(alfa) + y3*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy2:= x3*sin(alfa) + y3*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(xx1),round(yy1),round(xx2),round(yy2));
      
      xx3:= x4*cos(alfa) + y4*(-sin(alfa)) + (-50)*cos(alfa) + 50*sin(alfa) + 50;
      yy3:= x4*sin(alfa) + y4*cos(alfa) + (-50)*sin(alfa) - 50*cos(alfa) + 50;
      Line(round(xx2), round(yy2), round(xx3), round(yy3));
      
      Line(round(xx3), round(yy3), round(x1), round(y1));
      
      alfa +=0.1;
      redraw;
     // sleep(1);
    
    end;
end.

program LoRD; {Построение столбиковой диаграммы}
uses Crt, Graph;
const Count=10;
Width =40; {Ширина столбца диаграммы}
var
I,X1,X2,Y1,Y2 : integer;
M : array[1..Count] of byte;
DriverVar, ModeVar: integer;
S_M : string;
begin
Writeln('Ввод данных (целые числа) для построения диаграммы');
for I:=l to Count do
begin
repeat {Ввод с контролем, входит ли введенное значение в [1..10]}
Write('Введите значение' , I, '-го параметра (от 1 до 10) :');
Readln(M[I]) ;
if not M[I] in [1..10] {Если введенное значение не входит в ин-тервал [1..10]}
then Writeln('Значение параметра должно быть от 1 до 10');
until M[I] in [1..10];
end;
27
DriverVar:=Detect; {Инициализация графического режима}
InitGraph(DriverVar,ModeVar,'');
SetViewPort(10,10,630,400,True); {Создать окно}
SetTextStyle(DefaultFont,HorizDir,1);
Yl:=325; {Построение гистограммы}
for I:=l to Count do {Повторять, пока не построим все столбики}
begin
XI:=I*50;
Str(M[I],S_M) ; {Преобразовать значение М[1] в строку для вы-вода в графическом режиме на экран}
SetFillStyle(I,I); {Задать стиль и цвет заполнения}
Bar3D(Xl,Yl,Xl+Width,Yl-M[I]*30,10,TopOn); {Построить столбико-вую диаграмму}
OutTextXY (X1+15,Y1-M[I]*3O-15,S_M); {Напечатать над столбиком значение отображаемой величины}
end; {Конец цикла}
{Вывод пояснительных надписей}
SetTextStyle(DefaultFont,HorizDir,2);
OutTextXY(150,20,'Пример гистограммы');
SetTextStyle(DefaultFont,VertDir,1);
OutTextXY(40,175,'Величина параметра');
SetTextStyle(DefaultFont,HorizDir,1);
OutTextXY(250,GetMaxY-140,'Параметры');
OutTextXY(150,GetMaxY-100,'Для завершения нажмите Enter');
Readln;
CloseGraph;
end.

program spiral;
uses graph;
const
koef=1.1; {коефициент возростания сторон}
pochatok=10;
kinec=320;
var
driver,mode:integer;
procedure Myspiral(storona:integer);
begin
if storona<=kinec then
begin
storona:=-storona; {смена направления рисования}
linerel(0,storona);    {вверх или вниз}
linerel(storona,0);    {влево или вправо}
Myspiral(round(koef*storona))
end
end;
begin
driver:=detect;
initgraph(driver,mode,' ');
setbkcolor(1);
setcolor(1);
linerel(300,240);
setcolor(15);
Myspiral(pochatok);
readln;
end.

program LoRD;
uses crt,graph;
var dr,m:integer;             {графический драйвер и режим}
x,y,                          {координаты обьекта во время движения}
dx,dy:integer;                {прирост координат}
ptr:pointer;                  {указатель на область памяти
                               где сохраняется изображение}
size:integer;                 {размер памяти}
leftX, leftY,                 {координаты левого верхнего}
rightX,rightY:integer;        {правого нижнего углов прямоугольника, в
                              который вписано изображение}
i:integer;                    {параметр цикла}
{*************изображение звездного неба******************************}
procedure Sky;
begin
randomize;                    {инициализация генератора случайных чисел}
SetBkColor(i);                {цвет фона}
SetColor(14);                 {цвет звезд}
for i:=1 to 200 do            {изображение звезд}
Circle(random(640),random(480),1);
end;
{*****************изображение луны**************************************}
procedure Moon;
begin
SetColor(14);
Arc(450,100,270,90,50);
Arc(390,100,320,40,80);
SetFillStyle(1,14);
floodFill(480,100,14);
end;
{******************сохранение изображения в динамической памяти**********}
procedure SaveClip;
begin
leftX:=445;                   {координаты прямоугольника}
leftY:=45;                    {в который вписана луна}
rightX:=505;
rightY:=155;
size:=imagesize(leftX, leftY, rightX, rightY);   {выдиление памяти}
getmem(ptr,size);
getimage(leftX,leftY,rightX,rightY,ptr^);    {сохраняем изображение в памяти}
putimage(leftX,leftY,ptr^,xorput);           {спрятать изображение}
end;
{**************************движение луны**********************************}
procedure Move;
begin
x:=leftX; y:=leftY;           {стартовые координаты}
dx:=10; dy:=10;               {прирост координат}
repeat                        {сдвигизображения}
x:=x+dx;                      {смена координат луны}
y:=y+dy;
putimage(X,Y,ptr^,xorput);    {изобразить фигуру в новых координатах}
delay(2000);                  {задержка движения}
putimage(X,Y,ptr^,xorput);    {спрятать фигуру в старых координатах}
if (x>640) or (x<0)           {если фигура приблизилась к краю экрана}
then dx:=-dx                  {сменить ее направление}
else
if(y<0) or (y>480) then dy:=-dy;
until keypressed;
end;
{*********************основная программа***********************************}
BEGIN
dr:=Detect;
InitGraph(dr,m,'');
Sky;
Moon;
SaveClip;
Move;
readkey;
end.

Uses GraphABC,ABCObjects;
const n=800;
      nn=600;
      m=600;
 
type pixels=array[0..n-1,0..m-1] of longint;
 
var ARed: pixels;
    AGreen: pixels;
    ABlue: pixels;
    Parr: pixels;
    RAr,GAr,BAr, AH, ASS, AL: pixels;
    col: color;
    i, j, x, y, w, h: integer;
procedure RGBTOHSL(var w, hei: integer;AR, AG, AB: pixels; var AH, ASS, AL: pixels);
var R, G, B, H, S, L, Minimum, Maximum, delMax, delR, delG, delB: real;
begin
  for var i:=0 to w-1 do
    for var j:=0 to hei-1 do
    begin
      R := AR[i,j];   
      G := AG[i,j];
      B := AB[i,j];
  
      Minimum := min(min( R, G), B);
      Maximum := max(max( R, G), B);  
      delMax := Maximum - Minimum;         
   
      AL[i,j] := Round(( Maximum + Minimum ) / 2);
 
      if  delMax = 0 then      
      begin
        AH[i,j] := 0;                               
        ASS[i,j] := 0;
      end
      else    
      begin
         if ( AL[i,j] < 0.5 ) then
            ASS[i,j] := Round(delMax / ( Maximum + Minimum ))
         else
            ASS[i,j] := Round(delMax / ( 2 - Maximum - Minimum ));
 
         delR := ( ( ( Maximum - R ) / 6 ) + ( delMax / 2 ) ) / delMax;
         delG := ( ( ( Maximum - G ) / 6 ) + ( delMax / 2 ) ) / delMax;
         delB := ( ( ( Maximum - B ) / 6 ) + ( delMax / 2 ) ) / delMax;
 
         if  ( R = Maximum ) then
           AH[i,j] :=Round( delB - delG)
         else if ( G = Maximum ) then 
           AH[i,j] := Round(( 1 / 3 ) + delR - delB)
         else if ( B = Maximum ) then
           AH[i,j] := Round(( 2 / 3 ) + delG - delR);
 
         if ( AH[i,j] < 0 ) then
           AH[i,j] += 1;
         if ( AH[i,j] > 1 ) then
           AH[i,j] -= 1;
      end;
   //writeln(AH[i,j]);
   end;
end;
 
function HueToRGB( v1, v2, H: real):real;            
begin
      if ( H < 0 ) then
       H += 1;
      if ( H > 1 ) then
        H -= 1;
      if ( ( 6 * H ) < 1 )then
        Result:= ( v1 + ( v2 - v1 ) * 6 * H );
      if ( ( 2 * H ) < 1 ) then
        Result:= ( v2 );
      if ( ( 3 * H ) < 2 ) then
        Result:= ( v1 + ( v2 - v1 ) * ( ( 2 / 3 ) - H ) * 6 );
      Result:= ( v1 );
end;
 
 
procedure HSLTORGB(w, hei: integer; AH, ASS, AL: pixels; var AR, AG, AB: pixels);
var R, G, B, v2, v1: real;
begin
  for var i:=0 to w-1 do
    for var j:=0 to hei-1 do
    begin
      if ( ASS[i,j] = 0 ) then                      
      begin
       R := AL[i,j] * 255;                      
       G := AL[i,j] * 255;
       B := AL[i,j] * 255;
      end
      else
      begin
        if ( AL[i,j] < 0.5 ) then 
          v2 := AL[i,j] * ( 1 + ASS[i,j] )
        else      
          v2 := ( AL[i,j] + ASS[i,j] ) - ( ASS[i,j] * AL[i,j] );
 
        v1 := 2 * AL[i,j]- v2;
        
        R := 255 * HueToRGB( v1, v2, AH[i,j] + ( 1 / 3 ) );
        G := 255 * HueToRGB( v1, v2, AH[i,j] );
        B := 255 * HueToRGB( v1, v2, AH[i,j] - ( 1 / 3 ) );
        AR[i,j]:=Round(R);
        AG[i,j]:=Round(G);
        AB[i,j]:=Round(B);
      end; 
      //writeln(AR[i,j]);
    end;
end;
 
begin
 
//загружает картинку на экран
  var p:=new Picture('parhod.jpg');
  SetWindowSize(n,m);
  p.draw(0,0);
  
//загружает информацию в массив
  for i:=1 to WindowWidth-1 do
  begin
    for j:=1 to WindowHeight-1 do
    begin
      col:=GetPixel(i,j);
      ARed[i,j]:=col.R;
      AGreen[i,j]:=col.G;
      ABlue[i,j]:=col.B;
      //writeln(AREd[i,j]);
    end;
  end;
w:= WindowWidth;
  h:= WindowHeight;
RGBTOHSL(w, h, ARed, AGreen, ABlue, AH, ASS, AL);
HSLTORGB(w, h, AH, ASS, AL, ARed, AGreen, ABlue);
  
  for i:=1 to WindowWidth-1 do
  begin
    for j:=1 to WindowHeight-1 do
    begin
      SetPixel(i, j, RGB(ARed[i,j], AGreen[i,j], ABlue[i,j]));
    end;
  end;
  LockDrawing;
  UnlockDrawing;
end.

uses crt,graph;
 
var
   x,y,d,r : word;
 
procedure GrInit;
var
  gD,gM,gE:integer;
begin
 
   gD:=detect;
   InitGraph(gD,gM,'');
   gE:=GraphResult;
 
   if gE<>grOk then begin
      writeln('Error = ', GraphErrorMsg(gE));
      halt(1);
   end;
end;
 
 
Begin
 
   GrInit;
 
   SetColor(Yellow);
 
   x:=GetMaxX div 2;
   y:=GetMaxY div 2;
 
   r:=50;
 
   d:=r-10;
 
 
 
   Circle(x, y, r);
 
   Rectangle(x-d,y-d,x+d,y+d);
 
   SetFillStyle(1,white);
 
   FloodFill(x,y,yellow);
 
   readln;
 
   CloseGraph;
End.