Merge branch 'master' of git://factorcode.org/git/factor

db4
slava 2008-04-10 22:57:01 -05:00
commit a2c0df8a05
24 changed files with 793 additions and 676 deletions

View File

@ -0,0 +1,88 @@
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

View File

@ -0,0 +1,12 @@
USING: kernel math accessors combinators.cleave vars ;
IN: bubble-chamber.common
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: collision-theta
: dim ( -- dim ) 1000 ;
: center ( -- point ) dim 2 / dup {2} ; foldable

View File

@ -0,0 +1,67 @@
USING: kernel sequences random accessors multi-methods
math math.constants math.ranges math.points combinators.cleave
processing bubble-chamber.common bubble-chamber.particle ;
IN: bubble-chamber.particle.axion
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: axion < particle ;
: <axion> ( -- axion ) axion construct-empty 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 ;

View File

@ -0,0 +1,60 @@
USING: kernel random math math.constants math.points accessors multi-methods
processing
processing.color
bubble-chamber.common
bubble-chamber.particle ;
IN: bubble-chamber.particle.hadron
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: hadron < particle ;
: <hadron> ( -- hadron ) hadron construct-empty 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 <rgb> >>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 ;

View File

@ -0,0 +1,53 @@
USING: kernel sequences math math.constants accessors
processing
processing.color ;
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 ;

View File

@ -0,0 +1,62 @@
USING: kernel arrays sequences random
math
math.ranges
math.functions
math.vectors
multi-methods accessors
combinators.cleave
processing
bubble-chamber.common
bubble-chamber.particle
bubble-chamber.particle.muon.colors ;
IN: bubble-chamber.particle.muon
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: muon < particle ;
: <muon> ( -- muon ) muon construct-empty 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -0,0 +1,68 @@
USING: kernel sequences combinators
math math.vectors math.functions multi-methods
accessors combinators.cleave processing processing.color
bubble-chamber.common ;
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> >>myc
0 0 0 1 <rgba> >>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 ;

View File

@ -0,0 +1,53 @@
USING: kernel arrays sequences random math accessors multi-methods
processing
bubble-chamber.common
bubble-chamber.particle ;
IN: bubble-chamber.particle.quark
TUPLE: quark < particle ;
: <quark> ( -- quark ) quark construct-empty 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 ;

View File

@ -1,5 +0,0 @@
USING: kernel math test namespaces crypto crypto-internals ;
[ 6 ] [ 5 T{ bbs f 590695557939 811977232793 } random-bbs-bits* ] unit-test
[ 792723710536787233474130382522 ] [ 100 T{ bbs f 200352954495 846054538649 } [ random-bbs-bits* drop ] 2keep random-bbs-bits* ] unit-test

View File

@ -18,16 +18,16 @@ TUPLE: mysql-result-set ;
: mysql-error ( mysql -- )
[ mysql_error throw ] when* ;
: mysql-connect ( mysql-connection -- )
new-mysql over set-mysql-db-handle
dup {
mysql-db-handle
mysql-db-host
mysql-db-user
mysql-db-password
mysql-db-db
mysql-db-port
} get-slots f 0 mysql_real_connect mysql-error ;
! : mysql-connect ( mysql-connection -- )
! new-mysql over set-mysql-db-handle
! dup {
! mysql-db-handle
! mysql-db-host
! mysql-db-user
! mysql-db-password
! mysql-db-db
! mysql-db-port
! } get-slots f 0 mysql_real_connect mysql-error ;
! =========================================================
! Low level mysql utility definitions

View File

@ -1,56 +1,109 @@
USING: kernel sequences assocs qualified circular ;
USING: math multi-methods ;
QUALIFIED: sequences
QUALIFIED: assocs
QUALIFIED: circular
IN: newfx
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Now, we can see a new world coming into view.
! A world in which there is the very real prospect of a new world order.
!
! - George Herbert Walker Bush
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: at ( col key -- val )
GENERIC: of ( key col -- val )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nth-at ( seq i -- val ) swap nth ;
: nth-of ( i seq -- val ) nth ;
GENERIC: grab ( col key -- col val )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nth-is ( seq i val -- seq ) swap pick set-nth ;
: is-nth ( seq val i -- seq ) pick set-nth ;
GENERIC: is ( col key val -- col )
GENERIC: as ( col val key -- col )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: nth-is-of ( i val seq -- seq ) dup >r swapd set-nth r> ;
: is-nth-of ( val i seq -- seq ) dup >r set-nth r> ;
GENERIC: is-of ( key val col -- col )
GENERIC: as-of ( val key col -- col )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mutate-nth ( seq i val -- ) swap rot set-nth ;
: mutate-nth-at ( seq val i -- ) rot set-nth ;
: mutate-nth-of ( i val seq -- ) swapd set-nth ;
: mutate-nth-at-of ( val i seq -- ) set-nth ;
GENERIC: mutate-at ( col key val -- )
GENERIC: mutate-as ( col val key -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: at-key ( tbl key -- val ) swap at ;
: key-of ( key tbl -- val ) at ;
GENERIC: at-mutate ( key val col -- )
GENERIC: as-mutate ( val key col -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! sequence
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: at { sequence number } swap nth ;
METHOD: of { number sequence } nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: key-is ( tbl key val -- tbl ) swap pick set-at ;
: is-key ( tbl val key -- tbl ) pick set-at ;
METHOD: grab { sequence number } dupd swap nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: mutate-key ( tbl key val -- ) swap rot set-at ;
: mutate-at-key ( tbl val key -- ) rot set-at ;
METHOD: is { sequence number object } swap pick set-nth ;
METHOD: as { sequence object number } pick set-nth ;
: mutate-key-of ( key val tbl -- ) swapd set-at ;
: mutate-at-key-of ( val key tbl -- ) set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: is-of { number object sequence } dup >r swapd set-nth r> ;
METHOD: as-of { object number sequence } dup >r set-nth r> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: mutate-at { sequence number object } swap rot set-nth ;
METHOD: mutate-as { sequence object number } rot set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: at-mutate { number object sequence } swapd set-nth ;
METHOD: as-mutate { object number sequence } set-nth ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! assoc
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: at { assoc object } swap assocs:at ;
METHOD: of { object assoc } assocs:at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: grab { assoc object } dupd swap assocs:at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: is { assoc object object } swap pick set-at ;
METHOD: as { assoc object object } pick set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: is-of { object object assoc } dup >r swapd set-at r> ;
METHOD: as-of { object object assoc } dup >r set-at r> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: mutate-at { assoc object object } swap rot set-at ;
METHOD: mutate-as { assoc object object } rot set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: at-mutate { object object assoc } swapd set-at ;
METHOD: as-mutate { object object assoc } set-at ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,6 +1,7 @@
USING: alien alien.syntax combinators kernel parser sequences
system words namespaces hashtables init math arrays assocs
continuations ;
IN: opengl.gl.extensions
ERROR: unknown-gl-platform ;
<< {
@ -9,7 +10,6 @@ ERROR: unknown-gl-platform ;
{ [ os unix? ] [ "opengl.gl.unix" ] }
{ [ t ] [ unknown-gl-platform ] }
} cond use+ >>
IN: opengl.gl.extensions
SYMBOL: +gl-function-number-counter+
SYMBOL: +gl-function-pointers+

View File

@ -1,97 +0,0 @@
USING: help.syntax help.markup ;
IN: processing.gallery.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"
{ $subsection "bubble-chamber-introduction" }
{ $subsection "bubble-chamber-particles" }
{ $subsection "bubble-chamber-author" }
{ $subsection "bubble-chamber-running" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-introduction" "Introduction"
"The 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. " ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-particles" "Particles"
"Four types of particles exist. The behavior and graphic appearance of "
"each particle type is unique."
{ $subsection muon }
{ $subsection quark }
{ $subsection hadron }
{ $subsection axion } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-author" "Author"
"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/" } ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ARTICLE: "bubble-chamber-running" "How to use"
"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." ;

View File

@ -1,453 +0,0 @@
USING: kernel namespaces sequences combinators arrays threads
math
math.libm
math.vectors
math.ranges
math.constants
math.functions
math.points
ui
ui.gadgets
random accessors multi-methods
combinators.cleave
vars locals
newfx
processing
processing.gadget
processing.color ;
IN: processing.gallery.bubble-chamber
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-by ( obj delta -- obj ) over pos>> v+ >>pos ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: dim ( -- dim ) 1000 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: collision-theta
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: boom
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VARS: particles muons quarks hadrons axions ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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 }
} ;
: good-color ( i -- color ) good-colors nth-of ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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> >>myc
0 0 0 1 <rgba> >>mya ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
GENERIC: collide ( particle -- )
GENERIC: move ( particle -- )
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: muon < particle ;
: <muon> ( -- muon ) muon construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { muon }
dim 2 / dup 2array >>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
[ dup theta-dd>> abs 0.001 < ]
[ -0.1 0.1 2random >>theta-dd ]
[ ]
while
dup theta>> pi +
2 pi * /
good-colors length 1 - *
[ ] [ good-colors length >= ] [ 0 < ] tri or
[ drop ]
[
[ good-color >>myc ]
[ good-colors length swap - 1 - good-color >>mya ]
bi
]
if
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
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri - >>speed
out-of-bounds?
[ collide ]
[ drop ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: quark < particle ;
: <quark> ( -- quark ) quark construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { quark }
dim 2 / dup 2array >>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
[ dup theta-dd>> abs 0.00001 < ]
[ -0.001 0.001 2random >>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
dup
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
>>vel
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
! 1000 random 997 >
3/1000 chance
[
dup speed>> neg >>speed
2 over speed-d>> - >>speed-d
]
when
out-of-bounds?
[ collide ]
[ drop ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: hadron < particle ;
: <hadron> ( -- hadron ) hadron construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { hadron }
dim 2 / dup 2array >>pos
2 pi * 1random >>theta
0.5 3.5 2random >>speed
0.996 1.001 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ dup theta-dd>> abs 0.00001 < ]
[ -0.001 0.001 2random >>theta-dd ]
[ ]
while
0 1 0 <rgb> >>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
dup
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
>>vel
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
! 1000 random 997 >
3/1000 chance
[
1.0 >>speed-d
0.00001 >>theta-dd
! 100 random 70 >
30/100 chance
[
dim 2 / dup 2array >>pos
dup collide
]
when
]
when
out-of-bounds?
[ collide ]
[ drop ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: axion < particle ;
: <axion> ( -- axion ) axion construct-empty initialize-particle ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: collide { axion }
dim 2 / dup 2array >>pos
2 pi * 1random >>theta
1.0 6.0 2random >>speed
0.998 1.000 2random >>speed-d
0 >>theta-d
0 >>theta-dd
[ dup theta-dd>> abs 0.00001 < ]
[ -0.001 0.001 2random >>theta-dd ]
[ ]
while
drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
METHOD: move { axion }
{ 0.06 0.59 } stroke
dup pos>> point
1 4 [a,b]
[| dy |
1 30 dy 6 * - 255.0 / 2array stroke
dup pos>> 0 dy neg 2array v+ point
] with-locals
each
1 4 [a,b]
[| dy |
0 30 dy 6 * - 255.0 / 2array stroke
dup pos>> dy v+y point
] with-locals
each
dup vel>> move-by
dup
[ speed>> ] [ theta>> { sin cos } <arr> ] bi n*v
>>vel
[ ] [ theta>> ] [ theta-d>> ] tri + >>theta
[ ] [ theta-d>> ] [ theta-dd>> ] tri + >>theta-d
[ ] [ speed>> ] [ speed-d>> ] tri * >>speed
[ ] [ speed-d>> 0.9999 * ] bi >>speed-d
! 1000 random 996 >
4/1000 chance
[
dup speed>> neg >>speed
dup speed-d>> neg 2 + >>speed-d
! 100 random 30 >
70/100 chance
[
dim 2 / dup 2array >>pos
collide
]
[ drop ]
if
]
[ drop ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : draw ( -- )
! boom>
! [ particles> [ move ] each ]
! when ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: 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

View File

@ -8,7 +8,7 @@ USING: kernel namespaces threads combinators sequences arrays
combinators
combinators.lib
combinators.cleave
rewrite-closures fry accessors
rewrite-closures fry accessors newfx
processing.color
processing.gadget ;
@ -28,6 +28,14 @@ IN: processing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! : 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: fill-color
VAR: stroke-color
@ -282,7 +290,7 @@ VAR: frame-rate-value
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
VAR: slate
! VAR: slate
VAR: loop-flag

View File

@ -0,0 +1,28 @@
USING: kernel math tools.test namespaces random
random.blum-blum-shub ;
IN: blum-blum-shub.tests
[ 887708070 ] [
T{ blum-blum-shub f 590695557939 811977232793 } random-32*
] unit-test
[ 887708070 ] [
T{ blum-blum-shub f 590695557939 811977232793 } [
32 random-bits
] with-random
] unit-test
[ 5726770047455156646 ] [
T{ blum-blum-shub f 590695557939 811977232793 } [
64 random-bits
] with-random
] unit-test
[ 3716213681 ]
[
100 T{ blum-blum-shub f 200352954495 846054538649 } tuck [
random-32* drop
] curry times
random-32*
] unit-test

View File

@ -3,34 +3,26 @@ math.miller-rabin combinators.lib
math.functions accessors random ;
IN: random.blum-blum-shub
! TODO: take (log log M) bits instead of 1 bit
! Blum Blum Shub, M = pq
! Blum Blum Shub, n = pq, x_i+1 = x_i ^ 2 mod n
! return low bit of x+1
TUPLE: blum-blum-shub x n ;
C: <blum-blum-shub> blum-blum-shub
<PRIVATE
: generate-bbs-primes ( numbits -- p q )
#! two primes congruent to 3 (mod 4)
[ [ random-prime ] curry [ 4 mod 3 = ] generate ] dup bi ;
IN: crypto
: <blum-blum-shub> ( numbits -- blum-blum-shub )
#! returns a Blum-Blum-Shub tuple
generate-bbs-primes *
[ find-relative-prime ] keep
blum-blum-shub construct-boa ;
! 256 make-bbs blum-blum-shub set-global
: next-bbs-bit ( bbs -- bit )
#! x = x^2 mod n, return low bit of calculated x
[ [ x>> 2 ] [ n>> ] bi ^mod ]
[ [ >>x ] keep x>> 1 bitand ] bi ;
[ [ x>> 2 ] [ n>> ] bi ^mod ] keep
over >>x drop 1 bitand ;
IN: crypto
! : random ( n -- n )
! ! #! Cryptographically secure random number using Blum-Blum-Shub 256
! [ log2 1+ random-bits ] keep dupd >= [ -1 shift ] when ;
PRIVATE>
M: blum-blum-shub random-32* ( bbs -- r )
;
0 32 rot
[ next-bbs-bit swap 1 shift bitor ] curry times ;

View File

@ -0,0 +1,8 @@
IN: tools.vocabs.tests
USING: tools.test tools.vocabs namespaces continuations ;
[ ] [
changed-vocabs get-global
f changed-vocabs set-global
[ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
] unit-test

View File

@ -76,11 +76,11 @@ SYMBOL: changed-vocabs
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
: changed-vocab ( vocab -- )
dup vocab
[ dup changed-vocabs get-global set-at ] [ drop ] if ;
dup vocab changed-vocabs get and
[ dup changed-vocabs get set-at ] [ drop ] if ;
: unchanged-vocab ( vocab -- )
changed-vocabs get-global delete-at ;
changed-vocabs get delete-at ;
: unchanged-vocabs ( vocabs -- )
[ unchanged-vocab ] each ;

View File

@ -1,4 +1,27 @@
IN: ui.tools.interactor.tests
USING: ui.tools.interactor tools.test ;
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
tools.test kernel calendar ;
\ <interactor> must-infer
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
[ ] [ "[ 1 2 3" "interactor" get set-editor-string ] unit-test
[ ] [ <promise> "promise" set ] unit-test
[
"interactor" get stream-read-quot "promise" get fulfill
] "Interactor test" spawn drop
! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test
[ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test
[ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test
[ ] [ "interactor" get evaluate-input ] unit-test
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test

View File

@ -138,7 +138,9 @@ M: interactor stream-read-partial
drop parse-lines-interactive
] [
2nip
dup delegate unexpected-eof? [ drop f ] when
dup parse-error? [
dup error>> unexpected-eof? [ drop f ] when
] when
] recover ;
: handle-interactive ( lines interactor -- quot/f ? )

View File

@ -7,7 +7,7 @@ vectors words windows.kernel32 windows.gdi32 windows.user32
windows.opengl32 windows.messages windows.types windows.nt
windows threads libc combinators continuations command-line
shuffle opengl ui.render unicode.case ascii math.bitfields
locals symbols ;
locals symbols accessors ;
IN: ui.windows
SINGLETON: windows-ui-backend
@ -203,8 +203,18 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
wParam keystroke>gesture <key-up>
hWnd window-focus send-gesture drop ;
: set-window-active ( hwnd uMsg wParam lParam ? -- n )
>r 4dup r> 2nip nip
swap window set-world-active? DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
{
{ [ over SC_MINIMIZE = ] [ f set-window-active ] }
{ [ over SC_RESTORE = ] [ t set-window-active ] }
{ [ over SC_MAXIMIZE = ] [ t set-window-active ] }
{ [ dup alpha? ] [ 4drop 0 ] }
{ [ t ] [ DefWindowProc ] }
} cond ;
: cleanup-window ( handle -- )
dup win-title [ free ] when*

View File

@ -61,6 +61,133 @@ LIBRARY: advapi32
: CRYPT_MACHINE_KEYSET HEX: 20 ; inline
: CRYPT_SILENT HEX: 40 ; inline
C-STRUCT: ACL
{ "BYTE" "AclRevision" }
{ "BYTE" "Sbz1" }
{ "WORD" "AclSize" }
{ "WORD" "AceCount" }
{ "WORD" "Sbz2" } ;
TYPEDEF: ACL* PACL
: ACCESS_ALLOWED_ACE_TYPE 0 ; inline
: ACCESS_DENIED_ACE_TYPE 1 ; inline
: SYSTEM_AUDIT_ACE_TYPE 2 ; inline
: SYSTEM_ALARM_ACE_TYPE 3 ; inline
: OBJECT_INHERIT_ACE HEX: 1 ; inline
: CONTAINER_INHERIT_ACE HEX: 2 ; inline
: NO_PROPAGATE_INHERIT_ACE HEX: 4 ; inline
: INHERIT_ONLY_ACE HEX: 8 ; inline
: VALID_INHERIT_FLAGS HEX: f ; inline
C-STRUCT: ACE_HEADER
{ "BYTE" "AceType" }
{ "BYTE" "AceFlags" }
{ "WORD" "AceSize" } ;
TYPEDEF: ACE_HEADER* PACE_HEADER
C-STRUCT: ACCESS_ALLOWED_ACE
{ "ACE_HEADER" "Header" }
{ "DWORD" "Mask" }
{ "DWORD" "SidStart" } ;
TYPEDEF: ACCESS_ALLOWED_ACE* PACCESS_ALLOWED_ACE
C-STRUCT: ACCESS_DENIED_ACE
{ "ACE_HEADER" "Header" }
{ "DWORD" "Mask" }
{ "DWORD" "SidStart" } ;
TYPEDEF: ACCESS_DENIED_ACE* PACCESS_DENIED_ACE
C-STRUCT: SYSTEM_AUDIT_ACE
{ "ACE_HEADER" "Header" }
{ "DWORD" "Mask" }
{ "DWORD" "SidStart" } ;
TYPEDEF: SYSTEM_AUDIT_ACE* PSYSTEM_AUDIT_ACE
C-STRUCT: SYSTEM_ALARM_ACE
{ "ACE_HEADER" "Header" }
{ "DWORD" "Mask" }
{ "DWORD" "SidStart" } ;
TYPEDEF: SYSTEM_ALARM_ACE* PSYSTEM_ALARM_ACE
C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
{ "ACE_HEADER" "Header" }
{ "DWORD" "Mask" }
{ "DWORD" "SidStart" } ;
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
! typedef enum _TOKEN_INFORMATION_CLASS {
: TokenUser 1 ; inline
: TokenGroups 2 ; inline
: TokenPrivileges 3 ; inline
: TokenOwner 4 ; inline
: TokenPrimaryGroup 5 ; inline
: TokenDefaultDacl 6 ; inline
: TokenSource 7 ; inline
: TokenType 8 ; inline
: TokenImpersonationLevel 9 ; inline
: TokenStatistics 10 ; inline
: TokenRestrictedSids 11 ; inline
: TokenSessionId 12 ; inline
: TokenGroupsAndPrivileges 13 ; inline
: TokenSessionReference 14 ; inline
: TokenSandBoxInert 15 ; inline
! } TOKEN_INFORMATION_CLASS;
: DELETE HEX: 00010000 ; inline
: READ_CONTROL HEX: 00020000 ; inline
: WRITE_DAC HEX: 00040000 ; inline
: WRITE_OWNER HEX: 00080000 ; inline
: SYNCHRONIZE HEX: 00100000 ; inline
: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
: STANDARD_RIGHTS_READ READ_CONTROL ; inline
: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
: TOKEN_DUPLICATE HEX: 0002 ; inline
: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
: TOKEN_IMPERSONATE HEX: 0004 ; inline
: TOKEN_QUERY HEX: 0008 ; inline
: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
: TOKEN_WRITE
{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_DEFAULT
} flags ; foldable
: TOKEN_ALL_ACCESS
{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
TOKEN_DUPLICATE
TOKEN_IMPERSONATE
TOKEN_QUERY
TOKEN_QUERY_SOURCE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_SESSIONID
TOKEN_ADJUST_DEFAULT
} flags ; foldable
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
@ -85,7 +212,7 @@ LIBRARY: advapi32
! : AddAccessDeniedAce ;
! : AddAccessDeniedAceEx ;
! : AddAccessDeniedObjectAce ;
! : AddAce ;
FUNCTION: BOOL AddAce ( PACL pAcl, DWORD dwAceRevision, DWORD dwStartingAceIndex, LPVOID pAceList, DWORD nAceListLength ) ;
! : AddAuditAccessAce ;
! : AddAuditAccessAceEx ;
! : AddAuditAccessObjectAce ;
@ -382,7 +509,7 @@ FUNCTION: BOOL GetUserNameW ( LPCTSTR lpBuffer, LPDWORD lpnSize ) ;
! : ImpersonateLoggedOnUser ;
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
! : InitializeAcl ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
@ -508,70 +635,6 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName,
! : OpenEventLogA ;
! : OpenEventLogW ;
! typedef enum _TOKEN_INFORMATION_CLASS {
: TokenUser 1 ;
: TokenGroups 2 ;
: TokenPrivileges 3 ;
: TokenOwner 4 ;
: TokenPrimaryGroup 5 ;
: TokenDefaultDacl 6 ;
: TokenSource 7 ;
: TokenType 8 ;
: TokenImpersonationLevel 9 ;
: TokenStatistics 10 ;
: TokenRestrictedSids 11 ;
: TokenSessionId 12 ;
: TokenGroupsAndPrivileges 13 ;
: TokenSessionReference 14 ;
: TokenSandBoxInert 15 ;
! } TOKEN_INFORMATION_CLASS;
: DELETE HEX: 00010000 ; inline
: READ_CONTROL HEX: 00020000 ; inline
: WRITE_DAC HEX: 00040000 ; inline
: WRITE_OWNER HEX: 00080000 ; inline
: SYNCHRONIZE HEX: 00100000 ; inline
: STANDARD_RIGHTS_REQUIRED HEX: 000f0000 ; inline
: STANDARD_RIGHTS_READ READ_CONTROL ; inline
: STANDARD_RIGHTS_WRITE READ_CONTROL ; inline
: STANDARD_RIGHTS_EXECUTE READ_CONTROL ; inline
: TOKEN_TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
: TOKEN_ADJUST_GROUPS HEX: 0040 ; inline
: TOKEN_ADJUST_PRIVILEGES HEX: 0020 ; inline
: TOKEN_ADJUST_SESSIONID HEX: 0100 ; inline
: TOKEN_ASSIGN_PRIMARY HEX: 0001 ; inline
: TOKEN_DUPLICATE HEX: 0002 ; inline
: TOKEN_EXECUTE STANDARD_RIGHTS_EXECUTE ; inline
: TOKEN_IMPERSONATE HEX: 0004 ; inline
: TOKEN_QUERY HEX: 0008 ; inline
: TOKEN_QUERY_SOURCE HEX: 0010 ; inline
: TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline
: TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ;
: TOKEN_WRITE
{
STANDARD_RIGHTS_WRITE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_DEFAULT
} flags ; foldable
: TOKEN_ALL_ACCESS
{
STANDARD_RIGHTS_REQUIRED
TOKEN_ASSIGN_PRIMARY
TOKEN_DUPLICATE
TOKEN_IMPERSONATE
TOKEN_QUERY
TOKEN_QUERY_SOURCE
TOKEN_ADJUST_PRIVILEGES
TOKEN_ADJUST_GROUPS
TOKEN_ADJUST_SESSIONID
TOKEN_ADJUST_DEFAULT
} flags ; foldable
FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle,
DWORD DesiredAccess,
PHANDLE TokenHandle ) ;

View File

@ -1001,3 +1001,25 @@ windows-messages set-global
: LM_GETIDEALHEIGHT WM_USER HEX: 0301 + ; inline
: LM_SETITEM WM_USER HEX: 0302 + ; inline
: LM_GETITEM WM_USER HEX: 0303 + ; inline
: WA_INACTIVE 0 ; inline
: WA_ACTIVE 1 ; inline
: WA_CLICKACTIVE 2 ; inline
: SC_SIZE HEX: f000 ; inline
: SC_MOVE HEX: f010 ; inline
: SC_MINIMIZE HEX: f020 ; inline
: SC_MAXIMIZE HEX: f030 ; inline
: SC_NEXTWINDOW HEX: f040 ; inline
: SC_PREVWINDOW HEX: f050 ; inline
: SC_CLOSE HEX: f060 ; inline
: SC_VSCROLL HEX: f070 ; inline
: SC_HSCROLL HEX: f080 ; inline
: SC_MOUSEMENU HEX: f090 ; inline
: SC_KEYMENU HEX: f100 ; inline
: SC_ARRANGE HEX: f110 ; inline
: SC_RESTORE HEX: f120 ; inline
: SC_TASKLIST HEX: f130 ; inline
: SC_SCREENSAVE HEX: f140 ; inline
: SC_HOTKEY HEX: f150 ; inline