Making [ mpg ] undo work

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 -- )
+: enough? ( stack quot -- ? )
-    {
+    [ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
-        { [ dup word? not over symbol? or ] [ , ] }
+    recover ;
-        { [ 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 ;
 
-: math-exp? ( n n word -- ? )
+: fold-word ( stack quot -- stack )
-    { + - * / ^ } member? -rot [ number? ] both? and ;
+    2dup enough?
+    [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
 
-: (fold-constants) ( quot -- )
+: fold ( quot -- folded-quot )
-    dup length 3 < [ % ] [
+    [ { } swap [ fold-word ] each % ] [ ] make ; 
-        dup first3 3dup math-exp?
-        [ execute , 3 ] [ 2drop , 1 ] if
-        tail-slice (fold-constants) 
-    ] if ;
 
-: fold-constants ( quot -- folded )
+: flattenable? ( object -- ? )
-    [ (fold-constants) ] [ ] make ;
+    [ [ word? ] [ primitive? not ] and? ] [
+        { "inverse" "math-inverse" "pop-inverse" }
+        [ word-prop ] with contains? not
+    ] and? ; 
 
-: do-inlining ( quot -- inlined-quot )
+: (flatten) ( quot -- )
-    [ [ inline-word ] each ] [ ] make fold-constants ;
+    [ 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] ;
 

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 } <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

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