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
8097	maxcodehac	4	Copyright (c) 2013-2014, 2018-2020 Anton Krotov
		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
7693	akron1	274	x := exp(2.0 * x);
		275	x := (x - 1.0) / (x + 1.0)
7597	akron1	276	END
7693	akron1	277
		278	RETURN x
6613	leency	279	END tanh;
		280
7597	akron1	281
7693	akron1	282	PROCEDURE arsinh* (x: REAL): REAL;
		283	RETURN ln(x + sqrt(x * x + 1.0))
		284	END arsinh;
6613	leency	285
7597	akron1	286
7693	akron1	287	PROCEDURE arcosh* (x: REAL): REAL;
		288	RETURN ln(x + sqrt(x * x - 1.0))
		289	END arcosh;
6613	leency	290
7597	akron1	291
7693	akron1	292	PROCEDURE artanh* (x: REAL): REAL;
7597	akron1	293	VAR
		294	res: REAL;
		295
6613	leency	296	BEGIN
7597	akron1	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
7693	akron1	305	END artanh;
6613	leency	306
7597	akron1	307
		308	PROCEDURE floor* (x: REAL): REAL;
		309	VAR
		310	f: REAL;
		311
6613	leency	312	BEGIN
7597	akron1	313	f := frac(x);
		314	x := x - f;
		315	IF f < 0.0 THEN
		316	x := x - 1.0
		317	END
		318	RETURN x
6613	leency	319	END floor;
		320
7597	akron1	321
		322	PROCEDURE ceil* (x: REAL): REAL;
		323	VAR
		324	f: REAL;
		325
6613	leency	326	BEGIN
7597	akron1	327	f := frac(x);
		328	x := x - f;
		329	IF f > 0.0 THEN
		330	x := x + 1.0
		331	END
		332	RETURN x
6613	leency	333	END ceil;
		334
7597	akron1	335
		336	PROCEDURE power* (base, exponent: REAL): REAL;
		337	VAR
		338	res: REAL;
		339
6613	leency	340	BEGIN
7597	akron1	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
6613	leency	349	END power;
		350
7597	akron1	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
7597	akron1	386	PROCEDURE sgn* (x: REAL): INTEGER;
		387	VAR
		388	res: INTEGER;
		389
6613	leency	390	BEGIN
7597	akron1	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
7693	akron1	398
7597	akron1	399	RETURN res
6613	leency	400	END sgn;
		401
7693	akron1	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/KolibriOS/Math.ob07 – Rev 8097