extra/rosetta-code/metronome/metronome.factor

   1 ! Copyright (C) 2013 Jon Harper.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors calendar circular colors.constants colors.hsv
   4 command-line continuations io kernel math math.parser namespaces
   5 openal.example sequences system timers ui ui.gadgets
   6 ui.pens.solid ;
   7 IN: rosetta-code.metronome
   8
   9 : bpm>duration ( bpm -- duration ) 60 swap / seconds ;
  10
  11 : blink-gadget ( gadget freq -- )
  12     1.0 1.0 1.0 <hsva>  <solid> >>interior relayout-1 ;
  13
  14 : blank-gadget ( gadget -- )
  15     COLOR: white <solid> >>interior relayout-1 ;
  16
  17 : play-note ( gadget freq -- )
  18     [ blink-gadget ] [ 0.3 play-sine blank-gadget ] 2bi ;
  19
  20 : metronome-iteration ( gadget circular -- )
  21     [ first play-note ] [ rotate-circular ] bi ;
  22
  23 TUPLE: metronome-gadget < gadget bpm notes timer ;
  24
  25 : <metronome-gadget> ( bpm notes -- gadget )
  26     \ metronome-gadget new swap >>notes swap >>bpm ;
  27
  28 : metronome-quot ( gadget -- quot )
  29     dup notes>> <circular> [ metronome-iteration ] 2curry ;
  30
  31 : metronome-timer ( gadget -- timer )
  32     [ metronome-quot ] [ bpm>> bpm>duration ] bi every ;
  33
  34 M: metronome-gadget graft* ( gadget -- )
  35     [ metronome-timer ] keep timer<< ;
  36
  37 M: metronome-gadget ungraft*
  38     timer>> stop-timer ;
  39
  40 M: metronome-gadget pref-dim* drop { 200 200 } ;
  41
  42 : metronome-defaults ( -- bpm notes ) 60 { 440 220 330 } ;
  43
  44 : metronome-ui ( bpm notes -- ) <metronome-gadget> "Metronome" open-window ;
  45
  46 : metronome-example ( -- ) metronome-defaults metronome-ui ;
  47
  48 : validate-args ( int-args -- )
  49     [ length 2 < ] [ [ 0 <= ] any? ] bi or [ "args error" throw ] when ;
  50
  51 : (metronome-cmdline) ( args -- bpm notes )
  52     [ string>number ] map dup validate-args
  53     unclip swap ;
  54
  55 : metronome-cmdline ( -- bpm notes )
  56     command-line get [ metronome-defaults ] [ (metronome-cmdline) ] if-empty ;
  57
  58 : print-defaults ( -- )
  59   metronome-defaults swap prefix
  60   [ bl ] [ number>string write ] interleave nl ;
  61
  62 : metronome-usage ( -- )
  63     "Usage: metronome [BPM FREQUENCIES...]" print
  64     "Arguments must be non-zero" print
  65     "Example: metronome " write print-defaults flush ;
  66
  67 : metronome-main ( -- )
  68      [ [ metronome-cmdline metronome-ui ] [ drop metronome-usage 1 exit ] recover ] with-ui ;
  69
  70 MAIN: metronome-main