Author: wmb Date: 2010-01-07 09:04:00 +0100 (Thu, 07 Jan 2010) New Revision: 1647
Added: dev/hdaudio/noiseburst.fth Modified: dev/geode/ac97/selftest.fth dev/hdaudio/conexant.fth dev/hdaudio/core.fth Log: HD Audio - improvements to core HD Audio code and preliminary checkin of noise burst selftest code. That latter needs to be integrated properly.
Modified: dev/geode/ac97/selftest.fth =================================================================== --- dev/geode/ac97/selftest.fth 2010-01-05 23:22:48 UTC (rev 1646) +++ dev/geode/ac97/selftest.fth 2010-01-07 08:04:00 UTC (rev 1647) @@ -45,6 +45,8 @@ /cycle + ;
+\ This version puts the tone first into the left channel for +\ half the time, then into the right channel for the remainder : make-tone ( freq -- ) sample-rate to fs ( freq ) set-freq
@@ -64,6 +66,21 @@ /cycle +loop ;
+\ This version puts the tone into both channels simultaneously +: make-tone2 ( freq -- ) + sample-rate to fs ( freq ) set-freq + + record-base make-cycle drop + + \ Duplicate left into right in the template + record-base #cycle /l* bounds ?do i w@ i wa1+ w! /l +loop + + \ Replicate the template + record-base /cycle + record-len /cycle - bounds ?do + record-base i /cycle move + /cycle +loop +; + : tone ( freq -- ) record-len la1+ " dma-alloc" $call-parent to record-base make-tone
Modified: dev/hdaudio/conexant.fth =================================================================== --- dev/hdaudio/conexant.fth 2010-01-05 23:22:48 UTC (rev 1646) +++ dev/hdaudio/conexant.fth 2010-01-07 08:04:00 UTC (rev 1647) @@ -4,51 +4,67 @@
\ \ Conexant
-: power-on ( -- ) h# 70500 cmd ; -: power-off ( -- ) h# 70503 cmd ; +: power-on ( -- ) h# 70500 cmd ; \ Set power state - on +: power-off ( -- ) h# 70503 cmd ; \ Set power state - off : power-on-all ( -- ) " "(01 10 11 12 14 15 16 17 18 19 1a 1b 1c 1d 1e 1f 20 21 22 23 24)" bounds do i c@ to node power-on loop -; +;
+: set-node ( node-id -- ) to node ; + +: afg ( -- ) 1 set-node ; \ Audio Function Group +: dac1 ( -- ) h# 10 set-node ; +: adc1 ( -- ) h# 14 set-node ; +: mux ( -- ) h# 17 set-node ; \ mux between port b and port c +: mux2 ( -- ) h# 18 set-node ; +: porta ( -- ) h# 19 set-node ; +: portb ( -- ) h# 1a set-node ; \ Port B - OLPC external mic +: portc ( -- ) h# 1b set-node ; \ Port C - OLPC internal mic +: portd ( -- ) h# 1c set-node ; \ Port D - OLPC unused +: porte ( -- ) h# 1d set-node ; \ Port E - OLPC unused +: portf ( -- ) h# 1e set-node ; \ Port F - OLPC DC input +: portg ( -- ) h# 1f set-node ; \ Port G - speaker driver +: porth ( -- ) h# 20 set-node ; \ Port H - S/PDIF out +: porti ( -- ) h# 22 set-node ; \ Port I - S/PDIF out +: portj ( -- ) h# 23 set-node ; \ Digital mic +: vendor ( -- ) h# 25 set-node ; \ Vendor-specific controls + : volume-on-all ( -- ) - h# 14 to node h# 36006 cmd h# 35006 cmd - h# 23 to node h# 36004 cmd h# 35004 cmd - h# 17 to node h# 3a004 cmd h# 39004 cmd - h# 18 to node h# 3a004 cmd h# 39004 cmd - h# 14 to node h# 36200 cmd h# 35200 cmd - h# 10 to node h# 3a03e cmd h# 3903e cmd + adc1 h# 36006 cmd h# 35006 cmd \ Left gain/mute, right gain/mute + portj h# 36004 cmd h# 35004 cmd \ Left gain, right gain + mux h# 3a004 cmd h# 39004 cmd \ Left gain, right gain + mux2 h# 3a004 cmd h# 39004 cmd \ Left gain, right gain + adc1 h# 36200 cmd h# 35200 cmd \ Left gain/mute, right gain/mute + dac1 h# 3a03e cmd h# 3903e cmd \ Left gain, right gain ;
-h# 1a value mic-in \ Port B -h# 1b value mic \ Port C -h# 17 value mux \ mux between the two - : pin-sense? ( -- ? ) h# f0900 cmd? h# 8000.0000 and 0<> ; : set-connection ( n -- ) h# 70100 or cmd ; : enable-hp-input ( -- ) h# 70721 cmd ; : disable-hp-input ( -- ) h# 70700 cmd ;
: cx2058x-enable-recording ( -- ) - mic-in to node pin-sense? if - mux to node 0 set-connection mic-in to node enable-hp-input + portb pin-sense? if + mux 0 set-connection portb enable-hp-input else - mux to node 1 set-connection mic to node enable-hp-input + mux 1 set-connection portc enable-hp-input then ;
: cx2058x-disable-recording ( -- ) - mic-in to node disable-hp-input - mic to node disable-hp-input + portb disable-hp-input + portc disable-hp-input ;
: cx2058x-enable-playback ( -- ) - h# 19 to node pin-sense? if \ headphones attached - h# 1f to node power-off \ turn off speaker - else \ no headphones - h# 1f to node power-on \ turn on speaker - then - h# 10 to node h# 70640 cmd h# 20000 stream-format or cmd + porta pin-sense? if \ headphones attached + portg power-off \ turn off speaker + else \ no headphones + portg power-on \ turn on speaker + then + dac1 h# 70640 cmd \ 706sc - stream 4, channel 0 + h# 20000 stream-format or cmd ; : cx2058x-disable-playback ( -- ) ;
@@ -68,7 +84,7 @@ : unused ( u -- u ) h# 40000000 or ; : builtin ( u -- u ) h# 80000000 or ;
-: config( ( node -- null-config-default ) to node 0 ; +: config( ( node -- null-config-default ) 0 ;
: )config ( config-default -- ) \ set the high 24 bits of the config-default value @@ -78,25 +94,24 @@ 8 rshift h# ff and 71f00 or cmd ;
-: port-a ( -- u ) 19 config( 1/8" green left hp-out jack )config ; -: port-b ( -- u ) 1a config( 1/8" pink left mic-in jack )config ; -: port-c ( -- u ) 1b config( builtin front mic-in )config ; -: port-d ( -- u ) 1c config( unused line-out )config ; -: port-e ( -- u ) 1d config( unused line-out )config ; -: port-f ( -- u ) 1e config( 1/8" pink left line-in jack )config ; -: port-g ( -- u ) 1f config( builtin front speaker )config ; -: port-h ( -- u ) 20 config( unused spdiff-out )config ; -: port-i ( -- u ) 22 config( unused spdiff-out )config ; -: port-j ( -- u ) 23 config( unused mic-in )config ;
: config-default ( -- u ) f1c00 cmd? ;
: setup-config-default ( -- ) - port-a port-b port-c port-d port-e port-f port-g port-h port-i port-j + porta config( 1/8" green left hp-out jack )config + portb config( 1/8" pink left mic-in jack )config + portc config( builtin front mic-in )config + portd config( unused line-out )config + porte config( unused line-out )config + portf config( 1/8" pink left line-in jack )config + portg config( builtin front speaker )config + porth config( unused spdiff-out )config + porti config( unused spdiff-out )config + portj config( unused mic-in )config ;
: vendor-settings ( -- ) - h# 25 to node + vendor h# 290a8 cmd \ high-pass filter, semi-manual mode, 600Hz cutoff h# 34001 cmd \ speaker power 1 dB gain h# 38001 cmd \ over-current / short-circuit protection, 2.6A threshold @@ -121,7 +136,7 @@
\ Test word to make sure the right settings are configured : .vendor-settings ( -- ) - h# 25 to node + vendor h# 0a8 h# a9000 check-cmd h# 001 h# b4000 check-cmd h# 001 h# b8000 check-cmd @@ -135,17 +150,15 @@ ;
: cx2058x-open ( -- ) - h# 10 to dac - h# 14 to adc + ['] dac1 to with-dac + ['] adc1 to with-adc power-on-all volume-on-all vendor-settings setup-config-default ;
-: cx2058x-close ( -- ) - 1 to node ( function group) power-off -; +: cx2058x-close ( -- ) afg power-off ; \ Power off entire Audio Function Group
: cx2058x-init ( -- ) ['] cx2058x-open to open-codec
Modified: dev/hdaudio/core.fth =================================================================== --- dev/hdaudio/core.fth 2010-01-05 23:22:48 UTC (rev 1646) +++ dev/hdaudio/core.fth 2010-01-07 08:04:00 UTC (rev 1647) @@ -16,8 +16,8 @@ defer enable-codec-playback ' noop to enable-codec-playback defer disable-codec-playback ' noop to disable-codec-playback
-0 value dac \ digital to analogue converter node id -0 value adc \ analogue to digital converter node id +defer with-dac \ select digital to analogue converter node +defer with-adc \ select analogue to digital converter node
\ \ DMA setup
@@ -84,6 +84,11 @@ 1 value sample-format 2 value #channels
+variable in-stream-format h# 10 in-stream-format ! \ 48kHz 16bit mono +variable out-stream-format h# 11 out-stream-format ! \ 48kHz 16bit stereo + +defer selected-stream-format ' out-stream-format to selected-stream-format + : stream-format ( -- u ) sample-base d# 14 lshift ( acc ) sample-mul d# 11 lshift or ( acc ) @@ -92,19 +97,33 @@ #channels 1- or ( fmt ) ;
-: sample-rate! ( base mul div ) to sample-div to sample-mul to sample-base ; +: sample-rate! ( base mul div -- ) + 8 lshift swap d# 11 lshift or swap d# 14 lshift or ( rate-code ) + selected-stream-format @ h# ffffff00 invert and or selected-stream-format ! +; +: sample-width! ( code -- ) + 4 lshift + selected-stream-format @ h# f0 invert and or selected-stream-format ! +; +: channels! ( #channels -- ) + 1- + selected-stream-format @ h# f invert and or selected-stream-format ! +;
: 48kHz ( -- ) 0 0 0 sample-rate! ; : 44.1kHz ( -- ) 1 0 0 sample-rate! ; : 96kHz ( -- ) 0 1 0 sample-rate! ; : 192kHz ( -- ) 0 3 0 sample-rate! ;
-: 8bit ( -- ) 0 to sample-format ; -: 16bit ( -- ) 1 to sample-format ; -: 20bit ( -- ) 2 to sample-format ; -: 24bit ( -- ) 3 to sample-format ; -: 32bit ( -- ) 4 to sample-format ; +: 8bit ( -- ) 0 sample-width! ; +: 16bit ( -- ) 1 sample-width! ; +: 20bit ( -- ) 2 sample-width! ; +: 24bit ( -- ) 3 sample-width! ; +: 32bit ( -- ) 4 sample-width! ;
+: mono ( -- ) 1 channels! ; +: stereo ( -- ) 2 channels! ; + \ Stream descriptor register interface. \ There are multiple stream descriptors, each with their own register set. 0 value sd# @@ -199,7 +218,7 @@
0 0 value codec value node \ current target for commands
-: encode-command ( codec node verb -- ) +: encode-command ( verb -- ) codec d# 28 lshift node d# 20 lshift or or ;
@@ -241,6 +260,7 @@
d# 48.000 value sample-rate 1 value scale-factor +: upsampling? ( -- ? ) scale-factor 1 <> ;
: low-rate? ( Hz ) dup d# 48.000 < swap d# 44.100 <> and ;
@@ -278,34 +298,69 @@ \ \ Sound buffer \ Sample data for playback or recording.
-0 value sound-buffer -0 value sound-buffer-phys -0 value /sound-buffer +0 value in-buffer +0 value in-buffer-phys +0 value /in-buffer
-: install-sound-buffer ( adr len -- ) - 2dup to /sound-buffer to sound-buffer - true dma-map-in to sound-buffer-phys +0 value out-buffer +0 value out-buffer-phys +0 value /out-buffer + +: install-in-buffer ( adr len -- ) + 2dup to /in-buffer to in-buffer + true dma-map-in to in-buffer-phys ;
+: release-in-buffer ( -- ) + in-buffer in-buffer-phys /in-buffer dma-map-out +; + +: install-out-buffer ( adr len -- ) + 2dup to /out-buffer to out-buffer + true dma-map-in to out-buffer-phys +; + +: release-out-buffer ( -- ) + out-buffer out-buffer-phys /out-buffer dma-map-out + \ If we are upsampling, we allocated out-buffer so we need to free it. + \ If not, the caller owns out-buffer. + upsampling? if out-buffer /out-buffer dma-free then +; + \ Pad buffer: filled with zeros to pad out the end of the stream. \ (Streams automatically repeat -- this is so we'll have time to stop \ before that happens.)
-0 value pad-buffer -0 value pad-buffer-phys d# 8092 value /pad-buffer
-: alloc-pad-buffer ( -- ) - /pad-buffer dma-alloc to pad-buffer - pad-buffer /pad-buffer true dma-map-in to pad-buffer-phys - pad-buffer /pad-buffer 0 fill +0 value in-pad +0 value in-pad-phys + +: alloc-in-pad ( -- ) + /pad-buffer dma-alloc to in-pad + in-pad /pad-buffer true dma-map-in to in-pad-phys + in-pad /pad-buffer 0 fill ;
-: free-pad-buffer ( -- ) - pad-buffer pad-buffer-phys /pad-buffer dma-map-out - pad-buffer /pad-buffer dma-free +: free-in-pad ( -- ) + in-pad in-pad-phys /pad-buffer dma-map-out + in-pad /pad-buffer dma-free ;
+0 value out-pad +0 value out-pad-phys + +: alloc-out-pad ( -- ) + /pad-buffer dma-alloc to out-pad + out-pad /pad-buffer true dma-map-in to out-pad-phys + out-pad /pad-buffer 0 fill +; + +: free-out-pad ( -- ) + out-pad out-pad-phys /pad-buffer dma-map-out + out-pad /pad-buffer dma-free +; + \ \ Buffer Descriptor List
struct ( buffer descriptor ) @@ -315,54 +370,71 @@ 4 field >bd-ioc constant /bd
-0 value bdl -0 value bdl-phys +: set-buffer-descriptor ( phys uaddr len ioc bd-adr -- ) + tuck >bd-ioc ! tuck >bd-len ! tuck >bd-uaddr ! >bd-laddr ! +; + d# 256 /bd * value /bdl
-: buffer-descriptor ( n -- adr ) /bd * bdl + ; +0 value in-bdl +0 value in-bdl-phys
-: allocate-bdl ( -- ) - /bdl dma-alloc to bdl - bdl /bdl 0 fill - bdl /bdl true dma-map-in to bdl-phys +: in-buffer-descriptor ( n -- adr ) /bd * in-bdl + ; + +: allocate-in-bdl ( -- ) + /bdl dma-alloc to in-bdl + in-bdl /bdl 0 fill + in-bdl /bdl true dma-map-in to in-bdl-phys ;
-: free-bdl ( -- ) bdl bdl-phys /bdl dma-map-out bdl /bdl dma-free ; +: free-in-bdl ( -- ) in-bdl in-bdl-phys /bdl dma-map-out in-bdl /bdl dma-free ;
-: setup-bdl ( -- ) - allocate-bdl - sound-buffer-phys 0 buffer-descriptor >bd-laddr ! ( len ) - 0 0 buffer-descriptor >bd-uaddr ! ( len ) - /sound-buffer 0 buffer-descriptor >bd-len ! ( ) - 1 0 buffer-descriptor >bd-ioc ! - \ pad buffer - alloc-pad-buffer - pad-buffer-phys 1 buffer-descriptor >bd-laddr ! - 0 1 buffer-descriptor >bd-uaddr ! - /pad-buffer 1 buffer-descriptor >bd-len ! - 0 1 buffer-descriptor >bd-ioc ! +: setup-in-bdl ( -- ) + allocate-in-bdl + in-buffer-phys 0 /in-buffer 1 0 in-buffer-descriptor set-buffer-descriptor + alloc-in-pad + in-pad-phys 0 /pad-buffer 0 1 in-buffer-descriptor set-buffer-descriptor ;
-: teardown-bdl ( -- ) - free-bdl - free-pad-buffer +: teardown-in-bdl ( -- ) free-in-bdl free-in-pad ; + +0 value out-bdl +0 value out-bdl-phys + +: out-buffer-descriptor ( n -- adr ) /bd * out-bdl + ; + +: allocate-out-bdl ( -- ) + /bdl dma-alloc to out-bdl + out-bdl /bdl 0 fill + out-bdl /bdl true dma-map-in to out-bdl-phys ;
+: free-out-bdl ( -- ) out-bdl out-bdl-phys /bdl dma-map-out out-bdl /bdl dma-free ; + +: setup-out-bdl ( -- ) + allocate-out-bdl + out-buffer-phys 0 /out-buffer 1 0 out-buffer-descriptor set-buffer-descriptor + alloc-out-pad + out-pad-phys 0 /pad-buffer 0 1 out-buffer-descriptor set-buffer-descriptor +; + +: teardown-out-bdl ( -- ) free-out-bdl free-out-pad ; + \ \ Stream descriptor (DMA engine)
-: setup-stream ( -- ) +: setup-out-stream ( -- ) reset-stream - /sound-buffer /pad-buffer + sdcbl rl! \ bytes of stream data + /out-buffer /pad-buffer + sdcbl rl! \ bytes of stream data h# 440000 sdctl rl! \ stream 4 1 sdlvi rw! \ two buffers 1c sdsts rb! \ clear status flags - bdl-phys sdbdpl rl! - 0 sdbdpu rl! - stream-format sdfmt rw! + out-bdl-phys sdbdpl rl! + 0 sdbdpu rl! + out-stream-format @ sdfmt rw! ;
-: stream-done? ( -- ) sdsts c@ 4 and 0<> ; -: wait-stream-done ( -- ) begin stream-done? until ; +: stream-done? ( -- ) sdsts c@ 4 and 0<> ; +: wait-stream-done ( -- ) begin stream-done? until ;
\ \ Upsampling
@@ -425,52 +497,53 @@
\ \ Playback
+4 constant out-sd + false value playing?
-: upsampling? ( -- ? ) scale-factor 1 <> ; - : open-out ( -- ) - 4 to sd# + ['] out-stream-format to selected-stream-format d# 48.000 set-sample-rate ;
+: start-audio-out ( adr len -- ) + install-out-buffer ( ) + setup-out-bdl + out-sd to sd# + setup-out-stream + enable-codec-playback + start-stream + true to playing? +; : audio-out ( adr len -- actual ) dup >r upsampling? if scale-factor upsample then ( adr len ) - install-sound-buffer ( ) - setup-bdl - setup-stream - enable-codec-playback - start-stream + start-audio-out r> ( actual ) ;
-: release-sound-buffer ( -- ) - sound-buffer sound-buffer-phys /sound-buffer dma-map-out - upsampling? if sound-buffer /sound-buffer dma-free then -; - -: (write-done) ( -- ) +: stop-out ( -- ) + out-sd to sd# stop-stream - teardown-bdl - release-sound-buffer + teardown-out-bdl + release-out-buffer uninstall-playback-alarm + false to playing? ; -: write-done ( -- ) wait-stream-done (write-done) ; +: write-done ( -- ) out-sd to sd# wait-stream-done stop-out ;
: write ( adr len -- actual ) - 4 to sd# audio-out true to playing? install-playback-alarm + audio-out install-playback-alarm ;
-: ?end-sound ( -- ) - 4 to sd# - stream-done? if (write-done) false to playing? then +: ?end-playing ( -- ) + out-sd to sd# stream-done? if stop-out then ;
false value stop-lock : stop-sound ( -- ) true to stop-lock - playing? if (write-done) false to playing? then + playing? if stop-out then false to stop-lock ;
@@ -478,7 +551,7 @@ : playback-completed-alarm ( -- ) stop-lock if exit then playing? if - sd# ?end-sound to sd# + ?end-playing else \ If playback has already stopped as a result of \ someone else having waited for completion, we @@ -492,13 +565,13 @@ : still-playing? ( -- flag ) playing? 0= if false exit then stop-lock if true exit then - sd# ?end-sound to sd# + ?end-playing playing? ;
: wait-sound ( -- ) true to stop-lock - begin playing? while d# 10 ms ?end-sound repeat + begin playing? while d# 10 ms ?end-playing repeat false to stop-lock ;
@@ -506,7 +579,7 @@ false value right-mute?
: set-volume ( dB -- ) - dac to node + with-dac dB>step# dup left-mute? if h# 80 or then h# 3a000 or cmd \ left gain right-mute? if h# 80 or then h# 39000 or cmd \ right gain @@ -514,52 +587,84 @@
\ \ Recording
+0 constant in-sd 0 value recbuf 0 value recbuf-phys -d# 65535 value /recbuf
-: open-in ( -- ) d# 48.000 set-sample-rate ; +: open-in ( -- ) + ['] in-stream-format to selected-stream-format + d# 48.000 set-sample-rate +;
-: record-stream ( -- ) - 0 to sd# - 1 to #channels +: setup-in-stream ( -- ) + in-sd to sd# +\ 1 to #channels reset-stream - /sound-buffer /pad-buffer + sdcbl rl! \ buffer length + /in-buffer /pad-buffer + sdcbl rl! \ buffer length h# 100000 sdctl rl! \ stream 1, input 1 sdlvi rw! \ two buffers h# 1c sdsts c! \ clear status flags - bdl-phys sdbdpl rl! - 0 sdbdpu rl! - stream-format sdfmt rw! - adc to node - h# 70610 cmd \ stream 1, channel 0 - h# 20000 stream-format or cmd \ stream format + in-bdl-phys sdbdpl rl! + 0 sdbdpu rl! + in-stream-format @ sdfmt rw! + with-adc + h# 70610 cmd \ 706sc - stream 1, channel 0 + h# 20000 in-stream-format @ or cmd \ stream format ;
-: audio-in ( adr len -- actual ) - install-sound-buffer ( ) - setup-bdl - record-stream +0 value recording? +: start-audio-in ( adr len -- ) + install-in-buffer ( ) + setup-in-bdl + setup-in-stream enable-codec-recording start-stream - wait-stream-done + true to recording? +; +: stop-in ( -- ) + in-sd is sd# stop-stream - release-sound-buffer - teardown-bdl - /recbuf + teardown-in-bdl + release-in-buffer + false to recording? ; +: ?end-recording ( -- ) + in-sd to sd# + stream-done? if stop-in then +; +: audio-in ( adr len -- actual ) + start-audio-in + wait-stream-done + stop-in + /in-buffer +;
+: out-in ( out-adr out-len in-adr in-len -- ) + upsampling? if 2swap scale-factor upsample 2swap then ( out-adr,len in-adr,len ) + start-audio-in ( out-adr out-len ) + start-audio-out ( ) + begin + recording? if ?end-recording then + playing? if ?end-playing then + recording? 0= playing? 0= and + until +; + : close-in ( -- ) disable-codec-recording ;
+: pbuf " load-base 10000" evaluate ; +: rbuf " load-base 1meg + 20000" evaluate ; +: bufs ( -- pbuf,len rbuf,len ) pbuf rbuf ; + 0 value boost-db
: mic+20db ( -- ) d# 20 to boost-db ; : mic+0db ( -- ) 0 to boost-db ;
-: set-record-gain ( dB -- ) ; \ adc to node step# input-gain ; +: set-record-gain ( dB -- ) ; \ with-adc step# input-gain ; : in-amp-caps ( -- u ) h# f000d cmd? ; : in-gain-steps ( -- n ) in-amp-caps 8 rshift h# 7f and 1+ ; -: set-record-gain ( dB -- ) drop ( hardcoded for now ) adc to node h# 40 input-gain ; +: set-record-gain ( dB -- ) drop ( hardcoded for now ) with-adc h# 40 input-gain ;
\ LICENSE_BEGIN
Added: dev/hdaudio/noiseburst.fth =================================================================== --- dev/hdaudio/noiseburst.fth (rev 0) +++ dev/hdaudio/noiseburst.fth 2010-01-07 08:04:00 UTC (rev 1647) @@ -0,0 +1,486 @@ +.( cross-covariance audio test) cr +select /audio + +code mono-covar ( adr1 adr2 #samples -- d.sum ) + cx pop + + ax pop \ adr2 in ax + bx pop \ adr1 in bx + si push + di push + bp push + + ax si mov + bx di mov + + bp bp xor \ Zero accumulator + bx bx xor + + begin + op: ax lods + cwde + ax dx mov + op: 0 [di] ax mov + 2 [di] di lea + cwde + dx imul + ax bx add + dx bp adc + loopa + + bp ax mov + + bp pop + di pop + si pop + + bx push + ax push +c; +code stereo-mono-covar ( stereo-adr1 stereo-adr2 #samples -- d.sum ) + cx pop + + ax pop \ adr2 in ax + bx pop \ adr1 in bx + si push + di push + bp push + + ax si mov + bx di mov + + bp bp xor \ Zero accumulator + bx bx xor + + begin + op: ax lods + cwde + ax dx mov + op: 0 [di] ax mov + 4 [di] di lea \ Skip 2 samples for stereo + cwde + dx imul + ax bx add + dx bp adc + loopa + + bp ax mov + + bp pop + di pop + si pop + + bx push + ax push +c; +code stereo-covar ( stereo-adr1 stereo-adr2 #samples -- d.sum ) + cx pop + + ax pop \ adr2 in ax + bx pop \ adr1 in bx + si push + di push + bp push + + ax si mov + bx di mov + + bp bp xor \ Zero accumulator + bx bx xor + + begin + op: ax lods + 2 [si] si lea \ Skip other channel sample for stereo + cwde + ax dx mov + op: 0 [di] ax mov + 4 [di] di lea \ Skip 2 samples for stereo + cwde + dx imul + ax bx add + dx bp adc + loopa + + bp ax mov + + bp pop + di pop + si pop + + bx push + ax push +c; +code mono-wsum ( adr len -- d.sum ) + cx pop + + ax pop \ adr in ax + si push + bp push + + ax si mov + + bp bp xor \ Zero accumulator + bx bx xor + + begin + op: ax lods + cwde + cwd \ Actually cdq + ax bx add + dx bp adc + loopa + + bp ax mov + + bp pop + si pop + + bx push + ax push +c; +code stereo-wsum ( adr #samples -- d.sum ) + cx pop + + ax pop \ adr in ax + si push + bp push + + ax si mov + + bp bp xor \ Zero accumulator + bx bx xor + + begin + op: ax lods + 2 [si] si lea \ Skip other channel sample for stereo + cwde + cwd \ Actually cdq + ax bx add + dx bp adc + loopa + + bp ax mov + + bp pop + si pop + + bx push + ax push +c; +: mono-wmean ( adr len -- n ) + 2/ tuck mono-wsum ( d.sum len ) + rot m/mod nip ( mean ) +; +: stereo-wmean ( adr len -- n ) + 2/ 2/ tuck stereo-wsum ( d.sum len ) + rot m/mod nip ( mean ) +; +: -mono-wmean ( adr len -- ) + 2dup mono-wmean ( adr len mean ) + -rot bounds ?do ( mean ) + i <w@ over - h# 7fff min h# -7fff max i w! + /w +loop ( mean ) + drop ( ) +; +: -stereo-wmean ( adr len -- ) + 2dup stereo-wmean ( adr len mean ) + -rot bounds ?do ( mean ) + i <w@ over - h# 7fff min h# -7fff max i w! + /l +loop ( mean ) + drop ( ) +; +: lose-6db ( adr len -- ) + bounds ?do ( ) + i <w@ 2/ i w! ( ) + /w +loop ( ) +; + +create testarr 100 0 do 0 w, 100 w, loop + +create testarr2 100 0 do 0 w, -100 w, loop + +: .covar# ( d.covar -- ) + push-decimal + d# 1000000000 m/mod nip 8 .r + pop-base +; +: .m-covar ( adr1 adr2 len end-start -- ) + do + i 3 u.r space ( adr1 adr2 len ) + 3dup swap i wa+ swap mono-covar ( adr1 adr2 len d.covar ) + .covar# cr ( adr1 adr2 len ) + loop ( adr1 adr2 len ) + 3drop ( ) +; +: .sm-covar ( adr1 adr2 len end start -- ) + do + i 3 u.r space ( adr1 adr2 len ) + 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar ) + .covar# cr ( adr1 adr2 len ) + loop ( adr1 adr2 len ) + 3drop ( ) +; + +0. 2value total-covar +: sm-covar-sum ( adr1 adr2 len end start -- d.covar ) + 0. to total-covar + do + 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar ) + total-covar d+ to total-covar ( adr1 adr2 len ) + loop ( adr1 adr2 len ) + 3drop ( ) + total-covar +; +: sm-covar-abs-sum ( adr1 adr2 len end start -- d.covar ) + 0. to total-covar + do + 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 len d.covar ) + dabs total-covar d+ to total-covar ( adr1 adr2 len ) + loop ( adr1 adr2 len ) + 3drop ( ) + total-covar +; + +: ss-covar-abs-sum ( adr1 adr2 len end start -- d.covar ) + 0. to total-covar + do + 3dup swap i la+ swap stereo-covar ( adr1 adr2 len d.covar ) + dabs total-covar d+ to total-covar ( adr1 adr2 len ) + loop ( adr1 adr2 len ) + 3drop ( ) + total-covar +; + + +0 value max-index +0. 2value max-covar +: mono-covar-max ( adr1 adr2 #samples max-dly min-dly -- index ) + -1 to max-index ( adr1 adr2 #samples max-dly min-dly ) + 0. to max-covar ( adr1 adr2 #samples max-dly min-dly ) + + do ( adr1 adr2 #samples ) + 3dup swap i wa+ swap mono-covar ( adr1 adr2 #samples d.covar ) + dabs ( adr1 adr2 #samples |d.covar| ) + max-covar 2over d< if ( adr1 adr2 #samples |d.covar| ) + to max-covar i to max-index ( adr1 adr2 #samples ) + else ( adr1 adr2 #samples |d.covar| ) + 2drop ( adr1 adr2 #samples ) + then ( adr1 adr2 #samples ) + loop ( adr1 adr2 #samples ) + 3drop + max-index +; +: stereo-mono-covar-max ( adr1 adr2 #samples max-dly min-dly -- index ) + -1 to max-index ( adr1 adr2 #samples max-dly min-dly ) + 0. to max-covar ( adr1 adr2 #samples max-dly min-dly ) + + do ( adr1 adr2 #samples ) + 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 #samples d.covar ) + dabs ( adr1 adr2 #samples |d.covar| ) + max-covar 2over d< if ( adr1 adr2 #samples |d.covar| ) + to max-covar i to max-index ( adr1 adr2 #samples ) + else ( adr1 adr2 #samples |d.covar| ) + 2drop ( adr1 adr2 #samples ) + then ( adr1 adr2 #samples ) + loop ( adr1 adr2 #samples ) + 3drop + max-index +; +: mono-variance ( adr len -- d.variance ) + >r dup r> 2/ mono-covar +; +: left-variance ( adr len -- d.variance ) + >r dup r> 2/ 2/ stereo-covar +; +: right-variance ( adr len -- d.variance ) + >r wa1+ dup r> 2/ 2/ stereo-covar +; + +h# 40000 value /pb \ Stereo - 10000 is okay for fixter, 40000 is better for case, +: pb load-base ; +h# 21000 value /rb \ Mono (stereo for loopback) - 8100 for fixture, 21000 for case, +: rb load-base 1meg + ; + +: random-signal ( -- ) + pb /pb bounds do random-byte i c! loop + pb /pb -stereo-wmean + pb wa1+ /pb -stereo-wmean + pb /pb lose-6db +; + +: d.. ( -- ) <# # # # # ascii . hold # # # # ascii . hold #s #> type space ; +: find-max-mono ( -- ) + pb rb /pb 2 / h# 100 - d# 160 d# 120 mono-covar-max .d max-covar d.. +; +: find-max-left ( -- ) + pb rb /pb 4 / h# 100 - d# 160 d# 120 stereo-mono-covar-max .d max-covar d.. +; +: find-max-right ( -- ) + pb wa1+ rb /pb 4 / h# 100 - d# 160 d# 120 stereo-mono-covar-max .d max-covar d.. +; + +: #samples ( -- n ) /pb 4 / h# 100 - ; +: left-range ( -- stereo-adr mono-adr #points ) pb rb #samples ; +: right-range ( -- stereo-adr mono-adr #points ) pb wa1+ rb #samples ; +: left-stereo-range ( -- stereo-adr mono-adr #points ) pb rb #samples ; +: right-stereo-range ( -- stereo-adr mono-adr #points ) pb wa1+ rb wa1+ #samples ; + +: fixture-analyze-left ( -- ) + left-range d# 146 d# 141 sm-covar-sum dnegate + left-range d# 165 d# 155 sm-covar-sum d+ + left-range d# 190 d# 180 sm-covar-sum dnegate d+ + .covar# +; +: fixture-analyze-right ( -- ) + right-range d# 146 d# 141 sm-covar-sum dnegate + right-range d# 165 d# 155 sm-covar-sum d+ + right-range d# 190 d# 180 sm-covar-sum dnegate d+ + .covar# +; + +\ Reasonable threshold is d# 25 +: fixture-ratio-left ( -- ) + left-range d# 240 d# 140 sm-covar-abs-sum nip ( sum1 ) + left-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 ) + d# 10 swap */ + .d +; +: fixture-ratio-right ( -- ) + right-range d# 240 d# 140 sm-covar-abs-sum nip ( sum1 ) + right-range d# 400 d# 300 sm-covar-abs-sum nip ( sum1 sum2 ) + d# 10 swap */ + .d +; + +\ This compares the total energy within the impulse response band to the +\ total energy in a similar-length band +: case-ratio-left ( -- ratio ) + left-range d# 200 d# 140 sm-covar-abs-sum nip ( sum1.high ) + left-range d# 540 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high ) + d# 10 swap */ + .d +; +: case-ratio-right ( -- ratio ) + right-range d# 330 d# 140 sm-covar-abs-sum nip ( sum1.high ) + right-range d# 590 d# 400 sm-covar-abs-sum nip ( sum1.high sum2.high ) + d# 10 swap */ + .d +; + +\ This compares the total energy within the impulse response band to the +\ total energy in a similar-length band +: loopback-ratio-left ( -- ) + left-stereo-range d# 148 d# 128 ss-covar-abs-sum nip ( sum1.high ) + left-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high ) + d# 10 swap */ + .d +; +: loopback-ratio-right ( -- ) + right-stereo-range d# 148 d# 128 ss-covar-abs-sum nip ( sum1.high ) + right-stereo-range d# 220 d# 200 ss-covar-abs-sum nip ( sum1.high sum2.high ) + d# 10 swap */ + .d +; + + +d# 1024 /w* buffer: impulse-response + +: calc-sm-impulse ( offset -- ) \ offset is 0 for left or 2 for right + pb + rb #samples ( adr1 adr2 #samples ) + d# 1024 0 do + 3dup swap i wa+ swap stereo-mono-covar ( adr1 adr2 #samples d.covar ) + d# 50000000 m/mod nip ( adr1 adr2 #samples n.covar ) + impulse-response i wa+ w! ( adr1 adr2 #samples ) + loop ( adr1 adr2 len ) + 3drop ( ) +; +: .samples ( adr end start -- ) + do + i push-decimal 3 u.r pop-base ( adr ) + dup i wa+ <w@ push-decimal 8 .r pop-base cr ( adr ) + loop ( adr ) + drop +; +d# -23 value test-volume \ d# -23 for test fixture, d# -9 for in-case +defer rx-channels ' mono is rx-channels \ set to stereo for loopback +defer analyze-left +defer analyze-right +defer fix-dc +: setup-fixture ( -- ) + xxx - this needs to use the internal speakers and mic even though the loopback cable is attached + ['] mono is rx-channels + d# -23 is test-volume + h# 20000 to /pb \ Medium burst + /pb 2/ h# 1000 + to /rb \ Mono reception (internal mic) +\ ['] fixture-analyze-left to analyze-left +\ ['] fixture-analyze-right to analyze-right + ['] fixture-ratio-left to analyze-left + ['] fixture-ratio-right to analyze-right + ['] -mono-wmean to fix-dc +; +: setup-case ( -- ) + xxx - this needs to use the internal speakers and mic even though the loopback cable is attached + ['] mono is rx-channels + d# -9 is test-volume + h# 40000 to /pb \ Long burst for better S/N on far away speaker + /pb 2/ h# 1000 + to /rb \ Mono reception (internal mic) + ['] case-ratio-left to analyze-left + ['] case-ratio-right to analyze-right + ['] -mono-wmean to fix-dc +; +: setup-loopback ( -- ) + ['] stereo is rx-channels + d# -33 is test-volume + h# 10000 to /pb \ Short burst + /pb h# 1000 + to /rb \ Stereo reception + ['] loopback-ratio-left to analyze-left + ['] loopback-ratio-right to analyze-right + ['] -stereo-wmean to fix-dc +; +: doit ( -- ) + open-in 48kHz 16bit rx-channels with-adc d# 73 input-gain + \ -23 prevents obvious visible clipping + open-out 48kHz 16bit stereo test-volume set-volume + random-signal + lock[ \ Prevent timing jitter due to interrupts + pb /pb rb /rb out-in + ]unlock + rb /rb fix-dc +\ ." Mono " find-max-mono cr +\ ." Left " find-max-left cr +\ ." Right " find-max-right cr + analyze-left analyze-right +; + +0 [if] +: make-tone2 ( freq -- ) + sample-rate to fs ( freq ) set-freq + + \ Start with everything quiet + record-base record-len erase + + record-base make-cycle drop + + \ Duplicate left into right + record-base #cycle /l* bounds ?do i w@ i wa1+ w! /l +loop + + \ Replicate the wave template + record-base /cycle + record-len /cycle - bounds ?do + record-base i /cycle move + /cycle +loop +; +: freqtest ( frequency -- ) + open-in 48kHz 16bit mono with-adc d# 73 input-gain + \ -23 prevents obvious visible clipping + open-out 48kHz 16bit stereo d# -23 set-volume + + pb to record-base /pb to record-len + make-tone2 + + lock[ \ Prevent timing jitter due to interrupts + pb /pb rb /rb out-in + ]unlock + rb waveform +; +[then] +.( loaded) cr