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 7693	Rev 7696
1	(*	1	(*
2	Copyright 2013, 2014, 2018, 2019 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	BEGIN	254	BEGIN
255	x := exp(x)	255	x := exp(x)
256	RETURN (x - 1.0 / x) * 0.5	256	RETURN (x - 1.0 / x) * 0.5
257	END sinh;	257	END sinh;
258		258
259		259
260	PROCEDURE cosh* (x: REAL): REAL;	260	PROCEDURE cosh* (x: REAL): REAL;
261	BEGIN	261	BEGIN
262	x := exp(x)	262	x := exp(x)
263	RETURN (x + 1.0 / x) * 0.5	263	RETURN (x + 1.0 / x) * 0.5
264	END cosh;	264	END cosh;
265		265
266		266
267	PROCEDURE tanh* (x: REAL): REAL;	267	PROCEDURE tanh* (x: REAL): REAL;
268	BEGIN	268	BEGIN
269	IF x > 15.0 THEN	269	IF x > 15.0 THEN
270	x := 1.0	270	x := 1.0
271	ELSIF x < -15.0 THEN	271	ELSIF x < -15.0 THEN
272	x := -1.0	272	x := -1.0
273	ELSE	273	ELSE
274	x := exp(2.0 * x);	274	x := exp(2.0 * x);
275	x := (x - 1.0) / (x + 1.0)	275	x := (x - 1.0) / (x + 1.0)
276	END	276	END
277		277
278	RETURN x	278	RETURN x
279	END tanh;	279	END tanh;
280		280
281		281
282	PROCEDURE arsinh* (x: REAL): REAL;	282	PROCEDURE arsinh* (x: REAL): REAL;
283	RETURN ln(x + sqrt(x * x + 1.0))	283	RETURN ln(x + sqrt(x * x + 1.0))
284	END arsinh;	284	END arsinh;
285		285
286		286
287	PROCEDURE arcosh* (x: REAL): REAL;	287	PROCEDURE arcosh* (x: REAL): REAL;
288	RETURN ln(x + sqrt(x * x - 1.0))	288	RETURN ln(x + sqrt(x * x - 1.0))
289	END arcosh;	289	END arcosh;
290		290
291		291
292	PROCEDURE artanh* (x: REAL): REAL;	292	PROCEDURE artanh* (x: REAL): REAL;
293	VAR	293	VAR
294	res: REAL;	294	res: REAL;
295		295
296	BEGIN	296	BEGIN
297	IF SameValue(x, 1.0) THEN	297	IF SameValue(x, 1.0) THEN
298	res := SYSTEM.INF()	298	res := SYSTEM.INF()
299	ELSIF SameValue(x, -1.0) THEN	299	ELSIF SameValue(x, -1.0) THEN
300	res := -SYSTEM.INF()	300	res := -SYSTEM.INF()
301	ELSE	301	ELSE
302	res := 0.5 * ln((1.0 + x) / (1.0 - x))	302	res := 0.5 * ln((1.0 + x) / (1.0 - x))
303	END	303	END
304	RETURN res	304	RETURN res
305	END artanh;	305	END artanh;
306		306
307		307
308	PROCEDURE floor* (x: REAL): REAL;	308	PROCEDURE floor* (x: REAL): REAL;
309	VAR	309	VAR
310	f: REAL;	310	f: REAL;
311		311
312	BEGIN	312	BEGIN
313	f := frac(x);	313	f := frac(x);
314	x := x - f;	314	x := x - f;
315	IF f < 0.0 THEN	315	IF f < 0.0 THEN
316	x := x - 1.0	316	x := x - 1.0
317	END	317	END
318	RETURN x	318	RETURN x
319	END floor;	319	END floor;
320		320
321		321
322	PROCEDURE ceil* (x: REAL): REAL;	322	PROCEDURE ceil* (x: REAL): REAL;
323	VAR	323	VAR
324	f: REAL;	324	f: REAL;
325		325
326	BEGIN	326	BEGIN
327	f := frac(x);	327	f := frac(x);
328	x := x - f;	328	x := x - f;
329	IF f > 0.0 THEN	329	IF f > 0.0 THEN
330	x := x + 1.0	330	x := x + 1.0
331	END	331	END
332	RETURN x	332	RETURN x
333	END ceil;	333	END ceil;
334		334
335		335
336	PROCEDURE power* (base, exponent: REAL): REAL;	336	PROCEDURE power* (base, exponent: REAL): REAL;
337	VAR	337	VAR
338	res: REAL;	338	res: REAL;
339		339
340	BEGIN	340	BEGIN
341	IF exponent = 0.0 THEN	341	IF exponent = 0.0 THEN
342	res := 1.0	342	res := 1.0
343	ELSIF (base = 0.0) & (exponent > 0.0) THEN	343	ELSIF (base = 0.0) & (exponent > 0.0) THEN
344	res := 0.0	344	res := 0.0
345	ELSE	345	ELSE
346	res := exp(exponent * ln(base))	346	res := exp(exponent * ln(base))
347	END	347	END
348	RETURN res	348	RETURN res
349	END power;	349	END power;
350		350
351		351
352	PROCEDURE sgn* (x: REAL): INTEGER;	352	PROCEDURE sgn* (x: REAL): INTEGER;
353	VAR	353	VAR
354	res: INTEGER;	354	res: INTEGER;
355		355
356	BEGIN	356	BEGIN
357	IF x > 0.0 THEN	357	IF x > 0.0 THEN
358	res := 1	358	res := 1
359	ELSIF x < 0.0 THEN	359	ELSIF x < 0.0 THEN
360	res := -1	360	res := -1
361	ELSE	361	ELSE
362	res := 0	362	res := 0
363	END	363	END
364		364
365	RETURN res	365	RETURN res
366	END sgn;	366	END sgn;
367		367
368		368
369	PROCEDURE fact* (n: INTEGER): REAL;	369	PROCEDURE fact* (n: INTEGER): REAL;
370	VAR	370	VAR
371	res: REAL;	371	res: REAL;
372		372
373	BEGIN	373	BEGIN
374	res := 1.0;	374	res := 1.0;
375	WHILE n > 1 DO	375	WHILE n > 1 DO
376	res := res * FLT(n);	376	res := res * FLT(n);
377	DEC(n)	377	DEC(n)
378	END	378	END
379		379
380	RETURN res	380	RETURN res
381	END fact;	381	END fact;
382		382
383		383
384	END Math.	384	END Math.

Subversion Repositories Kolibri OS

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