! Copyright (C) 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-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 ;
+USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player 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 swap >>jamshred ;
-: default-width ( -- x ) 640 ;
-: default-height ( -- y ) 480 ;
+: default-width ( -- x ) 800 ;
+: default-height ( -- y ) 600 ;
M: jamshred-gadget pref-dim*
drop default-width default-height 2array ;
] [
dup [ jamshred>> jamshred-update ]
[ relayout-1 ] bi
- 50 sleep jamshred-loop
+ 10 sleep jamshred-loop
] if ;
M: jamshred-gadget graft* ( gadget -- )
] [ 2drop ] if*
] 2keep >>last-hand-loc drop ;
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> jamshred-player scroll-direction get
+ second neg swap change-player-speed ;
+
jamshred-gadget H{
{ T{ key-down f f "r" } [ jamshred-restart ] }
{ T{ key-down f f " " } [ jamshred>> toggle-running ] }
{ T{ motion } [ handle-mouse-motion ] }
+ { T{ mouse-scroll } [ handle-mouse-scroll ] }
} set-gestures
: jamshred-window ( -- )
! Copyright (C) 2007 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order sequences system ;
+USING: accessors colors jamshred.log jamshred.oint jamshred.tunnel kernel math math.constants math.order math.ranges sequences system ;
IN: jamshred.player
-TUPLE: player < oint name tunnel nearest-segment last-move ;
+TUPLE: player < oint name tunnel nearest-segment last-move speed ;
+
+! speeds are in GL units / second
+: default-speed ( -- speed ) 1.0 ;
+: max-speed ( -- speed ) 10.0 ;
: <player> ( name -- player )
- [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip f f f player boa ;
+ [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] dip
+ f f f default-speed player boa ;
: turn-player ( player x-radians y-radians -- )
>r over r> left-pivot up-pivot ;
[ (>>nearest-segment) ] tri ;
: moved ( player -- ) millis swap (>>last-move) ;
-: max-speed ( -- speed ) 1.0 ; ! units/second
-: player-speed ( player -- speed )
- drop max-speed ;
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + speed-range clamp-to-range ] change-speed drop ;
: distance-to-move ( player -- distance )
- [ player-speed ] [ last-move>> millis dup >r swap - 1000 / * r> ]
+ [ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
[ (>>last-move) ] tri ;
DEFER: (move-player)
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
: bounce-left ( segment oint -- )
- [ forward>> vneg ] dip [ left>> swap reflect ] [ (>>left) ] bi ;
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
: bounce-up ( segment oint -- )
#! must be done after forward and left!