! 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 ;
+TUPLE: jamshred tunnel players running quit ;
: <jamshred> ( -- jamshred )
- <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
+ <random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f f
jamshred boa ;
: 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 ;
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
: mouse-moved ( x-radians y-radians jamshred -- )
jamshred-player -rot turn-player ;
+
! 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 threads ui ui.gadgets ui.gestures ui.render math.vectors ;
IN: jamshred
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
: <jamshred-gadget> ( 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 ;
+: default-width ( -- x ) 640 ;
+: default-height ( -- y ) 480 ;
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-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ dup [ jamshred>> jamshred-update ]
+ [ relayout-1 ] bi
+ 50 sleep jamshred-loop
+ ] if ;
M: jamshred-gadget graft* ( gadget -- )
- [
- [ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
- ] keep set-jamshred-gadget-alarm ;
-
+ [ jamshred-loop ] in-thread drop ;
M: jamshred-gadget ungraft* ( gadget -- )
- [ jamshred-gadget-alarm cancel-alarm f ] keep
- set-jamshred-gadget-alarm ;
+ jamshred>> t >>quit drop ;
: jamshred-restart ( jamshred-gadget -- )
- <jamshred> swap set-jamshred-gadget-jamshred ;
+ <jamshred> >>jamshred drop ;
: pix>radians ( n m -- theta )
2 / / pi 2 * * ;
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
--- /dev/null
+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...
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
! 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
! segment's location and orientation are given by an oint.
TUPLE: oint location forward up left ;
-
-: <oint> ( 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 ;
+C: <oint> oint
: 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
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 ;
#! the scalar projection of v1 onto v2
tuck v. swap norm / ;
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
: 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 n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
! 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 system ;
IN: jamshred.player
-TUPLE: player name tunnel nearest-segment ;
+TUPLE: player < oint name tunnel nearest-segment last-move ;
: <player> ( name -- player )
- f f player boa
- F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
+ [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f 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 ;
+: moved ( player -- ) millis swap (>>last-move) ;
+: max-speed ( -- speed ) 1.0 ; ! units/second
: player-speed ( player -- speed )
- dup player-nearest-segment fraction-from-wall sq max-speed * ;
+ drop max-speed ;
+
+: distance-to-move ( player -- distance )
+ [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+ [ (>>last-move) ] tri ;
+
+DEFER: (move-player)
+
+: ?bounce ( distance-remaining player -- )
+ over 0 > [
+ [ dup nearest-segment>> bounce ] [ (move-player) ] bi
+ ] [
+ 2drop
+ ] if ;
+
+: move-player-distance ( distance-remaining player distance -- distance-remaining player )
+ pick min tuck over go-forward [ - ] dip ;
+
+: (move-player) ( distance-remaining player -- )
+ over 0 <= [
+ 2drop
+ ] [
+ dup dup nearest-segment>> distance-to-collision
+ move-player-distance ?bounce
+ ] if ;
: move-player ( player -- )
- dup player-speed over go-forward update-nearest-segment ;
+ [ distance-to-move ] [ (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 ;
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
IN: jamshred.tunnel.tests
-[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
- T{ segment T{ oint f { 1 1 1 } } 1 }
+[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
+ T{ segment f { 1 1 1 } f f f 1 }
T{ oint f { 0 0 0.25 } }
nearer-segment segment-number ] unit-test
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test
! 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 combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
IN: jamshred.tunnel
: n-segments ( -- n ) 5000 ; inline
-TUPLE: segment number color radius ;
-
-: <segment> ( number color radius location forward up left -- segment )
- <oint> >r segment boa r> over set-delegate ;
+TUPLE: segment < oint number color radius ;
+C: <segment> 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 ;
dup [ / pi 2 * * ] curry map ;
: segment-number++ ( segment -- )
- dup segment-number 1+ swap set-segment-number ;
+ [ number>> 1+ ] keep (>>number) ;
: random-color ( -- color )
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
: 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 } <segment> ;
+ F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
: 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 } <segment> ;
+ [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
: simple-segments ( n -- segments )
[ simple-segment ] map ;
[ nearest-segment-forward ] 3keep
nearest-segment-backward r> nearer-segment ;
-: distance-from-centre ( oint segment -- distance )
- perpendicular-distance ;
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
-: distance-from-wall ( oint segment -- distance )
- tuck distance-from-centre swap segment-radius swap - ;
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
-: fraction-from-centre ( oint segment -- fraction )
- tuck distance-from-centre swap segment-radius / ;
+: from ( seg loc -- radius d-f-c )
+ dupd location>> distance-from-centre [ radius>> ] dip ;
-: fraction-from-wall ( oint segment -- fraction )
+: distance-from-wall ( seg loc -- distance ) from - ;
+: fraction-from-centre ( seg loc -- fraction ) from / ;
+: fraction-from-wall ( seg loc -- fraction )
fraction-from-centre 1 swap - ;
+
+: distant 10 ; inline
+
+:: (collision-coefficient) ( -b sqrt(b^2-4ac) 2a -- c )
+ sqrt(b^2-4ac) complex? [
+ distant
+ ] [
+ -b sqrt(b^2-4ac) + 2a /
+ -b sqrt(b^2-4ac) - 2a / max ! the -ve answer is behind us
+ ] if ;
+
+:: collision-coefficient ( v w -- c )
+ [let* | a [ v dup v. ]
+ b [ v w v. 2 * ]
+ c [ w dup v. v dup v. - ] |
+ c b a quadratic [ real-part ] bi@ max ] ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: collision-vector ( oint segment -- v )
+ dupd [ sideways-heading ] [ sideways-relative-location ] 2bi
+ collision-coefficient swap forward>> n*v ;
+
+USING: prettyprint jamshred.log io.streams.string ;
+: distance-to-collision ( oint segment -- distance )
+ collision-vector norm [ dup . ] with-string-writer jamshred-log ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
projects / factor.git / commitdiff