diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 6bf1ea2ff1..27dc25de73 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -5,7 +5,7 @@ compression.lzw constructors endian fry grouping images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences -strings math.vectors specialized-arrays.float ; +strings math.vectors specialized-arrays.float locals ; IN: images.tiff TUPLE: tiff-image < image ; @@ -184,7 +184,7 @@ samples-per-pixel new-subfile-type subfile-type orientation software date-time photoshop exif-ifd sub-ifd inter-color-profile xmp iptc fill-order document-name page-number page-name x-position y-position host-computer copyright artist -min-sample-value max-sample-value make model cell-width cell-length +min-sample-value max-sample-value tiff-make tiff-model cell-width cell-length gray-response-unit gray-response-curve color-map threshholding image-description free-offsets free-byte-counts tile-width tile-length matteing data-type image-depth tile-depth @@ -243,10 +243,13 @@ ERROR: bad-tiff-magic bytes ; ERROR: no-tag class ; -: find-tag ( idf class -- tag ) - swap processed-tags>> ?at [ no-tag ] unless ; +: find-tag* ( ifd class -- tag/class ? ) + swap processed-tags>> ?at ; -: tag? ( idf class -- tag ) +: find-tag ( ifd class -- tag ) + find-tag* [ no-tag ] unless ; + +: tag? ( ifd class -- tag ) swap processed-tags>> key? ; : read-strips ( ifd -- ifd ) @@ -339,8 +342,8 @@ ERROR: bad-small-ifd-type n ; { 266 [ fill-order ] } { 269 [ ascii decode document-name ] } { 270 [ ascii decode image-description ] } - { 271 [ ascii decode make ] } - { 272 [ ascii decode model ] } + { 271 [ ascii decode tiff-make ] } + { 272 [ ascii decode tiff-model ] } { 273 [ strip-offsets ] } { 274 [ orientation ] } { 277 [ samples-per-pixel ] } @@ -350,7 +353,7 @@ ERROR: bad-small-ifd-type n ; { 281 [ max-sample-value ] } { 282 [ first x-resolution ] } { 283 [ first y-resolution ] } - { 284 [ planar-configuration ] } + { 284 [ lookup-planar-configuration planar-configuration ] } { 285 [ page-name ] } { 286 [ x-position ] } { 287 [ y-position ] } @@ -437,8 +440,8 @@ ERROR: unhandled-compression compression ; [ samples-per-pixel find-tag ] tri [ * ] keep '[ - _ group [ _ group [ rest ] [ first ] bi - [ v+ ] accumulate swap suffix concat ] map + _ group + [ _ group unclip [ v+ ] accumulate swap suffix concat ] map concat >byte-array ] change-bitmap ; @@ -521,23 +524,39 @@ ERROR: unknown-component-order ifd ; ] with-tiff-endianness ] with-file-reader ; -: process-tif-ifds ( parsed-tiff -- parsed-tiff ) - dup ifds>> [ - read-strips - uncompress-strips - strips>bitmap - fix-bitmap-endianness - strips-predictor - dup extra-samples tag? [ handle-alpha-data ] when - drop - ] each ; +: process-chunky-ifd ( ifd -- ) + read-strips + uncompress-strips + strips>bitmap + fix-bitmap-endianness + strips-predictor + dup extra-samples tag? [ handle-alpha-data ] when + drop ; + +: process-planar-ifd ( ifd -- ) + "planar ifd not supported" throw ; + +: dispatch-planar-configuration ( ifd planar-configuration -- ) + { + { planar-configuration-chunky [ process-chunky-ifd ] } + { planar-configuration-planar [ process-planar-ifd ] } + } case ; + +: process-ifd ( ifd -- ) + dup planar-configuration find-tag* [ + dispatch-planar-configuration + ] [ + drop "no planar configuration" throw + ] if ; + +: process-tif-ifds ( parsed-tiff -- ) + ifds>> [ process-ifd ] each ; : load-tiff ( path -- parsed-tiff ) - [ load-tiff-ifds ] [ - binary [ - [ process-tif-ifds ] with-tiff-endianness - ] with-file-reader - ] bi ; + [ load-tiff-ifds dup ] keep + binary [ + [ process-tif-ifds ] with-tiff-endianness + ] with-file-reader ; ! tiff files can store several images -- we just take the first for now M: tiff-image load-image* ( path tiff-image -- image ) diff --git a/basis/math/bits/bits.factor b/basis/math/bits/bits.factor index 8920955df3..72b83a991f 100644 --- a/basis/math/bits/bits.factor +++ b/basis/math/bits/bits.factor @@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ; C: bits : make-bits ( number -- bits ) - dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ ] if ; inline + dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + ] if ; inline M: bits length length>> ; diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor index 3148567bc0..73d111f91e 100755 --- a/basis/math/bitwise/bitwise.factor +++ b/basis/math/bitwise/bitwise.factor @@ -13,10 +13,10 @@ IN: math.bitwise : unmask? ( x n -- ? ) unmask 0 > ; inline : mask ( x n -- ? ) bitand ; inline : mask? ( x n -- ? ) mask 0 > ; inline -: wrap ( m n -- m' ) 1- bitand ; inline +: wrap ( m n -- m' ) 1 - bitand ; inline : bits ( m n -- m' ) 2^ wrap ; inline : mask-bit ( m n -- m' ) 2^ mask ; inline -: on-bits ( n -- m ) 2^ 1- ; inline +: on-bits ( n -- m ) 2^ 1 - ; inline : toggle-bit ( m n -- m' ) 2^ bitxor ; inline : shift-mod ( n s w -- n ) @@ -64,8 +64,8 @@ DEFER: byte-bit-count << \ byte-bit-count -256 [ - 8 0 [ [ 1+ ] when ] reduce +256 iota [ + 8 0 [ [ 1 + ] when ] reduce ] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ] (( byte -- table )) define-declared @@ -97,12 +97,12 @@ PRIVATE> ! Signed byte array to integer conversion : signed-le> ( bytes -- x ) - [ le> ] [ length 8 * 1- on-bits ] bi + [ le> ] [ length 8 * 1 - on-bits ] bi 2dup > [ bitnot bitor ] [ drop ] if ; : signed-be> ( bytes -- x ) signed-le> ; : >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; + 2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ; diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index d7c6ebc927..3017a12b18 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -164,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX 1- ; + (prepare-nrm2) IXAMAX 1 - ; M: VECTOR (blas-vector-like) drop ; diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 397a7cc2f3..66d813bab8 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -157,3 +157,8 @@ IN: math.functions.tests 2135623355842621559 [ >bignum ] tri@ ^mod ] unit-test + +[ 1.0 ] [ 1.0 2.5 0.0 lerp ] unit-test +[ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test +[ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test + diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index c21053317e..0a5e89ccd6 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -18,7 +18,7 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while + 0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while ] if ; inline > first 1 max dup most-positive-fixnum > [ drop full-interval interval-log2 ] - [ 1+ >integer log2 0 swap [a,b] ] + [ 1 + >integer log2 0 swap [a,b] ] if ] } case ; @@ -407,7 +407,7 @@ SYMBOL: incomparable : integral-closure ( i1 -- i2 ) dup special-interval? [ - [ from>> first2 [ 1+ ] unless ] - [ to>> first2 [ 1- ] unless ] + [ from>> first2 [ 1 + ] unless ] + [ to>> first2 [ 1 - ] unless ] bi [a,b] ] unless ; diff --git a/basis/math/miller-rabin/miller-rabin-tests.factor b/basis/math/miller-rabin/miller-rabin-tests.factor index 5f1b9835e4..676c4bf20d 100644 --- a/basis/math/miller-rabin/miller-rabin-tests.factor +++ b/basis/math/miller-rabin/miller-rabin-tests.factor @@ -1,4 +1,4 @@ -USING: math.miller-rabin tools.test ; +USING: math.miller-rabin tools.test kernel sequences ; IN: math.miller-rabin.tests [ f ] [ 473155932665450549999756893736999469773678960651272093993257221235459777950185377130233556540099119926369437865330559863 miller-rabin ] unit-test @@ -8,4 +8,12 @@ IN: math.miller-rabin.tests [ t ] [ 37 miller-rabin ] unit-test [ 101 ] [ 100 next-prime ] unit-test [ t ] [ 2135623355842621559 miller-rabin ] unit-test -[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test \ No newline at end of file +[ 100000000000031 ] [ 100000000000000 next-prime ] unit-test + +[ 863 ] [ 862 next-safe-prime ] unit-test +[ f ] [ 862 safe-prime? ] unit-test +[ t ] [ 7 safe-prime? ] unit-test +[ f ] [ 31 safe-prime? ] unit-test +[ t ] [ 863 safe-prime? ] unit-test + +[ f ] [ 1000 [ drop 15 miller-rabin ] any? ] unit-test diff --git a/basis/math/miller-rabin/miller-rabin.factor b/basis/math/miller-rabin/miller-rabin.factor index 8c237d0dc3..93d7f4c582 100755 --- a/basis/math/miller-rabin/miller-rabin.factor +++ b/basis/math/miller-rabin/miller-rabin.factor @@ -1,36 +1,32 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: combinators kernel locals math math.functions math.ranges -random sequences sets ; +random sequences sets combinators.short-circuit ; IN: math.miller-rabin odd ( n -- int ) dup even? [ 1+ ] when ; foldable +: >odd ( n -- int ) dup even? [ 1 + ] when ; foldable TUPLE: positive-even-expected n ; :: (miller-rabin) ( n trials -- ? ) - [let | r [ n 1- factor-2s drop ] - s [ n 1- factor-2s nip ] - prime?! [ t ] - a! [ 0 ] - count! [ 0 ] | - trials [ - n 1- [1,b] random a! - a s n ^mod 1 = [ - 0 count! - r [ - 2^ s * a swap n ^mod n - -1 = - [ count 1+ count! r + ] when - ] each - count zero? [ f prime?! trials + ] when - ] unless drop - ] each prime? ] ; + n 1 - :> n-1 + n-1 factor-2s :> s :> r + 0 :> a! + t :> prime?! + trials [ + n 1 - [1,b] random a! + a s n ^mod 1 = [ + r iota [ + 2^ s * a swap n ^mod n - -1 = + ] any? not [ f prime?! trials + ] when + ] unless drop + ] each prime? ; PRIVATE> -: next-odd ( m -- n ) dup even? [ 1+ ] [ 2 + ] if ; +: next-odd ( m -- n ) dup even? [ 1 + ] [ 2 + ] if ; : miller-rabin* ( n numtrials -- ? ) over { @@ -74,3 +70,36 @@ ERROR: too-few-primes ; dup 5 < [ too-few-primes ] when 2dup [ random-prime ] curry replicate dup all-unique? [ 2nip ] [ drop unique-primes ] if ; + +! Safe primes are of the form p = 2q + 1, p,q are prime +! See http://en.wikipedia.org/wiki/Safe_prime + +safe-prime-form ( q -- p ) 2 * 1 + ; + +: safe-prime-candidate? ( n -- ? ) + >safe-prime-form + 1 + 6 divisor? ; + +: next-safe-prime-candidate ( n -- candidate ) + 1 - 2/ + next-prime dup safe-prime-candidate? + [ next-safe-prime-candidate ] unless ; + +PRIVATE> + +: safe-prime? ( q -- ? ) + { + [ 1 - 2 / dup integer? [ miller-rabin ] [ drop f ] if ] + [ miller-rabin ] + } 1&& ; + +: next-safe-prime ( n -- q ) + next-safe-prime-candidate + dup >safe-prime-form + dup miller-rabin + [ nip ] [ drop next-safe-prime ] if ; + +: random-safe-prime ( numbits -- p ) + random-bits next-safe-prime ; diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index ec09b366a1..f65c4ecaaf 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -29,7 +29,7 @@ PRIVATE> : n*p ( n p -- n*p ) n*v ; : pextend-conv ( p q -- p q ) - 2dup [ length ] bi@ + 1- 2pad-tail [ >vector ] bi@ ; + 2dup [ length ] bi@ + 1 - 2pad-tail [ >vector ] bi@ ; : p* ( p q -- r ) 2unempty pextend-conv dup length @@ -44,7 +44,7 @@ PRIVATE> 2ptrim 2dup [ length ] bi@ - dup 1 < [ drop 1 ] when - [ over length + 0 pad-head pextend ] keep 1+ ; + [ over length + 0 pad-head pextend ] keep 1 + ; : /-last ( seq seq -- a ) #! divide the last two numbers in the sequences diff --git a/basis/math/ranges/ranges.factor b/basis/math/ranges/ranges.factor index 068f599b6f..883be006dc 100644 --- a/basis/math/ranges/ranges.factor +++ b/basis/math/ranges/ranges.factor @@ -10,7 +10,7 @@ TUPLE: range { step read-only } ; : ( a b step -- range ) - [ over - ] dip [ /i 1+ 0 max ] keep range boa ; inline + [ over - ] dip [ /i 1 + 0 max ] keep range boa ; inline M: range length ( seq -- n ) length>> ; diff --git a/basis/math/statistics/statistics.factor b/basis/math/statistics/statistics.factor index 589876184f..4cd8c5b888 100644 --- a/basis/math/statistics/statistics.factor +++ b/basis/math/statistics/statistics.factor @@ -15,7 +15,7 @@ IN: math.statistics : median ( seq -- n ) natural-sort dup length even? [ - [ midpoint@ dup 1- 2array ] keep nths mean + [ midpoint@ dup 1 - 2array ] keep nths mean ] [ [ midpoint@ ] keep nth ] if ; @@ -33,7 +33,7 @@ IN: math.statistics drop 0 ] [ [ [ mean ] keep [ - sq ] with sigma ] keep - length 1- / + length 1 - / ] if ; : std ( seq -- x ) @@ -47,7 +47,7 @@ IN: math.statistics 0 [ [ [ pick ] dip swap - ] bi@ * + ] 2reduce 2nip ; : (r) ( mean(x) mean(y) {x} {y} sx sy -- r ) - * recip [ [ ((r)) ] keep length 1- / ] dip * ; + * recip [ [ ((r)) ] keep length 1 - / ] dip * ; : [r] ( {{x,y}...} -- mean(x) mean(y) {x} {y} sx sy ) first2 [ [ [ mean ] bi@ ] 2keep ] 2keep [ std ] bi@ ; diff --git a/basis/math/vectors/vectors-tests.factor b/basis/math/vectors/vectors-tests.factor index aef4ade877..b4b12d619b 100644 --- a/basis/math/vectors/vectors-tests.factor +++ b/basis/math/vectors/vectors-tests.factor @@ -9,3 +9,8 @@ USING: math.vectors tools.test ; [ 5 ] [ { 1 2 } norm-sq ] unit-test [ 13 ] [ { 2 3 } norm-sq ] unit-test +[ { 1.0 2.5 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.0 vnlerp ] unit-test +[ { 2.5 1.0 } ] [ { 1.0 2.5 } { 2.5 1.0 } 1.0 vnlerp ] unit-test +[ { 1.75 1.75 } ] [ { 1.0 2.5 } { 2.5 1.0 } 0.5 vnlerp ] unit-test + +[ { 1.75 2.125 } ] [ { 1.0 2.5 } { 2.5 1.0 } { 0.5 0.25 } vlerp ] unit-test diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index eb5fa7b970..eb203a5f12 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -6,6 +6,11 @@ IN: math.vectors : vneg ( u -- v ) [ neg ] map ; +: v+n ( u n -- v ) [ + ] curry map ; +: n+v ( n u -- v ) [ + ] with map ; +: v-n ( u n -- v ) [ - ] curry map ; +: n-v ( n u -- v ) [ - ] with map ; + : v*n ( u n -- v ) [ * ] curry map ; : n*v ( n u -- v ) [ * ] with map ; : v/n ( u n -- v ) [ / ] curry map ; @@ -19,6 +24,10 @@ IN: math.vectors : vmax ( u v -- w ) [ max ] 2map ; : vmin ( u v -- w ) [ min ] 2map ; +: vfloor ( v -- _v_ ) [ floor ] map ; +: vceiling ( v -- ^v^ ) [ ceiling ] map ; +: vtruncate ( v -- -v- ) [ truncate ] map ; + : vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; : vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; @@ -32,6 +41,12 @@ IN: math.vectors : set-axis ( u v axis -- w ) [ [ zero? 2over ? ] dip swap nth ] map-index 2nip ; +: vlerp ( a b t -- a_t ) + [ lerp ] 3map ; + +: vnlerp ( a b t -- a_t ) + [ lerp ] curry 2map ; + HINTS: vneg { array } ; HINTS: norm-sq { array } ; HINTS: norm { array } ; @@ -50,3 +65,6 @@ HINTS: v/ { array array } ; HINTS: vmax { array array } ; HINTS: vmin { array array } ; HINTS: v. { array array } ; + +HINTS: vlerp { array array array } ; +HINTS: vnlerp { array array object } ; diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 20a54dff98..e5e32aac0e 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -444,6 +444,18 @@ CONSTANT: DISCL_FOREGROUND HEX: 00000004 CONSTANT: DISCL_BACKGROUND HEX: 00000008 CONSTANT: DISCL_NOWINKEY HEX: 00000010 +CONSTANT: DIMOFS_X 0 +CONSTANT: DIMOFS_Y 4 +CONSTANT: DIMOFS_Z 8 +CONSTANT: DIMOFS_BUTTON0 12 +CONSTANT: DIMOFS_BUTTON1 13 +CONSTANT: DIMOFS_BUTTON2 14 +CONSTANT: DIMOFS_BUTTON3 15 +CONSTANT: DIMOFS_BUTTON4 16 +CONSTANT: DIMOFS_BUTTON5 17 +CONSTANT: DIMOFS_BUTTON6 18 +CONSTANT: DIMOFS_BUTTON7 19 + CONSTANT: DIK_ESCAPE HEX: 01 CONSTANT: DIK_1 HEX: 02 CONSTANT: DIK_2 HEX: 03 diff --git a/extra/game-input/dinput/dinput.factor b/extra/game-input/dinput/dinput.factor index 20815859ab..8540907db9 100755 --- a/extra/game-input/dinput/dinput.factor +++ b/extra/game-input/dinput/dinput.factor @@ -5,16 +5,20 @@ windows.user32 windows.messages sequences combinators locals math.rectangles accessors math alien alien.strings io.encodings.utf16 io.encodings.utf16n continuations byte-arrays game-input.dinput.keys-array game-input -ui.backend.windows windows.errors ; +ui.backend.windows windows.errors struct-arrays +math.bitwise ; IN: game-input.dinput +CONSTANT: MOUSE-BUFFER-SIZE 16 + SINGLETON: dinput-game-input-backend dinput-game-input-backend game-input-backend set-global SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ +controller-devices+ +controller-guids+ - +device-change-window+ +device-change-handle+ ; + +device-change-window+ +device-change-handle+ + +mouse-device+ +mouse-state+ +mouse-buffer+ ; : create-dinput ( -- ) f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid @@ -35,8 +39,24 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ : set-data-format ( device format-symbol -- ) get IDirectInputDevice8W::SetDataFormat ole32-error ; +: ( size -- DIPROPDWORD ) + "DIPROPDWORD" + "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize + "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize + 0 over set-DIPROPHEADER-dwObj + DIPH_DEVICE over set-DIPROPHEADER-dwHow + swap over set-DIPROPDWORD-dwData ; + +: set-buffer-size ( device size -- ) + DIPROP_BUFFERSIZE swap + IDirectInputDevice8W::SetProperty ole32-error ; + : configure-keyboard ( keyboard -- ) [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ; +: configure-mouse ( mouse -- ) + [ c_dfDIMouse2 set-data-format ] + [ MOUSE-BUFFER-SIZE set-buffer-size ] + [ set-coop-level ] tri ; : configure-controller ( controller -- ) [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ; @@ -47,6 +67,15 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+ 256 keyboard-state boa +keyboard-state+ set-global ; +: find-mouse ( -- ) + GUID_SysMouse device-for-guid + [ configure-mouse ] + [ +mouse-device+ set-global ] bi + 0 0 0 0 8 f mouse-state boa + +mouse-state+ set-global + MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" + +mouse-buffer+ set-global ; + : device-info ( device -- DIDEVICEIMAGEINFOW ) "DIDEVICEINSTANCEW" "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize @@ -190,16 +219,22 @@ TUPLE: window-rect < rect window-loc ; +keyboard-device+ [ com-release f ] change-global f +keyboard-state+ set-global ; +: release-mouse ( -- ) + +mouse-device+ [ com-release f ] change-global + f +mouse-state+ set-global ; + M: dinput-game-input-backend (open-game-input) create-dinput create-device-change-window find-keyboard + find-mouse set-up-controllers add-wm-devicechange ; M: dinput-game-input-backend (close-game-input) remove-wm-devicechange release-controllers + release-mouse release-keyboard close-device-change-window delete-dinput ; @@ -263,6 +298,22 @@ CONSTANT: pov-values [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ] } 2cleave ; +: read-device-buffer ( device buffer count -- buffer count' ) + [ "DIDEVICEOBJECTDATA" heap-size ] 2dip + [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ; + +: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state ) + [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi { + { DIMOFS_X [ [ + ] curry change-dx ] } + { DIMOFS_Y [ [ + ] curry change-dy ] } + { DIMOFS_Z [ [ + ] curry change-scroll-dy ] } + [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ] + } case ; + +: fill-mouse-state ( buffer count -- state ) + [ +mouse-state+ get ] 2dip swap + [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ; + : get-device-state ( device byte-array -- ) [ dup IDirectInputDevice8W::Poll ole32-error ] dip [ length ] keep @@ -283,3 +334,17 @@ M: dinput-game-input-backend read-keyboard +keyboard-device+ get [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ] [ ] [ f ] with-acquisition ; + +M: dinput-game-input-backend read-mouse + +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ] + [ fill-mouse-state ] [ f ] with-acquisition ; + +M: dinput-game-input-backend reset-mouse + +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ] + [ 2drop ] [ ] with-acquisition + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; diff --git a/extra/game-input/game-input-docs.factor b/extra/game-input/game-input-docs.factor index 5428ca66d0..b46cf9a295 100755 --- a/extra/game-input/game-input-docs.factor +++ b/extra/game-input/game-input-docs.factor @@ -3,7 +3,7 @@ sequences strings math ; IN: game-input ARTICLE: "game-input" "Game controller input" -"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard input." $nl +"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl "The game input interface must be initialized before being used:" { $subsection open-game-input } { $subsection close-game-input } @@ -18,11 +18,13 @@ ARTICLE: "game-input" "Game controller input" { $subsection instance-id } "A hook is provided for invoking the system calibration tool:" { $subsection calibrate-controller } -"The current state of a controller or the keyboard can be read:" +"The current state of a controller, the keyboard, and the mouse can be read:" { $subsection read-controller } { $subsection read-keyboard } +{ $subsection read-mouse } { $subsection controller-state } -{ $subsection keyboard-state } ; +{ $subsection keyboard-state } +{ $subsection mouse-state } ; HELP: open-game-input { $description "Initializes the game input interface. An exception will be thrown if the initialization fails. If the game input interface is already opened, nothing happens." } ; @@ -86,6 +88,14 @@ HELP: read-keyboard { $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve." $nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: read-mouse +{ $values { "mouse-state" mouse-state } } +{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." } +{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ; + +HELP: reset-mouse +{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ; + HELP: controller-state { $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:" { $list @@ -121,6 +131,19 @@ HELP: keyboard-state { $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." } { $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ; +HELP: mouse-state +{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:" +{ $list + { { $snippet "dx" } " contains the mouse's X axis movement." } + { { $snippet "dy" } " contains the mouse's Y axis movement." } + { { $snippet "scroll-dx" } " contains the scroller's X axis movement." } + { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." } + { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." } +} +"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "." +} ; + + { keyboard-state read-keyboard } related-words ABOUT: "game-input" diff --git a/extra/game-input/game-input.factor b/extra/game-input/game-input.factor index 6efe31861a..8281b7bc4c 100755 --- a/extra/game-input/game-input.factor +++ b/extra/game-input/game-input.factor @@ -73,6 +73,15 @@ M: keyboard-state clone HOOK: read-keyboard game-input-backend ( -- keyboard-state ) +TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ; + +M: mouse-state clone + call-next-method dup buttons>> clone >>buttons ; + +HOOK: read-mouse game-input-backend ( -- mouse-state ) + +HOOK: reset-mouse game-input-backend ( -- ) + { { [ os windows? ] [ "game-input.dinput" require ] } { [ os macosx? ] [ "game-input.iokit" require ] } diff --git a/extra/game-input/iokit/iokit.factor b/extra/game-input/iokit/iokit.factor index 2ded263899..0cc8b5d51f 100755 --- a/extra/game-input/iokit/iokit.factor +++ b/extra/game-input/iokit/iokit.factor @@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs vectors arrays combinators core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input ; +alien.c-types math parser game-input vectors ; IN: game-input.iokit SINGLETON: iokit-game-input-backend @@ -23,9 +23,13 @@ iokit-game-input-backend game-input-backend set-global CONSTANT: game-devices-matching-seq { + H{ { "DeviceUsage" 1 } { "DeviceUsagePage" 1 } } ! pointers + H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards + H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads + H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers } CONSTANT: buttons-matching-hash @@ -46,6 +50,8 @@ CONSTANT: rz-axis-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } } CONSTANT: slider-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } } +CONSTANT: wheel-matching-hash + H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } } CONSTANT: hat-switch-matching-hash H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } } @@ -90,10 +96,17 @@ CONSTANT: hat-switch-matching-hash : transfer-element-property ( element from-key to-key -- ) [ dupd element-property ] dip swap set-element-property ; +: mouse-device? ( device -- ? ) + { + [ 1 1 IOHIDDeviceConformsTo ] + [ 1 2 IOHIDDeviceConformsTo ] + } 1|| ; + : controller-device? ( device -- ? ) { [ 1 4 IOHIDDeviceConformsTo ] [ 1 5 IOHIDDeviceConformsTo ] + [ 1 8 IOHIDDeviceConformsTo ] } 1|| ; : element-usage ( element -- {usage-page,usage} ) @@ -118,6 +131,8 @@ CONSTANT: hat-switch-matching-hash { 1 HEX: 35 } = ; inline : slider? ( {usage-page,usage} -- ? ) { 1 HEX: 36 } = ; inline +: wheel? ( {usage-page,usage} -- ? ) + { 1 HEX: 38 } = ; inline : hat-switch? ( {usage-page,usage} -- ? ) { 1 HEX: 39 } = ; inline @@ -132,12 +147,17 @@ CONSTANT: pov-values IOHIDValueGetIntegerValue dup zero? [ drop f ] when ; : axis-value ( value -- [-1,1] ) kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ; +: mouse-axis-value ( value -- n ) + IOHIDValueGetIntegerValue ; : pov-value ( value -- pov-direction ) IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ; +: record-button ( hid-value usage state -- ) + [ button-value ] [ second 1- ] [ buttons>> ] tri* set-nth ; + : record-controller ( controller-state value -- ) dup IOHIDValueGetElement element-usage { - { [ dup button? ] [ [ button-value ] [ second 1- ] bi* rot buttons>> set-nth ] } + { [ dup button? ] [ rot record-button ] } { [ dup x-axis? ] [ drop axis-value >>x drop ] } { [ dup y-axis? ] [ drop axis-value >>y drop ] } { [ dup z-axis? ] [ drop axis-value >>z drop ] } @@ -149,7 +169,7 @@ CONSTANT: pov-values [ 3drop ] } cond ; -SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; : ?set-nth ( value nth seq -- ) 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ; @@ -161,6 +181,27 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; +keyboard-state+ get ?set-nth ] [ drop ] if ; +: record-mouse ( value -- ) + dup IOHIDValueGetElement element-usage { + { [ dup button? ] [ +mouse-state+ get record-button ] } + { [ dup x-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dx drop ] } + { [ dup y-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-dy drop ] } + { [ dup wheel? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dx drop ] } + { [ dup z-axis? ] [ drop mouse-axis-value +mouse-state+ get [ + ] change-scroll-dy drop ] } + [ 2drop ] + } cond ; + +M: iokit-game-input-backend read-mouse + +mouse-state+ get ; + +M: iokit-game-input-backend reset-mouse + +mouse-state+ get + 0 >>dx + 0 >>dy + 0 >>scroll-dx + 0 >>scroll-dy + drop ; + : default-calibrate-saturation ( element -- ) [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ] [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ] @@ -194,12 +235,21 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; [ button-count f ] } cleave controller-state boa ; +: ?add-mouse-buttons ( device -- ) + button-count +mouse-state+ get buttons>> + 2dup length > + [ set-length ] [ 2drop ] if ; + : device-matched-callback ( -- alien ) [| context result sender device | - device controller-device? [ - device - device +controller-states+ get set-at - ] when + { + { [ device controller-device? ] [ + device + device +controller-states+ get set-at + ] } + { [ device mouse-device? ] [ device ?add-mouse-buttons ] } + [ ] + } cond ] IOHIDDeviceCallback ; : device-removed-callback ( -- alien ) @@ -209,15 +259,20 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +controller-states+ ; : device-input-callback ( -- alien ) [| context result sender value | - sender controller-device? - [ sender +controller-states+ get at value record-controller ] - [ value record-keyboard ] - if + { + { [ sender controller-device? ] [ + sender +controller-states+ get at value record-controller + ] } + { [ sender mouse-device? ] [ value record-mouse ] } + [ value record-keyboard ] + } cond ] IOHIDValueCallback ; : initialize-variables ( manager -- ) +hid-manager+ set-global 4 +controller-states+ set-global + 0 0 0 0 2 mouse-state boa + +mouse-state+ set-global 256 f +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) diff --git a/extra/perlin-noise/perlin-noise.factor b/extra/perlin-noise/perlin-noise.factor new file mode 100644 index 0000000000..e662202ca1 --- /dev/null +++ b/extra/perlin-noise/perlin-noise.factor @@ -0,0 +1,83 @@ +USING: byte-arrays combinators images kernel locals math +math.functions math.polynomials math.vectors random sequences +sequences.product ; +IN: perlin-noise + +: ( -- table ) + 256 iota >byte-array randomize dup append ; + +: fade ( point -- point' ) + { 0.0 0.0 0.0 10.0 -15.0 6.0 } swap [ polyval ] with map ; + +:: grad ( hash gradients -- gradient ) + hash 8 bitand zero? [ gradients first ] [ gradients second ] if + :> u + hash 12 bitand zero? + [ gradients second ] + [ hash 13 bitand 12 = [ gradients first ] [ gradients third ] if ] if + :> v + + hash 1 bitand zero? [ u ] [ u neg ] if + hash 2 bitand zero? [ v ] [ v neg ] if + ; + +: unit-cube ( point -- cube ) + [ floor >fixnum 256 mod ] map ; + +:: hashes ( table cube -- aaa baa aba bba aab bab abb bbb ) + cube first :> x + cube second :> y + cube third :> z + x table nth y + :> a + x 1 + table nth y + :> b + + a table nth z + :> aa + b table nth z + :> ba + a 1 + table nth z + :> ab + b 1 + table nth z + :> bb + + aa table nth + ba table nth + ab table nth + bb table nth + aa 1 + table nth + ba 1 + table nth + ab 1 + table nth + bb 1 + table nth ; + +:: 2tetra@ ( p q r s t u v w quot -- ) + p q quot call + r s quot call + t u quot call + v w quot call + ; inline + +:: noise ( table point -- value ) + point unit-cube :> cube + point dup vfloor v- :> gradients + gradients fade :> faded + + table cube hashes { + [ gradients grad ] + [ gradients { -1.0 0.0 0.0 } v+ grad ] + [ gradients { 0.0 -1.0 0.0 } v+ grad ] + [ gradients { -1.0 -1.0 0.0 } v+ grad ] + [ gradients { 0.0 0.0 -1.0 } v+ grad ] + [ gradients { -1.0 0.0 -1.0 } v+ grad ] + [ gradients { 0.0 -1.0 -1.0 } v+ grad ] + [ gradients { -1.0 -1.0 -1.0 } v+ grad ] + } spread + [ faded first lerp ] 2tetra@ + [ faded second lerp ] 2bi@ + faded third lerp ; + +: noise-map ( table scale dim -- map ) + [ iota ] map [ v* 0.0 suffix noise ] with with product-map ; + +: normalize ( sequence -- sequence' ) + [ supremum ] [ infimum [ - ] keep ] [ ] tri + [ swap - ] with map [ swap / ] with map ; + +: noise-image ( table scale dim -- image ) + [ noise-map normalize [ 255.0 * >fixnum ] B{ } map-as ] + [ swap [ L f ] dip image boa ] bi ; +