riconoscimento fenotipo, genotipo gruppo sanguigno
in padre, madre, figlio
con interazione e correzione

ricerca interattiva gruppo sanguigno genitori e figlio
http://www.youtube.com/watch?v=qY8e4DITEJ0

program sa1;       (* interattivo con gruppi sanguigni ABO *)
uses crt,graph;
var px,mx,fx,a,b,c,d,e,f,g,h,pa,mb,fa:string[30];


procedure grafica;
var t,s:integer;
    stringa:string;
begin
t:=0;
s:=0;
stringa:=('c:\SCHEDA\');
initgraph(s,t,stringa);
end;

procedure attende;
begin
delay(2000);
end;

procedure pausa1;
begin
setcolor(4);
outtextxy(430,10,'premi INVIO');readln;
setcolor(0);
outtextxy(430,10,'premi INVIO');
setcolor(15);
end;

procedure pausa;
begin
readln;cleardevice;
end;

procedure sosta;
begin
readln;
end;

procedure testo(x,y:integer;st:string);
begin
outtextxy(x,y,st);
end;

procedure ma(x1,y1,x2,y2,st,cm:integer);
begin
setfillstyle(st,cm);
bar(x1,y1,x2,y2);
end;

procedure fe(x1,y1,st,cm:integer);
begin
setfillstyle(st,cm);
fillellipse(x1,y1,25,25);
end;

procedure at;
begin
delay(1000);
end;


procedure programma;
begin
end;


procedure pro;
begin
setcolor(3);
testo(20,30,'A codominante,B codominante,0 recessivo ');
testo(20,50,'FENOTIPI NOTI:indicare genotipi possibili');
WRITELN('nel padre P,madre M,figlio F, usando la legenda a destra ');
writeln('es.P=1...M=1,2....F=2..');
setcolor(4);
testo(350,90,' genotipi possibili');
testo(350,260,'FENOTIPI :A,B,AB,O');
testo(350,100,'A,   1=AA   2=A0');ma(500,100,520,120,1,4);
testo(350,140,'B,   3=BB   4=B0');ma(500,140,520,160,2,3);
testo(350,180,'AB   5=AB ');ma(500,180,520,200,3,3);
testo(350,220,'0,   6=00 ');ma(500,220,520,240,4,2);
testo(120,80,'P');
testo(300,80,'M');
testo(220,260,'F');
end;

procedure pro1(sp,cp,sm,cm,sf,cf:integer;py,my,fy,pa,mb,fa:string);
begin
pro;
ma(100,100,150,150,sp,cp);testo(80,120,pa);
fe(300,125,sm,cm); testo(250,120,mb);
ma(200,200,250,250,sf,cf);testo(180,270,fa);
testo(30,300,'P=');gotoxy(50,30);readln(px);testo(50,300,px);
if px<>py then testo(100,300,'errato:era ' + py);
testo(30,320,'M=');gotoxy(50,32);readln(mx);testo(50,320,mx);
if mx<>my then testo(100,320,'errato:era ' + my);
testo(30,340,'F=');gotoxy(50,34);readln(fx);testo(50,340,fx);
if fx<>fy then testo(100,340,'errato:era ' + fy);
pausa;
end;


procedure scelta;
var sce:integer;
begin
cleardevice;
setcolor(3);
testo(20,20,'selezionare tra opzioni proposte');
setcolor(4);
testo(20,40,'A codominante,B codominante,0 recessivo ');
testo(20,60,'1...2...3....4....5....6...7...8...9..');
setcolor(15);testo(400,20,'scelta =');
gotoxy(2,5);readln(sce);cleardevice;
case sce of
1:pro1(1,4,2,3,1,4,c,e,b,'A','B','A');
2:pro1(1,4,1,4,1,4,c,c,c,'A','A','A');
3:pro1(3,3,3,3,3,3,g,g,g,'AB','AB','AB');
4:pro1(4,2,3,3,1,4,h,g,b,'O','AB','A');
5:pro1(3,3,1,4,2,4,g,c,c,'AB','A','B');
6:pro1(1,4,2,4,4,2,b,e,h,'A','B','O');
7:pro1(1,4,3,3,1,4,c,g,c,'A','AB','A');
8:pro1(4,2,4,2,4,2,h,h,h,'O','O','O');
9:pro1(3,3,3,3,1,4,g,g,a,'AB','AB','A');
end;
cleardevice;
testo(20,30,'per continuare premi 1..per finire 2 :scelta=');readln(sce);
cleardevice;
if sce=1 then scelta;
end;

begin
clrscr;
a:='1';b:='2';c:='1,2';d:='3';e:='4';f:='3,4';g:='5';h:='6';
writeln('esempio trasmissione carattere GRUPPO SANGUIGNO ABO');
writeln('durante la esecuzione,premere INVIO quando richiesto');
writeln('oppure attendere prosecuzione automatica');
writeln('premi INVIO per proseguire');readln;clrscr;
grafica;
scelta;
closegraph;
end.

indice o inizio