Changeset 2260


Ignore:
Timestamp:
Jun 11, 2011 1:51:31 AM (2 years ago)
Author:
wmb
Message:

OLPC XO-1.75 trac #10886 - autocorrelation-based audio selftest for XO-1.75

Files:
7 edited

Legend:

Unmodified
Added
Removed

  • cpu/arm/olpc/1.75/alc5631.fth

    r2246 r2260  
    1515   d# 100 ms 
    1616 
    17    h# 8021 h# 34 codec!  \ Slave mode, 16 bits, left justified, left channel on LRCLK high 
     17   h# 8001 h# 34 codec!  \ Slave mode, 16 bits, left justified 
    1818 
    1919   h# 1010 h# 38 codec!  \ Divisors; the values in this register don't seem to make much 
    … …  
    9696false value force-speakers? 
    9797: set-volume  ( n -- ) 
    98    headphones-inserted?  force-speakers? 0=  and  if 
    99       set-headphone-volume 
     98   headphones-inserted?  ( force-speakers? 0= and )  if 
     99      set-headphone-volume mute-speakers 
    100100   else 
    101       set-speaker-volume 
     101      set-speaker-volume mute-headphones 
    102102   then 
    103103; 
    … …  
    180180: set-default-gains  ( -- ) 
    181181   output-config 
    182    headphones-inserted?  force-speakers? 0= and if 
     182   headphones-inserted?  ( force-speakers? 0= and  ) if 
    183183      headphones-on 
    184184      speakers-off 

  • cpu/arm/olpc/1.75/sound.fth

    r2246 r2260  
    4949: reset-rx  ( -- )  h# 8000.0002 h# 0c sspa!  ; 
    5050 
     51: active-low-rx-fs  ( -- )  
     52   h# 0c sspa@  h# 8001.0000 or  h# 0c sspa! 
     53; 
     54: active-high-rx-fs  ( -- )  
     55   h# 0c sspa@  h# 10000 invert and  h# 8000.0000 or  h# 0c sspa! 
     56; 
    5157: setup-sspa-rx  ( -- ) 
    5258   reset-rx 
    … …  
    6571   h# 8000.0000          \ Enable writes 
    6672   d# 15 d# 20 lshift or \ Frame sync width 
    67 \ We choose the master/slave configuration later, in enable-sspa-tx 
     73\ We choose the master/slave configuration later, in enable-sspa-rx 
    6874   0     d# 18 lshift or \ Internal clock - master configuration 
    6975   0     d# 17 lshift or \ Sample on rising edge of clock 
    70    0     d# 16 lshift or \ Active high frame sync 
     76   1     d# 16 lshift or \ Active low frame sync (I2S standard) 
    7177   d# 31 d#  4 lshift or \ Frame sync period 
    7278   1     d#  2 lshift or \ Flush the FIFO 
    … …  
    8187: reset-tx  ( -- )  h# 8000.0002 h# 8c sspa!  ; 
    8288 
     89: active-low-tx-fs  ( -- ) 
     90   h# 8c sspa@  h# 8001.0000 or  h# 8c sspa! 
     91; 
     92: active-high-tx-fs  ( -- ) 
     93   h# 8c sspa@  h# 10000 and  h# 8000.0000 or  h# 8c sspa! 
     94; 
    8395: setup-sspa-tx  ( -- ) 
    8496   reset-tx 
    … …  
    101113   0     d# 18 lshift or \ External clock - slave configuration (Rx is master) 
    102114   0     d# 17 lshift or \ Sample on rising edge of clock 
    103    0     d# 16 lshift or \ Active high frame sync 
     115 
     116\ Empirically, this needs to be backwards from what we think it should be 
     117   0     d# 16 lshift or \ Active high frame sync (should be active low, but that gives backwards results) 
     118 
    104119   d# 31 d#  4 lshift or \ Frame sync period 
    105120   1     d#  2 lshift or \ Flush the FIFO 
    … …  
    248263: open-in   ( -- )  ; 
    249264: close-in  ( -- )  ; 
    250 : open-out  ( -- )  setup-sspa-tx  ; 
     265: open-out  ( -- )  ; 
    251266: close-out ( -- )  ; 
    252267 
    … …  
    275290: stop-out  ( -- ) 
    276291   disable-sspa-tx 
     292   reset-tx 
    277293   stop-out-ring 
    278294   uninstall-playback-alarm 
    … …  
    314330   to out-len            ( adr ) 
    315331   to out-adr            ( ) 
     332   setup-sspa-tx         ( ) 
    316333   make-out-ring 
    317334   copy-out 
    … …  
    370387   repeat                      ( actual ) 
    371388   disable-sspa-rx             ( actual ) 
     389   reset-rx                    ( actual ) 
    372390; 
    373391: read  ( adr len -- actual )  open-in audio-in  ; 
    374392 
     3930 value mono? 
     3940 value in-adr0 
     3950 value in-len0 
     396: collapse-in  ( -- ) 
     397   in-len0  0  ?do 
     398      in-adr0 i la+ w@   in-adr0 i wa+ w! 
     399   loop 
     400; 
    375401: out-in  ( out-adr out-len in-adr in-len -- ) 
    376    to in-len   to in-adr       ( out-adr out-len ) 
     402   to in-len0  to in-adr0      ( out-adr out-len ) 
    377403   to out-len  to out-adr      ( ) 
     404 
     405   in-adr0 to in-adr           ( ) 
     406   in-len0  mono?  if  2*  then  to in-len      
     407 
     408   audio-clock-on              ( ) \ This will mess up any frequency settings 
    378409 
    379410   setup-sspa-tx               ( ) 
    380411   setup-sspa-rx               ( ) 
     412   active-high-rx-fs           ( ) 
    381413 
    382414   make-in-ring                ( ) 
    … …  
    403435   disable-sspa-tx             ( ) 
    404436 
     437   reset-rx 
     438   reset-tx 
     439 
    405440   dac-off  adc-off            ( ) 
     441 
     442   mono?  if  collapse-in  then  ( ) 
    406443; 
    407444 
    … …  
    453490; 
    454491 
    455 : stereo  ; 
    456 : mono  ; 
     492: stereo  false to mono?  ; 
     493: mono  true to mono?  ; 
    457494 
    458495: init-codec  ( -- ) 
    … …  
    4875242 value #channels 
    488525fload ${BP}/dev/hdaudio/test.fth 
     526: input-settings  ( -- ) 
     527   audio-clock-on              ( )  \ If you don't do this, the L/R phase is often wrong 
     528; 
     529: output-settings  ( -- )  ; 
     530' input-settings to input-common-settings 
     531' output-settings to output-common-settings 
    489532 
    490533end-package 

  • dev/hdaudio/noiseburst.fth

    r2254 r2260  
    303303; 
    304304: -stereo-wmean  ( adr len -- ) 
    305    2dup stereo-wmean  ( adr len mean ) 
    306    -rot  bounds  ?do  ( mean ) 
    307       i <w@ over - h# 7fff min  h# -7fff max  i w! 
     305   2dup stereo-wmean >r  ( adr len r: lmean ) 
     306   over wa1+ over  stereo-wmean r> swap ( adr len lmean rmean ) 
     307   2swap  bounds  ?do                   ( lmean rmean ) 
     308      i      <w@ 2 pick - h# 7fff min  h# -7fff max  i      w! 
     309      i wa1+ <w@ over   - h# 7fff min  h# -7fff max  i wa1+ w! 
    308310   /l +loop           ( mean ) 
    309311   drop               ( ) 
    … …  
    341343; 
    342344 
     345\ sample-delay accounts for the different timing between adc-on and dac-on 
     346\ for different combinations of codec and controller. 
     347 
     348d# 0 value sample-delay 
     349: +sample-delay  ( start #samples -- end' start' ) 
     350   swap  sample-delay +  swap bounds 
     351; 
    3433520. 2value total-covar 
    344 : sm-covar-sum  ( adr1 adr2 len end start -- d.covar ) 
     353: sm-covar-sum  ( adr1 adr2 len start #samples -- d.covar ) 
     354   +sample-delay      ( adr1 adr2 len end' start' ) 
    345355   0. to total-covar 
    346356   do 
    … …  
    349359   loop                 ( adr1 adr2 len ) 
    350360   3drop                ( ) 
    351    total-covar 
    352 ; 
    353 : sm-covar-abs-sum  ( adr1 adr2 len end start -- d.covar ) 
     361   total-covar  d2* d2* 
     362; 
     363: sm-covar-abs-sum  ( adr1 adr2 len start #samples -- d.covar ) 
     364   +sample-delay      ( adr1 adr2 len end' start' ) 
    354365   0. to total-covar 
    355366   do 
    … …  
    358369   loop                 ( adr1 adr2 len ) 
    359370   3drop                ( ) 
    360    total-covar 
    361 ; 
    362  
    363 : ss-covar-abs-sum  ( adr1 adr2 len end start -- d.covar ) 
     371   total-covar  d2* d2* 
     372; 
     373 
     374: ss-covar-abs-sum  ( adr1 adr2 len start #samples -- d.covar ) 
     375   +sample-delay      ( adr1 adr2 len end' start' ) 
    364376   0. to total-covar 
    365377   do 
    … …  
    368380   loop                 ( adr1 adr2 len ) 
    369381   3drop                ( ) 
    370    total-covar 
     382   total-covar  d2* d2* 
    371383; 
    372384 
    … …  
    458470; 
    459471 
     472d# 100 value #fixture 
     473d# 25 value fixture-threshold 
    460474: fixture-ratio-left  ( -- error? ) 
    461    left-range  d# 160 d#  60 sm-covar-abs-sum nip  ( sum1 )  
    462    left-range  d# 400 d# 300 sm-covar-abs-sum nip  ( sum1 sum2 ) 
     475   left-range  d#  60 #fixture sm-covar-abs-sum nip  ( sum1 )  
     476   left-range  d# 300 #fixture sm-covar-abs-sum nip  ( sum1 sum2 ) 
    463477   >ratio 
    464    d# 25 < 
     478   fixture-threshold < 
    465479; 
    466480: fixture-ratio-right  ( -- error? ) 
    467    right-range  d# 160 d#  60 sm-covar-abs-sum nip  ( sum1 )  
    468    right-range  d# 400 d# 300 sm-covar-abs-sum nip  ( sum1 sum2 ) 
     481   right-range  d#  60 #fixture sm-covar-abs-sum nip  ( sum1 )  
     482   right-range  d# 300 #fixture sm-covar-abs-sum nip  ( sum1 sum2 ) 
    469483   >ratio 
    470    d# 25 < 
    471 ; 
     484   fixture-threshold < 
     485; 
     486 
     487d#  60 value case-start-left 
     488d#  60 value case-start-right 
     489d# 400 value case-start-quiet 
     490d#  60 value #case-left 
     491d# 190 value #case-right 
     492d#  25 value case-threshold-left 
     493d#  14 value case-threshold-right 
    472494 
    473495\ This compares the total energy within the impulse response band to the 
    474496\ total energy in a similar-length band  
    475497: case-ratio-left  ( -- error? ) 
    476    left-range  d# 120 d#  60 sm-covar-abs-sum  nip ( sum1.high ) 
    477    left-range  d# 460 d# 400 sm-covar-abs-sum  nip ( sum1.high sum2.high ) 
     498   left-range  case-start-left  #case-left sm-covar-abs-sum  nip ( sum1.high ) 
     499   left-range  case-start-quiet #case-left sm-covar-abs-sum  nip ( sum1.high sum2.high ) 
    478500   >ratio 
    479    d# 25 < 
     501   case-threshold-left < 
    480502; 
    481503: case-ratio-right  ( -- error? ) 
    482     right-range  d# 250 d#  60 sm-covar-abs-sum  nip ( sum1.high ) 
    483     right-range  d# 590 d# 400 sm-covar-abs-sum  nip ( sum1.high sum2.high ) 
     504   right-range  case-start-right #case-right sm-covar-abs-sum  nip ( sum1.high ) 
     505   right-range  case-start-quiet #case-right sm-covar-abs-sum  nip ( sum1.high sum2.high ) 
    484506   >ratio 
    485    d# 14 < 
    486 ; 
    487  
     507   case-threshold-right < 
     508; 
     509 
     510d# 20 value #loopback 
     511d# 70 value loopback-threshold 
    488512\ This compares the total energy within the impulse response band to the 
    489513\ total energy in a similar-length band  
    490514: loopback-ratio-left  ( -- error? ) 
    491    left-stereo-range  d#  68 d#  48 ss-covar-abs-sum  nip ( sum1.high ) 
    492    left-stereo-range  d# 220 d# 200 ss-covar-abs-sum  nip ( sum1.high sum2.high ) 
     515   left-stereo-range  d#  48 #loopback ss-covar-abs-sum  nip ( sum1.high ) 
     516   left-stereo-range  d# 200 #loopback ss-covar-abs-sum  nip ( sum1.high sum2.high ) 
    493517   >ratio 
    494    d# 70 < 
     518   loopback-threshold < 
    495519; 
    496520: loopback-ratio-right  ( -- error? ) 
    497    right-stereo-range  d#  68 d#  48 ss-covar-abs-sum  nip ( sum1.high ) 
    498    right-stereo-range  d# 220 d# 200 ss-covar-abs-sum  nip ( sum1.high sum2.high ) 
     521   right-stereo-range  d#  48 #loopback ss-covar-abs-sum  nip ( sum1.high ) 
     522   right-stereo-range  d# 200 #loopback ss-covar-abs-sum  nip ( sum1.high sum2.high ) 
    499523   >ratio 
    500    d# 70 < 
     524   loopback-threshold < 
     525; 
     526 
     527\ Ideally we would not put platform-specific information in this module. 
     528\ If we add many more platforms, this should be redesigned. 
     529: configure-xo1.75  ( -- ) 
     530   d# -23 to sample-delay 
     531   d# 50 to fixture-threshold 
     532   d# 40 to #fixture 
     533   d# 83 to case-start-right 
     534   d# 30 to #case-right 
     535   d# 25 to case-threshold-right 
    501536; 
    502537 
    … …  
    508543   #impulse-response 0  do 
    509544      3dup swap i wa+ swap stereo-mono-covar  ( adr1 adr2 #samples d.covar ) 
    510       d# 50000000 m/mod nip                   ( adr1 adr2 #samples n.covar ) 
     545      d# 500,000,000 m/mod nip                ( adr1 adr2 #samples n.covar ) 
    511546      impulse-response i wa+ w!               ( adr1 adr2 #samples ) 
    512547   loop                 ( adr1 adr2 len ) 
    … …  
    517552   dup pb +  swap rb +  #samples              ( adr1 adr2 #samples ) 
    518553   #impulse-response 0  do 
    519       3dup swap i wa+ swap stereo-covar       ( adr1 adr2 #samples d.covar ) 
    520       d# 50000000 m/mod nip                   ( adr1 adr2 #samples n.covar ) 
     554      3dup swap i la+ swap stereo-covar       ( adr1 adr2 #samples d.covar ) 
     555      d#  50,000,000 m/mod nip                ( adr1 adr2 #samples n.covar ) 
    521556      impulse-response i wa+ w!               ( adr1 adr2 #samples ) 
    522557   loop                 ( adr1 adr2 len ) 
    … …  
    562597   h# 20000 to /pb          \ Medium burst 
    563598   /pb 2/ h# 1000 + to /rb  \ Mono reception (internal mic) 
    564 \   ['] fixture-analyze-left  to analyze-left 
    565 \   ['] fixture-analyze-right to analyze-right 
    566599   ['] fixture-ratio-left  to analyze-left 
    567600   ['] fixture-ratio-right to analyze-right 

  • dev/hdaudio/test.fth

    r2246 r2260  
    109109defer output-common-settings 
    110110[ifdef] with-adc 
    111 \ XXX this is hd-audio specific.  Factore it out 
     111\ XXX this is hd-audio specific.  Factor it out 
    112112: (input-common-settings)  ( -- ) 
    113113   open-in  48kHz  16bit  with-adc d# 73 input-gain 
    … …  
    121121 
    122122: test-with-case  ( -- ) 
    123    " setup-case" $call-analyzer 
     123\   " setup-case" $call-analyzer 
    124124\   xxx - this needs to use the internal speakers and mic even though the loopback cable is attached 
    125125   true to force-speakers?  true to force-internal-mic? 
     126   mic-bias-on 
    126127   input-common-settings  mono 
    127    output-common-settings  d# -9 set-volume 
     128   output-common-settings  d# -1 set-volume 
    128129   ." Testing internal speakers and microphone" cr 
    129130   " setup-case" test-common 
    … …  
    136137: test-with-fixture  ( -- error? ) 
    137138   true to force-speakers?  true to force-internal-mic? 
     139   mic-bias-on 
    138140   input-common-settings  mono 
    139    output-common-settings  d# -23 set-volume  \ -23 prevents obvious visible clipping 
     141   output-common-settings  d# -13 set-volume  \ -23 prevents obvious visible clipping 
    140142   ." Testing internal speakers and microphone with fixture" cr 
    141143   " setup-fixture" test-common 
    … …  
    147149; 
    148150: test-with-loopback  ( -- error? ) 
    149    input-common-settings  stereo 
    150    output-common-settings  d# -33 set-volume  \ -23 prevents obvious visible clipping 
     151   mic-bias-off 
     152   input-common-settings   stereo 
     153   output-common-settings  d# -22 set-volume 
    151154   ." Testing headphone and microphone jacks with loopback cable" cr 
    152155   " setup-loopback" test-common 
    … …  
    194197   then 
    195198; 
     199: configure-platform  ( -- ) 
     200   board-revision  h# 1a28 >=  if  " configure-xo1.75" $call-analyzer  exit  then 
     201; 
    196202\ Returns failure by throwing 
    197203: automatic-test  ( -- ) 
     204   configure-platform    
     205   disconnect-loopback  \ Not for 1.5; it can test internal while loopback is connected 
    198206   " smt-test?" evaluate  if 
    199207      test-with-fixture throw 

  • forth/kernel/double.fth

    r1430 r2260  
    4444: -drot ( d1 d2 d3 -- d3 d1 d2 )  drot drot  ; 
    4545: dinvert  ( d1 -- d2 )  swap invert  swap invert  ; 
     46 
     47: dlshift  ( d1 n -- d2 ) 
     48   tuck lshift >r                           ( low n  r: high2 ) 
     49   2dup bits/cell  swap - rshift  r> or >r  ( low n  r: high2' ) 
     50   lshift r>                                ( d2 ) 
     51; 
     52: drshift  ( d1 n -- d2 ) 
     53   2dup rshift >r                           ( low high n  r: high2 ) 
     54   tuck  bits/cell swap - lshift            ( low n low2  r: high2 ) 
     55   -rot  rshift  or                         ( low2  r: high2 ) 
     56   r>                                       ( d2 ) 
     57; 
     58: d>>a  ( d1 n -- d2 ) 
     59   2dup rshift >r                           ( low high n  r: high2 ) 
     60   tuck  bits/cell swap - lshift            ( low n low2  r: high2 ) 
     61   -rot  >>a  or                            ( low2  r: high2 ) 
     62   r>                                       ( d2 ) 
     63; 
     64 
    4665\ LICENSE_BEGIN 
    4766\ Copyright (c) 2006 FirmWorks 

  • forth/lib/isin.fth

    r2019 r2260  
    17170 value fstep 
    18180 value #cycle 
    19 0 value #half-cycle 
    20 0 value #quarter-cycle 
     190 value #cycle/2 
     200 value #cycle/4 
    2121 
    2222: set-freq  ( freq sample-rate -- ) 
    … …  
    2525   pi * to fstep 
    2626   fs freq /  dup  to #cycle 
    27    2/         dup  to #half-cycle 
    28    2/              to #quarter-cycle 
     27   2/         dup  to #cycle/2 
     28   2/              to #cycle/4 
    2929; 
    30 : set-period  ( quarter-cycle -- ) 
    31    dup to #quarter-cycle       ( quarter-cycle ) 
    32    2* dup to #half-cycle       ( half-cycle ) 
     30: set-period  ( cycle/4 -- ) 
     31   dup to #cycle/4       ( cycle/4 ) 
     32   2* dup to #cycle/2       ( cycle/2 ) 
    3333   2* dup to #cycle            ( cycle ) 
    3434   fs over / to freq           ( period ) 
    35    pi swap /  fs *  to fstep   ( ) 
     35   pi fs rot */  to fstep      ( ) 
    3636; 
    3737 
    … …  
    4343: sin-step  ( last divisor -- next )  thetasq  swap /  times  one min  one swap -  ; 
    4444 
     450 [if] 
     46\ Cos 
     47\ 1 - t^2/(2) + t^4/(2..4) - t^6/2..6) + t^8/(2..8) 
     48\ 1 - (t^2/(1*2)) * (1 - (t^2/(3*4)) * (1 - (t^2/(5*6)) * (1 - (t^2/(7*8)))) 
     49 
     50: icos  ( index -- frac ) 
     51   fstep fs 2/  */  to theta 
     52   theta dup times  to thetasq 
     53   one  d# 90 cos-step  d# 56 cos-step d# 30 cos-step  d# 12 cos-step  2 cos-step  one min 
     54; 
     55[then] 
     56 
    4557\ Taylor series expansion of sin, calculated as 
     58\ t - t^3/(2*3) + t^5/(2*3*4*5) - t^7/(2..7) + t^9/(2...9) 
    4659\ theta * (1 - (theta^2/(2*3)) * (1 - (theta^2/(4*5)) * (1 - (theta^2/(6*7)) * (1 - (theta^2/(8*9)))))) 
    4760\ This is good for the first quadrant only, i.e. 0 <= index <= fs / freq / 4 
    48 : isin  ( index -- frac ) 
    49    fstep *  fs 2/  /  to theta 
     61: calc-sin  ( index -- frac ) 
     62   fstep fs 2/  */  to theta 
    5063   theta dup times to thetasq 
    5164   one  d# 72 sin-step d# 42 sin-step  d# 20 sin-step  6 sin-step  theta times  one min 
    … …  
    5366 
    5467: one-cycle  ( adr -- ) 
    55    #quarter-cycle 1+  0  do   ( adr ) 
    56       i isin 
     68   #cycle/4 1+  0  do   ( adr ) 
     69      i calc-sin 
    5770      2dup  swap  i wa+ w!                ( adr isin ) 
    58       2dup  swap  #half-cycle i - wa+ w!  ( adr isin ) 
     71      2dup  swap  #cycle/2 i - wa+ w!     ( adr isin ) 
    5972      negate                              ( adr -isin ) 
    60       2dup  swap  #half-cycle i + wa+ w!  ( adr -isin ) 
     73      2dup  swap  #cycle/2 i + wa+ w!     ( adr -isin ) 
    6174      over  #cycle i - wa+ w!             ( adr ) 
    6275   loop                                   ( adr ) 
    6376   drop 
    6477; 
     78 
     79 
     800 [if] 
     81: reduce-to-quarter-cycle  ( -- ) 
     82   \ Move a cycle/4 to the left until negative, then fix 
     83   #cycle/4 -  dup 0<=  if  #cycle/4 +  (sin)          exit  then  ( theta' )  \ Quadrant 1 
     84   #cycle/4 -  dup 0<=  if  negate      (sin)          exit  then  ( theta' )  \ Quadrant 2 
     85   #cycle/4 -  dup 0<=  if  #cycle/4 +  (sin)  negate  exit  then  ( theta' )  \ Quadrant 3 
     86   #cycle/4 -               negate      (sin)  negate                          \ Quadrant 4 
     87; 
     88[then] 
     89 
     90\ For isin and icos we use a cosine table instead of a sine table. 
     91\ Argument reduction is a bit easier for cos because it is an even function. 
     92: one-cycle-cos  ( adr -- ) 
     93   #cycle/4 1+  0  do   ( adr ) 
     94      i calc-sin                           ( adr isin ) 
     95      2dup  swap  #cycle/4     i - wa+ w!  ( adr isin )  \ Quadrant 1 
     96      2dup  swap  #cycle/4 3 * i + wa+ w!  ( adr isin )  \ Quadrant 4 
     97      negate                               ( adr -isin ) 
     98      2dup  swap  #cycle/4     i + wa+ w!  ( adr -isin ) \ Quadrant 2 
     99      over        #cycle/4 3 * i - wa+ w!  ( adr )       \ Quadrant 3 
     100   loop                                    ( adr ) 
     101   drop 
     102; 
     103 
     104\ The scale factor for theta is such that h# 10000 is pi radians. 
     105\ Binary 1 is therefore pi/2^16 
     1060 value cos-table 
     107: init-sincos  ( -- ) 
     108   cos-table  if  exit  then 
     109   h# 20000 /w* alloc-mem  to cos-table 
     110   1 h# 20000 set-freq 
     111   cos-table one-cycle-cos 
     112; 
     113: release-cos-table  ( -- )  cos-table h# 20000 /w* free-mem  0 to cos-table  ; 
     114 
     115: icos  ( theta -- cos ) 
     116   abs                                    ( theta' ) 
     117   dup #cycle  >=  if  #cycle mod  then   ( theta' ) 
     118   cos-table swap wa+ <w@                 ( cos ) 
     119;    
     120: isin  ( theta -- sin )  #cycle/4 -  icos  ; 
     121 
    65122 
    66123\ d# 16000 to fs 

  • forth/lib/tones.fth

    r2019 r2260  
    44 
    55: make-cycle  ( adr -- adr' ) 
    6    #quarter-cycle 1+  0  do               ( adr ) 
    7       i isin                              ( adr isin ) 
    8       2dup  swap  i la+ w!                ( adr isin ) 
    9       2dup  swap  #half-cycle i - la+ w!  ( adr isin ) 
    10       negate                              ( adr -isin ) 
    11       2dup  swap  #half-cycle i + la+ w!  ( adr -isin ) 
    12       over  #cycle i - la+ w!             ( adr ) 
    13    loop                                   ( adr ) 
     6   #cycle/4 1+  0  do                  ( adr ) 
     7      i calc-sin                       ( adr isin ) 
     8      2dup  swap  i la+ w!             ( adr isin ) 
     9      2dup  swap  #cycle/2 i - la+ w!  ( adr isin ) 
     10      negate                           ( adr -isin ) 
     11      2dup  swap  #cycle/2 i + la+ w!  ( adr -isin ) 
     12      over  #cycle i - la+ w!          ( adr ) 
     13   loop                                ( adr ) 
    1414   /cycle + 
    1515; 
Note: See TracChangeset for help on using the changeset viewer.