The post UNO Card Game first appeared on Delphijustin industries.

This game is a work of art! The rules are simple, in fact it may even be easier to win than regular solitaire! The object of this game is to discard all the cards by taking a pair of 2 cards and adding them up to 11. Jacks, queens and kings are only discarded when there is only one of each visible they are discarded automatically. It has a Cheat-sheet feature that shows all combinations that can be made. You can either drag and drop cards or type in there number. There number is the # on each card. For example in this screenshot to discard the 7 of clubs and the 4 of clubs type 23. The source code is written in Delphi.

The post Elevens Solitaire first appeared on Delphijustin industries.

The post Aces Up Solitaire first appeared on Delphijustin industries.

unit sudokuUnit1;

interface
n
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Menus,printers, ExtCtrls,mmsystem,shellapi;
const
APPVERSION='1.0.0.1';
sudo_win_value=2*3*4*5*6*7*8*9;
savedgame_exists=1;
stats_exists=2;
level_exists=4;
type
  TSudokuGame = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Edit4: TEdit;
    Edit5: TEdit;
    Edit6: TEdit;
    Edit7: TEdit;
    Edit8: TEdit;
    Edit9: TEdit;
    Edit10: TEdit;
    Edit11: TEdit;
    Edit12: TEdit;
    Edit13: TEdit;
    Edit14: TEdit;
    Edit15: TEdit;
    Edit16: TEdit;
    Edit17: TEdit;
    Edit18: TEdit;
    Edit19: TEdit;
    Edit20: TEdit;
    Edit21: TEdit;
    Edit22: TEdit;
    Edit23: TEdit;
    Edit24: TEdit;
    Edit25: TEdit;
    Edit26: TEdit;
    Edit27: TEdit;
    Edit28: TEdit;
    Edit29: TEdit;
    Edit30: TEdit;
    Edit31: TEdit;
    Edit32: TEdit;
    Edit33: TEdit;
    Edit34: TEdit;
    Edit35: TEdit;
    Edit36: TEdit;
    Edit37: TEdit;
    Edit38: TEdit;
    Edit39: TEdit;
    Edit40: TEdit;
    Edit41: TEdit;
    Edit42: TEdit;
    Edit43: TEdit;
    Edit44: TEdit;
    Edit45: TEdit;
    Edit46: TEdit;
    Edit47: TEdit;
    Edit48: TEdit;
    Edit49: TEdit;
    Edit50: TEdit;
    Edit51: TEdit;
    Edit52: TEdit;
    Edit53: TEdit;
    Edit54: TEdit;
    Edit55: TEdit;
    Edit56: TEdit;
    Edit57: TEdit;
    Edit58: TEdit;
    Edit59: TEdit;
    Edit60: TEdit;
    Edit61: TEdit;
    Edit62: TEdit;
    Edit63: TEdit;
    Edit64: TEdit;
    Edit65: TEdit;
    Edit66: TEdit;
    Edit67: TEdit;
    Edit68: TEdit;
    Edit69: TEdit;
    Edit70: TEdit;
    Edit71: TEdit;
    Edit72: TEdit;
    Edit73: TEdit;
    Edit74: TEdit;
    Edit75: TEdit;
    Edit76: TEdit;
    Edit77: TEdit;
    Edit78: TEdit;
    Edit79: TEdit;
    Edit80: TEdit;
    Edit81: TEdit;
    MainMenu1: TMainMenu;
    Game1: TMenuItem;
    Newgame1: TMenuItem;
    ChoosePuzzle1: TMenuItem;
    Level1: TMenuItem;
    Easiest1: TMenuItem;
    Easy1: TMenuItem;
    Medium1: TMenuItem;
    Hard1: TMenuItem;
    VeryHard1: TMenuItem;
    Print1: TMenuItem;
    PrintDialog1: TPrintDialog;
    Label1: TLabel;
    Label2: TLabel;
    Exit1: TMenuItem;
    Help1: TMenuItem;
    AboutSudoku1: TMenuItem;
    RandomLevel1: TMenuItem;
    Timer1: TTimer;
    PauseResume1: TMenuItem;
    HowToPlay1: TMenuItem;
    BlankPuzzle1: TMenuItem;
    ResetPuzzle1: TMenuItem;
    Stats1: TMenuItem;
    StartSavingToafileinsteadofregistry1: TMenuItem;
    SaveDialog1: TSaveDialog;
    ExportPuzzle1: TMenuItem;
    procedure FormCreate(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Print1Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Newgame1Click(Sender: TObject);
    procedure Easiest1Click(Sender: TObject);
    procedure ChoosePuzzle1Click(Sender: TObject);
    procedure Exit1Click(Sender: TObject);
    procedure AboutSudoku1Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure PauseResume1Click(Sender: TObject);
    procedure HowToPlay1Click(Sender: TObject);
    procedure BlankPuzzle1Click(Sender: TObject);
    procedure ResetPuzzle1Click(Sender: TObject);
    procedure Stats1Click(Sender: TObject);
    procedure StartSavingToafileinsteadofregistry1Click(Sender: TObject);
    procedure ExportPuzzle1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
  TSudokuGameDat=record
  gamenum:word;
  Puzzle:array[1..81]of byte;
  Enabled:array[1..81]of boolean;
  Time:TDateTime;
  end;
  TSudokuStat=record
  TotalTime:TDateTime;
  TotalPlayed:dword;
  end;
  TSudokuStats=array[1..5]of tsudokustat;
  TSudokuSav=record
  ValuesExist1:dword;
  SavedGame:tsudokugamedat;
  stats:TSudokuStats;
  Level:dword;
  end;
var
  SudokuGame: TSudokuGame;
  puzzleDat:TSudokuGameDat;
  puzzles: tstringlist;
  edits:array[1..81]of tedit;
  clevel,fen:dword;
  username:array[0..255]of char;
  loading:boolean=false;
  levels:array[1..5]of string=('Easiest','Easy','Medium','Hard','Very Hard');
  hkusr:hkey;
implementation

{$R *.DFM}
{$RESOURCE sudoku32.res}

function ImportSavFile:boolean;
var hf:THandle;
data:tsudokusav;
savname:string;
dwBytes,rtSize:dword;
begin
savname:=changefileext(paramstr(0),'.sav');
zeromemory(@Data,sizeof(data));
hf:=createfile(pchar(savname),generic_read,0,nil,open_existing,
file_attribute_normal,0);result:=(hf<>INVALID_HANDLE_VALUE);
if not result then exit;
readfile(hf,rtsize,4,dwBytes,nil);
readfile(hf,data,sizeof(data),dwBytes,nil);closehandle(hf);
result:=(dwBytes+rtsize=sizeof(data)*2);if not result then exit;
if(data.valuesexist1 and level_EXISTS>0)then regsetvalueex(hkusr,'Level',0,
reg_dword,@data.level,4)else regdeletevalue(hkusr,'Level');
if(Savedgame_exists and data.ValuesExist1>0)then regsetvalueex(hkusr,'SavedGame',
0,reg_binary,@data.SavedGame,sizeof(data.savedgame))else regdeletevalue(hkusr,
'SavedGame');
if(stats_exists and data.ValuesExist1>0)then regsetvalueex(hkusr,'Stat',0,
reg_binary,@data.stats,sizeof(data.stats))else regdeletevalue(hkusr,'Stat');
end;

function ExportSavFile:boolean;
var hf:thandle;
uname,compuname:array[0..255]of char;
savname,Footer:string;
unsize,cnsize,rs,dwBytes:dword;
data:tsudokusav;
begin
savname:=changefileext(paramstr(0),'.sav');
zeromemory(@data,sizeof(data));
rs:=4;
data.ValuesExist1:=(LEVEL_EXISTS*Byte(Regqueryvalueex(hkusr,'Level',nil,nil,
@data.level,@rs)=error_success))or data.valuesexist1;
rs:=Sizeof(data.stats);
data.ValuesExist1:=(stats_EXISTS*Byte(Regqueryvalueex(hkusr,'Stat',nil,nil,
@data.stats,@rs)=error_success))or data.valuesexist1;
rs:=Sizeof(data.savedgame);
data.ValuesExist1:=(savedgame_EXISTS*Byte(Regqueryvalueex(hkusr,'SavedGame',nil,
nil,@data.SavedGame,@rs)=error_success))or data.valuesexist1;
hf:=CreateFile(pchar(savname),generic_write,0,nil,create_always,
file_attribute_normal,0);result:=(hf<>INVALID_HANDLE_VALUE);
if not result then exit;
rs:=sizeof(data);
writefile(hf,rs,4,dwbytes,nil);
Writefile(hf,data,sizeof(data),dwBytes,nil);
cnsize:=256;unsize:=256;
getusername(uname,unsize);
getcomputername(compuname,cnsize);
footer:=format(#13#10'Sudoku v%s'#13#10'Last Exported on %s@%s',[appversion,uname,
compuname]);
result:=(dwBytes=Sizeof(data));
writefile(hf,footer[1],length(footer),dwbytes,nil);
closehandle(hf);
end;
procedure LoadPuzzles(level:dword);
var rpuzzle:tresourcestream;
begin
randomize;
if level=0 then clevel:=random(5)+1;
if level>5then clevel:=1 else clevel:=level;
rpuzzle:=tresourcestream.CreateFromID(hinstance,clevel,'PUZZLES');
puzzles.LoadFromStream(rpuzzle);
rpuzzle.Free;
case clevel of
1:sudokugame.Easiest1.Checked:=true;
2:sudokugame.easy1.Checked:=true;
3:sudokugame.medium1.Checked:=true;
4:sudokugame.hard1.Checked:=true;
5:sudokugame.veryhard1.Checked:=true;
end;
end;

procedure opengame;
var i:integer;
begin
loading:=true;
sudokugame.Label1.Caption:='Puzzle: '+Inttostr(puzzledat.gamenum);
sudokugame.Label2.Caption:='Level: '+inttostr(clevel);
for i:=1to 81do
begin
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=puzzledat.enabled[i];
if edits[i].text='0'then edits[i].clear;
end;
loading:=false;
end;

procedure NewGame;
var i:integer;
begin
zeromemory(@puzzledat,sizeof(puzzledat));
puzzledat.gamenum:=Random(puzzles.count);
loading:=true;
for i:=1to 81 do begin
puzzledat.Puzzle[i]:=strtoint(puzzles[puzzledat.gamenum][i]);
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=(edits[i].text='0');
puzzledat.Enabled[i]:=edits[i].enabled;
if edits[i].enabled then edits[i].clear;
end;
sudokugame.Label1.Caption:='Puzzle: '+inttostr(puzzledat.gamenum);
Sudokugame.Label2.Caption:='Level: '+levels[clevel];
loading:=false;
end;

procedure TSudokuGame.FormCreate(Sender: TObject);
var I:integer;
rs:dword;
hkjustin:hkey;
unsize:dword;
bsaved:boolean;
begin
edits[1]:=edit1;
edits[2]:=edit2;
edits[3]:=edit3;
edits[4]:=edit4;
edits[5]:=edit5;
edits[6]:=edit6;
edits[7]:=edit7;
edits[8]:=edit8;
edits[9]:=edit9;
edits[10]:=edit10;
edits[11]:=edit11;
edits[12]:=edit12;
edits[13]:=edit13;
edits[14]:=edit14;
edits[15]:=edit15;
edits[16]:=edit16;
edits[17]:=edit17;
edits[18]:=edit18;
edits[19]:=edit19;
edits[20]:=edit20;
edits[21]:=edit21;
edits[22]:=edit22;
edits[23]:=edit23;
edits[24]:=edit24;
edits[25]:=edit25;
edits[26]:=edit26;
edits[27]:=edit27;
edits[28]:=edit28;
edits[29]:=edit29;
edits[30]:=edit30;
edits[31]:=edit31;
edits[32]:=edit32;
edits[33]:=edit33;
edits[34]:=edit34;
edits[35]:=edit35;
edits[36]:=edit36;
edits[37]:=edit37;
edits[38]:=edit38;
edits[39]:=edit39;
edits[40]:=edit40;
edits[41]:=edit41;
edits[42]:=edit42;
edits[43]:=edit43;
edits[44]:=edit44;
edits[45]:=edit45;
edits[46]:=edit46;
edits[47]:=edit47;
edits[48]:=edit48;
edits[49]:=edit49;
edits[50]:=edit50;
edits[51]:=edit51;
edits[52]:=edit52;
edits[53]:=edit53;
edits[54]:=edit54;
edits[55]:=edit55;
edits[56]:=edit56;
edits[57]:=edit57;
edits[58]:=edit58;
edits[59]:=edit59;
edits[60]:=edit60;
edits[61]:=edit61;
edits[62]:=edit62;
edits[63]:=edit63;
edits[64]:=edit64;
edits[65]:=edit65;
edits[66]:=edit66;
edits[67]:=edit67;
edits[68]:=edit68;
edits[69]:=edit69;
edits[70]:=edit70;
edits[71]:=edit71;
edits[72]:=edit72;
edits[73]:=edit73;
edits[74]:=edit74;
edits[75]:=edit75;
edits[76]:=edit76;
edits[77]:=edit77;
edits[78]:=edit78;
edits[79]:=edit79;
edits[80]:=edit80;
edits[81]:=edit81;
for i:=1to 81do edits[i].tag:=i;
puzzles:=tstringlist.Create;
clevel:=1;
bsaved:=false;
fen:=0;rs:=4;regcreatekey(hkey_current_user,'Software\Justin',hkjustin);
regqueryvalueex(hkjustin,'FileSavingEnabled',nil,nil,@fen,@rs);regclosekey(hkjustin);
startsavingtoafileinsteadofregistry1.Checked:=(fen=1)or fileexists(ChangeFileExt(
paramstr(0),'.sav'));
regcreatekey(hkey_current_user,'Software\Justin\Sudoku',hkusr);
if startsavingtoafileinsteadofregistry1.Checked then importsavfile;
clevel:=1;
rs:=4;
regqueryvalueex(hkusr,'Level',nil,nil,@clevel,@rs);
loadpuzzles(clevel);
rs:=Sizeof(puzzledat);
if(RegQueryValueex(hkusr,'SavedGame',nil,nil,@puzzledat,@rs)=error_success)or
bsaved then
begin
if messagebox(handle,'Do you want to resume last saved game?','Sudoku',mb_yesno or
mb_iconquestion)=idyes then opengame else newgame;
exit;
end;
newgame;
end;

function GetWinValue(row,typ:byte):integer;
var x:integer;
begin
result:=1;
case typ of
1:case row of
1:result:=puzzledat.puzzle[1]*puzzledat.puzzle[2]*puzzledat.puzzle[3]*
puzzledat.puzzle[4]*puzzledat.puzzle[5]*puzzledat.puzzle[6]*puzzledat.puzzle[7]*
puzzledat.puzzle[8]*puzzledat.puzzle[9];
2:result:=puzzledat.puzzle[10]*puzzledat.puzzle[11]*puzzledat.puzzle[12]*
puzzledat.puzzle[13]*puzzledat.puzzle[14]*puzzledat.puzzle[15]*
puzzledat.puzzle[16]*puzzledat.puzzle[17]*puzzledat.puzzle[18];
3:result:=puzzledat.puzzle[19]*puzzledat.puzzle[20]*puzzledat.puzzle[21]*
puzzledat.puzzle[22]*puzzledat.puzzle[23]*puzzledat.puzzle[24]*
puzzledat.puzzle[25]*puzzledat.puzzle[26]*puzzledat.puzzle[27];
4:result:=puzzledat.puzzle[28]*puzzledat.puzzle[29]*puzzledat.puzzle[30]*
puzzledat.puzzle[31]*puzzledat.puzzle[32]*puzzledat.puzzle[33]*
puzzledat.puzzle[34]*puzzledat.puzzle[35]*puzzledat.puzzle[36];
5:result:=puzzledat.puzzle[37]*puzzledat.puzzle[38]*puzzledat.puzzle[39]*
puzzledat.puzzle[40]*puzzledat.puzzle[41]*puzzledat.puzzle[42]*
puzzledat.puzzle[43]*puzzledat.puzzle[44]*puzzledat.puzzle[45];
6:result:=puzzledat.puzzle[46]*puzzledat.puzzle[47]*puzzledat.puzzle[48]*
puzzledat.puzzle[49]*puzzledat.puzzle[50]*puzzledat.puzzle[51]*
puzzledat.puzzle[52]*puzzledat.puzzle[53]*puzzledat.puzzle[54];
7:result:=puzzledat.puzzle[55]*puzzledat.puzzle[56]*puzzledat.puzzle[57]*
puzzledat.puzzle[58]*puzzledat.puzzle[59]*puzzledat.puzzle[60]*
puzzledat.puzzle[61]*puzzledat.puzzle[62]*puzzledat.puzzle[63];
8:result:=puzzledat.puzzle[64]*puzzledat.puzzle[65]*puzzledat.puzzle[66]*
puzzledat.puzzle[67]*puzzledat.puzzle[68]*puzzledat.puzzle[69]*
puzzledat.puzzle[70]*puzzledat.puzzle[71]*puzzledat.puzzle[72];
9:result:=puzzledat.puzzle[73]*puzzledat.puzzle[74]*puzzledat.puzzle[75]*
puzzledat.puzzle[76]*puzzledat.puzzle[77]*puzzledat.puzzle[78]*
puzzledat.puzzle[79]*puzzledat.puzzle[80]*puzzledat.puzzle[81];
end;
2:for x:=1to 9 do result:=result*puzzledat.puzzle[9*x-(row-1)];
3:case row of
1:begin for x:=1to 3do result:=result*puzzledat.puzzle[x];
for x:=10to 12do result:=result*puzzledat.puzzle[x];
for x:=19to 21do result:=result*puzzledat.puzzle[x];
 end;
2:begin for x:=4to 6do result:=result*puzzledat.puzzle[x];
for x:=13to 15do result:=result*puzzledat.puzzle[x];
for x:=22to 24do result:=result*puzzledat.puzzle[x];
 end;
 3:begin for x:=7to 9do result:=result*puzzledat.puzzle[x];
for x:=16to 18do result:=result*puzzledat.puzzle[x];
for x:=25to 27do result:=result*puzzledat.puzzle[x];
 end;
 4:begin for x:=28to 30do result:=result*puzzledat.puzzle[x];
for x:=37to 39do result:=result*puzzledat.puzzle[x];
for x:=46to 48do result:=result*puzzledat.puzzle[x];
 end;
 5:begin for x:=31to 33do result:=result*puzzledat.puzzle[x];
for x:=40to 42do result:=result*puzzledat.puzzle[x];
for x:=49to 51do result:=result*puzzledat.puzzle[x];
 end;
 6:begin for x:=34to 36do result:=result*puzzledat.puzzle[x];
for x:=43to 45do result:=result*puzzledat.puzzle[x];
for x:=52to 54do result:=result*puzzledat.puzzle[x];
 end;
 7:begin for x:=55to 57do result:=result*puzzledat.puzzle[x];
for x:=64to 66do result:=result*puzzledat.puzzle[x];
for x:=73to 75do result:=result*puzzledat.puzzle[x];
 end;
 8:begin for x:=58to 60do result:=result*puzzledat.puzzle[x];
for x:=67to 69do result:=result*puzzledat.puzzle[x];
for x:=76to 78do result:=result*puzzledat.puzzle[x];
 end;
 9:begin for x:=61to 63do result:=result*puzzledat.puzzle[x];
for x:=70to 72do result:=result*puzzledat.puzzle[x];
for x:=79to 81do result:=result*puzzledat.puzzle[x];
 end;
 end;
end;
end;

procedure HighlightCells(row,typ:byte; HasError:boolean);
var x:integer;
begin
case typ of
1:case row of
1:for x:=1to 9do if haserror then  edits[x].color:=clred else edits[x].color:=
clwindow;
2:for x:=10to 18do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
3:for x:=19to 27do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
4:for x:=28to 36do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
5:for x:=37to 45do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
6:for x:=46to 54do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
7:for x:=55to 63do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
8:for x:=64to 72do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
9:for x:=73to 81do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
end;
2:for x:=1to 9 do if haserror then edits[9*x-(row-1)].color:=clred else
edits[9*x-(row-1)].color:=clWindow;
3:case row of
1:begin for x:=1to 3do if haserror then edits[x].color:=clred else
edits[x].color:=clwindow;
for x:=10to 12do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
for x:=19to 21do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
 end;
2:begin for x:=4to 6do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=13to 15do if haserror then edits[x].color:=clred else
edits[x].color:=clwindow;for x:=22to 24do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;
 end;
 3:begin for x:=7to 9do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=16to 18do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=25to 27do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 4:begin for x:=28to 30do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=37to 39do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=46to 48do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 5:begin for x:=31to 33do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=40to 42do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=49to 51do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 6:begin for x:=34to 36do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=43to 45do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=52to 54do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 7:begin for x:=55to 57do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=64to 66do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 8:begin for x:=58to 60do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=67to 69do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=76to 78do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 9:begin for x:=61to 63do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=70to 72do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow;for x:=79to 81do if haserror then edits[x].color:=clred else edits[x].color:=
clwindow; end;
 end;
end;
end;

procedure TSudokuGame.Edit1Change(Sender: TObject);
var i,j:integer;
rs:dword;
bwon:boolean;
stat:tsudokustats;
wav:array[0..4]of char;
msg:array[0..255]of char;
begin
if loading then exit;
if not timer1.Enabled then timer1.Enabled:=true;
for i:=1to 81do puzzledat.Puzzle[i]:=strtointdef(edits[i].text,0);
bwon:=true;
for j:=1to 3do for i:=1to 9 do begin bwon:=bwon and(GetWinValue(i,j)=
sudo_win_value);if(GetWinValue(i,j)>0)and(getwinvalue(i,j)<>sudo_win_value)then
highlightcells(i,j,true)else highlightcells(i,j,false);
end;
regsetvalueex(hkusr,'SavedGame',0,reg_binary,@puzzledat,sizeof(puzzledat));
if bwon then begin
timer1.Enabled:=false;
zeromemory(@stat,sizeof(stat));
rs:=sizeof(stat);
regqueryvalueex(hkusr,'Stat',nil,nil,@stat,@rs);
stat[clevel].TotalTime:=stat[clevel].TotalTime+puzzledat.Time;
inc(stat[clevel].totalplayed);
regsetvalueex(hkusr,'Stat',0,reg_binary,@stat,sizeof(stat));
regdeletevalue(hkusr,'SavedGame');
PlaySound(strfmt(wav,'WIN%d',[random(2)]),hinstance,snd_resource or snd_sync);
messagebox(handle,strfmt(msg,'Congradulations! You Won!'#13#10+
'Games played: %d Average playing time: %d days %s',[stat[clevel].totalplayed,
trunc(stat[clevel].totaltime/stat[clevel].TotalPlayed),FormatDateTime('hh:nn:ss',
stat[clevel].totaltime/stat[clevel].totalplayed)]),'Sudoku',0);
for i:=1to 81 do edits[i].enabled:=false;

end;
end;

procedure printAnotherPuzzle;
var bmp:tbitmap;
begin
newgame;
printer.NewPage;
bmp:=sudokugame.GetFormImage;
printer.Canvas.StretchDraw(Rect(0,0,printer.PageWidth,printer.PageHeight),bmp);
end;

procedure TSudokuGame.Print1Click(Sender: TObject);
var bmp:tbitmap;
n,i:integer;
begin
n:=Strtointdef(inputbox('Number of puzzle','Number of puzzles to print','1'),1);
if not printdialog1.Execute then exit;
bmp:=GetFormImage;
printer.BeginDoc;
printer.Canvas.StretchDraw(rect(0,0,printer.PageWidth,printer.PageHeight),bmp);
for i:=2 to n do
printanotherpuzzle;
printer.EndDoc;
end;

procedure TSudokuGame.FormClose(Sender: TObject; var Action: TCloseAction);
begin
if startsavingtoafileinsteadofregistry1.Checked then exportSavFile;
regclosekey(hkusr);
end;

procedure TSudokuGame.Newgame1Click(Sender: TObject);
begin
newgame;
end;

procedure TSudokuGame.Easiest1Click(Sender: TObject);
begin
clevel:=TMenuItem(Sender).tag;
regsetvalueex(hkusr,'Level',0,reg_dword,@clevel,4);
Easiest1.Checked:=false;
easy1.Checked:=false;
medium1.Checked:=false;
hard1.Checked:=false;
veryhard1.Checked:=false;
randomlevel1.Checked:=false;
loadpuzzles(clevel);
if messagebox(handle,'Do you want to start a new puzzle?','Sudoku',mb_yesno or
mb_iconquestion)=idyes then newgame;
end;

procedure TSudokuGame.ChoosePuzzle1Click(Sender: TObject);
var i:integer;
emsg:array[0..255]of char;
label tryagain;
begin
tryagain:
puzzledat.gamenum:=strtointdef(inputbox('Choose A Puzzle','Enter puzzle number',
inttostr(puzzledat.gamenum)),puzzledat.gamenum);
if(puzzledat.gamenum>=puzzles.Count) then begin
if Messagebox(handle,strfmt(emsg,'The puzzle number must be between 0 and %d.',[
puzzles.count-1]),'Sudoku',mb_iconexclamation or mb_okcancel)=id_cancel then exit;
goto tryagain;
end;
zeromemory(@puzzledat.puzzle,81);
puzzledat.Time:=0;
for i:=1to 81 do begin
puzzledat.Puzzle[i]:=strtoint(puzzles[puzzledat.gamenum][i]);
edits[i].text:=inttostr(puzzledat.puzzle[i]);
edits[i].enabled:=(edits[i].text='0');
puzzledat.Enabled[i]:=edits[i].enabled;
if edits[i].text='0' then edits[i].clear;
end;
sudokugame.Label1.Caption:='Puzzle: '+inttostr(puzzledat.gamenum);
Sudokugame.Label2.Caption:='Level: '+levels[clevel];
end;

procedure TSudokuGame.Exit1Click(Sender: TObject);
begin
close;
end;

procedure TSudokuGame.AboutSudoku1Click(Sender: TObject);
var msg:array[0..512]of char;
begin
Messagebox(handle,strfmt(msg,
'Sudoku v%s by Justin Roeder'#13#10'Puzzle database owned by printable-sudoku-puzzles.com',
[APPVERSION]),'About Sudoku',0);
end;

procedure TSudokuGame.Timer1Timer(Sender: TObject);
begin
puzzledat.Time:=puzzledat.Time+EncodeTime(0,0,1,0);
caption:=formatdatetime('"Sudoku ("hh:nn:ss")"',puzzledat.Time);
regsetvalueex(hkusr,'SavedGame',0,reg_binary,@puzzledat,sizeof(puzzledat));

end;

procedure TSudokuGame.PauseResume1Click(Sender: TObject);
var i:integer;
begin
timer1.Enabled:=not timer1.Enabled;
for i:=1to 81do edits[i].visible :=timer1.Enabled;
if not timer1.Enabled then caption:='Sudoku(paused)';

end;

procedure TSudokuGame.HowToPlay1Click(Sender: TObject);
var msg:array[0..1024]of char;
begin
messagebox(0,strpcopy(Msg,
'Objective of Sudoku is to fill every cell with digits 1 to 9'#13#10+
'But the rules are every row, column and 3x3 square must use the '#13#10+
'digits 1 to 9 once. Also when a full column,row or square is filled in wrong'#13#10+
'it is highlighted red.'),'Sudoku Rules',0);
end;

procedure TSudokuGame.BlankPuzzle1Click(Sender: TObject);
var i:integer;
begin
puzzledat.gamenum:=$ffff;
zeromemory(@puzzledat.puzzle,81);
fillmemory(@puzzledat.enabled,81,sizeof(puzzledat.enabled));
for i:=1to 81do begin edits[i].enabled:=true;edits[i].clear;end;

end;

procedure TSudokuGame.ResetPuzzle1Click(Sender: TObject);
var i:integer;
begin
if messagebox(handle,
'This will clear everything you entered.'#13#10'Do you wish to do that?',
'Sudoku',MB_YESNO or mb_iconquestion)<>idyes then exit;
for i:=1to 81do if edits[i].enabled then begin
puzzledat.Puzzle[i]:=0;
edits[i].clear;end;
end;

function Divide(n,d:extended):extended;
begin
result:=0;
if d=0 then exit;
result:=n/d;
end;

procedure TSudokuGame.Stats1Click(Sender: TObject);
var msg:array[0..255]of char;
stat:tsudokustats;
rs:dword;
begin
zeromemory(@stat,sizeof(stat));
rs:=sizeof(stat);
RegQueryValueex(hkusr,'Stat',nil,nil,@stat,@rs);
messagebox(handle,strfmt(msg,Pchar(
'Easiest Level:Games Played: %d Average Time: %d days %s'#13#10+
'Easy Level:Games Played: %d Average Time: %d days %s'#13#10+
'Medium Level:Games Played: %d Average Time: %d days %s'#13#10+
'Hard Level:Games Played: %d Average Time: %d days %s'#13#10+
'Very Hard Level:Games Played: %d Average Time: %d days %s'),[
stat[1].totalplayed,trunc(divide(stat[1].totaltime,stat[1].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[1].totaltime,stat[1].TotalPlayed)),
stat[2].totalplayed,trunc(divide(stat[2].totaltime,stat[2].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[2].totaltime,stat[2].TotalPlayed)),
stat[3].totalplayed,trunc(divide(stat[3].totaltime,stat[3].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[3].totaltime,stat[3].TotalPlayed)),
stat[4].totalplayed,trunc(divide(stat[4].totaltime,stat[4].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[4].totaltime,stat[1].TotalPlayed)),
stat[5].totalplayed,trunc(divide(stat[5].totaltime,stat[5].TotalPlayed)),
FormatDateTime('hh:nn:ss',divide(stat[5].totaltime,stat[5].TotalPlayed))]),
'Sudoku Stats',0);
end;

procedure TSudokuGame.StartSavingToafileinsteadofregistry1Click(
  Sender: TObject);
var hkjustin:HKey;
savname:string;
FileSavingEnabled:dword;
begin
startsavingtoafileinsteadofregistry1.Checked:=not startsavingtoafileinsteadofregistry1.Checked;
savname:=changefileext(paramstr(0),'.sav');
if startsavingtoafileinsteadofregistry1.Checked then exportsavfile else
deletefile(savname);
filesavingenabled:=byte(startsavingtoafileinsteadofregistry1.checked);
RegOpenKey(hkey_current_user,'Software\Justin',hkjustin);regsetvalueex(
hkjustin,'FileSavingEnabled',0,reg_dword,@filesavingenabled,4);regclosekey(hkjustin);
end;
function GetHTMLSudoku(edindex:byte):String;
begin
if edits[edindex].enabled then result:=format(
'<input type="text" maxlength="1" name="sudo%d" value="%s">',[edindex-1,
edits[edindex].text])else result:=format(
'%s<input type="hidden" name="sudo%d" value="%s">',[edits[edindex].text,edindex-1,
edits[edindex].text]);
end;
function SudokuSpace(edindex:byte):string;
begin
if edits[edindex].text=''then result:=#32#32else result:=#32+edits[edindex].text;
end;
function getfilecount:integer;
var i:integer;
begin
result:=1;
for i:=3to paramcount do
if paramstr(i)='/E'then result:=strtointdef(paramstr(i+1),1);
end;
procedure TSudokuGame.ExportPuzzle1Click(Sender: TObject);
var col,csv:tstringlist;
i,fn,c:integer;
forr:TResourceStream;
bm:tbitmap;
fns:String;
begin
if not savedialog1.Execute then exit;
fns:=extractfilepath(savedialog1.filename)+'\%d_'+
extractfilename(savedialog1.filename); 
c:=strtointdef(inputbox('Sudoku','Number of puzzles','1'),1);
for fn:=1to c do begin savedialog1.filename:=format(fns,[fn]);
if stricomp('.csv',pchar(extractfileext(savedialog1.filename)))=0then begin
col:=tstringlist.Create;
csv:=tstringlist.Create;
for i :=1to 9 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=10to 18 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=19to 27 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=28to 36 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=37to 45 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=46to 54 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=55to 63 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=64to 72 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
for i :=73to 81 do col.Add(edits[i].text);
csv.Add(col.commatext);col.Clear;
csv.SaveToFile(savedialog1.filename);
csv.Free;col.Free;
end else if stricomp('.txt',pchar(extractfileext(savedialog1.filename)))=0then
begin
forr:=tresourcestream.create(hinstance,'DOSTEXT','BIN');
csv:=tstringlist.create;
csv.loadfromstream(forr);
csv.text:=format(csv.text,[puzzledat.gamenum,
SudokuSpace(1),sudokuspace(2),sudokuspace(3),sudokuspace(4),sudokuspace(5),
sudokuspace(6),sudokuspace(7),sudokuspace(8),sudokuspace(9),
sudokuspace(10),sudokuspace(11),sudokuspace(12),sudokuspace(13),sudokuspace(14),
sudokuspace(15),sudokuspace(16),sudokuspace(17),sudokuspace(18),
sudokuspace(19),sudokuspace(20),sudokuspace(21),sudokuspace(22),sudokuspace(23),
sudokuspace(24),sudokuspace(25),sudokuspace(26),sudokuspace(27),
sudokuspace(28),sudokuspace(29),sudokuspace(30),sudokuspace(31),sudokuspace(32),
sudokuspace(33),sudokuspace(34),sudokuspace(35),sudokuspace(36),
sudokuspace(37),sudokuspace(38),sudokuspace(39),sudokuspace(40),sudokuspace(41),
sudokuspace(42),sudokuspace(43),sudokuspace(44),sudokuspace(45),
sudokuspace(46),sudokuspace(47),sudokuspace(48),sudokuspace(49),sudokuspace(50),
sudokuspace(51),sudokuspace(52),sudokuspace(53),sudokuspace(54),
sudokuspace(55),sudokuspace(56),sudokuspace(57),sudokuspace(58),sudokuspace(59),
sudokuspace(60),sudokuspace(61),sudokuspace(62),sudokuspace(63),
sudokuspace(64),sudokuspace(65),sudokuspace(66),sudokuspace(67),sudokuspace(68),
sudokuspace(69),sudokuspace(70),sudokuspace(71),sudokuspace(72),
sudokuspace(73),sudokuspace(74),sudokuspace(75),sudokuspace(76),sudokuspace(77),
sudokuspace(78),sudokuspace(79),sudokuspace(80),sudokuspace(81)]);
forr.Free;csv.SaveToFile(savedialog1.filename);csv.free;
end else if(stricomp('.htm',pchar(extractfileext(savedialog1.filename)))=0)or(
stricomp('.html',pchar(extractfileext(savedialog1.filename)))=0)then
begin
csv:=tstringlist.Create;
forr:=tresourcestream.Create(hinstance,'WEBPAGE1','BIN');
csv.LoadFromStream(forr);forr.Free;
csv.Text:=format(csv.Text,[puzzledat.gamenum,AppVersion,
GetHTMLSudoku(1),GetHTMLSudoku(2),GetHTMLSudoku(3),GetHTMLSudoku(4),GetHTMLSudoku(5),
GetHTMLSudoku(6),GetHTMLSudoku(7),GetHTMLSudoku(8),GetHTMLSudoku(9),
GetHTMLSudoku(10),GetHTMLSudoku(11),GetHTMLSudoku(12),GetHTMLSudoku(13),GetHTMLSudoku(14),
GetHTMLSudoku(15),GetHTMLSudoku(16),GetHTMLSudoku(17),GetHTMLSudoku(18),
GetHTMLSudoku(19),GetHTMLSudoku(20),GetHTMLSudoku(21),GetHTMLSudoku(22),GetHTMLSudoku(23),
GetHTMLSudoku(24),GetHTMLSudoku(25),GetHTMLSudoku(26),GetHTMLSudoku(27),
GetHTMLSudoku(28),GetHTMLSudoku(29),GetHTMLSudoku(30),GetHTMLSudoku(31),GetHTMLSudoku(32),
GetHTMLSudoku(33),GetHTMLSudoku(34),GetHTMLSudoku(35),GetHTMLSudoku(36),
GetHTMLSudoku(37),GetHTMLSudoku(38),GetHTMLSudoku(39),GetHTMLSudoku(40),GetHTMLSudoku(41),
GetHTMLSudoku(42),GetHTMLSudoku(43),GetHTMLSudoku(44),GetHTMLSudoku(45),
GetHTMLSudoku(46),GetHTMLSudoku(47),GetHTMLSudoku(48),GetHTMLSudoku(49),GetHTMLSudoku(50),
GetHTMLSudoku(51),GetHTMLSudoku(52),GetHTMLSudoku(53),GetHTMLSudoku(54),
GetHTMLSudoku(55),GetHTMLSudoku(56),GetHTMLSudoku(57),GetHTMLSudoku(58),GetHTMLSudoku(59),
GetHTMLSudoku(60),GetHTMLSudoku(61),GetHTMLSudoku(62),GetHTMLSudoku(63),
GetHTMLSudoku(64),GetHTMLSudoku(65),GetHTMLSudoku(66),GetHTMLSudoku(67),GetHTMLSudoku(68),
GetHTMLSudoku(69),GetHTMLSudoku(70),GetHTMLSudoku(71),GetHTMLSudoku(72),
GetHTMLSudoku(73),GetHTMLSudoku(74),GetHTMLSudoku(75),GetHTMLSudoku(76),GetHTMLSudoku(77),
GetHTMLSudoku(78),GetHTMLSudoku(79),GetHTMLSudoku(80),GetHTMLSudoku(81)]);
csv.savetofile(savedialog1.filename);csv.Free;
end else if stricomp('.bmp',pchar(extractfileext(savedialog1.filename)))=0then
begin
bm:=getformimage;
bm.SaveToFile(savedialog1.filename);
bm.Free;
end else begin
messagebox(handle,'Invalid file extension','Sudoku',mb_iconerror);
exit;
end;
if c>1then newgame;
end;
end;

end.

The post Sudoku For Windows first appeared on Delphijustin industries.

ScreenShots:

unit golfsol1;
//GolfSolitaire() is the main function
interface
uses graphics,windows,classes,sysutils,shellapi;
const
SCORES_SHOW_ONLY=126;
SCORES_INIT=127;
CurrentVersion=$01000000;
procedure GolfSolitaire(params:tstringlist);
implementation
type TRandom=function(range:integer):integer;stdcall;
TCard=record
face,suit,deck,notused:byte;
end;
TGolfScore=record
Name:shortstring;
gametype:byte;
score:shortint;
end;
TGolfGame=record
gamenum:integer;
decks:byte;
cardcount:array[-1..9]of byte;
drawpile:array[1..40]of pointer;
discardpile:array[1..104]of pointer;
end;
PGolfScore=^TGolfScore;
TGetConsoleWindow=Function:HWND;stdcall;
var rand:hmodule=0;
suits:array[1..4]of longint;
drandom:TRandom;
GetConsoleWindow:TGetConsoleWindow;//for compatiblity with older windows
carddeck:array[1..4,1..14]of byte;
tableua:array[-1..9]of tlist;
hout:thandle;
gameover,inGame:boolean;
defattrib: word;
currentscore:shortint;
scores:array[0..9]of tgolfscore;
hk:hkey;
gamenum,intour:integer;
lost,win,jokersused,aceking,decks,showdiscard,oldestver:dword;
drawpile_bonus_points:Shortint;


function AllUsedJokers:boolean;
begin
result:=(carddeck[1,14]=jokersused);
end;

procedure SaveGame;
var sav:tgolfgame;
i:integer;
begin
sav.gamenum:=gamenum;
sav.decks:=decks;
for i:=-1to 9do sav.cardcount[i]:=tableua[i].count;
for i:=1to tableua[-1].count do
sav.drawpile[i]:=tableua[-1][i-1];
for i:=1to tableua[0].count do
sav.discardpile[i]:=tableua[0][i-1];
regsetvalueex(hk,'SavedGame',0,reg_binary,@sav,sizeof(sav));
end;

function allused:boolean;
var i,j:integer;
begin
result:=allusedjokers;
for i:=1to 4do
for j:=1to 13do
result:=result and(carddeck[i,j]>=decks);
end;

function drawcard:pointer;
var car:tcard;
label shuffle;
begin
car.face:=16;
car.suit:=5;
result:=pointer(car);
if allused then exit;
shuffle:if jokersused>0then car.face:=drandom(14)+1 else car.face:=drandom(13)+1;
car.suit:=drandom(4)+1;
if(car.face=14) and (car.suit>1) then goto shuffle;
if carddeck[car.suit,car.face]=decks then goto shuffle;
inc(carddeck[car.suit,car.face]);
car.deck:=carddeck[car.suit,car.face];
result:=pointer(car);
end;

procedure clearconsole;
var co:coord;
written:dword;
begin
co.x:=0;
co.y:=0;
setconsolecursorposition(hout,co);
fillconsoleoutputcharacter(hout,#32,$ffff,co,written);
setconsolecursorposition(hout,co);
end;

procedure Randominit(gamenum:integer);
var i,j:integer;
begin
if decks=1then
drawpile_bonus_points:=-(16+JokersUsed);
if decks=2then
drawpile_bonus_points:=-(40+jokersused);
zeromemory(@carddeck,sizeof(carddeck));
if rand<>0then
freelibrary(rand);
zeromemory(@carddeck,sizeof(carddeck));
rand:=LoadLibrary('random32.dll');
@drandom:=getprocaddress(rand,'MyRandom');
if not assigned(drandom)then begin writeln('Could'#39't load random32.dll');readln;
regclosekey(hk);exitprocess(0);end;
for i:=0to gamenum do drandom(gamenum);
setconsoletitle(pchar('Golf Solitaire #'+inttostr(gamenum)));
if decks=1then
for i:=1to 7do begin tableua[i].clear;
for j:=1to 5do tableua[i].add(drawcard);
end;
if decks=2then
for i:=1to 9do begin tableua[i].clear;
for j:=1to 7do tableua[i].add(drawcard);
end;
tableua[0].clear;
tableua[-1].clear;
tableua[0].add(drawcard);
while not allused do tableua[-1].add(drawcard);
end;
const background_white=background_red or background_green or background_blue or
background_intensity;
char_heart=#3;
char_diamond=#4;
char_club=#5;
char_spade=#6;
function cardtostring(card:tcard):string;
var attrib:word;
begin
if lobyte(hiword(suits[card.suit]))=ord('R')then attrib:=foreground_red or foreground_intensity or
background_white else
attrib:=background_white;
if card.suit=0then attrib:=0;
setconsoletextattribute(hout, attrib);
case card.face of
0,16:result:=#32;
1:result:='A';
10:result:='T';
11:result:='J';
12:result:='Q';
13:result:='K';
14:begin result:='??';exit;end;//Joker
else result:=inttostr(card.face);end;
case card.suit of
 1,2,3,4:result:=result+chr(hibyte(hiword(suits[card.suit])));
else result:=result+#32;
end;
end;

function sortscores(Item1, Item2: pointer): Integer;
begin
if pgolfscore(item1).score<pgolfscore(item2).score then result:=-1;
if pgolfscore(item1).score=pgolfscore(item2).score then result:=0;
if pgolfscore(item1).score>pgolfscore(item2).score then result:=1;
end;

function ScoreStr(score:PGolfScore):string;
begin
result:=inttostr(score.score);
if score.score=scores_init then result:='N/A';
end;

function gametypetostr(gt:byte):string;
begin
result:='';
if gt and 1=1then result:='AceKing ';
if gt and 2=2then result:=result+'2-decks';
end;

procedure ShowScores(score:shortint);
var cbscores:dword;
I:integer;
thisscore:TGolfScore;
scorea:array[0..9]of tgolfscore;
sortedscores:tlist;
begin
setconsoletextattribute(hout,defattrib);
sortedscores:=tlist.Create;
thisscore.gametype:=0;
cbscores:=0;
if(aceking=1)then thisscore.gametype:=1;
if(decks=2)then thisscore.gametype:=thisscore.gametype or 2;
if score<scores_show_only then begin write('Enter your name:');readln(thisscore.name);
thisscore.score:=score;end;
regqueryvalueex(hk,'Scores',nil,nil,nil,@cbscores);
if cbscores=sizeof(scores)then
regqueryvalueex(hk,'Scores',nil,nil,@scores,@cbscores);
for i:=0to 9do sortedscores.Add(@scores[i]);
if score<126then sortedscores.Add(@thisscore);
sortedscores.Sort(sortscores);
writeln('Place,Score,Name,GameType');
for i:=0to 9do begin write(i+1,'. ',scorestr(sortedscores[i]),' ',pgolfscore(
sortedscores[i]).name,' ',gametypetostr(pgolfscore(sortedscores[i]).gametype));
if sortedscores[i]=@thisscore then write('<--');writeln;copymemory(@scorea[i],
sortedscores[i],sizeof(tgolfscore));
end;
copymemory(@scores,@scorea,sizeof(scorea));
regsetvalueex(hk,'Scores',0,reg_binary,@scores,sizeof(scores));
sortedscores.Free;
writeln('Wins: ',win,' Lost: ',lost,' Games Played: ',win+lost);
write('Press enter to return...');readln;
clearconsole;
end;

procedure loadgame;
var sav:tgolfgame;
i,j,colcount:integer;
cb:dword;
Begin
cb:=sizeof(sav);
RegQueryValueEx(hk,'SavedGame',nil,nil,@sav,@cb);
decks:=sav.decks;
if decks=1 then colcount:=5 else colcount:=7;
gamenum:=sav.gamenum;
randominit(gamenum);
for i:=1to 9do
if tableua[i].count>0then for j:=1to colcount-sav.cardcount[i] do tableua[i].remove(
tableua[i].last);
tableua[0].clear;tableua[-1].clear;
for i:=1 to sav.cardcount[-1] do
tableua[-1].add(sav.drawpile[i]);
for i:=1to sav.cardcount[0]do tableua[0].add(sav.discardpile[i]);
end;

procedure youwinproc;
var
conrect:trect;
sortedscores:tlist;
ywbmp:graphics.tbitmap;
concan:tcanvas;
begin
ingame:=false;
GetWindowRect(getconsolewindow,conrect);
writeln('ÉÍÍÍÍÍÍÍÍÍÍ»');
writeln('º You win! º');
writeln('ÈÍÍÍÍÍÍÍÍÍͼ');
gameover:=true;
@getconsolewindow:=GetProcAddress(getmodulehandle('kernel32.dll'),
'GetConsoleWindow');
if assigned(getconsolewindow)then
if getconsolewindow<>0then begin
ywbmp:=graphics.tbitmap.create;
ywbmp.Handle:=loadbitmap(hinstance,'YOUWON');
Concan:=tcanvas.Create;
concan.Handle:=GetWindowDC(getconsolewindow);
concan.Draw((conrect.Right-ywbmp.width)div 2,(conrect.Bottom-ywbmp.height)div 2,
ywbmp);
releasedc(getconsolewindow,concan.handle);
concan.Free;
ywbmp.FreeImage;
ywbmp.Free;
end;
showscores(drawpile_bonus_points);
inc(win);
regdeletevalue(hk,'SavedGame');
regsetvalueex(hk,'Win',0,reg_dword,@win,4);
end;
{$RESOURCE GOLFSOL32.RES}
function quit(typ:dword):Bool;stdcall;
var dwGame:dword;
begin
result:=true;
dwGame:=gamenum;
if ingame then savegame;
regsetvalueex(hk,'Win',0,reg_dword,@win,4);
regsetvalueex(hk,'Lost',0,reg_dword,@lost,4);
regclosekey(hk);
exitprocess(0);
end;

function ismove(pile1,pile2:tlist):boolean;
var p1,p2:pointer;
c1,c2:tcard;
begin
result:=false;
if(pile1.Count*pile2.Count=0)then exit;
p1:=pile1.last;
p2:=pile2.last;
copymemory(@c1,@p1,4);
copymemory(@c2,@p2,4);
result:=(abs(c1.face-c2.face)=1)or(c1.face=14)or(c2.face=14);
if(((c1.face=1)and(c2.face=13))or((c1.face=13)and(c2.face=1)))and(aceking=1)then
result:=true;
end;
function AnyMoreMoves:byte;
var i:integer;
begin
result:=0;
for i:=1to 9 do if ismove(tableua[0],tableua[i])then inc(result);
end;

procedure ShowRules;
begin
clearconsole;
writeln('ÉÍÍÍÍÍÍÍÍÍÍ͹Golf RulesÌÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºThe rules for golf solitaire are º');
writeln('ºvery simple. The whole idea of   º');
writeln('ºgame is to get rid of all cards  º');
writeln('ºin the seven columns(1 deck) or  º');
writeln('ºnine columns(2 decks). As in     º');
writeln('ºregular golf you want to get the º');
writeln('ºlowest points. When the game endsº');
writeln('ºwhatever cards are left count as º');
writeln('ºone point per card. If you go outº');
writeln('ºthe number of cards left will    º');
writeln('ºbecome a negative points. You    º');
writeln('ºwill try to move the cards from  º');
writeln('ºthe columns to the discard pile. º');
writeln('ºThey must be one card bigger or  º');
writeln('ºone card smaller.Example: a 5 canº');
writeln('ºbe moved to the discard pile onlyº');
writeln('ºif the top card is a 6 or a 4,theº');
writeln('ºsuit doesnt matter. You can choseº');
writeln('ºa column by entering the number 1º');
writeln('ºthough 9 and then pressng enter. º');
writeln('ºWhen there are no more moves you º');
writeln('ºcan type in 0 and hit enter or   º');
writeln('ºtype in 10 and hit enter to go toº');
writeln('ºmenu.                            º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
writeln('Press enter to return...');
readln;
intour:=2;
end;

procedure Tour;
begin
clearconsole;
writeln('ÉÍÍÍÍÍÍÍÍÍ͹Golf TourÌÍÍÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºTo know how to use this game you º');
writeln('ºwill be entering in numbers to   º');
writeln('ºtell the game your moves & what  º');
writeln('ºyou want to do. The columns are  º');
writeln('ºnumbered and so is the draw pile.º');
writeln('ºTo draw you enter in 0 and press º');
writeln('ºenter. Next we will look at the  º');
writeln('ºrules.                           º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
writeln('Press enter to continue...');
readln;
intour:=1;
end;

procedure GolfSolitaire(params:tstringlist);
var i,j,choice:integer;
topcard:tcard;
pc:pointer;
cb,sgame:dword;
label gamepmt,gameend,menu,trytour;
begin
hout:=getstdhandle(std_output_handle);
defattrib:=foreground_intensity or foreground_red or foreground_blue or
foreground_green;
decks:=1;
randomize;
ingame:=false;
setconsoleoutputcp(437);
oldestver:=0;
for i:=0to 9do begin scores[i].Name:='N/A';scores[i].score:=scores_init;end;
SetConsoleCtrlHandler(@quit,true);
regcreatekey(hkey_current_user,'Software\Justin\GolfSolitaire',hk);
intour:=0;
suits[1]:=makelong(ord('C'),makeword(ord('B'),ord(char_club)));
suits[2]:=makelong(ord('S'),makeword(ord('B'),ord(char_spade)));
suits[3]:=makelong(ord('H'),makeword(ord('R'),ord(char_heart)));
suits[4]:=makelong(ord('D'),makeword(ord('R'),ord(char_diamond)));
cb:=sizeof(suits);
regqueryvalueex(hk,'Suit',nil,nil,@suits,@cb);
regsetvalueex(hk,'Suit',0,reg_binary,@suits,sizeof(suits));
cb:=4;regqueryvalueex(hk,'Decks',nil,nil,@decks,@cb);
if(decks=0)or(decks>2)then decks:=1;
showdiscard:=0;
cb:=4;
lost:=0;
win:=0;
regqueryvalueex(hk,'Lost',nil,nil,@lost,@cb);
cb:=4;
gameover:=true;
regqueryvalueex(hk,'Win',nil,nil,@win,@cb);
cb:=4;
aceking:=0;jokersused:=0;sgame:=0;
//regqueryvalueex(hk,'JokersUsed',nil,nil,@jokersused,@cb);
//Jokers for some reason freeze up the game being delt.
regqueryvalueex(hk,'LastGame',nil,nil,@sgame,@cb);
cb:=4;
//if jokersused>2then jokersused:=0;
regqueryvalueex(hk,'AceKing',nil,nil,@aceking,@cb);
cb:=4;
if aceking>1then aceking:=0;
regqueryvalueex(hk,'ShowDiscard',nil,nil,@showdiscard,@cb);
if showdiscard>1then showdiscard:=0;
for i:=-1 to 9do tableua[i]:=tlist.create;
if regqueryvalueex(hk,'OldestVersion',nil,nil,nil,nil)<>error_success then
begin
trytour:
write('Would you like to take a tour? type in 1 for Yes or 0 for No:');
readln(choice);
case choice of
1:tour;
0:goto menu;
else goto trytour;
end;
oldestver:=currentversion;
regsetvalueex(hk,'OldestVersion',0,reg_dword,@oldestver,4);
if intour=1 then goto menu;
end;
menu:clearconsole;
setconsoletextattribute(hout,defattrib);
writeln('ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ»');
writeln('ºWelcome to Golf Solitaire         º');
writeln('ºWhat would you like to do?        º');
writeln('º1. Start a new game               º');
writeln('º2. Enter in a game number         º');
writeln('º3. View top ten                   º');
cb:=4;
writeln('º4. See game rules                 º');
writeln('º5. Change rules and settings      º');
if ingame then
writeln('º6. Return to game                 º');
if regqueryvalueex(hk,'SavedGame',nil,nil,nil,nil)=error_success then
writeln('º7. Load Saved Game                º');
writeln('ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ');
if intour=1 then
writeln('To see rules type 4 and press enter');
write('Choice Number:');readln(choice);
case choice of
4:begin showrules;goto menu;end;
1:begin
gamenum:=random(maxint)+1; randominit(gamenum);end;
2:begin write('Enter game#:');readln(gamenum);randominit(gamenum);end;
3:begin showscores(scores_show_only);goto menu;end;
5:begin writeln('Current Settings:');
write('Aces can be played on kings: ');if aceking=1then writeln('Yes')else
writeln('No');//writeln('Jokers used: ',jokersused);
writeln('Number of card decks:',decks);
write('Show all cards in the discard pile:');
if showdiscard=1then writeln('Yes')else writeln('No');
writeln('2=DontChange 1=Yes 0=No Any Other number returns to menu');
Write('Play Kings on Aces? Number Choice:');readln(aceking);
if aceking>1then goto menu;
{tryjoker:
write('Number of jokers to use. 0 though 2 are valid numbers:');
readln(jokersused);
if(JokersUsed>2)then begin Writeln('Too many jokers.');goto tryjoker;end;
}
write('Show all cards in the discard pile?(0=No 1=yes)');readln(showdiscard);
regsetvalueex(hk,'ShowDiscard',0,reg_dword,@showdiscard,4);
//regsetvalueex(hk,'JokersUsed',0,reg_dword,@jokersused,4);
regsetvalueex(HK,'AceKing',0,reg_dword,@aceking,4);
write('Enter number of decks to use(1 or 2):');readln(decks);
regsetvalueex(hk,'Decks',0,reg_dword,@decks,4);
goto menu;
end;
6:if ingame then goto gamepmt else goto menu;
7:if RegQueryValueex(hk,'SavedGame',nil,nil,nil,nil)=error_success then
 loadgame else goto menu;
else goto menu;
end;
gameover:=false;
drawpile_bonus_points:=-tableua[-1].count;
gamepmt:
clearconsole;
setconsoletextattribute(hout,defattrib);
ingame:=true;
write('Game#: ',gamenum,' Cards left:');
j:=0;
for i:=1to 9do j:=j+tableua[i].count;
write(j,' Draws left:',tableua[-1].count,' Type in 10 for menu');
writeln;
writeln('[1][2][3][4][5][6][7][8][9]');
if decks=1 then
for i:=0to 4do begin write(' ');
for j:=1to 9do begin if tableua[j].count>i then write(cardtostring(tcard(tableua[j][i])))
else write('  ');write(' ');end;
writeln;
end;
if decks=2 then
for i:=0to 6do begin write(' ');
for j:=1to 9do begin if tableua[j].count>i then write(cardtostring(tcard(tableua[j][i])))
else write('  ');write(' ');end;
writeln;
end;
setconsoletextattribute(hout,defattrib);
pc:=tableua[0].last;
copymemory(@topcard,@pc,4);
write('Draw[0]: ');
if showdiscard=0then
write(cardtostring(topcard))
else for i:=0to tableua[0].count-1do begin pc:=tableua[0][i];copymemory(@topcard,
@pc,4);write(cardtostring(topcard));end;
writeln;
setconsoletextattribute(hout,defattrib);
write('Choice:');
readln(choice);
case choice of
1,2,3,4,5,6,7,8,9:if ismove(tableua[0],tableua[choice])then
begin tableua[0].add(tableua[choice].last);tableua[choice].remove(
tableua[choice].last);if(tableua[-1].count=0) and(anymoremoves=0) then goto gameend;
end;
0:begin if((tableua[-1].count=0) and(anymoremoves=0)) then
goto gameend;tableua[0].add(tableua[-1].last);inc(drawpile_bonus_points);
tableua[-1].remove(tableua[-1].last);
end;
10:goto menu;
end;
if(tableua[1].count+tableua[2].count+tableua[3].count+tableua[4].count+
tableua[5].count+tableua[6].count+tableua[7].count+tableua[8].count+
tableua[9].count=0)then begin
 youwinproc;
 goto menu;
end;
goto gamepmt;
gameend:
regdeletevalue(hk,'SavedGame');
Writeln('Sorry, no more moves');
writeln('Tableua points: ',tableua[1].count+tableua[2].count+tableua[3].count+
tableua[4].count+tableua[5].count+tableua[6].count+tableua[7].count+
tableua[8].count+tableua[9].count);
gameover:=true;
inc(lost);
ingame:=false;
regsetvalueex(hk,'Lost',0,reg_dword,@lost,4);
showscores(tableua[1].count+tableua[2].count+tableua[3].count+tableua[4].count+
tableua[5].count+tableua[6].count+tableua[7].count);
//writeln('Press enter to return...');readln;
goto menu;
end;
end.

The post Console Golf Solitaire first appeared on Delphijustin industries.

How to build a card deck?

unit garbage1;
//Main Card Game Unit
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, Menus, ComCtrls,shellapi,mmsystem, DBClient, MConnect;
const
Version=$100;
card_error=1;
card_visible=4;
card_flipped=8;
card_exists=2;
card_dead=16+card_flipped;
type
  Tgarbagegame = class(TForm)
    GroupBox1: TGroupBox;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Image5: TImage;
    Image6: TImage;
    Image7: TImage;
    Image8: TImage;
    Image9: TImage;
    Image10: TImage;
    Image12: TImage;
    Image11: TImage;
    GroupBox2: TGroupBox;
    Image13: TImage;
    Image14: TImage;
    Image15: TImage;
    Image16: TImage;
    Image17: TImage;
    Image18: TImage;
    Image19: TImage;
    Image20: TImage;
    Image21: TImage;
    Image22: TImage;
    StatusBar1: TStatusBar;
    MainMenu1: TMainMenu;
    Game1: TMenuItem;
    ChangeBack1: TMenuItem;
    Button1: TButton;
    Help1: TMenuItem;
    AboutGarbage1: TMenuItem;
    ListBox1: TListBox;
    Rules1: TMenuItem;
    KingsAreWild1: TMenuItem;
    DCOMConnection1: TDCOMConnection;
    procedure FormCreate(Sender: TObject);
    procedure ChangeBack1Click(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Image13Click(Sender: TObject);
    procedure Image11Click(Sender: TObject);
    procedure AboutGarbage1Click(Sender: TObject);
    procedure ListBox1DblClick(Sender: TObject);
    procedure Rules1Click(Sender: TObject);
    procedure KingsAreWild1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;
TPlayingCard=record
face,suit:byte;
flags:word;
end;
TPlayingCards=array[1..10]of tplayingcard;
procedure newgame;
function pcback(index:integer):pchar;
procedure updatecards;
var
  garbagegame: Tgarbagegame;
  playerpos:byte=10;
  hdeck:hmodule;
  computerpos:byte=10;
  back:dword;
  deck_pics:array[0..12,1..4]of HBITMAP;
hbacks:array[0..11]of hbitmap;
emptyslots:array[0..2]of hbitmap;
Faces:array[0..12]of string=('Ace','Two','Three','Four','Five','Six','Seven',
'Eight','Nine','Ten','Jack','Queen','King');
Suits:array[1..4]of string=('Clubs','Diamonds','Hearts','Spades');
discard:tlist;
kingswild:dword=1;
cturn,pturn:byte;
candraw:boolean;
gamenum,whoseturn:integer;
harrows:array[0..1]of hicon;
playercards,computercards:tplayingcards;
used:array[0..12,1..4]of boolean;
implementation

{$R *.DFM}
{$RESOURCE DECK.RES}
{$RESOURCE GARBAGE32.RES}
uses garbage2;

procedure endround;
var msg,par:array[0..512]of char;
i:integer;
hk:hkey;
begin
for i:=1to 10do begin if computercards[i].flags and card_flipped=0then
computercards[i].flags:=computercards[i].flags or card_dead;
if playercards[i].flags and card_flipped=0then playercards[i].flags:=
playercards[i].flags or card_dead;
end;
updatecards;
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regdeletevalue(hk,'SavedGame');
regclosekey(hk);
if inttostr(playerpos)=garbagegame.StatusBar1.Panels[2].text then begin
dec(playerpos);
if playerpos=0 then begin
playsound('GOOD2',hinstance,snd_resource or snd_sync);
if messagebox(garbagegame.handle,strfmt(msg,
'You won!'#13#10'Your score:0 points'#13#10'Computer score:%d points'#13#10'Play again?',
[computerpos]),'Game Over',mb_yesno)=idno then exit;
computerpos:=10;
playerpos:=10;
gamenum:=0;
end else begin playsound('CLAP',hinstance,snd_resource or snd_sync);messagebox(
garbagegame.handle,strfmt(msg,
'You won this round!'#13#10'Your score:%d points'#13#10'Computer score:%d points',
[playerpos,computerpos]),'Garbage',0);
end;
end;
if inttostr(computerpos)=garbagegame.StatusBar1.Panels[3].text then begin
dec(computerpos);
if computerpos=0 then begin
if messagebox(garbagegame.handle,strfmt(msg,
'You lost!'#13#10'Your score:%d'#13#10'Computer score:0 points'#13#10'Play again?',
[playerpos]),'Game Over',mb_yesno)=idno then exit;
computerpos:=10;
playerpos:=10;
gamenum:=0;
end else messagebox(garbagegame.handle,strfmt(msg,
'You lost this round!'#13#10'Your score:%d points'#13#10'Computer score:%d points',
[playerpos,computerpos]),'Garbage',0);
end;
shellexecute(0,nil,pchar(application.exename),strfmt(par,'%d %d %d %d %d',[
playerpos,computerpos,gamenum,whoseturn,back]),nil,SW_SHOWNORMAL);
exitprocess(0);
end;
procedure reshuffle;
var i:integer;
p:pointer;
c:tplayingcard;
l:tlist;
begin
//With the game being two player I don't think this function will ever be called!
l:=tlist.Create;
for i:=0 to discard.Count-2do begin p:=discard[i];copymemory(@c,@p,4);l.Add(p);
used[c.face,c.suit]:=false;
end;
for i:=0to l.Count-1do discard.Remove(l[i]);
l.Free;
end;
function CardBack:byte;
var rs,rtyp:Dword;
hk:hkey;
begin
RegCreateKey(hkey_current_user,'Software\Justin\Garbage',hk);
back:=255;
rs:=4;
regqueryvalueex(hk,'CardBack',nil,@rtyp,@back,@rs);
result:=back;
regclosekey(hk);
if back>11then back:=strtointdef(paramstr(5),random(12));
end;
function allused:boolean;
var i,j:integer;
begin
result :=true;
for i:=0to 12do for j:=1to 4do result:= result and used[i,j];
end;
function drawcard:tplayingcard;
label newcard;
begin
result.flags:=card_error;
if allused then exit;
newcard:
result.suit:=Random(4)+1;
result.face:=random(13);
if used[result.face,result.suit] then goto newcard;
used[result.face,result.suit]:=true;
result.flags:=card_exists;
end;

procedure playermoveenable;
var p:pointer;
c:tplayingcard;
begin
garbagegame.Image13.Enabled:=false;
garbagegame.Image14.Enabled:=false;
garbagegame.Image15.Enabled:=false;
garbagegame.Image16.Enabled:=false;
garbagegame.Image17.Enabled:=false;
garbagegame.Image18.Enabled:=false;
garbagegame.Image19.Enabled:=false;
garbagegame.Image20.Enabled:=false;
garbagegame.Image21.Enabled:=false;
garbagegame.Image22.Enabled:=false;
p:=discard.Last;
copymemory(@c,@p,4);
if(c.face<10)then
if((1+c.face)>playerpos)and(c.face<12)then exit;
if(c.face<10)then
if playercards[c.face+1].flags and card_flipped>0then exit;
case c.face of
0:garbagegame.Image13.Enabled:=true;
1:garbagegame.Image14.Enabled:=true;
2:garbagegame.Image15.Enabled:=true;
3:garbagegame.Image16.Enabled:=true;
4:garbagegame.Image17.Enabled:=true;
5:garbagegame.Image18.Enabled:=true;
6:garbagegame.Image19.Enabled:=true;
7:garbagegame.Image20.Enabled:=true;
8:garbagegame.Image21.Enabled:=true;
9:garbagegame.Image22.Enabled:=true;
end;
if(kingswild=1)and(c.face=12)then begin
garbagegame.Image13.Enabled:=(playercards[1].flags and card_flipped=0);
garbagegame.Image14.Enabled:=(playercards[2].flags and card_flipped=0);
garbagegame.Image15.Enabled:=(playercards[3].flags and card_flipped=0);
garbagegame.Image16.Enabled:=(playercards[4].flags and card_flipped=0);
garbagegame.Image17.Enabled:=(playercards[5].flags and card_flipped=0);
garbagegame.Image18.Enabled:=(playercards[6].flags and card_flipped=0);
garbagegame.Image19.Enabled:=(playercards[7].flags and card_flipped=0);
garbagegame.Image20.Enabled:=(playercards[8].flags and card_flipped=0);
garbagegame.Image21.Enabled:=(playercards[9].flags and card_flipped=0);
garbagegame.Image22.Enabled:=(playercards[10].flags and card_flipped=0);
end;
end;

procedure AddCardToListBox(car:pointer;typ:integer;nturns:pbyte);
var c:tplayingcard;
p:pointer;
rwave:array[0..8]of char;
begin
p:=car;
copymemory(@C,@p,4);
if nturns<>nil then nturns^:=nturns^+1;
case typ of
0:garbagegame.ListBox1.Items.insert(0,format('You drawn an %s of %s.',[faces[c.face],
suits[c.suit]]));
1:begin garbagegame.ListBox1.Items.insert(0,format('You flipped over an %s of %s.',
[faces[c.face],suits[c.suit]]));if nturns=nil then playsound('DING',hinstance,
snd_Resource or SND_SYNC)else if nturns^>3 then playsound(strfmt(rwave,'GOOD%d',
[random(3)]),hinstance,snd_Resource or SND_SYNC)else playsound('DING',hinstance,
snd_Resource or SND_SYNC);end;
2:garbagegame.ListBox1.Items.insert(0,format('Computer has drawn an %s of %s.',[
faces[c.face],suits[c.suit]]));
3:Begin garbagegame.ListBox1.Items.insert(0,format(
'Computer has flipped over an %s of %s.',[faces[c.face],suits[c.suit]]));
if nturns=nil then playsound('DING',hinstance,snd_Resource or SND_SYNC)else if
nturns^>3 then playsound(strfmt(rwave,'GOOD%d',[random(3)]),hinstance,
snd_Resource or SND_SYNC)else playsound('DING',hinstance,snd_Resource or SND_SYNC);end;
end;
end;

procedure NewGame;
var i:integer;
begin
candraw:=true;
discard.clear;
Garbagegame.StatusBar1.Panels[1].text:=format('%d/%d',[playerpos,computerpos]);
for i:=2 to 3do
garbagegame.StatusBar1.Panels[i].text:='0';
inc(gamenum);
garbagegame.StatusBar1.Panels[0].text:=format('Game %d',[gamenum]);
zeromemory(@used,sizeof(used));
zeromemory(@playercards,sizeof(playercards));
zeromemory(@computercards,sizeof(computercards));
for i:=1to playerpos do playercards[i]:=drawcard;
for i:=1to computerpos do computercards[i]:= drawcard;
if allused then reshuffle;
discard.Add(pointer(drawcard));
addcardtolistbox(discard.Last,0,nil);
garbagegame.Image11.Enabled:=false;
playermoveenable;
garbagegame.Button1.visible:=true;
end;

function pccard(i,j:integer):pchar;
begin
result:=stralloc(8);
strfmt(result,'CARD%d%x',[j,i]);
end;

function pcback(index:integer):pchar;
begin
result:=stralloc(8);
strfmt(result,'BACK%d',[index]);
end;

procedure updatecards;
var p:pointer;
c:tplayingcard;
i,j:integer;
pc:pchar;
nocard:tbitmap;
begin
candraw:=not allused;
with garbagegame do begin
image1.Transparent:=(computercards[1].flags and card_dead=card_dead);
image2.Transparent:=(computercards[2].flags and card_dead=card_dead);
image3.Transparent:=(computercards[3].flags and card_dead=card_dead);
image4.Transparent:=(computercards[4].flags and card_dead=card_dead);
image5.Transparent:=(computercards[5].flags and card_dead=card_dead);
image6.Transparent:=(computercards[6].flags and card_dead=card_dead);
image7.Transparent:=(computercards[7].flags and card_dead=card_dead);
image8.Transparent:=(computercards[8].flags and card_dead=card_dead);
image9.Transparent:=(computercards[9].flags and card_dead=card_dead);
image10.Transparent:=(computercards[10].flags and card_dead=card_dead);
image13.Transparent:=(playercards[1].flags and card_dead=card_dead);
image14.Transparent:=(playercards[2].flags and card_dead=card_dead);
image15.Transparent:=(playercards[3].flags and card_dead=card_dead);
image16.Transparent:=(playercards[4].flags and card_dead=card_dead);
image17.Transparent:=(playercards[5].flags and card_dead=card_dead);
image18.Transparent:=(playercards[6].flags and card_dead=card_dead);
image19.Transparent:=(playercards[7].flags and card_dead=card_dead);
image20.Transparent:=(playercards[8].flags and card_dead=card_dead);
image21.Transparent:=(playercards[9].flags and card_dead=card_dead);
image22.Transparent:=(playercards[10].flags and card_dead=card_dead);

end;
for i:=0to 2do begin deleteobject(emptyslots[i]);pc:=pccard(i,0);emptyslots[i]:=loadbitmap(hdeck,pc);
strdispose(pc);end;
for i:=0to 11 do begin deleteobject(hbacks[i]);pc:=pcback(i);hbacks[i]:=loadbitmap(hdeck,pc);
strdispose(pc);end;
for i:=0 to 12do for j:=1to 4do begin deleteobject(deck_pics[i,j]);pc:=pccard(i,j);deck_pics[i,j]:=
loadbitmap(hdeck,pc);strdispose(pc);end;
if computercards[1].flags and card_flipped=0then
garbagegame.image1.picture.bitmap.handle:= hbacks[back] else
garbagegame.image1.picture.bitmap.handle:= deck_pics[computercards[1].face,
computercards[1].suit];
if computercards[2].flags and card_flipped=0then
garbagegame.image2.picture.bitmap.handle:= hbacks[back] else
garbagegame.image2.picture.bitmap.handle:= deck_pics[computercards[2].face,
computercards[2].suit];
if computercards[3].flags and card_flipped=0then
garbagegame.image3.picture.bitmap.handle:= hbacks[back] else
garbagegame.image3.picture.bitmap.handle:= deck_pics[computercards[3].face,
computercards[3].suit];
if computercards[4].flags and card_flipped=0then
garbagegame.image4.picture.bitmap.handle:= hbacks[back] else
garbagegame.image4.picture.bitmap.handle:= deck_pics[computercards[4].face,
computercards[4].suit];
if computercards[5].flags and card_flipped=0then
garbagegame.image5.picture.bitmap.handle:= hbacks[back] else
garbagegame.image5.picture.bitmap.handle:= deck_pics[computercards[5].face,
computercards[5].suit];
if computercards[6].flags and card_flipped=0then
garbagegame.image6.picture.bitmap.handle:= hbacks[back] else
garbagegame.image6.picture.bitmap.handle:= deck_pics[computercards[6].face,
computercards[6].suit];
if computercards[7].flags and card_flipped=0then
garbagegame.image7.picture.bitmap.handle:= hbacks[back] else
garbagegame.image7.picture.bitmap.handle:= deck_pics[computercards[7].face,
computercards[7].suit];
if computercards[8].flags and card_flipped=0then
garbagegame.image8.picture.bitmap.handle:= hbacks[back] else
garbagegame.image8.picture.bitmap.handle:= deck_pics[computercards[8].face,
computercards[8].suit];
if computercards[9].flags and card_flipped=0then
garbagegame.image9.picture.bitmap.handle:= hbacks[back] else
garbagegame.image9.picture.bitmap.handle:= deck_pics[computercards[9].face,
computercards[9].suit];
if computercards[10].flags and card_flipped=0then
garbagegame.image10.picture.bitmap.handle:= hbacks[back] else
garbagegame.image10.picture.bitmap.handle:= deck_pics[computercards[10].face,
computercards[10].suit];
if discard.Count=0 then garbagegame.Image12.Picture.Bitmap.Handle:=emptyslots[0]
else begin p:=discard.Last;Copymemory(@c,@p,4);
garbagegame.Image12.Picture.Bitmap.handle:=deck_pics[c.face,c.suit];
end;
if playercards[1].flags and card_flipped=0then
garbagegame.image13.picture.bitmap.handle:= hbacks[back] else
garbagegame.image13.picture.bitmap.handle:= deck_pics[playercards[1].face,
playercards[1].suit];
if playercards[2].flags and card_flipped=0then
garbagegame.image14.picture.bitmap.handle:= hbacks[back] else
garbagegame.image14.picture.bitmap.handle:= deck_pics[playercards[2].face,
playercards[2].suit];
if playercards[3].flags and card_flipped=0then
garbagegame.image15.picture.bitmap.handle:= hbacks[back] else
garbagegame.image15.picture.bitmap.handle:= deck_pics[playercards[3].face,
playercards[3].suit];
if playercards[4].flags and card_flipped=0then
garbagegame.image16.picture.bitmap.handle:= hbacks[back] else
garbagegame.image16.picture.bitmap.handle:= deck_pics[playercards[4].face,
playercards[4].suit];
if playercards[5].flags and card_flipped=0then
garbagegame.image17.picture.bitmap.handle:= hbacks[back] else
garbagegame.image17.picture.bitmap.handle:= deck_pics[playercards[5].face,
playercards[5].suit];
if playercards[6].flags and card_flipped=0then
garbagegame.image18.picture.bitmap.handle:= hbacks[back] else
garbagegame.image18.picture.bitmap.handle:= deck_pics[playercards[6].face,
playercards[6].suit];
if playercards[7].flags and card_flipped=0then
garbagegame.image19.picture.bitmap.handle:= hbacks[back] else
garbagegame.image19.picture.bitmap.handle:= deck_pics[playercards[7].face,
playercards[7].suit];
if playercards[8].flags and card_flipped=0then
garbagegame.image20.Picture.bitmap.handle:= hbacks[back] else
garbagegame.image20.picture.bitmap.handle:= deck_pics[playercards[8].face,
playercards[8].suit];
if playercards[9].flags and card_flipped=0then
garbagegame.image21.picture.bitmap.handle:= hbacks[back] else
garbagegame.image21.picture.bitmap.handle:= deck_pics[playercards[9].face,
playercards[9].suit];
if playercards[10].flags and card_flipped=0then
garbagegame.image22.picture.bitmap.handle:= hbacks[back] else
garbagegame.image22.picture.bitmap.handle:= deck_pics[playercards[10].face,
playercards[10].suit];
if allused then garbagegame.Image11.Picture.Bitmap.Handle:=emptyslots[2]
else garbagegame.Image11.Picture.Bitmap.handle:=hbacks[back];
end;


function computerthread(dummy:pointer):dword;stdcall;
var p:pointer;
c,cd:tplayingcard;
drawused:boolean;
i,kingpos:integer;
label draw,discard0,endturn,ktry;
begin
inc(whoseturn);
cturn:=0;
pturn:=0;
garbagegame.Button1.Visible:=false;
drawused:=false;
discard0:
p:=discard.Last;
copymemory(@c,@p,4);
if(c.face=12)and(kingswild=1)then begin
ktry:kingpos:=random(computerpos)+1;
if(computercards[kingpos].flags and card_flipped>0)then goto ktry;
i:=strtoint(garbagegame.statusbar1.panels[3].text)+1;
garbagegame.StatusBar1.Panels[3].text:=inttostr(i);
discard[discard.Count-1]:=pointer(computercards[kingpos]);
c.flags:=c.flags or card_flipped;
computercards[kingpos]:=c;
addcardtolistbox(discard.last,3,@cturn);
drawused:=true;
updatecards;
if i=computerpos then begin endround;exit;end;
goto discard0;
end;
if c.face+1>computerpos then goto draw;
if computercards[c.face+1].flags and card_flipped>0then goto draw;
i:=strtoint(garbagegame.statusbar1.panels[3].text)+1;
garbagegame.StatusBar1.Panels[3].text:=inttostr(i);
discard[discard.Count-1]:=pointer(computercards[c.face+1]);
c.flags:=c.flags or card_flipped;
computercards[c.face+1]:=c;
addcardtolistbox(discard.last,3,@cturn);
drawused:=true;
updatecards;
if i=computerpos then begin endround;exit;end;
goto discard0;
draw:
sleep(1000);
if drawused then goto endturn;
drawused:=true;
if allused then reshuffle;
discard.Add(pointer(drawcard));
addcardtolistbox(discard.last,2,nil);
goto discard0;
endturn:garbagegame.Button1.Visible:=true;
updatecards;
playermoveenable;
garbagegame.Image11.Enabled:=true;
end;

procedure Tgarbagegame.FormCreate(Sender: TObject);
var i,j:integer;
pc:pchar;
hk:hkey;
tid,rs:dword;
deckdll:array[0..max_path]of char;
begin
randomize;
candraw:=true;
discard:=tlist.Create;
regcreatekey(hkey_current_User,'Software\Justin\Garbage',hk);
if regqueryvalueex(hk,'DeckDLL',nil,nil,@deckdll,@rs)=error_success then
hdeck:=loadlibrary(deckdll)else hdeck:=hinstance;cardback;
rs:=4;
regqueryvalueex(hk,'KingsWild',nil,nil,@kingswild,@rs);
kingsarewild1.checked:=(kingswild=1);
playerpos:=strtointdef(paramstr(1),10);
computerpos:=strtointdef(paramstr(2),10);
gamenum:=strtointdef(paramstr(3),0);
regclosekey(hk);
whoseturn:=strtointdef(paramstr(4),0);
image1.Visible:=true;
image2.Visible:=(computerpos>1);
image3.Visible:=(computerpos>2);
image4.Visible:=(computerpos>3);
image5.Visible:=(computerpos>4);
image6.Visible:=(computerpos>5);
image7.Visible:=(computerpos>6);
image8.Visible:=(computerpos>7);
image9.Visible:=(computerpos>8);
image10.Visible:=(computerpos>9);
image13.Visible:=true;
image14.Visible:=(playerpos>1);
image15.Visible:=(playerpos>2);
image16.Visible:=(playerpos>3);
image17.Visible:=(playerpos>4);
image18.Visible:=(playerpos>5);
image19.Visible:=(playerpos>6);
image20.Visible:=(playerpos>7);
image21.Visible:=(playerpos>8);
image22.Visible:=(playerpos>9);
pturn:=0;
 newgame;
updatecards;

end;

procedure Tgarbagegame.ChangeBack1Click(Sender: TObject);
begin
changebackwnd.Visible:=true;
changebackwnd.BringToFront;
visible:=false;
end;

procedure Tgarbagegame.Button1Click(Sender: TObject);
var tid:dword;
begin
createthread(nil,0,@computerthread,nil,0,tid);
end;

procedure Tgarbagegame.Image13Click(Sender: TObject);
var p:pointer;
c,cd:tplayingcard;
i:integer;
begin
inc(whoseturn);
p:=discard.Last;
copymemory(@c,@p,4);
if kingswild=0 then
if TImage(sender).tag<>c.face then exit;
cd:=playercards[TImage(sender).tag+1];
discard[discard.Count-1]:=pointer(cd);
addcardtolistbox(discard.last,1,@pturn);
playercards[timage(sender).tag+1]:=c;
playercards[timage(sender).tag+1].flags:=c.flags or card_flipped;
playermoveenable;
garbagegame.Image11.Enabled:=false;
updatecards;
i:=strtoint(statusbar1.panels[2].text)+1;
statusbar1.Panels[2].text:=inttostr(i);
if i=playerpos then begin endround;exit;end;
end;
procedure Tgarbagegame.Image11Click(Sender: TObject);
begin
if allused then reshuffle;
discard.add(pointer(drawcard));
addcardtolistbox(discard.last,0,nil);
updatecards;
image11.Enabled:=false;
playermoveenable;
end;

procedure Tgarbagegame.AboutGarbage1Click(Sender: TObject);
var aboutt:array[0..1024]of char;
begin
messagebox(handle,strfmt(aboutt,
'Garbage v%d.%d by Justin Roeder.'#13#10'Special thanks goes to Camp CILCA'#13#10'Website: https://delphijustin.biz',[
hibyte(version),lobyte(version)]),'About Garbage',0);
end;

procedure Tgarbagegame.ListBox1DblClick(Sender: TObject);
begin
messagebox(handle,PChar(Listbox1.items[listbox1.itemindex]),'Garbage',0);
end;

procedure Tgarbagegame.Rules1Click(Sender: TObject);
begin
shellexecute(handle,nil,'http://www.gathertogethergames.com/garbage',nil,nil,
sw_show);
end;

procedure Tgarbagegame.KingsAreWild1Click(Sender: TObject);
var hk:hkey;
begin
kingsarewild1.Checked:=not kingsarewild1.Checked;
if kingsarewild1.Checked then kingswild:=1 else kingswild:=0;
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regsetvalueex(hk,'KingsWild',0,reg_dword,@kingswild,4);
regclosekey(hk);
end;

end.

unit garbage2;
//Change CardDeck Unit
interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ExtDlgs,Shellapi;

type
  Tchangebackwnd = class(TForm)
    ScrollBar1: TScrollBar;
    Button1: TButton;
    Button2: TButton;
    CheckBox1: TCheckBox;
    Button3: TButton;
    Button4: TButton;
    OpenDialog1: TOpenDialog;
    Button5: TButton;
    procedure Button1Click(Sender: TObject);
    procedure ScrollBar1Change(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button4Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  changebackwnd: Tchangebackwnd;

implementation

{$R *.DFM}
uses garbage1;

procedure Tchangebackwnd.Button1Click(Sender: TObject);
var hk:hkey;
ba:dword;
begin
regcreatekey(hkey_current_user,'software\Justin\Garbage',hk);
if checkbox1.checked then ba:=255 else ba:=scrollbar1.Position;
Regsetvalueex(hk,'CardBack',0,reg_dword,@ba,4);
regclosekey(hk);
if ba=255then back:=random(12)else back:=ba;
updatecards;
close;
end;

procedure Tchangebackwnd.ScrollBar1Change(Sender: TObject);
begin
formpaint(nil);
end;

procedure Tchangebackwnd.Button2Click(Sender: TObject);
begin
close;
end;

procedure Tchangebackwnd.FormPaint(Sender: TObject);
var bmp:tbitmap;
backst:array[0..8]of char;
begin
bmp:=tbitmap.Create;
bmp.Handle:=loadbitmap(hdeck,strfmt(backst,'BACK%d',[scrollbar1.position]));
canvas.Draw(0,0,bmp);
bmp.FreeImage;
bmp.Free;
end;

procedure Tchangebackwnd.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
garbagegame.Visible:=true;
end;

procedure Tchangebackwnd.Button4Click(Sender: TObject);
var hk:hkey;
begin
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regdeletevalue(hk,'DeckDLL');
Regdeletevalue(hk,'CardBack');
regclosekey(hk);
end;

procedure Tchangebackwnd.Button3Click(Sender: TObject);
var hk:hkey;
hdec:hmodule;
buff:array[0..max_path]of char;
begin
if not opendialog1.Execute then exit;
hdec:=loadlibrary(pchar(opendialog1.filename));
if hdec=0 then begin messagebox(handle,pchar(syserrormessage(getlasterror)),
'delphijustin Card Deck',mb_iconerror);exit;end;
hdeck:=hdec;
regcreatekey(hkey_current_user,'Software\Justin\Garbage',hk);
regsetvalueex(hk,'DeckDLL',0,reg_sz,strpcopy(buff,opendialog1.filename),length(
opendialog1.filename)+1);
Regclosekey(hk);
repaint;
end;

procedure Tchangebackwnd.Button5Click(Sender: TObject);
begin
shellexecute(handle,nil,'https://delphijustin.biz/bin/carddecks/',nil,nil,sw_show);

end;

end.

NEW HTML Version is available

The post Garbage CardGame first appeared on Delphijustin industries.