Forum

Code : Tout sélectionner

A$="SILICIUM C'EST SUPER"
LEN(A$) renvoit 20
A$[5,8] = "GLOUPS"
A$ renvoie "SILIGLOUPS C'EST SUPER"  donc on élimine les 4 caractères entre du 5éme au 8éme et on les remplace par les 6 caractères de "GLOUPS"
A$[5,10] = "CIUM"
A$ contient "SILICIUM C'EST SUPER"  on élimine les 6 caractères (entre 5 et 10) et on les remplace par 4 "CIUM"

Code : Tout sélectionner

10 INPUT A$ @ A$=STR$(VAL(A$))
20 L=LEN(A$) @ FOR J = L-1 TO 1 STEP -1 @ FOR I = 1 TO J
30 L$=A$[1,1] @ R$=A$[I+1,I+1]
40 IF R$>L$ THEN A$[I,I]=R$ @ A$[I+1,I+1]=L$
50 NEXT I @ NEXT J
60 B$=« » @ FOR I = 1 TO L @ B$[I,I]=A$[L-I+1,L-I+1] @ NEXT I
70 A$=STR$(VAL(A$)-VAL(B$))
80 PRINT A$ @ PAUSE @ GOTO 20

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.

Code : Tout sélectionner

10 "H" AREAD N : D=5 : GOSUB 40 : D=3 :GOSUB 40 : D=2 : GOSUB 40
20 IF N=1 THEN PRINT "YES" : END 
30 PRINT "NO" : END 
40 M=N/D : IF M=INT M THEN LET N=M : GOTO  40
50 RETURN 

Code : Tout sélectionner

1 INPUT N : RESTORE 7 : DIM R$(0)*15
2 FOR K = 1 TO 13 : READ L : U = INT(L/N) : IF U>=1 THEN GOSUB 4
3 NEXT K : PRINT R$(0) : CLEAR : END
4 RESTORE 6 : FOR I=1 TO K : READ T$ : NEXT I : FOR I=1 TO U : R$(0)=R$(0)+T$
5 N = N-L : NEXT I : RESTORE 7 : FOR I = 1 TO K : READ L : NEXT I : RETURN
6 DATA "M","CM","D","CD","C","XC","L","XL","X","IX,"V","IV","I"
7 DATA 1000,900,500,400,100,90,50,40,10,9,5,4,1

Code : Tout sélectionner

Romain(n)
prgm
 Local rm,dc,k,i,j,res
 ClrIO
 {"M","CM","D","CD","C","XC","L","XL","X","IX","V","IV","I"} -> rm
 {1000,900,500,400,100,90,50,40,10,9,5,4,1} -> dc
 "" -> res
 For k,1,dim(rm)
  int(n/(dc[k])) -> j
  n-j*dc[k] -> n
  If j>0 Then
   For i,1,j
    res & rm[k] -> res
   EndFor 
  EndIf
 EndFor
 Disp res
EndPrgm