math.pp 47 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2005 by Florian Klaempfl
  4. member of the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {
  12. This unit is an equivalent to the Delphi math unit
  13. (with some improvements)
  14. What's to do:
  15. o some statistical functions
  16. o all financial functions
  17. o optimizations
  18. }
  19. {$MODE objfpc}
  20. {$inline on }
  21. unit math;
  22. interface
  23. uses
  24. sysutils;
  25. { Ranges of the IEEE floating point types, including denormals }
  26. {$ifdef FPC_HAS_TYPE_SINGLE}
  27. const
  28. MinSingle = 1.5e-45;
  29. MaxSingle = 3.4e+38;
  30. {$endif FPC_HAS_TYPE_SINGLE}
  31. {$ifdef FPC_HAS_TYPE_DOUBLE}
  32. const
  33. MinDouble = 5.0e-324;
  34. MaxDouble = 1.7e+308;
  35. {$endif FPC_HAS_TYPE_DOUBLE}
  36. {$ifdef FPC_HAS_TYPE_EXTENDED}
  37. const
  38. MinExtended = 3.4e-4932;
  39. MaxExtended = 1.1e+4932;
  40. {$endif FPC_HAS_TYPE_EXTENDED}
  41. {$ifdef FPC_HAS_TYPE_COMP}
  42. const
  43. MinComp = -9.223372036854775807e+18;
  44. MaxComp = 9.223372036854775807e+18;
  45. {$endif FPC_HAS_TYPE_COMP}
  46. { the original delphi functions use extended as argument, }
  47. { but I would prefer double, because 8 bytes is a very }
  48. { natural size for the processor }
  49. { WARNING : changing float type will }
  50. { break all assembler code PM }
  51. {$ifdef FPC_HAS_TYPE_FLOAT128}
  52. type
  53. float = float128;
  54. const
  55. MinFloat = MinFloat128;
  56. MaxFloat = MaxFloat128;
  57. {$else FPC_HAS_TYPE_FLOAT128}
  58. {$ifdef FPC_HAS_TYPE_EXTENDED}
  59. type
  60. float = extended;
  61. const
  62. MinFloat = MinExtended;
  63. MaxFloat = MaxExtended;
  64. {$else FPC_HAS_TYPE_EXTENDED}
  65. {$ifdef FPC_HAS_TYPE_DOUBLE}
  66. type
  67. float = double;
  68. const
  69. MinFloat = MinDouble;
  70. MaxFloat = MaxDouble;
  71. {$else FPC_HAS_TYPE_DOUBLE}
  72. {$ifdef FPC_HAS_TYPE_SINGLE}
  73. type
  74. float = single;
  75. const
  76. MinFloat = MinSingle;
  77. MaxFloat = MaxSingle;
  78. {$else FPC_HAS_TYPE_SINGLE}
  79. {$fatal At least one floating point type must be supported}
  80. {$endif FPC_HAS_TYPE_SINGLE}
  81. {$endif FPC_HAS_TYPE_DOUBLE}
  82. {$endif FPC_HAS_TYPE_EXTENDED}
  83. {$endif FPC_HAS_TYPE_FLOAT128}
  84. type
  85. PFloat = ^Float;
  86. PInteger = ^Integer;
  87. tpaymenttime = (ptendofperiod,ptstartofperiod);
  88. einvalidargument = class(ematherror);
  89. TValueRelationship = -1..1;
  90. const
  91. EqualsValue = 0;
  92. LessThanValue = Low(TValueRelationship);
  93. GreaterThanValue = High(TValueRelationship);
  94. {$ifopt R+}
  95. {$define RangeCheckWasOn}
  96. {$R-}
  97. {$endif opt R+}
  98. {$ifopt Q+}
  99. {$define OverflowCheckWasOn}
  100. {$Q-}
  101. {$endif opt Q+}
  102. {$if defined(CPUARM) and defined(unix)}
  103. { the ARM linux emulator doesn't like 0.0/0.0 }
  104. NaN = ln(-1.0);
  105. {$else CPUARM}
  106. NaN = 0.0/0.0;
  107. {$endif CPUARM}
  108. Infinity = 1.0/0.0;
  109. {$ifdef RangeCheckWasOn}
  110. {$R+}
  111. {$undef RangeCheckWasOn}
  112. {$endif}
  113. {$ifdef OverflowCheckWasOn}
  114. {$Q+}
  115. {$undef OverflowCheckWasOn}
  116. {$endif}
  117. { Min/max determination }
  118. function MinIntValue(const Data: array of Integer): Integer;
  119. function MaxIntValue(const Data: array of Integer): Integer;
  120. { Extra, not present in Delphi, but used frequently }
  121. function Min(a, b: Integer): Integer;inline;
  122. function Max(a, b: Integer): Integer;inline;
  123. { this causes more trouble than it solves
  124. function Min(a, b: Cardinal): Cardinal;
  125. function Max(a, b: Cardinal): Cardinal;
  126. }
  127. function Min(a, b: Int64): Int64;inline;
  128. function Max(a, b: Int64): Int64;inline;
  129. {$ifdef FPC_HAS_TYPE_SINGLE}
  130. function Min(a, b: Single): Single;inline;
  131. function Max(a, b: Single): Single;inline;
  132. {$endif FPC_HAS_TYPE_SINGLE}
  133. {$ifdef FPC_HAS_TYPE_DOUBLE}
  134. function Min(a, b: Double): Double;inline;
  135. function Max(a, b: Double): Double;inline;
  136. {$endif FPC_HAS_TYPE_DOUBLE}
  137. {$ifdef FPC_HAS_TYPE_EXTENDED}
  138. function Min(a, b: Extended): Extended;inline;
  139. function Max(a, b: Extended): Extended;inline;
  140. {$endif FPC_HAS_TYPE_EXTENDED}
  141. function InRange(const AValue, AMin, AMax: Integer): Boolean;inline;
  142. function InRange(const AValue, AMin, AMax: Int64): Boolean;inline;
  143. {$ifdef FPC_HAS_TYPE_DOUBLE}
  144. function InRange(const AValue, AMin, AMax: Double): Boolean;inline;
  145. {$endif FPC_HAS_TYPE_DOUBLE}
  146. function EnsureRange(const AValue, AMin, AMax: Integer): Integer;inline;
  147. function EnsureRange(const AValue, AMin, AMax: Int64): Int64;inline;
  148. {$ifdef FPC_HAS_TYPE_DOUBLE}
  149. function EnsureRange(const AValue, AMin, AMax: Double): Double;inline;
  150. {$endif FPC_HAS_TYPE_DOUBLE}
  151. procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
  152. // Sign functions
  153. Type
  154. TValueSign = -1..1;
  155. const
  156. NegativeValue = Low(TValueSign);
  157. ZeroValue = 0;
  158. PositiveValue = High(TValueSign);
  159. function Sign(const AValue: Integer): TValueSign;inline;
  160. function Sign(const AValue: Int64): TValueSign;inline;
  161. function Sign(const AValue: Double): TValueSign;inline;
  162. function IsZero(const A: Single; Epsilon: Single): Boolean;
  163. function IsZero(const A: Single): Boolean;inline;
  164. {$ifdef FPC_HAS_TYPE_DOUBLE}
  165. function IsZero(const A: Double; Epsilon: Double): Boolean;
  166. function IsZero(const A: Double): Boolean;inline;
  167. {$endif FPC_HAS_TYPE_DOUBLE}
  168. {$ifdef FPC_HAS_TYPE_EXTENDED}
  169. function IsZero(const A: Extended; Epsilon: Extended): Boolean;
  170. function IsZero(const A: Extended): Boolean;inline;
  171. {$endif FPC_HAS_TYPE_EXTENDED}
  172. function IsNan(const d : Double): Boolean;
  173. function IsInfinite(const d : Double): Boolean;
  174. {$ifdef FPC_HAS_TYPE_EXTENDED}
  175. function SameValue(const A, B: Extended): Boolean;inline;
  176. {$endif}
  177. {$ifdef FPC_HAS_TYPE_DOUBLE}
  178. function SameValue(const A, B: Double): Boolean;inline;
  179. {$endif}
  180. function SameValue(const A, B: Single): Boolean;inline;
  181. {$ifdef FPC_HAS_TYPE_EXTENDED}
  182. function SameValue(const A, B: Extended; Epsilon: Extended): Boolean;
  183. {$endif}
  184. {$ifdef FPC_HAS_TYPE_DOUBLE}
  185. function SameValue(const A, B: Double; Epsilon: Double): Boolean;
  186. {$endif}
  187. function SameValue(const A, B: Single; Epsilon: Single): Boolean;
  188. { angle conversion }
  189. function degtorad(deg : float) : float;
  190. function radtodeg(rad : float) : float;
  191. function gradtorad(grad : float) : float;
  192. function radtograd(rad : float) : float;
  193. function degtograd(deg : float) : float;
  194. function gradtodeg(grad : float) : float;
  195. { one cycle are 2*Pi rad }
  196. function cycletorad(cycle : float) : float;
  197. function radtocycle(rad : float) : float;
  198. { trigoniometric functions }
  199. function tan(x : float) : float;
  200. function cotan(x : float) : float;
  201. procedure sincos(theta : float;var sinus,cosinus : float);
  202. { inverse functions }
  203. function arccos(x : float) : float;
  204. function arcsin(x : float) : float;
  205. { calculates arctan(y/x) and returns an angle in the correct quadrant }
  206. function arctan2(y,x : float) : float;
  207. { hyperbolic functions }
  208. function cosh(x : float) : float;
  209. function sinh(x : float) : float;
  210. function tanh(x : float) : float;
  211. { area functions }
  212. { delphi names: }
  213. function arccosh(x : float) : float;
  214. function arcsinh(x : float) : float;
  215. function arctanh(x : float) : float;
  216. { IMHO the function should be called as follows (FK) }
  217. function arcosh(x : float) : float;
  218. function arsinh(x : float) : float;
  219. function artanh(x : float) : float;
  220. { triangle functions }
  221. { returns the length of the hypotenuse of a right triangle }
  222. { if x and y are the other sides }
  223. function hypot(x,y : float) : float;
  224. { logarithm functions }
  225. function log10(x : float) : float;
  226. function log2(x : float) : float;
  227. function logn(n,x : float) : float;
  228. { returns natural logarithm of x+1 }
  229. function lnxp1(x : float) : float;
  230. { exponential functions }
  231. function power(base,exponent : float) : float;
  232. { base^exponent }
  233. function intpower(base : float;const exponent : Integer) : float;
  234. operator ** (bas,expo : float) e: float;
  235. operator ** (bas,expo : int64) i: int64;
  236. { number converting }
  237. { rounds x towards positive infinity }
  238. function ceil(x : float) : Integer;
  239. { rounds x towards negative infinity }
  240. function floor(x : float) : Integer;
  241. { misc. functions }
  242. { splits x into mantissa and exponent (to base 2) }
  243. procedure Frexp(X: float; var Mantissa: float; var Exponent: integer);
  244. { returns x*(2^p) }
  245. function ldexp(x : float; const p : Integer) : float;
  246. { statistical functions }
  247. {$ifdef FPC_HAS_TYPE_SINGLE}
  248. function mean(const data : array of Single) : float;
  249. function sum(const data : array of Single) : float;
  250. function mean(const data : PSingle; Const N : longint) : float;
  251. function sum(const data : PSingle; Const N : Longint) : float;
  252. {$endif FPC_HAS_TYPE_SINGLE}
  253. {$ifdef FPC_HAS_TYPE_DOUBLE}
  254. function mean(const data : array of double) : float;
  255. function sum(const data : array of double) : float;
  256. function mean(const data : PDouble; Const N : longint) : float;
  257. function sum(const data : PDouble; Const N : Longint) : float;
  258. {$endif FPC_HAS_TYPE_DOUBLE}
  259. {$ifdef FPC_HAS_TYPE_EXTENDED}
  260. function mean(const data : array of Extended) : float;
  261. function sum(const data : array of Extended) : float;
  262. function mean(const data : PExtended; Const N : longint) : float;
  263. function sum(const data : PExtended; Const N : Longint) : float;
  264. {$endif FPC_HAS_TYPE_EXTENDED}
  265. function sumInt(const data : PInt64;Const N : longint) : Int64;
  266. function sumInt(const data : array of Int64) : Int64;
  267. {$ifdef FPC_HAS_TYPE_SINGLE}
  268. function sumofsquares(const data : array of Single) : float;
  269. function sumofsquares(const data : PSingle; Const N : Integer) : float;
  270. { calculates the sum and the sum of squares of data }
  271. procedure sumsandsquares(const data : array of Single;
  272. var sum,sumofsquares : float);
  273. procedure sumsandsquares(const data : PSingle; Const N : Integer;
  274. var sum,sumofsquares : float);
  275. {$endif FPC_HAS_TYPE_SINGLE}
  276. {$ifdef FPC_HAS_TYPE_DOUBLE}
  277. function sumofsquares(const data : array of double) : float;
  278. function sumofsquares(const data : PDouble; Const N : Integer) : float;
  279. { calculates the sum and the sum of squares of data }
  280. procedure sumsandsquares(const data : array of Double;
  281. var sum,sumofsquares : float);
  282. procedure sumsandsquares(const data : PDouble; Const N : Integer;
  283. var sum,sumofsquares : float);
  284. {$endif FPC_HAS_TYPE_DOUBLE}
  285. {$ifdef FPC_HAS_TYPE_EXTENDED}
  286. function sumofsquares(const data : array of Extended) : float;
  287. function sumofsquares(const data : PExtended; Const N : Integer) : float;
  288. { calculates the sum and the sum of squares of data }
  289. procedure sumsandsquares(const data : array of Extended;
  290. var sum,sumofsquares : float);
  291. procedure sumsandsquares(const data : PExtended; Const N : Integer;
  292. var sum,sumofsquares : float);
  293. {$endif FPC_HAS_TYPE_EXTENDED}
  294. {$ifdef FPC_HAS_TYPE_SINGLE}
  295. function minvalue(const data : array of Single) : Single;
  296. function minvalue(const data : PSingle; Const N : Integer) : Single;
  297. function maxvalue(const data : array of Single) : Single;
  298. function maxvalue(const data : PSingle; Const N : Integer) : Single;
  299. {$endif FPC_HAS_TYPE_SINGLE}
  300. {$ifdef FPC_HAS_TYPE_DOUBLE}
  301. function minvalue(const data : array of Double) : Double;
  302. function minvalue(const data : PDouble; Const N : Integer) : Double;
  303. function maxvalue(const data : array of Double) : Double;
  304. function maxvalue(const data : PDouble; Const N : Integer) : Double;
  305. {$endif FPC_HAS_TYPE_DOUBLE}
  306. {$ifdef FPC_HAS_TYPE_EXTENDED}
  307. function minvalue(const data : array of Extended) : Extended;
  308. function minvalue(const data : PExtended; Const N : Integer) : Extended;
  309. function maxvalue(const data : array of Extended) : Extended;
  310. function maxvalue(const data : PExtended; Const N : Integer) : Extended;
  311. {$endif FPC_HAS_TYPE_EXTENDED}
  312. function minvalue(const data : array of integer) : Integer;
  313. function MinValue(const Data : PInteger; Const N : Integer): Integer;
  314. function maxvalue(const data : array of integer) : Integer;
  315. function maxvalue(const data : PInteger; Const N : Integer) : Integer;
  316. { returns random values with gaussian distribution }
  317. function randg(mean,stddev : float) : float;
  318. {$ifdef FPC_HAS_TYPE_SINGLE}
  319. { calculates the standard deviation }
  320. function stddev(const data : array of Single) : float;
  321. function stddev(const data : PSingle; Const N : Integer) : float;
  322. { calculates the mean and stddev }
  323. procedure meanandstddev(const data : array of Single;
  324. var mean,stddev : float);
  325. procedure meanandstddev(const data : PSingle;
  326. Const N : Longint;var mean,stddev : float);
  327. function variance(const data : array of Single) : float;
  328. function totalvariance(const data : array of Single) : float;
  329. function variance(const data : PSingle; Const N : Integer) : float;
  330. function totalvariance(const data : PSingle; Const N : Integer) : float;
  331. { I don't know what the following functions do: }
  332. function popnstddev(const data : array of Single) : float;
  333. function popnstddev(const data : PSingle; Const N : Integer) : float;
  334. function popnvariance(const data : PSingle; Const N : Integer) : float;
  335. function popnvariance(const data : array of Single) : float;
  336. procedure momentskewkurtosis(const data : array of Single;
  337. var m1,m2,m3,m4,skew,kurtosis : float);
  338. procedure momentskewkurtosis(const data : PSingle; Const N : Integer;
  339. var m1,m2,m3,m4,skew,kurtosis : float);
  340. { geometrical function }
  341. { returns the euclidean L2 norm }
  342. function norm(const data : array of Single) : float;
  343. function norm(const data : PSingle; Const N : Integer) : float;
  344. {$endif FPC_HAS_TYPE_SINGLE}
  345. {$ifdef FPC_HAS_TYPE_DOUBLE}
  346. { calculates the standard deviation }
  347. function stddev(const data : array of Double) : float;
  348. function stddev(const data : PDouble; Const N : Integer) : float;
  349. { calculates the mean and stddev }
  350. procedure meanandstddev(const data : array of Double;
  351. var mean,stddev : float);
  352. procedure meanandstddev(const data : PDouble;
  353. Const N : Longint;var mean,stddev : float);
  354. function variance(const data : array of Double) : float;
  355. function totalvariance(const data : array of Double) : float;
  356. function variance(const data : PDouble; Const N : Integer) : float;
  357. function totalvariance(const data : PDouble; Const N : Integer) : float;
  358. { I don't know what the following functions do: }
  359. function popnstddev(const data : array of Double) : float;
  360. function popnstddev(const data : PDouble; Const N : Integer) : float;
  361. function popnvariance(const data : PDouble; Const N : Integer) : float;
  362. function popnvariance(const data : array of Double) : float;
  363. procedure momentskewkurtosis(const data : array of Double;
  364. var m1,m2,m3,m4,skew,kurtosis : float);
  365. procedure momentskewkurtosis(const data : PDouble; Const N : Integer;
  366. var m1,m2,m3,m4,skew,kurtosis : float);
  367. { geometrical function }
  368. { returns the euclidean L2 norm }
  369. function norm(const data : array of double) : float;
  370. function norm(const data : PDouble; Const N : Integer) : float;
  371. {$endif FPC_HAS_TYPE_DOUBLE}
  372. {$ifdef FPC_HAS_TYPE_EXTENDED}
  373. { calculates the standard deviation }
  374. function stddev(const data : array of Extended) : float;
  375. function stddev(const data : PExtended; Const N : Integer) : float;
  376. { calculates the mean and stddev }
  377. procedure meanandstddev(const data : array of Extended;
  378. var mean,stddev : float);
  379. procedure meanandstddev(const data : PExtended;
  380. Const N : Longint;var mean,stddev : float);
  381. function variance(const data : array of Extended) : float;
  382. function totalvariance(const data : array of Extended) : float;
  383. function variance(const data : PExtended; Const N : Integer) : float;
  384. function totalvariance(const data : PExtended; Const N : Integer) : float;
  385. { I don't know what the following functions do: }
  386. function popnstddev(const data : array of Extended) : float;
  387. function popnstddev(const data : PExtended; Const N : Integer) : float;
  388. function popnvariance(const data : PExtended; Const N : Integer) : float;
  389. function popnvariance(const data : array of Extended) : float;
  390. procedure momentskewkurtosis(const data : array of Extended;
  391. var m1,m2,m3,m4,skew,kurtosis : float);
  392. procedure momentskewkurtosis(const data : PExtended; Const N : Integer;
  393. var m1,m2,m3,m4,skew,kurtosis : float);
  394. { geometrical function }
  395. { returns the euclidean L2 norm }
  396. function norm(const data : array of Extended) : float;
  397. function norm(const data : PExtended; Const N : Integer) : float;
  398. {$endif FPC_HAS_TYPE_EXTENDED}
  399. function ifthen(val:boolean;const iftrue:integer; const iffalse:integer= 0) :integer; {$ifdef MATHINLINE}inline; {$endif}
  400. function ifthen(val:boolean;const iftrue:int64 ; const iffalse:int64 = 0) :int64; {$ifdef MATHINLINE}inline; {$endif}
  401. function ifthen(val:boolean;const iftrue:double ; const iffalse:double =0.0):double; {$ifdef MATHINLINE}inline; {$endif}
  402. { include cpu specific stuff }
  403. {$i mathuh.inc}
  404. implementation
  405. { include cpu specific stuff }
  406. {$i mathu.inc}
  407. ResourceString
  408. SMathError = 'Math Error : %s';
  409. SInvalidArgument = 'Invalid argument';
  410. Procedure DoMathError(Const S : String);
  411. begin
  412. Raise EMathError.CreateFmt(SMathError,[S]);
  413. end;
  414. Procedure InvalidArgument;
  415. begin
  416. Raise EInvalidArgument.Create(SInvalidArgument);
  417. end;
  418. function Sign(const AValue: Integer): TValueSign;inline;
  419. begin
  420. If Avalue<0 then
  421. Result:=NegativeValue
  422. else If Avalue>0 then
  423. Result:=PositiveValue
  424. else
  425. Result:=ZeroValue;
  426. end;
  427. function Sign(const AValue: Int64): TValueSign;inline;
  428. begin
  429. If Avalue<0 then
  430. Result:=NegativeValue
  431. else If Avalue>0 then
  432. Result:=PositiveValue
  433. else
  434. Result:=ZeroValue;
  435. end;
  436. function Sign(const AValue: Double): TValueSign;inline;
  437. begin
  438. If Avalue<0.0 then
  439. Result:=NegativeValue
  440. else If Avalue>0.0 then
  441. Result:=PositiveValue
  442. else
  443. Result:=ZeroValue;
  444. end;
  445. function degtorad(deg : float) : float;
  446. begin
  447. degtorad:=deg*(pi/180.0);
  448. end;
  449. function radtodeg(rad : float) : float;
  450. begin
  451. radtodeg:=rad*(180.0/pi);
  452. end;
  453. function gradtorad(grad : float) : float;
  454. begin
  455. gradtorad:=grad*(pi/200.0);
  456. end;
  457. function radtograd(rad : float) : float;
  458. begin
  459. radtograd:=rad*(200.0/pi);
  460. end;
  461. function degtograd(deg : float) : float;
  462. begin
  463. degtograd:=deg*(200.0/180.0);
  464. end;
  465. function gradtodeg(grad : float) : float;
  466. begin
  467. gradtodeg:=grad*(180.0/200.0);
  468. end;
  469. function cycletorad(cycle : float) : float;
  470. begin
  471. cycletorad:=(2*pi)*cycle;
  472. end;
  473. function radtocycle(rad : float) : float;
  474. begin
  475. { avoid division }
  476. radtocycle:=rad*(1/(2*pi));
  477. end;
  478. function tan(x : float) : float;
  479. begin
  480. Tan:=Sin(x)/Cos(x)
  481. end;
  482. function cotan(x : float) : float;
  483. begin
  484. cotan:=Cos(X)/Sin(X);
  485. end;
  486. procedure sincos(theta : float;var sinus,cosinus : float);
  487. begin
  488. sinus:=sin(theta);
  489. cosinus:=cos(theta);
  490. end;
  491. { ArcSin and ArcCos from Arjan van Dijk ([email protected]) }
  492. function arcsin(x : float) : float;
  493. begin
  494. if abs(x) > 1 then InvalidArgument
  495. else if abs(x) < 0.5 then
  496. arcsin := arctan(x/sqrt(1-sqr(x)))
  497. else
  498. arcsin := sign(x) * (pi*0.5 - arctan(sqrt(1 / sqr(x) - 1)));
  499. end;
  500. function Arccos(x : Float) : Float;
  501. begin
  502. arccos := pi*0.5 - arcsin(x);
  503. end;
  504. {$ifndef FPC_MATH_HAS_ARCTAN2}
  505. function arctan2(y,x : float) : float;
  506. begin
  507. if (x=0) then
  508. begin
  509. if y=0 then
  510. arctan2:=0.0
  511. else if y>0 then
  512. arctan2:=pi/2
  513. else if y<0 then
  514. arctan2:=-pi/2;
  515. end
  516. else
  517. ArcTan2:=ArcTan(y/x);
  518. if x<0.0 then
  519. ArcTan2:=ArcTan2+pi;
  520. if ArcTan2>pi then
  521. ArcTan2:=ArcTan2-2*pi;
  522. end;
  523. {$endif FPC_MATH_HAS_ARCTAN2}
  524. function cosh(x : float) : float;
  525. var
  526. temp : float;
  527. begin
  528. temp:=exp(x);
  529. cosh:=0.5*(temp+1.0/temp);
  530. end;
  531. function sinh(x : float) : float;
  532. var
  533. temp : float;
  534. begin
  535. temp:=exp(x);
  536. sinh:=0.5*(temp-1.0/temp);
  537. end;
  538. Const MaxTanh = 5678.22249441322; // Ln(MaxExtended)/2
  539. function tanh(x : float) : float;
  540. var Temp : float;
  541. begin
  542. if x>MaxTanh then exit(1.0)
  543. else if x<-MaxTanh then exit (-1.0);
  544. temp:=exp(-2*x);
  545. tanh:=(1-temp)/(1+temp)
  546. end;
  547. function arccosh(x : float) : float;
  548. begin
  549. arccosh:=arcosh(x);
  550. end;
  551. function arcsinh(x : float) : float;
  552. begin
  553. arcsinh:=arsinh(x);
  554. end;
  555. function arctanh(x : float) : float;
  556. begin
  557. if x>1 then InvalidArgument;
  558. arctanh:=artanh(x);
  559. end;
  560. function arcosh(x : float) : float;
  561. begin
  562. if x<1 then InvalidArgument;
  563. arcosh:=Ln(x+Sqrt(x*x-1));
  564. end;
  565. function arsinh(x : float) : float;
  566. begin
  567. arsinh:=Ln(x+Sqrt(1+x*x));
  568. end;
  569. function artanh(x : float) : float;
  570. begin
  571. If abs(x)>1 then InvalidArgument;
  572. artanh:=(Ln((1+x)/(1-x)))*0.5;
  573. end;
  574. function hypot(x,y : float) : float;
  575. begin
  576. hypot:=Sqrt(x*x+y*y)
  577. end;
  578. function log10(x : float) : float;
  579. begin
  580. log10:=ln(x)/ln(10);
  581. end;
  582. function log2(x : float) : float;
  583. begin
  584. log2:=ln(x)/ln(2)
  585. end;
  586. function logn(n,x : float) : float;
  587. begin
  588. if n<0 then InvalidArgument;
  589. logn:=ln(x)/ln(n);
  590. end;
  591. function lnxp1(x : float) : float;
  592. begin
  593. if x<-1 then
  594. InvalidArgument;
  595. lnxp1:=ln(1+x);
  596. end;
  597. function power(base,exponent : float) : float;
  598. begin
  599. if Exponent=0.0 then
  600. if base <> 0.0 then
  601. result:=1.0
  602. else
  603. InvalidArgument
  604. else if (base=0.0) and (exponent>0.0) then
  605. result:=0.0
  606. else if (abs(exponent)<=maxint) and (frac(exponent)=0.0) then
  607. result:=intpower(base,trunc(exponent))
  608. else if base>0.0 then
  609. result:=exp(exponent * ln (base))
  610. else
  611. InvalidArgument;
  612. end;
  613. function intpower(base : float;const exponent : Integer) : float;
  614. var
  615. i : longint;
  616. begin
  617. if (base = 0.0) and (exponent = 0) then
  618. InvalidArgument;
  619. i:=abs(exponent);
  620. intpower:=1.0;
  621. while i>0 do
  622. begin
  623. while (i and 1)=0 do
  624. begin
  625. i:=i shr 1;
  626. base:=sqr(base);
  627. end;
  628. i:=i-1;
  629. intpower:=intpower*base;
  630. end;
  631. if exponent<0 then
  632. intpower:=1.0/intpower;
  633. end;
  634. operator ** (bas,expo : float) e: float;
  635. begin
  636. e:=power(bas,expo);
  637. end;
  638. operator ** (bas,expo : int64) i: int64;
  639. begin
  640. i:=round(intpower(bas,expo));
  641. end;
  642. function ceil(x : float) : integer;
  643. begin
  644. Ceil:=Trunc(x);
  645. If Frac(x)>0 then
  646. Ceil:=Ceil+1;
  647. end;
  648. function floor(x : float) : integer;
  649. begin
  650. Floor:=Trunc(x);
  651. If Frac(x)<0 then
  652. Floor := Floor-1;
  653. end;
  654. procedure Frexp(X: float; var Mantissa: float; var Exponent: integer);
  655. begin
  656. Exponent:=0;
  657. if (X<>0) then
  658. if (abs(X)<0.5) then
  659. repeat
  660. X:=X*2;
  661. Dec(Exponent);
  662. until (abs(X)>=0.5)
  663. else
  664. while (abs(X)>=1) do
  665. begin
  666. X:=X/2;
  667. Inc(Exponent);
  668. end;
  669. Mantissa:=X;
  670. end;
  671. function ldexp(x : float;const p : Integer) : float;
  672. begin
  673. ldexp:=x*intpower(2.0,p);
  674. end;
  675. {$ifdef FPC_HAS_TYPE_SINGLE}
  676. function mean(const data : array of Single) : float;
  677. begin
  678. Result:=Mean(PSingle(@data[0]),High(Data)+1);
  679. end;
  680. function mean(const data : PSingle; Const N : longint) : float;
  681. begin
  682. mean:=sum(Data,N);
  683. mean:=mean/N;
  684. end;
  685. function sum(const data : array of Single) : float;
  686. begin
  687. Result:=Sum(PSingle(@Data[0]),High(Data)+1);
  688. end;
  689. function sum(const data : PSingle;Const N : longint) : float;
  690. var
  691. i : longint;
  692. begin
  693. sum:=0.0;
  694. for i:=0 to N-1 do
  695. sum:=sum+data[i];
  696. end;
  697. {$endif FPC_HAS_TYPE_SINGLE}
  698. {$ifdef FPC_HAS_TYPE_DOUBLE}
  699. function mean(const data : array of Double) : float;
  700. begin
  701. Result:=Mean(PDouble(@data[0]),High(Data)+1);
  702. end;
  703. function mean(const data : PDouble; Const N : longint) : float;
  704. begin
  705. mean:=sum(Data,N);
  706. mean:=mean/N;
  707. end;
  708. function sum(const data : array of Double) : float;
  709. begin
  710. Result:=Sum(PDouble(@Data[0]),High(Data)+1);
  711. end;
  712. function sum(const data : PDouble;Const N : longint) : float;
  713. var
  714. i : longint;
  715. begin
  716. sum:=0.0;
  717. for i:=0 to N-1 do
  718. sum:=sum+data[i];
  719. end;
  720. {$endif FPC_HAS_TYPE_DOUBLE}
  721. {$ifdef FPC_HAS_TYPE_EXTENDED}
  722. function mean(const data : array of Extended) : float;
  723. begin
  724. Result:=Mean(PExtended(@data[0]),High(Data)+1);
  725. end;
  726. function mean(const data : PExtended; Const N : longint) : float;
  727. begin
  728. mean:=sum(Data,N);
  729. mean:=mean/N;
  730. end;
  731. function sum(const data : array of Extended) : float;
  732. begin
  733. Result:=Sum(PExtended(@Data[0]),High(Data)+1);
  734. end;
  735. function sum(const data : PExtended;Const N : longint) : float;
  736. var
  737. i : longint;
  738. begin
  739. sum:=0.0;
  740. for i:=0 to N-1 do
  741. sum:=sum+data[i];
  742. end;
  743. {$endif FPC_HAS_TYPE_EXTENDED}
  744. function sumInt(const data : PInt64;Const N : longint) : Int64;
  745. var
  746. i : longint;
  747. begin
  748. sumInt:=0;
  749. for i:=0 to N-1 do
  750. sumInt:=sumInt+data[i];
  751. end;
  752. function sumInt(const data : array of Int64) : Int64;
  753. begin
  754. Result:=SumInt(@Data[0],High(Data)+1);
  755. end;
  756. {$ifdef FPC_HAS_TYPE_SINGLE}
  757. function sumofsquares(const data : array of Single) : float;
  758. begin
  759. Result:=sumofsquares(PSingle(@data[0]),High(Data)+1);
  760. end;
  761. function sumofsquares(const data : PSingle; Const N : Integer) : float;
  762. var
  763. i : longint;
  764. begin
  765. sumofsquares:=0.0;
  766. for i:=0 to N-1 do
  767. sumofsquares:=sumofsquares+sqr(data[i]);
  768. end;
  769. procedure sumsandsquares(const data : array of Single;
  770. var sum,sumofsquares : float);
  771. begin
  772. sumsandsquares (PSingle(@Data[0]),High(Data)+1,Sum,sumofsquares);
  773. end;
  774. procedure sumsandsquares(const data : PSingle; Const N : Integer;
  775. var sum,sumofsquares : float);
  776. var
  777. i : Integer;
  778. temp : float;
  779. begin
  780. sumofsquares:=0.0;
  781. sum:=0.0;
  782. for i:=0 to N-1 do
  783. begin
  784. temp:=data[i];
  785. sumofsquares:=sumofsquares+sqr(temp);
  786. sum:=sum+temp;
  787. end;
  788. end;
  789. {$endif FPC_HAS_TYPE_SINGLE}
  790. {$ifdef FPC_HAS_TYPE_DOUBLE}
  791. function sumofsquares(const data : array of Double) : float;
  792. begin
  793. Result:=sumofsquares(PDouble(@data[0]),High(Data)+1);
  794. end;
  795. function sumofsquares(const data : PDouble; Const N : Integer) : float;
  796. var
  797. i : longint;
  798. begin
  799. sumofsquares:=0.0;
  800. for i:=0 to N-1 do
  801. sumofsquares:=sumofsquares+sqr(data[i]);
  802. end;
  803. procedure sumsandsquares(const data : array of Double;
  804. var sum,sumofsquares : float);
  805. begin
  806. sumsandsquares (PDouble(@Data[0]),High(Data)+1,Sum,sumofsquares);
  807. end;
  808. procedure sumsandsquares(const data : PDouble; Const N : Integer;
  809. var sum,sumofsquares : float);
  810. var
  811. i : Integer;
  812. temp : float;
  813. begin
  814. sumofsquares:=0.0;
  815. sum:=0.0;
  816. for i:=0 to N-1 do
  817. begin
  818. temp:=data[i];
  819. sumofsquares:=sumofsquares+sqr(temp);
  820. sum:=sum+temp;
  821. end;
  822. end;
  823. {$endif FPC_HAS_TYPE_DOUBLE}
  824. {$ifdef FPC_HAS_TYPE_EXTENDED}
  825. function sumofsquares(const data : array of Extended) : float;
  826. begin
  827. Result:=sumofsquares(PExtended(@data[0]),High(Data)+1);
  828. end;
  829. function sumofsquares(const data : PExtended; Const N : Integer) : float;
  830. var
  831. i : longint;
  832. begin
  833. sumofsquares:=0.0;
  834. for i:=0 to N-1 do
  835. sumofsquares:=sumofsquares+sqr(data[i]);
  836. end;
  837. procedure sumsandsquares(const data : array of Extended;
  838. var sum,sumofsquares : float);
  839. begin
  840. sumsandsquares (PExtended(@Data[0]),High(Data)+1,Sum,sumofsquares);
  841. end;
  842. procedure sumsandsquares(const data : PExtended; Const N : Integer;
  843. var sum,sumofsquares : float);
  844. var
  845. i : Integer;
  846. temp : float;
  847. begin
  848. sumofsquares:=0.0;
  849. sum:=0.0;
  850. for i:=0 to N-1 do
  851. begin
  852. temp:=data[i];
  853. sumofsquares:=sumofsquares+sqr(temp);
  854. sum:=sum+temp;
  855. end;
  856. end;
  857. {$endif FPC_HAS_TYPE_EXTENDED}
  858. function randg(mean,stddev : float) : float;
  859. Var U1,S2 : Float;
  860. begin
  861. repeat
  862. u1:= 2*random-1;
  863. S2:=Sqr(U1)+sqr(2*random-1);
  864. until s2<1;
  865. randg:=Sqrt(-2*ln(S2)/S2)*u1*stddev+Mean;
  866. end;
  867. {$ifdef FPC_HAS_TYPE_SINGLE}
  868. function stddev(const data : array of Single) : float;
  869. begin
  870. Result:=Stddev(PSingle(@Data[0]),High(Data)+1)
  871. end;
  872. function stddev(const data : PSingle; Const N : Integer) : float;
  873. begin
  874. StdDev:=Sqrt(Variance(Data,N));
  875. end;
  876. procedure meanandstddev(const data : array of Single;
  877. var mean,stddev : float);
  878. begin
  879. Meanandstddev(PSingle(@Data[0]),High(Data)+1,Mean,stddev);
  880. end;
  881. procedure meanandstddev(const data : PSingle;
  882. Const N : Longint;var mean,stddev : float);
  883. Var I : longint;
  884. begin
  885. Mean:=0;
  886. StdDev:=0;
  887. For I:=0 to N-1 do
  888. begin
  889. Mean:=Mean+Data[i];
  890. StdDev:=StdDev+Sqr(Data[i]);
  891. end;
  892. Mean:=Mean/N;
  893. StdDev:=(StdDev-N*Sqr(Mean));
  894. If N>1 then
  895. StdDev:=Sqrt(Stddev/(N-1))
  896. else
  897. StdDev:=0;
  898. end;
  899. function variance(const data : array of Single) : float;
  900. begin
  901. Variance:=Variance(PSingle(@Data[0]),High(Data)+1);
  902. end;
  903. function variance(const data : PSingle; Const N : Integer) : float;
  904. begin
  905. If N=1 then
  906. Result:=0
  907. else
  908. Result:=TotalVariance(Data,N)/(N-1);
  909. end;
  910. function totalvariance(const data : array of Single) : float;
  911. begin
  912. Result:=TotalVariance(PSingle(@Data[0]),High(Data)+1);
  913. end;
  914. function totalvariance(const data : PSingle;Const N : Integer) : float;
  915. var S,SS : Float;
  916. begin
  917. If N=1 then
  918. Result:=0
  919. else
  920. begin
  921. SumsAndSquares(Data,N,S,SS);
  922. Result := SS-Sqr(S)/N;
  923. end;
  924. end;
  925. function popnstddev(const data : array of Single) : float;
  926. begin
  927. PopnStdDev:=Sqrt(PopnVariance(PSingle(@Data[0]),High(Data)+1));
  928. end;
  929. function popnstddev(const data : PSingle; Const N : Integer) : float;
  930. begin
  931. PopnStdDev:=Sqrt(PopnVariance(Data,N));
  932. end;
  933. function popnvariance(const data : array of Single) : float;
  934. begin
  935. popnvariance:=popnvariance(PSingle(@data[0]),high(Data)+1);
  936. end;
  937. function popnvariance(const data : PSingle; Const N : Integer) : float;
  938. begin
  939. PopnVariance:=TotalVariance(Data,N)/N;
  940. end;
  941. procedure momentskewkurtosis(const data : array of Single;
  942. var m1,m2,m3,m4,skew,kurtosis : float);
  943. begin
  944. momentskewkurtosis(PSingle(@Data[0]),High(Data)+1,m1,m2,m3,m4,skew,kurtosis);
  945. end;
  946. procedure momentskewkurtosis(const data : PSingle; Const N : Integer;
  947. var m1,m2,m3,m4,skew,kurtosis : float);
  948. Var S,SS,SC,SQ,invN,Acc,M1S,S2N,S3N,temp : Float;
  949. I : Longint;
  950. begin
  951. invN:=1.0/N;
  952. s:=0;
  953. ss:=0;
  954. sq:=0;
  955. sc:=0;
  956. for i:=0 to N-1 do
  957. begin
  958. temp:=Data[i]; { faster }
  959. S:=S+temp;
  960. acc:=sqr(temp);
  961. ss:=ss+acc;
  962. Acc:=acc*temp;
  963. Sc:=sc+acc;
  964. acc:=acc*temp;
  965. sq:=sq+acc;
  966. end;
  967. M1:=s*invN;
  968. M1S:=sqr(M1);
  969. S2N:=SS*invN;
  970. S3N:=SC*invN;
  971. M2:=S2N-M1S;
  972. M3:=S3N-(M1*3*S2N) + 2*M1S*M1;
  973. M4:=SQ*invN - (M1 * 4 * S3N) + (M1S*6*S2N-3*Sqr(M1S));
  974. Skew:=M3*power(M2,-3/2);
  975. Kurtosis:=M4 / Sqr(M2);
  976. end;
  977. function norm(const data : array of Single) : float;
  978. begin
  979. norm:=Norm(PSingle(@data[0]),High(Data)+1);
  980. end;
  981. function norm(const data : PSingle; Const N : Integer) : float;
  982. begin
  983. norm:=sqrt(sumofsquares(data,N));
  984. end;
  985. {$endif FPC_HAS_TYPE_SINGLE}
  986. {$ifdef FPC_HAS_TYPE_DOUBLE}
  987. function stddev(const data : array of Double) : float;
  988. begin
  989. Result:=Stddev(PDouble(@Data[0]),High(Data)+1)
  990. end;
  991. function stddev(const data : PDouble; Const N : Integer) : float;
  992. begin
  993. StdDev:=Sqrt(Variance(Data,N));
  994. end;
  995. procedure meanandstddev(const data : array of Double;
  996. var mean,stddev : float);
  997. begin
  998. Meanandstddev(PDouble(@Data[0]),High(Data)+1,Mean,stddev);
  999. end;
  1000. procedure meanandstddev(const data : PDouble;
  1001. Const N : Longint;var mean,stddev : float);
  1002. Var I : longint;
  1003. begin
  1004. Mean:=0;
  1005. StdDev:=0;
  1006. For I:=0 to N-1 do
  1007. begin
  1008. Mean:=Mean+Data[i];
  1009. StdDev:=StdDev+Sqr(Data[i]);
  1010. end;
  1011. Mean:=Mean/N;
  1012. StdDev:=(StdDev-N*Sqr(Mean));
  1013. If N>1 then
  1014. StdDev:=Sqrt(Stddev/(N-1))
  1015. else
  1016. StdDev:=0;
  1017. end;
  1018. function variance(const data : array of Double) : float;
  1019. begin
  1020. Variance:=Variance(PDouble(@Data[0]),High(Data)+1);
  1021. end;
  1022. function variance(const data : PDouble; Const N : Integer) : float;
  1023. begin
  1024. If N=1 then
  1025. Result:=0
  1026. else
  1027. Result:=TotalVariance(Data,N)/(N-1);
  1028. end;
  1029. function totalvariance(const data : array of Double) : float;
  1030. begin
  1031. Result:=TotalVariance(PDouble(@Data[0]),High(Data)+1);
  1032. end;
  1033. function totalvariance(const data : PDouble;Const N : Integer) : float;
  1034. var S,SS : Float;
  1035. begin
  1036. If N=1 then
  1037. Result:=0
  1038. else
  1039. begin
  1040. SumsAndSquares(Data,N,S,SS);
  1041. Result := SS-Sqr(S)/N;
  1042. end;
  1043. end;
  1044. function popnstddev(const data : array of Double) : float;
  1045. begin
  1046. PopnStdDev:=Sqrt(PopnVariance(PDouble(@Data[0]),High(Data)+1));
  1047. end;
  1048. function popnstddev(const data : PDouble; Const N : Integer) : float;
  1049. begin
  1050. PopnStdDev:=Sqrt(PopnVariance(Data,N));
  1051. end;
  1052. function popnvariance(const data : array of Double) : float;
  1053. begin
  1054. popnvariance:=popnvariance(PDouble(@data[0]),high(Data)+1);
  1055. end;
  1056. function popnvariance(const data : PDouble; Const N : Integer) : float;
  1057. begin
  1058. PopnVariance:=TotalVariance(Data,N)/N;
  1059. end;
  1060. procedure momentskewkurtosis(const data : array of Double;
  1061. var m1,m2,m3,m4,skew,kurtosis : float);
  1062. begin
  1063. momentskewkurtosis(PDouble(@Data[0]),High(Data)+1,m1,m2,m3,m4,skew,kurtosis);
  1064. end;
  1065. procedure momentskewkurtosis(const data : PDouble; Const N : Integer;
  1066. var m1,m2,m3,m4,skew,kurtosis : float);
  1067. Var S,SS,SC,SQ,invN,Acc,M1S,S2N,S3N,temp : Float;
  1068. I : Longint;
  1069. begin
  1070. invN:=1.0/N;
  1071. s:=0;
  1072. ss:=0;
  1073. sq:=0;
  1074. sc:=0;
  1075. for i:=0 to N-1 do
  1076. begin
  1077. temp:=Data[i]; { faster }
  1078. S:=S+temp;
  1079. acc:=sqr(temp);
  1080. ss:=ss+acc;
  1081. Acc:=acc*temp;
  1082. Sc:=sc+acc;
  1083. acc:=acc*temp;
  1084. sq:=sq+acc;
  1085. end;
  1086. M1:=s*invN;
  1087. M1S:=sqr(M1);
  1088. S2N:=SS*invN;
  1089. S3N:=SC*invN;
  1090. M2:=S2N-M1S;
  1091. M3:=S3N-(M1*3*S2N) + 2*M1S*M1;
  1092. M4:=SQ*invN - (M1 * 4 * S3N) + (M1S*6*S2N-3*Sqr(M1S));
  1093. Skew:=M3*power(M2,-3/2);
  1094. Kurtosis:=M4 / Sqr(M2);
  1095. end;
  1096. function norm(const data : array of Double) : float;
  1097. begin
  1098. norm:=Norm(PDouble(@data[0]),High(Data)+1);
  1099. end;
  1100. function norm(const data : PDouble; Const N : Integer) : float;
  1101. begin
  1102. norm:=sqrt(sumofsquares(data,N));
  1103. end;
  1104. {$endif FPC_HAS_TYPE_DOUBLE}
  1105. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1106. function stddev(const data : array of Extended) : float;
  1107. begin
  1108. Result:=Stddev(PExtended(@Data[0]),High(Data)+1)
  1109. end;
  1110. function stddev(const data : PExtended; Const N : Integer) : float;
  1111. begin
  1112. StdDev:=Sqrt(Variance(Data,N));
  1113. end;
  1114. procedure meanandstddev(const data : array of Extended;
  1115. var mean,stddev : float);
  1116. begin
  1117. Meanandstddev(PExtended(@Data[0]),High(Data)+1,Mean,stddev);
  1118. end;
  1119. procedure meanandstddev(const data : PExtended;
  1120. Const N : Longint;var mean,stddev : float);
  1121. Var I : longint;
  1122. begin
  1123. Mean:=0;
  1124. StdDev:=0;
  1125. For I:=0 to N-1 do
  1126. begin
  1127. Mean:=Mean+Data[i];
  1128. StdDev:=StdDev+Sqr(Data[i]);
  1129. end;
  1130. Mean:=Mean/N;
  1131. StdDev:=(StdDev-N*Sqr(Mean));
  1132. If N>1 then
  1133. StdDev:=Sqrt(Stddev/(N-1))
  1134. else
  1135. StdDev:=0;
  1136. end;
  1137. function variance(const data : array of Extended) : float;
  1138. begin
  1139. Variance:=Variance(PExtended(@Data[0]),High(Data)+1);
  1140. end;
  1141. function variance(const data : PExtended; Const N : Integer) : float;
  1142. begin
  1143. If N=1 then
  1144. Result:=0
  1145. else
  1146. Result:=TotalVariance(Data,N)/(N-1);
  1147. end;
  1148. function totalvariance(const data : array of Extended) : float;
  1149. begin
  1150. Result:=TotalVariance(PExtended(@Data[0]),High(Data)+1);
  1151. end;
  1152. function totalvariance(const data : PExtended;Const N : Integer) : float;
  1153. var S,SS : Float;
  1154. begin
  1155. If N=1 then
  1156. Result:=0
  1157. else
  1158. begin
  1159. SumsAndSquares(Data,N,S,SS);
  1160. Result := SS-Sqr(S)/N;
  1161. end;
  1162. end;
  1163. function popnstddev(const data : array of Extended) : float;
  1164. begin
  1165. PopnStdDev:=Sqrt(PopnVariance(PExtended(@Data[0]),High(Data)+1));
  1166. end;
  1167. function popnstddev(const data : PExtended; Const N : Integer) : float;
  1168. begin
  1169. PopnStdDev:=Sqrt(PopnVariance(Data,N));
  1170. end;
  1171. function popnvariance(const data : array of Extended) : float;
  1172. begin
  1173. popnvariance:=popnvariance(PExtended(@data[0]),high(Data)+1);
  1174. end;
  1175. function popnvariance(const data : PExtended; Const N : Integer) : float;
  1176. begin
  1177. PopnVariance:=TotalVariance(Data,N)/N;
  1178. end;
  1179. procedure momentskewkurtosis(const data : array of Extended;
  1180. var m1,m2,m3,m4,skew,kurtosis : float);
  1181. begin
  1182. momentskewkurtosis(PExtended(@Data[0]),High(Data)+1,m1,m2,m3,m4,skew,kurtosis);
  1183. end;
  1184. procedure momentskewkurtosis(const data : PExtended; Const N : Integer;
  1185. var m1,m2,m3,m4,skew,kurtosis : float);
  1186. Var S,SS,SC,SQ,invN,Acc,M1S,S2N,S3N,temp : Float;
  1187. I : Longint;
  1188. begin
  1189. invN:=1.0/N;
  1190. s:=0;
  1191. ss:=0;
  1192. sq:=0;
  1193. sc:=0;
  1194. for i:=0 to N-1 do
  1195. begin
  1196. temp:=Data[i]; { faster }
  1197. S:=S+temp;
  1198. acc:=sqr(temp);
  1199. ss:=ss+acc;
  1200. Acc:=acc*temp;
  1201. Sc:=sc+acc;
  1202. acc:=acc*temp;
  1203. sq:=sq+acc;
  1204. end;
  1205. M1:=s*invN;
  1206. M1S:=sqr(M1);
  1207. S2N:=SS*invN;
  1208. S3N:=SC*invN;
  1209. M2:=S2N-M1S;
  1210. M3:=S3N-(M1*3*S2N) + 2*M1S*M1;
  1211. M4:=SQ*invN - (M1 * 4 * S3N) + (M1S*6*S2N-3*Sqr(M1S));
  1212. Skew:=M3*power(M2,-3/2);
  1213. Kurtosis:=M4 / Sqr(M2);
  1214. end;
  1215. function norm(const data : array of Extended) : float;
  1216. begin
  1217. norm:=Norm(PExtended(@data[0]),High(Data)+1);
  1218. end;
  1219. function norm(const data : PExtended; Const N : Integer) : float;
  1220. begin
  1221. norm:=sqrt(sumofsquares(data,N));
  1222. end;
  1223. {$endif FPC_HAS_TYPE_EXTENDED}
  1224. function MinIntValue(const Data: array of Integer): Integer;
  1225. var
  1226. I: Integer;
  1227. begin
  1228. Result := Data[Low(Data)];
  1229. For I := Succ(Low(Data)) To High(Data) Do
  1230. If Data[I] < Result Then Result := Data[I];
  1231. end;
  1232. function MaxIntValue(const Data: array of Integer): Integer;
  1233. var
  1234. I: Integer;
  1235. begin
  1236. Result := Data[Low(Data)];
  1237. For I := Succ(Low(Data)) To High(Data) Do
  1238. If Data[I] > Result Then Result := Data[I];
  1239. end;
  1240. function MinValue(const Data: array of Integer): Integer;
  1241. begin
  1242. Result:=MinValue(Pinteger(@Data[0]),High(Data)+1)
  1243. end;
  1244. function MinValue(const Data: PInteger; Const N : Integer): Integer;
  1245. var
  1246. I: Integer;
  1247. begin
  1248. Result := Data[0];
  1249. For I := 1 To N-1 do
  1250. If Data[I] < Result Then Result := Data[I];
  1251. end;
  1252. function MaxValue(const Data: array of Integer): Integer;
  1253. begin
  1254. Result:=MaxValue(PInteger(@Data[0]),High(Data)+1)
  1255. end;
  1256. function maxvalue(const data : PInteger; Const N : Integer) : Integer;
  1257. var
  1258. i : longint;
  1259. begin
  1260. { get an initial value }
  1261. maxvalue:=data[0];
  1262. for i:=1 to N-1 do
  1263. if data[i]>maxvalue then
  1264. maxvalue:=data[i];
  1265. end;
  1266. {$ifdef FPC_HAS_TYPE_SINGLE}
  1267. function minvalue(const data : array of Single) : Single;
  1268. begin
  1269. Result:=minvalue(PSingle(@data[0]),High(Data)+1);
  1270. end;
  1271. function minvalue(const data : PSingle; Const N : Integer) : Single;
  1272. var
  1273. i : longint;
  1274. begin
  1275. { get an initial value }
  1276. minvalue:=data[0];
  1277. for i:=1 to N-1 do
  1278. if data[i]<minvalue then
  1279. minvalue:=data[i];
  1280. end;
  1281. function maxvalue(const data : array of Single) : Single;
  1282. begin
  1283. Result:=maxvalue(PSingle(@data[0]),High(Data)+1);
  1284. end;
  1285. function maxvalue(const data : PSingle; Const N : Integer) : Single;
  1286. var
  1287. i : longint;
  1288. begin
  1289. { get an initial value }
  1290. maxvalue:=data[0];
  1291. for i:=1 to N-1 do
  1292. if data[i]>maxvalue then
  1293. maxvalue:=data[i];
  1294. end;
  1295. {$endif FPC_HAS_TYPE_SINGLE}
  1296. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1297. function minvalue(const data : array of Double) : Double;
  1298. begin
  1299. Result:=minvalue(PDouble(@data[0]),High(Data)+1);
  1300. end;
  1301. function minvalue(const data : PDouble; Const N : Integer) : Double;
  1302. var
  1303. i : longint;
  1304. begin
  1305. { get an initial value }
  1306. minvalue:=data[0];
  1307. for i:=1 to N-1 do
  1308. if data[i]<minvalue then
  1309. minvalue:=data[i];
  1310. end;
  1311. function maxvalue(const data : array of Double) : Double;
  1312. begin
  1313. Result:=maxvalue(PDouble(@data[0]),High(Data)+1);
  1314. end;
  1315. function maxvalue(const data : PDouble; Const N : Integer) : Double;
  1316. var
  1317. i : longint;
  1318. begin
  1319. { get an initial value }
  1320. maxvalue:=data[0];
  1321. for i:=1 to N-1 do
  1322. if data[i]>maxvalue then
  1323. maxvalue:=data[i];
  1324. end;
  1325. {$endif FPC_HAS_TYPE_DOUBLE}
  1326. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1327. function minvalue(const data : array of Extended) : Extended;
  1328. begin
  1329. Result:=minvalue(PExtended(@data[0]),High(Data)+1);
  1330. end;
  1331. function minvalue(const data : PExtended; Const N : Integer) : Extended;
  1332. var
  1333. i : longint;
  1334. begin
  1335. { get an initial value }
  1336. minvalue:=data[0];
  1337. for i:=1 to N-1 do
  1338. if data[i]<minvalue then
  1339. minvalue:=data[i];
  1340. end;
  1341. function maxvalue(const data : array of Extended) : Extended;
  1342. begin
  1343. Result:=maxvalue(PExtended(@data[0]),High(Data)+1);
  1344. end;
  1345. function maxvalue(const data : PExtended; Const N : Integer) : Extended;
  1346. var
  1347. i : longint;
  1348. begin
  1349. { get an initial value }
  1350. maxvalue:=data[0];
  1351. for i:=1 to N-1 do
  1352. if data[i]>maxvalue then
  1353. maxvalue:=data[i];
  1354. end;
  1355. {$endif FPC_HAS_TYPE_EXTENDED}
  1356. function Min(a, b: Integer): Integer;inline;
  1357. begin
  1358. if a < b then
  1359. Result := a
  1360. else
  1361. Result := b;
  1362. end;
  1363. function Max(a, b: Integer): Integer;inline;
  1364. begin
  1365. if a > b then
  1366. Result := a
  1367. else
  1368. Result := b;
  1369. end;
  1370. {
  1371. function Min(a, b: Cardinal): Cardinal;inline;
  1372. begin
  1373. if a < b then
  1374. Result := a
  1375. else
  1376. Result := b;
  1377. end;
  1378. function Max(a, b: Cardinal): Cardinal;inline;
  1379. begin
  1380. if a > b then
  1381. Result := a
  1382. else
  1383. Result := b;
  1384. end;
  1385. }
  1386. function Min(a, b: Int64): Int64;inline;
  1387. begin
  1388. if a < b then
  1389. Result := a
  1390. else
  1391. Result := b;
  1392. end;
  1393. function Max(a, b: Int64): Int64;inline;
  1394. begin
  1395. if a > b then
  1396. Result := a
  1397. else
  1398. Result := b;
  1399. end;
  1400. {$ifdef FPC_HAS_TYPE_SINGLE}
  1401. function Min(a, b: Single): Single;inline;
  1402. begin
  1403. if a < b then
  1404. Result := a
  1405. else
  1406. Result := b;
  1407. end;
  1408. function Max(a, b: Single): Single;inline;
  1409. begin
  1410. if a > b then
  1411. Result := a
  1412. else
  1413. Result := b;
  1414. end;
  1415. {$endif FPC_HAS_TYPE_SINGLE}
  1416. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1417. function Min(a, b: Double): Double;inline;
  1418. begin
  1419. if a < b then
  1420. Result := a
  1421. else
  1422. Result := b;
  1423. end;
  1424. function Max(a, b: Double): Double;inline;
  1425. begin
  1426. if a > b then
  1427. Result := a
  1428. else
  1429. Result := b;
  1430. end;
  1431. {$endif FPC_HAS_TYPE_DOUBLE}
  1432. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1433. function Min(a, b: Extended): Extended;inline;
  1434. begin
  1435. if a < b then
  1436. Result := a
  1437. else
  1438. Result := b;
  1439. end;
  1440. function Max(a, b: Extended): Extended;inline;
  1441. begin
  1442. if a > b then
  1443. Result := a
  1444. else
  1445. Result := b;
  1446. end;
  1447. {$endif FPC_HAS_TYPE_EXTENDED}
  1448. function InRange(const AValue, AMin, AMax: Integer): Boolean;inline;
  1449. begin
  1450. Result:=(AValue>=AMin) and (AValue<=AMax);
  1451. end;
  1452. function InRange(const AValue, AMin, AMax: Int64): Boolean;inline;
  1453. begin
  1454. Result:=(AValue>=AMin) and (AValue<=AMax);
  1455. end;
  1456. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1457. function InRange(const AValue, AMin, AMax: Double): Boolean;inline;
  1458. begin
  1459. Result:=(AValue>=AMin) and (AValue<=AMax);
  1460. end;
  1461. {$endif FPC_HAS_TYPE_DOUBLE}
  1462. function EnsureRange(const AValue, AMin, AMax: Integer): Integer;inline;
  1463. begin
  1464. Result:=AValue;
  1465. If Result<AMin then
  1466. Result:=AMin
  1467. else if Result>AMax then
  1468. Result:=AMax;
  1469. end;
  1470. function EnsureRange(const AValue, AMin, AMax: Int64): Int64;inline;
  1471. begin
  1472. Result:=AValue;
  1473. If Result<AMin then
  1474. Result:=AMin
  1475. else if Result>AMax then
  1476. Result:=AMax;
  1477. end;
  1478. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1479. function EnsureRange(const AValue, AMin, AMax: Double): Double;inline;
  1480. begin
  1481. Result:=AValue;
  1482. If Result<AMin then
  1483. Result:=AMin
  1484. else if Result>AMax then
  1485. Result:=AMax;
  1486. end;
  1487. {$endif FPC_HAS_TYPE_DOUBLE}
  1488. Const
  1489. EZeroResolution = 1E-16;
  1490. DZeroResolution = 1E-12;
  1491. SZeroResolution = 1E-4;
  1492. function IsZero(const A: Single; Epsilon: Single): Boolean;
  1493. begin
  1494. if (Epsilon=0) then
  1495. Epsilon:=SZeroResolution;
  1496. Result:=Abs(A)<=Epsilon;
  1497. end;
  1498. function IsZero(const A: Single): Boolean;inline;
  1499. begin
  1500. Result:=IsZero(A,single(SZeroResolution));
  1501. end;
  1502. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1503. function IsZero(const A: Double; Epsilon: Double): Boolean;
  1504. begin
  1505. if (Epsilon=0) then
  1506. Epsilon:=DZeroResolution;
  1507. Result:=Abs(A)<=Epsilon;
  1508. end;
  1509. function IsZero(const A: Double): Boolean;inline;
  1510. begin
  1511. Result:=IsZero(A,DZeroResolution);
  1512. end;
  1513. {$endif FPC_HAS_TYPE_DOUBLE}
  1514. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1515. function IsZero(const A: Extended; Epsilon: Extended): Boolean;
  1516. begin
  1517. if (Epsilon=0) then
  1518. Epsilon:=EZeroResolution;
  1519. Result:=Abs(A)<=Epsilon;
  1520. end;
  1521. function IsZero(const A: Extended): Boolean;inline;
  1522. begin
  1523. Result:=IsZero(A,EZeroResolution);
  1524. end;
  1525. {$endif FPC_HAS_TYPE_EXTENDED}
  1526. type
  1527. TSplitDouble = packed record
  1528. cards: Array[0..1] of cardinal;
  1529. end;
  1530. function IsNan(const d : Double): Boolean;
  1531. var
  1532. fraczero, expMaximal: boolean;
  1533. begin
  1534. {$if defined(FPC_BIG_ENDIAN) or (defined(CPUARM) and defined(FPUFPA))}
  1535. expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
  1536. fraczero:= (TSplitDouble(d).cards[0] and $fffff = 0) and
  1537. (TSplitDouble(d).cards[1] = 0);
  1538. {$else FPC_BIG_ENDIAN}
  1539. expMaximal := ((TSplitDouble(d).cards[1] shr 20) and $7ff) = 2047;
  1540. fraczero := (TSplitDouble(d).cards[1] and $fffff = 0) and
  1541. (TSplitDouble(d).cards[0] = 0);
  1542. {$endif FPC_BIG_ENDIAN}
  1543. Result:=expMaximal and not(fraczero);
  1544. end;
  1545. function IsInfinite(const d : Double): Boolean;
  1546. var
  1547. fraczero, expMaximal: boolean;
  1548. begin
  1549. {$if defined(FPC_BIG_ENDIAN) or (defined(CPUARM) and defined(FPUFPA))}
  1550. expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
  1551. fraczero:= (TSplitDouble(d).cards[0] and $fffff = 0) and
  1552. (TSplitDouble(d).cards[1] = 0);
  1553. {$else FPC_BIG_ENDIAN}
  1554. expMaximal := ((TSplitDouble(d).cards[1] shr 20) and $7ff) = 2047;
  1555. fraczero := (TSplitDouble(d).cards[1] and $fffff = 0) and
  1556. (TSplitDouble(d).cards[0] = 0);
  1557. {$endif FPC_BIG_ENDIAN}
  1558. Result:=expMaximal and fraczero;
  1559. end;
  1560. {$ifdef FPC_HAS_TYPE_EXTENDED}
  1561. function SameValue(const A, B: Extended; Epsilon: Extended): Boolean;
  1562. begin
  1563. if (Epsilon=0) then
  1564. Epsilon:=Max(Min(Abs(A),Abs(B))*EZeroResolution,EZeroResolution);
  1565. if (A>B) then
  1566. Result:=((A-B)<=Epsilon)
  1567. else
  1568. Result:=((B-A)<=Epsilon);
  1569. end;
  1570. function SameValue(const A, B: Extended): Boolean;inline;
  1571. begin
  1572. Result:=SameValue(A,B,0);
  1573. end;
  1574. {$endif FPC_HAS_TYPE_EXTENDED}
  1575. {$ifdef FPC_HAS_TYPE_DOUBLE}
  1576. function SameValue(const A, B: Double): Boolean;inline;
  1577. begin
  1578. Result:=SameValue(A,B,0);
  1579. end;
  1580. function SameValue(const A, B: Double; Epsilon: Double): Boolean;
  1581. begin
  1582. if (Epsilon=0) then
  1583. Epsilon:=Max(Min(Abs(A),Abs(B))*DZeroResolution,DZeroResolution);
  1584. if (A>B) then
  1585. Result:=((A-B)<=Epsilon)
  1586. else
  1587. Result:=((B-A)<=Epsilon);
  1588. end;
  1589. {$endif FPC_HAS_TYPE_DOUBLE}
  1590. function SameValue(const A, B: Single): Boolean;inline;
  1591. begin
  1592. Result:=SameValue(A,B,0);
  1593. end;
  1594. function SameValue(const A, B: Single; Epsilon: Single): Boolean;
  1595. begin
  1596. if (Epsilon=0) then
  1597. Epsilon:=Max(Min(Abs(A),Abs(B))*SZeroResolution,SZeroResolution);
  1598. if (A>B) then
  1599. Result:=((A-B)<=Epsilon)
  1600. else
  1601. Result:=((B-A)<=Epsilon);
  1602. end;
  1603. // Some CPUs probably allow a faster way of doing this in a single operation...
  1604. // There weshould define CPUDIVMOD in the header mathuh.inc and implement it using asm.
  1605. {$ifndef CPUDIVMOD}
  1606. procedure DivMod(Dividend: Integer; Divisor: Word; var Result, Remainder: Word);
  1607. begin
  1608. Result:=Dividend Div Divisor;
  1609. Remainder:=Dividend Mod Divisor;
  1610. end;
  1611. {$endif}
  1612. function ifthen(val:boolean;const iftrue:integer; const iffalse:integer= 0) :integer;
  1613. begin
  1614. if val then result:=iftrue else result:=iffalse;
  1615. end;
  1616. function ifthen(val:boolean;const iftrue:int64 ; const iffalse:int64 = 0) :int64;
  1617. begin
  1618. if val then result:=iftrue else result:=iffalse;
  1619. end;
  1620. function ifthen(val:boolean;const iftrue:double ; const iffalse:double =0.0):double;
  1621. begin
  1622. if val then result:=iftrue else result:=iffalse;
  1623. end;
  1624. end.