om.rhythm: new words map-rhythm and map-rhythm!

k7f · Mar 22, 2012 · d68fe01 · d68fe01
1 parent 0321cf1
commit d68fe01
Show file tree

Hide file tree

Showing 3 changed files with 50 additions and 1 deletion.
diff --git a/work/om/rhythm/rhythm-docs.factor b/work/om/rhythm/rhythm-docs.factor
@@ -101,6 +101,24 @@ HELP: zip-measures
 }
 { $description "Takes a sequence of durations followed by a sequence of time signatures, and outputs a corresponding " { $link rhythm } ", which contains a sequence of " { $link measure } "s in the " { $snippet "division" } " slot." } ;
 
+HELP: map-rhythm
+{ $values
+  { "relt" rhythm-element }
+  { "quot" { $quotation "( ... value -- ... value' )" } }
+  { "relt'" rhythm-element }
+}
+{ $description "If the input " { $link rhythm-element } " is a number, outputs the result of applying the quotation to that number.  If it is a " { $link rhythm } ", applies the quotation to each atomic " { $link rhythm-element } " of the rhythm, collecting new values in a new rhythm structure." }
+{ $see-also map-rhythm! } ;
+
+HELP: map-rhythm!
+{ $values
+  { "relt" rhythm-element }
+  { "quot" { $quotation "( ... value -- ... value' )" } }
+  { "relt'" rhythm-element }
+}
+{ $description "If the input " { $link rhythm-element } " is a number, outputs the result of applying the quotation to that number.  If it is a " { $link rhythm } ", applies the quotation to each atomic " { $link rhythm-element } " of the rhythm, replacing old values with new values in the same rhythm structure." }
+{ $see-also map-rhythm } ;
+
 OM-REFERENCE:
 "projects/02-musicproject/functions/trees.lisp"
 { "build-one-measure" <measure> }

diff --git a/work/om/rhythm/rhythm-tests.factor b/work/om/rhythm/rhythm-tests.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2012 krzYszcz.
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: om.rhythm om.rhythm.meter tools.test ;
+USING: kernel math om.rhythm om.rhythm.meter tools.test ;
 IN: om.rhythm.tests
 
 [ T{ rhythm f 1 { 1/4 1/4 1/4 1/4 } } ] [
@@ -145,3 +145,19 @@ IN: om.rhythm.tests
        T{ rhythm f T{ meter f 3 4 } { 3. } } } } ] [
     { 1/4 1/4 4/4 } { { 3 4 } { 3 4 } } zip-measures
 ] unit-test
+
+[ T{ rhythm f T{ meter f 4 4 } { T{ rhythm f 1 { 2 } } 2 4 } } ] [
+    T{ rhythm f T{ meter f 4 4 } { T{ rhythm f 1 { 1 } } 1 2 } } [ 2 * ] map-rhythm
+] unit-test
+
+[ T{ rhythm f T{ meter f 4 4 } { T{ rhythm f 1 { 2 } } 2 4 } } ] [
+    T{ rhythm f T{ meter f 4 4 } { T{ rhythm f 1 { 1 } } 1 2 } } [ 2 * ] map-rhythm!
+] unit-test
+
+[ f ] [
+    T{ rhythm f T{ meter f 4 4 } { 1 } } dup [ ] map-rhythm eq?
+] unit-test
+
+[ t ] [
+    T{ rhythm f T{ meter f 4 4 } { 1 } } dup [ ] map-rhythm! eq?
+] unit-test
diff --git a/work/om/rhythm/rhythm.factor b/work/om/rhythm/rhythm.factor
@@ -277,3 +277,18 @@ PRIVATE>
     [ nip (tsigs>bars) ] 2bi
     [ (zip-measure) ] 2curry map-index
     f swap rhythm boa ;
+
+! __________
+! map-rhythm
+
+: map-rhythm ( ... relt quot: ( ... value -- ... value' ) -- ... relt' )
+    over rhythm? [
+        swap clone
+        [ swap [ map-rhythm ] curry map ] change-division
+    ] [ call ] if ; inline recursive
+
+: map-rhythm! ( ... relt quot: ( ... value -- ... value' ) -- ... relt' )
+    over rhythm? [
+        swap
+        [ swap [ map-rhythm! ] curry map! ] change-division
+    ] [ call ] if ; inline recursive