fork download
copy 
  1. {this program site did not run the whole peg solitare of me http://e...content-available-to-author-only...a.org/wiki/Peg_solitaire becauuse of time 
  2. limit exceed therefore i used a small o shaped structure like this
  3. 	           .   .   .           
  4.                    *   *   *
  5.            .   *   *   .   *   *   .  
  6.            .   *   .   .   .   *   . 
  7.            .   *   *   .   *   *   .
  8.                    *   *   *         
  9.                    .   .   .   }
  10.                    {here '.' dots represets make moves and '*' represents which is to nove rest you lrn from wikipedia}
  11.   {also if want to add full solitare then you can run on free pascal compiler download "geany" and run this code by editing it}
  12.   			{all coments are requested to gauravalgo@gmail.com}
  13.  
  14.   			{how to see please see the resuts from bottom of the page to top }
  15.   			{beacuse of its recursive nature i am configuring it for new version}
  16.   			{enjoy the play at facebook!! :) }
  17. program io;
  18.  
  19. {$APPTYPE CONSOLE}
  20. {$ExtendedSyntax On}
  21.  
  22. uses
  23.   SysUtils;
  24.  
  25. { TODO -oUser -cConsole Main : Insert code here }
  26.  
  27.   {dedining dynamic array of characters}
  28.   type
  29.  
  30.     pegboard = Array[1..7,1..7]of Char;
  31.  
  32.     var
  33.     global:Array[1..100,1..3] of Integer;
  34.     type
  35.     moves = Array[1..4,1..2]of integer;
  36.     var
  37.     m : moves =((-2,0),
  38.                 (0,+2),
  39.                 (+2,0),
  40.                 (0,-2));
  41. procedure place (row,col,dir:integer;var tempboard:pegboard);
  42. begin
  43. 	if dir=1 then
  44. 	begin
  45. 		tempboard[row,col]:='.';
  46. 		tempboard[row+m[1,1]+1,col+m[1,2]]:='.';
  47. 		tempboard[row+m[1,1],col+m[1,2]]:='*';
  48.  
  49. 	end;
  50. 	if dir=2 then
  51. 	begin
  52. 		tempboard[row,col]:='.';
  53. 		tempboard[row+m[2,1],col+m[2,2]-1]:='.';
  54. 		tempboard[row+m[2,1],col+m[2,2]]:='*';
  55.  
  56. 	end;
  57. 	if dir=3 then
  58. 	begin
  59. 		tempboard[row,col]:='.';
  60. 		tempboard[row+m[3,1]-1,col+m[3,2]]:='.';
  61. 		tempboard[row+m[3,1],col+m[3,2]]:='*';
  62.  
  63. 	end;
  64. 	if dir=4 then
  65. 	begin
  66. 		tempboard[row,col]:='.';
  67. 		tempboard[row+m[4,1],col+m[4,2]+1]:='.';
  68. 		tempboard[row+m[4,1],col+m[4,2]]:='*';
  69.  
  70. 	end;
  71. end;
  72. procedure unplace (row,col,dir:integer;var tempboard:pegboard);
  73. begin
  74. 	if dir=1 then
  75. 	begin
  76. 		tempboard[row,col]:='*';
  77. 		tempboard[row+m[1,1]+1,col+m[1,2]]:='*';
  78. 		tempboard[row+m[1,1],col+m[1,2]]:='.';
  79.  
  80. 	end;
  81. 	if dir=2 then
  82. 	begin
  83. 		tempboard[row,col]:='*';
  84. 		tempboard[row+m[2,1],col+m[2,2]-1]:='*';
  85. 		tempboard[row+m[2,1],col+m[2,2]]:='.';
  86.  
  87. 	end;
  88. 	if dir=3 then
  89. 	begin
  90. 		tempboard[row,col]:='*';
  91. 		tempboard[row+m[3,1]-1,col+m[3,2]]:='*';
  92. 		tempboard[row+m[3,1],col+m[3,2]]:='.';
  93.  
  94. 	end;
  95. 	if dir=4 then
  96. 	begin
  97. 		tempboard[row,col]:='*';
  98. 		tempboard[row+m[4,1],col+m[4,2]+1]:='*';
  99. 		tempboard[row+m[4,1],col+m[4,2]]:='.';
  100.  
  101. 	end;
  102. end;
  103.  function count (tempboard : pegboard):integer;
  104.  var
  105.  i,j : integer;
  106.  counter:integer;
  107.  begin
  108.  counter:=0;
  109.   for i:=1 to 7 do
  110.       begin
  111.         for j:=1 to 7 do
  112.         begin
  113.           if tempboard[i,j]='*' then
  114.           begin
  115. 			inc(counter);
  116.           end;
  117.         end;
  118.       end;
  119.       count:=counter;
  120.  end;
  121.  
  122. procedure show (tempboard : pegboard);
  123.  var
  124.  i,j : integer;
  125.  begin
  126.   for i:=1 to 7 do
  127.       begin
  128.         for j:=1 to 7 do
  129.         begin
  130.           Write(tempboard[i,j],' ');
  131.         end;
  132.         Writeln;
  133.       end;
  134.  end;
  135. function testValid(temppegboard: pegboard):integer;
  136.  var
  137.  f,k:integer;
  138.   row1,col1,i,j:integer;
  139.  
  140.   begin
  141.        f:=0;
  142.        for i:=1 to 7 do
  143.       begin
  144.         for j:=1 to 7 do
  145.         begin
  146.           if temppegboard[i,j]='*' then
  147.           begin
  148.              row1:= i;
  149.              col1:= j;
  150.              for k:=1 to 4 do
  151.              begin
  152.               row1:=row1+m[k,1];
  153.               col1:=col1+m[k,2];
  154.              if((row1>0) and (col1 >0) and (row1<8) and (col1<8)) then
  155.              begin 
  156.  
  157. 					  if ((k=1) and (temppegboard[row1+1,col1]='*') and (temppegboard[row1,col1]='.')) then
  158. 					  begin
  159. 						 global[f+1,1]:=i;
  160. 						 global[f+1,2]:=j;
  161. 						 global[f+1,3]:=1;
  162. 						 Inc(f);
  163. 					  end;
  164.  
  165. 					  if((k=2) and (temppegboard[row1,col1-1]='*') and (temppegboard[row1,col1]='.'))  then
  166. 					  begin
  167. 						  global[f+1,1]:=i;
  168. 						  global[f+1,2]:=j;
  169. 						  global[f+1,3]:=2;
  170. 						  Inc(f);
  171. 					  end;
  172.  
  173. 					  if((k=3) and (temppegboard[row1-1,col1]='*') and (temppegboard[row1,col1]='.'))   then
  174. 					  begin
  175. 						  global[f+1,1]:=i;
  176. 						  global[f+1,2]:=j;
  177. 						  global[f+1,3]:=3;
  178. 						  Inc(f);
  179. 					  end;
  180.  
  181. 					  if((k=4) and (temppegboard[row1,col1+1]='*') and (temppegboard[row1,col1]='.'))   then
  182. 					  begin
  183. 							global[f+1,1]:=i;
  184. 							global[f+1,2]:=j;
  185. 							global[f+1,3]:=4;
  186. 							Inc(f);
  187. 					  end;
  188. 				end;
  189. 				row1:=i;
  190. 				col1:=j;
  191.              end;
  192.  
  193.           end;
  194.  
  195.         end;
  196.       end;
  197.       testValid:=f;
  198.   end;
  199.  
  200.  
  201.   function pegsolver(row,col,dir:integer;tempboard:pegboard):integer;
  202.   var
  203.   counter,i,r:integer;
  204.   begin
  205. 	counter := testValid(tempboard);
  206. 	i:=1;
  207.  
  208. 	while i<=counter do
  209. 		begin
  210.  
  211. 			row:=global[i,1];
  212. 			col:=global[i,2];
  213. 			dir:=global[i,3];
  214.  
  215. 			place(row,col,dir,tempboard);
  216. 			if count(tempboard) = 1 then
  217. 			begin
  218.       writeln('row1= ',row,' col1= ',col);
  219.       show(tempboard);
  220.       writeln;
  221. 			pegsolver:=1 ;
  222.       exit;
  223. 			end;
  224. 				r:=pegsolver(row,col,dir,tempboard);
  225. 				if r=1 then
  226. 				begin
  227.          writeln('row1= ',row,' col1= ',col);
  228.         show(tempboard);
  229.         writeln;
  230. 				pegsolver:=1;
  231.  
  232.  
  233.         exit;
  234. 				end;
  235.          unplace(row,col,dir,tempboard);
  236.          counter:=testValid(tempboard);
  237. 			inc(i);
  238. 		end;
  239.  
  240. 	pegsolver:=0;
  241.   end;
  242.  
  243.  
  244.   var
  245.     p : pegboard=
  246.         ((' ',' ','.','.','.',' ',' '),
  247.          (' ',' ','*','*','*',' ',' '),
  248.          ('.','*','*','.','*','*','.'),
  249.          ('.','*','.','.','.','*','.'),
  250.          ('.','*','*','.','*','*','.'),
  251.          (' ',' ','*','*','*',' ',' '),
  252.          (' ',' ','.','.','.',' ',' '));
  253.   temppegboard : pegboard;
  254.     var
  255.  i,j ,re,row,col,dir: integer;
  256.   begin
  257.    row:=1;
  258.    col:=1;
  259.    dir:=1;
  260.  for i:=1 to 7 do
  261.   begin
  262.   for j:=1 to 7 do
  263.     begin
  264.     temppegboard[i,j]:=p[i,j];
  265.     end;
  266.   end;
  267.      re:=pegsolver(row,col,dir,temppegboard);
  268.      writeln('start solving...');
  269.      show(temppegboard);
  270.      writeln(re);
  271.      readln;
  272.  end.
  273.  
stdin
copy 
Standard input is empty
compilation info 
Free Pascal Compiler version 2.2.0 [2009/11/16] for i386
Copyright (c) 1993-2007 by Florian Klaempfl
Target OS: Linux for i386
Compiling prog.pas
prog.pas(19,2) Warning: APPTYPE is not supported by the target OS
Linking prog
272 lines compiled, 0.1 sec
1 warning(s) issued
stdout
copy 
row1= 2 col1= 4
    . . .     
    . . .     
. . . . . . . 
. . . * . . . 
. . . . . . . 
    . . .     
    . . .     

row1= 3 col1= 2
    . . .     
    . * .     
. . . * . . . 
. . . . . . . 
. . . . . . . 
    . . .     
    . . .     

row1= 3 col1= 5
    . . .     
    . * .     
. * * . . . . 
. . . . . . . 
. . . . . . . 
    . . .     
    . . .     

row1= 3 col1= 7
    . . .     
    . * .     
. * . * * . . 
. . . . . . . 
. . . . . . . 
    . . .     
    . . .     

row1= 5 col1= 7
    . . .     
    . * .     
. * . * . * * 
. . . . . . . 
. . . . . . . 
    . . .     
    . . .     

row1= 5 col1= 5
    . . .     
    . * .     
. * . * . * . 
. . . . . . * 
. . . . . . * 
    . . .     
    . . .     

row1= 7 col1= 5
    . . .     
    . * .     
. * . * . * . 
. . . . . . * 
. . . . * * . 
    . . .     
    . . .     

row1= 6 col1= 3
    . . .     
    . * .     
. * . * . * . 
. . . . . . * 
. . . . . * . 
    . . *     
    . . *     

row1= 5 col1= 5
    . . .     
    . * .     
. * . * . * . 
. . . . . . * 
. . . . . * . 
    * * .     
    . . *     

row1= 5 col1= 4
    . . .     
    . * .     
. * . * . * . 
. . . . . . * 
. . . . * * . 
    * * *     
    . . .     

row1= 5 col1= 2
    . . .     
    . * .     
. * . . . * . 
. . . * . . * 
. . . * * * . 
    * * *     
    . . .     

row1= 4 col1= 5
    . . .     
    . * .     
. * . . . * . 
. . . * . . * 
. * * . * * . 
    * * *     
    . . .     

row1= 4 col1= 2
    . . .     
    . * .     
. * . . . * . 
. . . * * * . 
. * * . * * . 
    * * *     
    . . .     

row1= 2 col1= 5
    . . .     
    . * .     
. * . . . * . 
. * * . * * . 
. * * . * * . 
    * * *     
    . . .     

row1= 2 col1= 3
    . . .     
    . * *     
. * . . * * . 
. * * . . * . 
. * * . * * . 
    * * *     
    . . .     

start solving...
    . . .     
    * * *     
. * * . * * . 
. * . . . * . 
. * * . * * . 
    * * *     
    . . .     
1
https://ideone.com/4Qw8I
language:
Pascal (fpc 3.0.4)
created:
12 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!