factor: trim using lists

[factor.git] / extra / math / dual / dual.factor

diff --git a/extra/math/dual/dual.factor b/extra/math/dual/dual.factor
index 3e0e5437b4bff5491f635499f7db2ce05d865b19..b125861c83aa538c60aca88091d951b757569643 100644 (file)
--- a/extra/math/dual/dual.factor
+++ b/extra/math/dual/dual.factor
@@ -1,9 +1,8 @@
 ! Copyright (C) 2009 Jason W. Merrill.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.derivatives accessors
-    macros generic compiler.units words effects vocabs
-    sequences arrays assocs generalizations fry make
-    combinators.smart help help.markup ;
+USING: accessors arrays assocs combinators.smart compiler.units
+effects generalizations help help.markup kernel make math
+sequences vocabs words ;
 
 IN: math.dual
 
@@ -11,7 +10,7 @@ TUPLE: dual ordinary-part epsilon-part ;
 
 C: <dual> dual
 
-! Ordinary numbers implement the dual protocol by returning 
+! Ordinary numbers implement the dual protocol by returning
 ! themselves as the ordinary part, and 0 as the epsilon part.
 M: number ordinary-part>> ;
 
@@ -28,43 +27,42 @@ MACRO: ordinary-op ( word -- o )
     [ input-length ] keep
     '[ [ ordinary-part>> ] _ napply _ execute ] ;
 
-! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves 
+! Takes N dual numbers <o1,e1> <o2,e2> ... <oN,eN> and weaves
 ! their ordinary and epsilon parts to produce
 ! e1 o1 o2 ... oN e2 o1 o2 ... oN ... eN o1 o2 ... oN
-! This allows a set of partial derivatives each to be evaluated 
+! This allows a set of partial derivatives each to be evaluated
 ! at the same point.
-MACRO: duals>nweave ( n -- )
+MACRO: duals>nweave ( n -- quot )
    dup dup dup
    '[
-       [ [ epsilon-part>> ] _ napply ]
-       _ nkeep
-       [ ordinary-part>> ] _ napply
-       _ nweave
+       [ [ epsilon-part>> ] _ napply ] _ nkeep
+       [ ordinary-part>> ] _ napply _ nweave
     ] ;
 
 MACRO: chain-rule ( word -- e )
     [ input-length '[ _ duals>nweave ] ]
     [ "derivative" word-prop ]
-    [ input-length 1+ '[ _ nspread ] ]
+    [ input-length 1 + '[ _ nspread ] ]
     tri
     '[ [ @ _ @ ] sum-outputs ] ;
 
-: set-dual-help ( word dword -- ) 
-    [ swap
-        [ stack-effect [ in>> ] [ out>> ] bi append 
+: set-dual-help ( dword word -- )
+    [
+        [
+            stack-effect [ in>> ] [ out>> ] bi append
             [ dual ] { } map>assoc { $values } prepend
-        ]
-        [ [ { $description } % "Version of " , 
-                   { $link } swap suffix , 
-                   " extended to work on dual numbers." , ] 
-            { } make
-        ]
-        bi* 2array
-    ] keep set-word-help ;
+        ] [
+            [
+                { $description } % "Version of " ,
+                { $link } swap suffix ,
+                " extended to work on dual numbers." ,
+            ] { } make
+        ] bi* 2array
+    ] keepd set-word-help ;
 
 PRIVATE>
 
-MACRO: dual-op ( word -- )
+MACRO: dual-op ( word -- quot )
     [ '[ _ ordinary-op ] ]
     [ input-length '[ _ nkeep ] ]
     [ '[ _ chain-rule ] ]
@@ -72,12 +70,12 @@ MACRO: dual-op ( word -- )
     '[ _ @ @ <dual> ] ;
 
 : define-dual ( word -- )
-    dup name>> "d" prepend "math.dual" create
-    [ [ stack-effect ] dip set-stack-effect ]
+    [ name>> "d" prepend "math.dual" create-word ] keep
+    [ stack-effect set-stack-effect ]
     [ set-dual-help ]
-    [ swap '[ _ dual-op ] define ]
+    [ '[ _ dual-op ] define ]
     2tri ;
 
 ! Specialize math functions to operate on dual numbers.
 [ all-words [ "derivative" word-prop ] filter
-    [ define-dual ] each ] with-compilation-unit
\ No newline at end of file
+[ define-dual ] each ] with-compilation-unit