program LeapYear ;

{$I VERSION.PAS} {$IFNDEF PASCAL}{$IFNDEF DELPHI} Fail! ; {$ENDIF}{$ENDIF}

{ Detailed speed order depends on whether run-time checks are on; and
  probably on processor, language &c.

  A table lookup - Tbl - is only quickest of the full methods when run-time
  checks are off.

  Z15 is, IMHO, the nicest rule; but not the most efficient full one,
  which, so far, is Z00 or Z01.

  For speed, obviously one should test the 4-year rule first;
  if the year passes that, the next test should be the 100, then
  if needed the 400.  OTOH, within 1901-2099, just use the first, as in An3.

  In Pascal, "Y and 3" always beats "Y mod 4" for code size and speed.

  Cobol :    FUNCTION MOD (YEAR, 4) = 0   or ???
  }

{$IFDEF DELPHI} uses Windows ; {$ENDIF}
{$IFDEF WINDOWS} uses WinCrt ; {$ENDIF}


const YMin = 1980 ; YMax = 2107 ;

type YrT = YMin..YMax ;

var LArr : array [YrT] of boolean ;


function Nul(Y : word) : boolean ; FAR ; { Dummy }
begin Nul := false end ;

function UGH(Y : word) : boolean ; FAR ; { Just 1901-2099 }
begin UGH := boolean(Y and 3) end ;

function An3(Y : word) : boolean ; FAR ; { Just 1901-2099 }
begin An3 := (Y and 3) = 0 end ;

function Md4(Y : word) : boolean ; FAR ; { Just 1901-2099 }
begin Md4 := (Y mod 4) = 0 end ;

function Tbl(Y : word) : boolean ; FAR ; { Lookup }
begin Tbl := LArr[Y] end ;

function Cen(Y : word) : boolean ; FAR ; { Just 1901-2199 }
begin Cen := ((Y and 3) = 0) and (Y<>2100) end ;

function Ass(Y : word) : boolean ; FAR ; assembler ;
asm ;
  {$IFDEF PASCAL}

  {$IFDEF SLOWER}
  mov ax,[Y] ;             and ax,3 ; jne @1 ;
  mov ax,[Y] ; xor dx,dx ; mov cx,100 ; div cx ; or dx,dx ; ja @2 ;
  and ax,3 ; je @2 ;
  @1 : mov al,0 ; jmp @3 ;
  @2 : mov al,1 ;
  @3 : ;
  {$ELSE after Osmo}
  xor bx,bx ; mov ax,[Y] ; test ax,3 ; jne @out ;
  inc bx ; xor dx,dx ; mov cx,100 ; div cx ; or dx,dx ; jne @out ;
  test ax,3 ; je @out ;
  xor bx,bx ;
  @out : mov ax,bx ;
  {$ENDIF}

  {$ENDIF}
  {$IFDEF DELPHI} { WRONG
  mov ax,Y ; and ax,3 ; or ax,ax ; jne @1 ;
  mov ax,Y ; xor dx,dx ; mov cx,100 ; div cx ; xchg dx,ax ; or ax,ax ; ja @2 ;
  mov ax,Y ; xor dx,dx ; mov cx,400 ; div cx ; xchg dx,ax ; or ax,ax ; je @2 ;
  @1 : mov al,0 ; jmp @3 ;
  @2 : mov al,1 ;
  @3 : ;
  }
  push ebx ;
  xor bx,bx ; mov ax,Y ; test ax,3 ; jne @out ;
  inc bx ; xor dx,dx ; mov cx,100 ; div cx ; or dx,dx ; jne @out ;
  test ax,3 ; je @out ;
  xor bx,bx ;
  @out : mov ax,bx ;
  pop ebx ;
  {$ENDIF}
  end ;

function Z00(Y : word) : boolean ; FAR ;
begin Z00 := ((Y and 3) = 0) and ((Y mod 100 > 0) or (Y mod 400 = 0)) end ;

function Z01(Y : word) : boolean ; FAR ;
begin Z01 := ((Y and 3) = 0) and ((Y mod 100 <> 0) or (Y mod 400 = 0)) end ;

function Z02(Y : word) : boolean ; FAR ;
begin Z02 := False ;
  if (Y and 3)<>0 then EXIT ;
  if ((Y mod 400)=0) or ((Y mod 100)<>0) then Z02 := True;
  end {Olaf van der Spek} ;

function Z03(Y : word) : boolean ; FAR ;
begin Z03 := ((Y and 3) = 0) and ((Y mod 400 = 0) or (Y mod 100 > 0)) end ;

function Z04(Y : word) : boolean ; FAR ;
begin Z04 := (Y and 3) = 0 ;  if Y mod 100 = 0 then
    if Y div 100 in [19,21,22] then Z04 := FALSE ; end ;

function Z05(Y : word) : boolean ; FAR ;
begin Z05 := (Y mod 4 = 0) and not ((Y mod 100 = 0) and (Y mod 400 <> 0)) end ;

function Z06(Y : word) : boolean ; FAR ;
begin
  if Y mod 4 <> 0 then Z06 := false
    else if Y mod 100 <> 0 then Z06 := true
    else if Y mod 400 <> 0 then Z06 := false
    else Z06 := true ;
  end ;

function Z07(Y : word) : boolean ; FAR ;
begin
  if Y mod 4 <> 0 then Z07 := false
    else if Y mod 100 <> 0 then Z07 := true
    else Z07 := Y mod 400 = 0 ;
  end ;

function Z08(Y : word) : boolean ; FAR ;
begin Z08 := (Y mod 4 = 0) and ((Y mod 100 <> 0) or (Y mod 400 = 0)) end ;

function TSF(Y : word) : boolean ; FAR ; { from TSFAQP #91 2000-01-08 }
begin TSF := (Y mod 4 = 0) and not ((Y mod 100 = 0) and not (Y mod 400 = 0)) end ;

function Z09(Y : word) : boolean ; FAR ;
begin
  if Y mod 4 <> 0 then Z09 := false
    else Z09 := (Y mod 100 <> 0) or (Y mod 400 = 0) ;
  end ;

function Z10(Y : word) : boolean ; FAR ;
begin
  if (Y mod 4 <> 0) then Z10 := false
    else if Y mod 400 = 0 then Z10 := true
    else Z10 := Y mod 100 <> 0 ;
  end ;

function Z11(Y : word) : boolean ; FAR ;
begin Z11 := (Y mod 4 = 0) and ((Y mod 100 = 0) <= (Y mod 400 = 0)) end ;

function ESB(Year : word) : boolean ; FAR ;
begin ESB := false;
  if Year mod 400 = 0 then ESB := true else
    if (Year mod 4 = 0) and (Year mod 100 <> 0) then ESB := true ;
  end ;

function Z12(Y : word) : boolean ; FAR ;
(* suggested, but not recommended, by {R}, rearranged  *)
const divide : array [boolean] of word = (4, 400) ;
begin Z12 := Y mod divide[Y mod 100 = 0] = 0 end ;

function Z13(Y : word) : boolean ; FAR ;
begin
  if Y mod 400 = 0 then Z13 := true else
    if Y mod 100 = 0 then Z13 := false else
    if Y mod 4 = 0 then Z13 := true else Z13 := false ;
  end ;

function Z14(Y : word) : boolean ; FAR ;
begin Z14 := not (Y mod 4 <> 0) xor (Y mod 100 <> 0) xor (Y mod 400 <> 0) end ;

function Z15(Y : word) : boolean ; FAR ;
begin Z15 := (Y mod 4 = 0) xor (Y mod 100 = 0) xor (Y mod 400 = 0) end ;

function Z16(Y : word) : boolean ; FAR ;
begin Z16 := (Y mod 4 = 0) <> ((Y mod 100 = 0) <> (Y mod 400 = 0)) end ;

function Z17(Y : word) : boolean ; FAR ;
begin Z17 := ((Y mod 4 = 0) = (Y mod 100 = 0)) = (Y mod 400 = 0) end ;

function Z18(Y : word) : boolean ; FAR ;
begin Z18 := (Y mod 4 = 0) = ((Y mod 100 = 0) = (Y mod 400 = 0)) end ;

function Z19(Y : word) : boolean ; FAR ;
begin Z19 := ((Y mod 4 = 0) <> (Y mod 100 = 0)) <> (Y mod 400 = 0) end ;

function Z20(Y : word) : boolean ; FAR ;
begin Z20 := {suggested, but not recommended, by Roy Brown}
    Odd(Ord(Y mod 4 = 0) + Ord(Y mod 100 = 0) + Ord(Y mod 400 = 0)) end ;



type LeapFn = function(Y : word) : boolean ;

const MinF = -5 ; MaxF = 24 ;
FnAr : array [MinF..MaxF] of record F : LeapFn ; S : string [3] end = (
  (F:Nul; S:'Nul'),
  (F:UGH; S:'UGH'), (F:Tbl; S:'Tbl'), (F:An3; S:'An3'), (F:Md4; S:'Md4'),
  (F:Ass; S:'Ass'), (F:Cen; S:'Cen'),
  (F:Z00; S:'Z00'), (F:Z01; S:'Z01'), (F:Z02; S:'Z02'), (F:Z03; S:'Z03'),
  (F:Z04; S:'Z04'), (F:Z05; S:'Z05'), (F:Z06; S:'Z06'), (F:Z07; S:'Z07'),
  (F:Z08; S:'Z08'), (F:TSF; S:'TSF'), (F:Z09; S:'Z09'), (F:Z10; S:'Z10'),
  (F:Z11; S:'Z11'), (F:ESB; S:'ESB'), (F:Z12; S:'Z12'), (F:Z13; S:'Z13'),
  (F:Z14; S:'Z14'), (F:Z15; S:'Z15'), (F:Z16; S:'Z16'), (F:Z17; S:'Z17'),
  (F:Z18; S:'Z18'), (F:Z19; S:'Z19'), (F:Z20; S:'Z20') ) ;


procedure Test(Y : word) ;
const Z : array [boolean] of char = 'ny' ; ZZ : array [0..1] of char = '-~' ;
var C : char ; J : shortint ; L, L1 : boolean ;
begin Write(Y:5) ; L1 := LArr[Y] ;
  for J := Succ(MinF) to MaxF do begin
    L := FnAr[J].F(Y) ;
    C := Z[L] ;
    if L<>L1 then C := UpCase(C) ;
    Write(C:2) end ;
  Writeln end {Test} ;


procedure Perp ;
const Yrs : array [1..12] of word =
  (1980, 1990, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2010, 2020, 2100) ;
const Z : array [boolean] of char = 'ny' ;
var J, Y : word ; K : integer ; L : boolean ; C : char ;
begin
  Write('Function ') ; for J := Low(Yrs) to High(Yrs) do Write(Yrs[J]:5) ;
  Writeln ;
  for K := Succ(MinF) to MaxF do with FnAr[K] do begin Write(K:3, S:5) ;
    for J := Low(Yrs) to High(Yrs) do begin Y := Yrs[J] ;
      L := F(Y) ;
      C := Z[L] ;
      if L<>LArr[Y] then C := UpCase(C) ;
      Write(C:5) end ;
    Writeln end ;
  end {Perp} ;


procedure TestAll ;
const Z : array [boolean] of char = 'ny' ;
var J : shortint ; L, L1 : boolean ; Y : word ;
begin Writeln('TestAll:') ;
  for Y := YMin to YMax do begin Write(#13, Y:5) ; L1 := LArr[Y] ;
    for J := 0 to MaxF do with FnAr[J] do begin
      L := F(Y) ;
      if (L<>L1) xor (@F=@UGH) then begin
        Write('  ERROR! ', S:4, ' gave ', L:5, ' <cr>') ; Readln end ;
      end ;
    end ;
  Writeln(#13, 'TestAll Done.') end {TestAll} ;


function Timer : longint { P: 55ms; D: 1ms } ;
{$IFDEF PASCAL} assembler ; {$ENDIF}
{$IFDEF BORPAS}
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 {$ENDIF}
{$IFDEF __TMT__} asm  mov eax,[$046C]  end {$ENDIF}
{$IFDEF DELPHI} begin Timer := GetTickCount end {$ENDIF}
{Timer} ;


var Overhead : longint ;


procedure Speed(J : shortint ; Ticks : longint) ;
var L : boolean ; N, T : longint ; Y : YrT ;
(*
  {$IFDEF PASCAL} Tix : longint absolute $40:$6C ; {$ENDIF not hour-safe}
  {$IFDEF DELPHI}
  function Tix : longint ; assembler ; { not midnight-safe }
  asm  xor ax,ax ; Int $1A ; mov ax,dx ; mov dx,cx end {Tix} ;
  {$ENDIF}
  *)
begin with FnAr[J] do begin Write(' Func ', S, '':2) ;
    repeat T := Timer until T<>Timer ;
    Inc(T, Ticks) ; N := 0 ;
    while Timer<=T do begin
      for Y := YMin to YMax do L := F(Y) ;
      Inc(N) end ;
    end ;
  Write('did', N:8, ' loops of ', YMin, -YMax) ;
  if J=MinF then Overhead := N ;
  if N>0 then Write(',  relative Func time ', (Overhead/N-1.0):1:3) ;
  end {Speed} ;


var Ticks : longint ; YY : word ; J : shortint ; K : byte ;


BEGIN ;
Writeln('LEAPYEAR.PAS >= 2000-06-03  www.merlyn.demon.co.uk   ',
  {$IFDEF PASCAL} 'Pascal' {$ENDIF} {$IFDEF DELPHI} 'Delphi' {$ENDIF} ,
  ^M^J'  N.B. UGH is inverse & malformed!') ;
for YY := YMin to YMax do LArr[YY] := Z15(YY) ;
(*
  Write('':31) ;    for J := 10 to MaxF do Write(J div 10:2) ; Writeln ;
  Write('Fn #':5) ; for J := Succ(MinF) to 9 do Write(J:2) ;
  {}                for J := 10 to MaxF do Write(J mod 10:2) ; Writeln ;
  *)
for K := 1 to 3 do begin Write('':5) ;
  for J := Succ(MinF) to MaxF do Write(FnAr[J].S[K]:2) ; Writeln end ;
Test(1980) ; Test(1990) ;
for YY := 1999 to 2005 do Test(YY) ;
Test(2010) ; Test(2020) ; Test(2100) ;
{ Perp ; }
TestAll ;
repeat Write(' (0=Next) Year (', Ymin, '-', Ymax, ') ? ') ;
  Readln(YY) ; if YY=0 then BREAK ;
  Test(YY) until false ;
Writeln(' OK') ;
Write('Test Time in Ticks (P:55ms, D:1ms) ? ') ; Readln(Ticks) ;
Writeln(' Preloading any cache:') ;
for J := MinF to MaxF do begin Speed(J, 1) ; Write(#13) end ;
Speed(MinF, Ticks) ; Writeln(#13' Done.', '':73) ;
for J := MinF to MaxF do begin Speed(J, Ticks) ; Writeln end ;
Write(' Done<cr>') ; Readln ;
END.