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