81 lines
2.3 KiB
Factor
81 lines
2.3 KiB
Factor
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
|