Software realizzato in PASCAL
Turbo Pascal 3.02 - Borland Inc.©
Program astrologia;
const ndati=8;
type
matrice=array[1..200,1..ndati] of char; {*200 righe per ndati colonne*}
var x,y,z,a:string [10];
luogo:string [20];
totaledati, moda, mese,giorno,anno:integer;
ora,min:string [2];
risposta,sex,classe,sezione,credi,leggi,carat,corrisponde,pause,perche,condiz:char;
statistica:matrice;
file_disco:file of char;
nome_file:string [14];
errore,ancora:boolean;
{----------------------------------------------------}
PROCEDURE fondo_pagina;
const bianco=' ';
var i:integer;
begin
for i:=18 to 23 do
begin
gotoxy (1,i);
writeln (bianco);
end;
gotoxy (1,20);
end;
{----------------------------------------------------}
PROCEDURE fondo;
begin
gotoxy (1,24);
end;
{----------------------------------------------------}
PROCEDURE scrive_su_file (var numdati:integer; var vscrive:matrice);
var i,j:integer;
c:char;
begin
nome_file:='2.a';
assign(file_disco,nome_file);
rewrite (file_disco);
c:=chr(numdati);
write (file_disco,c);
for i:=1 to numdati do
for j:=1 to ndati do
write (file_disco,vscrive[i,j]);
close (file_disco);
end;
{----------------------------------------------------}
PROCEDURE legge_da_file (var numdati:integer; var vlegge:matrice);
var filesi:boolean;
i,j:integer;
c:char;
err:integer;
begin
filesi:=false;
nome_file:='2.a';
assign(file_disco,nome_file);
{$I-} reset(file_disco); {$I+}
filesi:=(IOresult=0);
if not (filesi) then exit;
read(file_disco,c);
numdati:=ord(c);
for i:=1 to numdati do
for j:=1 to ndati do
read(file_disco,vlegge[i,j]);
close(file_disco);
end;
{----------------------------------------------------}
{*riempie la matrice da registrare con i dati letti*}
PROCEDURE fadati;
var numero:integer;
sudisco:matrice;
var c,control:char;
begin
repeat
fondo;
write ('Vuoi registrare i dati inseriti? [S/N]');
readln (control);
until (control='S') or (control='s') or (control='N') or (control='n');
if (control='S') or (control = 's') then
begin
legge_da_file (numero,sudisco); {legge dal disco quelli gia' registrati}
numero:= numero+1;
writeln('registrazione dati nø',numero);
sudisco[numero,1]:=sex;
sudisco[numero,2]:=chr(anno);
sudisco[numero,3]:=credi;
sudisco[numero,4]:=leggi;
sudisco[numero,5]:=perche;
sudisco[numero,6]:=carat;
sudisco[numero,7]:=condiz;
sudisco[numero,8]:=corrisponde;
scrive_su_file (numero,sudisco); {riscrive su disco quelli vecchi piu' quello nuovo}
writeln ('eseguita. Premere invio per continuare');
read (control);
end;
end;
{----------------------------------------------------}
PROCEDURE preambolo;
begin
clrscr;
writeln ('LA CLASSE 2°A P.N.I. STA FACENDO UNA INCHIESTA SUGLI OROSCOPI;');
writeln (' ');
writeln ('SICURI DELLA TUA COLLABORAZIONE TI ELABOREREMO UN PROFILO ASTRALE');
writeln ('AL TERMINE DEL QUALE TI SOTTOPORREMO ALCUNE DOMANDE;');
writeln ('GRAZIE ');
end;
{----------------------------------------------------}
PROCEDURE pausa;
begin
writeln (' ');
writeln ('Premi un tasto per continuare...');
repeat
until keypressed;
end;
{----------------------------------------------------}
PROCEDURE riga15;
const bianco=' ';
var i:integer;
begin
for i:=14 to 23 do
begin
gotoxy (1,i);
writeln (bianco);
end;
gotoxy (1,15);
end;
{----------------------------------------------------}
PROCEDURE error;
begin
gotoxy (20,22);
writeln ('Dato errato, ripeti l''operazione!');
sound (500); delay (1000); sound (800); delay (1000); sound (1000); delay (1000);
nosound ;
end;
{----------------------------------------------------}
PROCEDURE controllo_dati ;
var gmax:integer ;
begin
case mese of
1,3,5,7,8,10,12:
gmax:=31;
2:
begin
moda := anno mod 4;
if moda = 0 then gmax:=29 else gmax:=28
end;
4,6,9,11:
gmax:=30 ;
end;
errore:=false ;
if gmax<giorno then
begin
errore:=true ;
error;
writeln (' - Metti il giorno giusto -');
end ;
end ;
{----------------------------------------------------}
PROCEDURE sesso;
begin
repeat
riga15;
writeln ('Dimmi di che sesso sei: M o F');
readln (sex);
if not ((sex='m') or (sex='M') or (sex='f') or (sex='F')) then error;
until (sex='m') or (sex='M') or (sex='f') or (sex='F');
if (sex= 'm') or (sex= 'M') then x:='o'
else x:='a';
if (sex= 'm') or (sex= 'M') then z:=' '
else z:='a';
if (sex= 'm') or (sex= 'M') then a:='ore'
else a:='rice';
end;
{----------------------------------------------------}
PROCEDURE domande1;
begin
repeat
riga15;
repeat
riga15;
anno:=0; giorno:=0; mese:=0;
write ('Dimmi l'' anno di nascita (le ultime due cifre)');readln(anno);
writeln ('Dimmi il luogo di nascita ');readln(luogo);
writeln('Dimmi il giorno di nascita ');readln(giorno);
writeln('Dimmi il mese di nascita ');readln(mese);
writeln ('');
if not ((anno>1) and (anno<86) )then error;
until (anno>1) and (anno<86) ;
controllo_dati ;
if errore then error
until not (errore);
riga15;
repeat
riga15;
writeln ('Per ottenere una maggiore precisione nel profilo astrale se la conosci');
writeln ('introduci la tua ora di nascita nel formato cosŤ indicato - XX:XX -');
gotoxy (9,17); writeln (':');
gotoxy (7,17); read (ora);
gotoxy (10,17); read (min);
if not( (ora>='0') and (ora<='24') or (ora=' ') and (min>='0') and (min<='60') or (min=' ')
then error;
until (ora>='0') and (ora<='24') or (ora=' ') and (min>='0') and (min<='60') or (min=' ');
end;
{----------------------------------------------------}
PROCEDURE domande3;
begin
repeat
riga15;
writeln ('Il suddetto profilo astrale corrisponde al tuo carattere?');
writeln ('1)esattamente 2)molto 3)poco 4)per niente');
writeln ('');
readln (corrisponde);
if not ((corrisponde>='1') and (corrisponde <='4')) then error;
until (corrisponde>='1') and (corrisponde <='4');
end;
{----------------------------------------------------}
PROCEDURE ritieni;
begin
repeat
riga15;
writeln ('Perch‚ li leggi ?');
writeln ('1)Ci credo 2)Per curiosit… 3)Per caso ');
readln (perche);
if not ( (perche>='1') and (perche<='3')) then error;
until (perche>='1') and (perche<='3');
repeat
riga15;
writeln ('Ritieni che quanto si legge negli oroscopi dei settimanali descriva con');
writeln ('precisione gli eventi che effettivamente caratterizzano la tua vita?');
writeln ('1)esattamente 2)molto 3)abbastanza 4)poco 5)per niente');
writeln('');
readln (carat);
if not ((carat>='1') and (carat<='5')) then error;
until (carat>='1') and (carat<='5');
repeat
riga15;
writeln ('Gli oroscopi condizionano la tua esistenza ?');
writeln ('1)Moltissimo 2)Molto 3Qualche volta 4)Poco 5)Per niente');
readln (Condiz);
if not ((condiz>='1') and (condiz<='5')) then error;
until (condiz>='1') and (condiz<='5');
domande3;
end;
{----------------------------------------------------}
PROCEDURE domande2;
begin
repeat
riga15;
writeln ('Sei superstizioso ?');
writeln ('1)Molto 2)Abbastanza 3)poco 4)per niente');writeln('');
readln (credi);
if not ((credi >='1') and (credi <= '4')) then error;
until (credi >='1') and (credi <= '4');
repeat
riga15;
writeln ('Con che frequenza leggi gli oroscopi ?');
writeln ('1)Regolarmente 2)Qualche volta 3)Quasi mai 4)Per niente');writeln('');
readln (leggi);
if not ((leggi>='1') and (leggi<='4')) then error;
until (leggi>='1') and (leggi<='4');
if leggi <> '4' then ritieni;
if leggi = '4' then
begin
perche:='0'; carat:='0'; condiz:='0';
domande3;
end;
end;
{----------------------------------------------------}
PROCEDURE domande4;
begin
repeat
riga15;
writeln ('Gli oroscopi condizionano la tua esistenza ?');
writeln ('1)Moltissimo 2)Molto 3Qualche volta 4)Poco 5)Per niente');
readln (Condiz);
if not ((Condiz>='1') and (condiz<='5')) then error;
until (Condiz>='1') and (condiz<='5');
end;
{----------------------------------------------------}
PROCEDURE testo1;
begin
clrscr;
writeln (' '); writeln(' '); writeln(' ');
writeln ('Il seguente profilo astrale tiene conto del tuo segno e ascendente');
writeln ('è stato realizzato dal computer secondo le disposizioni di un noto');
writeln ('astrologo in base alla tua data e luogo di nascita.');
writeln (' '); writeln (' ');
writeln ('Dopo aver letto attentamente il tuo profilo astrale, sei pregat',x,' di compilare');
writeln ('il questionario allegato per valutare la accuratezza del profilo medesimo.');
writeln (' '); writeln (' '); writeln (' ');
end;
{----------------------------------------------------}
PROCEDURE testo2;
PROCEDURE music;
CONST
DOB= 258; FA= 345; SOL= 387; LA= 435; SIB= 461; DOA= 516;
T1= 200; T2= 400; T3= 600; T4= 800; T5= 0;
{----------------------------------------------------}
PROCEDURE battuta_uno;
BEGIN
SOUND (LA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (LA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (SIB);DELAY (T2); NOSOUND; DELAY (T5);
SOUND (DOA);DELAY (T2); NOSOUND; DELAY (T5);
END;
{----------------------------------------------------}
PROCEDURE battuta_due;
BEGIN
SOUND (DOA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (SIB); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (LA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (SOL); DELAY (T2); NOSOUND; DELAY (T5);
END;
{----------------------------------------------------}
PROCEDURE battuta_tre;
BEGIN
SOUND (FA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (FA); DELAY (T2); NOSOUND; DELAY (T5);
SOUND (SOL);DELAY (T2); NOSOUND; DELAY (T5);
SOUND (LA); DELAY(T2); NOSOUND; DELAY (T5);
END;
{----------------------------------------------------}
PROCEDURE battuta_quattro;
BEGIN
SOUND(LA); DELAY (T3); NOSOUND;DELAY(T5);
SOUND(SOL); DELAY (T1); NOSOUND;DELAY(T5);
SOUND(SOL); DELAY (T4); NOSOUND;DELAY(T2);
END;
{----------------------------------------------------}
PROCEDURE battuta_otto;
BEGIN
SOUND(SOL); DELAY(T3); NOSOUND; DELAY(T5);
SOUND(FA); DELAY(T1); NOSOUND; DELAY(T5);
SOUND(FA); DELAY(T4); NOSOUND; DELAY(T2);
END;
{----------------------------------------------------}
PROCEDURE riga_uno;
BEGIN
battuta_uno; battuta_due;
battuta_tre; battuta_quattro;
END;
{----------------------------------------------------}
PROCEDURE riga_due;
BEGIN
battuta_uno; battuta_due;
battuta_tre; battuta_otto;
END;
{----------------------------------------------------}
begin
clrscr;
gotoxy (5,12);
writeln('Attendi un attimo perché sto elaborando il tuo profilo astrale');
riga_uno;
riga_due;
end;
begin
clrscr;
MUSIC;
clrscr;
writeln(' ');
writeln (' Alcune delle tue aspirazioni tendono ad essere poco realistiche,');
writeln (' a volte sei estrovers',x,', affabile, socievole, mentre altre volte sei');
writeln (' introvers',x,', diffidente e riservat',x,'. Hai scoperto che in molti casi');
writeln (' non è saggio rivelarsi troppo apertamente agli altri. Sei un',z,' ');
writeln (' pensat',a,' indipendente e non accetti l`opinione degli altri');
writeln (' senza prove soddisfacenti. Preferisci una certa quantità di');
writeln (' cambiamenti e varietà e ti senti insoddisfatt',x,' se ti trovi di');
writeln (' fronte a restrizioni. A volte dubiti di aver preso la decisione');
writeln (' migliore o fatto la cosa giusta. Sei disciplinat',x,' e controllat',x);
writeln (' esternamente ma dentro di te tendi ad essere ansios',x,' ed insicur',x,'.');
writeln (' ');
end;
{----------------------------------------------------}
PROCEDURE ringraziamenti;
begin
fondo_pagina;
writeln ('Ti ringraziamo per la collaborazione');
writeln (' La classe 2A PNI');
end;
{----------------------------------------------------}
PROCEDURE programmastatistica;
begin
preambolo;
pausa;
sesso;
domande1;
testo1;
pausa;
testo2;
pausa;
domande2;
pausa;
ringraziamenti;
end ;
{----------------------------------------------------}
{main}
begin
ancora:=true;
while ancora do
begin
clrscr;
repeat
clrscr;
writeln('proseguo nella acquisizione dati? [S/N]');
read (risposta);
until (risposta='N') or (risposta='n') or (risposta='S') or (risposta='s');
if (risposta='N') or (risposta='n') then
ancora:=false;
if ancora then
begin
programmastatistica;
fadati;
end
else
ancora:=false
end;
clrscr;
end.