{ $list
"Make a new tuple to represent your data"
{ "Map the Factor types to the database types with " { $link define-persistent } }
- { "Make a custom database combinator (see" { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
+ { "Make a custom database combinator (see " { $link "db-custom-database-combinators" } ") to open your database and run a " { $link quotation } }
{ "Create a table with " { $link create-table } ", " { $link ensure-table } ", or " { $link recreate-table } }
{ "Start making and storing objects with " { $link insert-tuple } ", " { $link update-tuple } ", " { $link delete-tuples } ", and " { $link select-tuples } }
} ;
-USING: tools.test system io io.encodings.ascii io.pathnames\r
-io.files io.files.info io.files.temp kernel tools.deploy.config\r
-tools.deploy.config.editor tools.deploy.backend math sequences\r
-io.launcher arrays namespaces continuations layouts accessors\r
-urls math.parser io.directories tools.deploy.test ;\r
-IN: tools.deploy.tests\r
-\r
-[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test\r
-\r
-[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test\r
-\r
-[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
-\r
-[ "staging.math-threads-compiler-ui.image" ] [\r
- "hello-ui" deploy-config\r
- [ bootstrap-profile staging-image-name file-name ] bind\r
-] unit-test\r
-\r
-[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test\r
-\r
-[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
-\r
-[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
-\r
-[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test\r
-\r
-os macosx? [\r
- [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test\r
-] when\r
-\r
-[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test\r
-\r
-{\r
- "tools.deploy.test.1"\r
- "tools.deploy.test.2"\r
- "tools.deploy.test.3"\r
- "tools.deploy.test.4"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-USING: http.client http.server http.server.dispatchers\r
-http.server.responses http.server.static io.servers.connection ;\r
-\r
-SINGLETON: quit-responder\r
-\r
-M: quit-responder call-responder*\r
- 2drop stop-this-server "Goodbye" "text/html" <content> ;\r
-\r
-: add-quot-responder ( responder -- responder )\r
- quit-responder "quit" add-responder ;\r
-\r
-: test-httpd ( responder -- )\r
- [\r
- main-responder set\r
- <http-server>\r
- 0 >>insecure\r
- f >>secure\r
- dup start-server*\r
- sockets>> first addr>> port>>\r
- dup number>string "resource:temp/port-number" ascii set-file-contents\r
- ] with-scope\r
- "port" set ;\r
-\r
-[ ] [\r
- <dispatcher>\r
- add-quot-responder\r
- "vocab:http/test" <static> >>default\r
-\r
- test-httpd\r
-] unit-test\r
-\r
-[ ] [\r
- "tools.deploy.test.5" shake-and-bake\r
- run-temp-image\r
-] unit-test\r
-\r
-: add-port ( url -- url' )\r
- >url clone "port" get >>port ;\r
-\r
-[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test\r
-\r
-{\r
- "tools.deploy.test.6"\r
- "tools.deploy.test.7"\r
- "tools.deploy.test.9"\r
- "tools.deploy.test.10"\r
- "tools.deploy.test.11"\r
- "tools.deploy.test.12"\r
-} [\r
- [ ] swap [\r
- shake-and-bake\r
- run-temp-image\r
- ] curry unit-test\r
-] each\r
-\r
-os windows? os macosx? or [\r
- [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-os macosx? [\r
- [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test\r
-] when\r
-\r
-[ { "a" "b" "c" } ] [\r
- "tools.deploy.test.15" shake-and-bake deploy-test-command\r
- { "a" "b" "c" } append\r
- ascii [ lines ] with-process-reader\r
- rest\r
-] unit-test\r
-\r
-[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test\r
-\r
-[ t ] [\r
- "tools.deploy.test.18" shake-and-bake\r
- deploy-test-command ascii [ readln ] with-process-reader\r
- "test.image" temp-file =\r
-] unit-test\r
+USING: tools.test system io io.encodings.ascii io.pathnames
+io.files io.files.info io.files.temp kernel tools.deploy.config
+tools.deploy.config.editor tools.deploy.backend math sequences
+io.launcher arrays namespaces continuations layouts accessors
+urls math.parser io.directories tools.deploy.test ;
+IN: tools.deploy.tests
+
+[ ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
+
+[ ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
+
+[ ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
+
+[ "staging.math-threads-compiler-ui.image" ] [
+ "hello-ui" deploy-config
+ [ bootstrap-profile staging-image-name file-name ] bind
+] unit-test
+
+[ ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
+
+[ ] [ "terrain" shake-and-bake 1700000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.raytrace" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
+
+[ ] [ "gpu.demos.bunny" shake-and-bake 3500000 small-enough? ] unit-test
+
+os macosx? [
+ [ ] [ "webkit-demo" shake-and-bake 500000 small-enough? ] unit-test
+] when
+
+[ ] [ "benchmark.regex-dna" shake-and-bake 900000 small-enough? ] unit-test
+
+{
+ "tools.deploy.test.1"
+ "tools.deploy.test.2"
+ "tools.deploy.test.3"
+ "tools.deploy.test.4"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+USING: http.client http.server http.server.dispatchers
+http.server.responses http.server.static io.servers.connection ;
+
+SINGLETON: quit-responder
+
+M: quit-responder call-responder*
+ 2drop stop-this-server "Goodbye" "text/html" <content> ;
+
+: add-quot-responder ( responder -- responder )
+ quit-responder "quit" add-responder ;
+
+: test-httpd ( responder -- )
+ [
+ main-responder set
+ <http-server>
+ 0 >>insecure
+ f >>secure
+ dup start-server*
+ sockets>> first addr>> port>>
+ dup number>string "resource:temp/port-number" ascii set-file-contents
+ ] with-scope
+ "port" set ;
+
+[ ] [
+ <dispatcher>
+ add-quot-responder
+ "vocab:http/test" <static> >>default
+
+ test-httpd
+] unit-test
+
+[ ] [
+ "tools.deploy.test.5" shake-and-bake
+ run-temp-image
+] unit-test
+
+: add-port ( url -- url' )
+ >url clone "port" get >>port ;
+
+[ ] [ "http://localhost/quit" add-port http-get 2drop ] unit-test
+
+{
+ "tools.deploy.test.6"
+ "tools.deploy.test.7"
+ "tools.deploy.test.9"
+ "tools.deploy.test.10"
+ "tools.deploy.test.11"
+ "tools.deploy.test.12"
+} [
+ [ ] swap [
+ shake-and-bake
+ run-temp-image
+ ] curry unit-test
+] each
+
+os windows? os macosx? or [
+ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
+] when
+
+os macosx? [
+ [ ] [ "tools.deploy.test.14" shake-and-bake run-temp-image ] unit-test
+] when
+
+[ { "a" "b" "c" } ] [
+ "tools.deploy.test.15" shake-and-bake deploy-test-command
+ { "a" "b" "c" } append
+ ascii [ lines ] with-process-reader
+ rest
+] unit-test
+
+[ ] [ "tools.deploy.test.16" shake-and-bake run-temp-image ] unit-test
+
+[ ] [ "tools.deploy.test.17" shake-and-bake run-temp-image ] unit-test
+
+[ t ] [
+ "tools.deploy.test.18" shake-and-bake
+ deploy-test-command ascii [ readln ] with-process-reader
+ "test.image" temp-file =
+] unit-test
-USING: accessors alien alien.c-types arrays classes.struct combinators\r
-io.backend kernel locals math sequences specialized-arrays\r
-tools.deploy.windows windows.kernel32 windows.types ;\r
-IN: tools.deploy.windows.ico\r
-\r
-<PRIVATE\r
-\r
-STRUCT: ico-header\r
- { Reserved WORD }\r
- { Type WORD }\r
- { ImageCount WORD } ;\r
-\r
-STRUCT: ico-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageOffset DWORD } ;\r
-SPECIALIZED-ARRAY: ico-directory-entry\r
-\r
-STRUCT: group-directory-entry\r
- { Width BYTE }\r
- { Height BYTE }\r
- { Colors BYTE }\r
- { Reserved BYTE }\r
- { Planes WORD }\r
- { BitsPerPixel WORD }\r
- { ImageSize DWORD }\r
- { ImageResourceID WORD } ;\r
-\r
-: ico>group-directory-entry ( ico i -- group )\r
- [ {\r
- [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]\r
- [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]\r
- } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline\r
-\r
-: ico-icon ( directory-entry bytes -- subbytes )\r
- [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline\r
-\r
-:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )\r
- bytes ico-header memory>struct :> header\r
-\r
- ico-header heap-size bytes <displaced-alien> \r
- header ImageCount>> <direct-ico-directory-entry-array> :> directory\r
-\r
- directory dup length iota [ ico>group-directory-entry ] { } 2map-as\r
- :> group-directory\r
- directory [ bytes ico-icon ] { } map-as :> icon-bytes\r
-\r
- header clone >c-ptr group-directory concat append\r
- icon-bytes ; inline\r
-\r
-PRIVATE>\r
-\r
-:: embed-icon-resource ( exe ico-bytes id -- )\r
- exe normalize-path 1 BeginUpdateResource :> hUpdate\r
- hUpdate [\r
- ico-bytes ico-group-and-icons :> ( group icons )\r
- hUpdate RT_GROUP_ICON id 0 group dup byte-length\r
- UpdateResource drop\r
-\r
- icons [| icon i |\r
- hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length\r
- UpdateResource drop\r
- ] each-index\r
-\r
- hUpdate 0 EndUpdateResource drop\r
- ] when ;\r
-\r
+USING: accessors alien alien.c-types arrays classes.struct combinators
+io.backend kernel locals math sequences specialized-arrays
+tools.deploy.windows windows.kernel32 windows.types ;
+IN: tools.deploy.windows.ico
+
+<PRIVATE
+
+STRUCT: ico-header
+ { Reserved WORD }
+ { Type WORD }
+ { ImageCount WORD } ;
+
+STRUCT: ico-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageOffset DWORD } ;
+SPECIALIZED-ARRAY: ico-directory-entry
+
+STRUCT: group-directory-entry
+ { Width BYTE }
+ { Height BYTE }
+ { Colors BYTE }
+ { Reserved BYTE }
+ { Planes WORD }
+ { BitsPerPixel WORD }
+ { ImageSize DWORD }
+ { ImageResourceID WORD } ;
+
+: ico>group-directory-entry ( ico i -- group )
+ [ {
+ [ Width>> ] [ Height>> ] [ Colors>> ] [ Reserved>> ]
+ [ Planes>> ] [ BitsPerPixel>> ] [ ImageSize>> ]
+ } cleave ] [ 1 + ] bi* group-directory-entry <struct-boa> >c-ptr ; inline
+
+: ico-icon ( directory-entry bytes -- subbytes )
+ [ [ ImageOffset>> dup ] [ ImageSize>> + ] bi ] dip subseq ; inline
+
+:: ico-group-and-icons ( bytes -- group-bytes icon-bytes )
+ bytes ico-header memory>struct :> header
+
+ ico-header heap-size bytes <displaced-alien>
+ header ImageCount>> <direct-ico-directory-entry-array> :> directory
+
+ directory dup length iota [ ico>group-directory-entry ] { } 2map-as
+ :> group-directory
+ directory [ bytes ico-icon ] { } map-as :> icon-bytes
+
+ header clone >c-ptr group-directory concat append
+ icon-bytes ; inline
+
+PRIVATE>
+
+:: embed-icon-resource ( exe ico-bytes id -- )
+ exe normalize-path 1 BeginUpdateResource :> hUpdate
+ hUpdate [
+ ico-bytes ico-group-and-icons :> ( group icons )
+ hUpdate RT_GROUP_ICON id 0 group dup byte-length
+ UpdateResource drop
+
+ icons [| icon i |
+ hUpdate RT_ICON i 1 + MAKEINTRESOURCE 0 icon dup byte-length
+ UpdateResource drop
+ ] each-index
+
+ hUpdate 0 EndUpdateResource drop
+ ] when ;
+
CONSTANT: D3DMULTISAMPLE_15_SAMPLES 15
CONSTANT: D3DMULTISAMPLE_16_SAMPLES 16
CONSTANT: D3DMULTISAMPLE_FORCE_DWORD HEX: 7fffffff
-
-:: MAKEFOURCC ( ch0 ch1 ch2 ch3 -- n )
- ch3 HEX: ff bitand 24 shift
- ch2 HEX: ff bitand 16 shift
- ch1 HEX: ff bitand 8 shift
- ch0 HEX: ff bitand bitor bitor bitor ; inline
TYPEDEF: int D3DFORMAT
CONSTANT: D3DFMT_UNKNOWN 0
CONSTANT: D3DFMT_Q8W8V8U8 63
CONSTANT: D3DFMT_V16U16 64
CONSTANT: D3DFMT_A2W10V10U10 67
-#! : D3DFMT_UYVY ( -- n ) 'U' 'Y' 'V' 'Y' MAKEFOURCC
-#! D3DFMT_R8G8_B8G8 = MAKEFOURCC('R', 'G', 'B', 'G'),
-#! D3DFMT_YUY2 = MAKEFOURCC('Y', 'U', 'Y', '2'),
-#! D3DFMT_G8R8_G8B8 = MAKEFOURCC('G', 'R', 'G', 'B'),
-#! D3DFMT_DXT1 = MAKEFOURCC('D', 'X', 'T', '1'),
-#! D3DFMT_DXT2 = MAKEFOURCC('D', 'X', 'T', '2'),
-#! D3DFMT_DXT3 = MAKEFOURCC('D', 'X', 'T', '3'),
-#! D3DFMT_DXT4 = MAKEFOURCC('D', 'X', 'T', '4'),
-#! D3DFMT_DXT5 = MAKEFOURCC('D', 'X', 'T', '5'),
+CONSTANT: D3DFMT_UYVY HEX: 55595659
+CONSTANT: D3DFMT_R8G8_B8G8 HEX: 52474247
+CONSTANT: D3DFMT_YUY2 HEX: 59555932
+CONSTANT: D3DFMT_G8R8_G8B8 HEX: 47524742
+CONSTANT: D3DFMT_DXT1 HEX: 44585431
+CONSTANT: D3DFMT_DXT2 HEX: 44585432
+CONSTANT: D3DFMT_DXT3 HEX: 44585433
+CONSTANT: D3DFMT_DXT4 HEX: 44585434
+CONSTANT: D3DFMT_DXT5 HEX: 44585435
CONSTANT: D3DFMT_D16_LOCKABLE 70
CONSTANT: D3DFMT_D32 71
CONSTANT: D3DFMT_D15S1 73
CONSTANT: D3DFMT_INDEX16 101
CONSTANT: D3DFMT_INDEX32 102
CONSTANT: D3DFMT_Q16W16V16U16 110
-#! D3DFMT_MULTI2_ARGB8 = MAKEFOURCC('M', 'E', 'T', '1'),
+CONSTANT: D3DFMT_MULTI2_ARGB8 HEX: 4d455431
CONSTANT: D3DFMT_R16F 111
CONSTANT: D3DFMT_G16R16F 112
CONSTANT: D3DFMT_A16B16G16R16F 113
! Copyright (C) 2010 Erik Charlebois
! See http:// factorcode.org/license.txt for BSD license.
-USING: accessors chipmunk classes.struct game.loop game.worlds gpu
-gpu.util.wasd kernel literals locals math method-chains opengl.gl
-random sequences specialized-arrays
-specialized-arrays.instances.alien.c-types.void* ui.gadgets.worlds
+USING: accessors chipmunk classes.struct game.worlds kernel locals
+math method-chains opengl.gl random sequences specialized-arrays
+specialized-arrays.instances.alien.c-types.void* ui ui.gadgets.worlds
ui.pixel-formats ;
IN: chipmunk.demo
cpCircleShapeAlloc body 0.95 0 0 cpv cpCircleShapeInit cpCircleShape memory>struct
[ shape>> 0 >>e ] [ shape>> 0 >>u ] bi drop ;
-TUPLE: chipmunk-world < wasd-world
+TUPLE: chipmunk-world < game-world
space ;
AFTER: chipmunk-world tick-game-world
M:: chipmunk-world begin-game-world ( world -- )
cpInitChipmunk
- init-gpu
- world { -0.2 0.13 0.1 } 1.1 0.2 set-wasd-view drop
cpSpaceAlloc cpSpaceInit cpSpace memory>struct :> space
[ cpSpaceFreeChildren ]
[ cpSpaceFree ] bi ;
-M: chipmunk-world wasd-movement-speed drop 1/160. ;
-M: chipmunk-world wasd-near-plane drop 1/32. ;
-M: chipmunk-world wasd-far-plane drop 256.0 ;
-
-GAME: chipmunk-demo {
- { world-class chipmunk-world }
- { title "Chipmunk Physics Demo" }
- { pixel-format-attributes {
- windowed
- double-buffered
- T{ depth-bits { value 24 } }
- } }
- { grab-input? t }
- { use-game-input? t }
- { pref-dim { 640 480 } }
- { tick-interval-micros $[ 60 fps ] }
- } ;
+: chipmunk-demo ( -- )
+ [
+ f
+ T{ game-attributes
+ { world-class chipmunk-world }
+ { title "Chipmunk Physics Demo" }
+ { pixel-format-attributes
+ { windowed double-buffered }
+ }
+ { pref-dim { 640 480 } }
+ { tick-interval-micros 16666 }
+ }
+ clone
+ open-window
+ ] with-ui ;
+
-FFI bindings to the Chipmunk 2D physics library.
+Chipmunk 2D physics library binding
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax math ;
+IN: math.splines
+
+HELP: <bezier-curve>
+{ $values
+ { "control-points" "sequence of control points same dimension" }
+ { "polynomials" "sequence of polynomials for each dimension" }
+}
+{ $description "Creates bezier curve polynomials for the given control points." } ;
+
+HELP: <catmull-rom-spline>
+{ $values
+ { "points" "points on the spline" } { "m0" "initial tangent vector" } { "mn" "final tangent vector" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points and generating tangents for C1 continuity." } ;
+
+HELP: <cubic-hermite-curve>
+{ $values
+ { "p0" "start point" } { "m0" "start tangent" } { "p1" "end point" } { "m1" "end tangent" }
+ { "polynomials" "sequence of polynomials" }
+}
+{ $description "Creates a sequence of polynomials (one per dimension) for the curve passing through " { $emphasis "p0" } " and " { $emphasis "p1" } "." } ;
+
+HELP: <cubic-hermite-spline>
+{ $values
+ { "point-tangent-pairs" "sequence of point and tangent pairs" }
+ { "polynomials-sequence" "sequence of sequences of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points with the given tangents." } ;
+
+HELP: <kochanek-bartels-curve>
+{ $values
+ { "points" "points on the spline" } { "m0" "start tangent" } { "mn" "end tangent" } { "tension" number } { "bias" number } { "continuity" number }
+ { "polynomials-sequence" "sequence of sequence of polynomials" }
+}
+{ $description "Creates a sequence of cubic hermite curves (each a sequence of polynomials) passing through the given points, generating tangents with the given tuning parameters." } ;
+
+ARTICLE: "math.splines" "Common parametric curves."
+"The curve creating functions create sequences of polynomials, one for each degree of the input points. The spline creating functions create sequences of these curve polynomial sequences. The " { $vocab-link "math.splines.viewer" } " vocabulary provides a gadget to evaluate the generated polynomials and view the results.";
+
+ABOUT: "math.splines"
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel locals math math.combinatorics
+math.polynomials opengl.gl sequences ui.gadgets ui.gadgets.panes
+ui.render arrays grouping math.vectors assocs
+ui.gestures ;
+IN: math.splines
+
+<PRIVATE
+:: bernstein-polynomial-ith ( n i -- p )
+ n i nCk { 0 1 } i p^ { 1 -1 } n i - p^ p* n*p ;
+
+:: hermite-polynomial ( p0 m0 p1 m1 -- poly )
+ p0
+ m0
+ -3 p0 * -2 m0 * + 3 p1 * + m1 neg +
+ 2 p0 * m0 + -2 p1 * + m1 +
+ 4array ;
+
+:: kochanek-bartels-coefficients ( tension bias continuity -- s1 d1 s2 d2 )
+ 1 tension -
+ [
+ 1 bias +
+ [ 1 continuity + * * 2 / ]
+ [ 1 continuity - * * 2 / ] 2bi
+ ]
+ [
+ 1 bias -
+ [ 1 continuity - * * 2 / ]
+ [ 1 continuity + * * 2 / ] 2bi
+ ] bi ;
+
+:: kochanek-bartels-tangents ( points m0 mn c1 c2 -- tangents )
+ points 3 clump [
+ first3 :> ( pi-1 pi pi+1 )
+ pi pi-1 v- c1 v*n
+ pi+1 pi v- c2 v*n v+
+ ] map
+ m0 prefix
+ mn suffix ;
+PRIVATE>
+
+:: <bezier-curve> ( control-points -- polynomials )
+ control-points
+ [ length 1 - ]
+ [ first length [ { 0 } ] replicate ]
+ bi :> ( n acc )
+
+ control-points [| pt i |
+ n i bernstein-polynomial-ith :> poly
+ pt [| v j |
+ j acc [ v poly n*p p+ ] change-nth
+ ] each-index
+ ] each-index
+ acc ;
+
+:: <cubic-hermite-curve> ( p0 m0 p1 m1 -- polynomials )
+ p0 length iota [
+ {
+ [ p0 nth ] [ m0 nth ]
+ [ p1 nth ] [ m1 nth ]
+ } cleave
+ hermite-polynomial
+ ] map ;
+
+<PRIVATE
+: (cubic-hermite-spline) ( point-in-out-triplets -- polynomials-sequence )
+ 2 clump [
+ first2 [ first2 ] [ [ first ] [ third ] bi ] bi* <cubic-hermite-curve>
+ ] map ;
+PRIVATE>
+
+: <cubic-hermite-spline> ( point-tangent-pairs -- polynomials-sequence )
+ 2 clump [ first2 [ first2 ] bi@ <cubic-hermite-curve> ] map ;
+
+:: <kochanek-bartels-curve> ( points m0 mn tension bias continuity -- polynomials-sequence )
+ tension bias continuity kochanek-bartels-coefficients :> ( s1 d1 s2 d2 )
+ points m0 mn
+ [ s1 s2 kochanek-bartels-tangents ]
+ [ d1 d2 kochanek-bartels-tangents ] 3bi :> ( in out )
+ points in out [ 3array ] 3map (cubic-hermite-spline) ;
+
+: <catmull-rom-spline> ( points m0 mn -- polynomials-sequence )
+ 0 0 0 <kochanek-bartels-curve> ;
--- /dev/null
+Common parametric curves
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: locals math.splines math.splines.viewer arrays ;
+IN: math.splines.testing
+
+: test1 ( -- )
+ {
+ { { 0 0 } { 0 200 } }
+ { { 100 50 } { 0 -200 } }
+ { { 300 300 } { 500 200 } }
+ { { 400 400 } { 300 0 } }
+ } <cubic-hermite-spline> { 50 100 } 4 spline. ;
+
+: test2 ( -- )
+ {
+ { 50 50 }
+ { 100 100 }
+ { 300 200 }
+ { 350 0 }
+ { 400 400 }
+ } { 0 100 } { 100 0 } <catmull-rom-spline> { 100 50 } 50 spline. ;
+
+:: test3 ( x y z -- )
+ {
+ { 100 50 }
+ { 200 350 }
+ { 300 50 }
+ } { 0 100 } { 0 -100 } x y z <kochanek-bartels-curve> { 50 50 } 1000 spline. ;
+
+: test4 ( -- )
+ {
+ { 0 5 }
+ { 0.5 3 }
+ { 10 10 }
+ { 12 4 }
+ { 15 5 }
+ } <bezier-curve> 1array { 100 100 } 100 spline. ;
+
+: test-splines ( -- )
+ test1 test2
+ 1 0 0 test3
+ -1 0 0 test3
+ 0 1 0 test3
+ 0 -1 0 test3
+ 0 0 1 test3
+ 0 0 -1 test3
+ test4 ;
+
+
--- /dev/null
+Erik Charlebois
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel locals math math.order math.polynomials
+math.splines opengl.gl sequences ui.gadgets ui.gadgets.panes ui.render
+arrays ;
+IN: math.splines.viewer
+
+<PRIVATE
+: eval-polynomials ( polynomials-seq n -- xy-sequence )
+ [
+ [ 1 + iota ] keep [
+ /f swap [ polyval ] with map
+ ] curry with map
+ ] curry map concat ;
+PRIVATE>
+
+TUPLE: spline-gadget < gadget polynomials steps spline-dim ;
+
+M: spline-gadget pref-dim* spline-dim>> ;
+
+M:: spline-gadget draw-gadget* ( gadget -- )
+ 0 0 0 glColor3f
+
+ gadget [ polynomials>> ] [ steps>> ] bi eval-polynomials :> pts
+
+ pts [ first ] [ max ] map-reduce :> x-max
+ pts [ first ] [ min ] map-reduce :> x-min
+ pts [ second ] [ max ] map-reduce :> y-max
+ pts [ second ] [ min ] map-reduce :> y-min
+
+ pts [
+ [ first x-min - x-max x-min - / gadget spline-dim>> first * ]
+ [ second y-min - y-max y-min - / gadget spline-dim>> second * ] bi 2array
+ ] map :> pts
+
+ GL_LINE_STRIP glBegin
+ pts [
+ first2 neg gadget spline-dim>> second + glVertex2f
+ ] each
+ glEnd ;
+
+:: <spline-gadget> ( polynomials dim steps -- gadget )
+ spline-gadget new
+ dim >>spline-dim
+ polynomials >>polynomials
+ steps >>steps ;
+
+: spline. ( curve dim steps -- )
+ <spline-gadget> gadget. ;
projects / factor.git / commitdiff