Keskustelu: Koodit: Simuloidaan Paha-akka pasianssia

program pahaakkapasiassi;
CONST maxlapikaynti=5;
	maxarvo=15;
TYPE arvot=1..maxarvo;
	maat=1..4;
	korttiosoitin=^kortti;
	kortti=RECORD
		maa: maat;
		arvo: arvot;
		seur: korttiosoitin;
	END;
	maachr=PACKED ARRAY[1..6] OF CHAR;
VAR	pakka,
	kasipakka,
	nakyvakasipakka,
	piilopino,
	kayttamattomat: korttiosoitin;
	peruspakka: ARRAY[1..4] OF korttiosoitin;
	apurivi: ARRAY[1..8] OF korttiosoitin;
	maatchr: ARRAY[1..4] OF maachr;
	lapikayntikerta: 1..maxlapikaynti;
	pelataan: BOOLEAN;
	maxlkm:	INTEGER;
	vastaus: char;
	pasiansseja,
	lapimenoja,
	pros: Double;
FUNCTION ontyhja(osoitin: korttiosoitin): BOOLEAN;
BEGIN
	ontyhja:=(osoitin=NIL);
END;
PROCEDURE siirrakortti(VAR otto,laitto: korttiosoitin);
VAR apu: korttiosoitin;
BEGIN
	IF NOT ontyhja(otto) THEN
	BEGIN
		apu:=otto;
		otto:=otto^.seur;
		apu^.seur:=laitto;
		laitto:=apu;
	END;
END;
FUNCTION kayperuspakkaan(card: korttiosoitin):BOOLEAN;
BEGIN
	IF ontyhja(card) THEN kayperuspakkaan:=FALSE
	ELSE kayperuspakkaan:=card^.arvo=peruspakka[card^.maa]^.arvo+1;
END;
PROCEDURE tulostakortit;
VAR i: Integer;
BEGIN;
	WRITE('Peruspakat:');
	FOR i:=1 TO 4 DO
		BEGIN
		WRITELN(i);
		WITH peruspakka[i]^ DO
			BEGIN
				WRITE(maatchr[2]:4,maa:4);
				WRITE(maatchr[maa]:7, arvo:3,'  ');
			END;
		END;
	WRITE('Nakyvakasipakka:');
	IF NOT ontyhja(nakyvakasipakka) THEN
		WITH nakyvakasipakka^ DO
			WRITELN(maatchr[maa]:7,arvo:3,'  ')
	ELSE
		WRITELN('');
	WRITELN('Apurivi:');
	FOR i:=1 TO 8 DO
		IF NOT ontyhja(apurivi[i]) THEN
			WITH apurivi[i]^ DO
				WRITE(maatchr[maa]:7, arvo:3,'  ');
END;
FUNCTION rivistakay(VAR rivi: Integer): BOOLEAN;
VAR r: Integer;
	kay: BOOLEAN;
BEGIN
	r:=0;
	REPEAT
		r:=r+1;
	UNTIL kayperuspakkaan(apurivi[r]) OR (r>=8);
	IF kayperuspakkaan(apurivi[r]) THEN  rivi:=r;
	rivistakay:=kayperuspakkaan(apurivi[r]);
END;
PROCEDURE kasitteleapurivia;
VAR i: Integer;
BEGIN
	WHILE rivistakay(i) DO
		BEGIN
			WITH apurivi[i]^DO
			BEGIN
				IF vastaus='t' THEN WRITE('Nostetaan apurivista', maatchr[maa]:7,arvo:3,' peruspakkaan.');
				siirrakortti(apurivi[i], peruspakka[maa]);
			END;
			IF NOT ontyhja(piilopino) THEN
				WITH piilopino^ DO
				BEGIN
					IF vastaus='t' THEN WRITELN('...ja piilopinosta', maatchr[maa]:7, arvo:4,' tilalle.');
					siirrakortti(piilopino,apurivi[i]);
				END;
				IF vastaus='t' THEN tulostakortit;
		END;
END;
FUNCTION lapimeni: BOOLEAN;
VAR paknro,
	valmiit: Integer;
BEGIN
	valmiit:=0;
	FOR paknro:=1 TO 4 DO
		IF peruspakka[paknro]^.arvo=maxarvo THEN
			valmiit:=valmiit+1;
	lapimeni:=(valmiit=4);
END;
FUNCTION liikaaselattu:BOOLEAN;
VAR dum: Integer;
BEGIN
	liikaaselattu:=(lapikayntikerta=maxlapikaynti)
		AND ontyhja(kasipakka)
		AND NOT kayperuspakkaan(nakyvakasipakka)
		AND NOT rivistakay(dum)
		AND NOT lapimeni;
END;
FUNCTION korttipiilopinossa: BOOLEAN;
VAR piilossalkm: Integer;
	piilokortit: korttiosoitin;
BEGIN
	piilossalkm:=0;
	piilokortit:=piilopino;
	WHILE NOT ontyhja(piilokortit) DO
	BEGIN
		IF kayperuspakkaan(piilokortit) THEN
			piilossalkm:=piilossalkm+1;
		piilokortit:=piilokortit^.seur;
	END;
	korttipiilopinossa:=(piilossalkm=4);
END;
PROCEDURE katsonakyvaakasipakkaa;
PROCEDURE nostakasipakastaperuspakkaan;
BEGIN
	WHILE kayperuspakkaan(nakyvakasipakka) DO
		WITH nakyvakasipakka^DO
		BEGIN
			IF vastaus='t' THEN WRITELN('Nostetaan kasipakasta',maatchr[maa]:7, arvo:3,' peruspakkaan');
			siirrakortti(nakyvakasipakka, peruspakka[maa]);
			IF vastaus='t' THEN tulostakortit;
		END;
END;
PROCEDURE selaakasipakkaa;
BEGIN
	IF NOT ontyhja(kasipakka) THEN
	BEGIN
		IF vastaus='t' THEN WRITELN('Selataan kasipakkaa, kasipakasta kaannettiin: ');
		REPEAT
			siirrakortti(kasipakka, nakyvakasipakka);
			WITH nakyvakasipakka^ DO
				IF vastaus='t' THEN WRITE(maatchr[maa]:7, arvo:3)
		UNTIL kayperuspakkaan(nakyvakasipakka) OR ontyhja(kasipakka);
	END;
END;
BEGIN
	IF kayperuspakkaan(nakyvakasipakka) THEN
		nostakasipakastaperuspakkaan
	ELSE
		IF NOT lapimeni THEN
			BEGIN
				selaakasipakkaa;
				IF kayperuspakkaan(nakyvakasipakka) THEN
					nostakasipakastaperuspakkaan
				ELSE
					IF NOT liikaaselattu THEN
					BEGIN
						lapikayntikerta:=lapikayntikerta+1;
						IF vastaus='t' THEN WRITELN('Kasipakan selauksessa alkaa', lapikayntikerta,'.s','kierros.');
						WHILE NOT ontyhja(nakyvakasipakka) DO
							siirrakortti(nakyvakasipakka, kasipakka);
					END;
			END;
END;
PROCEDURE alkuasetukset;
VAR i: Integer;
BEGIN
	FOR i:=1 TO 4 DO peruspakka[i]:=NIL;
	FOR i:=1 TO 8 DO apurivi[i]:=NIL;
	pakka:=NIL; kasipakka:=NIL; nakyvakasipakka:=NIL;
	kayttamattomat:=NIL;
	piilopino:=NIL;
	maxlkm:=4*(maxarvo-1);
	maatchr[1]:='hertta';
	maatchr[2]:='ruutu';
	maatchr[3]:='risti';
	maatchr[4]:='pata';
	pelataan:=TRUE;
	pasiansseja:=0;
	lapimenoja:=0;
END;
PROCEDURE uusisolmu(VAR os: korttiosoitin);
BEGIN
	IF ontyhja(kayttamattomat) THEN new(os)
	ELSE
		BEGIN
			os:=kayttamattomat;
			kayttamattomat:=kayttamattomat^.seur;
			os^.seur:=NIL;
		END;
END;
PROCEDURE jaapakka;
VAR i:Integer;
BEGIN

	FOR i:=1 TO 4 DO
		BEGIN
			uusisolmu(peruspakka[i]);
				WITH peruspakka[i]^DO
				BEGIN
					arvo:=1;
					maa:=i;
				END;
		END;
	FOR i:=1 TO 8 DO
		siirrakortti(pakka, apurivi[i]);
	FOR i:=1 TO 8 DO
		siirrakortti(pakka, piilopino);
	kasipakka:=pakka;
	pakka:=NIL;
END;
PROCEDURE kaannapino(VAR pino: korttiosoitin);
VAR apupino: korttiosoitin;
BEGIN
	apupino:=NIL;
	WHILE NOT ontyhja(pino) DO siirrakortti(pino, apupino);
	pino:=apupino;
END;
PROCEDURE sekoitapakka;
VAR m: maat;
	a: arvot;
	vaihtoapu,
	arpo,
	ind,
	luku: Integer;
	arpopakka: ARRAY[1..100] OF Integer;
	card: korttiosoitin;
BEGIN
	Randomize;
	FOR ind:=1 TO maxlkm DO arpopakka[ind]:=ind;
	FOR ind:=1 TO maxlkm DO
	BEGIN
		arpo:=RANDOM(maxlkm)+1;
		vaihtoapu:=arpopakka[ind];
		arpopakka[ind]:=arpopakka[arpo];
		arpopakka[arpo]:=vaihtoapu;
	END;
	IF vastaus='t' THEN	WRITELN('Arpomasi pakka paalimmaisesta kortista lahtien:');
	FOR ind:=1 TO maxlkm DO
	BEGIN
		luku:=arpopakka[ind];
		m:=(luku-1) DIV (maxarvo-1)+1;
		a:=luku-(maxarvo-1)*(m-1)+1;
		IF vastaus='t' THEN WRITELN(ind:3,':',maatchr[m]:8, a:3);
		uusisolmu(card);
		card^.maa:=m;
		card^.arvo:=a;
		card^.seur:=NIL;
		siirrakortti(card, pakka);
	END;
	kaannapino(pakka);
	IF vastaus='t' THEN WRITELN('Jaan kortit poytaan niin aloitetaan peli');
END;
PROCEDURE luesyottoaineistoa;
BEGIN //LUESYOTTOAINEISTOA
	WRITELN('Syota "t", jos haluat tulostaa pasianssipelin vaiheet.');
	WRITE('Syota "s", jos haluat vain simuloida tilastollista tutkimusta varten ');
	WRITELN(' ilman tulostusta. (pysayta ajo silloin painamalla CNTRL-C)');
	WRITELN('Syota "l" jos haluat kokonaan lopettaa simuloinnin');
	READLN(vastaus);
	IF vastaus='l' THEN pelataan:=FALSE;
END;
PROCEDURE keraakortit;
VAR i: Integer;
BEGIN
	FOR i:=1 TO 4 DO
		WHILE NOT ontyhja(peruspakka[i]) DO
			siirrakortti(peruspakka[i], kayttamattomat);
	FOR i:=1 TO 8 DO
		siirrakortti(apurivi[i], kayttamattomat);
	WHILE NOT ontyhja(kasipakka) DO
		siirrakortti(kasipakka, kayttamattomat);
	WHILE NOT ontyhja(nakyvakasipakka) DO
		siirrakortti(nakyvakasipakka, kayttamattomat);
	WHILE NOT ontyhja(piilopino) DO
		siirrakortti(piilopino, kayttamattomat);
END;
BEGIN
	alkuasetukset;
	luesyottoaineistoa;
	WHILE pelataan DO
		BEGIN
			sekoitapakka;
			jaapakka;
			lapikayntikerta:=1;

			IF vastaus='t' THEN tulostakortit;
			REPEAT
				kasitteleapurivia;
				katsonakyvaakasipakkaa;
			UNTIL (liikaaselattu OR lapimeni OR korttipiilopinossa);
			pasiansseja:=pasiansseja+1;
			pros:=100*lapimenoja/pasiansseja;
			WRITELN(pros);
			IF liikaaselattu THEN
				BEGIN
					if vastaus='t' THEN WRITELN('Kasipakkaa on selattu liikaa. Pasianssi ei mennyt lapi.');
				END
			ELSE IF lapimeni THEN
			BEGIN
				IF vastaus='t' THEN WRITELN('Pasianssi meni lapi! :)');
				lapimenoja:=lapimenoja+1;
				END
				ELSE BEGIN
					IF vastaus='t' THEN WRITELN('Ei kannata jatkaa. Kaikki seuraavaksi peruspakkaan kayvat kortit ovat piilopinossa.');
				END;
			keraakortit;
			IF vastaus<>'s' THEN luesyottoaineistoa;
		END;
END.