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