Código de Basic - Resolver Sudokus

<<>>
Imágen de perfil
Actualizado

Resolver Sudokusgráfica de visualizaciones


Basic

estrellaestrellaestrellaestrellaestrella(5)
Actualizado el 17 de Septiembre del 2017 por Adelino (Publicado el 12 de Septiembre del 2016)
1.748 visualizaciones desde el 12 de Septiembre del 2016. Una media de 35 por semana
Resuelve Sudokus por fuerza bruta método "backtrack".
Se maneja con las teclas de dirección.

Dificil

Requerimientos

QBasic64 en Windows x64.
Qbasic4.5 x86.

SDKQB64
estrellaestrellaestrellaestrellaestrella(4)

Publicado el 12 de Septiembre del 2016gráfica de visualizaciones de la versión: SDKQB64
303 visualizaciones desde el 12 de Septiembre del 2016. Una media de 7 por semana

1.2

Actualizado el 17 de Septiembre del 2017 (Publicado el 12 de Septiembre del 2016)gráfica de visualizaciones de la versión: 1.2
336 visualizaciones desde el 12 de Septiembre del 2016. Una media de 7 por semana

1.3

Actualizado el 06 de Octubre del 2016 (Publicado el 26 de Septiembre del 2016)gráfica de visualizaciones de la versión: 1.3
992 visualizaciones desde el 26 de Septiembre del 2016. Una media de 21 por semana

1.4

Publicado el 16 de Septiembre del 2017gráfica de visualizaciones de la versión: 1.4
53 visualizaciones desde el 16 de Septiembre del 2017

1.5
estrellaestrellaestrellaestrellaestrella(1)

Publicado el 17 de Septiembre del 2017gráfica de visualizaciones de la versión: 1.5
65 visualizaciones desde el 17 de Septiembre del 2017
estrellaestrellaestrellaestrellaestrella
estrellaestrellaestrellaestrella
estrellaestrellaestrella
estrellaestrella
estrella

Modo grafico.
Pantalla completa= "ALT+Intro".
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
DEFINT A-Z 'Declara enteras las variables
SCREEN 1 'Pantalla grafica
DIM a(80), b(81) 'Casillas y fijos
DIM y1(80), y2(80), y3(80) 'Agrupando casillas
DIM x1(8, 9), x2(8, 9), x3(8, 9) 'Control de ocupacion
DIM X(80), Y(80), c$(9) 'Posicion en pantalla y caracter
 
CLS 'Limpiar pantalla
LINE (89, 25)-(237, 173), 3, B 'Cuadricula
LINE (89, 25)-(236, 172), 3, B
FOR v = 0 TO 2 'Inicio agrupamiento
    FOR w = 0 TO 2
        FOR x = 0 TO 2
            FOR y = 0 TO 2
                'READ a(n): REM Activar para cargar sudoku
                y1(n) = 3 * v + w 'Fila de casilla (0,8)
                y2(n) = 3 * x + y 'Columna de casilla (0,8)
                y3(n) = 3 * v + x 'Zona de casilla (0,8)
 
                X(n) = 13 + 2 * (n MOD 9)
                Y(n) = 5 + 2 * (n \ 9)
                IF n < 10 THEN c$(n) = CHR$(48 + n)
                LINE (8 * X(n) - 13, 8 * Y(n) - 13)-(8 * X(n) + 3, 8 * Y(n) + 3), 3, B
                IF w + y = 0 THEN LINE (8 * X(n) - 14, 8 * Y(n) - 14)-(8 * X(n) + 35, 8 * Y(n) + 35), 3, B
                n = n + 1 ' Siguiente casilla
NEXT y, x, w, v 'Fin agrupamiento
c$(0) = " "
n = 0 'Casilla inicial
 
WHILE a$ <> CHR$(13)
    LOCATE Y(n), X(n) 'Valor en pantalla
    PRINT c$(a(n))
    PAINT (8 * X(n) - 10, 8 * Y(n) - 10), 2, 3 'Cursor
 
    IF a OR a$ = " " OR a$ = "0" THEN
        a$ = "M" 'Si el ultimo valor fue valido avanzar una casilla
    ELSE GOSUB Teclado
    END IF
 
    PAINT (8 * X(n) - 10, 8 * Y(n) - 10), 0, 3
    a$ = RIGHT$(a$, 1) 'Caracter derecho, las teclas de direccion devuelven dos caracteres)
    a = VAL(a$) 'Valor de tecla pulsada
    IF a$ = "M" AND n < 80 THEN n = n + 1 'Flecha derecha
    IF a$ = "K" AND n > 0 THEN n = n - 1 ' Flecha izquierda
    IF a$ = "P" AND n < 72 THEN n = n + 9 'Flecha abajo
    IF a$ = "H" AND n > 8 THEN n = n - 9 ' Flecha arriba
    IF a OR a$ = " " OR a$ = "0" THEN a(n) = a 'Asignar valor pulsado
WEND
 
FOR n = 0 TO 80 'Inicio control de casillas ocupadas
    a = a(n) 'Obtener valor de casilla
    IF a THEN
        IF x1(y1(n), a) + x2(y2(n), a) + x3(y3(n), a) THEN 'Valor no valido
            a(n) = 0
            LOCATE Y(n), X(n)
            PRINT " " 'Borrado
 
        ELSE b(n) = 1 'Establecer casilla ocupada
            x1(y1(n), a) = 1 'Establecer valor en uso para fila
            x2(y2(n), a) = 1
            x3(y3(n), a) = 1
            PAINT (8 * X(n) - 10, 8 * Y(n) - 10), 2, 3
        END IF
    END IF
NEXT 'Fin control de ocupacion
n = 0 'Inicio rutina de resolucion
 
Inicio:
IF b(n) THEN n = n + 1: GOTO Inicio 'El valor es fijo
IF n < 81 THEN
    a = a(n) 'Valor de casilla (0,9)
    x1(y1(n), a) = 0 'Liberar valor de casilla en fila
    x2(y2(n), a) = 0
    x3(y3(n), a) = 0
 
    Siguiente:
    IF a < 9 THEN
        a = a + 1 'Siguiente valor en casilla
        IF x1(y1(n), a) GOTO Siguiente 'Valor en uso para fila
        IF x2(y2(n), a) GOTO Siguiente
        IF x3(y3(n), a) GOTO Siguiente
 
        x1(y1(n), a) = 1 'Establecer valor en uso para fila
        x2(y2(n), a) = 1
        x3(y3(n), a) = 1
 
        a(n) = a 'Asignar nuevo valor a casilla
        LOCATE Y(n), X(n) 'Valor en pantalla
        PRINT c$(a)
        n = n + 1 'Casilla siguiente
        GOTO Inicio
    END IF
 
    a(n) = 0 'Asignar "0" por rebase
    LOCATE Y(n), X(n) 'Borrar
    PRINT " "
 
    Anterior:
    n = n - 1 'Casilla anterior
    IF n < 0 THEN GOSUB Teclado: RUN 'No hay mas soluciones reiniciar
    IF b(n) GOTO Anterior 'Es fijo
    GOTO Inicio
END IF
 
e = e + 1 'Solucion en pantalla
LOCATE 2, 18
PRINT "**"; e; "**";
LOCATE 24, 15
PRINT " Pulse INTRO ";
GOSUB Teclado
GOTO Anterior 'Si no se pulsa ESCAPE, busca mas soluciones
 
Teclado:
IF INKEY$ <> "" GOTO Teclado 'Limpia pulsaciones
a$ = ""
WHILE a$ = ""
    a$ = INKEY$
WEND
IF a$ = CHR$(27) THEN SYSTEM
RETURN
'Sudoku dificil
DATA 5,0,2,0,0,0,0,0,0
DATA 0,0,0,0,6,0,9,0,0
DATA 0,0,0,0,0,0,0,0,0
DATA 0,4,1,0,0,7,0,0,0
DATA 0,0,0,5,0,0,0,6,0
DATA 0,0,5,0,0,2,0,0,0
DATA 0,9,7,0,8,5,0,0,0
DATA 0,0,0,0,0,0,0,3,5
DATA 0,5,4,0,0,0,0,9,6



Comentarios sobre la versión: 1.5 (1)

Imágen de perfil
sol karina
Hace 2d
estrellaestrellaestrellaestrellaestrella
excelente codigo
Responder

Comentar la versión: 1.5

Nombre
Correo (no se visualiza en la web)
Valoración
Comentarios

http://lwp-l.com/s3664