WebSVN – Kolibri OS – Blame – /programs/develop/oberon07/lib/KolibriOS/Math.ob07

Rev	Author	Line No.	Line
7983	leency	1	(*
8097	maxcodehac	2	BSD 2-Clause License
6613	leency	3
9893	akron1	4	Copyright (c) 2013-2014, 2018-2022 Anton Krotov
8097	maxcodehac	5	All rights reserved.
6613	leency	6	*)
		7
		8	MODULE Math;
		9
7597	akron1	10	IMPORT SYSTEM;
6613	leency	11
		12
7597	akron1	13	CONST
6613	leency	14
7597	akron1	15	pi* = 3.141592653589793;
		16	e* = 2.718281828459045;
		17
		18
		19	PROCEDURE IsNan* (x: REAL): BOOLEAN;
		20	VAR
		21	h, l: SET;
		22
6613	leency	23	BEGIN
7597	akron1	24	SYSTEM.GET(SYSTEM.ADR(x), l);
		25	SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
		26	RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
6613	leency	27	END IsNan;
		28
7597	akron1	29
		30	PROCEDURE IsInf* (x: REAL): BOOLEAN;
		31	RETURN ABS(x) = SYSTEM.INF()
6613	leency	32	END IsInf;
		33
7597	akron1	34
		35	PROCEDURE Max (a, b: REAL): REAL;
		36	VAR
		37	res: REAL;
		38
6613	leency	39	BEGIN
7597	akron1	40	IF a > b THEN
		41	res := a
		42	ELSE
		43	res := b
		44	END
		45	RETURN res
6613	leency	46	END Max;
		47
7597	akron1	48
		49	PROCEDURE Min (a, b: REAL): REAL;
		50	VAR
		51	res: REAL;
		52
6613	leency	53	BEGIN
7597	akron1	54	IF a < b THEN
		55	res := a
		56	ELSE
		57	res := b
		58	END
		59	RETURN res
6613	leency	60	END Min;
		61
7597	akron1	62
		63	PROCEDURE SameValue (a, b: REAL): BOOLEAN;
		64	VAR
		65	eps: REAL;
		66	res: BOOLEAN;
		67
6613	leency	68	BEGIN
7597	akron1	69	eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
		70	IF a > b THEN
		71	res := (a - b) <= eps
		72	ELSE
		73	res := (b - a) <= eps
		74	END
		75	RETURN res
6613	leency	76	END SameValue;
		77
7597	akron1	78
		79	PROCEDURE IsZero (x: REAL): BOOLEAN;
		80	RETURN ABS(x) <= 1.0E-12
6613	leency	81	END IsZero;
		82
7597	akron1	83
		84	PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
6613	leency	85	BEGIN
7597	akron1	86	SYSTEM.CODE(
		87	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		88	0D9H, 0FAH, (* fsqrt *)
		89	0C9H, (* leave *)
		90	0C2H, 008H, 000H (* ret 08h *)
		91	)
		92	RETURN 0.0
6613	leency	93	END sqrt;
		94
7597	akron1	95
		96	PROCEDURE [stdcall] sin* (x: REAL): REAL;
6613	leency	97	BEGIN
7597	akron1	98	SYSTEM.CODE(
		99	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		100	0D9H, 0FEH, (* fsin *)
		101	0C9H, (* leave *)
		102	0C2H, 008H, 000H (* ret 08h *)
		103	)
		104	RETURN 0.0
6613	leency	105	END sin;
		106
7597	akron1	107
		108	PROCEDURE [stdcall] cos* (x: REAL): REAL;
6613	leency	109	BEGIN
7597	akron1	110	SYSTEM.CODE(
		111	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		112	0D9H, 0FFH, (* fcos *)
		113	0C9H, (* leave *)
		114	0C2H, 008H, 000H (* ret 08h *)
		115	)
		116	RETURN 0.0
6613	leency	117	END cos;
		118
7597	akron1	119
		120	PROCEDURE [stdcall] tan* (x: REAL): REAL;
6613	leency	121	BEGIN
7597	akron1	122	SYSTEM.CODE(
		123	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		124	0D9H, 0FBH, (* fsincos *)
		125	0DEH, 0F9H, (* fdivp st1, st *)
		126	0C9H, (* leave *)
		127	0C2H, 008H, 000H (* ret 08h *)
		128	)
		129	RETURN 0.0
6613	leency	130	END tan;
		131
7597	akron1	132
		133	PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
6613	leency	134	BEGIN
7597	akron1	135	SYSTEM.CODE(
		136	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		137	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
		138	0D9H, 0F3H, (* fpatan *)
		139	0C9H, (* leave *)
		140	0C2H, 010H, 000H (* ret 10h *)
		141	)
		142	RETURN 0.0
6613	leency	143	END arctan2;
		144
7597	akron1	145
		146	PROCEDURE [stdcall] ln* (x: REAL): REAL;
6613	leency	147	BEGIN
7597	akron1	148	SYSTEM.CODE(
		149	0D9H, 0EDH, (* fldln2 *)
		150	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		151	0D9H, 0F1H, (* fyl2x *)
		152	0C9H, (* leave *)
		153	0C2H, 008H, 000H (* ret 08h *)
		154	)
		155	RETURN 0.0
6613	leency	156	END ln;
		157
7597	akron1	158
		159	PROCEDURE [stdcall] log* (base, x: REAL): REAL;
7693	akron1	160	BEGIN
7597	akron1	161	SYSTEM.CODE(
		162	0D9H, 0E8H, (* fld1 *)
7693	akron1	163	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
7597	akron1	164	0D9H, 0F1H, (* fyl2x *)
		165	0D9H, 0E8H, (* fld1 *)
		166	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		167	0D9H, 0F1H, (* fyl2x *)
		168	0DEH, 0F9H, (* fdivp st1, st *)
		169	0C9H, (* leave *)
		170	0C2H, 010H, 000H (* ret 10h *)
		171	)
		172	RETURN 0.0
6613	leency	173	END log;
		174
7597	akron1	175
		176	PROCEDURE [stdcall] exp* (x: REAL): REAL;
6613	leency	177	BEGIN
7597	akron1	178	SYSTEM.CODE(
		179	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		180	0D9H, 0EAH, (* fldl2e *)
		181	0DEH, 0C9H, 0D9H, 0C0H,
		182	0D9H, 0FCH, 0DCH, 0E9H,
		183	0D9H, 0C9H, 0D9H, 0F0H,
		184	0D9H, 0E8H, 0DEH, 0C1H,
		185	0D9H, 0FDH, 0DDH, 0D9H,
		186	0C9H, (* leave *)
		187	0C2H, 008H, 000H (* ret 08h *)
		188	)
		189	RETURN 0.0
6613	leency	190	END exp;
		191
7597	akron1	192
		193	PROCEDURE [stdcall] round* (x: REAL): REAL;
6613	leency	194	BEGIN
7597	akron1	195	SYSTEM.CODE(
		196	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		197	0D9H, 07DH, 0F4H, 0D9H,
		198	07DH, 0F6H, 066H, 081H,
		199	04DH, 0F6H, 000H, 003H,
		200	0D9H, 06DH, 0F6H, 0D9H,
		201	0FCH, 0D9H, 06DH, 0F4H,
		202	0C9H, (* leave *)
		203	0C2H, 008H, 000H (* ret 08h *)
		204	)
		205	RETURN 0.0
6613	leency	206	END round;
		207
7597	akron1	208
		209	PROCEDURE [stdcall] frac* (x: REAL): REAL;
6613	leency	210	BEGIN
7597	akron1	211	SYSTEM.CODE(
		212	050H,
		213	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
		214	0D9H, 0C0H, 0D9H, 03CH,
		215	024H, 0D9H, 07CH, 024H,
		216	002H, 066H, 081H, 04CH,
		217	024H, 002H, 000H, 00FH,
		218	0D9H, 06CH, 024H, 002H,
		219	0D9H, 0FCH, 0D9H, 02CH,
		220	024H, 0DEH, 0E9H,
		221	0C9H, (* leave *)
		222	0C2H, 008H, 000H (* ret 08h *)
		223	)
		224	RETURN 0.0
6613	leency	225	END frac;
		226
7597	akron1	227
8097	maxcodehac	228	PROCEDURE sqri* (x: INTEGER): INTEGER;
		229	RETURN x * x
		230	END sqri;
		231
		232
		233	PROCEDURE sqrr* (x: REAL): REAL;
		234	RETURN x * x
		235	END sqrr;
		236
		237
7597	akron1	238	PROCEDURE arcsin* (x: REAL): REAL;
		239	RETURN arctan2(x, sqrt(1.0 - x * x))
6613	leency	240	END arcsin;
		241
7597	akron1	242
		243	PROCEDURE arccos* (x: REAL): REAL;
		244	RETURN arctan2(sqrt(1.0 - x * x), x)
6613	leency	245	END arccos;
		246
7597	akron1	247
		248	PROCEDURE arctan* (x: REAL): REAL;
		249	RETURN arctan2(x, 1.0)
6613	leency	250	END arctan;
		251
7597	akron1	252
		253	PROCEDURE sinh* (x: REAL): REAL;
6613	leency	254	BEGIN
7693	akron1	255	x := exp(x)
		256	RETURN (x - 1.0 / x) * 0.5
6613	leency	257	END sinh;
		258
7597	akron1	259
		260	PROCEDURE cosh* (x: REAL): REAL;
6613	leency	261	BEGIN
7693	akron1	262	x := exp(x)
		263	RETURN (x + 1.0 / x) * 0.5
6613	leency	264	END cosh;
		265
7597	akron1	266
		267	PROCEDURE tanh* (x: REAL): REAL;
6613	leency	268	BEGIN
7693	akron1	269	IF x > 15.0 THEN
		270	x := 1.0
		271	ELSIF x < -15.0 THEN
		272	x := -1.0
7597	akron1	273	ELSE
9893	akron1	274	x := 1.0 - 2.0 / (exp(2.0 * x) + 1.0)
7597	akron1	275	END
7693	akron1	276
		277	RETURN x
6613	leency	278	END tanh;
		279
7597	akron1	280
7693	akron1	281	PROCEDURE arsinh* (x: REAL): REAL;
		282	RETURN ln(x + sqrt(x * x + 1.0))
		283	END arsinh;
6613	leency	284
7597	akron1	285
7693	akron1	286	PROCEDURE arcosh* (x: REAL): REAL;
		287	RETURN ln(x + sqrt(x * x - 1.0))
		288	END arcosh;
6613	leency	289
7597	akron1	290
7693	akron1	291	PROCEDURE artanh* (x: REAL): REAL;
7597	akron1	292	VAR
		293	res: REAL;
		294
6613	leency	295	BEGIN
7597	akron1	296	IF SameValue(x, 1.0) THEN
		297	res := SYSTEM.INF()
		298	ELSIF SameValue(x, -1.0) THEN
		299	res := -SYSTEM.INF()
		300	ELSE
		301	res := 0.5 * ln((1.0 + x) / (1.0 - x))
		302	END
		303	RETURN res
7693	akron1	304	END artanh;
6613	leency	305
7597	akron1	306
		307	PROCEDURE floor* (x: REAL): REAL;
		308	VAR
		309	f: REAL;
		310
6613	leency	311	BEGIN
7597	akron1	312	f := frac(x);
		313	x := x - f;
		314	IF f < 0.0 THEN
		315	x := x - 1.0
		316	END
		317	RETURN x
6613	leency	318	END floor;
		319
7597	akron1	320
		321	PROCEDURE ceil* (x: REAL): REAL;
		322	VAR
		323	f: REAL;
		324
6613	leency	325	BEGIN
7597	akron1	326	f := frac(x);
		327	x := x - f;
		328	IF f > 0.0 THEN
		329	x := x + 1.0
		330	END
		331	RETURN x
6613	leency	332	END ceil;
		333
7597	akron1	334
		335	PROCEDURE power* (base, exponent: REAL): REAL;
		336	VAR
		337	res: REAL;
		338
6613	leency	339	BEGIN
7597	akron1	340	IF exponent = 0.0 THEN
		341	res := 1.0
		342	ELSIF (base = 0.0) & (exponent > 0.0) THEN
		343	res := 0.0
		344	ELSE
		345	res := exp(exponent * ln(base))
		346	END
		347	RETURN res
6613	leency	348	END power;
		349
7597	akron1	350
8097	maxcodehac	351	PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
		352	VAR
		353	i: INTEGER;
		354	a: REAL;
		355
		356	BEGIN
		357	a := 1.0;
		358
		359	IF base # 0.0 THEN
		360	IF exponent # 0 THEN
		361	IF exponent < 0 THEN
		362	base := 1.0 / base
		363	END;
		364	i := ABS(exponent);
		365	WHILE i > 0 DO
		366	WHILE ~ODD(i) DO
		367	i := LSR(i, 1);
		368	base := sqrr(base)
		369	END;
		370	DEC(i);
		371	a := a * base
		372	END
		373	ELSE
		374	a := 1.0
		375	END
		376	ELSE
		377	ASSERT(exponent > 0);
		378	a := 0.0
		379	END
		380
		381	RETURN a
		382	END ipower;
		383
		384
7597	akron1	385	PROCEDURE sgn* (x: REAL): INTEGER;
		386	VAR
		387	res: INTEGER;
		388
6613	leency	389	BEGIN
7597	akron1	390	IF x > 0.0 THEN
		391	res := 1
		392	ELSIF x < 0.0 THEN
		393	res := -1
		394	ELSE
		395	res := 0
		396	END
7693	akron1	397
7597	akron1	398	RETURN res
6613	leency	399	END sgn;
		400
7693	akron1	401
		402	PROCEDURE fact* (n: INTEGER): REAL;
		403	VAR
		404	res: REAL;
		405
		406	BEGIN
		407	res := 1.0;
		408	WHILE n > 1 DO
		409	res := res * FLT(n);
		410	DEC(n)
		411	END
		412
		413	RETURN res
		414	END fact;
		415
		416
8097	maxcodehac	417	PROCEDURE DegToRad* (x: REAL): REAL;
		418	RETURN x * (pi / 180.0)
		419	END DegToRad;
		420
		421
		422	PROCEDURE RadToDeg* (x: REAL): REAL;
		423	RETURN x * (180.0 / pi)
		424	END RadToDeg;
		425
		426
		427	(* Return hypotenuse of triangle *)
		428	PROCEDURE hypot* (x, y: REAL): REAL;
		429	VAR
		430	a: REAL;
		431
		432	BEGIN
		433	x := ABS(x);
		434	y := ABS(y);
		435	IF x > y THEN
		436	a := x * sqrt(1.0 + sqrr(y / x))
		437	ELSE
		438	IF x > 0.0 THEN
		439	a := y * sqrt(1.0 + sqrr(x / y))
		440	ELSE
		441	a := y
		442	END
		443	END
		444
		445	RETURN a
		446	END hypot;
		447
		448
7983	leency	449	END Math.

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/lib/KolibriOS/Math.ob07 – Rev 9893