steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

rosetta-code.image-noise: fix vocab name.

db4
John Benediktsson 2012-08-04 17:34:59 -07:00
parent cc621ee5ee
commit 5ca6fb95a7
1 changed files with 18 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
extra/rosetta-code/image-noise/image-noise.factor
View File

@ -3,30 +3,32 @@
USING: accessors calendar images images.viewer kernel math
math.parser models models.arrow random sequences threads timers
ui ui.gadgets ui.gadgets.labels ui.gadgets.packs ;
IN: noise-ui
IN: rosetta-code.image-noise
: bits>pixels ( bits -- bits' pixels )
[ -1 shift ] [ 1 bitand ] bi 255 * ; inline
[ -1 shift ] [ 1 bitand ] bi 255 * ; inline
: ?generate-more-bits ( a bits -- a bits' )
over 32 mod zero? [ drop random-32 ] when ; inline
over 32 mod zero? [ drop random-32 ] when ; inline
: <random-images-bytes> ( dim -- bytes )
[ 0 0 ] dip product [
?generate-more-bits
[ 1 + ] [ bits>pixels ] bi*
] B{ } replicate-as 2nip ;
[ 0 0 ] dip product [
?generate-more-bits
[ 1 + ] [ bits>pixels ] bi*
] B{ } replicate-as 2nip ;
: <random-bw-image> ( -- image )
<image>
{ 320 240 } [ >>dim ] [ <random-images-bytes> >>bitmap ] bi
L >>component-order
ubyte-components >>component-type ;
TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
: animate-image ( control -- )
[ 1 + ] change-cnt
model>> <random-bw-image> swap set-model ;
: update-cnt ( gadget -- )
[ cnt>> ] [ old-cnt<< ] bi ;
@ -35,7 +37,7 @@ TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
: fps-monitor ( gadget -- )
[ fps ] [ update-cnt ] [ fps-model>> set-model ] tri ;
: start-animation ( gadget -- )
[ [ animate-image ] curry 1 nanoseconds every ] [ timers>> push ] bi ;
@ -47,11 +49,11 @@ TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
: stop-animation ( gadget -- )
timers>> [ [ stop-timer ] each ] [ 0 swap set-length ] bi ;
M: bw-noise-gadget graft* [ call-next-method ] [ setup-timers ] bi ;
M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
: <bw-noise-gadget> ( -- gadget )
<random-bw-image> <model> bw-noise-gadget new-image-gadget*
0 >>cnt 0 >>old-cnt 0 <model> >>fps-model V{ } clone >>timers ;
@ -60,11 +62,11 @@ M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
[ number>string ] <arrow> <label-control>
"FPS: " <label>
<shelf> swap add-gadget swap add-gadget ;
: with-fps ( gadget -- gadget' )
[ fps-model>> fps-gadget ]
[ <pile> swap add-gadget swap add-gadget ] bi ;
: open-noise-window ( -- )
[ <bw-noise-gadget> with-fps "Black and White noise" open-window ] with-ui ;