Permalink
Browse files

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

  • Loading branch information...
1 parent 0321cf1 commit d68fe01a09e30568ffe76967cd23962d4f811e11 @k7f committed Mar 22, 2012
Showing with 50 additions and 1 deletion.
  1. +18 −0 work/om/rhythm/rhythm-docs.factor
  2. +17 −1 work/om/rhythm/rhythm-tests.factor
  3. +15 −0 work/om/rhythm/rhythm.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> }
@@ -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
@@ -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

0 comments on commit d68fe01

Please sign in to comment.