Skip to content

Commit 85b7f46

Browse files
author
Sylvain Maltais
committed
Ajout du jeu SODOKU
1 parent 6450806 commit 85b7f46

File tree

1 file changed

+361
-0
lines changed

1 file changed

+361
-0
lines changed

‎SODOKU.PAS

+361
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,361 @@
1+
{ @author: Sylvain Maltais (support@gladir.com)
2+
@created: 2023
3+
@website(https://www.gladir.com/7iles)
4+
@abstract(Target: Turbo Pascal 7, Free Pascal 3.2)
5+
}
6+
7+
Program SODOKU;
8+
9+
Uses {$IFDEF FPC}
10+
Crt,PtcGraph,PtcCrt,PtcMouse
11+
{$ELSE}
12+
Crt,Graph
13+
{$ENDIF};
14+
15+
Const
16+
CaseWidth=40;
17+
GridX=(640-9*CaseWidth) shr 1;
18+
GridY=(480-9*CaseWidth) shr 1;
19+
20+
Var
21+
Win:Boolean;
22+
I,J:Integer;
23+
S:String;
24+
CursorX,CursorY:Integer;
25+
SolutionGrid:Array[1..9,1..9] of Integer;
26+
UserGrid:Array[1..9,1..9,1..2] of Integer;
27+
B:Char;
28+
29+
Function StrToUpper(S:String):String;
30+
Var
31+
I:Byte;
32+
Begin
33+
For I:=1 to Length(S)do Begin
34+
If S[I] in['a'..'z']Then S[I]:=Chr(Ord(S[I])-32);
35+
End;
36+
StrToUpper:=S;
37+
End;
38+
39+
Function Left(Const Str:String;Num:Byte):String;Begin
40+
Left:=Copy(Str,1,Num);
41+
End;
42+
43+
Procedure DelChrAt(Var S:String;P:Byte);Begin
44+
If P=1Then S:=Copy(S,2,255)
45+
Else S:=Left(S,P-1)+Copy(S,P+1,255)
46+
End;
47+
48+
Function VerticalFound(X,YMax,Number:Integer):Boolean;
49+
Var
50+
J:Integer;
51+
Begin
52+
VerticalFound:=False;
53+
For J:=1 to YMax do Begin
54+
If(SolutionGrid[J,X]=Number)Then Begin
55+
VerticalFound:=True;
56+
Exit;
57+
End;
58+
End;
59+
End;
60+
61+
Function FindZero:Boolean;
62+
Var
63+
I,J:Integer;
64+
Begin
65+
FindZero:=False;
66+
For J:=1 to 9 do For I:=1 to 9 do Begin
67+
If SolutionGrid[J,I]=0 Then Begin
68+
FindZero:=True;
69+
End;
70+
End;
71+
End;
72+
73+
Procedure InitScr;
74+
Var
75+
Driver,Mode:Integer;
76+
ErrCode:Integer;
77+
Begin
78+
{$IFDEF FPC}
79+
Driver:=VGA;
80+
Mode:=VGAHi;
81+
{$ELSE}
82+
Driver:=Detect;
83+
Mode:=VGAHi;
84+
{$ENDIF}
85+
InitGraph(Driver,Mode,'');
86+
ErrCode:=GraphResult;
87+
If ErrCode=grOk Then Begin
88+
SetColor(White);
89+
SetLineStyle(0,0,1);
90+
End
91+
Else
92+
Begin
93+
WriteLn('Erreur graphique : ',GraphErrorMsg(ErrCode));
94+
Halt;
95+
End;
96+
End;
97+
98+
Procedure DrawGrid;Begin
99+
For I:=0 to 9 do Begin
100+
If I in[0,3,6,9]Then SetLineStyle(0,$C3,3)
101+
Else SetLineStyle(0,$C3,1);
102+
Line(GridX,GridY+i*CaseWidth,GridX+9*CaseWidth,GridY+i*CaseWidth);
103+
Line(GridX+i*CaseWidth,GridY,GridX+i*CaseWidth,GridY+9*CaseWidth);
104+
End;
105+
SetTextStyle(0,0,0);
106+
End;
107+
108+
Procedure FindSolution;
109+
Var
110+
Base:String;
111+
I,J,K,L:Integer;
112+
R,P:Integer;
113+
Begin
114+
Randomize;
115+
For K:=1 to 5000 do Begin
116+
For J:=1 to 9 do Begin
117+
Base[0]:=#9;
118+
For I:=1 to 9 do Base[I]:=Chr(I);
119+
For I:=1 to 9 do Begin
120+
R:=Random(Length(Base))+1;
121+
If VerticalFound(I,J,Byte(Base[R]))Then Begin
122+
For L:=1 to Length(Base)do Begin
123+
If Not VerticalFound(I,J,Byte(Base[L]))Then Begin
124+
SolutionGrid[J,I]:=Byte(Base[L]);
125+
DelChrAt(Base,L);
126+
Break;
127+
End;
128+
End;
129+
End
130+
Else
131+
Begin
132+
SolutionGrid[J,I]:=Byte(Base[R]);
133+
DelChrAt(Base,R);
134+
End;
135+
End;
136+
End;
137+
If Not FindZero Then Break;
138+
End;
139+
End;
140+
141+
Procedure FindBegin;Begin
142+
UserGrid[1,2,1]:=SolutionGrid[1,2];
143+
UserGrid[1,2,2]:=1;
144+
UserGrid[1,4,1]:=SolutionGrid[1,4];
145+
UserGrid[1,4,2]:=1;
146+
UserGrid[1,5,1]:=SolutionGrid[1,5];
147+
UserGrid[1,5,2]:=1;
148+
UserGrid[1,6,1]:=SolutionGrid[1,6];
149+
UserGrid[1,6,2]:=1;
150+
UserGrid[1,7,1]:=SolutionGrid[1,7];
151+
UserGrid[1,7,2]:=1;
152+
UserGrid[2,2,1]:=SolutionGrid[2,2];
153+
UserGrid[2,2,2]:=1;
154+
UserGrid[2,6,1]:=SolutionGrid[2,6];
155+
UserGrid[2,6,2]:=1;
156+
UserGrid[2,9,1]:=SolutionGrid[2,9];
157+
UserGrid[2,9,2]:=1;
158+
UserGrid[3,5,1]:=SolutionGrid[3,5];
159+
UserGrid[3,5,2]:=1;
160+
UserGrid[3,7,1]:=SolutionGrid[3,7];
161+
UserGrid[3,7,2]:=1;
162+
UserGrid[3,9,1]:=SolutionGrid[3,9];
163+
UserGrid[3,9,2]:=1;
164+
UserGrid[4,1,1]:=SolutionGrid[4,1];
165+
UserGrid[4,1,2]:=1;
166+
UserGrid[4,3,1]:=SolutionGrid[4,3];
167+
UserGrid[4,3,2]:=1;
168+
UserGrid[4,6,1]:=SolutionGrid[4,6];
169+
UserGrid[4,6,2]:=1;
170+
UserGrid[4,7,1]:=SolutionGrid[4,7];
171+
UserGrid[4,7,2]:=1;
172+
UserGrid[4,8,1]:=SolutionGrid[4,8];
173+
UserGrid[4,8,2]:=1;
174+
UserGrid[5,2,1]:=SolutionGrid[5,2];
175+
UserGrid[5,2,2]:=1;
176+
UserGrid[5,4,1]:=SolutionGrid[5,4];
177+
UserGrid[5,4,2]:=1;
178+
UserGrid[5,6,1]:=SolutionGrid[5,6];
179+
UserGrid[5,6,2]:=1;
180+
UserGrid[5,8,1]:=SolutionGrid[5,8];
181+
UserGrid[5,8,2]:=1;
182+
UserGrid[6,2,1]:=SolutionGrid[6,2];
183+
UserGrid[6,2,2]:=1;
184+
UserGrid[6,3,1]:=SolutionGrid[6,3];
185+
UserGrid[6,3,2]:=1;
186+
UserGrid[6,4,1]:=SolutionGrid[6,4];
187+
UserGrid[6,4,2]:=1;
188+
UserGrid[6,7,1]:=SolutionGrid[6,7];
189+
UserGrid[6,7,2]:=1;
190+
UserGrid[6,9,1]:=SolutionGrid[6,9];
191+
UserGrid[6,9,2]:=1;
192+
UserGrid[7,1,1]:=SolutionGrid[7,1];
193+
UserGrid[7,1,2]:=1;
194+
UserGrid[7,3,1]:=SolutionGrid[7,3];
195+
UserGrid[7,3,2]:=1;
196+
UserGrid[7,5,1]:=SolutionGrid[7,5];
197+
UserGrid[7,5,2]:=1;
198+
UserGrid[8,1,1]:=SolutionGrid[8,1];
199+
UserGrid[8,1,2]:=1;
200+
UserGrid[8,4,1]:=SolutionGrid[8,4];
201+
UserGrid[8,4,2]:=1;
202+
UserGrid[8,8,1]:=SolutionGrid[8,8];
203+
UserGrid[8,8,2]:=1;
204+
UserGrid[9,3,1]:=SolutionGrid[9,3];
205+
UserGrid[9,3,2]:=1;
206+
UserGrid[9,4,1]:=SolutionGrid[9,4];
207+
UserGrid[9,4,2]:=1;
208+
UserGrid[9,5,1]:=SolutionGrid[9,5];
209+
UserGrid[9,5,2]:=1;
210+
UserGrid[9,6,1]:=SolutionGrid[9,6];
211+
UserGrid[9,6,2]:=1;
212+
UserGrid[9,8,1]:=SolutionGrid[9,8];
213+
UserGrid[9,8,2]:=1;
214+
End;
215+
216+
Procedure WriteUserGrid;Begin
217+
SetTextJustify(CenterText,CenterText);
218+
SetTextStyle(1,HorizDir,3);
219+
For i:=1 to 9 do For j:=1 to 9 do If UserGrid[i,j,1]<>0 Then Begin
220+
Str(UserGrid[i,j,1],S);
221+
SetColor(Black);
222+
OutTextXY(GridX+CaseWidth*(2*i-1) div 2,GridY+CaseWidth*(2*j-1) div 2,Chr(219));
223+
If UserGrid[i,j,2]=1 Then SetColor(Yellow)
224+
Else SetColor(White);
225+
OutTextXY(GridX+CaseWidth*(2*i-1) div 2,GridY+CaseWidth*(2*j-1) div 2,S);
226+
End
227+
Else
228+
Begin
229+
SetColor(Black);
230+
OutTextXY(GridX+CaseWidth*(2*i-1) div 2-1,GridY+CaseWidth*(2*j-1) div 2,Chr(219));
231+
End;
232+
SetTextJustify(LeftText,BottomText);
233+
SetTextStyle(0,0,0);
234+
End;
235+
236+
Function Instruction:Boolean;Begin
237+
Instruction:=False;
238+
ClearDevice;
239+
SetColor(White);
240+
outtextxy(20,20,'1. Le jeu Sodoku un gros carr‚ divis‚ en 9 carr‚s.');
241+
outtextxy(20,40,' et dans ses 9 carr‚s, il contiennent 9 cases compos‚es de 3 lignes et 3 colonnes.');
242+
outtextxy(20,60,'2. Sur chaque ligne vous devez placer les chiffres de 1 … 9 sans les r‚p‚ter.');
243+
outtextxy(20,80,'3. Sur chaque colonne vous devez placer les chiffres de 1 … 9 sans les r‚p‚ter.');
244+
outtextxy(20,120,'4. Dans chaque r‚gion de 9 cases, vous devez placer les chiffres de 1 … 9');
245+
outtextxy(20,140,' sans les r‚p‚ter.');
246+
outtextxy(20,160,'5. Un truc tres pratique est d''eliminer les cases ou votre chiffre...');
247+
outtextxy(20,180,' ne peut se trouver.');
248+
outtextxy(20,200,'6. Pour gagner du temps vous pouvez commencer par les chiffres les plus nombreux');
249+
outtextxy(20,220,'7. Attention a ce que vos chiffres ne se repetent pas dans une meme ligne.');
250+
outtextxy(20,240,' ni dans un mˆme carr‚');
251+
outtextxy(20,260,'8. Les nombres ecrits en jaune sont ceux que l''ordinateur vous donne');
252+
outtextxy(20,280,'9. Vous ne pouvez pas ‚crire par dessus les chiffres jaunes.');
253+
outtextxy(20,300,'10. Pour ‚crire un chiffre, d‚placez le curseur a l''aide des 4 flŠches.');
254+
outtextxy(20,320,' et appuyer sur un nombre');
255+
outtextxy(20,340,'11. Si vous voulez effacer un nombre que vous avez inscrit (pas ceux en jaune).');
256+
outtextxy(20,360,' vous devez appuyer sur la touche E pour effacer votre valeur');
257+
outtextxy(20,380,'12. Pour quitter le jeu appuyer sur la touche <Q>');
258+
outtextxy(250,400,'amusez-vous! en appuyant sur <2> maintenant');
259+
outtextxy(20,440,' Pour revenir au menu appuyez sur la touche <Enter>');
260+
If ReadKey='2'Then Instruction:=True;
261+
End;
262+
263+
Procedure Play;
264+
Var
265+
Key:Char;
266+
Begin
267+
FillChar(UserGrid,SizeOf(UserGrid),0);
268+
FillChar(SolutionGrid,SizeOf(SolutionGrid),0);
269+
ClearDevice;
270+
OutTextXY(20,20,'Q=Quitter');
271+
OutTextXY(20,40,'E=Effacer');
272+
OutTextXY(20,60,'S=Solution');
273+
DrawGrid;
274+
FindSolution;
275+
FindBegin;
276+
WriteUserGrid;
277+
CursorX:=1;
278+
CursorY:=1;
279+
Repeat
280+
SetColor(White);
281+
Line(GridX+(CaseWidth shr 2)+CaseWidth*(CursorX-1),GridY+CaseWidth*CursorY-3,
282+
GridX+3*CaseWidth div 4+CaseWidth*(CursorX-1),GridY+CaseWidth*CursorY-3);
283+
Key:=ReadKey;
284+
SetColor(black);
285+
Line(GridX+CaseWidth div 4+CaseWidth*(CursorX-1),GridY+CaseWidth*CursorY-3,
286+
GridX+3*CaseWidth div 4+CaseWidth*(CursorX-1),GridY+CaseWidth*CursorY-3);
287+
Case UpCase(Key) of
288+
#75:if CursorX>1 Then Dec(CursorX);
289+
#77:if CursorX<9 Then Inc(CursorX);
290+
#72:if CursorY>1 Then dec(CursorY);
291+
#80:if CursorY<9 Then inc(CursorY);
292+
'E':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=0;
293+
'1':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=1;
294+
'2':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=2;
295+
'3':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=3;
296+
'4':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=4;
297+
'5':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=5;
298+
'6':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=6;
299+
'7':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=7;
300+
'8':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=8;
301+
'9':if UserGrid[CursorX,CursorY,2]<>1 Then UserGrid[CursorX,CursorY,1]:=9;
302+
'S':Begin
303+
For i:=1 to 9 do For j:=1 to 9 do Begin
304+
UserGrid[i,j,1]:=SolutionGrid[i,j];
305+
End;
306+
WriteUserGrid;
307+
If ReadKey=#0 Then ReadKey;
308+
End;
309+
End;
310+
WriteUserGrid;
311+
Win:=True;
312+
For i:=1 to 9 do For j:=1 to 9 do If UserGrid[i,j,1]<>SolutionGrid[i,j]Then Win:=False;
313+
If(Win)Then Begin
314+
ClearDevice;
315+
SetColor(White);
316+
SetLineStyle(0,0,0);
317+
OutTextXY(5,200,'F‚licitations, vous avez r‚ussie !');
318+
If ReadKey=#0 Then ReadKey;
319+
Key:=#27;
320+
End;
321+
Until UpCase(Key) in[#27,'Q','X'];
322+
End;
323+
324+
BEGIN
325+
{$IFDEF FPC}
326+
{$IFDEF WINDOWS}
327+
SetUseACP(False);
328+
{$ENDIF}
329+
{$ENDIF}
330+
If(ParamStr(1)='/?')or(ParamStr(1)='--help')or(ParamStr(1)='-h')or
331+
(ParamStr(1)='/h')or(ParamStr(1)='/H')Then Begin
332+
WriteLn('SODOKU : Cette commande permet de lancer le jeu SODOKU.');
333+
WriteLn;
334+
WriteLn('Syntaxe : SODOKU [/PLAY]');
335+
WriteLn;
336+
WriteLn(' /PLAY Permet de jouer imm‚diatement');
337+
WriteLn;
338+
End
339+
Else
340+
Begin
341+
InitScr;
342+
If StrToUpper(ParamStr(1))='/PLAY'Then Play Else
343+
Repeat
344+
ClearDevice;
345+
ClearViewPort;
346+
SetColor(Blue);
347+
SetTextStyle(0,0,11);
348+
OutTextXY(100,20,'Sudoku');
349+
SetColor(White);
350+
SetTextStyle(0,0,0);
351+
OutTextXY(150,300,'1 - Consulter les instructions');
352+
OutTextXY(150,315,'2 - Jouer au jeu Sudoku');
353+
OutTextXY(150,330,'X - Quitter');
354+
B:=UpCase(ReadKey);
355+
Case B of
356+
'1':If(Instruction)Then Play;
357+
'2':Play;
358+
End;
359+
Until B in[#27,'Q','X'];
360+
End;
361+
END.

0 commit comments

Comments
 (0)