Adding output>sequence and input<sequence to inverse; refactoring [ narray ] undo
parent
848cf3924f
commit
40b225f765
|
@ -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
|
USING: inverse tools.test arrays math kernel sequences
|
||||||
math.functions math.constants continuations ;
|
math.functions math.constants continuations combinators.smart ;
|
||||||
IN: inverse-tests
|
IN: inverse-tests
|
||||||
|
|
||||||
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
||||||
|
@ -69,7 +71,7 @@ C: <nil> nil
|
||||||
|
|
||||||
[ t ] [ pi [ pi ] matches? ] unit-test
|
[ t ] [ pi [ pi ] matches? ] unit-test
|
||||||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] 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
|
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
|
||||||
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] 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> ( -- funny-tuple ) \ funny-tuple boa ;
|
||||||
: funny-tuple ( -- ) "OOPS" throw ;
|
: 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
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors kernel words summary slots quotations
|
USING: accessors kernel words summary slots quotations
|
||||||
sequences assocs math arrays stack-checker effects generalizations
|
sequences assocs math arrays stack-checker effects generalizations
|
||||||
continuations debugger classes.tuple namespaces make vectors
|
continuations debugger classes.tuple namespaces make vectors
|
||||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||||
sequences.private combinators mirrors splitting
|
sequences.private combinators mirrors splitting combinators.smart
|
||||||
combinators.short-circuit fry words.symbol generalizations ;
|
combinators.short-circuit fry words.symbol generalizations
|
||||||
RENAME: _ fry => __
|
classes ;
|
||||||
IN: inverse
|
IN: inverse
|
||||||
|
|
||||||
ERROR: fail ;
|
ERROR: fail ;
|
||||||
M: fail summary drop "Matching failed" ;
|
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
|
! Inverse of a quotation
|
||||||
|
|
||||||
|
@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
|
||||||
\ pick [ [ pick ] dip =/fail ] define-inverse
|
\ pick [ [ pick ] dip =/fail ] define-inverse
|
||||||
\ tuck [ swapd [ =/fail ] keep ] 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
|
\ not define-involution
|
||||||
\ >boolean [ { t f } memq? assure ] define-inverse
|
\ >boolean [ dup { t f } memq? assure ] define-inverse
|
||||||
|
|
||||||
\ tuple>array \ >tuple define-dual
|
\ tuple>array \ >tuple define-dual
|
||||||
\ reverse define-involution
|
\ reverse define-involution
|
||||||
|
|
||||||
\ undo 1 [ [ call ] curry ] define-pop-inverse
|
\ undo 1 [ ] define-pop-inverse
|
||||||
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
|
\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
|
||||||
|
|
||||||
\ exp \ log define-dual
|
\ exp \ log define-dual
|
||||||
\ sq \ sqrt define-dual
|
\ sq \ sqrt define-dual
|
||||||
|
@ -173,16 +178,13 @@ ERROR: missing-literal ;
|
||||||
2curry
|
2curry
|
||||||
] define-pop-inverse
|
] define-pop-inverse
|
||||||
|
|
||||||
DEFER: _
|
DEFER: __
|
||||||
\ _ [ drop ] define-inverse
|
\ __ [ drop ] define-inverse
|
||||||
|
|
||||||
: both ( object object -- object )
|
: both ( object object -- object )
|
||||||
dupd assert= ;
|
dupd assert= ;
|
||||||
\ both [ dup ] define-inverse
|
\ both [ dup ] define-inverse
|
||||||
|
|
||||||
: assure-length ( seq length -- seq )
|
|
||||||
over length =/fail ;
|
|
||||||
|
|
||||||
{
|
{
|
||||||
{ >array array? }
|
{ >array array? }
|
||||||
{ >vector vector? }
|
{ >vector vector? }
|
||||||
|
@ -194,14 +196,23 @@ DEFER: _
|
||||||
{ >string string? }
|
{ >string string? }
|
||||||
{ >sbuf sbuf? }
|
{ >sbuf sbuf? }
|
||||||
{ >quotation quotation? }
|
{ >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?
|
: assure-length ( seq length -- )
|
||||||
\ 1array [ 1 assure-length first ] define-inverse
|
swap length =/fail ; inline
|
||||||
\ 2array [ 2 assure-length first2 ] define-inverse
|
|
||||||
\ 3array [ 3 assure-length first3 ] define-inverse
|
: assure-array ( array -- array )
|
||||||
\ 4array [ 4 assure-length first4 ] define-inverse
|
dup array? assure ; inline
|
||||||
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
|
|
||||||
|
: 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
|
\ first [ 1array ] define-inverse
|
||||||
\ first2 [ 2array ] define-inverse
|
\ first2 [ 2array ] define-inverse
|
||||||
|
@ -214,6 +225,12 @@ DEFER: _
|
||||||
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
|
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
|
||||||
\ prepend 1 [ [ ?head 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
|
! Constructor inverse
|
||||||
: deconstruct-pred ( class -- quot )
|
: deconstruct-pred ( class -- quot )
|
||||||
"predicate" word-prop [ dupd call assure ] curry ;
|
"predicate" word-prop [ dupd call assure ] curry ;
|
||||||
|
@ -245,7 +262,7 @@ DEFER: _
|
||||||
] recover ; inline
|
] recover ; inline
|
||||||
|
|
||||||
: true-out ( quot effect -- quot' )
|
: true-out ( quot effect -- quot' )
|
||||||
out>> '[ @ __ ndrop t ] ;
|
out>> '[ @ _ ndrop t ] ;
|
||||||
|
|
||||||
: false-recover ( effect -- quot )
|
: false-recover ( effect -- quot )
|
||||||
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
||||||
|
|
Loading…
Reference in New Issue