From fbdf62bb1cf45809ed64061220c7aa9569cc64d9 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 29 Mar 2008 16:18:46 -0400 Subject: [PATCH] Making [ mpg ] undo work --- extra/inverse/inverse.factor | 55 +++++++++++++++++++--------------- extra/units/units-tests.factor | 4 +-- extra/units/units.factor | 6 ++++ 3 files changed, 38 insertions(+), 27 deletions(-) diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 308bf36bf4..f4bd403b75 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,7 +1,8 @@ USING: kernel words inspector slots quotations sequences assocs math arrays inference effects shuffle continuations debugger tuples namespaces vectors bit-arrays byte-arrays strings sbufs -math.functions macros sequences.private combinators mirrors ; +math.functions macros sequences.private combinators mirrors +combinators.lib ; IN: inverse TUPLE: fail ; @@ -59,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 ; @@ -108,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] ; diff --git a/extra/units/units-tests.factor b/extra/units/units-tests.factor index 9f0e704157..9b450ed18b 100755 --- a/extra/units/units-tests.factor +++ b/extra/units/units-tests.factor @@ -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 } = ] 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 diff --git a/extra/units/units.factor b/extra/units/units.factor index 13d0a5d1cf..b92cbb659a 100755 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -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