! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals words summary slots quotations
-sequences assocs math arrays stack-checker effects
-continuations debugger classes.tuple namespaces make vectors
-bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting combinators.smart
-combinators.short-circuit fry words.symbol generalizations
-classes ;
+USING: accessors arrays assocs bit-arrays byte-arrays classes
+classes.tuple combinators combinators.short-circuit
+combinators.smart continuations effects generalizations
+kernel make math math.functions namespaces parser
+quotations sbufs sequences sequences.generalizations slots
+splitting stack-checker strings summary vectors words
+words.symbol ;
IN: inverse
ERROR: fail ;
: define-math-inverse ( word quot1 quot2 -- )
pick 1quotation 3array "math-inverse" set-word-prop ;
-: define-pop-inverse ( word n quot -- )
- [ dupd "pop-length" set-word-prop ] dip
- "pop-inverse" set-word-prop ;
-
-ERROR: no-inverse word ;
-M: no-inverse summary
- drop "The word cannot be used in pattern matching" ;
+:: define-pop-inverse ( word n quot -- )
+ word n "pop-length" set-word-prop
+ word quot "pop-inverse" set-word-prop ;
ERROR: bad-math-inverse ;
: next ( revquot -- revquot* first )
- [ bad-math-inverse ]
- [ unclip-slice ] if-empty ;
+ [ bad-math-inverse ] [ unclip-slice ] if-empty ;
: constant-word? ( word -- ? )
- stack-effect
- [ out>> length 1 = ]
- [ in>> empty? ] bi and ;
+ stack-effect [ out>> length 1 = ] [ in>> empty? ] bi and ;
: assure-constant ( constant -- quot )
dup word? [ bad-math-inverse ] when 1quotation ;
: pull-inverse ( math-inverse revquot const -- revquot* quot )
assure-constant rot first compose ;
-: ?word-prop ( word/object name -- value/f )
- over word? [ word-prop ] [ 2drop f ] if ;
-
: undo-literal ( object -- quot ) [ =/fail ] curry ;
-PREDICATE: normal-inverse < word "inverse" word-prop ;
-PREDICATE: math-inverse < word "math-inverse" word-prop ;
-PREDICATE: pop-inverse < word "pop-length" word-prop ;
+PREDICATE: normal-inverse < word "inverse" word-prop >boolean ;
+PREDICATE: math-inverse < word "math-inverse" word-prop >boolean ;
+PREDICATE: pop-inverse < word "pop-length" word-prop >boolean ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
- [ [ length ] [ 1quotation infer in>> ] bi* >= ]
+ [ [ length ] [ 1quotation inputs ] bi* >= ]
[ 3drop f ] recover
] if ;
if ;
: fold ( quot -- folded-quot )
- [ { } [ fold-word ] reduce % ] [ ] make ;
+ [ { } [ fold-word ] reduce % ] [ ] make ;
ERROR: no-recursive-inverse ;
SYMBOL: visited
: flattenable? ( object -- ? )
- { [ word? ] [ primitive? not ] [
- { "inverse" "math-inverse" "pop-inverse" }
- [ word-prop ] with any? not
- ] } 1&& ;
+ {
+ [ word? ]
+ [ primitive? not ]
+ [ explicit-inverse? not ]
+ } 1&& ;
: flatten ( quot -- expanded )
- [
- visited [ over suffix ] change
+ visited get over suffix visited [
[
dup flattenable? [
def>>
bi
] [ 1quotation ] if
] map concat
- ] with-scope ;
+ ] with-variable ;
ERROR: undefined-inverse ;
: [undo] ( quot -- undo )
flatten fold reverse [ (undo) ] [ ] make ;
-MACRO: undo ( quot -- ) [undo] ;
+MACRO: undo ( quot -- quot ) [undo] ;
! Inverse of selected words
\ undo 1 [ ] define-pop-inverse
\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
-\ exp \ log define-dual
+\ e^ \ log define-dual
\ sq \ sqrt define-dual
ERROR: missing-literal ;
: assert-literal ( n -- n )
- dup
- [ word? ] [ symbol? not ] bi and
+ dup { [ word? ] [ symbol? not ] } 1&&
[ missing-literal ] when ;
+
\ + [ - ] [ - ] define-math-inverse
\ - [ + ] [ - ] define-math-inverse
\ * [ / ] [ / ] define-math-inverse
: both ( object object -- object )
dupd assert= ;
+
\ both [ dup ] define-inverse
{
\ first4 [ 4array ] define-inverse
\ prefix \ unclip define-dual
-\ suffix [ dup but-last swap last ] define-inverse
+\ suffix \ unclip-last define-dual
\ 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
+ [ class-of ] same? 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 ;
+ predicate-def [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
: empty-inverse ( class -- quot )
deconstruct-pred
- [ tuple>array rest [ ] any? [ fail ] when ]
+ [ tuple-slots [ ] any? [ fail ] when ]
compose ;
\ new 1 [ ?wrapped empty-inverse ] define-pop-inverse
: recover-fail ( try fail -- )
[ drop call ] [
- [ nip ] dip dup fail?
+ nipd dup fail?
[ drop call ] [ nip throw ] if
] recover ; inline
: true-out ( quot effect -- quot' )
- out>> '[ @ _ ndrop t ] ;
+ out>> length '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
- in>> [ ndrop f ] curry [ recover-fail ] curry ;
+ in>> length [ ndrop f ] curry [ recover-fail ] curry ;
: [matches?] ( quot -- undoes?-quot )
[undo] dup infer [ true-out ] [ false-recover ] bi curry ;
-MACRO: matches? ( quot -- ? ) [matches?] ;
+MACRO: matches? ( quot -- quot' ) [matches?] ;
ERROR: no-match ;
+
M: no-match summary drop "Fall through in switch" ;
: recover-chain ( seq -- quot )
reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
-MACRO: switch ( quot-alist -- ) [switch] ;
+MACRO: switch ( quot-alist -- quot ) [switch] ;
+
+SYNTAX: INVERSE: scan-word parse-definition define-inverse ;
+
+SYNTAX: DUAL: scan-word scan-word define-dual ;
projects / factor.git / blobdiff