(****************************************************************
** Nombre: Resolucion de Sudokus
** Autor: Jose Roman H.M. (Manz)
** Fecha: Miercoles, 18 de Enero de 2006
** Descripcion: 
** 
** Programa que resuelva Sudokus.
**
****************************************************************)

Program Sudoku;

Uses Dos,Crt;

Type 
	Sudocuadro = 0..10;
	TCuadricula = Array [1..9,1..9] of Sudocuadro;
	Unicuadricula = Array [1..9] of Sudocuadro;

Var
	Cuadricula, Inicial,Comprobacion : TCuadricula;
	Retrocediendo : Boolean;
	
	(********************************************************************
	   Procedimiento que borra el array pasado por parametro (a ceros)
	*********************************************************************)

	Procedure Borrar(var cuad : TCuadricula);
	Var
		f,c : Sudocuadro;
	Begin
		
		for c := 1 to 9 do
			for f := 1 to 9 do
				cuad[f,c] := 0;

	End;
	
	(********************************************************************
	   Procedimiento que copia el array Origen al array Destino
	*********************************************************************)	

	Procedure Copiar(var Origen : TCuadricula; var Destino : TCuadricula);
	Var
		f,c : Sudocuadro;
	Begin

		for c := 1 to 9 do
			for f := 1 to 9 do
				Destino[f,c] := Origen[f,c];

	End;
	
	(********************************************************************
	   Funcion que devuelve true si los array pasados por parametro son
		iguales.
	*********************************************************************)	
	
	Function Compara(var Origen : TCuadricula; var Destino : TCuadricula): Boolean;
	Var
		f,c : Sudocuadro;
	Begin

		c := 1;
		f := 1;
		Compara := True;
		
		while ( ( c <= 9 )and(Compara = True) ) do
		begin
			while ( ( f <= 9 )and(Compara = True) ) do
			begin
				if ( Origen[f,c] = Destino[f,c] ) Then
					Compara := True
				else
					Compara := False;
				f := f + 1;
			end;
			c := c + 1;
		end;

	End;	
	
	(********************************************************************
	   Procedimiento que crea un sudoku por valores metidos por teclado
	*********************************************************************)	

	Procedure CrearSudoku(var cuad : TCuadricula);
	Var
		f,c : Sudocuadro;
	Begin

		for c := 1 to 9 do
			for f := 1 to 9 do
				begin
					write('Introduce coordenada ',f,'x',c,' (0 en blanco): ');
					readln(cuad[f,c]);
				end;

	End;
	
	(****************************************************
		Procedimiento que carga un fichero con sudokus
		para resolver.
	****************************************************)

	Procedure CargaFichero(var cuad : TCuadricula);
	Var
		Fich : File of Sudocuadro;
		Nombre : String;
		x,y,num : Sudocuadro;
	Begin
		
		// Evitar warnings
		Num := 0; 
		Nombre := '';
		
		Repeat
			Write('Introduzca el nombre del fichero: ');
			readln(Nombre);
		Until ( nombre <> '' );
		
		{$I-}
		Assign(Fich, Nombre);
		Reset(Fich);
		{$I+}
		
		If ( IOResult <> 0 ) Then
			writeln('Error abriendo el fichero.')
		Else
		Begin
			
			for y := 1 to 9 do
			begin
				for x := 1 to 9 do
				begin
					read(Fich,num);
					cuad[x,y] := num;
				end;
			end;
			
		End;
		
		writeln('Proceso de lectura terminado.');
		readln;		
		Close(Fich);
		
	End;	
	
	(****************************************************
		Procedimiento que guarda un fichero con sudokus
		para resolver.
	****************************************************)

	Procedure GuardaFichero(var cuad : TCuadricula);
	Var
		Fich : File of Sudocuadro;
		Nombre : String;
		x,y : Sudocuadro;
	Begin
		
		// Evitar warnings
		Nombre := '';
		
		Repeat
			Write('Introduzca el nombre del fichero: ');
			readln(Nombre);
		Until ( nombre <> '' );
		
		{$I-}
		Assign(Fich, Nombre);
		Rewrite(Fich);
		{$I+}
		
		If ( IOResult <> 0 ) Then
			writeln('Probable problema de permisos de escritura.')
		Else
		Begin
			
			for y := 1 to 9 do
			begin
				for x := 1 to 9 do
				begin
					write(Fich,cuad[x,y]);
				end;
			end;
			
		End;
		
		writeln('Proceso de escritura terminado.');
		readln;		
		Close(Fich);
		
	End;
	
	Procedure GeneraTablero(var cuad : TCuadricula);
	Var
		f,c : Sudocuadro;
	Begin
	
		Clrscr();
		TextColor(LightCyan);
		GotoXY(1, 1);
		writeln('+-------------------------+');
		write('|       ');
		TextColor(LightRed);
		write('S U D O K U');
		TextColor(LightCyan);
		writeln('       |');
		writeln('+---------+-------+-------+');
		write('|   ');
		TextColor(LightBlue);
		write('1 2 3   4 5 6   7 8 9');
		TextColor(LightCyan);
		writeln(' |');
		writeln('+-+-------+-------+-------+');

		for c := 1 to 9 do
		begin

			for f := 1 to 9 do
			begin

				If (f = 1) Then
				begin
					TextColor(LightCyan);
					write('|');
					TextColor(LightBlue);
					write(c);
					TextColor(LightCyan);
					write('|');					
				end;

				TextColor(LightGreen);

				if ( cuad[f,c] <> 0 ) Then
					write(' ', cuad[f,c])
				else
					write('  ');

				if ((f mod 3) = 0) Then
				begin
					TextColor(LightCyan);
					write(' |');
				end;

			end;

			Writeln;

			if ((c mod 3) = 0) Then
			begin
				TextColor(LightCyan);
				writeln('+-+-------+-------+-------+');
			end;

		end;

		TextColor(LightGray);
		writeln;

	End;

	(*****************************************************************
	*
	** Funcion que comprueba si el numero existe en la fila
	* Devuelve: 
	* (True) - Si el numero se puede colocar (No existe)
	* (False) - Si el numero no se puede colocar (Existe)
	*****************************************************************)

	Function ComprobarFila(var cuad : TCuadricula; Numero : Sudocuadro; Fila : Sudocuadro; Columna : Sudocuadro; FilaMov : Sudocuadro): Boolean;
	Begin

		ComprobarFila := True; 	// En principio el numero se puede colocar
		
		if ( cuad[filamov,columna] = Numero ) Then
		begin
			ComprobarFila := False;
			//writeln('Detectado ',numero,' en ',filamov,'x',columna);
		end
		else
			if ( FilaMov < 9 ) Then
				ComprobarFila := ComprobarFila(cuad,numero,Fila,columna,FilaMov+1);
	End;

	(*****************************************************************
	*
	** Funcion que comprueba si el numero existe en la columna
	* Devuelve: 
	* (True) - Si el numero se puede colocar (No existe)
	* (False) - Si el numero no se puede colocar (Existe)
	*****************************************************************)

	Function ComprobarColumna(var cuad : TCuadricula; Numero : Sudocuadro; Fila : Sudocuadro; Columna : Sudocuadro; ColumnaMov : Sudocuadro): Boolean;
	Begin

		ComprobarColumna := True; 	// En principio el numero se puede colocar
		
		if ( cuad[fila,columnamov] = Numero ) Then
		begin
			ComprobarColumna := False;
			//writeln('Detectado ',numero,' en ',fila,'x',columnamov);
		end
		else
			if ( ColumnaMov < 9 ) Then
			begin
				//writeln(ColumnaMov);
				ComprobarColumna := ComprobarColumna(cuad,numero,Fila,columna,ColumnaMov+1);
			end;
	End;

	(*****************************************************************
	*
	** Funcion que comprueba si el numero existe en la region
	* Devuelve: 
	* (True) - Si el numero se puede colocar (No existe)
	* (False) - Si el numero no se puede colocar (Existe)
	*****************************************************************)

	Function ComprobarRegion(var cuad : TCuadricula; Numero : Sudocuadro; v : Unicuadricula; pos : sudocuadro): Boolean;
	Begin
		
		ComprobarRegion := True;

		if ( v[pos] = Numero ) Then
		begin
			ComprobarRegion := False;
			//writeln('Detectado ',numero,' en region.');
		end
		else
		begin
			//writeln('vpos: ',v[pos],' numero: ',numero);
			if ( pos < 9 ) Then
				ComprobarRegion := ComprobarRegion(cuad,numero,v,pos+1);
		end;

	End;

	
	(*****************************************************************
	*
	** Funcion para comprobar si se puede establecer un (numero) en la posicion
	indicada por parametro (fila, columna) en la cuadricula (c).
	Devuelve:
	*
	** True si se puede colocar el numero
	** False si no se puede colocar
	*
	*****************************************************************)
	Function Comprobar(var cuad : TCuadricula; Numero : Sudocuadro; Fila : Sudocuadro; Columna : Sudocuadro): Boolean;
	Var
		auxx, auxy, i : Sudocuadro;
		vector : unicuadricula;
	Begin
		
		Comprobar := True;	// En principio el numero se puede colocar
		
		// Comenzamos por la Comprobacion de Filas
			
		Comprobar := ComprobarFila(cuad,Numero,fila,columna,1);

		If ( Comprobar = True ) Then
			Comprobar := ComprobarColumna(cuad,Numero,fila,columna,1);

		If ( Comprobar = True ) Then
		Begin
			auxx := (((fila-1) div 3)*3)+1;
			auxy := (((columna-1) div 3)*3)+1;

			for i := 1 to 9 do
			begin
				vector[i] := cuad[auxx,auxy];
				auxx := auxx + 1;
				if ((i = 3)or(i = 6)) Then
				begin
					auxx := auxx - 3;
					auxy := auxy + 1;
				end;
			end;

			{for i := 1 to 9 do
				write('|',vector[i]);
			writeln;}
			
			Comprobar := ComprobarRegion(cuad,Numero,vector,1);
		End;

	End;

	Function Insertar(var cuad : TCuadricula; numero : Sudocuadro; f : sudocuadro; c : sudocuadro): Boolean;
	Begin

		If ( Comprobar(cuad,numero,f,c) = True ) Then
		Begin
			Insertar := True;
			cuad[f,c] := numero;
		end
		else
		begin
			Insertar := False;
			writeln('No se puede colocar ese numero.');
		end;

	End;

	(************************************************************************
	      Devuelve True si la casilla esta vacia, o false si esta ocupada
	************************************************************************)

	Function CasillaVacia(var cuad : TCuadricula; f, c : sudocuadro): boolean;
	Begin

		If ( cuad[f,c] = 0 ) Then
			CasillaVacia := True
		else
			CasillaVacia := False;

	End;
	
	(********************************************************************
	   Procedimiento que entra en un nivel de bucle recursivo para
	   intentar resolver el sudoku. Se le pasa por parametro la cuadricula
	   del sudoku, la fila (f), la columna (c), la variable solucion (que
	   devuelve true si encontro una o false en caso contrario y empieza
	   que indica si comenzamos a generar los numeros desde 1 o desde 9.
	*********************************************************************)

	Procedure Ensayo(var cuad : TCuadricula; f,c : sudocuadro; var solucion : boolean; empieza : sudocuadro);
	var
		num : sudocuadro;
	Begin
		GeneraTablero(cuad);
		if ( empieza = 1 ) then
			num := 1
		else
			num := 9;

		if ( c = 10 ) Then
			solucion := true
		else
		begin

			solucion := false;

			Repeat

				// Respetar sudoku inicial
				If ( CasillaVacia(Inicial,f,c) ) Then
				begin

					Retrocediendo := False;
					//writeln('Comprobando ',f,'x',c,' (',num,') ...');
				
					// Comprobar sudoku
					If ( Comprobar(cuad,num,f,c) ) Then
					begin

						cuad[f,c] := num;
						// Ir avanzando
		
						If ( f < 9 ) Then
							Ensayo(cuad, f+1, c, solucion, empieza)
						else { f = 9 }
							Ensayo(cuad, 1, c+1, solucion, empieza);

					end
					else 
					begin

						// Si no se puede poner el numero intentamos otro
						if ( empieza = 1 ) then
							num := num + 1
						else
							if ( num = 1 ) then
								num := 10
							else
								num := num - 1;					
					end;

				end

				else	// Si casilla del sudoku inicial no esta vacia...
				begin
						// Ir avanzando
						
						If ( not Retrocediendo ) Then

							If ( f < 9 ) Then
								Ensayo(cuad, f+1, c, solucion, empieza)
							else { f = 9 }
								Ensayo(cuad, 1, c+1, solucion, empieza);

						Retrocediendo := True;
						num := 10;
				end;

			Until ( solucion or ((num=10)and(not solucion)) );

			if ((not solucion) and (num=10)) then
			begin
				if ( not Retrocediendo ) Then 
					cuad[f,c] := 0;
					solucion := false;
			end;

		end;

	End;
	
	(********************************************************************
	   Procedimiento que inicia el proceso de resolucion de sudokus. Se
	   encarga de comprobar el tiempo que tarda en resolverlos, hacer una
	   copia de sudokus para comprobar si tiene una o varias soluciones,
	   etc. 
	*********************************************************************)	
	
	Procedure Resolver(var cuad : TCuadricula; var backup : TCuadricula);
	var
		solucion : boolean;
		h,m,s,c : word;
		ini,fin : real;
		opcion : byte;
	Begin
		
		clrscr();
		GetTime(h,m,s,c);
		ini := c/100+s+m*60+h*60*60;
		GeneraTablero(cuad);
		copiar(cuad,backup);
		Retrocediendo := False;

		Ensayo(cuad, 1, 1, solucion, 1);
		
		GetTime(h,m,s,c);
		fin := c/100+s+m*60+h*60*60;
		
		writeln('Operacion realizada en ',fin-ini:8:2,' segundos.');
	
		If Solucion Then
		begin
			Writeln('Sudoku resuelto');
			Repeat
				write('Comprobar si existen mas soluciones? (1- Si, 2- No): ');
				readln(opcion);
			Until ( (opcion=1)or(opcion=2) );
			
			If opcion=1 Then
			begin

				GetTime(h,m,s,c);
				ini := c/100+s+m*60+h*60*60;
				copiar(cuad,Comprobacion);
				copiar(backup,cuad);
				Retrocediendo := False;
				solucion := false;
				generatablero(cuad);
				Ensayo(cuad, 1, 1, solucion, 9);
				If ( Compara(cuad,Comprobacion) = True ) Then
					writeln('La solucion del sudoku es unica.')
				else
					writeln('El sudoku tiene varias soluciones.');
					
				GetTime(h,m,s,c);
				fin := c/100+s+m*60+h*60*60;
				
				writeln('Operacion realizada en ',fin-ini:8:2,' segundos.');
									
			end;
		end
		else
			writeln('Sudoku sin solucion');
		
		writeln('Pulse una tecla para volver al menu.');
		readln;			
			
	End;
	
	(********************************************************************
	   Procedimiento con el menu del programa.
	*********************************************************************)	

	Procedure Menu(var cuad : TCuadricula; var backup : TCuadricula);
	Var
		opcion : byte;
		f,c,num : sudocuadro;
	Begin

		repeat

			GeneraTablero(cuad);
			writeln('Menu de opciones:');
			writeln('1 - Insertar un numero en el sudoku');
			writeln('2 - Cargar un sudoku guardado');
			writeln('3 - Guardar el sudoku actual');
			writeln('4 - Intentar resolver el sudoku');
			writeln('5 - Crear sudoku por coordenadas');
			writeln('6 - Borrar sudoku');
			writeln('0 - Salir');
			writeln;
			write('Opcion: ');
			readln(opcion);

			case opcion of
				1 : begin
						Repeat
							write('Introduzca el numero a insertar: ');
							readln(num);
						Until ( num <> 0 );
						Repeat
							write('Introduzca la posicion de la columna: ');
							readln(f);
						Until ( f <> 0 );
						Repeat
							write('Introduzca la posicion de la fila: ');
							readln(c);
						Until ( c <> 0 );

						If ( Insertar(cuad,num,f,c) = False ) Then
						begin
							writeln('Pulse una tecla para continuar.');
							readln;
						end;
					 end;
				2 : CargaFichero(cuad);
				3 : GuardaFichero(cuad);
				4 : Resolver(cuad,backup);
				5 : CrearSudoku(cuad);
				6 : Borrar(cuad);
				0 : writeln;
				else writeln('Opcion desconocida.');
			end;
		until ( opcion = 0 );

	End;

(***********************
   Programa principal.
***********************)

Begin
	Borrar(Inicial);
	Borrar(Cuadricula);
	Menu(Cuadricula,Inicial);
End.