From 55159701c86e0934713e7841f56188cc507c462c Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 22 Jul 2008 04:29:48 -0400 Subject: [PATCH 1/6] Adding 24 game --- extra/24-game/24.factor | 48 +++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) create mode 100644 extra/24-game/24.factor diff --git a/extra/24-game/24.factor b/extra/24-game/24.factor new file mode 100644 index 0000000000..36392d77ff --- /dev/null +++ b/extra/24-game/24.factor @@ -0,0 +1,48 @@ +! 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 + +MACRO: amb-execute ( seq -- quot ) + [ length ] [ [ 1quotation ] assoc-map ] bi + '[ , amb , case ] ; +: if-amb ( true false -- ) + [ + [ { t f } amb ] + [ '[ @ require t ] ] + [ '[ @ f ] ] + tri* if +] with-scope ; inline +: 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 From 967f2873abfc69257415bc00c764b955da303131 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 22 Jul 2008 04:31:11 -0400 Subject: [PATCH 2/6] New extra/math vocabs --- extra/math/derivatives/derivatives.factor | 8 ++++++++ extra/math/function-tools/function-tools.factor | 8 ++++++++ extra/math/newtons-method/newtons-method.factor | 11 +++++++++++ extra/math/points/points.factor | 9 +++++++-- extra/math/secant-method/secant-method.factor | 14 ++++++++++++++ 5 files changed, 48 insertions(+), 2 deletions(-) create mode 100644 extra/math/derivatives/derivatives.factor create mode 100644 extra/math/function-tools/function-tools.factor create mode 100644 extra/math/newtons-method/newtons-method.factor create mode 100644 extra/math/secant-method/secant-method.factor diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor new file mode 100644 index 0000000000..b5bbfa7fbe --- /dev/null +++ b/extra/math/derivatives/derivatives.factor @@ -0,0 +1,8 @@ +! 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: derivatives + +: small-amount ( -- n ) 1.0e-12 ; +: near ( x -- y ) small-amount + ; +: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ; \ 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..3f719767d3 --- /dev/null +++ b/extra/math/function-tools/function-tools.factor @@ -0,0 +1,8 @@ +! Copyright © 2008 Reginald Keith Ford II +! Tools for quickly comparing 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 ; \ No newline at end of file diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor new file mode 100644 index 0000000000..55241c523b --- /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 derivatives ; +IN: 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 From 5e61c97272e2469349bc3b3399e35b35ecf842c7 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 22 Jul 2008 04:43:27 -0400 Subject: [PATCH 3/6] minor adjustments --- extra/24-game/{24.factor => 24-game.factor} | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) rename extra/24-game/{24.factor => 24-game.factor} (86%) diff --git a/extra/24-game/24.factor b/extra/24-game/24-game.factor similarity index 86% rename from extra/24-game/24.factor rename to extra/24-game/24-game.factor index 36392d77ff..3b1ec133e6 100644 --- a/extra/24-game/24.factor +++ b/extra/24-game/24-game.factor @@ -6,19 +6,8 @@ parser io math prettyprint combinators vectors words quotations accessors math.parser backtrack math.ranges locals fry memoize macros assocs ; -IN: 24 +IN: 24-game -MACRO: amb-execute ( seq -- quot ) - [ length ] [ [ 1quotation ] assoc-map ] bi - '[ , amb , case ] ; -: if-amb ( true false -- ) - [ - [ { t f } amb ] - [ '[ @ require t ] ] - [ '[ @ f ] ] - tri* if -] with-scope ; inline -: 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 ) From fa2e448e3866a5184bb206ded9c3816d07a7e1ec Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 22 Jul 2008 20:27:56 -0400 Subject: [PATCH 4/6] eliminated circular dependancies and started documentation --- extra/math/derivatives/derivatives-docs.factor | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 extra/math/derivatives/derivatives-docs.factor 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 From 4fc9860c0a7334801e45c3dd371590696addf0f3 Mon Sep 17 00:00:00 2001 From: Rex Ford Date: Tue, 22 Jul 2008 20:45:13 -0400 Subject: [PATCH 5/6] more minor fixes --- extra/24-game/24-game.factor | 1 + extra/math/derivatives/derivatives.factor | 5 +++-- extra/math/function-tools/function-tools.factor | 4 ++-- extra/math/newtons-method/newtons-method.factor | 2 +- 4 files changed, 7 insertions(+), 5 deletions(-) diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 3b1ec133e6..86940dfa95 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -8,6 +8,7 @@ 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 ) diff --git a/extra/math/derivatives/derivatives.factor b/extra/math/derivatives/derivatives.factor index b5bbfa7fbe..fef93cabc4 100644 --- a/extra/math/derivatives/derivatives.factor +++ b/extra/math/derivatives/derivatives.factor @@ -1,8 +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: derivatives +IN: math.derivatives : small-amount ( -- n ) 1.0e-12 ; : near ( x -- y ) small-amount + ; -: derivative ( x function -- m ) 2dup [ near ] dip [ eval ] 2bi@ slope ; \ No newline at end of file +: 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 index 3f719767d3..042b5f0897 100644 --- a/extra/math/function-tools/function-tools.factor +++ b/extra/math/function-tools/function-tools.factor @@ -1,8 +1,8 @@ ! Copyright © 2008 Reginald Keith Ford II -! Tools for quickly comparing and evaluating mathematical Factor functions +! 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 ; \ No newline at end of file +: 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 index 55241c523b..bac41bab15 100644 --- a/extra/math/newtons-method/newtons-method.factor +++ b/extra/math/newtons-method/newtons-method.factor @@ -1,7 +1,7 @@ ! Copyright © 2008 Reginald Keith Ford II ! Newton's Method of approximating roots -USING: kernel math math.derivatives derivatives ; +USING: kernel math math.derivatives ; IN: newtons-method Date: Thu, 24 Jul 2008 01:09:01 -0400 Subject: [PATCH 6/6] vocab fix --- extra/math/newtons-method/newtons-method.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/math/newtons-method/newtons-method.factor b/extra/math/newtons-method/newtons-method.factor index bac41bab15..b2778a2d85 100644 --- a/extra/math/newtons-method/newtons-method.factor +++ b/extra/math/newtons-method/newtons-method.factor @@ -2,7 +2,7 @@ ! Newton's Method of approximating roots USING: kernel math math.derivatives ; -IN: newtons-method +IN: math.newtons-method