WebSVN – Kolibri OS – Diff – /programs/develop/oberon07/Lib/KolibriOS/Math.ob07


﻿(*
    Copyright 2013, 2014, 2018, 2019 Anton Krotov
 
    This program is free software: you can redistribute it and/or modify
    it under the terms of the GNU Lesser General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.
 
    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Lesser General Public License for more details.
 
    You should have received a copy of the GNU Lesser General Public License
    along with this program.  If not, see .
*)
 
MODULE Math;
 
IMPORT SYSTEM;
 
 
CONST
 
    pi* = 3.141592653589793;
    e*  = 2.718281828459045;
 
 
PROCEDURE IsNan* (x: REAL): BOOLEAN;
VAR
    h, l: SET;
 
BEGIN
    SYSTEM.GET(SYSTEM.ADR(x), l);
    SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
    RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
END IsNan;
 
 
PROCEDURE IsInf* (x: REAL): BOOLEAN;
    RETURN ABS(x) = SYSTEM.INF()
END IsInf;
 
 
PROCEDURE Max (a, b: REAL): REAL;
VAR
    res: REAL;
 
BEGIN
    IF a > b THEN
        res := a
    ELSE
        res := b
    END
    RETURN res
END Max;
 
 
PROCEDURE Min (a, b: REAL): REAL;
VAR
    res: REAL;
 
BEGIN
    IF a < b THEN
        res := a
    ELSE
        res := b
    END
    RETURN res
END Min;
 
 
PROCEDURE SameValue (a, b: REAL): BOOLEAN;
VAR
    eps: REAL;
    res: BOOLEAN;
 
BEGIN
    eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
    IF a > b THEN
        res := (a - b) <= eps
    ELSE
        res := (b - a) <= eps
    END
    RETURN res
END SameValue;
 
 
PROCEDURE IsZero (x: REAL): BOOLEAN;
    RETURN ABS(x) <= 1.0E-12
END IsZero;
 
 
PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0FAH,                    (*  fsqrt                      *)
    0C9H,                          (*  leave                      *)
    0C2H, 008H, 000H               (*  ret     08h                *)
    )
    RETURN 0.0
END sqrt;
 
 
PROCEDURE [stdcall] sin* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0FEH,                    (*  fsin                       *)
    0C9H,                          (*  leave                      *)
    0C2H, 008H, 000H               (*  ret     08h                *)
    )
    RETURN 0.0
END sin;
 
 
PROCEDURE [stdcall] cos* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0FFH,                    (*  fcos                       *)
    0C9H,                          (*  leave                      *)
    0C2H, 008H, 000H               (*  ret     08h                *)
    )
    RETURN 0.0
END cos;
 
 
PROCEDURE [stdcall] tan* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0FBH,                    (*  fsincos                    *)
    0DEH, 0F9H,                    (*  fdivp st1, st              *)
    0C9H,                          (*  leave                      *)
    0C2H, 008H, 000H               (*  ret     08h                *)
    )
    RETURN 0.0
END tan;
 
 
PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0DDH, 045H, 010H,              (*  fld     qword [ebp + 10h]  *)
    0D9H, 0F3H,                    (*  fpatan                     *)
    0C9H,                          (*  leave                      *)
    0C2H, 010H, 000H               (*  ret     10h                *)
    )
    RETURN 0.0
END arctan2;
 
 
PROCEDURE [stdcall] ln* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0D9H, 0EDH,                    (*  fldln2                     *)
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0F1H,                    (*  fyl2x                      *)
    0C9H,                          (*  leave                      *)
    0C2H, 008H, 000H               (*  ret     08h                *)
    )
    RETURN 0.0
END ln;
 
 
PROCEDURE [stdcall] log* (base, x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0D9H, 0E8H,                    (*  fld1                       *)
    0DDH, 045H, 010H,              (*  fld     qword [ebp + 10h]  *)
    0D9H, 0F1H,                    (*  fyl2x                      *)
    0D9H, 0E8H,                    (*  fld1                       *)
    0DDH, 045H, 008H,              (*  fld     qword [ebp + 08h]  *)
    0D9H, 0F1H,                    (*  fyl2x                      *)
    0DEH, 0F9H,                    (*  fdivp st1, st              *)
    0C9H,                          (*  leave                      *)
    0C2H, 010H, 000H               (*  ret     10h                *)
    )
    RETURN 0.0
END log;
 
 
PROCEDURE [stdcall] exp* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,           (*  fld     qword [ebp + 08h]  *)
    0D9H, 0EAH,                 (*  fldl2e                     *)
    0DEH, 0C9H, 0D9H, 0C0H,
    0D9H, 0FCH, 0DCH, 0E9H,
    0D9H, 0C9H, 0D9H, 0F0H,
    0D9H, 0E8H, 0DEH, 0C1H,
    0D9H, 0FDH, 0DDH, 0D9H,
    0C9H,                       (*  leave                      *)
    0C2H, 008H, 000H            (*  ret     08h                *)
    )
    RETURN 0.0
END exp;
 
 
PROCEDURE [stdcall] round* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    0DDH, 045H, 008H,           (*  fld     qword [ebp + 08h]  *)
    0D9H, 07DH, 0F4H, 0D9H,
    07DH, 0F6H, 066H, 081H,
    04DH, 0F6H, 000H, 003H,
    0D9H, 06DH, 0F6H, 0D9H,
    0FCH, 0D9H, 06DH, 0F4H,
    0C9H,                       (*  leave                     *)
    0C2H, 008H, 000H            (*  ret     08h               *)
    )
    RETURN 0.0
END round;
 
 
PROCEDURE [stdcall] frac* (x: REAL): REAL;
BEGIN
    SYSTEM.CODE(
    050H,
    0DDH, 045H, 008H,           (*  fld     qword [ebp + 08h]  *)
    0D9H, 0C0H, 0D9H, 03CH,
    024H, 0D9H, 07CH, 024H,
    002H, 066H, 081H, 04CH,
    024H, 002H, 000H, 00FH,
    0D9H, 06CH, 024H, 002H,
    0D9H, 0FCH, 0D9H, 02CH,
    024H, 0DEH, 0E9H,
    0C9H,                       (*  leave                     *)
    0C2H, 008H, 000H            (*  ret     08h               *)
    )
    RETURN 0.0
END frac;
 
 
PROCEDURE arcsin* (x: REAL): REAL;
    RETURN arctan2(x, sqrt(1.0 - x * x))
END arcsin;
 
 
PROCEDURE arccos* (x: REAL): REAL;
    RETURN arctan2(sqrt(1.0 - x * x), x)
END arccos;
 
 
PROCEDURE arctan* (x: REAL): REAL;
    RETURN arctan2(x, 1.0)
END arctan;
 
 
PROCEDURE sinh* (x: REAL): REAL;
 
 
 
BEGIN
    x := exp(x)
 
 
    RETURN (x - 1.0 / x) * 0.5
 
 
END sinh;
 
 
PROCEDURE cosh* (x: REAL): REAL;
 
 
 
BEGIN
    x := exp(x)
 
 
    RETURN (x + 1.0 / x) * 0.5
 
 
END cosh;
 
 
PROCEDURE tanh* (x: REAL): REAL;
 
 
 
BEGIN
    IF x > 15.0 THEN
        x := 1.0
    ELSIF x < -15.0 THEN
        x := -1.0
    ELSE
        x := exp(2.0 * x);
        x := (x - 1.0) / (x + 1.0)
    END
 
    RETURN x
END tanh;
 
 
PROCEDURE arsinh* (x: REAL): REAL;
    RETURN ln(x + sqrt(x * x + 1.0))
END arsinh;
 
 
PROCEDURE arcosh* (x: REAL): REAL;
    RETURN ln(x + sqrt(x * x - 1.0))
END arcosh;
 
 
PROCEDURE artanh* (x: REAL): REAL;
VAR
    res: REAL;
 
BEGIN
    IF SameValue(x, 1.0) THEN
        res := SYSTEM.INF()
    ELSIF SameValue(x, -1.0) THEN
        res := -SYSTEM.INF()
    ELSE
        res := 0.5 * ln((1.0 + x) / (1.0 - x))
    END
    RETURN res
END artanh;
 
 
PROCEDURE floor* (x: REAL): REAL;
VAR
    f: REAL;
 
BEGIN
    f := frac(x);
    x := x - f;
    IF f < 0.0 THEN
        x := x - 1.0
    END
    RETURN x
END floor;
 
 
PROCEDURE ceil* (x: REAL): REAL;
VAR
    f: REAL;
 
BEGIN
    f := frac(x);
    x := x - f;
    IF f > 0.0 THEN
        x := x + 1.0
    END
    RETURN x
END ceil;
 
 
PROCEDURE power* (base, exponent: REAL): REAL;
VAR
    res: REAL;
 
BEGIN
    IF exponent = 0.0 THEN
        res := 1.0
    ELSIF (base = 0.0) & (exponent > 0.0) THEN
        res := 0.0
    ELSE
        res := exp(exponent * ln(base))
    END
    RETURN res
END power;
 
 
PROCEDURE sgn* (x: REAL): INTEGER;
VAR
    res: INTEGER;
 
BEGIN
    IF x > 0.0 THEN
        res := 1
    ELSIF x < 0.0 THEN
        res := -1
    ELSE
        res := 0
    END
 
    RETURN res
END sgn;
 
 
PROCEDURE fact* (n: INTEGER): REAL;
VAR
    res: REAL;
 
BEGIN
    res := 1.0;
    WHILE n > 1 DO
        res := res * FLT(n);
        DEC(n)
    END
 
    RETURN res
END fact;
 
 
END Math.

Rev 7597	Rev 7693
1	(*	1	(*
2	Copyright 2013, 2014, 2018 Anton Krotov	2	Copyright 2013, 2014, 2018, 2019 Anton Krotov
3		3
4	This program is free software: you can redistribute it and/or modify	4	This program is free software: you can redistribute it and/or modify
5	it under the terms of the GNU Lesser General Public License as published by	5	it under the terms of the GNU Lesser General Public License as published by
6	the Free Software Foundation, either version 3 of the License, or	6	the Free Software Foundation, either version 3 of the License, or
7	(at your option) any later version.	7	(at your option) any later version.
8		8
9	This program is distributed in the hope that it will be useful,	9	This program is distributed in the hope that it will be useful,
10	but WITHOUT ANY WARRANTY; without even the implied warranty of	10	but WITHOUT ANY WARRANTY; without even the implied warranty of
11	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	11	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12	GNU Lesser General Public License for more details.	12	GNU Lesser General Public License for more details.
13		13
14	You should have received a copy of the GNU Lesser General Public License	14	You should have received a copy of the GNU Lesser General Public License
15	along with this program. If not, see .	15	along with this program. If not, see .
16	*)	16	*)
17		17
18	MODULE Math;	18	MODULE Math;
19		19
20	IMPORT SYSTEM;	20	IMPORT SYSTEM;
21		21
22		22
23	CONST	23	CONST
24		24
25	pi* = 3.141592653589793;	25	pi* = 3.141592653589793;
26	e* = 2.718281828459045;	26	e* = 2.718281828459045;
27		27
28		28
29	PROCEDURE IsNan* (x: REAL): BOOLEAN;	29	PROCEDURE IsNan* (x: REAL): BOOLEAN;
30	VAR	30	VAR
31	h, l: SET;	31	h, l: SET;
32		32
33	BEGIN	33	BEGIN
34	SYSTEM.GET(SYSTEM.ADR(x), l);	34	SYSTEM.GET(SYSTEM.ADR(x), l);
35	SYSTEM.GET(SYSTEM.ADR(x) + 4, h)	35	SYSTEM.GET(SYSTEM.ADR(x) + 4, h)
36	RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))	36	RETURN (h * {20..30} = {20..30}) & ((h * {0..19} # {}) OR (l * {0..31} # {}))
37	END IsNan;	37	END IsNan;
38		38
39		39
40	PROCEDURE IsInf* (x: REAL): BOOLEAN;	40	PROCEDURE IsInf* (x: REAL): BOOLEAN;
41	RETURN ABS(x) = SYSTEM.INF()	41	RETURN ABS(x) = SYSTEM.INF()
42	END IsInf;	42	END IsInf;
43		43
44		44
45	PROCEDURE Max (a, b: REAL): REAL;	45	PROCEDURE Max (a, b: REAL): REAL;
46	VAR	46	VAR
47	res: REAL;	47	res: REAL;
48		48
49	BEGIN	49	BEGIN
50	IF a > b THEN	50	IF a > b THEN
51	res := a	51	res := a
52	ELSE	52	ELSE
53	res := b	53	res := b
54	END	54	END
55	RETURN res	55	RETURN res
56	END Max;	56	END Max;
57		57
58		58
59	PROCEDURE Min (a, b: REAL): REAL;	59	PROCEDURE Min (a, b: REAL): REAL;
60	VAR	60	VAR
61	res: REAL;	61	res: REAL;
62		62
63	BEGIN	63	BEGIN
64	IF a < b THEN	64	IF a < b THEN
65	res := a	65	res := a
66	ELSE	66	ELSE
67	res := b	67	res := b
68	END	68	END
69	RETURN res	69	RETURN res
70	END Min;	70	END Min;
71		71
72		72
73	PROCEDURE SameValue (a, b: REAL): BOOLEAN;	73	PROCEDURE SameValue (a, b: REAL): BOOLEAN;
74	VAR	74	VAR
75	eps: REAL;	75	eps: REAL;
76	res: BOOLEAN;	76	res: BOOLEAN;
77		77
78	BEGIN	78	BEGIN
79	eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);	79	eps := Max(Min(ABS(a), ABS(b)) * 1.0E-12, 1.0E-12);
80	IF a > b THEN	80	IF a > b THEN
81	res := (a - b) <= eps	81	res := (a - b) <= eps
82	ELSE	82	ELSE
83	res := (b - a) <= eps	83	res := (b - a) <= eps
84	END	84	END
85	RETURN res	85	RETURN res
86	END SameValue;	86	END SameValue;
87		87
88		88
89	PROCEDURE IsZero (x: REAL): BOOLEAN;	89	PROCEDURE IsZero (x: REAL): BOOLEAN;
90	RETURN ABS(x) <= 1.0E-12	90	RETURN ABS(x) <= 1.0E-12
91	END IsZero;	91	END IsZero;
92		92
93		93
94	PROCEDURE [stdcall] sqrt* (x: REAL): REAL;	94	PROCEDURE [stdcall] sqrt* (x: REAL): REAL;
95	BEGIN	95	BEGIN
96	SYSTEM.CODE(	96	SYSTEM.CODE(
97	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	97	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
98	0D9H, 0FAH, (* fsqrt *)	98	0D9H, 0FAH, (* fsqrt *)
99	0C9H, (* leave *)	99	0C9H, (* leave *)
100	0C2H, 008H, 000H (* ret 08h *)	100	0C2H, 008H, 000H (* ret 08h *)
101	)	101	)
102	RETURN 0.0	102	RETURN 0.0
103	END sqrt;	103	END sqrt;
104		104
105		105
106	PROCEDURE [stdcall] sin* (x: REAL): REAL;	106	PROCEDURE [stdcall] sin* (x: REAL): REAL;
107	BEGIN	107	BEGIN
108	SYSTEM.CODE(	108	SYSTEM.CODE(
109	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	109	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
110	0D9H, 0FEH, (* fsin *)	110	0D9H, 0FEH, (* fsin *)
111	0C9H, (* leave *)	111	0C9H, (* leave *)
112	0C2H, 008H, 000H (* ret 08h *)	112	0C2H, 008H, 000H (* ret 08h *)
113	)	113	)
114	RETURN 0.0	114	RETURN 0.0
115	END sin;	115	END sin;
116		116
117		117
118	PROCEDURE [stdcall] cos* (x: REAL): REAL;	118	PROCEDURE [stdcall] cos* (x: REAL): REAL;
119	BEGIN	119	BEGIN
120	SYSTEM.CODE(	120	SYSTEM.CODE(
121	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	121	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
122	0D9H, 0FFH, (* fcos *)	122	0D9H, 0FFH, (* fcos *)
123	0C9H, (* leave *)	123	0C9H, (* leave *)
124	0C2H, 008H, 000H (* ret 08h *)	124	0C2H, 008H, 000H (* ret 08h *)
125	)	125	)
126	RETURN 0.0	126	RETURN 0.0
127	END cos;	127	END cos;
128		128
129		129
130	PROCEDURE [stdcall] tan* (x: REAL): REAL;	130	PROCEDURE [stdcall] tan* (x: REAL): REAL;
131	BEGIN	131	BEGIN
132	SYSTEM.CODE(	132	SYSTEM.CODE(
133	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	133	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
134	0D9H, 0FBH, (* fsincos *)	134	0D9H, 0FBH, (* fsincos *)
135	0DEH, 0F9H, (* fdivp st1, st *)	135	0DEH, 0F9H, (* fdivp st1, st *)
136	0C9H, (* leave *)	136	0C9H, (* leave *)
137	0C2H, 008H, 000H (* ret 08h *)	137	0C2H, 008H, 000H (* ret 08h *)
138	)	138	)
139	RETURN 0.0	139	RETURN 0.0
140	END tan;	140	END tan;
141		141
142		142
143	PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;	143	PROCEDURE [stdcall] arctan2* (y, x: REAL): REAL;
144	BEGIN	144	BEGIN
145	SYSTEM.CODE(	145	SYSTEM.CODE(
146	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	146	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
147	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)	147	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
148	0D9H, 0F3H, (* fpatan *)	148	0D9H, 0F3H, (* fpatan *)
149	0C9H, (* leave *)	149	0C9H, (* leave *)
150	0C2H, 010H, 000H (* ret 10h *)	150	0C2H, 010H, 000H (* ret 10h *)
151	)	151	)
152	RETURN 0.0	152	RETURN 0.0
153	END arctan2;	153	END arctan2;
154		154
155		155
156	PROCEDURE [stdcall] ln* (x: REAL): REAL;	156	PROCEDURE [stdcall] ln* (x: REAL): REAL;
157	BEGIN	157	BEGIN
158	SYSTEM.CODE(	158	SYSTEM.CODE(
159	0D9H, 0EDH, (* fldln2 *)	159	0D9H, 0EDH, (* fldln2 *)
160	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	160	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
161	0D9H, 0F1H, (* fyl2x *)	161	0D9H, 0F1H, (* fyl2x *)
162	0C9H, (* leave *)	162	0C9H, (* leave *)
163	0C2H, 008H, 000H (* ret 08h *)	163	0C2H, 008H, 000H (* ret 08h *)
164	)	164	)
165	RETURN 0.0	165	RETURN 0.0
166	END ln;	166	END ln;
167		167
168		168
169	PROCEDURE [stdcall] log* (base, x: REAL): REAL;	169	PROCEDURE [stdcall] log* (base, x: REAL): REAL;
170	BEGIN	170	BEGIN
171	SYSTEM.CODE(	171	SYSTEM.CODE(
172	0D9H, 0E8H, (* fld1 *)	172	0D9H, 0E8H, (* fld1 *)
173	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)	173	0DDH, 045H, 010H, (* fld qword [ebp + 10h] *)
174	0D9H, 0F1H, (* fyl2x *)	174	0D9H, 0F1H, (* fyl2x *)
175	0D9H, 0E8H, (* fld1 *)	175	0D9H, 0E8H, (* fld1 *)
176	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	176	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
177	0D9H, 0F1H, (* fyl2x *)	177	0D9H, 0F1H, (* fyl2x *)
178	0DEH, 0F9H, (* fdivp st1, st *)	178	0DEH, 0F9H, (* fdivp st1, st *)
179	0C9H, (* leave *)	179	0C9H, (* leave *)
180	0C2H, 010H, 000H (* ret 10h *)	180	0C2H, 010H, 000H (* ret 10h *)
181	)	181	)
182	RETURN 0.0	182	RETURN 0.0
183	END log;	183	END log;
184		184
185		185
186	PROCEDURE [stdcall] exp* (x: REAL): REAL;	186	PROCEDURE [stdcall] exp* (x: REAL): REAL;
187	BEGIN	187	BEGIN
188	SYSTEM.CODE(	188	SYSTEM.CODE(
189	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	189	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
190	0D9H, 0EAH, (* fldl2e *)	190	0D9H, 0EAH, (* fldl2e *)
191	0DEH, 0C9H, 0D9H, 0C0H,	191	0DEH, 0C9H, 0D9H, 0C0H,
192	0D9H, 0FCH, 0DCH, 0E9H,	192	0D9H, 0FCH, 0DCH, 0E9H,
193	0D9H, 0C9H, 0D9H, 0F0H,	193	0D9H, 0C9H, 0D9H, 0F0H,
194	0D9H, 0E8H, 0DEH, 0C1H,	194	0D9H, 0E8H, 0DEH, 0C1H,
195	0D9H, 0FDH, 0DDH, 0D9H,	195	0D9H, 0FDH, 0DDH, 0D9H,
196	0C9H, (* leave *)	196	0C9H, (* leave *)
197	0C2H, 008H, 000H (* ret 08h *)	197	0C2H, 008H, 000H (* ret 08h *)
198	)	198	)
199	RETURN 0.0	199	RETURN 0.0
200	END exp;	200	END exp;
201		201
202		202
203	PROCEDURE [stdcall] round* (x: REAL): REAL;	203	PROCEDURE [stdcall] round* (x: REAL): REAL;
204	BEGIN	204	BEGIN
205	SYSTEM.CODE(	205	SYSTEM.CODE(
206	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	206	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
207	0D9H, 07DH, 0F4H, 0D9H,	207	0D9H, 07DH, 0F4H, 0D9H,
208	07DH, 0F6H, 066H, 081H,	208	07DH, 0F6H, 066H, 081H,
209	04DH, 0F6H, 000H, 003H,	209	04DH, 0F6H, 000H, 003H,
210	0D9H, 06DH, 0F6H, 0D9H,	210	0D9H, 06DH, 0F6H, 0D9H,
211	0FCH, 0D9H, 06DH, 0F4H,	211	0FCH, 0D9H, 06DH, 0F4H,
212	0C9H, (* leave *)	212	0C9H, (* leave *)
213	0C2H, 008H, 000H (* ret 08h *)	213	0C2H, 008H, 000H (* ret 08h *)
214	)	214	)
215	RETURN 0.0	215	RETURN 0.0
216	END round;	216	END round;
217		217
218		218
219	PROCEDURE [stdcall] frac* (x: REAL): REAL;	219	PROCEDURE [stdcall] frac* (x: REAL): REAL;
220	BEGIN	220	BEGIN
221	SYSTEM.CODE(	221	SYSTEM.CODE(
222	050H,	222	050H,
223	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)	223	0DDH, 045H, 008H, (* fld qword [ebp + 08h] *)
224	0D9H, 0C0H, 0D9H, 03CH,	224	0D9H, 0C0H, 0D9H, 03CH,
225	024H, 0D9H, 07CH, 024H,	225	024H, 0D9H, 07CH, 024H,
226	002H, 066H, 081H, 04CH,	226	002H, 066H, 081H, 04CH,
227	024H, 002H, 000H, 00FH,	227	024H, 002H, 000H, 00FH,
228	0D9H, 06CH, 024H, 002H,	228	0D9H, 06CH, 024H, 002H,
229	0D9H, 0FCH, 0D9H, 02CH,	229	0D9H, 0FCH, 0D9H, 02CH,
230	024H, 0DEH, 0E9H,	230	024H, 0DEH, 0E9H,
231	0C9H, (* leave *)	231	0C9H, (* leave *)
232	0C2H, 008H, 000H (* ret 08h *)	232	0C2H, 008H, 000H (* ret 08h *)
233	)	233	)
234	RETURN 0.0	234	RETURN 0.0
235	END frac;	235	END frac;
236		236
237		237
238	PROCEDURE arcsin* (x: REAL): REAL;	238	PROCEDURE arcsin* (x: REAL): REAL;
239	RETURN arctan2(x, sqrt(1.0 - x * x))	239	RETURN arctan2(x, sqrt(1.0 - x * x))
240	END arcsin;	240	END arcsin;
241		241
242		242
243	PROCEDURE arccos* (x: REAL): REAL;	243	PROCEDURE arccos* (x: REAL): REAL;
244	RETURN arctan2(sqrt(1.0 - x * x), x)	244	RETURN arctan2(sqrt(1.0 - x * x), x)
245	END arccos;	245	END arccos;
246		246
247		247
248	PROCEDURE arctan* (x: REAL): REAL;	248	PROCEDURE arctan* (x: REAL): REAL;
249	RETURN arctan2(x, 1.0)	249	RETURN arctan2(x, 1.0)
250	END arctan;	250	END arctan;
251		251
252		252
253	PROCEDURE sinh* (x: REAL): REAL;	253	PROCEDURE sinh* (x: REAL): REAL;
254	VAR	-
255	res: REAL;	-
256		-
257	BEGIN	254	BEGIN
258	IF IsZero(x) THEN	255	x := exp(x)
259	res := 0.0	-
260	ELSE	-
261	res := (exp(x) - exp(-x)) / 2.0	256	RETURN (x - 1.0 / x) * 0.5
262	END	-
263	RETURN res	-
264	END sinh;	257	END sinh;
265		258
266		259
267	PROCEDURE cosh* (x: REAL): REAL;	260	PROCEDURE cosh* (x: REAL): REAL;
268	VAR	-
269	res: REAL;	-
270		-
271	BEGIN	261	BEGIN
272	IF IsZero(x) THEN	262	x := exp(x)
273	res := 1.0	-
274	ELSE	-
275	res := (exp(x) + exp(-x)) / 2.0	263	RETURN (x + 1.0 / x) * 0.5
276	END	-
277	RETURN res	-
278	END cosh;	264	END cosh;
279		265
280		266
281	PROCEDURE tanh* (x: REAL): REAL;	267	PROCEDURE tanh* (x: REAL): REAL;
282	VAR	-
283	res: REAL;	-
284		-
285	BEGIN	268	BEGIN
286	IF IsZero(x) THEN	269	IF x > 15.0 THEN
287	res := 0.0	270	x := 1.0
-		271	ELSIF x < -15.0 THEN
-		272	x := -1.0
288	ELSE	273	ELSE
-		274	x := exp(2.0 * x);
289	res := sinh(x) / cosh(x)	275	x := (x - 1.0) / (x + 1.0)
290	END	276	END
-		277
291	RETURN res	278	RETURN x
292	END tanh;	279	END tanh;
293		280
294		281
295	PROCEDURE arcsinh* (x: REAL): REAL;	282	PROCEDURE arsinh* (x: REAL): REAL;
296	RETURN ln(x + sqrt((x * x) + 1.0))	283	RETURN ln(x + sqrt(x * x + 1.0))
297	END arcsinh;	284	END arsinh;
298		285
299		286
300	PROCEDURE arccosh* (x: REAL): REAL;	287	PROCEDURE arcosh* (x: REAL): REAL;
301	RETURN ln(x + sqrt((x - 1.0) / (x + 1.0)) * (x + 1.0))	288	RETURN ln(x + sqrt(x * x - 1.0))
302	END arccosh;	289	END arcosh;
303		290
304		291
305	PROCEDURE arctanh* (x: REAL): REAL;	292	PROCEDURE artanh* (x: REAL): REAL;
306	VAR	293	VAR
307	res: REAL;	294	res: REAL;
308		295
309	BEGIN	296	BEGIN
310	IF SameValue(x, 1.0) THEN	297	IF SameValue(x, 1.0) THEN
311	res := SYSTEM.INF()	298	res := SYSTEM.INF()
312	ELSIF SameValue(x, -1.0) THEN	299	ELSIF SameValue(x, -1.0) THEN
313	res := -SYSTEM.INF()	300	res := -SYSTEM.INF()
314	ELSE	301	ELSE
315	res := 0.5 * ln((1.0 + x) / (1.0 - x))	302	res := 0.5 * ln((1.0 + x) / (1.0 - x))
316	END	303	END
317	RETURN res	304	RETURN res
318	END arctanh;	305	END artanh;
319		306
320		307
321	PROCEDURE floor* (x: REAL): REAL;	308	PROCEDURE floor* (x: REAL): REAL;
322	VAR	309	VAR
323	f: REAL;	310	f: REAL;
324		311
325	BEGIN	312	BEGIN
326	f := frac(x);	313	f := frac(x);
327	x := x - f;	314	x := x - f;
328	IF f < 0.0 THEN	315	IF f < 0.0 THEN
329	x := x - 1.0	316	x := x - 1.0
330	END	317	END
331	RETURN x	318	RETURN x
332	END floor;	319	END floor;
333		320
334		321
335	PROCEDURE ceil* (x: REAL): REAL;	322	PROCEDURE ceil* (x: REAL): REAL;
336	VAR	323	VAR
337	f: REAL;	324	f: REAL;
338		325
339	BEGIN	326	BEGIN
340	f := frac(x);	327	f := frac(x);
341	x := x - f;	328	x := x - f;
342	IF f > 0.0 THEN	329	IF f > 0.0 THEN
343	x := x + 1.0	330	x := x + 1.0
344	END	331	END
345	RETURN x	332	RETURN x
346	END ceil;	333	END ceil;
347		334
348		335
349	PROCEDURE power* (base, exponent: REAL): REAL;	336	PROCEDURE power* (base, exponent: REAL): REAL;
350	VAR	337	VAR
351	res: REAL;	338	res: REAL;
352		339
353	BEGIN	340	BEGIN
354	IF exponent = 0.0 THEN	341	IF exponent = 0.0 THEN
355	res := 1.0	342	res := 1.0
356	ELSIF (base = 0.0) & (exponent > 0.0) THEN	343	ELSIF (base = 0.0) & (exponent > 0.0) THEN
357	res := 0.0	344	res := 0.0
358	ELSE	345	ELSE
359	res := exp(exponent * ln(base))	346	res := exp(exponent * ln(base))
360	END	347	END
361	RETURN res	348	RETURN res
362	END power;	349	END power;
363		350
364		351
365	PROCEDURE sgn* (x: REAL): INTEGER;	352	PROCEDURE sgn* (x: REAL): INTEGER;
366	VAR	353	VAR
367	res: INTEGER;	354	res: INTEGER;
368		355
369	BEGIN	356	BEGIN
370	IF x > 0.0 THEN	357	IF x > 0.0 THEN
371	res := 1	358	res := 1
372	ELSIF x < 0.0 THEN	359	ELSIF x < 0.0 THEN
373	res := -1	360	res := -1
374	ELSE	361	ELSE
375	res := 0	362	res := 0
376	END	363	END
-		364
377	RETURN res	365	RETURN res
378	END sgn;	366	END sgn;
379		367
-		368
-		369	PROCEDURE fact* (n: INTEGER): REAL;
-		370	VAR
-		371	res: REAL;
-		372
-		373	BEGIN
-		374	res := 1.0;
-		375	WHILE n > 1 DO
-		376	res := res * FLT(n);
-		377	DEC(n)
-		378	END
-		379
-		380	RETURN res
-		381	END fact;
-		382
380		383
381	END Math.	384	END Math.

Subversion Repositories Kolibri OS

(root)/programs/develop/oberon07/Lib/KolibriOS/Math.ob07 – Rev 7597 → 7693