Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
31af895821
|
|
@ -1,84 +0,0 @@
|
|||
|
||||
USING: help.syntax help.markup ;
|
||||
|
||||
USING: bubble-chamber.particle.muon
|
||||
bubble-chamber.particle.quark
|
||||
bubble-chamber.particle.hadron
|
||||
bubble-chamber.particle.axion ;
|
||||
|
||||
IN: bubble-chamber
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
HELP: muon
|
||||
|
||||
{ $class-description
|
||||
"The muon is a colorful particle with an entangled friend."
|
||||
"It draws both itself and its horizontally symmetric partner."
|
||||
"A high range of speed and almost no speed decay allow the"
|
||||
"muon to reach the extents of the window, often forming rings"
|
||||
"where theta has decayed but speed remains stable. The result"
|
||||
"is color almost everywhere in the general direction of collision,"
|
||||
"stabilized into fuzzy rings." } ;
|
||||
|
||||
HELP: quark
|
||||
|
||||
{ $class-description
|
||||
"The quark draws as a translucent black. Their large numbers"
|
||||
"create fields of blackness overwritten only by the glowing shadows of "
|
||||
"Hadrons. "
|
||||
"quarks are allowed to accelerate away with speed decay values above 1.0. "
|
||||
"Each quark has an entangled friend. Both particles are drawn identically,"
|
||||
"mirrored along the y-axis." } ;
|
||||
|
||||
HELP: hadron
|
||||
|
||||
{ $class-description
|
||||
"Hadrons collide from totally random directions. "
|
||||
"Those hadrons that do not exit the drawing area, "
|
||||
"tend to stabilize into perfect circular orbits. "
|
||||
"Each hadron draws with a slight glowing emboss. "
|
||||
"The hadron itself is not drawn." } ;
|
||||
|
||||
HELP: axion
|
||||
|
||||
{ $class-description
|
||||
"The axion particle draws a bold black path. Axions exist "
|
||||
"in a slightly higher dimension and as such are drawn with "
|
||||
"elevated embossed shadows. Axions are quick to stabilize "
|
||||
"and fall into single pixel orbits axions automatically "
|
||||
"recollide themselves after stabilizing." } ;
|
||||
|
||||
{ muon quark hadron axion } related-words
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
ARTICLE: "bubble-chamber" "Bubble Chamber"
|
||||
|
||||
"The " { $vocab-link "bubble-chamber" }
|
||||
" is a generative painting system of imaginary "
|
||||
"colliding particles. A single super-massive collision produces a "
|
||||
"discrete universe of four particle types. Particles draw their "
|
||||
"positions over time as pixel exposures.\n"
|
||||
"\n"
|
||||
"Four types of particles exist. The behavior and graphic appearance of "
|
||||
"each particle type is unique.\n"
|
||||
{ $subsection muon }
|
||||
{ $subsection quark }
|
||||
{ $subsection hadron }
|
||||
{ $subsection axion }
|
||||
"\n"
|
||||
"After you run the vocabulary, a window will appear. Click the "
|
||||
"mouse in a random area to fire 11 particles of each type. "
|
||||
"Another way to fire particles is to press the "
|
||||
"spacebar. This fires all the particles.\n"
|
||||
"\n"
|
||||
"Bubble Chamber was created by Jared Tarbell. "
|
||||
"It was originally implemented in Processing. "
|
||||
"It was ported to Factor by Eduardo Cavazos. "
|
||||
"The original work is on display here: "
|
||||
{ $url
|
||||
"http://www.complexification.net/gallery/machines/bubblechamber/" } ;
|
||||
|
||||
ABOUT: "bubble-chamber"
|
||||
|
||||
|
|
@ -1,88 +0,0 @@
|
|||
|
||||
USING: kernel namespaces sequences random math math.constants math.libm vars
|
||||
ui
|
||||
processing
|
||||
processing.gadget
|
||||
bubble-chamber.common
|
||||
bubble-chamber.particle
|
||||
bubble-chamber.particle.muon
|
||||
bubble-chamber.particle.quark
|
||||
bubble-chamber.particle.hadron
|
||||
bubble-chamber.particle.axion ;
|
||||
|
||||
IN: bubble-chamber
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VARS: particles muons quarks hadrons axions ;
|
||||
|
||||
VAR: boom
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: collide-all ( -- )
|
||||
|
||||
2 pi * 1random >collision-theta
|
||||
|
||||
particles> [ collide ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: collide-one ( -- )
|
||||
|
||||
dim 2 / mouse-x - dim 2 / mouse-y - fatan2 >collision-theta
|
||||
|
||||
hadrons> random collide
|
||||
quarks> random collide
|
||||
muons> random collide ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mouse-pressed ( -- )
|
||||
boom on
|
||||
1 background ! kludge
|
||||
11 [ drop collide-one ] each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: key-released ( -- )
|
||||
key " " =
|
||||
[
|
||||
boom on
|
||||
1 background
|
||||
collide-all
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: bubble-chamber ( -- )
|
||||
|
||||
1000 1000 size*
|
||||
|
||||
[
|
||||
1 background
|
||||
no-stroke
|
||||
|
||||
1789 [ drop <muon> ] map >muons
|
||||
1300 [ drop <quark> ] map >quarks
|
||||
1000 [ drop <hadron> ] map >hadrons
|
||||
111 [ drop <axion> ] map >axions
|
||||
|
||||
muons> quarks> hadrons> axions> 3append append >particles
|
||||
|
||||
collide-one
|
||||
] setup
|
||||
|
||||
[
|
||||
boom>
|
||||
[ particles> [ move ] each ]
|
||||
when
|
||||
] draw
|
||||
|
||||
[ mouse-pressed ] button-down
|
||||
[ key-released ] key-up ;
|
||||
|
||||
: go ( -- ) [ bubble-chamber run ] with-ui ;
|
||||
|
||||
MAIN: go
|
||||
|
|
@ -1,12 +0,0 @@
|
|||
|
||||
USING: kernel math accessors combinators.cleave vars ;
|
||||
|
||||
IN: bubble-chamber.common
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: collision-theta
|
||||
|
||||
: dim ( -- dim ) 1000 ;
|
||||
|
||||
: center ( -- point ) dim 2 / dup {2} ; foldable
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
|
||||
USING: kernel sequences random accessors multi-methods
|
||||
math math.constants math.ranges math.points combinators.cleave
|
||||
processing processing.shapes
|
||||
bubble-chamber.common bubble-chamber.particle ;
|
||||
|
||||
IN: bubble-chamber.particle.axion
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: axion < particle ;
|
||||
|
||||
: <axion> ( -- axion ) axion new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: collide { axion }
|
||||
|
||||
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 {2} stroke ;
|
||||
: axion-black ( dy -- dy ) dup 0 swap dy>alpha {2} stroke ;
|
||||
|
||||
: axion-point- ( particle dy -- particle ) >r dup pos>> r> v-y point ;
|
||||
: axion-point+ ( particle dy -- particle ) >r dup pos>> r> v+y point ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: move { axion }
|
||||
|
||||
{ 0.06 0.59 } stroke
|
||||
dup pos>> point
|
||||
|
||||
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 ;
|
||||
|
|
@ -1,59 +0,0 @@
|
|||
|
||||
USING: kernel random math math.constants math.points accessors multi-methods
|
||||
processing processing.shapes
|
||||
bubble-chamber.common
|
||||
bubble-chamber.particle colors ;
|
||||
|
||||
IN: bubble-chamber.particle.hadron
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: hadron < particle ;
|
||||
|
||||
: <hadron> ( -- hadron ) hadron new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: collide { hadron }
|
||||
|
||||
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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: move { hadron }
|
||||
|
||||
{ 1 0.11 } stroke
|
||||
dup pos>> 1 v-y point
|
||||
|
||||
{ 0 0.11 } stroke
|
||||
dup pos>> 1 v+y point
|
||||
|
||||
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
|
||||
|
||||
out-of-bounds? [ collide ] [ drop ] if ;
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
|
||||
USING: kernel sequences math math.constants math.order accessors
|
||||
processing
|
||||
colors ;
|
||||
|
||||
IN: bubble-chamber.particle.muon.colors
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: good-colors ( -- seq )
|
||||
{
|
||||
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 ;
|
||||
|
|
@ -1,63 +0,0 @@
|
|||
|
||||
USING: kernel arrays sequences random
|
||||
math
|
||||
math.ranges
|
||||
math.functions
|
||||
math.vectors
|
||||
multi-methods accessors
|
||||
combinators.cleave
|
||||
processing
|
||||
processing.shapes
|
||||
bubble-chamber.common
|
||||
bubble-chamber.particle
|
||||
bubble-chamber.particle.muon.colors ;
|
||||
|
||||
IN: bubble-chamber.particle.muon
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: muon < particle ;
|
||||
|
||||
: <muon> ( -- muon ) muon new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: collide { muon }
|
||||
|
||||
center >>pos
|
||||
2 32 [a,b] random >>speed
|
||||
0.0001 0.001 2random >>speed-d
|
||||
|
||||
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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: move { muon }
|
||||
|
||||
dup myc>> 0.16 >>alpha stroke
|
||||
dup pos>> point
|
||||
|
||||
dup mya>> 0.16 >>alpha stroke
|
||||
dup pos>> first2 >r dim swap - r> 2array point
|
||||
|
||||
dup
|
||||
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
|
||||
move-by
|
||||
|
||||
step-theta
|
||||
step-theta-d
|
||||
step-speed-sub
|
||||
|
||||
out-of-bounds? [ collide ] [ drop ] if ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,68 +0,0 @@
|
|||
|
||||
USING: kernel sequences combinators
|
||||
math math.vectors math.functions multi-methods
|
||||
accessors combinators.cleave processing
|
||||
bubble-chamber.common colors ;
|
||||
|
||||
IN: bubble-chamber.particle
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: collide ( particle -- )
|
||||
GENERIC: move ( particle -- )
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: particle pos vel speed speed-d theta theta-d theta-dd myc mya ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: initialize-particle ( particle -- particle )
|
||||
|
||||
0 0 {2} >>pos
|
||||
0 0 {2} >>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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: theta-dd-small? ( par limit -- par ? ) >r dup theta-dd>> abs r> < ;
|
||||
|
||||
: random-theta-dd ( par a b -- par ) 2random >>theta-dd ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: turn ( particle -- particle )
|
||||
dup
|
||||
[ speed>> ] [ theta>> { sin cos } <arr> ] 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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: x ( particle -- x ) pos>> first ;
|
||||
: y ( particle -- x ) pos>> second ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: out-of-bounds? ( particle -- particle ? )
|
||||
dup
|
||||
{ [ x dim neg < ] [ x dim 2 * > ] [ y dim neg < ] [ y dim 2 * > ] } cleave
|
||||
or or or ;
|
||||
|
|
@ -1,53 +0,0 @@
|
|||
|
||||
USING: kernel arrays sequences random math accessors multi-methods
|
||||
processing processing.shapes
|
||||
bubble-chamber.common
|
||||
bubble-chamber.particle ;
|
||||
|
||||
IN: bubble-chamber.particle.quark
|
||||
|
||||
TUPLE: quark < particle ;
|
||||
|
||||
: <quark> ( -- quark ) quark new initialize-particle ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: collide { quark }
|
||||
|
||||
center >>pos
|
||||
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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
METHOD: move { quark }
|
||||
|
||||
dup myc>> 0.13 >>alpha stroke
|
||||
dup pos>> point
|
||||
|
||||
dup pos>> first2 >r dim swap - r> 2array point
|
||||
|
||||
[ ] [ 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
|
||||
|
||||
out-of-bounds? [ collide ] [ drop ] if ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
demos
|
||||
|
|
@ -0,0 +1,112 @@
|
|||
|
||||
USING: accessors alien.c-types combinators grouping kernel
|
||||
locals math math.geometry.rect math.vectors opengl.gl sequences
|
||||
ui.gadgets ui.render ;
|
||||
|
||||
IN: frame-buffer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: <frame-buffer> < gadget pixels last-dim ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: update-frame-buffer ( <frame-buffer> -- )
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-frame-buffer-pixels ( frame-buffer -- )
|
||||
dup
|
||||
rect-dim product "uint[4]" <c-array>
|
||||
>>pixels
|
||||
drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: frame-buffer ( -- <frame-buffer> ) <frame-buffer> new-gadget ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: draw-pixels ( FRAME-BUFFER -- )
|
||||
|
||||
FRAME-BUFFER rect-dim first2
|
||||
GL_RGBA
|
||||
GL_UNSIGNED_INT
|
||||
FRAME-BUFFER pixels>>
|
||||
glDrawPixels ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: read-pixels ( FRAME-BUFFER -- )
|
||||
|
||||
0
|
||||
0
|
||||
FRAME-BUFFER rect-dim first2
|
||||
GL_RGBA
|
||||
GL_UNSIGNED_INT
|
||||
FRAME-BUFFER pixels>>
|
||||
glReadPixels ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
:: copy-row ( OLD NEW -- )
|
||||
|
||||
[let | LEN [ OLD NEW min-length ] |
|
||||
|
||||
OLD LEN head-slice 0 NEW copy ] ;
|
||||
|
||||
: copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||
[ 16 * <sliced-groups> ] 2bi@
|
||||
[ copy-row ] 2each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: update-last-dim ( frame-buffer -- ) dup rect-dim >>last-dim drop ;
|
||||
|
||||
M:: <frame-buffer> layout* ( FRAME-BUFFER -- )
|
||||
|
||||
{
|
||||
{
|
||||
[ FRAME-BUFFER last-dim>> f = ]
|
||||
[
|
||||
FRAME-BUFFER init-frame-buffer-pixels
|
||||
|
||||
FRAME-BUFFER update-last-dim
|
||||
]
|
||||
}
|
||||
{
|
||||
[ FRAME-BUFFER [ rect-dim ] [ last-dim>> ] bi = not ]
|
||||
[
|
||||
[let | OLD-PIXELS [ FRAME-BUFFER pixels>> ]
|
||||
OLD-WIDTH [ FRAME-BUFFER last-dim>> first ] |
|
||||
|
||||
FRAME-BUFFER init-frame-buffer-pixels
|
||||
|
||||
FRAME-BUFFER update-last-dim
|
||||
|
||||
[let | NEW-PIXELS [ FRAME-BUFFER pixels>> ]
|
||||
NEW-WIDTH [ FRAME-BUFFER last-dim>> first ] |
|
||||
|
||||
OLD-PIXELS OLD-WIDTH NEW-PIXELS NEW-WIDTH copy-pixels ] ]
|
||||
]
|
||||
}
|
||||
{ [ t ] [ ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M:: <frame-buffer> draw-gadget* ( FRAME-BUFFER -- )
|
||||
|
||||
FRAME-BUFFER rect-dim { 0 1 } v* first2 glRasterPos2i
|
||||
|
||||
FRAME-BUFFER draw-pixels
|
||||
|
||||
FRAME-BUFFER update-frame-buffer
|
||||
|
||||
glFlush
|
||||
|
||||
FRAME-BUFFER read-pixels ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -1,69 +0,0 @@
|
|||
|
||||
USING: kernel namespaces combinators
|
||||
ui.gestures accessors ui.gadgets.frame-buffer ;
|
||||
|
||||
IN: processing.gadget
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: processing-gadget < frame-buffer button-down button-up key-down key-up ;
|
||||
|
||||
: <processing-gadget> ( -- gadget ) processing-gadget new-frame-buffer ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: mouse-pressed-value
|
||||
SYMBOL: key-pressed-value
|
||||
|
||||
SYMBOL: button-value
|
||||
SYMBOL: key-value
|
||||
|
||||
: key-pressed? ( -- ? ) key-pressed-value get ;
|
||||
: mouse-pressed? ( -- ? ) mouse-pressed-value get ;
|
||||
|
||||
: key ( -- key ) key-value get ;
|
||||
: button ( -- val ) button-value get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: processing-gadget handle-gesture ( gesture gadget -- ? )
|
||||
swap
|
||||
{
|
||||
{
|
||||
[ dup key-down? ]
|
||||
[
|
||||
sym>> key-value set
|
||||
key-pressed-value on
|
||||
key-down>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup key-up? ]
|
||||
[
|
||||
key-pressed-value off
|
||||
drop
|
||||
key-up>> dup [ call ] [ drop ] if
|
||||
t
|
||||
] }
|
||||
{
|
||||
[ dup button-down? ]
|
||||
[
|
||||
#>> button-value set
|
||||
mouse-pressed-value on
|
||||
button-down>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup button-up? ]
|
||||
[
|
||||
mouse-pressed-value off
|
||||
drop
|
||||
button-up>> dup [ call ] [ drop ] if
|
||||
t
|
||||
]
|
||||
}
|
||||
{ [ t ] [ 2drop t ] }
|
||||
}
|
||||
cond ;
|
||||
|
|
@ -1,313 +0,0 @@
|
|||
|
||||
USING: kernel namespaces threads combinators sequences arrays
|
||||
math math.functions math.ranges random
|
||||
opengl.gl opengl.glu vars multi-methods generalizations shuffle
|
||||
ui
|
||||
ui.gestures
|
||||
ui.gadgets
|
||||
combinators
|
||||
combinators.lib
|
||||
combinators.cleave
|
||||
rewrite-closures bake bake.fry accessors newfx
|
||||
processing.gadget math.geometry.rect
|
||||
processing.shapes
|
||||
colors ;
|
||||
|
||||
IN: processing
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: 2random ( a b -- num ) 2dup swap - 100 / <range> random ;
|
||||
|
||||
: 1random ( b -- num ) 0 swap 2random ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: chance ( fraction -- ? ) 0 1 2random > ;
|
||||
|
||||
: percent-chance ( percent -- ? ) 100 / chance ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : at-fraction ( seq fraction -- val ) over length 1- * nth-at ;
|
||||
|
||||
: at-fraction ( seq fraction -- val ) over length 1- * at ;
|
||||
|
||||
: at-fraction-of ( fraction seq -- val ) swap at-fraction ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: canonical-color-value ( obj -- color )
|
||||
|
||||
METHOD: canonical-color-value { number } dup dup 1 rgba boa ;
|
||||
|
||||
METHOD: canonical-color-value { array }
|
||||
dup length
|
||||
{
|
||||
{ 2 [ first2 >r dup dup r> rgba boa ] }
|
||||
{ 3 [ first3 1 rgba boa ] }
|
||||
{ 4 [ first4 rgba boa ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
! METHOD: canonical-color-value { rgba }
|
||||
! { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave 4array ;
|
||||
|
||||
METHOD: canonical-color-value { color } ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: fill ( value -- ) canonical-color-value >fill-color ;
|
||||
: stroke ( value -- ) canonical-color-value >stroke-color ;
|
||||
|
||||
! : no-fill ( -- ) 0 fill-color> set-fourth ;
|
||||
! : no-stroke ( -- ) 0 stroke-color> set-fourth ;
|
||||
|
||||
: no-fill ( -- ) fill-color> 0 >>alpha drop ;
|
||||
: no-stroke ( -- ) stroke-color> 0 >>alpha drop ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: stroke-weight ( w -- ) glLineWidth ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : quad-vertices ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
|
||||
! GL_POLYGON glBegin
|
||||
! glVertex2d
|
||||
! glVertex2d
|
||||
! glVertex2d
|
||||
! glVertex2d
|
||||
! glEnd ;
|
||||
|
||||
! : quad ( x1 y1 x2 y2 x3 y3 x4 y4 -- )
|
||||
|
||||
! 8 ndup
|
||||
|
||||
! GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
! fill-color> set-color
|
||||
|
||||
! quad-vertices
|
||||
|
||||
! GL_FRONT_AND_BACK GL_LINE glPolygonMode
|
||||
! stroke-color> set-color
|
||||
|
||||
! quad-vertices ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! : ellipse-disk ( x y width height -- )
|
||||
! glPushMatrix
|
||||
! >r >r
|
||||
! 0 glTranslated
|
||||
! r> r> 1 glScaled
|
||||
! gluNewQuadric
|
||||
! dup 0 0.5 20 1 gluDisk
|
||||
! gluDeleteQuadric
|
||||
! glPopMatrix ;
|
||||
|
||||
! : ellipse-center ( x y width height -- )
|
||||
|
||||
! 4dup
|
||||
|
||||
! GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
! stroke-color> set-color
|
||||
|
||||
! ellipse-disk
|
||||
|
||||
! GL_FRONT_AND_BACK GL_FILL glPolygonMode
|
||||
! fill-color> set-color
|
||||
|
||||
! [ 2 - ] bi@ ! [ stroke-width 1+ - ] bi@
|
||||
|
||||
! ellipse-disk ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! SYMBOL: CENTER
|
||||
! SYMBOL: RADIUS
|
||||
! SYMBOL: CORNER
|
||||
! SYMBOL: CORNERS
|
||||
|
||||
! SYMBOL: ellipse-mode-value
|
||||
|
||||
! : ellipse-mode ( val -- ) ellipse-mode-value set ;
|
||||
|
||||
! : ellipse-radius ( x y hori vert -- ) [ 2 * ] bi@ ellipse-center ;
|
||||
|
||||
! : ellipse-corner ( x y width height -- )
|
||||
! [ drop nip 2 / + ] 4keep
|
||||
! [ nip rot drop 2 / + ] 4keep
|
||||
! [ >r >r 2drop r> r> ] 4keep
|
||||
! 4drop
|
||||
! ellipse-center ;
|
||||
|
||||
! : ellipse-corners ( x1 y1 x2 y2 -- )
|
||||
! [ drop nip + 2 / ] 4keep
|
||||
! [ nip rot drop + 2 / ] 4keep
|
||||
! [ drop nip - abs 1+ ] 4keep
|
||||
! [ nip rot drop - abs 1+ ] 4keep
|
||||
! 4drop
|
||||
! ellipse-center ;
|
||||
|
||||
! : ellipse ( a b c d -- )
|
||||
! ellipse-mode-value get
|
||||
! {
|
||||
! { CENTER [ ellipse-center ] }
|
||||
! { RADIUS [ ellipse-radius ] }
|
||||
! { CORNER [ ellipse-corner ] }
|
||||
! { CORNERS [ ellipse-corners ] }
|
||||
! }
|
||||
! case ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
GENERIC: background ( value -- )
|
||||
|
||||
METHOD: background { number }
|
||||
dup dup 1 glClearColor
|
||||
GL_COLOR_BUFFER_BIT glClear ;
|
||||
|
||||
METHOD: background { array }
|
||||
dup length
|
||||
{
|
||||
{ 2 [ first2 >r dup dup r> glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||
{ 3 [ first3 1 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||
{ 4 [ first4 glClearColor GL_COLOR_BUFFER_BIT glClear ] }
|
||||
}
|
||||
case ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: translate ( x y -- ) 0 glTranslated ;
|
||||
|
||||
: rotate ( angle -- ) 0 0 1 glRotated ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: mouse ( -- point ) hand-loc get ;
|
||||
|
||||
: mouse-x ( -- x ) mouse first ;
|
||||
: mouse-y ( -- y ) mouse second ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
VAR: frame-rate-value
|
||||
|
||||
: frame-rate ( fps -- ) 1000 swap / >frame-rate-value ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! VAR: slate
|
||||
|
||||
VAR: loop-flag
|
||||
|
||||
: defaults ( -- )
|
||||
0.8 background
|
||||
! CENTER ellipse-mode
|
||||
60 frame-rate ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: size-val
|
||||
|
||||
: size ( seq -- ) size-val set ;
|
||||
|
||||
: size* ( width height -- ) 2array size-val set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: setup-action
|
||||
SYMBOL: draw-action
|
||||
|
||||
! : setup ( quot -- ) closed-quot setup-action set ;
|
||||
! : draw ( quot -- ) closed-quot draw-action set ;
|
||||
|
||||
: setup ( quot -- ) setup-action set ;
|
||||
: draw ( quot -- ) draw-action set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: key-down-action
|
||||
SYMBOL: key-up-action
|
||||
|
||||
: key-down ( quot -- ) closed-quot key-down-action set ;
|
||||
: key-up ( quot -- ) closed-quot key-up-action set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: button-down-action
|
||||
SYMBOL: button-up-action
|
||||
|
||||
: button-down ( quot -- ) closed-quot button-down-action set ;
|
||||
: button-up ( quot -- ) closed-quot button-up-action set ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: start-processing-thread ( -- )
|
||||
loop-flag get not
|
||||
[
|
||||
loop-flag on
|
||||
[
|
||||
[ loop-flag get ]
|
||||
processing-gadget get frame-rate-value> '[ , relayout-1 , sleep ]
|
||||
[ ]
|
||||
while
|
||||
]
|
||||
in-thread
|
||||
]
|
||||
when ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: get-size ( -- size ) processing-gadget get rect-dim ;
|
||||
|
||||
: width ( -- width ) get-size first ;
|
||||
: height ( -- height ) get-size second ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
SYMBOL: setup-called
|
||||
|
||||
: setup-called? ( -- ? ) setup-called get ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: run ( -- )
|
||||
|
||||
loop-flag off
|
||||
|
||||
500 sleep
|
||||
|
||||
<processing-gadget>
|
||||
size-val get >>pdim
|
||||
dup "Processing" open-window
|
||||
|
||||
500 sleep
|
||||
|
||||
defaults
|
||||
|
||||
setup-called off
|
||||
|
||||
[
|
||||
setup-called? not
|
||||
[
|
||||
setup-action get call
|
||||
setup-called on
|
||||
]
|
||||
[
|
||||
draw-action get call
|
||||
]
|
||||
if
|
||||
]
|
||||
closed-quot >>action
|
||||
|
||||
key-down-action get >>key-down
|
||||
key-up-action get >>key-up
|
||||
|
||||
button-down-action get >>button-down
|
||||
button-up-action get >>button-up
|
||||
|
||||
processing-gadget set
|
||||
|
||||
start-processing-thread ;
|
||||
|
|
@ -1,115 +0,0 @@
|
|||
|
||||
USING: kernel alien.c-types combinators sequences splitting grouping
|
||||
opengl.gl ui.gadgets ui.render
|
||||
math math.vectors accessors math.geometry.rect ;
|
||||
|
||||
IN: ui.gadgets.frame-buffer
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
TUPLE: frame-buffer < gadget action pdim last-dim graft ungraft pixels ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: init-frame-buffer-pixels ( frame-buffer -- frame-buffer )
|
||||
dup
|
||||
rect-dim product "uint[4]" <c-array>
|
||||
>>pixels ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: new-frame-buffer ( class -- gadget )
|
||||
new-gadget
|
||||
[ ] >>action
|
||||
{ 100 100 } >>pdim
|
||||
[ ] >>graft
|
||||
[ ] >>ungraft ;
|
||||
|
||||
: <frame-buffer> ( -- frame-buffer ) frame-buffer new-frame-buffer ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: draw-pixels ( fb -- fb )
|
||||
dup >r
|
||||
dup >r
|
||||
rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glDrawPixels
|
||||
r> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: read-pixels ( fb -- fb )
|
||||
dup >r
|
||||
dup >r
|
||||
>r
|
||||
0 0 r> rect-dim first2 GL_RGBA GL_UNSIGNED_INT r> pixels>> glReadPixels
|
||||
r> ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: frame-buffer pref-dim* pdim>> ;
|
||||
M: frame-buffer graft* graft>> call ;
|
||||
M: frame-buffer ungraft* ungraft>> call ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
: copy-row ( old new -- )
|
||||
2dup min-length swap >r head-slice 0 r> copy ;
|
||||
|
||||
! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||
! [ group ] 2bi@
|
||||
! [ copy-row ] 2each ;
|
||||
|
||||
! : copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||
! [ 16 * group ] 2bi@
|
||||
! [ copy-row ] 2each ;
|
||||
|
||||
: copy-pixels ( old-pixels old-width new-pixels new-width -- )
|
||||
[ 16 * <sliced-groups> ] 2bi@
|
||||
[ copy-row ] 2each ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: frame-buffer layout* ( fb -- )
|
||||
{
|
||||
{
|
||||
[ dup last-dim>> f = ]
|
||||
[
|
||||
init-frame-buffer-pixels
|
||||
dup
|
||||
rect-dim >>last-dim
|
||||
drop
|
||||
]
|
||||
}
|
||||
{
|
||||
[ dup [ rect-dim ] [ last-dim>> ] bi = not ]
|
||||
[
|
||||
dup [ pixels>> ] [ last-dim>> first ] bi
|
||||
|
||||
rot init-frame-buffer-pixels
|
||||
dup rect-dim >>last-dim
|
||||
|
||||
[ pixels>> ] [ rect-dim first ] bi
|
||||
|
||||
copy-pixels
|
||||
]
|
||||
}
|
||||
{ [ t ] [ drop ] }
|
||||
}
|
||||
cond ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
M: frame-buffer draw-gadget* ( fb -- )
|
||||
|
||||
dup rect-dim { 0 1 } v* first2 glRasterPos2i
|
||||
|
||||
draw-pixels
|
||||
|
||||
dup action>> call
|
||||
|
||||
glFlush
|
||||
|
||||
read-pixels
|
||||
|
||||
drop ;
|
||||
|
||||
Loading…
Reference in New Issue