Merge commit 'drford/master'

extra/24-game/24-game.factor

@@ -0,0 +1,38 @@
+! Copyright © 2008 Reginald Keith Ford II
+! 24, the Factor game!
+
+USING: kernel random namespaces shuffle sequences
+parser io math prettyprint combinators
+vectors words quotations accessors math.parser
+backtrack math.ranges locals fry memoize macros assocs ;
+
+IN: 24-game
+
+: nop ;
+: do-something ( a b -- c ) { + - * } amb-execute ;
+: maybe-swap ( a b -- a b ) { nop swap } amb-execute ;
+: some-rots ( a b c -- a b c )
+    #! Try each permutation of 3 elements.
+    { nop rot -rot swap spin swapd } amb-execute ;
+: makes-24? ( a b c d -- ? ) [ some-rots do-something some-rots do-something maybe-swap do-something 24 = ] [ 4drop ] if-amb ;
+: vector-24-able? ( vector -- t/f ) [ makes-24? ] with-datastack first ;
+: q ( -- obj ) "quit" ;
+: show-commands ( -- ) "Commands: " write "commands" get unparse print ;
+: report ( vector -- ) unparse print show-commands ;
+: give-help ( -- ) "Command not found..." print show-commands ;
+: find-word ( string choices -- word ) [ name>> = ] with find nip ;
+: obtain-word ( -- word ) readln "commands" get find-word dup [ drop give-help obtain-word ] unless ;
+: done? ( vector -- t/f ) 1 swap length = ;
+: victory? ( vector -- t/f ) V{ 24 } = ;
+: apply-word ( vector word -- vector ) 1quotation with-datastack >vector ;
+: update-commands ( vector -- ) length 3 < [ "commands" [ \ rot swap remove ] change ] [ ] if ;
+DEFER: check-status
+: quit-game ( vector -- ) drop "you're a quitter" print ;
+: quit? ( vector -- t/f ) peek "quit" = ;
+: end-game ( vector -- ) dup victory? [ drop "You WON!" ] [ pop number>string " is not 24... You lose." append ] if print ;
+: repeat ( vector -- ) dup report obtain-word apply-word dup update-commands check-status  ;
+: check-status ( object -- ) dup done? [ end-game ] [ dup quit? [ quit-game ] [ repeat ] if ] if ;
+: build-quad ( -- vector ) 4 [ 10 random ] replicate >vector ;
+: 24-able ( -- vector ) build-quad dup vector-24-able? [ drop build-quad ] unless ;
+: set-commands ( -- ) { + - * / rot swap q } "commands" set ;
+: play-game ( -- ) set-commands 24-able repeat ;

extra/math/derivatives/derivatives-docs.factor

@@ -0,0 +1,9 @@
+USING: help.markup help.syntax ;
+
+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." } ;
+
+{ derivative-func } related-words

extra/math/derivatives/derivatives.factor

@@ -0,0 +1,9 @@
+! 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 ;
+IN: math.derivatives
+
+: small-amount ( -- n ) 1.0e-12 ;
+: near ( x -- y ) small-amount + ;
+: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ;
+: derivative-func ( function -- function ) [ derivative ] curry ;

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

@@ -0,0 +1,8 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Tools for quickly comparing, transforming, and evaluating mathematical Factor functions
+
+USING: kernel math arrays ;
+IN: math.function-tools 
+: difference-func ( func func -- func ) [ bi - ] 2curry ;
+: eval ( x func -- pt ) dupd call 2array ;
+: eval3d ( x y func -- pt ) [ 2dup ] dip call 3array ;

extra/math/newtons-method/newtons-method.factor

@@ -0,0 +1,11 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Newton's Method of approximating roots
+
+USING: kernel math math.derivatives ;
+IN: math.newtons-method
+
+<PRIVATE
+: newton-step ( x function -- x2 ) dupd [ call ] [ derivative ] 2bi / - ;
+: newton-precision ( -- n ) 7 ;
+PRIVATE>
+: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ;

extra/math/points/points.factor

@@ -1,5 +1,4 @@
-
+USING: kernel arrays math.vectors sequences math ;
-USING: kernel arrays math.vectors ;
 
 IN: math.points
 
@@ -20,3 +19,9 @@ PRIVATE>
 : v+z ( seq z -- seq ) Z v+ ;
 : v-z ( seq z -- seq ) Z v- ;
 
+: rise ( pt2 pt1 -- n ) [ second ] bi@ - ;
+: run ( pt2 pt1 -- n ) [ first ] bi@ - ;
+: slope ( pt pt -- slope ) [ rise ] [ run ] 2bi / ;
+: distance ( point point -- float ) v- norm ;
+: midpoint ( point point -- point ) v+ 2 v/n ;
+: linear-solution ( pt pt -- x ) [ drop first2 ] [ slope ] 2bi / - ;

extra/math/secant-method/secant-method.factor

@@ -0,0 +1,14 @@
+! Copyright © 2008 Reginald Keith Ford II
+! Secant Method of approximating roots
+
+USING: kernel math math.function-tools math.points math.vectors ;
+IN: math.secant-method
+
+<PRIVATE
+: secant-solution ( x1 x2 function -- solution ) [ eval ] curry bi@ linear-solution ;
+: secant-step ( x1 x2 func -- x2 x3 func ) 2dup [ secant-solution ] 2dip swapd ;
+: secant-precision ( -- n ) 11 ;
+PRIVATE>
+: secant-method ( left right function -- x ) secant-precision [ secant-step ] times drop v+ 2 v*n ;
+! : close-enough? ( a b -- t/f ) - abs tiny-amount < ;
+! : secant-method2 ( left right function -- x ) 2over close-enough? [ drop average ] [ secant-step secant-method ] if  ;