diff --git a/extra/jamshred/game/game.factor b/extra/jamshred/game/game.factor index 3842816f0e..2a5fefcaed 100644 --- a/extra/jamshred/game/game.factor +++ b/extra/jamshred/game/game.factor @@ -1,7 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel opengl arrays sequences jamshred.tunnel -jamshred.player math.vectors ; +USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.tunnel math.vectors ; IN: jamshred.game TUPLE: jamshred tunnel players running ; @@ -12,15 +11,15 @@ TUPLE: jamshred tunnel players running ; : jamshred-player ( jamshred -- player ) ! TODO: support more than one player - jamshred-players first ; + players>> first ; : jamshred-update ( jamshred -- ) - dup jamshred-running [ + dup running>> [ jamshred-player update-player ] [ drop ] if ; : toggle-running ( jamshred -- ) - dup jamshred-running not swap set-jamshred-running ; + [ running>> not ] [ (>>running) ] bi ; : mouse-moved ( x-radians y-radians jamshred -- ) jamshred-player -rot turn-player ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index 42414b9893..3a7047929f 100755 --- a/extra/jamshred/jamshred.factor +++ b/extra/jamshred/jamshred.factor @@ -1,14 +1,12 @@ ! Copyright (C) 2007, 2008 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: alarms arrays calendar jamshred.game jamshred.gl kernel math -math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render -math.vectors ; +USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.log kernel math math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render math.vectors ; IN: jamshred TUPLE: jamshred-gadget jamshred last-hand-loc alarm ; : ( jamshred -- gadget ) - jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ; + jamshred-gadget construct-gadget swap >>jamshred ; : default-width ( -- x ) 1024 ; : default-height ( -- y ) 768 ; @@ -17,22 +15,21 @@ M: jamshred-gadget pref-dim* drop default-width default-height 2array ; M: jamshred-gadget draw-gadget* ( gadget -- ) - dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ; + [ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ; : tick ( gadget -- ) - dup jamshred-gadget-jamshred jamshred-update relayout-1 ; + [ jamshred>> jamshred-update ] [ relayout-1 ] bi ; M: jamshred-gadget graft* ( gadget -- ) [ [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm - ] keep set-jamshred-gadget-alarm ; + ] keep (>>alarm) ; M: jamshred-gadget ungraft* ( gadget -- ) - [ jamshred-gadget-alarm cancel-alarm f ] keep - set-jamshred-gadget-alarm ; + [ alarm>> cancel-alarm ] [ f >>alarm drop ] bi ; : jamshred-restart ( jamshred-gadget -- ) - swap set-jamshred-gadget-jamshred ; + >>jamshred drop ; : pix>radians ( n m -- theta ) 2 / / pi 2 * * ; @@ -46,21 +43,20 @@ M: jamshred-gadget ungraft* ( gadget -- ) rect-dim second pix>radians ; : (handle-mouse-motion) ( jamshred-gadget mouse-motion -- ) - over jamshred-gadget-jamshred >r + over jamshred>> >r [ first swap x>radians ] 2keep second swap y>radians r> mouse-moved ; : handle-mouse-motion ( jamshred-gadget -- ) hand-loc get [ - over jamshred-gadget-last-hand-loc [ + over last-hand-loc>> [ v- (handle-mouse-motion) ] [ 2drop ] if* - ] 2keep swap set-jamshred-gadget-last-hand-loc ; + ] 2keep >>last-hand-loc drop ; -USE: vocabs.loader jamshred-gadget H{ { T{ key-down f f "r" } [ jamshred-restart ] } - { T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] } + { T{ key-down f f " " } [ jamshred>> toggle-running ] } { T{ motion } [ handle-mouse-motion ] } } set-gestures diff --git a/extra/jamshred/log/log.factor b/extra/jamshred/log/log.factor new file mode 100644 index 0000000000..33498d8a2e --- /dev/null +++ b/extra/jamshred/log/log.factor @@ -0,0 +1,10 @@ +USING: kernel logging ; +IN: jamshred.log + +LOG: (jamshred-log) DEBUG + +: with-jamshred-log ( quot -- ) + "jamshred" swap with-logging ; + +: jamshred-log ( message -- ) + [ (jamshred-log) ] with-jamshred-log ; ! ugly... diff --git a/extra/jamshred/oint/oint.factor b/extra/jamshred/oint/oint.factor index 4680be4575..6b4f22bb9e 100644 --- a/extra/jamshred/oint/oint.factor +++ b/extra/jamshred/oint/oint.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; +USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ; IN: jamshred.oint ! An oint is a point with three linearly independent unit vectors @@ -10,46 +10,23 @@ IN: jamshred.oint TUPLE: oint location forward up left ; -: ( location forward up left -- oint ) - oint boa ; - -! : x-rotation ( theta -- matrix ) -! #! construct this matrix: -! #! { { 1 0 0 } -! #! { 0 cos(theta) sin(theta) } -! #! { 0 -sin(theta) cos(theta) } } -! dup sin neg swap cos 2dup 0 -rot 3float-array >r -! swap neg 0 -rot 3float-array >r -! { 1 0 0 } r> r> 3float-array ; -! -! : y-rotation ( theta -- matrix ) -! #! costruct this matrix: -! #! { { cos(theta) 0 -sin(theta) } -! #! { 0 1 0 } -! #! { sin(theta) 0 cos(theta) } } -! dup sin swap cos 2dup -! 0 swap 3float-array >r -! { 0 1 0 } >r -! 0 rot neg 3float-array r> r> 3float-array ; - -: apply-to-oint ( oint quot -- ) - #! apply quot to each of forward, up, and left, storing the results - over oint-forward over call pick set-oint-forward - over oint-up over call pick set-oint-up - over oint-left swap call swap set-oint-left ; - : rotation-quaternion ( theta axis -- quaternion ) swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ; +: rotate-vector ( q qrecip v -- v ) + v>q swap q* q* q>v ; + : rotate-oint ( oint theta axis -- ) - rotation-quaternion dup qrecip - [ rot v>q swap q* q* q>v ] curry curry apply-to-oint ; + rotation-quaternion dup qrecip pick + [ forward>> rotate-vector >>forward ] + [ up>> rotate-vector >>up ] + [ left>> rotate-vector >>left ] 3tri drop ; : left-pivot ( oint theta -- ) - over oint-left rotate-oint ; + over left>> rotate-oint ; : up-pivot ( oint theta -- ) - over oint-up rotate-oint ; + over up>> rotate-oint ; : random-float+- ( n -- m ) #! find a random float between -n/2 and n/2 @@ -59,10 +36,10 @@ TUPLE: oint location forward up left ; 2 / 2dup random-float+- left-pivot random-float+- up-pivot ; : go-forward ( distance oint -- ) - tuck oint-forward n*v over oint-location v+ swap set-oint-location ; + [ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ; : distance-vector ( oint oint -- vector ) - oint-location swap oint-location v- ; + [ location>> ] bi@ swap v- ; : distance ( oint oint -- distance ) distance-vector norm ; @@ -72,9 +49,16 @@ TUPLE: oint location forward up left ; tuck v. swap norm / ; : perpendicular-distance ( oint oint -- distance ) - tuck distance-vector swap 2dup oint-left scalar-projection abs - -rot oint-up scalar-projection abs + ; + tuck distance-vector swap 2dup left>> scalar-projection abs + -rot up>> scalar-projection abs + ; -:: reflect ( v l -- v' ) - #! reflect v on l - v l v. l l v. / 2 * l n*v v v- ; +: proj-perp ( v u -- w ) + dupd proj v- ; + +! :: reflect ( v l -- v' ) +! #! reflect v on l +! v l v. l l v. / 2 * l n*v v v- ; + +:: reflect ( vec n -- v' ) + #! bounce v on a surface with normal n + vec n v. n n*v -2 * vec v+ ; diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 3e143a845e..6feca27366 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -1,39 +1,64 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: colors jamshred.oint jamshred.tunnel kernel -math math.constants sequences ; +USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences ; IN: jamshred.player -TUPLE: player name tunnel nearest-segment ; +TUPLE: player < oint name tunnel nearest-segment ; : ( name -- player ) - f f player boa - F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } over set-delegate ; + [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f player boa ; : turn-player ( player x-radians y-radians -- ) >r over r> left-pivot up-pivot ; : to-tunnel-start ( player -- ) - dup player-tunnel first dup oint-location pick set-oint-location - swap set-player-nearest-segment ; + [ tunnel>> first dup location>> ] + [ tuck (>>location) (>>nearest-segment) ] bi ; : play-in-tunnel ( player segments -- ) - over set-player-tunnel to-tunnel-start ; + >>tunnel to-tunnel-start ; : update-nearest-segment ( player -- ) - dup player-tunnel over dup player-nearest-segment nearest-segment - swap set-player-nearest-segment ; + [ tunnel>> ] [ dup nearest-segment>> nearest-segment ] + [ (>>nearest-segment) ] tri ; : max-speed ( -- speed ) - 0.3 ; + 0.01 ; : player-speed ( player -- speed ) - max-speed ; - ! dup player-nearest-segment fraction-from-wall sq max-speed * ; + drop max-speed ; + ! dup nearest-segment>> fraction-from-wall sq max-speed * ; + +! : move-player ( player -- ) +! dup player-speed over go-forward update-nearest-segment ; +DEFER: (move-player) + +: ?bounce ( distance-remaining player -- ) + over 0 > [ + [ dup nearest-segment>> bounce ] + ! [ (move-player) ] ! uncomment when bounce works... + [ 2drop ] + bi + ] [ + 2drop + ] if ; + +: move-player-distance ( distance-remaining player distance -- distance-remaining player ) + pick min tuck over go-forward [ - ] dip ; + +USE: prettyprint +USE: io.streams.string +: (move-player) ( distance-remaining player -- ) + over 0 <= [ + 2drop + ] [ + dup dup nearest-segment>> distance-to-collision ! [ .s ] with-string-writer jamshred-log + move-player-distance ?bounce + ] if ; : move-player ( player -- ) - dup player-speed over go-forward update-nearest-segment ; + [ player-speed ] [ (move-player) ] [ update-nearest-segment ] tri ; : update-player ( player -- ) - dup move-player player-nearest-segment + dup move-player nearest-segment>> white swap set-segment-color ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index c3f6b37fb8..7c6740f139 100755 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -1,23 +1,20 @@ ! Copyright (C) 2007 Alex Chapman ! See http://factorcode.org/license.txt for BSD license. -USING: arrays float-arrays kernel jamshred.oint math math.functions -math.ranges math.vectors math.constants random sequences vectors ; +USING: accessors arrays float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors random sequences vectors ; IN: jamshred.tunnel : n-segments ( -- n ) 5000 ; inline -TUPLE: segment number color radius ; - -: ( number color radius location forward up left -- segment ) - >r segment boa r> over set-delegate ; +TUPLE: segment < oint number color radius ; +C: segment : segment-vertex ( theta segment -- vertex ) - tuck 2dup oint-up swap sin v*n - >r oint-left swap cos v*n r> v+ - swap oint-location v+ ; + tuck 2dup up>> swap sin v*n + >r left>> swap cos v*n r> v+ + swap location>> v+ ; : segment-vertex-normal ( vertex segment -- normal ) - oint-location swap v- normalize ; + location>> swap v- normalize ; : segment-vertex-and-normal ( segment theta -- vertex normal ) swap [ segment-vertex ] keep dupd segment-vertex-normal ; @@ -50,15 +47,15 @@ TUPLE: segment number color radius ; : default-segment-radius ( -- r ) 1 ; : initial-segment ( -- segment ) - 0 random-color default-segment-radius - F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; + F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } + 0 random-color default-segment-radius ; : random-segments ( n -- segments ) initial-segment 1vector swap (random-segments) ; : simple-segment ( n -- segment ) - random-color default-segment-radius pick F{ 0 0 -1 } n*v - F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ; + [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep + random-color default-segment-radius ; : simple-segments ( n -- segments ) [ simple-segment ] map ; @@ -111,3 +108,60 @@ TUPLE: segment number color radius ; : fraction-from-wall ( oint segment -- fraction ) fraction-from-centre 1 swap - ; + +: sideways-heading ( oint segment -- v ) + [ forward>> ] bi@ proj-perp ; + +! : facing-nearest-wall? ( oint segment -- ? ) +! [ [ location>> ] bi@ distance ] +! [ sideways-heading ] +! [ [ location>> ] bi@ [ v+ ] dip distance ] tri < ; + +! : distance-to-collision ( oint segment -- distance ) +! ! TODO: this isn't right. If oint is facing away from the wall then it should return a much bigger distance... +! #! distance on the oint's heading to the segment wall +! facing-nearest-wall? [ +! [ sideways-heading norm ] +! [ distance-from-wall ] 2bi swap / +! ] [ +! ] if ; + +:: (collision-coefficient) ( -2b sqrt(b^2-2ac) 2a -- c ) + -2b sqrt(b^2-2ac) + 2a / + -2b sqrt(b^2-2ac) - 2a / max ; ! the -ve answer is behind us (I think..) + +:: collision-coefficient ( v w -- c ) + [let* | a [ v dup v. ] + b [ v w v. 2 * ] + c [ w dup v. v dup v. - ] | + b -2 * b sq a c * 2 * - sqrt a 2 * (collision-coefficient) ] ; + +: distance-to-collision ( oint segment -- distance ) + [ sideways-heading ] [ [ location>> ] bi@ v- collision-coefficient ] + [ drop forward>> n*v norm ] 2tri ; + +:: (wall-normal) ( seg loc -- n ) + [let* | back [ loc seg location>> v- ] + back-proj [ back seg forward>> proj ] + perp-point [ loc back-proj v- ] | + perp-point seg location>> v- normalize ] ; + +: wall-normal ( segment oint -- n ) + location>> (wall-normal) ; + +: bounce-forward ( segment oint -- ) + [ wall-normal ] [ swap reflect ] [ (>>forward) ] tri ; + +: bounce-up ( oint segment -- ) + 2drop ; ! TODO + +: bounce-left ( oint segment -- ) + 2drop ; ! TODO + +! : bounce ( oint segment -- ) +! [ swap bounce-forward ] +! [ bounce-up ] +! [ bounce-left ] 2tri ; + +: bounce ( oint segment -- ) + drop 0.01 left-pivot ; ! just temporary