1 ! Copyright (C) 2009 Jason W. Merrill.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel math math.functions math.derivatives accessors
4 macros generic compiler.units words effects vocabs
5 sequences arrays assocs generalizations fry make
6 combinators.smart help help.markup ;
10 TUPLE: dual ordinary-part epsilon-part ;
14 ! Ordinary numbers implement the dual protocol by returning
15 ! themselves as the ordinary part, and 0 as the epsilon part.
16 M: number ordinary-part>> ;
18 M: number epsilon-part>> drop 0 ;
20 : unpack-dual ( dual -- ordinary-part epsilon-part )
21 [ ordinary-part>> ] [ epsilon-part>> ] bi ;
25 : input-length ( word -- n ) stack-effect in>> length ;
27 MACRO: ordinary-op ( word -- o )
29 '[ [ ordinary-part>> ] _ napply _ execute ] ;
31 ! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves
32 ! their ordinary and epsilon parts to produce
33 ! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
34 ! This allows a set of partial derivatives each to be evaluated
36 MACRO: duals>nweave ( n -- quot )
39 [ [ epsilon-part>> ] _ napply ] _ nkeep
40 [ ordinary-part>> ] _ napply _ nweave
43 MACRO: chain-rule ( word -- e )
44 [ input-length '[ _ duals>nweave ] ]
45 [ "derivative" word-prop ]
46 [ input-length 1 + '[ _ nspread ] ]
48 '[ [ @ _ @ ] sum-outputs ] ;
50 : set-dual-help ( dword word -- )
53 stack-effect [ in>> ] [ out>> ] bi append
54 [ dual ] { } map>assoc { $values } prepend
57 { $description } % "Version of " ,
58 { $link } swap suffix ,
59 " extended to work on dual numbers." ,
62 ] keepd set-word-help ;
66 MACRO: dual-op ( word -- quot )
67 [ '[ _ ordinary-op ] ]
68 [ input-length '[ _ nkeep ] ]
73 : define-dual ( word -- )
74 [ name>> "d" prepend "math.dual" create-word ] keep
75 [ stack-effect set-stack-effect ]
77 [ '[ _ dual-op ] define ]
80 ! Specialize math functions to operate on dual numbers.
81 [ all-words [ "derivative" word-prop ] filter
82 [ define-dual ] each ] with-compilation-unit