CODE PASCAL

 

uses
    crt,dos;

Type
  t_b_int=integer;
  t_b_str=string[80];
  t_b_boo=boolean;

var
   i:integer;
   j:integer;
   l:integer;
   p:integer;
   Ecod:integer;
   n_v_const:string;
   n_const:string;
   v_const:string;
   str_v_const:string;
   str_x:string;
   str_i:string;
   str_j:string;
   compt:integer;
   choix:char;
   nomfic:string[40];
   nomsvar:string;
   fic:text;
   coef:double;

   nom_finfos:string;
   nom_fmax:string;
   nom_fmat:string;
   nom_fcst:string;
   nom_fres:string;
   nom_fnres:string;
   nom_fvres:string;
   nom_ffait_x:string;
   nom_ffait_c:string;

   nom_log_finfos:text;
   nom_log_fmax:text;
   nom_log_fmat:text;
   nom_log_fcst:text;
   nom_log_fres:text;
   nom_log_fnres:text;
   nom_log_fvres:text;
   nom_log_ffait_x:text;
   nom_log_ffait_c:text;

   nom_col:string;
   nom_lig:string;


PROCEDURE BOX(x1,y1,x2,y2,FG,BG:t_b_int;
             name:t_b_str;blnk:t_b_boo);
Var
     x,q:t_b_int;
Begin
     Window(x1,y1,x2,y1+1);
     TextBackground(1);
     GotoXY(1,1);
     x:=x2-x1;
     If length(name)>x then name[0]:=chr(x-4);
     Textcolor(7);
     Write(chr(218));      {1øligne gauche}
     If blnk then Textcolor(FG+blink) else Textcolor(7);
     Write(name);
     Textcolor(7);
     for q:=x1+length(name)+1 to x2-1 do
         Write(char(196)); {1øligne suite}
     Write(char(191));     {1øligne droit}
     for q:=1 to y2-y1 do
     Begin
          Window(x1,y1,x2,y1+q+1);
          GotoXY(1,q+1);Write(char(179));
          If blnk then clreol;
          GotoXY(x2-x1+1,q+1);Write(char(179));
     end;
     {
     for q:=1 to y2-y1 do
     Begin
          Window(x1,y1,x2+1,y1+q+1);
          If blnk then clreol;
          GotoXY(x2-x1+1+1,q+1);Write(char(178));
     end;
     }
     Window(x1,y1,x2,y2+1);
     GotoXY(1,y2-y1+1);
     Write(char(192));
     for q:=x1+1 to x2-1 do
         Write(char(196));
     Write(char(217));
     {
     Window(x1,y1,x2+1,y2+1+1);
     GotoXY(2,y2-y1+1+1);
     for q:=x1+1 to x2+1 do
         Write(char(178));
     }
end;

PROCEDURE BOX_WIND(x1,y1,x2,y2,LightGray,Blue:t_b_int;
                  name:t_b_str;blnk:t_b_boo);
Begin
     BOX(x1,y1,x2,y2,LightGray,Blue,name,blnk);
     Window(x1+1,y1+1,x2-1,y2-1);
end;

{
BEGINENVIRON

CONST
   n  =   ;        (* nb col=nb variables de chaque équation de contraintes *)
   m  =   ;        (* nb lig=nb équations de contraintes *)
   np =   ;        (* np> n+1 *)
   mp =   ;        (* mp> m+2 *)

TYPE
   RealArrayMPbyNP = ARRAY [1..mp,1..np] OF double;
   IntegerArrayN = ARRAY [1..n] OF integer;
   IntegerArrayM = ARRAY [1..m] OF integer;
   IntegerArrayNP = ARRAY [1..np] OF integer;

ENDENVIRON
}

CONST
   n_col  = 50;        (* nb col=nb variables de chaque ‚quation de contraintes *)
   m_lig  = 50;        (* nb lig=nb ‚quations de contraintes *)
   np     = 51;        (* np> n+1 *)
   mp     = 52;        (* mp> m+2 *)


TYPE
   RealArrayMPbyNP = ARRAY [1..mp,1..np] OF double;
   IntegerArrayN = ARRAY [1..n_col] OF integer;
   IntegerArrayM = ARRAY [1..m_lig] OF integer;
   IntegerArrayNP = ARRAY [1..np] OF integer;

VAR
   a,abis: RealArrayMPbyNP;
   n,m,m1,m2,m3: integer;
   icase: integer;
   izrov: IntegerArrayN;
   iposv: IntegerArrayM;


PROCEDURE simplx(VAR a: RealArrayMPbyNP;
          m,n,m1,m2,m3: integer;
             VAR icase: integer;
             VAR izrov: IntegerArrayN;
             VAR iposv: IntegerArrayM);

LABEL 1,2,3,4,5,99;

CONST
   eps = 1.0e-38;

VAR
   nl2,nl1,m12,kp,kh,k,is,ir,ip,i: integer;
   q1,bmax: double;
   l1: ^IntegerArrayNP;
   l2,l3: ^IntegerArrayM;

   PROCEDURE simp1(VAR a: RealArrayMPbyNP;
                   mm: integer;
               VAR ll: IntegerArrayNP;
             nll,iabf: integer;
               VAR kp: integer;
             VAR bmax: double);
   VAR
      k: integer;
      test: double;
   BEGIN
        (* determine le nb maxi d'éléments de la liste ll *)
        (* writeln('debut proc simp1'); *)
        kp := ll[1];
        (* writeln('kp=',kp); *)
        bmax := a[mm+1,kp+1];
        (* writeln('bmax(a[',mm+1,',',kp+1,'])=',a[mm+1,kp+1]); *)
        FOR k := 2 TO nll DO
        BEGIN
             IF iabf = 0 THEN
             BEGIN
                  (* writeln('iabf=',iabf); *)
                  test := a[mm+1,ll[k]+1]-bmax;
                  (* writeln('test(a[',mm+1,',',ll[k]+1,']-bmax)=',test); *)
             END
             ELSE
             BEGIN
                  (* writeln('iabf=',iabf); *)
                  test := abs(a[mm+1,ll[k]+1])-abs(bmax);
                  (* writeln('test(a[',mm+1,',',ll[k]+1,']-abs(bmax))=',test); *)
             END;

             IF test > 0.0 THEN
             BEGIN
                  bmax := a[mm+1,ll[k]+1];
                  kp := ll[k];
                  (* writeln('bmax=',bmax); *)
             END;
             (* writeln('bmax=',bmax); *)
        END;
   END;

   PROCEDURE simp2(VAR a: RealArrayMPbyNP;
                  m,n: integer;
               VAR l2: IntegerArrayM;
                  nl2: integer;
               VAR ip: integer;
                   kp: integer;
               VAR q1: double);
   LABEL 1,2,99;
   CONST
        eps = 1.0e-38;
   VAR
      k,ii,i: integer;
      qp,q0,q: double;
   BEGIN
        (* localise l'élément pivot *)
        ip := 0;
        FOR i := 1 TO nl2 DO
        IF a[l2[i]+1,kp+1] < -eps THEN GOTO 1;
        {writeln('plus (pas) de pivot possible');}
        GOTO 99;

1:      q1 := -a[l2[i]+1,1]/a[l2[i]+1,kp+1];
        ip := l2[i];
        write('i');
        FOR i := i+1 TO nl2 DO
        BEGIN
             ii := l2[i];
             IF a[ii+1,kp+1] < -eps THEN
             BEGIN
                  q := -a[ii+1,1]/a[ii+1,kp+1];
                  IF q < q1 THEN
                  BEGIN
                       ip := ii;
                       q1 := q;
                  END
                  ELSE IF q = q1 THEN
                  BEGIN
                       FOR k := 1 TO n DO
                       BEGIN
                            qp := -a[ip+1,k+1]/a[ip+1,kp+1];
                            q0 := -a[ii+1,k+1]/a[ii+1,kp+1];
                            IF q0 <> qp THEN GOTO 2
                       END;
2:                     IF q0 < qp THEN ip := ii;
                  END;
             END;
        END;
99:END;

   PROCEDURE simp3(VAR a: RealArrayMPbyNP;
          i1,k1,ip,kp: integer);
   VAR
      kk,ii: integer;
      piv: double;
   BEGIN
        piv := 1.0/a[ip+1,kp+1];
        FOR ii := 1 TO i1+1 DO
        BEGIN
             IF ii-1 <> ip THEN
             BEGIN
                  a[ii,kp+1] := a[ii,kp+1]*piv;
                  FOR kk := 1 TO k1+1 DO
                  IF kk-1 <> kp THEN
                  a[ii,kk] := a[ii,kk] -a[ip+1,kk]*a[ii,kp+1];
             END;
        END;
        FOR kk := 1 TO k1+1 DO
        IF kk-1 <> kp THEN
        a[ip+1,kk] := -a[ip+1,kk]*piv;
        a[ip+1,kp+1] := piv;
   END;

   (* /////////////////////////// proc simplx /////////////////////////// *)

   BEGIN
        {
        writeln('debut de proc simplx ');
        writeln('verif struc matrice : ');
        writeln('m=',m);
        }
        IF m <> m1+m2+m3 THEN   (* m = nb lignes *)
        BEGIN
             writeln('nombre de contraintes erron‚');
        END;
        new(l1);
        new(l2);
        new(l3);
        nl1 := n;               (* n = nb colonnes *)
        FOR k := 1 TO n DO
        BEGIN
             l1^[k] := k;
             izrov[k] := k;
        END;

        {writeln('verif val contr : ');}
        nl2 := m;               (* m = nb lignes *)
        FOR i := 1 TO m DO
        BEGIN
             {writeln('val contr de la ',i,'ø ‚quation (a[',i+1,',1]) = ',a[i+1,1]);}
             IF a[i+1,1] < 0.0 THEN                (* a[2øligne,1øcolonne] *)
             BEGIN
                  writeln('val contrainte erron‚e (<0)');
                  {writeln('a[',i+1,',1]','=',a[i+1,1]);}
                  {readln}
             END;
             l2^[i] := i;
             iposv[i] := n+i;
        END;

        FOR i := 1 TO m2 DO l3^[i] := 1;
        ir := 0;
        IF m2+m3 = 0 THEN GOTO 5;
        ir := 1;

        {writeln('construction de la fonction auxilliaire');}
        FOR k := 1 TO n+1 DO
        BEGIN
             q1 := 0.0;
             FOR i := m1+1 TO m DO q1 := q1+a[i+1,k];
             a[m+2,k] := -q1;
        END;
        {writeln('recherche du coeff maxi de la fonction objectif auxilliaire');}

3:      simp1(a,m+1,l1^,nl1,0,kp,bmax);
        IF ((bmax <= eps) AND (a[m+2,1] < -eps)) THEN
        BEGIN
             icase := -1;
             {
             writeln('icase -1 =',icase);
             writeln('bmax (',bmax,') <= ',eps);
             writeln('et a[',m+2,',1] (',a[m+2,1],') < ',-eps);
             }
             GOTO 99;
        END
        ELSE
        {writeln('bmax =',bmax);}
        IF (bmax <= eps) AND (a[m+2,1] <= eps) THEN
        BEGIN
             m12 := m1+m2+1;
             IF m12 <= m THEN
             BEGIN
                  FOR ip := m12 TO m DO
                  BEGIN
                  IF iposv[ip] = ip+n THEN
                  BEGIN
                       simp1(a,ip,l1^,nl1,1,kp,bmax);
                       IF bmax > 0.0 THEN GOTO 1
                  END;
             END;
        END;
        ir := 0;
        m12 := m12-1;
        IF m1+1 > m12 THEN GOTO 5;
        FOR i := m1+1 TO m12 DO
        IF l3^[i-m1] = 1 THEN
        FOR k := 1 TO n+1 DO a[i+1,k] := -a[i+1,k];
        GOTO 5;
   END;

   simp2(a,m,n,l2^,nl2,ip,kp,q1);
   IF ip = 0 THEN
   BEGIN
        icase := -1;
        GOTO 99;
   END;

1: simp3(a,m+1,n,ip,kp);
   IF iposv[ip] >= n+m1+m2+1 THEN
   BEGIN
        FOR k := 1 TO nl1 DO
        IF l1^[k] = kp THEN GOTO 2;

2:      nl1 := nl1-1;
        FOR is := k TO nl1 DO l1^[is] := l1^[is+1];
   END
   ELSE
   BEGIN
        IF iposv[ip] < n+m1+1 THEN GOTO 4;
        kh := iposv[ip]-m1-n;
        IF l3^[kh] = 0 THEN GOTO 4;
        l3^[kh] := 0;
   END;
   a[m+2,kp+1] := a[m+2,kp+1]+1.0;
   FOR i := 1 TO m+2 DO a[i,kp+1] := -a[i,kp+1];

4: is := izrov[kp];
   izrov[kp] := iposv[ip];
   iposv[ip] := is;
   IF ir <> 0 THEN
   GOTO 3;

5: simp1(a,0,l1^,nl1,0,kp,bmax);
   IF bmax <= 0.0 THEN
   BEGIN
        icase := 0;
        GOTO 99;
   END;

   simp2(a,m,n,l2^,nl2,ip,kp,q1);
   IF ip = 0 THEN
   BEGIN
        icase := 1;
        GOTO 99;
   END;

   simp3(a,m,n,ip,kp);
   GOTO 4;

99:
   dispose(l3);
   dispose(l2);
   dispose(l1)
END;


(* /////////////////////////// proc. environnement /////////////////////// *)
procedure environnement;
begin
   writeln('Patience,');
   assign(nom_log_finfos,'SIMPLEXX.BAT');
   reset(nom_log_finfos);
   readln(nom_log_finfos,nom_finfos);
   close(nom_log_finfos);
   (* writeln('... comme indiqué dans le fichier ',nom_finfos,' ...'); *)
   assign(nom_log_finfos,nom_finfos);
   reset(nom_log_finfos);
   readln(nom_log_finfos,nom_fmax);
   readln(nom_log_finfos,nom_fmat);
   readln(nom_log_finfos,nom_fcst);
   readln(nom_log_finfos,n);
   readln(nom_log_finfos,m);
   readln(nom_log_finfos,m1);
   readln(nom_log_finfos,m2);
   readln(nom_log_finfos,m3);
   readln(nom_log_finfos,nom_fres);
   close(nom_log_finfos);
end;


(* /////////////////////////// proc. lecture ////////////////////////// *)
var
   b:ARRAY[1..np] OF real;
procedure lecture;
begin
   writeln('... je mémorise les informations de ',nom_fmax,' ...');
   {lecture de la fonction … maximiser}
   assign(nom_log_fmax,nom_fmax);
   reset(nom_log_fmax);
   {1øligne:noms de la fonction a maximiser-->pour infos}
   readln(nom_log_fmax,nomsvar);
   {2øligne,1øVar: valeur initiale de F(xi) … maximiser}
   read(nom_log_fmax,a[1,1]);
   {jøVar :coeff. ki de la jø variable de l''‚quation F(xi) … maximiser}
   for j:=1 to n do
   begin
        {coeff. de la ',j,'ø variable}
        read(nom_log_fmax,a[1,j+1]);
        b[j]:=a[1,j+1];
        abis[1,j+1]:=a[1,j+1];
        {writeln(a[1,j+1]);}
   end;

   writeln('... je mémorise les informations de ',nom_fcst,' ...');
   {ouverture-lecture de la matrice de contraintes}
   assign(nom_log_fcst,nom_fcst);
   reset(nom_log_fcst);
   {lecture de la 1ø ligne pour memo}
   readln(nom_log_fcst,n_v_const);
   for i:=1 to m do
   {pour chaque ligne-‚quation de contrainte}
   begin
        {lecture de la valeur de la iø contrainte}
       read(nom_log_fcst,a[i+1,1]);
        {writeln(a[i+1,1]);}
   end;

   writeln('... je mémorise les informations de ',nom_fmat,' ...');
   {ouverture-lecture de la matrice des coeff}
   assign(nom_log_fmat,nom_fmat);
   reset(nom_log_fmat);
   {pour chaque colonne de la matrice des coeff}
   for j:=1 to n do
   begin
       {lecture de la 1ø ligne pour memo}
       readln(nom_log_fmat,nomsvar);
       for i:=1 to m do
       {pour chaque ligne-‚quation de contrainte}
       begin
          {coeff. de la ',j,'ø variable}
          read(nom_log_fmat,coef);
          a[i+1,j+1]:=-coef;
          {writeln(coef);}
     end;
     readln(nom_log_fmat,nomsvar);
   end;
   close(nom_log_fmat);
   close(nom_log_fcst);
   (*
   writeln('[Entr‚e] pour continuer ...');
   readln;
   *)
end;

(* /////////////////////////// proc. simplexe ////////////////////////// *)
var
   fmax:double;
procedure simplexe;
begin
   writeln('... je cherche à résoudre le problème ...');
   write('... ');
   simplx(a,m,n,m1,m2,m3,icase,izrov,iposv);
   nom_fnres:='N'+nom_fres;
   nom_fvres:='V'+nom_fres;
   nom_ffait_x:='X'+nom_fres;
   nom_ffait_c:='C'+nom_fres;

   assign(nom_log_fres,nom_fres);
   rewrite(nom_log_fres);
   assign(nom_log_fnres,nom_fnres);
   rewrite(nom_log_fnres);
   assign(nom_log_fvres,nom_fvres);
   rewrite(nom_log_fvres);
   assign(nom_log_ffait_x,nom_ffait_x);
   rewrite(nom_log_ffait_x);
   assign(nom_log_ffait_c,nom_ffait_c);
   rewrite(nom_log_ffait_c);

   if icase<>0 then
   begin
        writeln(nom_log_fvres,'‚chec !');
        write(nom_log_fvres,'icase = ',icase);
        if icase=1 then writeln(nom_log_fvres,' --> il existe une infinité de solutions ...')
        else writeln(nom_log_fvres,' --> ce système n'a pas de solution ...');
        close(nom_log_fvres);
        writeln('... d‚sol‚,');
        if icase=1 then writeln('échec : il existe une infinité de solutions ...!')
        else writeln('échec : ce système n'a pas de solution ...!');
   end
   else
   begin
        (*
        writeln('... OK !, voici les solutions : ');
        writeln('    NB : ces résultats seront sauvegardés');
        writeln('    dans les fichiers ',nom_fres);
        writeln('    ',nom_fnres);
        writeln('    et ',nom_fvres);
        BOX_WIND(55,4,80,24,7,1,'[R‚sultats]',false);
        Textcolor(14);
        clrscr;
        *)

        (* eliminer les produits des kj nulles *)
        fmax:=0;
        for j:=1 to m do
        begin
             if (iposv[j]<=n) and (b[iposv[j]]<>0)
             then fmax:=fmax+(b[iposv[j]]*a[j+1,1]);
        end;

        (* str(a[1,1]:12:2,str_x); *)
        str(fmax:12:2,str_x);
        (* writeln('Fopt=',str_x); *)
        writeln(nom_log_fres,'Marge brute=',str_x);
        writeln(nom_log_ffait_x,'evalue("marge_new",str("',str_x,'"),question)');

        (* writeln('pour'); *)
        for j:=1 to m do
        (* liste des activit‚s retenues et ampleurs *)
        begin
             if (iposv[j]<=n) and (b[iposv[j]]<>0) then
             begin
                  str(a[j+1,1]:12:2,str_x);
                  (* writeln('X(',iposv[j],')=',str_x); *)
                  writeln(nom_log_fres,'X(',iposv[j],')=',str_x);
             end;
        end;
        {
        for j:=1 to n do
        begin
             if (izrov[j]<=n) then
             begin
                  str(0.0:12:2,str_x);
                  writeln('X(',izrov[j],')=',str_x);
                  writeln(nom_log_fres,'X(',izrov[j],')=',str_x);
             end;
        end;
        }
        for j:=1 to m do
        (* liste des produits marge.ampleur des activit‚s retenues *)
        begin
             if (iposv[j]<=n) and (b[iposv[j]]<>0) then
             begin
                  str(a[j+1,1]*abis[1,iposv[j]+1]:12:2,str_x);
                  (* writeln('R(',iposv[j],')=',str_x); *)
                  writeln(nom_log_fres,'R(',iposv[j],')=',str_x);
             end;
        end;
        {
        for j:=1 to n do
        begin
             if (izrov[j]<=n) then
             begin
                  str(0.0:12:2,str_x);
                  writeln('R(',izrov[j],')=',str_x);
                  writeln(nom_log_fres,'R(',izrov[j],')=',str_x);
             end;
        end;
        }

        (*
        writeln('[Entr‚e] continue ...');
        readln;
        writeln('avec');
        writeln('contraintes satur‚es');
        writeln('et prod. marginales');
        writeln('suivantes');
        *)
        compt:=0;
        for j:=1 to n do
        (* liste des contraintes satur‚es avec productivt‚s marginales *)
        begin
             if (izrov[j]>n) then
             begin
                  str(-a[1,j+1]:12:2,str_x);
                  (* writeln('C(',izrov[j]-n,')=',str_x); *)
                  writeln(nom_log_fres,'C(',izrov[j]-n,')=',str_x);
             end;
             compt:=compt+1;
        end;
        (* if compt=0 then writeln('n‚ant ...'); *)
        writeln;
        writeln('    OK : le problŠme est r‚solu !');

        (* mˆmes choses mais en d‚couplant noms et valeurs *)
        {
        writeln(nom_log_fnres,'vfmax');
        (* str(a[1,1]:12:2,str_x); *)
        str(fmax:12:2,str_x);
        writeln(nom_log_fvres,str_x);
        }
        for j:=1 to m do
        (* pour les activit‚ retenues *)
        begin
             if (iposv[j]<=n) and (b[iposv[j]]<>0) then
             begin
                  str(iposv[j],str_j);
                  nom_col:='X'+str_j;
                  (* str(a[j+1,1]:12:2,str_x); *)
                  str(a[j+1,1]*abis[1,iposv[j]+1]:12:2,str_x);
                  writeln(nom_log_fnres,nom_col);
                  writeln(nom_log_fvres,str_x);
             end;
        end;
        {
        for j:=1 to n do
        (* pour les activit‚s non retenues *)
        begin
             if (izrov[j]<=n) then
             begin
                  str(izrov[j],str_j);
                  nom_col:='X'+str_j;
                  str(0.0:12:2,str_x);
                  writeln(nom_log_fnres,nom_col);
                  writeln(nom_log_fvres,str_x);
             end;
        end;
        }
        (* mˆmes choses mais en base de faits couplant noms et valeurs *)
        for j:=1 to m do
        (* liste des activit‚s retenues et ampleurs *)
        begin
             if (iposv[j]<=n) and (b[iposv[j]]<>0) then
             begin
                  str(a[j+1,1]:10:2,str_x);
                  (* writeln('x(',iposv[j],')=',str_x); *)
                  (* writeln(nom_log_fres,'X(',iposv[j],')=',str_x); *)
                  begin
                       while pos(' ',str_x)>0 do
                       str_x[pos(' ',str_x)]:='0';
                  end;
                  writeln(nom_log_ffait_x,'evalue("x',iposv[j],'",str("',str_x,'"),question)');
             end;
        end;
        for j:=1 to n do
        begin
             if (izrov[j]<=n) or (b[iposv[j]]=0) then
             begin
                  (* str(0.0:12:2,str_x); *)
                  (* writeln('x(',izrov[j],')=',str_x); *)
                  (* writeln(nom_log_fres,'X(',izrov[j],')=',str_x); *)
                  writeln(nom_log_ffait_x,'evalue("x',izrov[j],'",str("0.00"),question)');
             end;
        end;

        for j:=1 to n do
        begin
             if (izrov[j]>n) then
             begin
                  str(izrov[j]-n,str_j);
                  (* nom_lig:='C'+str_j; *)
                  str(-a[1,j+1]:12:2,str_x);
                  (* writeln(nom_log_fnres,nom_lig); *)
                  (* writeln(nom_log_fvres,str_x); *)
                  begin
                       while pos(' ',str_x)>0 do
                       str_x[pos(' ',str_x)]:='0';
                  end;
                  writeln(nom_log_ffait_c,'evalue("c',izrov[j]-n,'",str("',str_x,'"),question)');
             end;
        end;

        close(nom_log_fres);
        close(nom_log_fnres);
        close(nom_log_fvres);
        close(nom_log_ffait_x);
        close(nom_log_ffait_c);
        writeLn('[Entr‚e] pour continuer...');
        readln;
   end;
end;


(* /////////////////////////// proc. principale ////////////////////////// *)
{main proc}
begin
   TextBackground(1);
   Textcolor(7);
   clrscr;
   writeln;
   writeln(' Programme SIMPLEXX.EXE Copyright JP.BOUSSET CEMAGREF Div PEA 1992-1993');
   BOX_WIND(1,4,80,24,7,1,'[Dialogue]',false);
   Textcolor(14);
   environnement;
   lecture;
   simplexe;
end.