Merge branch 'master' of git://factorcode.org/git/factor

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 )
+: find-tag* ( ifd class -- tag/class ? )
-    swap processed-tags>> ?at [ no-tag ] unless ;
+    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 ] }
+        { 271 [ ascii decode tiff-make ] }
-        { 272 [ ascii decode model ] }
+        { 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
+        _ group
-        [ v+ ] accumulate swap suffix concat ] map
+        [ _ 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 )
+: process-chunky-ifd ( ifd -- )
-    dup ifds>> [
     read-strips
     uncompress-strips
     strips>bitmap
     fix-bitmap-endianness
     strips-predictor
     dup extra-samples tag? [ handle-alpha-data ] when
-        drop
+    drop ;
-    ] each ;
+
+: 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 ] [
+    [ load-tiff-ifds dup ] keep
     binary [
         [ process-tif-ifds ] with-tiff-endianness
-        ] with-file-reader
+    ] with-file-reader ;
-    ] bi ;
 
 ! tiff files can store several images -- we just take the first for now
 M: tiff-image load-image* ( path tiff-image -- image )

basis/math/bits/bits.factor

@@ -7,7 +7,7 @@ TUPLE: bits { number read-only } { length read-only } ;
 C: <bits> bits
 
 : make-bits ( number -- bits )
-    dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
+    dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1 + <bits> ] if ; inline
 
 M: bits length length>> ;
 

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 [
+256 iota [
-    8 <bits> 0 [ [ 1+ ] when ] reduce
+    8 <bits> 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 )
     <reversed> signed-le> ;
 
 : >signed ( x n -- y )
-    2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+    2dup neg 1 + shift 1 = [ 2^ - ] [ drop ] if ;
 

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 <VECTOR> ;

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
+

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
 
 <PRIVATE
@@ -216,17 +216,17 @@ M: real tanh ftanh ;
 : coth ( x -- y ) tanh recip ; inline
 
 : acosh ( x -- y )
-    dup sq 1- sqrt + log ; inline
+    dup sq 1 - sqrt + log ; inline
 
 : asech ( x -- y ) recip acosh ; inline
 
 : asinh ( x -- y )
-    dup sq 1+ sqrt + log ; inline
+    dup sq 1 + sqrt + log ; inline
 
 : acosech ( x -- y ) recip asinh ; inline
 
 : atanh ( x -- y )
-    [ 1+ ] [ 1- neg ] bi / log 2 / ; inline
+    [ 1 + ] [ 1 - neg ] bi / log 2 / ; inline
 
 : acoth ( x -- y ) recip atanh ; inline
 
@@ -259,6 +259,9 @@ M: real atan fatan ;
 
 : floor ( x -- y )
     dup 1 mod dup zero?
-    [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
+    [ drop ] [ dup 0 < [ - 1 - ] [ - ] if ] if ; foldable
 
 : ceiling ( x -- y ) neg floor neg ; foldable
+
+: lerp ( a b t -- a_t ) [ over - ] dip * + ; inline
+

basis/math/intervals/intervals.factor

@@ -380,7 +380,7 @@ SYMBOL: incomparable
         [
             to>> 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 ]
+        [ from>> first2 [ 1 + ] unless ]
-        [ to>> first2 [ 1- ] unless ]
+        [ to>> first2 [ 1 - ] unless ]
         bi [a,b]
     ] unless ;

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
@@ -9,3 +9,11 @@ IN: math.miller-rabin.tests
 [ 101 ] [ 100 next-prime ] unit-test
 [ t ] [ 2135623355842621559 miller-rabin ] unit-test
 [ 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

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
 
 <PRIVATE
 
-: >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 ]
+    n 1 - :> n-1
-           s [ n 1- factor-2s nip ]
+    n-1 factor-2s :> s :> r
-           prime?! [ t ]
+    0 :> a!
-           a! [ 0 ]
+    t :> prime?!
-           count! [ 0 ] |
     trials [
-            n 1- [1,b] random a!
+        n 1 - [1,b] random a!
         a s n ^mod 1 = [
-                0 count!
+            r iota [
-                r [
                 2^ s * a swap n ^mod n - -1 =
-                    [ count 1+ count! r + ] when
+            ] any? not [ f prime?! trials + ] when
-                ] each
-                count zero? [ f prime?! trials + ] when
         ] unless drop
-        ] each prime? ] ;
+    ] 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
+
+<PRIVATE
+
+: >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 ;

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 <reversed> 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

basis/math/ranges/ranges.factor

@@ -10,7 +10,7 @@ TUPLE: range
 { step read-only } ;
 
 : <range> ( 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>> ;

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@ ;

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 

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 } ;

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

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 ;
 
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+    "DIPROPDWORD" <c-object>
+        "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 <buffer-size-diprop>
+    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 <byte-array> <keys-array> 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 <array> mouse-state boa
+    +mouse-state+ set-global
+    MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+    +mouse-buffer+ set-global ;
+
 : device-info ( device -- DIDEVICEIMAGEINFOW )
     "DIDEVICEINSTANCEW" <c-object>
     "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 <uint>
+    [ 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 ;

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"

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 ] }

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 <array> ]
     } 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 controller-device? ] [
                 device <device-controller-state>
                 device +controller-states+ get set-at
-        ] when
+            ] }
+            { [ 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 ]
+            { [ sender controller-device? ] [
+                sender +controller-states+ get at value record-controller
+            ] }
+            { [ sender mouse-device? ] [ value record-mouse ] }
             [ value record-keyboard ]
-        if
+        } cond
     ] IOHIDValueCallback ;
 
 : initialize-variables ( manager -- )
     +hid-manager+ set-global
     4 <vector> +controller-states+ set-global
+    0 0 0 0 2 <vector> mouse-state boa
+        +mouse-state+ set-global
     256 f <array> +keyboard-state+ set-global ;
 
 M: iokit-game-input-backend (open-game-input)

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
+
+: <noise-table> ( -- 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 ;
+