Merge branch 'master' of git://factorforge.org/git/drford

extra/24-game/24-game-docs.factor

@@ -31,12 +31,12 @@ HELP: 24-able ( -- vector )
     "just using the provided commands and the 4 numbers. The Following are the "
     "provided commands: "
     { $link + } ", " { $link - } ", " { $link * } ", "
-    { $link / } ", and " { $link swap } "."
+    { $link / } ", " { $link swap } ", and " { $link rot } "."
 }
 { $examples
     { $example
         "USE: 24-game"
-        "24-able vector-24-able?"
+        "24-able vector-24-able? ."
         "t"
     }
     { $notes { $link 24-able? } " is used in " { $link 24-able } "." }

extra/24-game/24-game.factor

@@ -60,3 +60,4 @@ DEFER: check-status
 : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ;
 : set-commands ( -- ) { + - * / rot swap q } commands set ;
 : play-game ( -- ) set-commands 24-able repeat ;
+MAIN: play-game

extra/animations/animations-docs.factor

@@ -1,34 +1,65 @@
 USING: help.markup help.syntax ;
-IN: extra.animations
+IN: animations
 
 HELP: animate ( quot duration -- )
+
 { $values
     { "quot" "a quot which uses " { $link progress } }
     { "duration" "a duration of time" }
 }
-{ $description { $link animate } " calls " { $link reset-progress } " , then continously calls the given quot until the duration of time has elapsed. The quot should use " { $link progress } " at least once."  }
-{ $example 
-    "USING: extra.animations calendar threads prettyprint ;"
-    "[ 1 sleep progress unparse write \" ms elapsed\" print ] 1/20 seconds animate ;"
+{ $description
+    { $link animate } " calls " { $link reset-progress }
+    " , then continously calls the given quot until the"
+    " duration of time has elapsed. The quot should use "
+    { $link progress } " at least once."
+}
+{ $examples
+    { $unchecked-example 
+        "USING: animations calendar threads prettyprint ;"
+        "[ 1 sleep progress unparse write \" ms elapsed\" print ] "
+        "1/20 seconds animate ;"
         "46 ms elapsed\n17 ms elapsed"
+    }
+    { $notes "The amount of time elapsed between these iterations will very." }
 } ;
 
 HELP: reset-progress ( -- )
-{ $description "Initiates the timer. Call this before using a loop which makes use of " { $link progress } "." } ;
+{ $description
+    "Initiates the timer. Call this before using "
+    "a loop which makes use of " { $link progress } "."
+} ;
 
 HELP: progress ( -- time )
 { $values { "time" "an integer" } }
-{ $description "Gives the time elapsed since the last time this word was called, in milliseconds." }
-{ $example
-    "USING: extra.animations threads prettyprint ;"
-    "reset-progress 3 [ 1 sleep progress unparse write \"ms elapsed\" print ] times ;"
+{ $description
+    "Gives the time elapsed since the last time"
+    " this word was called, in milliseconds." 
+}
+{ $examples
+    { $unchecked-example
+        "USING: animations threads prettyprint ;"
+        "reset-progress 3 "
+        "[ 1 sleep progress unparse write \"ms elapsed\" print ] "
+        "times ;"
         "31 ms elapsed\n18 ms elapsed\n16 ms elapsed"
+    }
+    { $notes "The amount of time elapsed between these iterations will very." }
 } ;
 
-ARTICLE: "extra.animations" "Animations"
-"Provides a lightweight framework for properly simulating continuous functions of real time. This framework helps one create animations that use rates which do not change across platforms. The speed of the computer should correlate with the smoothness of the animation, not the speed of the animation!"
+ARTICLE: "animations" "Animations"
+"Provides a lightweight framework for properly simulating continuous"
+" functions of real time. This framework helps one create animations "
+"that use rates which do not change across platforms. The speed of the "
+"computer should correlate with the smoothness of the animation, not "
+"the speed of the animation!"
 { $subsection animate }
 { $subsection reset-progress }
 { $subsection progress }
-{ $link progress } " specifically provides the length of time since " { $link reset-progress } " was called, and also calls " { $link reset-progress } " as its last action. This can be directly used when one's quote runs for a specific number of iterations, instead of a length of time. If the animation is like most, and is expected to run for a specific length of time, " { $link animate } " should be used." ;
-ABOUT: "extra.animations"
+! A little talk about when to use progress and when to use animate
+    { $link progress } " specifically provides the length of time since "
+    { $link reset-progress } " was called, and also calls "
+    { $link reset-progress } " as its last action. This can be directly "
+    "used when one's quote runs for a specific number of iterations, instead "
+    "of a length of time. If the animation is like most, and is expected to "
+    "run for a specific length of time, " { $link animate } " should be used." ;
+ABOUT: "animations"

extra/animations/animations.factor

@@ -2,11 +2,16 @@
 
 USING: kernel shuffle system locals
 prettyprint math io namespaces threads calendar ;
-IN: extra.animations
+IN: animations
 
 SYMBOL: last-loop
+SYMBOL: sleep-period
+
 : reset-progress ( -- ) millis last-loop set ;
+! : my-progress ( -- progress ) millis 
 : progress ( -- progress ) millis last-loop get - reset-progress ;
+: progress-peek ( -- progress ) millis last-loop get - ;
 : set-end ( duration -- end-time ) dt>milliseconds millis + ;
-: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ;
-: animate ( quot duration -- ) reset-progress set-end loop ;
+: loop ( quot end -- ) dup millis > [ [ dup call ] dip loop ] [ 2drop ] if ; inline
+: animate ( quot duration -- ) reset-progress set-end loop ; inline
+: sample ( revs quot -- avg ) reset-progress dupd times progress swap / ; inline

extra/animations/authors.txt

@@ -1 +1 @@
-Reginald Keith Ford II
+Reginald Ford

extra/math/derivatives/authors.txt

@@ -1 +1,2 @@
 Reginald Ford
+Eduardo Cavazos

extra/math/derivatives/derivatives-docs.factor

@@ -1,9 +1,101 @@
-USING: help.markup help.syntax ;
-
+USING: help.markup help.syntax math.functions ;
 IN: math.derivatives
 
 HELP: derivative ( x function -- m )
-{ $values { "x" "the x-position on the function" } { "function" "a differentiable function" } }
-{ $description "Finds the slope of the tangent line at the given x-position on the given function." } ;
+{ $values { "x" "a position on the function" } { "function" "a differentiable function" } }
+{ $description
+    "Approximates the slope of the tangent line by using Ridders' "
+    "method of computing derivatives, from the chapter \"Accurate computation "
+    "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, Vol. 4, pp. 75-76 ."
+}
+{ $examples
+    { $example
+        "USING: math.derivatives prettyprint ;"
+        "[ sq ] 4 derivative ."
+        "8"
+    }
+    { $notes
+        "For applied scientists, you may play with the settings "
+        "in the source file to achieve arbitrary accuracy. "
+    }
+} ;
 
-{ derivative-func } related-words
+HELP: (derivative) ( x function h err -- m )
+{ $values
+    { "x" "a position on the function" }
+    { "function" "a differentiable function" }
+    {
+        "h" "distance between the points of the first secant line used for "
+        "approximation of the tangent. This distance will be divided "
+        "constantly, by " { $link con } ". See " { $link init-hh }
+        " for the code which enforces this. H should be .001 to .5 -- too "
+        "small can cause bad convergence. Also, h should be small enough "
+        "to give the correct sgn(f'(x)). In other words, if you're expecting "
+        "a positive derivative, make h small enough to give the same "
+        "when plugged into the academic limit definition of a derivative. "
+        "See " { $link update-hh } " for the code which performs this task."
+    }
+    {
+        "err" "maximum tolerance of increase in error. For example, if this "
+        "is set to 2.0, the program will terminate with its nearest answer "
+        "when the error multiplies by 2. See " { $link check-safe } " for "
+        "the enforcing code."
+    }
+}
+{ $description
+    "Approximates the slope of the tangent line by using Ridders' "
+    "method of computing derivatives, from the chapter \"Accurate computation "
+    "of F'(x) and F'(x)F''(x)\", from \"Advances in Engineering Software, "
+    "Vol. 4, pp. 75-76 ."
+}
+{ $examples
+    { $example
+        "USING: math.derivatives prettyprint ;"
+        "[ sq ] 4 derivative ."
+        "8"
+    }
+    { $notes
+        "For applied scientists, you may play with the settings "
+        "in the source file to achieve arbitrary accuracy. "
+    }
+} ;
+
+HELP: derivative-func ( function -- der )
+{ $values { "func" "a differentiable function" } { "der" "the derivative" } }
+{ $description
+    "Provides the derivative of the function. The implementation simply "
+    "attaches the " { $link derivative } " word to the end of the function."
+}
+{ $examples
+    { $example
+        "USING: math.derivatives prettyprint ;"
+        "60 deg>rad [ sin ] derivative-func call ."
+        "0.5000000000000173"
+    }
+    { $notes
+        "Without a heavy algebraic system, derivatives must be "
+        "approximated. With the current settings, there is a fair trade of "
+        "speed and accuracy; the first 12 digits "
+        "will always be correct with " { $link sin } " and " { $link cos }
+        ". The following code performs a minumum and maximum error test."
+        { $code
+            "USING: kernel math math.functions math.trig sequences sequences.lib ;"
+            "360"
+            "["
+            "           deg>rad"
+            "            [ [ sin ] derivative-func call ]"
+            "           ! Note: the derivative of sin is cos"
+            "            [ cos ]"
+            "       bi - abs"
+            "] map minmax"
+            
+        }
+    }
+} ;
+
+ARTICLE: "derivatives" "The Derivative Toolkit"
+"A toolkit for computing the derivative of functions."
+{ $subsection derivative }
+{ $subsection derivative-func }
+{ $subsection (derivative) } ;
+ABOUT: "derivatives"

extra/math/derivatives/derivatives.factor

@@ -1,10 +1,123 @@
-! Copyright © 2008 Reginald Keith Ford II
-! Tool for computing the derivative of a function at a point 
-USING: kernel math math.points math.function-tools ;
+
+USING: kernel continuations combinators sequences math
+      math.order math.ranges accessors float-arrays ;
+
 IN: math.derivatives
 
-: small-amount ( -- n ) 1.0e-14 ;
-: some-more ( x -- y ) small-amount + ;
-: some-less ( x -- y ) small-amount - ;
-: derivative ( x function -- m ) [ [ some-more ] dip eval ] [ [ some-less ] dip eval ] 2bi slope ;
-: derivative-func ( function -- function ) [ derivative ] curry ;
+TUPLE: state x func h err i j errt fac hh ans a done ;
+
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable
+: ntab ( -- val ) 8 ;
+: con ( -- val ) 1.6 ;
+: con2 ( -- val ) con con * ;
+: big ( -- val ) largest-float ;
+: safe ( -- val ) 2.0 ;
+
+! Yes, this was ported from C code.
+: a[i][i]     ( state -- elt ) [ i>>     ] [ i>>     ] [ a>> ] tri nth nth ;
+: a[j][i]     ( state -- elt ) [ i>>     ] [ j>>     ] [ a>> ] tri nth nth ;
+: a[j-1][i]   ( state -- elt ) [ i>>     ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[j-1][i-1] ( state -- elt ) [ i>> 1 - ] [ j>> 1 - ] [ a>> ] tri nth nth ;
+: a[i-1][i-1] ( state -- elt ) [ i>> 1 - ] [ i>> 1 - ] [ a>> ] tri nth nth ;
+
+: check-h ( state -- state )
+ dup h>> 0 = [ "h must be nonzero in dfridr" throw ] when ;
+: init-a     ( state -- state ) ntab [ ntab <float-array> ] replicate >>a ;
+: init-hh    ( state -- state ) dup h>> >>hh ;
+: init-err   ( state -- state ) big >>err ;
+: update-hh  ( state -- state ) dup hh>> con / >>hh ;
+: reset-fac  ( state -- state ) con2 >>fac ;
+: update-fac ( state -- state ) dup fac>> con2 * >>fac ;
+
+! If error is decreased, save the improved answer
+: error-decreased? ( state -- state ? ) [ ] [ errt>> ] [ err>> ] tri <= ;
+: save-improved-answer ( state -- state )
+ dup err>>   >>errt
+ dup a[j][i] >>ans ;
+
+! If higher order is worse by a significant factor SAFE, then quit early.
+: check-safe ( state -- state )
+ dup
+ [ [ a[i][i] ] [ a[i-1][i-1] ] bi - abs ] [ err>> safe * ] bi >=
+   [ t >>done ]
+ when ;
+: x+hh ( state -- val ) [ x>> ] [ hh>> ] bi + ;
+: x-hh ( state -- val ) [ x>> ] [ hh>> ] bi - ;
+: limit-approx ( state -- val )
+ [
+   [ [ x+hh ] [ func>> ] bi call ]
+   [ [ x-hh ] [ func>> ] bi call ]
+   bi -
+ ]
+ [ hh>> 2.0 * ]
+ bi / ;
+: a[0][0]! ( state -- state )
+ { [ ] [ limit-approx ] [ drop 0 ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[0][i]! ( state -- state )
+ { [ ] [ limit-approx ] [ i>> ] [ drop 0 ] [ a>> ] } cleave nth set-nth ;
+: a[j-1][i]*fac ( state -- val ) [ a[j-1][i] ] [ fac>> ] bi * ;
+: new-a[j][i] ( state -- val )
+ [ [ a[j-1][i]*fac ] [ a[j-1][i-1] ] bi - ]
+ [ fac>> 1.0 - ]
+ bi / ;
+: a[j][i]! ( state -- state )
+ { [ ] [ new-a[j][i] ] [ i>> ] [ j>> ] [ a>> ] } cleave nth set-nth ;
+
+: update-errt ( state -- state )
+ dup
+    [ [ a[j][i] ] [ a[j-1][i]   ] bi - abs ]
+    [ [ a[j][i] ] [ a[j-1][i-1] ] bi - abs ]
+ bi max
+ >>errt ;
+
+: not-done? ( state -- state ? ) dup done>> not ;
+
+: derive ( state -- state )
+ init-a
+ check-h
+ init-hh
+ a[0][0]!
+ init-err
+ 1 ntab [a,b)
+  [
+     >>i
+     not-done?
+       [
+         update-hh
+         a[0][i]!
+         reset-fac
+         1 over i>> [a,b]
+           [
+             >>j
+             a[j][i]!
+             update-fac
+             update-errt
+             error-decreased? [ save-improved-answer ] when
+           ]
+         each
+         check-safe
+       ]
+     when
+   ]
+ each ;
+
+: derivative-state ( x func h err -- state )
+    state new
+    swap >>err
+    swap >>h
+    swap >>func
+    swap >>x ;
+
+! For scientists:
+! h should be .001 to .5 -- too small can cause bad convergence,
+! h should be small enough to give the correct sgn(f'(x))
+! err is the max tolerance of gain in error for a single iteration-
+: (derivative) ( x func h err -- ans error )
+ derivative-state
+ derive
+    [ ans>> ]
+    [ errt>> ]
+ bi ;
+
+: derivative ( x func -- m ) 0.01 2.0 (derivative) drop ; 
+: derivative-func ( func -- der ) [ derivative ] curry ;

extra/math/function-tools/function-tools.factor

@@ -3,7 +3,7 @@
 
 USING: kernel math arrays sequences sequences.lib ;
 IN: math.function-tools 
-: difference-func ( func func -- func ) [ bi - ] 2curry ;
-: eval ( x func -- pt ) dupd call 2array ;
-: eval-inverse ( y func -- pt ) dupd call swap 2array ;
-: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;
+: difference-func ( func func -- func ) [ bi - ] 2curry ; inline
+: eval ( x func -- pt ) dupd call 2array ; inline
+: eval-inverse ( y func -- pt ) dupd call swap 2array ; inline
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ; inline