diff options
| author | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:19 +0100 |
|---|---|---|
| committer | Lars-Dominik Braun <lars@6xq.net> | 2019-02-11 11:49:39 +0100 |
| commit | 98cab31fc3659e33aef260efca55bf9f1753164c (patch) | |
| tree | f1affa84049ef9b268e6c4f521f000478b0f3a8e /system/std.zusatz/1.7.3/src/vector | |
| parent | 71e2b36ccd05ea678e62e32ee6245df2b8d6ac17 (diff) | |
| download | eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.gz eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.tar.bz2 eumel-src-98cab31fc3659e33aef260efca55bf9f1753164c.zip | |
Add source files from Michael
Diffstat (limited to 'system/std.zusatz/1.7.3/src/vector')
| -rw-r--r-- | system/std.zusatz/1.7.3/src/vector | 213 |
1 files changed, 213 insertions, 0 deletions
diff --git a/system/std.zusatz/1.7.3/src/vector b/system/std.zusatz/1.7.3/src/vector new file mode 100644 index 0000000..fd1b0ef --- /dev/null +++ b/system/std.zusatz/1.7.3/src/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 :
+
+LET n = 4000;
+
+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;
|