unmaintained/jamshred/player/player.factor

   1 ! Copyright (C) 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors colors combinators jamshred.log jamshred.oint
   4 jamshred.sound jamshred.tunnel kernel locals math math.constants
   5 math.order math.ranges math.vectors math.matrices shuffle
   6 sequences system float-arrays ;
   7 IN: jamshred.player
   8
   9 TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
  10
  11 ! speeds are in GL units / second
  12 : default-speed ( -- speed ) 1.0 ;
  13 : max-speed ( -- speed ) 30.0 ;
  14
  15 : <player> ( name sounds -- player )
  16     [ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
  17     f f f default-speed player boa ;
  18
  19 : turn-player ( player x-radians y-radians -- )
  20     >r over r> left-pivot up-pivot ;
  21
  22 : roll-player ( player z-radians -- )
  23     forward-pivot ;
  24
  25 : to-tunnel-start ( player -- )
  26     [ tunnel>> first dup location>> ]
  27     [ tuck (>>location) (>>nearest-segment) ] bi ;
  28
  29 : play-in-tunnel ( player segments -- )
  30     >>tunnel to-tunnel-start ;
  31
  32 : update-nearest-segment ( player -- )
  33     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
  34     [ (>>nearest-segment) ] tri ;
  35
  36 : update-time ( player -- seconds-passed )
  37     millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
  38
  39 : moved ( player -- ) millis swap (>>last-move) ;
  40
  41 : speed-range ( -- range )
  42     max-speed [0,b] ;
  43
  44 : change-player-speed ( inc player -- )
  45     [ + speed-range clamp-to-range ] change-speed drop ;
  46
  47 : multiply-player-speed ( n player -- )
  48     [ * speed-range clamp-to-range ] change-speed drop ;
  49
  50 : distance-to-move ( seconds-passed player -- distance )
  51     speed>> * ;
  52
  53 : bounce ( d-left player -- d-left' player )
  54     {
  55         [ dup nearest-segment>> bounce-off-wall ]
  56         [ sounds>> bang ]
  57         [ 3/4 swap multiply-player-speed ]
  58         [ ]
  59     } cleave ;
  60
  61 :: (distance) ( heading player -- current next location heading )
  62     player nearest-segment>>
  63     player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
  64     player location>> heading ;
  65
  66 : distance-to-heading-segment ( heading player -- distance )
  67     (distance) distance-to-next-segment ;
  68
  69 : distance-to-heading-segment-area ( heading player -- distance )
  70     (distance) distance-to-next-segment-area ;
  71
  72 : distance-to-collision ( player -- distance )
  73     dup nearest-segment>> (distance-to-collision) ;
  74
  75 : from ( player -- radius distance-from-centre )
  76     [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
  77     distance-from-centre ;
  78
  79 : distance-from-wall ( player -- distance ) from - ;
  80 : fraction-from-centre ( player -- fraction ) from swap / ;
  81 : fraction-from-wall ( player -- fraction )
  82     fraction-from-centre 1 swap - ;
  83
  84 : update-nearest-segment2 ( heading player -- )
  85     2dup distance-to-heading-segment-area 0 <= [
  86         [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
  87         [ (>>nearest-segment) ] tri
  88     ] [
  89         2drop
  90     ] if ;
  91
  92 :: move-player-on-heading ( d-left player distance heading -- d-left' player )
  93     [let* | d-to-move [ d-left distance min ]
  94             move-v [ d-to-move heading n*v ] |
  95         move-v player location+
  96         heading player update-nearest-segment2
  97         d-left d-to-move - player ] ;
  98
  99 : move-toward-wall ( d-left player d-to-wall -- d-left' player )
 100     over [ forward>> ] keep distance-to-heading-segment-area min
 101     over forward>> move-player-on-heading ;
 102
 103 : ?move-player-freely ( d-left player -- d-left' player )
 104     over 0 > [
 105         dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
 106             move-toward-wall ?move-player-freely
 107         ] [ drop ] if
 108     ] when ;
 109
 110 : drag-heading ( player -- heading )
 111     [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
 112
 113 : drag-player ( d-left player -- d-left' player )
 114     dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
 115     [ drag-heading move-player-on-heading ] bi ;
 116
 117 : (move-player) ( d-left player -- d-left' player )
 118     ?move-player-freely over 0 > [
 119         ! bounce
 120         drag-player
 121         (move-player)
 122     ] when ;
 123
 124 : move-player ( player -- )
 125     [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
 126
 127 : update-player ( player -- )
 128     [ move-player ] [ nearest-segment>> white swap (>>color) ] bi ;