home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Delphi Programming Unleashed
/
Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso
/
units
/
image2.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1995-03-20
|
8KB
|
354 lines
unit Image2;
{$N+}
{$Define VER70}
interface
uses
{$IfnDef Windows}
Crt,
{$Else}
WinTypes,
{$EndIf}
Objects,
Strings;
const
MaxSize = 1024;
type
TColorMap = record
Zero: Char;
Red: Char;
Green: Char;
Blue: Char;
end;
PDemHeader = ^TDemHeader;
TDemHeader = record
ID: array[0..31] of Char;
Name: array[0..31] of Char;
Comment: array[0..63] of Char;
Compression: LongInt;
HeaderType: LongInt;
Reserved: array[0..887] of Char;
ColorMap: array[0..255] of TColorMap;
end;
PYValues = ^TYValues;
TYValues = array[1..MaxSize] of Integer;
TValues = array[1..MaxSize] of PYValues;
PVista = ^TVista;
TVista = Object(TObject)
Max: Integer;
Tests: Boolean;
FileInMem: Boolean;
LowNum, HighNum: LongInt;
Image: TValues;
DemHeader: TDemHeader;
constructor Init(IMax: Integer; Test: Boolean);
destructor Done; virtual;
procedure DoSquare(x, y, Distance, NewValue: Integer);
procedure DoRaise(XPos, YPos, Width, NewValue: Integer);
function Validate(v: Integer): Boolean;
procedure SetPoint(x, y, v: Integer);
function GetPoint(x, y: Integer): Integer;
procedure WritePoints(FN: String); virtual;
procedure WriteTextPoints(FN: String); virtual;
procedure ReadPoints(FN: String); virtual;
procedure MakeDemHeader(iName, iComment: PChar);
procedure WriteDem(FN: String);
procedure ReadDem(FN: String); virtual;
procedure ReadDemArea(FN: String; LinesToSkip: LongInt);
procedure WriteDemArea(FN: String; LinesToSkip: LongInt);
procedure SetHighLow;
function TranHeight(i: Integer): LongInt;
function TranHeight2(i: Integer): Double;
end;
implementation
constructor TVista.Init(IMax: Integer; Test: Boolean);
var
i: Integer;
begin
inherited Init;
Max := IMax;
Tests := Test;
for i := 1 to Max do
New(Image[i]);
HighNum := 0;
LowNum := 100000;
FileInMem := False;
end;
destructor TVista.Done;
var
i: Integer;
begin
for i := 1 to Max do
if Image[i] <> nil then Dispose(Image[i]);
inherited Done;
end;
procedure TVista.DoSquare(x, y, Distance, NewValue: Integer);
var
i,j: Integer;
OldValue: Integer;
begin
for j := y to y + Distance do
for i := x to x + Distance do begin
if (i < Max) and (i > 0) and (j < Max) and (j > 0) then begin
OldValue := GetPoint(i, j);
SetPoint(i, j, NewValue + OldValue);
end;
end;
end;
procedure TVista.DoRaise(XPos, YPos, Width, NewValue: Integer);
var
Start: TPoint;
NewNum, i: Integer;
begin
NewNum := GetPoint(XPos, YPos) + NewValue;
SetPoint(XPos, YPos, NewNum);
Start.x := XPos;
Start.y := YPos;
for i := 1 to Width do begin
Dec(Start.x);
Dec(Start.y);
DoSquare(Start.x, Start.y, i * 2, NewValue);
end;
SetPoint(XPos, YPos, NewNum);
end;
function TVista.Validate(v: Integer): Boolean;
begin
Validate := True;
if not Tests then exit;
if (v <= HighNum) and (v > LowNum) then
Exit
else
Validate := False;
end;
procedure TVista.SetPoint(x, y, v: Integer);
begin
if Validate(v) then
Image[x]^[y] := v;
end;
function TVista.GetPoint(x, y: Integer): Integer;
begin
if (x > 0) and (x <= Max) and (y > 0) and (y <= Max) then
GetPoint := Image[x]^[y]
else
GetPoint := 0;
end;
procedure TVista.WritePoints(FN: String);
var
F: File of TYValues;
i, j: Integer;
YValues: TYValues;
begin
Assign(F, FN);
ReWrite(F);
for i := 1 to Max do begin
for j := 1 to Max do
YValues[j] := GetPoint(j, i);
Write(F, YValues);
end;
Close(F);
end;
procedure TVista.WriteTextPoints(FN: String);
var
F: Text;
i, j, Val: Integer;
begin
Assign(F, FN);
ReWrite(F);
for i := 1 to Max do begin
for j := 1 to Max do begin
Val := GetPoint(j, i);
if j < 200 then
Write(F, Val, ' ');
end;
WriteLn(F);
{$IfnDef Windows}
GotoXY(1, 1); WriteLn(i);
{$EndIf}
end;
Close(F);
end;
procedure TVista.ReadPoints(FN: String);
var
F: File;
YValues: TYValues;
i, j: Integer;
Result: Integer;
begin
HighNum := 1000000;
LowNum := -1000000;
Assign(F, FN);
Reset(F);
for i := 1 to Max do begin
BlockRead(F, YValues, Max * SizeOf(Integer), Result);
for j := 1 to Max do
SetPoint(j, i, YValues[j]);
end;
Close(F);
HighNum := 0;
LowNum := 100000;
SetHighLow;
FileInMem := True;
end;
procedure TVista.MakeDemHeader(iName, iComment: PChar);
begin
FillChar(DemHeader, SizeOf(TDemHeader), #0);
with DemHeader do begin
StrCopy(ID, 'Vista DEM File');
StrCopy(Name, iName);
StrCopy(Comment, iComment);
Compression := 0;
HeaderType := 0;
end;
end;
procedure TVista.WriteDem(FN: String);
var
F: File;
i, j: Integer;
YValues: TYValues;
Result: Integer;
begin
Assign(F, FN);
ReWrite(F, 1);
BlockWrite(F, DemHeader, SizeOf(DemHeader), Result);
for i := 1 to Max do begin
for j := 1 to Max do
YValues[j] := GetPoint(j, (Max) - i);
BlockWrite(F, YValues, Max * SizeOf(Integer), Result);
end;
Close(F);
end;
procedure TVista.ReadDem(FN: String);
var
F: File;
YValues: TYValues;
i, j: Integer;
Result: Integer;
begin
HighNum := 1000000;
LowNum := -1000000;
Assign(F, FN);
Reset(F, 1);
BlockRead(F, DemHeader, SizeOf(DemHeader), Result);
Seek(F, 2048);
for i := 1 to Max do begin
BlockRead(F, YValues, Max * SizeOf(Integer), Result);
for j := 1 to Max do
SetPoint(j, (Max + 1) - i, YValues[j]);
end;
Close(F);
HighNum := 0;
LowNum := 100000;
SetHighLow;
FileInMem := True;
end;
procedure TVista.ReadDemArea(FN: String; LinesToSkip: LongInt);
var
F: File;
YValues: TYValues;
i, j: Integer;
Result: Integer;
begin
HighNum := 1000000;
LowNum := -1000000;
Assign(F, FN);
Reset(F, 1);
BlockRead(F, DemHeader, SizeOf(DemHeader), Result);
Seek(F, 2048);
Seek(F, 1028 * LinesToSkip);
for i := 1 to Max do begin
BlockRead(F, YValues, Max * SizeOf(Integer), Result);
for j := 1 to Max do
SetPoint(j, (Max + 1) - i, YValues[j]);
BlockRead(F, YValues, (Max * SizeOf(Integer)) - 4, Result);
end;
Close(F);
HighNum := 0;
LowNum := 100000;
SetHighLow;
FileInMem := True;
end;
procedure TVista.WriteDemArea(FN: String; LinesToSkip: LongInt);
var
F: File;
YValues: TYValues;
Distance, i, j: LongInt;
Result: Integer;
begin
Distance := 1028;
Assign(F, FN);
Reset(F, 1);
Seek(F, 2048);
for i := 1 to Max - 3 do begin
for j := 1 to Max do
YValues[j] := GetPoint(j, (Max) - i);
Seek(F, (Distance * LinesToSkip) + (i * Distance));
BlockWrite(F, YValues, Max * SizeOf(Integer), Result);
end;
Close(F);
end;
procedure TVista.SetHighLow;
var
x, y, j: Integer;
begin
for y := 1 to Max do begin
for x := 1 to Max do begin
if x = 258 then
x := x;
j := GetPoint(x, y);
if J > 1000 then
j := j;
if j < LowNum then LowNum := j;
if j > HighNum then HighNum := j;
if j < 0 then SetPoint(x, y, Random(15));
end;
end;
if LowNum < 0 then LowNum := 0;
end;
function TVista.TranHeight(i: Integer): LongInt;
var
Temp1, Temp, x: LongInt;
begin
Temp1 := i;
Temp := Temp1 * LongInt(255);
x := Temp div LongInt(HighNum);
TranHeight := x
end;
{ Use this one with Shape3d or whenever Z has a small range }
function TVista.TranHeight2(i: Integer): Double;
var
Temp1, Temp, x: Double;
begin
Temp1 := i;
Temp := Temp1 * 10.0;
x := Temp / HighNum;
TranHeight2 := x
end;
end.