note synthesis with harmonics, and added some more virtual sequences

extra/morse/morse.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth.buffers unicode.case ;
+USING: accessors assocs combinators hashtables kernel lazy-lists math namespaces openal parser-combinators promises sequences strings symbols synth synth.buffers unicode.case ;
 IN: morse
 
 <PRIVATE
@@ -136,7 +136,7 @@ SYMBOLS: source dot-buffer dash-buffer intra-char-gap-buffer letter-gap-buffer ;
 : beep-freq 880 ;
 
 : <morse-buffer> ( -- buffer )
-    half-sample-freq t <mono-buffer> ;
+    half-sample-freq <8bit-mono-buffer> ;
 
 : sine-buffer ( seconds -- id )
     beep-freq swap <morse-buffer> >sine-wave-buffer

extra/sequences/merged/merged.factor

@@ -23,4 +23,6 @@ M: merged length seqs>> [ length ] map sum ;
 M: merged virtual@ ( n seq -- n' seq' )
     seqs>> [ length /mod ] [ nth ] bi ;
 
+M: merged virtual-seq ( merged -- seq ) [ ] { } map-as ;
+
 INSTANCE: merged virtual-sequence

extra/sequences/modified/modified-tests.factor

@@ -0,0 +1,15 @@
+USING: accessors arrays kernel sequences sequences.modified tools.test ;
+IN: sequences.modified.tests
+
+[ { 2 4 6 } ] [ { 1 2 3 } 2 scale ] unit-test
+[ { 1 4 3 } ] [ { 1 2 3 } 2 <scaled> 8 1 pick set-nth seq>> ] unit-test
+[ { 2 8 6 } ] [ { 1 2 3 } 2 <scaled> 8 1 pick set-nth >array ] unit-test
+
+[ { 2 3 4 } ] [ { 1 2 3 } 1 seq-offset ] unit-test
+[ { 1 5 3 } ] [ { 1 2 3 } 1 <offset> 6 1 pick set-nth seq>> ] unit-test
+[ { 2 6 4 } ] [ { 1 2 3 } 1 <offset> 6 1 pick set-nth >array ] unit-test
+
+[ 4 ] [ { { 1 2 } { 3 4 } } <summed> 0 swap nth ] unit-test
+[ 6 ] [ { { 1 2 } { 3 4 } } <summed> 1 swap nth ] unit-test
+[ 2 ] [ { { 1 2 } { 3 4 } } <summed> length ] unit-test
+[ { 4 6 } ] [ { { 1 2 } { 3 4 } } <summed> >array ] unit-test

extra/sequences/modified/modified.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math sequences sequences.private shuffle ;
+IN: sequences.modified
+
+TUPLE: modified ;
+
+GENERIC: modified-nth ( n seq -- elt )
+M: modified nth modified-nth ;
+M: modified nth-unsafe modified-nth ;
+
+GENERIC: modified-set-nth ( elt n seq -- )
+M: modified set-nth modified-set-nth ;
+M: modified set-nth-unsafe modified-set-nth ;
+
+INSTANCE: modified virtual-sequence
+
+TUPLE: 1modified < modified seq ;
+
+M: modified length seq>> length ;
+M: modified set-length seq>> set-length ;
+
+M: 1modified virtual-seq seq>> ;
+
+TUPLE: scaled < 1modified c ;
+C: <scaled> scaled
+
+: scale ( seq c -- new-seq )
+    dupd <scaled> swap like ;
+
+M: scaled modified-nth ( n seq -- elt )
+    [ seq>> nth ] [ c>> * ] bi ;
+
+M: scaled modified-set-nth ( elt n seq -- elt )
+    ! don't set c to 0!
+    tuck [ c>> / ] 2dip seq>> set-nth ;
+
+TUPLE: offset < 1modified n ;
+C: <offset> offset
+
+: seq-offset ( seq n -- new-seq )
+    dupd <offset> swap like ;
+
+M: offset modified-nth ( n seq -- elt )
+    [ seq>> nth ] [ n>> + ] bi ;
+
+M: offset modified-set-nth ( elt n seq -- )
+    tuck [ n>> - ] 2dip seq>> set-nth ;
+
+TUPLE: summed < modified seqs ;
+C: <summed> summed
+
+M: summed length seqs>> [ length ] map supremum ;
+
+<PRIVATE
+: ?+ ( x/f y/f -- sum )
+    #! addition that treats f as 0
+    [
+        swap [ + ] when*
+    ] [
+        [ ] [ 0 ] if*
+    ] if* ;
+PRIVATE>
+
+M: summed modified-nth ( n seq -- )
+    seqs>> [ ?nth ?+ ] with 0 swap reduce ;
+
+M: summed modified-set-nth ( elt n seq -- ) immutable ;
+
+M: summed set-length ( n seq -- )
+    seqs>> [ set-length ] with each ;
+
+M: summed virtual-seq ( summed -- seq ) [ ] { } map-as ;
+
+: <2summed> ( seq seq -- summed-seq ) 2array <summed> ;
+: <3summed> ( seq seq seq -- summed-seq ) 3array <summed> ;

extra/synth/buffers/buffers-tests.factor

@@ -1,5 +0,0 @@
-USING: kernel synth.buffers sequences tools.test ;
-IN: synth.buffers.tests
-
-
-[ ] [ 440 1 half-sample-freq play-sine-wave ] unit-test

extra/synth/buffers/buffers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators kernel locals math math.constants math.functions math.ranges openal sequences sequences.merged sequences.repeating ;
+USING: accessors alien.c-types combinators kernel locals math math.ranges openal sequences sequences.merged ;
 IN: synth.buffers
 
 TUPLE: buffer sample-freq 8bit? id ;
@@ -13,11 +13,17 @@ TUPLE: mono-buffer < buffer data ;
 : <mono-buffer> ( sample-freq 8bit? -- buffer )
     f f mono-buffer boa ;
 
+: <8bit-mono-buffer> ( sample-freq -- buffer ) t <mono-buffer> ;
+: <16bit-mono-buffer> ( sample-freq -- buffer ) f <mono-buffer> ;
+
 TUPLE: stereo-buffer < buffer left-data right-data ;
 
 : <stereo-buffer> ( sample-freq 8bit? -- buffer )
     f f f stereo-buffer boa ;
 
+: <8bit-stereo-buffer> ( sample-freq -- buffer ) t <stereo-buffer> ;
+: <16bit-stereo-buffer> ( sample-freq -- buffer ) f <stereo-buffer> ;
+
 PREDICATE: 8bit-buffer < buffer 8bit?>> ;
 PREDICATE: 16bit-buffer < buffer 8bit?>> not ;
 INTERSECTION: 8bit-mono-buffer 8bit-buffer mono-buffer ;
@@ -68,21 +74,3 @@ M: 16bit-stereo-buffer buffer-data
 : ?send-buffer ( buffer -- buffer )
     dup id>> [ send-buffer ] unless ;
 
-: (sine-wave) ( samples/wave n-samples -- seq )
-    pi 2 * pick / swapd [ * sin ] curry map swap <repeating> ;
-
-: sine-wave ( sample-freq freq seconds -- seq )
-    pick * >integer [ /i ] dip (sine-wave) ;
-
-: >sine-wave-buffer ( freq seconds buffer -- buffer )
-    [ sample-freq>> -rot sine-wave ] keep swap >>data ;
-
-: >silent-buffer ( seconds buffer -- buffer )
-    tuck sample-freq>> * >integer 0 <repetition> >>data ;
-
-: play-sine-wave ( freq seconds sample-freq -- )
-    init-openal
-    t <mono-buffer> >sine-wave-buffer send-buffer id>>
-    1 gen-sources first
-    [ AL_BUFFER rot set-source-param ] [ source-play ] bi
-    check-error ;

extra/synth/example/example.factor

@@ -0,0 +1,35 @@
+USING: accessors arrays kernel namespaces openal sequences synth synth.buffers ;
+IN: synth.example
+
+: play-sine-wave ( freq seconds sample-freq -- )
+    init-openal
+    <16bit-mono-buffer> >sine-wave-buffer send-buffer id>>
+    1 gen-sources first
+    [ AL_BUFFER rot set-source-param ] [ source-play ] bi
+    check-error ;
+
+: test-instrument1 ( -- harmonics )
+    [
+        1 0.5 <harmonic> ,
+        2 0.125 <harmonic> ,
+        3 0.0625 <harmonic> ,
+        4 0.03125 <harmonic> ,
+    ] { } make ;
+
+: test-instrument2 ( -- harmonics )
+    [
+        1 0.25 <harmonic> ,
+        2 0.25 <harmonic> ,
+        3 0.25 <harmonic> ,
+        4 0.25 <harmonic> ,
+    ] { } make ;
+
+: sine-instrument ( -- harmonics )
+    1 1 <harmonic> 1array ;
+
+: test-note-buffer ( note -- )
+    init-openal
+    test-instrument2 swap cd-sample-freq <16bit-mono-buffer>
+    >note send-buffer id>>
+    1 gen-sources first [ swap queue-buffer ] [ source-play ] bi
+    check-error ;

extra/synth/synth.factor

@@ -0,0 +1,34 @@
+USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
+IN: synth
+
+MEMO: single-sine-wave ( samples/wave -- seq )
+    pi 2 * over / [ * sin ] curry map ;
+
+: (sine-wave) ( samples/wave n-samples -- seq )
+    [ single-sine-wave ] dip <repeating> ;
+
+: sine-wave ( sample-freq freq seconds -- seq )
+    pick * >integer [ /i ] dip (sine-wave) ;
+
+: >sine-wave-buffer ( freq seconds buffer -- buffer )
+    [ sample-freq>> -rot sine-wave ] keep swap >>data ;
+
+: >silent-buffer ( seconds buffer -- buffer )
+    tuck sample-freq>> * >integer 0 <repetition> >>data ;
+
+TUPLE: harmonic n amplitude ;
+C: <harmonic> harmonic
+
+TUPLE: note hz secs ;
+C: <note> note
+
+: harmonic-freq ( note harmonic -- freq )
+    n>> swap hz>> * ;
+
+:: note-harmonic-data ( harmonic note buffer -- data )
+    buffer sample-freq>> note harmonic harmonic-freq note secs>> sine-wave
+    harmonic amplitude>> <scaled> ;
+
+: >note ( harmonics note buffer -- buffer )
+    dup -roll [ note-harmonic-data ] 2curry map <summed> >>data ;
+