501 lines
13 KiB
Factor
501 lines
13 KiB
Factor
USING: accessors arrays ascii calendar colors colors.gray
|
|
combinators.short-circuit fry kernel locals math math.constants
|
|
math.functions math.libm math.order math.points math.ranges
|
|
math.vectors namespaces opengl processing.shapes quotations
|
|
random sequences splitting timers ui ui.gadgets
|
|
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.frame-buffer
|
|
ui.gadgets.packs ui.gestures ;
|
|
|
|
IN: bubble-chamber
|
|
|
|
! This is a Factor implementation of an art piece by Jared Tarbell:
|
|
!
|
|
! http://complexification.net/gallery/machines/bubblechamber/
|
|
!
|
|
! Jared's version is written in Processing (Java)
|
|
|
|
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
|
|
|
: 1random ( b -- num ) 0 swap 2random ;
|
|
|
|
: at-fraction ( seq fraction -- val ) over length 1 - * >integer swap nth ;
|
|
|
|
: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
|
|
|
|
: mouse ( -- point ) hand-loc get ;
|
|
|
|
: mouse-x ( -- x ) mouse first ;
|
|
: mouse-y ( -- y ) mouse second ;
|
|
|
|
: draw ( point -- )
|
|
gl-scale-factor get-global [
|
|
stroke-color get fill-color set
|
|
>integer draw-circle
|
|
] [
|
|
draw-point
|
|
] if* ;
|
|
|
|
GENERIC: collide ( particle -- )
|
|
GENERIC: move ( particle -- )
|
|
|
|
TUPLE: particle
|
|
bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
|
|
|
|
: initialize-particle ( particle -- particle )
|
|
|
|
{ 0 0 } >>pos
|
|
{ 0 0 } >>vel
|
|
|
|
0 >>speed
|
|
0 >>speed-d
|
|
0 >>theta
|
|
0 >>theta-d
|
|
0 >>theta-dd
|
|
|
|
0 0 0 1 rgba boa >>myc
|
|
0 0 0 1 rgba boa >>mya ;
|
|
|
|
: center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
|
|
|
|
DEFER: collision-theta
|
|
|
|
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
|
|
|
|
: theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
|
|
|
|
: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
|
|
|
|
: turn ( particle -- particle )
|
|
dup
|
|
[ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
|
|
>>vel ;
|
|
|
|
: step-theta ( p -- p ) [ ] [ theta>> ] [ theta-d>> ] tri + >>theta ;
|
|
: step-theta-d ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
|
|
: step-speed-sub ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri - >>speed ;
|
|
: step-speed-mul ( p -- p ) [ ] [ speed>> ] [ speed-d>> ] tri * >>speed ;
|
|
|
|
:: out-of-bounds? ( PARTICLE -- ? )
|
|
PARTICLE pos>> first :> X
|
|
PARTICLE pos>> second :> Y
|
|
PARTICLE bubble-chamber>> size>> first :> WIDTH
|
|
PARTICLE bubble-chamber>> size>> second :> HEIGHT
|
|
|
|
WIDTH neg :> LEFT
|
|
WIDTH 2 * :> RIGHT
|
|
HEIGHT neg :> BOTTOM
|
|
HEIGHT 2 * :> TOP
|
|
|
|
{ [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ;
|
|
|
|
TUPLE: axion < particle ;
|
|
|
|
: <axion> ( -- axion ) axion new initialize-particle ;
|
|
|
|
M: axion collide
|
|
|
|
dup center >>pos
|
|
2 pi * 1random >>theta
|
|
1.0 6.0 2random >>speed
|
|
0.998 1.000 2random >>speed-d
|
|
0 >>theta-d
|
|
0 >>theta-dd
|
|
|
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
|
|
|
|
drop ;
|
|
|
|
: dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
|
|
|
|
! : axion-white ( dy -- dy ) dup 1 swap dy>alpha 2array stroke-color set ;
|
|
! : axion-black ( dy -- dy ) dup 0 swap dy>alpha 2array stroke-color set ;
|
|
|
|
: axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa stroke-color set ;
|
|
: axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa stroke-color set ;
|
|
|
|
: axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y draw ;
|
|
: axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y draw ;
|
|
|
|
M: axion move
|
|
|
|
T{ gray f 0.06 0.59 } stroke-color set
|
|
dup pos>> draw
|
|
|
|
1 4 [a,b] [ axion-white axion-point- ] each
|
|
1 4 [a,b] [ axion-black axion-point+ ] each
|
|
|
|
dup vel>> move-by
|
|
|
|
turn
|
|
|
|
step-theta
|
|
step-theta-d
|
|
step-speed-mul
|
|
|
|
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
|
|
|
|
1000 random 996 >
|
|
[
|
|
dup speed>> neg >>speed
|
|
dup speed-d>> neg 2 + >>speed-d
|
|
|
|
100 random 30 > [ collide ] [ drop ] if
|
|
]
|
|
[ drop ]
|
|
if ;
|
|
|
|
TUPLE: hadron < particle ;
|
|
|
|
: <hadron> ( -- hadron ) hadron new initialize-particle ;
|
|
|
|
M: hadron collide
|
|
|
|
dup center >>pos
|
|
2 pi * 1random >>theta
|
|
0.5 3.5 2random >>speed
|
|
0.996 1.001 2random >>speed-d
|
|
0 >>theta-d
|
|
0 >>theta-dd
|
|
|
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
|
|
|
|
0 1 0 1 rgba boa >>myc
|
|
|
|
drop ;
|
|
|
|
M: hadron move
|
|
|
|
T{ gray f 1 0.11 } stroke-color set dup pos>> 1 v-y draw
|
|
T{ gray f 0 0.11 } stroke-color set dup pos>> 1 v+y draw
|
|
|
|
dup vel>> move-by
|
|
|
|
turn
|
|
|
|
step-theta
|
|
step-theta-d
|
|
step-speed-mul
|
|
|
|
1000 random 997 >
|
|
[
|
|
1.0 >>speed-d
|
|
0.00001 >>theta-dd
|
|
|
|
100 random 70 > [ dup collide ] when
|
|
]
|
|
when
|
|
|
|
dup out-of-bounds? [ collide ] [ drop ] if ;
|
|
|
|
CONSTANT: good-colors {
|
|
T{ rgba f 0.23 0.14 0.17 1 }
|
|
T{ rgba f 0.23 0.14 0.15 1 }
|
|
T{ rgba f 0.21 0.14 0.15 1 }
|
|
T{ rgba f 0.51 0.39 0.33 1 }
|
|
T{ rgba f 0.49 0.33 0.20 1 }
|
|
T{ rgba f 0.55 0.45 0.32 1 }
|
|
T{ rgba f 0.69 0.63 0.51 1 }
|
|
T{ rgba f 0.64 0.39 0.18 1 }
|
|
T{ rgba f 0.73 0.42 0.20 1 }
|
|
T{ rgba f 0.71 0.45 0.29 1 }
|
|
T{ rgba f 0.79 0.45 0.22 1 }
|
|
T{ rgba f 0.82 0.56 0.34 1 }
|
|
T{ rgba f 0.88 0.72 0.49 1 }
|
|
T{ rgba f 0.85 0.69 0.40 1 }
|
|
T{ rgba f 0.96 0.92 0.75 1 }
|
|
T{ rgba f 0.99 0.98 0.87 1 }
|
|
T{ rgba f 0.85 0.82 0.69 1 }
|
|
T{ rgba f 0.99 0.98 0.87 1 }
|
|
T{ rgba f 0.82 0.82 0.79 1 }
|
|
T{ rgba f 0.65 0.69 0.67 1 }
|
|
T{ rgba f 0.53 0.60 0.55 1 }
|
|
T{ rgba f 0.57 0.53 0.68 1 }
|
|
T{ rgba f 0.47 0.42 0.56 1 }
|
|
}
|
|
|
|
: anti-colors ( -- seq ) good-colors <reversed> ;
|
|
|
|
: color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
|
|
|
|
: set-good-color ( particle -- particle )
|
|
color-fraction dup 0 1 between?
|
|
[ good-colors at-fraction-of >>myc ] [ drop ] if ;
|
|
|
|
: set-anti-color ( particle -- particle )
|
|
color-fraction dup 0 1 between?
|
|
[ anti-colors at-fraction-of >>mya ] [ drop ] if ;
|
|
|
|
TUPLE: muon < particle ;
|
|
|
|
: <muon> ( -- muon ) muon new initialize-particle ;
|
|
|
|
M: muon collide
|
|
|
|
dup center >>pos
|
|
2 32 [a,b] random >>speed
|
|
0.0001 0.001 2random >>speed-d
|
|
|
|
dup collision-theta -0.1 0.1 2random + >>theta
|
|
0 >>theta-d
|
|
0 >>theta-dd
|
|
|
|
[ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
|
|
|
|
set-good-color
|
|
set-anti-color
|
|
|
|
drop ;
|
|
|
|
M:: muon move ( MUON -- )
|
|
|
|
MUON bubble-chamber>> size>> first :> WIDTH
|
|
|
|
MUON
|
|
|
|
dup myc>> >rgba-components drop 0.16 <rgba> stroke-color set
|
|
dup pos>> draw
|
|
|
|
dup mya>> >rgba-components drop 0.16 <rgba> stroke-color set
|
|
dup pos>> first2 [ WIDTH swap - ] dip 2array draw
|
|
|
|
dup
|
|
[ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
|
|
move-by
|
|
|
|
step-theta
|
|
step-theta-d
|
|
step-speed-sub
|
|
|
|
dup out-of-bounds? [ collide ] [ drop ] if ;
|
|
|
|
TUPLE: quark < particle ;
|
|
|
|
: <quark> ( -- quark ) quark new initialize-particle ;
|
|
|
|
M: quark collide
|
|
|
|
dup center >>pos
|
|
dup collision-theta -0.11 0.11 2random + >>theta
|
|
0.5 3.0 2random >>speed
|
|
|
|
0.996 1.001 2random >>speed-d
|
|
0 >>theta-d
|
|
0 >>theta-dd
|
|
|
|
[ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
|
|
|
|
drop ;
|
|
|
|
M:: quark move ( QUARK -- )
|
|
|
|
QUARK bubble-chamber>> size>> first :> WIDTH
|
|
|
|
QUARK
|
|
|
|
dup myc>> >rgba-components drop 0.13 <rgba> stroke-color set
|
|
dup pos>> draw
|
|
|
|
dup pos>> first2 [ WIDTH swap - ] dip 2array draw
|
|
|
|
[ ] [ vel>> ] bi move-by
|
|
|
|
turn
|
|
|
|
step-theta
|
|
step-theta-d
|
|
step-speed-mul
|
|
|
|
1000 random 997 > [
|
|
dup speed>> neg >>speed
|
|
2 over speed-d>> - >>speed-d
|
|
] when
|
|
|
|
dup out-of-bounds? [ collide ] [ drop ] if ;
|
|
|
|
TUPLE: bubble-chamber < frame-buffer
|
|
particles collision-theta size timer ;
|
|
|
|
M: bubble-chamber graft*
|
|
[ timer>> start-timer ] [ call-next-method ] bi ;
|
|
|
|
M: bubble-chamber ungraft*
|
|
[ timer>> stop-timer ] [ call-next-method ] bi ;
|
|
|
|
! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
|
|
! 0 2 pi * 0.001 <range> random >>collision-theta ;
|
|
|
|
: randomize-collision-theta ( bubble-chamber -- bubble-chamber )
|
|
pi neg pi 0.001 <range> random >>collision-theta ;
|
|
|
|
: collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
|
|
|
|
M: bubble-chamber pref-dim* ( gadget -- dim ) size>> ;
|
|
|
|
: iterate-particle ( particle -- ) move ;
|
|
|
|
M:: bubble-chamber update-frame-buffer ( BUBBLE-CHAMBER -- )
|
|
BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
|
|
|
|
: iterate-system ( bubble-chamber -- ) drop ;
|
|
|
|
: <bubble-chamber> ( -- bubble-chamber )
|
|
bubble-chamber new
|
|
{ 1000 1000 } >>size
|
|
randomize-collision-theta
|
|
dup '[ _ dup iterate-system relayout-1 ]
|
|
f 10 milliseconds <timer> >>timer ;
|
|
|
|
: bubble-chamber-window ( -- bubble-chamber )
|
|
<bubble-chamber> dup "Bubble Chamber" open-window ;
|
|
|
|
:: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
|
|
PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
|
|
BUBBLE-CHAMBER [ PARTICLE suffix ] change-particles ;
|
|
|
|
:: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
|
|
mouse
|
|
BUBBLE-CHAMBER size>> 2 v/n
|
|
v-
|
|
first2
|
|
fatan2
|
|
BUBBLE-CHAMBER collision-theta<<
|
|
BUBBLE-CHAMBER ;
|
|
|
|
:: mouse-pressed ( BUBBLE-CHAMBER -- )
|
|
BUBBLE-CHAMBER mouse->collision-theta drop
|
|
|
|
11 [
|
|
BUBBLE-CHAMBER particles>> [ hadron? ] filter random [ collide ] when*
|
|
BUBBLE-CHAMBER particles>> [ quark? ] filter random [ collide ] when*
|
|
BUBBLE-CHAMBER particles>> [ muon? ] filter random [ collide ] when*
|
|
] times ;
|
|
|
|
bubble-chamber H{
|
|
{ T{ button-down } [ mouse-pressed ] }
|
|
} set-gestures
|
|
|
|
: collide-random-particle ( bubble-chamber -- bubble-chamber )
|
|
dup particles>> random collide ;
|
|
|
|
: big-bang ( bubble-chamber -- bubble-chamber )
|
|
dup particles>> [ collide ] each ;
|
|
|
|
: collide-one-of-each ( bubble-chamber -- bubble-chamber )
|
|
dup
|
|
particles>>
|
|
[ [ muon? ] filter random collide ]
|
|
[ [ quark? ] filter random collide ]
|
|
[ [ hadron? ] filter random collide ]
|
|
tri ;
|
|
|
|
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
: ten-hadrons ( -- )
|
|
bubble-chamber-window
|
|
10 [ <hadron> add-particle ] times
|
|
drop ;
|
|
|
|
: original ( -- )
|
|
bubble-chamber-window
|
|
|
|
1789 [ <muon> add-particle ] times
|
|
1300 [ <quark> add-particle ] times
|
|
1000 [ <hadron> add-particle ] times
|
|
111 [ <axion> add-particle ] times
|
|
|
|
particles>>
|
|
[ [ muon? ] filter random collide ]
|
|
[ [ quark? ] filter random collide ]
|
|
[ [ hadron? ] filter random collide ]
|
|
tri ;
|
|
|
|
: hadron-chamber ( -- )
|
|
bubble-chamber-window
|
|
1000 [ <hadron> add-particle ] times
|
|
big-bang
|
|
drop ;
|
|
|
|
: quark-chamber ( -- )
|
|
bubble-chamber-window
|
|
100 [ <quark> add-particle ] times
|
|
big-bang
|
|
drop ;
|
|
|
|
: small ( -- )
|
|
<bubble-chamber>
|
|
{ 200 200 } >>size
|
|
dup "Bubble Chamber" open-window
|
|
|
|
42 [ <muon> add-particle ] times
|
|
30 [ <quark> add-particle ] times
|
|
21 [ <hadron> add-particle ] times
|
|
7 [ <axion> add-particle ] times
|
|
|
|
collide-one-of-each
|
|
drop ;
|
|
|
|
: medium ( -- )
|
|
<bubble-chamber>
|
|
{ 400 400 } >>size
|
|
dup "Bubble Chamber" open-window
|
|
|
|
100 [ <muon> add-particle ] times
|
|
81 [ <quark> add-particle ] times
|
|
60 [ <hadron> add-particle ] times
|
|
9 [ <axion> add-particle ] times
|
|
|
|
collide-one-of-each
|
|
drop ;
|
|
|
|
: large ( -- )
|
|
<bubble-chamber>
|
|
{ 600 600 } >>size
|
|
dup "Bubble Chamber" open-window
|
|
|
|
550 [ <muon> add-particle ] times
|
|
339 [ <quark> add-particle ] times
|
|
100 [ <hadron> add-particle ] times
|
|
11 [ <axion> add-particle ] times
|
|
|
|
collide-one-of-each
|
|
drop ;
|
|
|
|
: muon-chamber ( -- )
|
|
bubble-chamber-window
|
|
1000 [ <muon> add-particle ] times
|
|
dup particles>> [ collide randomize-collision-theta ] each
|
|
drop ;
|
|
|
|
: original-big-bang ( -- )
|
|
<bubble-chamber>
|
|
{ 1000 1000 } >>size
|
|
dup "Bubble Chamber" open-window
|
|
|
|
1789 [ <muon> add-particle ] times
|
|
1300 [ <quark> add-particle ] times
|
|
1000 [ <hadron> add-particle ] times
|
|
111 [ <axion> add-particle ] times
|
|
|
|
big-bang
|
|
drop ;
|
|
|
|
: original-big-bang-variant ( -- )
|
|
bubble-chamber-window
|
|
1789 [ <muon> add-particle ] times
|
|
1300 [ <quark> add-particle ] times
|
|
1000 [ <hadron> add-particle ] times
|
|
111 [ <axion> add-particle ] times
|
|
dup particles>> [ collide randomize-collision-theta ] each
|
|
drop ;
|
|
|
|
MAIN-WINDOW: run-bubble-chamber { { title "Bubble Chamber" } }
|
|
<filled-pile> { 2 2 } >>gap {
|
|
original small medium large hadron-chamber
|
|
quark-chamber muon-chamber ten-hadrons
|
|
original-big-bang original-big-bang-variant
|
|
} [
|
|
[ name>> "-" " " replace >title ]
|
|
[ 1quotation [ drop ] prepend ] bi
|
|
<border-button> add-gadget
|
|
] each { 2 2 } <border> >>gadgets ;
|