|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 20992 (0x5200) Types: TextFile Names: »LP3.PAS«
└─⟦cd307176b⟧ Bits:30002666 Programmer fra Forlaget FAG ApS └─ ⟦this⟧ »LP3.PAS«
program LP; (* Martin Rasmussen, Forlaget FAG, januar 1984 *) const (* COMPAS PASCAL version 3.02 *) maxm=25; maxn=25; (* kan maximalt vaere 40 *) maxmn=50; (* maxmn = maxm+maxn *) type atype = array(.1..maxm,1..maxmn.) of real; btype = array(.1..maxm.) of real; ctype = array(.1..maxmn.) of real; fil1type = record a:atype; b:btype; c:ctype; rn,rm:integer; vardi:real; end; printype = (cons,prin,spog,clos); var r:fil1type; kv:btype; bv:array(.1..maxm.) of integer; ibv:array(.1..maxmn.) of integer; c0: array(.1..maxn.) of real; n,m,n1,taller,stars,min,max,i,j,neghs:integer; vaerdi0,vaerdi1,bigm,min1,max1:real; svar:char; fil:string(.12.); fil1:file of fil1type; alleud,prt:boolean; outf:text; procedure menu; forward; procedure nulstil; forward; procedure stop; forward; procedure alletud; forward; procedure printer(mode:printype); forward; procedure forklaring; forward; procedure erklaringer; forward; procedure inddata; forward; procedure indlas1; forward; procedure indlas2; forward; procedure rettelser; forward; procedure retdata; forward; function hentdata:boolean; forward; procedure gemdata; forward; procedure simplexdata; forward; procedure nykritfkt; forward; procedure korsel; forward; procedure pivot; forward; procedure iteration; forward; procedure uddata(stopud:boolean); forward; procedure losning; forward; procedure skyggepris; forward; procedure menu; begin repeat writeln(clrhom);writeln; writeln(' L I N E Æ R P R O G R A M M E R I N G'); writeln; writeln; writeln(' Der kan vælges mellem følgende muligheder:'); writeln; writeln(' 1. Kørsel af ny LP opgave.'); writeln; writeln(' 2. Kørsel af gammel LP opgave.'); writeln; writeln(' 3. Gentag udskrivning af løsningen.'); writeln; writeln(' 4. Forklaring.'); writeln; writeln(' 5. Stop kørslen.'); writeln; write(' Anfør det ønskede nummer > '); readln(svar); writeln; if svar in (.'1'..'4'.) then writeln(clrhom); case svar of '1':begin erklaringer; inddata; rettelser; gemdata; alletud; printer(spog); simplexdata; korsel; printer(clos); end; '2':if hentdata then begin rettelser; gemdata; alletud; printer(spog); simplexdata; korsel; printer(clos); end; '3':begin printer(spog); losning; printer(clos); end; '4':forklaring; end; until svar='5'; end; (* menu *) procedure nulstil; begin fill(r,size(r),0); fill(kv,size(kv),0); fill(c0,size(c0),0); fill(bv,size(bv),0); fill(ibv,size(ibv),0); r.vardi:=0; n:=0; m:=0; n1:=0; taller:=0; stars:=0; min:=0; max:=0; i:=0; j:=0; bigm:=0; min1:=0; max1:=0; neghs:=0; fil:=''; alleud:=true; prt:=false; end; (* nulstil *) procedure stop; begin writeln; writeln; writeln; writeln('** Fejlmeldingen er uden betydning. **'); if 1/0=0 then; end; (* stop *) procedure alletud; begin write(' Skal alle tabeller udskrives under kørsel (j/n) ? '); readln(svar); writeln; if svar in (.'j','J'.) then alleud:=true else alleud:=false; end; (* alletud *) procedure printer; begin if mode=spog then begin write(' Ønskes udskrift på skærm/printer? (s/p) '); readln(svar); writeln; if svar in (.'p','P'.) then mode:=prin else mode:=cons; end; case mode of cons :begin assign(outf,'CON:'); rewrite(outf); prt:=false; end; prin :begin assign(outf,'LST:'); rewrite(outf); prt:=true; end; clos :begin close(outf); prt:=false; end; end; end; (* printer *) procedure forklaring; begin writeln(clrhom);writeln; writeln(' *******************************************************'); writeln(' * DETTE PROGRAM LØSER OPGAVER I LINEÆR PROGRAMMERING *'); writeln(' * PÅ FØLGENDE FORM. *'); writeln(' * *'); writeln(' * MAKSIMER: C1*X1 + C2*X2 + ... +CN*XN + C0 *'); writeln(' * *'); writeln(' * UNDER BIBETINGELSERNE: *'); writeln(' * *'); writeln(' * A11*X1 + A12*X2 + ... + A1N*XN <= B1 *'); writeln(' * . . . . *'); writeln(' * . . . . *'); writeln(' * AM1*X1 + AM2*X2 + ... + AMN*XN <= BM *'); writeln(' * HVOR *'); writeln(' * N = ANTAL VARIABLE *'); writeln(' * M = ANTAL BIBETINGELSER *'); writeln(' * *'); writeln(' * *'); writeln(' * (c) Martin Rasmussen Tommy Borch *'); writeln(' * Forlaget FAG December 1983. *'); writeln(' *******************************************************'); writeln; write(' Tast return > '); readln(svar); writeln(clrhom);writeln; writeln(' *******************************************************'); writeln(' * ALLE BIBETINGELSER SKAL VÆRE BRAGT PÅ OVENNÆVNTE *'); writeln(' * STANDARDFORM. KRITERIEFUNKTIONEN SKAL MAKSIMERES. *'); writeln(' * *'); writeln(' * ET MINIMUMSPROBLEM ÆNDRES TIL ET MAKSIMUMSPROBLEM *'); writeln(' * VED AT GANGE KRITERIEFUNKTIONEN IGENNEM MED -1. *'); writeln(' * *'); writeln(' * HAR MAN ULIGHEDER AF TYPEN >= , SKAL ULIGHEDEN *'); writeln(' * GANGES IGENNEM MED -1 FØR INDTASTNING AF DATA. *'); writeln(' * HERVED KAN MAN FÅ EN NEGATIV HØJRESIDE. *'); writeln(' * PROGRAMMET BENYTTER "STRAFFEMETODEN" TIL AT AF- *'); writeln(' * SKAFFE EVENTUELLE NEGATIVE HØJRESIDER, OG TIL AT *'); writeln(' * FREMBRINGE EN STARTBASIS MED KUNSTIGE VARIABLE. *'); writeln(' * *'); writeln(' * HAR MAN LIGNINGER, KAN DISSE OMSKRIVES TIL ULIGHE- *'); writeln(' * DER SOM I FØLGENDE EKSEMPEL: X1 + X2 = 4 *'); writeln(' * OMSKRIVES TIL X1 + X2 <= 4 OG -X1 - X2 <= -4 . *'); writeln(' * *'); writeln(' * N OG M ER KONSTANTER, SOM ER SAT TIL 25. *'); writeln(' * DE KAN ØGES OP TIL 40 VED AT ÆNDRE I ERKLÆRINGERNE *'); writeln(' *******************************************************'); writeln; write(' Tast return > '); readln(svar); end; (* forklaring *) procedure erklaringer; begin nulstil; writeln(clrhom);writeln; (*$I-*) repeat write(' Antal variable (max ',maxn,') ? '); readln(n); writeln; write(' Antal bibetingelser (max ',maxm,') ? '); if iores=0 then readln(m); writeln; until (n>0) and (m>0) and (n<=maxn) and (m<=maxm) and (iores=0); (*$I+*) n1:=n; end; (* erklaringer *) procedure inddata; begin if (n<=9) and (m<=9) then indlas1 else indlas2; end; (* inddata *) procedure indlas1; var i,j,pos,pos1,pos2,fejl:integer; svar:string(.20.); begin writeln(clrhom); writeln(' BIBETINGELSER: '); for i:=1 to m do begin for j:=1 to n do begin pos:=10*(j-1); pos1:=pos mod 70+4; pos2:=i*2+pos div 70; gotoxy(pos1,pos2); writeln('0 X',j,'+'); end; gotoxy(pos1+8,pos2); writeln(' <= '); end; for i:=1 to m do begin for j:=1 to n do begin pos:=10*(j-1); pos1:=pos mod 70+4; pos2:=i*2+pos div 70; repeat gotoxy(pos1,pos2); readln(svar); val(svar,r.a(.i,j.),fejl); until fejl=0; end; repeat gotoxy(pos1+12,pos2); readln(svar); val(svar,r.b(.i.),fejl); until fejl=0; end; gotoxy(5,pos2+2); writeln('KRITERIEFUNKTIONEN: '); for j:=1 to n do begin pos:=10*(j-1); pos1:=pos mod 70+4; pos2:=(m+2)*2+pos div 70; gotoxy(pos1,pos2); writeln('0 X',j,'+'); end; gotoxy(pos1+15,pos2); writeln('0'); for j:=1 to n do begin pos:=10*(j-1); pos1:=pos mod 70+4; pos2:=(m+2)*2+pos div 70; repeat gotoxy(pos1,pos2); readln(svar); val(svar,r.c(.j.),fejl); until fejl=0; end; repeat gotoxy(pos1+15,pos2); readln(svar); val(svar,r.vardi,fejl); until fejl=0; end; (* indlas1 *) procedure indlas2; var i,j:integer; begin writeln(clrhom); writeln(' BIBETINGELSER.','':31,'N = ',n,' M = ',m); writeln('Kun koefficienter forskellig fra 0 skal indtastes.'); writeln('Tast først nummeret på søjlen og så koefficientens talværdi.'); writeln('Søjlenummer 0 afslutter en række i koefficient-matricen .'); writeln; writeln('Række Søjle koefficient'); for i:=1 to m do begin j:=0; repeat j:=j+1; (*$I-*) repeat write(i:3,'':12); read(j); if (j>0) and (j<=n) and (iores=0) then begin write('':20,'A(',i,',',j,') = '); readln(r.a(.i,j.)); end else begin writeln; end; until iores=0;(*$I+*) until (j=0) or (j=n); (*$I-*) repeat write(i:3,'':33,'HØJRESIDE NR. ',i); write(' B(',i,') = '); readln(r.b(.i.)); until iores=0;(*$I+*) writeln; end; writeln; writeln(' KRITERIEFUNKTIONEN: '); for j:=1 to n do begin (*$I-*) repeat write(' C(',j,') = '); read(r.c(.j.)); until iores=0;(*$I+*) if j mod 4=0 then writeln; end; writeln; (*$I-*)repeat write(' konstanten C(0) = '); readln(r.vardi) until iores=0; (*$I+*) end; (* indlas2 *) procedure rettelser; begin repeat printer(cons); uddata(false); printer(clos); write(' Er dette korrekt? (j/n) '); readln(svar); writeln; if not(svar in (.'j','J'.)) then retdata; until svar in (.'j','J'.); end; (* rettelser *) procedure retdata; var svar:char; begin repeat writeln; write(' Rettelser i : (a) A-matricen. '); writeln('(venstresiderne)'); write(' (b) B-matricen. '); writeln('(højresiderne)'); writeln(' (c) Kriteriefunktionen.'); writeln(' (d) Størrelsen af matricen.'); writeln(' (p) Matricen på printer.'); writeln(' (s) Stop rettelser'); repeat write(clreol,' Vælg bogstav > '); read(svar); if ord(svar)>96 then svar:=chr(ord(svar)-32); until svar in (.'A','B','C','D','P','S'.); writeln; case svar of 'A':begin (*$I-*) repeat write(' Anfør rækkenummer : '); readln(i); until iores=0; repeat write(' og søjlenummer : '); readln(j); until iores=0; repeat write(' A(',i,',',j,') = '); write(r.a(.i,j.):0:3,' = '); readln(r.a(.i,j.)); until iores=0;(*$I+*) end; 'B':begin (*$I-*) repeat write(' Anfør rækkenummer : '); readln(i); until iores=0; write(' B(',i,') = '); repeat write(r.b(.i.):0:3,' = '); readln(r.b(.i.)); until iores=0;(*$I+*) end; 'C':begin (*$I-*) repeat write(' Anfør nummeret på den variabel : '); readln(i); until iores=0; if i=0 then begin repeat write(' C(0) = '); write(r.vardi:0:3,' = '); readln(r.vardi); until iores=0; end else begin repeat write(' C(',i,') = '); write(r.c(.i.):0:3,' = '); readln(r.c(.i.)); until iores=0;(*$I+*) end; end; 'D':begin (*$I-*) repeat write(' Anfør antal variable : '); readln(n); until iores=0; repeat write(' Anfør antal bibetingelser : '); readln(m); until iores=0; (*$I+*) n1:=n; end; 'P':begin printer(prin); uddata(true); printer(clos); end; end; until svar in (.'s','S'.); end; (* retdata *) function hentdata; var ok: boolean; begin repeat write(' Hvad er filens navn? (højst 8 bogstaver) '); buflen:=8; readln(fil); writeln; if fil<>'' then fil:=fil+'.LPD'; assign(fil1,fil); (*$I-*) if fil<>'' then reset(fil1);(*$I+*) ok:=iores=0; if not ok and (fil<>'') then writeln(' FEJL. FILEN FINDES IKKE. PRØV IGEN!'); until ok or (fil=''); if fil<>'' then begin read(fil1,r); close(fil1); n:=r.rn; m:=r.rm; n1:=n;end; hentdata:=fil<>''; end; (* hentdata *) procedure gemdata; var p: integer; begin write(' Skal disse data gemmes på en fil? (j/n) '); svar:='j'; readln(svar); writeln; if svar in (.'j','J'.) then begin repeat write(' Hvad er filens navn? (højst 8 bogstaver) '); buflen:=8; readln(fil); writeln; until len(fil)<>0; p:=pos('.',fil); if p>0 then delete(fil,p,1); fil:=fil+'.LPD'; r.rn:=n; r.rm:=m; assign(fil1,fil); rewrite(fil1); write(fil1,r); close(fil1); end; end; (* gemdata *) procedure simplexdata; begin uddata(true); min1:=1; neghs:=0; for i:=1 to m do begin if r.b(.i.)<0 then begin neghs:=neghs+1; for j:=1 to n do begin r.a(.i,j.):=-r.a(.i,j.); if (r.a(.i,j.)>0) and (r.a(.i,j.)<min1) then min1:=r.a(.i,j.); end; r.b(.i.):=-r.b(.i.); r.a(.i,n+neghs.):=-1; r.a(.i,n+m.):=-1; end; end; bigm:=0;vaerdi0:=r.vardi; for j:=1 to n do c0ÆjÅ:=r.cÆjÅ; n1:=n+neghs; if neghs>0 then begin stars:=10*(n1+1)+5; if stars>79 then stars:=79; nykritfkt; end; end; (* simplexdata *) procedure nykritfkt; begin writeln(outf); writeln(outf,' NEGATIV HØJRESIDE.'); writeln(outf,' KRITERIEFUNKTIONEN ÆNDRES VHA. "STRAFFEMETODEN"'); writeln(outf); max1:=abs(r.c(.1.)); for j:=2 to n do begin if abs(r.c(.j.))>max1 then max1:=abs(r.c(.j.)); end; bigm:=8*max1/min1; writeln(outf,' STORE M ER ',bigm:10:3); writeln(outf); if not prt then begin write(' tast return > '); readln(svar); end; for j:=1 to n do begin for i:=1 to m do begin if r.a(.i,n+m.)=-1 then r.c(.j.):=r.c(.j.)+ bigm*r.a(.i,j.); end; end; for j:=n+1 to n1 do r.c(.j.):=-bigm; for i:=1 to m-1 do begin if r.a(.i,n+m.)=-1 then begin r.vardi:=r.vardi-bigm*r.b(.i.); r.a(.i,n+m.):=0; end; end; if r.a(.m,n+m.)=-1 then r.vardi:=r.vardi-bigm*r.b(.m.); uddata(true); end; (* nykritfkt *) procedure korsel; begin for i:=1 to m do bv(.i.):=n1+i; for j:=1 to n1 do ibv(.j.):=j; if not alleud then begin writeln(clrhom); writeln('Antal iterationer:'); end; j:=1; while j<=n1 do begin if r.c(.j.)>0.0001 then begin max:=j; pivot; iteration; if alleud then uddata(true) else write(taller:10); j:=1; end else j:=j+1; end; if not alleud then uddata(true); losning; end; (* korsel *) procedure pivot; var fundet:boolean; begin max:=1; fundet:=false; for j:=2 to n1 do begin if r.c(.j.)>r.c(.max.) then max:=j; end; for i:=1 to m do begin if r.a(.i,max.)>0 then begin kv(.i.):=r.b(.i.)/r.a(.i,max.); fundet:=true; min:=i; end else kv(.i.):=-1; end; if not fundet then begin writeln(clrhom);writeln; writeln('*** UBEGRÆNSET LØSNING. PROGRAMMET STOPPER. ***'); stop; end else begin for i:=1 to m do begin if (kv(.i.)>=0) and (kv(.i.)<kv(.min.)) then min:=i; end; end; end; (* pivot *) procedure iteration; var husk:integer; begin r.a(.min,max.):=1/r.a(.min,max.); for j:=1 to n1 do begin if j<>max then r.a(.min,j.):=r.a(.min,j.)*r.a(.min,max.); end; r.b(.min.):=r.b(.min.)*r.a(.min,max.); for i:=1 to m do begin if i<>min then r.a(.i,max.):=-r.a(.i,max.)*r.a(.min,max.); end; r.c(.max.):=-r.c(.max.)*r.a(.min,max.); for i:=1 to m do begin if i<>min then r.b(.i.):=r.b(.i.)+r.b(.min.)*r.a(.i,max.)/ r.a(.min,max.); end; for j:=1 to n1 do begin if j<>max then r.c(.j.):=r.c(.j.)+r.c(.max.)*r.a(.min,j.)/ r.a(.min,max.); end; for i:=1 to m do begin for j:=1 to n1 do begin if (i<>min) and (j<>max) then begin r.a(.i,j.):=r.a(.i,j.)+r.a(.i,max.)* r.a(.min,j.)/r.a(.min,max.); end; end; end; r.vardi:=r.vardi-r.b(.min.)*r.c(.max.)/r.a(.min,max.); husk:=ibv(.max.); ibv(.max.):=bv(.min.); bv(.min.):=husk; taller:=taller+1; if taller>30 then begin writeln(clrhom);writeln; write('*** PROGRAMMET ER GÅET I LØKKE OG'); writeln(' STOPPER DERFOR. ***'); stop; end; end; (* iteration *) procedure uddata; begin if taller=0 then begin writeln(clrhom); if prt then writeln(outf,@12); writeln(outf); writeln(outf); writeln(outf,' START SIMPLEX-TABELLEN'); stars:=10*(n1+1)+5; if stars>80 then stars:=80; end else begin writeln(outf); writeln(outf); writeln(outf,' SIMPLEX-TABEL NUMMER ',taller); end; for j:=1 to stars do write(outf,'*'); for i:=1 to m do begin for j:=1 to n1 do begin if (j-1) mod 7=0 then writeln(outf); write(outf,r.a(.i,j.):10:3); end; if (n1-1) mod 7=6 then writeln(outf); writeln(outf,' :',r.b(.i.):10:3); end; for j:=1 to stars do write(outf,'-'); for j:=1 to n1 do begin if (j-1) mod 7=0 then writeln(outf); write(outf,r.c(.j.):10:3); end; if (n1-1) mod 7=6 then writeln(outf); writeln(outf,' :',r.vardi:10:3); for j:=1 to stars do write(outf,'*'); if taller>0 then begin for j:=1 to n1 do begin if (j-1) mod 7=0 then writeln(outf); write(outf,ibv(.j.):6,' '); end; writeln(outf); writeln(outf,' Ikke-basis variable.'); end; if (not prt) and (stopud) then begin writeln; write(' Tast return > '); read(svar); end else writeln(outf); end; (* uddata *) procedure losning; var dimet,dimto:integer; fundet:boolean; begin dimet:=0; dimto:=0; vaerdi1:=vaerdi0; writeln(clrhom); if prt then writeln(outf,@12);writeln; if len(fil)>0 then writeln(' ':54,'FIL : ',fil); writeln; for i:=1 to 27 do write(outf,'-'); write(outf,' Løsning til LP opgaven. '); for i:=1 to 27 do write(outf,'-'); writeln(outf); writeln(outf); writeln(outf); writeln(outf,'OPGAVEN ER LØST PÅ ',taller,' ITERATIONER.'); writeln(outf); write(outf,'MAKSIMUM OPNÅS I PUNKTET:'); for j:=1 to n do begin i:=1; fundet:=false; while (not fundet) and (i<=m) do begin if bv(.i.)=j then fundet:=true else i:=i+1; end; if (j-1) mod 4=0 then writeln(outf); if not fundet then write(outf,' X(',j,') = 0 ') else begin write(outf,' X(',j,') = ',r.b(.i.):10:3); vaerdi1:=vaerdi1+r.b(.i.)*c0(.j.); end; end; writeln(outf); writeln(outf); write(outf,'VÆRDIEN AF KRITERIEFUNKTIONEN I DETTE PUNKT ER '); writeln(outf,r.vardi:10:3); writeln(outf); for j:=1 to n1 do begin if r.c(.j.)=0 then dimet:=dimet+1; end; write(outf,'Dimensionen af det primære problems løsningsområde'); writeln(outf,' er: ',dimet); writeln(outf); if abs(vaerdi1-r.vardi)>0.1 then begin writeln(outf,' ADVARSEL! INKONSISTENT LØSNING.'); writeln(outf,' KUNSTIG VARIABEL I BASIS.'); writeln(outf,' VÆRDIEN SKAL VÆRE',vaerdi1:10:3); writeln(outf,' MEN DEN ER BEREGNET TIL',r.vardi:10:3); writeln(outf,' LØSNINGSMÆNGDEN ER TOM') end; if (neghs=0) or (neghs=m) then begin if prt then begin writeln; writeln; end; write(' Ønskes skyggepriser? (j/n) '); readln(svar); writeln; if not(svar in (.'n','N'.)) then begin skyggepris; for i:=1 to m do begin if abs(r.b(.i.))<=0.0001 then dimto:=dimto+1; end; writeln(outf); write(outf,'Dimensionen af det duale problems '); write(outf,'løsningsområde er: '); writeln(outf,dimto); writeln(outf); end; end; if not prt then begin write(' Tast return > '); readln(svar); end else writeln(outf); end; (* losning *) procedure skyggepris; var i,j:integer; fundet:boolean; begin writeln(outf); writeln(outf); write(outf,'SKYGGEPRISER FOR DE INDGÅENDE BEREGNINGER ER:'); for i:=1 to m do begin j:=1; fundet:=false; while (not fundet) and (j<=n1) do begin if ibv(.j.)=i+n1 then fundet:=true else j:=j+1; end; if (i-1) mod 4=0 then writeln(outf); if not fundet then write(outf,' Z(',i,') = 0 ') else write(outf,' Z(',i,') = ',abs(bigm+r.c(.j.)):10:3); end; writeln(outf); writeln(outf); end; (* skyggepris *) begin nulstil; menu; writeln; end. «eof»