extra/rosetta-code/image-noise/image-noise.factor

   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 IN: rosetta-code.image-noise
   7
   8 : bits>pixels ( bits -- bits' pixels )
   9     [ -1 shift ] [ 1 bitand ] bi 255 * ; inline
  10
  11 : ?generate-more-bits ( a bits -- a bits' )
  12     over 32 mod zero? [ drop random-32 ] when ; inline
  13
  14 : <random-images-bytes> ( dim -- bytes )
  15     [ 0 0 ] dip product  [
  16         ?generate-more-bits
  17         [ 1 + ] [ bits>pixels ] bi*
  18     ] B{ } replicate-as 2nip ;
  19
  20 : <random-bw-image> ( -- image )
  21     <image>
  22         { 320 240 } [ >>dim ] [ <random-images-bytes> >>bitmap ] bi
  23         L >>component-order
  24         ubyte-components >>component-type ;
  25
  26 TUPLE: bw-noise-gadget < image-control timers cnt old-cnt fps-model ;
  27
  28 : animate-image ( control -- )
  29     [ 1 + ] change-cnt
  30     model>> <random-bw-image> swap set-model ;
  31
  32 : update-cnt ( gadget -- )
  33     [ cnt>> ] [ old-cnt<< ] bi ;
  34
  35 : fps ( gadget -- fps )
  36     [ cnt>> ] [ old-cnt>> ] bi - ;
  37
  38 : fps-monitor ( gadget -- )
  39     [ fps ] [ update-cnt ] [ fps-model>> set-model ] tri ;
  40
  41 : start-animation ( gadget -- )
  42     [ [ animate-image ] curry 1 nanoseconds every ] [ timers>> push ] bi ;
  43
  44 : start-fps ( gadget -- )
  45     [ [ fps-monitor ] curry 1 seconds every ] [ timers>> push ] bi ;
  46
  47 : setup-timers ( gadget -- )
  48     [ start-animation ] [ start-fps ] bi ;
  49
  50 : stop-animation ( gadget -- )
  51     timers>> [ [ stop-timer ] each ] [ 0 swap set-length ] bi ;
  52
  53 M: bw-noise-gadget graft* [ call-next-method ] [ setup-timers ] bi ;
  54
  55 M: bw-noise-gadget ungraft* [ stop-animation ] [ call-next-method ] bi ;
  56
  57 : <bw-noise-gadget> ( -- gadget )
  58     <random-bw-image> <model> bw-noise-gadget new-image-gadget*
  59     0 >>cnt 0 >>old-cnt 0 <model> >>fps-model V{ } clone >>timers ;
  60
  61 : fps-gadget ( model -- gadget )
  62     [ number>string ] <arrow> <label-control>
  63     "FPS: " <label>
  64     <shelf> swap add-gadget swap add-gadget ;
  65
  66 : with-fps ( gadget -- gadget' )
  67     [ fps-model>> fps-gadget ]
  68     [ <pile> swap add-gadget swap add-gadget ] bi ;
  69
  70 : open-noise-window ( -- )
  71     [ <bw-noise-gadget> with-fps "Black and White noise" open-window ] with-ui ;
  72
  73 MAIN: open-noise-window