home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programming Unleashed / Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso / units / image2.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-03-21  |  7.7 KB  |  354 lines
  1. unit Image2;
  2. {$N+}
  3. {$Define VER70}
  4. interface
  5. uses
  6. {$IfnDef Windows}
  7.  Crt,
  8. {$Else}
  9.  WinTypes,
  10. {$EndIf}
  11.  Objects,
  12.  Strings;
  13.  
  14. const
  15.   MaxSize = 1024;
  16.  
  17. type
  18.   TColorMap = record
  19.     Zero: Char;
  20.     Red: Char;
  21.     Green: Char;
  22.     Blue: Char;
  23.   end;
  24.  
  25.   PDemHeader = ^TDemHeader;
  26.   TDemHeader = record
  27.     ID: array[0..31] of Char;
  28.     Name: array[0..31] of Char;
  29.     Comment: array[0..63] of Char;
  30.     Compression: LongInt;
  31.     HeaderType: LongInt;
  32.     Reserved: array[0..887] of Char;
  33.     ColorMap: array[0..255] of TColorMap;
  34.   end;
  35.  
  36.   PYValues = ^TYValues;
  37.   TYValues = array[1..MaxSize] of Integer;
  38.  
  39.   TValues = array[1..MaxSize] of PYValues;
  40.  
  41.   PVista = ^TVista;
  42.   TVista = Object(TObject)
  43.       Max: Integer;
  44.       Tests: Boolean;
  45.       FileInMem: Boolean;
  46.       LowNum, HighNum: LongInt;
  47.       Image: TValues;
  48.       DemHeader: TDemHeader;
  49.     constructor Init(IMax: Integer; Test: Boolean);
  50.     destructor Done; virtual;
  51.     procedure DoSquare(x, y, Distance, NewValue: Integer);
  52.     procedure DoRaise(XPos, YPos, Width, NewValue: Integer);
  53.     function Validate(v: Integer): Boolean;
  54.     procedure SetPoint(x, y, v: Integer);
  55.     function GetPoint(x, y: Integer): Integer;
  56.     procedure WritePoints(FN: String); virtual;
  57.     procedure WriteTextPoints(FN: String); virtual;
  58.     procedure ReadPoints(FN: String); virtual;
  59.     procedure MakeDemHeader(iName, iComment: PChar);
  60.     procedure WriteDem(FN: String);
  61.     procedure ReadDem(FN: String); virtual;
  62.     procedure ReadDemArea(FN: String; LinesToSkip: LongInt);
  63.     procedure WriteDemArea(FN: String; LinesToSkip: LongInt);
  64.     procedure SetHighLow;
  65.     function TranHeight(i: Integer): LongInt;
  66.     function TranHeight2(i: Integer): Double;
  67.   end;
  68.  
  69. implementation
  70.  
  71. constructor TVista.Init(IMax: Integer; Test: Boolean);
  72. var
  73.   i: Integer;
  74. begin
  75.   inherited Init;
  76.   Max := IMax;
  77.   Tests := Test;
  78.   for i := 1 to Max do
  79.     New(Image[i]);
  80.   HighNum := 0;
  81.   LowNum := 100000;
  82.   FileInMem := False;
  83. end;
  84.  
  85. destructor TVista.Done;
  86. var
  87.   i: Integer;
  88. begin
  89.   for i := 1 to Max do
  90.     if Image[i] <> nil then Dispose(Image[i]);
  91.   inherited Done;
  92. end;
  93.  
  94. procedure TVista.DoSquare(x, y, Distance, NewValue: Integer);
  95. var
  96.   i,j: Integer;
  97.   OldValue: Integer;
  98. begin
  99.   for j := y to y + Distance do
  100.     for i := x to x + Distance do begin
  101.       if (i < Max) and (i > 0) and (j < Max) and (j > 0) then begin
  102.         OldValue := GetPoint(i, j);
  103.         SetPoint(i, j, NewValue + OldValue);
  104.       end;
  105.     end;
  106. end;
  107.  
  108. procedure TVista.DoRaise(XPos, YPos, Width, NewValue: Integer);
  109. var
  110.   Start: TPoint;
  111.   NewNum, i: Integer;
  112. begin
  113.   NewNum := GetPoint(XPos, YPos) + NewValue;
  114.   SetPoint(XPos, YPos, NewNum);
  115.   Start.x := XPos;
  116.   Start.y := YPos;
  117.   for i := 1 to Width do begin
  118.     Dec(Start.x);
  119.     Dec(Start.y);
  120.     DoSquare(Start.x, Start.y, i * 2, NewValue);
  121.   end;
  122.   SetPoint(XPos, YPos, NewNum);
  123. end;
  124.  
  125.  
  126. function TVista.Validate(v: Integer): Boolean;
  127. begin
  128.   Validate := True;
  129.   if not Tests then exit;
  130.   if (v <= HighNum) and (v > LowNum) then
  131.     Exit
  132.   else
  133.     Validate := False;
  134. end;
  135.  
  136. procedure TVista.SetPoint(x, y, v: Integer);
  137. begin
  138.   if Validate(v) then
  139.     Image[x]^[y] := v;
  140. end;
  141.  
  142. function TVista.GetPoint(x, y: Integer): Integer;
  143. begin
  144.   if (x > 0) and (x <= Max) and (y > 0) and (y <= Max) then
  145.     GetPoint := Image[x]^[y]
  146.   else
  147.     GetPoint := 0;
  148. end;
  149.  
  150. procedure TVista.WritePoints(FN: String);
  151. var
  152.   F: File of TYValues;
  153.   i, j: Integer;
  154.   YValues: TYValues;
  155. begin
  156.   Assign(F, FN);
  157.   ReWrite(F);
  158.   for i := 1 to Max do begin
  159.     for j := 1 to Max do
  160.       YValues[j] := GetPoint(j, i);
  161.     Write(F, YValues);
  162.   end;
  163.   Close(F);
  164. end;
  165.  
  166. procedure TVista.WriteTextPoints(FN: String);
  167. var
  168.   F: Text;
  169.   i, j, Val: Integer;
  170. begin
  171.   Assign(F, FN);
  172.   ReWrite(F);
  173.   for i := 1 to Max do begin
  174.     for j := 1 to Max do begin
  175.       Val := GetPoint(j, i);
  176.       if j < 200 then
  177.         Write(F, Val, ' ');
  178.     end;
  179.     WriteLn(F);
  180.     {$IfnDef Windows}
  181.     GotoXY(1, 1); WriteLn(i);
  182.     {$EndIf}
  183.   end;
  184.   Close(F);
  185. end;
  186.  
  187. procedure TVista.ReadPoints(FN: String);
  188. var
  189.   F: File;
  190.   YValues: TYValues;
  191.   i, j: Integer;
  192.   Result: Integer;
  193. begin
  194.   HighNum := 1000000;
  195.   LowNum := -1000000;
  196.   Assign(F, FN);
  197.   Reset(F);
  198.   for i := 1 to Max do begin
  199.     BlockRead(F, YValues, Max * SizeOf(Integer), Result);
  200.     for j := 1 to Max do
  201.       SetPoint(j, i, YValues[j]);
  202.   end;
  203.   Close(F);
  204.   HighNum := 0;
  205.   LowNum := 100000;
  206.   SetHighLow;
  207.   FileInMem := True;
  208. end;
  209.  
  210. procedure TVista.MakeDemHeader(iName, iComment: PChar);
  211. begin
  212.   FillChar(DemHeader, SizeOf(TDemHeader), #0);
  213.   with DemHeader do begin
  214.     StrCopy(ID, 'Vista DEM File');
  215.     StrCopy(Name, iName);
  216.     StrCopy(Comment, iComment);
  217.     Compression := 0;
  218.     HeaderType := 0;
  219.   end;
  220. end;
  221.  
  222. procedure TVista.WriteDem(FN: String);
  223. var
  224.   F: File;
  225.   i, j: Integer;
  226.   YValues: TYValues;
  227.   Result: Integer;
  228. begin
  229.   Assign(F, FN);
  230.   ReWrite(F, 1);
  231.   BlockWrite(F, DemHeader, SizeOf(DemHeader), Result);
  232.   for i := 1 to Max do begin
  233.     for j := 1 to Max do
  234.       YValues[j] := GetPoint(j, (Max) - i);
  235.     BlockWrite(F, YValues, Max * SizeOf(Integer), Result);
  236.   end;
  237.   Close(F);
  238. end;
  239.  
  240. procedure TVista.ReadDem(FN: String);
  241. var
  242.   F: File;
  243.   YValues: TYValues;
  244.   i, j: Integer;
  245.   Result: Integer;
  246. begin
  247.   HighNum := 1000000;
  248.   LowNum := -1000000;
  249.   Assign(F, FN);
  250.   Reset(F, 1);
  251.   BlockRead(F, DemHeader, SizeOf(DemHeader), Result);
  252.   Seek(F, 2048);
  253.   for i := 1 to Max do begin
  254.     BlockRead(F, YValues, Max * SizeOf(Integer), Result);
  255.     for j := 1 to Max do
  256.       SetPoint(j, (Max + 1) - i, YValues[j]);
  257.   end;
  258.   Close(F);
  259.   HighNum := 0;
  260.   LowNum := 100000;
  261.   SetHighLow;
  262.   FileInMem := True;
  263. end;
  264.  
  265. procedure TVista.ReadDemArea(FN: String; LinesToSkip: LongInt);
  266. var
  267.   F: File;
  268.   YValues: TYValues;
  269.   i, j: Integer;
  270.   Result: Integer;
  271. begin
  272.   HighNum := 1000000;
  273.   LowNum := -1000000;
  274.   Assign(F, FN);
  275.   Reset(F, 1);
  276.   BlockRead(F, DemHeader, SizeOf(DemHeader), Result);
  277.   Seek(F, 2048);
  278.   Seek(F, 1028 * LinesToSkip);
  279.   for i := 1 to Max do begin
  280.     BlockRead(F, YValues, Max * SizeOf(Integer), Result);
  281.     for j := 1 to Max do
  282.       SetPoint(j, (Max + 1) - i, YValues[j]);
  283.     BlockRead(F, YValues, (Max * SizeOf(Integer)) - 4, Result);
  284.   end;
  285.   Close(F);
  286.   HighNum := 0;
  287.   LowNum := 100000;
  288.   SetHighLow;
  289.   FileInMem := True;
  290. end;
  291.  
  292. procedure TVista.WriteDemArea(FN: String; LinesToSkip: LongInt);
  293. var
  294.   F: File;
  295.   YValues: TYValues;
  296.   Distance, i, j: LongInt;
  297.   Result: Integer;
  298. begin
  299.   Distance := 1028;
  300.   Assign(F, FN);
  301.   Reset(F, 1);
  302.   Seek(F, 2048);
  303.   for i := 1 to Max - 3 do begin
  304.     for j := 1 to Max do
  305.       YValues[j] := GetPoint(j, (Max) - i);
  306.     Seek(F, (Distance * LinesToSkip) + (i * Distance));
  307.     BlockWrite(F, YValues, Max * SizeOf(Integer), Result);
  308.   end;
  309.   Close(F);
  310. end;
  311.  
  312. procedure TVista.SetHighLow;
  313. var
  314.   x, y, j: Integer;
  315. begin
  316.   for y := 1 to Max do begin
  317.     for x := 1 to Max do begin
  318.       if x = 258 then
  319.         x := x;
  320.       j := GetPoint(x, y);
  321.       if J > 1000 then
  322.         j := j;
  323.       if j < LowNum then LowNum := j;
  324.       if j > HighNum then HighNum := j;
  325.       if j < 0 then SetPoint(x, y, Random(15));
  326.     end;
  327.   end;
  328.   if LowNum < 0 then LowNum := 0;
  329. end;
  330.  
  331. function TVista.TranHeight(i: Integer): LongInt;
  332. var
  333.   Temp1, Temp, x: LongInt;
  334. begin
  335.   Temp1 := i;
  336.   Temp := Temp1 * LongInt(255);
  337.   x := Temp div LongInt(HighNum);
  338.   TranHeight := x
  339. end;
  340.  
  341. { Use this one with Shape3d or whenever Z has a small range }
  342. function TVista.TranHeight2(i: Integer): Double;
  343. var
  344.   Temp1, Temp, x: Double;
  345. begin
  346.   Temp1 := i;
  347.   Temp := Temp1 * 10.0;
  348.   x := Temp / HighNum;
  349.   TranHeight2 := x
  350. end;
  351.  
  352. end.
  353.  
  354.