factor: trim using lists

[factor.git] / basis / inverse / inverse.factor

diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor
index 8ba0289060d4be042b16dd7c9018d28fcb74bf0d..13537e2c920850449375e80fb9423dbdba3f390c 100644 (file)
--- a/basis/inverse/inverse.factor
+++ b/basis/inverse/inverse.factor
@@ -1,12 +1,12 @@
 ! 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
-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
-sequences.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 ;
@@ -28,20 +28,17 @@ M: fail summary drop "Matching failed" ;
 : 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 ;
+:: 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 ;
@@ -52,9 +49,6 @@ ERROR: bad-math-inverse ;
 : 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 >boolean ;
@@ -82,14 +76,14 @@ 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>>
@@ -98,7 +92,7 @@ SYMBOL: visited
                 bi
             ] [ 1quotation ] if
         ] map concat
-    ] with-scope ;
+    ] with-variable ;
 
 ERROR: undefined-inverse ;
 
@@ -158,9 +152,9 @@ MACRO: undo ( quot -- quot ) [undo] ;
 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
@@ -178,6 +172,7 @@ DEFER: __
 
 : both ( object object -- object )
     dupd assert= ;
+
 \ both [ dup ] define-inverse
 
 {
@@ -264,7 +259,7 @@ DEFER: __
 
 : recover-fail ( try fail -- )
     [ drop call ] [
-        [ nip ] dip dup fail?
+        nipd dup fail?
         [ drop call ] [ nip throw ] if
     ] recover ; inline
 
@@ -280,6 +275,7 @@ DEFER: __
 MACRO: matches? ( quot -- quot' ) [matches?] ;
 
 ERROR: no-match ;
+
 M: no-match summary drop "Fall through in switch" ;
 
 : recover-chain ( seq -- quot )
@@ -291,3 +287,7 @@ M: no-match summary drop "Fall through in switch" ;
     recover-chain ;
 
 MACRO: switch ( quot-alist -- quot ) [switch] ;
+
+SYNTAX: INVERSE: scan-word parse-definition define-inverse ;
+
+SYNTAX: DUAL: scan-word scan-word define-dual ;