diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor new file mode 100644 index 0000000000..86940dfa95 --- /dev/null +++ b/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 ; \ No newline at end of file diff --git a/extra/math/derivatives/derivatives-docs.factor b/extra/math/derivatives/derivatives-docs.factor new file mode 100644 index 0000000000..23847e82f7 --- /dev/null +++ b/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 diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..fef93cabc4 --- /dev/null +++ b/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 ; \ No newline at end of file diff --git a/extra/math/function-tools/function-tools.factor b/extra/math/function-tools/function-tools.factor new file mode 100644 index 0000000000..042b5f0897 --- /dev/null +++ b/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 ; diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor new file mode 100644 index 0000000000..b2778a2d85 --- /dev/null +++ b/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 + + +: newton-method ( guess function -- x ) newton-precision [ [ newton-step ] keep ] times drop ; diff --git a/extra/math/points/points.factor b/extra/math/points/points.factor index 5efd6e07e0..c8654869e2 100644 --- a/extra/math/points/points.factor +++ b/extra/math/points/points.factor @@ -1,5 +1,4 @@ - -USING: kernel arrays math.vectors ; +USING: kernel arrays math.vectors sequences math ; 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 / - ; \ No newline at end of file diff --git a/extra/math/secant-method/secant-method.factor b/extra/math/secant-method/secant-method.factor new file mode 100644 index 0000000000..2089dde848 --- /dev/null +++ b/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 + + +: 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 ; \ No newline at end of file