vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 23:52:25 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Rename lib to library.

Browse source
This commit is contained in:
David Brown 2016-06-16 13:56:12 +01:00
parent b7536a8446
commit 1304822769
130 changed files with 0 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

61
src/library/misc/Listen.Mod Normal file
View file

@ -0,0 +1,61 @@
(*
Module taken from http://www.dg.bnv-bamberg.de/seiten/faecher/informat/oberon/aachen/listen.htm
Author: zita@pegasus.dvz.fh-aachen.de
*)
MODULE Listen;
TYPE
Element* = POINTER TO ElementDesc;
ElementDesc* = RECORD END;
Liste* = POINTER TO ListDesc;
ListDesc = RECORD
e: Element;
rest: Liste
END;
CompareProc=PROCEDURE(e1,e2:Element):BOOLEAN;
PROCEDURE Concat*(head: Element; tail: Liste): Liste;
VAR temp:Liste;
BEGIN
NEW(temp); temp.e := head; temp.rest := tail;
RETURN temp
END Concat;
PROCEDURE Head* (l:Liste):Element;
BEGIN
RETURN l.e
END Head;
PROCEDURE Tail* (l:Liste):Liste;
BEGIN
RETURN l.rest
END Tail;
PROCEDURE Append* (list: Liste; e: Element): Liste;
BEGIN
IF list = NIL THEN
RETURN Concat(e, NIL) ELSE
RETURN Concat(Head(list),Append(Tail(list),e))
END;
END Append;
PROCEDURE IsElement*(e:Element;l:Liste;equal:CompareProc):BOOLEAN;
BEGIN
IF l = NIL THEN RETURN FALSE
ELSIF equal(e,Head(l)) THEN RETURN TRUE
ELSE RETURN IsElement(e,Tail(l),equal)
END
END IsElement;
PROCEDURE Find*(e:Element;l:Liste;equal:CompareProc):Element;
BEGIN
IF l = NIL THEN RETURN NIL
ELSIF equal(e,Head(l)) THEN RETURN Head(l)
ELSE RETURN Find(e,Tail(l),equal)
END
END Find;
END Listen.

243
src/library/misc/MersenneTwister.Mod Normal file
View file

@ -0,0 +1,243 @@
(*<* O2EXTENSIONS + *>
<* IOVERFLOW - *>*)
MODULE MersenneTwister;
IMPORT
SYS:=SYSTEM,(*Win:=Windows*) SysClock := oocSysClock, MathL := oocLRealMath;
CONST
(* Period parameter *)
MT19937N*=624;
(* Period parameters *)
MT19937M=397;
(*MT19937MATRIXA =SYS.VAL(SET,-1727483681(*9908b0dfH*)); (* -- constant vector a*)
MT19937UPPERMASK=SYS.VAL(SET,80000000H); (* -- most significant w-r bits*)
MT19937LOWERMASK=SYS.VAL(SET,7fffffffH); (* -- least significant r bits*)
(* Tempering parameters *)
TEMPERINGMASKB=SYS.VAL(SET,9d2c5680H);
TEMPERINGMASKC=SYS.VAL(SET,0efc60000H);
*)
Seed0=4357;
TYPE
tMT19937StateArray=ARRAY MT19937N OF SET; (*-- the array for the state vector*)
VAR
Seed-:LONGINT;
MT19937MATRIXA, MT19937UPPERMASK, MT19937LOWERMASK : SET;
TEMPERINGMASKB, TEMPERINGMASKC : SET;
mt : tMT19937StateArray;
mti: LONGINT; (*-- mti=MT19937N+1 means mt[] is not initialized*)
GaussRandomBuf:LONGREAL;
GaussRandomBufFilled:BOOLEAN;
(* Initializing the array with a seed *)
PROCEDURE SetSeed*(seed:LONGINT);(* sgenrand_MT19937 *)
(*CONST
HighBits=SYS.VAL(SET, 0ffff0000H);*)
VAR
HighBits : SET;
i:LONGINT;
BEGIN
HighBits := SYS.VAL(SET, -65536(*0ffff0000H*));
Seed:=seed;
FOR i:=0 TO MT19937N-1 DO
mt[i]:=SYS.VAL(SET,seed) * HighBits;
seed:=69069*seed+1;
(*mt[i]:=mt[i] + (SYS.SHIFT(SYS.VAL(SET,seed) * HighBits,-16));*)
mt[i]:=mt[i] + SYS.VAL(SET, (SYS.LSH(seed * SYS.VAL(LONGINT, HighBits),-16)));
seed:=69069*seed+1;
END;
mti := MT19937N;
END SetSeed;
(* Initialization by array of seeds *)
PROCEDURE SetSeeds*(seedarray:tMT19937StateArray); (* lsgenrand_MT19937 *)
VAR
i:LONGINT;
BEGIN
FOR i:=0 TO MT19937N-1 DO
mt[i]:=seedarray[i];
END;
mti:=MT19937N;
END SetSeeds;
(* random longint (full range) *)
PROCEDURE Int*():LONGINT; (* genrand_MT19937 *)
TYPE
ar=ARRAY 2 OF SET;
VAR
mag01:ARRAY 2 OF SET;
y:SET;
kk:LONGINT;
BEGIN
mag01[0]:={};
mag01[1]:=MT19937MATRIXA;
IF mti>=MT19937N THEN (* generate MT19937N longints at one time *)
IF mti=(MT19937N+1) THEN (*-- if sgenrand_MT19937() has not been called,*)
SetSeed(Seed0); (*-- default initial seed is used*)
END;
FOR kk:=0 TO MT19937N-MT19937M-1 DO
y:=(mt[kk] * MT19937UPPERMASK) + (mt[kk+1] * MT19937LOWERMASK);
(*mt[kk]:=mt[kk+MT19937M]/SYS.SHIFT(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
(*mt[kk]:=mt[kk+MT19937M]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
mt[kk]:=mt[kk+MT19937M]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y * {0})];
(*mt[kk] := mt[kk+MT19937M];
mt[kk] := mt[kk]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1));
mt[kk] := mt[kk] / mag01[SYS.VAL(LONGINT,y * {0})];*)
END;
FOR kk:=MT19937N-MT19937M TO MT19937N-2 DO
y:=(mt[kk] * MT19937UPPERMASK) + (mt[kk+1] * MT19937LOWERMASK);
(*mt[kk]:=mt[kk+(MT19937M-MT19937N)]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y * {0})];*)
mt[kk]:=mt[kk+(MT19937M-MT19937N)]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y * {0})];
END;
y:=(mt[MT19937N-1] * MT19937UPPERMASK) + (mt[0] * MT19937LOWERMASK);
(*mt[MT19937N-1]:=mt[MT19937M-1]/SYS.LSH(y,-1)/mag01[SYS.VAL(LONGINT,y* {0})];*)
mt[MT19937N-1]:=mt[MT19937M-1]/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-1))/mag01[SYS.VAL(LONGINT,y* {0})];
mti:=0;
END;
y:=mt[mti]; INC(mti);
y:=y/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-11));
y:=y/(SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),7)) * TEMPERINGMASKB);
y:=y/(SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),15)) * TEMPERINGMASKC);
y:=y/SYS.VAL(SET, SYS.LSH(SYS.VAL(LONGINT, y),-18));
RETURN SYS.VAL(LONGINT,y);
END Int;
(*randomization*)
PROCEDURE Randomize*(); (* Randomize_MT19937 *)
VAR sec, usec, l : LONGINT;
(*ST:Win.SYSTEMTIME;*)
BEGIN
(*Win.GetSYS.emTime(ST);
SetSeed(((SYS.VAL(LONGINT,ST.wHour)*60+ST.wMinute)*60+ST.wSecond)*1000+S
T.wMilliseconds);*)
l := SysClock.GetTimeOfDay(sec, usec);
IF l = 0 THEN SetSeed(sec*usec) ELSE HALT(1) END
(*IF l = 0 THEN SetSeed(sec*1000 + usec / 1000) ELSE HALT(1) END*) (* this way it'll repeat every 24 days; -- noch *)
(*IF l = 0 THEN SetSeed(sec*100 + usec / 100) ELSE HALT(1) END*) (* this way it'll repeat every 248 days; -- noch *)
END Randomize;
(*integer RANDOM with positive range*)
(*-- bug fixed 21.6.2000.*)
PROCEDURE IntRange*(Range:LONGINT):LONGINT; (* RandInt_MT19937 *)
TYPE
VAR
(*X:SYS.CARD64;*)
X:LONGINT;
BEGIN
X:=Range;
(*X:=X * SYS.VAL(SYS.CARD64,Int());*)
X:=X * Int();
SYS.MOVE(SYS.ADR(X)+SIZE(INTEGER)(*4*),SYS.ADR(Range),SIZE(INTEGER)(*4*));
RETURN Range;
END IntRange;
(*float RANDOM on 0..1 interval*)
PROCEDURE Real*():LONGREAL; (* RandFloat_MT19937 *)
VAR l : LONGINT;
BEGIN
(*RETURN SYS.VAL(SYS.CARD32,Int())/(1.0*MAX(SYS.CARD32)+1)*)
l := Int();
RETURN l/(1.0*MAX(LONGINT)+1)
END Real;
PROCEDURE Gauss*(mean,std:LONGREAL):LONGREAL;
VAR
r1,r2,s,result:LONGREAL;
BEGIN
IF GaussRandomBufFilled THEN
result:=GaussRandomBuf*std+mean
ELSE
REPEAT
r1:=2*Real()-1;
r2:=2*Real()-1;
s:=r1*r1+r2*r2;
UNTIL s<1;
s:=MathL.sqrt((-2*MathL.ln(s))/s);
result:=r1*s*std+mean;
GaussRandomBuf:=r2*s;
END;
(*GaussRandomBufFilled:=NOT GaussRandomBufFilled;*)
GaussRandomBufFilled := ~GaussRandomBufFilled;
RETURN result
END Gauss;
BEGIN
MT19937MATRIXA := SYS.VAL(SET,-1727483681)(*9908b0dfH*); (* -- constant vector a*)
MT19937UPPERMASK := SYS.VAL(SET,80000000H); (* -- most significant w-r bits*)
MT19937LOWERMASK := SYS.VAL(SET, 2147483647 (* 7fffffffH*)); (* -- least significant r bits*)
(* Tempering parameters *)
TEMPERINGMASKB := SYS.VAL(SET, -1658038656 (*9d2c5680H*));
TEMPERINGMASKC := SYS.VAL(SET, -272236544 (*0efc60000H*));
Seed:=Seed0;
mti:=MT19937N+1;
GaussRandomBufFilled:=FALSE;
END MersenneTwister.
(*----------------------------------------------------------------------
Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
Pseudo-Random Number Generator.
What is Mersenne Twister?
Mersenne Twister(MT) is a pseudorandom number generator developped by
Makoto Matsumoto and Takuji Nishimura (alphabetical order) during
1996-1997. MT has the following merits:
It is designed with consideration on the flaws of various existing
generators.
Far longer period and far higher order of equidistribution than any
other implemented generators. (It is proved that the period is 2^19937-1,
and 623-dimensional equidistribution property is assured.)
Fast generation. (Although it depends on the system, it is reported that
MT is sometimes faster than the standard ANSI-C library in a system
with pipeline and cache memory.)
Efficient use of the memory. (The implemented C-code mt19937.c
consumes only 624 words of working area.)
home page
http://www.math.keio.ac.jp/~matumoto/emt.html
original c source
http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c
Coded by Takuji Nishimura, considering the suggestions by
Topher Cooper and Marc Rieffel in July-Aug. 1997.
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later
version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU Library General Public License for more details.
You should have received a copy of the GNU Library General
Public License along with this library; if not, write to the
Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
02111-1307 USA
Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura.
When you use this, send an email to: matumoto@math.keio.ac.jp
with an appropriate reference to your work.
REFERENCE
M. Matsumoto and T. Nishimura,
"Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
Pseudo-Random Number Generator",
ACM Transactions on Modeling and Computer Simulation,
Vol. 8, No. 1, January 1998, pp 3--30.
Translated to OP and Delphi interface added by Roman Krejci (6.12.1999)
http://www.rksolution.cz/delphi/tips.htm
Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed
----------------------------------------------------------------------*)

549
src/library/misc/MultiArrayRiders.Mod Normal file
View file

@ -0,0 +1,549 @@
(* Copyright 1999-2001, Patrick Hunziker
This library is free software; you can redistribute it and/or modify it under the terms of the
GNU Library General Public License as published by the Free Software Foundation;
either version 2 of the License, or any later version.
This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU Library General Public License for more details.
You should have received a copy of the GNU Library General Public License along with this library;
if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Patrick Hunziker,Basel.
email Patrick.Hunziker@unibas.ch
*)
(** Version 1.0, 19.1.2001 *)
MODULE MultiArrayRiders; (** Patrick Hunziker, Basel, **)
(** Implements an array rider access mechanism for multidimensional arrays of arbitrary
dimensions defined in MultiArrays*)
IMPORT MultiArrays, Out:= Console, Input := Kernel;
CONST (** behaviour of array rider at end of array line;
not yet completely implemented.
The seemingly more exotic variants are especially useful in image processing *)
halt = 0;
zeropadding = 1; (* not yet implemented *)
constant = 2; (* not yet implemented *)
circular* = 3; (** after finishing one line, the same line is restarted *)
mirror = 4; (* not yet implemented *)
incremental* = 5; (** after finishing one line, the next line is started *)
(** rider has not passed any border of the array *)
noteol* = MAX(LONGINT);
TYPE
(** Array riders allow traversal of arbitrary dimensional array using procedures Inc() and Dec(),
and can be positioned using Set(). *)
Rider* = RECORD
array-: MultiArrays.Array; (** points to the array the rider is based on *)
order-: LONGINT; (** dimensionality of array *)
offset- : LONGINT; (** Rider position in linear array representation *)
eol*: LONGINT; (** Rider has gone beyond the border of the
line of indicated dimension .
if eol=noteol, rider is inside array *)
eolBehaviour*: INTEGER; (** What to do when reaching eol. Not yet completely satisfactory *)
dimension, (* dimensions of Array, in vector notation *)
pos, (* position of rider in Array, in vector notation *)
step: MultiArrays.SizeVector; (* unit increment for offset in each dimension, in vector notation *)
END;
PROCEDURE CalculatePos (pos, dimension: MultiArrays.SizeVector): LONGINT;
VAR maxI, res, i: LONGINT;
BEGIN
maxI := LEN(dimension^)-1;
ASSERT(LEN(pos^) = LEN(dimension^));
res := pos[maxI];
FOR i := 1 TO maxI DO res := res*dimension[maxI-i]+pos[maxI-i] END;
RETURN res
END CalculatePos;
PROCEDURE InitRider* (VAR R: Rider; A: MultiArrays.Array; pos: MultiArrays.SizeVector);
(** Sets array rider in position pos in array A *)
VAR i, step: LONGINT;
BEGIN
ASSERT(MultiArrays.Order(A) = LEN(pos^));
R.array := A;
R.order := MultiArrays.Order(A);
NEW(R.pos,R.order);
NEW(R.step,R.order);
NEW(R.dimension,R.order);
step := 1;
FOR i := 0 TO R.order-1 DO
ASSERT(pos[i] <= MultiArrays.Len(A,i));
R.pos[i] := pos[i];
R.step[i] := step; step := step*MultiArrays.Len(A,i);
R.dimension[i] := MultiArrays.Len(A,i)
END;
R.eol := noteol;
R.offset := CalculatePos(R.pos,MultiArrays.Size(A));
R.eolBehaviour := incremental
END InitRider;
PROCEDURE SetRider* (VAR R: Rider; pos: MultiArrays.SizeVector);
VAR i: LONGINT;
BEGIN
ASSERT(R.array # NIL);
ASSERT(LEN(pos^) = R.order);
FOR i := 0 TO R.order-1 DO ASSERT(pos[i] < R.dimension[i]); R.pos[i] := pos[i] END;
R.offset := CalculatePos(pos,R.dimension);
R.eol := noteol
END SetRider;
PROCEDURE Inc* (VAR R: Rider; Dim: LONGINT);
(** array rider advances one element in dimension Dim;
at end of line, eol is assigned the number of the dimension overflown *)
BEGIN
ASSERT(Dim < R.order);
IF R.pos[Dim] < R.dimension[Dim]-1
THEN INC(R.pos[Dim]); INC(R.offset, R.step[Dim]);
ELSE
R.eol := Dim;
CASE R.eolBehaviour OF
halt: HALT(100);
| zeropadding: HALT(100); (* not yet implemented *)
| constant:
| mirror: HALT(100); (* not yet implemented *)
| incremental:
R.pos[Dim] := 0;
IF Dim < R.order-1
THEN
INC(R.offset, R.step[Dim]-R.step[Dim+1]);
Inc(R, R.eol+1)
ELSE INC(R.offset, R.step[Dim]-R.array.len)
END
| circular:
R.pos[Dim] := 0;
IF Dim < R.order-1
THEN INC(R.offset, R.step[Dim]-R.step[Dim+1])
ELSE INC(R.offset, R.step[Dim]-R.array.len)
END
ELSE HALT(100)
END
END
END Inc;
PROCEDURE Dec* (VAR R: Rider; Dim: LONGINT);
(** array rider goes back one element in dimension Dim *)
BEGIN
ASSERT(Dim < R.order);
IF R.pos[Dim] > 0
THEN DEC(R.pos[Dim]); DEC(R.offset, R.step[Dim]);
ELSE R.eol := Dim;
CASE R.eolBehaviour OF
halt: HALT(100);
| zeropadding: HALT(100); (* not yet implemented *)
| constant:
| mirror: HALT(100); (* not yet implemented *)
| incremental:
R.pos[Dim] := R.dimension[Dim]-1;
IF Dim > 0
THEN
DEC(R.offset, R.step[Dim]-R.step[Dim+1]);
Dec(R, R.eol+1)
ELSE DEC(R.offset, R.step[Dim]-R.array.len)
END
| circular:
R.pos[Dim] := R.dimension[Dim]-1;
IF Dim > 0
THEN DEC(R.offset, R.step[Dim]-R.step[Dim+1])
ELSE DEC(R.offset, R.step[Dim]-R.array.len)
END
ELSE HALT(100)
END
END
END Dec;
PROCEDURE Pos* (R: Rider): MultiArrays.SizeVector;
(** gives actual position of R in its associated array *)
VAR i: LONGINT; res: MultiArrays.SizeVector;
BEGIN
NEW(res,R.order);
FOR i := 0 TO R.order-1 DO res[i] := R.pos[i] END;
RETURN res
END Pos;
(** elementwise reading from Array Rider, followed by advancing the rider by
one step in direction "dir"; with specific "eolBehaviour" (see above) at border of array *)
PROCEDURE ReadSInt* (VAR R: Rider; dir: LONGINT; VAR s: SHORTINT);
BEGIN
IF R.array IS MultiArrays.SIntArray
THEN s := R.array(MultiArrays.SIntArray).s[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadSInt;
PROCEDURE ReadSIntRun* (VAR R: Rider; dir: LONGINT;
VAR srun: ARRAY OF SHORTINT; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.SIntArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.SIntArray);
array := R.array(MultiArrays.SIntArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN FOR i := 0 TO n-1 DO srun[i] := array.s[offset]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END
| circular:
IF R.pos[dir]+n-1 < dim
THEN FOR i := 0 TO n-1 DO srun[i] := array.s[offset]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
srun[i] := array.s[offset+((pos+i) MOD dim)*step] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END ReadSIntRun;
PROCEDURE ReadInt* (VAR R: Rider; dir: LONGINT; VAR i: INTEGER);
BEGIN
IF R.array IS MultiArrays.IntArray
THEN i := R.array(MultiArrays.IntArray).i[R.offset]; Inc(R, dir);
ELSE HALT(100)
END
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; dir: LONGINT; VAR j: LONGINT);
BEGIN
IF R.array IS MultiArrays.LIntArray
THEN j := R.array(MultiArrays.LIntArray).j[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadLInt;
(* PROCEDURE ReadHInt* (VAR R: Rider; dir: LONGINT; VAR h: HUGEINT);
BEGIN
HALT(100) (* yet to implement *)
END ReadHInt; *)
PROCEDURE ReadReal* (VAR R: Rider; dir: LONGINT; VAR x: REAL);
BEGIN
IF R.array IS MultiArrays.RealArray
THEN x := R.array(MultiArrays.RealArray).x[R.offset]; Inc(R, dir)
ELSE HALT(100)
END;
END ReadReal;
PROCEDURE ReadRealRun* (VAR R: Rider; dir: LONGINT;
VAR srun: ARRAY OF REAL; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.RealArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.RealArray);
array := R.array(MultiArrays.RealArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN FOR i := 0 TO n-1 DO srun[i] := array.x[offset]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END;
| circular:
IF R.pos[dir]+n-1 < dim
THEN FOR i := 0 TO n-1 DO srun[i] := array.x[offset]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
srun[i] := array.x[offset+((pos+i) MOD dim)*step] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END ReadRealRun;
PROCEDURE ReadLReal* (VAR R: Rider; dir: LONGINT; VAR y: LONGREAL);
BEGIN
IF R.array IS MultiArrays.LRealArray
THEN y := R.array(MultiArrays.LRealArray).y[R.offset]; Inc(R, dir)
ELSE HALT(100)
END
END ReadLReal;
(* PROCEDURE ReadBool* (VAR R: Rider; dir: LONGINT; VAR b: BOOLEAN);
BEGIN
HALT(100) (* to implement *)
END ReadBool; *)
(* PROCEDURE ReadComplex* (VAR R: Rider; dir: LONGINT; VAR z: MultiArrays.Complex);
BEGIN
HALT(100) (* yet to implement *)
END ReadComplex; *)
PROCEDURE WriteSInt* (VAR R: Rider; dir: LONGINT; s: SHORTINT);
BEGIN
IF R.array IS MultiArrays.SIntArray
THEN R.array(MultiArrays.SIntArray).s[R.offset] := s; Inc(R, dir)
ELSE HALT(100) END
END WriteSInt;
PROCEDURE WriteInt* (VAR R: Rider; dir: LONGINT; i: INTEGER);
BEGIN
IF R.array IS MultiArrays.IntArray
THEN R.array(MultiArrays.IntArray).i[R.offset] := i; Inc(R, dir)
ELSE HALT(100) END
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; dir: LONGINT; j: LONGINT);
BEGIN
IF R.array IS MultiArrays.LIntArray
THEN R.array(MultiArrays.LIntArray).j[R.offset] := j; Inc(R, dir)
ELSE HALT(100) END
END WriteLInt;
(* PROCEDURE WriteHInt* (VAR R: Rider; dir: LONGINT; h: HUGEINT);
BEGIN
HALT(100); (* yet to implement *) END
END WriteHInt; *)
PROCEDURE WriteReal* (VAR R: Rider; dir: LONGINT; x: REAL);
BEGIN
IF R.array IS MultiArrays.RealArray
THEN R.array(MultiArrays.RealArray).x[R.offset] := x; Inc(R, dir)
ELSE HALT(100) END
END WriteReal;
PROCEDURE WriteRealRun* (VAR R: Rider; dir: LONGINT; srun: ARRAY OF REAL; n: LONGINT);
VAR i, step, offset, pos, dim: LONGINT; array: MultiArrays.RealArray;
BEGIN
ASSERT(LEN(srun) >= n);
ASSERT(dir < R.order);
ASSERT(R.array IS MultiArrays.RealArray);
array := R.array(MultiArrays.RealArray);
offset := R.offset;
step := R.step[dir];
pos := R.pos[dir];
dim := R.dimension[dir];
CASE R.eolBehaviour OF
halt: HALT(100); (* not yet implemented *)
| incremental:
IF offset+(n-1)*step < R.array.len
THEN
FOR i := 0 TO n-1 DO array.x[offset] := srun[i]; INC(offset, step) END
ELSE HALT(100) (* not yet implemented *)
END
| circular:
IF R.pos[dir]+n-1 < dim
THEN
FOR i := 0 TO n-1 DO array.x[offset] := srun[i]; INC(offset, step) END
ELSE
FOR i := 0 TO n-1 DO
array.x[offset+((pos+i) MOD dim)*step] := srun[i] (* can further be optimized *)
END
END
ELSE HALT(100) (* not yet implemented *)
END
END WriteRealRun;
PROCEDURE WriteLReal* (VAR R: Rider; dir: LONGINT; y: LONGREAL);
BEGIN
IF R.array IS MultiArrays.LRealArray
THEN R.array(MultiArrays.LRealArray).y[R.offset] := y; Inc(R, dir)
ELSE HALT(100) END
END WriteLReal;
PROCEDURE WriteBool* (VAR R: Rider; dir: LONGINT; b: BOOLEAN);
BEGIN
IF R.array IS MultiArrays.BoolArray
THEN R.array(MultiArrays.BoolArray).b[R.offset] := b; Inc(R, dir)
ELSE HALT(100) END
END WriteBool;
(* PROCEDURE WriteComplex* (VAR R: Rider; dir: LONGINT; VAR z: MultiArrays.Complex);
BEGIN
HALT(100) (* yet to implement *)
END WriteComplex; *)
PROCEDURE InvertSign (s: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN -s
END InvertSign;
PROCEDURE Assign (VAR S: SHORTINT;s: SHORTINT); (* Testing *)
BEGIN
S := s
END Assign;
PROCEDURE Test*; (** Tests if eol mechanism is working correctly *)
VAR pos, dimension: MultiArrays.SizeVector; A: MultiArrays.Array;
i, j: LONGINT; R: Rider;
BEGIN
MultiArrays.SizeVector4(dimension, 10, 10, 10, 10);
MultiArrays.SizeVector4(pos, 2, 3, 4, 5);
NEW(A); MultiArrays.InitInt(A, dimension, NIL, FALSE);
InitRider(R,A,pos);
R.eolBehaviour := circular;
FOR j := 0 TO 3 DO
FOR i := 1 TO 10 DO
Inc(R, j); Out.Int(CalculatePos(R.pos,MultiArrays.Size(A)), 5); Out.Ln;
IF R.eol#noteol THEN
Out.String("R.eol:"); Out.Int(R.eol, 5); Out.Ln;
R.eol := noteol
END
END;
Out.String("----"); Out.Ln
END
END Test;
PROCEDURE Test1*;
VAR A1: MultiArrays.Array;
SA: ARRAY 256 OF SHORTINT;
R1: Rider;
dim0, dim1: MultiArrays.SizeVector;
starttime, endtime, a, b, c, d, opcount1, opcount2: LONGINT;
A3: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
s: SHORTINT;
BEGIN
Out.Ln;
Out.String("**********************************"); Out.Ln;
Out.String(" Benchmark:"); Out.Ln;
Out.String(" Arbitrary arrays with riders vs. ARRAY[x,y,z,...] concept"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
MultiArrays.SizeVector4(dim0, 0, 0, 0, 0);
MultiArrays.SizeVector4(dim1, 256, 128, 8, 8);
MultiArrays.InitSInt(A1, dim1, NIL, FALSE);
InitRider(R1, A1, dim0);
R1.eolBehaviour := incremental;
opcount1 := 0;
(* ASSIGN *)
starttime := Input.Time();
REPEAT (* main loop of elementwise rider writing *)
ReadSInt(R1,0,s);
INC(opcount1);
UNTIL R1.eol=R1.order-1;
endtime := Input.Time();
Out.String("ASSIGN:");Out.Ln;
Out.String("Arbitrary multidimensional array: elementwise writing:"); Out.Ln;
Out.String(" time: "); Out.Int(endtime-starttime,5);
Out.String(" opcount: "); Out.Int(opcount1, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
MultiArrays.SizeVector4(dim0,0,0,0,0);
MultiArrays.SizeVector4(dim1,256,128,8,8);
SetRider(R1,dim0); R1.eolBehaviour := circular;
opcount2 := 0;
dim0[0] := 0;
starttime := Input.Time();
FOR b := 0 TO dim1[1]-1 DO (* main loop of linewise reading *)
dim0[1] := b;
FOR c := 0 TO dim1[2]-1 DO
dim0[2] := c;
FOR d := 0 TO dim1[3]-1 DO
dim0[3] := d;
SetRider(R1,dim0);
ReadSIntRun(R1,0,SA,256);
INC(opcount2, 256)
END
END
END;
endtime := Input.Time();
Out.String(" Arbitrary multidimensional array: line reading with rider"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(A3, 256, 128, 8, 8 );
starttime := Input.Time();
opcount2 := 0;
FOR a := 0 TO LEN(A3^,0)-1 DO (* main loop of conventional array handling *)
FOR b := 0 TO LEN(A3^,1)-1 DO
FOR c := 0 TO LEN(A3^,2)-1 DO
FOR d := 0 TO LEN(A3^,3)-1 DO
SA[a] := A3[a,b,c,d]; INC(opcount2)
END
END
END
END;
endtime := Input.Time();
Out.String(" conventional multidimensional array: index line reading:"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln;
Out.String("**********************************"); Out.Ln
END Test1;
(* Intel may have register problems with the following procedure *)
(* PROCEDURE Test2*;
VAR A1, A2: MultiArrays.Array;
R1: Rider;
dim0, dim1: MultiArrays.SizeVector;
i, starttime, endtime, a, b, c, d, e, f, dir, opcount1, opcount2: LONGINT;
A3: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
s: SHORTINT;
BEGIN
Out.Ln;
Out.String("**********************************"); Out.Ln;
Out.String(" Benchmark:"); Out.Ln;
Out.String(" Arbitrary arrays with riders vs. ARRAY[x,y,z,...] concept"); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(dim0, 6); FOR i := 0 TO 5 DO dim0[i] := 0 END;
NEW(dim1, 6);
dim1[0] := 64; dim1[1] := 32; dim1[2] := 16; dim1[3] := 16;
dim1[4] := 2; dim1[5] := 2;
MultiArrays.InitSInt(A1, dim1, NIL, FALSE);
InitRider(R1, A1, dim0);
R1.eolBehaviour := incremental;
opcount1 := 0;
(* ASSIGN *)
starttime := Input.Time();
REPEAT
WriteSInt(R1,0,1);
INC(opcount1);
UNTIL R1.eol=5;
endtime := Input.Time();
Out.String("ASSIGN:");Out.Ln;
Out.String("arbitrary array rider assignement:"); Out.Ln;
Out.String(" time: "); Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount1, 5); Out.Ln;
Out.String("----------------------------------"); Out.Ln;
NEW(A3, 64,32,16,16, 2,2);
starttime := Input.Time();
opcount2 := 0;
FOR a := 0 TO LEN(A3^,0)-1 DO
FOR b := 0 TO LEN(A3^,1)-1 DO
FOR c := 0 TO LEN(A3^,2)-1 DO
FOR d := 0 TO LEN(A3^,3)-1 DO
FOR e := 0 TO LEN(A3^,4)-1 DO
FOR f := 0 TO LEN(A3^,5)-1 DO
Assign(A3[a,b,c,d,e,f],1); INC(opcount2)
END
END
END
END
END
END;
endtime := Input.Time();
Out.String("multidim index assignement:"); Out.Ln;
Out.String(" time: ");
Out.Int(endtime-starttime, 5);
Out.String(" opcount: "); Out.Int(opcount2, 5); Out.Ln
END Test2;
*)
BEGIN
END MultiArrayRiders.
MultiArrayRiders.Test1 (4D), MultiArrayRiders.Test2 (6D)
Compares execution times for
-arbitrary dimensional approach with riders
-conventional ARRAY [x,y,z,...] approach
This is done for elementwise assignements and reading of "runs" of data.

747
src/library/misc/MultiArrays.Mod Normal file
View file

@ -0,0 +1,747 @@
MODULE MultiArrays; (** P. Hunziker, Basel, **)
(**
AIM: To provide a library solution for
a multidimensional array type for numbers of arbitrary dimensions,
with the following features:
-compatible types for 1,2,3..n dimensions, allowing exchangeable use in procedure headers etc
-> generic/OO procedures for multidimensional array handling can be implemented
-arrays can be accessed in multiple ways:
-a) conventional indexing (though not by using brackets[ ], but using procedure IndexN. )
-b) in a linear fashion (fast)
-c) using an "ALL()" procedure without need for index handling by the user (very fast !)
-d) using array riders movable along arbitrary axis (Module MultiArrayRiders)
-e) by reading "runs" of data with rider (Module MultiArrayRiders)
A type 'scalar' is also based on the same base type as arrays, to allow mixing of arrays and scalars
in procedure headers, for more generic procedure headers when e.g. defining array operations:
(e.g. PROCEDURE Add(d1, d2: Data): Data;
can be used for mixed expressions of arrays and numbers).
This is in the hope that a family of array handling modules similar to the functionality of
MATLAB or APL will be based on these types in the future. (Help is welcome !).
See 'Test', 'Test1', procedures in both modules for insight how to use them.
*)
(** Copyright 1999-2001, Patrick Hunziker
This library is free software; you can redistribute it and/or modify it under the terms of the
GNU Library General Public License as published by the Free Software Foundation;
either version 2 of the License, or any later version.
This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU Library General Public License for more details.
You should have received a copy of the GNU Library General Public License along with this library;
if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
Patrick Hunziker,Basel.
email Patrick.Hunziker@unibas.ch
*)
(** Version 0.9, 19.1.2001 *)
IMPORT Out:= Console, Input:= Kernel; (* Import only needed for Demo purposes *)
TYPE
SIntPtr* = POINTER TO ARRAY OF SHORTINT;
IntPtr* = POINTER TO ARRAY OF INTEGER;
LIntPtr* = POINTER TO ARRAY OF LONGINT;
(* HIntPtr* = POINTER TO ARRAY OF HUGEINT; *)
RealPtr* = POINTER TO ARRAY OF REAL;
LRealPtr* = POINTER TO ARRAY OF LONGREAL;
BoolPtr* = POINTER TO ARRAY OF BOOLEAN;
(* ComplxPtr* = POINTER TO ARRAY OF COMPLEX; *)
Data* = POINTER TO DataDesc; (** abstract base type, not containing data.
This could be an Objects.Object for S3 *)
DataDesc* = RECORD END;
Scalar* = POINTER TO ScalarDesc; (** abstract base type, not containing data. *)
ScalarDesc* = RECORD (DataDesc) END;
SInt* = POINTER TO SIntDesc;
SIntDesc* = RECORD (ScalarDesc)
s*: SHORTINT;
END;
Int* = POINTER TO IntDesc;
IntDesc* = RECORD (ScalarDesc)
i*: INTEGER;
END;
LInt* = POINTER TO LIntDesc;
LIntDesc* = RECORD (ScalarDesc)
j*: LONGINT;
END;
(* HInt* = POINTER TO HIntDesc;
HIntDesc* = RECORD (ScalarDesc)
h*: HUGEINT;
END;
*)
Real* = POINTER TO RealDesc;
RealDesc* = RECORD (ScalarDesc)
x*: REAL;
END;
LReal* = POINTER TO LRealDesc;
LRealDesc* = RECORD (ScalarDesc)
y*: LONGREAL;
END;
Bool* = POINTER TO BoolDesc;
BoolDesc* = RECORD (ScalarDesc)
b*: BOOLEAN;
END;
Complex* = POINTER TO ComplexDesc;
ComplexDesc* = RECORD (ScalarDesc)
r*, i*: REAL;
END;
SizeVector* = POINTER TO SizeVectorDesc; (* used for description of array size; eventually = CATLIntVector *)
SizeVectorDesc* = ARRAY OF LONGINT;
Array* = POINTER TO ArrayDesc; (** abstract base type, not containing data *)
ArrayDesc* = RECORD (DataDesc)
(*ARRAY of arbitrary dimensionality *)
dimension: SizeVector; (* dimension vector *)
len-: LONGINT; (* Overall number of array elements *)
END;
SIntArray* = POINTER TO SIntArrayDesc;
SIntArrayDesc* = RECORD (ArrayDesc)
s-: SIntPtr;
END;
IntArray* = POINTER TO IntArrayDesc;
IntArrayDesc* = RECORD (ArrayDesc)
i-: IntPtr;
END;
LIntArray* = POINTER TO LIntArrayDesc;
LIntArrayDesc* = RECORD (ArrayDesc)
j-: LIntPtr;
END;
(* HIntArray* = POINTER TO HIntArrayDesc;
HIntArrayDesc* = RECORD (ArrayDesc)
h-: HIntPtr;
END;
*)
RealArray* = POINTER TO RealArrayDesc;
RealArrayDesc* = RECORD (ArrayDesc)
x-: RealPtr;
END;
LRealArray* = POINTER TO LRealArrayDesc;
LRealArrayDesc* = RECORD (ArrayDesc)
y-: LRealPtr;
END;
BoolArray* = POINTER TO BoolArrayDesc;
BoolArrayDesc* = RECORD (ArrayDesc)
b-: BoolPtr;
END;
ComplexArray* = POINTER TO ComplexArrayDesc;
ComplexArrayDesc* = RECORD (ArrayDesc)
r-, i-: RealPtr;
END;
PROCEDURE Order* (A: Array): LONGINT;
(** returns Nr of dimensions of array A *)
BEGIN
RETURN LEN(A.dimension^)
END Order;
PROCEDURE Size* (A: Array): SizeVector;
(** returns dimension vector *)
VAR i: LONGINT; res: SizeVector;
BEGIN
NEW(res,LEN(A.dimension^));
FOR i := 0 TO LEN(A.dimension^)-1 DO res[i] := A.dimension[i] END;
RETURN res
END Size;
PROCEDURE Len* (A: Array; dim: LONGINT): LONGINT;
(** returns length of dimension Nr 'dim' *)
BEGIN
IF dim >= LEN(A.dimension^) THEN HALT(100)
ELSE RETURN A.dimension[dim]
END
END Len;
PROCEDURE Index*(pos, dimension: ARRAY OF LONGINT): LONGINT;
VAR maxI,res,i: LONGINT;
BEGIN
maxI := LEN(dimension)-1;
ASSERT(LEN(pos) = LEN(dimension));
res := pos[maxI];
FOR i := 1 TO maxI DO res := res*dimension[maxI-i]+pos[maxI-i] END;
RETURN res
END Index;
PROCEDURE Index1*(A: Array; x: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 1);
ASSERT(x < A.len);
RETURN x
END Index1;
PROCEDURE Index2*(A: Array; x,y: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 2);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
RETURN y*Len(A,0)+x
END Index2;
PROCEDURE Index3*(A: Array; x,y,z: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 3);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
ASSERT(z < Len(A,2));
RETURN (z*Len(A,1)+y)*Len(A,0)+x
END Index3;
PROCEDURE Index4*(A: Array; x,y,z,u: LONGINT): LONGINT;
BEGIN
ASSERT(Order(A) = 4);
ASSERT(x < Len(A,0));
ASSERT(y < Len(A,1));
ASSERT(z < Len(A,2));
ASSERT(u < Len(A,3));
RETURN ((u*Len(A,2)+z)*Len(A,1)+y)*Len(A,0)+x
END Index4;
PROCEDURE SizeVector1*(VAR Vec: SizeVector; x: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#1) THEN NEW(Vec,1) END;
Vec[0] := x
END SizeVector1;
PROCEDURE SizeVector2*(VAR Vec: SizeVector; x,y: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#2) THEN NEW(Vec,2) END;
Vec[0] := x; Vec[1] := y
END SizeVector2;
PROCEDURE SizeVector3*(VAR Vec: SizeVector; x,y,z: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#3) THEN NEW(Vec,3) END;
Vec[0] := x; Vec[1] := y; Vec[2] := z
END SizeVector3;
PROCEDURE SizeVector4*(VAR Vec: SizeVector; x,y,z,u: LONGINT);
BEGIN
IF (Vec=NIL) OR (LEN(Vec^)#4) THEN NEW(Vec,4) END;
Vec[0] := x; Vec[1] := y; Vec[2] := z; Vec[3] := u
END SizeVector4;
PROCEDURE CalculatePos*(Index: LONGINT; dimension: ARRAY OF LONGINT): SizeVector;
VAR maxI, n, i: LONGINT;
res: SizeVector;
BEGIN
n := Index;
maxI := LEN(dimension)-1;
FOR i := 0 TO maxI-1 DO
res[maxI-i] := n MOD dimension[maxI-i];
n := n DIV dimension[maxI-i]
END;
RETURN res
END CalculatePos;
PROCEDURE InitSInt* (VAR A: Array; dimension: SizeVector; data: SIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: SIntArray;
BEGIN
IF (A=NIL) OR ~(A IS SIntArray) THEN NEW(AA) ELSE IF A IS SIntArray THEN AA := A(SIntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.s,n); FOR i := 0 TO n-1 DO AA.s[i] := data[i] END;
ELSE AA.s := data
END;
A := AA
END InitSInt;
PROCEDURE InitInt* (VAR A: Array; dimension: SizeVector; data: IntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: IntArray;
BEGIN
IF (A=NIL) OR ~(A IS IntArray) THEN NEW(AA) ELSE IF A IS IntArray THEN AA := A(IntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.i,n); FOR i := 0 TO n-1 DO AA.i[i] := data[i] END;
ELSE AA.i := data
END;
A := AA
END InitInt;
PROCEDURE InitLInt* (VAR A: Array; dimension: SizeVector; data: LIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: LIntArray;
BEGIN
IF (A=NIL) OR ~(A IS LIntArray) THEN NEW(AA) ELSE IF A IS LIntArray THEN AA := A(LIntArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.j,n); FOR i := 0 TO n-1 DO AA.j[i] := data[i] END;
ELSE AA.j := data
END;
A := AA
END InitLInt;
(* PROCEDURE InitHInt* (VAR A: Array; dimension: SizeVector; data: HIntPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: HIntArray;
BEGIN
IF (A=NIL) OR ~(A IS HIntArray) THEN NEW(AA) ELSE WITH A: HIntArray DO AA := A END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.h,n); FOR i := 0 TO n-1 DO AA.h[i] := data[i] END;
ELSE AA.h := data
END;
A := AA
END InitHInt; *)
PROCEDURE InitReal* (VAR A: Array; dimension: SizeVector; data: RealPtr; copy: BOOLEAN);
VAR i, n:LONGINT;
AA:RealArray;
BEGIN
IF (A=NIL) OR ~(A IS RealArray) THEN NEW(AA) ELSE IF A IS RealArray THEN AA := A(RealArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.x,n); FOR i := 0 TO n-1 DO AA.x[i] := data[i] END;
ELSE AA.x := data
END;
A := AA
END InitReal;
PROCEDURE InitLReal* (VAR A: Array; dimension: SizeVector; data: LRealPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: LRealArray;
BEGIN
IF (A=NIL) OR ~(A IS LRealArray) THEN NEW(AA) ELSE IF A IS LRealArray THEN AA := A(LRealArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.y,n); FOR i := 0 TO n-1 DO AA.y[i] := data[i] END;
ELSE AA.y := data
END;
A := AA
END InitLReal;
PROCEDURE InitBool* (VAR A: Array; dimension: SizeVector; data: BoolPtr; copy: BOOLEAN);
VAR i, n: LONGINT;
AA: BoolArray;
BEGIN
IF (A=NIL) OR ~(A IS BoolArray) THEN NEW(AA) ELSE IF A IS BoolArray THEN AA := A(BoolArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
IF data=NIL THEN NEW(data,n); copy := FALSE END;
ASSERT (LEN(data^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.b,n); FOR i := 0 TO n-1 DO AA.b[i] := data[i] END
ELSE AA.b := data
END;
A := AA
END InitBool;
PROCEDURE InitComplex* (VAR A:Array; dimension: SizeVector;
dataR,dataI: RealPtr; copy:BOOLEAN);
VAR i, n: LONGINT;
AA: ComplexArray;
BEGIN
IF (A=NIL) OR ~(A IS ComplexArray) THEN NEW(AA) ELSE IF A IS ComplexArray THEN AA := A(ComplexArray) END END;
n := 1;
FOR i := 0 TO LEN(dimension^)-1 DO n := n*dimension[i] END;
ASSERT (LEN(dataR^)=n); ASSERT (LEN(dataI^)=n);
NEW(AA.dimension,LEN(dimension^));
FOR i := 0 TO LEN(dimension^)-1 DO AA.dimension[i] := dimension[i]; END;
AA.len := n;
IF copy
THEN NEW (AA.r,n); NEW (AA.i,n);
FOR i := 0 TO n-1 DO AA.r[i] := dataR[i]; AA.i[i] := dataI[i] END
ELSE AA.r := dataR; AA.i := dataI
END;
A := AA
END InitComplex;
PROCEDURE Copy* (From,To:Array);
BEGIN
WITH
From: SIntArray DO InitSInt(To,From.dimension,From.s,TRUE) ;
| From: IntArray DO InitInt(To,From.dimension,From.i,TRUE);
| From: LIntArray DO InitLInt(To,From.dimension,From.j,TRUE);
(* | From: HIntArray DO HALT(100) *)
| From: RealArray DO InitReal(To,From.dimension,From.x,TRUE);
| From: LRealArray DO InitLReal(To,From.dimension,From.y,TRUE);
| From: BoolArray DO InitBool(To,From.dimension,From.b,TRUE);
| From: ComplexArray DO InitComplex(To,From.dimension,From.r,From.i,TRUE);
ELSE HALT(100)
END
END Copy;
(* PROCEDURE CopySubArray* (A1,A2:Array; start,dimension:ARRAY OF LONGINT);
(** Copies subrange of Array A1, beginning at 'start' with 'dimension' to (usually smaller) array A2 *)
BEGIN
WITH A1: ...
ELSE HALT(100)
END
END CopySubarray; *)
PROCEDURE GetSInt* (A: Array; position: SizeVector): SHORTINT;
BEGIN
IF A IS SIntArray THEN RETURN A(SIntArray).s[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetSInt;
PROCEDURE GetInt* (A: Array; position: SizeVector): INTEGER;
BEGIN
IF A IS IntArray THEN RETURN A(IntArray).i[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetInt;
PROCEDURE GetLInt* (A: Array; position: SizeVector): LONGINT;
BEGIN
IF A IS LIntArray THEN RETURN A(LIntArray).j[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetLInt;
(*PROCEDURE GetHInt* (A: Array; position: SizeVector): HUGEINT;
BEGIN
IF A IS HIntArray THEN RETURN A(HIntArray).h[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetHInt; *)
PROCEDURE GetReal* (A: Array; position: SizeVector): REAL;
BEGIN
IF A IS RealArray THEN RETURN A(RealArray).x[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetReal;
PROCEDURE GetLReal* (A: Array; position: SizeVector): LONGREAL;
BEGIN
IF A IS LRealArray THEN RETURN A(LRealArray).y[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetLReal;
PROCEDURE GetBool* (A: Array; position: SizeVector): BOOLEAN;
BEGIN
IF A IS BoolArray THEN RETURN A(BoolArray).b[Index(position^,A.dimension^)]
ELSE HALT (100) END
END GetBool;
PROCEDURE GetComplex* (A: Array; position: SizeVector): Complex;
VAR res: Complex;
BEGIN
IF A IS ComplexArray
THEN
NEW(res);
res.r := A(ComplexArray).r[Index(position^,A.dimension^)];
res.i := A(ComplexArray).i[Index(position^,A.dimension^)];
RETURN res
ELSE HALT (100)
END
END GetComplex;
(* PROCEDURE Store* (R: Files.Rider; A: Array);
(* S3 specific ->eliminate from this module, into utility module *)
(** not yet implemented *)
BEGIN
(**)
END Store;
PROCEDURE Load* (R: Files.Rider; VAR A: Array);
(* S3 specific ->eliminate from this module, into utility module *)
(** not yet implemented *)
BEGIN
(**)
END Load;
*)
PROCEDURE AllSInt1* (A: Array; f: PROCEDURE(s:SHORTINT): SHORTINT);
VAR n: LONGINT;
BEGIN
WITH A: SIntArray DO FOR n := 0 TO A.len-1 DO A.s[n] := f(A.s[n]) END
ELSE HALT(100)
END
END AllSInt1;
PROCEDURE AllSInt2* (A,B: Array; f: PROCEDURE(s1,s2:SHORTINT): SHORTINT);
VAR n: LONGINT;
BEGIN
WITH A: SIntArray DO
WITH B: SIntArray DO
FOR n := 0 TO A.len-1 DO A.s[n] := f(A.s[n],B.s[n]) END
ELSE HALT(100)
END
ELSE HALT(100)
END;
END AllSInt2;
PROCEDURE AllInt1* (A: Array; f: PROCEDURE(i:INTEGER): INTEGER);
VAR n: LONGINT;
BEGIN
WITH A: IntArray DO FOR n := 0 TO A.len-1 DO A.i[n] := f(A.i[n]) END
ELSE HALT(100)
END
END AllInt1;
PROCEDURE AllInt2* (A,B: Array; f: PROCEDURE(i1,i2:INTEGER): INTEGER);
VAR n: LONGINT;
BEGIN
WITH A: IntArray DO
WITH B: IntArray DO
FOR n := 0 TO A.len-1 DO A.i[n] := f(A.i[n],B.i[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END
END AllInt2;
PROCEDURE AllLInt1* (A: Array; f: PROCEDURE(j:LONGINT): LONGINT);
VAR n: LONGINT;
BEGIN
WITH A: LIntArray DO FOR n := 0 TO A.len-1 DO A.j[n] := f(A.j[n]) END
ELSE HALT(100)
END
END AllLInt1;
PROCEDURE AllLInt2* (A,B: Array; f: PROCEDURE(j1,j2:LONGINT): LONGINT);
VAR n: LONGINT;
BEGIN
WITH A: LIntArray DO
WITH B: LIntArray DO
FOR n := 0 TO A.len-1 DO A.j[n] := f(A.j[n],B.j[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END;
END AllLInt2;
PROCEDURE AllReal1* (A: Array; f: PROCEDURE(x:REAL): REAL);
VAR n: LONGINT;
BEGIN
WITH A: RealArray DO FOR n := 0 TO A.len-1 DO A.x[n] := f(A.x[n]) END
ELSE HALT(100)
END
END AllReal1;
PROCEDURE AllReal2* (A,B: Array; f: PROCEDURE(x1,x2:REAL): REAL);
VAR n: LONGINT;
BEGIN
WITH A: RealArray DO
WITH B: RealArray DO
FOR n := 0 TO A.len-1 DO A.x[n] := f(A.x[n],B.x[n]) END
ELSE HALT(100)
END;
ELSE HALT(100)
END
END AllReal2;
PROCEDURE AllLReal1* (A: Array; f: PROCEDURE(y:LONGREAL): LONGREAL);
VAR n: LONGINT;
BEGIN
WITH A: LRealArray DO FOR n := 0 TO A.len-1 DO A.y[n] := f(A.y[n]) END
ELSE HALT(100)
END
END AllLReal1;
PROCEDURE AllLReal2* (A,B: Array; f: PROCEDURE(y1,y2:LONGREAL): LONGREAL);
VAR n: LONGINT;
BEGIN
WITH A: LRealArray DO
WITH B: LRealArray DO
FOR n := 0 TO A.len-1 DO A.y[n] := f(A.y[n],B.y[n]) END
ELSE HALT(100)
END
ELSE HALT(100)
END
END AllLReal2;
PROCEDURE InvertSign (s: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN -s
END InvertSign;
PROCEDURE Add (s1,s2: SHORTINT): SHORTINT; (* Test procedure for unary operations *)
BEGIN
RETURN s1+s2
END Add;
PROCEDURE Test*;
(** Compares "Allxxx" procedure with conventional indexing scheme *)
VAR A1: Array;
A2: POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF SHORTINT;
data: SIntPtr;
dim1: SizeVector;
i, starttime, endtime, a, b, c, d: LONGINT;
BEGIN
(* ALL ELEMENT OPERATIONS *)
Out.String("----------------------------------"); Out.Ln;
NEW(A1);
SizeVector4(dim1, 64, 32, 32, 32);
NEW(data, dim1[0]*dim1[1]*dim1[2]*dim1[3]);
InitSInt(A1, dim1, data, FALSE);
starttime := Input.Time();
WITH A1: SIntArray DO
FOR i := 0 TO A1.len-1 DO A1.s[i] := InvertSign(A1.s[i]); END (* linear array access *)
END;
endtime := Input.Time();
Out.String("ALL ELEMENT MONADIC OPERATION:"); Out.Ln;
Out.String("arbitrary array, linear access, invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
starttime := Input.Time();
AllSInt1(A1, InvertSign); (* monadic proc. using "All" procedure *)
endtime := Input.Time();
Out.String("arbitrary array 'ALL procedure', invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
NEW(A2, 64, 32, 32, 32);
starttime := Input.Time();
FOR a := 0 TO LEN(A2^, 0)-1 DO (* monadic proc. using conventional indices *)
FOR b := 0 TO LEN(A2^, 1)-1 DO
FOR c := 0 TO LEN(A2^, 2)-1 DO
FOR d := 0 TO LEN(A2^, 3)-1 DO
A2[a, b, c, d] := InvertSign(A2[a, b, c, d])
END
END
END
END;
endtime := Input.Time();
Out.String("conventional indexed array invert sign:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
Out.String("**********************************"); Out.Ln;
starttime := Input.Time();
AllSInt2(A1, A1, Add); (* dyadic proc. using "All" procedure *)
endtime := Input.Time();
Out.String("ALL ELEMENT DYADIC OPERATION:"); Out.Ln;
Out.String("arbitrary array ,'ALL procedure, addition:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
starttime := Input.Time();
FOR a := 0 TO LEN(A2^, 0)-1 DO (* dyadic proc. using conventional approach *)
FOR b := 0 TO LEN(A2^, 1)-1 DO
FOR c := 0 TO LEN(A2^, 2)-1 DO
FOR d := 0 TO LEN(A2^, 3)-1 DO
A2[a, b, c, d] := Add(A2[a, b, c, d], A2[a, b, c, d])
END
END
END
END;
endtime := Input.Time();
Out.String("conventional indexed array, addition:"); Out.String(" time: ");
Out.Int(endtime-starttime, 5); Out.String("ms for "); Out.Int(A1.len, 10);
Out.String(" elements"); Out.Ln;
Out.String("**********************************"); Out.Ln
END Test;
(*PROCEDURE Test2*; (* insufficient registers with Intel *)
VAR A, B: ARRAY 2, 2, 2, 2, 2, 2 OF INTEGER;
i, j, k, l, m, n, o, p, q, r: INTEGER;
BEGIN
Out.String('Test2: ... ');
FOR i := 0 TO 1 DO
FOR j := 0 TO 1 DO
FOR k := 0 TO 1 DO
FOR l := 0 TO 1 DO
FOR m := 0 TO 1 DO
FOR n := 0 TO 1 DO
A[i, j, k, l, m, n] := B[i, j, k, l, m, n]+1
END
END
END
END
END
END
Out.String('done'); Out.Ln
END Test2; *)
(*PROCEDURE Test3*; (* insufficient registers with Intel *)
VAR A, B: ARRAY 2,2,2,2,2,2,2,2,2,2 OF INTEGER;
i, j, k, l, m, n, o, p, q, r: INTEGER;
BEGIN
Out.String('Test3: ... ');
FOR i := 0 TO 1 DO
FOR j := 0 TO 1 DO
FOR k := 0 TO 1 DO
FOR l := 0 TO 1 DO
FOR m := 0 TO 1 DO
FOR n := 0 TO 1 DO
FOR o := 0 TO 1 DO
FOR p := 0 TO 1 DO
FOR q := 0 TO 1 DO
FOR r := 0 TO 1 DO
A[i, j, k, l, m, n, o, p, q, r] := B[i, j, k, l, m, n, o, p, q, r]+1
END
END
END
END
END
END
END
END
END
END
Out.String('done'); Out.Ln
END Test3; *)
BEGIN
END MultiArrays.
MultiArrays.Test
MultiArrays.Test2
MultiArrays.Test3
Compiler.Compile \xc MultiArrays.Mod ~
System.Free MultiArrays~

187
src/library/misc/crt.Mod Normal file
View file

@ -0,0 +1,187 @@
MODULE crt;
IMPORT vt100, Unix, Console,
Strings; (* strings to remove later ? *)
CONST
(* Foreground and background color constants *)
Black* = 0;
Blue* = 1;
Green* = 2;
Cyan* = 3;
Red* = 4;
Magenta* = 5;
Brown* = 6;
LightGray* = 7;
(* Foreground color constants *)
DarkGray* = 8;
LightBlue* = 9;
LightGreen* = 10;
LightCyan* = 11;
LightRed* = 12;
LightMagenta* = 13;
Yellow* = 14;
White* = 15;
(* Add-in for blinking *)
Blink* = 128;
TYPE
PFdSet = POINTER TO Unix.FdSet;
VAR tmpstr : ARRAY 23 OF CHAR;
PROCEDURE EraseDisplay*;
BEGIN
vt100.ED(2);
END EraseDisplay;
PROCEDURE ClrScr*;
BEGIN
vt100.ED(2);
END ClrScr;
PROCEDURE ClrEol*;
BEGIN
vt100.EL(0);
END ClrEol;
PROCEDURE cursoroff*;
BEGIN
vt100.DECTCEMl;
END cursoroff;
PROCEDURE cursoron*;
BEGIN
vt100.DECTCEMh;
END cursoron;
PROCEDURE Delay*( ms : INTEGER);
VAR i : LONGINT;
tv : Unix.Timeval;
pfd : PFdSet;
BEGIN
tv.sec := 0;
tv.usec := ms * 1000;
pfd := NIL;
i := Unix.Select(0, pfd^, pfd^, pfd^, tv);
END Delay;
PROCEDURE GotoXY* (x, y: INTEGER);
BEGIN
vt100.CUP (y, x);
END GotoXY;
PROCEDURE HighVideo*;
VAR tmpstr: ARRAY 5 OF CHAR;
BEGIN
COPY (vt100.CSI, tmpstr);
Strings.Append(vt100.Bold, tmpstr);
Console.String(tmpstr);
END HighVideo;
PROCEDURE DelLine*;
BEGIN
vt100.EL(2);
END DelLine;
PROCEDURE InsLine*;
BEGIN
vt100.SCP;
Console.Ln;
vt100.RCP;
END InsLine;
PROCEDURE LowVideo*;
VAR tmpstr : ARRAY 7 OF CHAR;
BEGIN
COPY (vt100.CSI, tmpstr);
Strings.Append(vt100.ResetBold, tmpstr);
Console.String(tmpstr);
END LowVideo;
PROCEDURE NormVideo*;
VAR tmpstr : ARRAY 7 OF CHAR;
BEGIN
COPY(vt100.CSI, tmpstr);
Strings.Append(vt100.ResetAll, tmpstr);
Console.String(tmpstr);
END NormVideo;
PROCEDURE TextBackground*(color : SHORTINT);
BEGIN
IF color = Black THEN
vt100.SetAttr(vt100.BBlack)
ELSIF color = Blue THEN
vt100.SetAttr(vt100.BBlue)
ELSIF color = Green THEN
vt100.SetAttr(vt100.BGreen)
ELSIF color = Cyan THEN
vt100.SetAttr(vt100.BCyan)
ELSIF color = Red THEN
vt100.SetAttr(vt100.BRed)
ELSIF color = Magenta THEN
vt100.SetAttr(vt100.BMagenta)
ELSIF color = Brown THEN
vt100.SetAttr(vt100.BYellow)
ELSIF color = LightGray THEN
vt100.SetAttr(vt100.BLightGray)
ELSIF color = DarkGray THEN
vt100.SetAttr(vt100.BDarkGray)
ELSIF color = LightBlue THEN
vt100.SetAttr(vt100.BLightBlue)
ELSIF color = LightGreen THEN
vt100.SetAttr(vt100.BLightBlue)
ELSIF color = LightCyan THEN
vt100.SetAttr(vt100.BLightCyan)
ELSIF color = LightRed THEN
vt100.SetAttr(vt100.BLightRed)
ELSIF color = LightMagenta THEN
vt100.SetAttr(vt100.BLightMagenta)
ELSIF color = Yellow THEN
vt100.SetAttr(vt100.BLightYellow)
ELSIF color = White THEN
vt100.SetAttr(vt100.BWhite)
END;
END TextBackground;
PROCEDURE TextColor*(color : SHORTINT);
BEGIN
IF color = Black THEN
vt100.SetAttr(vt100.Black)
ELSIF color = Blue THEN
vt100.SetAttr(vt100.Blue)
ELSIF color = Green THEN
vt100.SetAttr(vt100.Green)
ELSIF color = Cyan THEN
vt100.SetAttr(vt100.Cyan)
ELSIF color = Red THEN
vt100.SetAttr(vt100.Red)
ELSIF color = Magenta THEN
vt100.SetAttr(vt100.Magenta)
ELSIF color = Brown THEN
vt100.SetAttr(vt100.Yellow)
ELSIF color = LightGray THEN
vt100.SetAttr(vt100.LightGray)
ELSIF color = DarkGray THEN
vt100.SetAttr(vt100.DarkGray)
ELSIF color = LightBlue THEN
vt100.SetAttr(vt100.LightBlue)
ELSIF color = LightGreen THEN
vt100.SetAttr(vt100.LightBlue)
ELSIF color = LightCyan THEN
vt100.SetAttr(vt100.LightCyan)
ELSIF color = LightRed THEN
vt100.SetAttr(vt100.LightRed)
ELSIF color = LightMagenta THEN
vt100.SetAttr(vt100.LightMagenta)
ELSIF color = Yellow THEN
vt100.SetAttr(vt100.LightYellow)
ELSIF color = White THEN
vt100.SetAttr(vt100.White)
END;
END TextColor;
END crt.

342
src/library/misc/vt100.Mod Normal file
View file

@ -0,0 +1,342 @@
MODULE vt100;
IMPORT Console, Strings;
(* reference http://en.wikipedia.org/wiki/ANSI_escape_code
& http://misc.flogisoft.com/bash/tip_colors_and_formatting
*)
CONST
Escape* = 1BX;
SynchronousIdle* = 16X;
LeftCrotchet* = '[';
(* formatting *)
Bold* = "1m";
Dim* = "2m";
Underlined* = "4m";
Blink* = "5m"; (* does not work with most emulators, works in tty and xterm *)
Reverse* = "7m"; (* invert the foreground and background colors *)
Hidden* = "8m"; (* useful for passwords *)
(* reset *)
ResetAll* = "0m";
ResetBold* = "21m";
ResetDim* = "22m";
ResetUnderlined* = "24m";
ResetBlink* = "25m";
ResetReverse* = "27m";
ResetHidden* = "28m";
(* foreground colors *)
Black* = "30m";
Red* = "31m";
Green* = "32m";
Yellow* = "33m";
Blue* = "34m";
Magenta* = "35m";
Cyan* = "36m";
LightGray* = "37m";
Default* = "39m";
DarkGray* = "90m";
LightRed* = "91m";
LightGreen* = "92m";
LightYellow* = "93m";
LightBlue* = "94m";
LightMagenta* = "95m";
LightCyan* = "96m";
White* = "97m";
(* background colors *)
BBlack* = "40m";
BRed* = "41m";
BGreen* = "42m";
BYellow* = "43m";
BBlue* = "44m";
BMagenta* = "45m";
BCyan* = "46m";
BLightGray* = "47m";
BDefault* = "49m";
BDarkGray* = "100m";
BLightRed* = "101m";
BLightGreen* = "102m";
BLightYellow* = "103m";
BLightBlue* = "104m";
BLightMagenta*= "105m";
BLightCyan* = "106m";
BWhite* = "107m";
VAR
CSI* : ARRAY 5 OF CHAR;
tmpstr : ARRAY 32 OF CHAR;
(* IntToStr routine taken from
https://github.com/romiras/Oberon-F-components/blob/master/Ott/Mod/IntStr.cp
and modified to work on 64bit system,
in order to avoid using oocIntStr, which has many dependencies *)
PROCEDURE Reverse0 (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse0;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(* Converts the value of `int' to string form and copies the possibly truncated
result to `str'. *)
VAR
b : ARRAY 21 OF CHAR;
s, e: INTEGER;
maxLength : SHORTINT; (* maximum number of digits representing a LONGINT value *)
BEGIN
IF SIZE(LONGINT) = 4 THEN maxLength := 11 END;
IF SIZE(LONGINT) = 8 THEN maxLength := 20 END;
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
IF SIZE(LONGINT) = 4 THEN
b := "-2147483648";
e := 11
ELSE (* SIZE(LONGINT) = 8 *)
b := "-9223372036854775808";
e := 20
END
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse0(b, s, e-1);
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
PROCEDURE EscSeq0 (letter : ARRAY OF CHAR);
VAR
cmd : ARRAY 9 OF CHAR;
BEGIN
COPY(CSI, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq0;
PROCEDURE EscSeq (n : INTEGER; letter : ARRAY OF CHAR);
VAR nstr : ARRAY 2 OF CHAR;
cmd : ARRAY 7 OF CHAR;
BEGIN
IntToStr (n, nstr);
COPY(CSI, cmd);
Strings.Append (nstr, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq;
PROCEDURE EscSeqSwapped (n : INTEGER; letter : ARRAY OF CHAR);
VAR nstr : ARRAY 2 OF CHAR;
cmd : ARRAY 7 OF CHAR;
BEGIN
IntToStr (n, nstr);
COPY(CSI, cmd);
Strings.Append (letter, cmd);
Strings.Append (nstr, cmd);
Console.String (cmd);
END EscSeqSwapped;
PROCEDURE EscSeq2(n, m : INTEGER; letter : ARRAY OF CHAR);
VAR nstr, mstr : ARRAY 5 OF CHAR;
cmd : ARRAY 12 OF CHAR;
BEGIN
IntToStr(n, nstr);
IntToStr(m, mstr);
COPY (CSI, cmd);
Strings.Append (nstr, cmd);
Strings.Append (';', cmd);
Strings.Append (mstr, cmd);
Strings.Append (letter, cmd);
Console.String (cmd);
END EscSeq2;
(* Cursor up
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUU*(n : INTEGER);
BEGIN
EscSeq (n, 'A');
END CUU;
(* Cursor down
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUD*(n : INTEGER);
BEGIN
EscSeq (n, 'B');
END CUD;
(* Cursor forward
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUF*(n : INTEGER);
BEGIN
EscSeq (n, 'C');
END CUF;
(* Cursor back
moves cursor n cells in the given direction. if the cursor is already at the edge of the screen, this has no effect *)
PROCEDURE CUB*(n : INTEGER);
BEGIN
EscSeq (n, 'D');
END CUB;
(* Curnser Next Line
moves cursor to beginning of the line n lines down *)
PROCEDURE CNL*( n: INTEGER);
BEGIN
EscSeq (n, 'E');
END CNL;
(* Cursor Previous Line
Moves cursor to beginning of the line n lines down *)
PROCEDURE CPL*( n : INTEGER);
BEGIN
EscSeq (n, 'F');
END CPL;
(* Cursor Horizontal Absolute
Moves the cursor to column n *)
PROCEDURE CHA*( n : INTEGER);
BEGIN
EscSeq (n, 'G');
END CHA;
(* Cursor position, moves cursor to row n, column m *)
PROCEDURE CUP*(n, m : INTEGER);
BEGIN
EscSeq2 (n, m, 'H');
END CUP;
(* Erase Display
if n = 0 then clears from cursor to end of the screen
if n = 1 then clears from cursor to beginning of the screen
if n = 2 then clears entire screen *)
PROCEDURE ED* (n : INTEGER);
BEGIN
EscSeq(n, 'J');
END ED;
(* Erase in Line
Erases part of the line. If n is zero, clear from cursor to the end of the line. If n is one, clear from cursor to beginning of the line. If n is two, clear entire line. Cursor position does not change *)
PROCEDURE EL*( n : INTEGER);
BEGIN
EscSeq(n, 'K');
END EL;
(* Scroll Up
Scroll whole page up by n lines. New lines are added at the bottom *)
PROCEDURE SU*( n : INTEGER);
BEGIN
EscSeq(n, 'S')
END SU;
(* Scroll Down
Scroll whole page down by n (default 1) lines. New lines are added at the top *)
PROCEDURE SD*( n : INTEGER);
BEGIN
EscSeq(n, 'T');
END SD;
(* Horizontal and Vertical Position,
Moves the cursor to row n, column m. Both default to 1 if omitted. Same as CUP *)
PROCEDURE HVP*(n, m : INTEGER);
BEGIN
EscSeq2 (n, m, 'f');
END HVP;
(* Select Graphic Rendition
Sets SGR parameters, including text color. After CSI can be zero or more parameters separated with ;. With no parameters, CSI m is treated as CSI 0 m (reset / normal), which is typical of most of the ANSI escape sequences *)
PROCEDURE SGR*( n : INTEGER);
BEGIN
EscSeq(n, 'm');
END SGR;
PROCEDURE SGR2*( n, m : INTEGER);
BEGIN
EscSeq2(n, m, 'm');
END SGR2;
(* Device Status Report
Reports the cursor position (CPR) to the application as (as though typed at the keyboard) ESC[n;mR, where n is the row and m is the column.) *)
PROCEDURE DSR*(n : INTEGER);
BEGIN
EscSeq(6, 'n');
END DSR;
(* Save Cursor Position *)
PROCEDURE SCP*;
BEGIN
EscSeq0('s');
END SCP;
(* Restore Cursor Position *)
PROCEDURE RCP*;
BEGIN
EscSeq0('u');
END RCP;
(* Hide the cursor *)
PROCEDURE DECTCEMl*;
BEGIN
EscSeq0("?25l")
END DECTCEMl;
(* shows the cursor *)
PROCEDURE DECTCEMh*;
BEGIN
EscSeq0("?25h")
END DECTCEMh;
PROCEDURE SetAttr*(attr : ARRAY OF CHAR);
VAR tmpstr : ARRAY 16 OF CHAR;
BEGIN
COPY(CSI, tmpstr);
Strings.Append(attr, tmpstr);
Console.String(tmpstr);
END SetAttr;
BEGIN
(* init CSI sequence *)
COPY(Escape, CSI);
Strings.Append(LeftCrotchet, CSI);
(*
EraseDisplay;
GotoXY (0, 0);
COPY(CSI, tmpstr);
Strings.Append(Green, tmpstr);
Strings.Append("hello", tmpstr);
Console.String(tmpstr); Console.Ln;
*)
END vt100.