برنامه زیر یک Console Application به زبان دلفی است که کار تبدیل تاریخ میلادی به شمسی و بالعکس با یک تبدیل خطی انجام میده:
program ProjectSolarDate;
{$APPTYPE CONSOLE}
uses
SysUtils,DateUtils;
procedure AShams_DivMod(A,B:Integer;var _Div, _Mod: Integer);
begin
_Mod := A mod B;
if _Mod < 0 then
if B > 0 then Inc(_Mod,B) else Dec(_Mod,B);
_Div := (A - _Mod) div B;
end;
function AShams_EncodeJulianDate(Y,M,D:Integer): Integer;
var
_Div,_Mod:Integer;
begin
AShams_DivMod(M-1,12,_Div,_Mod); M := _Mod + 1; Inc(Y, _Div);
AShams_DivMod(Y,400,_Div,_Mod); Result := (_Div - 1) * 146097;
Inc(Result, Round(EncodeDate(_Mod+400,M,1)+D-1));
end;
procedure AShams_DecodeJulianDate(JulianDate:Integer;var Y,M,D: Integer);
var
Wy, Wm, Wd: Word;
_Div,_Mod:Integer;
begin
AShams_DivMod(JulianDate,146097,_Div,_Mod); Y := (_Div - 1) * 400;
DecodeDate(_Mod+146097, Wy, Wm, Wd); Inc(Y,Wy); M := Wm; D := Wd;
end;
function AShams_EncodeSolarDate(Y,M,D:Integer):Integer;
var
DayOfYear,_Div,_Mod:Integer;
begin
AShams_DivMod(M-1,12,_Div,_Mod); M := _Mod + 1; Inc(Y, _Div);
DayOfYear := (M-1)*31+D; if M > 7 then Dec(DayOfYear, M-7);
AShams_DivMod(Y*12053+21,33,_Div,_Mod);
Result := _Div+DayOfYear-467065;
end;
procedure AShams_DecodeSolarDate(SolarDate:Integer;var Y,M,D:Integer);
var
DayOfYear,_Div,_Mod:Integer;
begin
AShams_DivMod(SolarDate*33+9389,12053,_Div,_Mod);
Y := _Div + 1278;
DayOfYear := _Mod div 33 + 1;
if DayOfYear < 187 then
begin
M := 1 + (DayOfYear-1) div 31;
D := 1 + (DayOfYear-1) mod 31;
end else begin
M := 7 + (DayOfYear-187) div 30;
D := 1 + (DayOfYear-187) mod 30;
end;
end;
procedure AShams_JulianToSolar(var Y,M,D:Integer);
begin
AShams_DecodeSolarDate(AShams_EncodeJulianDate(Y,M,D),Y,M,D);
end;
procedure AShams_SolarToJulian(var Y,M,D:Integer);
begin
AShams_DecodeJulianDate(AShams_EncodeSolarDate(Y,M,D),Y,M,D);
end;
var
BothJulianAndSolarDate,Y,M,D:Integer;
begin
{ TODO -oUser -cConsole Main : Insert code here }
for BothJulianAndSolarDate := 1000000 downto -1000000 do
begin
AShams_DecodeJulianDate(BothJulianAndSolarDate,Y,M,D);
if AShams_EncodeJulianDate(Y,M,D) <> BothJulianAndSolarDate then
Writeln(Format('Error in Julian (%8d : %5d/%2.2d/%2.2d) decode or endcode.',
[BothJulianAndSolarDate,Y,M,D]));
AShams_DecodeSolarDate(BothJulianAndSolarDate,Y,M,D);
if AShams_EncodeSolarDate(Y,M,D) <> BothJulianAndSolarDate then
Writeln(Format('Error in Solar (%8d : %5d/%2.2d/%2.2d) decode or endcode.',
[BothJulianAndSolarDate,Y,M,D]));
end;
end.