Array1dInt.Mod 40 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118
  1. (* CAPO - Computational Analysis Platform for Oberon - by Alan Freed and Felix Friedrich. *)
  2. (* Version 1, Update 2 *)
  3. MODULE Array1dInt; (** AUTHOR "adf, fof"; PURPOSE "Basic operations on type ARRAY OF Integer"; *)
  4. (* Compile this module with index check disabled, index checks are performed globally for each loop! *)
  5. IMPORT SYSTEM, Array1dBytes, DataErrors, NbrInt, NbrInt64, NbrRe;
  6. TYPE
  7. Value* = NbrInt.Integer; LongerValue* = NbrInt64.Integer; ShorterValue* = INTEGER; RealValue* = NbrRe.Real;
  8. Array* = POINTER TO ARRAY OF Value;
  9. Index* = LONGINT;
  10. CONST
  11. sz = SIZEOF( Value );
  12. TYPE
  13. Map* = PROCEDURE {DELEGATE} ( VAR i: Value );
  14. (** fast access routines *)
  15. PROCEDURE Copy*( VAR x: ARRAY OF Value; VAR res: ARRAY OF Value; srcoffset, destoffset, len: Index );
  16. BEGIN
  17. Array1dBytes.RangeCheck( srcoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( destoffset, len, LEN( res ) );
  18. Array1dBytes.MoveB( ADDRESSOF( x[srcoffset] ), ADDRESSOF( res[destoffset] ), len * sz );
  19. END Copy;
  20. PROCEDURE CreateCopy*( VAR x: ARRAY OF Value ): Array;
  21. VAR a: Array;
  22. BEGIN
  23. NEW( a, LEN( x ) ); Copy( x, a^, 0, 0, LEN( x ) ); RETURN a;
  24. END CreateCopy;
  25. PROCEDURE CopyPat*( VAR x: ARRAY OF Value; VAR res: ARRAY OF Value;
  26. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  27. BEGIN
  28. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  29. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  30. Array1dBytes.MoveBPat( ADDRESSOF( x[srcoffset] ), ADDRESSOF( res[destoffset] ), srcstep * sz, deststep * sz,
  31. piecelen * sz, pieces );
  32. END CopyPat;
  33. PROCEDURE CreateCopyPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): Array;
  34. VAR a: Array;
  35. BEGIN
  36. (* range check done in copy pat *)
  37. NEW( a, piecelen * pieces ); CopyPat( x, a^, offset, step, 0, piecelen, piecelen, pieces ); RETURN a;
  38. END CreateCopyPat;
  39. PROCEDURE Fill*( x: Value; VAR res: ARRAY OF Value; offset, len: Index );
  40. (* fills in dyadic steps *)
  41. BEGIN
  42. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  43. Array1dBytes.Fill( ADDRESSOF( res[offset] ), x, len ); (* implicitly selects the right version of Fill in Array1dBytes *)
  44. END Fill;
  45. PROCEDURE FillPat*( x: Value; VAR res: ARRAY OF Value; offset, step, piecelen, pieces: Index );
  46. BEGIN
  47. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( res ) );
  48. Array1dBytes.FillPat( ADDRESSOF( res[offset] ), x, step, piecelen, pieces ); (* implicitly selects the right version of FillPat in Array1dBytes *)
  49. END FillPat;
  50. (** monadic operations *)
  51. PROCEDURE Negate*( VAR x: ARRAY OF Value; offset, len: Index );
  52. BEGIN
  53. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  54. INC( len, offset );
  55. WHILE (offset < len) DO x[offset] := -x[offset]; INC( offset ) END;
  56. END Negate;
  57. PROCEDURE NegatePat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index );
  58. VAR idx: Index;
  59. BEGIN
  60. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  61. WHILE (pieces > 0) DO
  62. idx := offset; INC( offset, piecelen );
  63. WHILE (idx < offset) DO x[idx] := -x[idx]; INC( idx ) END;
  64. INC( offset, step - piecelen ); DEC( pieces )
  65. END;
  66. END NegatePat;
  67. PROCEDURE Abs*( VAR x: ARRAY OF Value; offset, len: Index );
  68. BEGIN
  69. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  70. INC( len, offset );
  71. WHILE (offset < len) DO x[offset] := ABS( x[offset] ); INC( offset ) END;
  72. END Abs;
  73. PROCEDURE AbsPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index );
  74. VAR idx: Index;
  75. BEGIN
  76. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  77. WHILE (pieces > 0) DO
  78. idx := offset; INC( offset, piecelen );
  79. WHILE (idx < offset) DO x[idx] := ABS( x[idx] ); INC( idx ) END;
  80. INC( offset, step - piecelen ); DEC( pieces )
  81. END;
  82. END AbsPat;
  83. (* Array Array operations *)
  84. PROCEDURE AddAA*( VAR x, y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  85. BEGIN
  86. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  87. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  88. INC( len, offset );
  89. WHILE (offset < len) DO res[offset] := x[offset] + y[offset]; INC( offset ) END;
  90. END AddAA;
  91. PROCEDURE SubtractAA*( VAR x, y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  92. BEGIN
  93. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  94. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  95. INC( len, offset );
  96. WHILE (offset < len) DO res[offset] := x[offset] - y[offset]; INC( offset ) END;
  97. END SubtractAA;
  98. PROCEDURE MultAA*( VAR x, y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  99. BEGIN
  100. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  101. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  102. INC( len, offset );
  103. WHILE (offset < len) DO res[offset] := x[offset] * y[offset]; INC( offset ) END;
  104. END MultAA;
  105. PROCEDURE ScalarProduct*( VAR x, y: ARRAY OF Value; VAR res: Value; xoffset, yoffset, len: Index );
  106. BEGIN
  107. Array1dBytes.RangeCheck( xoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( yoffset, len, LEN( y ) );
  108. res := 0; INC( len, xoffset );
  109. WHILE (xoffset < len) DO res := res + x[xoffset] * y[yoffset]; INC( xoffset ); INC( yoffset ) END;
  110. END ScalarProduct;
  111. PROCEDURE ScalarProductPat*( VAR x, y: ARRAY OF Value; VAR res: Value;
  112. xoffset, yoffset, xstep, ystep, piecelen, pieces: Index );
  113. VAR xidx, yidx: LONGINT;
  114. BEGIN
  115. Array1dBytes.PatRangeCheck( xoffset, xstep, piecelen, pieces, LEN( x ) );
  116. Array1dBytes.PatRangeCheck( yoffset, ystep, piecelen, pieces, LEN( y ) );
  117. res := 0; xidx := xoffset; yidx := yoffset;
  118. WHILE (pieces > 0) DO
  119. INC( xoffset, piecelen ); INC( yoffset, piecelen );
  120. WHILE (xidx < xoffset) DO res := res + x[xidx] * y[yidx]; INC( xidx ); INC( yidx ); END;
  121. INC( xoffset, xstep - piecelen ); INC( yoffset, ystep - piecelen ); DEC( pieces );
  122. END;
  123. END ScalarProductPat;
  124. PROCEDURE ModAA*( VAR x, y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  125. (** no checks for y[..] # 0, programmers responsibility *)
  126. BEGIN
  127. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  128. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  129. INC( len, offset );
  130. WHILE (offset < len) DO res[offset] := x[offset] MOD y[offset]; INC( offset ) END;
  131. END ModAA;
  132. PROCEDURE DivAA*( VAR x, y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  133. (** no checks for y[..] # 0, programmers responsibility *)
  134. BEGIN
  135. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  136. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  137. INC( len, offset );
  138. WHILE (offset < len) DO res[offset] := x[offset] DIV y[offset]; INC( offset ) END;
  139. END DivAA;
  140. PROCEDURE EqualsAA*( VAR x, y: ARRAY OF Value; offset, len: Index ): BOOLEAN;
  141. BEGIN
  142. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( y ) );
  143. INC( len, offset );
  144. WHILE (offset < len) DO
  145. IF x[offset] # y[offset] THEN RETURN FALSE END;
  146. INC( offset )
  147. END;
  148. RETURN TRUE;
  149. END EqualsAA;
  150. (** Array - Value operations *)
  151. PROCEDURE AddAV*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value; offset, len: Index );
  152. BEGIN
  153. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  154. INC( len, offset );
  155. WHILE (offset < len) DO res[offset] := x[offset] + y; INC( offset ) END;
  156. END AddAV;
  157. PROCEDURE AddAVPat*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value;
  158. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  159. VAR si, di, end, endpiece: Index;
  160. BEGIN
  161. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  162. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  163. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  164. deststep := deststep - piecelen;
  165. WHILE si < end DO
  166. endpiece := si + piecelen;
  167. WHILE si < endpiece DO res[di] := x[si] + y; INC( si ); INC( di ); END;
  168. INC( si, srcstep ); INC( di, deststep );
  169. END;
  170. END AddAVPat;
  171. PROCEDURE SubtractAV*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value; offset, len: Index );
  172. BEGIN
  173. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  174. INC( len, offset );
  175. WHILE (offset < len) DO res[offset] := x[offset] - y; INC( offset ) END;
  176. END SubtractAV;
  177. PROCEDURE SubtractAVPat*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value;
  178. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  179. VAR si, di, end, endpiece: Index;
  180. BEGIN
  181. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  182. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  183. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  184. deststep := deststep - piecelen;
  185. WHILE si < end DO
  186. endpiece := si + piecelen;
  187. WHILE si < endpiece DO res[di] := x[si] - y; INC( si ); INC( di ); END;
  188. INC( si, srcstep ); INC( di, deststep );
  189. END;
  190. END SubtractAVPat;
  191. PROCEDURE SubtractVA*( VAR x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  192. BEGIN
  193. Array1dBytes.RangeCheck( offset, len, LEN( y ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  194. INC( len, offset );
  195. WHILE (offset < len) DO res[offset] := x - y[offset]; INC( offset ) END;
  196. END SubtractVA;
  197. PROCEDURE SubtractVAPat*( x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value;
  198. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  199. VAR si, di, end, endpiece: Index;
  200. BEGIN
  201. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( y ) );
  202. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  203. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  204. deststep := deststep - piecelen;
  205. WHILE si < end DO
  206. endpiece := si + piecelen;
  207. WHILE si < endpiece DO res[di] := y[si] - x; INC( si ); INC( di ); END;
  208. INC( si, srcstep ); INC( di, deststep );
  209. END;
  210. END SubtractVAPat;
  211. PROCEDURE MultAV*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value; offset, len: Index );
  212. BEGIN
  213. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  214. INC( len, offset );
  215. WHILE (offset < len) DO res[offset] := x[offset] * y; INC( offset ) END;
  216. END MultAV;
  217. PROCEDURE MultAVPat*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value;
  218. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  219. VAR si, di, end, endpiece: Index;
  220. BEGIN
  221. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  222. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  223. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  224. deststep := deststep - piecelen;
  225. WHILE si < end DO
  226. endpiece := si + piecelen;
  227. WHILE si < endpiece DO res[di] := x[si] * y; INC( si ); INC( di ); END;
  228. INC( si, srcstep ); INC( di, deststep );
  229. END;
  230. END MultAVPat;
  231. PROCEDURE DivAV*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value; offset, len: Index );
  232. BEGIN
  233. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  234. INC( len, offset );
  235. WHILE (offset < len) DO res[offset] := x[offset] DIV y; INC( offset ) END;
  236. END DivAV;
  237. PROCEDURE DivAVPat*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value;
  238. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  239. VAR si, di, end, endpiece: Index;
  240. BEGIN
  241. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  242. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  243. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  244. deststep := deststep - piecelen;
  245. WHILE si < end DO
  246. endpiece := si + piecelen;
  247. WHILE si < endpiece DO res[di] := x[si] DIV y; INC( si ); INC( di ); END;
  248. INC( si, srcstep ); INC( di, deststep );
  249. END;
  250. END DivAVPat;
  251. PROCEDURE DivVA*( x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  252. BEGIN
  253. Array1dBytes.RangeCheck( offset, len, LEN( y ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  254. INC( len, offset );
  255. WHILE (offset < len) DO res[offset] := x DIV y[offset]; INC( offset ) END;
  256. END DivVA;
  257. PROCEDURE DivVAPat*( x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value;
  258. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  259. VAR si, di, end, endpiece: Index;
  260. BEGIN
  261. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( y ) );
  262. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  263. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  264. deststep := deststep - piecelen;
  265. WHILE si < end DO
  266. endpiece := si + piecelen;
  267. WHILE si < endpiece DO res[di] := x DIV y[si]; INC( si ); INC( di ); END;
  268. INC( si, srcstep ); INC( di, deststep );
  269. END;
  270. END DivVAPat;
  271. PROCEDURE ModAV*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value; offset, len: Index );
  272. BEGIN
  273. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  274. INC( len, offset );
  275. WHILE (offset < len) DO res[offset] := x[offset] MOD y; INC( offset ) END;
  276. END ModAV;
  277. PROCEDURE ModAVPat*( VAR x: ARRAY OF Value; y: Value; VAR res: ARRAY OF Value;
  278. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  279. VAR si, di, end, endpiece: Index;
  280. BEGIN
  281. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( x ) );
  282. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  283. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  284. deststep := deststep - piecelen;
  285. WHILE si < end DO
  286. endpiece := si + piecelen;
  287. WHILE si < endpiece DO res[di] := x[si] MOD y; INC( si ); INC( di ); END;
  288. INC( si, srcstep ); INC( di, deststep );
  289. END;
  290. END ModAVPat;
  291. PROCEDURE ModVA*( x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value; offset, len: Index );
  292. BEGIN
  293. Array1dBytes.RangeCheck( offset, len, LEN( y ) ); Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  294. INC( len, offset );
  295. WHILE (offset < len) DO res[offset] := x MOD y[offset]; INC( offset ) END;
  296. END ModVA;
  297. PROCEDURE ModVAPat*( x: Value; VAR y: ARRAY OF Value; VAR res: ARRAY OF Value;
  298. srcoffset, srcstep, destoffset, deststep, piecelen, pieces: Index );
  299. VAR si, di, end, endpiece: Index;
  300. BEGIN
  301. Array1dBytes.PatRangeCheck( srcoffset, srcstep, piecelen, pieces, LEN( y ) );
  302. Array1dBytes.PatRangeCheck( destoffset, deststep, piecelen, pieces, LEN( res ) );
  303. si := srcoffset; di := destoffset; end := srcoffset + srcstep * pieces; srcstep := srcstep - piecelen;
  304. deststep := deststep - piecelen;
  305. WHILE si < end DO
  306. endpiece := si + piecelen;
  307. WHILE si < endpiece DO res[di] := x MOD y[si]; INC( si ); INC( di ); END;
  308. INC( si, srcstep ); INC( di, deststep );
  309. END;
  310. END ModVAPat;
  311. (** mappings *)
  312. PROCEDURE ApplyMap*( map: Map; VAR res: ARRAY OF Value; offset, len: Index );
  313. BEGIN
  314. Array1dBytes.RangeCheck( offset, len, LEN( res ) );
  315. INC( len, offset );
  316. WHILE (offset < len) DO map( res[offset] ); INC( offset ); END;
  317. END ApplyMap;
  318. PROCEDURE ApplyMapPat*( map: Map; VAR res: ARRAY OF Value; offset, step, piecelen, pieces: Index );
  319. VAR i, end, endpiece: Index;
  320. BEGIN
  321. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( res ) );
  322. i := offset; end := offset + step * pieces; step := step - piecelen;
  323. WHILE i < end DO
  324. endpiece := i + piecelen;
  325. WHILE i < endpiece DO map( res[i] ); INC( i ); END;
  326. INC( i, step );
  327. END;
  328. END ApplyMapPat;
  329. (** characteristics *)
  330. PROCEDURE Min*( VAR x: ARRAY OF Value; offset, len: Index; VAR minpos: Index ): Value;
  331. VAR min: Value;
  332. BEGIN
  333. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  334. min := MAX( Value ); minpos := -1; INC( len, offset );
  335. WHILE offset < len DO
  336. IF x[offset] < min THEN min := x[offset]; minpos := offset END;
  337. INC( offset )
  338. END;
  339. RETURN min;
  340. END Min;
  341. PROCEDURE Max*( VAR x: ARRAY OF Value; offset, len: Index; VAR maxpos: Index ): Value;
  342. VAR max: Value;
  343. BEGIN
  344. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  345. max := MIN( Value ); maxpos := -1; INC( len, offset );
  346. WHILE offset < len DO
  347. IF x[offset] > max THEN max := x[offset]; maxpos := offset END;
  348. INC( offset )
  349. END;
  350. RETURN max;
  351. END Max;
  352. PROCEDURE MinMax*( VAR x: ARRAY OF Value; offset, len: Index; VAR min, max: Value; minpos, maxpos: Index );
  353. BEGIN
  354. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  355. max := x[offset]; maxpos := offset; min := x[offset]; minpos := offset; INC( len, offset ); INC( offset );
  356. WHILE offset < len DO
  357. IF x[offset] > max THEN max := x[offset]; maxpos := offset
  358. ELSIF x[offset] < min THEN min := x[offset]; minpos := offset
  359. END;
  360. INC( offset )
  361. END;
  362. END MinMax;
  363. PROCEDURE MinMaxPat*( map: Map; VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index; VAR min, max: Value;
  364. minpos, maxpos: Index );
  365. VAR i, end, endpiece: Index;
  366. BEGIN
  367. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  368. i := offset; end := offset + step * pieces; step := step - piecelen; max := x[offset]; maxpos := offset; min := x[offset];
  369. minpos := offset;
  370. WHILE i < end DO
  371. endpiece := i + piecelen;
  372. WHILE i < endpiece DO
  373. IF x[i] > max THEN max := x[i]; maxpos := offset
  374. ELSIF x[i] < min THEN min := x[i]; minpos := offset
  375. END;
  376. INC( i );
  377. END;
  378. INC( i, step );
  379. END;
  380. END MinMaxPat;
  381. PROCEDURE MeanSsq*( VAR x: ARRAY OF Value; offset, len: Index; VAR mean, ssq: RealValue );
  382. (* mean and ssq distance of mean by provisional means algorithm *)
  383. VAR d: RealValue; val: Value; i: Index;
  384. BEGIN
  385. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  386. mean := 0; ssq := 0; i := offset; INC( len, offset );
  387. WHILE i < len DO val := x[i]; d := val - mean; mean := mean + d / (i + 1 - offset); ssq := ssq + d * (val - mean); INC( i ) END
  388. END MeanSsq;
  389. PROCEDURE kSmallestModify*( k: Index; VAR a: ARRAY OF Value; len: LONGINT ): Value;
  390. (* algorithm of Nikolaus Wirth, array is modified ! *)
  391. VAR i, j, l, m: Index; x: Value;
  392. PROCEDURE swap( VAR x, y: Value );
  393. VAR z: Value;
  394. BEGIN
  395. z := x; x := y; y := z
  396. END swap;
  397. BEGIN
  398. Array1dBytes.RangeCheck( 0, len, LEN( a ) );
  399. l := 0; m := len - 1;
  400. WHILE (l < m) DO
  401. x := a[k]; i := l; j := m;
  402. REPEAT
  403. WHILE (a[i] < x) DO INC( i ) END;
  404. WHILE (x < a[j]) DO DEC( j ) END;
  405. IF i <= j THEN swap( a[i], a[j] ); INC( i ); DEC( j ) END
  406. UNTIL i > j;
  407. IF j < k THEN l := i END;
  408. IF k < i THEN m := j END
  409. END;
  410. RETURN a[k]
  411. END kSmallestModify;
  412. PROCEDURE kSmallest*( k: Index; VAR a: ARRAY OF Value; len: LONGINT ): Value;
  413. (** avoids modification by creatning a copy of a, not for frequent use *)
  414. VAR copy: Array;
  415. BEGIN
  416. Array1dBytes.RangeCheck( 0, len, LEN( a ) );
  417. NEW( copy, len ); Copy( a, copy^, 0, 0, len ); RETURN kSmallestModify( k, copy^, len );
  418. END kSmallest;
  419. PROCEDURE Median*( VAR a: ARRAY OF Value; len: LONGINT ): Value;
  420. BEGIN
  421. RETURN kSmallest( len DIV 2, a, len );
  422. END Median;
  423. (** norms and distances*)
  424. PROCEDURE HammingWeight*( VAR x: ARRAY OF Value; offset, len: Index ): Index;
  425. VAR res: Index;
  426. BEGIN
  427. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  428. INC( len, offset ); res := 0;
  429. WHILE offset < len DO
  430. IF x[offset] # 0 THEN INC( res ) END;
  431. INC( offset );
  432. END;
  433. RETURN res;
  434. END HammingWeight;
  435. PROCEDURE HammingWeightPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): Index;
  436. VAR i, end, endpiece: Index; res: Index;
  437. BEGIN
  438. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  439. i := offset; end := offset + step * pieces; step := step - piecelen; res := 0;
  440. WHILE i < end DO
  441. endpiece := i + piecelen;
  442. WHILE i < endpiece DO
  443. IF x[i] # 0 THEN INC( res ) END;
  444. INC( i );
  445. END;
  446. INC( i, step );
  447. END;
  448. RETURN res;
  449. END HammingWeightPat;
  450. PROCEDURE HammingDist*( VAR x, y: ARRAY OF Value; xoffset, yoffset, len: Index ): Index;
  451. VAR res: Index;
  452. BEGIN
  453. Array1dBytes.RangeCheck( xoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( yoffset, len, LEN( y ) );
  454. INC( len, xoffset ); res := 0;
  455. WHILE xoffset < len DO
  456. IF x[xoffset] # y[yoffset] THEN INC( res ) END;
  457. INC( xoffset ); INC( yoffset );
  458. END;
  459. RETURN res;
  460. END HammingDist;
  461. PROCEDURE L1Norm*( VAR x: ARRAY OF Value; offset, len: Index ): Value;
  462. (** caution: routine does not check overflows *)
  463. VAR res: Value;
  464. BEGIN
  465. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  466. INC( len, offset ); res := 0;
  467. WHILE offset < len DO INC( res, ABS( x[offset] ) ); INC( offset ); END;
  468. RETURN res;
  469. END L1Norm;
  470. PROCEDURE L1NormPat*( map: Map; VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): Value;
  471. VAR i, end, endpiece: Index; res: Value;
  472. BEGIN
  473. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  474. i := offset; end := offset + step * pieces; step := step - piecelen; res := 0;
  475. WHILE i < end DO
  476. endpiece := i + piecelen;
  477. WHILE i < endpiece DO res := res + ABS( x[i] ); INC( i ); END;
  478. INC( i, step );
  479. END;
  480. RETURN res;
  481. END L1NormPat;
  482. PROCEDURE L1Dist*( VAR x, y: ARRAY OF Value; xoffset, yoffset, len: Index ): Value;
  483. VAR res: Value;
  484. BEGIN
  485. Array1dBytes.RangeCheck( xoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( yoffset, len, LEN( y ) );
  486. INC( len, xoffset ); res := 0;
  487. WHILE xoffset < len DO res := res + ABS( x[xoffset] - y[yoffset] ); INC( xoffset ); INC( yoffset ); END;
  488. RETURN res;
  489. END L1Dist;
  490. PROCEDURE L2NormSq*( VAR x: ARRAY OF Value; offset, len: Index ): NbrRe.Real;
  491. (** caution: routine does not check overflow *)
  492. VAR res: NbrRe.Real;
  493. BEGIN
  494. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  495. INC( len, offset ); res := 0;
  496. WHILE offset < len DO res := res + x[offset] * x[offset]; INC( offset ); END;
  497. RETURN res;
  498. END L2NormSq;
  499. PROCEDURE L2Norm*( VAR x: ARRAY OF Value; offset, len: Index ): NbrRe.Real;
  500. BEGIN
  501. RETURN NbrRe.Sqrt( L2NormSq( x, offset, len ) );
  502. END L2Norm;
  503. PROCEDURE L2NormPatSq*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): NbrRe.Real;
  504. VAR i, end, endpiece: Index; res: NbrRe.Real;
  505. BEGIN
  506. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  507. i := offset; end := offset + step * pieces; step := step - piecelen; res := 0;
  508. WHILE i < end DO
  509. endpiece := i + piecelen;
  510. WHILE i < endpiece DO res := res + (x[i] * x[i]); INC( i ); END;
  511. INC( i, step );
  512. END;
  513. RETURN res;
  514. END L2NormPatSq;
  515. PROCEDURE L2NormPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): NbrRe.Real;
  516. BEGIN
  517. RETURN NbrRe.Sqrt( L2NormPatSq( x, offset, step, piecelen, pieces ) );
  518. END L2NormPat;
  519. PROCEDURE L2DistSq*( VAR x, y: ARRAY OF Value; xoffset, yoffset, len: Index ): NbrRe.Real;
  520. VAR res: NbrRe.Real; mult: Value;
  521. BEGIN
  522. Array1dBytes.RangeCheck( xoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( yoffset, len, LEN( y ) );
  523. INC( len, xoffset ); res := 0;
  524. WHILE xoffset < len DO mult := x[xoffset] - y[yoffset]; res := res + mult * mult; INC( xoffset ); INC( yoffset ); END;
  525. RETURN res;
  526. END L2DistSq;
  527. PROCEDURE L2Dist*( VAR x, y: ARRAY OF Value; xoffset, yoffset, len: Index ): NbrRe.Real;
  528. BEGIN
  529. RETURN NbrRe.Sqrt( L2DistSq( x, y, xoffset, yoffset, len ) );
  530. END L2Dist;
  531. PROCEDURE LInftyNorm*( VAR x: ARRAY OF Value; offset, len: Index ): Value;
  532. (** caution: routine does not check overflow *)
  533. VAR res, val: Value;
  534. BEGIN
  535. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  536. INC( len, offset ); res := 0;
  537. WHILE offset < len DO
  538. val := ABS( x[offset] );
  539. IF val > res THEN res := val END;
  540. INC( offset );
  541. END;
  542. RETURN res;
  543. END LInftyNorm;
  544. PROCEDURE LInftyNormPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: Index ): Value;
  545. VAR i, end, endpiece: Index; res, val: Value;
  546. BEGIN
  547. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  548. i := offset; end := offset + step * pieces; step := step - piecelen; res := 0;
  549. WHILE i < end DO
  550. endpiece := i + piecelen;
  551. WHILE i < endpiece DO
  552. val := ABS( x[i] );
  553. IF val > res THEN res := val END;
  554. INC( i );
  555. END;
  556. INC( i, step );
  557. END;
  558. RETURN res;
  559. END LInftyNormPat;
  560. PROCEDURE LInftyDist*( VAR x, y: ARRAY OF Value; xoffset, yoffset, len: Index ): Value;
  561. VAR res, val: Value;
  562. BEGIN
  563. Array1dBytes.RangeCheck( xoffset, len, LEN( x ) ); Array1dBytes.RangeCheck( yoffset, len, LEN( y ) );
  564. INC( len, xoffset ); res := 0;
  565. WHILE xoffset < len DO
  566. val := ABS( x[xoffset] - y[yoffset] );
  567. IF val > res THEN res := val END;
  568. INC( xoffset ); INC( yoffset );
  569. END;
  570. RETURN res;
  571. END LInftyDist;
  572. PROCEDURE MinIndex( x, y: Index ): Index;
  573. BEGIN
  574. IF x < y THEN RETURN x ELSE RETURN y END;
  575. END MinIndex;
  576. PROCEDURE SetLen*( VAR a: Array; len: Index );
  577. (** extend: append zeros, shrink: simple cut *)
  578. VAR res: Array;
  579. BEGIN
  580. NEW( res, len ); Copy( a^, res^, 0, 0, MinIndex( LEN( a ), len ) );
  581. END SetLen;
  582. (** index operations *)
  583. PROCEDURE RemoveBlock*( VAR x: ARRAY OF Value; offset, len: Index );
  584. (* remove block [offset,offset+len), fill rest with 0 *)
  585. VAR restlen: Index;
  586. BEGIN
  587. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  588. restlen := LEN( x ) - offset - len; Copy( x, x, offset + len, offset, restlen ); Fill( 0, x, offset + len, restlen )
  589. END RemoveBlock;
  590. PROCEDURE InsertBlock*( VAR x: ARRAY OF Value; offset, len: Index );
  591. (* insert (empty) block [offset,offset+len), content formerly in [offset,offset+len) is shifted upwards !*)
  592. VAR restlen: Index;
  593. BEGIN
  594. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  595. restlen := LEN( x ) - offset - len; Copy( x, x, offset, offset + len, restlen ); Fill( 0, x, offset, len );
  596. END InsertBlock;
  597. PROCEDURE ShiftBlock*( VAR x: ARRAY OF Value; from, to, len: Index );
  598. (** memory allocation by far not optimized, not intended for very frequent use*)
  599. VAR temp: Array;
  600. BEGIN
  601. Array1dBytes.RangeCheck( from, len, LEN( x ) ); Array1dBytes.RangeCheck( to, len, LEN( x ) );
  602. NEW( temp, len ); Copy( x, temp^, from, 0, len ); RemoveBlock( x, from, len ); InsertBlock( x, to, len );
  603. Copy( temp^, x, 0, to, len );
  604. END ShiftBlock;
  605. PROCEDURE RemovePat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: LONGINT ): Array;
  606. (* for example: remove row or col from matrix *)
  607. VAR srcidx, destidx: LONGINT; res: Array;
  608. BEGIN
  609. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) );
  610. NEW( res, LEN( x ) - pieces * piecelen ); srcidx := 0; destidx := 0;
  611. WHILE (srcidx < offset) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  612. WHILE (pieces) > 0 DO
  613. INC( offset, piecelen );
  614. WHILE (srcidx < offset) DO INC( srcidx ); END;
  615. INC( offset, step - piecelen );
  616. IF (offset > LEN( x )) THEN offset := LEN( x ) END;
  617. WHILE (srcidx < offset) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  618. DEC( pieces );
  619. END;
  620. offset := LEN( x );
  621. WHILE (srcidx < offset) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  622. ASSERT ( destidx = LEN( res ) );
  623. RETURN res;
  624. END RemovePat;
  625. PROCEDURE Remove*( VAR x: ARRAY OF Value; offset, len: LONGINT ): Array; (* optimize if necessary *)
  626. BEGIN
  627. RETURN RemovePat( x, offset, len, len, 1 );
  628. END Remove;
  629. PROCEDURE InsertPat*( VAR x: ARRAY OF Value; offset, step, piecelen, pieces: LONGINT ): Array;
  630. (* for example: insert row or col in matrix *)
  631. VAR srcidx, destidx: LONGINT; res: Array; null: Value;
  632. BEGIN
  633. Array1dBytes.PatRangeCheck( offset, step, piecelen, pieces, LEN( x ) + pieces * piecelen );
  634. null := 0; NEW( res, LEN( x ) + pieces * piecelen ); srcidx := 0; destidx := 0;
  635. WHILE (srcidx < offset) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  636. WHILE (pieces) > 0 DO
  637. INC( offset, piecelen );
  638. WHILE (destidx < offset) DO res[destidx] := null; INC( destidx ); END;
  639. INC( offset, step - piecelen );
  640. WHILE ((destidx < offset) & (srcidx < LEN( x ))) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  641. DEC( pieces );
  642. END;
  643. offset := LEN( x );
  644. WHILE (srcidx < offset) DO res[destidx] := x[srcidx]; INC( srcidx ); INC( destidx ); END;
  645. ASSERT ( destidx = LEN( res ) );
  646. RETURN res;
  647. END InsertPat;
  648. PROCEDURE Insert*( VAR x: ARRAY OF Value; offset, len: LONGINT ): Array; (* optimize if necessary *)
  649. BEGIN
  650. RETURN InsertPat( x, offset, len, len, 1 );
  651. END Insert;
  652. PROCEDURE GetPieces*( VAR a: ARRAY OF Value; offset, step, piecelen: LONGINT ): LONGINT;
  653. BEGIN
  654. IF (LEN( a ) - offset) MOD step >= piecelen THEN RETURN (LEN( a ) - offset) DIV step + 1 ELSE RETURN (LEN( a ) - offset) DIV step END;
  655. END GetPieces;
  656. PROCEDURE Long*( VAR x: ARRAY OF Value; res: ARRAY OF LongerValue; len: Index );
  657. VAR i: LONGINT;
  658. BEGIN
  659. Array1dBytes.RangeCheck( 0, len, LEN( x ) ); Array1dBytes.RangeCheck( 0, len, LEN( res ) );
  660. DEC( len );
  661. FOR i := 0 TO len DO res[i] := x[i]; END;
  662. END Long;
  663. PROCEDURE Short*( VAR x: ARRAY OF Value; res: ARRAY OF ShorterValue; len: Index );
  664. VAR i: LONGINT;
  665. BEGIN
  666. Array1dBytes.RangeCheck( 0, len, LEN( x ) ); Array1dBytes.RangeCheck( 0, len, LEN( res ) );
  667. DEC( len );
  668. FOR i := 0 TO len DO res[i] := SHORT( x[i] ); END;
  669. END Short;
  670. (** sorting *)
  671. PROCEDURE Sort*( VAR x: ARRAY OF Value; offset, len: Index );
  672. PROCEDURE ThreeSort( l, c, r: Index );
  673. VAR sort: Value;
  674. BEGIN
  675. IF x[l] > x[c] THEN sort := x[l]; x[l] := x[c]; x[c] := sort END;
  676. IF x[l] > x[r] THEN sort := x[l]; x[l] := x[r]; x[r] := sort END;
  677. IF x[c] > x[r] THEN sort := x[c]; x[c] := x[r]; x[r] := sort END
  678. END ThreeSort;
  679. PROCEDURE InsertionSort( l, r: Index );
  680. VAR i, j: Index; sort: Value;
  681. BEGIN
  682. FOR i := l + 1 TO r DO
  683. sort := x[i]; j := i;
  684. WHILE (j > 0) & (x[j - 1] > sort) DO x[j] := x[j - 1]; DEC( j ) END;
  685. x[j] := sort
  686. END
  687. END InsertionSort;
  688. PROCEDURE QuickSort( l, r: Index );
  689. CONST short = 7; (* Short vectors sort faster with insertion. *)
  690. VAR c, i, j: Index; sort, temp: Value;
  691. BEGIN
  692. IF r - l > short THEN (* quick sort *)
  693. c := (l + r) DIV 2; ThreeSort( l, c, r ); sort := x[r]; i := l - 1; j := r;
  694. REPEAT
  695. REPEAT INC( i ) UNTIL x[i] >= sort;
  696. REPEAT DEC( j ) UNTIL x[j] <= sort;
  697. temp := x[i]; x[i] := x[j]; x[j] := temp
  698. UNTIL j < i;
  699. x[j] := x[i]; x[i] := x[r]; x[r] := temp; QuickSort( l, j ); QuickSort( i + 1, r )
  700. ELSIF r > l THEN InsertionSort( l, r )
  701. ELSE (* Nothing to sort. *)
  702. END
  703. END QuickSort;
  704. BEGIN
  705. Array1dBytes.RangeCheck( offset, len, LEN( x ) );
  706. IF len <= 1 THEN RETURN
  707. END;
  708. QuickSort( offset, offset + len - 1 );
  709. END Sort;
  710. PROCEDURE SortWithIndex*( VAR x: ARRAY OF Value; VAR index: ARRAY OF Index; offset, len: Index );
  711. PROCEDURE ThreeSort( l, c, r: Index );
  712. VAR sort: Value; ind: Index;
  713. BEGIN
  714. IF x[l] > x[c] THEN sort := x[l]; x[l] := x[c]; x[c] := sort; ind := index[l]; index[l] := index[c]; index[c] := ind; END;
  715. IF x[l] > x[r] THEN sort := x[l]; x[l] := x[r]; x[r] := sort; ind := index[l]; index[l] := index[r]; index[r] := ind; END;
  716. IF x[c] > x[r] THEN sort := x[c]; x[c] := x[r]; x[r] := sort; ind := index[c]; index[c] := index[r]; index[r] := ind; END
  717. END ThreeSort;
  718. PROCEDURE InsertionSort( l, r: Index );
  719. VAR i, j: Index; sort: Value; ind: Index;
  720. BEGIN
  721. FOR i := l + 1 TO r DO
  722. sort := x[i]; ind := index[i]; j := i;
  723. WHILE (j > 0) & (x[j - 1] > sort) DO x[j] := x[j - 1]; index[j] := index[j - 1]; DEC( j ) END;
  724. x[j] := sort; index[j] := ind;
  725. END
  726. END InsertionSort;
  727. PROCEDURE QuickSort( l, r: Index );
  728. CONST short = 7; (* Short vectors sort faster with insertion. *)
  729. VAR c, i, j: Index; sort, temp: Value; ind: Index;
  730. BEGIN
  731. IF r - l > short THEN (* quick sort *)
  732. c := (l + r) DIV 2; ThreeSort( l, c, r ); sort := x[r]; ind := index[r]; i := l - 1; j := r;
  733. REPEAT
  734. REPEAT INC( i ) UNTIL x[i] >= sort;
  735. REPEAT DEC( j ) UNTIL x[j] <= sort;
  736. temp := x[i]; x[i] := x[j]; x[j] := temp; ind := index[i]; index[i] := index[j]; index[j] := ind;
  737. UNTIL j < i;
  738. x[j] := x[i]; x[i] := x[r]; x[r] := temp; index[j] := index[i]; index[i] := index[r]; index[r] := ind; QuickSort( l, j );
  739. QuickSort( i + 1, r )
  740. ELSIF r > l THEN InsertionSort( l, r )
  741. ELSE (* Nothing to sort. *)
  742. END
  743. END QuickSort;
  744. BEGIN
  745. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( index ) );
  746. IF len <= 1 THEN RETURN END;
  747. QuickSort( offset, offset + len - 1 );
  748. END SortWithIndex;
  749. PROCEDURE SortByIndex*( VAR x: ARRAY OF Value; VAR index: ARRAY OF Index; offset, len: Index );
  750. PROCEDURE ThreeSort( l, c, r: Index );
  751. VAR sort: Value; ind: Index;
  752. BEGIN
  753. IF index[l] > index[c] THEN
  754. sort := x[l]; x[l] := x[c]; x[c] := sort; ind := index[l]; index[l] := index[c]; index[c] := ind;
  755. END;
  756. IF index[l] > index[r] THEN sort := x[l]; x[l] := x[r]; x[r] := sort; ind := index[l]; index[l] := index[r]; index[r] := ind; END;
  757. IF index[c] > index[r] THEN
  758. sort := x[c]; x[c] := x[r]; x[r] := sort; ind := index[c]; index[c] := index[r]; index[r] := ind;
  759. END
  760. END ThreeSort;
  761. PROCEDURE InsertionSort( l, r: Index );
  762. VAR i, j: Index; sort: Value; ind: Index;
  763. BEGIN
  764. FOR i := l + 1 TO r DO
  765. sort := x[i]; ind := index[i]; j := i;
  766. WHILE (j > 0) & (index[j - 1] > ind) DO x[j] := x[j - 1]; index[j] := index[j - 1]; DEC( j ) END;
  767. x[j] := sort; index[j] := ind;
  768. END
  769. END InsertionSort;
  770. PROCEDURE QuickSort( l, r: Index );
  771. CONST short = 7; (* Short vectors sort faster with insertion. *)
  772. VAR c, i, j, ind: Index; sort, temp: Value;
  773. BEGIN
  774. IF r - l > short THEN (* quick sort *)
  775. c := (l + r) DIV 2; ThreeSort( l, c, r ); sort := x[r]; ind := index[r]; i := l - 1; j := r;
  776. REPEAT
  777. REPEAT INC( i ) UNTIL index[i] >= ind;
  778. REPEAT DEC( j ) UNTIL index[j] <= ind;
  779. temp := x[i]; x[i] := x[j]; x[j] := temp; ind := index[i]; index[i] := index[j]; index[j] := ind;
  780. UNTIL j < i;
  781. x[j] := x[i]; x[i] := x[r]; x[r] := temp; index[j] := index[i]; index[i] := index[r]; index[r] := ind; QuickSort( l, j );
  782. QuickSort( i + 1, r )
  783. ELSIF r > l THEN InsertionSort( l, r )
  784. ELSE (* Nothing to sort. *)
  785. END
  786. END QuickSort;
  787. BEGIN
  788. Array1dBytes.RangeCheck( offset, len, LEN( x ) ); Array1dBytes.RangeCheck( offset, len, LEN( index ) );
  789. IF len <= 1 THEN RETURN
  790. END;
  791. QuickSort( offset, offset + len - 1 );
  792. END SortByIndex;
  793. (** Overloaded operators for type: Array. *)
  794. (** Monadic Operator - does not overwrite the argument *)
  795. OPERATOR "-"*( x: Array ): Array;
  796. VAR minus: Array;
  797. BEGIN
  798. IF x # NIL THEN minus := CreateCopy( x^ ); Negate( minus^, 0, LEN( minus ) ); ELSE DataErrors.Error( "The supplied vector was NIL." ) END;
  799. RETURN minus
  800. END "-";
  801. (** Dyadic Operators *)
  802. OPERATOR ":="*( VAR l: Array; VAR r: ARRAY OF Value );
  803. BEGIN
  804. IF l = NIL THEN NEW( l, LEN( r ) )
  805. ELSIF LEN( l ) # LEN( r ) THEN NEW( l, LEN( r ) )
  806. ELSE (* vector l is properly dimensioned *)
  807. END;
  808. Copy( l^, r, 0, 0, LEN( r ) );
  809. END ":=";
  810. OPERATOR "="*( l: Array; VAR r: ARRAY OF Value ): BOOLEAN;
  811. BEGIN
  812. IF (l # NIL ) & (LEN( l ) = LEN( r )) THEN RETURN EqualsAA( l^, r, 0, LEN( l ) ); ELSE DataErrors.Error( "The lengths of the two supplied Array vectors were not equal." ); END;
  813. RETURN FALSE;
  814. END "=";
  815. OPERATOR "="*( VAR l: ARRAY OF Value; r: Array ): BOOLEAN;
  816. BEGIN
  817. IF (r # NIL ) & (LEN( l ) = LEN( r )) THEN RETURN EqualsAA( r^, l, 0, LEN( r ) ); ELSE DataErrors.Error( "The lengths of the two supplied Array vectors were not equal." ); END;
  818. RETURN FALSE;
  819. END "=";
  820. (* filling *)
  821. OPERATOR ":="*( VAR l: Array; r: Value );
  822. BEGIN
  823. IF l = NIL THEN RETURN END;
  824. Fill( r, l^, 0, LEN( l ) );
  825. END ":=";
  826. (** Arithmetic. Operators do not overwrite the arguments. *)
  827. OPERATOR "+"*( l, r: Array ): Array;
  828. VAR len: Index; sum: Array;
  829. BEGIN
  830. IF (l # NIL ) & (r # NIL ) THEN
  831. IF LEN( l ) = LEN( r ) THEN len := LEN( l ); NEW( sum, len ); AddAA( l^, r^, sum^, 0, len ); ELSE DataErrors.Error( "The lengths of the two supplied Array vectors were not equal." ) END
  832. ELSE DataErrors.Error( "One or both of the two supplied Array vectors was NIL." )
  833. END;
  834. RETURN sum
  835. END "+";
  836. OPERATOR "+"*( l: Array; r: Value ): Array;
  837. VAR sum: Array;
  838. BEGIN
  839. IF (l # NIL ) THEN NEW( sum, LEN( l ) ); AddAV( l^, r, sum^, 0, LEN( l ) ); ELSE DataErrors.Error( "Supplied Array was NIL" ); END;
  840. RETURN sum
  841. END "+";
  842. OPERATOR "+"*( r: Value; l: Array ): Array;
  843. VAR sum: Array;
  844. BEGIN
  845. IF (l # NIL ) THEN NEW( sum, LEN( l ) ); AddAV( l^, r, sum^, 0, LEN( l ) ); ELSE DataErrors.Error( "Supplied Array was NIL" ); END;
  846. RETURN sum
  847. END "+";
  848. OPERATOR "-"*( l: Array; r: Value ): Array;
  849. VAR sum: Array;
  850. BEGIN
  851. IF (l # NIL ) THEN NEW( sum, LEN( l ) ); SubtractAV( l^, r, sum^, 0, LEN( l ) ); ELSE DataErrors.Error( "Supplied Array was NIL" ); END;
  852. RETURN sum
  853. END "-";
  854. OPERATOR "-"*( l: Value; r: Array ): Array;
  855. VAR sum: Array;
  856. BEGIN
  857. IF (r # NIL ) THEN NEW( sum, LEN( r ) ); SubtractVA( l, r^, sum^, 0, LEN( r ) ); ELSE DataErrors.Error( "Supplied Array was NIL" ); END;
  858. RETURN sum
  859. END "-";
  860. OPERATOR "-"*( l, r: Array ): Array;
  861. VAR len: Index; diff: Array;
  862. BEGIN
  863. IF (l # NIL ) & (r # NIL ) THEN
  864. IF LEN( l ) = LEN( r ) THEN len := LEN( l ); NEW( diff, len ); SubtractAA( l^, r^, diff^, 0, len ) ELSE DataErrors.Error( "The lengths of the two supplied Array vectors were not equal." ) END
  865. ELSE DataErrors.Error( "One or both of the two supplied Array vectors was NIL." )
  866. END;
  867. RETURN diff
  868. END "-";
  869. (** Array dot product *)
  870. OPERATOR "*"*( l, r: Array ): Value;
  871. VAR len: Index; dot: Value;
  872. BEGIN
  873. dot := 0;
  874. IF (l # NIL ) & (r # NIL ) THEN
  875. IF LEN( l ) = LEN( r ) THEN len := LEN( l ); ScalarProduct( l^, r^, dot, 0, 0, len ); ELSE DataErrors.Error( "The lengths of the two supplied Array vectors were not equal." ) END
  876. ELSE DataErrors.Error( "One or both of the two supplied Array vectors was NIL." )
  877. END;
  878. RETURN dot
  879. END "*";
  880. (** Scalar multiplication *)
  881. OPERATOR "*"*( l: Value; r: Array ): Array;
  882. VAR len: Index; prod: Array;
  883. BEGIN
  884. IF r # NIL THEN len := LEN( r ); NEW( prod, len ); MultAV( r^, l, prod^, 0, len ); ELSE DataErrors.Error( "The supplied Array vector was NIL." ) END;
  885. RETURN prod
  886. END "*";
  887. OPERATOR "*"*( l: Array; r: Value ): Array;
  888. VAR len: Index; prod: Array;
  889. BEGIN
  890. IF l # NIL THEN len := LEN( l ); NEW( prod, len ); MultAV( l^, r, prod^, 0, len ); ELSE DataErrors.Error( "The supplied Array vector was NIL." ) END;
  891. RETURN prod
  892. END "*";
  893. (** Scalar division *)
  894. OPERATOR "DIV"*( l: Array; r: Value ): Array;
  895. VAR len: Index; div: Array;
  896. BEGIN
  897. IF l # NIL THEN
  898. IF r # 0 THEN len := LEN( l ); NEW( div, len ); DivAV( l^, r, div^, 0, len ); ELSE DataErrors.Error( "Division by zero." ) END
  899. ELSE DataErrors.Error( "The supplied Array vector was NIL." )
  900. END;
  901. RETURN div
  902. END "DIV";
  903. OPERATOR "DIV"*( l: Value; r: Array ): Array;
  904. VAR len: Index; div: Array;
  905. BEGIN
  906. IF r # NIL THEN len := LEN( r ); NEW( div, len ); DivVA( l, r^, div^, 0, len ); ELSE DataErrors.Error( "The supplied Array vector was NIL." ) END;
  907. RETURN div
  908. END "DIV";
  909. OPERATOR "MOD"*( l: Array; r: Value ): Array;
  910. VAR len: Index; mod: Array;
  911. BEGIN
  912. IF l # NIL THEN
  913. IF r # 0 THEN len := LEN( l ); NEW( mod, len ); ModAV( l^, r, mod^, 0, len ); ELSE DataErrors.Error( "Division by zero." ) END
  914. ELSE DataErrors.Error( "The supplied Array vector was NIL." )
  915. END;
  916. RETURN mod
  917. END "MOD";
  918. OPERATOR "MOD"*( l: Value; r: Array ): Array;
  919. VAR len: Index; div: Array;
  920. BEGIN
  921. IF r # NIL THEN len := LEN( r ); NEW( div, len ); ModVA( l, r^, div^, 0, len ); ELSE DataErrors.Error( "The supplied Array vector was NIL." ) END;
  922. RETURN div
  923. END "MOD";
  924. END Array1dInt.