Merge branch 'master' of git://factorcode.org/git/wrunt
Slava Pestov
commit
ffe749f275
|
|
@ -0,0 +1,12 @@
|
|||
USING: tools.deploy.config ;
|
||||
V{
|
||||
{ deploy-ui? t }
|
||||
{ deploy-io 1 }
|
||||
{ deploy-reflection 1 }
|
||||
{ deploy-compiler? t }
|
||||
{ deploy-math? t }
|
||||
{ deploy-word-props? f }
|
||||
{ deploy-c-types? f }
|
||||
{ "stop-after-last-window?" t }
|
||||
{ deploy-name "Jamshred" }
|
||||
}
|
||||
|
|
@ -1,26 +1,31 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel opengl arrays sequences jamshred.tunnel
|
||||
jamshred.player math.vectors ;
|
||||
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math.vectors ;
|
||||
IN: jamshred.game
|
||||
|
||||
TUPLE: jamshred tunnel players running ;
|
||||
TUPLE: jamshred sounds tunnel players running quit ;
|
||||
|
||||
: <jamshred> ( -- jamshred )
|
||||
<random-tunnel> "Player 1" <player> 2dup swap play-in-tunnel 1array f
|
||||
jamshred boa ;
|
||||
<sounds> <random-tunnel> "Player 1" pick <player>
|
||||
2dup swap play-in-tunnel 1array f f jamshred boa ;
|
||||
|
||||
: jamshred-player ( jamshred -- player )
|
||||
! TODO: support more than one player
|
||||
jamshred-players first ;
|
||||
players>> first ;
|
||||
|
||||
: jamshred-update ( jamshred -- )
|
||||
dup jamshred-running [
|
||||
dup running>> [
|
||||
jamshred-player update-player
|
||||
] [ drop ] if ;
|
||||
|
||||
: toggle-running ( jamshred -- )
|
||||
dup jamshred-running not swap set-jamshred-running ;
|
||||
dup running>> [
|
||||
f >>running drop
|
||||
] [
|
||||
[ jamshred-player moved ]
|
||||
[ t >>running drop ] bi
|
||||
] if ;
|
||||
|
||||
: mouse-moved ( x-radians y-radians jamshred -- )
|
||||
jamshred-player -rot turn-player ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,38 +1,48 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alarms arrays calendar jamshred.game jamshred.gl kernel math
|
||||
math.constants namespaces sequences ui ui.gadgets ui.gestures ui.render
|
||||
math.vectors ;
|
||||
USING: accessors alarms arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render math.vectors ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
|
||||
|
||||
: <jamshred-gadget> ( jamshred -- gadget )
|
||||
jamshred-gadget construct-gadget tuck set-jamshred-gadget-jamshred ;
|
||||
jamshred-gadget construct-gadget swap >>jamshred ;
|
||||
|
||||
: default-width ( -- x ) 1024 ;
|
||||
: default-height ( -- y ) 768 ;
|
||||
: default-width ( -- x ) 800 ;
|
||||
: default-height ( -- y ) 600 ;
|
||||
|
||||
M: jamshred-gadget pref-dim*
|
||||
drop default-width default-height 2array ;
|
||||
|
||||
M: jamshred-gadget draw-gadget* ( gadget -- )
|
||||
dup jamshred-gadget-jamshred swap rect-dim first2 draw-jamshred ;
|
||||
[ jamshred>> ] [ rect-dim first2 draw-jamshred ] bi ;
|
||||
|
||||
: tick ( gadget -- )
|
||||
dup jamshred-gadget-jamshred jamshred-update relayout-1 ;
|
||||
: jamshred-loop ( gadget -- )
|
||||
dup jamshred>> quit>> [
|
||||
drop
|
||||
] [
|
||||
dup [ jamshred>> jamshred-update ]
|
||||
[ relayout-1 ] bi
|
||||
yield jamshred-loop
|
||||
] if ;
|
||||
|
||||
: fullscreen ( gadget -- )
|
||||
find-world t swap set-fullscreen* ;
|
||||
|
||||
: no-fullscreen ( gadget -- )
|
||||
find-world f swap set-fullscreen* ;
|
||||
|
||||
: toggle-fullscreen ( world -- )
|
||||
[ fullscreen? not ] keep set-fullscreen* ;
|
||||
|
||||
M: jamshred-gadget graft* ( gadget -- )
|
||||
[
|
||||
[ tick ] curry 10 milliseconds from-now 10 milliseconds add-alarm
|
||||
] keep set-jamshred-gadget-alarm ;
|
||||
[ jamshred-loop ] in-thread drop ;
|
||||
|
||||
M: jamshred-gadget ungraft* ( gadget -- )
|
||||
[ jamshred-gadget-alarm cancel-alarm f ] keep
|
||||
set-jamshred-gadget-alarm ;
|
||||
jamshred>> t swap (>>quit) ;
|
||||
|
||||
: jamshred-restart ( jamshred-gadget -- )
|
||||
<jamshred> swap set-jamshred-gadget-jamshred ;
|
||||
<jamshred> >>jamshred drop ;
|
||||
|
||||
: pix>radians ( n m -- theta )
|
||||
2 / / pi 2 * * ;
|
||||
|
|
@ -46,22 +56,31 @@ M: jamshred-gadget ungraft* ( gadget -- )
|
|||
rect-dim second pix>radians ;
|
||||
|
||||
: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
|
||||
over jamshred-gadget-jamshred >r
|
||||
over jamshred>> >r
|
||||
[ first swap x>radians ] 2keep second swap y>radians
|
||||
r> mouse-moved ;
|
||||
|
||||
: handle-mouse-motion ( jamshred-gadget -- )
|
||||
hand-loc get [
|
||||
over jamshred-gadget-last-hand-loc [
|
||||
over last-hand-loc>> [
|
||||
v- (handle-mouse-motion)
|
||||
] [ 2drop ] if*
|
||||
] 2keep swap set-jamshred-gadget-last-hand-loc ;
|
||||
] 2keep >>last-hand-loc drop ;
|
||||
|
||||
: handle-mouse-scroll ( jamshred-gadget -- )
|
||||
jamshred>> jamshred-player scroll-direction get
|
||||
second neg swap change-player-speed ;
|
||||
|
||||
: quit ( gadget -- )
|
||||
[ no-fullscreen ] [ close-window ] bi ;
|
||||
|
||||
USE: vocabs.loader
|
||||
jamshred-gadget H{
|
||||
{ T{ key-down f f "r" } [ jamshred-restart ] }
|
||||
{ T{ key-down f f " " } [ jamshred-gadget-jamshred toggle-running ] }
|
||||
{ T{ key-down f f " " } [ jamshred>> toggle-running ] }
|
||||
{ T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
|
||||
{ T{ key-down f f "q" } [ quit ] }
|
||||
{ T{ motion } [ handle-mouse-motion ] }
|
||||
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: jamshred-window ( -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
USING: kernel logging ;
|
||||
IN: jamshred.log
|
||||
|
||||
LOG: (jamshred-log) DEBUG
|
||||
|
||||
: with-jamshred-log ( quot -- )
|
||||
"jamshred" swap with-logging ;
|
||||
|
||||
: jamshred-log ( message -- )
|
||||
[ (jamshred-log) ] with-jamshred-log ; ! ugly...
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
USING: jamshred.oint tools.test ;
|
||||
IN: jamshred.oint-tests
|
||||
|
||||
[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
|
||||
[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
|
||||
[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
|
||||
[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
|
||||
[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays float-arrays kernel math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
|
||||
USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
|
||||
IN: jamshred.oint
|
||||
|
||||
! An oint is a point with three linearly independent unit vectors
|
||||
|
|
@ -9,47 +9,25 @@ IN: jamshred.oint
|
|||
! segment's location and orientation are given by an oint.
|
||||
|
||||
TUPLE: oint location forward up left ;
|
||||
|
||||
: <oint> ( location forward up left -- oint )
|
||||
oint boa ;
|
||||
|
||||
! : x-rotation ( theta -- matrix )
|
||||
! #! construct this matrix:
|
||||
! #! { { 1 0 0 }
|
||||
! #! { 0 cos(theta) sin(theta) }
|
||||
! #! { 0 -sin(theta) cos(theta) } }
|
||||
! dup sin neg swap cos 2dup 0 -rot 3float-array >r
|
||||
! swap neg 0 -rot 3float-array >r
|
||||
! { 1 0 0 } r> r> 3float-array ;
|
||||
!
|
||||
! : y-rotation ( theta -- matrix )
|
||||
! #! costruct this matrix:
|
||||
! #! { { cos(theta) 0 -sin(theta) }
|
||||
! #! { 0 1 0 }
|
||||
! #! { sin(theta) 0 cos(theta) } }
|
||||
! dup sin swap cos 2dup
|
||||
! 0 swap 3float-array >r
|
||||
! { 0 1 0 } >r
|
||||
! 0 rot neg 3float-array r> r> 3float-array ;
|
||||
|
||||
: apply-to-oint ( oint quot -- )
|
||||
#! apply quot to each of forward, up, and left, storing the results
|
||||
over oint-forward over call pick set-oint-forward
|
||||
over oint-up over call pick set-oint-up
|
||||
over oint-left swap call swap set-oint-left ;
|
||||
C: <oint> oint
|
||||
|
||||
: rotation-quaternion ( theta axis -- quaternion )
|
||||
swap 2 / dup cos swap sin rot n*v first3 rect> >r rect> r> 2array ;
|
||||
|
||||
: rotate-vector ( q qrecip v -- v )
|
||||
v>q swap q* q* q>v ;
|
||||
|
||||
: rotate-oint ( oint theta axis -- )
|
||||
rotation-quaternion dup qrecip
|
||||
[ rot v>q swap q* q* q>v ] curry curry apply-to-oint ;
|
||||
rotation-quaternion dup qrecip pick
|
||||
[ forward>> rotate-vector >>forward ]
|
||||
[ up>> rotate-vector >>up ]
|
||||
[ left>> rotate-vector >>left ] 3tri drop ;
|
||||
|
||||
: left-pivot ( oint theta -- )
|
||||
over oint-left rotate-oint ;
|
||||
over left>> rotate-oint ;
|
||||
|
||||
: up-pivot ( oint theta -- )
|
||||
over oint-up rotate-oint ;
|
||||
over up>> rotate-oint ;
|
||||
|
||||
: random-float+- ( n -- m )
|
||||
#! find a random float between -n/2 and n/2
|
||||
|
|
@ -59,10 +37,10 @@ TUPLE: oint location forward up left ;
|
|||
2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
|
||||
|
||||
: go-forward ( distance oint -- )
|
||||
tuck oint-forward n*v over oint-location v+ swap set-oint-location ;
|
||||
[ forward>> n*v ] [ location>> v+ ] [ (>>location) ] tri ;
|
||||
|
||||
: distance-vector ( oint oint -- vector )
|
||||
oint-location swap oint-location v- ;
|
||||
[ location>> ] bi@ swap v- ;
|
||||
|
||||
: distance ( oint oint -- distance )
|
||||
distance-vector norm ;
|
||||
|
|
@ -71,6 +49,13 @@ TUPLE: oint location forward up left ;
|
|||
#! the scalar projection of v1 onto v2
|
||||
tuck v. swap norm / ;
|
||||
|
||||
: proj-perp ( u v -- w )
|
||||
dupd proj v- ;
|
||||
|
||||
: perpendicular-distance ( oint oint -- distance )
|
||||
tuck distance-vector swap 2dup oint-left scalar-projection abs
|
||||
-rot oint-up scalar-projection abs + ;
|
||||
tuck distance-vector swap 2dup left>> scalar-projection abs
|
||||
-rot up>> scalar-projection abs + ;
|
||||
|
||||
:: reflect ( v n -- v' )
|
||||
#! bounce v on a surface with normal n
|
||||
v v n v. n n v. / 2 * n n*v v- ;
|
||||
|
|
|
|||
|
|
@ -1,38 +1,68 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: colors jamshred.oint jamshred.tunnel kernel
|
||||
math math.constants sequences ;
|
||||
USING: accessors colors jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel math math.constants math.order math.ranges shuffle sequences system ;
|
||||
IN: jamshred.player
|
||||
|
||||
TUPLE: player name tunnel nearest-segment ;
|
||||
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
||||
|
||||
: <player> ( name -- player )
|
||||
f f player boa
|
||||
F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <oint> over set-delegate ;
|
||||
! speeds are in GL units / second
|
||||
: default-speed ( -- speed ) 1.0 ;
|
||||
: max-speed ( -- speed ) 30.0 ;
|
||||
|
||||
: <player> ( name sounds -- player )
|
||||
[ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
|
||||
f f f default-speed player boa ;
|
||||
|
||||
: turn-player ( player x-radians y-radians -- )
|
||||
>r over r> left-pivot up-pivot ;
|
||||
|
||||
: to-tunnel-start ( player -- )
|
||||
dup player-tunnel first dup oint-location pick set-oint-location
|
||||
swap set-player-nearest-segment ;
|
||||
[ tunnel>> first dup location>> ]
|
||||
[ tuck (>>location) (>>nearest-segment) ] bi ;
|
||||
|
||||
: play-in-tunnel ( player segments -- )
|
||||
over set-player-tunnel to-tunnel-start ;
|
||||
>>tunnel to-tunnel-start ;
|
||||
|
||||
: update-nearest-segment ( player -- )
|
||||
dup player-tunnel over dup player-nearest-segment nearest-segment
|
||||
swap set-player-nearest-segment ;
|
||||
[ tunnel>> ] [ dup nearest-segment>> nearest-segment ]
|
||||
[ (>>nearest-segment) ] tri ;
|
||||
|
||||
: max-speed ( -- speed )
|
||||
0.3 ;
|
||||
: moved ( player -- ) millis swap (>>last-move) ;
|
||||
|
||||
: player-speed ( player -- speed )
|
||||
dup player-nearest-segment fraction-from-wall sq max-speed * ;
|
||||
: speed-range ( -- range )
|
||||
max-speed [0,b] ;
|
||||
|
||||
: change-player-speed ( inc player -- )
|
||||
[ + speed-range clamp-to-range ] change-speed drop ;
|
||||
|
||||
: distance-to-move ( player -- distance )
|
||||
[ speed>> ] [ last-move>> millis dup >r swap - 1000 / * r> ]
|
||||
[ (>>last-move) ] tri ;
|
||||
|
||||
DEFER: (move-player)
|
||||
|
||||
: ?bounce ( distance-remaining player -- )
|
||||
over 0 > [
|
||||
[ dup nearest-segment>> bounce ] [ sounds>> bang ]
|
||||
[ (move-player) ] tri
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: move-player-distance ( distance-remaining player distance -- distance-remaining player )
|
||||
pick min tuck over go-forward [ - ] dip ;
|
||||
|
||||
: (move-player) ( distance-remaining player -- )
|
||||
over 0 <= [
|
||||
2drop
|
||||
] [
|
||||
dup dup nearest-segment>> distance-to-collision
|
||||
move-player-distance ?bounce
|
||||
] if ;
|
||||
|
||||
: move-player ( player -- )
|
||||
dup player-speed over go-forward update-nearest-segment ;
|
||||
[ distance-to-move ] [ (move-player) ] [ update-nearest-segment ] tri ;
|
||||
|
||||
: update-player ( player -- )
|
||||
dup move-player player-nearest-segment
|
||||
dup move-player nearest-segment>>
|
||||
white swap set-segment-color ;
|
||||
|
|
|
|||
Binary file not shown.
|
|
@ -0,0 +1,13 @@
|
|||
USING: accessors io.files kernel openal sequences ;
|
||||
IN: jamshred.sound
|
||||
|
||||
TUPLE: sounds bang ;
|
||||
|
||||
: assign-sound ( source wav-path -- )
|
||||
resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
|
||||
|
||||
: <sounds> ( -- sounds )
|
||||
init-openal 1 gen-sources first sounds boa
|
||||
dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
|
||||
|
||||
: bang ( sounds -- ) bang>> source-play check-error ;
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
USING: jamshred.oint jamshred.tunnel kernel sequences tools.test ;
|
||||
IN: jamshred.tunnel.tests
|
||||
|
||||
[ 0 ] [ T{ segment T{ oint f { 0 0 0 } } 0 }
|
||||
T{ segment T{ oint f { 1 1 1 } } 1 }
|
||||
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
|
||||
T{ segment f { 1 1 1 } f f f 1 }
|
||||
T{ oint f { 0 0 0.25 } }
|
||||
nearer-segment segment-number ] unit-test
|
||||
|
||||
|
|
@ -15,3 +15,30 @@ IN: jamshred.tunnel.tests
|
|||
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
|
||||
|
||||
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
|
||||
|
||||
: test-segment-oint ( -- oint )
|
||||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
|
||||
|
||||
[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
|
||||
[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
|
||||
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
|
||||
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
|
||||
[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
|
||||
[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
|
||||
[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
|
||||
[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
|
||||
|
||||
: simplest-straight-ahead ( -- oint segment )
|
||||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
|
||||
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
|
||||
|
||||
: simple-collision-up ( -- oint segment )
|
||||
{ 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
|
||||
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
|
||||
[ { 0 1 0 } ] [ simple-collision-up collision-vector ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,23 +1,20 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays float-arrays kernel jamshred.oint math math.functions
|
||||
math.ranges math.vectors math.constants random sequences vectors ;
|
||||
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 ;
|
||||
IN: jamshred.tunnel
|
||||
|
||||
: n-segments ( -- n ) 5000 ; inline
|
||||
|
||||
TUPLE: segment number color radius ;
|
||||
|
||||
: <segment> ( number color radius location forward up left -- segment )
|
||||
<oint> >r segment boa r> over set-delegate ;
|
||||
TUPLE: segment < oint number color radius ;
|
||||
C: <segment> segment
|
||||
|
||||
: segment-vertex ( theta segment -- vertex )
|
||||
tuck 2dup oint-up swap sin v*n
|
||||
>r oint-left swap cos v*n r> v+
|
||||
swap oint-location v+ ;
|
||||
tuck 2dup up>> swap sin v*n
|
||||
>r left>> swap cos v*n r> v+
|
||||
swap location>> v+ ;
|
||||
|
||||
: segment-vertex-normal ( vertex segment -- normal )
|
||||
oint-location swap v- normalize ;
|
||||
location>> swap v- normalize ;
|
||||
|
||||
: segment-vertex-and-normal ( segment theta -- vertex normal )
|
||||
swap [ segment-vertex ] keep dupd segment-vertex-normal ;
|
||||
|
|
@ -27,7 +24,7 @@ TUPLE: segment number color radius ;
|
|||
dup [ / pi 2 * * ] curry map ;
|
||||
|
||||
: segment-number++ ( segment -- )
|
||||
dup segment-number 1+ swap set-segment-number ;
|
||||
[ number>> 1+ ] keep (>>number) ;
|
||||
|
||||
: random-color ( -- color )
|
||||
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
|
||||
|
|
@ -50,15 +47,15 @@ TUPLE: segment number color radius ;
|
|||
: default-segment-radius ( -- r ) 1 ;
|
||||
|
||||
: initial-segment ( -- segment )
|
||||
0 random-color default-segment-radius
|
||||
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
|
||||
F{ 0 0 0 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 }
|
||||
0 random-color default-segment-radius <segment> ;
|
||||
|
||||
: random-segments ( n -- segments )
|
||||
initial-segment 1vector swap (random-segments) ;
|
||||
|
||||
: simple-segment ( n -- segment )
|
||||
random-color default-segment-radius pick F{ 0 0 -1 } n*v
|
||||
F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } <segment> ;
|
||||
[ F{ 0 0 -1 } n*v F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] keep
|
||||
random-color default-segment-radius <segment> ;
|
||||
|
||||
: simple-segments ( n -- segments )
|
||||
[ simple-segment ] map ;
|
||||
|
|
@ -100,14 +97,54 @@ TUPLE: segment number color radius ;
|
|||
[ nearest-segment-forward ] 3keep
|
||||
nearest-segment-backward r> nearer-segment ;
|
||||
|
||||
: distance-from-centre ( oint segment -- distance )
|
||||
perpendicular-distance ;
|
||||
: vector-to-centre ( seg loc -- v )
|
||||
over location>> swap v- swap forward>> proj-perp ;
|
||||
|
||||
: distance-from-wall ( oint segment -- distance )
|
||||
tuck distance-from-centre swap segment-radius swap - ;
|
||||
: distance-from-centre ( seg loc -- distance )
|
||||
vector-to-centre norm ;
|
||||
|
||||
: fraction-from-centre ( oint segment -- fraction )
|
||||
tuck distance-from-centre swap segment-radius / ;
|
||||
: wall-normal ( seg oint -- n )
|
||||
location>> vector-to-centre normalize ;
|
||||
|
||||
: fraction-from-wall ( oint segment -- fraction )
|
||||
: from ( seg loc -- radius d-f-c )
|
||||
dupd location>> distance-from-centre [ radius>> ] dip ;
|
||||
|
||||
: distance-from-wall ( seg loc -- distance ) from - ;
|
||||
: fraction-from-centre ( seg loc -- fraction ) from / ;
|
||||
: fraction-from-wall ( seg loc -- fraction )
|
||||
fraction-from-centre 1 swap - ;
|
||||
|
||||
:: collision-coefficient ( v w r -- c )
|
||||
[let* | a [ v dup v. ]
|
||||
b [ v w v. 2 * ]
|
||||
c [ w dup v. r sq - ] |
|
||||
c b a quadratic max ] ;
|
||||
|
||||
: sideways-heading ( oint segment -- v )
|
||||
[ forward>> ] bi@ proj-perp ;
|
||||
|
||||
: sideways-relative-location ( oint segment -- loc )
|
||||
[ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
|
||||
|
||||
: collision-vector ( oint segment -- v )
|
||||
[ sideways-heading ] [ sideways-relative-location ] [ radius>> ] 2tri
|
||||
swap [ collision-coefficient ] dip forward>> n*v ;
|
||||
|
||||
: distance-to-collision ( oint segment -- distance )
|
||||
collision-vector norm ;
|
||||
|
||||
: bounce-forward ( segment oint -- )
|
||||
[ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
|
||||
|
||||
: bounce-left ( segment oint -- )
|
||||
#! must be done after forward
|
||||
[ forward>> vneg ] dip [ left>> swap reflect ]
|
||||
[ forward>> proj-perp normalize ] [ (>>left) ] tri ;
|
||||
|
||||
: bounce-up ( segment oint -- )
|
||||
#! must be done after forward and left!
|
||||
nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
|
||||
|
||||
: bounce ( oint segment -- )
|
||||
swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue