Path: ...!weretis.net!feeder9.news.weretis.net!news.nk.ca!rocksolid2!i2pn2.org!.POSTED!not-for-mail
From: melahi_ahmed@yahoo.fr (ahmed)
Newsgroups: comp.lang.forth
Subject: Re: Differentiable Forth
Date: Fri, 19 Jul 2024 07:39:04 +0000
Organization: novaBBS
Message-ID: <a8ec944a53a7b48d3994102035e987ab@www.novabbs.com>
References: <e9689378e46f06961fe4fe43b47dfd3b@www.novabbs.com> <v766m4$3hipk$1@news.xmission.com> <f806c73034c83af94d0ce3d857075241@www.novabbs.com> <7e6998ad43698a3e80e2483e932ec7a1@www.novabbs.com> <06155327b9b2e4b08c479044803e2511@www.novabbs.com> <a6052445cfd6c3264ff86446dbbe2d37@www.novabbs.com>
MIME-Version: 1.0
Content-Type: text/plain; charset=utf-8; format=flowed
Content-Transfer-Encoding: 8bit
Injection-Info: i2pn2.org;
	logging-data="3799940"; mail-complaints-to="usenet@i2pn2.org";
	posting-account="fh2jRJ/PGtIlZMySaIjc6gsLWP80WZpB2lZYFC5wgKI";
User-Agent: Rocksolid Light
X-Rslight-Site: $2y$10$YA7G/SaKzB8WNhKbfhkZKeZFkZHDdIchoVSgPOun5.aTon7AlES52
X-Rslight-Posting-User: a55529988cdb6fa7b5e36631aef8884238b8448a
X-Spam-Checker-Version: SpamAssassin 4.0.0
Bytes: 7686
Lines: 262

I added some words and examples for the case of functions with two
variables.
See functions f9() and f10() in the examples

Here the code begins.

: -frot frot frot ;
: f>dl   ( f: a -- a 0) 0e ; \ real to dual value
: f>dl_d ( f: a -- a 1) 1e ; \ real to dual value with respect to
differentiate
: dl>rl  ( f: a b -- a) fdrop ;
: dl>eps ( f: a b -- b) fnip ;


: dl. ( f: a b -- ) fswap f. ." + eps " f. ;
: dl(,). ( f: a b -- ) ." (" fswap f. ." , " f. ." )" ;

: dl+ ( f: a b c d -- a+c b+d)
    frot ( f: a c d b)
    f+   ( f: a c b+d)
    -frot ( f: b+d a c)
    f+   ( f: b+d a+c)
    fswap ( f: a+c b+d) ;

: dl- ( f: a b c d -- a-c b-d)
    frot ( f: a c d b)
    fswap f-   ( f: a c b-d)
    -frot ( f: b-d a c)
    f-   ( f: b-d a-c)
    fswap ( f: a-c b-d) ;


fvariable b*c
: dl* ( f: a b c d -- a*c  a*d+b*c)
    -frot ( f: a d b c)
    ftuck f* ( f: a d c b*c)
    b*c f! ( f: a d c)
    frot ( f: d c a)
    ftuck ( f: d a c a)
    f*    ( f: d a a*c)
    -frot  ( f: a*c d a)
    f* b*c f@ f+ ( f: a*c a*d+b*c)
;

: 1/dl ( f: a b -- 1/a -b*1/a^2)
    fswap 1/f ( f: b 1/a)
    ftuck     ( f: 1/a b 1/a)
    fdup f*   ( f: 1/a b 1/a^2)
    f* fnegate ( f: 1/a -b/a^2)
;

: dl/ ( f: a b c d -- a/c rest)
    1/dl dl*
;


: dl^f ( f: a b c -- a^c b*c)
    ftuck ( f: a c b c)
    f* -frot ( f: b*c a c)
    f** fswap ( f: a^c b*c)
;

\
: dldup ( f: a b -- a b a b) fover fover ;
: dlnip ( f: a b c d -- c d) frot fdrop frot fdrop ;
: dldrop ( f: a b -- ) fdrop fdrop ;

fvariable dlswap_temp
: dlswap ( f: a b c d -- c d a b)
    frot dlswap_temp f! ( f: a c d)
    frot ( f: c d a)
    dlswap_temp f@  ;

fvariable dlover_temp1
fvariable dlover_temp2
: dlover ( f: a b c d -- a b c d a b)
    dlswap ( f: a b c d -- c d a b)
    dlover_temp2 f! dlover_temp1 f! ( f: c d)
    dlover_temp1 f@ dlover_temp2 f@ ( f: c d a b)
    dlswap ( f: a b c d)
    dlover_temp1 f@ dlover_temp2 f@ ( f: a b c d a b)
;


: dltuck dlswap dlover ;

: dlvariable create 2 floats allot ;
: dl! ( dlvar -- ) ( f: f1 f2 -- ) dup float+ f! f! ;
: dl@ ( dlvar -- ) ( f: -- f1 f2)  dup f@ float+ f@ ;

dlvariable dlrot_temp1
dlvariable dlrot_temp2
: dlrot ( dl: d1 d2 d3 -- d2 d3 d1)
    dlrot_temp1 dl! ( dl: d1 d2)
    dlswap    ( dl: d2 d1)
    dlrot_temp2 dl! ( dl: d2)
    dlrot_temp1 dl@ ( dl: d2 d3)
    dlrot_temp2 dl@ ( dl: d2 d3 d1)
;

\ dual number funuctions of dula number variables



: dlident ( f: a b -- a b) ;
: dlsin ( f: a b -- c d) fswap fdup fsin fswap fcos frot f* ;
: dlcos ( f: a b -- c d) fswap fdup fcos fswap fsin fnegate frot f* ;
: dlexp ( f: a b -- c d) fswap fdup fexp fswap fexp frot f* ;
: dlln ( f: a b -- c d)  fswap fdup fln  fswap 1/f frot f* ;
\ ..... add others





\ derivatives
variable func
: der 1e ' func ! func @ execute dl>eps ;

\ examples
1 [if]
: dlf() 1e 0e dl+ ; \ f(x) = x + 1
: dlf2() dldup dl* ; \ f2(x) = x^2


: dlf3() dldup dlf2() dlswap dlf() dl+ ; \ f3(x) = x^2 + x + 1
: der_f3() ( f: x -- y) 2e f* 1e f+ ; \ d/dx(f3) = 2*x + 1
cr 1e der dlf3() f. \ 3. ok
cr 1e der_f3() f.   \ 3. ok
cr cr

: dlf4() dlf3() dlexp ; \ f3(x) = exp(x^2+x+1)
: der_f4() ( f: x -- y) \ d/dx(f4) = (2*x+1)*exp(x^2+x+1)
    fdup 2e f* 1e f+ fswap
    fdup fdup f* f+ 1e f+ fexp f*
;
cr 2e der dlf4() f. \ 5483.16579214229  ok, calculated at 2e
cr 2e der_f4() f.   \ 5483.16579214229  ok
cr cr

: dlf5() 1/dl ;
: der_f5() ( f: x) \ d/dx(f5) = -1/x^2
    fdup f* 1/f fnegate
;

cr 2e der dlf5() f. \ -0.25  ok calculated at 2e
cr 2e der_f5() f.   \ -0.25
cr cr


: dlf6() dldup dldup dl* dlswap dlsin dl+ 1/dl ; \ f6(x) =
1/(x^2+sin(x))
\ using the derivative calculated analytically d/dx (f6(x)) =
-(2*x+cos(x))/(x^2+sin(x))^2
: der_f6() ( f: x -- y) fdup fdup fdup f* fswap fsin f+ fdup f* 1/f
fswap fdup 2e f* fswap fcos f+ f* fnegate ;

cr 1e der dlf6() f. \ -0.749127330692909  ok calculated at x = 1
cr 1e der_f6() f.   \ -0.749127330692909  ok
cr cr


: dlf7() dldup dldup dl* dlcos dl* ; \ f7(x) = x*cos(x^2),
: der_f7() ( f: x --y)  \ its deriv: d/dx(f7) = cos(x^2)-2*x^2*sin(x^2)
    fdup f* ( f: x^2)
    fdup fsincos ( f: x^2 s c )
    -frot ( f:  c x^2 s )
    f* 2e f* ( f: c 2s*x^2)
    f-
;

cr 1e der_f7() f.   \ -1.14263966374765  ok calculated at 1e
cr 1e der dlf7() f. \ -1.14263966374765  ok
cr cr

cr 2e der_f7() f.   \ 5.40077634159981  ok calculated at 2e
cr 2e der dlf7() f. \ 5.40077634159981  ok
cr cr

========== REMAINDER OF ARTICLE TRUNCATED ==========