sapynhos
(usa Outra)
Enviado em 07/03/2016 - 19:49h
Isso foi feito para rodar no XP, queria no WIN8
unit UMaiorIVDN;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ComCtrls, ExtCtrls, FileCtrl, StdCtrls, Mask, Buttons, ToolWin;
type
TForm1 = class(TForm)
Panel1: TPanel;
DriveComboBox1: TDriveComboBox;
DirectoryListBox1: TDirectoryListBox;
FileListBox1: TFileListBox;
Panel2: TPanel;
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
Edit2: TEdit;
Edit3: TEdit;
Edit4: TEdit;
Edit5: TEdit;
GroupBox1: TGroupBox;
CheckBox1: TCheckBox;
CheckBox2: TCheckBox;
CheckBox3: TCheckBox;
StaticText1: TStaticText;
CheckBox4: TCheckBox;
Edit1: TEdit;
Label5: TLabel;
Label6: TLabel;
Edit6: TEdit;
RadioButton1: TRadioButton;
RadioButton2: TRadioButton;
ToolBar1: TToolBar;
SpeedButton1: TSpeedButton;
procedure DriveComboBox1Change(Sender: TObject);
procedure DirectoryListBox1Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure RadioButton2Click(Sender: TObject);
procedure RadioButton1Click(Sender: TObject);
procedure SpeedButton1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
uses Unit2;
{$R *.DFM}
const LONGa1 : real = -53.1425; // um número inicial de minha escolha
const LONGq : real = 0.0400; // fator somador do próximo ponto de longitude
const LATa1 : real = 3.6232; // um número inicial de minha escolha
const LATq : real = -0.0398; // fator somador do próximo ponto de latitude
const TAM : integer = 700; //Tamanho da matriz quadrada
const MAXDIAS : integer = 100;
type M = array [1..700, 1..700, 1..100] of real;
Var NLAT, NLONG : integer;
MATRIZ : M;
LATS, LATI, LONGE, LONGD : string;
rLatS, rLatI, rLongE, rLongD : real;
procedure TForm1.DriveComboBox1Change(Sender: TObject);
begin
DirectoryListBox1.Drive := DriveComboBox1.Drive;
FileListBox1.Drive := DriveComboBox1.Drive;
FileListBox1.Directory := DirectoryListBox1.Directory;
end;
procedure TForm1.DirectoryListBox1Change(Sender: TObject);
begin
FileListBox1.Directory := DirectoryListBox1.Directory;
end;
//verifica de há inconsistencias nos dados
function VerificaDados(LatS, LatI, LongE, LongD : string) : boolean;
begin
try
rLatS := strToFloat(LatS);
rLatI := strToFloat(LatI);
rLongE := strToFloat(LongE);
rLongD := strToFloat(LongD);
if((rLatS >= rLatI) and (rLongD >= rLongE)) then
result := true
else result := false;
except result := false;
end;
end;
// ajusta a longitude devido a pequenas diferenças do
// mesmo ponto entre imagens diferentes
function retornarLongitude(Longitude : integer):real;
begin
result := LONGa1 + (longitude - 1)*LONGq;
end;
function ajustarLongitude(longitude : real): real;
begin
// Uma P.A. an = a1 + (n -1)*q
NLONG := round(((longitude - LONGa1)/LONGq) + 1.0); // posiciona na long que desejo
// encontra a nova lontidude
result := retornarLongitude(NLONG);
end;
// da mesma forma para latitude
function retornarLatitude(NLAT: integer):real;
begin
result := LATa1 + (NLAT - 1.0)*LATq;
end;
function ajustarLatitude(latitude : real): real;
begin
// Uma P.A. an = a1 + (n -1)*q
NLAT := round(((latitude - LATa1)/LATq) + 1.0); // posiciona na long que desejo
// encontra a nova latitude
result := retornarLatitude(NLAT);
end;
function pontoOk(long, lat : integer) : boolean;
begin
if ((retornarLongitude(long) >= rLONGE) and (retornarLongitude(long) <= rLONGD)) then
if ((retornarLatitude(lat) >= rLATI) and (retornarLatitude(lat) <= rLATS )) then
result := true
else result:= false
else result := false;
end;
// Preenche a Matriz
procedure preencheMatriz(ValorEntrada : real);
var dia : integer;
begin
dia := 1;
while(Matriz[NLONG,NLAT,dia] <> 0.000) do
dia := dia + 1;
Matriz[NLONG,NLAT,dia] := ValorEntrada;
end;
function buscarMaior(long, lat : integer):real;
var dia : integer;
maior, valor : real;
begin
// varre a Matriz a procura do maior valor para cada ponto
maior := 0.0000;
dia := 1;
valor := MATRIZ[long,lat,dia];
while (( valor <> 0.0000) and (dia <= MAXDIAS)) do begin
if valor > maior then
maior := valor;
dia := dia + 1;
valor := MATRIZ[long,lat,dia];
end;
result := maior;
end;
//********************************************************
//********************************************************
// calcula a média do IVDN em cada ponto da imagem
//********************************************************
//********************************************************
function calcularMedia(long, lat: integer):real;
var dia, n : integer;
soma, valor, media : real;
begin
// varre a Matriz a procura do maior valor para cada ponto
media := 0.0000;
dia := 1;
n := 0;
soma := 0.0000;
valor := MATRIZ[long,lat,dia];
while (( valor <> 0.0000) and (dia <= MAXDIAS)) do begin
soma := soma + valor;
n := n + 1;
dia := dia + 1;
valor := MATRIZ[long,lat,dia];
end;
if (soma > 0.000) then
media := soma / n
else media := 0;
result := media;
end;
function retornarLinha(long, lat : integer; valor : real): string;
var sLongitude, sLatitude, sValor : string;
i : integer;
begin
sLongitude := formatfloat('##0.0000',retornarLongitude(long));
sLatitude := formatfloat('##0.0000',retornarLatitude(lat));
sValor := formatfloat('0.0000', valor);
for i := 1 to (14 - length(sLongitude)) do
sLongitude := ' ' + sLongitude;
for i := 1 to (14 - length(SLatitude)) do
sLatitude := ' ' + sLatitude;
for i := 1 to (14 - length(sValor)) do
sValor := ' ' + sValor;
result := sLongitude + sLatitude + sValor;
end;
procedure calculaMedia(path: string);
var fout : textfile;
linha : string;
long,lat : integer;
media, valor, soma : real;
dia : integer;
latitude, longitude : real;
slatitude, slongitude, sMedia : string;
i,n : integer;
begin
try
assignfile(fout,path + 'ValorMedio.txt');
rewrite(fout);
// varre a Matriz a procura do maior valor para cada ponto
for lat := 1 to TAM do
for long := 1 to TAM do
if pontoOk(long,lat) then begin
media := calcularMedia(long, lat);
if media > 0.0000 then begin
writeln(fout,retornarLinha(long,lat,media));
end;
end; // for
except
end;
closefile(fout);
end;
// Procura maior valor de IVDN para cada ponto
procedure procuraMaior(path : string);
var fout : textfile;
linha : string;
long,lat : integer;
maior, valor : real;
dia : integer;
latitude, longitude : real;
slatitude, slongitude, sValor : string;
i : integer;
begin
try
// cria arquivo de saida .txt
assignfile(fout,path + 'MaiorValor.txt');
rewrite(fout);
// varre a Matriz a procura do maior valor para cada ponto
for lat := 1 to TAM do
for long := 1 to TAM do
if (pontoOk(long,lat)) then begin
maior := 0.0000;
dia := 1;
valor := MATRIZ[long,lat,dia];
while ((valor <> 0.0000) and (dia <= MAXDIAS)) do begin
if valor > maior then
maior := valor;
dia := dia + 1;
valor := MATRIZ[long,lat,dia];
end;
if (maior > 0.000) then begin
linha := retornarLinha(long,lat,maior);
writeln(fout,linha);
end;
end; // if
except
showmessage('Não foi possível criar o arquivo de saída');
end;
closefile(fout);
end;
// Lê os arquivos e recorta a área de interesse
procedure recortarArea(path, nomeDoArquivo,LatS, LatI, LongE, LongD : string);
var fin : textfile; //arquivo de entrada
fout: textfile; //arquivo de saída
linha, novalinha : string;
valorEntrada : real; //limites de área
latitude, longitude : real;
code,i : integer;
S, Slongitude, Slatitude : string;
begin
s := '';
try
// lê o arquivo txt de entrada gerado pelo ENVI
assignfile(fin, path + nomeDoArquivo);
reset(fin);
// pula 5 linhas
for i := 1 to 5 do readln(fin,linha);
// leitura linha-a-linha do arquivo de entrada
while not eof(fin) do begin
readln(fin,linha);
val(copy(linha,29,14),valorEntrada,code);
val(copy(linha,1,14),longitude,code);
val(copy(linha,15,14),latitude,code);
longitude := ajustarLongitude(longitude);
latitude := ajustarLatitude(latitude);
// verifica se o valor é menor ou igual a zero e despreza
if (valorEntrada < 0.0000) then begin
// verifica se a longitude está dentro da área
if ((longitude >= rLongE) and (longitude <= rLongD)) then begin
if ((latitude <= rLatS) and (latitude >= rLatI)) then begin
preencheMatriz(ValorEntrada);
end; // if latitude
end; // if longitude
end; // if valor de entrada
end; // while não fim do arquivo
except
end;
closefile(fin);
end;
procedure mediaDosPontos(path : string; fator : integer);
var fout : textfile;
novalat, novalong, sublat, sublong : integer;
novoTam :integer;
valor, acumulado, media : real;
totalDeZeros : integer;
linha, zeros : string;
lat, long : integer;
verLat, verLong : real;
begin
try
zeros := form1.Edit6.text;
assignfile(fout, path + 'ValorMedio' + inttostr(fator) + '.txt');
rewrite(fout);
// novo tamanho da matriz
novoTam := trunc(TAM/fator);
for novaLat := 1 to novoTam do
for novaLong := 1 to novoTam do begin
media := 0.0000;
totalDeZeros := 0;
acumulado := 0;
for subLat := 1 to fator do
for subLong := 1 to fator do begin
long := subLong + (novaLong - 1)* fator;
lat := subLat + (novaLat - 1)* fator;
if pontoOk(long,lat) then begin
valor := BuscarMaior(long,lat);
if (valor = 0.000) then
totalDeZeros := totaldeZeros + 1;
acumulado := acumulado + valor;
end;
end;
//calcula média
if (totalDeZeros <= strToint(zeros)) then
if (acumulado > 0.0000) then begin
media := acumulado / (fator * fator - totalDeZeros);
linha := retornarLinha(long - trunc((fator + 1)/2) , lat - trunc((fator+1)/2) , media);
//grava em arquivo
writeln(fout,linha);
end;
end;
except
showmessage('Não foi possível criar arquivo fator de saida');
end;
closefile(fout);
end;
procedure TForm1.Button1Click(Sender: TObject);
var TotalDeArquivos : integer;
path : string;
nomeDoArquivo : string;
indice, i, j, k : integer;
begin
// inicialização das constantes
TotalDeArquivos := FileListBox1.Items.Count;
LatS := Edit2.Text;
LatI := Edit3.Text;
LongE := Edit4.Text;
LongD := Edit5.Text;
button1.Enabled := false;
if (VerificaDados(LatS, LatI, LongE, LongD)) then
if ((TotalDeArquivos > 0) and (TotalDeArquivos <= MAXDIAS)) then begin
// limpar Matriz 3D (Lat, Long, Valor) com valores zerados
for i := 1 to TAM do
for j := 1 to TAM do
for k := 1 to MAXDIAS do
Matriz[i,j,k] := 0.000;
path := DirectoryListBox1.Directory + '\';
for indice := 0 to TotalDeArquivos - 1 do begin
nomeDoArquivo := FileListBox1.Items.Strings[indice];
statictext1.caption := nomeDoArquivo;
// selecionar área e ajusta lat e long
recortarArea(path, nomeDoArquivo,LatS, LatI, LongE, LongD);
// gera arquivo final maior valor;
if checkbox1.Checked then
procuraMaior(path);
// gera arquivo final media;
if checkbox2.Checked then
calculaMedia(path);
// gera arquivo diário
//if checkbox3.Checked then
//calculaDiario(path);
if checkbox4.Checked then
// calcular média ponto
mediaDosPontos(path, strtoint(edit1.text));
end;
end
else showmessage('Não há arquivos selecionados ou é maior que 31')
else showmessage('Dados informados incorretos');
button1.Enabled := true;
showmessage('fim');
end;
procedure TForm1.RadioButton2Click(Sender: TObject);
begin
Edit2.Text := '-6.0000';
Edit3.Text := '-8.5000';
Edit4.Text := '-39.0000';
Edit5.Text := '-34.0000';
end;
procedure TForm1.RadioButton1Click(Sender: TObject);
begin
Edit2.Text := '-0.0000';
Edit3.Text := '-18.5000';
Edit4.Text := '-49.0000';
Edit5.Text := '-34.0000';
end;
procedure TForm1.SpeedButton1Click(Sender: TObject);
begin
form2.show;
end;
end.
