program ABO2; uses crt; var feno:string[10]; s:char; tipo:integer; f:array[1..9] of string[10]; g:array[1..9] of string[10]; h:array[1..9] of string[10]; procedure gruppi; begin f[1]:='A,0';f[2]:='B,0';f[3]:='0';f[4]:='A,B,AB';f[5]:='A,B,AB,0'; f[6]:='A,0';f[7]:='A,B,AB';f[8]:='B,0';f[9]:='A,B,AB'; g[1]:='0,A';g[2]:='0,B';g[3]:='0';g[4]:='A,B,AB';g[5]:='A,B,AB,0'; g[6]:='0,A';g[7]:='A,B,AB';g[8]:='0,B';g[9]:='A,B,AB'; h[1]:='A,A';h[2]:='B,B';h[3]:='0,0';h[4]:='AB,AB';h[5]:='A,B'; h[6]:='A,0';h[7]:='A,AB';h[8]:='B,0';h[9]:='B,AB'; clrscr; writeln('indicare fenotipo dei genitori,scrivendo il numero '); writeln('----------------------------------------------------'); writeln('1...A,A'); writeln('2...B,B'); writeln('3...0,0'); writeln('4...AB,AB'); writeln('5...A,B'); writeln('6...A,0'); writeln('7...A,AB'); writeln('8...B,0'); writeln('9...B,AB'); writeln('-----------------------------------------------------'); write('fenotipo=');readln(tipo); end; procedure chiede; begin gruppi; clrscr; writeln('fenotipo genitori=',h[tipo]); writeln('-------------------------------------------------'); writeln('indicare fenotipi possibili nei figli '); writeln('scrivendo le sigle separate da virgola '); writeln('es.A,AB......0.....A,0..'); writeln('es.se sono 3-4 scrivere in ordine A,B,AB,0 '); writeln('--------------------------------------------------'); writeln('fenotipi possibili=');readln(feno); if ((feno<>f[tipo]) and (feno<>g[tipo])) then writeln('errato:era :',f[tipo]) ELSE WRITELN('esatto'); writeln('--------------------------------------------------'); writeln('premi INVIO'); readln;clrscr; writeln('scrivi S per altra prova,oppure N per finire'); write('scelta=');readln(s); if ((s='S') or (s='s')) then chiede; end; begin clrscr; writeln; writeln('GENETICA dei GRUPPI SANGUIGNI AB0 '); writeln('esempio di fenotipi compatibili nei figli'); writeln('in funzione dei fenotipi noti nei genitori'); writeln('-------------------------------------------'); writeln('ricordare che A e B sono codominanti e 0 recessivo'); writeln('premi ENTER');readln; chiede; end.