From 724cc003460ec67eda269911da85c9f9e40aa6cf Mon Sep 17 00:00:00 2001 From: Lars-Dominik Braun Date: Fri, 30 Sep 2016 16:57:23 +0200 Subject: Add extracted sources from floppy disk images Some files have no textual representation (yet) and were added as raw dataspaces. --- datatype/complex | 115 +++++++++++++ datatype/longint | 423 ++++++++++++++++++++++++++++++++++++++++++++++++ datatype/matrix | 482 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ datatype/vector | 213 ++++++++++++++++++++++++ 4 files changed, 1233 insertions(+) create mode 100644 datatype/complex create mode 100644 datatype/longint create mode 100644 datatype/matrix create mode 100644 datatype/vector (limited to 'datatype') diff --git a/datatype/complex b/datatype/complex new file mode 100644 index 0000000..e2139d0 --- /dev/null +++ b/datatype/complex @@ -0,0 +1,115 @@ + +PACKET complex DEFINES COMPLEX,:=,complex zero,complex one,complex i, + complex,realpart,imagpart,CONJ,+,-,*,/,=,<>, + put,get, ABS, sqrt, phi, dphi : + +TYPE COMPLEX = STRUCT(REAL re,im); +COMPLEX PROC complex zero: COMPLEX :(0.0,0.0). END PROC complex zero; +COMPLEX PROC complex one : COMPLEX :(1.0,0.0). END PROC complex one; +COMPLEX PROC complex i : COMPLEX :(0.0,1.0). END PROC complex i; + +OP := (COMPLEX VAR dest, COMPLEX CONST source) : + + CONCR (dest) := CONCR (source) + +ENDOP := ; + +COMPLEX PROC complex(REAL CONST re,im): + COMPLEX :(re,im). +END PROC complex; + +REAL PROC realpart(COMPLEX CONST number): + number.re. +END PROC realpart; + +REAL PROC imagpart(COMPLEX CONST number): + number.im. +END PROC imagpart ; + +COMPLEX OP CONJ(COMPLEX CONST number): + COMPLEX :( number.re,- number.im). +END OP CONJ; + +BOOL OP =(COMPLEX CONST a,b): + IF a.re=b.re + THEN a.im=b.im + ELSE FALSE + FI. +END OP =; + +BOOL OP <>(COMPLEX CONST a,b): + IF a.re=b.re + THEN a.im<>b.im + ELSE TRUE + FI. +END OP <>; + +COMPLEX OP +(COMPLEX CONST a,b): + COMPLEX :(a.re+b.re,a.im+b.im). +END OP +; + +COMPLEX OP -(COMPLEX CONST a,b): + COMPLEX :(a.re-b.re,a.im-b.im). +END OP -; + +COMPLEX OP *(COMPLEX CONST a,b): + REAL VAR re of a::a.re,im of a ::a.im, + re of b::b.re,im of b ::b.im; + COMPLEX :(re of a*re of b- im of a *im of b, + re of a*im of b+ im of a*re of b). +END OP *; + +COMPLEX OP /(COMPLEX CONST a,b): + REAL VAR re of a::a.re,im of a::a.im, + re of b::b.re,im of b::b.im; + REAL VAR sqare sum of re and im ::b.re*b.re+b.im*b.im; + COMPLEX :( (re of a * re of b + im of a * im of b)/sqare sum of re and im, + (im of a *re of b - re of a*im of b)/sqare sum of re and im). +END OP /; + +PROC get(COMPLEX VAR a): + REAL VAR realpart,imagpart; + get(realpart);get(imagpart); + a:= COMPLEX :(realpart,imagpart); +END PROC get; + +PROC put(COMPLEX CONST a): + put(a.re);put(" ");put(a.im); +END PROC put; + +REAL PROC dphi(COMPLEX CONST x): + IF imagpart(x)=0.0 THEN reell + ELIF realpart(x)=0.0 THEN imag + ELIF realpart(x)>0.0 THEN realpositiv + ELSE realnegativ + FI. +reell: IF sign(realpart(x)) < 0 THEN 180.0 ELSE 0.0 FI. +imag: IF imagpart(x)>0.0 THEN 90.0 ELSE 270.0 FI. +realpositiv:IF imagpart(x)>0.0 THEN arctand(realpart(x)/imagpart(x)) + ELSE +arctand(realpart(x)/imagpart(x))+360.0 FI. +realnegativ: arctand(realpart(x)/imagpart(x))+180.0. +END PROC dphi; + +REAL PROC phi(COMPLEX CONST x): +dphi(x)*3.141592653689793/180.0. +END PROC phi; + +COMPLEX PROC sqrt(COMPLEX CONST x): +IF x=complex zero THEN x +ELIF realpart(x)<0.0 THEN +complex(imagpart(x)/(2.0*real(sign(imagpart(x))) + *sqrt((ABSx-realpart(x))/2.0)), + real(sign(imagpart(x)))*sqrt((ABS x-realpart(x))/2.0)) +ELSE complex(sqrt((ABS x+realpart(x))/2.0), + imagpart(x)/(2.0*sqrt((ABS x+realpart(x))/2.0))) +FI. + +END PROC sqrt; + +REAL OP ABS(COMPLEX CONST x): + sqrt(realpart(x)*realpart(x)+imagpart(x)*imagpart(x)). +END OP ABS; + +END PACKET complex; + diff --git a/datatype/longint b/datatype/longint new file mode 100644 index 0000000..e78bb52 --- /dev/null +++ b/datatype/longint @@ -0,0 +1,423 @@ +PACKET longint DEFINES LONGINT, (* Autoren: S.Baumann,A.Bentrup *) + :=, (* T.Sillke *) + <, (* Stand: 17.03.81 *) + >, + <=, + >=, + <>, + =, + -, + +, + *, + **, + ABS, + abs, + DECR, + DIV, + get, + INCR, + int, + (*last rest,*) + longint, + max, + max longint, + min, + MOD, + put, + random, + SIGN, + sign, + text, + zero: + +TYPE LONGINT = TEXT; + +LONGINT VAR result,aleft,aright; +TEXT VAR ergebnis,x,y,z,h; +INT VAR v byte,slr,sll; +INT CONST snull :: code("0"), mtl :: 300 ; +TEXT CONST negativ :: code(127),max digit :: code(99),null :: code(0), + overflow :: "LONGINT overflow",eins :: code(1); +BOOL VAR vorl,vorr,vleft,vright; + +OP := (LONGINT VAR left, LONGINT CONST right) : + CONCR(left) := CONCR(right) +END OP :=; + +BOOL OP < (LONGINT CONST left,right) : + slr := sign(right)*length(right); + sll := sign(left )*length(left ); + IF slr <> sll THEN + IF slr > sll THEN TRUE ELSE FALSE FI + ELSE IF slr>0 + THEN CONCR(left) < CONCR(right) + ELSE CONCR(left) > CONCR(right) FI + FI +END OP < ; + +BOOL OP > (LONGINT CONST left,right) : + slr := sign(right)*length(right); + sll := sign(left )*length(left ); + IF slr <> sll THEN + IF slr < sll THEN TRUE ELSE FALSE FI + ELSE IF slr>0 + THEN CONCR(left) > CONCR(right) + ELSE CONCR(left) < CONCR(right) FI + FI +END OP > ; + +BOOL OP <= (LONGINT CONST left,right) : + NOT (left > right) +END OP <=; + +BOOL OP >= (LONGINT CONST left,right) : + NOT (left < right) +END OP >=; + +BOOL OP <> (LONGINT CONST left,right) : + CONCR (left) <> CONCR (right) +END OP <>; + +BOOL OP = (LONGINT CONST left,right) : + CONCR (left) = CONCR (right) +END OP = ; + +LONGINT OP - (LONGINT CONST arg) : + SELECT code(CONCR(arg)SUB1) OF + CASE 0 : zero + CASE 127: LONGINT : (subtext(CONCR(arg),2)) + OTHERWISE LONGINT : (negativ + CONCR(arg)) + END SELECT +END OP -; + +LONGINT OP + (LONGINT CONST arg) : arg END OP +; + +LONGINT OP - (LONGINT CONST left,right) : + IF CONCR(left ) = null THEN LEAVE - WITH -right + ELIF CONCR(right) = null THEN LEAVE - WITH left + ELIF sign(left) <> sign(right) THEN LEAVE - WITH left + (-right) FI; + betrag(left,right); + BOOL CONST betrag max :: aleft > aright; + IF betrag max + THEN result := LONGINT : (CONCR(aleft ) SUB CONCR(aright)) + ELSE result := LONGINT : (CONCR(aright) SUB CONCR(aleft )) FI; + kuerze fuehrende nullen(CONCR(result),null); + IF vleft XOR betrag max THEN -result ELSE result FI +END OP -; + +LONGINT OP + (LONGINT CONST left,right) : + IF sign(left) <> sign(right) THEN LEAVE + WITH left - (-right) FI; + betrag(left,right); + IF aleft > aright + THEN result := LONGINT : (CONCR(aleft ) ADD CONCR(aright)) + ELSE result := LONGINT : (CONCR(aright) ADD CONCR(aleft )) FI; + IF vleft THEN result ELSE -result FI +END OP +; + +LONGINT OP * (LONGINT CONST left,right) : + IF CONCR(left) = null OR CONCR(right) = null THEN LEAVE * WITH zero + ELIF length(left) + length(right) > mtl THEN errorstop (overflow) FI; + betrag(left,right); + IF aleft < aright + THEN result := LONGINT : (CONCR(aright) MUL CONCR(aleft )) + ELSE result := LONGINT : (CONCR(aleft ) MUL CONCR(aright)) FI; + IF length(CONCR(result)) = mtl THEN errorstop(overflow) FI; + IF vleft XOR vright THEN -result ELSE result FI +END OP *; + +LONGINT OP ** (LONGINT CONST arg,exp) : + IF exp > longint(max int) THEN errorstop (overflow) FI; + arg ** int(exp) +END OP **; + +LONGINT OP ** (LONGINT CONST arg,INT CONST exp) : + IF exp < 0 THEN errorstop ("LONGINT OP ** : negativ exp") + ELIF CONCR(arg)=null AND exp=0 THEN errorstop(text(0 ** 0)) FI; + IF exp = 0 THEN one + ELIF exp = 1 THEN arg + ELIF sign(arg) = -1 AND exp MOD 2 <> 0 + THEN -LONGINT:(CONCR(abs(arg))EXPexp) + ELSE LONGINT:(CONCR(abs(arg))EXPexp) FI +END OP **; + +LONGINT OP ABS (LONGINT CONST arg) : abs(arg) END OP ABS; + +LONGINT PROC abs (LONGINT CONST a) : + IF (CONCR(a)SUB1)=negativ THEN LONGINT:(subtext(CONCR(a),2)) ELSE a FI +END PROC abs; + +OP DECR (LONGINT VAR result,LONGINT CONST ab) : + result := result - ab; +END OP DECR; + +LONGINT OP DIV (LONGINT CONST left,right) : + IF CONCR(right) = null THEN error stop("LONGINT OP DIV by zero") FI; + betrag(left,right); h := CONCR(aright); + y := null + CONCR(aleft ); vorl := vleft; + z := null + CONCR(aright); vorr := vright; + IF aleft < aright THEN y:=CONCR(aleft); LEAVE DIV WITH zero FI; + INT VAR try,i,cr1 :: code(z SUB 2),cr2,cr3,zw; + BOOL VAR sh :: length(z) <> 2; + IF sh THEN cr3:=code(zSUB3); cr2:=10*cr1+cr3DIV10; cr3:=100*cr1+cr3 FI; + CONCR(result) := ""; + FOR i FROM 0 UPTO length(y)-length(z) REP + laufe eine abschaetzung durch; + CONCR (result) CAT code(try) + PER; kuerze fuehrende nullen(y,null); + IF(CONCR(result)SUB1)=nullTHEN CONCR(result):=subtext(CONCR(result),2)FI; + IF vleft XOR vright THEN -result ELSE result FI. + + laufe eine abschaetzung durch : + zw := 100*code(y SUB i+1) + code(y SUB i+2); + IF zw < 3276 AND sh THEN IF zw < 327 + THEN try := min((100*zw + code(ySUBi+3)) DIV cr3, 99) + ELSE try := min(( 10*zw + code(ySUBi+3)DIV10)DIV cr2, 99) FI + ELSE try := min( zw DIV cr1, 99) FI; + x := z MUL code(try); + WHILE x > subtext(y,i+1,i+length(x)) REP + try DECR 1; x := x SUB z PER; + replace(y,i + 1,subtext(y,i + 1,i + length(x)) SUB x) +END OP DIV; + +PROC get (LONGINT VAR result) : + get (ergebnis); + result := longint(ergebnis); +END PROC get; + +PROC get (FILE VAR file,LONGINT VAR result) : + get(file,ergebnis); + result := longint(ergebnis); +END PROC get; + +OP INCR (LONGINT VAR result,LONGINT CONST dazu) : + result := result + dazu; +END OP INCR; + +INT PROC int (LONGINT CONST longint) : + IF length(longint) > 3 + THEN max int + 1 + ELSE ergebnis := (3-length(longint))*null + CONCR(abs(longint)); + (code(ergebnis SUB 1) * 10000 + + code(ergebnis SUB 2) * 100 + + code(ergebnis SUB 3)) * sign(longint) + FI +END PROC int; + +LONGINT PROC longint (INT CONST int) : + CONCR(result) := code( abs(int) DIV 10000) + + code((abs(int) MOD 10000) DIV 100) + + code( abs(int) MOD 100); + kuerze fuehrende nullen (CONCR(result),null); + IF int < 1 THEN -result ELSE result FI +END PROC longint; + +LONGINT PROC longint (TEXT CONST text) : + INT VAR i; + ergebnis := compress(text); + BOOL VAR minus :: (ergebnisSUB1) = "-"; + IF (ergebnisSUB1)="+" OR minus THEN ergebnis:=subtext(ergebnis,2) FI; + kuerze fuehrende nullen(ergebnis,"0"); + kuerze die unzulaessigen zeichen aus ergebnis; + schreibe ergebnis im hundertersystem in result; + result mit vorzeichen. + + kuerze die unzulaessigen zeichen aus ergebnis : + ergebnis := subtext(ergebnis,1,letztes zulaessiges zeichen). + letztes zulaessiges zeichen : + FOR i FROM 1 UPTO length(ergebnis) REP + UNTIL pos("0123456789", ergebnis SUB i) = 0 PER; + i - 1. + schreibe ergebnis im hundertersystem in result : + sll := length(ergebnis); + IF sll MOD 2 <> 0 THEN ergebnis := "0"+ergebnis; sll INCR 1 FI; + i := 1; CONCR(result) := ""; + REP schreibe ein zeichen im hundertersystem in result; + i INCR 2 + UNTIL i >= sll PER. + schreibe ein zeichen im hundertersystem in result : + CONCR(result) CAT code((code(ergebnis SUB i ) - snull) * 10 + + code(ergebnis SUB i + 1) - snull). + result mit vorzeichen : + IF ergebnis="" THEN zero ELIF minus THEN -result ELSE result FI +END PROC longint; + +LONGINT PROC max (LONGINT CONST left,right) : + IF left > right THEN left ELSE right FI +END PROC max; + +LONGINT PROC max longint : + LONGINT : ((mtl - 1) * max digit) +END PROC max longint; + +LONGINT PROC min (LONGINT CONST left,right) : + IF left < right THEN left ELSE right FI +END PROC min; + +LONGINT OP MOD (LONGINT CONST left,right) : + IF CONCR(right) = null THEN errorstop("LONGINT OP MOD by zero") FI; + result := left DIV right; last rest +END OP MOD; + +PROC put (LONGINT CONST longint) : + INT VAR i :: 1,zwei ziffern; + IF sign(longint) = -1 THEN out("-"); i:=2 FI; + out(text(code(CONCR(longint) SUB i))); + FOR i FROM i + 1 UPTO length(CONCR(longint)) REP + zwei ziffern := code(CONCR(longint) SUB i); + out(code(zwei ziffern DIV 10 + snull)); + out(code(zwei ziffern MOD 10 + snull)); + PER;out(" ") +END PROC put; + +PROC put (FILE VAR file,LONGINT CONST longint) : + put(file,text(longint)); +END PROC put; + +LONGINT PROC random (LONGINT CONST lower bound,upper bound) : + INT VAR i; x := CONCR(upper bound - lower bound - one); y := ""; + FOR i FROM 1 UPTO length(x) REP y CAT code(random(0,99)) PER; + upper bound - (LONGINT : (y) MOD LONGINT : (x)) +END PROC random; + +INT OP SIGN (LONGINT CONST arg) : sign(arg) END OP SIGN; + +INT PROC sign (LONGINT CONST arg) : + SELECT code(CONCR(arg) SUB 1) OF + CASE 0 : 0 + CASE 127 : -1 + OTHERWISE 1 + END SELECT +END PROC sign; + +TEXT PROC text (LONGINT CONST longint) : + INT VAR i::1,zwei ziffern; ergebnis := ""; + IF sign(longint) = -1 THEN ergebnis := "-"; i:=2 FI; + ergebnis CAT text (code (CONCR (longint) SUB i ) ) ; + FOR i FROM i+1 UPTO length(CONCR(longint)) REP + zwei ziffern := code(CONCR(longint) SUB i); + ergebnis CAT code(zwei ziffern DIV 10 + snull); + ergebnis CAT code(zwei ziffern MOD 10 + snull) + PER; ergebnis +END PROC text; + +TEXT PROC text (LONGINT CONST longint,INT CONST length) : + x := text(longint); sll := LENGTH x; + IF sll > length THEN length * "*" ELSE (length - sll)*" " + x FI +END PROC text; + +LONGINT PROC last rest : + IF y=null THEN LEAVE last rest WITH zero FI; + IF vorl XOR vorr THEN y := h SUB y; kuerze fuehrende nullen(y,null); + vorl := TRUE FI; + IF NOTvorr THEN y:=negativ+y; vorr := TRUE FI; LONGINT:(y) +END PROC last rest; + +LONGINT PROC zero : LONGINT : (null) END PROC zero; +LONGINT PROC one : LONGINT : (""1"") END PROC one; + + +(* ----------------------- INTERNE HILFSPROZEDUREN ----------------------- *) + +TEXT OP ADD (TEXT CONST left,right) : + INT VAR carrybit :: 0,i,dif :: length(left) - length(right); + ergebnis := left; + FOR i FROM length(left) DOWNTO dif + 1 REP + replace(ergebnis,i,das result der addition) + PER; + IF carrybit = 1 THEN addiere den uebertrag FI; + ergebnis. + + das result der addition : + v byte := (code(left SUB i) + code(right SUB i - dif) + carrybit); + IF v byte > 99 + THEN carrybit := 1; code(v byte - 100) + ELSE carrybit := 0; code(v byte) + FI. + addiere den uebertrag : + FOR i FROM i DOWNTO 1 + WHILE (ergebnis SUB i) >= max digit REP + replace(ergebnis,i,null) + PER; + IF (ergebnis SUB 1) = null OR dif = 0 + THEN pruefe auf longint overflow + ELSE replace(ergebnis,i,code(code(ergebnis SUB i) + 1)) + FI. + pruefe auf longint overflow : + IF length(ergebnis) = mtl - 1 THEN errorstop(overflow) FI; + ergebnis := eins + ergebnis +END OP ADD; + +PROC betrag (LONGINT CONST a, b) : + vleft := (CONCR(a)SUB1)<>negativ; vright := (CONCR(b)SUB1)<>negativ; + IF vleft THEN aleft :=a ELSE CONCR(aleft ):=subtext(CONCR(a),2) FI; + IF vright THEN aright:=b ELSE CONCR(aright):=subtext(CONCR(b),2) FI +END PROC betrag; + +TEXT OP EXP (TEXT CONST arg,INT CONST exp) : + INT VAR zaehler :: exp; + x := arg; z := eins; + REP IF zaehler MOD 2 = 1 THEN z := z MUL x FI; + zaehler := zaehler DIV 2; x := x MUL x + UNTIL zaehler = 1 PER; + x MUL z +END OP EXP; + +PROC kuerze fuehrende nullen ( TEXT VAR text,TEXT CONST snull) : + INT VAR i; + text := subtext(text,erste nicht snull). + + erste nicht snull : + FOR i FROM 1 UPTO length (text) - 1 REP + UNTIL (text SUB i) <> snull PER; + i +END PROC kuerze fuehrende nullen; + +INT PROC length (LONGINT CONST a) : + IF (CONCR(a)SUB1)=negativ THEN length(CONCR(a))-1 ELSE length(CONCR(a)) FI +END PROC length; + +TEXT OP MUL (TEXT CONST left,right) : + INT VAR i,j,carrybit,v,w; + ergebnis := (length(left) + length(right) - 1) * null; + FOR i FROM length(ergebnis) DOWNTO length(left) REP + v := i - length(left); w := length(right) - length(ergebnis) + i; + carrybit := 0; + FOR j FROM length(left) DOWNTO 1 REP + replace(ergebnis,v + j,result der addition) + PER; + replace(ergebnis,v,code(code(ergebnis SUB v) + carrybit)); + PER; + IF carrybit = 0 THEN ergebnis ELSE code(carrybit) + ergebnis FI. + + result der addition : + v byte := code(right SUB w) * code(left SUB j) + carrybit + + code(ergebnis SUB v + j); + carrybit := v byte DIV 100; + code(v byte MOD 100) +END OP MUL; + +TEXT OP SUB (TEXT CONST left,right) : + INT VAR carrybit :: 0,i,dif :: length(left) - length(right); + ergebnis := left; + FOR i FROM length(left) DOWNTO dif + 1 REP + replace(ergebnis,i,das result der subtraktion); + PER; + IF carrybit = 1 THEN subtrahiere den uebertrag FI; + ergebnis. + + das result der subtraktion : + v byte := (code(left SUB i) - code(right SUB i - dif) - carrybit); + IF v byte < 0 + THEN carrybit := 1;code(v byte + 100) + ELSE carrybit := 0;code(v byte) + FI. + subtrahiere den uebertrag : + FOR i FROM i DOWNTO 2 + WHILE (ergebnis SUB i) = null REP + replace(ergebnis,i,max digit) + PER; + replace(ergebnis,i,code(code(ergebnis SUB i) - 1)) +END OP SUB; + +END PACKET longint; + diff --git a/datatype/matrix b/datatype/matrix new file mode 100644 index 0000000..d9de9fb --- /dev/null +++ b/datatype/matrix @@ -0,0 +1,482 @@ +PACKET matrix DEFINES MATRIX, matrix, idn, (* Stand : 16.06.86 wk *) + :=, sub, (* Autor : H.Indenbirken *) + row, column, + COLUMNS, + ROWS, + DET, + INV, + TRANSP, + transp, + replace row, replace column, + replace element, + get, put, + =, <>, + +, -, * : + +TYPE MATRIX = STRUCT (INT rows, columns, VECTOR elems); +TYPE INITMATRIX = STRUCT (INT rows, columns, REAL value, BOOL idn); + +MATRIX VAR a :: idn (1); +INT VAR i; + +(**************************************************************************** +PROC dump (MATRIX CONST m) : + put line (text (m.rows) + " Reihen, " + text (m.columns) + " Spalten."); + dump (m.elems) . + +END PROC dump; +****************************************************************************) + +OP := (MATRIX VAR l, MATRIX CONST r) : + CONCR (l) := CONCR (r); +END OP :=; + +OP := (MATRIX VAR l, INITMATRIX CONST r) : + l.rows := r.rows; + l.columns := r.columns; + l.elems := vector (r.rows*r.columns, r.value); + IF r.idn + THEN idn FI . + +idn : + INT VAR i; + FOR i FROM 1 UPTO r.rows + REP replace (l.elems, calc pos (l.columns, i, i), 1.0) PER + +END OP :=; + +INITMATRIX PROC matrix (INT CONST rows, columns, REAL CONST value) : + IF rows <= 0 + THEN errorstop ("PROC matrix : rows <= 0") + ELIF columns <= 0 + THEN errorstop ("PROC matrix : columns <= 0") FI; + + INITMATRIX : (rows, columns, value, FALSE) + +END PROC matrix; + +INITMATRIX PROC matrix (INT CONST rows, columns) : + matrix (rows, columns, 0.0) + +END PROC matrix; + +INITMATRIX PROC idn (INT CONST size) : + IF size <= 0 + THEN errorstop ("MATRIX PROC idn : size <= 0") FI; + + INITMATRIX : (size, size, 0.0, TRUE) + +END PROC idn; + +VECTOR PROC row (MATRIX CONST m, INT CONST i) : + VECTOR VAR v :: vector (m.columns); + INT VAR j, k :: 1, pos :: (i-1) * m.columns; + FOR j FROM pos+1 UPTO pos + m.columns + REP replace (v, k, m.elems SUB j); + k INCR 1 + PER; + v + +END PROC row; + +VECTOR PROC column (MATRIX CONST m, INT CONST j) : + VECTOR VAR v :: vector (m.rows); + INT VAR i, k :: j; + FOR i FROM 1 UPTO m.rows + REP replace (v, i, m.elems SUB k); + k INCR m.columns + PER; + v + +END PROC column; + +INT OP COLUMNS (MATRIX CONST m) : + m.columns + +END OP COLUMNS; + +INT OP ROWS (MATRIX CONST m) : + m.rows + +END OP ROWS; + +REAL PROC sub (MATRIX CONST a, INT CONST row, column) : + a.elems SUB calc pos (a.columns, row, column) + +END PROC sub; + +PROC replace row (MATRIX VAR m, INT CONST rowindex, VECTOR CONST rowvalue) : + test ("PROC replace row : ", "LENGTH rowvalue", "COLUMNS m", + LENGTH rowvalue, m.columns); + test ("PROC replace row : row ", rowindex, m.rows); + + INT VAR i, pos :: (rowindex-1) * m.columns; + FOR i FROM 1 UPTO m.columns + REP replace (m.elems, pos+i, rowvalue SUB i) PER + +END PROC replace row; + +PROC replace column (MATRIX VAR m, INT CONST columnindex, + VECTOR CONST columnvalue) : + test ("PROC replace column : ", "LENGTH columnvalue", "ROWS m", + LENGTH columnvalue, m.rows); + test ("PROC replace column : column ", columnindex, m.columns); + + INT VAR i; + FOR i FROM 1 UPTO m.rows + REP replace (m.elems, calc pos (m.columns, i, columnindex), + columnvalue SUB i) PER + +END PROC replace column; + +PROC replace element (MATRIX VAR a, INT CONST row, column, REAL CONST x) : + test ("PROC replace element : row ", row, a.rows); + test ("PROC replace element : column ", column, a.columns); + replace (a.elems, calc pos (a.columns, row, column), x) + +END PROC replace element; + +BOOL OP = (MATRIX CONST l, r) : + IF l.rows <> r.rows + THEN FALSE + ELIF l.columns <> r.columns + THEN FALSE + ELSE l.elems = r.elems FI + +END OP =; + +BOOL OP <> (MATRIX CONST l, r) : + IF l.rows <> r.rows + THEN TRUE + ELIF l.columns <> r.columns + THEN TRUE + ELSE l.elems <> r.elems FI + +END OP <>; + +INT PROC calc pos (INT CONST columns, z, s) : + (z-1) * columns + s +END PROC calc pos; + +MATRIX OP + (MATRIX CONST m) : + m + +END OP +; + +MATRIX OP + (MATRIX CONST l, r) : + test ("MATRIX OP + : ", "ROWS l", "ROWS r", l.rows, r.rows); + test ("MATRIX OP + : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns); + + a := l; + INT VAR i; + FOR i FROM 1 UPTO l.rows * l.columns + REP replace (a.elems, i, (l.elems SUB i) + (r.elems SUB i)) + PER; + a + +END OP +; + +MATRIX OP - (MATRIX CONST m) : + a := m; + INT VAR i; + FOR i FROM 1 UPTO m.rows * m.columns + REP replace (a.elems, i, -a.elems SUB i) + PER; + a + +END OP -; + +MATRIX OP - (MATRIX CONST l, r) : + test ("MATRIX OP - : ", "ROWS l", "ROWS r", l.rows, r.rows); + test ("MATRIX OP - : ", "COLUMNS l", "COLUMNS r", l.columns, r.columns); + + a := l; + INT VAR i; + FOR i FROM 1 UPTO l.rows * l.columns + REP replace (a.elems, i, (l.elems SUB i) - (r.elems SUB i)) + PER; + a + +END OP -; + +MATRIX OP * (REAL CONST x, MATRIX CONST m) : + m*x + +END OP *; + +MATRIX OP * (MATRIX CONST m, REAL CONST x) : + a := m; + INT VAR i; + FOR i FROM 1 UPTO m.rows * m.columns + REP replace (a.elems, i, x*m.elems SUB i) PER; + a + +END OP *; + +VECTOR OP * (VECTOR CONST v, MATRIX CONST m) : + test ("VECTOR OP * : ", "LENGTH v", "ROWS m", LENGTH v, m.rows); + VECTOR VAR result :: vector (m.columns); (*wk*) + INT VAR i; + FOR i FROM 1 UPTO m.columns + REP replace (result, i, v * column (m, i)) PER; + result . + +END OP *; + +VECTOR OP * (MATRIX CONST m, VECTOR CONST v) : + test ("VECTOR OP * : ", "COLUMNS m", "LENGTH v", COLUMNS m, LENGTH v); + VECTOR VAR result :: vector (m.rows); (*wk*) + INT VAR i; + FOR i FROM 1 UPTO m.rows + REP replace (result, i, row (m, i) * v) PER; + result . + +END OP *; + +MATRIX OP * (MATRIX CONST l, r) : + test ("MATRIX OP * : ","COLUMNS l","ROWS r", l.columns, r.rows); + + a.rows := l.rows; + a.columns := r.columns; + a.elems := vector (a.rows*a.columns) + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP VECTOR VAR rl :: row (l, i), cr :: column (r, j); + replace (a.elems, calc pos (a.columns, i, j), rl * cr) + PER + PER; + a . + +END OP *; + +PROC get (MATRIX VAR a, INT CONST rows, columns) : + + a := matrix (rows,columns); + INT VAR i, j; + VECTOR VAR v; + FOR i FROM 1 UPTO rows + REP get (v, columns); + store row + PER . + +store row : + FOR j FROM 1 UPTO a.columns + REP replace (a.elems, calc pos (a.columns, i, j), v SUB j) + PER . + +END PROC get; + +PROC put (MATRIX CONST a, INT CONST length, fracs) : + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP put (text (sub (a, i, j), length, fracs)) PER; + line (2); + PER + +END PROC put; + +PROC put (MATRIX CONST a) : + INT VAR i, j; + FOR i FROM 1 UPTO a.rows + REP FOR j FROM 1 UPTO a.columns + REP TEXT CONST number :: " " + text (sub (a, i, j)); + put (subtext (number, LENGTH number - 15)) + PER; + line (2); + PER + +END PROC put; + +TEXT VAR error :: ""; +PROC test (TEXT CONST proc, l text, r text, INT CONST left, right) : + IF left <> right + THEN error := proc; + error CAT l text; + error CAT " ("; + error CAT text (left); + error CAT ") <> "; + error CAT r text; + error CAT " ("; + error CAT text (right); + error CAT ")"; + errorstop (error) + FI . + +END PROC test; + +PROC test (TEXT CONST proc, INT CONST i, n) : + IF i < 1 + THEN error := proc; + error CAT "subscript underflow ("; + error CAT text (i); + error CAT ")"; + errorstop (error) + ELIF i > n + THEN error := proc; + error CAT "subscript overflow (i="; + error CAT text (i); + error CAT ", max="; + IF n <= 0 + THEN error CAT "undefined" + ELSE error CAT text (n) FI; + error CAT ")"; + errorstop (error) + FI + +END PROC test; + + +MATRIX OP TRANSP (MATRIX CONST m) : + MATRIX VAR a :: m; + transp (a); + a + +END OP TRANSP; + +PROC transp (MATRIX VAR m) : + INT VAR k :: 1, n :: m.rows*m.columns; + a := m; + FOR i FROM 2 UPTO n + REP replace (m.elems, i, a.elems SUB position) PER; + a := idn (1); + i := m.rows; + m.rows := m.columns; + m.columns := i . + +position : + k INCR m.columns; + IF k > n + THEN k DECR (n-1) FI; + k . +END PROC transp; + +MATRIX OP INV (MATRIX CONST m) : + a := m; + ROW 32 INT VAR pivots; + INT VAR i, j, k :: ROWS a, n :: COLUMNS a, pos; + + IF n <> k + THEN errorstop ("MATRIX OP INV : no square matrix") FI; + + initialisiere die pivotpositionen; + + FOR j FROM 1 UPTO n + REP pivotsuche (a, j, pos); + IF sub (a, pos, pos) = 0.0 + THEN errorstop ("MATRIX OP INV : singular matrix") FI; + zeilentausch (a, j, pos); + merke dir die vertauschung; + transformiere die matrix + PER; + + spaltentausch; + a . + +initialisiere die pivotpositionen : + FOR i FROM 1 UPTO n + REP pivots [i] := i PER . + +merke dir die vertauschung : + IF pos > j + THEN INT VAR hi :: pivots [j]; + pivots [j] := pivots [pos]; + pivots [pos] := hi + FI . + +transformiere die matrix : + REAL VAR h := 1.0/sub (a, j, j); + + FOR k FROM 1 UPTO n + REP IF k <> j + THEN FOR i FROM 1 UPTO n + REP IF i <> j + THEN replace element (a, i, k, sub (a, i, k) - + sub (a, i, j)*sub (a, j, k)*h); + FI + PER; + FI + PER; + + FOR k FROM 1 UPTO n + REP replace element (a, j, k, -h*sub (a, j, k)); + replace element (a, k, j, h*sub (a, k, j)) + PER; + replace element (a, j, j, h) . + +spaltentausch : + VECTOR VAR v :: vector (n); + FOR i FROM 1 UPTO n + REP FOR k FROM 1 UPTO n + REP replace (v, pivots [k], sub(a, i, k)) PER; + replace row (a, i, v) + PER . + +END OP INV; + +REAL OP DET (MATRIX CONST m) : + IF COLUMNS m <> ROWS m + THEN errorstop ("REAL OP DET : no square matrix") FI; + + a := m; + INT VAR i, j, k, n :: COLUMNS m, pos; + REAL VAR merker := 1.0; + FOR j FROM 1 UPTO n + REP pivotsuche (a, j, pos); + IF j<> pos + THEN zeilentausch (a, j, pos); + zeilen tausch merken + FI; + transformiere die matrix + PER; + produkt der pivotelemente . + +transformiere die matrix : + REAL VAR hp := sub(a,j,j); + IF hp = 0.0 + THEN LEAVE DET WITH 0.0 + ELSE REAL VAR h := 1.0/hp; + FI; + FOR i FROM j+1 UPTO n + REP FOR k FROM j+1 UPTO n + REP replace element (a, i, k, sub (a, i, k) - + sub (a, i, j)*h*sub (a, j, k)) + PER + PER . + +produkt der pivotelemente : + REAL VAR produkt :: sub (a, 1, 1); + FOR j FROM 2 UPTO n + REP produkt := produkt * sub (a, j, j) PER; + a := idn (1); + produkt * merker. + +zeilen tausch merken: + merker := merker * (-1.0). + +END OP DET; + +PROC pivotsuche (MATRIX CONST a, INT CONST start pos, INT VAR pos) : + REAL VAR max :: abs (sub (a, start pos, start pos)); + INT VAR i; + pos := start pos; + + FOR i FROM start pos+1 UPTO COLUMNS a + REP IF abs (sub (a, i, start pos)) > max + THEN max := abs (sub (a, i, start pos)); + pos := i + FI + PER . + +END PROC pivotsuche; + +PROC zeilentausch (MATRIX VAR a, INT CONST old pos, pos) : + VECTOR VAR v := row (a, pos); + replace row (a, pos, row (a, old pos)); + replace row (a, old pos, v) . + +END PROC zeilentausch; + +END PACKET matrix; + diff --git a/datatype/vector b/datatype/vector new file mode 100644 index 0000000..5c9e896 --- /dev/null +++ b/datatype/vector @@ -0,0 +1,213 @@ +PACKET vector DEFINES VECTOR, :=, vector, (* Autor : H.Indenbirken *) + SUB, LENGTH, length, norm, (* Stand : 21.10.83 *) + nilvector, replace, =, <>, + +, -, *, /, + get, put : + + +TYPE VECTOR = STRUCT (INT lng, TEXT elem); +TYPE INITVECTOR = STRUCT (INT lng, REAL value); + +INT VAR i; +TEXT VAR t :: "12345678"; +VECTOR VAR v :: nilvector; + +(**************************************************************************** +PROC dump (VECTOR CONST v) : + put line (text (v.lng) + " Elemente :"); + FOR i FROM 1 UPTO v.lng + REP put line (text (i) + ": " + text (element i)) PER . + +element i : + v.elem RSUB i . + +END PROC dump; +****************************************************************************) + +OP := (VECTOR VAR l, VECTOR CONST r) : + l.lng := r.lng; + l.elem := r.elem + +END OP :=; + +OP := (VECTOR VAR l, INITVECTOR CONST r) : + l.lng := r.lng; + replace (t, 1, r.value); + l.elem := r.lng * t + +END OP :=; + +INITVECTOR PROC nilvector : + vector (1, 0.0) + +END PROC nilvector; + +INITVECTOR PROC vector (INT CONST lng, REAL CONST value) : + IF lng <= 0 + THEN errorstop ("PROC vector : lng <= 0") FI; + INITVECTOR : (lng, value) + +END PROC vector; + +INITVECTOR PROC vector (INT CONST lng) : + vector (lng, 0.0) + +END PROC vector; + +REAL OP SUB (VECTOR CONST v, INT CONST i) : + test ("REAL OP SUB : ", v, i); + v.elem RSUB i + +END OP SUB; + +INT OP LENGTH (VECTOR CONST v) : + v.lng + +END OP LENGTH; + +INT PROC length (VECTOR CONST v) : + v.lng + +END PROC length; + +REAL PROC norm (VECTOR CONST v) : + REAL VAR result :: 0.0; + FOR i FROM 1 UPTO v.lng + REP result INCR ((v.elem RSUB i)**2) PER; + sqrt (result) . + +END PROC norm; + +PROC replace (VECTOR VAR v, INT CONST i, REAL CONST r) : + test ("PROC replace : ", v, i); + replace (v.elem, i, r) + +END PROC replace; + +BOOL OP = (VECTOR CONST l, r) : + l.elem = r.elem +END OP =; + +BOOL OP <> (VECTOR CONST l, r) : + l.elem <> r.elem +END OP <>; + +VECTOR OP + (VECTOR CONST v) : + v +END OP +; + +VECTOR OP + (VECTOR CONST l, r) : + test ("VECTOR OP + : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) + (r.elem RSUB i)) PER; + v + +END OP +; + +VECTOR OP - (VECTOR CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, - (a.elem RSUB i)) PER; + v + +END OP -; + +VECTOR OP - (VECTOR CONST l, r) : + test ("VECTOR OP - : ", l, r); + v := l; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (l.elem RSUB i) - (r.elem RSUB i)) PER; + v +END OP -; + +REAL OP * (VECTOR CONST l, r) : + test ("REAL OP * : ", l, r); + REAL VAR x :: 0.0; + FOR i FROM 1 UPTO l.lng + REP x INCR ((l.elem RSUB i) * (r.elem RSUB i)) PER; + x + +END OP *; + +VECTOR OP * (VECTOR CONST v, REAL CONST r) : + r*v + +END OP *; + +VECTOR OP * (REAL CONST r, VECTOR CONST a) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, r*(a.elem RSUB i)) PER; + v + +END OP *; + +VECTOR OP / (VECTOR CONST a, REAL CONST r) : + v := a; + FOR i FROM 1 UPTO v.lng + REP replace (v.elem, i, (a.elem RSUB i)/r) PER; + v + +END OP /; + +TEXT VAR error :: ""; +PROC test (TEXT CONST proc, VECTOR CONST v, INT CONST i) : + IF i > v.lng + THEN error := proc; + error CAT "subscript overflow (LENGTH v="; + error CAT text (v.lng); + error CAT ", i="; + error CAT text (i); + error CAT ")"; + errorstop (error) + ELIF i < 1 + THEN error := proc; + error CAT "subscript underflow (i = "; + error CAT text (i); + error CAT ")"; + errorstop (error) + FI . + +END PROC test; + +PROC test (TEXT CONST proc, VECTOR CONST a, b) : + IF a.lng <> b.lng + THEN error := proc; + error CAT "LENGTH a ("; + IF a.lng <= 0 + THEN error CAT "undefined" + ELSE error CAT text (a.lng) FI; + error CAT ") <> LENGTH b ("; + error CAT text (b.lng); + error CAT ")"; + errorstop (error) + FI + +END PROC test; + +PROC get (VECTOR VAR v, INT CONST lng) : + v.lng := lng; + v.elem := lng * "12345678"; + REAL VAR x; + FOR i FROM 1 UPTO lng + REP get (x); + replace (v.elem, i, x) + PER . + +END PROC get; + +PROC put (VECTOR CONST v, INT CONST length, fracs) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i, length, fracs)) PER + +END PROC put; + +PROC put (VECTOR CONST v) : + FOR i FROM 1 UPTO v.lng + REP put (text (v.elem RSUB i)) PER + +END PROC put; + +END PACKET vector; + -- cgit v1.2.3