program DateRate ;

(*
  From ts@uwasa.fi Sun May 10 00:01:59 1998
  Subject: Adding to a date

  119. *****
  Q: What is the Pascal code to add a number of days to a date?

  A: The code is given below, but first you need to obtain
  303573 May 2 1991 ftp://garbo.uwasa.fi/pc/turbopas/nrpas13.zip
  nrpas13.zip Numerical Recipes Pascal shareware version, 303K!
  Extract caldat.pas and julday.pas from the archive. Replace all
  occurrences of "integer" with "longint" in those two routines. After
  that you can apply the DATEADD procedure tested below.
  ...

  A2: Robert Prins (prinsra@wcg.co.uk) kindly sent me the following
  useful procedures for Julian day numbers and their inverse. Note
  that the arguments of the routines are in a lightly different order
  than in the Numerical Recipes solution.
  ...
  --------------------------------------------------------------------
  *)

uses DateProx, RAHPDATE ;

(* Routines would be faster with  type real = extended ; *)

(* NRPAS13 : *)

procedure caldat(julian: longint; var mm,id,iyyy: longint);
const
igreg=2299161;
var
je,jd,jc,jb,jalpha,ja: longint;
begin
  if (julian >= igreg) then begin
    jalpha := trunc(((julian-1867216)-0.25)/36524.25);
    ja := julian+1+jalpha-trunc(0.25*jalpha) ;
    end else begin
    ja := julian ;
    end;
  jb := ja+1524;
  jc := trunc(6680.0+((jb-2439870)-122.1)/365.25);
  jd := 365*jc+trunc(0.25*jc);
  je := trunc((jb-jd)/30.6001);
  id := jb-jd-trunc(30.6001*je);
  mm := je-1;
  if (mm > 12) then mm := mm-12;
  iyyy := jc-4715;
  if (mm > 2) then iyyy := iyyy-1;
  if (iyyy <= 0) then iyyy := iyyy-1 ;
  end;

function julday(mm,id,iyyy: longint): longint;
const
igreg=588829;
var
ja,jm,jy,jul: longint;
begin
  if  (iyyy = 0) then begin
    writeln('there is no year zero.'); readln;
    end;
  if  (iyyy < 0) then  iyyy := iyyy+1;
  if  (mm > 2)  then begin
    jy := iyyy;
    jm := mm+1 ;
    end else begin
    jy := iyyy-1;
    jm := mm+13 ;
    end;
  jul := trunc(365.25*jy)+trunc(30.6001*jm)+id+1720995;
  if  (id+31*(mm+12*iyyy) >= igreg)  then begin
    ja := trunc(0.01*jy);
    jul := jul+2-ja+trunc(0.25*ja) ;
    end;
  julday := jul ;
  end;

  { Prins : }

{ _CJ converts a dd,mm,yyyy date into to its corresponding Julian
  Day Number. }
procedure _CJ(dd, mm, yyyy: integer; var jdn: longint);
var yy: real;
c : real;
begin
  yy:= 1.0 * yyyy + (1.0 * mm - 2.85) / 12;
  if (10000 * longint(yyyy) + 100 * mm + dd) <= 15821004 then
    c:= 0.75 * 2
    else
    c:= 0.75 * trunc(yy / 100);
  jdn:= trunc(
    trunc(
    trunc(367 * yy) - 1.75 * trunc(yy) + dd) - c) + 1721115;
  end; { _CJ }
{}
{ _JC converts a Julian Day Number to a dd,mm,yyyy date }
procedure _JC(jdn: longint; var dd, mm, yyyy: integer);
var n: real;
c: real;
begin
  n:= 1.0 * jdn - 1721119.2;
  c:= trunc(n / 36524.25);
  if jdn < 2299161 then
    n:= n + 2
    else
    n:= n + c - trunc(c / 4);
  yyyy:= trunc(n / 365.25);
  n   := n - trunc(365.25 * yyyy) - 0.3;
  mm  := trunc(n / 30.6);
  dd  := trunc(n - 30.6 * mm + 1);
  if mm > 9 then
    begin
    dec(mm, 9);
    inc(yyyy);
    end
  else
    inc(mm, 3);
  end; { _JC }


const
Op : Options = (Cal : Civil ; Astr : false) ;
_POK : boolean = true ;
rPOK : boolean = true ;
iPOK : boolean = true ;
aPOK : boolean = true ;

const
T1 : word = 0 ; T2 : word = 0 ;
T3 : word = 0 ; T4 : word = 0 ;
T5 : word = 0 ; T6 : word = 0 ;
X1 : word = 0 ; X2 : word = 0 ;
X3 : word = 0 ; X4 : word = 0 ;
X5 : word = 0 ; X6 : word = 0 ;
First = 2450000 { 2450000 } { 2299161 } ;
Last  = 2500000 { 2500000 } { 13410000 } ;
WW = 40 ;

var DayOut, DayIn, MJDin, M, D, Y, _X, rX, iX, aX : longint ;
ID, IM, IY, JD, JM, JY : integer ; BM, BD : byte ;
T : byte ; Tkr : byte absolute $40:$6C ;
W : longint ; Tok : longint absolute $40:$6C ;


BEGIN Writeln('DATERATE.PAS   www.merlyn.demon.co.uk  >=1998/06/08') ;
InitialiseDates ; ChangeDay := Romish ;
_CJ(10, 10, 1995, _X) ;
rX := rCJ(10, 10, 1995) ;
iX := iCJ(10, 10, 1995) ;
aX := aCJ(10, 10, 1995) ;
Writeln('Checking : ', YMD_to_MJD(Op, 1995, 10, 10):10,
  JulDay(10, 10, 1995):10, _X:10, rX:10, iX:10, aX:10) ;

Write('Compiler Options : ',
  {$IFOPT B+}'$B+ '{$ELSE}'$B- '{$ENDIF},
  {$IFOPT R+}'$R+ '{$ELSE}'$R- '{$ENDIF},
  {$IFOPT S+}'$S+ '{$ELSE}'$S- '{$ENDIF},
  {$IFOPT I+}'$I+ '{$ELSE}'$I- '{$ENDIF},
  {$IFOPT Q+}'$Q+ '{$ELSE}'$Q- '{$ENDIF},
  {$IFOPT D+}'$D+ '{$ELSE}'$D- '{$ENDIF},
  {$IFOPT L+}'$L+ '{$ELSE}'$L- '{$ENDIF},
  {$IFOPT Y+}'$Y+ '{$ELSE}'$Y- '{$ENDIF},
  ^M^J) ;

Write('Scan range :') ;
MJD_to_YMD(Op, First-2400001, IY, BM, BD) ;
Write  (IY:10, BM:3, BD:3, '   to ') ;
MJD_to_YMD(Op,  Last-2400001, IY, BM, BD) ;
Writeln(IY:10, BM:3, BD:3) ;

for DayIn := First to Last do begin MJDin := DayIn - 2400001 ;

  T := Tkr ;
  MJDtoYMD(MJDin, IY, BM, BD) ;
  if T<>Tkr then Inc(T5) ;
  T := Tkr ;
  DayOut := YMDtoMJD(IY, BM, BD) ;
  if T<>Tkr then Inc(T6) ;
  if DayOut<>MJDin then begin
    Write('Quick', MJDin:10, IY:8, '/', BM:2, '/', BD:2, DayOut:10) ;
    Readln end ;

  T := Tkr ;
  CALDAT(DayIn, M, D, Y);
  if T<>Tkr then Inc(T1) ;
  if (Y<>IY) or (M<>BM) or (D<>BD) then begin
    Write('CALDAT?', DayIn:10, IY:7, BM:3, BD:3, Y:7, M:3, D:3) ;
    Readln end ;
  T := Tkr ;
  DayOut := JULDAY(M, D, Y);
  if T<>Tkr then Inc(T2) ;
  if DayOut<>DayIn then begin
    Write('JULDAY?', DayIn:10, Y:8, M:3, D:3, DayOut:10) ;
    Readln end ;

  if _POK then begin
    T := Tkr ;
    _JC(DayIn, JD, JM, JY) ;
    if T<>Tkr then Inc(T3) ;
    if (JY<>IY) or (JM<>BM) or (JD<>BD) then begin
      Write('_JC?', DayIn:10, IY:7, BM:3, BD:3, JY:7, JM:3, JD:3, ' ? ') ;
      Readln(byte(_POK)) end ;
    T := Tkr ;
    _CJ(JD, JM, JY, DayOut) ;
    if T<>Tkr then Inc(T4) ;
    if DayOut<>DayIn then begin
      Write('_CJ?', DayIn:10, JY:8, JM:3, JD:3, DayOut:10) ; Readln end ;
    end {_POK} ;

  if rPOK then begin
    T := Tkr ;
    rJC(DayIn, JD, JM, JY) ;
    if T<>Tkr then Inc(X1) ;
    if (JY<>IY) or (JM<>BM) or (JD<>BD) then begin
      Write('rJC?', DayIn:10, IY:7, BM:3, BD:3, JY:7, JM:3, JD:3, ' ? ') ;
      Readln(byte(rPOK)) end ;
    T := Tkr ;
    Dayout := rCJ(JD, JM, JY) ;
    if T<>Tkr then Inc(X2) ;
    if DayOut<>DayIn then begin
      Write('rCJ?', DayIn:10, JY:8, JM:3, JD:3, DayOut:10) ; Readln end ;
    end {rPOK} ;

  if iPOK then begin
    T := Tkr ;
    iJC(DayIn, JD, JM, JY) ;
    if T<>Tkr then Inc(X3) ;
    if (JY<>IY) or (JM<>BM) or (JD<>BD) then begin
      Write('iJC?', DayIn:10, IY:7, BM:3, BD:3, JY:7, JM:3, JD:3, ' ? ') ;
      Readln(byte(iPOK)) end ;
    T := Tkr ;
    Dayout := iCJ(JD, JM, JY) ;
    if T<>Tkr then Inc(X4) ;
    if DayOut<>DayIn then begin
      Write('iCJ?', DayIn:10, JY:8, JM:3, JD:3, DayOut:10) ; Readln end ;
    end {iPOK} ;

  if aPOK then begin
    T := Tkr ;
    aJC(DayIn, JD, JM, JY) ;
    if T<>Tkr then Inc(X5) ;
    if (JY<>IY) or (JM<>BM) or (JD<>BD) then begin
      Write('aJC?', DayIn:10, IY:7, BM:3, BD:3, JY:7, JM:3, JD:3, ' ? ') ;
      Readln(byte(aPOK)) end ;
    T := Tkr ;
    Dayout := aCJ(JD, JM, JY) ;
    if T<>Tkr then Inc(X6) ;
    if DayOut<>DayIn then begin
      Write('aCJ?', DayIn:10, JY:8, JM:3, JD:3, DayOut:10) ; Readln end ;
    end {aPOK} ;

  if (BM+BD)=2 then Write(IY:8, #13) ;
  end {DayIn} ;

{Writeln ;}
Writeln('Sloth : Tick-hits in Scan :') ;
Writeln('':11, '  D -> YMD  YMD -> D  '#241#251'N') ;
Writeln('  J R S '' s', T5:10, T6:10) ;
Writeln('  NRPAS13  ', T1:10, T2:10) ;
Writeln('  R PRINS _', T3:10, T4:10) ;
Writeln('  R PRINS r', X1:10, X2:10) ;
Writeln('  R PRINS i', X3:10, X4:10) ;
Writeln('  R PRINS a', X5:10, X6:10) ;

Writeln('Speed: Days converted in ', WW, ' Ticks :') ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  Inc(DayIn) until Tok>W ;
Writeln('  Overheads', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  MJDtoYMD(MJDin, IY, BM, BD) ;
  DayOut := YMDtoMJD(IY, BM, BD) ;
  Inc(DayIn) until Tok>W ;
Writeln('  J R S '' s', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  CALDAT(DayIn, M, D, Y);
  DayOut := JULDAY(M, D, Y);
  Inc(DayIn) until Tok>W ;
Writeln('  NRPAS13  ', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  _JC(DayIn, JD, JM, JY) ;
  _CJ(JD, JM, JY, DayOut) ;
  Inc(DayIn) until Tok>W ;
Writeln('  R PRINS _', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  rJC(DayIn, JD, JM, JY) ;
  DayOut := rCJ(JD, JM, JY) ;
  Inc(DayIn) until Tok>W ;
Writeln('  R PRINS r', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  iJC(DayIn, JD, JM, JY) ;
  Dayout := iCJ(JD, JM, JY) ;
  Inc(DayIn) until Tok>W ;
Writeln('  R PRINS i', Dayin-First:10) ;

DayIn := First ;
W := Tok ; repeat until W<>Tok ; Inc(W, WW) ;
repeat
  MJDin := DayIn - 2400001 ;
  aJC(DayIn, JD, JM, JY) ;
  DayOut := aCJ(JD, JM, JY) ;
  Inc(DayIn) until Tok>W ;
Writeln('  R PRINS a', Dayin-First:10) ;

Write('<CR>?'^G) ; Readln ;
END.

function rcj(dd, mm, yyyy: integer): longint;
function icj(dd, mm, yyyy: integer): longint;
function acj(dd, mm, yyyy: integer): longint;
procedure rjc(jdn: longint; var dd, mm, yyyy: integer);
procedure ijc(jdn: longint; var dd, mm, yyyy: integer);
procedure ajc(jdn: longint; var dd, mm, yyyy: integer);