program HijriCal { www.merlyn.demon.co.uk } ;

{$I Version.pas}

uses {$IFDEF DELPHI} Windows, SysUtils, {$ELSE} Dos, {$ENDIF} DateProx ;

const UHC = '   HIJRICAL.PAS >= 2002-11-18.' ;


{ Turbo Pascal 7 / Borland Pascal 7 / Borland Pascal for Windows /
  Delphi 3 Console Mode - etc.  In Delphi, variable types can be larger.


  Conversion of Modified Julian Date (MJD) to/from a certain form of Hijri
  Calendar Date YYYY MM DD, using only Whitaker/EGR rules as implemented
  by JRS; my code is adjusted so that A.D. 1988-08-14 is A.H. 1409-01-01
  (which I know to be so, from Whitaker 1989).

  * This may be called the astronomical calendar.
  * Diaries may use a differently-predicted moon.
  * The religious may use an observed moon to start the month.


  Using MJD instead of JD avoids doubt with the odd half-day; MJD changes
  at about GMT midnight; for most uses, just ignore timezone and DST.

  Julian Day Count is the number of days that have elapsed since
  Greenwich Mean Noon, Jan. 1, 4713 B.C., Julian;  MJD = JD - 2400000.5 .
  Be specially careful with negative non-integer days.  CJD = JD + 0.5 .

  For calendar info, see The Calendar FAQ by Claus Tondering - a link
  is now maintained at http://www.merlyn.demon.co.uk/datelinx.htm#CF -
  Whitaker's Almanac, E G Richards' book; and other references at merlyn.

  See http://www.merlyn.demon.co.uk/miscdate.htm
  and http://www.merlyn.demon.co.uk/misclinx.htm


  The JRS... routines are mine, derived from Whitaker 1989.

  EGRalgE, EGRalgF are Algorithms E & F from E G Richards' book; they
  accommodate many calendars by parameterisation.  EGR...X provide the
  Islamic parameters; EGR...Y are those, near-optimised.


  For program control, see Cmnd, near the end of this.


  NOTE : it is easiest to calculate in reverse order for test.  SORT
  will put it all in good order, apart from newlines.  May need to set
  short=true for DOS SORT, for reasons of size; this only affects display.

  }



{ $B-}



{ EGR's general algorithms E & F, into Pascal by JRS : }


function EGRalgE(const Yr : word ; const Mo, Dy : byte ;
  const y, j, m, n, r, p, q, v, u, s, t, w : word) : MJDate ;
var Y_, M_, D_, c, d : longint ;
begin
  Y_ := Yr + y - (n+m-1-Mo) div n ;
  M_ := (Mo-m+n) mod n ;
  D_ := Dy-1 ;
  c  := (p*Y_+q) div r ;
  d  := (s*M_+t) div u ;
  EGRalgE := c+d+D_-j - 2400001 ;
  end {EGRalgE} ;


procedure EGRalgF(const MJD : MJDate ; var Yr : word ; var Mo, Dy : byte ;
  const y, j, m, n, r, p, q, v, u, s, t, w : word) ;
var J_, Y_, T_, M_, D_ : longint ;
begin
  J_ := MJD + 2400001 + j ;
  Y_ :=  (r*J_+v) div p ;
  T_ := ((r*J_+v) mod p) div r ;
  M_ :=  (u*T_+w) div s ;
  D_ := ((u*T_+w) mod s) div u ;
  Dy  := D_+1 ;
  Mo  := ((M_+m-1) mod n) + 1 ;
  Yr  := Y_ - y + (n+m-1-Mo) div n ;
  end {EGRalgF} ;



{ EGR's E & F, wrapped for Hijri only : }


function EGRHjYMDtoMJD1
  (const HjYr : word ; const HjMo, HjDy : byte) : MJDate ; FAR ;
{ Hijri Y M D to Modified Julian Day - from 0 A.H. to >32000 A.D. }
begin EGRHjYMDtoMJD1 := EGRalgE(HjYr, HjMo, HjDy,
    5519, 7664, 1, 12, 30, 10631, 14, 15, 100, 2951, 51, 10) ;
  end {EGRHjYMDtoMJD1} ;


procedure EGRMJDtoHjYMD1
  (const MJD : MJDate ; var HjYr : word ; var HjMo, HjDy : byte) ; FAR ;
{ Modified Julian Day to Hijri Y M D - from 0 A.H. to >32000 A.D. }
begin EGRalgF(MJD, HjYr, HjMo, HjDy,
    5519, 7664, 1, 12, 30, 10631, 14, 15, 100, 2951, 51, 10) ;
  end {EGRMJDtoHjYMD1} ;



{ EGR's E & F, condensed for Hijri only : }


procedure EGRMJDtoHjYMD2
  (const MJD : MJDate ; var HjYr : word ; var HjMo, HjDy : byte) ; FAR ;
{ Modified Julian Day to Hijri Y M D - from 0 A.H. to >32000 A.D. }
var x : longint ;
begin
  x  := (MJD + 2407665) * 30 + 15 ;
  HjYr  := x div 10631 - 5519 ;
  x  := ((x mod 10631) div 30) * 100 + 10 ;
  HjMo :=  x div 2951 + 1 ;
  HjDy := (x mod 2951) div 100 + 1 ;
  end {EGRMJDtoHjYMD2} ;


function EGRHjYMDtoMJD2
  (const HjYr : word ; const HjMo, HjDy : byte) : MJDate ; FAR ;
{ Hijri Y M D to Modified Julian Day - from 0 A.H. to >32000 A.D. }
begin
  EGRHjYMDtoMJD2 := (longint(10631)*HjYr + 58672503) div 30  +
    (2951*Pred(HjMo)+51) div 100  +  HjDy - 2407666 ;
  end {EGRHjYMDtoMJD2} ;




{ JRS's routines, from description in Whitaker : }


const
HijriBias = 451916 { empiric } ;
Yrs30 = 19*354 + 11*355 ;

LongMos : set of 1..12 = [1, 3, 5, 7, 9, 11, 12] ;
LongYrs : set of 0..29 = [2, 5, 7, 10, 13, 16, 18, 21, 24, 26, 29] ;


{ Note : because of the looping, neither of these routines is very efficient;
  but, now shown accurate, they can be used to test faster methods. }


procedure JRSMJDtoHjYMD0
  (const MJD : MJDate ; var HjYr : word ; var HjMo, HjDy : byte) ; FAR ;
{ Modified Julian Day to Hijri Y M D - from 0 A.H. to >32000 A.D. }
var J, Days : word ; MJL : longint ; MJW : word absolute MJL ;
begin

  MJL := MJD + HijriBias-1 ;

  J := MJL div Yrs30 ; HjYr := J*30 ; Dec(MJL, J*longint(Yrs30)) ;

  for J := 0 to 29 do begin
    Days := 354 + Ord(J in LongYrs) ;
    if MJW<Days then BREAK ;
    Inc(HjYr) ; Dec(MJW, Days) end ;

  HjMo := 1 ;
  for J := 1 to 12 do begin
    Days := 29 + Ord(J in LongMos) ;
    if MJW<Days then BREAK ;
    Inc(HjMo) ; Dec(MJW, Days) end ;

  HjDy := MJW+1 ;

  end {JRSMJDtoHjYMD0} ;



function JRSHjYMDtoMJD0
  (const HjYr : word ; const HjMo, HjDy : byte) : MJDate ; FAR ;
{ Hijri Y M D to Modified Julian Day - from 0 A.H. to >32000 A.D. }
var MJD : MJDate ; Anni : word ; M : byte ;
begin
  Anni := HjYr ; MJD := -HijriBias ;

  Inc(MJD, longint(Anni div 30)*Yrs30) ; Anni := Anni mod 30 ;

  for M := 1 to Anni do Inc(MJD, 354 + Ord(Pred(M) in LongYrs)) ;

  for M := 1 to Pred(HjMo) do Inc(MJD, 29 + Ord(M in LongMos)) ;

  JRSHjYMDtoMJD0 := MJD + HjDy ;

  end {JRSHjYMDtoMJD0} ;



{ Dummies, for timing overhead : }

function JRSHjYMDtoMJD_
  (const HjYr : word ; const HjMo, HjDy : byte) : MJDate ; FAR ;
begin JRSHjYMDtoMJD_ := 0 end ;


procedure JRSMJDtoHjYMD_
  (const MJD : MJDate ; var HjYr : word ; var HjMo, HjDy : byte) ; FAR ;
begin end ;



(********** TESTS ************)

const short : boolean = true ;

type
PMtoY = procedure (const MJD : MJDate ; var HjYr : word ; var HjMo, HjDy : byte) ;
FYtoM = function (const HjYr : word ; const HjMo, HjDy : byte) : MJDate ;
S20 = string [20] ;

{$IFDEF BORPAS}
function IntToStr(const X : longint) : S20 ;
var S : S20 ;
begin Str(X, S) ; IntToStr := S end {IntToStr} ;
{$ENDIF}

function HjStr(const HY : word ; const HM, HD : byte) : S20 ;
begin HjStr := IntToStr(HY) + '.' + LZ(HM) + '.' + LZ(HD) end {HjStr} ;


procedure ShowBase(Proc : PMtoY ; const St : string ; const MJD : MJDate) ;
var HY : word ; HM, HD : byte ;
begin
  Proc(MJD, HY, HM, HD) ;
  Writeln('A  A.H. by ', St, ' for that date  ', HjStr(HY, HM, HD)) ;
  end {ShowBase} ;



procedure TestA ;
var MJD : MJDate ; K : byte ;
begin
  Writeln('A') ;
  Writeln('A    Using these routines :') ;
  Write('A   Long Months :') ;
  for K := 1 to 12 do if K in LongMos then Write(K:3) ;
  Writeln('  (12 can be)') ;
  Write ('A   Long Years : ') ;
  for K := 0 to 29 do if K in LongYrs then Write(K:3) ;
  Writeln ;
  Writeln('A  A.D. 1988-08-14 equals A.H. 1409.01.01') ;
  MJD := YMDtoMJD(1988, 08, 14) ;
  ShowBase(JRSMJDtoHjYMD0, 'JRS0', MJD) ;
  ShowBase(EGRMJDtoHjYMD1, 'EGR1', MJD) ;
  ShowBase(EGRMJDtoHjYMD2, 'EGR2', MJD) ;

  MJD := JRSHjYMDtoMJD0(0001, 01, 01) ;
  Writeln('A  A.H. era 000', HjStr(1, 1, 1), ' : ', WkDstr[DayOfWeek(MJD)],
    ', MJD ', MJD, '; that is'^M^J'A  ',
    MJDateStr(JulCal, MJD), 'Julian,  ',
    MJDateStr(GrgCal, MJD), 'Gregorian.') ;

  end {TestA} ;



procedure TestB ;
var MJD : MJDate ; B, Bad, XB : boolean ;
{ Those beginning E are EGR's; those beginning J are JRS's; those beginning
  G are Gregorian; I are IoP's : }
var JMJD, EMJD : MJDate ; EHjYr, JHjYr : word ; GY : integer ;
EHjMo, EHjDy, JHjMo, JHjDy, GM, GD : byte ;
begin
  Writeln('B') ;
  Write('B     Known Good          JRS Code   ') ;
  if not short then Write('        EGR Code   ') ;
  Writeln ;

  Write('B   Gregorian  MJD     Islamic    ') ;
  if not short then Write('MJD     Islamic    MJD') ;
  Writeln ;

  B := true ;
  for MJD := YMDtoMJD(2019, 12, 31) downto YMDtoMJD(1988, 1, 1) do begin

    Bad := false ;

    JRSMJDtoHjYMD0(   MJD, JHjYr, JHjMo, JHjDy) ;
    JMJD := JRSHjYMDtoMJD0(JHjYr, JHjMo, JHjDy) ;
    Bad := Bad or (JMJD<>MJD) ;

    EGRMJDtoHjYMD1(   MJD, EHjYr, EHjMo, EHjDy) ;
    EMJD := EGRHjYMDtoMJD1(EHjYr, EHjMo, EHjDy) ;
    Bad := Bad or (EMJD<>MJD)
      or (JHjYr<>EHjYr) or (JHjMo<>EHjMo) or (JHjDy<>EHjDy) ;

    EGRMJDtoHjYMD2(   MJD, EHjYr, EHjMo, EHjDy) ;
    EMJD := EGRHjYMDtoMJD2(EHjYr, EHjMo, EHjDy) ;
    Bad := Bad or (EMJD<>MJD)
      or (JHjYr<>EHjYr) or (JHjMo<>EHjMo) or (JHjDy<>EHjDy) ;

    MJDtoYMD(MJD, GY, GM, GD) ;
    XB := B { End of a month } ;
    B := (GD=1) or (JHjDy=1) or (EHjDy=1) { Beginning of a month } ;
    if B or XB or Bad then begin
      Write('B', GY:6, '-', LZ(GM), '-', LZ(GD), MJD:6) ;
      {}        Write(HjStr(JHjYr, JHjMo, JHjDy):13) ;
      if not short then
        Write(JMJD:6, HjStr(EHjYr, EHjMo, EHjDy):13, EMJD:6) ;
      if Bad then Write(' Bad'^G) ;
      Writeln ;
      end ;
    {}
    end {MJD} ;

  end {TestB} ;



procedure TestC ;
type MD = (Mon, Day) ;
const IoPDiaries : array [1414..1424] of array [MD] of byte = (
  (06, 21), (06, 10), (05, 30), (05, 18), (05, 07),
  (04, 27), (04, 17), (04, 05), (03, 26), (03, 15), (03, 04) ) ;
var MJD : MJDate ; HjYr : word ; GY : integer ; GM, GD, IM, ID : byte ;
begin
  Writeln('C') ;
  Writeln('C   Calculated by EGR routine         JRS''s IoP Diaries') ;
  for HjYr := 1409 to 1428 do begin
    Write('C  A.H.', HjYr:5, ' begins ') ;
    MJD := EGRHjYMDtoMJD1(HjYr, 1, 1) ;
    Write(MJDateStr(GrgCal, MJD)) ;

    if (HjYr>=Low(IoPDiaries)) and (HjYr<=High(IoPDiaries)) then begin
      MJDtoYMD(MJD, GY, GM, GD) ;
      IM := IoPDiaries[HjYr, Mon] ; ID := IoPDiaries[HjYr, Day] ;
      Write(LZ(IM):6, '-', LZ(ID), ' IoP') ;
      if (IM<>GM) or (ID<>GD) then Write('  Differs'^G) ;
      end ;

    Writeln ;
    end ;

  end {TestC} ;



{$IFDEF BORPAS}
function GetTickCount : longint ; assembler ;
asm
    mov es,[Seg0040] ;
  @1: mov ax,[es:$6c] ; mov dx,[es:$6e] ; mov cl,[es:$70]
    cmp ax,[es:$6c] ; jne @1
    cmp cl,0 ; je @2
    add ax,$B0 ; adc dx,$18 ;
  @2:
    end {GetTickCount} ;
{$ENDIF}


function SynchTickCount : longint ;
var T1, T2 : longint ;
begin
  T1 := GetTickCount ;
  repeat T2 := GetTickCount until T2 <> T1 ;
  SynchTickCount := T2 end {SynchTickCount} ;



procedure Rate(const MtoY : PMtoY ; const YtoM : FYtoM ; const St : string) ;
var T0, T1 : longint ; Y, Y_ : word ; M, M_, D, D_ : byte ;
const From = {$IFDEF BORPAS} 1400 - 30 {$ELSE} 1400 - 40*30 {$ENDIF} ;
begin { Full cycle omitting 11 days -12-30 }
  Write('D  Time for ', St:6) ;
  T0 := SynchTickCount ;
  for Y := From to 1429 { A.H. } do for M := 1 to 12 do
    for D := 1 to 29+Ord(Odd(M)) do MtoY(YtoM(Y, M, D), Y_, M_, D_) ;
  T1 := GetTickCount ;
  Writeln(T1-T0:5, ' ticks') ;
  end {Rate} ;



procedure TestD ;
begin Writeln('D') ;
  Writeln('D  Time comparisons :') ;
  Rate(EGRMJDtoHjYMD1, EGRHjYMDtoMJD1, 'EGR1') ;
  Rate(EGRMJDtoHjYMD2, EGRHjYMDtoMJD2, 'EGR2') ;
  Rate(JRSMJDtoHjYMD0, JRSHjYMDtoMJD0, 'JRS0') ;
  Rate(JRSMJDtoHjYMD_, JRSHjYMDtoMJD_, 'Ovhd') ;
  Writeln('D  Time tested.') end {TestD} ;



procedure TestE ;
var {$IFDEF BORPAS} W, {$ENDIF} Y, M, D : word ; HY : word ; HM, HD : byte ;
begin Writeln('E') ;
  Write('E  Today : A.H. ') ;
  {$IFDEF DELPHI} DecodeDate(Now, Y, M, D)
    {$ELSE} GetDate(Y, M, D, W) {$ENDIF} ;
  JRSMJDtoHjYMD0(YMDtoMJD(Y, M, D), HY, HM, HD) ;
  Writeln(HjStr(HY, HM, HD)) ;
  end {TestE} ;


const ID2002 : array [1..24] of string [22] = (
  {  '1423 10 27  2002 12 31', }
  '1423 10 01  2001 12 05',
  '1423 09 29  2002 12 04',
  '1423 09 01  2002 11 06',
  '1423 08 30  2002 11 05',
  '1423 08 01  2002 10 07',
  '1423 07 29  2002 10 06',
  '1423 07 01  2002 09 08',
  '1423 06 30  2002 09 07',
  '1423 06 01  2002 08 09',
  '1423 05 29  2002 08 08',
  '1423 05 01  2002 07 11',
  '1423 04 29  2002 07 10',
  '1423 04 01  2002 06 12',
  '1423 03 30  2002 06 11',
  '1423 03 01  2002 05 13',
  '1423 02 29  2002 05 12',
  '1423 02 01  2002 04 14',
  '1423 01 30  2002 04 13',
  '1423 01 01  2002 03 15',
  '1422 12 30  2002 03 14',
  '1422 12 01  2002 02 13',
  '1422 11 29  2002 02 12',
  '1422 11 01  2002 01 15',
  '1422 10 30  2002 01 14') ;



procedure TestF ;
var MJD : MJDate ; B, Bad, XB : boolean ;
{ Those beginning E are EGR's; those beginning J are JRS's; those beginning
  G are Gregorian; I are IoP's : }
var JHjYr : word ; GY : integer ;
JHjMo, JHjDy, GM, GD, K : byte ;
begin
  Writeln('F') ;
  Writeln('F                                     Month Start & Finish') ;
  Writeln('F          Calculated                 From MM''s 2002 diary') ;
  Writeln('F   MJD    Gregorian  Islamic           these correspond ') ;

  K := 0 ;
  B := false ;
  for MJD := YMDtoMJD(2002, 12, 31) downto YMDtoMJD(2002, 01, 01) do begin

    MJDtoYMD(MJD, GY, GM, GD) ;
    JRSMJDtoHjYMD0(   MJD, JHjYr, JHjMo, JHjDy) ;

    XB := B { End of a month } ;
    B := JHjDy=1 { Beginning of a month } ;
    if B or XB then begin
      Inc(K) ;
      Write('F ', MJD:6, GY:6, '-', LZ(GM), '-', LZ(GD),
        HjStr(JHjYr, JHjMo, JHjDy):12, #32) ;
      if LZ(JHjDy)<>Copy(ID2002[K], 09, 2) then Write(' -> '^G) else write('':4) ;
      Write(ID2002[K]) ;
      if LZ(   GD)<>Copy(ID2002[K], 21, 2) then Write(' <- '^G) ;
      Writeln ;
      end ;
    {}
    end {MJD} ;

  Writeln('F Evidently diaries use different rules.') ;
  end {TestF} ;



procedure HELP ;
begin Writeln(' Parameters either Y M D Gregorian;',
    ' or letter string, see code for Cmnd.') ;
  HALT end {HELP} ;


procedure DoJob ;
const Cmnd : string [20] = 'ABCDEF' ;
var N : integer ; Y : word ; M, D : byte ;
begin

  if ParamCount>0 then Cmnd := ParamStr(1) ;

  if Cmnd[1] in ['0'..'9'] then begin
    Val(ParamStr(1), Y, N) ;
    Val(ParamStr(2), M, N) ;
    Val(ParamStr(3), D, N) ;
    JRSMJDtoHjYMD0(YMDtoMJD(Y, M, D), Y, M, D) ;
    Writeln(Y:5, M:3, D:3) ;
    EXIT end ;

  Writeln ;
  Writeln('Islamic Calendar Program':35) ;
  Writeln('(c) www.merlyn.demon.co.uk':36) ;
  Writeln(UHC:37) ;
  Writeln(UDP:37) ;
  Writeln('Two or more calculable Calendars exist':40) ;

  for M := 1 to Length(Cmnd) do begin
    case UpCase(Cmnd[M]) of
      'A' : TestA ;
      'B' : TestB ;
      'C' : TestC ;
      'D' : TestD ;
      'E' : TestE ;
      'F' : TestF ;
      '#' : begin Write('_ ? ') ; Readln end ;
      'Y' : short := false ;
      'Z' : short := true ;
      '/', '?' : HELP ;
      else Writeln(^G'Unknown'^G) ;
      end ;
    end ;
  end {DoJob} ;


BEGIN ;
DoJob ;
END.