{$I version.pas}

{$IFDEF BORPAS}
{$IFDEF DEBUG} {$M $2000, 33000, 33000} {$ELSE} {$M $2000, 0, 0} {$ENDIF}
{$ENDIF BORPAS}

program NOWMINUS ;

uses
  {$IFDEF DEBUG} Crt, {$ENDIF}
  {$IFDEF BORPAS} {$IFDEF DPMI} JRS_EnvD {$ELSE} JRS_EnvU {$ENDIF}, {$ENDIF}
  {$IFDEF DELPHI} SysUtils, {$ENDIF}
  {$IFNDEF DELPHI} Dos, {$ENDIF}
  DateProx ;


const LZ = 0 { to block dateprox' LZ } ;

var Scr : text ;

procedure Help ;
begin Writeln(Scr,
    'NOWMINUS ',
{$IFDEF BORPAS} '16', {$ENDIF}
{$IFDEF DELPHI} '32', {$ENDIF}
    '-bit  www.merlyn.demon.co.uk  >= 2006-04-29; see NOWMINUS.TXT.',
    ^M^J' To set Now, or offset Now, in chosen form',
{$IFDEF BORPAS} ' to the Environment', {$ENDIF}
    '.' ) ;
  HALT end {Help} ;


type S80 = string [80] ; S32 = string [32] ; S3 = string [3] ;

const Base : word = 10 ;
RandRange : word = 0 ;
NM = ' NOWMINUS: ' ;
Gen : integer = 8 { TS default } ;
Alf : string [36] = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ' ;
Dogs : boolean = false ;


function StrF(Q : longint ; const n : byte) : S32 ;
var i : byte ; St : string [15] ;
begin if Q<0 then begin Writeln(Scr, NM, Q, ' Out<0 ! **') ; HALT(1) end ;
  St := '' ;
  for i := 1 to n do begin
    St := Alf[Succ(Q mod Base)] + St ; Q := Q div Base end ;
  StrF := St end {StrF} ;


function D2(const Q : longint) : S32 ;
begin D2 := StrF(Q, 2) end {D2} ;


procedure Norm(var Y : integer ; var M, D : byte ; var DD, IsS : longint) ;
var MJD : longint ;
begin
  MJD := YMDtoMJD(Y, M, D)+DD ; DD := 0 ;
  while IsS <      0 do begin MJD := MJD-1 ; Inc(IsS, 86400) end ;
  while IsS >= 86400 do begin MJD := MJD+1 ; Dec(IsS, 86400) end ;
  MJDtoYMD(MJD, Y, M, D) ;
  end {Norm} ;


{$IFDEF BORPAS}
function EnvGet(const St : S80) : string ;
var Ostr : string ; Status : byte ;
begin
  Environ(Gen, Get, St, Ostr, Status) ;
  {} {$IFDEF DEBUG} Writeln('*** C: Ostr="', Ostr, '"') ; {$ENDIF}
  if Status<>0 then Writeln(Scr, NM,
    'Environ Status = ', Status, ' OK=', Status=0, #32, St, '=', Ostr) ;
  EnvGet := Ostr end {EnvGet} ;
{$ENDIF BORPAS}


function GetLI(St : S32) : longint ;
var F : longint ; J : integer ; B : boolean ;
begin GetLI := 0 ;
  if St='' then EXIT ;
  B := false ;

{$IFDEF BORPAS}
  if St[1]='#' then begin B := St[2]='-' ;
    Delete(St, 1, 2) ;
    St := EnvGet(St) ;
    if St='' then EXIT ;
    end ;
{$ENDIF BORPAS}

  Val(St, F, J) ;
  if J<>0 then begin Writeln(Scr, NM, '"', St, '" Bad number') ; HALT(2) end ;
  if B then F := -F ;
  GetLI := F end {GetLI} ;


function FSep(const St : S3) : S3 ;
begin if St='' then FSep := #32 else FSep := St[1] ;
  if St[1] in ['0'..'9'] then FSep := '' end {Fsep} ;



type Bitz = (NoTime, NoDate, WeekNo, Use_JD, time_t, UKTaxW, UKTaxM, ThreeD,
  RFCfmt, Quartr, DaySec, UKform, TDdiff, B13, B14, RandNo) ;
BSet = set of Bitz ;


{Option Globals, preset}
const
{ UTZ : integer = 0 ; }
Sep : string [1] = 'T' ;
Dsp : string [1] = '-' ;
Tsp : string [1] = ':' ;
Fmt : Bset = [] ;
Beg : byte = 1 ;
Len : byte = 255 ;
Mon : boolean = false ;
USA : boolean = false ;
Summer : boolean = false ;
AndStr : string [10] = '' ;

{Date-Time Globals}
var Yr, XYr : integer ; Mo, XMo, Dy, XDy : byte ;
PlusDays, PlusSecs, XSecs : longint ;


procedure UTCfromEuroTime(const TZhrs : longint) ;
var PsHrs, ST_on, SToff : word ;
begin (* USA : With DST; 1987-2006 rules *)
  if not USA then begin { Shift to UK Civil }
    Dec(PlusSecs, TZhrs) ; Norm(Yr, Mo, Dy, PlusDays, PlusSecs) end ;

  PsHrs := (Mo*word(32)+       Dy          )*24 + (PlusSecs div 3600) ;

  ST_on := (03*word(32)+LastSun(Yr, 03, 31))*24 + 1 ;
  SToff := (10*word(32)+LastSun(Yr, 10, 31))*24 + 2 ;
  if USA then begin Inc(ST_on, 7*24+1) ; { Inc(SToff) } end ;

  Summer := (PsHrs >= ST_on) and (PsHrs < SToff) ;
  if Mon then Writeln(Scr, NM, 'Summer=', Summer) ;

  if USA then Dec(PlusSecs, TZhrs) ;
  if Summer then Dec(PlusSecs, 3600) end {UTCfromEuroTime} ;



function OutStrF : S32 ;
const D : byte = 10 ;
PM : array [boolean] of string [1] = ('+', '-') ;
var LI : longint ;
Yu, M, S : integer ; H, Mu, Du : byte ; Wu : shortint ; Ch : Char ;
Q : S32 ; Sign : string [1] ;
begin
  Sign := '' ;
  if Base=10 then D := 10 ;
  if Base=16 then D := 8 ;
  if Base=36 then D := 6 ; (** ??? **)
  repeat { until true }

    if RandRange>0 then begin Q := StrF(Random(RandRange), 5) ; BREAK end ;

    if TDdiff in Fmt then begin
      LI := YMDtoMJD(Yr, Mo, Dy)*86400+PlusSecs ;
      Sign := PM[LI<0] ; Q := StrF(Abs(LI), D) ; BREAK end ;

    if RandNo in Fmt then begin
      if Base=10 then Q := StrF(Random(10000), 4) ;
      if Base=16 then Q := StrF(Random($100), 2)+StrF(Random($100), 2) ;
      if Base=36 then Q := StrF(Random(36*36*36), 3) ;
      BREAK end ;

    if time_t in Fmt then begin Q :=
        StrF((YMDtoMJD(Yr, Mo, Dy)-40587)*86400+PlusSecs, D) ; BREAK end ;

    M := PlusSecs div 60 ; S := PlusSecs mod 60 ;
    H := M div 60 ; M := M mod 60 ;

    if (UKTaxW in Fmt) then begin
      UKTaxWeekNo(Yr, Mo, Dy, Yu, Wu, Du) ; Mu := Wu end else
      if (UKTaxM in Fmt) then begin
      UKTaxMonthDay(Yr, Mo, Dy, Yu, Wu, Du) ; Mu := Wu end else
      if (WeekNo in Fmt) then begin
      CTWeekNo_Day(Yr, Mo, Dy, Yu, Wu, Du) ; Mu := Wu end
    else begin Yu := Yr ; Mu := Mo ; Du := Dy end ;


    if noDate in Fmt then Q := '' else
      if (Use_JD in Fmt)
      then Q := StrF(YMDtoMJD(Yr, Mo, Dy)+2400001, D)

      else if (RFCfmt in Fmt)
      then Q := WkDstr[DayOfWeek(YMDtoMJD(Yu, Mu, Du))] + ', ' +
      D2(Du) + #32 + MonthS[Mu] + #32 + StrF(Yu, 4)

      else begin Q := StrF(Yu, 4) ;
      if Quartr in Fmt then begin Wu := (Mu-1) div 3 ;
        Ch := char(49 + Wu) ;
        Q := Q+Dsp + Ch + Dsp +
          D2(YMDtoMJD(Yr, Mo, Dy)-YMDtoMJD(Yr, 1+3*Wu, 1)+1) + #32 +
          Ch + 'Q' + D2(Yu mod 100) + #32 +
          Ch + 'Q' + StrF(Yu, 4) + #32 ;
        end
      else
        if ThreeD in Fmt
        then Q := Q+Dsp+StrF(YMDtoMJD(Yr, Mo, Dy)-YMDtoMJD(Yr, 1, 1)+1, 3) {Yu?}
        else
        if UKform in Fmt then Q := D2(Du)+Dsp+D2(Mu)+Dsp+Q
        else
        Q := Q+Dsp+D2(Mu)+Dsp+D2(Du) ;
      end ;


    if RFCfmt in Fmt then Q := Q + #32 else
      if Fmt*[noDate, noTime]=[] then Q := Q + Sep ;

    if not (noTime in Fmt) then begin
      if not (noDate in Fmt) then D := 5 ;
      if DaySec in Fmt then Q := Q + StrF(PlusSecs, D)
        {}             else Q := Q + D2(H)+Tsp+D2(M)+Tsp+D2(S) ;
      end ;

    if RFCfmt in Fmt then if AndStr='' then Q := Q + ' GMT'
      else Q := Q + #32 + Copy(AndStr, Succ(5*Ord(Summer)), 5) ;

    until true ;

  OutStrF := Sign + Copy(Q, Beg, Len) end {OutStrF} ;



procedure Zed(Z : byte) ;
var Y : integer ; W : shortint ; D : byte ;
const G : array [6..7, 15..17] of shortint = ((-1, -1, +2), (-2, +1, +1)) ;
begin
  if Z in [15..17] then begin CTWeekNo_Day(Yr, Mo, Dy, Y, W, D) ;
    if D>=6 then PlusDays := G[D, Z] ;
    EXIT end ;
  if Z=14 then begin Mo := 1 + 3*(Pred(Mo) div 3) ; Z := 4 end ;
  if Z=13 then begin
    if word(Mo)*32+Dy < 04*32+06 then Dec(Yr) ;
    Mo := 04 ; Dy := 06 ; Z := 3 end ;
  if Z in [11,12] then begin
    if Z=12 then UKTaxMonthDay(Yr, Mo, Dy, Y, W, D)
      {}    else UKTaxWeekNo(Yr, Mo, Dy, Y, W, D) ;
    PlusDays := -(D-1) ;
    Z := 3 end ;
  if Z=10 then begin Yr := 1970 ; Mo := 01 ; Dy := 01 ; Z := 3 end ;
  if Z=9  then begin Yr := 1858 ; Mo := 11 ; Dy := 17 ; Z := 3 end ;
  if Z in [7,8] then begin CTWeekNo_Day(Yr, Mo, Dy, Y, W, D) ;
    PlusDays := -(D-1) ;
    if Z=8 then Dec(PlusDays, 7*(W-1)) ;
    Z := 3 end ;
  if Z>=6 then Yr := 0001 ;
  if Z>=5 then Mo := 01 ;
  if Z>=4 then Dy := 01 ;
  if Z>=3 then PlusSecs := 86400*(PlusSecs div 86400) ;
  if Z>=2 then PlusSecs :=  3600*(PlusSecs div  3600) ;
  if Z>=1 then PlusSecs :=    60*(PlusSecs div    60) ;
  end {Zed} ;



procedure Initialise ;
var {$IFDEF BORPAS} X, DoW, {$ENDIF} Y, M, D, Hr, Mi, Sc, Cs : word ;
{$IFDEF DELPHI} DT : TDateTime ; {$ENDIF}
begin Randomize { caveat if scheduled } ;

{$IFDEF BORPAS}
  GetDate(Y, M, D, DoW) ;
  repeat X := DoW ;
    GetTime(Hr, Mi, Sc, Cs) ; GetDate(Y, M, D, Dow) until DoW=X ;
{$ENDIF BORPAS}
{$IFDEF DELPHI}
  DT := Now ;
  DecodeTime(DT, Hr, Mi, Sc, Cs {!} ) ;
  DecodeDate(DT, Y, M, D) ;
{$ENDIF DELPHI}

  Yr := Y ; Mo := M ; Dy := D ;
  PlusSecs := longint(Hr*60+Mi)*60+Sc ;
  PlusDays := 0 ;
  end {Initialise} ;



procedure GetDT(St : S32) ;
var Q : longint ; J, K, P : byte ; D, xD : boolean ; C : char ;
begin
  if Mon then Writeln(Scr, NM, 'GetDT parameter "', St, '"') ;
  if Pos('%', St)>0 then Writeln(Scr, NM, 'warning: % in GetDT parameter') ;
  St := St+#32 ;

  if time_t in Fmt then Zed(10) else
    if Use_JD in Fmt then Zed(9) else
    if RandNo in Fmt then RandSeed := $87654321 else
    Zed(6) ;

  PlusSecs := 0 ;
  D := false ; J := 0 ; Q := 0 ;
  if NoDate in Fmt then K := 3 else K := 0 ;
  while J < Length(St) do begin xD := D ;
    Inc(J) ; C := St[J] ;
    P := Pos(UpCase(C), Alf) ;
    D := (P>0) and (P<=Base) ;
    if D then Q := Q*Base+Pred(P) else
      if XD then begin
      Inc(K) ;
      case K of
        1 : if time_t in Fmt then PlusSecs := Q else
          if Use_JD in Fmt then MJDtoYMD(Q-2400001, Yr, Mo, Dy) else
          if RandNo in FMT then RandSeed := Q else
          if UKform in Fmt then Dy := Q else Yr := Q ;
        2 : if not (ThreeD in Fmt) then Mo := Q else begin
          Mo := 1 ; Dy := 0 ; PlusDays := Q ; Inc(K) end ;
        3 : if UKform in Fmt then Yr := Q else Dy := Q ;
        4 : Inc(PlusSecs, 3600*Q) ;
        5 : Inc(PlusSecs,   60*Q) ;
        6 : Inc(PlusSecs,      Q) ;
        else begin Writeln(Scr, NM, 'too many fields') ; HALT(4) end ;
        end {K} ;
      Q := 0 ;
      end {XD} ;
    end {while} ;

  if WeekNo in Fmt then
    MJDtoYMD(ISO_WNDtoMJD(GrgCal, Yr, Mo, Dy), Yr, Mo, Dy) ;

  if UKTaxW in Fmt then
    MJDtoYMD(UKTax_WNDtoMJD(Yr, Mo, Dy), Yr, Mo, Dy) ;

  if UKTaxM in Fmt then
    MJDtoYMD(UKTax_WMDtoMJD(Yr, Mo, Dy), Yr, Mo, Dy) ;

  { if Mon then Write(Scr, NM, 'GetDT') ; }
  end {GetDT} ;


{ $IFDEF BORPAS}
procedure FileDateStamp(var St : S80) ;
var F : file ; LI : longint ; B : boolean ;
const Prev : S80 = '' ;
begin
  B := St[1]='*' ; if B then Delete(St, 1, 1) ;

  if St='' then St := Prev else Prev := St ;

  (* Delphi : fileopen FileAge FileGetDate FileSetDate FmxUtils *)

  Assign(F, St) ; {$I-} Reset(F) {$I+} ;
  if IOResult<>0 then begin
    Writeln(Scr, NM, 'cannot get "', St, '"') ; HALT(5) end ;

  case B of
    false : begin
      GetFTime(F, LI) ;
      Yr := (LI shr 25)+1980 ;
      Mo := (LI shr 21) and $F ;
      Dy := (LI shr 16) and $1F ;
      PlusSecs := ((LI shr 11) and $1F) * 3600
        + ((LI shr 5) and $3F) * 60
        + ((LI shr 0) and $1F) * 2 ;
      end ;
    true : begin
      LI := longint(((Yr-1980) shl 4 + Mo) shl 5 + Dy) shl 16 +
        (PlusSecs div 3600) shl 11 +
        (PlusSecs mod 3600 div 60) shl 5 +
        PlusSecs mod 60 div 2 ;
      SetFTime(F, LI) ;
      end ;
    end ;

  Close(F) end {FileDateStamp} ;
{ $ENDIF BORPAS}



{$IFDEF BORPAS}
function DCB(const X : byte) : byte ;
begin DCB := 10*(X shr 4) + (X and $0F) end {DCB} ;


procedure GetRTC ;
var R : Registers ; XDL : byte ;
begin with R do begin
    AH := $04 ; Intr($1A, R) ;
    repeat XDL := DL ;
      AH := $02 ; Intr($1A, R) ;
      PlusSecs := (DCB(CH)*longint(60)+DCB(CL))*60+DCB(DH) ;
      AH := $04 ; Intr($1A, R) ;
      Yr := DCB(CH)*100+DCB(CL) ; Mo := DCB(DH) ; Dy := DCB(DL) ;
      until XDL = DL ;
    end end {GetRTC} ;
{$ENDIF BORPAS}


procedure ExecFile(const St : string) ; forward ;


procedure DoCommand(St : S80) ;
var Z : longint ; Ult : word ; Ch : char ;
{$IFNDEF DELPHI} Status, {$ENDIF} P : byte ;
{$IFNDEF DELPHI} Zmt : Bset ; Ostr : string ; {$ENDIF}

const DaysInMonth : array [1..12] of byte =
  (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) ;
begin
  if (Length(St)>1) and (St[1] in ['-', '/']) then Delete(St, 1, 1) ;
  Ch := UpCase(St[1]) ; Delete(St, 1, 1) ;

  case Ch of
    '?' : Help ;

{$IFDEF BORPAS}
    'E',
      'V' : begin Ostr := OutStrF ;
      Environ(Gen, Put, St, Ostr, Status) ;
      if (Ch='E') or (Status<>0) then Writeln(Scr, NM, 'Environ Status = ',
        Status, ' OK=', Status=0, #32, St, '=', Ostr) ;
      end ;
{$ENDIF BORPAS}

    'P' : Writeln('SET ' + St + '=' + OutStrF) ;
    'Q' : Writeln('@SET ' + St + '=' + OutStrF) ;

    'R' : begin St := {$IFDEF BORPAS} GetEnv(St) {$ELSE} '' {$ENDIF} ;
      P := Pos('œ', St) ; if P>0 then St[P] := '=' ;
      Write(St + OutStrF) ;
      if Dogs then Write('"') ; Dogs := false ;
      Writeln end ;

    'Y',
      '_' : begin Yr := Yr - GetLI(St) ;
      if (Ch<>'_') and (Mo=2) and (Dy>28) and not Greg_Leap_Year(Yr)
        then Dy := 28 ;
      end ;

    'N',
      '~' : begin Z := Mo - GetLI(St) ;
      while Z<01 do begin Inc(Z, 12) ; Yr := Yr-1 end ;
      while Z>12 do begin Dec(Z, 12) ; Yr := Yr+1 end ;
      if Ch<>'~' then { crop days } begin
        Ult := DaysInMonth[Z] + Ord((Z=2) and Greg_Leap_Year(Yr)) ;
        if Dy>Ult then Dy := Ult ;
        end ;
      Mo := Z end ;

    'W' : PlusDays := PlusDays - GetLI(St)*7 ;
    'D' : PlusDays := PlusDays - GetLI(St) ;
    'H' : PlusSecs := PlusSecs - GetLI(St)*3600 ;
    'M' : PlusSecs := PlusSecs - GetLI(St)*60 ;
    'S' : PlusSecs := PlusSecs - GetLI(St) ;
    'F' : word(Fmt) := GetLI(St) ;
    'I' : Sep := FSep(St) ;
    'J' : Dsp := FSep(St) ;
    'K' : Tsp := FSep(St) ;
    'B' : Beg := GetLI(St) ;
    'L' : Len := GetLI(St) ;
    'Z' : Zed(GetLI(St)) ;
    'X' : Mon := Odd(GetLI(St)) ;
    'G' : Gen := GetLI(St) ;
    'T' : GetDT(St) ;
{$IFDEF BORPAS}
    'O' : FileDateStamp(St) ;

    'C' : begin Ostr := EnvGet(St) ; GetDT(Ostr) end ;
{$ENDIF BORPAS}

    'U' : UTCfromEuroTime(3600*GetLI(St)) ;
    'A' : USA := Odd(GetLI(St)) ;
    '&' : AndStr := St ;
    ':' : if St[1]=':' then Writeln('??') else RandRange := GetLI(St) ;

    ']' : begin XYr := Yr ; XMo := Mo ; XDy := Dy ; XSecs := PlusSecs end ;
    '[' : begin Yr := XYr ; Mo := XMo ; Dy := XDy ; PlusSecs := XSecs end ;
    '-' : begin MJDtoYMD(YMDtoMJD(XYr, XMo, XDy)-YMDtoMJD(Yr, Mo, Dy),
        Yr, Mo, Dy) ; PlusSecs := XSecs - PlusSecs end ;
{$IFDEF BORPAS}
    '^' : GetRTC ;
{$ENDIF BORPAS}

    '$' : if St='$' then Base := 36 else Base := 16 ;
    '#' : Base := 10 ;
    'œ' : begin Write(Scr, NM, 'œ ? ') ; Readln end ;

    '''' : Write(St) ;
    '*' : begin
      if St='*' then begin Write('"') ; Dogs := not Dogs end else begin
        if St='' then Z := 1 else Z := GetLI(St) ;
        while Z>0 do begin Write(#32) ; Dec(Z) end ;
        end ;
      end ;

    '@' : ExecFile(St) ;

{$IFDEF BORPAS}
    '!' : begin
      Environ(Gen, Get, St, Ostr, Status) ;
      {} {$IFDEF DEBUG} Writeln(Scr, '*** !: Ostr="', Ostr, '"') ; {$ENDIF}
      if Status<>0 then Writeln(Scr, ^I, 'Environ Status = ', Status,
        ', OK=', Status=0 {, #32, St, '=', Ostr}) ;
      if Status<>0 then
        begin Writeln('Environment read failed') ; HALT(11) end ;
      SwapVectors ; Exec(GetEnv('COMSPEC'), ' /C '+Ostr) ;
      SwapVectors end ;
{$ENDIF BORPAS}

    '=' : ;

    'ª' : GregorianEaster(Yr, Mo, Dy) ;

    ';' : EXIT ;
    else begin
      Writeln(Scr, NM, Ch, ' = Bad option') ; HALT(3) end ;
    end {Ch} ;

  Norm(Yr, Mo, Dy, PlusDays, PlusSecs) ;
  if Mon then Writeln(Scr, NM, #32, Yr, #32, Mo, #32, Dy, ', ', PlusSecs) ;
  end {DoCommand} ;


procedure ExecFile(const St : string) ;
var F : text ; S : string ; P : byte ;
begin Assign(F, St) ; Reset(F) ;
  while not EoF(F) do begin Readln(F, S) ; S := S + #32 ;
    repeat
      if S='' then BREAK ;
      P := Pos(#32, S) ; if P=1 then begin Delete(S, 1, 1) ; CONTINUE end ;
      DoCommand(Copy(S, 1, P-1)) ; Delete(S, 1, P) ;
      until false ;
    end { line } ;
  Close(F) end {ExecFile} ;


procedure ProcessParameters ;
var Par : word ;
begin
  for Par := 1 to ParamCount do DoCommand(ParamStr(Par)) ;
  end {ProcessParameters} ;



BEGIN ;
{} {$IFDEF DEBUG}
{} TextMode(LastMode + Font8x8) ;
{} Writeln('*** NOWMINUS starting') ;
{} {$ENDIF}
Assign(Scr, 'CON') ; Rewrite(Scr) ;
if ParamCount=0 then Help ;
Initialise ;
ProcessParameters ;
if Mon then Writeln(Scr, NM, 'ends OK.') ;
Close(Scr) ;
{ Examples in NOWMINUS.TXT }
END.