ReadChunkName;
if ChunkName<>'WAVE' then OK:= False;
{Считываем ChunkName "fmt_"}
ReadChunkName;
if ChunkName<>'fmt ' then OK:= False;
{Считываем ChunkSize}
ReadChunkSize;
fmtSize:= ChunkSize.lint; {должно быть 18}
{Считываем formatTag, nChannels}
ReadChunkSize;
ChunkSize.x:= M1;
formatTag:= ChunkSize.up;
nChannels:= ChunkSize.dn;
{Считываем nSamplesPerSec}
ReadChunkSize;
nSamplesPerSec := ChunkSize.lint;
{Считываем nAvgBytesPerSec}
ReadChunkSize;
nAvgBytesPerSec:= ChunkSize.lint;
{Считываем nBlockAlign}
ChunkSize.x:= F0;
ChunkSize.lint:= 0;
for i:= 0 to 3 do begin
Read(InFile, MM);
ChunkSize.chrs[I]:= MM;
end;
ChunkSize.x:= M1;
nBlockAlign:= ChunkSize.up;
{Считываем nBitsPerSample}
nBitsPerSample:= ChunkSize.dn;
for I:= 17 to fmtSize do Read(InFile,MM);
NoDataYet:= True;
while NoDataYet do begin
{Считываем метку блока данных "data"}
ReadChunkName;
{Считываем DataSize}
ReadChunkSize;
DataSize:= ChunkSize.lint;
if ChunkName <> 'data' then begin
for I:= 1 to DataSize do {пропуск данных, не относящихся к набору звуковых данных}
Read(InFile, MM);
end else NoDataYet:= False;
end;
nDataBytes:= DataSize;
{Наконец, начинаем считывать данные для байтов nDataBytes}
if nDataBytes>0 then DataYet:= True;
N:=0; {чтение с первой позиции}
while DataYet do begin
ReadOneDataBlock(Ki,Kj); {получаем 4 байта}
nDataBytes:= nDataBytes-4;
if nDataBytes<=4 then DataYet:= False;
end;
ScaleData(Ki);
if Ki.WAV.nChannels=2 then begin Kj.WAV:= Ki.WAV;
ScaleData(Kj);
end;
{Освобождаем буфер файла}
CloseFile(InFile);
end else begin
InitSpecs;{файл не существует}
InitSignals(Ki);{обнуляем массив "Ki"}
InitSignals(Kj);{обнуляем массив "Kj"}
end;
end; { ReadWAVFile}
{================= Операции с набором данных ====================} const MaxNumberOfDataBaseItems = 360; type SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;
VAR DataBaseFile: file of Observation; LastDataBaseItem: LongInt; {Номер текущего элемента набора данных} ItemNameS: array[SignalDirectoryIndex] of String[40];
procedure GetDatabaseItem(Kk : Observation; N : LongInt); begin if N<MaxNumberOfDataBaseItems then begin Seek(DataBaseFile, N); Read(DataBaseFile, Kk); end else InitSignals(Kk); end; {GetDatabaseItem}
procedure PutDatabaseItem(Kk : Observation; N : LongInt); begin if N<MaxNumberOfDataBaseItems then if N<=LastDataBaseItem then begin Seek(DataBaseFile, N); Write(DataBaseFile, Kk); LastDataBaseItem:= LastDataBaseItem+1; end else while lastdatabaseitem<=n do begin Seek(DataBaseFile, LastDataBaseItem); Write(DataBaseFile, Kk); LastDataBaseItem:= LastDataBaseItem+1; end else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems} end; {PutDatabaseItem}
procedure InitDataBase; begin LastDataBaseItem:= 0; if FileExists(StandardDataBase) then begin Assign(DataBaseFile,StandardDataBase); Reset(DataBaseFile); while not EOF(DataBaseFile) do begin GetDataBaseItem(K0R, LastDataBaseItem); ItemNameS[LastDataBaseItem]:= K0R.Name; LastDataBaseItem:= LastDataBaseItem+1; end; if EOF(DataBaseFile) then if LastDataBaseItem>0 then LastDataBaseItem:= LastDataBaseItem-1; end; end; {InitDataBase}
function FindDataBaseName(Nstg: String): LongInt; var ThisOne : LongInt; begin ThisOne:= 0; FindDataBaseName:= –1; while ThisOne<LastDataBaseItem do begin if Nstg = ItemNameS[ThisOne] then begin FindDataBaseName:= ThisOne; Exit; end; ThisOne:= ThisOne+1; end; end; {FindDataBaseName}
{======================= Инициализация модуля ========================} procedure InitLinearSystem; begin BaseFileName:= '\PROGRA~1\SIGNAL~1\'; StandardOutput:= BaseFileName + 'K0.wav'; StandardInput:= BaseFileName + 'K0.wav'; StandardDataBase:= BaseFileName + 'Radar.sdb'; InitAllSignals; InitDataBase; ReadWAVFile(K0R,K0B); ScaleAllData; end; {InitLinearSystem}
begin {инициализируемый модулем код} InitLinearSystem; end. {Unit LinearSystem}
interface
function checkdate(date : string): boolean; function Date2julian(date : string): longint; function Julian2date(julian : longint): string; function DayOfTheWeek(date: string): string; function idag: string;
implementation
uses sysutils;
function idag() : string; {Получает текущую дату и возвращает ее в формате YYYYMMDD для использования другими функциями данного модуля.} var Year, Month, Day: Word; begin DecodeDate(Now, Year, Month, Day); result:= IntToStr(year)+ IntToStr(Month) +IntToStr(day); end;
function Date2julian(date : string) : longint; {Получает дату в формате YYYYMMDD. Если у вас другой формат, в первую очередь преобразуйте его.} var month, day, year:integer; ta, tb, tc : longint; begin month:= strtoint(copy(date,5,2)); day:= strtoint(copy(date,7,2)); year:= strtoint(copy(date,1,4)); if month > 2 then month:= month – 3 else begin month:= month + 9; year:= year – 1; end; ta:= 146097 * (year div 100) div 4; tb:= 1461 * (year MOD 100) div 4; tc:= (153 * month + 2) div 5 + day + 1721119; result:= ta + tb + tc end;
function mdy2date(month, day, year : integer): string; var y, m, d : string; begin y:= '000'+inttostr(year); y:= copy(y,length(y)-3,4); m:= '0'+inttostr(month); m:= copy(m,length(m)-1,2); d:= '0'+inttostr(day); d:= copy(d,length(d)-1,2); result:= y+m+d; end;
function Julian2date(julian : longint): string; {Получает значение и возвращает дату в формате YYYYMMDD} var x,y,d,m : longint; month,day,year : integer; begin x:= 4 * julian – 6884477; y:= (x div 146097) * 100; d:= (x MOD 146097) div 4; x:= 4 * d + 3; y:= (x div 1461) + y; d:= (x MOD 1461) div 4 + 1; x:= 5 * d – 3; m:= x div 153 + 1; d:= (x MOD 153) div 5 + 1; if m < 11 then month:= m + 2 else month:= m – 10; day:= d; year:= y + m div 11; result:= mdy2date(month, day, year); end;
function checkdate(date : string): boolean; {Дата должна быть в формате YYYYMMDD.} var julian: longint; test: string; begin {Сначала преобразовываем строку в юлианский формат даты. Это позволит получить необходимое значение.} julian:= Date2julian(date); {Затем преобразовываем полученную величину в дату. Это всегда будет правильной датой. Для проверки делаем обратное преобразование. Результат проверки передаем как выходной параметр функции.} test:= Julian2date(julian); if date = test then result:= true else result:= false; end;
function DayOfTheWeek(date : string): string; {Получаем дату в формате YYYYMMDD и возвращаем день недели.} var julian: longint; begin julian:= (Date2julian(date)) MOD 7; case julian of 0: result:= 'Понедельник'; 1: result := 'Вторник'; 2: result:= 'Среда'; 3: result:= 'Четверг'; 4: result:= 'Пятница'; 5: result:= 'Суббота'; 6: result:= 'Воскресенье'; end; end;
{================= Операции с набором данных ====================} const MaxNumberOfDataBaseItems = 360; type SignalDirectoryIndex = 0..MaxNumberOfDataBaseItems;
VAR DataBaseFile: file of Observation; LastDataBaseItem: LongInt; {Номер текущего элемента набора данных} ItemNameS: array[SignalDirectoryIndex] of String[40];
procedure GetDatabaseItem(Kk : Observation; N : LongInt); begin if N<MaxNumberOfDataBaseItems then begin Seek(DataBaseFile, N); Read(DataBaseFile, Kk); end else InitSignals(Kk); end; {GetDatabaseItem}
procedure PutDatabaseItem(Kk : Observation; N : LongInt); begin if N<MaxNumberOfDataBaseItems then if N<=LastDataBaseItem then begin Seek(DataBaseFile, N); Write(DataBaseFile, Kk); LastDataBaseItem:= LastDataBaseItem+1; end else while lastdatabaseitem<=n do begin Seek(DataBaseFile, LastDataBaseItem); Write(DataBaseFile, Kk); LastDataBaseItem:= LastDataBaseItem+1; end else ReportError(1); {Попытка чтения MaxNumberOfDataBaseItems} end; {PutDatabaseItem}
procedure InitDataBase; begin LastDataBaseItem:= 0; if FileExists(StandardDataBase) then begin Assign(DataBaseFile,StandardDataBase); Reset(DataBaseFile); while not EOF(DataBaseFile) do begin GetDataBaseItem(K0R, LastDataBaseItem); ItemNameS[LastDataBaseItem]:= K0R.Name; LastDataBaseItem:= LastDataBaseItem+1; end; if EOF(DataBaseFile) then if LastDataBaseItem>0 then LastDataBaseItem:= LastDataBaseItem-1; end; end; {InitDataBase}
function FindDataBaseName(Nstg: String): LongInt; var ThisOne : LongInt; begin ThisOne:= 0; FindDataBaseName:= –1; while ThisOne<LastDataBaseItem do begin if Nstg = ItemNameS[ThisOne] then begin FindDataBaseName:= ThisOne; Exit; end; ThisOne:= ThisOne+1; end; end; {FindDataBaseName}
{======================= Инициализация модуля ========================} procedure InitLinearSystem; begin BaseFileName:= '\PROGRA~1\SIGNAL~1\'; StandardOutput:= BaseFileName + 'K0.wav'; StandardInput:= BaseFileName + 'K0.wav'; StandardDataBase:= BaseFileName + 'Radar.sdb'; InitAllSignals; InitDataBase; ReadWAVFile(K0R,K0B); ScaleAllData; end; {InitLinearSystem}
begin {инициализируемый модулем код} InitLinearSystem; end. {Unit LinearSystem}
Даты
Вычисление даты Пасхи
function TtheCalendar.CalcEaster:String; var B,D,E,Q:Integer; GF:String; begin B:= 225-11*(Year Mod 19); D:= ((B-21)Mod 30)+21; If d>48 then Dec(D); E:= (Year+(Year Div 4)+d+1) Mod 7; Q:= D+7-E; If q<32 then begin If ShortDateFormat[1]='d' then Result:= IntToStr(Q)+'/3/'+IntToStr(Year) else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year); end else begin If ShortDateFormat[1]='d' then Result:= IntToStr(Q-31)+'/4/'+IntToStr(Year) else Result:='4/'+IntToStr(Q-31)+'/'+IntToStr(Year); end; {вычисление страстной пятницы} If Q<32 then begin If ShortDateFormat[1]='d' then GF:= IntToStr(Q-2)+'/3/'+IntToStr(Year) else GF:='3/'+IntToStr(Q-2)+'/'+IntToStr(Year); end else begin If ShortDateFormat[1]='d' then GF:= IntToStr(Q-31-2)+'/4/'+IntToStr(Year) else GF:='4/'+IntToStr(Q-31-2)+'/'+IntToStr(Year); end; end;Дни недели
Кто-нибудь пробовал написать функцию, возвращающую для определенной даты день недели? Моя функция как раз этим и занимается. unit datefunc;interface
function checkdate(date : string): boolean; function Date2julian(date : string): longint; function Julian2date(julian : longint): string; function DayOfTheWeek(date: string): string; function idag: string;
implementation
uses sysutils;
function idag() : string; {Получает текущую дату и возвращает ее в формате YYYYMMDD для использования другими функциями данного модуля.} var Year, Month, Day: Word; begin DecodeDate(Now, Year, Month, Day); result:= IntToStr(year)+ IntToStr(Month) +IntToStr(day); end;
function Date2julian(date : string) : longint; {Получает дату в формате YYYYMMDD. Если у вас другой формат, в первую очередь преобразуйте его.} var month, day, year:integer; ta, tb, tc : longint; begin month:= strtoint(copy(date,5,2)); day:= strtoint(copy(date,7,2)); year:= strtoint(copy(date,1,4)); if month > 2 then month:= month – 3 else begin month:= month + 9; year:= year – 1; end; ta:= 146097 * (year div 100) div 4; tb:= 1461 * (year MOD 100) div 4; tc:= (153 * month + 2) div 5 + day + 1721119; result:= ta + tb + tc end;
function mdy2date(month, day, year : integer): string; var y, m, d : string; begin y:= '000'+inttostr(year); y:= copy(y,length(y)-3,4); m:= '0'+inttostr(month); m:= copy(m,length(m)-1,2); d:= '0'+inttostr(day); d:= copy(d,length(d)-1,2); result:= y+m+d; end;
function Julian2date(julian : longint): string; {Получает значение и возвращает дату в формате YYYYMMDD} var x,y,d,m : longint; month,day,year : integer; begin x:= 4 * julian – 6884477; y:= (x div 146097) * 100; d:= (x MOD 146097) div 4; x:= 4 * d + 3; y:= (x div 1461) + y; d:= (x MOD 1461) div 4 + 1; x:= 5 * d – 3; m:= x div 153 + 1; d:= (x MOD 153) div 5 + 1; if m < 11 then month:= m + 2 else month:= m – 10; day:= d; year:= y + m div 11; result:= mdy2date(month, day, year); end;
function checkdate(date : string): boolean; {Дата должна быть в формате YYYYMMDD.} var julian: longint; test: string; begin {Сначала преобразовываем строку в юлианский формат даты. Это позволит получить необходимое значение.} julian:= Date2julian(date); {Затем преобразовываем полученную величину в дату. Это всегда будет правильной датой. Для проверки делаем обратное преобразование. Результат проверки передаем как выходной параметр функции.} test:= Julian2date(julian); if date = test then result:= true else result:= false; end;
function DayOfTheWeek(date : string): string; {Получаем дату в формате YYYYMMDD и возвращаем день недели.} var julian: longint; begin julian:= (Date2julian(date)) MOD 7; case julian of 0: result:= 'Понедельник'; 1: result := 'Вторник'; 2: result:= 'Среда'; 3: result:= 'Четверг'; 4: result:= 'Пятница'; 5: result:= 'Суббота'; 6: result:= 'Воскресенье'; end; end;