extra/jamshred/tunnel/tunnel.factor

   1 ! Copyright (C) 2007, 2008 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types colors combinators jamshred.oint
   4 kernel literals math math.constants math.order math.quadratic
   5 math.vectors random sequences specialized-arrays
   6 specialized-arrays.instances.alien.c-types.float vectors ;
   7 FROM: jamshred.oint => distance ;
   8 FROM: alien.c-types => float ;
   9 SPECIALIZED-ARRAY: float
  10 IN: jamshred.tunnel
  11
  12 CONSTANT: n-segments 5000
  13
  14 TUPLE: segment < oint number color radius ;
  15 C: <segment> segment
  16
  17 : segment-number++ ( segment -- )
  18     [ number>> 1 + ] keep number<< ;
  19
  20 : clamp-length ( n seq -- n' )
  21     0 swap length clamp ;
  22
  23 : random-color ( -- color )
  24     { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
  25
  26 CONSTANT: tunnel-segment-distance 0.4
  27 CONSTANT: random-rotation-angle $[ pi 20 / ]
  28
  29 : random-segment ( previous-segment -- segment )
  30     clone dup random-rotation-angle random-turn
  31     tunnel-segment-distance over go-forward
  32     random-color >>color dup segment-number++ ;
  33
  34 : (random-segments) ( segments n -- segments )
  35     [ dup last random-segment suffix! ] times ;
  36
  37 CONSTANT: default-segment-radius 1
  38
  39 : initial-segment ( -- segment )
  40     float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
  41     0 random-color default-segment-radius <segment> ;
  42
  43 : random-segments ( n -- segments )
  44     initial-segment 1vector swap (random-segments) ;
  45
  46 : simple-segment ( n -- segment )
  47     [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
  48     random-color default-segment-radius <segment> ;
  49
  50 : simple-segments ( n -- segments )
  51     [ simple-segment ] map ;
  52
  53 : <random-tunnel> ( -- segments )
  54     n-segments random-segments ;
  55
  56 : <straight-tunnel> ( -- segments )
  57     n-segments simple-segments ;
  58
  59 : sub-tunnel ( from to segments -- segments )
  60     ! return segments between from and to, after clamping from and to to
  61     ! valid values
  62     [ '[ _ clamp-length ] bi@ ] keep <slice> ;
  63
  64 : get-segment ( segments n -- segment )
  65     over clamp-length swap nth ;
  66
  67 : next-segment ( segments current-segment -- segment )
  68     number>> 1 + get-segment ;
  69
  70 : previous-segment ( segments current-segment -- segment )
  71     number>> 1 - get-segment ;
  72
  73 : heading-segment ( segments current-segment heading -- segment )
  74     ! the next segment on the given heading
  75     over forward>> vdot 0 <=> {
  76         { +gt+ [ next-segment ] }
  77         { +lt+ [ previous-segment ] }
  78         { +eq+ [ nip ] } ! current segment
  79     } case ;
  80
  81 :: distance-to-next-segment ( current next location heading -- distance )
  82     current forward>> :> cf
  83     cf next location>> vdot cf location vdot - cf heading vdot / ;
  84
  85 :: distance-to-next-segment-area ( current next location heading -- distance )
  86     current forward>> :> cf
  87     next current half-way-between-oints :> h
  88     cf h vdot cf location vdot - cf heading vdot / ;
  89
  90 : vector-to-centre ( seg loc -- v )
  91     over location>> swap v- swap forward>> proj-perp ;
  92
  93 : distance-from-centre ( seg loc -- distance )
  94     vector-to-centre norm ;
  95
  96 : wall-normal ( seg oint -- n )
  97     location>> vector-to-centre normalize ;
  98
  99 CONSTANT: distant 1000
 100
 101 : max-real ( a b -- c )
 102     ! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
 103     dup real? [
 104         over real? [ max ] [ nip ] if
 105     ] [
 106         drop dup real? [ drop distant ] unless
 107     ] if ;
 108
 109 :: collision-coefficient ( v w r -- c )
 110     v norm 0 = [
 111         distant
 112     ] [
 113         v dup vdot :> a
 114         v w vdot 2 * :> b
 115         w dup vdot r sq - :> c
 116         c b a quadratic max-real
 117     ] if ;
 118
 119 : sideways-heading ( oint segment -- v )
 120     [ forward>> ] bi@ proj-perp ;
 121
 122 : sideways-relative-location ( oint segment -- loc )
 123     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 124
 125 : (distance-to-collision) ( oint segment -- distance )
 126     [ sideways-heading ] [ sideways-relative-location ]
 127     [ nip radius>> ] 2tri collision-coefficient ;
 128
 129 : collision-vector ( oint segment -- v )
 130     dupd (distance-to-collision) swap forward>> n*v ;
 131
 132 : bounce-forward ( segment oint -- )
 133     [ wall-normal ] [ forward>> swap reflect ] [ forward<< ] tri ;
 134
 135 : bounce-left ( segment oint -- )
 136     ! must be done after forward
 137     [ forward>> vneg ] dip [ left>> swap reflect ]
 138     [ forward>> proj-perp normalize ] [ left<< ] tri ;
 139
 140 : bounce-up ( segment oint -- )
 141     ! must be done after forward and left!
 142     nip [ forward>> ] [ left>> cross ] [ up<< ] tri ;
 143
 144 : bounce-off-wall ( oint segment -- )
 145     swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;