Оригинальный DVD-ROM: eXeL@B DVD !
eXeL@B ВИДЕОКУРС !

ВИДЕОКУРС
выпущен 4 ноября!


УЗНАТЬ БОЛЬШЕ >>
Домой | Статьи | RAR-cтатьи | FAQ | Форум | Скачать | Видеокурс
Новичку | Ссылки | Программирование | Интервью | Архив | Связь

БОЛЬШОЙ FAQ ПО DELPHI



Программа для работы с точечной графикой

Я yгадаю этy пpогpаммy с 7 байт!


 unit Functs;
 
 interface
 
 uses
   WinTypes, Classes, Graphics, SysUtils;
 
 type
   TPoint2D = record
     X, Y: Real;
   end;
   TPoint3D = record
     X, Y, Z: Real;
   end;
 
 function Point2D(X, Y: Real): TPoint2D;
 function RoundPoint(P: TPoint2D): TPoint;
 function FloatPoint(P: TPoint): TPoint2D;
 function Point3D(X, Y, Z: Real): TPoint3D;
 function Angle2D(P: TPoint2D): Real;
 function Dist2D(P: TPoint2D): Real;
 function Dist3D(P: TPoint3D): Real;
 function RelAngle2D(PA, PB: TPoint2D): Real;
 function RelDist2D(PA, PB: TPoint2D): Real;
 function RelDist3D(PA, PB: TPoint3D): Real;
 procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
 procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
 procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
 function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
 function DistLine(A, B, C: Real; P: TPoint2D): Real;
 function Dist2P(P, P1, P2: TPoint2D): Real;
 function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
 function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
 function AddPoints(P1, P2: TPoint2D): TPoint2D;
 function SubPoints(P1, P2: TPoint2D): TPoint2D;
 
 function Invert(Col: TColor): TColor;
 function Dark(Col: TColor; Percentage: Byte): TColor;
 function Light(Col: TColor; Percentage: Byte): TColor;
 function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
 function MMix(Cols: array of TColor): TColor;
 function Log(Base, Value: Real): Real;
 function Modulator(Val, Max: Real): Real;
 function M(I, J: Integer): Integer;
 function Tan(Angle2D: Real): Real;
 procedure Limit(var Value: Integer; Min, Max: Integer);
 function Exp2(Exponent: Byte): Word;
 function GetSysDir: string;
 function GetWinDir: string;
 
 implementation
 
 function Point2D(X, Y: Real): TPoint2D;
 begin
 
   Point2D.X := X;
   Point2D.Y := Y;
 end;
 
 function RoundPoint(P: TPoint2D): TPoint;
 begin
 
   RoundPoint.X := Round(P.X);
   RoundPoint.Y := Round(P.Y);
 end;
 
 function FloatPoint(P: TPoint): TPoint2D;
 begin
 
   FloatPoint.X := P.X;
   FloatPoint.Y := P.Y;
 end;
 
 function Point3D(X, Y, Z: Real): TPoint3D;
 begin
 
   Point3D.X := X;
   Point3D.Y := Y;
   Point3D.Z := Z;
 end;
 
 function Angle2D(P: TPoint2D): Real;
 begin
 
   if P.X = 0 then
   begin
     if P.Y > 0 then
       Result := Pi / 2;
     if P.Y = 0 then
       Result := 0;
     if P.Y < 0 then
       Result := Pi / -2;
   end
   else
     Result := Arctan(P.Y / P.X);
 
   if P.X < 0 then
   begin
     if P.Y < 0 then
       Result := Result + Pi;
     if P.Y >= 0 then
       Result := Result - Pi;
   end;
 
   if Result < 0 then
     Result := Result + 2 * Pi;
 end;
 
 function Dist2D(P: TPoint2D): Real;
 begin
 
   Result := Sqrt(P.X * P.X + P.Y * P.Y);
 end;
 
 function Dist3D(P: TPoint3D): Real;
 begin
 
   Dist3d := Sqrt(P.X * P.X + P.Y * P.Y + P.Z * P.Z);
 end;
 
 function RelAngle2D(PA, PB: TPoint2D): Real;
 begin
 
   RelAngle2D := Angle2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
 end;
 
 function RelDist2D(PA, PB: TPoint2D): Real;
 begin
 
   Result := Dist2D(Point2D(PB.X - PA.X, PB.Y - PA.Y));
 end;
 
 function RelDist3D(PA, PB: TPoint3D): Real;
 begin
 
   RelDist3D := Dist3D(Point3D(PB.X - PA.X, PB.Y - PA.Y, PB.Z - PA.Z));
 end;
 
 procedure Rotate2D(var P: TPoint2D; Angle2D: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp.X := P.X * Cos(Angle2D) - P.Y * Sin(Angle2D);
   Temp.Y := P.X * Sin(Angle2D) + P.Y * Cos(Angle2D);
   P := Temp;
 end;
 
 procedure RelRotate2D(var P: TPoint2D; PCentr: TPoint2D; Angle2D: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp := SubPoints(P, PCentr);
   Rotate2D(Temp, Angle2D);
   P := AddPoints(Temp, PCentr);
 end;
 
 procedure Move2D(var P: TPoint2D; Angle2D, Distance: Real);
 var
 
   Temp: TPoint2D;
 begin
 
   Temp.X := P.X + (Cos(Angle2D) * Distance);
   Temp.Y := P.Y + (Sin(Angle2D) * Distance);
   P := Temp;
 end;
 
 function Between(PA, PB: TPoint2D; Preference: Real): TPoint2D;
 begin
 
   Between.X := PA.X * Preference + PB.X * (1 - Preference);
   Between.Y := PA.Y * Preference + PB.Y * (1 - Preference);
 end;
 
 function DistLine(A, B, C: Real; P: TPoint2D): Real;
 begin
 
   Result := (A * P.X + B * P.Y + C) / Sqrt(Sqr(A) + Sqr(B));
 end;
 
 function Dist2P(P, P1, P2: TPoint2D): Real;
 begin
 
   Result := DistLine(P1.Y - P2.Y, P2.X - P1.X, -P1.Y * P2.X + P1.X * P2.Y, P);
 end;
 
 function DistD1P(DX, DY: Real; P1, P: TPoint2D): Real;
 begin
 
   Result := DistLine(DY, -DX, -DY * P1.X + DX * P1.Y, P);
 end;
 
 function NearLine2P(P, P1, P2: TPoint2D; D: Real): Boolean;
 begin
 
   Result := False;
   if DistD1P(-(P2.Y - P1.Y), P2.X - P1.X, P1, P) * DistD1P(-(P2.Y - P1.Y), P2.X
     - P1.X, P2, P) <= 0 then
     if Abs(Dist2P(P, P1, P2)) < D then
       Result := True;
 end;
 
 function AddPoints(P1, P2: TPoint2D): TPoint2D;
 begin
 
   AddPoints := Point2D(P1.X + P2.X, P1.Y + P2.Y);
 end;
 
 function SubPoints(P1, P2: TPoint2D): TPoint2D;
 begin
 
   SubPoints := Point2D(P1.X - P2.X, P1.Y - P2.Y);
 end;
 
 function Invert(Col: TColor): TColor;
 begin
 
   Invert := not Col;
 end;
 
 function Dark(Col: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := GetRValue(Col);
   G := GetGValue(Col);
   B := GetBValue(Col);
   R := Round(R * Percentage / 100);
   G := Round(G * Percentage / 100);
   B := Round(B * Percentage / 100);
   Dark := RGB(R, G, B);
 end;
 
 function Light(Col: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := GetRValue(Col);
   G := GetGValue(Col);
   B := GetBValue(Col);
   R := Round(R * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   G := Round(G * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   B := Round(B * Percentage / 100) + Round(255 - Percentage / 100 * 255);
   Light := RGB(R, G, B);
 end;
 
 function Mix(Col1, Col2: TColor; Percentage: Byte): TColor;
 var
 
   R, G, B: Byte;
 begin
 
   R := Round((GetRValue(Col1) * Percentage / 100) + (GetRValue(Col2) * (100 -
     Percentage) / 100));
   G := Round((GetGValue(Col1) * Percentage / 100) + (GetGValue(Col2) * (100 -
     Percentage) / 100));
   B := Round((GetBValue(Col1) * Percentage / 100) + (GetBValue(Col2) * (100 -
     Percentage) / 100));
   Mix := RGB(R, G, B);
 end;
 
 function MMix(Cols: array of TColor): TColor;
 var
 
   I, R, G, B, Length: Integer;
 begin
 
   Length := High(Cols) - Low(Cols) + 1;
   R := 0;
   G := 0;
   B := 0;
   for I := Low(Cols) to High(Cols) do
   begin
     R := R + GetRValue(Cols[I]);
     G := G + GetGValue(Cols[I]);
     B := B + GetBValue(Cols[I]);
   end;
   R := R div Length;
   G := G div Length;
   B := B div Length;
   MMix := RGB(R, G, B);
 end;
 
 function Log(Base, Value: Real): Real;
 begin
 
   Log := Ln(Value) / Ln(Base);
 end;
 
 function Power(Base, Exponent: Real): Real;
 begin
 
   Power := Ln(Base) * Exp(Exponent);
 end;
 
 function Modulator(Val, Max: Real): Real;
 begin
 
   Modulator := (Val / Max - Round(Val / Max)) * Max;
 end;
 
 function M(I, J: Integer): Integer;
 begin
 
   M := ((I mod J) + J) mod J;
 end;
 
 function Tan(Angle2D: Real): Real;
 begin
 
   Tan := Sin(Angle2D) / Cos(Angle2D);
 end;
 
 procedure Limit(var Value: Integer; Min, Max: Integer);
 begin
 
   if Value < Min then
     Value := Min;
   if Value > Max then
     Value := Max;
 end;
 
 function Exp2(Exponent: Byte): Word;
 var
 
   Temp, I: Word;
 begin
 
   Temp := 1;
   for I := 1 to Exponent do
     Temp := Temp * 2;
   Result := Temp;
 end;
 
 function GetSysDir: string;
 var
 
   Temp: array[0..255] of Char;
 begin
 
   GetSystemDirectory(Temp, 256);
   Result := StrPas(Temp);
 end;
 
 function GetWinDir: string;
 var
 
   Temp: array[0..255] of Char;
 begin
 
   GetWindowsDirectory(Temp, 256);
   Result := StrPas(Temp);
 end;
 
 end.
 




<< ВЕРНУТЬСЯ В ОГЛАВЛЕНИЕ



Материалы находятся на сайте https://exelab.ru/pro/



Оригинальный DVD-ROM: eXeL@B DVD !


Вы находитесь на EXELAB.rU
Проект ReactOS