{ $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 } }
} ;
{
{ [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
- { [ t ] [ ] }
+ { [ os linux? ] [ "game.input.linux" require ] }
} cond
--- /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: kernel game.input namespaces classes windows.com.syntax
+bit-arrays
+vectors ;
+IN: game.input.linux
+
+SINGLETON: linux-game-input-backend
+
+linux-game-input-backend game-input-backend set-global
+
+M: linux-game-input-backend (open-game-input)
+ ;
+
+M: linux-game-input-backend (close-game-input)
+ ;
+
+M: linux-game-input-backend (reset-game-input)
+ ;
+
+M: linux-game-input-backend get-controllers
+ { } ;
+
+M: linux-game-input-backend product-string
+ drop "" ;
+
+M: linux-game-input-backend product-id
+ drop GUID: {00000000-0000-0000-0000-000000000000} ;
+
+M: linux-game-input-backend instance-id
+ drop GUID: {00000000-0000-0000-0000-000000000000} ;
+
+M: linux-game-input-backend read-controller
+ drop controller-state new ;
+
+M: linux-game-input-backend calibrate-controller
+ drop ;
+
+M: linux-game-input-backend vibrate-controller
+ 3drop ;
+
+M: linux-game-input-backend read-keyboard
+ 256 <bit-array> keyboard-state boa ;
+
+M: linux-game-input-backend read-mouse
+ 0 0 0 0 2 <vector> mouse-state boa ;
+
+M: linux-game-input-backend reset-mouse
+ ;
--- /dev/null
+Linux backend for game input.
-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 ;
+
! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types arrays ascii assocs colors
-classes.struct combinators io.encodings.ascii
-io.encodings.string io.encodings.utf8 kernel literals math
-namespaces sequences strings ui ui.backend ui.clipboards
-ui.event-loop ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures ui.pixel-formats ui.pixel-formats.private
-ui.private x11 x11.clipboard x11.constants x11.events x11.glx
-x11.io x11.windows x11.xim x11.xlib environment command-line
-combinators.short-circuit ;
+USING: accessors alien.c-types ascii assocs classes.struct combinators
+combinators.short-circuit command-line environment io.encodings.ascii
+io.encodings.string io.encodings.utf8 kernel literals locals math
+namespaces sequences specialized-arrays.instances.alien.c-types.uchar
+strings ui ui.backend ui.clipboards ui.event-loop ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures ui.pixel-formats
+ui.pixel-formats.private ui.private x11 x11.clipboard x11.constants
+x11.events x11.glx x11.io x11.windows x11.xim x11.xlib ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;
+: black ( -- xcolor ) 0 0 0 0 0 0 XColor <struct-boa> ; inline
+
+M:: x11-ui-backend (grab-input) ( handle -- )
+ handle window>> :> wnd
+ dpy get :> dpy
+ dpy wnd uchar-array{ 0 0 0 0 0 0 0 0 } 8 8 XCreateBitmapFromData :> pixmap
+ dpy pixmap dup black dup 0 0 XCreatePixmapCursor :> cursor
+
+ dpy wnd 1 NoEventMask GrabModeAsync dup wnd cursor CurrentTime XGrabPointer drop
+
+ dpy cursor XFreeCursor drop
+ dpy pixmap XFreePixmap drop ;
+
+M: x11-ui-backend (ungrab-input)
+ drop dpy get CurrentTime XUngrabPointer drop ;
+
x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui.tools" "listener" ? ]
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
X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+! 5.2 - Creating, Recoloring, and Freeing Cursors
+
+C-TYPE: XColor
+X-FUNCTION: Cursor XCreatePixmapCursor ( Display* display, Pixmap source, Pixmap mask, XColor* foreground_color, XColor* background_color, uint x, uint y ) ;
+X-FUNCTION: int XFreeCursor ( Display* display, Cursor cursor ) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 6 - Color Management Functions
X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: int XGrabKeyboard ( Display* display, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode, Time time ) ;
X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
X-FUNCTION: Status XGetInputFocus ( Display* display,
{ colormap_size int }
{ bits_per_rgb int } ;
+! 16.9 Manipulating Bitmaps
+X-FUNCTION: Pixmap XCreateBitmapFromData (
+ Display* display,
+ Drawable d,
+ char* data,
+ uint width,
+ uint height ) ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Appendix D - Compatibility Functions
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! 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
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types alien.libraries
+alien.syntax classes.struct combinators endian io.binary
+kernel locals math sequences specialized-arrays
+system unix.time unix.types ;
+FROM: alien.c-types => short ;
+IN: libusb
+
+<< "libusb" {
+ { [ os windows? ] [ "libusb-1.0.dll" ] }
+ { [ os macosx? ] [ "libusb-1.0.dylib" ] }
+ { [ os unix? ] [ "libusb-1.0.so" ] }
+ } cond "cdecl" add-library >>
+LIBRARY: libusb
+
+: libusb_cpu_to_le16 ( x -- y )
+ 2 >native-endian le> ; inline
+
+ALIAS: libusb_le16_to_cpu libusb_cpu_to_le16
+
+CONSTANT: LIBUSB_CLASS_PER_INTERFACE 0
+CONSTANT: LIBUSB_CLASS_AUDIO 1
+CONSTANT: LIBUSB_CLASS_COMM 2
+CONSTANT: LIBUSB_CLASS_HID 3
+CONSTANT: LIBUSB_CLASS_PRINTER 7
+CONSTANT: LIBUSB_CLASS_PTP 6
+CONSTANT: LIBUSB_CLASS_MASS_STORAGE 8
+CONSTANT: LIBUSB_CLASS_HUB 9
+CONSTANT: LIBUSB_CLASS_DATA 10
+CONSTANT: LIBUSB_CLASS_VENDOR_SPEC HEX: ff
+TYPEDEF: int libusb_class_code
+
+CONSTANT: LIBUSB_DT_DEVICE HEX: 01
+CONSTANT: LIBUSB_DT_CONFIG HEX: 02
+CONSTANT: LIBUSB_DT_STRING HEX: 03
+CONSTANT: LIBUSB_DT_INTERFACE HEX: 04
+CONSTANT: LIBUSB_DT_ENDPOINT HEX: 05
+CONSTANT: LIBUSB_DT_HID HEX: 21
+CONSTANT: LIBUSB_DT_REPORT HEX: 22
+CONSTANT: LIBUSB_DT_PHYSICAL HEX: 23
+CONSTANT: LIBUSB_DT_HUB HEX: 29
+TYPEDEF: int libusb_descriptor_type
+
+CONSTANT: LIBUSB_DT_DEVICE_SIZE 18
+CONSTANT: LIBUSB_DT_CONFIG_SIZE 9
+CONSTANT: LIBUSB_DT_INTERFACE_SIZE 9
+CONSTANT: LIBUSB_DT_ENDPOINT_SIZE 7
+CONSTANT: LIBUSB_DT_ENDPOINT_AUDIO_SIZE 9
+CONSTANT: LIBUSB_DT_HUB_NONVAR_SIZE 7
+
+CONSTANT: LIBUSB_ENDPOINT_ADDRESS_MASK HEX: 0f
+CONSTANT: LIBUSB_ENDPOINT_DIR_MASK HEX: 80
+
+CONSTANT: LIBUSB_ENDPOINT_IN HEX: 80
+CONSTANT: LIBUSB_ENDPOINT_OUT HEX: 00
+TYPEDEF: int libusb_endpoint_direction
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_MASK HEX: 03
+
+CONSTANT: LIBUSB_TRANSFER_TYPE_CONTROL 0
+CONSTANT: LIBUSB_TRANSFER_TYPE_ISOCHRONOUS 1
+CONSTANT: LIBUSB_TRANSFER_TYPE_BULK 2
+CONSTANT: LIBUSB_TRANSFER_TYPE_INTERRUPT 3
+TYPEDEF: int libusb_transfer_type
+
+CONSTANT: LIBUSB_REQUEST_GET_STATUS HEX: 00
+CONSTANT: LIBUSB_REQUEST_CLEAR_FEATURE HEX: 01
+CONSTANT: LIBUSB_REQUEST_SET_FEATURE HEX: 03
+CONSTANT: LIBUSB_REQUEST_SET_ADDRESS HEX: 05
+CONSTANT: LIBUSB_REQUEST_GET_DESCRIPTOR HEX: 06
+CONSTANT: LIBUSB_REQUEST_SET_DESCRIPTOR HEX: 07
+CONSTANT: LIBUSB_REQUEST_GET_CONFIGURATION HEX: 08
+CONSTANT: LIBUSB_REQUEST_SET_CONFIGURATION HEX: 09
+CONSTANT: LIBUSB_REQUEST_GET_INTERFACE HEX: 0A
+CONSTANT: LIBUSB_REQUEST_SET_INTERFACE HEX: 0B
+CONSTANT: LIBUSB_REQUEST_SYNCH_FRAME HEX: 0C
+TYPEDEF: int libusb_standard_request
+
+CONSTANT: LIBUSB_REQUEST_TYPE_STANDARD HEX: 00
+CONSTANT: LIBUSB_REQUEST_TYPE_CLASS HEX: 20
+CONSTANT: LIBUSB_REQUEST_TYPE_VENDOR HEX: 40
+CONSTANT: LIBUSB_REQUEST_TYPE_RESERVED HEX: 60
+
+CONSTANT: LIBUSB_RECIPIENT_DEVICE HEX: 00
+CONSTANT: LIBUSB_RECIPIENT_INTERFACE HEX: 01
+CONSTANT: LIBUSB_RECIPIENT_ENDPOINT HEX: 02
+CONSTANT: LIBUSB_RECIPIENT_OTHER HEX: 03
+TYPEDEF: int libusb_request_recipient
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_MASK HEX: 0C
+
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_NONE 0
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ASYNC 1
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_ADAPTIVE 2
+CONSTANT: LIBUSB_ISO_SYNC_TYPE_SYNC 3
+TYPEDEF: int libusb_iso_sync_type
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_MASK HEX: 30
+
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_DATA 0
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_FEEDBACK 1
+CONSTANT: LIBUSB_ISO_USAGE_TYPE_IMPLICIT 2
+TYPEDEF: int libusb_iso_usage_type
+
+STRUCT: libusb_device_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bcdUSB uint16_t }
+ { bDeviceClass uint8_t }
+ { bDeviceSubClass uint8_t }
+ { bDeviceProtocol uint8_t }
+ { bMaxPacketSize0 uint8_t }
+ { idVendor uint16_t }
+ { idProduct uint16_t }
+ { bcdDevice uint16_t }
+ { iManufacturer uint8_t }
+ { iProduct uint8_t }
+ { iSerialNumber uint8_t }
+ { bNumConfigurations uint8_t } ;
+
+STRUCT: libusb_endpoint_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bEndpointAddress uint8_t }
+ { bmAttributes uint8_t }
+ { wMaxPacketSize uint16_t }
+ { bInterval uint8_t }
+ { bRefresh uint8_t }
+ { bSynchAddress uint8_t }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { bInterfaceNumber uint8_t }
+ { bAlternateSetting uint8_t }
+ { bNumEndpoints uint8_t }
+ { bInterfaceClass uint8_t }
+ { bInterfaceSubClass uint8_t }
+ { bInterfaceProtocol uint8_t }
+ { iInterface uint8_t }
+ { endpoint libusb_endpoint_descriptor* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_interface
+ { altsetting libusb_interface_descriptor* }
+ { num_altsetting int } ;
+
+STRUCT: libusb_config_descriptor
+ { bLength uint8_t }
+ { bDescriptorType uint8_t }
+ { wTotalLength uint16_t }
+ { bNumInterfaces uint8_t }
+ { bConfigurationValue uint8_t }
+ { iConfiguration uint8_t }
+ { bmAttributes uint8_t }
+ { MaxPower uint8_t }
+ { interface libusb_interface* }
+ { extra uchar* }
+ { extra_length int } ;
+
+STRUCT: libusb_control_setup
+ { bmRequestType uint8_t }
+ { bRequest uint8_t }
+ { wValue uint16_t }
+ { wIndex uint16_t }
+ { wLength uint16_t } ;
+
+: LIBUSB_CONTROL_SETUP_SIZE ( -- x ) libusb_control_setup heap-size ; inline
+
+C-TYPE: libusb_context
+C-TYPE: libusb_device
+C-TYPE: libusb_device_handle
+
+CONSTANT: LIBUSB_SUCCESS 0
+CONSTANT: LIBUSB_ERROR_IO -1
+CONSTANT: LIBUSB_ERROR_INVALID_PARAM -2
+CONSTANT: LIBUSB_ERROR_ACCESS -3
+CONSTANT: LIBUSB_ERROR_NO_DEVICE -4
+CONSTANT: LIBUSB_ERROR_NOT_FOUND -5
+CONSTANT: LIBUSB_ERROR_BUSY -6
+CONSTANT: LIBUSB_ERROR_TIMEOUT -7
+CONSTANT: LIBUSB_ERROR_OVERFLOW -8
+CONSTANT: LIBUSB_ERROR_PIPE -9
+CONSTANT: LIBUSB_ERROR_INTERRUPTED -10
+CONSTANT: LIBUSB_ERROR_NO_MEM -11
+CONSTANT: LIBUSB_ERROR_NOT_SUPPORTED -12
+CONSTANT: LIBUSB_ERROR_OTHER -99
+TYPEDEF: int libusb_error
+
+C-ENUM:
+ LIBUSB_TRANSFER_COMPLETED
+ LIBUSB_TRANSFER_ERROR
+ LIBUSB_TRANSFER_TIMED_OUT
+ LIBUSB_TRANSFER_CANCELLED
+ LIBUSB_TRANSFER_STALL
+ LIBUSB_TRANSFER_NO_DEVICE
+ LIBUSB_TRANSFER_OVERFLOW ;
+TYPEDEF: int libusb_transfer_status
+
+CONSTANT: LIBUSB_TRANSFER_SHORT_NOT_OK 1
+CONSTANT: LIBUSB_TRANSFER_FREE_BUFFER 2
+CONSTANT: LIBUSB_TRANSFER_FREE_TRANSFER 4
+TYPEDEF: int libusb_transfer_flags
+
+STRUCT: libusb_iso_packet_descriptor
+ { length uint }
+ { actual_length uint }
+ { status libusb_transfer_status } ;
+SPECIALIZED-ARRAY: libusb_iso_packet_descriptor
+
+C-TYPE: libusb_transfer
+
+CALLBACK: void libusb_transfer_cb_fn ( libusb_transfer* transfer ) ;
+
+STRUCT: libusb_transfer
+ { dev_handle libusb_device_handle* }
+ { flags uint8_t }
+ { endpoint uchar }
+ { type uchar }
+ { timeout uint }
+ { status libusb_transfer_status }
+ { length int }
+ { actual_length int }
+ { callback libusb_transfer_cb_fn }
+ { user_data void* }
+ { buffer uchar* }
+ { num_iso_packets int }
+ { iso_packet_desc libusb_iso_packet_descriptor[0] } ;
+
+FUNCTION: int libusb_init ( libusb_context** ctx ) ;
+FUNCTION: void libusb_exit ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_debug ( libusb_context* ctx, int level ) ;
+
+FUNCTION: ssize_t libusb_get_device_list ( libusb_context* ctx, libusb_device*** list ) ;
+FUNCTION: void libusb_free_device_list ( libusb_device** list, int unref_devices ) ;
+FUNCTION: libusb_device* libusb_ref_device ( libusb_device* dev ) ;
+FUNCTION: void libusb_unref_device ( libusb_device* dev ) ;
+
+FUNCTION: int libusb_get_configuration ( libusb_device_handle* dev, int* config ) ;
+FUNCTION: int libusb_get_device_descriptor ( libusb_device* dev, libusb_device_descriptor* desc ) ;
+FUNCTION: int libusb_get_active_config_descriptor ( libusb_device* dev, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor ( libusb_device* dev, uint8_t config_index, libusb_config_descriptor** config ) ;
+FUNCTION: int libusb_get_config_descriptor_by_value ( libusb_device* dev, uint8_t bConfigurationValue, libusb_config_descriptor** config ) ;
+FUNCTION: void libusb_free_config_descriptor ( libusb_config_descriptor* config ) ;
+FUNCTION: uint8_t libusb_get_bus_number ( libusb_device* dev ) ;
+FUNCTION: uint8_t libusb_get_device_address ( libusb_device* dev ) ;
+FUNCTION: int libusb_get_max_packet_size ( libusb_device* dev, uchar endpoint ) ;
+
+FUNCTION: int libusb_open ( libusb_device* dev, libusb_device_handle** handle ) ;
+FUNCTION: void libusb_close ( libusb_device_handle* dev_handle ) ;
+FUNCTION: libusb_device* libusb_get_device ( libusb_device_handle* dev_handle ) ;
+
+FUNCTION: int libusb_set_configuration ( libusb_device_handle* dev, int configuration ) ;
+FUNCTION: int libusb_claim_interface ( libusb_device_handle* dev, int iface ) ;
+FUNCTION: int libusb_release_interface ( libusb_device_handle* dev, int iface ) ;
+
+FUNCTION: libusb_device_handle* libusb_open_device_with_vid_pid ( libusb_context* ctx, uint16_t vendor_id, uint16_t product_id ) ;
+
+FUNCTION: int libusb_set_interface_alt_setting ( libusb_device_handle* dev, int interface_number, int alternate_setting ) ;
+FUNCTION: int libusb_clear_halt ( libusb_device_handle* dev, uchar endpoint ) ;
+FUNCTION: int libusb_reset_device ( libusb_device_handle* dev ) ;
+
+FUNCTION: int libusb_kernel_driver_active ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_detach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+FUNCTION: int libusb_attach_kernel_driver ( libusb_device_handle* dev, int interface ) ;
+
+: libusb_control_transfer_get_data ( transfer -- data )
+ buffer>> LIBUSB_CONTROL_SETUP_SIZE swap <displaced-alien> ; inline
+
+: libusb_control_transfer_get_setup ( transfer -- setup )
+ buffer>> libusb_control_setup memory>struct ; inline
+
+:: libusb_fill_control_setup ( buffer bmRequestType bRequest wValue wIndex wLength -- )
+ buffer libusb_control_setup memory>struct
+ bmRequestType >>bmRequestType
+ bRequest >>bRequest
+ wValue libusb_cpu_to_le16 >>wValue
+ wIndex libusb_cpu_to_le16 >>wIndex
+ wLength libusb_cpu_to_le16 >>wLength drop ; inline
+
+FUNCTION: libusb_transfer* libusb_alloc_transfer ( int iso_packets ) ;
+FUNCTION: int libusb_submit_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: int libusb_cancel_transfer ( libusb_transfer* transfer ) ;
+FUNCTION: void libusb_free_transfer ( libusb_transfer* transfer ) ;
+
+:: libusb_fill_control_transfer ( transfer dev_handle buffer callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ 0 >>endpoint
+ LIBUSB_TRANSFER_TYPE_CONTROL >>type
+ timeout >>timeout
+ buffer >>buffer
+ user_data >>user_data
+ callback >>callback
+
+ buffer [
+ libusb_control_setup memory>struct wLength>> LIBUSB_CONTROL_SETUP_SIZE +
+ ] [ 0 ] if* >>length drop ; inline
+
+:: libusb_fill_bulk_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_BULK >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_interrupt_transfer ( transfer dev_handle endpoint buffer length callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_INTERRUPT >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+:: libusb_fill_iso_transfer ( transfer dev_handle endpoint buffer length num_iso_packets callback user_data timeout -- )
+ transfer
+ dev_handle >>dev_handle
+ endpoint >>endpoint
+ LIBUSB_TRANSFER_TYPE_ISOCHRONOUS >>type
+ timeout >>timeout
+ buffer >>buffer
+ length >>length
+ num_iso_packets >>num_iso_packets
+ user_data >>user_data
+ callback >>callback
+ drop ; inline
+
+: libusb_set_iso_packet_lengths ( transfer length -- )
+ [ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array>
+ ] dip [ >>length drop ] curry each ; inline
+
+:: libusb_get_iso_packet_buffer ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> 0
+ [ length>> + ] reduce
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+:: libusb_get_iso_packet_buffer_simple ( transfer packet -- data )
+ packet transfer num_iso_packets>> >=
+ [ f ]
+ [
+ 0 transfer
+ [ iso_packet_desc>> >c-ptr ]
+ [ num_iso_packets>> ] bi
+ <direct-libusb_iso_packet_descriptor-array> nth
+ length>> packet *
+ transfer buffer>> <displaced-alien>
+ ] if ;
+
+FUNCTION: int libusb_control_transfer ( libusb_device_handle* dev_handle,
+ uint8_t request_type, uint8_t request, uint16_t value, uint16_t index,
+ uchar* data, uint16_t length, uint timeout ) ;
+
+FUNCTION: int libusb_bulk_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, uint timeout ) ;
+
+FUNCTION: int libusb_interrupt_transfer ( libusb_device_handle* dev_handle,
+ uchar endpoint, uchar* data, int length,
+ int* actual_length, int timeout ) ;
+
+:: libusb_get_descriptor ( dev desc_type desc_index data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ desc_type 8 shift desc_index bitor 0 data
+ length 1000 libusb_control_transfer ; inline
+
+:: libusb_get_string_descriptor ( dev desc_index langid data length -- int )
+ dev LIBUSB_ENDPOINT_IN LIBUSB_REQUEST_GET_DESCRIPTOR
+ LIBUSB_DT_STRING 8 shift desc_index bitor
+ langid data length 1000 libusb_control_transfer ; inline
+
+FUNCTION: int libusb_get_string_descriptor_ascii ( libusb_device_handle* dev,
+ uint8_t index,
+ uchar* data,
+ int length ) ;
+
+FUNCTION: int libusb_try_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_events ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handling_ok ( libusb_context* ctx ) ;
+FUNCTION: int libusb_event_handler_active ( libusb_context* ctx ) ;
+FUNCTION: void libusb_lock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: void libusb_unlock_event_waiters ( libusb_context* ctx ) ;
+FUNCTION: int libusb_wait_for_event ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events_timeout ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_handle_events ( libusb_context* ctx ) ;
+FUNCTION: int libusb_handle_events_locked ( libusb_context* ctx, timeval* tv ) ;
+FUNCTION: int libusb_get_next_timeout ( libusb_context* ctx, timeval* tv ) ;
+
+STRUCT: libusb_pollfd
+ { fd int }
+ { events short } ;
+
+CALLBACK: void libusb_pollfd_added_cb ( int fd, short events, void* user_data ) ;
+CALLBACK: void libusb_pollfd_removed_cb ( int fd, void* user_data ) ;
+
+FUNCTION: libusb_pollfd** libusb_get_pollfds ( libusb_context* ctx ) ;
+FUNCTION: void libusb_set_pollfd_notifiers ( libusb_context* ctx,
+ libusb_pollfd_added_cb added_cb,
+ libusb_pollfd_removed_cb removed_cb,
+ void* user_data ) ;
--- /dev/null
+Bindings to libusb
--- /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