Fix conflict
commit
f72336e70e
|
@ -2,7 +2,7 @@ USING: kernel words inspector slots quotations sequences assocs
|
|||
math arrays inference effects shuffle continuations debugger
|
||||
classes.tuple namespaces vectors bit-arrays byte-arrays strings
|
||||
sbufs math.functions macros sequences.private combinators
|
||||
mirrors ;
|
||||
mirrors combinators.lib ;
|
||||
IN: inverse
|
||||
|
||||
TUPLE: fail ;
|
||||
|
@ -60,38 +60,44 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
|
|||
PREDICATE: pop-inverse < word "pop-length" word-prop ;
|
||||
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
|
||||
|
||||
: inline-word ( word -- )
|
||||
{
|
||||
{ [ dup word? not over symbol? or ] [ , ] }
|
||||
{ [ dup explicit-inverse? ] [ , ] }
|
||||
! { [ dup compound? over { if dispatch } member? not and ]
|
||||
! [ word-def [ inline-word ] each ] }
|
||||
{ [ dup word? over { if dispatch } member? not and ]
|
||||
[ word-def [ inline-word ] each ] }
|
||||
{ [ drop t ] [ "Quotation is not invertible" throw ] }
|
||||
} cond ;
|
||||
: enough? ( stack quot -- ? )
|
||||
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
|
||||
recover ;
|
||||
|
||||
: math-exp? ( n n word -- ? )
|
||||
{ + - * / ^ } member? -rot [ number? ] both? and ;
|
||||
: fold-word ( stack quot -- stack )
|
||||
2dup enough?
|
||||
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
|
||||
|
||||
: (fold-constants) ( quot -- )
|
||||
dup length 3 < [ % ] [
|
||||
dup first3 3dup math-exp?
|
||||
[ execute , 3 ] [ 2drop , 1 ] if
|
||||
tail-slice (fold-constants)
|
||||
] if ;
|
||||
: fold ( quot -- folded-quot )
|
||||
[ { } swap [ fold-word ] each % ] [ ] make ;
|
||||
|
||||
: fold-constants ( quot -- folded )
|
||||
[ (fold-constants) ] [ ] make ;
|
||||
: flattenable? ( object -- ? )
|
||||
[ [ word? ] [ primitive? not ] and? ] [
|
||||
{ "inverse" "math-inverse" "pop-inverse" }
|
||||
[ word-prop ] with contains? not
|
||||
] and? ;
|
||||
|
||||
: do-inlining ( quot -- inlined-quot )
|
||||
[ [ inline-word ] each ] [ ] make fold-constants ;
|
||||
: (flatten) ( quot -- )
|
||||
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
|
||||
|
||||
: retain-stack-overflow? ( error -- ? )
|
||||
{ "kernel-error" 14 f f } = ;
|
||||
|
||||
: flatten ( quot -- expanded )
|
||||
[ [ (flatten) ] [ ] make ] [
|
||||
dup retain-stack-overflow?
|
||||
[ drop "No inverse defined on recursive word" ] when
|
||||
throw
|
||||
] recover ;
|
||||
|
||||
GENERIC: inverse ( revquot word -- revquot* quot )
|
||||
|
||||
M: object inverse undo-literal ;
|
||||
|
||||
M: symbol inverse undo-literal ;
|
||||
|
||||
M: word inverse drop "Inverse is undefined" throw ;
|
||||
|
||||
M: normal-inverse inverse
|
||||
"inverse" word-prop ;
|
||||
|
||||
|
@ -109,7 +115,7 @@ M: pop-inverse inverse
|
|||
[ unclip-slice inverse % (undo) ] if ;
|
||||
|
||||
: [undo] ( quot -- undo )
|
||||
do-inlining reverse [ (undo) ] [ ] make ;
|
||||
flatten fold reverse [ (undo) ] [ ] make ;
|
||||
|
||||
MACRO: undo ( quot -- ) [undo] ;
|
||||
|
||||
|
|
|
@ -15,9 +15,7 @@ IN: units.tests
|
|||
[ t ] [ 1 m 2 m 3 m 3array d-product 6 m^3 = ] unit-test
|
||||
[ t ] [ 3 m d-recip 1/3 { } { m } <dimensioned> = ] unit-test
|
||||
|
||||
! I want these to work, Dan
|
||||
|
||||
: km/L km 1 L d/ ;
|
||||
: mpg miles 1 gallons d/ ;
|
||||
|
||||
! [ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
|
||||
[ t ] [ 100 10 / km/L [ mpg ] undo 23 1 ~ ] unit-test
|
||||
|
|
|
@ -95,3 +95,9 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
|
|||
: d-infimum ( v -- d ) unclip-slice [ d-min ] reduce ;
|
||||
|
||||
: d-supremum ( v -- d ) unclip-slice [ d-max ] reduce ;
|
||||
|
||||
\ d+ [ d- ] [ d- ] define-math-inverse
|
||||
\ d- [ d+ ] [ d- ] define-math-inverse
|
||||
\ d* [ d/ ] [ d/ ] define-math-inverse
|
||||
\ d/ [ d* ] [ d/ ] define-math-inverse
|
||||
\ d-recip [ d-recip ] define-inverse
|
||||
|
|
Loading…
Reference in New Issue