1 ! Copyright (C) 2012 Anonymous.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors calendar images images.viewer kernel math
4 math.parser models models.arrow random sequences threads timers
5 ui ui.gadgets ui.gadgets.labels ui.gadgets.packs
6 ui.gadgets.status-bar ui.gadgets.worlds ;
7 IN: rosetta-code.image-noise
9 : bits>pixels ( bits -- bits' pixels )
10 [ -1 shift ] [ 1 bitand ] bi 255 * ; inline
12 : ?generate-more-bits ( a bits -- a bits' )
13 over 32 mod zero? [ drop random-32 ] when ; inline
15 : <random-images-bytes> ( dim -- bytes )
18 [ 1 + ] [ bits>pixels ] bi*
19 ] B{ } replicate-as 2nip ;
21 : <random-bw-image> ( -- image )
23 { 320 240 } [ >>dim ] [ <random-images-bytes> >>bitmap ] bi
25 ubyte-components >>component-type ;
27 TUPLE: bw-noise-gadget < image-control timers cnt old-cnt ;
29 : animate-image ( control -- )
31 model>> <random-bw-image> swap set-model ;
33 : update-cnt ( gadget -- )
34 [ cnt>> ] [ old-cnt<< ] bi ;
36 : fps ( gadget -- fps )
37 [ cnt>> ] [ old-cnt>> ] bi -
38 number>string "FPS: " prepend ;
40 : fps-monitor ( gadget -- )
41 [ fps ] [ update-cnt ] [ show-status ] tri ;
43 : start-animation ( gadget -- )
44 [ [ animate-image ] curry 1 nanoseconds every ] [ timers>> push ] bi ;
46 : start-fps ( gadget -- )
47 [ [ fps-monitor ] curry 1 seconds every ] [ timers>> push ] bi ;
49 : setup-timers ( gadget -- )
50 [ start-animation ] [ start-fps ] bi ;
52 : stop-animation ( gadget -- )
53 timers>> [ [ stop-timer ] each ] [ delete-all ] bi ;
55 M: bw-noise-gadget graft* [ call-next-method ] [ setup-timers ] bi ;
57 M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
59 : <bw-noise-gadget> ( -- gadget )
60 <random-bw-image> <model> bw-noise-gadget new-image-gadget*
61 0 >>cnt 0 >>old-cnt V{ } clone >>timers ;
63 : open-noise-window ( -- )
64 [ <bw-noise-gadget> "Black and White noise" open-status-window ] with-ui ;
66 MAIN: open-noise-window