à 2048 en Basic

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

Modérateur : Politburo

Répondre
Avatar de l’utilisateur
ledudu
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4675
Inscription : 26 mars 2009 14:07
Localisation : Ile de France
Contact :

à 2048 en Basic

Message par ledudu » 30 mars 2016 00:25

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
Dernière édition par ledudu le 30 mars 2016 08:04, édité 1 fois.

Avatar de l’utilisateur
Marge
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4608
Inscription : 01 oct. 2008 14:39
Localisation : En bas, tout au fond à gauche.

Re: à 2048 en Basic

Message par Marge » 30 mars 2016 02:00

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

« Boris », c'est juste Maurice enrhumé.

Avatar de l’utilisateur
Hobiecat
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 2982
Inscription : 06 sept. 2011 14:57
Localisation : Normandie / Antwerpen

Re: à 2048 en Basic

Message par Hobiecat » 30 mars 2016 06:31

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 de l’utilisateur
leglatin
Fonctionne à 1200 bauds
Fonctionne à 1200 bauds
Messages : 726
Inscription : 03 févr. 2003 20:46
Localisation : A proximité de Deauville (14)
Contact :

Re: à 2048 en Basic

Message par leglatin » 30 mars 2016 06:48

Sympa :D !

(Je ne connaissais pas ce jeu non plus... :oops: )
Commodore 7970 - Texas Instruments TI-30, 57, 80, 81, 82, 83, 85, 86, 89, 92 - Casio PB-100, PB-110, PB-410, PB-500, PB-700, PB-770, FA-3, FA-4, 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 - Philips VG8020, NMS8255, VY0010, VY0011, VS0080, D6450, VW0030, SBC3810, NMS1112, NMS1150, NMS1170 - Atari 1040 STE

Avatar de l’utilisateur
ledudu
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4675
Inscription : 26 mars 2009 14:07
Localisation : Ile de France
Contact :

Re: à 2048 en Basic

Message par ledudu » 30 mars 2016 08:19

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 de l’utilisateur
bernouilli92
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 3196
Inscription : 21 nov. 2012 14:03
Localisation : Ile de France

Re: à 2048 en Basic

Message par bernouilli92 » 30 mars 2016 10:23

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 de l’utilisateur
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4228
Inscription : 31 oct. 2006 16:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 » 30 mars 2016 14:34

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 de l’utilisateur
ledudu
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4675
Inscription : 26 mars 2009 14:07
Localisation : Ile de France
Contact :

Re: à 2048 en Basic

Message par ledudu » 30 mars 2016 21:10

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 de l’utilisateur
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4228
Inscription : 31 oct. 2006 16:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 » 30 mars 2016 23:03

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 de l’utilisateur
pir2
Fonctionne à 9600 bauds
Fonctionne à 9600 bauds
Messages : 4228
Inscription : 31 oct. 2006 16:08
Localisation : 67310 Westhoffen
Contact :

Re: à 2048 en Basic

Message par pir2 » 30 mars 2016 23:37

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 de l’utilisateur
babaorhum
Fonctionne à 1200 bauds
Fonctionne à 1200 bauds
Messages : 450
Inscription : 13 janv. 2013 20:44
Localisation : Toulon-ouest

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

Message par babaorhum » 31 mars 2016 19:53

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

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