Pascal/Turbo Pascal - SOLITARIO EN PASCAL

   
Vista:

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 23/02/2015 10:33:17
He estado mirando este programa de 1º de Ingenieria Tecnica en Informatica de Sistemas.
Y me compila y lo ejecuto, pero me gustaria que lo probarais.
Saca cartas del monton de reserva y coloca una carta en cada monton de trabajo pero no
consigo que reorganice cartas. ¿Por que puede ser? ¿Alguien puede ayudarme?

Despues de barajar las 40 cartas de la baraja española, se descubren 4 cartas. sobre
estas 4 cartas se van a ir formando montones ordenados decrecientemente,c on numeros
correlativosy dos cartas comunes nunca pueden pertenecer al mismo palo. 4 montones de trabajo.

Simultaneamente se pueden ir formando otros 4 montones de formación empezando por el as
del palo y añadiendo cartas orrrelativas (mismo palo y numero inmediato superior)

Despues de barajar y descubrir las 4 primeras cartas. del monton de reserva solo es
accesible la carta situada encima. Este es el monton de reserva

En cualquier momento se pueden reorganizar la cartas en los montones, llevando una
carta de un monton a otro, siempre que se mantenga la naturaleza de cada uno. de cada
monton, cada vez solo sera accesible la ultima carta que entro en el. este proceso se puede
realizar las veces que se quiera.

el juego finaliza cuando se hayan formado los cuatro montones ordenados de cada palo, sea
imposible seguir realizando jugadas o no se quiera continuar jugando.

Acciones permitidas en el juego:

- Iniciar el juego, barajar y colocar cada una de las cuatro primeras cartas en cdad monton
de trabajo

- Sacar la siguiente carta de la baraja al monton de reserva

- Reorganizar montones
- Del monton de reserva a un monton de trabajo
- dEL monton de reserva a un monton de formacion
- de un monton de trabajoa otro
- de un monton de trabajo a un monton de formacion
- de un monton de formacion a un monton de trabajo.

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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
PROGRAM SOLITARIO (Input,Output);
Uses CRT;
Type
  T_Palo = (Oros,Copas,Bastos,Espadas);
  T_Numero = 0..12;
  Carta = RECORD
            Numero:T_Numero;
            Palo:T_Palo;
            Flag:Boolean
          END;
  T_Reserva = Array [1..36] of Carta;
  T_Monton = Array [1..4,1..10] of Carta;
  T_Baraja = Array [1..40] of Carta;
 
Var
  MReserva:T_Reserva;
  MT,MF: T_Monton;
  Baraja:T_Baraja;
  c1,c2,c3,c4,co,cc,cb,ce,cr,cba,sit:Integer;
  Terminar : Boolean;
  Opcion,caracter:Char;
 
PROCEDURE Limpiar_pantalla;
(*Procedimiento para limpiar la pantalla*)
VAR
 Cont:Integer;
BEGIN
  FOR Cont:= 1 TO 24 DO
    Writeln;
END;
 
PROCEDURE Eliminar_Mtf(VAR M:T_Monton;Fila:Integer);
(* Elimina la primera posición de una de las filas de la tabla *)
(* bidimensional que actua como montón de trabajo ó de formación *)
VAR
  Cont:Integer;
BEGIN
  FOR Cont:=1 TO 9 DO
    M[Fila,Cont] := M[Fila,Cont+1];
  M[1,10].Numero := 0
END;
 
PROCEDURE Eliminar_baraja (VAR B1:T_Baraja);
(* Elimina una carta de la Baraja, poniendo la carta Nº 40 a cero. *)
VAR
  Cont:Integer;
BEGIN
  FOR Cont:= 1 TO 39 DO
    B1[Cont] := B1[Cont+1];
  B1[40].Numero := 0;
  B1[40].Flag := false;
END;
 
PROCEDURE Inicializar_Baraja(VAR B2:T_Baraja);
(* Coloca todas las cartas a valor Numero=0 y Flag=False *)
VAR
  Cont:Integer;
BEGIN
  FOR Cont := 1 TO 40 DO
  BEGIN
    B2[Cont].Numero := 0;
    B2[Cont].Flag := false
  END;
END;
 
PROCEDURE Barajar (VAR Bar:T_Baraja;VAR Matriz:T_Monton);
(* Barajar la barja y colocar cada una de las cuatro primeras *)
(* cartas de la baraja en cada montón de trabajo. *)
VAR
  I,J,Cont:Integer;
  Contador:T_Palo;
  Num:1..40;
 
BEGIN
   Randomize;
   Gotoxy(1,1);
   Inicializar_baraja(Bar);
   Cont := 0;
   FOR Contador := Oros TO Espadas DO
   BEGIN
     I:= 1;
     REPEAT
       Num := Random(41);
       IF (Bar[Num].Flag = False) AND (Num<>0)
       THEN BEGIN
              Bar[Num].Numero := 1;
              Bar[Num].Palo := Contador;
              Bar[Num].Flag := True;
              Cont := Cont +1;
              I:=I+1;
            END;
     UNTIL I=8;
 
     J:=10;
     REPEAT
       Num:= Random(41);
       IF(Bar[Num].Flag = False) AND (Num<>0)
       THEN BEGIN
              Bar[Num].Numero := J;
              Bar[Num].Palo := Contador;
              Bar[Num].Flag := True;
              Cont := Cont+1;
              J:=J+1
            END;
     UNTIL J= 13;
   END;
 
(* Colocacion de las 4 primeras cartas de la baraja en cada montón de trabajo *)
FOR Cont := 1 TO 4 DO
BEGIN
  Matriz[Cont,1].Numero := Bar[Cont].Numero;
  Matriz[Cont,1].Palo := Bar[Cont].Palo
END;
 
FOR Cont:=1 TO 4 DO
  Eliminar_baraja(Bar);
 
END; (*BARAJAR*)
 
PROCEDURE Mtrabajo (VAR ct_m,ctador: Integer: M1:T_Monton);
(* Escritura tanto de los montones de formación como de trabajo *)
BEGIN
  Write(M1[ct_m,ctador].Numero)
  CASE M1[ct_m,ctador].Palo OF
    Oros: Writeln('Oros');
    Copas: Writeln('Copas');
    Bastos:Writeln('Bastos');
    Espadas:Writeln('Espadas');
  END;
END;
 
PROCEDURE Mformacion(VAR cont_m,contador:Integer; M2:T_Monton);
(*Escritura tanto de los montones de formación como de trabajo *)
BEGIN
  Write(M2[cont_m,contador].Numero);
  CASE M2[cont_m,contador].Palo OF
    Oros: Writeln('Oros');
    Copas: Writeln('Copas');
    Bastos: Writeln('Bastos');
    Espadas: Writeln('Espadas');
  END;
END;
 
PROCEDURE Situacion (Mtrab,Mform:T_Monton;Mfreserva:T_Reserva;Mfbaraja:T_Baraja;VAR cuenta:Integer);
(* A partir del cual imprimiremos en OUTPUT la representación gráfica de la cartas que se encuentran *)
(* en cada montón, al igual que le menu de opciones que se encontrará al final dela ejecución de dicho *)
(* Procedimiento. *)
VAR
  I,J,K,L,M,N,NY,O,P,Q,R,m1,m2,m3,m4:Integer;
  Cont,cont1,cont2,cont3,cont4,cont5,cont6,cont7,cont8,cont9:Integer;
BEGIN
  Gotoxy(1,1);
  Textcolor(Blue);
  Writeln('Situacion',cuenta);
  Writeln;
  Textcolor(Red);
  GotoXY(8,3); Write('Monton 1');
  GotoXY(27,3); Write('Monton 2');
  GotoXY(45,3); Write('Monton 3');
  GotoXY(63,3); Write('Monton 4');
  K:= 5;L:=5;M:= 5;N:= 5;
 
  FOR Cont:=3 DOWNTO 1 DO
    IF Mtrab[m1,Cont].Numero<>0
    THEN BEGIN
           Gotoxy(8,K);
           Mtrabajo(m1,Cont,Mtrab);
           K := K+1;
         END;
 
  FOR Cont:=3 DOWNTO 1 DO
    IF Mtrab[m2,Cont].Numero<>0
    THEN BEGIN
           Gotoxy(27,L);
           Mtrabajo(m2,Cont,Mtrab);
           L := L+1;
         END;
 
  FOR Cont:=3 DOWNTO 1 DO
    IF Mtrab[m3,Cont].Numero<>0
    THEN BEGIN
           Gotoxy(45,K);
           Mtrabajo(m3,Cont,Mtrab);
           M := M+1;
         END;
 
  FOR Cont:=3 DOWNTO 1 DO
    IF Mtrab[m4,Cont].Numero<>0
    THEN BEGIN
           Gotoxy(63,N);
           Mtrabajo(m4,Cont,Mtrab);
           N := N+1;
         END;
 
Textcolor(Yellow);
Gotoxy(8,9); Write('Oros');
Gotoxy(27,9); Write('Copas');
Gotoxy(45,9); Write('Espadas');
Gotoxy(63,9); Write('Bastos');
NY := 11;0:= 11;P:=11;Q:= 11;
 
FOR Cont:= 3 DOWNTO 1 DO
  IF Mform[m1,Cont].Numero<>0
  THEN BEGIN
         Gotoxy(8,NY);
         Mformacion(m1,Cont,Mform);
         NY := NY+1;
       END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
  IF Mform[m2,Cont].Numero<>0
  THEN BEGIN
         Gotoxy(27,O);
         Mformacion(m2,Cont,Mform);
         O := O+1;
       END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
  IF Mform[m3,Cont].Numero<>0
  THEN BEGIN
         Gotoxy(45,P);
         Mformacion(m3,Cont,Mform);
         P := P+1;
       END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
  IF Mform[m4,Cont].Numero<>0
  THEN BEGIN
         Gotoxy(63,Q);
         Mformacion(m4,Cont,Mform);
         Q := Q+1;
       END;
 
Textcolor(Black);
Gotoxy(8,15); Writeln('Reserva');
R := 17;
 
FOR Cont:= 3 DOWNTO 1 DO
  IF Mfreserva[Cont].Numero <> 0
  THEN BEGIN
         Gotoxy(8,R);
         Write (Mfreserva[Cont].Numero);
         CASE Mfreserva[Cont].Palo OF
            Oros: Writeln('Oros');
            Copas: Writeln('Copas');
            Bastos:Writeln('Bastos');
            Espadas:Writeln('Espadas');
         END;
         R:= R+1;
  END;
 
END; (* Situacion *)
 
PROCEDURE Sacar_carta (VAR mb:T_Baraja; Var mr:T_Reserva)
(* Sacamos una carta de la baraja y la introducimos en el montón de *)
(* reserva, incrementando respectivamnete los contadores del montón de *)
(* baraja y reserva. *)
VAR
  Cont:Integer;
BEGIN
  mr[1].Numero := mb[1].Numero;
  mr[1].Palo := mb[1].Palo;
  Eliminar_baraja[mb];
  IF mr[1].Numero <> 0
  THEN BEGIN
         FOR Cont := 1 TO 9 DO
           mr[10].Numero :=  0;
       END
       ELSE
          Write('Ya no existen más cartas para sacar');
END;
 
PROCEDURE Reorganizar
VAR
  monton,p_monton:Char;
BEGIN
  Writeln('Pasar carta del montón 1,2,3,4,'O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA:');
  Read(monton);
  Writeln('al montón '1','2','3','4','O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA');
  Read(p_monton);
END;
 
BEGIN (* SOLITARIO *)
  Limpiar_pantalla;
  Textbackground(White);
  Terminar:=False;
  Barajar(Baraja,MT);
  sit:=1;
  WHILE NOT Terminar DO
  BEGIN
    Limpiar_pantalla;
    Situacion(MT,MF,MReserva,Baraja,sit);
    Gotoxy(1,21);
    Write(''S'acar carta,'R'eorganizar ó 'F'inalizar?'=;
    Read(Opcion);
    CASE Opcion OF
       'S','s':Sacar_carta(Baraja,MReserva);
       'R','r':Reorganizar;
       'F','f':Terminar:=True;
    END;
  END;
 
END.
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 24/02/2015 21:39:29
1
2
3
4
5
6
7
8
9
10
11
PROCEDURE Reorganizar
VAR
monton,p_monton:Char;
BEGIN
Writeln('Pasar carta del montón 1,2,3,4,'O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA:');
Read(monton);
Writeln('al montón '1','2','3','4','O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA');
Read(p_monton);
END;
 
{Esto por si solo no organiza nada solo toma datos }
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 25/02/2015 14:14:52
Ya te entiendo, pero Ramon el procedimiento situacion muestra las ultimas 3 cartas de cada monton de trabajo y formación. Podrias pasarme el codigo que crees que falta para reorganizar.

Muchisimas gracias.
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 25/02/2015 22:38:02
Sustituye esto.

1
2
3
4
5
6
7
8
9
10
11
PROCEDURE Reorganizar;
BEGIN
   Limpiar_pantalla;
   Textbackground(White);
   Terminar:=False;
   Barajar(Baraja,MT);
   fillchar(MReserva,sizeof(MReserva),0);
   sit:=1;
   delay(299);
   clrscr;
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

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 26/02/2015 12:10:08
Bueno, ante todo saber si eres !! Luis Ramon Alvarez Gonzalez, mi compañero de la Universidad ¡¡
De no serlo, también encantado.

Te paso el enunciado que se compone de 2 folios y 5 folios de una posible ejecución que plantearon
los profesores.

De todas maneras decirte que debe aparecer cuando quieres reorganizar los sgtes comentarios:

'Pasar carta del montón 1,2,3,4,'O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA:

al montón '1','2','3','4','O'ROS,'C'OPAS,'B'ASTOS,'E'SPADAS,'R'ESERVA
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 26/02/2015 12:30:32
Primero no soy la persona que comentas.
Segundo intentare revisar el anunciado y ayudarte en lo que pueda.
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

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 26/02/2015 23:07:41
Muchisimas gracias Ramon. ¿Tengo que pagarte algo?
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 27/02/2015 22:12:36
Intento ayudar a todo aquel que pueda y considero que el ayudar es gratis sino no seria ayuda sino negocio.
Con lo cual sabiendo que mi ayuda sirvió para que alguien aprenda estoy satisfecho.
Valora esta respuesta
Me gusta: Está respuesta es útil y esta claraNo me gusta: Está respuesta no esta clara o no es útil
1
Comentar

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 27/02/2015 23:16:41
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
{Ejecuta esto y mira las cartas que sean cargado}
 
PROGRAM SOLITARIO (Input,Output);
Uses CRT;
Type
T_Palo = (Oros,Copas,Bastos,Espadas);
T_Numero = 0..12;
Carta = RECORD
Numero:T_Numero;
Palo:T_Palo;
Flag:Boolean
END;
T_Reserva = Array [1..36] of Carta;
T_Monton = Array [1..4,1..10] of Carta;
T_Baraja = Array [1..40] of Carta;
 
Var
MReserva:T_Reserva;
MT,MF: T_Monton;
Baraja:T_Baraja;
coo,nn, c1,c2,c3,c4,co,cc,cb,ce,cr,cba,sit:Integer;
Terminar : Boolean;
Opcion,caracter:Char;
pal : string[7];
 
PROCEDURE Limpiar_pantalla;
(*Procedimiento para limpiar la pantalla*)
VAR
Cont:Integer;
BEGIN
FOR Cont:= 1 TO 24 DO
Writeln;
END;
 
PROCEDURE Eliminar_Mtf(VAR M:T_Monton;Fila:Integer);
(* Elimina la primera posición de una de las filas de la tabla *)
(* bidimensional que actua como montón de trabajo ó de formación *)
VAR
Cont:Integer;
BEGIN
FOR Cont:=1 TO 9 DO
M[Fila,Cont] := M[Fila,Cont+1];
M[1,10].Numero := 0
END;
 
PROCEDURE Eliminar_baraja (VAR B1:T_Baraja);
(* Elimina una carta de la Baraja, poniendo la carta Nº 40 a cero. *)
VAR
Cont:Integer;
BEGIN
FOR Cont:= 1 TO 39 DO
B1[Cont] := B1[Cont+1];
B1[40].Numero := 0;
B1[40].Flag := false;
END;
 
PROCEDURE Inicializar_Baraja(VAR B2:T_Baraja);
(* Coloca todas las cartas a valor Numero=0 y Flag=False *)
VAR
Cont:Integer;
BEGIN
FOR Cont := 1 TO 40 DO
BEGIN
B2[Cont].Numero := 0;
B2[Cont].Flag := false
END;
END;
 
PROCEDURE Barajar (VAR Bar:T_Baraja;VAR Matriz:T_Monton);
(* Barajar la barja y colocar cada una de las cuatro primeras *)
(* cartas de la baraja en cada montón de trabajo. *)
VAR
I,J,Cont:Integer;
Contador:T_Palo;
Num:1..40;
 
BEGIN
Randomize;
Gotoxy(1,1);
Inicializar_baraja(Bar);
Cont := 0;
FOR Contador := Oros TO Espadas DO
BEGIN
I:= 1;
REPEAT
Num := Random(41);
IF (Bar[Num].Flag = False) AND (Num<>0)
THEN BEGIN
Bar[Num].Numero := 1;
Bar[Num].Palo := Contador;
Bar[Num].Flag := True;
Cont := Cont +1;
I:=I+1;
END;
UNTIL I=8;
 
J:=10;
REPEAT
Num:= Random(41);
IF(Bar[Num].Flag = False) AND (Num<>0)
THEN BEGIN
Bar[Num].Numero := J;
Bar[Num].Palo := Contador;
Bar[Num].Flag := True;
Cont := Cont+1;
J:=J+1
END;
UNTIL J= 13;
END;
 
(* Colocacion de las 4 primeras cartas de la baraja en cada montón de trabajo *)
FOR Cont := 1 TO 4 DO
BEGIN
Matriz[Cont,1].Numero := Bar[Cont].Numero;
Matriz[Cont,1].Palo := Bar[Cont].Palo
END;
 
FOR Cont:=1 TO 4 DO
Eliminar_baraja(Bar);
 
END; (*BARAJAR*)
 
PROCEDURE Mtrabajo (VAR ct_m,ctador: Integer; M1:T_Monton);
(* Escritura tanto de los montones de formación como de trabajo *)
BEGIN
Write(M1[ct_m,ctador].Numero);
CASE M1[ct_m,ctador].Palo OF
Oros: Writeln('Oros');
Copas: Writeln('Copas');
Bastos:Writeln('Bastos');
Espadas:Writeln('Espadas');
END;
END;
 
PROCEDURE Mformacion(VAR cont_m,contador:Integer; M2:T_Monton);
(*Escritura tanto de los montones de formación como de trabajo *)
BEGIN
Write(M2[cont_m,contador].Numero);
CASE M2[cont_m,contador].Palo OF
Oros: Writeln('Oros');
Copas: Writeln('Copas');
Bastos: Writeln('Bastos');
Espadas: Writeln('Espadas');
END;
END;
 
PROCEDURE Situacion (Mtrab,Mform:T_Monton;Mfreserva:T_Reserva;Mfbaraja:T_Baraja;VAR cuenta:Integer);
(* A partir del cual imprimiremos en OUTPUT la representación gráfica de la cartas que se encuentran *)
(* en cada montón, al igual que le menu de opciones que se encontrará al final dela ejecución de dicho *)
(* Procedimiento. *)
VAR
I,J,K,L,M,N,NY,O,P,Q,R,m1,m2,m3,m4:Integer;
Cont,cont1,cont2,cont3,cont4,cont5,cont6,cont7,cont8,cont9:Integer;
BEGIN
Gotoxy(1,1);
Textcolor(Blue);
Writeln('Situacion',cuenta);
Writeln;
Textcolor(Red);
GotoXY(8,3); Write('Monton 1');
GotoXY(27,3); Write('Monton 2');
GotoXY(45,3); Write('Monton 3');
GotoXY(63,3); Write('Monton 4');
K:= 5;L:=5;M:= 5;N:= 5;
 
FOR Cont:=3 DOWNTO 1 DO
IF Mtrab[m1,Cont].Numero<>0
THEN BEGIN
Gotoxy(8,K);
Mtrabajo(m1,Cont,Mtrab);
K := K+1;
END;
 
FOR Cont:=3 DOWNTO 1 DO
IF Mtrab[m2,Cont].Numero<>0
THEN BEGIN
Gotoxy(27,L);
Mtrabajo(m2,Cont,Mtrab);
L := L+1;
END;
 
FOR Cont:=3 DOWNTO 1 DO
IF Mtrab[m3,Cont].Numero<>0
THEN BEGIN
Gotoxy(45,K);
Mtrabajo(m3,Cont,Mtrab);
M := M+1;
END;
 
FOR Cont:=3 DOWNTO 1 DO
IF Mtrab[m4,Cont].Numero<>0
THEN BEGIN
Gotoxy(63,N);
Mtrabajo(m4,Cont,Mtrab);
N := N+1;
END;
 
Textcolor(Yellow);
Gotoxy(8,9); Write('Oros');
Gotoxy(27,9); Write('Copas');
Gotoxy(45,9); Write('Espadas');
Gotoxy(63,9); Write('Bastos');
NY := 11;o:= 11;P:=11;Q:= 11;
 
FOR Cont:= 3 DOWNTO 1 DO
IF Mform[m1,Cont].Numero<>0
THEN BEGIN
Gotoxy(8,NY);
Mformacion(m1,Cont,Mform);
NY := NY+1;
END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
IF Mform[m2,Cont].Numero<>0
THEN BEGIN
Gotoxy(27,O);
Mformacion(m2,Cont,Mform);
O := O+1;
END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
IF Mform[m3,Cont].Numero<>0
THEN BEGIN
Gotoxy(45,P);
Mformacion(m3,Cont,Mform);
P := P+1;
END;
 
 
FOR Cont:= 3 DOWNTO 1 DO
IF Mform[m4,Cont].Numero<>0
THEN BEGIN
Gotoxy(63,Q);
Mformacion(m4,Cont,Mform);
Q := Q+1;
END;
 
Textcolor(Black);
Gotoxy(8,15); Writeln('Reserva');
R := 17;
 
FOR Cont:= 3 DOWNTO 1 DO
IF Mfreserva[Cont].Numero <> 0
THEN BEGIN
Gotoxy(8,R);
Write (Mfreserva[Cont].Numero);
CASE Mfreserva[Cont].Palo OF
Oros: Writeln('Oros');
Copas: Writeln('Copas');
Bastos:Writeln('Bastos');
Espadas:Writeln('Espadas');
END;
R:= R+1;
END;
 
END; (* Situacion *)
 
PROCEDURE Sacar_carta (VAR mb:T_Baraja; Var mr:T_Reserva);
(* Sacamos una carta de la baraja y la introducimos en el montón de *)
(* reserva, incrementando respectivamnete los contadores del montón de *)
(* baraja y reserva. *)
VAR
Cont:Integer;
BEGIN
mr[1].Numero := mb[1].Numero;
mr[1].Palo := mb[1].Palo;
Eliminar_baraja(mb);
IF mr[1].Numero <> 0
THEN BEGIN
FOR Cont := 1 TO 9 DO
mr[10].Numero := 0;
END
ELSE
Write('Ya no existen más cartas para sacar');
END;
 
PROCEDURE Reorganizar;
VAR
monton,p_monton:Char;
BEGIN
Writeln('Pasar carta del montón 1,2,3,4,O ROS, C OPAS, B ASTOS, E SPADAS, R ESERVA:');
Read(monton);
Writeln('al montón 1   2   3   4   O ROS  C OPAS  B ASTOS  E SPADAS  R ESERVA');
Read(p_monton);
END;
 
BEGIN (* SOLITARIO *)
TextMode(C80 + Font8x8);
Limpiar_pantalla;
 
Terminar:=False;
Barajar(Baraja,MT);
sit:=1;
clrscr;
Textbackground(0);
for nn := 4 downto 1 do
 begin
   case nn of
 4 : pal := 'Espadas';
 3 : pal := 'Bastos';
 2 : pal := 'Copas';
 1 : pal := 'Oros';
   end;
   for coo := 1 to 10 do
   begin
      writeln('  ',baraja[coo].numero,'   ',pal,'   ',baraja[coo].flag);
   end;
  end;
 readkey;
 Textbackground(White);
 clrscr;
WHILE NOT Terminar DO
BEGIN
Limpiar_pantalla;
Situacion(MT,MF,MReserva,Baraja,sit);
Gotoxy(1,21);
Write(' S acar carta  R eorganizar  F inalizar');
Read(Opcion);
CASE Opcion OF
'S','s':Sacar_carta(Baraja,MReserva);
'R','r':Reorganizar;
'F','f':Terminar:=True;
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
1
Comentar

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 28/02/2015 16:56:09
No se preocupe, no se moleste más. Fué una práctica de 1º de Carrera que aprobe o me aprobaron.
Ya preguntaré a algun compañero mio por si ellos la tienen echa.

Tan solo indicarle que se muestran algunas cartas con valor a true que me imagino son las cartas que van apareciendo en la baraja, pero sigue sin reorganizar.

En un ejecucion se mostraron las sgts cartas:

1 Espadas TRUE
10 Espadas TRUE
1 Espadas TRUE
1 Espadas TRUE
1 Espadas TRUE
1 Espadas TRUE
10 Espadas TRUE
12 Espadas TRUE
1 Espadas TRUE
1 Bastos TRUE
10 Bastos TRUE
1 Bastos TRUE
1 Bastos TRUE
1 Bastos TRUE
1 Bastos TRUE
10 Bastos TRUE
12 Bastos TRUE
1 Bastos TRUE
1 Copas TRUE
10 Copas TRUE
1 Copas TRUE
1 Copas TRUE
1 Copas TRUE
1 Copas TRUE
10 Copas TRUE
12 Copas TRUE
1 Copas TRUE
1 Oros TRUE
10 Oros TRUE
1 Oros TRUE
1 Oros TRUE
1 Oros TRUE
1 Oros TRUE
10 Oros TRUE
10 Oros TRUE
12 Oros TRUE
1 Oros TRUE

>Tambien indicarle que en el procedimiento Reorganizar, habria que poner en lugar de 2 Read, 2 Readln.

>No pasa un 1 Oros del monton de reserva al monton de Oros ó un 11 de Bastos a un montón de formación

>¿Como me indica usted la introducción de caracteres?

Para sacar carta, poner S ó s

Suponiendo haya salido 1 Espadas

Para reorganizar, poner R ó r mostrar el texto 'Pasar carta del montón 1,2,3,4,O ROS, C OPAS, B ASTOS, E SPADAS, R ESERVA' y poner por ejemplo una R ó r
al montón 1 2 3 4 O ROS C OPAS B ASTOS E SPADAS R ESERVA E

Para finalizar, poner f
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 28/02/2015 20:55:18
Eso es lo que quería que vieras que no esta bien creadas las cartas.

para poder ayudar primero tengo que ver como esta echo el programa y luego sabre que arreglar. eso era para informarte
de los fallos que salen.
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

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 01/03/2015 20:55:38
Hola Ramon, en el proceso Barajar ahi un error la sentencia Bar[Num].Numero := 1 no es correcta.

Seria Bar[Num].Numero := I;
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 01/03/2015 22:00:15
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
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
{Mira esto creo te ayudara }
 
program solitario;
 uses
    crt;
  const
      elpalo : array[1..4] of string[7] = ('Oros','Espadas','Copas','Vastos');
  type
     carta = record
              palo : string[7];
              nume : integer;
           end;
     labaraja = array[1..4,1..10] of carta;
     eljuego = array[1..4,1..10] of carta;
     elmonton = array[1..40] of carta;
 
   var
   monton : elmonton;
   baraja : labaraja;
   juego : eljuego;
   reset : elmonton;
   m1, m2, m3, m4, res, cont, h, t, m : integer;
   tecla : char;
   azti : boolean;
 
   procedure limpiado_inicio;
   begin
      fillchar(monton,sizeof(monton),0);
      fillchar(baraja,sizeof(baraja),0);
      fillchar(juego,sizeof(juego),0);
      fillchar(reset,sizeof(reset),0);
   end;
 
   procedure crea_cartas(var cc : labaraja);
   var
     esta : boolean;
   begin
      for cont := 1 to 4 do
      begin
         h := 1;
         repeat
             t := random(40) + 1;
             case t of
           1..10 : t := t;
          11..20 : t := t - 10;
          21..30 : t := t - 20;
          31..40 : t := t - 30;
              end;
          case t of
        8 : t := 10;
        9 : t := 11;
       10 : t := 12;
           end;
             esta := false;
             for m := h - 1 downto 1 do
             begin
             if cc[cont,m].nume = t then
             begin
             esta := true;
             break;
             end;
             end;
             if esta = false then
             begin
                if t <= 7 then
                cc[cont,h].nume := t;
                if t > 7 then
                begin
                  case t of
                10 : cc[cont,h].nume := 10;
                11 : cc[cont,h].nume := 11;
                12 : cc[cont,h].nume := 12;
                  end;
                end;
                cc[cont,h].palo := elpalo[cont];
                h := h + 1;
                t := 0;
             end;
         until h > 10;
      end;
   end;
 
    procedure ordena(var nn : labaraja);
    var
      k, y, x : integer;
      auxi : carta;
    begin
       for y := 1 to 4 do
       begin
           for k := 1 to 10 do
            for x := k + 1 to  10 do
            if nn[y,x].nume < nn[y,k].nume then
            begin
               auxi := nn[y,x];
               nn[y,x] := nn[y,k];
               nn[y,k] := auxi;
            end;
       end;
    end;
 
   procedure  barajear;
   var
     m1, n2, p, v1, r2 : integer;
    begin
        p := 1;
        m1 := 1;
        n2 := 5;
    repeat
        v1 := m1;
        r2 := n2;
      repeat
          monton[p] := baraja[v1,r2];
          p := p + 1;
          r2 := r2 - 1;
          v1 := v1 + 1;
      until v1 > 4;
      m1 := m1 + 1;
      n2 := n2 + 1;
      if n2 > 10 then
      n2 := 1;
      if m1 > 4 then
      m1 := 1;
    until p > 40;
    end;
 
  procedure ponestado_juego(h : eljuego; dd : integer);
  var
    z, v, n : integer;
  begin
     for z := 1 to 4 do
     begin
    case z of
 1 : n := 10;
 2 : n := 24;
 3 : n := 38;
 4 : n := 52;
   end;
       for v := 1 to 10 do
       begin
       if (h[z,v].nume > 0) and (h[z,v].palo > '') then
       begin
          gotoxy(n,7 + v);clreol;
          gotoxy(n,7 + v);write(h[z,v].nume,' ',h[z,v].palo);
       end
    else
       begin
          gotoxy(n,7 + v);write('----------');
       end;
     end;
   end;
      if (reset[dd].nume > 0) and (reset[dd].palo > '') then
      begin
      gotoxy(66,7 + dd);clreol;
      gotoxy(66,7 + dd);write(reset[dd].nume,'   ',reset[dd].palo);
      end
    else
       begin
        gotoxy(66,7);write('__________');
      end;
  end;
 
   procedure presenta_pantalla;
   begin
      clrscr;
      gotoxy(12,2);write('****** El Juego Del Solitario ******');
      gotoxy(12,3);write('ÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ');
      gotoxy(11,5);write('Mt. 1         Mt. 2         Mt. 3         Mt. 4   ');
      gotoxy(11,6);write('Oros          Copas         Bastos        Espadas ');
      gotoxy(68,6);write('Reserva');
      ponestado_juego(juego,res);
   end;
 
  procedure pon_cartas_inicio;
  begin
     gotoxy(10,8);write('            ');
     gotoxy(10,8);write(monton[1].nume,'  ',monton[1].palo);
     juego[1,1] := monton[1];
     gotoxy(24,8);write('            ');
     gotoxy(24,8);write(monton[2].nume,'  ',monton[2].palo);
     juego[2,1] := monton[2];
     gotoxy(38,8);write('            ');
     gotoxy(38,8);write(monton[3].nume,'  ',monton[3].palo);
     juego[3,1] := monton[3];
     gotoxy(52,8);write('            ');
     gotoxy(52,8);write(monton[4].nume,'  ',monton[4].palo);
     juego[4,1] := monton[4];
     m1 := 1;
     m2 := 1;
     m3 := 1;
     m4 := 1;
  end;
 
  procedure reorganiza;
  var
    mt1, mt2 : char;
    dato1 : eljuego;
  begin
     gotoxy(2,28);write('Sacar Del Monton [1, 2, 3, 4, R] = ',
                            'Oros, Copas, Bastos, Espadas, Reserva');
     gotoxy(75,28);readln(mt1);
     gotoxy(2,29);write('Al Monton [1, 2, 3, 4, R] = ',
                            'Oros, Copas, Bastos, Espadas, Reserva');
     gotoxy(68,29);readln(mt2);
     fillchar(dato1[1,1],sizeof(dato1[1,1]),0);
     case mt1 of
  '1' : begin
          if m1 > 0 then
          begin
          dato1[1,1] := juego[1,m1];
          fillchar(juego[1,m1],sizeof(juego[1,m1]),0);
          m1 := m1 - 1;
          if m1 < 0 then
          m1 := 0;
          end;
        end;
  '2' : begin
          if m2 > 0 then
          begin
          dato1[1,1] := juego[2,m2];
          fillchar(juego[2,m2],sizeof(juego[2,m2]),0);
          m2 := m2 - 1;
          if m2 < 0 then
          m2 := 0;
          end;
        end;
  '3' : begin
          if m3 > 0 then
          begin
          dato1[1,1] := juego[3,m3];
          fillchar(juego[3,m3],sizeof(juego[3,m3]),0);
          m3 := m3 - 1;
          if m3 < 0 then
          m3 := 0;
          end;
        end;
  '4' : begin
          if m4 > 0 then
          begin
          dato1[1,1] := juego[4,m4];
          fillchar(juego[4,m4],sizeof(juego[4,m4]),0);
          m4 := m4 - 1;
          if m4 < 0 then
          m4 := 0;
          end;
        end;
  'R','r' : begin
             if res > 0 then
             begin
             dato1[1,1] := reset[res - 1];
             fillchar(reset[res - 1],sizeof(reset[res - 1]),0);
             res := res - 1;
             if res < 0 then
             res := 0;
            end;
        end;
    end;
     case mt2 of
  '1' : begin
          if m1 < 10 then
          begin
             m1 := m1 + 1;
             juego[1,m1] := dato1[1,1];
          end;
        end;
  '2' : begin
          if m2 < 10 then
          begin
            m2 := m2 + 1;
            juego[2,m2] := dato1[1,1];
          end;
        end;
  '3' : begin
          if m3 < 10 then
          begin
             m3 := m3 + 1;
             juego[3,m3] := dato1[1,1];
          end;
        end;
  '4' : begin
          if m4 < 10 then
          begin
             m4 := m4 + 1;
             juego[4,m4] := dato1[1,1];
          end;
        end;
  'R','r' : begin
              if res < 40 then
              begin
                res := res + 1;
                reset[res] := dato1[1,1];
              end;
            end;
     end;
     gotoxy(2,28);clreol;
     gotoxy(2,29);clreol;
     ponestado_juego(juego,res);
  end;
 
 
  procedure saca_carta;
  begin
     if azti = true then
     begin
       reset[res] := monton[cont - 1];
       azti := false;
     end;
     gotoxy(10,18);clreol;
     gotoxy(10,18);write(monton[cont].nume,'   ',monton[cont].palo);
     cont := cont + 1;
  end;
 
  procedure menu;
  var
     salir : boolean;
   begin
      clrscr;
      m1 := 0;
      m2 := 0;
      m3 := 0;
      m4 := 0;
      limpiado_inicio;
      crea_cartas(baraja);
      ordena(baraja);
      barajear;
      presenta_pantalla;
      pon_cartas_inicio;
      salir := false;
      azti := false;
      res := 1;
      cont := 5;
    repeat
        textcolor(10);
        gotoxy(28,19);write('Menu Solitario');
        gotoxy(14,21);write('[S]=sacar carta   [R]=reorganizar   [F]=finalizar');
        gotoxy(28,23);write('Elija Opcion');
        textcolor(7);
        repeat
        tecla := upcase(readkey);
        until tecla in['S','R','F'];
     case tecla of
  'S' : begin
          saca_carta;
          azti := true;
          ponestado_juego(juego,res);
          res := res + 1;
        end;
  'R' : reorganiza;
  'F' : salir := true;
    end;
    until salir = true;
      end;
 
 
 
   begin
      menu;
   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

SOLITARIO EN PASCAL

Publicado por Jose Miguel (7 intervenciones) el 02/03/2015 19:42:35
He probado el programa y queda muy bonito, realiza el proceso de reorganización también, pero no reorganiza del monton de reserva a la hora de sacar carta a los montones de Oros, Copas, Bastos y Espadas ó por lo menos no lo muestra en pantalla.

También quería comentarle a usted, que el programa tiene residuos, puesto que haria falta creo yo un procedimiento que refrescará los montones de trabajo puesto que llega un momento que no se pueden ver las cartas de los montones de formación (Oros, Copas, Espadas y Bastos)

Muy buen trabajo !!!
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

SOLITARIO EN PASCAL

Publicado por ramon (2072 intervenciones) el 02/03/2015 21:47:47
Fíjate que es un ejemplo para que tu lo termines como tu creas yo no lo aria con arrays sino con pilas por lo tanto solo
intento indicarte el camino.
Ni necesitas mas ayuda dime lo suerte.
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