Модуль DISPLAY PAS

unit Display; { Fractal Landscapes 3.0 - Copyright © 1987..1997, Джон Шемитц } interface uses WinTypes, WinProcs, SysUtils, Graphics, Forms, Global, Database; const DrawingNow: boolean = False; AbortDraw: boolean = False; type EAbortedDrawing = class (Exception) end; procedure ScreenColors; procedure PrinterColors; procedure DrawTriangle( Canvas: TCanvas; const A, B, C: TVertex; Plys: word; PointDn: boolean);
procedure DrawVerticals(Canvas: TCanvas);
{$ifdef Debug} const DebugString: string = ''; {$endif} implementation uses Main; type Surfaces = record Outline, Fill: TColor; end; const scrnLand: Surfaces = (Outline: clLime; Fill: clGreen);
scrnWater: Surfaces = (Outline: clBlue; Fill: clNavy);
scrnVertical: Surfaces = (Outline: clGray; Fill: clSilver);
prnLand: Surfaces = (Outline: clBlack; Fill: clWhite);
prnWater: Surfaces = (Outline: clBlack; Fill: clWhite);
prnVertical: Surfaces = (Outline: clBlack; Fill: clWhite);
var Land, Water, Vertical: Surfaces; procedure ScreenColors; begin Land := scrnLand; Water := scrnWater; Vertical := scrnVertical; end; procedure PrinterColors; begin Land := prnLand; Water := prnWater; Vertical := prnVertical; end; function Surface(Outline, Fill: TColor): Surfaces; begin Result.Outline := Outline; Result.Fill := Fill; end; { $define Pascal} {$define Float} {$ifdef Pascal} {$ifdef Float} type TFloatTriple = record X, Y, Z: double; end; function FloatTriple(T: TTriple): TFloatTriple; begin Result.X := T.X / UnitLength; Result.Y := T.Y / UnitLength; Result.Z := T.Z / UnitLength; end; function Project(const P: TTriple): TPixel; { Перспективное преобразование координат точки } var Delta_Y: double; Tr, V: TFloatTriple; begin Tr := FloatTriple(P);
V := FloatTriple(VanishingPoint);
Delta_Y := Tr.Y / V.Y; Result.X := Round( DisplayWidth * ((V.X - Tr.X) * Delta_Y + Tr.X));
Result.Y := DisplayHeight - Round( DisplayHeight * ((V.Z - Tr.Z) * Delta_Y + Tr.Z));
end; {$else} function Project(const Tr: TTriple): TPixel; { Перспективное преобразование координат точки } var Delta_Y: integer; begin Delta_Y := MulDiv(Tr.Y, UnitLength, VanishingPoint.Y);
Result.X := MulDiv( MulDiv ( VanishingPoint.X - Tr.X, Delta_Y, UnitLength) + Tr.X, DisplayWidth, UnitLength);
Result.Y := DisplayHeight - MulDiv( MulDiv( VanishingPoint.Z - Tr.Z, Delta_Y, UnitLength) + Tr.Z, DisplayHeight, UnitLength );
end; {$endif} {$else} function Project(const Tr: TTriple): TPixel; assembler; { Перспективное преобразование координат точки } asm {$ifdef Ver80} {Delphi 1.0; 16-bit} les di,[Tr] mov si,word ptr UnitLength { Масштабный коэффициент } mov ax,[TTriple ptr es:di].Y{ Tr.Y } imul si { Умножаем на LoWord(UnitLength) } idiv VanishingPoint.Y { Scaled(depth/vanishing.depth) } {DeltaY equ bx } mov bx,ax { Сохраняем Delta.Y } mov ax,VanishingPoint.Z sub ax,[TTriple ptr es:di].Z{ Delta.Z } imul bx { Delta.Z * Delta.Y } idiv si { Unscale(Delta.Z * Delta.Y) } add ax,[TTriple ptr es:di].Z { Tr.Z + Unscale(Delta.Z * Delta.Y) } mov cx,[DisplayHeight] { Используем дважды... } imul cx { (Tr.Z+Delta.Z*Delta.Y)*Screen.Row } idiv si { Unscale } sub cx,ax { Px.Y } mov ax,VanishingPoint.X sub ax,[TTriple ptr es:di].X { Delta.X } imul bx { Delta.X * Delta.Y } idiv si { Unscale(Delta.X * Delta.Y) } add ax,[TTriple ptr es:di].X { Tr.X + Unscale(Delta.X * Delta.Y) } imul [DisplayWidth] { (Tr.X+Delta.X*Delta.Y)*Screen.Col} idiv si { Px.X := Unscale(см. выше) } mov dx,cx {Возвращаем (X,Y) в ax:dx} {$else} {Delphi 2.0 or better; 32-bit} push ebx { Delphi 2.0 требует, чтобы } push esi { значения этих регистров } push edi { были сохранены } mov edi,eax { lea edi,[Tr]} push edx { Сохраняем @Result } mov si,word ptr UnitLength { Масштабный коэффициент } mov ax,TTriple[edi].Y { Tr.Y } imul si { Умножаем на } { LoWord(UnitLength) } idiv VanishingPoint.Y { отношение глубины текущей точки к глубине точки перспективы} {DeltaY equ bx } mov bx,ax { Сохраняем Delta.Y } mov ax,VanishingPoint.Z sub ax,TTriple[edi].Z { Delta.Z } imul bx { Delta.Z * Delta.Y } idiv si { Unscale(Delta.Z * Delta.Y) } add ax,TTriple[edi].Z { Tr.Z + Unscale(Delta.Z * Delta.Y) } mov cx,[DisplayHeight] { Используем дважды... } imul cx { (Tr.Z+Delta.Z*Delta.Y)*Screen.Row } idiv si { Unscale } sub cx,ax { Px.Y } mov ax,VanishingPoint.X sub ax,TTriple[edi].X { Delta.X } imul bx { Delta.X * Delta.Y } idiv si { Unscale(Delta.X * Delta.Y) } add ax,TTriple[edi].X { Tr.X + Unscale(Delta.X * Delta.Y) } imul [DisplayWidth] { (Tr.X+Delta.X*Delta.Y)*Screen.Col } idiv si { Px.X := Unscale(см. выше) } // Теперь ax=x, cx=y; мы хотим превратить //их в longint // и сохранить в Result mov ebx,$0000FFFF and eax,ebx { Очищаем старшее слово} and ecx,ebx pop edx { Восстанавливаем результат } mov TPixel[edx].X,eax mov TPixel[edx].Y,ecx pop edi pop esi pop ebx {$endif} end; {$endif} procedure DrawPixels(const Canvas: TCanvas; const A, B, C, D: TPixel; const N: word; const Surface: Surfaces);
begin if AbortDraw then raise EAbortedDrawing.Create('');
Canvas.Pen.Color := Surface.Outline; if DrawMode = dmOutline then if N = 3 then Canvas.PolyLine( [A, B, C, A] ) else Canvas.PolyLine( [A, B, C, D, A] ) else begin Canvas.Brush.Color := Surface.Fill; if N = 3 then Canvas.Polygon( [A, B, C] ) else Canvas.Polygon( [A, B, C, D] ) end; end; procedure CalcCrossing(var Low, High, Crossing: TTriple; SetLow: boolean);
var CrossOverRatio: LongInt; begin CrossOverRatio := (SeaLevel - Low.Z) * UnitLength div (High.Z - Low.Z);
{ Расстояние от точки пересечения до A рассчитывается как отношение } { длины отрезка к полной длине AB, умноженное на UnitLength } Crossing := Triple( Low.X + Unscale ((High.X - Low.X) * CrossOverRatio), Low.Y + Unscale((High.Y - Low.Y) * CrossOverRatio), SeaLevel );
if SetLow then Low.Z := SeaLevel; end; procedure DrawVertical(Canvas: TCanvas; const A, B: TTriple; var pA, pB: TPixel);
var pC, pD: TPixel; tC, tD: TTriple; begin tC := A; tC.Z := SeaLevel; pC := Project(tC);
tD := B; tD.Z := SeaLevel; pD := Project(tD);
DrawPixels(Canvas, pA, pB, pD, pC, 4, Vertical);
end; procedure DrawVerticals(Canvas: TCanvas);
type Triad = record T: TTriple; V: TVertex; P: TPixel; end; var Work: Triad; procedure Step( const Start: TVertex; var Front: Triad; var StepDn: GridCoordinate );
var Idx: word; Back, Interpolate: Triad; begin Back.V := Start; Back.T := GetTriple(Back.V);
if Back.T.Z >
SeaLevel then Back.P := Project(Back.T);
for Idx := 1 to EdgeLength do begin Front.V := Back.V; Inc(Work.V.BC);
Dec(StepDn);
Front.T := GetTriple(Front.V);
if Front.T.Z >
SeaLevel then Front.P := Project(Front.T);
case (ord(Back.T.Z >
SeaLevel) shl 1) + ord(Front.T.Z >
SeaLevel) of 1: begin { Задняя точка ниже уровня моря, передняя - выше } CalcCrossing(Back.T, Front.T, Interpolate.T, False);
Interpolate.P := Project (Interpolate.T);
DrawVertical(Canvas, Interpolate.T, Front.T, Interpolate.P, Front.P);
end; 2: begin { Задняя точка выше уровня моря, передняя - ниже } CalcCrossing(Front.T, Back.T, Interpolate.T, False);
Interpolate.P := Project(Interpolate.T);
DrawVertical(Canvas, Back.T, Interpolate.T, Back.P, Interpolate.P);
end; 3: DrawVertical(Canvas, Back.T, Front.T, Back.P, Front.P);
{ Обе точки выше уровня моря } end; Back := Front; end; end; begin Step(C, Work, Work.V.AB );
Step(B, Work, Work.V.CA );
end; function InnerProduct({const} A, B: TTriple): LongInt; begin InnerProduct := IMUL(A.X, B.X) + IMUL(A.Y, B.Y) + IMUL(A.Z, B.Z) ; end; function Delta(A, B: TTriple): TTriple; begin Result := Triple(A.X - B.X, A.Y - B.Y, A.Z - B.Z);
end; function LandColor(const A, B, C: TTriple): TColor; var Center, ToA, ToLight: TTriple; Cos, Angle: double; GrayLevel: integer; begin Center := Triple( (A.X + B.X + C.X) div 3, (A.Y + B.Y + C.Y) div 3, (A.Z + B.Z + C.Z) div 3 );
ToA := Delta(A, Center);
ToLight := Delta(Center, LightSource);
{$ifopt R-} {$define ResetR} {$endif} {$R+} try Cos := InnerProduct(ToA, ToLight) / (Sqrt({Abs(}InnerProduct(ToA, ToA){)}) * Sqrt({Abs(}InnerProduct(ToLight, ToLight){)}) );
try Angle := ArcTan (Sqrt (1 - Sqr (Cos)) / Cos);
except on Exception do Angle := Pi / 2; {ArcCos(0)} end; {$ifdef HighContrast} GrayLevel := 255 - Round(255 * (Abs(Angle) / (Pi / 2)));
{$else} GrayLevel := 235 - Round(180 * (Abs(Angle) / (Pi / 2)));
{$endif} except on Exception {любое исключение} do GrayLevel := 255; { Деление на 0... } end; {$ifdef ResetR} {$R-} {$undef ResetR} {$endif} Result := PaletteRGB(GrayLevel, GrayLevel, GrayLevel);
end; procedure Draw3Vertices( Canvas: TCanvas; const A, B, C: TVertex; Display: boolean);
var Color: TColor; pA, pB, pC, pD, pE: TPixel; tA, tB, tC, tD, tE: TTriple; aBelow, bBelow, cBelow: boolean; begin tA := GetTriple(A);
tB := GetTriple(B);
tC := GetTriple(C);
{$ifdef FloatingTriangles} ta.z := ta.z + random(Envelope shr Plys) - random(Envelope shr Plys);
tb.z := tb.z + random(Envelope shr Plys) - random(Envelope shr Plys);
tc.z := tc.z + random(Envelope shr Plys) - random(Envelope shr Plys);
{$endif} aBelow := tA.Z <= SeaLevel; bBelow := tB.Z <= SeaLevel; cBelow := tC.Z <= SeaLevel; case ord(aBelow) + ord(bBelow) + ord(cBelow) of 0: if Display then { Все вершины выше уровня моря } begin pA := Project(tA);
pB := Project(tB);
pC := Project(tC);
if DrawMode = dmRender then begin Color := LandColor(tA, tB, tC);
DrawPixels( Canvas, pA, pB, pC, pC, 3, Surface(Color, Color));
end else DrawPixels( Canvas, pA, pB, pC, pC, 3, Land);
end; 3: if Display then { Все вершины ниже уровня моря } begin tA.Z := SeaLevel; tB.Z := SeaLevel; tC.Z := SeaLevel; pA := Project(tA);
pB := Project(tB);
pC := Project(tC);
DrawPixels( Canvas, pA, pB, pC, pC, 3, Water);
end; 2: begin { Одна вершина над водой } { Сделаем так, чтобы это была вершина tA } if aBelow then if bBelow then SwapTriples(tA, tC) else SwapTriples(tA, tB);
CalcCrossing(tB, tA, tD, True);
CalcCrossing(tC, tA, tE, True);
pA := Project(tA);
pB := Project(tB);
pC := Project(tC);
pD := Project(tD);
pE := Project(tE);
DrawPixels( Canvas, pD, pB, pC, pE, 4, Water);
if Drawmode = dmRender then begin Color := LandColor(tD, tA, tE);
DrawPixels( Canvas, pD, pA, pE, pE, 3, Surface(Color, Color));
end else DrawPixels( Canvas, pD, pA, pE, pE, 3, Land);
end; 1:begin { Одна вершина под водой } { Сделаем так, чтобы это была вершина tA } if bBelow then SwapTriples(tA, tB) else if cBelow then SwapTriples(tA, tC);
CalcCrossing(tA, tB, tD, False);
CalcCrossing(tA, tC, tE, True);
pA := Project(tA);
pB := Project(tB);
pC := Project(tC);
pD := Project(tD);
pE := Project(tE);
DrawPixels( Canvas, pD, pA, pE, pE, 3, Water);
if DrawMode = dmRender then begin Color := LandColor(tD, tB, tC);
DrawPixels( Canvas, pD, pB, pC, pE, 4, Surface(Color, Color));
end else DrawPixels( Canvas, pD, pB, pC, pE, 4, Land);
end; end; end; procedure DrawTriangle( Canvas: TCanvas; const A, B, C: TVertex; Plys: word; PointDn: boolean);
var AB, BC, CA: TVertex; begin if Plys = 1 then Draw3Vertices(Canvas, A, B, C, (DrawMode <>
dmOutline) OR PointDn) else begin AB := Midpoint(A, B);
BC := Midpoint(B, C);
CA := Midpoint(C, A);
if Plys = 3 then FractalLandscape.DrewSomeTriangles(16);
Dec(Plys);
if PointDn then begin DrawTriangle(Canvas, CA, BC, C, Plys, True);
DrawTriangle(Canvas, AB, B, BC, Plys, True);
DrawTriangle(Canvas, BC, CA, AB, Plys, False);
DrawTriangle(Canvas, A, AB, CA, Plys, True);
end else begin DrawTriangle(Canvas, A, CA, AB, Plys, False);
DrawTriangle(Canvas, BC, CA, AB, Plys, True);
DrawTriangle(Canvas, CA, C, BC, Plys, False);
DrawTriangle(Canvas, AB, BC, B, Plys, False);
end; end; end; begin ScreenColors; end.

Отображение ландшафта может выполняться в трех режимах: каркасном (Outline), c заполнением (Filled) и со светотенью (rendered). В любом из этих режимов ландшафт рисуется как набор треугольников, при этом координаты отдельных вершин TTriple с помощью простого перспективного преобразования пересчитываются в экранные пиксели TPixel, а затем получившийся треугольник рисуется с помощью функции PolyLine или Polygon. Единственное отличие между режимами заключается в том, что в каркасном режиме рисуется обычная «проволочная сетка» без отсечения невидимых линий, а в двух последних режимах порядок вывода и заполнение прямоугольников обеспечивают отсечение невидимых линий методом «грубой силы» (иногда это называется «алгоритмом маляра»). В свою очередь режим со светотенью отличается тем, что цвет каждого треугольника в нем зависит от угла, под которым данная грань расположена по отношению к «солнцу».

Чтобы увеличить правдоподобие изображения, в Draw3Vertices() реализована упрощенная концепция «уровня моря». Любой треугольник, полностью находящийся над уровнем моря, рисуется нормально, а любой треугольник, полностью погруженный в воду, рисуется синим цветом на уровне моря. Если треугольник пересекает уровень моря, FL3 интерполирует точки пересечения, после чего отдельно рисует надводную и подводную части. Хотя для «побережий» такая методика вполне приемлема, с «озерами» дело обстоит сложнее: FL3 рисует воду лишь в тех местах, которые находятся ниже уровня моря.

После завершения прорисовки всех треугольников FL3 рисует вертикальные линии вдоль двух передних краев от уровня моря до всех вершин, которые находятся над водой. Эти линии особенно полезны в заполненном и светотеневом режимах — непрозрачные вертикальные грани будут скрывать «внутреннюю» структуру поверхности.

Содержание раздела

---