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