Adding output>sequence and input<sequence to inverse; refactoring [ narray ] undo

basis/inverse/inverse-tests.factor

@@ -1,5 +1,7 @@
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants continuations ;
+math.functions math.constants continuations combinators.smart ;
 IN: inverse-tests
 
 [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@@ -69,7 +71,7 @@ C: <nil> nil
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
-[ ] [ 3 [ _ ] undo ] unit-test
+[ ] [ 3 [ __ ] undo ] unit-test
 
 [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
 [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
@@ -88,4 +90,7 @@ TUPLE: funny-tuple ;
 : <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
 : funny-tuple ( -- ) "OOPS" throw ;
 
-[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+
+[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test

basis/inverse/inverse.factor

@@ -1,20 +1,20 @@
-! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel words summary slots quotations
 sequences assocs math arrays stack-checker effects generalizations
 continuations debugger classes.tuple namespaces make vectors
 bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting
-combinators.short-circuit fry words.symbol generalizations ;
-RENAME: _ fry => __
+sequences.private combinators mirrors splitting combinators.smart
+combinators.short-circuit fry words.symbol generalizations
+classes ;
 IN: inverse
 
 ERROR: fail ;
 M: fail summary drop "Matching failed" ;
 
-: assure ( ? -- ) [ fail ] unless ;
+: assure ( ? -- ) [ fail ] unless ; inline
 
-: =/fail ( obj1 obj2 -- ) = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ; inline
 
 ! Inverse of a quotation
 
@@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
 \ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
+\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
+\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
+\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
+\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
+
 \ not define-involution
-\ >boolean [ { t f } memq? assure ] define-inverse
+\ >boolean [ dup { t f } memq? assure ] define-inverse
 
 \ tuple>array \ >tuple define-dual
 \ reverse define-involution
 
-\ undo 1 [ [ call ] curry ] define-pop-inverse
-\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
+\ undo 1 [ ] define-pop-inverse
+\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
 
 \ exp \ log define-dual
 \ sq \ sqrt define-dual
@@ -173,16 +178,13 @@ ERROR: missing-literal ;
     2curry
 ] define-pop-inverse
 
-DEFER: _
-\ _ [ drop ] define-inverse
+DEFER: __
+\ __ [ drop ] define-inverse
 
 : both ( object object -- object )
     dupd assert= ;
 \ both [ dup ] define-inverse
 
-: assure-length ( seq length -- seq )
-    over length =/fail ;
-
 {
     { >array array? }
     { >vector vector? }
@@ -194,14 +196,23 @@ DEFER: _
     { >string string? }
     { >sbuf sbuf? }
     { >quotation quotation? }
-} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
+} [ '[ dup _ execute assure ] define-inverse ] assoc-each
 
-! These actually work on all seqs--should they?
-\ 1array [ 1 assure-length first ] define-inverse
-\ 2array [ 2 assure-length first2 ] define-inverse
-\ 3array [ 3 assure-length first3 ] define-inverse
-\ 4array [ 4 assure-length first4 ] define-inverse
-\ narray 1 [ [ firstn ] curry ] define-pop-inverse
+: assure-length ( seq length -- )
+    swap length =/fail ; inline
+
+: assure-array ( array -- array )
+    dup array? assure ; inline
+
+: undo-narray ( array n -- ... )
+    [ assure-array ] dip
+    [ assure-length ] [ firstn ] 2bi ; inline
+
+\ 1array [ 1 undo-narray ] define-inverse
+\ 2array [ 2 undo-narray ] define-inverse
+\ 3array [ 3 undo-narray ] define-inverse
+\ 4array [ 4 undo-narray ] define-inverse
+\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
 
 \ first [ 1array ] define-inverse
 \ first2 [ 2array ] define-inverse
@@ -214,6 +225,12 @@ DEFER: _
 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
 \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
 
+: assure-same-class ( obj1 obj2 -- )
+    [ class ] bi@ = assure ; inline
+
+\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
+\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
     "predicate" word-prop [ dupd call assure ] curry ;
@@ -245,7 +262,7 @@ DEFER: _
     ] recover ; inline
 
 : true-out ( quot effect -- quot' )
-    out>> '[ @ __ ndrop t ] ;
+    out>> '[ @ _ ndrop t ] ;
 
 : false-recover ( effect -- quot )
     in>> [ ndrop f ] curry [ recover-fail ] curry ;