extra/jamshred/tunnel/tunnel.factor

   1 ! Copyright (C) 2007 Alex Chapman
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.functions math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
   4 IN: jamshred.tunnel
   5
   6 : n-segments ( -- n ) 5000 ; inline
   7
   8 TUPLE: segment < oint number color radius ;
   9 C: <segment> segment
  10
  11 : segment-vertex ( theta segment -- vertex )
  12      tuck 2dup up>> swap sin v*n
  13      >r left>> swap cos v*n r> v+
  14      swap location>> v+ ;
  15
  16 : segment-vertex-normal ( vertex segment -- normal )
  17     location>> swap v- normalize ;
  18
  19 : segment-vertex-and-normal ( segment theta -- vertex normal )
  20     swap [ segment-vertex ] keep dupd segment-vertex-normal ;
  21
  22 : equally-spaced-radians ( n -- seq )
  23     #! return a sequence of n numbers between 0 and 2pi
  24     dup [ / pi 2 * * ] curry map ;
  25
  26 : segment-number++ ( segment -- )
  27     [ number>> 1+ ] keep (>>number) ;
  28
  29 : random-color ( -- color )
  30     { 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
  31
  32 : tunnel-segment-distance ( -- n ) 0.4 ;
  33 : random-rotation-angle ( -- theta ) pi 20 / ;
  34
  35 : random-segment ( previous-segment -- segment )
  36     clone dup random-rotation-angle random-turn
  37     tunnel-segment-distance over go-forward
  38     random-color over set-segment-color dup segment-number++ ;
  39
  40 : (random-segments) ( segments n -- segments )
  41     dup 0 > [
  42         >r dup peek random-segment over push r> 1- (random-segments)
  43     ] [
  44         drop
  45     ] if ;
  46
  47 : default-segment-radius ( -- r ) 1 ;
  48
  49 : initial-segment ( -- segment )
  50     F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
  51     0 random-color default-segment-radius <segment> ;
  52
  53 : random-segments ( n -- segments )
  54     initial-segment 1vector swap (random-segments) ;
  55
  56 : simple-segment ( n -- segment )
  57     [ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
  58     random-color default-segment-radius <segment> ;
  59
  60 : simple-segments ( n -- segments )
  61     [ simple-segment ] map ;
  62
  63 : <random-tunnel> ( -- segments )
  64     n-segments random-segments ;
  65
  66 : <straight-tunnel> ( -- segments )
  67     n-segments simple-segments ;
  68
  69 : sub-tunnel ( from to sements -- segments )
  70     #! return segments between from and to, after clamping from and to to
  71     #! valid values
  72     [ sequence-index-range [ clamp-to-range ] curry bi@ ] keep <slice> ;
  73
  74 : nearer-segment ( segment segment oint -- segment )
  75     #! return whichever of the two segments is nearer to the oint
  76     >r 2dup r> tuck distance >r distance r> < -rot ? ;
  77
  78 : (find-nearest-segment) ( nearest next oint -- nearest ? )
  79     #! find the nearest of 'next' and 'nearest' to 'oint', and return
  80     #! t if the nearest hasn't changed
  81     pick >r nearer-segment dup r> = ;
  82
  83 : find-nearest-segment ( oint segments -- segment )
  84     dup first swap rest-slice rot [ (find-nearest-segment) ] curry
  85     find 2drop ;
  86
  87 : nearest-segment-forward ( segments oint start -- segment )
  88     rot dup length swap <slice> find-nearest-segment ;
  89
  90 : nearest-segment-backward ( segments oint start -- segment )
  91     swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
  92
  93 : nearest-segment ( segments oint start-segment -- segment )
  94     #! find the segment nearest to 'oint', and return it.
  95     #! start looking at segment 'start-segment'
  96     segment-number over >r
  97     [ nearest-segment-forward ] 3keep
  98     nearest-segment-backward r> nearer-segment ;
  99
 100 : vector-to-centre ( seg loc -- v )
 101     over location>> swap v- swap forward>> proj-perp ;
 102
 103 : distance-from-centre ( seg loc -- distance )
 104     vector-to-centre norm ;
 105
 106 : wall-normal ( seg oint -- n )
 107     location>> vector-to-centre normalize ;
 108
 109 : from ( seg loc -- radius d-f-c )
 110     dupd location>> distance-from-centre [ radius>> ] dip ;
 111
 112 : distance-from-wall ( seg loc -- distance ) from - ;
 113 : fraction-from-centre ( seg loc -- fraction ) from / ;
 114 : fraction-from-wall ( seg loc -- fraction )
 115     fraction-from-centre 1 swap - ;
 116
 117 :: collision-coefficient ( v w r -- c )
 118     [let* | a [ v dup v. ]
 119             b [ v w v. 2 * ]
 120             c [ w dup v. r sq - ] |
 121         c b a quadratic max ] ;
 122
 123 : sideways-heading ( oint segment -- v )
 124     [ forward>> ] bi@ proj-perp ;
 125
 126 : sideways-relative-location ( oint segment -- loc )
 127     [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
 128
 129 : bounce-offset 0.1 ; inline
 130
 131 : bounce-radius ( segment -- r )
 132     radius>> bounce-offset - ; ! bounce before we hit so that we can't see through the wall (hack?)
 133
 134 : collision-vector ( oint segment -- v )
 135     [ sideways-heading ] [ sideways-relative-location ]
 136     [ bounce-radius ] 2tri
 137     swap [ collision-coefficient ] dip forward>> n*v ;
 138
 139 : distance-to-collision ( oint segment -- distance )
 140     collision-vector norm ;
 141
 142 : bounce-forward ( segment oint -- )
 143     [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
 144
 145 : bounce-left ( segment oint -- )
 146     #! must be done after forward
 147     [ forward>> vneg ] dip [ left>> swap reflect ]
 148     [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
 149
 150 : bounce-up ( segment oint -- )
 151     #! must be done after forward and left!
 152     nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
 153
 154 : bounce ( oint segment -- )
 155     swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
 156