Скачать: DOM.PAS
В программе применены:
Код
uses Graph, CRT;
var
Gd, Gm : Integer;
type
XY = record
X : Integer;
Y : Integer;
end;
procedure LineXY(A, B : XY);
begin
Line(A.X, A.Y, B.X, B.Y);
end;
procedure AddXY(A, B : XY; var Res : XY);
begin
Res.X := A.X + B.X;
Res.Y := A.Y + B.Y;
end;
procedure SubXY(A, B : XY; var Res : XY);
begin
Res.X := A.X - B.X;
Res.Y := A.Y - B.Y;
end;
procedure MulXY(A : XY; L : Integer; var Res : XY);
begin
Res.X := A.X * L;
Res.Y := A.Y * L;
end;
procedure CopyXY(A : XY; var Res : XY);
begin
Res.X := A.X;
Res.Y := A.Y;
end;
procedure DrawRect(Origin, Dir1, Dir2 : XY;
X1, Y1, X2, Y2 : Integer; Fill, Draw : Boolean);
var
a, b, c, d, e, f, g : XY;
Points : array[1 .. 5] of XY;
begin
MulXY(Dir1, X1, a);
MulXY(Dir1, X2, b);
MulXY(Dir2, Y1, c);
MulXY(Dir2, Y2, d);
AddXY(Origin, a, e);
AddXY(e, c, Points[1]);
AddXY(e, d, Points[2]);
AddXY(Origin, b, f);
AddXY(f, d, Points[3]);
AddXY(f, c, Points[4]);
CopyXY(Points[1], Points[5]);
if Fill then
FillPoly(5, Points);
if Draw then
DrawPoly(5, Points);
end;
procedure DrawWall(Origin, Dir1, Dir2 : XY;
L1, L2 : Integer; Oddity : Boolean);
{ Рисует кирпичную стену }
var
i, j : Integer;
a, b, c, d, e : XY;
Poly : array[1 .. 5] of XY;
begin
{ Внешний контур }
CopyXY(Origin, Poly[1]);
MulXY(Dir1, L1, c);
MulXY(Dir2, L2, d);
AddXY(c, d, e);
AddXY(Origin, c, Poly[2]);
AddXY(Origin, e, Poly[3]);
AddXY(Origin, d, Poly[4]);
CopyXY(Origin, Poly[5]);
FillPoly(5, Poly);
DrawPoly(5, Poly);
{ Кирпичи }
for i := 1 to L2 - 1 do
begin
{ Line(Origin + Dir2 * i,
Origin + Dir2 * i + Dir1 * L1) }
MulXY(Dir2, i, a);
AddXY(Origin, a, b);
AddXY(b, c, d);
LineXY(b, d);
end;
for i := 1 to L2 do
begin
MulXY(Dir2, i - 1, a);
AddXY(Origin, a, b);
MulXY(Dir2, i, a);
AddXY(Origin, a, c);
for j := 1 to L1 - 1 do
begin
if ((i mod 2) = 1) xor ((j mod 2) = 1) xor Oddity then
begin
{ Line(Origin + Dir2 * (i - 1) + Dir1 * j,
Origin + Dir2 * i + Dir1 * j) }
MulXY(Dir1, j, a);
AddXY(b, a, d);
AddXY(c, a, e);
LineXY(d, e);
end;
end;
end;
end;
type XYC = record
X, Y, C : LongInt; { проективные координаты }
end;
procedure XY2XYC(A : XY; var Res : XYC);
begin
Res.X := A.X;
Res.Y := A.Y;
Res.C := 1;
end;
procedure XYC2XY(A : XYC; var Res : XY);
var
ResX, ResY : LongInt;
begin
ResX := A.X div A.C;
ResY := A.Y div A.C;
Res.X := ResX;
Res.Y := ResY;
end;
procedure IncidXYC(A, B : XYC; var Res : XYC);
begin
Res.X := A.Y * B.C - A.C * B.Y;
Res.Y := -A.C * B.X + A.X * B.C;
Res.C := A.X * B.Y - A.Y * B.X;
end;
procedure Intersect(a1, a2, b1, b2 : XY; var Res : XY);
{ Точка пересечения линий a1a2 и b1b2 }
var pa1, pa2, pb1, pb2, { проективные координаты точек a1, a2, b1 и b2 }
pal, pbl, { проективные координаты линий a1a2 и b1b2 }
pRes : XYC; { проективные координаты точки пересечения }
begin
XY2XYC(a1, pa1); XY2XYC(a2, pa2); XY2XYC(b1, pb1); XY2XYC(b2, pb2);
IncidXYC(pa1, pa2, pal);
IncidXYC(pb1, pb2, pbl);
IncidXYC(pal, pbl, pRes);
XYC2XY(pRes, Res);
end;
procedure Cloud(X, Y : Integer);
const CloudImage : array[1 .. 7] of String =
(' . . . . ',
' . . . . . . ',
' . . . . . . . . ',
' . . . . . . . . . . ',
' . . . . . . . . . . ',
' . . . . . . . . ',
' ');
var
i, j : Integer;
begin
for i := 1 to 7 do
for j := 1 to Length(CloudImage[1]) do
if CloudImage[i, j] = '.' then
PutPixel(X + j - 1, Y + i - 1, LightGray);
end;
var
a, b, c, d, e, f, g, h, i, j, k, l, m, n, o,
p, q, r, s, t, u, v, w, x, y, z, a0, b0, c0 : XY;
Roof : array[1 .. 5] of XY;
Roof2 : array[1 .. 4] of XY;
Shadow : array[1 .. 9] of XY;
begin
Gd := VGA;
Gm := VGAHi; { 640x480 }
InitGraph(Gd, Gm, 'X:\BP');
{ Небо }
SetFillStyle(SolidFill, LightCyan);
Bar(0, 0, 639, 479);
{ Облака }
Cloud( 89, 91); Cloud( 90, 82); Cloud( 11, 91); Cloud( 72, 98);
Cloud( 52, 27); Cloud( 42, 77); Cloud( 98, 58); Cloud( 48, 12);
Cloud( 67, 62); Cloud(167, 34); Cloud( 62, 73); Cloud(363, 54);
Cloud(122, 46); Cloud( 40, 46); Cloud( 27, 26); Cloud( 49, 23);
{ Трава }
SetFillStyle(SolidFill, LightGreen);
FillEllipse(320, 380, 500, 200);
{ Кирпичные стены }
SetLineStyle(SolidLn, 0, NormWidth);
SetColor(Black);
SetFillStyle(SolidFill, Brown);
a.X := 200;
a.Y := 150;
b.X := 10;
b.Y := 0;
c.X := 0;
c.Y := 10;
DrawWall(a, b, c, 20, 20, False);
MulXY(b, 20, d);
AddXY(a, d, e);
f.X := 5;
f.Y := -5;
DrawWall(e, f, c, 20, 20, True);
{ Крыша }
MulXY(b, 4, g);
SubXY(a, g, h);
MulXY(f, 4, i);
SubXY(h, i, Roof[1]);
AddXY(e, g, j);
SubXY(j, i, Roof[2]);
CopyXY(Roof[2], Roof2[1]);
MulXY(f, 20 + 4, k);
AddXY(e, k, l);
AddXY(l, g, Roof2[2]);
MulXY(f, 10, m);
AddXY(a, m, n);
MulXY(c, 9, o);
SubXY(n, o, p);
MulXY(b, 10 - 4, q);
AddXY(p, q, Roof[4]);
MulXY(b, 10 + 4, r);
AddXY(p, r, Roof[3]);
CopyXY(Roof[3], Roof2[3]);
CopyXY(Roof[1], Roof[5]);
CopyXY(Roof2[1], Roof2[4]);
SetFillStyle(SolidFill, LightGray);
FillPoly(5, Roof);
DrawPoly(5, Roof);
SetFillStyle(SolidFill, DarkGray);
FillPoly(4, Roof2);
DrawPoly(4, Roof2);
{ Тень }
s.X := 8;
s.Y := 3;
MulXY(c, 20, t);
MulXY(s, 20, u);
AddXY(t, u, v);
AddXY(a, t, Shadow[1]);
AddXY(a, v, w);
AddXY(Roof[1], v, Shadow[3]);
MulXY(f, 20 + 4 + 4, x);
AddXY(Shadow[3], x, y);
Intersect(Shadow[1], w, Shadow[3], y, Shadow[2]);
AddXY(Roof[2], v, Shadow[4]);
AddXY(Roof2[2], v, Shadow[5]);
AddXY(e, t, Shadow[8]);
MulXY(f, 20, z);
AddXY(Shadow[8], z, Shadow[7]);
SubXY(Shadow[7], u, a0);
Intersect(Shadow[5], y, Shadow[7], a0, Shadow[6]);
CopyXY(Shadow[1], Shadow[9]);
SetFillStyle(SolidFill, Green);
FillPoly(9, Shadow);
{ Дверь }
SetFillStyle(SolidFill, Red);
DrawRect(e, f, c, 7, 8, 13, 20, True, True);
{ Окно }
SetColor(White);
SetFillStyle(SolidFill, Blue);
DrawRect(a, b, c, 6, 6, 14, 14, True, True);
DrawRect(a, b, c, 10, 6, 14, 14, True, True);
DrawRect(a, b, c, 10, 6, 14, 9, True, True);
{ Табличка }
SetColor(Blue);
SetFillStyle(SolidFill, White);
DrawRect(a, b, c, 1, 2, 19, 5, True, True);
SetTextStyle(5, HorizDir, 1);
OutTextXY(a.X + b.X * 1 + c.X * 1 + 3, a.Y + b.Y * 2 + c.Y * 2,
'Дом-2: Перестройка');
while not KeyPressed do
Delay(200);
CloseGraph;
end.
var
Gd, Gm : Integer;
type
XY = record
X : Integer;
Y : Integer;
end;
procedure LineXY(A, B : XY);
begin
Line(A.X, A.Y, B.X, B.Y);
end;
procedure AddXY(A, B : XY; var Res : XY);
begin
Res.X := A.X + B.X;
Res.Y := A.Y + B.Y;
end;
procedure SubXY(A, B : XY; var Res : XY);
begin
Res.X := A.X - B.X;
Res.Y := A.Y - B.Y;
end;
procedure MulXY(A : XY; L : Integer; var Res : XY);
begin
Res.X := A.X * L;
Res.Y := A.Y * L;
end;
procedure CopyXY(A : XY; var Res : XY);
begin
Res.X := A.X;
Res.Y := A.Y;
end;
procedure DrawRect(Origin, Dir1, Dir2 : XY;
X1, Y1, X2, Y2 : Integer; Fill, Draw : Boolean);
var
a, b, c, d, e, f, g : XY;
Points : array[1 .. 5] of XY;
begin
MulXY(Dir1, X1, a);
MulXY(Dir1, X2, b);
MulXY(Dir2, Y1, c);
MulXY(Dir2, Y2, d);
AddXY(Origin, a, e);
AddXY(e, c, Points[1]);
AddXY(e, d, Points[2]);
AddXY(Origin, b, f);
AddXY(f, d, Points[3]);
AddXY(f, c, Points[4]);
CopyXY(Points[1], Points[5]);
if Fill then
FillPoly(5, Points);
if Draw then
DrawPoly(5, Points);
end;
procedure DrawWall(Origin, Dir1, Dir2 : XY;
L1, L2 : Integer; Oddity : Boolean);
{ Рисует кирпичную стену }
var
i, j : Integer;
a, b, c, d, e : XY;
Poly : array[1 .. 5] of XY;
begin
{ Внешний контур }
CopyXY(Origin, Poly[1]);
MulXY(Dir1, L1, c);
MulXY(Dir2, L2, d);
AddXY(c, d, e);
AddXY(Origin, c, Poly[2]);
AddXY(Origin, e, Poly[3]);
AddXY(Origin, d, Poly[4]);
CopyXY(Origin, Poly[5]);
FillPoly(5, Poly);
DrawPoly(5, Poly);
{ Кирпичи }
for i := 1 to L2 - 1 do
begin
{ Line(Origin + Dir2 * i,
Origin + Dir2 * i + Dir1 * L1) }
MulXY(Dir2, i, a);
AddXY(Origin, a, b);
AddXY(b, c, d);
LineXY(b, d);
end;
for i := 1 to L2 do
begin
MulXY(Dir2, i - 1, a);
AddXY(Origin, a, b);
MulXY(Dir2, i, a);
AddXY(Origin, a, c);
for j := 1 to L1 - 1 do
begin
if ((i mod 2) = 1) xor ((j mod 2) = 1) xor Oddity then
begin
{ Line(Origin + Dir2 * (i - 1) + Dir1 * j,
Origin + Dir2 * i + Dir1 * j) }
MulXY(Dir1, j, a);
AddXY(b, a, d);
AddXY(c, a, e);
LineXY(d, e);
end;
end;
end;
end;
type XYC = record
X, Y, C : LongInt; { проективные координаты }
end;
procedure XY2XYC(A : XY; var Res : XYC);
begin
Res.X := A.X;
Res.Y := A.Y;
Res.C := 1;
end;
procedure XYC2XY(A : XYC; var Res : XY);
var
ResX, ResY : LongInt;
begin
ResX := A.X div A.C;
ResY := A.Y div A.C;
Res.X := ResX;
Res.Y := ResY;
end;
procedure IncidXYC(A, B : XYC; var Res : XYC);
begin
Res.X := A.Y * B.C - A.C * B.Y;
Res.Y := -A.C * B.X + A.X * B.C;
Res.C := A.X * B.Y - A.Y * B.X;
end;
procedure Intersect(a1, a2, b1, b2 : XY; var Res : XY);
{ Точка пересечения линий a1a2 и b1b2 }
var pa1, pa2, pb1, pb2, { проективные координаты точек a1, a2, b1 и b2 }
pal, pbl, { проективные координаты линий a1a2 и b1b2 }
pRes : XYC; { проективные координаты точки пересечения }
begin
XY2XYC(a1, pa1); XY2XYC(a2, pa2); XY2XYC(b1, pb1); XY2XYC(b2, pb2);
IncidXYC(pa1, pa2, pal);
IncidXYC(pb1, pb2, pbl);
IncidXYC(pal, pbl, pRes);
XYC2XY(pRes, Res);
end;
procedure Cloud(X, Y : Integer);
const CloudImage : array[1 .. 7] of String =
(' . . . . ',
' . . . . . . ',
' . . . . . . . . ',
' . . . . . . . . . . ',
' . . . . . . . . . . ',
' . . . . . . . . ',
' ');
var
i, j : Integer;
begin
for i := 1 to 7 do
for j := 1 to Length(CloudImage[1]) do
if CloudImage[i, j] = '.' then
PutPixel(X + j - 1, Y + i - 1, LightGray);
end;
var
a, b, c, d, e, f, g, h, i, j, k, l, m, n, o,
p, q, r, s, t, u, v, w, x, y, z, a0, b0, c0 : XY;
Roof : array[1 .. 5] of XY;
Roof2 : array[1 .. 4] of XY;
Shadow : array[1 .. 9] of XY;
begin
Gd := VGA;
Gm := VGAHi; { 640x480 }
InitGraph(Gd, Gm, 'X:\BP');
{ Небо }
SetFillStyle(SolidFill, LightCyan);
Bar(0, 0, 639, 479);
{ Облака }
Cloud( 89, 91); Cloud( 90, 82); Cloud( 11, 91); Cloud( 72, 98);
Cloud( 52, 27); Cloud( 42, 77); Cloud( 98, 58); Cloud( 48, 12);
Cloud( 67, 62); Cloud(167, 34); Cloud( 62, 73); Cloud(363, 54);
Cloud(122, 46); Cloud( 40, 46); Cloud( 27, 26); Cloud( 49, 23);
{ Трава }
SetFillStyle(SolidFill, LightGreen);
FillEllipse(320, 380, 500, 200);
{ Кирпичные стены }
SetLineStyle(SolidLn, 0, NormWidth);
SetColor(Black);
SetFillStyle(SolidFill, Brown);
a.X := 200;
a.Y := 150;
b.X := 10;
b.Y := 0;
c.X := 0;
c.Y := 10;
DrawWall(a, b, c, 20, 20, False);
MulXY(b, 20, d);
AddXY(a, d, e);
f.X := 5;
f.Y := -5;
DrawWall(e, f, c, 20, 20, True);
{ Крыша }
MulXY(b, 4, g);
SubXY(a, g, h);
MulXY(f, 4, i);
SubXY(h, i, Roof[1]);
AddXY(e, g, j);
SubXY(j, i, Roof[2]);
CopyXY(Roof[2], Roof2[1]);
MulXY(f, 20 + 4, k);
AddXY(e, k, l);
AddXY(l, g, Roof2[2]);
MulXY(f, 10, m);
AddXY(a, m, n);
MulXY(c, 9, o);
SubXY(n, o, p);
MulXY(b, 10 - 4, q);
AddXY(p, q, Roof[4]);
MulXY(b, 10 + 4, r);
AddXY(p, r, Roof[3]);
CopyXY(Roof[3], Roof2[3]);
CopyXY(Roof[1], Roof[5]);
CopyXY(Roof2[1], Roof2[4]);
SetFillStyle(SolidFill, LightGray);
FillPoly(5, Roof);
DrawPoly(5, Roof);
SetFillStyle(SolidFill, DarkGray);
FillPoly(4, Roof2);
DrawPoly(4, Roof2);
{ Тень }
s.X := 8;
s.Y := 3;
MulXY(c, 20, t);
MulXY(s, 20, u);
AddXY(t, u, v);
AddXY(a, t, Shadow[1]);
AddXY(a, v, w);
AddXY(Roof[1], v, Shadow[3]);
MulXY(f, 20 + 4 + 4, x);
AddXY(Shadow[3], x, y);
Intersect(Shadow[1], w, Shadow[3], y, Shadow[2]);
AddXY(Roof[2], v, Shadow[4]);
AddXY(Roof2[2], v, Shadow[5]);
AddXY(e, t, Shadow[8]);
MulXY(f, 20, z);
AddXY(Shadow[8], z, Shadow[7]);
SubXY(Shadow[7], u, a0);
Intersect(Shadow[5], y, Shadow[7], a0, Shadow[6]);
CopyXY(Shadow[1], Shadow[9]);
SetFillStyle(SolidFill, Green);
FillPoly(9, Shadow);
{ Дверь }
SetFillStyle(SolidFill, Red);
DrawRect(e, f, c, 7, 8, 13, 20, True, True);
{ Окно }
SetColor(White);
SetFillStyle(SolidFill, Blue);
DrawRect(a, b, c, 6, 6, 14, 14, True, True);
DrawRect(a, b, c, 10, 6, 14, 14, True, True);
DrawRect(a, b, c, 10, 6, 14, 9, True, True);
{ Табличка }
SetColor(Blue);
SetFillStyle(SolidFill, White);
DrawRect(a, b, c, 1, 2, 19, 5, True, True);
SetTextStyle(5, HorizDir, 1);
OutTextXY(a.X + b.X * 1 + c.X * 1 + 3, a.Y + b.Y * 2 + c.Y * 2,
'Дом-2: Перестройка');
while not KeyPressed do
Delay(200);
CloseGraph;
end.