Информационный сервер для программистов: Исходники со всего света. Паскальные исходники со всего света
  Powered by Поисковый сервер Яndex: Найдется ВСЁ!
На Главную Исходники Форум Информер Страны мира
   Дата и Время    >>    calenfun
   
 
 Функции календарных вычислений   Victor Ostashev 08.08.1996

Набор функций для работы с датами и вычислений по календарю.



2k 
 

{ Calendar.pas набор функций для работы с датами и вычислений по календарю. Автор: Виктор Осташев Fido: 2:5020/1194 E-mail: v_ostashev@chat.ru WWW: http://ostashev.newmail.ru } unit calendar; interface type tdate = record d : byte; m : byte; y : integer; end; {Хранит дату} tstyle = (grigorian, julian); {Старый стиль - это юлианский, а новый - григорианский} function datein(low, high, dt : tdate) : boolean; {Проверяет нахождение даты в промежутке между low и high} procedure stringtodate(st : string; var dt : tdate); {Преобразует строку в дату} procedure datetostring(dt : tdate; var st : string); {Преобразует дату в строку} function compdate(d1, d2 : tdate) : integer; {Сравнивает две даты. Возвращает 0, если даты равны, -1, если первая дата меньше второй и 1, если наоборот} function numofday(dat : tdate; style : tstyle) : longint; {Вычисляет условный номер дня для даты dat с учетом нового стиля при style=true} function dayofweek(dat : tdate; style : tstyle) : byte; {Вычисляет день недели для даты dat с учетом нового стиля при style=true} function numinyear(dat : tdate; style : tstyle) : word; {Вычисляет номер дня от начала года с учетом стиля} function lenofmonth(month: byte; year: word; style: tstyle): byte; {Вычисляет длину месяца с учетом стиля} procedure numtodate(num: longint; style: tstyle; var dat: tdate); {Вычисляет дату по данному номеру дня} function isleap(year : integer):boolean; {Является ли год високосным} implementation function datein; begin datein := (compdate(low, dt) <= 0) and (compdate(high, dt) >= 0); end; procedure stringtodate; var s : array[1..3] of string[5]; i, j : integer; begin for i := 1 to 3 do s[i] := ''; j := 1; for i := 1 to 3 do begin while (st[j] in ['0'..'9']) and (j <= length(st)) do begin s[i] := s[i]+st[j]; inc(j); end; inc(j); end; val(s[1], dt.d, i); val(s[2], dt.m, i); val(s[3], dt.y, i); end; procedure datetostring; var s1, s2, s3 : string[5]; begin str(dt.d, s1); str(dt.m, s2); str(dt.y, s3); if dt.d < 10 then s1 := '0'+s1; if dt.m < 10 then s2 := '0'+s2; st := s1+'.'+s2+'.'+s3; end; function compdate; var a, b : longint; begin {Нет никакой разницы по какому стилю номер дня} a:= numofday(d1,julian); b:= numofday(d2,julian); if a-b = 0 then compdate := 0; if a-b > 0 then compdate := 1; if a-b < 0 then compdate := -1; end; function numofday; var stcor : integer; begin {По формуле num=[year*365.25]+[(month+1)*30.6]+day+style} {Вычисляем поправку на григорианский стиль} if style = grigorian then begin stcor := 2-dat.y div 100+dat.y div 400; if ((dat.y mod 100 = 0) and (dat.y mod 400 <> 0)) and (dat.m <= 2) then stcor := stcor + 1; end else begin stcor := 0; end; {Сразу увеличить месяц} inc(dat.m); {Если месяц январь и февраль, то month=month+12, year=year-1} if dat.m <= 3 then begin dat.m := dat.m+12; dec(dat.y); end; {Вычисляем номер дня} numofday := (36525*dat.y) div 100 + (306*dat.m) div 10 + stcor + dat.d; end; function dayofweek; var sum : real; day : byte; buf : longint; begin buf := numofday(dat, style); {Прибавляем константу 4.5 - так по формуле} buf := buf+4; day := buf mod 7; {Воскресеньем у нас кончается неделя} if day = 0 then day := 7; dayofweek := day; end; function lenofmonth; var len : byte; begin case month of 2 : begin if year mod 4 = 0 then len := 29 else len := 28; if (style = grigorian) and (year mod 100 = 0) and (year mod 400 > 0) then len := 28; end; 4, 6, 9, 11 : len := 30 else len := 31; end; lenofmonth := len; end; function numinyear; var dbuf : tdate; begin dbuf.d := 0; dbuf.m := 1; dbuf.y := dat.y; numinyear := word(numofday(dat, style)-numofday(dbuf, style)); end; procedure numtodate; begin {Приблизительно находим год и для гарантии прибавляем 5, чтобы точно промахнуться в известную сторону} dat.y := (num*100) div 36525 + 5; dat.d := 1; dat.m := 1; {А здесь спускаемся и находим год перебором} repeat dec(dat.y); until (num >= numofday(dat, style)); {А здесь ищем перебором месяц, поднимаясь вверх} repeat inc(dat.m); until (num < numofday(dat, style)); {Промахнулись на 1 месяц вверх} dec(dat.m); {А уж что у нас осталось - то день месяца} dat.d := num-numofday(dat, style)+1; end; function isleap; begin isleap := (((year mod 4 = 0) and (year mod 100 <> 0)) or (year mod 400 = 0)); end; end.