Добавил на Паскале алгоритм Гаусса ( https://www.hmong.press/wiki/Determination_of_the_day_of_the_week ) и применил его в нужном месте.
То есть всё, что было возможно существующими средствами сделал, ускорил. Но выглядит всё равно не очень.
Для идеального языка программирования нужны хорошие возможности работы с временем.
В существующем Паскале и вовсе отрицательный год не предусмотрен: https://www.freepascal.org/docs-html/rt ... edate.html
Year
must be between 1 and 9999.
Отсюда (как минимум)
https://www.freepascal.org/docs-html/rt ... eweek.html
ограничен.
То же и с алгоритмом из Википедии.
Не существует ли готовых быстрых свободных реализаций Weekday с любым числом года ?
Ну и наверное возможно сделать новый. Гаусс жил давно. Но это посложнее.
Собственно текущая версия юнита:
- Код: Выделить всё
unit time;
{$MODE OBJFPC}
{$LONGSTRINGS ON}
{$RANGECHECKS ON}
{$SMARTLINK ON}
{$GOTO ON}
{$ASMMODE INTEL}
{$CODEPAGE UTF8}
{$ModeSwitch UnicodeStrings}
{
Time unit.
For GNU/Linux 64 bit version.
Version: 1.
Written on FreePascal (https://freepascal.org/).
Copyright (C) 1995-2019 Artyomov Alexander
http://self-made-free.ru/ (Ex http://aralni.narod.ru/)
aralni@mail.ru
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
}
interface uses sysutils;
type
TMonth = 1..12;
TDay = 1..31;
TTick = 0..59;
THour = 0..23;
TQuartal = 1..4;
TWeekDay = 0..6;
TWeekDayRu = 1..7;
const
monlen : array [TMonth] of TDay = (31,28,31,30,31,30,31,31,30,31,30,31);
var
wdn : array[0..7] of utf8string;
wdn2 : array[0..7] of utf8string;
mon_names : array[TMonth] of utf8string;
mon_names3 : array[TMonth] of utf8string;
function vg(y : Int64) : boolean; // finding bissextile from known year.
function Weekday(year: Int64; month: TMonth; day: TDay): TWeekday; // finding weekday number by known year, month, day.
function WeekdayRu(year: Int64; month: TMonth; day: TDay) : TWeekDayRu;
function inttofix2str(i : Int64) : string;
function monthlen(y : Int64; m : TMonth) : TDay;
function f0(m : TMonth; d : TDay) : byte;
function fdnd(y : Int64; m : TMonth; d : TDay) : Int64;
function Gauss(y : Int64) : Int64;
function gaussedfdnd(y : Int64; m : TMonth; d : TDay) : Int64;
implementation
var
f : Int64;
function inttofix2str(i : Int64) : string;
begin result := inttostr(i);if 10 > i then result := '0' + result; end;
function Gauss(y : Int64) : Int64; // 1... y
var
Aminus1: Int64;
begin
Aminus1 := y - 1;
result := (1 + 5*(Aminus1 mod 4) + 4*(Aminus1 mod 100) + 6*(Aminus1 mod 400)) mod 7;
if result = 0 then result := 7; // ru
end;
function vg(y : Int64) : boolean;
begin
vg := ((int(y / 4) = y / 4) and (not(int(y / 100) = y / 100))) or (int(y / 400) = y / 400);
end;
function Weekday(year: Int64; month: TMonth; day: TDay): TWeekDay;
begin
if year = 0 then Exit(f0(month,day));
if year < 0 then Exit(fdnd(year, month, day));
if month < 3 then begin
year := year - 1;
month := month + 10;
end else month := month - 2;
Weekday := (day + 31 * month div 12 + year + year div 4 - year div 100 + year div 400) mod 7;
end;
function WeekdayRu(year: Int64; month: TMonth; day: TDay) : TWeekDayRu;
var tmp : byte;
begin
tmp := WeekDay(year, month, day);
if tmp = 0 then Exit(7) else Exit(tmp);
end;
function monthlen(y : Int64; m : TMonth) : TDay;
begin
if (m = 2) and vg(y) then Exit(29);
Exit(monlen[m]);
end;
function f0(m : TMonth; d : TDay) : byte;
label ex;
const
monl : array [TMonth] of TDay =(31,29,31,30,31,30,31,31,30,31,30,31);
var f,fm : QWord;
begin
result := 6;
for fm := 1 to 12 do begin
for f := 1 to monl[fm] do begin
if fm = m then if f = d then goto ex;
inc(result); if result = 8 then result := 1;
end;
end;
ex:
if result = 7 then result := 0; // to eng
end;
function fdnd(y : Int64; m : TMonth; d : TDay) : Int64;
var f,fy,fm : Int64;
begin
fy := 2019; result := 2;
if y > fy then begin while y <> fy do begin
if vg(fy) then inc(result);
inc(fy); inc(result);
if result = 8 then result := 1; if result = 9 then result := 2;
end; end else begin
if y < fy then while y <> fy do begin
dec(fy);
if vg(fy) then begin
dec(result); if result = 0 then result := 7; end;
dec(result);
if result = 0 then result := 7;
end; end;
for fm := 1 to 12 do begin
for f := 1 to monthlen(y, fm) do begin
if fm = m then if f = d then exit;
inc(result); if result = 8 then result := 1;
end;
end;
end;
function gaussedfdnd(y : Int64; m : TMonth; d : TDay) : Int64;
var f,fy,fm : Int64;
begin
if y > 0 then begin
result := Gauss(y);
end else begin
fy := 2019; result := 2;
if y > fy then begin while y <> fy do begin
if vg(fy) then inc(result);
inc(fy); inc(result);
if result = 8 then result := 1; if result = 9 then result := 2;
end; end else begin
if y < fy then while y <> fy do begin
dec(fy);
if vg(fy) then begin
dec(result); if result = 0 then result := 7; end;
dec(result);
if result = 0 then result := 7;
end; end;
end;
for fm := 1 to 12 do begin
for f := 1 to monthlen(y, fm) do begin
if fm = m then if f = d then exit;
inc(result); if result = 8 then result := 1;
end;
end;
end;
initialization
for f := 1 to 7 do wdn2[f-1] := DefaultFormatSettings.ShortDayNames[f]; wdn2[7] := wdn2[0];
for f := 1 to 7 do wdn[f-1] := DefaultFormatSettings.LongDayNames[f]; wdn[7] := wdn[0];
for f := 1 to 12 do mon_names[f] := DefaultFormatSettings.LongMonthNames[f];
for f := 1 to 12 do mon_names3[f] := DefaultFormatSettings.ShortMonthNames[f];
end.
