Initial data commit

Task/Numeric-error-propagation/Factor/numeric-error-propagation-1.factor

@@ -0,0 +1,80 @@
+USING: accessors arrays fry kernel locals math math.functions
+multi-methods parser prettyprint prettyprint.custom sequences ;
+RENAME: GENERIC: multi-methods => MM-GENERIC:
+FROM: syntax => M: ;
+IN: imprecise
+
+TUPLE: imprecise
+    { value float read-only }
+    { sigma float read-only } ;
+
+C: <imprecise> imprecise
+
+: >imprecise< ( imprecise -- value sigma )
+    [ value>> ] [ sigma>> ] bi ;
+
+! Define a custom syntax for imprecise numbers.
+
+<< SYNTAX: I{ \ } [ first2 <imprecise> ] parse-literal ; >>
+M: imprecise pprint-delims drop \ I{ \ } ;
+M: imprecise >pprint-sequence >imprecise< 2array ;
+M: imprecise pprint* pprint-object ;
+
+<PRIVATE
+
+! Error functions
+
+: f+-i ( float imprecise quot -- imprecise )
+    [ >imprecise< ] dip dip <imprecise> ; inline
+
+: i+-i ( imprecise1 imprecise2 quot -- imprecise )
+    '[ [ value>> ] bi@ @ ]
+    [ [ sigma>> sq ] bi@ + sqrt <imprecise> ] 2bi ; inline
+
+: f*/i ( float imprecise quot -- imprecise )
+    [ >imprecise< overd ] dip [ * abs ] 2bi* <imprecise> ;
+    inline
+
+:: i*/i ( a b quot -- imprecise )
+    a b [ >imprecise< ] bi@ :> ( vala siga valb sigb )
+    vala valb quot call :> val
+    val sq siga sq * vala sq /f sigb sq + valb sq /f sqrt :> sig
+    val sig <imprecise> ; inline
+
+PRIVATE>
+
+MM-GENERIC: ~+ ( obj1 obj2 -- imprecise ) foldable flushable
+METHOD: ~+ { float imprecise } [ + ] f+-i ;
+METHOD: ~+ { imprecise float } swap ~+ ;
+METHOD: ~+ { imprecise imprecise } [ + ] i+-i ;
+
+MM-GENERIC: ~- ( obj1 obj2 -- imprecise ) foldable flushable
+METHOD: ~- { float imprecise } [ - ] f+-i ;
+METHOD: ~- { imprecise float } swap [ swap - ] f+-i ;
+METHOD: ~- { imprecise imprecise } [ - ] i+-i ;
+
+MM-GENERIC: ~* ( obj1 obj2 -- imprecise ) foldable flushable
+METHOD: ~* { float imprecise } [ * ] f*/i ;
+METHOD: ~* { imprecise float } swap ~* ;
+METHOD: ~* { imprecise imprecise } [ * ] i*/i ;
+
+MM-GENERIC: ~/ ( obj1 obj2 -- imprecise ) foldable flushable
+METHOD: ~/ { float imprecise } [ /f ] f*/i ;
+METHOD: ~/ { imprecise float } swap [ swap /f ] f*/i ;
+METHOD: ~/ { imprecise imprecise } [ /f ] i*/i ;
+
+:: ~^ ( a x -- imprecise )
+    a >imprecise< :> ( vala siga )
+    vala x ^ >rect drop :> val
+    val x * siga vala /f * abs :> sig
+    val sig <imprecise> ; foldable flushable
+
+<PRIVATE
+
+: imprecise-demo ( -- )
+    I{ 100 1.1 } I{ 200 2.2 } ~- 2. ~^
+    I{ 50 1.2 } I{ 100 2.3 } ~- 2. ~^ ~+ 0.5 ~^ . ;
+
+PRIVATE>
+
+MAIN: imprecise-demo