WebSVN – Kolibri OS – Blame – /programs/develop/oberon07/Lib/Linux32/Math.ob07

Rev	Author	Line No.	Line
7983	leency	1	(*
8097	maxcodehac	2	BSD 2-Clause License
7983	leency	3
8097	maxcodehac	4	Copyright (c) 2013-2014, 2018-2020 Anton Krotov
		5	All rights reserved.
7983	leency	6	*)
		7
		8	MODULE Math;
		9
		10	IMPORT SYSTEM;
		11
		12
		13	CONST
		14
		15	pi* = 3.141592653589793;
		16	e* = 2.718281828459045;
		17
		18
		19	PROCEDURE IsNan* (x: REAL): BOOLEAN;
		20	VAR
		21	h, l: SET;
		22
		23	BEGIN
		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} # {}))
		27	END IsNan;
		28
		29
		30	PROCEDURE IsInf* (x: REAL): BOOLEAN;
		31	RETURN ABS(x) = SYSTEM.INF()
		32	END IsInf;
		33
		34
		35	PROCEDURE Max (a, b: REAL): REAL;
		36	VAR
		37	res: REAL;
		38
		39	BEGIN
		40	IF a > b THEN
		41	res := a
		42	ELSE
		43	res := b
		44	END
		45	RETURN res
		46	END Max;
		47
		48
		49	PROCEDURE Min (a, b: REAL): REAL;
		50	VAR
		51	res: REAL;
		52
		53	BEGIN
		54	IF a < b THEN
		55	res := a
		56	ELSE
		57	res := b
		58	END
		59	RETURN res
		60	END Min;
		61
		62
		63	PROCEDURE SameValue (a, b: REAL): BOOLEAN;
		64	VAR
		65	eps: REAL;
		66	res: BOOLEAN;
		67
		68	BEGIN
		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
		76	END SameValue;
		77
		78
		79	PROCEDURE IsZero (x: REAL): BOOLEAN;
		80	RETURN ABS(x) <= 1.0E-12
		81	END IsZero;
		82
		83
		84	PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
		85	BEGIN
		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
		93	END sqrt;
		94
		95
		96	PROCEDURE [stdcall] sin* (x: REAL): REAL;
		97	BEGIN
		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
		105	END sin;
		106
		107
		108	PROCEDURE [stdcall] cos* (x: REAL): REAL;
		109	BEGIN
		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
		117	END cos;
		118
		119
		120	PROCEDURE [stdcall] tan* (x: REAL): REAL;
		121	BEGIN
		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
		130	END tan;
		131
		132
		133	PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
		134	BEGIN
		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
		143	END arctan2;
		144
		145
		146	PROCEDURE [stdcall] ln* (x: REAL): REAL;
		147	BEGIN
		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
		156	END ln;
		157
		158
		159	PROCEDURE [stdcall] log* (base, x: REAL): REAL;
		160	BEGIN
		161	SYSTEM.CODE(
		162	0D9H, 0E8H, (* fld1 *)
		163	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
		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
		173	END log;
		174
		175
		176	PROCEDURE [stdcall] exp* (x: REAL): REAL;
		177	BEGIN
		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
		190	END exp;
		191
		192
		193	PROCEDURE [stdcall] round* (x: REAL): REAL;
		194	BEGIN
		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
		206	END round;
		207
		208
		209	PROCEDURE [stdcall] frac* (x: REAL): REAL;
		210	BEGIN
		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
		225	END frac;
		226
		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
7983	leency	238	PROCEDURE arcsin* (x: REAL): REAL;
		239	RETURN arctan2(x, sqrt(1.0 - x * x))
		240	END arcsin;
		241
		242
		243	PROCEDURE arccos* (x: REAL): REAL;
		244	RETURN arctan2(sqrt(1.0 - x * x), x)
		245	END arccos;
		246
		247
		248	PROCEDURE arctan* (x: REAL): REAL;
		249	RETURN arctan2(x, 1.0)
		250	END arctan;
		251
		252
		253	PROCEDURE sinh* (x: REAL): REAL;
		254	BEGIN
		255	x := exp(x)
		256	RETURN (x - 1.0 / x) * 0.5
		257	END sinh;
		258
		259
		260	PROCEDURE cosh* (x: REAL): REAL;
		261	BEGIN
		262	x := exp(x)
		263	RETURN (x + 1.0 / x) * 0.5
		264	END cosh;
		265
		266
		267	PROCEDURE tanh* (x: REAL): REAL;
		268	BEGIN
		269	IF x > 15.0 THEN
		270	x := 1.0
		271	ELSIF x < -15.0 THEN
		272	x := -1.0
		273	ELSE
		274	x := exp(2.0 * x);
		275	x := (x - 1.0) / (x + 1.0)
		276	END
		277
		278	RETURN x
		279	END tanh;
		280
		281
		282	PROCEDURE arsinh* (x: REAL): REAL;
		283	RETURN ln(x + sqrt(x * x + 1.0))
		284	END arsinh;
		285
		286
		287	PROCEDURE arcosh* (x: REAL): REAL;
		288	RETURN ln(x + sqrt(x * x - 1.0))
		289	END arcosh;
		290
		291
		292	PROCEDURE artanh* (x: REAL): REAL;
		293	VAR
		294	res: REAL;
		295
		296	BEGIN
		297	IF SameValue(x, 1.0) THEN
		298	res := SYSTEM.INF()
		299	ELSIF SameValue(x, -1.0) THEN
		300	res := -SYSTEM.INF()
		301	ELSE
		302	res := 0.5 * ln((1.0 + x) / (1.0 - x))
		303	END
		304	RETURN res
		305	END artanh;
		306
		307
		308	PROCEDURE floor* (x: REAL): REAL;
		309	VAR
		310	f: REAL;
		311
		312	BEGIN
		313	f := frac(x);
		314	x := x - f;
		315	IF f < 0.0 THEN
		316	x := x - 1.0
		317	END
		318	RETURN x
		319	END floor;
		320
		321
		322	PROCEDURE ceil* (x: REAL): REAL;
		323	VAR
		324	f: REAL;
		325
		326	BEGIN
		327	f := frac(x);
		328	x := x - f;
		329	IF f > 0.0 THEN
		330	x := x + 1.0
		331	END
		332	RETURN x
		333	END ceil;
		334
		335
		336	PROCEDURE power* (base, exponent: REAL): REAL;
		337	VAR
		338	res: REAL;
		339
		340	BEGIN
		341	IF exponent = 0.0 THEN
		342	res := 1.0
		343	ELSIF (base = 0.0) & (exponent > 0.0) THEN
		344	res := 0.0
		345	ELSE
		346	res := exp(exponent * ln(base))
		347	END
		348	RETURN res
		349	END power;
		350
		351
8097	maxcodehac	352	PROCEDURE ipower* (base: REAL; exponent: INTEGER): REAL;
		353	VAR
		354	i: INTEGER;
		355	a: REAL;
		356
		357	BEGIN
		358	a := 1.0;
		359
		360	IF base # 0.0 THEN
		361	IF exponent # 0 THEN
		362	IF exponent < 0 THEN
		363	base := 1.0 / base
		364	END;
		365	i := ABS(exponent);
		366	WHILE i > 0 DO
		367	WHILE ~ODD(i) DO
		368	i := LSR(i, 1);
		369	base := sqrr(base)
		370	END;
		371	DEC(i);
		372	a := a * base
		373	END
		374	ELSE
		375	a := 1.0
		376	END
		377	ELSE
		378	ASSERT(exponent > 0);
		379	a := 0.0
		380	END
		381
		382	RETURN a
		383	END ipower;
		384
		385
7983	leency	386	PROCEDURE sgn* (x: REAL): INTEGER;
		387	VAR
		388	res: INTEGER;
		389
		390	BEGIN
		391	IF x > 0.0 THEN
		392	res := 1
		393	ELSIF x < 0.0 THEN
		394	res := -1
		395	ELSE
		396	res := 0
		397	END
		398
		399	RETURN res
		400	END sgn;
		401
		402
		403	PROCEDURE fact* (n: INTEGER): REAL;
		404	VAR
		405	res: REAL;
		406
		407	BEGIN
		408	res := 1.0;
		409	WHILE n > 1 DO
		410	res := res * FLT(n);
		411	DEC(n)
		412	END
		413
		414	RETURN res
		415	END fact;
		416
		417
8097	maxcodehac	418	PROCEDURE DegToRad* (x: REAL): REAL;
		419	RETURN x * (pi / 180.0)
		420	END DegToRad;
		421
		422
		423	PROCEDURE RadToDeg* (x: REAL): REAL;
		424	RETURN x * (180.0 / pi)
		425	END RadToDeg;
		426
		427
		428	(* Return hypotenuse of triangle *)
		429	PROCEDURE hypot* (x, y: REAL): REAL;
		430	VAR
		431	a: REAL;
		432
		433	BEGIN
		434	x := ABS(x);
		435	y := ABS(y);
		436	IF x > y THEN
		437	a := x * sqrt(1.0 + sqrr(y / x))
		438	ELSE
		439	IF x > 0.0 THEN
		440	a := y * sqrt(1.0 + sqrr(x / y))
		441	ELSE
		442	a := y
		443	END
		444	END
		445
		446	RETURN a
		447	END hypot;
		448
		449
7983	leency	450	END Math.

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/Lib/Linux32/Math.ob07 – Rev 8097