extra/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.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays.float strings system ;
   4 IN: jamshred.player
   5
   6 TUPLE: player < oint
   7     { name string }
   8     { sounds sounds }
   9     tunnel
  10     nearest-segment
  11     { last-move integer }
  12     { speed float } ;
  13
  14 ! speeds are in GL units / second
  15 CONSTANT: default-speed 1.0
  16 CONSTANT: max-speed 30.0
  17
  18 : <player> ( name sounds -- player )
  19     [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
  20     f f 0 default-speed player boa ;
  21
  22 : turn-player ( player x-radians y-radians -- )
  23     [ over ] dip left-pivot up-pivot ;
  24
  25 : roll-player ( player z-radians -- )
  26     forward-pivot ;
  27
  28 : to-tunnel-start ( player -- )
  29     [ tunnel>> first dup location>> ]
  30     [ tuck (>>location) (>>nearest-segment) ] bi ;
  31
  32 : play-in-tunnel ( player segments -- )
  33     >>tunnel to-tunnel-start ;
  34
  35 : update-nearest-segment ( player -- )
  36     [ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
  37     [ (>>nearest-segment) ] tri ;
  38
  39 : update-time ( player -- seconds-passed )
  40     millis swap [ last-move>> - 1000 / ] [ (>>last-move) ] 2bi ;
  41
  42 : moved ( player -- ) millis swap (>>last-move) ;
  43
  44 : speed-range ( -- range )
  45     max-speed [0,b] ;
  46
  47 : change-player-speed ( inc player -- )
  48     [ + 0 max-speed clamp ] change-speed drop ;
  49
  50 : multiply-player-speed ( n player -- )
  51     [ * 0 max-speed clamp ] change-speed drop ;
  52
  53 : distance-to-move ( seconds-passed player -- distance )
  54     speed>> * ;
  55
  56 : bounce ( d-left player -- d-left' player )
  57     {
  58         [ dup nearest-segment>> bounce-off-wall ]
  59         [ sounds>> bang ]
  60         [ 3/4 swap multiply-player-speed ]
  61         [ ]
  62     } cleave ;
  63
  64 :: (distance) ( heading player -- current next location heading )
  65     player nearest-segment>>
  66     player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
  67     player location>> heading ;
  68
  69 : distance-to-heading-segment ( heading player -- distance )
  70     (distance) distance-to-next-segment ;
  71
  72 : distance-to-heading-segment-area ( heading player -- distance )
  73     (distance) distance-to-next-segment-area ;
  74
  75 : distance-to-collision ( player -- distance )
  76     dup nearest-segment>> (distance-to-collision) ;
  77
  78 : almost-to-collision ( player -- distance )
  79     distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
  80
  81 : from ( player -- radius distance-from-centre )
  82     [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
  83     distance-from-centre ;
  84
  85 : distance-from-wall ( player -- distance ) from - ;
  86 : fraction-from-centre ( player -- fraction ) from swap / ;
  87 : fraction-from-wall ( player -- fraction )
  88     fraction-from-centre 1 swap - ;
  89
  90 : update-nearest-segment2 ( heading player -- )
  91     2dup distance-to-heading-segment-area 0 <= [
  92         [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
  93         [ (>>nearest-segment) ] tri
  94     ] [
  95         2drop
  96     ] if ;
  97
  98 :: move-player-on-heading ( d-left player distance heading -- d-left' player )
  99     [let* | d-to-move [ d-left distance min ]
 100             move-v [ d-to-move heading n*v ] |
 101         move-v player location+
 102         heading player update-nearest-segment2
 103         d-left d-to-move - player ] ;
 104
 105 : distance-to-move-freely ( player -- distance )
 106     [ almost-to-collision ]
 107     [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
 108
 109 : ?move-player-freely ( d-left player -- d-left' player )
 110     over 0 > [
 111         ! must make sure we are moving a significant distance, otherwise
 112         ! we can recurse endlessly due to floating-point imprecision.
 113         ! (at least I /think/ that's what causes it...)
 114         dup distance-to-move-freely dup 0.1 > [
 115             over forward>> move-player-on-heading ?move-player-freely
 116         ] [ drop ] if
 117     ] when ;
 118
 119 : drag-heading ( player -- heading )
 120     [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
 121
 122 : drag-player ( d-left player -- d-left' player )
 123     dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
 124     [ drag-heading move-player-on-heading ] bi ;
 125
 126 : (move-player) ( d-left player -- d-left' player )
 127     ?move-player-freely over 0 > [
 128         ! bounce
 129         drag-player
 130         (move-player)
 131     ] when ;
 132
 133 : move-player ( player -- )
 134     [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
 135
 136 : update-player ( player -- )
 137     [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;