|
program ROUETTE; uses crt, dos; {$R rouletteres.res} type slot = record v : real; s : boolean; end; salvataggi = array [1..8] of slot; const S = ''; procedure Text_N; begin textcolor (15); textbackground (0); end; procedure Text_1; begin textcolor (14); textbackground(1); end; procedure Text_3; begin textcolor (14); textbackground(4); end; var Salv : File of salvataggi; sl : salvataggi; Ric: SearchRec; A, B, ESTR, Q, ss : byte; Psalv, P1, P2, P3 : boolean; BK : char; M, P : real; S1 : string; function Y(A : byte) : byte; var M : byte; begin M := A mod 3; if M = 0 then A := (A div 3) + 1 else A := (A div 3) + 2; Y := A end; function X(A : byte): byte; begin if A > 0 then begin A := A mod 3; if A = 0 then A := 76 else A := A * 3 + 67; end else A := 73; X := A end; procedure SWR1(Color,I : byte); begin gotoxy(64,I); textcolor(Color); writeln (S); delay(85); end; procedure SWR2(Color : byte); begin textcolor(Color); write(S); delay(70); end; procedure SWR3(A : byte); begin if (A < 11) or ((A > 18) and (A < 29)) then begin if A mod 2 = 0 then textcolor(0) else textcolor(4); end else begin if A mod 2 = 0 then textcolor(4) else textcolor(0); end; gotoxy(X(A),Y(A)); end; procedure WR1; var I : byte; begin I := 0; repeat I := I + 1; SWR1(14,I); I := I + 1; SWR1(10,I); until I = 16; gotoxy (64,17); repeat SWR2(14); SWR2(10); I := I - 2 until I = 0; SWR2(14); end; procedure WR2; begin window(66,1,79,15); textbackground(2); textcolor(14); clrscr; writeln(' _ 0'); writeln; writeln('> W <'); writeln(' _'); writeln('_ _'); writeln(' X'); writeln(' _'); writeln('P D'); writeln(' Y'); writeln('_ _ _'); writeln; writeln(' Z'); writeln(' _'); writeln(' A B C'); end; procedure WR3; var I : byte; begin window(1,1,80,25); textcolor(4); gotoxy(79,12); write(''); textcolor(0); gotoxy(66,12); write(''); for I := 1 to 36 do begin SWR3(I); write(I); end; end; procedure WR5; begin window(66,22,79,24); Text_3; clrscr; gotoxy(2,2); writeln ('$ = ',M:5:2); window(66,18,79,20); clrscr; gotoxy(2,2); writeln('Estratto=',ESTR); end; procedure WR4; var G, K : byte; begin case A of 2 : begin G := 68; case BK of 'W' : K := 3; 'X' : K := 6; 'Y' : K := 9; 'Z' : K := 12; end; end; 3 : begin K := 14; case BK of 'A' : G := 70; 'B' : G := 73; 'C' : G := 76; end; end; 4 : begin K := 8; if BK = 'P' then G := 66 else G := 79; end; 5 : begin K := 3; if BK = '>' then G := 66 else G := 79; end; else begin K := 12; if BK = 'N' then G := 66 else G := 79; end; end; gotoxy(G,K); if A = 6 then write('') else begin textcolor(10); write (BK); textcolor(14); end; end; procedure Clean; begin Text_N; window(64,1,64,17); clrscr; window(64,17,80,17); clrscr; window(4,6,54,20); clrscr; WR2; WR3; Text_1; end; procedure LettFile; var I : byte; P : boolean; begin P := false; Assign (Salv, 'Salv.roulette'); reset(Salv); read(Salv,sl); close(Salv); for I := 1 to 8 do if sl[I].s then P := true; if P then begin writeln ('Caricare il salvataggio(s\n)?'); repeat readln(BK); until (BK = 'S') or (BK = 's') or (BK = 'N') or (BK = 'n'); Findclose(Ric); if (BK = 'S') or (BK = 's') then begin Psalv := true; write ('Quale slot carichi?('); for I := 1 to 8 do if sl[I].s then write (I,'; '); writeln(')'); repeat repeat readln(ss); until (ss>0) and (ss <9); until sl[ss].s; M := sl[ss].v end; end; end; procedure ScriviFile; begin rewrite(Salv); write(Salv,sl); close(Salv); end; BEGIN randomize; clrscr; FindFirst('Salv.roulette', anyfile, Ric); if Doserror = 0 then LettFile; clrscr; WR2; WR3; window(1,1,80,25); if not(Psalv) then M := 200; WR5; window(3,2,62,4); Text_1; clrscr; gotoxy(25,2); writeln('ROULETTE'); repeat window(4,6,54,20); writeln('Puntare su: 1* numero singolo 4* pari\dispari'); writeln(' 2* settore(W,X..) 5* > 18 \ <= 18'); writeln(' 3* colonna(A,B,C) 6* neri \ rossi'); window(5,9,6,9); repeat readln(A); until (A > 0) and (A < 7); window(4,6,54,20); case A of 1 : S1 := 'numero'; 2 : S1 := 'settore'; 3 : S1 := 'colonna'; 4 : S1 := '"P" o "D"'; 5 : S1 := '">" o "<"'; else S1 := '"N" o "R"'; end; gotoxy(1,6); writeln ('Puntare su ', S1); window(5,12,7,12); case A of 1 : begin repeat readln (B); until B < 37; P1 := true; end; 2 : begin repeat readln (BK); until (BK = 'W') or (BK = 'X') or (BK = 'Y') or (BK = 'Z'); end; 3 : begin repeat readln (BK); until (BK = 'A') or (BK = 'B') or (BK = 'C'); end; 4 : begin repeat readln (BK); until (BK = 'P') or (BK = 'D'); end; 5 : begin repeat readln (BK); until (BK = '>') or (BK = '<'); end; else begin repeat readln (BK); until (BK = 'N') or (BK = 'R'); end; end; window(1,1,80,25); if P1 then begin gotoxy(X(B),Y(B)); write(B); end else WR4; ESTR := random(36); gotoxy(5,14); write('Quanto punti ?'); window(20,14,35,14); repeat clrscr; readln(P); until P <= M; window(1,1,80,25); gotoxy(7,16); writeln ('!!ESTRAZIONE.... !!'); Text_N; case A of 1 : begin Q := 35; if B = ESTR then P3 := true; end; 2 : begin case BK of 'W' : Q := 10; 'X' : Q := 19; 'Y' : Q := 28; else Q := 37; end; if (ESTR < Q) and (ESTR > 0) and (ESTR > (Q-10)) then P3 := true; Q := 5; end; 3 : begin case BK of 'A' : Q := 1; 'B' : Q := 2; else Q := 0; end; if (ESTR > 0) and ((ESTR mod 3) = Q) then P3 := true; Q := 3; end; 4 : begin if BK = 'P' then Q := 0 else Q := 1; if (ESTR > 0) and ((ESTR mod 2) = Q) then P3 := true; Q := 1; end; 5 : begin if (((ESTR < 19) and (BK = '<')) or ((ESTR > 18)and (BK = '>'))) and (ESTR > 0) then P3 := true; Q := 1; end; 6 : begin Q := 1; end; end; WR1; gotoxy(X(ESTR),Y(ESTR)); Text_3; write(ESTR); Text_1; gotoxy(7,16); if P3 then begin write(space(7), '! HAI VINTO !', space(7)); M := M + (P * Q); end else begin write(space(7), '! HAI PERSO !', space(7)); M := M - P; end; WR5; Text_1; window(5,18,44,18); if Psalv then begin; sl[ss].v := M; sl[ss].s := true; ScriviFile; end; if M = 0 then begin P2 := true; textcolor(7); textbackground(4); writeln('!!! BANCAROTTA !!!'); if Psalv then begin sl[ss].s := false; ScriviFile; end; end; readln; if not(P2) then begin write ('Proseguire il gioco(1) o salvare e uscire(2)?'); window(6,19,7,19); repeat readln(BK); until (BK = '1') or (BK = '2'); if (BK = '2') then begin clrscr; writeln('Su quale slot scrivi(1..8)?'); window(7,20,8,20); repeat readln(ss); until (ss>0) and (ss <9); sl[ss].v := M; sl[ss].s := true; P2 := true; if not(Psalv) then assign(Salv,'Salv.roulette'); ScriviFile; end; Text_1; Clean; end; P3 := false; until P2; Text_1; delay(300); clrscr; gotoxy(2,2); writeln('Bye'); delay(500); END.
|
|
