2
0

ArrayXdRat.Mod 43 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170
  1. (* CAPO - Computational Analysis Platform for Oberon - by Alan Freed and Felix Friedrich. *)
  2. (* Version 1, Update 2 *)
  3. MODULE ArrayXdRat; (** AUTHOR "fof"; PURPOSE "Basic operations on an X-dimensional array of Rational"; *)
  4. (** any item containing the string "dbg" is for debugging purposes only and will be removed from this module, do NOT use *)
  5. IMPORT SYSTEM, NbrInt, ArrayXdBytes, Array1d := Array1dRat, dbgOut := KernelLog, NbrRat, DataErrors,
  6. Array1dInt, DataIO;
  7. CONST
  8. generic* = 0; vector* = 1; matrix* = 2; cube* = 3; hcube* = 4;
  9. (** The version used when reading/writing an arbitrary dimensional array to file. *)
  10. VERSION* = 1;
  11. StrictBoundaryC* = 0; (* data beyond limit -> TRAP *)
  12. AbsorbingBoundaryC* = 1; (* data beyond limit = zero*)
  13. PeriodicBoundaryC* = 2; (* data[x] =data[x MOD LEN(data)], torus *)
  14. SymmetricOnBoundaryC* = 3; (* mirror boundaries, using border point once; W= reflection centered on point N *)
  15. SymmetricOffBoundaryC* = 4; (* mirror boundaries, using border point twice; reflection centered between point N and point N+1 *)
  16. AntisymmetricOnBoundaryC* = 5; (* like SymmetricOnBoundaryC but with additional change of sign if out of bounds *)
  17. AntisymmetricOffBoundaryC* = 6; (* like SymmetricOffBoundaryC but with additional change of sign if out of bounds *)
  18. TYPE
  19. Value* = Array1d.Value; Index* = LONGINT; Array1* = Array1d.Array; IntValue* = Array1dInt.Value;
  20. Array2* = POINTER TO ARRAY OF ARRAY OF Value;
  21. Array3* = POINTER TO ARRAY OF ARRAY OF ARRAY OF Value;
  22. Array4* = POINTER TO ARRAY OF ARRAY OF ARRAY OF ARRAY OF Value;
  23. Map* = Array1d.Map;
  24. (** Class Array has been DataIO registered, and therefore, any instance of it can be made persistent
  25. by using the DataIO Reader and Writer, or more simply, by calling procedures Load and Store below. *)
  26. Array* = OBJECT (ArrayXdBytes.Array)
  27. VAR data-: Array1; (*! will probably be removed, do not use ! *)
  28. (** override *)
  29. PROCEDURE Allocate*( size: LONGINT; VAR adr: Index; VAR ptr: ANY );
  30. BEGIN
  31. NEW( data, size ); adr := ADDRESSOF( data[0] ); ptr := data;
  32. END Allocate;
  33. PROCEDURE GetInfo*( VAR elementsize: Index );
  34. BEGIN
  35. elementsize := SIZEOF( Value );
  36. END GetInfo;
  37. PROCEDURE AlikeX*( ): ArrayXdBytes.Array;
  38. VAR copy: Array;
  39. BEGIN
  40. NEW( copy, origin, len ); RETURN copy;
  41. END AlikeX;
  42. (** new *)
  43. (** Read and Write are for internal use only.
  44. Exporting them permits extensible, persistent, data types to be constructed. *)
  45. PROCEDURE Read*( R: DataIO.Reader );
  46. BEGIN {EXCLUSIVE}
  47. LoadXd( R )
  48. END Read;
  49. PROCEDURE Write*( W: DataIO.Writer );
  50. BEGIN
  51. StoreXd( W, TRUE )
  52. END Write;
  53. PROCEDURE Type*( ): SHORTINT;
  54. (* generic, vector, matrix, cube, hcube *)
  55. BEGIN
  56. IF dim < 5 THEN RETURN SHORT( SHORT( dim ) ) ELSE RETURN 0 END;
  57. END Type;
  58. PROCEDURE Get1*( x: Index ): Value;
  59. VAR v: Value;
  60. BEGIN
  61. ArrayXdBytes.Get1( SELF, x, v ); RETURN v;
  62. END Get1;
  63. PROCEDURE Set1*( x: Index; v: Value );
  64. BEGIN
  65. ArrayXdBytes.Set1( SELF, x, v );
  66. END Set1;
  67. PROCEDURE Get2*( x, y: Index ): Value;
  68. VAR v: Value;
  69. BEGIN
  70. ArrayXdBytes.Get2( SELF, x, y, v ); RETURN v;
  71. END Get2;
  72. PROCEDURE Set2*( x, y: Index; v: Value );
  73. BEGIN
  74. ArrayXdBytes.Set2( SELF, x, y, v );
  75. END Set2;
  76. PROCEDURE Get3*( x, y, z: Index ): Value;
  77. VAR v: Value;
  78. BEGIN
  79. ArrayXdBytes.Get3( SELF, x, y, z, v ); RETURN v;
  80. END Get3;
  81. PROCEDURE Set3*( x, y, z: Index; v: Value );
  82. BEGIN
  83. ArrayXdBytes.Set3( SELF, x, y, z, v );
  84. END Set3;
  85. PROCEDURE Get4*( x, y, z, t: Index ): Value;
  86. VAR v: Value;
  87. BEGIN
  88. ArrayXdBytes.Get4( SELF, x, y, z, t, v ); RETURN v;
  89. END Get4;
  90. PROCEDURE Set4*( x, y, z, t: Index; v: Value );
  91. BEGIN
  92. ArrayXdBytes.Set4( SELF, x, y, z, t, v );
  93. END Set4;
  94. PROCEDURE GetX*( VAR x: ARRAY OF Index; dim: Index ): Value;
  95. VAR v: Value;
  96. BEGIN
  97. ArrayXdBytes.GetX( SELF, x, dim, v ); RETURN v;
  98. END GetX;
  99. PROCEDURE SetX*( VAR x: ARRAY OF Index; dim: Index; v: Value );
  100. BEGIN
  101. ArrayXdBytes.SetX( SELF, x, dim, v );
  102. END SetX;
  103. (*** Get with boundary conditions *)
  104. (** absorbing: data beyond limit = zero *)
  105. PROCEDURE Get1BAbsorbing*( x: Index ): Value;
  106. VAR v: Value;
  107. BEGIN
  108. IF ArrayXdBytes.InBounds( o0, l0, x ) THEN ArrayXdBytes.Get1( SELF, x, v ); RETURN v ELSE RETURN zero END;
  109. END Get1BAbsorbing;
  110. PROCEDURE Get2BAbsorbing*( x, y: Index ): Value;
  111. VAR v: Value;
  112. BEGIN
  113. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) THEN
  114. ArrayXdBytes.Get2( SELF, x, y, v ); RETURN v
  115. ELSE RETURN zero
  116. END;
  117. END Get2BAbsorbing;
  118. PROCEDURE Get3BAbsorbing*( x, y, z: Index ): Value;
  119. VAR v: Value;
  120. BEGIN
  121. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) THEN
  122. ArrayXdBytes.Get3( SELF, x, y, z, v ); RETURN v
  123. ELSE RETURN zero
  124. END;
  125. END Get3BAbsorbing;
  126. PROCEDURE Get4BAbsorbing*( x, y, z, t: Index ): Value;
  127. VAR v: Value;
  128. BEGIN
  129. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) &
  130. ArrayXdBytes.InBounds( o3, l3, t ) THEN
  131. ArrayXdBytes.Get4( SELF, x, y, z, t, v ); RETURN v
  132. ELSE RETURN zero
  133. END;
  134. END Get4BAbsorbing;
  135. PROCEDURE GetXBAbsorbing*( b: ARRAY OF Index; dim: Index ): Value;
  136. VAR v: Value; i: Index;
  137. BEGIN
  138. i := 0;
  139. WHILE (i < dim) DO
  140. IF ~ArrayXdBytes.InBounds( origin[i], len[i], b[i] ) THEN RETURN zero END;
  141. INC( i );
  142. END;
  143. ArrayXdBytes.GetX( SELF, b, dim, v ); RETURN v
  144. END GetXBAbsorbing;
  145. (** periodic: data[x] =data[x MOD LEN(data)] *)
  146. PROCEDURE Get1BPeriodic*( x: Index ): Value;
  147. VAR v: Value;
  148. BEGIN
  149. ArrayXdBytes.Get1( SELF, ArrayXdBytes.PeriodicBounds( o0, l0, x ), v ); RETURN v
  150. END Get1BPeriodic;
  151. PROCEDURE Get2BPeriodic*( x, y: Index ): Value;
  152. VAR v: Value;
  153. BEGIN
  154. ArrayXdBytes.Get2( SELF, ArrayXdBytes.PeriodicBounds( o0, l0, x ), ArrayXdBytes.PeriodicBounds( o1, l1, y ), v );
  155. RETURN v
  156. END Get2BPeriodic;
  157. PROCEDURE Get3BPeriodic*( x, y, z: Index ): Value;
  158. VAR v: Value;
  159. BEGIN
  160. ArrayXdBytes.Get3( SELF, ArrayXdBytes.PeriodicBounds( o0, l0, x ), ArrayXdBytes.PeriodicBounds( o1, l1, y ),
  161. ArrayXdBytes.PeriodicBounds( o2, l2, z ), v );
  162. RETURN v
  163. END Get3BPeriodic;
  164. PROCEDURE Get4BPeriodic*( x, y, z, t: Index ): Value;
  165. VAR v: Value;
  166. BEGIN
  167. ArrayXdBytes.Get4( SELF, ArrayXdBytes.PeriodicBounds( o0, l0, x ), ArrayXdBytes.PeriodicBounds( o1, l1, y ),
  168. ArrayXdBytes.PeriodicBounds( o2, l2, z ), ArrayXdBytes.PeriodicBounds( o3, l3, z ), v );
  169. RETURN v
  170. END Get4BPeriodic;
  171. PROCEDURE GetXBPeriodic*( b: ARRAY OF Index; dim: Index ): Value;
  172. VAR v: Value; i: Index;
  173. BEGIN
  174. i := 0;
  175. WHILE (i < dim) DO b[i] := ArrayXdBytes.PeriodicBounds( origin[i], len[i], b[i] ); INC( i ) END;
  176. ArrayXdBytes.GetX( SELF, b, dim, v ); RETURN v
  177. END GetXBPeriodic;
  178. (** mirror boundaries, using border point twice; reflection centered between point N and point N+1 *)
  179. PROCEDURE Get1BSymmetricOffB*( x: Index ): Value;
  180. VAR v: Value;
  181. BEGIN
  182. ArrayXdBytes.Get1( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), v ); RETURN v
  183. END Get1BSymmetricOffB;
  184. PROCEDURE Get2BSymmetricOffB*( x, y: Index ): Value;
  185. VAR v: Value;
  186. BEGIN
  187. ArrayXdBytes.Get2( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ), v ); RETURN v
  188. END Get2BSymmetricOffB;
  189. PROCEDURE Get3BSymmetricOffB*( x, y, z: Index ): Value;
  190. VAR v: Value;
  191. BEGIN
  192. ArrayXdBytes.Get3( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ),
  193. ArrayXdBytes.MirrorOffB( o2, l2, z ), v );
  194. RETURN v
  195. END Get3BSymmetricOffB;
  196. PROCEDURE Get4BSymmetricOffB*( x, y, z, t: Index ): Value;
  197. VAR v: Value;
  198. BEGIN
  199. ArrayXdBytes.Get4( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ),
  200. ArrayXdBytes.MirrorOffB( o2, l2, z ), ArrayXdBytes.MirrorOffB( o3, l3, z ), v );
  201. RETURN v
  202. END Get4BSymmetricOffB;
  203. PROCEDURE GetXBSymmetricOffB*( b: ARRAY OF Index; dim: Index ): Value;
  204. VAR v: Value; i: Index;
  205. BEGIN
  206. i := 0;
  207. WHILE (i < dim) DO b[i] := ArrayXdBytes.MirrorOffB( origin[i], len[i], b[i] ); INC( i ) END;
  208. ArrayXdBytes.GetX( SELF, b, dim, v ); RETURN v
  209. END GetXBSymmetricOffB;
  210. (** mirror boundaries, using border point once; reflection centered on point N*)
  211. PROCEDURE Get1BSymmetricOnB*( x: Index ): Value;
  212. VAR v: Value;
  213. BEGIN
  214. x := ArrayXdBytes.MirrorOnB( o0, l0, x ); ArrayXdBytes.Get1( SELF, x, v ); RETURN v
  215. END Get1BSymmetricOnB;
  216. PROCEDURE Get2BSymmetricOnB*( x, y: Index ): Value;
  217. VAR v: Value;
  218. BEGIN
  219. x := ArrayXdBytes.MirrorOnB( o0, l0, x ); y := ArrayXdBytes.MirrorOnB( o1, l1, y );
  220. ArrayXdBytes.Get2( SELF, x, y, v ); RETURN v
  221. END Get2BSymmetricOnB;
  222. PROCEDURE Get3BSymmetricOnB*( x, y, z: Index ): Value;
  223. VAR v: Value;
  224. BEGIN
  225. x := ArrayXdBytes.MirrorOnB( o0, l0, x ); y := ArrayXdBytes.MirrorOnB( o1, l1, y );
  226. z := ArrayXdBytes.MirrorOnB( o2, l2, z ); ArrayXdBytes.Get3( SELF, x, y, z, v ); RETURN v
  227. END Get3BSymmetricOnB;
  228. PROCEDURE Get4BSymmetricOnB*( x, y, z, t: Index ): Value;
  229. VAR v: Value;
  230. BEGIN
  231. x := ArrayXdBytes.MirrorOnB( o0, l0, x ); y := ArrayXdBytes.MirrorOnB( o1, l1, y );
  232. z := ArrayXdBytes.MirrorOnB( o2, l2, z ); t := ArrayXdBytes.MirrorOnB( o3, l3, z );
  233. ArrayXdBytes.Get4( SELF, x, y, z, t, v ); RETURN v
  234. END Get4BSymmetricOnB;
  235. PROCEDURE GetXBSymmetricOnB*( b: ARRAY OF Index; dim: Index ): Value;
  236. VAR v: Value; i: Index;
  237. BEGIN
  238. i := 0;
  239. WHILE (i < dim) DO b[i] := ArrayXdBytes.MirrorOnB( origin[i], len[i], b[i] ); INC( i ) END;
  240. ArrayXdBytes.GetX( SELF, b, dim, v ); RETURN v
  241. END GetXBSymmetricOnB;
  242. (* like SymmetricOffB but with change of sign if not in range *)
  243. PROCEDURE Get1BAntisymmetricOffB*( x: Index ): Value;
  244. VAR v: Value;
  245. BEGIN
  246. IF ArrayXdBytes.InBounds( o0, l0, x ) THEN ArrayXdBytes.Get1( SELF, x, v ); RETURN v
  247. ELSE ArrayXdBytes.Get1( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), v ); RETURN -v;
  248. END;
  249. END Get1BAntisymmetricOffB;
  250. PROCEDURE Get2BAntisymmetricOffB*( x, y: Index ): Value;
  251. VAR v: Value;
  252. BEGIN
  253. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) THEN
  254. ArrayXdBytes.Get2( SELF, x, y, v ); RETURN v
  255. ELSE
  256. ArrayXdBytes.Get2( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ), v ); RETURN -v
  257. END;
  258. END Get2BAntisymmetricOffB;
  259. PROCEDURE Get3BAntisymmetricOffB*( x, y, z: Index ): Value;
  260. VAR v: Value;
  261. BEGIN
  262. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) THEN
  263. ArrayXdBytes.Get3( SELF, x, y, z, v ); RETURN v
  264. ELSE
  265. ArrayXdBytes.Get3( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ),
  266. ArrayXdBytes.MirrorOffB( o2, l2, z ), v );
  267. RETURN -v
  268. END;
  269. END Get3BAntisymmetricOffB;
  270. PROCEDURE Get4BAntisymmetricOffB*( x, y, z, t: Index ): Value;
  271. VAR v: Value;
  272. BEGIN
  273. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) &
  274. ArrayXdBytes.InBounds( o3, l3, t ) THEN
  275. ArrayXdBytes.Get4( SELF, x, y, z, t, v ); RETURN v
  276. ELSE
  277. ArrayXdBytes.Get4( SELF, ArrayXdBytes.MirrorOffB( o0, l0, x ), ArrayXdBytes.MirrorOffB( o1, l1, y ),
  278. ArrayXdBytes.MirrorOffB( o2, l2, z ), ArrayXdBytes.MirrorOffB( o3, l3, t ), v );
  279. RETURN -v
  280. END;
  281. END Get4BAntisymmetricOffB;
  282. PROCEDURE GetXBAntisymmetricOffB*( b: ARRAY OF Index; dim: Index ): Value;
  283. VAR v: Value; i: Index; inv: BOOLEAN;
  284. BEGIN
  285. i := 0; inv := FALSE;
  286. WHILE (i < dim) DO
  287. inv := inv OR (~ArrayXdBytes.InBounds( origin[i], len[i], b[i] ));
  288. b[i] := ArrayXdBytes.MirrorOffB( origin[i], len[i], b[i] ); INC( i );
  289. END;
  290. ArrayXdBytes.GetX( SELF, b, dim, v );
  291. IF inv THEN RETURN -v ELSE RETURN v END;
  292. END GetXBAntisymmetricOffB;
  293. (** like SymmetricOnB but with change of sign if not in range *)
  294. PROCEDURE Get1BAntisymmetricOnB*( x: Index ): Value;
  295. VAR v: Value;
  296. BEGIN
  297. IF ArrayXdBytes.InBounds( o0, l0, x ) THEN ArrayXdBytes.Get1( SELF, x, v ); RETURN v
  298. ELSE ArrayXdBytes.Get1( SELF, ArrayXdBytes.MirrorOnB( o0, l0, x ), v ); RETURN -v;
  299. END;
  300. END Get1BAntisymmetricOnB;
  301. PROCEDURE Get2BAntisymmetricOnB*( x, y: Index ): Value;
  302. VAR v: Value;
  303. BEGIN
  304. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) THEN
  305. ArrayXdBytes.Get2( SELF, x, y, v ); RETURN v
  306. ELSE
  307. ArrayXdBytes.Get2( SELF, ArrayXdBytes.MirrorOnB( o0, l0, x ), ArrayXdBytes.MirrorOnB( o1, l1, y ), v ); RETURN -v
  308. END;
  309. END Get2BAntisymmetricOnB;
  310. PROCEDURE Get3BAntisymmetricOnB*( x, y, z: Index ): Value;
  311. VAR v: Value;
  312. BEGIN
  313. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) THEN
  314. ArrayXdBytes.Get3( SELF, x, y, z, v ); RETURN v
  315. ELSE
  316. ArrayXdBytes.Get3( SELF, ArrayXdBytes.MirrorOnB( o0, l0, x ), ArrayXdBytes.MirrorOnB( o1, l1, y ),
  317. ArrayXdBytes.MirrorOnB( o2, l2, z ), v );
  318. RETURN -v
  319. END;
  320. END Get3BAntisymmetricOnB;
  321. PROCEDURE Get4BAntisymmetricOnB*( x, y, z, t: Index ): Value;
  322. VAR v: Value;
  323. BEGIN
  324. IF ArrayXdBytes.InBounds( o0, l0, x ) & ArrayXdBytes.InBounds( o1, l1, y ) & ArrayXdBytes.InBounds( o2, l2, z ) &
  325. ArrayXdBytes.InBounds( o3, l3, t ) THEN
  326. ArrayXdBytes.Get4( SELF, x, y, z, t, v ); RETURN v
  327. ELSE
  328. ArrayXdBytes.Get4( SELF, ArrayXdBytes.MirrorOnB( o0, l0, x ), ArrayXdBytes.MirrorOnB( o1, l1, y ),
  329. ArrayXdBytes.MirrorOnB( o2, l2, z ), ArrayXdBytes.MirrorOnB( o3, l3, t ), v );
  330. RETURN -v
  331. END;
  332. END Get4BAntisymmetricOnB;
  333. PROCEDURE GetXBAntisymmetricOnB*( b: ARRAY OF Index; dim: Index ): Value;
  334. VAR v: Value; i: Index; inv: BOOLEAN;
  335. BEGIN
  336. i := 0; inv := FALSE;
  337. WHILE (i < dim) DO
  338. inv := inv OR (~ArrayXdBytes.InBounds( origin[i], len[i], b[i] ));
  339. b[i] := ArrayXdBytes.MirrorOnB( origin[i], len[i], b[i] ); INC( i );
  340. END;
  341. ArrayXdBytes.GetX( SELF, b, dim, v );
  342. IF inv THEN RETURN -v ELSE RETURN v END;
  343. END GetXBAntisymmetricOnB;
  344. (** copy using the current boundary condition SELF:bc*)
  345. PROCEDURE CopyToArray*( dest: Array; srcpos, srclen, destpos, destlen: ArrayXdBytes.IndexArray );
  346. BEGIN
  347. CopyArrayToArrayPartB( SELF, dest, bc, srcpos, srclen, destpos, destlen );
  348. END CopyToArray;
  349. (** apply map m to all entries, dimension ordering is not necessarily preserved! *)
  350. PROCEDURE MapAll*( m: Array1d.Map );
  351. BEGIN
  352. IF m # NIL THEN Array1d.ApplyMap( m, data^, 0, LEN( data ) ); ELSE DataErrors.Error( "A NIL mapping function was supplied." ) END
  353. END MapAll;
  354. PROCEDURE Negate*;
  355. BEGIN {EXCLUSIVE}
  356. Array1d.Negate( data^, 0, LEN( data ) );
  357. (*
  358. FOR i := 0 TO len - 1 DO vec[i] := -vec[i] END
  359. *)
  360. END Negate;
  361. (** arr := arr+x *)
  362. PROCEDURE Add*( x: Array );
  363. BEGIN
  364. IF x # NIL THEN
  365. IF LEN( data ) = LEN( x.data ) THEN
  366. BEGIN {EXCLUSIVE}
  367. (*FOR i := 0 TO len - 1 DO vec[i] := vec[i] - x.vec[i] END*)
  368. Array1d.AddAA( data^, x.data^, data^, 0, len[0] );
  369. END
  370. ELSE DataErrors.Error( "Lengths of the two arrays were not equal." )
  371. END
  372. ELSE DataErrors.Error( "The supplied array to be subtracted was NIL." )
  373. END
  374. END Add;
  375. (** arr := arr-x *)
  376. PROCEDURE Subtract*( x: Array );
  377. BEGIN
  378. IF x # NIL THEN
  379. IF LEN( data ) = LEN( x.data ) THEN
  380. BEGIN {EXCLUSIVE}
  381. (*FOR i := 0 TO len - 1 DO vec[i] := vec[i] - x.vec[i] END*)
  382. Array1d.SubtractAA( data^, x.data^, data^, 0, len[0] );
  383. END
  384. ELSE DataErrors.Error( "Lengths of the two arrays were not equal." )
  385. END
  386. ELSE DataErrors.Error( "The supplied array to be subtracted was NIL." )
  387. END
  388. END Subtract;
  389. (* arr[i] := a*arr[i] forall i*)
  390. PROCEDURE Multiply*( a: Value );
  391. VAR i: Index;
  392. BEGIN {EXCLUSIVE}
  393. FOR i := 0 TO LEN( data ) - 1 DO data[i] := a * data[i] END
  394. END Multiply;
  395. (** arr[i] :=arr[i] / a forall i *)
  396. PROCEDURE Divide*( a: Value );
  397. VAR i: Index;
  398. BEGIN
  399. IF a # 0 THEN
  400. BEGIN {EXCLUSIVE}
  401. FOR i := 0 TO LEN( data ) - 1 DO data[i] := data[i] / a; END
  402. END;
  403. ELSE DataErrors.Error( "Division by zero." )
  404. END
  405. END Divide;
  406. PROCEDURE dbgWrite*;
  407. VAR x, y, z: LONGINT;
  408. str: ARRAY 256 OF CHAR;
  409. BEGIN
  410. IF Type() = vector THEN
  411. FOR x := origin[0] TO origin[0] + len[0] - 1 DO
  412. NbrRat.RatToString( Get1( x ), str ); dbgOut.String( str ); dbgOut.String( "|" );
  413. END;
  414. dbgOut.Ln;
  415. ELSIF Type() = matrix THEN
  416. FOR y := origin[1] TO origin[1] + len[1] - 1 DO
  417. FOR x := origin[0] TO origin[0] + len[0] - 1 DO
  418. NbrRat.RatToString( Get2( x, y ), str ); dbgOut.String( str ); dbgOut.String( "|" );
  419. END;
  420. dbgOut.Ln;
  421. END;
  422. dbgOut.Ln;
  423. ELSIF Type() = cube THEN
  424. FOR z := origin[2] TO origin[2] + len[2] - 1 DO
  425. FOR y := origin[1] TO origin[1] + len[1] - 1 DO
  426. FOR x := origin[0] TO origin[0] + len[0] - 1 DO
  427. NbrRat.RatToString( Get3( x, y, z ), str ); dbgOut.String( str ); dbgOut.String( "|" );
  428. END;
  429. dbgOut.Ln;
  430. END;
  431. dbgOut.Ln;
  432. END;
  433. END;
  434. END dbgWrite;
  435. END Array;
  436. VAR
  437. zero: Value;
  438. PROCEDURE New1d*( ox, w: Index ): Array;
  439. VAR res: Array;
  440. BEGIN
  441. NEW( res, ArrayXdBytes.Array1( ox ), ArrayXdBytes.Array1( w ) ); RETURN res;
  442. END New1d;
  443. PROCEDURE New2d*( ox, w, oy, h: Index ): Array;
  444. VAR res: Array;
  445. BEGIN
  446. NEW( res, ArrayXdBytes.Array2( ox, oy ), ArrayXdBytes.Array2( w, h ) ); RETURN res;
  447. END New2d;
  448. PROCEDURE New3d*( ox, w, oy, h, oz, d: Index ): Array;
  449. VAR res: Array;
  450. BEGIN
  451. NEW( res, ArrayXdBytes.Array3( ox, oy, oz ), ArrayXdBytes.Array3( w, h, d ) ); RETURN res;
  452. END New3d;
  453. PROCEDURE New4d*( ox, w, oy, h, oz, d, ot, dt: Index ): Array;
  454. VAR res: Array;
  455. BEGIN
  456. NEW( res, ArrayXdBytes.Array4( ox, oy, oz, ot ), ArrayXdBytes.Array4( w, h, d, dt ) ); RETURN res;
  457. END New4d;
  458. PROCEDURE CopyVecToVec*( src, dest: Array; srcx, destx, len: Index );
  459. BEGIN
  460. IF (src.dim # 1) OR (dest.dim # 1) THEN HALT( 1001 ) END;
  461. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index1( srcx ), ArrayXdBytes.Index1( len ),
  462. ArrayXdBytes.Index1( destx ), ArrayXdBytes.Index1( len ) );
  463. END CopyVecToVec;
  464. PROCEDURE CopyMtxToVec*( src, dest: Array; dim: Index; srcx, srcy, destx, len: Index );
  465. VAR slen: ArrayXdBytes.IndexArray;
  466. BEGIN
  467. IF (src.dim # 2) OR (dest.dim # 1) THEN HALT( 1002 ) END;
  468. slen := ArrayXdBytes.Index2( 1, 1 ); slen[dim] := len;
  469. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index2( srcx, srcy ), slen,
  470. ArrayXdBytes.Index1( destx ), ArrayXdBytes.Index1( len ) );
  471. END CopyMtxToVec;
  472. PROCEDURE CopyVecToMtx*( src, dest: Array; dim: Index; srcx, destx, desty, len: Index );
  473. VAR slen: ArrayXdBytes.IndexArray;
  474. BEGIN
  475. IF (src.dim # 1) OR (dest.dim # 2) THEN HALT( 1002 ) END;
  476. slen := ArrayXdBytes.Index2( 1, 1 ); slen[dim] := len;
  477. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index1( srcx ), ArrayXdBytes.Index1( len ),
  478. ArrayXdBytes.Index2( destx, desty ), slen );
  479. END CopyVecToMtx;
  480. PROCEDURE CopyCubeToVec*( src, dest: Array; dim: Index; srcx, srcy, srcz, destx, len: Index );
  481. VAR slen: ArrayXdBytes.IndexArray;
  482. BEGIN
  483. IF (src.dim # 3) OR (dest.dim # 1) THEN HALT( 1003 ) END;
  484. slen := ArrayXdBytes.Index3( 1, 1, 1 ); slen[dim] := len;
  485. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index3( srcx, srcy, srcz ), slen,
  486. ArrayXdBytes.Index1( destx ), ArrayXdBytes.Index1( len ) );
  487. END CopyCubeToVec;
  488. PROCEDURE CopyVecToCube*( src, dest: Array; dim: Index; srcx, destx, desty, destz, len: Index );
  489. VAR slen: ArrayXdBytes.IndexArray;
  490. BEGIN
  491. IF (src.dim # 1) OR (dest.dim # 3) THEN HALT( 1002 ) END;
  492. slen := ArrayXdBytes.Index3( 1, 1, 1 ); slen[dim] := len;
  493. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index1( srcx ), ArrayXdBytes.Index1( len ),
  494. ArrayXdBytes.Index3( destx, desty, destz ), slen );
  495. END CopyVecToCube;
  496. PROCEDURE CopyHCubeToVec*( src, dest: Array; dim: Index; srcx, srcy, srcz, srct, destx, len: Index );
  497. VAR slen: ArrayXdBytes.IndexArray;
  498. BEGIN
  499. IF (src.dim # 4) OR (dest.dim # 1) THEN HALT( 1004 ) END;
  500. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dim] := len;
  501. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ), slen,
  502. ArrayXdBytes.Index1( destx ), ArrayXdBytes.Index1( len ) );
  503. END CopyHCubeToVec;
  504. PROCEDURE CopyVecToHCube*( src, dest: Array; dim: Index; srcx, destx, desty, destz, destt, len: Index );
  505. VAR slen: ArrayXdBytes.IndexArray;
  506. BEGIN
  507. IF (src.dim # 1) OR (dest.dim # 4) THEN HALT( 1002 ) END;
  508. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dim] := len;
  509. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index1( srcx ), ArrayXdBytes.Index1( len ),
  510. ArrayXdBytes.Index4( destx, desty, destz, destt ), slen );
  511. END CopyVecToHCube;
  512. PROCEDURE CopyMtxToMtx*( src, dest: Array; srcx, srcy, destx, desty, lenx, leny: Index );
  513. VAR slen: ArrayXdBytes.IndexArray;
  514. BEGIN
  515. IF (src.dim # 2) OR (dest.dim # 2) THEN HALT( 1005 ) END;
  516. slen := ArrayXdBytes.Index2( lenx, leny );
  517. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index2( srcx, srcy ), slen,
  518. ArrayXdBytes.Index2( destx, desty ), slen );
  519. END CopyMtxToMtx;
  520. PROCEDURE CopyCubeToMtx*( src, dest: Array; dimx, dimy: Index; srcx, srcy, srcz, destx, desty, lenx, leny: Index );
  521. VAR slen: ArrayXdBytes.IndexArray;
  522. BEGIN
  523. IF (src.dim # 3) OR (dest.dim # 2) THEN HALT( 1005 ) END;
  524. slen := ArrayXdBytes.Index3( 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny;
  525. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index3( srcx, srcy, srcz ), slen,
  526. ArrayXdBytes.Index2( destx, desty ), ArrayXdBytes.Index2( lenx, leny ) );
  527. END CopyCubeToMtx;
  528. PROCEDURE CopyMtxToCube*( src, dest: Array; dimx, dimy: Index; srcx, srcy, destx, desty, destz, lenx, leny: Index );
  529. VAR slen: ArrayXdBytes.IndexArray;
  530. BEGIN
  531. IF (src.dim # 2) OR (dest.dim # 3) THEN HALT( 1005 ) END;
  532. slen := ArrayXdBytes.Index3( 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny;
  533. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index2( srcx, srcy ), ArrayXdBytes.Index2( lenx, leny ),
  534. ArrayXdBytes.Index3( destx, desty, destz ), slen );
  535. END CopyMtxToCube;
  536. PROCEDURE CopyHCubeToMtx*( src, dest: Array; dimx, dimy: Index; srcx, srcy, srcz, srct, destx, desty, lenx, leny: Index );
  537. VAR slen: ArrayXdBytes.IndexArray;
  538. BEGIN
  539. IF (src.dim # 4) OR (dest.dim # 2) THEN HALT( 1005 ) END;
  540. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny;
  541. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ), slen,
  542. ArrayXdBytes.Index2( destx, desty ), ArrayXdBytes.Index2( lenx, leny ) );
  543. END CopyHCubeToMtx;
  544. PROCEDURE CopyMtxToHCube*( src, dest: Array; dimx, dimy: Index;
  545. srcx, srcy, destx, desty, destz, destt, lenx, leny: Index );
  546. VAR slen: ArrayXdBytes.IndexArray;
  547. BEGIN
  548. IF (src.dim # 2) OR (dest.dim # 4) THEN HALT( 1005 ) END;
  549. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny;
  550. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index2( srcx, srcy ), ArrayXdBytes.Index2( lenx, leny ),
  551. ArrayXdBytes.Index4( destx, desty, destz, destt ), slen );
  552. END CopyMtxToHCube;
  553. PROCEDURE CopyCubeToCube*( src, dest: Array; srcx, srcy, srcz, destx, desty, destz, lenx, leny, lenz: Index );
  554. VAR slen: ArrayXdBytes.IndexArray;
  555. BEGIN
  556. IF (src.dim # 3) OR (dest.dim # 3) THEN HALT( 1005 ) END;
  557. slen := ArrayXdBytes.Index3( lenx, leny, lenz );
  558. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index3( srcx, srcy, srcz ), slen,
  559. ArrayXdBytes.Index3( destx, desty, destz ), slen );
  560. END CopyCubeToCube;
  561. PROCEDURE CopyHCubeToCube*( src, dest: Array; dimx, dimy, dimz: Index;
  562. srcx, srcy, srcz, srct, destx, desty, destz, lenx, leny, lenz: Index );
  563. VAR slen: ArrayXdBytes.IndexArray;
  564. BEGIN
  565. IF (src.dim # 4) OR (dest.dim # 3) THEN HALT( 1005 ) END;
  566. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny; slen[dimz] := lenz;
  567. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ), slen,
  568. ArrayXdBytes.Index3( destx, desty, destz ),
  569. ArrayXdBytes.Index3( lenx, leny, lenz ) );
  570. END CopyHCubeToCube;
  571. PROCEDURE CopyCubeToHCube*( src, dest: Array; dimx, dimy, dimz: Index;
  572. srcx, srcy, srcz, destx, desty, destz, destt, lenx, leny, lenz: Index );
  573. VAR slen: ArrayXdBytes.IndexArray;
  574. BEGIN
  575. IF (src.dim # 3) OR (dest.dim # 4) THEN HALT( 1005 ) END;
  576. slen := ArrayXdBytes.Index4( 1, 1, 1, 1 ); slen[dimx] := lenx; slen[dimy] := leny; slen[dimz] := lenz;
  577. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index3( srcx, srcy, srcz ),
  578. ArrayXdBytes.Index3( lenx, leny, lenz ),
  579. ArrayXdBytes.Index4( destx, desty, destz, destt ), slen );
  580. END CopyCubeToHCube;
  581. PROCEDURE CopyHCubeToHCube*( src, dest: Array;
  582. srcx, srcy, srcz, srct, destx, desty, destz, destt, lenx, leny, lenz, lent: Index );
  583. VAR slen: ArrayXdBytes.IndexArray;
  584. BEGIN
  585. IF (src.dim # 4) OR (dest.dim # 4) THEN HALT( 1005 ) END;
  586. slen := ArrayXdBytes.Index4( lenx, leny, lenz, lent );
  587. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ), slen,
  588. ArrayXdBytes.Index4( destx, desty, destz, destt ), slen );
  589. END CopyHCubeToHCube;
  590. PROCEDURE CopyArrayToVec*( VAR src: ARRAY OF Value; dest: Array; srcx, destx, len: Index );
  591. BEGIN
  592. IF dest.dim # 1 THEN HALT( 1005 ) END;
  593. ArrayXdBytes.CheckLEQ( 0, srcx ); ArrayXdBytes.CheckLE( srcx + len, LEN( src ) );
  594. ArrayXdBytes.CopyMemoryToArrayPart( ADDRESSOF( src[srcx] ), dest, len, ArrayXdBytes.Index1( destx ),
  595. ArrayXdBytes.Index1( len ) );
  596. END CopyArrayToVec;
  597. PROCEDURE CopyVecToArray*( src: Array; VAR dest: ARRAY OF Value; srcx, destx, len: Index );
  598. BEGIN
  599. IF src.dim # 1 THEN HALT( 1005 ) END;
  600. ArrayXdBytes.CheckLEQ( 0, destx ); ArrayXdBytes.CheckLE( destx + len, LEN( dest ) );
  601. ArrayXdBytes.CopyArrayPartToMemory( src, ADDRESSOF( dest[destx] ), ArrayXdBytes.Index1( srcx ),
  602. ArrayXdBytes.Index1( len ), len );
  603. END CopyVecToArray;
  604. PROCEDURE CopyArrayToMtx*( VAR src: ARRAY OF ARRAY OF Value; dest: Array; srcx, srcy, destx, desty, lenx, leny: Index );
  605. VAR srcmem: ArrayXdBytes.ArrayMemoryStructure;
  606. BEGIN
  607. IF dest.dim # 2 THEN HALT( 1005 ) END;
  608. srcmem :=
  609. ArrayXdBytes.MakeMemoryStructure( 2, ArrayXdBytes.Index2( 0, 0 ), ArrayXdBytes.Index2( LEN( src, 1 ), LEN( src, 0 ) ),
  610. SIZEOF( Value ), ADDRESSOF( src[0, 0] ) );
  611. ArrayXdBytes.CopyArrayPartToArrayPart( srcmem, dest, ArrayXdBytes.Index2( srcx, srcy ),
  612. ArrayXdBytes.Index2( lenx, leny ), ArrayXdBytes.Index2( destx, desty ),
  613. ArrayXdBytes.Index2( lenx, leny ) );
  614. END CopyArrayToMtx;
  615. PROCEDURE CopyMtxToArray*( src: Array; VAR dest: ARRAY OF ARRAY OF Value; srcx, srcy, destx, desty, lenx, leny: Index );
  616. VAR destmem: ArrayXdBytes.ArrayMemoryStructure;
  617. BEGIN
  618. IF src.dim # 2 THEN HALT( 1005 ) END;
  619. destmem :=
  620. ArrayXdBytes.MakeMemoryStructure( 2, ArrayXdBytes.Index2( 0, 0 ), ArrayXdBytes.Index2( LEN( dest, 1 ), LEN( dest, 0 ) ),
  621. SIZEOF( Value ), ADDRESSOF( dest[0, 0] ) );
  622. ArrayXdBytes.CopyArrayPartToArrayPart( src, destmem, ArrayXdBytes.Index2( srcx, srcy ),
  623. ArrayXdBytes.Index2( lenx, leny ), ArrayXdBytes.Index2( destx, desty ),
  624. ArrayXdBytes.Index2( lenx, leny ) );
  625. END CopyMtxToArray;
  626. PROCEDURE CopyArrayToCube*( VAR src: ARRAY OF ARRAY OF ARRAY OF Value; dest: Array;
  627. srcx, srcy, srcz, destx, desty, destz, lenx, leny, lenz: Index );
  628. VAR srcmem: ArrayXdBytes.ArrayMemoryStructure;
  629. BEGIN
  630. IF dest.dim # 3 THEN HALT( 1005 ) END;
  631. srcmem :=
  632. ArrayXdBytes.MakeMemoryStructure( 3, ArrayXdBytes.Index3( 0, 0, 0 ),
  633. ArrayXdBytes.Index3( LEN( src, 2 ), LEN( src, 1 ), LEN( src, 0 ) ), SIZEOF( Value ),
  634. ADDRESSOF( src[0, 0, 0] ) );
  635. ArrayXdBytes.CopyArrayPartToArrayPart( srcmem, dest, ArrayXdBytes.Index3( srcx, srcy, srcz ),
  636. ArrayXdBytes.Index3( lenx, leny, lenz ),
  637. ArrayXdBytes.Index3( destx, desty, destz ),
  638. ArrayXdBytes.Index3( lenx, leny, lenz ) );
  639. END CopyArrayToCube;
  640. PROCEDURE CopyCubeToArray*( src: Array; VAR dest: ARRAY OF ARRAY OF ARRAY OF Value;
  641. srcx, srcy, srcz, destx, desty, destz, lenx, leny, lenz: Index );
  642. VAR destmem: ArrayXdBytes.ArrayMemoryStructure;
  643. BEGIN
  644. IF src.dim # 3 THEN HALT( 1005 ) END;
  645. destmem :=
  646. ArrayXdBytes.MakeMemoryStructure( 3, ArrayXdBytes.Index3( 0, 0, 0 ),
  647. ArrayXdBytes.Index3( LEN( dest, 2 ), LEN( dest, 1 ), LEN( dest, 0 ) ), SIZEOF( Value ),
  648. ADDRESSOF( dest[0, 0, 0] ) );
  649. ArrayXdBytes.CopyArrayPartToArrayPart( src, destmem, ArrayXdBytes.Index3( srcx, srcy, srcz ),
  650. ArrayXdBytes.Index3( lenx, leny, lenz ),
  651. ArrayXdBytes.Index3( destx, desty, destz ),
  652. ArrayXdBytes.Index3( lenx, leny, lenz ) );
  653. END CopyCubeToArray;
  654. PROCEDURE CopyArrayToHCube*( VAR src: ARRAY OF ARRAY OF ARRAY OF ARRAY OF Value; dest: Array;
  655. srcx, srcy, srcz, srct, destx, desty, destz, destt, lenx, leny, lenz, lent: Index );
  656. VAR srcmem: ArrayXdBytes.ArrayMemoryStructure;
  657. BEGIN
  658. IF dest.dim # 4 THEN HALT( 1005 ) END;
  659. srcmem :=
  660. ArrayXdBytes.MakeMemoryStructure( 4, ArrayXdBytes.Index4( 0, 0, 0, 0 ),
  661. ArrayXdBytes.Index4( LEN( src, 3 ), LEN( src, 2 ), LEN( src, 1 ), LEN( src, 0 ) ), SIZEOF( Value ),
  662. ADDRESSOF( src[0, 0, 0] ) );
  663. ArrayXdBytes.CopyArrayPartToArrayPart( srcmem, dest, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ),
  664. ArrayXdBytes.Index4( lenx, leny, lenz, lent ),
  665. ArrayXdBytes.Index4( destx, desty, destz, destt ),
  666. ArrayXdBytes.Index4( lenx, leny, lenz, lent ) );
  667. END CopyArrayToHCube;
  668. PROCEDURE CopyHCubeToArray*( src: Array; VAR dest: ARRAY OF ARRAY OF ARRAY OF ARRAY OF Value;
  669. srcx, srcy, srcz, srct, destx, desty, destz, destt, lenx, leny, lenz, lent: Index );
  670. VAR destmem: ArrayXdBytes.ArrayMemoryStructure;
  671. BEGIN
  672. IF src.dim # 4 THEN HALT( 1005 ) END;
  673. destmem :=
  674. ArrayXdBytes.MakeMemoryStructure( 4, ArrayXdBytes.Index4( 0, 0, 0, 0 ),
  675. ArrayXdBytes.Index4( LEN( dest, 3 ), LEN( dest, 2 ), LEN( dest, 1 ), LEN( dest, 0 ) ), SIZEOF( Value ),
  676. ADDRESSOF( dest[0, 0, 0] ) );
  677. ArrayXdBytes.CopyArrayPartToArrayPart( src, destmem, ArrayXdBytes.Index4( srcx, srcy, srcz, srct ),
  678. ArrayXdBytes.Index4( lenx, leny, lenz, lent ),
  679. ArrayXdBytes.Index4( destx, desty, destz, destt ),
  680. ArrayXdBytes.Index4( lenx, leny, lenz, lent ) );
  681. END CopyHCubeToArray;
  682. PROCEDURE CopyArrayToArrayPartB*( src: Array; dest: ArrayXdBytes.ArrayMemoryStructure; boundaryCondition: SHORTINT;
  683. srcpos, srclen, destpos, destlen: ArrayXdBytes.IndexArray );
  684. VAR temp: ArrayXdBytes.ArrayMemoryStructure;
  685. spos, dpos, last, borigin, blen, srcposcut, srclencut, destoffset: ArrayXdBytes.IndexArray; i, dim: LONGINT;
  686. val: Value; temp2: Array; enumB: ArrayXdBytes.BoundaryEnum;
  687. Get: PROCEDURE {DELEGATE} ( x: ARRAY OF Index;
  688. dim: Index ): Value;
  689. noinbound: BOOLEAN; v: Value;
  690. (* for debugging
  691. PROCEDURE OutIndex( idx: ArrayXdBytes.IndexArray; name: ARRAY OF CHAR );
  692. VAR i: LONGINT;
  693. BEGIN
  694. dbgOut.String( name );
  695. FOR i := 0 TO LEN( idx ) - 1 DO dbgOut.Int( idx[i], 1 ); dbgOut.String( "," ); END;
  696. dbgOut.Ln;
  697. END OutIndex;
  698. *)
  699. PROCEDURE Same( a, b: ArrayXdBytes.IndexArray ): BOOLEAN;
  700. BEGIN
  701. IF LEN( a ) # LEN( b ) THEN RETURN FALSE END;
  702. FOR i := 0 TO LEN( a ) - 1 DO
  703. IF a[i] # b[i] THEN RETURN FALSE END;
  704. END;
  705. RETURN TRUE;
  706. END Same;
  707. BEGIN
  708. dim := src.dim;
  709. IF boundaryCondition = StrictBoundaryC THEN
  710. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, srcpos, srclen, destpos, destlen ); (* checks are done there *)
  711. ELSE
  712. srcposcut := ArrayXdBytes.IndexCpy( srcpos ); srclencut := ArrayXdBytes.IndexCpy( srclen );
  713. NEW( enumB, src, srcposcut, srclencut );
  714. IF (Same( srcposcut, srcpos )) & (Same( srclencut, srclen )) THEN (* no boundaries *)
  715. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, srcpos, srclen, destpos, destlen ); RETURN;
  716. ELSE
  717. CASE boundaryCondition OF
  718. PeriodicBoundaryC:
  719. Get := src.GetXBPeriodic;
  720. | SymmetricOnBoundaryC:
  721. Get := src.GetXBSymmetricOnB;
  722. | SymmetricOffBoundaryC:
  723. Get := src.GetXBSymmetricOffB;
  724. | AntisymmetricOnBoundaryC:
  725. Get := src.GetXBAntisymmetricOnB;
  726. | AntisymmetricOffBoundaryC:
  727. Get := src.GetXBAntisymmetricOffB;
  728. | AbsorbingBoundaryC:
  729. ArrayXdBytes.FillArrayPart( dest, destpos, destlen, val ); (* fill with 0 first *)
  730. Get := NIL;
  731. END;
  732. NEW( destoffset, dim ); noinbound := FALSE;
  733. IF Same( srclen, destlen ) THEN (* same geometry, direct copy to boundary rects can be used*)
  734. FOR i := 0 TO dim - 1 DO
  735. destoffset[i] := destpos[i] + srcposcut[i] - srcpos[i];
  736. IF srclencut[i] = 0 THEN noinbound := TRUE END;
  737. END;
  738. IF ~noinbound THEN
  739. ArrayXdBytes.CopyArrayPartToArrayPart( src, dest, srcposcut, srclencut, destoffset, srclencut );
  740. END;
  741. FOR i := 0 TO dim - 1 DO destoffset[i] := destpos[i] - srcpos[i]; END;
  742. temp := dest;
  743. ELSE (* not the same geometry, direct copy using rectangles cannot be used *)
  744. NEW( temp2, srcpos, srclen ); temp := temp2;
  745. FOR i := 0 TO dim - 1 DO
  746. destoffset[i] := 0;
  747. IF srclencut[i] = 0 THEN noinbound := TRUE END;
  748. END;
  749. IF ~noinbound THEN
  750. ArrayXdBytes.CopyArrayPartToArrayPart( src, temp, srcposcut, srclencut, srcposcut, srclencut );
  751. END;
  752. END;
  753. IF Get # NIL THEN
  754. NEW( spos, dim ); NEW( dpos, dim ); NEW( last, dim );
  755. WHILE (enumB.Get( borigin, blen )) DO (* enumeration of rects describing the region out of range *)
  756. FOR i := 0 TO dim - 1 DO spos[i] := borigin[i]; last[i] := spos[i] + blen[i]; dpos[i] := spos[i] + destoffset[i] END;
  757. REPEAT
  758. v := Get( spos^, dim );
  759. SYSTEM.MOVE( ADDRESSOF( v ), ArrayXdBytes.AdrX( temp, dpos^, dim ), SIZEOF( Value ) ); (* optimize adress handling of destination, compute here ! *)
  760. (*temp.SetX( dpos^, dim, Get( spos^, dim ) );*) i := 0; INC( spos[i] ); INC( dpos[i] );
  761. WHILE (i < dim - 1) & (spos[i] = last[i]) DO
  762. spos[i] := borigin[i]; dpos[i] := destoffset[i] + borigin[i]; INC( i ); INC( spos[i] ); INC( dpos[i] );
  763. END;
  764. UNTIL spos[i] = last[i];
  765. END;
  766. END;
  767. IF temp # dest THEN ArrayXdBytes.CopyArrayPartToArrayPart( temp, dest, srcpos, srclen, destpos, destlen );
  768. END;
  769. END;
  770. END;
  771. END CopyArrayToArrayPartB;
  772. OPERATOR ":="*( VAR l: Array1; r: Array );
  773. BEGIN
  774. IF r = NIL THEN l := NIL; RETURN END;
  775. ArrayXdBytes.CheckEQ( 1, r.dim ); (*ArrayXdBytes.CheckEQ( r.origin[0], 0 ); *)
  776. IF (l = NIL ) OR (LEN( l ) # r.len[0]) THEN NEW( l, r.len[0] ); END;
  777. ArrayXdBytes.CopyArrayToMemory( r, ADDRESSOF( l[0] ), LEN( l, 0 ) );
  778. END ":=";
  779. OPERATOR ":="*( VAR l: Array2; r: Array );
  780. BEGIN
  781. IF r = NIL THEN l := NIL; RETURN END;
  782. ArrayXdBytes.CheckEQ( 2, r.dim ); (*ArrayXdBytes.CheckEQ( r.origin[0], 0 ); ArrayXdBytes.CheckEQ( r.origin[1], 0 ); *)
  783. IF (l = NIL ) OR (LEN( l, 1 ) # r.len[0]) OR (LEN( l, 0 ) # r.len[1]) THEN NEW( l, r.len[1], r.len[0] ); END;
  784. ArrayXdBytes.CopyArrayToMemory( r, ADDRESSOF( l[0, 0] ), LEN( l, 0 ) * LEN( l, 1 ) );
  785. END ":=";
  786. OPERATOR ":="*( VAR l: Array3; r: Array );
  787. BEGIN
  788. IF r = NIL THEN l := NIL; RETURN END;
  789. ArrayXdBytes.CheckEQ( 3, r.dim ); (*ArrayXdBytes.CheckEQ( r.origin[0], 0 ); ArrayXdBytes.CheckEQ( r.origin[1], 0 ); ArrayXdBytes.CheckEQ( r.origin[2], 0 ); *)
  790. IF (l = NIL ) OR (LEN( l, 2 ) # r.len[0]) OR (LEN( l, 1 ) # r.len[1]) OR (LEN( l, 0 ) # r.len[2]) THEN NEW( l, r.len[2], r.len[1], r.len[0] ); END;
  791. ArrayXdBytes.CopyArrayToMemory( r, ADDRESSOF( l[0, 0, 0] ), LEN( l, 0 ) * LEN( l, 1 ) * LEN( l, 2 ) );
  792. END ":=";
  793. (*
  794. OPERATOR ":="( VAR l: Array4; r: Array );
  795. BEGIN
  796. IF r = NIL THEN l := NIL; RETURN END;
  797. ArrayXdBytes.CheckEQ( 4, r.dim ); (*ArrayXdBytes.CheckEQ( r.origin[0], 0 ); ArrayXdBytes.CheckEQ( r.origin[1], 0 ); ArrayXdBytes.CheckEQ( r.origin[2], 0 );
  798. ArrayXdBytes.CheckEQ( r.origin[3], 0 ); *)
  799. IF (l = NIL ) OR (LEN( l, 3 ) # r.len[0]) OR (LEN( l, 2 ) # r.len[1]) OR (LEN( l, 1 ) # r.len[2]) OR (LEN( l, 0 ) # r.len[3]) THEN
  800. NEW( l, r.len[3], r.len[2], r.len[1], r.len[0] );
  801. END;
  802. ArrayXdBytes.CopyArrayToMemory( r, ADDRESSOF( l[0, 0, 0, 0] ), LEN( l, 0 ) * LEN( l, 1 ) * LEN( l, 2 ) * LEN( l, 3 ) );
  803. END ":=";
  804. *)
  805. PROCEDURE Fill*( l: Array; r: Value );
  806. BEGIN
  807. Array1d.Fill( r, l.data^, 0, LEN( l.data ) );
  808. END Fill;
  809. (*
  810. OPERATOR ":="*( VAR l: Array; r: Value );
  811. BEGIN
  812. IF l # NIL THEN Fill( l, r ) END;
  813. END ":=";
  814. OPERATOR ":="*( VAR l: Array; r: IntValue );
  815. VAR r1: Value;
  816. BEGIN
  817. r1 := r; l := r1;
  818. END ":=";
  819. *)
  820. PROCEDURE Add*( l, r, res: Array );
  821. BEGIN
  822. ArrayXdBytes.CheckEqDimensions( l, r ); Array1d.AddAA( l.data^, r.data^, res.data^, 0, LEN( res.data ) );
  823. END Add;
  824. OPERATOR "+"*( l, r: Array ): Array;
  825. VAR res: Array;
  826. BEGIN
  827. NEW( res, l.origin, l.len ); Add( l, r, res ); RETURN res;
  828. END "+";
  829. PROCEDURE Sub*( l, r, res: Array );
  830. BEGIN
  831. ArrayXdBytes.CheckEqDimensions( l, r ); Array1d.SubtractAA( l.data^, r.data^, res.data^, 0, LEN( res.data ) );
  832. END Sub;
  833. OPERATOR "-"*( l, r: Array ): Array;
  834. VAR res: Array;
  835. BEGIN
  836. NEW( res, l.origin, l.len ); Sub( l, r, res ); RETURN res;
  837. END "-";
  838. PROCEDURE Mul*( l, r, res: Array );
  839. BEGIN
  840. ArrayXdBytes.CheckEqDimensions( l, r ); Array1d.MultAA( l.data^, r.data^, res.data^, 0, LEN( res.data ) );
  841. END Mul;
  842. PROCEDURE Div*( l, r, res: Array );
  843. BEGIN
  844. ArrayXdBytes.CheckEqDimensions( l, r ); Array1d.DivAA( l.data^, r.data^, res.data^, 0, LEN( res.data ) );
  845. END Div;
  846. (*
  847. PROCEDURE Mod*( l, r, res: Array );
  848. BEGIN
  849. ArrayXdBytes.CheckEqDimensions( l, r ); Array1d.ModAA( l.data^, r.data^, res.data^, 0, LEN( res.data ) );
  850. END Mod;
  851. *)
  852. PROCEDURE AddAV*( l: Array; r: Value; res: Array );
  853. BEGIN
  854. Array1d.AddAV( l.data^, r, res.data^, 0, LEN( res.data ) );
  855. END AddAV;
  856. (*
  857. OPERATOR "+"( l: Array; r: Value ): Array;
  858. VAR res: Array;
  859. BEGIN
  860. NEW( res, l.origin^, l.len^ ); AddAV( l, r, res ); RETURN res;
  861. END "+";
  862. *)
  863. OPERATOR "+"( l: Array; r: IntValue ): Array;
  864. VAR res: Array; r1: Value;
  865. BEGIN
  866. NEW( res, l.origin, l.len ); r1 := r; AddAV( l, r1, res ); RETURN res;
  867. END "+";
  868. (*
  869. OPERATOR "+"( l: Value; r: Array ): Array;
  870. BEGIN
  871. RETURN r + l
  872. END "+";
  873. *)
  874. OPERATOR "+"( l: IntValue; r: Array ): Array;
  875. BEGIN
  876. RETURN r + l
  877. END "+";
  878. PROCEDURE MulAV*( l: Array; r: Value; res: Array );
  879. BEGIN
  880. Array1d.MultAV( l.data^, r, res.data^, 0, LEN( res.data ) );
  881. END MulAV;
  882. (*
  883. OPERATOR "*"( l: Array; r: Value ): Array;
  884. VAR res: Array;
  885. BEGIN
  886. NEW( res, l.origin^, l.len^ ); MulAV( l, r, res ); RETURN res;
  887. END "*";
  888. *)
  889. (*
  890. OPERATOR "*"( l: Value; r: Array ): Array;
  891. BEGIN
  892. RETURN r * l
  893. END "*";
  894. *)
  895. OPERATOR "*"( l: Array; r: IntValue ): Array;
  896. VAR res: Array; r1: Value;
  897. BEGIN
  898. NEW( res, l.origin, l.len ); r1 := r; MulAV( l, r1, res ); RETURN res;
  899. END "*";
  900. OPERATOR "*"( l: IntValue; r: Array ): Array;
  901. BEGIN
  902. RETURN r * l
  903. END "*";
  904. PROCEDURE DivAV*( l: Array; r: Value; res: Array );
  905. BEGIN
  906. Array1d.DivAV( l.data^, r, res.data^, 0, LEN( res.data ) );
  907. END DivAV;
  908. (*
  909. OPERATOR "/"( l: Array; r: Value ): Array;
  910. VAR res: Array;
  911. BEGIN
  912. NEW( res, l.origin^, l.len^ ); DivAV( l, r, res ); RETURN res;
  913. END "/";
  914. OPERATOR "/"( l: Array; r: IntValue ): Array;
  915. VAR res: Array; r1: Value;
  916. BEGIN
  917. NEW( res, l.origin^, l.len^ ); r1 := r; DivAV( l, r1, res ); RETURN res;
  918. END "/";
  919. *)
  920. PROCEDURE DivVA*( l: Value; r: Array; res: Array );
  921. BEGIN
  922. Array1d.DivVA( l, r.data^, res.data^, 0, LEN( res.data ) );
  923. END DivVA;
  924. (*
  925. OPERATOR "/"( l: Value; r: Array ): Array;
  926. VAR res: Array;
  927. BEGIN
  928. NEW( res, r.origin^, r.len^ ); DivVA( l, r, res ); RETURN res;
  929. END "/";
  930. *)
  931. OPERATOR "/"( l: IntValue; r: Array ): Array;
  932. VAR res: Array; l1: Value;
  933. BEGIN
  934. NEW( res, r.origin, r.len ); l1 := l; DivVA( l1, r, res ); RETURN res;
  935. END "/";
  936. (*
  937. PROCEDURE ModAV*( l: Array; r: Value; res: Array );
  938. BEGIN
  939. Array1d.ModAV( l.data^, r, res.data^, 0, LEN( res.data ) );
  940. END ModAV;
  941. OPERATOR "MOD"( l: Array; r: Value ): Array;
  942. VAR res: Array;
  943. BEGIN
  944. NEW( res, l.origin^, l.len^ ); ModAV( l, r, res ); RETURN res;
  945. END "MOD";
  946. PROCEDURE ModVA*( l: Value; r: Array; res: Array );
  947. BEGIN
  948. Array1d.ModVA( l, r.data^, res.data^, 0, LEN( res.data ) );
  949. END ModVA;
  950. OPERATOR "MOD"( l: Value; r: Array ): Array;
  951. VAR res: Array;
  952. BEGIN
  953. NEW( res, r.origin^, r.len^ ); ModVA( l, r, res ); RETURN res;
  954. END "MOD";
  955. *)
  956. PROCEDURE SubAV*( l: Array; r: Value; res: Array );
  957. BEGIN
  958. Array1d.SubtractAV( l.data^, r, res.data^, 0, LEN( res.data ) );
  959. END SubAV;
  960. (*
  961. OPERATOR "-"( l: Array; r: Value ): Array;
  962. VAR res: Array;
  963. BEGIN
  964. NEW( res, l.origin^, l.len^ ); SubAV( l, r, res ); RETURN res;
  965. END "-";
  966. OPERATOR "-"( l: Array; r: IntValue ): Array;
  967. VAR res: Array; r1: Value;
  968. BEGIN
  969. NEW( res, l.origin^, l.len^ ); r1 := r; SubAV( l, r1, res ); RETURN res;
  970. END "-";
  971. *)
  972. PROCEDURE SubVA*( l: Value; r: Array; res: Array );
  973. BEGIN
  974. Array1d.SubtractVA( l, r.data^, res.data^, 0, LEN( res.data ) );
  975. END SubVA;
  976. OPERATOR "-"*( l: Value; r: Array ): Array;
  977. VAR res: Array;
  978. BEGIN
  979. NEW( res, r.origin, r.len ); SubVA( l, r, res ); RETURN res;
  980. END "-";
  981. OPERATOR "-"*( l: IntValue; r: Array ): Array;
  982. VAR res: Array; l1: Value;
  983. BEGIN
  984. NEW( res, r.origin, r.len ); l1 := l; SubVA( l1, r, res ); RETURN res;
  985. END "-";
  986. (* The procedures needed to register an arbitrary Array so that its instances can be made persistent. *)
  987. PROCEDURE LoadArray( R: DataIO.Reader; VAR obj: OBJECT );
  988. VAR a: Array; version: SHORTINT; ver: NbrInt.Integer;
  989. BEGIN
  990. R.RawSInt( version );
  991. IF version = -1 THEN
  992. obj := NIL (* Version tag is -1 for NIL. *)
  993. ELSE
  994. IF version = VERSION THEN NEW( a, ArrayXdBytes.Array1( 0 ), ArrayXdBytes.Array1( 0 ) ); a.LoadXd( R ); obj := a
  995. ELSE (* Encountered an unknown version number. *)
  996. ver := version; DataErrors.IntError( ver, "Alien version number encountered." ); HALT( 1000 )
  997. END
  998. END
  999. END LoadArray;
  1000. PROCEDURE StoreArray( W: DataIO.Writer; obj: OBJECT );
  1001. VAR a: Array;
  1002. BEGIN
  1003. IF obj = NIL THEN W.RawSInt( -1 ) ELSE W.RawSInt( VERSION ); a := obj( Array ); a.StoreXd( W, TRUE ) END
  1004. END StoreArray;
  1005. PROCEDURE Register;
  1006. VAR a: Array;
  1007. BEGIN
  1008. NEW( a, ArrayXdBytes.Array1( 0 ), ArrayXdBytes.Array1( 0 ) ); DataIO.PlugIn( a, LoadArray, StoreArray )
  1009. END Register;
  1010. (** Load and Store are procedures for external use that read/write an instance of an arbitrary array from/to a file. *)
  1011. PROCEDURE Load*( R: DataIO.Reader; VAR obj: Array );
  1012. VAR ptr: OBJECT;
  1013. BEGIN
  1014. R.Object( ptr ); obj := ptr( Array )
  1015. END Load;
  1016. PROCEDURE Store*( W: DataIO.Writer; obj: Array );
  1017. BEGIN
  1018. W.Object( obj )
  1019. END Store;
  1020. BEGIN
  1021. Register
  1022. END ArrayXdRat.