à 2048 en Basic

Les derniers trucs auxquels vous avez joué, les derniers ordinateurs que vous avez bidouillés.

Modérateur : Politburo

Répondre
Avatar du membre
ledudu
Fonctionne à 14400 bauds
Fonctionne à 14400 bauds
Messages : 5633
Enregistré le : 26 mars 2009 13:07
Localisation : Ile de France
Contact :

à 2048 en Basic

Message par ledudu »

Le 2048 est un jeu à portée de nos pockets, du moment qu'ils aient les 4 lignes nécessaires.
L'intérêt de l'exercice consiste à optimiser la partie résolution afin que le temps de réponse reste jouable.
Programme entier

Image

Après quelques heures que le week-end pascal a rendu possibles, voici mon programme :
Initialisations :
A() : matrice des valeurs - B() et C() : utilisés pour le traitement d'une ligne de la matrice.
T servira à détecter qu'au moins une des valeurs a été modifiée (sinon, aucun nouveau chiffre n’apparaît).
N : nombre de coups - P : nombre de points
B : option pour émettre en Beep lorsque la machine est dispo pour la commande suivante
C=26 : position d'impression des points.

Code : Tout sélectionner

1 REM ****************
2 REM ***** 2048 *****
3 REM ****************
5 CLEAR
10 ERASE A,B,C:DIM A(5,5),B(5),C(5)
20 N=0:P=0:C=26:B=0:ANGLE 0:T=2
50 GOSUB 950: GOSUB 900
Attente de la commande : les flèches pour jouer et option B .

Code : Tout sélectionner

100 REM BOUCLE DE JEU
105 REM INITIALISATION AVEC DEUX 2
110 GOSUB 1000
120 IF T>1 THEN GOSUB 900
130 K$=INKEY$
140 IF K$="B" OR K$="b" THEN B=1-B:BEEP:ANGLE B
150 IF ASC(K$)<28 OR ASC(K$)>31 THEN GOTO 130
155 IN=0:T=0
160 ON ASC(K$)-27 GOSUB 500,600,800,700
170 GOTO 100
Flèche droite : pour chaque ligne de la matrice A(), on stocke dans B() les valeurs cadrées à droite et on appelle le bloc 1200
Ainsi dans l'image, la deuxième ligne est stockée dans B ainsi (. 2 16 2). Le bloc 1200 ne changera rien dans ce cas.
Au retour on recadre à droite et on remet dans A().

Code : Tout sélectionner

500 REM JEU A DROITE
510 FOR I=1 TO 4:IN=1
520 REM Copie Cadree du Vecteur dans B
525 IF T=1 THEN T=0
530 MM=4:CC=1:FOR J=4 TO 1 STEP -1  :IF A(I,J)<>0 THEN B(MM)=A(I,J):MM=MM-1:IN=0:T=T*2 ELSE B(CC)=0:CC=CC+1:IF T=0 THEN T=1
535 NEXT J
537 IF IN=1 THEN GOTO 560
540 GOSUB 1200
550 MM=4:CC=1:FOR J=4 TO 1 STEP -1:IF B(J)<>0 THEN A(I,MM)=B(J):MM=MM-1 ELSE A(I,CC)=0:CC=CC+1
555 NEXT J
560 NEXT I
570 RETURN
Flèche gauche
Boucle sur les lignes cadrées à gauche

Code : Tout sélectionner

600 REM JEU A GAUCHE
610 FOR I=1 TO 4:IN=1
620 REM Copie Cadree du Vecteur dans B
625 IF T=1 THEN T=0
630 MM=1:CC=4:FOR J=1 TO 4 :IF A(I,J)<>0 THEN B(5-MM)=A(I,J):MM=MM+1:IN=0:T=T*2 ELSE B(5-CC)=0:CC=CC-1:IF T=0 THEN T=1
635 NEXT J
637 IF IN THEN 660
640 GOSUB 1200
650 MM=1:CC=4:FOR J=1 TO 4:IF B(5-J)<>0 THEN A(I,MM)=B(5-J):MM=MM+1 ELSE A(I,CC)=0:CC=CC-1
655 NEXT J
660 NEXT I
670 RETURN
Flèche haut
Boucle sur les colonnes cadrées en haut :la 4ème colonne de l'image est stockée dans B ainsi : (. 4 2 8 )

Code : Tout sélectionner

700 REM JEU en HAUT
710 FOR I=1 TO 4:IN=1
720 REM Copie Cadree du Vecteur dans B
725 IF T=1 THEN T=0
730 MM=4:CC=1:FOR J=4 TO 1 STEP -1:IF A(J,I)<>0 THEN B(MM)=A(J,I):MM=MM-1:IN=0:T=2*T ELSE B(CC)=0:CC=CC+1:IF T=0 THEN T=1
735 NEXT J
737 IF IN THEN 760
740 GOSUB 1200
750 MM=4:CC=1:FOR J=4 TO 1 STEP -1:IF B(J)<>0 THEN A(MM,I)=B(J):MM=MM-1 ELSE A(CC,I)=0:CC=CC+1
755 NEXT J
760 NEXT I
790 RETURN
Flèche bas
Boucle sur les colonnes cadrées en bas : la 4ème colonne de l'image est stockée dans B ainsi : (. 8 2 4)

Code : Tout sélectionner

800 REM JEU en BAS
805 IN=1
810 FOR I=1 TO 4:IN=1
820 REM Copie Cadree du Vecteur dans B
825 IF T=1 THEN T=0
830 MM=1:CC=4:FOR J=1 TO 4 :IF A(J,I)<>0 THEN B(5-MM)=A(J,I):MM=MM+1:IN=0:T=2*T ELSE B(5-CC)=0:CC=CC-1:IF T=0 THEN T=1
835 NEXT J
837 IF IN THEN 860
840 GOSUB 1200
850 MM=1:CC=4:FOR J=1 TO 4:IF B(5-J)<>0 THEN A(MM,I)=B(5-J):MM=MM+1 ELSE A(CC,I)=0:CC=CC-1
855 NEXT J
860 NEXT I
890 RETURN
Tirage aléatoire du nouveau chiffre suivant

Code : Tout sélectionner

900 REM TIRAGE ALEATOIRE
910 X=INT(RAN#*4+1):Y=INT(RAN#*4+1)
920 IF A(X,Y)<>0 THEN 910
930 A(X,Y)=2:N=N+1
935 LOCATE (Y-1)*6,X-1:PRINT " 2";
936 LOCATE C-LOG(N+1)/2,1:PRINT N
938 IF B=1 THEN BEEP
940 RETURN
Dessin initial du plateau

Code : Tout sélectionner

950 REM Preparation du plateau
952 CLS
955 DRAW (35,0)-(35,30)
960 DRAW (70,0)-(70,30)
965 DRAW (105,0)-(105,30)
970 DRAW (140,0)-(140,30)
980 LOCATE C,0:PRINT "Nbr:";
985 LOCATE C,2:PRINT "Pts:";
990 RETURN
Impression des chiffres à chaque tour

Code : Tout sélectionner

1000 REM Impression des chiffres
1020 FOR I=1 TO 4
1030 FOR J=1 TO 4
1035 P$="     "
1040 IF A(I,J)<>0 THEN P$=LEFT$(STR$(A(I,J))+"    " ,5)
1045 LOCATE (J-1)*6,I-1:PRINT P$;
1050 NEXT J
1060 NEXT I
1074 LOCATE C-LOG(P+1)/2,3:PRINT P;
1090 RETURN
Élimination des chiffres contigües égaux dans un vecteur B
(1 1 2 2) devient (. 2 . 4)
(1 1 . 3) devient (. 2 . 3)
Le cadrage à droite sera fait au moment de la recopie dans A()

Code : Tout sélectionner

1200 REM ELIMINATION
1220 FOR J=4 TO 2 STEP -1
1230 IF B(J)=B(J-1) AND B(J)<>0  THEN B(J)=B(J)*2:B(J-1)=0:P=P+B(J):T=2
1240 NEXT J
1260 RETURN
Modifié en dernier par ledudu le 30 mars 2016 08:04, modifié 1 fois.
Avatar du membre
Marge
Fonctionne à 14400 bauds
Fonctionne à 14400 bauds
Messages : 6172
Enregistré le : 01 oct. 2008 14:39
Localisation : En bas, tout au fond à gauche.

Re: à 2048 en Basic

Message par Marge »

Pas mal, ledudu, mais je n'ai pas compris le but du jeu. :oops:
3 hommes, 3 demis, un 3a... Magnéto, Serge !

Quelques-uns de mes petits programmes pour machines Hewlett-Packard :
15C : Knight's Tour ;
29C : (k-)Permutations, Combinations, Linear Regression and Pseudo-random number ;
34C : Hanoi Towers - Automatic & Manual resolutions ;
67
__: A L I E N .

« Boris », c'était juste Maurice enrhumé.
Avatar du membre
Hobiecat
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 3626
Enregistré le : 06 sept. 2011 14:57
Localisation : Normandie

Re: à 2048 en Basic

Message par Hobiecat »

Sympa ce programme Ledudu !
Marge a écrit :Pas mal, ledudu, mais je n'ai pas compris le but du jeu. :oops:
C'est un jeu qui a été très à la mode l'année passée sur les tablettes et autres smartphones. Voir les Explications de wikipedia par exemple :wink:
Avatar du membre
leglatin
Fonctionne à 1200 bauds
Fonctionne à 1200 bauds
Messages : 761
Enregistré le : 03 févr. 2003 19:46
Localisation : Berville-sur-Mer (27)
Contact :

Re: à 2048 en Basic

Message par leglatin »

Sympa :D !

(Je ne connaissais pas ce jeu non plus... :oops: )
Commodore 7970 - Texas Instruments TI-30, 57, 60, 66, 74, 76.fr, 80, 81, 82, 82 Stats.fr, 83, 85, 86, 89, 92 - Casio PB-100, PB-110, PB-410, PB-500, PB-700, PB-770, FX-180Pv, FX-7500G, FC-200, FA-3, FA-4, FA-5, FA-10, FA-11, FA-20, FP-12, CM-1, OR-1, OR-1(E), OR-4, OR-8, RC-2, RC-4 - Canon X-07 - Psion Series 5 mx - PalmOne Tungsten E2 - Compaq iPAQ H3900 - HP iPAQ HX2110 - Philips VG8020, NMS8255, VY0010, VY0011, VS0080, D6450, VW0030, SBC3810, NMS1112, NMS1150, NMS1170 - Atari 1040 STE
Avatar du membre
ledudu
Fonctionne à 14400 bauds
Fonctionne à 14400 bauds
Messages : 5633
Enregistré le : 26 mars 2009 13:07
Localisation : Ile de France
Contact :

Re: à 2048 en Basic

Message par ledudu »

J'ai réalisé hier que dans le jeu original, le nouveau chiffre apparaissant pouvait être un 2 ou un 4.
Selon ce blogger qui a vérifié dans le code source original du créateur, le 4 apparaît une fois sur 10.
Il faut que je change les lignes suivantes :

Code : Tout sélectionner

930 A(X,Y)=2-2*(RAN#>0.9):N=N+1
935 LOCATE (Y-1)*6,X-1:PRINT A(X,Y);
Avatar du membre
bernouilli92
Fonctionne à 14400 bauds
Fonctionne à 14400 bauds
Messages : 5229
Enregistré le : 21 nov. 2012 13:03
Localisation : Ile de France

Re: à 2048 en Basic

Message par bernouilli92 »

Il a l'air pas mal ton petit programme, plus concis que ce que j'avais fait à l'époque.
De mon coté j'affichais un 4 une fois sur deux. Je n'ai pas pensé à vérifier le code source du jeu original.

Voici le lien vers le post de l'époque :
www.silicium.org/forum/viewtopic.php?f=46&t=37086

Il y a une version pour PC1360 et pour PC-e500 dans le cloud de Pockemul. C'est jouable sur pc-e500 mais pas trop sur le PC1360 qui est trop lent.
il faudrait que je teste ton code sur le pc-e500 pour voir la différence. Ce sera l'occasion de tester l'interface USB pour pc-e500 que j'ai acheté il y a un moment déjà.
HP, Casio, Sharp, Psion, quelques TI et divers autres
Avatar du membre
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4642
Enregistré le : 31 oct. 2006 15:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 »

Merci bernouilli pour le rappel :)

A noter qu'il y a le code pour g850 dans ce fil, et mon code aléatoire pouor le 4 et le 2 donne également dans le 50/50 ;)

Il faudrait que je change les lignes 40 et 50.
Image
Image
Avatar du membre
ledudu
Fonctionne à 14400 bauds
Fonctionne à 14400 bauds
Messages : 5633
Enregistré le : 26 mars 2009 13:07
Localisation : Ile de France
Contact :

Re: à 2048 en Basic

Message par ledudu »

Effectivement, Bernouilli, ton programme m'avait échappé à l'époque. J'aurais dû m'y intéresser.

Je n'ai pas fait de mesure mais je dirai que le temps de réponse sur le Z1-GRA est de l'ordre de la seconde, je n'ai pas pu faire mieux.
C'est la version 3 de l'algorithme, au début j'étais plutôt à 2 secondes.

Au début j'avais privilégié la "beauté" de la conception en centralisant au maximum les traitements des 4 flèches dans le bloc 1200 : cadrage, élimination, cadrage. Ç'était élégant mais trop lent.

Puis j'ai remonté les deux étapes de cadrage dans les 4 blocs de traitement des flèches. Le cadrage se fait en même temps que la copie dans B(), idem au retour.
Et enfin j'ai limité le nombre d'étapes
- pour les lignes toutes blanches (sans perdre de temps pour vérifier qu'elle est blanche...)
- pour les lignes déjà cadrés après la phase d'élimination, je saute le cadrage (sans perdre de temps pour vérifier qu'elle est déjà cadrée...).

Et enfin, j'ai reperdu un peu de temps de réponse parce que si ,lors d'un coup, aucun chiffre n'est déplacé, il ne faut pas ajouter de chiffres.
Avatar du membre
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4642
Enregistré le : 31 oct. 2006 15:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 »

Je viens de corriger mes RAN et donc de re-tester sur mon Sharp PC-G850 (le plus lent des 4 ;) ) et c'est tout à fait jouable, moins d'une seconde entre chaque coup (pas mesuré).

Code : Tout sélectionner

60 R= 2+( RAN 0<.9)
Reste à implémenter le test de fin de partie, retour dans quelques minutes :)
Image
Image
Avatar du membre
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4642
Enregistré le : 31 oct. 2006 15:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 »

Voilà, c'est fait, même pas très coûteux finalement, ni en code, ni en temps (pourquoi n'y avais-je pas pensé plus tôt?).

Par contre, difficile de perdre rapidement sur ce jeu :mrgreen:

J'ai (re)découvert deux trucs en modifiant mon programme:
1-L'écran de mon PC-G850 commence à fatiguer (quelques lignes verticales doivent "chauffer quelques minutes avant de se ré-afficher - vous avez déjà rencontré çà sur des pockets "récents" :?: )
2-La syntaxe du Basic G850 (et probablement dès le E500, à vérifier) est exigeante avec certains espaces (et n'est plus aidée par les token qui faisaient la "joie" des codeurs sur 1211 -> 1475)

Code : Tout sélectionner

IF ZGOTO 200
ne passe pas, il faut taper

Code : Tout sélectionner

IF Z GOTO 200
Le programme revu un autre jour, flemme de brancher ma CE-124 ou pire, CE-126P :oops:
Image
Image
Avatar du membre
babaorhum
Fonctionne à 1200 bauds
Fonctionne à 1200 bauds
Messages : 454
Enregistré le : 13 janv. 2013 19:44
Localisation : Marseille-est

Re: à 2048 en Basic (mais pas que en basic !)

Message par babaorhum »

Bonjour à tous,

Puisqu'on reparle 2048, j'avais fais une version DOS sous TP7 pour mon 200LX à l'époque du pgm de Bernouilli92.

Si ca vous dis de le tester, y'a plus qu'à copier/coller et compiler
d'ailleurs
Je ne suis pas sûr d'avoir les mêmes règles que l'original et je ne fais apparaître que des "2" - facile à changer si vous voulez.

Chaque mouvement se fait avec les flèches et si on en a marre on sort avec "ESC". On perd quand la grille est pleine. Ca marche aussi sur un "vrai PC" et DOSBOX.
Cette version est assez ludique, jamais réussi à atteindre le 2048 (pas testé par le pgm d'ailleurs).


@ bientôt

Code : Tout sélectionner

program p2048;
uses crt, dos;

const maxdim = 4;
      base = 2;
type carre = array[1..maxDim,1..maxdim] of integer;
     Ligne = array[1..MaxDim] of integer;

var J1 : carre;
    L1 : ligne;
    FIN : boolean ;
    score : integer ;

procedure LigCarreToLig(MyCarre:carre;l:integer; var Lig:ligne);
var i : integer;
begin
   for i:=1 to Maxdim do
   begin
     Lig[i]:=MyCarre[l,i];
   end;
end;

procedure LigToLigCarre(Lig:ligne;l:integer;var myCarre:carre);
var i : integer;
begin
   for i:=1 to Maxdim do
   begin
     MyCarre[l,i]:=Lig[i];
   end;
end;

procedure ColCarreToLig(MyCarre:carre;l:integer; var Lig:ligne);
var i : integer;
begin
   for i:=1 to Maxdim do
   begin
     Lig[i]:=MyCarre[i,l];
   end;
end;

procedure LigToColCarre(Lig:ligne;l:integer;var myCarre:carre);
var i : integer;
begin
   for i:=1 to Maxdim do
   begin
     MyCarre[i,l]:=Lig[i];
   end;
end;

procedure CompressRight(var Lig : ligne);
var i,j : integer;
begin
 for i:=1 to (MaxDim-1) do
  begin
    if Lig[i] = lig[i+1] then
     begin
       Lig[i]:=Lig[i]*2;
       Lig[i+1]:=0;
     end;
    if Lig[i]=0 then
     begin
       j:=i;
       repeat
        j:=j+1;
        if Lig[j]<>0 then
         begin
          Lig[i]:=Lig[j];
          Lig[j]:=0;
          j:=maxDim;
         end;
       until j=maxDim
     end;
   end;
 end;

procedure CompressLeft(var Lig : ligne);
var i,j : integer;
begin
 for i:=Maxdim downto 2 do
  begin
    if Lig[i] = lig[i-1] then
     begin
       Lig[i]:=Lig[i]*2;
       Lig[i-1]:=0;
     end;
    if Lig[i]=0 then
     begin
       j:=i;
       repeat
        j:=j-1;
        if Lig[j]<>0 then
         begin
          Lig[i]:=Lig[j];
          Lig[j]:=0;
          j:=1;
         end;
       until j=1;
     end;
   end;
 end;

procedure clearCarre(var Mycarre:carre);
var i,j : integer;
begin
 for i:=1 to maxdim do
  for j:=1 to maxdim do
   MyCarre[i,j]:=0;
end;

procedure initcarre(var MyCarre : carre);
var i,j,r : integer;
begin
score := 0;
 for i:=1 to maxdim do
  for j:=1 to maxdim do
   begin
     if MyCarre[i,j] > score then
       score := MyCarre[i,j];
     if MyCarre[i,j]=0 then
     begin
      r:=base;
      if random(4)=1 then
        MyCarre[i,j]:=r ;
      end;
   end;
end;

procedure testFin(Mycarre:Carre) ;
var i,j : integer;
begin
if NOT FIN then
begin
 FIN := true;
  for i:=1 to maxdim do
   for j:=1 to maxdim do
    begin
     if MyCarre[i,j]=0 then
       FIN := false;
   end;
end;
end;


procedure showcarre(Mycarre: carre);
var i,j,k,n:integer;
    L,C : string;
begin
 clrscr;
 writeln;
   for k:=1 to maxdim do
   write('---------');
   writeln;
 for i:=1 to maxdim do
 begin
  for j:=1 to maxdim do
   begin
     str(MyCarre[i,j],c);
     n:=length(c);
     n:=5-n;
     c:='|   '+c;
     for k := 1 to n do
      c:=c+' ';
      write (c);
   end;
   write('|');
   writeln;
   for k:=1 to maxdim do
   write('---------');
   writeln;
  end;
  writeln;
  writeln('              score : ',score);
end;



procedure MouvCarre(var Mycarre:carre);
var i,j,l : integer;
    kk:char;
begin
 kk:= readkey;
 if ord(kk)=27 then
     FIN := true;
 if ord(kk)=0 then
 begin
  kk:=readkey;
  case ord(kk) of
   77 : {droite}
       begin
        for i:=1 to MaxDim do
        begin
         LigCarreToLig(MyCarre,i,L1);
         CompressLeft(L1);
         LigToLigCarre(L1,i,myCarre);
         end;
       end;
   80 : {bas}
      begin
        for i:=1 to MaxDim do
        begin
         ColCarreToLig(MyCarre,i,L1);
         CompressLeft(L1);
         LigToColCarre(L1,i,myCarre);
        end;
      end;
   75 : {gauche}
      begin
        for i:=1 to MaxDim do
        begin
         LigCarreToLig(MyCarre,i,L1);
         CompressRight(L1);
         LigToLigCarre(L1,i,myCarre);
         end;
      end;
   72 : {haut}
      begin
        for i:=1 to MaxDim do
        begin
         ColCarreToLig(MyCarre,i,L1);
         CompressRight(L1);
         LigToColCarre(L1,i,myCarre);
        end;
      end;
  else
      begin
      end;
  end;
 end;
end;



begin
 FIN := false ;
 clearcarre(J1);
 InitCarre(J1);
 showcarre(J1);
 repeat
  Mouvcarre(J1);
  initcarre(J1);
  ShowCarre(J1);
  testFIN(J1);
 until FIN;
 writeln('*********** FINAL **********');
 repeat until keypressed;
end.
Répondre

Retourner vers « A quoi t'as joué hier ? »