Calendario perpetuo - CalendarioPerpetuo.lpr
Cerca
 
Programmi ~ Forum ~ Blog ~ Community ~ Project Zone ~ Supportaci ~ Feeds    











Ico Feeds
Ico Sondaggio
Google Plus o Facebook?

Facebook
Google Plus

Ico Condividi
Entra nel nostro gruppo su FB!

Ico Supportaci

16,40 €
Visita il negozio
Ico Numeri
Programmi: 2510
Articoli: 585
Progetti: 327
Sorgenti: 3546
Topics: 19195
Membri: 277

CalendarioPerpetuo.lpr

 Caricato da: Poggi Marco
Scarica il programma completo

  1. program CalendarioPerpetuo;
  2. (* Calendario perpetuo.
  3.  * Calcola il giorno della settimana di una data.
  4.  * Nota: la data deve essere successiva al 1/01/1900
  5. *)
  6.  
  7. {$mode objfpc}{$H+}
  8.  
  9. uses
  10.   {$IFDEF UNIX}{$IFDEF UseCThreads}
  11.   cthreads,
  12.   {$ENDIF}{$ENDIF}
  13.   Classes
  14.   { you can add units after this };
  15.  
  16. {$IFDEF WINDOWS}{$R CalendarioPerpetuo.rc}{$ENDIF}
  17.  
  18. var g,m,a:integer;
  19.       giorni:longint; (*Usa longint perche' ha un intervallo di
  20.                         rappresentabilita' maggiore di integer *)
  21.       i:integer;
  22.       bis:boolean;
  23.  
  24.   (* Restituisce true se anno e' bisestile *)
  25.   function bisestile(anno:integer):boolean;
  26.     begin
  27.       bisestile := ((anno mod 4 = 0) and not (anno mod 100 = 0))
  28.                    or (anno mod 400 = 0);
  29.     end;
  30.  
  31.   (* Restituisce il numero di giorni in un mese.
  32.    * Il parametro bis indica se l'anno e' bisestile
  33.    *)
  34.   function giorniMese(mese:integer; bis:boolean):integer;
  35.     begin
  36.       case mese of
  37.         1: giorniMese:=31;
  38.         2: if bis then
  39.              giorniMese:=29
  40.            else
  41.              giorniMese:=28;
  42.         3: giorniMese:=31;
  43.         4: giorniMese:=30;
  44.         5: giorniMese:=31;
  45.         6: giorniMese:=30;
  46.         7: giorniMese:=31;
  47.         8: giorniMese:=31;
  48.         9: giorniMese:=30;
  49.        10: giorniMese:=31;
  50.        11: giorniMese:=30;
  51.        12: giorniMese:=31;
  52.        else
  53.          begin
  54.            writeln('ERRORE in giorniMese: mese=', mese);
  55.          end
  56.       end;
  57.     end;
  58.  
  59. function domanda(testo:string; l1,l2:integer):integer;
  60. var x:integer;
  61.     ch:boolean;
  62. begin
  63.  repeat
  64.    write(testo);
  65.    {$I-}
  66.      readln(x);
  67.    {$I+}
  68.    if IoResult<>0 then
  69.    begin
  70.      ch:=false;
  71.      writeln('Sono ammessi solo numeri interi');
  72.    end
  73.    else
  74.    begin
  75.      ch:=(x>=l1) and (x<=l2);
  76.      if not ch then writeln('I limiti ammessi vanno da ',l1,' a ',l2);
  77.    end;
  78.  until ch;
  79.  domanda:=x;
  80. end;
  81.  
  82.   (* Parte esecutiva del programma principale *)
  83.  
  84. begin
  85.   write('Inserisci la data (giorno mese anno): ');
  86.   writeln;
  87.   g:=domanda('Giorno ', 1, 31);
  88.   m:=domanda('Mese ', 1, 12);
  89.   a:=domanda('Anno ', 1900, 2500);
  90.     giorni:=0;
  91.     for i:=1900 to a-1 do
  92.       begin
  93.         giorni:=giorni+365;
  94.         if bisestile(i) then
  95.           giorni:=giorni+1;
  96.       end;
  97.     bis:=bisestile(a);
  98.     for i:=1 to m-1 do
  99.       giorni:=giorni + giorniMese(i, bis);
  100.     giorni := giorni + g-1;
  101.  
  102.     write('Il gioeno e'': ');
  103.     case giorni mod 7 of
  104.       0: writeln('Lunedi''');
  105.       1: writeln('Martedi''');
  106.       2: writeln('Mercoledi''');
  107.       3: writeln('Giovedi''');
  108.       4: writeln('Venerdi''');
  109.       5: writeln('Sabato');
  110.       6: writeln('Domenica');
  111.     end;
  112.     readln;
  113. end.
 

Creative Commons License
Il layout di questo sito è concesso sotto licenza Creative Commons.
Per maggiori informazioni sulle licenze dei contenuti del sito, clicca.