{        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.