From 40b225f7651836a0cb6fb38ac4753053151c8e67 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 1 May 2009 22:14:26 -0500 Subject: [PATCH] Adding output>sequence and input 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 boa ; : funny-tuple ( -- ) "OOPS" throw ; -[ ] [ [ ] [undo] drop ] unit-test \ No newline at end of file +[ ] [ [ ] [undo] drop ] unit-test + +[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test +[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input __ +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 _ inputsequence ] ] 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 ;