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 arrays colors combinators fry jamshred.oint
   4 kernel literals locals math math.constants math.matrices
   5 math.order math.quadratic math.ranges math.vectors random
   6 sequences specialized-arrays 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 0 > [
  36         [ dup last random-segment over push ] dip 1 - (random-segments)
  37     ] [ drop ] if ;
  38
  39 CONSTANT: default-segment-radius 1
  40
  41 : initial-segment ( -- segment )
  42     float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
  43     0 random-color default-segment-radius <segment> ;
  44
  45 : random-segments ( n -- segments )
  46     initial-segment 1vector swap (random-segments) ;
  47
  48 : simple-segment ( n -- segment )
  49     [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
  50     random-color default-segment-radius <segment> ;
  51
  52 : simple-segments ( n -- segments )
  53     [ simple-segment ] map ;
  54
  55 : <random-tunnel> ( -- segments )
  56     n-segments random-segments ;
  57
  58 : <straight-tunnel> ( -- segments )
  59     n-segments simple-segments ;
  60
  61 : sub-tunnel ( from to segments -- segments )
  62     #! return segments between from and to, after clamping from and to to
  63     #! valid values
  64     [ '[ _ clamp-length ] bi@ ] keep <slice> ;
  65
  66 :: nearer-segment ( seg-a seg-b oint -- segment )
  67     seg-a oint distance
  68     seg-b oint distance <
  69     seg-a seg-b ? ;
  70
  71 : (find-nearest-segment) ( nearest next oint -- nearest ? )
  72     #! find the nearest of 'next' and 'nearest' to 'oint', and return
  73     #! t if the nearest hasn't changed
  74     pick [ nearer-segment dup ] dip = ;
  75
  76 : find-nearest-segment ( oint segments -- segment )
  77     dup first swap rest-slice rot [ (find-nearest-segment) ] curry
  78     find 2drop ;
  79
  80 : nearest-segment-forward ( segments oint start -- segment )
  81     rot tail-slice find-nearest-segment ;
  82
  83 : nearest-segment-backward ( segments oint start -- segment )
  84     1 + rot head-slice <reversed> find-nearest-segment ;
  85
  86 : nearest-segment ( segments oint start-segment -- segment )
  87     #! find the segment nearest to 'oint', and return it.
  88     #! start looking at segment 'start-segment'
  89     number>> over [
  90         [ nearest-segment-forward ] 3keep nearest-segment-backward
  91     ] dip nearer-segment ;
  92
  93 : get-segment ( segments n -- segment )
  94     over clamp-length swap nth ;
  95
  96 : next-segment ( segments current-segment -- segment )
  97     number>> 1 + get-segment ;
  98
  99 : previous-segment ( segments current-segment -- segment )
 100     number>> 1 - get-segment ;
 101
 102 : heading-segment ( segments current-segment heading -- segment )
 103     #! the next segment on the given heading
 104     over forward>> v. 0 <=> {
 105         { +gt+ [ next-segment ] }
 106         { +lt+ [ previous-segment ] }
 107         { +eq+ [ nip ] } ! current segment
 108     } case ;
 109
 110 :: distance-to-next-segment ( current next location heading -- distance )
 111     current forward>> :> cf
 112     cf next location>> v. cf location v. - cf heading v. / ;
 113
 114 :: distance-to-next-segment-area ( current next location heading -- distance )
 115     current forward>> :> cf
 116     next current half-way-between-oints :> h
 117     cf h v. cf location v. - cf heading v. / ;
 118
 119 : vector-to-centre ( seg loc -- v )
 120     over location>> swap v- swap forward>> proj-perp ;
 121
 122 : distance-from-centre ( seg loc -- distance )
 123     vector-to-centre norm ;
 124
 125 : wall-normal ( seg oint -- n )
 126     location>> vector-to-centre normalize ;
 127
 128 CONSTANT: distant 1000
 129
 130 : max-real ( a b -- c )
 131     #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
 132     dup real? [
 133         over real? [ max ] [ nip ] if
 134     ] [
 135         drop dup real? [ drop distant ] unless
 136     ] if ;
 137
 138 :: collision-coefficient ( v w r -- c )
 139     v norm 0 = [
 140         distant
 141     ] [
 142         v dup v. :> a
 143         v w v. 2 * :> b
 144         w dup v. r sq - :> c
 145         c b a quadratic max-real
 146     ] if ;
 147
 148 : sideways-heading ( oint segment -- v )
 149     [ forward>> ] bi@ proj-perp ;
 150
 151 : sideways-relative-location ( oint segment -- loc )
 152     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 153
 154 : (distance-to-collision) ( oint segment -- distance )
 155     [ sideways-heading ] [ sideways-relative-location ]
 156     [ nip radius>> ] 2tri collision-coefficient ;
 157
 158 : collision-vector ( oint segment -- v )
 159     dupd (distance-to-collision) swap forward>> n*v ;
 160
 161 : bounce-forward ( segment oint -- )
 162     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 163
 164 : bounce-left ( segment oint -- )
 165     #! must be done after forward
 166     [ forward>> vneg ] dip [ left>> swap reflect ]
 167     [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
 168
 169 : bounce-up ( segment oint -- )
 170     #! must be done after forward and left!
 171     nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
 172
 173 : bounce-off-wall ( oint segment -- )
 174     swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
 175