Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
dbac0a1543
build-support
core
continuations
definitions
generic/standard
io/files
threads
vocabs/loader
extra
bubble-chamber
common
particle
axion
hadron
muon
colors
quark
concurrency
core-foundation/fsevents
crypto/test
db/mysql/lib
help/cookbook
io
timeouts
unix
backend
bsd
kqueue
linux
monitors
macosx
select
newfx
opengl/gl/extensions
processing
gallery/bubble-chamber
random/blum-blum-shub
tools
ui
tools/interactor
windows
windows
advapi32
messages
|
|
@ -89,6 +89,11 @@ set_md5sum() {
|
|||
set_gcc() {
|
||||
case $OS in
|
||||
openbsd) ensure_program_installed egcc; CC=egcc;;
|
||||
netbsd) if [[ $WORD -eq 64 ]] ; then
|
||||
CC=/usr/pkg/gcc34/bin/gcc
|
||||
else
|
||||
CC=gcc
|
||||
fi ;;
|
||||
*) CC=gcc;;
|
||||
esac
|
||||
}
|
||||
|
|
@ -185,6 +190,7 @@ find_architecture() {
|
|||
i386) ARCH=x86;;
|
||||
i686) ARCH=x86;;
|
||||
amd64) ARCH=x86;;
|
||||
ppc64) ARCH=ppc;;
|
||||
*86) ARCH=x86;;
|
||||
*86_64) ARCH=x86;;
|
||||
"Power Macintosh") ARCH=ppc;;
|
||||
|
|
|
|||
|
|
@ -90,7 +90,11 @@ ABOUT: "continuations"
|
|||
|
||||
HELP: dispose
|
||||
{ $values { "object" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. No further operations can be performed on a disposable object after this call. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on."
|
||||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." } ;
|
||||
|
||||
HELP: with-disposal
|
||||
|
|
|
|||
|
|
@ -2,26 +2,6 @@ IN: definitions.tests
|
|||
USING: tools.test generic kernel definitions sequences
|
||||
compiler.units words ;
|
||||
|
||||
TUPLE: combination-1 ;
|
||||
|
||||
M: combination-1 perform-combination drop [ ] define ;
|
||||
|
||||
M: combination-1 make-default-method 2drop [ "No method" throw ] ;
|
||||
|
||||
SYMBOL: generic-1
|
||||
|
||||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
object \ generic-1 create-method [ ] define
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
[
|
||||
{ combination-1 { object generic-1 } } forget-all
|
||||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
GENERIC: some-generic ( a -- b )
|
||||
|
||||
USE: arrays
|
||||
|
|
|
|||
|
|
@ -110,6 +110,9 @@ ERROR: no-next-method class generic ;
|
|||
\ if ,
|
||||
] [ ] make ;
|
||||
|
||||
: single-effective-method ( obj word -- method )
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
|
@ -142,8 +145,7 @@ M: standard-combination next-method-quot*
|
|||
] with-standard ;
|
||||
|
||||
M: standard-generic effective-method
|
||||
[ dispatch# (picker) call ] keep
|
||||
[ order [ instance? ] with find-last nip ] keep method ;
|
||||
[ dispatch# (picker) call ] keep single-effective-method ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
|
|
@ -161,6 +163,10 @@ M: hook-combination dispatch# drop 0 ;
|
|||
|
||||
M: hook-generic extra-values drop 1 ;
|
||||
|
||||
M: hook-generic effective-method
|
||||
[ "combination" word-prop var>> get ] keep
|
||||
single-effective-method ;
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
|
||||
|
|
|
|||
|
|
@ -112,8 +112,7 @@ ARTICLE: "io.files" "Basic file operations"
|
|||
{ $subsection "file-streams" }
|
||||
{ $subsection "fs-meta" }
|
||||
{ $subsection "directories" }
|
||||
{ $subsection "delete-move-copy" }
|
||||
{ $see-also "os" } ;
|
||||
{ $subsection "delete-move-copy" } ;
|
||||
|
||||
ABOUT: "io.files"
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
IN: threads
|
||||
USING: arrays hashtables heaps kernel kernel.private math
|
||||
namespaces sequences vectors continuations continuations.private
|
||||
dlists assocs system combinators init boxes ;
|
||||
dlists assocs system combinators init boxes accessors ;
|
||||
|
||||
SYMBOL: initial-thread
|
||||
|
||||
|
|
@ -18,11 +18,10 @@ mailbox variables sleep-entry ;
|
|||
|
||||
! Thread-local storage
|
||||
: tnamespace ( -- assoc )
|
||||
self dup thread-variables
|
||||
[ ] [ H{ } clone dup rot set-thread-variables ] ?if ;
|
||||
self variables>> [ H{ } clone dup self (>>variables) ] unless* ;
|
||||
|
||||
: tget ( key -- value )
|
||||
self thread-variables at ;
|
||||
self variables>> at ;
|
||||
|
||||
: tset ( value key -- )
|
||||
tnamespace set-at ;
|
||||
|
|
@ -35,7 +34,7 @@ mailbox variables sleep-entry ;
|
|||
: thread ( id -- thread ) threads at ;
|
||||
|
||||
: thread-registered? ( thread -- ? )
|
||||
thread-id threads key? ;
|
||||
id>> threads key? ;
|
||||
|
||||
: check-unregistered
|
||||
dup thread-registered?
|
||||
|
|
@ -48,38 +47,37 @@ mailbox variables sleep-entry ;
|
|||
<PRIVATE
|
||||
|
||||
: register-thread ( thread -- )
|
||||
check-unregistered dup thread-id threads set-at ;
|
||||
check-unregistered dup id>> threads set-at ;
|
||||
|
||||
: unregister-thread ( thread -- )
|
||||
check-registered thread-id threads delete-at ;
|
||||
check-registered id>> threads delete-at ;
|
||||
|
||||
: set-self ( thread -- ) 40 setenv ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <thread> ( quot name -- thread )
|
||||
\ thread counter <box> [ ] {
|
||||
set-thread-quot
|
||||
set-thread-name
|
||||
set-thread-id
|
||||
set-thread-continuation
|
||||
set-thread-exit-handler
|
||||
} \ thread construct ;
|
||||
\ thread construct-empty
|
||||
swap >>name
|
||||
swap >>quot
|
||||
\ thread counter >>id
|
||||
<box> >>continuation
|
||||
[ ] >>exit-handler ;
|
||||
|
||||
: run-queue 42 getenv ;
|
||||
|
||||
: sleep-queue 43 getenv ;
|
||||
|
||||
: resume ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-front ;
|
||||
|
||||
: resume-now ( thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered run-queue push-back ;
|
||||
|
||||
: resume-with ( obj thread -- )
|
||||
f over set-thread-state
|
||||
f >>state
|
||||
check-registered 2array run-queue push-front ;
|
||||
|
||||
: sleep-time ( -- ms/f )
|
||||
|
|
@ -93,14 +91,14 @@ PRIVATE>
|
|||
|
||||
: schedule-sleep ( thread ms -- )
|
||||
>r check-registered dup r> sleep-queue heap-push*
|
||||
swap set-thread-sleep-entry ;
|
||||
>>sleep-entry drop ;
|
||||
|
||||
: expire-sleep? ( heap -- ? )
|
||||
dup heap-empty?
|
||||
[ drop f ] [ heap-peek nip millis <= ] if ;
|
||||
|
||||
: expire-sleep ( thread -- )
|
||||
f over set-thread-sleep-entry resume ;
|
||||
f >>sleep-entry resume ;
|
||||
|
||||
: expire-sleep-loop ( -- )
|
||||
sleep-queue
|
||||
|
|
@ -123,21 +121,21 @@ PRIVATE>
|
|||
] [
|
||||
pop-back
|
||||
dup array? [ first2 ] [ f swap ] if dup set-self
|
||||
f over set-thread-state
|
||||
thread-continuation box>
|
||||
f >>state
|
||||
continuation>> box>
|
||||
continue-with
|
||||
] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: stop ( -- )
|
||||
self dup thread-exit-handler call
|
||||
self dup exit-handler>> call
|
||||
unregister-thread next ;
|
||||
|
||||
: suspend ( quot state -- obj )
|
||||
[
|
||||
self thread-continuation >box
|
||||
self set-thread-state
|
||||
self continuation>> >box
|
||||
self (>>state)
|
||||
self swap call next
|
||||
] callcc1 2nip ; inline
|
||||
|
||||
|
|
@ -157,9 +155,9 @@ M: real sleep
|
|||
millis + >integer sleep-until ;
|
||||
|
||||
: interrupt ( thread -- )
|
||||
dup thread-state [
|
||||
dup thread-sleep-entry [ sleep-queue heap-delete ] when*
|
||||
f over set-thread-sleep-entry
|
||||
dup state>> [
|
||||
dup sleep-entry>> [ sleep-queue heap-delete ] when*
|
||||
f >>sleep-entry
|
||||
dup resume
|
||||
] when drop ;
|
||||
|
||||
|
|
@ -171,7 +169,7 @@ M: real sleep
|
|||
V{ } set-catchstack
|
||||
{ } set-retainstack
|
||||
>r { } set-datastack r>
|
||||
thread-quot [ call stop ] call-clear
|
||||
quot>> [ call stop ] call-clear
|
||||
] 1 (throw)
|
||||
] "spawn" suspend 2drop ;
|
||||
|
||||
|
|
@ -196,8 +194,8 @@ GENERIC: error-in-thread ( error thread -- )
|
|||
<min-heap> 43 setenv
|
||||
initial-thread global
|
||||
[ drop f "Initial" <thread> ] cache
|
||||
<box> over set-thread-continuation
|
||||
f over set-thread-state
|
||||
<box> >>continuation
|
||||
f >>state
|
||||
dup register-thread
|
||||
set-self ;
|
||||
|
||||
|
|
|
|||
|
|
@ -110,6 +110,8 @@ IN: vocabs.loader.tests
|
|||
] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
[ ] [ "vocabs.loader.test.b" changed-vocab ] unit-test
|
||||
|
||||
[ ] [ "vocabs.loader.test.b" refresh ] unit-test
|
||||
|
||||
[ 3 ] [ "count-me" get-global ] unit-test
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -57,7 +57,7 @@ HELP: mailbox-get?
|
|||
|
||||
|
||||
ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error."
|
||||
"A " { $emphasis "mailbox" } " is a first-in-first-out queue where the operation of removing an element blocks if the queue is empty, instead of throwing an error. Mailboxes are implemented in the " { $vocab-link "concurrency.mailboxes" } " vocabulary."
|
||||
{ $subsection mailbox }
|
||||
{ $subsection <mailbox> }
|
||||
"Removing the first element:"
|
||||
|
|
@ -73,3 +73,5 @@ ARTICLE: "concurrency.mailboxes" "Mailboxes"
|
|||
"Testing if a mailbox is empty:"
|
||||
{ $subsection mailbox-empty? }
|
||||
{ $subsection while-mailbox-empty } ;
|
||||
|
||||
ABOUT: "concurrency.mailboxes"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
IN: concurrency.mailboxes.tests
|
||||
USING: concurrency.mailboxes vectors sequences threads
|
||||
tools.test math kernel strings ;
|
||||
USING: concurrency.mailboxes concurrency.count-downs vectors
|
||||
sequences threads tools.test math kernel strings namespaces
|
||||
continuations calendar ;
|
||||
|
||||
[ V{ 1 2 3 } ] [
|
||||
0 <vector>
|
||||
|
|
@ -38,3 +39,37 @@ tools.test math kernel strings ;
|
|||
"junk2" over mailbox-put
|
||||
mailbox-get
|
||||
] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
[ "m" get mailbox-get drop ]
|
||||
[ drop "d" get count-down ] recover
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
<mailbox> "m" set
|
||||
|
||||
1 <count-down> "c" set
|
||||
1 <count-down> "d" set
|
||||
|
||||
[
|
||||
"c" get await
|
||||
"m" get wait-for-close
|
||||
"d" get count-down
|
||||
] "Mailbox close test" spawn drop
|
||||
|
||||
[ ] [ "c" get count-down ] unit-test
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
[ ] [ "d" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,41 +3,50 @@
|
|||
IN: concurrency.mailboxes
|
||||
USING: dlists threads sequences continuations
|
||||
namespaces random math quotations words kernel arrays assocs
|
||||
init system concurrency.conditions ;
|
||||
init system concurrency.conditions accessors ;
|
||||
|
||||
TUPLE: mailbox threads data ;
|
||||
TUPLE: mailbox threads data closed ;
|
||||
|
||||
: check-closed ( mailbox -- )
|
||||
closed>> [ "Mailbox closed" throw ] when ; inline
|
||||
|
||||
M: mailbox dispose
|
||||
t >>closed threads>> notify-all ;
|
||||
|
||||
: <mailbox> ( -- mailbox )
|
||||
<dlist> <dlist> mailbox construct-boa ;
|
||||
<dlist> <dlist> f mailbox construct-boa ;
|
||||
|
||||
: mailbox-empty? ( mailbox -- bool )
|
||||
mailbox-data dlist-empty? ;
|
||||
data>> dlist-empty? ;
|
||||
|
||||
: mailbox-put ( obj mailbox -- )
|
||||
[ mailbox-data push-front ] keep
|
||||
mailbox-threads notify-all yield ;
|
||||
[ data>> push-front ]
|
||||
[ threads>> notify-all ] bi yield ;
|
||||
|
||||
: wait-for-mailbox ( mailbox timeout -- )
|
||||
>r threads>> r> "mailbox" wait ;
|
||||
|
||||
: block-unless-pred ( mailbox timeout pred -- )
|
||||
pick mailbox-data over dlist-contains? [
|
||||
pick check-closed
|
||||
pick data>> over dlist-contains? [
|
||||
3drop
|
||||
] [
|
||||
>r over mailbox-threads over "mailbox" wait r>
|
||||
block-unless-pred
|
||||
>r 2dup wait-for-mailbox r> block-unless-pred
|
||||
] if ; inline
|
||||
|
||||
: block-if-empty ( mailbox timeout -- mailbox )
|
||||
over check-closed
|
||||
over mailbox-empty? [
|
||||
over mailbox-threads over "mailbox" wait
|
||||
block-if-empty
|
||||
2dup wait-for-mailbox block-if-empty
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: mailbox-peek ( mailbox -- obj )
|
||||
mailbox-data peek-back ;
|
||||
data>> peek-back ;
|
||||
|
||||
: mailbox-get-timeout ( mailbox timeout -- obj )
|
||||
block-if-empty mailbox-data pop-back ;
|
||||
block-if-empty data>> pop-back ;
|
||||
|
||||
: mailbox-get ( mailbox -- obj )
|
||||
f mailbox-get-timeout ;
|
||||
|
|
@ -45,7 +54,7 @@ TUPLE: mailbox threads data ;
|
|||
: mailbox-get-all-timeout ( mailbox timeout -- array )
|
||||
block-if-empty
|
||||
[ dup mailbox-empty? ]
|
||||
[ dup mailbox-data pop-back ]
|
||||
[ dup data>> pop-back ]
|
||||
[ ] unfold nip ;
|
||||
|
||||
: mailbox-get-all ( mailbox -- array )
|
||||
|
|
@ -60,11 +69,18 @@ TUPLE: mailbox threads data ;
|
|||
|
||||
: mailbox-get-timeout? ( mailbox timeout pred -- obj )
|
||||
3dup block-unless-pred
|
||||
nip >r mailbox-data r> delete-node-if ; inline
|
||||
nip >r data>> r> delete-node-if ; inline
|
||||
|
||||
: mailbox-get? ( mailbox pred -- obj )
|
||||
f swap mailbox-get-timeout? ; inline
|
||||
|
||||
: wait-for-close-timeout ( mailbox timeout -- )
|
||||
over closed>>
|
||||
[ 2drop ] [ 2dup wait-for-mailbox wait-for-close-timeout ] if ;
|
||||
|
||||
: wait-for-close ( mailbox -- )
|
||||
f wait-for-close-timeout ;
|
||||
|
||||
TUPLE: linked-error thread ;
|
||||
|
||||
: <linked-error> ( error thread -- linked )
|
||||
|
|
|
|||
|
|
@ -32,7 +32,7 @@ HELP: spawn-linked
|
|||
{ $description "Start a thread which runs the given quotation. If that quotation throws an error which is not caught then the error will get propagated to the thread that spawned it. This can be used to set up 'supervisor' threades that restart child threades that crash due to uncaught errors.\n" }
|
||||
{ $see-also spawn } ;
|
||||
|
||||
ARTICLE: { "concurrency" "messaging" } "Mailboxes"
|
||||
ARTICLE: { "concurrency" "messaging" } "Sending and receiving messages"
|
||||
"Each thread has an associated mailbox. Other threads can place items on this queue by sending the thread a message. A thread can check its mailbox for messages, blocking if none are pending, and thread them as they are queued."
|
||||
$nl
|
||||
"The messages that are sent from thread to thread are any Factor value. Factor tuples are ideal for this sort of thing as you can send a tuple to a thread and the generic word dispatch mechanism can be used to perform actions depending on what the type of the tuple is."
|
||||
|
|
@ -43,7 +43,8 @@ $nl
|
|||
{ $subsection receive }
|
||||
{ $subsection receive-timeout }
|
||||
{ $subsection receive-if }
|
||||
{ $subsection receive-if-timeout } ;
|
||||
{ $subsection receive-if-timeout }
|
||||
{ $see-also "concurrency.mailboxes" } ;
|
||||
|
||||
ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
|
||||
"The " { $link send } " word sends a message asynchronously, and the sending thread continues immediately. It is also possible to send a message to a thread and block until a response is received:"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
!
|
||||
USING: kernel threads vectors arrays sequences
|
||||
namespaces tools.test continuations dlists strings math words
|
||||
match quotations concurrency.messaging concurrency.mailboxes ;
|
||||
match quotations concurrency.messaging concurrency.mailboxes
|
||||
concurrency.count-downs ;
|
||||
IN: concurrency.messaging.tests
|
||||
|
||||
[ ] [ my-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||
|
|
@ -52,4 +53,15 @@ SYMBOL: exit
|
|||
[ value , self , ] { } make "counter" get send
|
||||
receive
|
||||
exit "counter" get send
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
! Not yet
|
||||
|
||||
! 1 <count-down> "c" set
|
||||
|
||||
! [
|
||||
! "c" get count-down
|
||||
! receive drop
|
||||
! ] "Bad synchronous send" spawn "t" set
|
||||
|
||||
! [ 3 "t" get send-synchronous ] must-fail
|
||||
|
|
@ -151,12 +151,10 @@ SYMBOL: event-stream-callbacks
|
|||
|
||||
[
|
||||
event-stream-callbacks global
|
||||
[ [ drop expired? not ] assoc-subset ] change-at
|
||||
[ [ drop expired? not ] assoc-subset H{ } assoc-like ] change-at
|
||||
1 \ event-stream-counter set-global
|
||||
] "core-foundation" add-init-hook
|
||||
|
||||
event-stream-callbacks global [ H{ } assoc-like ] change-at
|
||||
|
||||
: add-event-source-callback ( quot -- id )
|
||||
event-stream-counter <alien>
|
||||
[ event-stream-callbacks get set-at ] keep ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -224,7 +224,7 @@ $nl
|
|||
":errors - print 2 compiler errors."
|
||||
":warnings - print 50 compiler warnings."
|
||||
}
|
||||
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erronous stack effect declarations."
|
||||
"These warnings arise from the compiler's stack effect checker. Warnings are non-fatal conditions -- not all code has a static stack effect, so you try to minimize warnings but understand that in many cases they cannot be eliminated. Errors indicate programming mistakes, such as erroneous stack effect declarations."
|
||||
{ $references
|
||||
"To learn more about the compiler and static stack effect inference, read these articles:"
|
||||
"compiler"
|
||||
|
|
@ -259,7 +259,7 @@ $nl
|
|||
{ $code "#! /usr/bin/env factor -script" }
|
||||
"Running the text file will run it through Factor, assuming the " { $snippet "factor" } " binary is in your " { $snippet "$PATH" } "."
|
||||
$nl
|
||||
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch supresses compiler messages, and exits Factor when the script finishes."
|
||||
"The space between " { $snippet "#!" } " and " { $snippet "/usr/bin/env" } " is necessary, since " { $link POSTPONE: #! } " is a parsing word, and a syntax error would otherwise result. The " { $snippet "-script" } " switch suppresses compiler messages, and exits Factor when the script finishes."
|
||||
{ $references
|
||||
{ }
|
||||
"cli"
|
||||
|
|
@ -273,7 +273,7 @@ $nl
|
|||
$nl
|
||||
"Keep the following guidelines in mind to avoid losing your sense of balance:"
|
||||
{ $list
|
||||
"SImplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
|
||||
"Simplify, simplify, simplify. Break your program up into small words which operate on a few values at a time. Most word definitions should fit on a single line; very rarely should they exceed two or three lines."
|
||||
"In addition to keeping your words short, keep them meaningful. Give them good names, and make sure each word only does one thing. Try documenting your words; if the documentation for a word is unclear or complex, chances are the word definition is too. Don't be afraid to refactor your code."
|
||||
"If your code looks repetitive, factor it some more."
|
||||
"If after factoring, your code still looks repetitive, introduce combinators."
|
||||
|
|
@ -285,7 +285,7 @@ $nl
|
|||
"Every time you define a word which simply manipulates sequences, hashtables or objects in an abstract way which is not related to your program domain, check the library to see if you can reuse an existing definition."
|
||||
{ "Learn to use the " { $link "inference" } " tool." }
|
||||
{ "Write unit tests. Factor provides good support for unit testing; see " { $link "tools.test" } ". Once your program has a good test suite you can refactor with confidence and catch regressions early." }
|
||||
"Don't write Factor as if it were C. Imperitive programming and indexed loops are almost always not the most idiomatic solution."
|
||||
"Don't write Factor as if it were C. Imperative programming and indexed loops are almost always not the most idiomatic solution."
|
||||
{ "Use sequences, assocs and objects to group related data. Object allocation is very cheap. Don't be afraid to create tuples, pairs and triples. Don't be afraid of operations which allocate new objects either, such as " { $link append } "." }
|
||||
{ "If you find yourself writing a loop with a sequence and an index, there's almost always a better way. Learn the " { $link "sequences-combinators" } " by heart." }
|
||||
{ "If you find yourself writing a heavily nested loop which performs several steps on each iteration, there is almost always a better way. Break the problem down into a series of passes over the data instead, gradually transforming it into the desired result with a series of simple loops. Factor the loops out and reuse them. If you're working on anything math-related, learn " { $link "math-vectors" } " by heart." }
|
||||
|
|
@ -312,7 +312,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
|
|||
$nl
|
||||
"Unit tests for the " { $vocab-link "inference" } " vocabulary can be used to ensure that any methods your vocabulary defines on core generic words have static stack effects:"
|
||||
{ $code "\"inference\" test" }
|
||||
"In general, you should strive to write code with inferrable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
|
||||
"In general, you should strive to write code with inferable stack effects, even for sections of a program which are not performance sensitive; the " { $link infer. } " tool together with the optimizing compiler's error reporting can catch many bugs ahead of time." }
|
||||
{ "Be careful when calling words which access variables from a " { $link make-assoc } " which constructs an assoc with arbitrary keys, since those keys might shadow variables." }
|
||||
{ "If " { $link run-file } " throws a stack depth assertion, it means that the top-level form in the file left behind values on the stack. The stack depth is compared before and after loading a source file, since this type of situation is almost always an error. If you have a legitimate need to load a source file which returns data in some manner, define a word in the source file which produces this data on the stack and call the word after loading the file." }
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -1,58 +1,108 @@
|
|||
IN: io.monitors
|
||||
USING: help.markup help.syntax continuations ;
|
||||
USING: help.markup help.syntax continuations
|
||||
concurrency.mailboxes quotations ;
|
||||
|
||||
HELP: with-monitors
|
||||
{ $values { "quot" quotation } }
|
||||
{ $description "Calls a quotation in a new dynamic scope where file system monitor operations can be performed." }
|
||||
{ $errors "Throws an error if the platform does not support file system change monitors." } ;
|
||||
|
||||
HELP: <monitor>
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "monitor" "a new monitor" } }
|
||||
{ $description "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported."
|
||||
$nl
|
||||
"Not all operating systems support recursive monitors; if recursive monitoring is not available, an error is thrown and the caller must implement alternative logic for monitoring subdirectories." } ;
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: (monitor)
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "mailbox" mailbox } { "monitor" "a new monitor" } }
|
||||
{ $contract "Opens a file system change monitor which listens for changes on " { $snippet "path" } " and posts notifications to " { $snippet "mailbox" } " as triples with shape " { $snippet "{ path changed monitor } " } ". The boolean indicates whether changes in subdirectories should be reported." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: next-change
|
||||
{ $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changed" "a change descriptor" } }
|
||||
{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ;
|
||||
{ $contract "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is a sequence of symbols documented in " { $link "io.monitors.descriptors" } "." }
|
||||
{ $errors "Throws an error if the monitor is closed from another thread." } ;
|
||||
|
||||
HELP: with-monitor
|
||||
{ $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } }
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." } ;
|
||||
{ $description "Opens a file system change monitor and passes it to the quotation. Closes the monitor after the quotation returns or throws an error." }
|
||||
{ $errors "Throws an error if the pathname does not exist, if a monitor could not be created or if the platform does not support monitors." } ;
|
||||
|
||||
HELP: +add-file+
|
||||
{ $description "Indicates that the file has been added to the directory." } ;
|
||||
{ $description "Indicates that a file has been added to its parent directory." } ;
|
||||
|
||||
HELP: +remove-file+
|
||||
{ $description "Indicates that the file has been removed from the directory." } ;
|
||||
{ $description "Indicates that a file has been removed from its parent directory." } ;
|
||||
|
||||
HELP: +modify-file+
|
||||
{ $description "Indicates that the file contents have changed." } ;
|
||||
{ $description "Indicates that a file's contents have changed." } ;
|
||||
|
||||
HELP: +rename-file-old+
|
||||
{ $description "Indicates that a file has been renamed, and this is the old name." } ;
|
||||
|
||||
HELP: +rename-file-new+
|
||||
{ $description "Indicates that a file has been renamed, and this is the new name." } ;
|
||||
|
||||
HELP: +rename-file+
|
||||
{ $description "Indicates that file has been renamed." } ;
|
||||
{ $description "Indicates that a file has been renamed." } ;
|
||||
|
||||
ARTICLE: "io.monitors.descriptors" "File system change descriptors"
|
||||
"Change descriptors output by " { $link next-change } ":"
|
||||
{ $subsection +add-file+ }
|
||||
{ $subsection +remove-file+ }
|
||||
{ $subsection +modify-file+ }
|
||||
{ $subsection +rename-file+ }
|
||||
{ $subsection +add-file+ } ;
|
||||
{ $subsection +rename-file-old+ }
|
||||
{ $subsection +rename-file-new+ }
|
||||
{ $subsection +rename-file+ } ;
|
||||
|
||||
ARTICLE: "io.monitors.platforms" "Monitors on different platforms"
|
||||
"Whether the " { $snippet "path" } " output value of " { $link next-change } " contains an absolute path or a path relative to the path given to " { $link <monitor> } " is platform-specific. User code should not assume either case."
|
||||
{ $heading "Mac OS X" }
|
||||
"Factor uses " { $snippet "FSEventStream" } "s to implement monitors on Mac OS X. This requires Mac OS X 10.5 or later."
|
||||
$nl
|
||||
{ $snippet "FSEventStream" } "s always monitor directory hierarchies recursively, and the " { $snippet "recursive?" } " parameter to " { $link <monitor> } " has no effect."
|
||||
$nl
|
||||
"The " { $snippet "changed" } " output value of the " { $link next-change } " word always outputs " { $link +modify-file+ } " and the " { $snippet "path" } " output value is always the directory containing the file that changed. Unlike other platforms, fine-grained information is not available."
|
||||
{ $heading "Windows" }
|
||||
"Factor uses " { $snippet "ReadDirectoryChanges" } " to implement monitors on Windows."
|
||||
$nl
|
||||
"Both recursive and non-recursive monitors are directly supported by the operating system."
|
||||
{ $heading "Linux" }
|
||||
"Factor uses " { $snippet "inotify" } " to implement monitors on Linux. This requires Linux kernel version 2.6.16 or later."
|
||||
$nl
|
||||
"Factor simulates recursive monitors by creating a hierarchy of monitors for every subdirectory, since " { $snippet "inotify" } " can only monitor a single directory. This is transparent to user code."
|
||||
$nl
|
||||
"Inside a single " { $link with-monitors } " scope, only one monitor may be created for any given directory."
|
||||
{ $heading "BSD" }
|
||||
"Factor uses " { $snippet "kqueue" } " to implement monitors on BSD."
|
||||
$nl
|
||||
"The " { $snippet "kqueue" } " system is limited to monitoring individual files and directories. Monitoring a directory only notifies of files being added and removed to the directory itself, not of changes to file contents."
|
||||
{ $heading "Windows CE" }
|
||||
"Windows CE does not support monitors." ;
|
||||
|
||||
ARTICLE: "io.monitors" "File system change monitors"
|
||||
"File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored."
|
||||
$nl
|
||||
"Monitoring operations must be wrapped in a combinator:"
|
||||
{ $subsection with-monitors }
|
||||
"Creating a file system change monitor and listening for changes:"
|
||||
{ $subsection <monitor> }
|
||||
{ $subsection next-change }
|
||||
"An alternative programming style is where instead of having a thread listen for changes on a monitor, change notifications are posted to a mailbox:"
|
||||
{ $subsection (monitor) }
|
||||
{ $subsection "io.monitors.descriptors" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "."
|
||||
$nl
|
||||
"A utility combinator which opens a monitor and cleans it up after:"
|
||||
{ $subsection "io.monitors.platforms" }
|
||||
"Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } ". An easy way to pair construction with disposal is to use a combinator:"
|
||||
{ $subsection with-monitor }
|
||||
"An example which watches the Factor directory for changes:"
|
||||
"Monitors support the " { $link "io.timeouts" } "."
|
||||
$nl
|
||||
"An example which watches a directory for changes:"
|
||||
{ $code
|
||||
"USE: io.monitors"
|
||||
": watch-loop ( monitor -- )"
|
||||
" dup next-change . . nl nl flush watch-loop ;"
|
||||
""
|
||||
"\"\" resource-path f [ watch-loop ] with-monitor"
|
||||
": watch-directory ( path -- )"
|
||||
" [ t [ watch-loop ] with-monitor ] with-monitors"
|
||||
} ;
|
||||
|
||||
ABOUT: "io.monitors"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,91 @@
|
|||
IN: io.monitors.tests
|
||||
USING: io.monitors tools.test io.files system sequences
|
||||
continuations namespaces concurrency.count-downs kernel io
|
||||
threads calendar prettyprint ;
|
||||
|
||||
os { winnt linux macosx } member? [
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/a1" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/a2" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/a1" temp-file "monitor-test/a2" temp-file move-file-into ] unit-test
|
||||
|
||||
[ t ] [ "monitor-test/a2/a1" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/a2/a1/a3.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ t ] [ "monitor-test/a2/a1/a3.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file touch-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a4.txt" temp-file delete-file ] unit-test
|
||||
[ ] [ "monitor-test/a2/a1/a5.txt" temp-file "monitor-test/a2/a1/a4.txt" temp-file move-file ] unit-test
|
||||
|
||||
[ t ] [ "monitor-test/a2/a1/a4.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
|
||||
|
||||
[
|
||||
[ "monitor-test" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "monitor-test/xyz" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test" temp-file t <monitor> "m" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "b" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c1" set ] unit-test
|
||||
|
||||
[ ] [ 1 <count-down> "c2" set ] unit-test
|
||||
|
||||
[ ] [
|
||||
[
|
||||
"b" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "xyz" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c1" get count-down
|
||||
|
||||
[
|
||||
"m" get next-change drop
|
||||
dup print flush
|
||||
dup parent-directory
|
||||
[ right-trim-separators "yxy" tail? ] either? not
|
||||
] [ ] [ ] while
|
||||
|
||||
"c2" get count-down
|
||||
] "Monitor test thread" spawn drop
|
||||
] unit-test
|
||||
|
||||
[ ] [ "b" get await ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c1" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
|
||||
|
||||
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
|
||||
|
||||
[ ] [ "c2" get 5 seconds await-timeout ] unit-test
|
||||
|
||||
! Dispose twice
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
] when
|
||||
|
|
@ -1,82 +1,50 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend kernel continuations namespaces sequences
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts ;
|
||||
assocs hashtables sorting arrays threads boxes io.timeouts
|
||||
accessors concurrency.mailboxes ;
|
||||
IN: io.monitors
|
||||
|
||||
<PRIVATE
|
||||
HOOK: init-monitors io-backend ( -- )
|
||||
|
||||
TUPLE: monitor queue closed? ;
|
||||
HOOK: dispose-monitors io-backend ( -- )
|
||||
|
||||
: check-monitor ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: (monitor) ( delegate -- monitor )
|
||||
H{ } clone {
|
||||
set-delegate
|
||||
set-monitor-queue
|
||||
} monitor construct ;
|
||||
|
||||
GENERIC: fill-queue ( monitor -- )
|
||||
|
||||
: changed-file ( changed path -- )
|
||||
namespace [ append ] change-at ;
|
||||
|
||||
: dequeue-change ( assoc -- path changes )
|
||||
delete-any prune natural-sort >array ;
|
||||
|
||||
M: monitor dispose
|
||||
dup check-monitor
|
||||
t over set-monitor-closed?
|
||||
delegate dispose ;
|
||||
|
||||
! Simple monitor; used on Linux and Mac OS X. On Windows,
|
||||
! monitors are full-fledged ports.
|
||||
TUPLE: simple-monitor handle callback timeout ;
|
||||
|
||||
M: simple-monitor timeout simple-monitor-timeout ;
|
||||
|
||||
M: simple-monitor set-timeout set-simple-monitor-timeout ;
|
||||
|
||||
: <simple-monitor> ( handle -- simple-monitor )
|
||||
f (monitor) <box> {
|
||||
set-simple-monitor-handle
|
||||
set-delegate
|
||||
set-simple-monitor-callback
|
||||
} simple-monitor construct ;
|
||||
|
||||
: construct-simple-monitor ( handle class -- simple-monitor )
|
||||
>r <simple-monitor> r> construct-delegate ; inline
|
||||
|
||||
: notify-callback ( simple-monitor -- )
|
||||
simple-monitor-callback [ resume ] if-box? ;
|
||||
|
||||
M: simple-monitor timed-out
|
||||
notify-callback ;
|
||||
|
||||
M: simple-monitor fill-queue ( monitor -- )
|
||||
: with-monitors ( quot -- )
|
||||
[
|
||||
[ swap simple-monitor-callback >box ]
|
||||
"monitor" suspend drop
|
||||
] with-timeout
|
||||
check-monitor ;
|
||||
init-monitors
|
||||
[ dispose-monitors ] [ ] cleanup
|
||||
] with-scope ; inline
|
||||
|
||||
M: simple-monitor dispose ( monitor -- )
|
||||
dup delegate dispose notify-callback ;
|
||||
TUPLE: monitor < identity-tuple path queue timeout ;
|
||||
|
||||
PRIVATE>
|
||||
M: monitor hashcode* path>> hashcode* ;
|
||||
|
||||
HOOK: <monitor> io-backend ( path recursive? -- monitor )
|
||||
M: monitor timeout timeout>> ;
|
||||
|
||||
M: monitor set-timeout (>>timeout) ;
|
||||
|
||||
: construct-monitor ( path mailbox class -- monitor )
|
||||
construct-empty
|
||||
swap >>queue
|
||||
swap >>path ; inline
|
||||
|
||||
: queue-change ( path changes monitor -- )
|
||||
3dup and and
|
||||
[ [ 3array ] keep queue>> mailbox-put ] [ 3drop ] if ;
|
||||
|
||||
HOOK: (monitor) io-backend ( path recursive? mailbox -- monitor )
|
||||
|
||||
: <monitor> ( path recursive? -- monitor )
|
||||
<mailbox> (monitor) ;
|
||||
|
||||
: next-change ( monitor -- path changed )
|
||||
dup check-monitor
|
||||
dup monitor-queue dup assoc-empty? [
|
||||
drop dup fill-queue next-change
|
||||
] [ nip dequeue-change ] if ;
|
||||
[ queue>> ] [ timeout ] bi mailbox-get-timeout first2 ;
|
||||
|
||||
SYMBOL: +add-file+
|
||||
SYMBOL: +remove-file+
|
||||
SYMBOL: +modify-file+
|
||||
SYMBOL: +rename-file-old+
|
||||
SYMBOL: +rename-file-new+
|
||||
SYMBOL: +rename-file+
|
||||
|
||||
: with-monitor ( path recursive? quot -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,59 @@
|
|||
USING: accessors math kernel namespaces continuations
|
||||
io.files io.monitors io.monitors.recursive io.backend
|
||||
concurrency.mailboxes
|
||||
tools.test ;
|
||||
IN: io.monitors.recursive.tests
|
||||
|
||||
\ pump-thread must-infer
|
||||
|
||||
SINGLETON: mock-io-backend
|
||||
|
||||
TUPLE: counter i ;
|
||||
|
||||
SYMBOL: dummy-monitor-created
|
||||
SYMBOL: dummy-monitor-disposed
|
||||
|
||||
TUPLE: dummy-monitor < monitor ;
|
||||
|
||||
M: dummy-monitor dispose
|
||||
drop dummy-monitor-disposed get [ 1+ ] change-i drop ;
|
||||
|
||||
M: mock-io-backend (monitor)
|
||||
nip
|
||||
over exists? [
|
||||
dummy-monitor construct-monitor
|
||||
dummy-monitor-created get [ 1+ ] change-i drop
|
||||
] [
|
||||
"Does not exist" throw
|
||||
] if ;
|
||||
|
||||
M: mock-io-backend link-info
|
||||
global [ link-info ] bind ;
|
||||
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-created set ] unit-test
|
||||
[ ] [ 0 counter construct-boa dummy-monitor-disposed set ] unit-test
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> 0 > ] unit-test
|
||||
|
||||
[ t ] [ dummy-monitor-created get i>> dummy-monitor-disposed get i>> = ] unit-test
|
||||
|
||||
[ "doesnotexist" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[
|
||||
mock-io-backend io-backend [
|
||||
"doesnotexist" temp-file <mailbox> <recursive-monitor> dispose
|
||||
] with-variable
|
||||
] must-fail
|
||||
|
||||
[ ] [
|
||||
mock-io-backend io-backend [
|
||||
"" resource-path <mailbox> <recursive-monitor>
|
||||
[ dispose ] [ dispose ] bi
|
||||
] with-variable
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors sequences assocs arrays continuations combinators kernel
|
||||
threads concurrency.messaging concurrency.mailboxes
|
||||
concurrency.promises
|
||||
io.files io.monitors ;
|
||||
IN: io.monitors.recursive
|
||||
|
||||
! Simulate recursive monitors on platforms that don't have them
|
||||
|
||||
TUPLE: recursive-monitor < monitor children thread ready ;
|
||||
|
||||
DEFER: add-child-monitor
|
||||
|
||||
: qualify-path ( path -- path' )
|
||||
monitor tget path>> prepend-path ;
|
||||
|
||||
: add-child-monitors ( path -- )
|
||||
#! We yield since this directory scan might take a while.
|
||||
[
|
||||
directory* [ first add-child-monitor yield ] each
|
||||
] curry ignore-errors ;
|
||||
|
||||
: add-child-monitor ( path -- )
|
||||
qualify-path dup link-info type>> +directory+ eq? [
|
||||
[ add-child-monitors ]
|
||||
[
|
||||
[ f my-mailbox (monitor) ] keep
|
||||
monitor tget children>> set-at
|
||||
] bi
|
||||
] [ drop ] if ;
|
||||
|
||||
USE: io
|
||||
USE: prettyprint
|
||||
|
||||
: remove-child-monitor ( monitor -- )
|
||||
monitor tget children>> delete-at*
|
||||
[ dispose ] [ drop ] if ;
|
||||
|
||||
M: recursive-monitor dispose
|
||||
dup queue>> closed>> [
|
||||
drop
|
||||
] [
|
||||
[ "stop" swap thread>> send-synchronous drop ]
|
||||
[ queue>> dispose ] bi
|
||||
] if ;
|
||||
|
||||
: stop-pump ( -- )
|
||||
monitor tget children>> [ nip dispose ] assoc-each ;
|
||||
|
||||
: pump-step ( msg -- )
|
||||
first3 path>> swap >r prepend-path r> monitor tget 3array
|
||||
monitor tget queue>>
|
||||
mailbox-put ;
|
||||
|
||||
: child-added ( path monitor -- )
|
||||
path>> prepend-path add-child-monitor ;
|
||||
|
||||
: child-removed ( path monitor -- )
|
||||
path>> prepend-path remove-child-monitor ;
|
||||
|
||||
: update-hierarchy ( msg -- )
|
||||
first3 swap [
|
||||
{
|
||||
{ +add-file+ [ child-added ] }
|
||||
{ +remove-file+ [ child-removed ] }
|
||||
{ +rename-file-old+ [ child-removed ] }
|
||||
{ +rename-file-new+ [ child-added ] }
|
||||
[ 3drop ]
|
||||
} case
|
||||
] with with each ;
|
||||
|
||||
: pump-loop ( -- )
|
||||
receive dup synchronous? [
|
||||
>r stop-pump t r> reply-synchronous
|
||||
] [
|
||||
[ [ update-hierarchy ] curry ignore-errors ] [ pump-step ] bi
|
||||
pump-loop
|
||||
] if ;
|
||||
|
||||
: monitor-ready ( error/t -- )
|
||||
monitor tget ready>> fulfill ;
|
||||
|
||||
: pump-thread ( monitor -- )
|
||||
monitor tset
|
||||
[ "" add-child-monitor t monitor-ready ]
|
||||
[ [ self <linked-error> monitor-ready ] keep rethrow ]
|
||||
recover
|
||||
pump-loop ;
|
||||
|
||||
: start-pump-thread ( monitor -- )
|
||||
dup [ pump-thread ] curry
|
||||
"Recursive monitor pump" spawn
|
||||
>>thread drop ;
|
||||
|
||||
: wait-for-ready ( monitor -- )
|
||||
ready>> ?promise ?linked drop ;
|
||||
|
||||
: <recursive-monitor> ( path mailbox -- monitor )
|
||||
>r (normalize-path) r>
|
||||
recursive-monitor construct-monitor
|
||||
H{ } clone >>children
|
||||
<promise> >>ready
|
||||
dup start-pump-thread
|
||||
dup wait-for-ready ;
|
||||
|
|
@ -18,13 +18,13 @@ HELP: with-timeout
|
|||
{ $description "Applies the quotation to the object. If the object's timeout expires before the quotation returns, " { $link timed-out } " is called on the object." } ;
|
||||
|
||||
ARTICLE: "io.timeouts" "I/O timeout protocol"
|
||||
"Streams and processes support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
"Streams, processes and monitors support optional timeouts, which impose an upper bound on the length of time for which an operation on these objects can block. Timeouts are used in network servers to prevent malicious clients from holding onto connections forever, and to ensure that runaway processes get killed."
|
||||
{ $subsection timeout }
|
||||
{ $subsection set-timeout }
|
||||
"The I/O timeout protocol can be implemented by any class wishing to support timeouts on blocking operations."
|
||||
{ $subsection timed-out }
|
||||
"A combinator to be used in operations which can time out:"
|
||||
{ $subsection with-timeout }
|
||||
{ $see-also "stream-protocol" "io.launcher" } ;
|
||||
{ $see-also "stream-protocol" "io.launcher" "io.monitors" } ;
|
||||
|
||||
ABOUT: "io.timeouts"
|
||||
|
|
|
|||
|
|
@ -203,3 +203,6 @@ M: mx-task do-io-task
|
|||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,22 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
IN: io.unix.bsd
|
||||
USING: io.backend io.unix.backend io.unix.select
|
||||
namespaces system ;
|
||||
USING: namespaces system kernel accessors assocs continuations
|
||||
unix
|
||||
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
|
||||
|
||||
M: bsd init-io ( -- )
|
||||
<select-mx> mx set-global ;
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task>
|
||||
dup io-task-fd
|
||||
[ mx get-global reads>> set-at ]
|
||||
[ mx get-global writes>> set-at ] 2bi ;
|
||||
|
||||
M: bsd init-monitors ;
|
||||
|
||||
M: bsd dispose-monitors ;
|
||||
|
||||
M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
<vnode-monitor> ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
sequences assocs unix unix.time unix.kqueue unix.process math namespaces
|
||||
combinators threads vectors io.launcher
|
||||
io.unix.launcher ;
|
||||
USING: alien.c-types kernel math math.bitfields namespaces
|
||||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
TUPLE: kqueue-mx events ;
|
||||
TUPLE: kqueue-mx events monitors ;
|
||||
|
||||
: max-events ( -- n )
|
||||
#! We read up to 256 events at a time. This is an arbitrary
|
||||
|
|
@ -15,8 +17,9 @@ TUPLE: kqueue-mx events ;
|
|||
|
||||
: <kqueue-mx> ( -- mx )
|
||||
kqueue-mx construct-mx
|
||||
kqueue dup io-error over set-mx-fd
|
||||
max-events "kevent" <c-array> over set-kqueue-mx-events ;
|
||||
H{ } clone >>monitors
|
||||
kqueue dup io-error >>fd
|
||||
max-events "kevent" <c-array> >>events ;
|
||||
|
||||
GENERIC: io-task-filter ( task -- n )
|
||||
|
||||
|
|
@ -24,14 +27,19 @@ M: input-task io-task-filter drop EVFILT_READ ;
|
|||
|
||||
M: output-task io-task-filter drop EVFILT_WRITE ;
|
||||
|
||||
GENERIC: io-task-fflags ( task -- n )
|
||||
|
||||
M: io-task io-task-fflags drop 0 ;
|
||||
|
||||
: make-kevent ( task flags -- event )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
over io-task-fd over set-kevent-ident
|
||||
over io-task-fflags over set-kevent-fflags
|
||||
swap io-task-filter over set-kevent-filter ;
|
||||
|
||||
: register-kevent ( kevent mx -- )
|
||||
mx-fd swap 1 f 0 f kevent
|
||||
fd>> swap 1 f 0 f kevent
|
||||
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
|
||||
|
||||
M: kqueue-mx register-io-task ( task mx -- )
|
||||
|
|
@ -43,33 +51,52 @@ M: kqueue-mx unregister-io-task ( task mx -- )
|
|||
swap EV_DELETE make-kevent swap register-kevent ;
|
||||
|
||||
: wait-kevent ( mx timespec -- n )
|
||||
>r dup mx-fd f 0 roll kqueue-mx-events max-events r> kevent
|
||||
>r [ fd>> f 0 ] keep events>> max-events r> kevent
|
||||
dup multiplexer-error ;
|
||||
|
||||
: kevent-read-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
:: kevent-read-task ( mx fd kevent -- )
|
||||
mx fd mx reads>> at handle-io-task ;
|
||||
|
||||
: kevent-write-task ( mx fd -- )
|
||||
over mx-reads at handle-io-task ;
|
||||
:: kevent-write-task ( mx fd kevent -- )
|
||||
mx fd mx writes>> at handle-io-task ;
|
||||
|
||||
: kevent-proc-task ( pid -- )
|
||||
dup wait-for-pid swap find-process
|
||||
:: kevent-proc-task ( mx pid kevent -- )
|
||||
pid wait-for-pid
|
||||
pid find-process
|
||||
dup [ swap notify-exit ] [ 2drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
NOTE_DELETE +remove-file+ ?flag
|
||||
NOTE_WRITE +modify-file+ ?flag
|
||||
NOTE_EXTEND +modify-file+ ?flag
|
||||
NOTE_ATTRIB +modify-file+ ?flag
|
||||
NOTE_RENAME +rename-file+ ?flag
|
||||
NOTE_REVOKE +remove-file+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
:: kevent-vnode-task ( mx kevent fd -- )
|
||||
""
|
||||
kevent kevent-fflags parse-action
|
||||
fd mx monitors>> at queue-change ;
|
||||
|
||||
: handle-kevent ( mx kevent -- )
|
||||
dup kevent-ident swap kevent-filter {
|
||||
[ ] [ kevent-ident ] [ kevent-filter ] tri {
|
||||
{ [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
|
||||
{ [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task drop ] }
|
||||
{ [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
|
||||
{ [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
|
||||
} cond ;
|
||||
|
||||
: handle-kevents ( mx n -- )
|
||||
[ over kqueue-mx-events kevent-nth handle-kevent ] with each ;
|
||||
[ over events>> kevent-nth handle-kevent ] with each ;
|
||||
|
||||
M: kqueue-mx wait-for-events ( ms mx -- )
|
||||
swap dup [ make-timespec ] when
|
||||
dupd wait-kevent handle-kevents ;
|
||||
|
||||
! Procs
|
||||
: make-proc-kevent ( pid -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-ident
|
||||
|
|
@ -77,5 +104,44 @@ M: kqueue-mx wait-for-events ( ms mx -- )
|
|||
EVFILT_PROC over set-kevent-filter
|
||||
NOTE_EXIT over set-kevent-fflags ;
|
||||
|
||||
: add-pid-task ( pid mx -- )
|
||||
: register-pid-task ( pid mx -- )
|
||||
swap make-proc-kevent swap register-kevent ;
|
||||
|
||||
! VNodes
|
||||
TUPLE: vnode-monitor < monitor fd ;
|
||||
|
||||
: vnode-fflags ( -- n )
|
||||
{
|
||||
NOTE_DELETE
|
||||
NOTE_WRITE
|
||||
NOTE_EXTEND
|
||||
NOTE_ATTRIB
|
||||
NOTE_LINK
|
||||
NOTE_RENAME
|
||||
NOTE_REVOKE
|
||||
} flags ;
|
||||
|
||||
: make-vnode-kevent ( fd flags -- kevent )
|
||||
"kevent" <c-object>
|
||||
tuck set-kevent-flags
|
||||
tuck set-kevent-ident
|
||||
EVFILT_VNODE over set-kevent-filter
|
||||
vnode-fflags over set-kevent-fflags ;
|
||||
|
||||
: register-monitor ( monitor mx -- )
|
||||
>r dup fd>> r>
|
||||
[ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
|
||||
[ monitors>> set-at ] 3bi ;
|
||||
|
||||
: unregister-monitor ( monitor mx -- )
|
||||
>r fd>> r>
|
||||
[ monitors>> delete-at ]
|
||||
[ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
|
||||
|
||||
: <vnode-monitor> ( path mailbox -- monitor )
|
||||
>r [ O_RDONLY 0 open dup io-error ] keep r>
|
||||
vnode-monitor construct-monitor swap >>fd
|
||||
[ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
|
||||
|
||||
M: vnode-monitor dispose
|
||||
[ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;
|
||||
|
|
|
|||
|
|
@ -1,125 +1,10 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.private
|
||||
io.files io.buffers io.nonblocking io.timeouts io.unix.backend
|
||||
io.unix.select io.unix.launcher unix.linux.inotify assocs
|
||||
namespaces threads continuations init math alien.c-types alien
|
||||
vocabs.loader accessors system ;
|
||||
USING: kernel io.backend io.monitors io.unix.backend
|
||||
io.unix.select io.unix.linux.monitors system namespaces ;
|
||||
IN: io.unix.linux
|
||||
|
||||
TUPLE: linux-monitor ;
|
||||
|
||||
: <linux-monitor> ( wd -- monitor )
|
||||
linux-monitor construct-simple-monitor ;
|
||||
|
||||
TUPLE: inotify watches ;
|
||||
|
||||
: watches ( -- assoc ) inotify get-global watches>> ;
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
H{ } clone
|
||||
inotify_init dup 0 < [ 2drop f ] [
|
||||
inotify <buffered-port>
|
||||
{ set-inotify-watches set-delegate } inotify construct
|
||||
] if ;
|
||||
|
||||
: inotify-fd inotify get-global handle>> ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: add-watch ( path mask -- monitor )
|
||||
(add-watch) dup check-existing
|
||||
[ <linux-monitor> dup ] keep watches set-at ;
|
||||
|
||||
: remove-watch ( monitor -- )
|
||||
dup simple-monitor-handle watches delete-at
|
||||
simple-monitor-handle inotify-fd swap inotify_rm_watch io-error ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"inotify is not supported by this Linux release" throw
|
||||
] unless ;
|
||||
|
||||
M: linux <monitor> ( path recursive? -- monitor )
|
||||
check-inotify
|
||||
drop IN_CHANGE_EVENTS add-watch ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
dup delegate dispose remove-watch ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_DELETE_SELF +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file+ ?flag
|
||||
IN_MOVED_TO +rename-file+ ?flag
|
||||
IN_MOVE_SELF +rename-file+ ?flag
|
||||
drop
|
||||
] { } make ;
|
||||
|
||||
: parse-file-notify ( buffer -- changed path )
|
||||
{ inotify-event-name inotify-event-mask } get-slots
|
||||
parse-action swap alien>char-string ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor [
|
||||
monitor-queue [
|
||||
parse-file-notify changed-file
|
||||
] bind
|
||||
] keep notify-callback
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: read-notifications ( port -- )
|
||||
dup refill drop
|
||||
0 over parse-file-notifications
|
||||
0 swap buffer-reset ;
|
||||
|
||||
TUPLE: inotify-task ;
|
||||
|
||||
: <inotify-task> ( port -- task )
|
||||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify> dup [
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux init-io ( -- )
|
||||
<select-mx>
|
||||
[ mx set-global ]
|
||||
[ init-inotify ] bi ;
|
||||
<select-mx> mx set-global ;
|
||||
|
||||
linux set-io-backend
|
||||
|
|
|
|||
|
|
@ -0,0 +1,126 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||
io.unix.backend io.unix.select unix.linux.inotify assocs
|
||||
namespaces threads continuations init math math.bitfields
|
||||
alien.c-types alien vocabs.loader accessors system ;
|
||||
IN: io.unix.linux.monitors
|
||||
|
||||
TUPLE: linux-monitor < monitor wd ;
|
||||
|
||||
: <linux-monitor> ( wd path mailbox -- monitor )
|
||||
linux-monitor construct-monitor
|
||||
swap >>wd ;
|
||||
|
||||
SYMBOL: watches
|
||||
|
||||
SYMBOL: inotify
|
||||
|
||||
: wd>monitor ( wd -- monitor ) watches get at ;
|
||||
|
||||
: <inotify> ( -- port/f )
|
||||
inotify_init dup 0 < [ drop f ] [ <reader> ] if ;
|
||||
|
||||
: inotify-fd inotify get handle>> ;
|
||||
|
||||
: check-existing ( wd -- )
|
||||
watches get key? [
|
||||
"Cannot open multiple monitors for the same file" throw
|
||||
] when ;
|
||||
|
||||
: (add-watch) ( path mask -- wd )
|
||||
inotify-fd -rot inotify_add_watch dup io-error dup check-existing ;
|
||||
|
||||
: add-watch ( path mask mailbox -- monitor )
|
||||
>r
|
||||
>r (normalize-path) r>
|
||||
[ (add-watch) ] [ drop ] 2bi r>
|
||||
<linux-monitor> [ ] [ ] [ wd>> ] tri watches get set-at ;
|
||||
|
||||
: check-inotify
|
||||
inotify get [
|
||||
"Calling <monitor> outside with-monitors" throw
|
||||
] unless ;
|
||||
|
||||
M: linux (monitor) ( path recursive? mailbox -- monitor )
|
||||
swap [
|
||||
<recursive-monitor>
|
||||
] [
|
||||
check-inotify
|
||||
IN_CHANGE_EVENTS swap add-watch
|
||||
] if ;
|
||||
|
||||
M: linux-monitor dispose ( monitor -- )
|
||||
[ wd>> watches get delete-at ]
|
||||
[ wd>> inotify-fd swap inotify_rm_watch io-error ] bi ;
|
||||
|
||||
: ignore-flags? ( mask -- ? )
|
||||
{
|
||||
IN_DELETE_SELF
|
||||
IN_MOVE_SELF
|
||||
IN_UNMOUNT
|
||||
IN_Q_OVERFLOW
|
||||
IN_IGNORED
|
||||
} flags bitand 0 > ;
|
||||
|
||||
: parse-action ( mask -- changed )
|
||||
[
|
||||
IN_CREATE +add-file+ ?flag
|
||||
IN_DELETE +remove-file+ ?flag
|
||||
IN_MODIFY +modify-file+ ?flag
|
||||
IN_ATTRIB +modify-file+ ?flag
|
||||
IN_MOVED_FROM +rename-file-old+ ?flag
|
||||
IN_MOVED_TO +rename-file-new+ ?flag
|
||||
drop
|
||||
] { } make prune ;
|
||||
|
||||
: parse-file-notify ( buffer -- path changed )
|
||||
dup inotify-event-mask ignore-flags? [
|
||||
drop f f
|
||||
] [
|
||||
[ inotify-event-name alien>char-string ]
|
||||
[ inotify-event-mask parse-action ] bi
|
||||
] if ;
|
||||
|
||||
: events-exhausted? ( i buffer -- ? )
|
||||
fill>> >= ;
|
||||
|
||||
: inotify-event@ ( i buffer -- alien )
|
||||
ptr>> <displaced-alien> ;
|
||||
|
||||
: next-event ( i buffer -- i buffer )
|
||||
2dup inotify-event@
|
||||
inotify-event-len "inotify-event" heap-size +
|
||||
swap >r + r> ;
|
||||
|
||||
: parse-file-notifications ( i buffer -- )
|
||||
2dup events-exhausted? [ 2drop ] [
|
||||
2dup inotify-event@ dup inotify-event-wd wd>monitor
|
||||
>r parse-file-notify r> queue-change
|
||||
next-event parse-file-notifications
|
||||
] if ;
|
||||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
0 over parse-file-notifications
|
||||
0 over buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
||||
: inotify-read-thread ( port -- )
|
||||
[ inotify-read-loop ] curry ignore-errors ;
|
||||
|
||||
M: linux init-monitors
|
||||
H{ } clone watches set
|
||||
<inotify> [
|
||||
[ inotify set ]
|
||||
[
|
||||
[ inotify-read-thread ] curry
|
||||
"Linux monitor thread" spawn drop
|
||||
] bi
|
||||
] [
|
||||
"Linux kernel version is too old" throw
|
||||
] if* ;
|
||||
|
||||
M: linux dispose-monitors
|
||||
inotify get dispose ;
|
||||
|
|
@ -1,23 +1,27 @@
|
|||
USING: io.unix.bsd io.backend io.monitors io.monitors.private
|
||||
continuations kernel core-foundation.fsevents sequences
|
||||
namespaces arrays system ;
|
||||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.unix.bsd io.backend io.monitors core-foundation.fsevents
|
||||
continuations kernel sequences namespaces arrays system locals
|
||||
accessors ;
|
||||
IN: io.unix.macosx
|
||||
|
||||
macosx set-io-backend
|
||||
|
||||
TUPLE: macosx-monitor ;
|
||||
TUPLE: macosx-monitor < monitor handle ;
|
||||
|
||||
: enqueue-notifications ( triples monitor -- )
|
||||
tuck monitor-queue
|
||||
[ [ first { +modify-file+ } swap changed-file ] each ] bind
|
||||
notify-callback ;
|
||||
[
|
||||
>r first { +modify-file+ } r> queue-change
|
||||
] curry each ;
|
||||
|
||||
M: macosx <monitor>
|
||||
drop
|
||||
f macosx-monitor construct-simple-monitor
|
||||
M: macosx init-monitors ;
|
||||
|
||||
M: macosx dispose-monitors ;
|
||||
|
||||
M:: macosx (monitor) ( path recursive? mailbox -- monitor )
|
||||
path mailbox macosx-monitor construct-monitor
|
||||
dup [ enqueue-notifications ] curry
|
||||
rot 1array 0 0 <event-stream>
|
||||
over set-simple-monitor-handle ;
|
||||
path 1array 0 0 <event-stream> >>handle ;
|
||||
|
||||
M: macosx-monitor dispose
|
||||
dup simple-monitor-handle dispose delegate dispose ;
|
||||
handle>> dispose ;
|
||||
|
||||
macosx set-io-backend
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ handle-fd ] 2curry assoc-each ;
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
! dup clear-bits
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
|
|
@ -45,9 +44,9 @@ TUPLE: select-mx read-fdset write-fdset ;
|
|||
[ reads>> max-fd ] [ writes>> max-fd ] bi max 1+ ;
|
||||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ] keep
|
||||
[ read-fdset/tasks tuck init-fdset ] keep
|
||||
write-fdset/tasks tuck init-fdset
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks tuck init-fdset ]
|
||||
[ write-fdset/tasks tuck init-fdset ] tri
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
|
|
|
|||
|
|
@ -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" ] }
|
||||
[ unknown-gl-platform ]
|
||||
} cond use+ >>
|
||||
IN: opengl.gl.extensions
|
||||
|
||||
SYMBOL: +gl-function-number-counter+
|
||||
SYMBOL: +gl-function-pointers+
|
||||
|
|
|
|||
|
|
@ -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." ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -22,7 +22,7 @@ heaps.private system math math.parser ;
|
|||
: threads. ( -- )
|
||||
standard-table-style [
|
||||
[
|
||||
{ "ID" "Name" "Waiting on" "Remaining sleep" }
|
||||
{ "ID:" "Name:" "Waiting on:" "Remaining sleep:" }
|
||||
[ [ write ] with-cell ] each
|
||||
] with-row
|
||||
|
||||
|
|
|
|||
|
|
@ -10,8 +10,7 @@ IN: tools.vocabs.monitor
|
|||
{ { CHAR: / CHAR: . } { CHAR: \\ CHAR: . } } substitute ;
|
||||
|
||||
: path>vocab-name ( path -- vocab )
|
||||
dup ".factor" tail? [ parent-directory ] when
|
||||
;
|
||||
dup ".factor" tail? [ parent-directory ] when ;
|
||||
|
||||
: chop-vocab-root ( path -- path' )
|
||||
"resource:" prepend-path (normalize-path)
|
||||
|
|
@ -23,29 +22,32 @@ IN: tools.vocabs.monitor
|
|||
: path>vocab ( path -- vocab )
|
||||
chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
|
||||
|
||||
: changed-vocab ( vocab -- )
|
||||
dup vocab
|
||||
[ dup changed-vocabs get-global set-at ] [ drop ] if ;
|
||||
|
||||
: monitor-thread ( monitor -- )
|
||||
: monitor-loop ( monitor -- )
|
||||
#! On OS X, monitors give us the full path, so we chop it
|
||||
#! off if its there.
|
||||
next-change drop path>vocab changed-vocab reset-cache ;
|
||||
dup next-change drop path>vocab changed-vocab
|
||||
reset-cache
|
||||
monitor-loop ;
|
||||
|
||||
: monitor-thread ( -- )
|
||||
[
|
||||
[
|
||||
"" resource-path t <monitor>
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
vocabs [ changed-vocab ] each
|
||||
|
||||
monitor-loop
|
||||
] with-monitors
|
||||
] ignore-errors ;
|
||||
|
||||
: start-monitor-thread ( -- )
|
||||
#! Silently ignore errors during monitor creation since
|
||||
#! monitors are not supported on all platforms.
|
||||
[
|
||||
"" resource-path t <monitor> [ monitor-thread t ] curry
|
||||
"Vocabulary monitor" spawn-server drop
|
||||
|
||||
H{ } clone changed-vocabs set-global
|
||||
|
||||
vocabs [ changed-vocab ] each
|
||||
] ignore-errors ;
|
||||
[ monitor-thread ] "Vocabulary monitor" spawn drop ;
|
||||
|
||||
[
|
||||
"-no-monitors" cli-args get member? [
|
||||
"-no-monitors" cli-args member? [
|
||||
start-monitor-thread
|
||||
] unless
|
||||
] "tools.vocabs.monitor" add-init-hook
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
IN: tools.vocabs.tests
|
||||
USING: tools.test tools.vocabs namespaces continuations ;
|
||||
|
||||
[ ] [
|
||||
changed-vocabs get-global
|
||||
f changed-vocabs set-global
|
||||
[ t ] [ "kernel" changed-vocab? ] unit-test
|
||||
[ "kernel" changed-vocab ] [ changed-vocabs set-global ] [ ] cleanup
|
||||
] unit-test
|
||||
|
|
@ -32,43 +32,6 @@ IN: tools.vocabs
|
|||
[ vocab-tests % ] tri
|
||||
] { } make ;
|
||||
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
dup source-file-path
|
||||
dup exists? [
|
||||
utf8 file-lines lines-crc32
|
||||
swap source-file-checksum = not
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
exists?
|
||||
] ?if ;
|
||||
|
||||
: modified ( seq quot -- seq )
|
||||
[ dup ] swap compose { } map>assoc
|
||||
[ nip ] assoc-subset
|
||||
[ nip source-modified? ] assoc-subset keys ; inline
|
||||
|
||||
: modified-sources ( vocabs -- seq )
|
||||
[ vocab-source-path ] modified ;
|
||||
|
||||
: modified-docs ( vocabs -- seq )
|
||||
[ vocab-docs-path ] modified ;
|
||||
|
||||
SYMBOL: changed-vocabs
|
||||
|
||||
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
||||
|
||||
: filter-changed ( vocabs -- vocabs' )
|
||||
changed-vocabs get [
|
||||
[ delete-at* nip ] curry subset
|
||||
] when* ;
|
||||
|
||||
: to-refresh ( prefix -- modified-sources modified-docs )
|
||||
child-vocabs filter-changed
|
||||
[ modified-sources ] [ modified-docs ] bi ;
|
||||
|
||||
: vocab-heading. ( vocab -- )
|
||||
nl
|
||||
"==== " write
|
||||
|
|
@ -95,12 +58,88 @@ SYMBOL: failures
|
|||
failures get
|
||||
] with-compiler-errors ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs -- )
|
||||
: source-modified? ( path -- ? )
|
||||
dup source-files get at [
|
||||
dup source-file-path
|
||||
dup exists? [
|
||||
utf8 file-lines lines-crc32
|
||||
swap source-file-checksum = not
|
||||
] [
|
||||
2drop f
|
||||
] if
|
||||
] [
|
||||
exists?
|
||||
] ?if ;
|
||||
|
||||
SYMBOL: changed-vocabs
|
||||
|
||||
[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook
|
||||
|
||||
: changed-vocab ( vocab -- )
|
||||
dup vocab changed-vocabs get and
|
||||
[ dup changed-vocabs get set-at ] [ drop ] if ;
|
||||
|
||||
: unchanged-vocab ( vocab -- )
|
||||
changed-vocabs get delete-at ;
|
||||
|
||||
: unchanged-vocabs ( vocabs -- )
|
||||
[ unchanged-vocab ] each ;
|
||||
|
||||
: changed-vocab? ( vocab -- ? )
|
||||
changed-vocabs get dup [ key? ] [ 2drop t ] if ;
|
||||
|
||||
: filter-changed ( vocabs -- vocabs' )
|
||||
[ changed-vocab? ] subset ;
|
||||
|
||||
SYMBOL: modified-sources
|
||||
SYMBOL: modified-docs
|
||||
|
||||
: (to-refresh) ( vocab variable loaded? path -- )
|
||||
dup [
|
||||
swap [
|
||||
pick changed-vocab? [
|
||||
source-modified? [ get push ] [ 2drop ] if
|
||||
] [ 3drop ] if
|
||||
] [ drop get push ] if
|
||||
] [ 2drop 2drop ] if ;
|
||||
|
||||
: to-refresh ( prefix -- modified-sources modified-docs unchanged )
|
||||
[
|
||||
V{ } clone modified-sources set
|
||||
V{ } clone modified-docs set
|
||||
|
||||
child-vocabs [
|
||||
[
|
||||
[
|
||||
[ modified-sources ]
|
||||
[ vocab-source-loaded? ]
|
||||
[ vocab-source-path ]
|
||||
tri (to-refresh)
|
||||
] [
|
||||
[ modified-docs ]
|
||||
[ vocab-docs-loaded? ]
|
||||
[ vocab-docs-path ]
|
||||
tri (to-refresh)
|
||||
] bi
|
||||
] each
|
||||
|
||||
modified-sources get
|
||||
modified-docs get
|
||||
]
|
||||
[ modified-sources get modified-docs get append swap seq-diff ] bi
|
||||
] with-scope ;
|
||||
|
||||
: do-refresh ( modified-sources modified-docs unchanged -- )
|
||||
unchanged-vocabs
|
||||
[
|
||||
[ [ f swap set-vocab-source-loaded? ] each ]
|
||||
[ [ f swap set-vocab-docs-loaded? ] each ] bi*
|
||||
]
|
||||
[ append prune require-all load-failures. ] 2bi ;
|
||||
[
|
||||
append prune
|
||||
[ unchanged-vocabs ]
|
||||
[ require-all load-failures. ] bi
|
||||
] 2bi ;
|
||||
|
||||
: refresh ( prefix -- ) to-refresh do-refresh ;
|
||||
|
||||
|
|
|
|||
|
|
@ -72,6 +72,7 @@ M: object add-breakpoint ;
|
|||
{
|
||||
{ [ dup "step-into" word-prop ] [ "step-into" word-prop call ] }
|
||||
{ [ dup standard-generic? ] [ effective-method (step-into-execute) ] }
|
||||
{ [ dup hook-generic? ] [ effective-method (step-into-execute) ] }
|
||||
{ [ dup primitive? ] [ execute break ] }
|
||||
[ word-def (step-into-quot) ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ? )
|
||||
|
|
|
|||
|
|
@ -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*
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -315,7 +315,7 @@ INLINE void* allot_object(CELL type, CELL a)
|
|||
{
|
||||
CELL *object;
|
||||
|
||||
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||
if(HAVE_NURSERY_P && nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||
{
|
||||
/* If there is insufficient room, collect the nursery */
|
||||
if(nursery->here + ALLOT_BUFFER_ZONE + a > nursery->end)
|
||||
|
|
|
|||
|
|
@ -1,4 +1,12 @@
|
|||
#include <ucontext.h>
|
||||
|
||||
#define FRAME_RETURN_ADDRESS(frame) *((XT *)(frame_successor(frame) + 1) + 1)
|
||||
|
||||
INLINE void *ucontext_stack_pointer(void *uap)
|
||||
{
|
||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||
return (void *)ucontext->uc_mcontext.uc_regs->gregs[PT_R1];
|
||||
}
|
||||
|
||||
#define UAP_PROGRAM_COUNTER(ucontext) \
|
||||
(((ucontext_t *)(ucontext))->uc_mcontext.uc_regs->gregs[PT_NIP])
|
||||
|
|
|
|||
|
|
@ -15,4 +15,10 @@ DLLEXPORT void c_to_factor_toplevel(CELL quot);
|
|||
#ifndef environ
|
||||
extern char ***_NSGetEnviron(void);
|
||||
#define environ (*_NSGetEnviron())
|
||||
#endif
|
||||
#endif
|
||||
|
||||
INLINE void *ucontext_stack_pointer(void *uap)
|
||||
{
|
||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||
return ucontext->uc_stack.ss_sp;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +0,0 @@
|
|||
#include <ucontext.h>
|
||||
|
||||
INLINE void *ucontext_stack_pointer(void *uap)
|
||||
{
|
||||
ucontext_t *ucontext = (ucontext_t *)uap;
|
||||
return ucontext->uc_stack.ss_sp;
|
||||
}
|
||||
10
vm/os-unix.c
10
vm/os-unix.c
|
|
@ -85,6 +85,16 @@ DEFINE_PRIMITIVE(read_dir)
|
|||
dpush(result);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(os_env)
|
||||
{
|
||||
char *name = unbox_char_string();
|
||||
char *value = getenv(name);
|
||||
if(value == NULL)
|
||||
dpush(F);
|
||||
else
|
||||
box_char_string(value);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(os_envs)
|
||||
{
|
||||
GROWABLE_ARRAY(result);
|
||||
|
|
|
|||
|
|
@ -215,19 +215,34 @@ void sleep_millis(DWORD msec)
|
|||
Sleep(msec);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(os_env)
|
||||
{
|
||||
F_CHAR *key = unbox_u16_string();
|
||||
F_CHAR *value = safe_malloc(MAX_UNICODE_PATH);
|
||||
int ret;
|
||||
ret = GetEnvironmentVariable(key, value, MAX_UNICODE_PATH);
|
||||
if(ret == 0)
|
||||
dpush(F);
|
||||
else
|
||||
dpush(tag_object(from_u16_string(value)));
|
||||
free(value);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(set_os_env)
|
||||
{
|
||||
F_CHAR *key = unbox_u16_string();
|
||||
REGISTER_C_STRING(key);
|
||||
F_CHAR *value = unbox_u16_string();
|
||||
UNREGISTER_C_STRING(key);
|
||||
SetEnvironmentVariable(key, value);
|
||||
if(!SetEnvironmentVariable(key, value))
|
||||
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(unset_os_env)
|
||||
{
|
||||
F_CHAR *key = unbox_u16_string();
|
||||
SetEnvironmentVariable(key, NULL);
|
||||
if(!SetEnvironmentVariable(unbox_u16_string(), NULL)
|
||||
&& GetLastError() != ERROR_ENVVAR_NOT_FOUND)
|
||||
general_error(ERROR_IO, tag_object(get_error_message()), F, NULL);
|
||||
}
|
||||
|
||||
DEFINE_PRIMITIVE(set_os_envs)
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@
|
|||
#include "os-unix.h"
|
||||
|
||||
#ifdef __APPLE__
|
||||
#include "os-unix-ucontext.h"
|
||||
#include "os-macosx.h"
|
||||
#include "mach_signal.h"
|
||||
|
||||
|
|
@ -84,7 +83,6 @@
|
|||
#if defined(FACTOR_X86)
|
||||
#include "os-linux-x86.32.h"
|
||||
#elif defined(FACTOR_PPC)
|
||||
#include "os-unix-ucontext.h"
|
||||
#include "os-linux-ppc.h"
|
||||
#elif defined(FACTOR_ARM)
|
||||
#include "os-linux-arm.h"
|
||||
|
|
|
|||
Loading…
Reference in New Issue