unit ckcalend;

interface

uses dvcrt, dvwin,
windos,
ckjan, ckvars;

    function calcDias (dd, mm, aa: integer): longint;
    procedure calendario;

implementation

function calcDias (dd, mm, aa: integer): longint;
var l: longint;
    i: integer;
const
    tabmes: array [1..12] of integer =
        (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
    l := aa * longint(365);
    for i := 0 to aa-1 do
        if (i mod 4) = 0 then l := l + 1;
    for i := 1 to mm-1 do
        l := l + tabMes [i];
    if ((aa mod 4) = 0) and (mm > 2) then
        l := l + 1;
    l := l + dd;

    calcDias := l;
end;

{--------------------------------------------------------}

procedure calendario;
const
tabMes: array [1..12] of word = (
        31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
var
    diaDig, mesDig, anoDig: word;
    diaSemana, somaDias: word;
    indMes: word;
    erro, i: integer;
    arqSantos: text;
    arqSt: string;
    santoDoDia: string;
    indSanto: integer;
    signo: string;
    opcao: char;
    s: string;

label mostraSignos, redefineData, fim;

begin

    if senha <> '' then
    begin
        writeln;
        write ('Informe a senha : ');
        sintsom ('cksenhap');
        sintreadln (s);
        if s <> senha then
        exit;
    end;

    {INTERFACE GRÁFICA}

    jan_mei;
    sintsom ('cktec');

    gotoxy (10, 5);
    write ('Digite uma data qualquer e obtenha : ');
    gotoxy (10, 6);
    write ('O dia da semana');
    gotoxy (10, 7);
    write ('O santo do dia');
    gotoxy (10, 8);
    write ('O estágio da lua');
    gotoxy (10,9);
    write ('O signo respectivo');

    {DIA DA SEMANA}

    jan_fim;

redefineData:
    delline;
    write ('Qual o dia desejado ? No formato dia/mês/ano : ');
    sintsom ('ckddes');
    sintsom ('ckformd');
    sintreadln (s);
    dataString:= s;
    if dataString = '' then exit;

    i := pos ('/', dataString);
    val (copy (dataString,1,i-1), diaDig, erro);
    if erro <> 0 then goto redefineData;
    delete (dataString, 1, i);
    i := pos ('/', dataString);
    val (copy (dataString,1, i-1), mesDig, erro);
    if erro <> 0 then goto redefineData;
    delete (dataString, 1, i);
    val (dataString, anoDig, erro);
    if erro <> 0 then goto redefineData;
    if anoDig <= 99 then anoDig := anoDig + 1900;

    diaSemana := (4+calcDias (diaDig, mesDig, anoDig)) mod 7;

    if (diaDig < 1) or (diaDig > 31)
    or
    (mesDig < 1) or (mesDig > 12)
    or
    (mesDig = 02) and (diaDig >= 29)
    or
(anoDig < 1900) or (anoDig > 2099) then

        begin
            sintsom ('ckdinc');
            goto redefineData;
        end;

    {RESULTADO DA CONSULTA}

    sintsom ('ckcal');

    if diaSemana = 0 then begin
    writeln ('Domingo');
    sintsom ('ckdoming'); end;

    if diaSemana = 1 then begin
    writeln ('Segunda-feira');
    sintsom ('cksegund'); end;

    if diaSemana = 2 then begin
    writeln ('Terça-feira');
    sintsom ('ckterc'); end;

    if diaSemana = 3 then begin
    writeln ('Quarta-feira');
    sintsom ('ckquart'); end;

    if diaSemana = 4 then begin
    writeln ('Quinta-feira');
    sintsom ('ckquint'); end;

    if diaSemana = 5 then begin
    writeln ('Sexta-feira');
    sintsom ('cksext'); end;

    if diaSemana = 6 then begin
    writeln ('Sábado');
    sintsom ('cksabad'); end;

    {SANTO DO DIA}

    somaDias:= 0;
    indMes:= 0;

    if mesDig > 1 then
    begin
        repeat
        indMes:= indMes + 1;
        SomaDias:= somaDias + tabMes[indMes];
    until indMes = mesDig - 1;
    end;

    somaDias:= somaDias + diaDig;

    arqSt:= sintAmbiente ('CLOCKVOX', 'ARQSANTOS');
    if arqSt = '' then goto mostraSignos;

    assign (arqSantos, arqSt);
    {$i-} reset(arqSantos); {$i+}
    If IOresult <> 0  then
    sintbip
    {sintetiza ('Não será possível informar o santo do dia, o arquivo foi excluído da memória')}
    else
    begin
        indSanto:= 0;
        repeat
        indSanto:= indSanto + 1;
            readln (arqSantos, santoDoDia);
        until indSanto = somaDias;

    close (arqSantos);

    if (anoDig mod 4 = 0) and (diaDig = 29) and (mesDig = 2) then
    begin
        writeln ('Ano bissexto, não se homenagea nenhum santo neste dia');
        sintsom ('ckanob');
    end
    else
    begin
        delete (santoDoDia, 1,6);
        write ('Santo do dia: ');
        sintsom ('cksanto');
        sintwriteln (santoDoDia);
    end;

    end;

    {SIGNO}

mostraSignos:

    s:= '';
    signo:= 'HOUVE ERRO NA CONVERÇÃO';

    s := sintAmbiente ('CLOCKVOX', 'COMSIGNOS');
    if (s <> '') and (upcase(s[1]) = 'N') then goto fim;

    if ((mesDig = 1) and (diaDig > 20)) or
       ((mesDig = 2) and (diaDig < 20)) then
             signo:= 'Aquário';

    if ((mesDig = 2) and (diaDig > 19)) or
       ((mesDig = 3) and (diaDig < 21)) then
            signo:= 'Peixes';

    if ((mesDig = 3) and (diaDig > 20)) or
       ((mesDig = 4) and (diaDig < 21)) then
            signo:= 'Aries';

    if ((mesDig = 4) and (diaDig > 20)) or
       ((mesDig = 5) and (diaDig < 21)) then
            signo:= 'Touro';

    if ((mesDig = 5) and (diaDig > 20)) or
       ((mesDig = 6) and (diaDig < 21)) then
            signo:= 'Gêmeos';

    if ((mesDig = 6) and (diaDig > 20)) or
       ((mesDig = 7) and (diaDig < 22)) then
            signo:= 'Câncer';

    if ((mesDig = 7) and (diaDig > 21)) or
       ((mesDig = 8) and (diaDig < 23)) then
            signo:= 'Leão';

    if ((mesDig = 8) and (diaDig > 22)) or
       ((mesDig = 9) and (diaDig < 23)) then
            signo:= 'Virgem';

    if ((mesDig = 9)  and (diaDig > 22)) or
       ((mesDig = 10) and (diaDig < 23)) then
            signo:= 'Libra';

    if ((mesDig = 10) and (diaDig > 22)) or
       ((mesDig = 11) and (diaDig < 22)) then
            signo:= 'Escorpião';

    if ((mesDig = 11) and (diaDig > 21)) or
       ((mesDig = 12) and (diaDig < 22)) then
            signo:= 'Sagitário';

    if ((mesDig = 12) and (diaDig > 21)) or
       ((mesDig = 1 ) and (diaDig < 21)) then
            signo:= 'Capricórnio';;

    write ('Signo regente : ');
    sintsom ('cksigno');

    sintwriteln (signo);

    {CONFIRMA O FIM}

fim:
    write ('Deseja mais uma consulta ? (S/N) : ');
    sintsom ('ckcons');
    opcao:= sintreadkey;
    writeln;
    if upcase(opcao) = 'S' then
    goto redefineData;

end; {procedure}

end.
