program sol;
{$R+}
{$I Gbjack.inc}
{$I graphict}
{-----------------------------------------------------------------------------
Rainbow Graphics Solitaire
Copyright (c) 1986 Marc E. Kenig
This program is donated to the public domain. This program, any copy
of it or any enhanced version upon which this program or its data
is based, may NOT be sold without the express permission of the author.
It is always and forever to be distributed free of charge as shareware.
------------------------------------------------------------------------------}
type
suit = (spade,diamond,club,heart);
const
number_of_columns = 7;
suit_name : array [spade..heart] of char = ('S',
'D','C','H');
rank_name : array [1..13] of string[2] = (' A',' 2',' 3',' 4',' 5',' 6',
' 7',' 8',' 9','10',' J',' Q',' K');
col_name : array [1..9] of string[1] = ('1','2','3','4','5',
'6','7','8','9');
type
card = record
pip: suit;
rank: integer;
end;
deck = array [1..52] of card;
hand = array [1..8] of card;
pip_place = record
x,y: integer;
end;
pip_array = array [1..13] of pip_place;
str1 = string[1];
colm = record
tot_cards, up, down: integer;
up_cards: array [0..13] of card;
down_cards: array [0..number_of_columns] of card;
end;
colm_array = array [0..number_of_columns] of colm;
var
ch: char;
i: integer;
suits: suit;
pip_offs: pip_array;
you_lose,color_dsp: boolean;
column: colm_array;
cards: deck;
ok: boolean;
deck_last,deck_top,deck_next: integer;
procedure help;
var
ch:char;
begin
graphicsoff;
clrscr;
Normvideo;
writeln(' S O L I T A I R E FOR DEC-RAINBOW w/GRAPHICS OPTION');
writeln(' Copyright(c)1987 Marc E. Kenig - All rights reserved');
writeln;
writeln(' Solitaire, also known as "patience" in english speaking parts of the world,');
writeln('is an irritating card game to play alone against a shuffled deck of cards. The');
writeln('object is to re-arrange the deck into 4 descending columns of alternating suit');
writeln('beginning with the king. For a tutorial on solitaire basics see the help file');
writeln('shipped with this program or Charles Goren''s book on the subject.');
writeln(' This program implements the standard game: arrange 7 columns into 4 (king');
writeln('high) of alternating suit. Empty rows may only be filled by kings drawn from');
writeln('the deck or other columns beginning with a king. Draw from the deck one time');
writeln('through or lose. Sorry, no cheating mode is implemented. Drawing is automatic');
writeln('and will stop when a card can be used. You must use the card.');
writeln(' There are 4 commands each activated by a single keystroke (not echoed):');
writeln(' C - Move card(s) from one column to another. Columns (labled)');
writeln(' are numbered starting at 1, from the left.');
writeln(' D - Try to draw a card from the deck. Drawing continues until a card can');
writeln(' (and must) be used. No card''s found in 1 circuit through, you lose.');
writeln('? or H - This text again.');
writeln(' Q - Quit. After you quit or lose, the deck is displayed.');
writeln(' The Deck appears on the rightmost side, face down until you draw.');
writeln(' Press any key to continue....');
read(kbd,ch);
graphicson;
end;
procedure init_pip(var pip_offs: pip_array);
var
i: integer;
begin
for i:=1 to 5 do
pip_offs[i].x:=12;
pip_offs[1].y:=19;
pip_offs[2].y:=37;
pip_offs[3].y:=46;
pip_offs[4].y:=55;
pip_offs[5].y:=73;
for i:=6 to 8 do
begin
pip_offs[i].x:=36;
pip_offs[i].y:=pip_offs[i-4].y;
end;
for i:=9 to 13 do
begin
pip_offs[i].x:=60;
pip_offs[i].y:=pip_offs[i-8].y;
end;
end;
procedure init_deck;
var
s: suit;
c,i: integer;
begin
c:=1;
for s:=spade to heart do
for i:=1 to 13 do
begin
cards[c].pip:=s;
cards[c].rank:=i;
c:=c+1;
end;
deck_top:=1;
deck_last:=52;
end;
procedure drawblank(x,x1,y,y1:integer);
begin
if y1>239 then
y1:=239;
color(1);
drawbar(x,x1,y,y1);
color(0);
drawline(x-1,y-1,x-1,y1+1);
drawline(x-1,y1+1,x1+1,y1+1);
drawline(x1+1,y1+1,x1+1,y-1);
drawline(x1+1,y-1,x-1,y-1);
end;
procedure draw_back(card_x,card_y: integer);
var
x,y: integer;
begin
color(1);
drawbar(card_x,card_x+90,card_y,card_y+80);
color(3);
Backgroundcolor(2);
preblanking:=false;
Pattern(122,2);
for x:=5 to 85 do
drawline(card_x+5,card_y+75,card_x+x,card_y+5);
for y:=6 to 75 do
drawline(card_x+5,card_y+75,card_x+85,card_y+y);
Pattern(255,15);
Backgroundcolor(0);
end;
function card_color(strng:str1): integer;
begin
if color_dsp then
case ord(strng[1]) of
128,129: card_color:=2;
else card_color:=0
end
else
case ord(strng[1]) of
128,130,131: card_color:=0;
else card_color:=2;
end;
end;
procedure draw_corner(card_x,card_y: integer; strng: str1; i: integer);
begin
color(card_color(strng));
if ord(strng[1])=128 then color(2);
charcursor(card_x+2,card_y+9);
charscale(5.0,7.0,6,7);
case i of
1: drawstring('A');
2: drawstring('2');
3: drawstring('3');
4: drawstring('4');
5: drawstring('5');
6: drawstring('6');
7: drawstring('7');
8: drawstring('8');
9: drawstring('9');
10: drawstring('10');
11: drawstring('J');
12: drawstring('Q');
13: drawstring('K');
end;
if i>10 then
begin
charscale(5.0,7.0,6,10);
charcursor(card_x+2,card_y+25);
drawstring(strng);
end;
end;
procedure draw_face_card(card_x,card_y: integer; str: str1; i: integer);
begin
color(1);
drawblank(card_x,card_x+90,card_y,card_y+80);
draw_corner(card_x,card_y,str,i);
{ if color_dsp then
if ord(str[1]) in [128,129] then
color(2)
else
color(0)
else}
color(card_color(str[1]));
if ord(str[1])=128 then color(2);
charscale(20.0,20.0,6,10);
charcursor(card_x+25,card_y+60);
drawstring(chr(132+(i-11)));
draw_corner(card_x,card_y,str,i);
end;
procedure draw_pip_card(card_x,card_y: integer; str: str1; i: integer);
begin
color(1);
drawblank(card_x,card_x+90,card_y,card_y+80);
draw_corner(card_x,card_y,str,i);
charscale(5.0,7.0,6,10);
color(card_color(str));
case i of
1: begin
if ord(str[1])=131 then
begin
charscale(20.0,20.0,6,10);
charcursor(card_x+25,card_y+60);
end
else
charcursor(card_x+pip_offs[7].x,card_y+pip_offs[7].y);
drawstring(str);
charscale(5.0,7.0,6,10);
end;
2: begin
charcursor(card_x+pip_offs[6].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[8].x,card_y+pip_offs[5].y);
drawstring(str);
end;
3: begin
charcursor(card_x+pip_offs[6].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[7].x,card_y+pip_offs[3].y);
drawstring(str);
charcursor(card_x+pip_offs[8].x,card_y+pip_offs[5].y);
drawstring(str);
end;
4: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
5: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[7].x,card_y+pip_offs[7].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
6: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[3].x,card_y+pip_offs[3].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[11].x,card_y+pip_offs[11].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
7: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[3].x,card_y+pip_offs[3].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[6].x,card_y+pip_offs[6].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[11].x,card_y+pip_offs[11].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
8: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[3].x,card_y+pip_offs[3].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[6].x,card_y+pip_offs[6].y);
drawstring(str);
charcursor(card_x+pip_offs[8].x,card_y+pip_offs[8].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[11].x,card_y+pip_offs[11].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
9: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[2].x,card_y+pip_offs[2].y);
drawstring(str);
charcursor(card_x+pip_offs[4].x,card_y+pip_offs[4].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[7].x,card_y+pip_offs[7].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[10].x,card_y+pip_offs[10].y);
drawstring(str);
charcursor(card_x+pip_offs[12].x,card_y+pip_offs[12].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
10: begin
charcursor(card_x+pip_offs[1].x,card_y+pip_offs[1].y);
drawstring(str);
charcursor(card_x+pip_offs[2].x,card_y+pip_offs[2].y);
drawstring(str);
charcursor(card_x+pip_offs[4].x,card_y+pip_offs[4].y);
drawstring(str);
charcursor(card_x+pip_offs[5].x,card_y+pip_offs[5].y);
drawstring(str);
charcursor(card_x+pip_offs[6].x,card_y+pip_offs[6].y);
drawstring(str);
charcursor(card_x+pip_offs[8].x,card_y+pip_offs[8].y);
drawstring(str);
charcursor(card_x+pip_offs[9].x,card_y+pip_offs[9].y);
drawstring(str);
charcursor(card_x+pip_offs[10].x,card_y+pip_offs[10].y);
drawstring(str);
charcursor(card_x+pip_offs[12].x,card_y+pip_offs[12].y);
drawstring(str);
charcursor(card_x+pip_offs[13].x,card_y+pip_offs[13].y);
drawstring(str);
end;
end;
end;
procedure draw_a_card(a_card: card; card_x,card_y: integer);
var
str: str1;
begin
str[0]:=chr(1);
case a_card.pip of
diamond: str[1]:=chr(128);
heart: str[1]:=chr(129);
club: str[1]:=chr(130);
spade: str[1]:=chr(131);
end;
if a_card.rank=0 then draw_back(card_x,card_y)
else if a_card.rank<=10 then
draw_pip_card(card_x,card_y,str,a_card.rank)
else
draw_face_card(card_x,card_y,str,a_card.rank);
end;
procedure shuffle;
var
h: card;
t,c,i,j: integer;
begin
t:=600+random(2000);
for c:=1 to t do
begin
i:=1+random(52);
j:=1+random(52);
while i=j do
j:=1+random(51);
h.pip:=cards[i].pip;
h.rank:=cards[i].rank;
cards[i].pip:=cards[j].pip;
cards[i].rank:=cards[j].rank;
cards[j].pip:=h.pip;
cards[j].rank:=h.rank;
end;
end;
procedure init_column;
var
i: integer;
begin
for i:=0 to number_of_columns do
with column[i] do
begin
tot_cards:=0;
up:=0;
down:=0;
column[i].up_cards[0].rank:=0;
column[i].up_cards[0].pip:=spade;
end;
end;
procedure deal;
var
i,j: integer;
begin
for i:=1 to number_of_columns do
begin
column[i].tot_cards:=column[i].tot_cards+1;
column[i].up:=1;
column[i].up_cards[1]:=cards[deck_top];
deck_top:=deck_top+1;
for j:=i+1 to number_of_columns do
with column[j] do
begin
tot_cards:=tot_cards+1;
down:=down+1;
down_cards[down]:=cards[deck_top];
deck_top:=deck_top+1;
end;
end;
deck_next:=deck_top;
end;
procedure gblank_col(i: integer);
begin
color(0);
drawbar((i-1)*100+2,i*100+2,0,240);
end;
procedure gdraw_col(i:integer; Acolumn: colm);
var
col_x,col_y,j: integer;
val: string[2];
begin
col_x:=(i-1)*100+2;
charcursor(col_x+1,12);
color(1);
charscale(5.0,7.0,6,10);
drawstring('Col: '+col_name[i]);
col_y:=14;
with Acolumn do
begin
if tot_cards=0 then
begin
gblank_col(i);
color(1);
charcursor(col_x+1,12);
drawstring('Col: '+col_name[i]);
drawstring(' *EMPTY*')
end
else
begin
str(down:2,val);
drawstring(' DOWN:'+val);
for j:=1 to up do
begin
draw_a_card(up_cards[j],col_x,col_y);
col_y:=col_y+17;
end;
end;
end;
end;
procedure gdisplay;
var
i: integer;
ch:char;
begin
clearallplanes;
for i:= 1 to number_of_columns do
begin
gblank_col(i);
gdraw_col(i,column[i]);
end;
end;
function get_column: integer;
var
c: char;
col: integer;
begin
read(kbd,c);
col:=ord(c)-ord('0');
if col=0 then
get_column:=-1
else
while (col<1) or (col>number_of_columns) do
begin
preblanking:=true;
Charcursor(700,180);
drawstring('Illegal column');
read(kbd,c);
col:=ord(c)-ord('0');
end;
get_column:=col;
end;
function opposite(pip1,pip2: suit): boolean;
begin
opposite:=((pip1 in [spade,club]) and (pip2 in [heart,diamond]))
or ((pip1 in [heart,diamond]) and (pip2 in [spade,club]));
end;
procedure play;
var
i,j,from_column, to_column: integer;
cmd: char;
procedure column_move;
var
moved: boolean;
begin
moved:=false;
preblanking:=true;
charcursor(700,200);
drawstring('From column:');
from_column:=get_column;
charcursor(700,210);
drawstring('To column:');
to_column:=get_column;
if (column[to_column].tot_cards<>0) then
begin
if (opposite(column[from_column].up_cards[1].pip,
column[to_column].up_cards[column[to_column].up].pip)
and (column[from_column].up_cards[1].rank+1
=column[to_column].up_cards[column[to_column].up].rank))
then
begin
moved:=true;
for i:=1 to column[from_column].up do
begin
column[to_column].up:=column[to_column].up+1;
column[to_column].up_cards[column[to_column].up]:=
column[from_column].up_cards[i];
column[from_column].tot_cards:=column[from_column].tot_cards-1;
column[to_column].tot_cards:=column[to_column].tot_cards+1;
end;
if column[from_column].tot_cards > 0 then
begin
column[from_column].up_cards[1]:=column[from_column].
down_cards[column[from_column].down];
column[from_column].down:=column[from_column].down-1;
column[from_column].up:=1;
end
else
column[from_column].up:=0;
end;
end
else if (column[from_column].up_cards[1].rank=13) then
begin
moved:=true;
for i:=1 to column[from_column].up do
begin
column[to_column].up:=column[to_column].up+1;
column[to_column].up_cards[column[to_column].up]:=
column[from_column].up_cards[i];
column[from_column].tot_cards:=column[from_column].tot_cards-1;
column[to_column].tot_cards:=column[to_column].tot_cards+1;
end;
if column[from_column].tot_cards > 0 then
begin
column[from_column].up_cards[1]:=column[from_column].
down_cards[column[from_column].down];
column[from_column].down:=column[from_column].down-1;
column[from_column].up:=1;
end
else
column[from_column].up:=0;
end;
if moved then
begin
preblanking:=false;
gblank_col(from_column);
gdraw_col(from_column,column[from_column]);
gblank_col(to_column);
gdraw_col(to_column,column[to_column]);
end;
color(0);
drawbar(700,800,180,240);
end;
procedure card_draw;
var
deck_look,i,j: integer;
c: char;
save,save2: card;
function usable(cd: card):boolean;
var
i: integer;
ok: boolean;
begin
ok:=false;
for i:=1 to number_of_columns do
if (cd.rank=13) and (column[i].up=0) then ok:=true
else if (column[i].up<>0) then
ok:=ok
or (
(opposite(column[i].up_cards[column[i].up].pip,cd.pip)
and (column[i].up_cards[column[i].up].rank-1=cd.rank))
);
usable:=ok
end;
begin
save2:=cards[deck_top];
repeat
for i:=1 to 3 do
begin
save:=cards[deck_top];
for j:=deck_top to deck_last-1 do
cards[j]:=cards[j+1];
cards[deck_last]:=save;
end;
cards[deck_last]:=cards[deck_last-2];
cards[deck_last-2]:=save;
preblanking:=false;
draw_a_card(cards[deck_top],700,40);
until usable(cards[deck_top]) or ((cards[deck_top].pip=save2.pip)
and (cards[deck_top].rank=save2.rank));
if (not usable(cards[deck_top]))
and (cards[deck_top].pip=save2.pip)
and (cards[deck_top].rank=save2.rank) then
begin
clrscr;
you_lose:=true;
ok:=false
end
else
begin
color(1);
charcursor(700,200);
drawstring('Column: ');
j:=get_column;
while not (
( opposite(column[j].up_cards[column[j].up].pip,
cards[deck_top].pip)
and (column[j].up_cards[column[j].up].rank-1=
cards[deck_top].rank)
)
or
((column[j].up=0) and (cards[deck_top].rank=13))
)
do
begin
preblanking:=true;
charcursor(700,200);
drawstring('No, Column:');
j:=get_column;
end;
with column[j] do
begin
tot_cards:=tot_cards+1;
up:=up+1;
up_cards[up]:=cards[deck_top];
end;
deck_top:=deck_top+1;
end;
if ok then
begin
gblank_col(j);
preblanking:=false;
gdraw_col(j,column[j]);
draw_back(700,40);
end;
color(0);
drawbar(700,800,180,240);
end;
begin
while ok do
begin
color(1);
PreBlanking:=true;
charcursor(700,180);
drawstring('Move-> ');
read(kbd,cmd);
cmd:=upcase(cmd);
case cmd of
'C': column_move;
'D': card_draw;
'Q': begin
ok:=false;
you_lose:=true;
end;
'?',
'H': help;
else write(chr(7));
end;
if deck_top=deck_last then
begin
you_lose:=false;
ok:=false
end;
{ display }
end;
end;
procedure display_deck;
var
col_x,col_y,I: integer;
ch: char;
begin
charcursor(20,20);
charscale(10.0,14.0,12,14);
if you_lose then
begin
color(0);
drawbar(0,700,0,240);
color(1);
drawstring('You lose, sorry. The deck contained:');
col_x:=1;
col_y:=40;
preblanking:=false;
for i:=deck_top to deck_last do
begin
draw_a_card(cards[i],col_x,col_y);
col_x:=col_x+40;
col_y:=col_y+2;
if col_x>600 then
begin
col_x:=10;
col_y:=80;
end;
end;
end
else
begin
charscale(10.0,14.0,12,14);
preblanking:=true;
drawstring('Congratulations, you win.');
end;
color(1);
preblanking:=true;
charscale(10.0,14.0,12,14);
charcursor(1,200);
drawstring('Type any character to exit...');
read(kbd,ch);
clearallplanes;
end;
begin
{ required initialization }
LeftMargin:=15;RightMargin:=15; { used by DrawString }
TopMargin:=10;BottomMargin:=10; { used by DrawString }
for P:=0 to 255 do ScrollMap[P]:=P;
HighResolution:=true; { Change to 'true' for high resolution demo }
Ginitialize; { Initialize }
LoadScrollMap(ScrollMap); { Load scroll map }
DualMonitor:=false; { Dual CRTs }
{ end of required initialization }
ClearAllPlanes;
Pattern(255,4); { Draw all lines as solid lines }
PreBlanking:=false;
normvideo;
writeln('Welcome to Rainbow Graphics Solitaire(c).');
Write('C)olor or B)lack&White display: ');
readln(ch);
while not (Upcase(ch) in ['C','B']) do
begin
Write('C)olor or B)lack&White display: ');
readln(ch);
end;
if Upcase(ch)='C' then
begin
ColorMap[00]:=$00; ColorMap[16]:=$00; { 0 black }
ColorMap[01]:=$FF; ColorMap[17]:=$FF; { 1 white }
ColorMap[02]:=$F0; ColorMap[18]:=$06; { 2 red }
ColorMap[03]:=$0F; ColorMap[19]:=$F0; { 3 green }
Operation(0,15); { REPLACE write to all planes }
Color_dsp:=true;
end
else
begin
ColorMap[00]:=$00; ColorMap[16]:=$00; { 0 black }
ColorMap[01]:=$FF; ColorMap[17]:=$FF; { 1 white }
ColorMap[02]:=$00; ColorMap[18]:=$22; { 2 black }
ColorMap[03]:=$00; ColorMap[19]:=$00; { 3 black }
Operation(0,15); { REPLACE write to all plane }
Color_dsp:=false;
end;
LoadColorMap(ColorMap); { Load color map }
writeln('WARNING: You must have a Rainbow Graphics card to play this game, or else');
writeln('you won''t see anything!!!');
writeln('Type an "H" or a "?" for HELP,');
writeln('Otherwise, type any character to start game...');
read(kbd,ch);
if (Upcase(ch)='H') or (ch='?') then help;
graphicson;
clearallplanes;
Backgroundcolor(3);
init_pip(pip_offs);
init_deck;
shuffle;
init_column;
deal;
gdisplay;
draw_back(700,40);
ok:=true;
play;
display_deck;
clrscr;
Normvideo;
graphicsoff;
end.