extra/bubble-chamber/bubble-chamber.factor

   1 USING: accessors arrays ascii calendar colors colors.gray
   2 combinators.short-circuit kernel math math.constants
   3 math.functions math.libm math.order math.points math.vectors
   4 namespaces opengl processing.shapes quotations random ranges
   5 sequences splitting timers ui ui.gadgets ui.gadgets.borders
   6 ui.gadgets.buttons ui.gadgets.frame-buffer ui.gadgets.packs
   7 ui.gestures ;
   8
   9 IN: bubble-chamber
  10
  11 ! This is a Factor implementation of an art piece by Jared Tarbell:
  12 !
  13 !   http://complexification.net/gallery/machines/bubblechamber/
  14 !
  15 ! Jared's version is written in Processing (Java)
  16
  17 : 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
  18
  19 : 1random ( b -- num ) 0 swap 2random ;
  20
  21 : at-fraction ( seq fraction -- val ) over length 1 - * >integer swap nth ;
  22
  23 : at-fraction-of ( fraction seq -- val ) swap at-fraction ;
  24
  25 : mouse ( -- point ) hand-loc get ;
  26
  27 : mouse-x ( -- x ) mouse first  ;
  28 : mouse-y ( -- y ) mouse second ;
  29
  30 : draw ( point -- )
  31     gl-scale-factor get-global [
  32         stroke-color get fill-color set
  33         >integer draw-circle
  34     ] [
  35         draw-point
  36     ] if* ;
  37
  38 GENERIC: collide ( particle -- )
  39 GENERIC: move    ( particle -- )
  40
  41 TUPLE: particle
  42     bubble-chamber pos vel speed speed-d theta theta-d theta-dd myc mya ;
  43
  44 : initialize-particle ( particle -- particle )
  45
  46   { 0 0 } >>pos
  47   { 0 0 } >>vel
  48
  49   0 >>speed
  50   0 >>speed-d
  51   0 >>theta
  52   0 >>theta-d
  53   0 >>theta-dd
  54
  55   0 0 0 1 rgba boa >>myc
  56   0 0 0 1 rgba boa >>mya ;
  57
  58 : center ( particle -- point ) bubble-chamber>> size>> 2 v/n ;
  59
  60 DEFER: collision-theta
  61
  62 : move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
  63
  64 : theta-dd-small? ( par limit -- par ? ) [ dup theta-dd>> abs ] dip < ;
  65
  66 : random-theta-dd  ( par a b -- par ) 2random >>theta-dd ;
  67
  68 : turn ( particle -- particle )
  69   dup
  70     [ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
  71   >>vel ;
  72
  73 : step-theta     ( p -- p ) [ ] [ theta>>   ] [ theta-d>>  ] tri + >>theta   ;
  74 : step-theta-d   ( p -- p ) [ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d ;
  75 : step-speed-sub ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri - >>speed   ;
  76 : step-speed-mul ( p -- p ) [ ] [ speed>>   ] [ speed-d>>  ] tri * >>speed   ;
  77
  78 :: out-of-bounds? ( PARTICLE -- ? )
  79     PARTICLE pos>> first :> X
  80     PARTICLE pos>> second :> Y
  81     PARTICLE bubble-chamber>> size>> first :> WIDTH
  82     PARTICLE bubble-chamber>> size>> second :> HEIGHT
  83
  84     WIDTH  neg :> LEFT
  85     WIDTH  2 * :> RIGHT
  86     HEIGHT neg :> BOTTOM
  87     HEIGHT 2 * :> TOP
  88
  89     { [ X LEFT < ] [ X RIGHT > ] [ Y BOTTOM < ] [ Y TOP > ] } 0|| ;
  90
  91 TUPLE: axion < particle ;
  92
  93 : <axion> ( -- axion ) axion new initialize-particle ;
  94
  95 M: axion collide
  96
  97   dup center          >>pos
  98   2 pi *      1random >>theta
  99   1.0   6.0   2random >>speed
 100   0.998 1.000 2random >>speed-d
 101   0                   >>theta-d
 102   0                   >>theta-dd
 103
 104   [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
 105
 106   drop ;
 107
 108 : dy>alpha ( dy -- alpha ) neg 6 * 30 + 255.0 / ;
 109
 110 ! : axion-white ( dy -- dy ) dup 1 swap dy>alpha 2array stroke-color set ;
 111 ! : axion-black ( dy -- dy ) dup 0 swap dy>alpha 2array stroke-color set ;
 112
 113 : axion-white ( dy -- dy ) dup 1 swap dy>alpha gray boa stroke-color set ;
 114 : axion-black ( dy -- dy ) dup 0 swap dy>alpha gray boa stroke-color set ;
 115
 116 : axion-point- ( particle dy -- particle ) [ dup pos>> ] dip v-y draw ;
 117 : axion-point+ ( particle dy -- particle ) [ dup pos>> ] dip v+y draw ;
 118
 119 M: axion move
 120
 121   T{ gray f 0.06 0.59 } stroke-color set
 122   dup pos>> draw
 123
 124   4 [1..b] [ axion-white axion-point- ] each
 125   4 [1..b] [ axion-black axion-point+ ] each
 126
 127   dup vel>> move-by
 128
 129   turn
 130
 131   step-theta
 132   step-theta-d
 133   step-speed-mul
 134
 135   [ ] [ speed-d>> 0.9999 * ] bi >>speed-d
 136
 137   1000 random 996 >
 138     [
 139       dup speed>>   neg     >>speed
 140       dup speed-d>> neg 2 + >>speed-d
 141
 142       100 random 30 > [ collide ] [ drop ] if
 143     ]
 144     [ drop ]
 145   if ;
 146
 147 TUPLE: hadron < particle ;
 148
 149 : <hadron> ( -- hadron ) hadron new initialize-particle ;
 150
 151 M: hadron collide
 152
 153   dup center          >>pos
 154   2 pi *      1random >>theta
 155   0.5   3.5   2random >>speed
 156   0.996 1.001 2random >>speed-d
 157   0                   >>theta-d
 158   0                   >>theta-dd
 159
 160   [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
 161
 162   0 1 0 1 rgba boa >>myc
 163
 164   drop ;
 165
 166 M: hadron move
 167
 168   T{ gray f 1 0.11 } stroke-color set  dup pos>> 1 v-y draw
 169   T{ gray f 0 0.11 } stroke-color set  dup pos>> 1 v+y draw
 170
 171   dup vel>> move-by
 172
 173   turn
 174
 175   step-theta
 176   step-theta-d
 177   step-speed-mul
 178
 179   1000 random 997 >
 180     [
 181       1.0     >>speed-d
 182       0.00001 >>theta-dd
 183
 184       100 random 70 > [ dup collide ] when
 185     ]
 186   when
 187
 188   dup out-of-bounds? [ collide ] [ drop ] if ;
 189
 190 CONSTANT: good-colors {
 191     T{ rgba f 0.23 0.14 0.17 1 }
 192     T{ rgba f 0.23 0.14 0.15 1 }
 193     T{ rgba f 0.21 0.14 0.15 1 }
 194     T{ rgba f 0.51 0.39 0.33 1 }
 195     T{ rgba f 0.49 0.33 0.20 1 }
 196     T{ rgba f 0.55 0.45 0.32 1 }
 197     T{ rgba f 0.69 0.63 0.51 1 }
 198     T{ rgba f 0.64 0.39 0.18 1 }
 199     T{ rgba f 0.73 0.42 0.20 1 }
 200     T{ rgba f 0.71 0.45 0.29 1 }
 201     T{ rgba f 0.79 0.45 0.22 1 }
 202     T{ rgba f 0.82 0.56 0.34 1 }
 203     T{ rgba f 0.88 0.72 0.49 1 }
 204     T{ rgba f 0.85 0.69 0.40 1 }
 205     T{ rgba f 0.96 0.92 0.75 1 }
 206     T{ rgba f 0.99 0.98 0.87 1 }
 207     T{ rgba f 0.85 0.82 0.69 1 }
 208     T{ rgba f 0.99 0.98 0.87 1 }
 209     T{ rgba f 0.82 0.82 0.79 1 }
 210     T{ rgba f 0.65 0.69 0.67 1 }
 211     T{ rgba f 0.53 0.60 0.55 1 }
 212     T{ rgba f 0.57 0.53 0.68 1 }
 213     T{ rgba f 0.47 0.42 0.56 1 }
 214 }
 215
 216 : anti-colors ( -- seq ) good-colors <reversed> ;
 217
 218 : color-fraction ( particle -- particle fraction ) dup theta>> pi + 2 pi * / ;
 219
 220 : set-good-color ( particle -- particle )
 221     color-fraction dup 0 1 between?
 222     [ good-colors at-fraction-of >>myc ] [ drop ] if ;
 223
 224 : set-anti-color ( particle -- particle )
 225     color-fraction dup 0 1 between?
 226     [ anti-colors at-fraction-of >>mya ] [ drop ] if ;
 227
 228 TUPLE: muon < particle ;
 229
 230 : <muon> ( -- muon ) muon new initialize-particle ;
 231
 232 M: muon collide
 233
 234   dup center           >>pos
 235   2 32 [a..b] random    >>speed
 236   0.0001 0.001 2random >>speed-d
 237
 238   dup collision-theta  -0.1 0.1 2random + >>theta
 239   0                                    >>theta-d
 240   0                                    >>theta-dd
 241
 242   [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while
 243
 244   set-good-color
 245   set-anti-color
 246
 247   drop ;
 248
 249 M:: muon move ( MUON -- )
 250
 251     MUON bubble-chamber>> size>> first :> WIDTH
 252
 253     MUON
 254
 255     dup myc>> >rgba-components drop 0.16 <rgba> stroke-color set
 256     dup pos>> draw
 257
 258     dup mya>> >rgba-components drop 0.16 <rgba> stroke-color set
 259     dup pos>> first2 [ WIDTH swap - ] dip 2array draw
 260
 261     dup
 262     [ speed>> ] [ theta>> [ sin ] [ cos ] bi 2array ] bi n*v
 263     move-by
 264
 265     step-theta
 266     step-theta-d
 267     step-speed-sub
 268
 269     dup out-of-bounds? [ collide ] [ drop ] if ;
 270
 271 TUPLE: quark < particle ;
 272
 273 : <quark> ( -- quark ) quark new initialize-particle ;
 274
 275 M: quark collide
 276
 277   dup center                             >>pos
 278   dup collision-theta -0.11 0.11 2random +  >>theta
 279   0.5 3.0 2random                        >>speed
 280
 281   0.996 1.001 2random                    >>speed-d
 282   0                                      >>theta-d
 283   0                                      >>theta-dd
 284
 285   [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while
 286
 287   drop ;
 288
 289 M:: quark move ( QUARK -- )
 290
 291     QUARK bubble-chamber>> size>> first :> WIDTH
 292
 293     QUARK
 294
 295     dup myc>> >rgba-components drop 0.13 <rgba> stroke-color set
 296     dup pos>> draw
 297
 298     dup pos>> first2 [ WIDTH swap - ] dip 2array draw
 299
 300     [ ] [ vel>> ] bi move-by
 301
 302     turn
 303
 304     step-theta
 305     step-theta-d
 306     step-speed-mul
 307
 308     1000 random 997 > [
 309         dup speed>> neg    >>speed
 310         2 over speed-d>> - >>speed-d
 311     ] when
 312
 313     dup out-of-bounds? [ collide ] [ drop ] if ;
 314
 315 TUPLE: bubble-chamber < frame-buffer
 316   particles collision-theta size timer ;
 317
 318 M: bubble-chamber graft*
 319     [ timer>> start-timer ] [ call-next-method ] bi ;
 320
 321 M: bubble-chamber ungraft*
 322     [ timer>> stop-timer ] [ call-next-method ] bi ;
 323
 324 ! : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
 325 !     0  2 pi *  0.001  <range>  random >>collision-theta ;
 326
 327 : randomize-collision-theta ( bubble-chamber -- bubble-chamber )
 328     pi neg  pi  0.001 <range> random >>collision-theta ;
 329
 330 : collision-theta ( particle -- theta ) bubble-chamber>> collision-theta>> ;
 331
 332 M: bubble-chamber pref-dim* ( gadget -- dim ) size>> ;
 333
 334 : iterate-particle ( particle -- ) move ;
 335
 336 M:: bubble-chamber update-frame-buffer ( BUBBLE-CHAMBER -- )
 337     BUBBLE-CHAMBER particles>> [ iterate-particle ] each ;
 338
 339 : iterate-system ( bubble-chamber -- ) drop ;
 340
 341 : <bubble-chamber> ( -- bubble-chamber )
 342     bubble-chamber new
 343         { 1000 1000 } >>size
 344         randomize-collision-theta
 345         dup '[ _ dup iterate-system relayout-1 ]
 346         f 10 milliseconds <timer> >>timer ;
 347
 348 : bubble-chamber-window ( -- bubble-chamber )
 349     <bubble-chamber> dup "Bubble Chamber" open-window ;
 350
 351 :: add-particle ( BUBBLE-CHAMBER PARTICLE -- bubble-chamber )
 352     PARTICLE BUBBLE-CHAMBER >>bubble-chamber drop
 353     BUBBLE-CHAMBER [ PARTICLE suffix ] change-particles ;
 354
 355 :: mouse->collision-theta ( BUBBLE-CHAMBER -- BUBBLE-CHAMBER )
 356     mouse
 357     BUBBLE-CHAMBER size>> 2 v/n
 358     v-
 359     first2
 360     fatan2
 361     BUBBLE-CHAMBER collision-theta<<
 362     BUBBLE-CHAMBER ;
 363
 364 :: mouse-pressed ( BUBBLE-CHAMBER -- )
 365     BUBBLE-CHAMBER mouse->collision-theta drop
 366
 367     11 [
 368         BUBBLE-CHAMBER particles>> [ hadron? ] filter random [ collide ] when*
 369         BUBBLE-CHAMBER particles>> [ quark?  ] filter random [ collide ] when*
 370         BUBBLE-CHAMBER particles>> [ muon?   ] filter random [ collide ] when*
 371     ] times ;
 372
 373 bubble-chamber H{
 374     { T{ button-down } [ mouse-pressed ] }
 375 } set-gestures
 376
 377 : collide-random-particle ( bubble-chamber -- bubble-chamber )
 378     dup particles>> random collide ;
 379
 380 : big-bang ( bubble-chamber -- bubble-chamber )
 381     dup particles>> [ collide ] each ;
 382
 383 : collide-one-of-each ( bubble-chamber -- bubble-chamber )
 384     dup
 385     particles>>
 386     [ [ muon?   ] filter random collide ]
 387     [ [ quark?  ] filter random collide ]
 388     [ [ hadron? ] filter random collide ]
 389     tri ;
 390
 391 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 392
 393 : ten-hadrons ( -- )
 394     bubble-chamber-window
 395     10 [ <hadron> add-particle ] times
 396     drop ;
 397
 398 : original ( -- )
 399     bubble-chamber-window
 400
 401     1789 [ <muon>   add-particle ] times
 402     1300 [ <quark>  add-particle ] times
 403     1000 [ <hadron> add-particle ] times
 404      111 [ <axion>  add-particle ] times
 405
 406     particles>>
 407     [ [ muon?   ] filter random collide ]
 408     [ [ quark?  ] filter random collide ]
 409     [ [ hadron? ] filter random collide ]
 410     tri ;
 411
 412 : hadron-chamber ( -- )
 413     bubble-chamber-window
 414     1000 [ <hadron> add-particle ] times
 415     big-bang
 416     drop ;
 417
 418 : quark-chamber ( -- )
 419     bubble-chamber-window
 420     100 [ <quark> add-particle ] times
 421     big-bang
 422     drop ;
 423
 424 : small ( -- )
 425     <bubble-chamber>
 426     { 200 200 } >>size
 427     dup "Bubble Chamber" open-window
 428
 429     42 [ <muon>   add-particle ] times
 430     30 [ <quark>  add-particle ] times
 431     21 [ <hadron> add-particle ] times
 432      7 [ <axion>  add-particle ] times
 433
 434     collide-one-of-each
 435     drop ;
 436
 437 : medium ( -- )
 438     <bubble-chamber>
 439     { 400 400 } >>size
 440     dup "Bubble Chamber" open-window
 441
 442     100 [ <muon>   add-particle ] times
 443      81 [ <quark>  add-particle ] times
 444      60 [ <hadron> add-particle ] times
 445       9 [ <axion>  add-particle ] times
 446
 447     collide-one-of-each
 448     drop ;
 449
 450 : large ( -- )
 451     <bubble-chamber>
 452     { 600 600 } >>size
 453     dup "Bubble Chamber" open-window
 454
 455     550 [ <muon>   add-particle ] times
 456     339 [ <quark>  add-particle ] times
 457     100 [ <hadron> add-particle ] times
 458      11 [ <axion>  add-particle ] times
 459
 460     collide-one-of-each
 461     drop ;
 462
 463 : muon-chamber ( -- )
 464     bubble-chamber-window
 465     1000 [ <muon> add-particle ] times
 466     dup particles>> [ collide randomize-collision-theta ] each
 467     drop ;
 468
 469 : original-big-bang ( -- )
 470     <bubble-chamber>
 471     { 1000 1000 } >>size
 472     dup "Bubble Chamber" open-window
 473
 474     1789 [ <muon>   add-particle ] times
 475     1300 [ <quark>  add-particle ] times
 476     1000 [ <hadron> add-particle ] times
 477      111 [ <axion>  add-particle ] times
 478
 479     big-bang
 480     drop ;
 481
 482 : original-big-bang-variant ( -- )
 483     bubble-chamber-window
 484     1789 [ <muon>   add-particle ] times
 485     1300 [ <quark>  add-particle ] times
 486     1000 [ <hadron> add-particle ] times
 487      111 [ <axion>  add-particle ] times
 488     dup particles>> [ collide randomize-collision-theta ] each
 489     drop ;
 490
 491 MAIN-WINDOW: run-bubble-chamber { { title "Bubble Chamber" } }
 492     <filled-pile> { 2 2 } >>gap {
 493         original small medium large hadron-chamber
 494         quark-chamber muon-chamber ten-hadrons
 495         original-big-bang original-big-bang-variant
 496     } [
 497         [ name>> "-" " " replace >title ]
 498         [ 1quotation [ drop ] prepend ] bi
 499         <border-button> add-gadget
 500     ] each { 2 2 } <border> >>gadgets ;