steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix to inverse, and syntax change

db4
Daniel Ehrenberg 2008-04-07 00:45:46 -05:00
parent d81a4aa914
commit 368599baf8
2 changed files with 14 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
extra/inverse/inverse-tests.factor
View File

@ -1,5 +1,5 @@
USING: inverse tools.test arrays math kernel sequences USING: inverse tools.test arrays math kernel sequences
math.functions math.constants ; math.functions math.constants continuations ;
IN: inverse-tests IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@ -51,7 +51,7 @@ C: <nil> nil
{ {
{ [ <cons> ] [ list-sum + ] } { [ <cons> ] [ list-sum + ] }
{ [ <nil> ] [ 0 ] } { [ <nil> ] [ 0 ] }
{ [ ] [ "Malformed list" throw ] } [ "Malformed list" throw ]
} switch ; } switch ;
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test [ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
@ -59,6 +59,7 @@ C: <nil> nil
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test [ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test [ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test [ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
: empty-cons ( -- cons ) cons construct-empty ; : empty-cons ( -- cons ) cons construct-empty ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ; : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
@ -68,3 +69,4 @@ 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

17
extra/inverse/inverse.factor
View File

@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
PREDICATE: pop-inverse < word "pop-length" word-prop ; PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ; UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: enough? ( stack quot -- ? ) : enough? ( stack word -- ? )
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ] dup deferred? [ 2drop f ] [
recover ; [ >r length r> 1quotation infer effect-in >= ]
[ 3drop f ] recover
] if ;
: fold-word ( stack quot -- stack ) : fold-word ( stack word -- stack )
2dup enough? 2dup enough?
[ 1quotation with-datastack ] [ >r % r> , { } ] if ; [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
[ { } swap [ fold-word ] each % ] [ ] make ; [ { } swap [ fold-word ] each % ] [ ] make ;
: flattenable? ( object -- ? ) : flattenable? ( object -- ? )
[ [ word? ] [ primitive? not ] and? ] [ { [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" } { "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not [ word-prop ] with contains? not
] and? ; ] } <-&& ;
: (flatten) ( quot -- ) : (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ; [ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ;
2curry 2curry
] define-pop-inverse ] define-pop-inverse
: _ f ; DEFER: _
\ _ [ drop ] define-inverse \ _ [ drop ] define-inverse
: both ( object object -- object ) : both ( object object -- object )
@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ; [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
: [switch] ( quot-alist -- quot ) : [switch] ( quot-alist -- quot )
[ dup quotation? [ [ ] swap 2array ] when ] map
reverse [ >r [undo] r> compose ] { } assoc>map reverse [ >r [undo] r> compose ] { } assoc>map
recover-chain ; recover-chain ;