1 {===
2 MrCircus v2.02, for a description see Guida
3 Copyright (C) 1999 by Marco Borsari <borsa77@libero.it>
4
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
18
19 You can compile it with Turbo Pascal 5.5+ or FPC 0.99.10+, and the
20 source should follow your dream ;-)
21 ===}
22
23 PROGRAM MrCircus;
24 {$N+,E+}
25 {$IFDEF go32v2}
26 USES emu387;
27 {$ENDIF go32v2}
28 CONST
29 nmax = 100;
30 err : BYTE = 0;
31 TYPE
32 tipo = EXTENDED;
33 vett = ARRAY[1..nmax+1] OF tipo;
34 vettd = ^vett;
35 matr = ARRAY[1..nmax] OF vettd;
36 matrd = ^matr;
37 VAR
38 { </ SIGNIFICATO DELLE VARIABILI: }
39 { n - numero delle equazioni, limitato a nmax }
40 { A - matrice dei coefficienti }
41 { b - vettore dei termini noti }
42 { x - vettore delle incognite }
43 { S - matrice a n+1 colonne per includere A+b }
44 n : INTEGER;
45 S : matrd;
46 { />}
47
48 PROCEDURE Guida;
49 { routine per l'aiuto a linea di comando }
50 BEGIN
51 WRITELN(' ** USER''S GUIDE **');
52 WRITELN('This "bare-bones" program solves a system of linear');
53 WRITELN('equations, first you have to store it on the disk so');
54 WRITELN('you make a text file with name [syst.dat] as follows:');
55 WRITELN('SYSTEM SAMPLE');
56 WRITELN('X(1) - 2.5X(2) = -6');
57 WRITELN('X(1) + 1.5X(2) = 2');
58 WRITELN('FILE SYST.DAT');
59 WRITELN('line 1) #abc <- comment (in any line)');
60 WRITELN('line 2) 2 <- number of equations or unknowns');
61 WRITELN('line 3) 1 <- coefficient of X(1) first equation');
62 WRITELN('line 4) -2.5 <- coefficient of X(2) first equation');
63 WRITELN('line 5) -6 <- first constant');
64 WRITELN('line 6) 1 <- coefficient of X(1) second equation');
65 WRITELN('line 7) 1.5 <- coefficient of X(2) second equation');
66 WRITELN('line 8) 2 <- second constant');
67 WRITELN('Launching mrcircus you may choose the filename');
68 WRITELN('with the solution which will always be overwrite.');
69 HALT(0);
70 END;
71
72 PROCEDURE CreaMatr(VAR m : matrd; dim : INTEGER);
73 { routine per l'allocazione dinamica con controllo sull'heap }
74 VAR
75 i : LONGINT;
76 sp1,sp2 : WORD;
77 BEGIN
78 IF err<2 THEN
79 BEGIN
80 sp1:=dim*SIZEOF(vettd);
81 sp2:=(dim+1)*SIZEOF(tipo);
82 { </ qui i e' usato anche per la memoria totale }
83 i:=sp1+dim*sp2;
84 { />}
85 IF i>MAXAVAIL THEN
86 BEGIN
87 err:=7;
88 m:=NIL;
89 END
90 ELSE
91 BEGIN
92 GETMEM(m,sp1);
93 FOR i:=1 TO dim DO
94 BEGIN
95 GETMEM(m^[i],sp2);
96 FILLCHAR(m^[i]^,sp2,0);
97 END;
98 END;
99 END;
100 END;
101
102 PROCEDURE Opzioni;
103 { routine per la selezione delle opzioni }
104 VAR
105 st : STRING[5];
106 p,q : BYTE;
107 BEGIN
108 WRITELN('MrCircus v2.02, Copyright (C) 1999 by Marco Borsari;');
109 WRITELN('it comes with ABSOLUTELY NO WARRANTY as freeware.');
110 FOR p:=1 TO PARAMCOUNT DO
111 BEGIN
112 st:=PARAMSTR(p);
113 FOR q:=1 TO LENGTH(st) DO st[q]:=UPCASE(st[q]);
114 IF st='-H' THEN Guida;
115 IF st='-T' THEN err:=1;
116 END;
117 END;
118
119 PROCEDURE Carica(VAR n : INTEGER; VAR S : matrd);
120 { routine per caricare il sistema dal disco in memoria }
121 TYPE
122 tipor = STRING[100];
123 VAR
124 f : TEXT;
125
126 FUNCTION Riga : tipor;
127 { routine per leggere le righe dal file di testo }
128 VAR
129 st : tipor;
130 i,j,l : BYTE;
131 BEGIN
132 REPEAT
133 IF SEEKEOF(f) THEN
134 BEGIN
135 err:=4;
136 Riga:='0';
137 END
138 ELSE
139 BEGIN
140 READLN(f,st);
141 { </ elimina gli spazi bianchi che danno errore con VAL }
142 l:=LENGTH(st);
143 i:=1;
144 j:=l;
145 WHILE (i<l) AND (st[i]=' ') DO INC(i);
146 WHILE (j>i) AND (st[j]=' ') DO DEC(j);
147 Riga:=COPY(st,i,j-i+1);
148 { />}
149 END;
150 { </ salta le linee che iniziano con # come commenti }
151 UNTIL (st[1]<>'#') OR (err>1);
152 { />}
153 END;
154
155 PROCEDURE Ini(VAR n : INTEGER; VAR S : matrd);
156 { routine di inizializzazione, n e S passati per indirizzo }
157 VAR
158 i : LONGINT;
159 j,cod : INTEGER;
160 BEGIN
161 { </ qui i e' usato anche come check prima di assegnare n, }
162 { se c'e' un fine file da Riga n viene riassegnato a zero }
163 VAL(Riga,i,cod);
164 IF cod>0 THEN err:=5
165 ELSE IF NOT (i IN [0..nmax]) THEN err:=3
166 ELSE n:=i;
167 { />}
168 CreaMatr(S,n);
169 FOR i:=1 TO n DO
170 BEGIN
171 j:=1;
172 WHILE (j<=n+1) AND (err<2) DO
173 BEGIN
174 VAL(Riga,S^[i]^[j],cod);
175 IF cod>0 THEN err:=5;
176 INC(j);
177 END;
178 END;
179 END;
180
181 BEGIN
182 n:=0;
183 {$I-} ASSIGN(f,'syst.dat');
184 RESET(f); {$I+}
185 IF IORESULT=0 THEN
186 BEGIN
187 Ini(n,S);
188 CLOSE(f);
189 END
190 ELSE err:=2;
191 END;
192
193 PROCEDURE Fattorizzazione(n : INTEGER; S : matrd);
194 { routine della fattorizzazione per trasformazioni elementari di Gauss }
195 VAR
196 i,j,k : INTEGER;
197 m,prec : tipo;
198
199 FUNCTION EPSM : tipo;
200 { routine di calcolo dello zero macchina per il tipo prescelto }
201 VAR
202 a,b : tipo;
203 BEGIN
204 b:=1.0;
205 a:=1.0+b;
206 WHILE (a>1.0) AND (err<2) DO
207 BEGIN
208 b:=b/2.0;
209 a:=1.0+b;
210 END;
211 EPSM:=b;
212 END;
213
214 PROCEDURE Pivotaggio(n,k : INTEGER; S : matrd);
215 { routine di ricerca massimo elemento diagonale sulle righe }
216 TYPE
217 campi = (a,b);
218 tipou = RECORD
219 CASE campi OF
220 a : (i : INTEGER);
221 b : (aus : vettd);
222 END;
223 VAR
224 uni : tipou;
225 magg : INTEGER;
226 BEGIN
227 magg:=k;
228 FOR uni.i:=k+1 TO n DO
229 IF ABS(S^[uni.i]^[k])>ABS(S^[magg]^[k]) THEN magg:=uni.i;
230 uni.aus:=S^[k];
231 S^[k]:=S^[magg];
232 S^[magg]:=uni.aus;
233 END;
234
235 BEGIN
236 prec:=EPSM;
237 k:=1;
238 WHILE (k<=n) AND (err<2) DO
239 BEGIN
240 Pivotaggio(n,k,S);
241 IF ABS(S^[k]^[k])<=prec THEN err:=6
242 ELSE FOR i:=k+1 TO n DO
243 BEGIN
244 m:=S^[i]^[k]/S^[k]^[k];
245 FOR j:=k TO n+1 DO S^[i]^[j]:=S^[i]^[j]-m*S^[k]^[j];
246 END;
247 INC(k);
248 END;
249 END;
250
251 PROCEDURE Soluzione(n : INTEGER; S : matrd);
252 { routine della soluzione del sistema triangolare }
253 VAR
254 pol : tipo;
255 i,j : INTEGER;
256 BEGIN
257 IF err<2 THEN
258 FOR i:=n DOWNTO 1 DO
259 BEGIN
260 pol:=0.0;
261 { </ qui i vettori b e x usano entrambi la colonna n+1 }
262 { perche' non si sovrappongono }
263 FOR j:=i+1 TO n DO pol:=pol+S^[i]^[j]*S^[j]^[n+1];
264 S^[i]^[n+1]:=(S^[i]^[n+1]-pol)/S^[i]^[i];
265 { />}
266 END;
267 END;
268
269 PROCEDURE Salva(n : INTEGER; S : matrd);
270 { routine per salvare la soluzione su disco }
271 CONST
272 st = #10+#13+'try the -h option for more information.';
273 VAR
274 i,j : INTEGER;
275 f : TEXT;
276 nf : STRING[15];
277 BEGIN
278 CASE err OF
279 0..1 : BEGIN
280 REPEAT
281 WRITE('Insert output filename: ');
282 READLN(nf);
283 {$I-} ASSIGN(f,nf);
284 REWRITE(f); {$I+}
285 UNTIL (IORESULT=0) AND (nf<>'');
286 WRITELN(f,'Solution:');
287 FOR i:=1 TO n DO WRITELN(f,'X(',i,')= ',S^[i]^[n+1]:1:10);
288 CLOSE(f);
289 { </ l'opzione -t salva la matrice triangolare }
290 IF err=1 THEN
291 BEGIN
292 ASSIGN(f,'trmatr.dat');
293 REWRITE(f);
294 FOR i:=1 TO n DO
295 BEGIN
296 FOR j:=1 TO n DO WRITE(f,S^[i]^[j]:1:3,' ');
297 WRITELN(f);
298 END;
299 CLOSE(f);
300 END;
301 { />}
302 WRITELN('I hope you have enjoyed the show!');
303 END;
304 2 : WRITELN('!-Error opening file syst.dat,',st);
305 3 : WRITELN('!-Number of equations out of (0-',nmax,'),',st);
306 4 : WRITELN('!-Unexpected end of file in syst.dat,',st);
307 5 : WRITELN('!-Syntax error in syst.dat,',st);
308 6 : WRITELN('!-There is a singular matrix.');
309 7 : WRITELN('!-Not enough memory to run.');
310 END;
311 END;
312
313 BEGIN
314 Opzioni;
315 Carica(n,S);
316 Fattorizzazione(n,S);
317 Soluzione(n,S);
318 Salva(n,S);
319 END.