Pascal/Turbo Pascal - Alguien me podria pasar un sudoku en pascal?

 
Vista:

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (1 intervención) el 09/03/2011 20:35:42
Llevo toda una semana intentandolo y no me sale!
Muchissimas gracias
Valora esta pregunta
Me gusta: Está pregunta es útil y esta claraNo me gusta: Está pregunta no esta clara o no es útil
0
Responder

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:23:24
[paquete 1]

{funciona pero falta revisarlo bien}
{tiene que separar la unidad mouse del finas de sudoku3}
{En modo grafico}
{te lo mando en 4 paquetes segun deves colocarlos no medeja mandarlo en 1}
program sudoku3;
uses
crt, dos, graph, unimous;
type

archiv = record
nom : array [1..120] of string[12];
end;

creado = record
nume : string[12];
matr : array[1..9,1..9] of char;
juego : array[1..9,1..9] of char;
partida : array[1..9,1..9] of char;
end;

matriz = array[1..9,1..9] of char;
control = array[1..9] of char;
linea = array[1..9] of char;

const
fondo : FillPatternType = ($FF, $FF, $FF,
$FF, $FF, $FF, $FF, $FF);


var
crear : integer;
lin : linea;
ff : file of creado;
crea : creado;
reg_sud : creado;
con1, drive, modo : integer;
inx, iny, xk, yk, x, y, xx, yy : integer;
tecla : char;
OldPattern : FillPatternType;
archivos : archiv;
dirinfo : searchrec;
si, para, cagado, sudok : boolean;
nombar : string;
matri : matriz;
contro : control;
i, j, line2, columna, cpt : integer;
res, sav, s : array[1..9,1..9] of integer;
init : array[1..9,1..9] of boolean;
final, sepuede : boolean;
sm : string;
fecha : string[8];

function worstring(xe : word) : string;
var
s : string;
begin
fillchar(s,9,' ');
s[0] := chr(8);
str(xe,s);
worstring := copy(s,1,length(s));
end;

function fecha_hors : string;
var
y, m, d, dow : Word;
h, m1, s, hund : Word;
dato : string;
mas : string;
begin
fecha_hors := ' ';
GetDate(y,m,d,dow);
dato := worstring(d) + worstring(m);
GetTime(h,m1,s,hund);
mas := worstring(m) + worstring(s);
fecha_hors := dato + mas;
end;

procedure graph_ini;
begin
drive := detect;
initgraph(drive,modo,'c:\tp\bgi');
if graphresult <> 0 then
begin
halt(1);
end;
GetFillPattern(OldPattern);
SetFillPattern(fondo, 0);
end;

function intstring(xe : integer) : string;
var
s : string;
begin
fillchar(s,9,' ');
s[0] := chr(8);
str(xe,s);
intstring := copy(s,1,length(s));
end;

function wordchar(nd : word) : char;
var
s : string[8];
begin
str(nd,s);
wordchar := s[1];
end;

function integerchar(nk : integer) : char;
var
s : string[8];
begin
str(nk,s);
integerchar := s[1];
end;

procedure pantalla;
begin
x := 2;
setcolor(2);
repeat
y := 2;
repeat
rectangle((getmaxx div 2) - (9 * 10) + x,(getmaxy div 2) - (9 * 10) + y,
(getmaxx div 2) - (9 * 10) + x + 20,(getmaxy div 2) - (9 * 10) + y + 20);
inc(y,20);
until y > (9 * 20);
inc(x,20);
until x > (9 * 20);
setcolor(3);
line((getmaxx div 2) - (9 * 10) + 62,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 62,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 61,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 61,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 122,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 122,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 123,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 123,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 183,(getmaxy div 2) - (9 * 10) + 1,
(getmaxx div 2) - (9 * 10) + 183,(getmaxy div 2) - (9 * 10) + 183);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 1,(getmaxy div 2) - (9 * 10) + 1,
(getmaxx div 2) - (9 * 10) + 1,(getmaxy div 2) - (9 * 10) + 183);

line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 2,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 2);
line((getmaxx div 2) - (9 * 10) + 1,(getmaxy div 2) - (9 * 10) + 1,
(getmaxx div 2) - (9 * 10) + 183,(getmaxy div 2) - (9 * 10) + 1);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 62,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 62);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 61,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 61);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 122,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 122);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 121,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 121);
line((getmaxx div 2) - (9 * 10) + 2,(getmaxy div 2) - (9 * 10) + 182,
(getmaxx div 2) - (9 * 10) + 182,(getmaxy div 2) - (9 * 10) + 182);
line((getmaxx div 2) - (9 * 10) + 1,(getmaxy div 2) - (9 * 10) + 183,
(getmaxx div 2) - (9 * 10) + 183,(getmaxy div 2) - (9 * 10) + 183);
setcolor(15);
end;

procedure presenta_pantalla_inicio;
begin
SetFillPattern(fondo, 11);
bar(1,1,getmaxx - 1,20);
SetFillPattern(fondo, 7);
bar(1,20,getmaxx - 1,40);
SetFillPattern(fondo, 7);
bar(1,getmaxy - 20,getmaxx - 1,getmaxy);
SetFillPattern(fondo, 7);
rectangle(1,1,getmaxx,getmaxy);
rectangle(2,2,getmaxx - 1,getmaxy - 1);
rectangle(3,3,getmaxx - 2,getmaxy - 2);
setcolor(1);
outtextxy((getmaxx div 2) - 90,8,'****** SUDOKU ******');
outtextxy(10,28,'[ ] [ ] [ ]');
setcolor(0);
outtextxy(10,28,' CARGAR CREAR SALIR');
setcolor(1);
outtextxy(342,28,'[ ]');
setcolor(0);
outtextxy(342,28,' SEGIR P. ');
setcolor(1);
outtextxy(470,28,'[ ]');
setcolor(0);
outtextxy(470,28,' SUDOKU AUTOMATICO ');
setcolor(14);
outtextxy(10,getmaxy - 14,'ELIJA OPCION');
pantalla;
setcolor(12);
outtextxy((getmaxx div 2) - (7 * 10),(getmaxy div 2) - (10 * 10) + 2,
'TABLERO DEL SUDOKU');
setcolor(11);
outtextxy(30,80,'*** INSTRUCIONES DEL PASATIEMPOS *** ');
setcolor(14);
outtextxy(15,88,'Setrata de completar');
outtextxy(15,98,'el tablero de 81 casillas');
outtextxy(15,108,'dispuestas en 9 filas');
outtextxy(15,118,'y 9 columnas rellenando');
outtextxy(15,128,'las celdas vacias con los');
outtextxy(15,138,'numeros del 1 al 9, de modo');
outtextxy(15,148,'que no se repitan ninguna');
outtextxy(15,158,'cifra en cada fila ni en');
outtextxy(15,168,'cadacolumna, ver muestra.');
setcolor(7);
line(15,180,100,180);
line(15,181,100,181);
line(15,180,15,276);
line(16,180,16,276);
line(25,180,25,276);
line(34,180,34,276);
line(43,180,43,276);
line(44,180,44,276);
line(53,180,53,276);
line(62,180,62,276);
line(71,180,71,276);
line(72,180,72,276);
line(81,180,81,276);
line(90,180,90,276);
line(99,180,99,276);
line(100,180,100,276);
line(15,192,100,192);
line(15,202,100,202);
line(15,212,100,212);
line(15,213,100,213);
line(15,223,100,223);
line(15,234,100,234);
line(15,244,100,244);
line(15,245,100,245);
line(15,255,100,255);
line(15,265,100,265);
line(15,275,100,275);
line(15,276,100,276);
setcolor(11);
outtextxy(18,183,'5');
setcolor(14);
outtextxy(27,183,'1');
outtextxy(36,183,'7');
setcolor(11);
outtextxy(46,183,'2');
outtextxy(55,183,'6');
outtextxy(64,183,'3');
outtextxy(74,183,'9');
outtextxy(83,183,'4');
setcolor(14);
outtextxy(92,183,'8');
setcolor(11);
outtextxy(18,194,'2');
outtextxy(27,194,'8');
outtextxy(36,194,'4');
outtextxy(46,194,'7');
setcolor(14);
outtextxy(55,194,'9');
setcolor(11);
outtextxy(65,194,'5');
setcolor(14);
outtextxy(74,194,'3');
setcolor(11);
outtextxy(83,194,'1');
outtextxy(92,194,'6');
setcolor(14);
outtextxy(18,204,'9');
outtextxy(27,204,'6');
setcolor(11);
outtextxy(36,204,'3');
setcolor(14);
outtextxy(46,204,'1');
setcolor(11);
outtextxy(55,204,'8');
outtextxy(64,204,'4');
outtextxy(74,204,'5');
outtextxy(83,204,'2');
setcolor(14);
outtextxy(92,204,'7');
setcolor(11);
outtextxy(18,215,'8');
outtextxy(27,215,'9');
setcolor(14);
outtextxy(36,215,'1');
outtextxy(46,215,'5');
setcolor(11);
outtextxy(55,215,'3');
outtextxy(64,215,'6');
outtextxy(74,215,'2');
setcolor(14);
outtextxy(83,215,'7');
setcolor(11);
outtextxy(92,215,'4');
setcolor(14);
outtextxy(18,226,'7');
setcolor(11);
outtextxy(27,226,'5');
outtextxy(36,226,'2');
outtextxy(46,226,'8');
setcolor(14);
outtextxy(55,226,'4');
setcolor(11);
outtextxy(64,226,'1');
outtextxy(74,226,'6');
outtextxy(83,226,'9');
setcolor(14);
outtextxy(92,226,'3');
setcolor(11);
outtextxy(18,236,'4');
outtextxy(27,236,'3');
setcolor(14);
outtextxy(36,236,'6');
setcolor(11);
outtextxy(46,236,'9');
setcolor(14);
outtextxy(55,236,'7');
setcolor(11);
outtextxy(64,236,'2');
setcolor(14);
outtextxy(74,236,'1');
setcolor(11);
outtextxy(83,236,'8');
outtextxy(92,236,'5');
setcolor(14);
outtextxy(18,247,'6');
setcolor(11);
outtextxy(27,247,'2');
outtextxy(36,247,'9');
outtextxy(46,247,'4');
outtextxy(55,247,'5');
outtextxy(64,247,'7');
outtextxy(74,247,'8');
setcolor(14);
outtextxy(83,247,'3');
setcolor(11);
outtextxy(92,247,'1');
setcolor(14);
outtextxy(18,257,'1');
setcolor(11);
outtextxy(27,257,'7');
outtextxy(36,257,'5');
setcolor(14);
outtextxy(46,257,'3');
setcolor(11);
outtextxy(55,257,'2');
setcolor(14);
outtextxy(64,257,'8');
setcolor(11);
outtextxy(74,257,'4');
setcolor(14);
outtextxy(83,257,'6');
setcolor(11);
outtextxy(92,257,'9');
outtextxy(18,267,'3');
setcolor(14);
outtextxy(27,267,'4');
setcolor(11);
outtextxy(36,267,'8');
outtextxy(46,267,'6');
outtextxy(55,267,'1');
setcolor(14);
outtextxy(64,267,'9');
setcolor(11);
outtextxy(74,267,'7');
outtextxy(83,267,'5');
setcolor(14);
outtextxy(92,267,'2');
setcolor(11);
setcolor(14);
outtextxy(258,158,'1');
outtextxy(279,158,'7');
outtextxy(398,158,'8');
outtextxy(318,179,'9');
outtextxy(358,179,'3');
outtextxy(258,198,'6');
outtextxy(298,198,'1');
outtextxy(238,198,'9');
outtextxy(398,198,'7');
outtextxy(278,219,'1');
outtextxy(318,239,'4');
outtextxy(238,239,'7');
outtextxy(298,219,'5');
outtextxy(318,258,'7');
outtextxy(278,258,'6');
outtextxy(378,218,'7');
outtextxy(398,239,'3');
outtextxy(358,258,'1');
outtextxy(238,279,'6');
outtextxy(378,279,'3');
outtextxy(238,298,'1');
outtextxy(298,298,'3');
outtextxy(338,298,'8');
outtextxy(378,298,'6');
outtextxy(258,318,'4');
outtextxy(338,318,'9');
outtextxy(398,318,'2');
setcolor(15);
outtextxy(192,397,'<<<<<< SUDOKU Y SOLUCION >>>>>>');
end;

function adelante : boolean;
var
t : boolean;
begin
if columna = 9 then
begin
line2 := line2 + 1;
columna := 1;
end
else
columna := columna + 1;
if line2 = 10 then
t := false
else
t := true;
adelante := t;
if init[line2,columna] and t then
adelante := adelante;
end;

function atras : boolean;
var
k : boolean;
begin
if columna = 1 then
begin
line2 := line2 - 1;
columna := 9;
end
else
columna := columna - 1;
if line2 = 0 then
begin
k := false;
end
else
k := true;
atras := k;
if init[line2,columna] and k then
atras := atras;
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:24:57
[paquete 2]

function verifica_la_linea(a : integer) : boolean;
var
k : array [0..9] of integer;
l : integer;
begin
for l := 1 to 9 do
k[l] := 0;
for l := 1 to 9 do
k[s[a,l]] := k[s[a,l]] + 1;
verifica_la_linea := true;
for l := 1 to 9 do
if k[l] > 1 then
verifica_la_linea := false;
end;

function verifica_la_columna(a : integer) : boolean;
var
k : array [0..9] of integer;
l : integer;
begin
for l := 1 to 9 do
k[l] := 0;
for l := 1 to 9 do
k[s[l,a]] := k[s[l,a]] + 1;
verifica_la_columna := true;
for l := 1 to 9 do
if k[l] > 1 then
verifica_la_columna := false;
end;

function verifica_linea_columna(ln, cl : integer) : boolean;
var
k : array [0..9] of integer;
tt, nn, l : integer;
begin
nn := (ln - 1) div 3;
tt := (cl - 1) div 3;
for l := 1 to 9 do
k[l] := 0;
for cl := 1 to 3 do
for ln := 1 to 3 do
k[s[ln + nn * 3,cl + tt * 3]] := k[s[ln + nn * 3,cl + tt * 3]] + 1;
verifica_linea_columna := true;
for l := 1 to 9 do
if k[l] > 1 then
verifica_linea_columna := false;
end;

function comprueva_valor : boolean;
var
lp : boolean;
begin
lp := true;

for line2 := 1 to 9 do
for columna := 1 to 9 do
begin
lp := lp and verifica_la_linea(line2);
lp := lp and verifica_la_columna(columna);
lp := lp and verifica_linea_columna(line2,columna);
end;
comprueva_valor := lp;
end;


function bale_datos : boolean;
begin
final := false;
sepuede := false;
while not final and not sepuede do
begin
if s[line2,columna] < 9 then
begin
repeat
s[line2,columna] := s[line2,columna] + 1;
until (verifica_la_linea(line2) and verifica_la_columna(columna)
and verifica_linea_columna(line2,columna)) or (s[line2,columna] = 10);
if s[line2,columna] < 10 then
final := not adelante;
end
else
begin
s[line2,columna] := 0;
sepuede := not atras;
end;
end;
if final then
bale_datos := true;
if sepuede then
bale_datos := false;
end;

function verifica_sudoku(var sp) : boolean;
var
compara1 : array[1..9,1..9] of char;
compara2 : array[1..9,1..9] of char;
compara3 : array[1..9,1..9] of char;
co1, co2 : integer;
rr, gg : integer;
begin
for co1 := 1 to 9 do
for co2 := 1 to 9 do
begin
compara1[co1][co2] := crea.matr[co1][co2];
compara2[co1][co2] := crea.juego[co1][co2];
compara3[co1][co2] := crea.partida[co1][co2];
end;
for co1 := 1 to 9 do
for co2 := 1 to 9 do
begin

if integerchar(s[co1][co2]) = compara1[co1][co2] then
begin
verifica_sudoku := true;
end
else
begin
verifica_sudoku := false;
break;
end;
end;
end;

procedure generacion_automatica;
var
vide : integer;
begin
randomize;
case crear of
1 : vide := 26;
2 : vide := 30;
3 : vide := 36;
end;
fillchar(reg_sud.partida,sizeof(reg_sud.partida),' ');
repeat
repeat
for line2 := 1 to 9 do
for columna := 1 to 9 do
begin
s[line2,columna] := 0;
init[line2,columna] := false;
end;
for i := 1 to 10 do
begin
line2 := random(9) + 1;
columna := random(9) + 1;
s[line2,columna] := random(9) + 1;
init[line2,columna] := true;
end;
until comprueva_valor;
line2 := 0;
columna := 9;
adelante;
until bale_datos;
for i:=1 to 9do
for j:=1 to 9 do
begin
sav[i,j] := s[i,j];
init[i,j] := true;
end;
for i := 1 to 9 do
for j := 1 to 9 do
begin
str(s[i,j],sm);
matri[i,j] := sm[1];
{outtextxy(20 + i * 15,50 + j * 15,sm);}
end;
for i := 1 to 9 do
for j := 1 to 9 do
begin
reg_sud.matr[i][j] := matri[i][j];
end;
cpt:=0;
while cpt < vide do
begin
i := random(9) + 1;
j := random(9) + 1;
if s[i,j] <> 0 then
begin
s[i,j] := 0;
init[i,j] := false;
cpt := cpt + 1;
s[10 - i,10 - j] := 0;
init[10 - i,10 - j] := false;
end;
end;
for i := 1 to 9 do
for j := 1 to 9 do
begin
if integerchar(s[i,j]) <> '0' then
reg_sud.juego[i][j] := integerchar(s[i,j])
else
reg_sud.juego[i][j] := ' ';
end;
for i := 1 to 9 do
for j := 1 to 9 do
begin
crea.juego[i][j] := reg_sud.juego[i][j];
end;
for i := 1 to 9 do
for j := 1 to 9 do
if s[i,j] = 0 then
res[i,j] := sav[i,j]
else
res[i,j] := 0;
end;

procedure cargasudoku;
var
i, locgx, locgy : integer;
ii, xc, yc : integer;
toma : char;
begin
fillchar(archivos.nom,sizeof(archivos.nom),' ');
ii := 1;
findfirst('*.suk',archive,dirinfo);
while doserror = 0 do
begin
archivos.nom[ii] := dirinfo.name;
inc(ii);
if ii > 120 then
ii := 120;
findnext(dirinfo);
end;
i := 1;
locgx := 45 + 110;
locgy := 55 + (16 * (ii - 1));
if locgy > 420 then
begin
locgy := 420;
locgx := 45 + 220;
end;
bar3d(45,55,locgx,locgy,(locgx - 44) div 12, TopOn);
outtextxy(25,locgy + 12,'USE LAS TECLAS DE FLECHA');
outtextxy(25,locgy + 21,'Y PULSE [ENTER] O [ESC]');
xc := 0;
yc := 0;
for i := 1 to ii - 1 do
begin
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
inc(yc,14);
if yc > 400 then
begin
yc := 0;
xc := 110;
end;
end;
i := 1;
xc := 0;
yc := 0;
repeat
SetFillPattern(fondo, 7);
bar(48,58 + yc,locgx - 4,69 + yc);
SetFillPattern(fondo, 0);
setcolor(1);
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
toma := readkey;
if toma = #80 then
begin
delay(160);
SetFillPattern(fondo, 0);
bar(48,58 + yc,locgx - 4,69 + yc);
setcolor(15);
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
inc(i);
inc(yc,14);
if i > (ii - 1) then
begin
i := (ii - 1);
dec(yc,14);
end;
SetFillPattern(fondo, 7);
bar(48,58 + yc,locgx - 4,69 + yc);
setcolor(1);
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
end;
if toma = #72 then
begin
delay(160);
SetFillPattern(fondo, 0);
bar(48,58 + yc,locgx - 4,69 + yc);
setcolor(15);
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
dec(i);
dec(yc,14);
if i < 1 then
begin
i := 1;
inc(yc,14);
end;
SetFillPattern(fondo, 7);
bar(48,58 + yc,locgx - 4,69 + yc);
setcolor(1);
outtextxy(50 + xc,60 + yc,archivos.nom[i]);
end;
until (toma = #13) or (toma = #27);
if toma = #27 then
begin
sudok := false;
end;
if toma = #13 then
begin
sudok := true;
assign(ff,archivos.nom[i]);
{$i-} reset(ff); {$i+}
if ioresult <> 0 then
begin
exit;
end;
seek(ff,0);
read(ff,crea);
close(ff);
for i := 1 to 9 do
for j := 1 to 9 do
begin
reg_sud.juego[i][j] := crea.juego[i][j];
reg_sud.matr[i][j] := crea.matr[i][j];
reg_sud.partida[i][j] := crea.partida[i][j];
reg_sud.nume := crea.nume;
end;
end;
setcolor(1);
outtextxy(10,28,'[ ] [ ] [ ]');
setcolor(15);
outtextxy(10,28,' CARGAR CREAR SALIR ');
outtextxy(470,28,' SUDOKU AUTOMATICO ');
SetFillPattern(fondo, 7);
bar(342,28,408,38);
SetFillPattern(fondo, 0);
setcolor(1);
outtextxy(342,28,'[ ]');
setcolor(0);
outtextxy(342,28,' SALVAR ');
SetFillPattern(fondo, 0);
bar(4,41,locgx + 80,locgy + 32);
end;

procedure guarda_partida;
var
nomb : string;
tcl : char;
valo : word;
n, m, xl, yl, l : integer;
label salto;
begin
if para = false then
begin
rectangle(400,50,600,62);
outtextxy(408,53,'NOMBRE : ');
l := 1;
xl := 473;
yl := 53;
repeat
tcl := readkey;
if tcl = #0 then
valo := word(ord(readkey)) shl 8
else
valo := ord(tcl);
if valo in [65..90,97..122,164,165,92,58,49..57,95] then
begin
nomb[0] := chr(l);
nomb[l] := upcase(chr(valo));
outtextxy(xl,yl,nomb[l]);
inc(l);
inc(xl,8);
if l > 25 then
begin
l := 25;
dec(xl,8);
end;
end;
if valo in [8] then
begin
dec(l);
dec(xl,8);
if l < 1 then
begin
inc(l);
inc(xl,8);
end;
nomb[0] := chr(l);
nomb[l] := ' ';
SetFillPattern(fondo, 0);
bar(xl,yl,xl + 8,yl + 8);
end;
until (valo = 13) or (valo = 27);
if valo = 13 then
begin
assign(ff,nomb + '.jug');
{$i-} reset(ff); {$i+}
if ioresult <> 0 then
begin
m := 1;
repeat
for n := 1 to 9 do
begin
crea.matr[m][n] := reg_sud.matr[m][n];
crea.juego[m][n] := reg_sud.juego[m][n];
crea.partida[m][n] := reg_sud.partida[m][n];
end;
inc(m);
until m > 9;
crea.nume := reg_sud.nume;
rewrite(ff);
seek(ff,0);
write(ff,crea);
close(ff);
end
else
begin
close(ff);
goto salto;
salto:
outtextxy(348,73,'EL ARCHIVO ESISTE ENTRE OTRO NOMBRE');
delay(2000);
SetFillPattern(fondo, 0);
bar(347,72,634,84);
bar(472,49,598,59);
guarda_partida;
end;
end;
end
else
begin
m := 1;
assign(ff,nombar);
rewrite(ff);
repeat
for n := 1 to 9 do
begin
crea.matr[m][n] := reg_sud.matr[m][n];
crea.juego[m][n] := reg_sud.juego[m][n];
crea.partida[m][n] := reg_sud.partida[m][n];
end;
inc(m);
until m > 9;
crea.nume := reg_sud.nume;
seek(ff,0);
write(ff,crea);
close(ff);
end;
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:38:09
{lo siento an tenido que ser 9 paquetes}
[paquete 3]

procedure crea_sudocu(cual : integer);
var
tm, tec : char;
n, m, ii, u : integer;
nombre : string;
xp, yp, pl1, pl2, raton_boton, xs, ys, i : integer;
no, salir : boolean;
begin
pantalla;
if cual = 1 then
begin
setcolor(10);
outtextxy((getmaxx div 2) - (13 * 10) + 2,(getmaxy div 2) - (11 * 10) + 2,
'*** CREACION O COPIA DE SUDOKU ***');
setcolor(14);
outtextxy((getmaxx div 2) - (26 * 10) + 2,(getmaxy div 2) - (8 * 10) + 190,
'PONGA EL RATON EN LA CASILLA Y PULSE BOTON IZQUIERDO [ENTER] FINAL');
outtextxy((getmaxx div 2) - (26 * 10) + 2,(getmaxy div 2) - (8 * 10) + 208,
'[ESC] AVANDONA ENTRADA SUDOKU');
fillchar(reg_sud.juego,sizeof(reg_sud.juego),' ');
setcolor(15);
end;
if cual = 2 then
begin
outtextxy((getmaxx div 2) - (13 * 8) + 2,(getmaxy div 2) - (11 * 10) + 2,
'*** COMPLETA EL SUDOKU ***');
outtextxy((getmaxx div 2) - (21 * 10) + 2,(getmaxy div 2) + (11 * 10) + 2,
'Elija la casilla con el raton y entre Numero [Esc] = SALIR');
pl1 := 1;
xp := ((getmaxx div 2) - (9 * 10)) + 9;
yp := ((getmaxy div 2) - (9 * 10)) + 9;
repeat
pl2 := 1;
repeat
setcolor(15);
outtextxy(xp, yp,reg_sud.partida[pl1][pl2]);
setcolor(15);
if cagado = true then
begin
setcolor(14);
outtextxy(xp, yp,reg_sud.juego[pl1][pl2]);
end;
inc(pl2);
inc(xp,20);
until pl2 > 9;
inc(pl1);
inc(yp,20);
xp := ((getmaxx div 2) - (9 * 10)) + 9;
until pl1 > 9;
setcolor(14);
outtextxy((getmaxx div 2) - (13 * 3) + 2,(getmaxy div 2) - (11 * 12) + 2,
'NIVEL : ' + reg_sud.nume);
setcolor(15);
end;
if cual = 3 then
begin
pl1 := 1;
xp := ((getmaxx div 2) - (9 * 10)) + 9;
yp := ((getmaxy div 2) - (9 * 10)) + 9;
repeat
pl2 := 1;
repeat
setcolor(9);
outtextxy(xp, yp,reg_sud.juego[pl1][pl2]);
setcolor(15);
if cagado = true then
begin
setcolor(15);
outtextxy(xp, yp,reg_sud.matr[pl1][pl2]);
end;
inc(pl2);
inc(xp,20);
until pl2 > 9;
inc(pl1);
inc(yp,20);
xp := ((getmaxx div 2) - (9 * 10)) + 9;
until pl1 > 9;
setcolor(14);
outtextxy((getmaxx div 2) - (13 * 3) + 2,(getmaxy div 2) - (11 * 12) + 2,
'NIVEL : ' + reg_sud.nume);
setcolor(15);
rectangle(9,55,149,95);
setcolor(7);
rectangle(10,56,148,94);
setcolor(14);
outtextxy(14,59,'DESEA GUARDARLO');
outtextxy(14,72,'Y SEGIR [S/N] ');
setcolor(15);
repeat
tm := readkey;
if tm in['n','N','S','s'] then
begin
end
else
begin
write(^G);
end;
until tm in['n','N','S','s'];
SetFillPattern(fondo, 0);
bar(8,54,150,100);
if tm in['N','n'] then
begin
exit;
end
else
begin
repeat
for n := 1 to 9 do
begin
crea.matr[m][n] := reg_sud.matr[m][n];
crea.juego[m][n] := reg_sud.juego[m][n];
crea.partida[m][n] := reg_sud.partida[m][n];
end;
inc(m);
until m > 9;
crea.nume := reg_sud.nume;
fecha := fecha_hors;
nombre := crea.nume[1] + 'K' + fecha + '.SUK';
assign(ff,nombre);
rewrite(ff);
seek(ff,0);
write(ff,crea);
close(ff);
outtextxy((getmaxx div 2) - (13 * 8) + 2,(getmaxy div 2) - (11 * 10) + 2,
'*** COMPLETA EL SUDOKU ***');
outtextxy((getmaxx div 2) - (21 * 10) + 2,(getmaxy div 2) + (11 * 10) + 2,
'Elija la casilla con el raton y entre Numero [Esc] = SALIR');
SetFillPattern(fondo, 7);
bar(342,28,448,38);
setcolor(15);
outtextxy(10,28,' CARGAR CREAR SALIR ');
outtextxy(470,28,' SUDOKU AUTOMATICO ');
setcolor(1);
outtextxy(342,28,'[ ]');
setcolor(0);
outtextxy(342,28,' SALVAR ');
SetFillPattern(fondo, 0);
end;
end;
muestra_raton;
pon_posicion_raton(500,200);
xs := posx_raton;
ys := posy_raton;
raton_boton := 0;
xk := 0;
yk := 0;
delay(160);
setcolor(15);
repeat
if (xs <> posx_raton) or (ys <> posy_raton) then
begin
xs := posx_raton;
ys := posy_raton;
end;
raton_boton := boton_raton;
if raton_boton = 1 then
begin
no := false;
if (cual = 2) or (cual = 3) then
begin
case ys of
29..37 : begin
case xs of
343..391 : begin
guarda_partida;
tec := #27;
end;
end;
end;
end;
end;
if ((xs > 222) and (xs < 410)) and ((ys > 154) and (ys < 329)) then
begin
oculta_raton;
case ys of
154..168 : begin
case xs of
233..248 : begin
xk := 233; yk := 154; xx := 1;yy := 1;
end;
252..268 : begin
xk := 252; yk := 154; xx := 2; yy := 1;
end;
273..289 : begin
xk := 273; yk := 154; xx := 3; yy := 1;
end;
293..308 : begin
xk := 293; yk := 154; xx := 4;yy := 1;
end;
313..328 : begin
xk := 313; yk := 154; xx := 5;yy := 1;
end;
333..349 : begin
xk := 333; yk := 154; xx := 6; yy := 1;
end;
352..368 : begin
xk := 352; yk := 154;xx := 7;yy := 1;
end;
373..388 : begin
xk := 373; yk := 154; xx := 8; yy := 1;
end;
392..408 : begin
xk := 392; yk := 154; xx := 9; yy := 1;
end;
end;
end;
174..188 : begin
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:41:04
[paquete 4]
case xs of
233..248 : begin
xk := 233; yk := 174; xx := 1; yy := 2;
end;
252..268 : begin
xk := 252;
yk := 174;
xx := 2;
yy := 2;
end;
273..289 : begin
xk := 273;
yk := 174;
xx := 3;
yy := 2;
end;
293..308 : begin
xk := 293;
yk := 174;
xx := 4;
yy := 2;
end;
313..328 : begin
xk := 313;
yk := 174;
xx := 5;
yy := 2;
end;
333..349 : begin
xk := 333;
yk := 174;
xx := 6;
yy := 2;
end;
352..368 : begin
xk := 352;
yk := 174;
xx := 7;
yy := 2;
end;
373..388 : begin
xk := 373;
yk := 174;
xx := 8;
yy := 2;
end;
392..408 : begin
xk := 392;
yk := 174;
xx := 9;
yy := 2;
end;
end;
end;
194..208 : begin
case xs of
233..248 : begin
xk := 233;
yk := 194;
xx := 1;
yy := 3;
end;
252..268 : begin
xk := 252;
yk := 194;
xx := 2;
yy := 3;
end;
273..289 : begin
xk := 273;
yk := 194;
xx := 3;
yy := 3;
end;
293..308 : begin
xk := 293;
yk := 194;
xx := 4;
yy := 3;
end;
313..328 : begin
xk := 313;
yk := 194;
xx := 5;
yy := 3;
end;
333..349 : begin
xk := 333;
yk := 194;
xx := 6;
yy := 3;
end;
352..368 : begin
xk := 352;
yk := 194;
xx := 7;
yy := 3;
end;
373..388 : begin
xk := 373;
yk := 194;
xx := 8;
yy := 3;
end;
392..408 : begin
xk := 392;
yk := 194;
xx := 9;
yy := 3;
end;
end;
end;
214..228 : begin
case xs of
233..248 : begin
xk := 233;
yk := 214;
xx := 1;
yy := 4;
end;
252..268 : begin
xk := 252;
yk := 214;
xx := 2;
yy := 4;
end;
273..289 : begin
xk := 273;
yk := 214;
xx := 3;
yy := 4;
end;
293..308 : begin
xk := 293;
yk := 214;
xx := 4;
yy := 4;
end;
313..328 : begin
xk := 313;
yk := 214;
xx := 5;
yy := 4;
end;
333..349 : begin
xk := 333;
yk := 214;
xx := 6;
yy := 4;
end;
352..368 : begin
xk := 352;
yk := 214;
xx := 7;
yy := 4;
end;
373..388 : begin
xk := 373;
yk := 214;
xx := 8;
yy := 4;
end;
392..408 : begin
xk := 392;
yk := 214;
xx := 9;
yy := 4;
end;
end;
end;
234..248 : begin
case xs of
233..248 : begin
xk := 233;
yk := 234;
xx := 1;
yy := 5;
end;
252..268 : begin
xk := 252;
yk := 234;
xx := 2;
yy := 5;
end;
273..289 : begin
xk := 273;
yk := 234;
xx := 3;
yy := 5;
end;
293..308 : begin
xk := 293;
yk := 234;
xx := 4;
yy := 5;
end;
313..328 : begin
xk := 313;
yk := 234;
xx := 5;
yy := 5;
end;
333..349 : begin
xk := 333;
yk := 234;
xx := 6;
yy := 5;
end;
352..368 : begin
xk := 352;
yk := 234;
xx := 7;
yy := 5;
end;
373..388 : begin
xk := 373;
yk := 234;
xx := 8;
yy := 5;
end;
392..408 : begin
xk := 392;
yk := 234;
xx := 9;
yy := 5;
end;
end;
end;
254..268 : begin
case xs of
233..248 : begin
xk := 233;
yk := 254;
xx := 1;
yy := 6;
end;
252..268 : begin
xk := 252;
yk := 254;
xx := 2;
yy := 6;
end;
273..289 : begin
xk := 273;
yk := 254;
xx := 3;
yy := 6;
end;
293..308 : begin
xk := 293;
yk := 254;
xx := 4;
yy := 6;
end;
313..328 : begin
xk := 313;
yk := 254;
xx := 5;
yy := 6;
end;
333..349 : begin
xk := 333;
yk := 254;
xx := 6;
yy := 6;
end;
352..368 : begin
xk := 352;
yk := 254;
xx := 7;
yy := 6;
end;
373..388 : begin
xk := 373;
yk := 254;
xx := 8;
yy := 6;
end;
392..408 : begin
xk := 392;
yk := 254;
xx := 9;
yy := 6;
end;
end;
end;
274..288 : begin
case xs of
233..248 : begin
xk := 233;
yk := 274;
xx := 1;
yy := 7;
end;
252..268 : begin
xk := 252;
yk := 274;
xx := 2;
yy := 7;
end;
273..289 : begin
xk := 273;
yk := 274;
xx := 3;
yy := 7;
end;
293..308 : begin
xk := 293;
yk := 274;
xx := 4;
yy := 7;
end;
313..328 : begin
xk := 313;
yk := 274;
xx := 5;
yy := 7;
end;
333..349 : begin
xk := 333;
yk := 274;
xx := 6;
yy := 7;
end;
352..368 : begin
xk := 352;
yk := 274;
xx := 7;
yy := 7;
end;
373..388 : begin
xk := 373;
yk := 274;
xx := 8;
yy := 7;
end;
392..408 : begin
xk := 393;
yk := 274;
xx := 9;
yy := 7;
end;
end;
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:42:19
[paquete 5]
294..308 : begin
case xs of
233..248 : begin
xk := 233;
yk := 294;
xx := 1;
yy := 8;
end;
252..268 : begin
xk := 252;
yk := 294;
xx := 2;
yy := 8;
end;
273..289 : begin
xk := 273;
yk := 294;
xx := 3;
yy := 8;
end;
293..308 : begin
xk := 293;
yk := 294;
xx := 4;
yy := 8;
end;
313..328 : begin
xk := 313;
yk := 294;
xx := 5;
yy := 8;
end;
333..349 : begin
xk := 333;
yk := 294;
xx := 6;
yy := 8;
end;
352..368 : begin
xk := 352;
yk := 294;
xx := 7;
yy := 8;
end;
373..388 : begin
xk := 373;
yk := 294;
xx := 8;
yy := 8;
end;
392..408 : begin
xk := 392;
yk := 294;
xx := 9;
yy := 8;
end;
end;
end;
314..328 : begin
case xs of
233..248 : begin
xk := 233;
yk := 314;
xx := 1;
yy := 9;
end;
252..268 : begin
xk := 252;
yk := 314;
xx := 2;
yy := 9;
end;
273..289 : begin
xk := 273;
yk := 314;
xx := 3;
yy := 9;
end;
293..308 : begin
xk := 293;
yk := 314;
xx := 4;
yy := 9;
end;
313..328 : begin
xk := 313;
yk := 314;
xx := 5;
yy := 9;
end;
333..349 : begin
xk := 333;
yk := 314;
xx := 6;
yy := 9;
end;
352..368 : begin
xk := 352;
yk := 314;
xx := 7;
yy := 9;
end;
373..388 : begin
xk := 373;
yk := 314;
xx := 8;
yy := 9;
end;
392..408 : begin
xk := 392;
yk := 314;
xx := 9;
yy := 9;
end;
end;
end;
end;
SetFillPattern(fondo, 7);
bar(xk + 4,yk + 3,xk + 11,yk + 12);
tecla := readkey;
if tecla in['1'..'9'] then
begin
if cual = 1 then
begin
reg_sud.juego[yy][xx] := tecla;
end;
if cual = 2 then
begin
if reg_sud.juego[yy][xx] > ' ' then
begin
no := true;
SetFillPattern(fondo, 0);
bar(xk + 4,yk + 3,xk + 11,yk + 12);
setcolor(14);
outtextxy(xk + 5, yk + 4,reg_sud.juego[yy][xx]);
end
else
begin
reg_sud.partida[yy][xx] := tecla;
end;
end;
end;
if no = false then
begin
SetFillPattern(fondo, 0);
bar(xk + 4,yk + 3,xk + 11,yk + 12);
setcolor(15);
outtextxy(xk + 5, yk + 4,tecla);
SetFillPattern(fondo, 0);
end;
muestra_raton;
pon_posicion_raton(xs,ys);
setcolor(15);
end;
end;
if keypressed then
begin
tec := readkey;
end;
until ((tec = #13) and (cual = 1)) or (tec = #27);
if (tec = #13) and (cual = 1) then
begin
bar((getmaxx div 2) - (26 * 10) + 2,(getmaxy div 2) - (8 * 10) + 190,
(getmaxx div 2) + (28 * 10),(getmaxy div 2) - (8 * 10) + 228);
outtextxy((getmaxx div 2) - (11 * 10) + 2,(getmaxy div 2) - (8 * 10) + 182,
'DESEA GUARDARLO [S/N]');
repeat
tec:= readkey;
if tec in ['s','S','n','N'] then
begin
end
else
begin
write(^G);
end;
until tec in ['s','S','n','N'];
if tec in ['s','S'] then
begin
bar((getmaxx div 2) - (11 * 10) + 2,(getmaxy div 2) - (8 * 10) + 182,
(getmaxx div 2) + (11 * 10) + 2,(getmaxy div 2) - (8 * 10) + 218);
outtextxy((getmaxx div 2) - (11 * 10) + 2,(getmaxy div 2) - (8 * 10) + 182,
'ENTRE NIVEL : ');
u := 1;
repeat
tec := readkey;
if tec in['A'..'Z','a'..'z','¤','¥'] then
begin
reg_sud.nume[0] := chr(u);
reg_sud.nume[u] := upcase(tec);
outtextxy(((getmaxx div 2) - (11 * 10) + 115) + (u * 8) ,(getmaxy div 2) - (8 * 10) + 182,
reg_sud.nume[u]);
inc(u);
if u > 255 then
begin
dec(u);
end;
end;
if tec = #8 then
begin
dec(u);
if u < 1 then
begin
u := 1;
end;
reg_sud.nume[0] := chr(u);
reg_sud.nume[u] := ' ';
outtextxy(((getmaxx div 2) - (11 * 10) + 115) + (u * 8) ,(getmaxy div 2) - (8 * 10) + 182,
reg_sud.nume[u]);
end;
until tec = #13;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:43:38
[paquete 6]
i := 1;
ii := 1;
findfirst('*.suk',archive,dirinfo);
while doserror = 0 do
begin
archivos.nom[ii] := dirinfo.name;
inc(ii);
if ii > 120 then
ii := 120;
findnext(dirinfo);
end;
i := ii - 1;
if i = 0 then
begin
for x := 1 to 9 do
for y := 1 to 9 do
begin
crea.matr[x][y] := reg_sud.matr[x][y];
crea.juego[x][y] := reg_sud.juego[x][y];
crea.partida[x][y] := reg_sud.partida[x][y];
end;
crea.nume := reg_sud.nume;
i := 1;
nombre := 'sudoku' + intstring(i) + '.suk';
assign(ff,nombre);
rewrite(ff);
seek(ff,0);
write(ff,crea);
close(ff);
end
else
begin
for x := 1 to 9 do
for y := 1 to 9 do
begin
crea.matr[x][y] := reg_sud.matr[x][y];
crea.juego[x][y] := reg_sud.juego[x][y];
crea.partida[x][y] := reg_sud.partida[x][y];
end;
crea.nume := reg_sud.nume;
i := ii;
nombre := 'sudoku' + intstring(i) + '.suk';
assign(ff,nombre);
rewrite(ff);
seek(ff,0);
write(ff,crea);
close(ff);
end;
end;
end;
bar((getmaxx div 2) - (26 * 10) + 2,(getmaxy div 2) - (8 * 10) + 190,
(getmaxx div 2) + (28 * 10),(getmaxy div 2) - (8 * 10) + 228);
oculta_raton;
end;
procedure carga_juego_guardado;
var
conta, w, ii, yt, g, t : integer;
tec : char;
valot : word;
begin
fillchar(archivos.nom,sizeof(archivos.nom),' ');
ii := 1;
findfirst('*.jug',archive,dirinfo);
while doserror = 0 do
begin
archivos.nom[ii] := dirinfo.name;
inc(ii);
if ii > 120 then
ii := 120;
findnext(dirinfo);
end;
conta := 0;
conta := ii - 1;
if conta = 0 then
begin
outtextxy((getmaxx div 2) - 180,55,'*** NO TIENE FICHEROS GUARDADOS ***');
delay(3000);
bar((getmaxx div 2) - 180,55,(getmaxx div 2) + 180,65);
end
else
begin
rectangle((getmaxx div 2) - 80,55,
(getmaxx div 2) + 80,55 + (12 * conta));
for w := 1 to ii do
begin
setcolor(15);
outtextxy((getmaxx div 2) - 74,58 + ((w - 1) * 10),archivos.nom[w]);
end;
SetFillPattern(fondo, 7);
bar((getmaxx div 2) - 76,57,
(getmaxx div 2) + 77,65);
SetFillPattern(fondo, 0);
setcolor(15);
w := 1;
yt := 0;
outtextxy((getmaxx div 2) - 74,58 + yt,archivos.nom[w]);
para := false;
repeat
tec := readkey;
if tec = #0 then
valot := word(ord(readkey)) shl 8
else
valot := ord(tec);
if valot = 20480 then
begin
SetFillPattern(fondo, 0);
bar((getmaxx div 2) - 76,57 + yt,
(getmaxx div 2) + 77,65 + yt);
outtextxy((getmaxx div 2) - 74,58 + yt ,archivos.nom[w]);
inc(w);
inc(yt,10);
if w > conta then
begin
dec(w);
dec(yt,10);
end;
SetFillPattern(fondo, 7);
bar((getmaxx div 2) - 76,57 + yt,
(getmaxx div 2) + 77,65 + yt);
setcolor(15);
outtextxy((getmaxx div 2) - 74,58 + yt ,archivos.nom[w]);
end;
if valot = 18432 then
begin
SetFillPattern(fondo, 0);
bar((getmaxx div 2) - 76,57 + yt,
(getmaxx div 2) + 77,65 + yt);
setcolor(15);
outtextxy((getmaxx div 2) - 74,58 + yt ,archivos.nom[w]);
dec(yt,10);
dec(w);
if w < 1 then
begin
inc(w);
inc(yt,10);
end;
SetFillPattern(fondo, 7);
bar((getmaxx div 2) - 76,57 + yt,
(getmaxx div 2) + 77,65 + yt);
setcolor(15);
outtextxy((getmaxx div 2) - 74,58 + yt ,archivos.nom[w]);
end;
until (valot = 13) or (valot = 27);
if valot = 13 then
begin
assign(ff,archivos.nom[w]);
reset(ff);
seek(ff,0);
read(ff,reg_sud);
close(ff);
cagado := true;
nombar := archivos.nom[w];
SetFillPattern(fondo, 7);
bar(342,28,448,38);
setcolor(15);
outtextxy(10,28,' CARGAR CREAR SALIR ');
outtextxy(470,28,' SUDOKU AUTOMATICO ');
setcolor(1);
outtextxy(342,28,'[ ]');
setcolor(0);
outtextxy(342,28,' SALVAR ');
SetFillPattern(fondo, 0);
bar((getmaxx div 2) - 80,55,
(getmaxx div 2) + 80,55 + (12 * conta));
para := true;
crea_sudocu(2);
end;
end;
end;

function intchar(n : integer) : char;
var
s : string[2];
begin
str(n,s);
intchar := s[1];
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:44:29
[paquete 7]

procedure menu_generacion_sudoku;
var
pulsa : char;
valori : word;
xmp, ymp : integer;
opcion : integer;
begin
pantalla;
setcolor(10);
outtextxy(20,50,'<<< GENERACION AUTOMATICA >>>');
setcolor(15);
rectangle(75,65,200,135);
setcolor(7);
rectangle(76,66,201,156);
rectangle(75,136,200,157);
rectangle(76,136,200,157);
setcolor(15);
outtextxy(88,72,' NIVEL BAJO ');
outtextxy(88,87,' NIVEL MEDIO ');
outtextxy(88,102,' NIVEL ALTO ');
outtextxy(88,118,' SALIR ');
setcolor(14);
outtextxy(78,142,'* ELEJA NIVEL *');
opcion := 1;
repeat
case opcion of
1 : begin
SetFillPattern(fondo, 0);
bar(88,70,189,128);
setcolor(15);
outtextxy(88,72,' NIVEL BAJO ');
outtextxy(88,87,' NIVEL MEDIO ');
outtextxy(88,102,' NIVEL ALTO ');
outtextxy(88,118,' SALIR ');
SetFillPattern(fondo, 7);
bar(88,71,186,81);
setcolor(1);
outtextxy(88,72,' NIVEL BAJO ');
setcolor(15);
end;
2 : begin
SetFillPattern(fondo, 0);
bar(88,70,198,128);
setcolor(15);
outtextxy(88,72,' NIVEL BAJO ');
outtextxy(88,87,' NIVEL MEDIO ');
outtextxy(88,102,' NIVEL ALTO ');
outtextxy(88,118,' SALIR ');
SetFillPattern(fondo, 7);
bar(88,84,186,96);
setcolor(1);
outtextxy(88,87,' NIVEL MEDIO ');
setcolor(15);
end;
3 : begin
SetFillPattern(fondo, 0);
bar(88,70,198,128);
setcolor(15);
outtextxy(88,72,' NIVEL BAJO ');
outtextxy(88,87,' NIVEL MEDIO ');
outtextxy(88,102,' NIVEL ALTO ');
outtextxy(88,118,' SALIR ');
SetFillPattern(fondo, 7);
bar(88,100,186,110);
setcolor(1);
outtextxy(88,102,' NIVEL ALTO ');
setcolor(15);
end;
4 : begin
SetFillPattern(fondo, 0);
bar(88,70,198,128);
setcolor(15);
outtextxy(88,72,' NIVEL BAJO ');
outtextxy(88,87,' NIVEL MEDIO ');
outtextxy(88,102,' NIVEL ALTO ');
outtextxy(88,118,' SALIR ');
SetFillPattern(fondo, 7);
bar(88,116,186,126);
setcolor(1);
outtextxy(88,118,' SALIR ');
setcolor(15);
end;
end;
pulsa := readkey;
if pulsa = #0 then
valori := word(ord(readkey)) shl 8
else
valori := ord(pulsa);
if valori = 18432 then {abajo}
begin
dec(opcion);
if opcion < 1 then
opcion := 1;
end;
if valori = 20480 then {abajo}
begin
inc(opcion);
if opcion > 4 then
opcion := 4;
end;
until (valori = 13) or (valori = 27);
SetFillPattern(fondo, 0);
bar(3,45,getmaxx - 2,getmaxy - 2);
if valori = 13 then
begin
crear := opcion;
end
else
begin
crear := 0;
end;
setcolor(15);
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:45:27
[paquete 8]

procedure pantalla_windows;
var
salimos : boolean;
tecl : char;
pulsado : integer;
begin
presenta_pantalla_inicio;
muestra_raton;
x := posx_raton;
y := posy_raton;
salimos := false;
pulsado := 0;

repeat
if (x <> posx_raton) or (y <> posy_raton) then
begin
x := posx_raton;
y := posy_raton;
end;
pulsado := boton_raton;
if pulsado = 1 then
begin
oculta_raton;
case y of
28..34 : begin
case x of
13..69 : begin
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
sudok := false;
cargasudoku;
if sudok = true then
begin
crea_sudocu(2);
end;
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
presenta_pantalla_inicio;
end;
117..165 : begin
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
crea_sudocu(1);
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
presenta_pantalla_inicio;
end;
214..261 : begin
salimos := true;
end;
346..416 : begin
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
carga_juego_guardado;
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
presenta_pantalla_inicio;
end;
473..617 : begin
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
menu_generacion_sudoku;
generacion_automatica;
if crear > 0 then
begin
case crear of
1 : begin
crea.nume := 'NIVEL BAJO';
end;
2 : begin
crea.nume := 'NIVEL MEDIO';
end;
3 : begin
crea.nume := 'NIVEL ALTO';
end;
end;
if crear <> 0 then
begin
reg_sud.nume := crea.nume;
crea_sudocu(3);
end;
end;
SetFillPattern(fondo, 0);
bar(4,41,getmaxx - 4,getmaxy - 21);
presenta_pantalla_inicio;
end;
end;
end;
end;
muestra_raton;
pon_posicion_raton(x,y);
end;
if keypressed then
begin
tecl := readkey;
end;
until (salimos = true) or (tecl = #27);
oculta_raton;
setcolor(15);
SetFillPattern(fondo, 0);
end;
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar

Alguien me podria pasar un sudoku en pascal?

Publicado por ramon (2158 intervenciones) el 10/03/2011 23:47:23
[parte finat del paquete 8]

begin
graph_ini;
para := false;
pantalla_windows;
SetFillPattern(OldPattern,0);
CloseGraph;
end.



{--------------------------------------------------------------------------------------------------------------------------}
[paquete 9]
{unidat de mouse}

unit unimous;
interface
uses
dos;
var
regs : registers;
raton : boolean;
pulsado : integer;
function raton_presente : boolean;
procedure muestra_raton;
procedure oculta_raton;
function posx_raton : word;
function posy_raton : word;
function boton_raton : word;
procedure pon_posicion_raton(xp, yp : word);
procedure ventana_raton(xv, yv, xxv, yyv : word);
procedure sensib_raton(xs, ys : word);
procedure pulsa_boton(var pulsado : integer; boton : byte);
procedure relacion_pixel_mickeys(px, py : integer);
implementation
function raton_presente : boolean;
begin
regs.ah := $00;
regs.al := $00;
intr($33,regs);
if regs.ax <> 0 then
raton_presente := true
else
raton_presente := false;
end;
procedure muestra_raton;
begin
raton := false;
if raton_presente then
begin
regs.ah := $00;
regs.al := $01;
intr($33,regs);
raton := true;
end;
end;
procedure oculta_raton;
begin
if raton = true then
begin
regs.ah := $00;
regs.al := $02;
intr($33,regs);
raton := false;
end;
end;
function posx_raton : word;
begin
posx_raton := 0;
regs.ah := $00;
regs.al := $03;
intr($33,regs);
posx_raton := regs.cx
end;
function posy_raton : word;
begin
posy_raton := 0;
regs.ah := $00;
regs.al := $03;
intr($33,regs);
posy_raton := regs.dx
end;
function boton_raton : word;
begin
boton_raton := 0;
regs.ah := $00;
regs.al := $03;
intr($33,regs);
boton_raton := regs.bx
end;
procedure pon_posicion_raton(xp, yp : word);
begin
regs.ah := $00;
regs.al := $04;
regs.cx := xp;
regs.dx := yp;
intr($33,regs);
end;
procedure ventana_raton(xv, yv, xxv, yyv : word);
begin
regs.ah := $00;
regs.al := $07;
regs.cx := xv;
regs.dx := xxv;
intr($33,regs);
regs.ah := $00;
regs.al := $08;
regs.cx := yv;
regs.dx := yyv;
intr($33,regs);
end;
procedure sensib_raton(xs, ys : word);
begin
regs.ah := $00;
regs.al := $1A;
regs.bx := xs;
regs.cx := ys;
regs.dx := 32;
intr($33,regs);
end;
procedure pulsa_boton(var pulsado : integer; boton : byte);
begin
regs.ah := $00;
regs.al := $05;
regs.bx := boton;
intr($33,regs);
pulsado := regs.bx;
end;
procedure relacion_pixel_mickeys(px, py : integer);
begin
regs.ah := $00;
regs.al := $0f;
regs.cx := px;
regs.dx := py;
intr($33,regs);
end;
begin
end.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
0
Comentar