Skip to content

Commit

Permalink
More dsp.dc lib refactoring to use locals; fix for biquad_lp_example.dc
Browse files Browse the repository at this point in the history
  • Loading branch information
Aaron K. Johnson committed Oct 21, 2024
1 parent e99a40b commit 174dd8a
Show file tree
Hide file tree
Showing 2 changed files with 160 additions and 181 deletions.
53 changes: 11 additions & 42 deletions examples/dsp_examples/biquad_lp_example.dc
View file
Original file line number Diff line number Diff line change
@@ -1,52 +1,21 @@
"dsp.dc" import

make_biquad myflt1
make_biquad myflt2
make_biquad myflt3
make_biquad myflt4
make_biquad myflt

: biquad_lp_example
#####################
# fat source (left) #
#####################
noise 0.3 *
dup
myflt1
false
120
67.2
biquad_lp
# scale down, it's louder
0.5 *
myflt2
false
120
1.2
biquad_bp
# scale down, it's louder
0.008 *
# mix into center
0.05
panmix
#####################################
# right side (duplicated from above #
#####################################
myflt3
false
120.431
67.2
# some noise, scaled to 0.1 max amplitude
noise 0.1 *
myflt
false
0.2 sine
500 *
1500 +
29.99
biquad_lp
# scale down, it's louder
0.5 *
myflt4
false
120.431
1.2
biquad_bp
# scale down, it's louder
0.002 *
0.07 *
# mix into center
0.95
0.5
panmix
# put to output
stereo_stack
Expand Down
288 changes: 149 additions & 139 deletions lib/dsp.dc
View file
Original file line number Diff line number Diff line change
Expand Up @@ -203,7 +203,6 @@ var _phasor_array 64 allot
@ # ( ceil_val )
;


: _interpolate { real_val floor_val ceil_val }
ceil_val floor_val -
real_val 1.0 %
Expand Down Expand Up @@ -329,174 +328,185 @@ var _phasor_array 64 allot
# BIQUAD FILTERS #
##################

: cutoff 0 + ;
: res 1 + ;
: theta 2 + ;
: alpha 3 + ;
: beta 4 + ;
: gamma 5 + ;
: chi 6 + ;
: mu 7 + ;
: sigma 8 + ;
: xt1 9 + ;
: yt1 10 + ;
: xt2 11 + ;
: yt2 12 + ;
: reinit 13 + ;

: reinit_biquad
# ( struct )
0.0 over xt1 !
0.0 over xt2 !
0.0 over yt1 !
0.0 over yt2 !
# ( struct )
;

: set_bq_type
# ( struct reinit cutoff res type -- struct reinit cutoff res )
4 pick
# ( * type struct )
over 0 =
0 const :cutoff
1 const :res
2 const :theta
3 const :alpha
4 const :beta
5 const :gamma
6 const :chi
7 const :mu
8 const :sigma
9 const :xt1
10 const :yt1
11 const :xt2
12 const :yt2
13 const :reinit

#################################
# biquad initialization helpers #
#################################

: _set_bq_type { struct type } # ( struct type -- )
type 0 =
if
-1.0 over chi !
2.0 over mu !
1.0 over sigma !
-1.0 struct :chi + !
2.0 struct :mu + !
1.0 struct :sigma + !
else
over 1 =
type 1 =
if
1.0 over chi !
-2.0 over mu !
1.0 over sigma !
1.0 struct :chi + !
-2.0 struct :mu + !
1.0 struct :sigma + !
else
over 2 =
type 2 =
if
1.0 over chi !
0.0 over mu !
-1.0 over sigma !
1.0 struct :chi + !
0.0 struct :mu + !
-1.0 struct :sigma + !
endif endif endif
2drop
;

: set_cf_res_reinit # ( struct reinit cutoff res )
3 pick res !
2 pick cutoff !
over reinit ! # ( struct )
;

: calc_theta # ( struct -- struct )
dup cutoff @ 2PIDSR *
over theta ! # ( struct )
;

: calc_beta # ( struct -- struct )
dup theta @ over res @ # ( struct theta res )
over sin 0.5 * # ( struct theta res sin(theta)*0.5 )
over swap - -rot # ( struct res-sin(theta)*0.5 theta res )
swap sin 0.5 * + # ( struct res-sin(theta)*0.5 res+sin(theta)*0.5 )
/ # ( (struct res-sin(theta)*0.5 / res+sin(theta)*0.5) )
over beta ! # struct
;

: calc_gamma # ( struct -- struct )
dup beta @ 1 + # ( struct beta+1)
over theta @ cos * # ( struct (beta+1)*cos(theta) )
over gamma ! # ( struct )
;

: calc_alpha # ( struct -- struct )
dup beta @ 1 + # ( struct beta+1 )
over gamma @ # ( struct beta+1 gamma )
2 pick chi @ # ( struct beta+1 gamma chi )
* + 0.5 * # ( struct (beta+1+(gamma*chi) * 0.5) )
over alpha ! # ( struct )
;

: init_biquad # ( struct reinit cutoff res type -- struct )
set_bq_type set_cf_res_reinit calc_theta
calc_beta calc_gamma calc_alpha
: _set_cf_res_reinit { struct reinit cutoff res }
res struct :res + !
cutoff struct :cutoff + !
reinit struct :reinit + !
;

: _calc_theta { struct } # ( struct -- )
struct :cutoff + @ # ( cutoff_val )
2PIDSR * # ( cutoff_val*2PIDSR )
struct :theta + # ( cutoff_val*2PIDSR theta_addr )
! # poked into theta
;

: _calc_beta { struct tmp } # ( struct tmp -- )
struct :res + @ # ( res )
struct :theta + @ # ( res theta )
sin 0.5 * # ( res sin(theta)*0.5 )
2dup # ( res sin(theta)*0.5 res sin(theta)*0.5 )
+ # ( res sin(theta)*0.5 res+sin(theta)*0.5 )
tmp! # ( res sin(theta)*0.5 <in_tmp> )
- # ( res-sin(theta)*0.5 <in_tmp> )
tmp # ( res-sin(theta)*0.5 res+sin(theta)*0.5 )
/ # ( (res-sin(theta)*0.5)/(res+sin(theta)*0.5) ) # answer
struct :beta + ! # poked into beta
;

: _calc_gamma { struct } # ( struct -- )
struct :beta + @ 1 + # ( beta+1 )
struct :theta + @ cos * # ( (beta+1)*cos(theta) )
struct :gamma + # ( (beta+1)*cos(theta) gamma_addr )
! # poked into gamma
;

: _calc_alpha { struct } # ( struct -- )
struct :beta + @ 1 + # ( beta+1 )
struct :gamma + @ # ( beta+1 gamma )
struct :chi + @ # ( struct beta+1 gamma chi )
* + 0.5 * # ( (beta+1+(gamma*chi))*0.5 )
struct :alpha + # ( (beta+1+(gamma*chi))*0.5 alpha_addr )
! # poked into alpha
;

: _reinit_biquad { struct } # ( struct -- )
0.0 struct :xt1 + !
0.0 struct :xt2 + !
0.0 struct :yt1 + !
0.0 struct :yt2 + !
;

#######################################################################
# entry-point for all biquad initialization, which uses above helpers #
#######################################################################
: _init_biquad { struct reinit cutoff res type } # ( struct reinit cutoff res type -- )
struct type _set_bq_type
struct reinit cutoff res _set_cf_res_reinit
struct _calc_theta
struct 0 _calc_beta
struct _calc_gamma
struct _calc_alpha
# check if we should reinit!
dup reinit @ if reinit_biquad else endif
struct :reinit + @ if
struct _reinit_biquad
endif
;

: biquad_compute
: biquad_compute { sig struct }
# ( sig struct -- sig_out )
# the actual transformative equation:
2dup # ( sig struct sig struct )
dup mu @ # ( sig struct sig struct mu )
swap xt1 @ # ( sig struct sig mu xt1 )
* # ( sig struct sig mu*xt1 )
2 pick # ( sig struct sig mu*xt1 struct )
dup sigma @ # ( sig struct sig mu*xt1 struct sigma )
swap xt2 @ # ( sig struct sig mu*xt1 sigma xt2 )
* # ( sig struct sig mu*xt1 xt2*sigma)
+ # ( sig struct sig mu*xt1+xt2*sigma)
+ # ( sig struct sig+mu*xt1+sigma*xt2 )
over alpha @ * # ( sig struct alpha*(sig+mu*xt1+sigma*xt2) )
over gamma @ # ( sig struct alpha*(sig+mu*xt1+sigma*xt2) gamma )
2 pick yt1 @ * # ( sig struct alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 )
2 pick beta @ # ( sig struct alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 beta )
3 pick yt2 @ # ( sig struct alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 beta yt2 )
*
-
+ # ( sig struct alpha*(sig+mu*xt1+sigma*xt2)+gamma*yt1-beta*yt2 )
struct :mu + @ # ( mu )
struct :xt1 + @ # ( mu xt1 )
* # ( mu*xt1 )
struct :sigma + @ # ( mu*xt1 sigma )
struct :xt2 + @ # ( mu*xt1 asigma xt2 )
* # ( mu*xt1 xt2*sigma)
+ # ( mu*xt1+xt2*sigma)
sig + # ( sig+mu*xt1+sigma*xt2 )
struct :alpha + @ # ( sig+mu*xt1+sigma*xt2 alpha )
* # ( alpha*(sig+mu*xt1+sigma*xt2 alpha) )
struct :gamma + @ # ( alpha*(sig+mu*xt1+sigma*xt2) gamma )
struct :yt1 + @ # ( alpha*(sig+mu*xt1+sigma*xt2) gamma yt1 )
* # ( alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 )
struct :beta + @ # ( alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 beta )
struct :yt2 + @ # ( alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 beta yt2 )
* # ( alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1 beta*yt2 )
- # ( alpha*(sig+mu*xt1+sigma*xt2) gamma*yt1-beta*yt2 )
+ # ( alpha*(sig+mu*xt1+sigma*xt2)+gamma*yt1-beta*yt2 )
# simplification:
# ( sig struct sig_out )
svpush # ( sig struct ) ( sig_out )
# ( sig_out )
##################################
# UPDATE xt2, yt2, xt1, and yt1: #
##################################
dup xt1 @ # ( sig struct xt1 ) ( sig_out )
over xt2 # ( sig struct xt1 xt2_addr ) ( sig_out )
! # ( sig struct ) ( sig_out )
dup yt1 @ # ( sig struct yt1 ) ( sig_out )
over yt2 # ( sig struct yt1 yt2_addr ) ( sig_out )
! # ( sig struct ) ( sig_out )
2dup xt1 # ( sig struct sig xt1_addr ) ( sig_out )
! # ( sig struct ) ( sig_out )
swap drop # ( struct ) ( sig_out )
svpop 2dup # ( struct sig_out struct sig_out ) ( )
swap yt1 # ( struct sig_out sig_out yt1_addr ) ( )
! # ( struct sig_out ) ( )
swap drop # ( sig_out ) ( )
;
struct :xt1 + @ # ( sig_out xt1_val )
struct :xt2 + # ( sig_out xt1_val xt2_addr )
! # ( sig_out )
struct :yt1 + @ # ( sig_out yt1_val )
struct :yt2 + # ( sig_out yt1_val yt2_addr )
! # ( sig_out )
sig # ( sig_out sig )
struct :xt1 + # ( sig_out sig xt1_addr )
! # ( sig_out )
dup # ( sig_out sig_out )
struct :yt1 + # ( sig_out sig_out yt1_addr )
! # ( sig_out )
;

#############################################
# The 'public' API words for biquad filters #
#############################################

: make_biquad
create
0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 , 0 ,
;

: biquad_lp # ( sig struct reinit cutoff res -- sig_out )
3 pick cutoff @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff )
4 pick res @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff bool_resdiff )
or if # ( sig struct reinit cutoff res )
0 init_biquad
else
2drop drop
: biquad_lp { sig struct reinit cutoff res } # ( sig struct reinit cutoff res -- sig_out )
struct :cutoff + @ cutoff <> # ( bool_cfdiff )
struct :res + @ res <> # ( bool_cfdiff bool_resdiff )
or if
struct reinit cutoff res 0 _init_biquad
endif
biquad_compute
sig struct biquad_compute
;

: biquad_hp # ( sig struct reinit cutoff res -- sig_out )
3 pick cutoff @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff )
4 pick res @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff bool_resdiff )
or if # ( sig struct reinit cutoff res )
1 init_biquad
else
2drop drop
: biquad_hp { sig struct reinit cutoff res } # ( sig struct reinit cutoff res -- sig_out )
struct :cutoff + @ cutoff <> # ( bool_cfdiff )
struct :res + @ res <> # ( bool_cfdiff bool_resdiff )
or if
struct reinit cutoff res 1 _init_biquad
endif
biquad_compute
sig struct biquad_compute
;

: biquad_bp # ( sig struct reinit cutoff res -- sig_out )
3 pick cutoff @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff )
4 pick res @ 2 pick <> # ( sig struct reinit cutoff res bool_cfdiff bool_resdiff )
or if # ( sig struct reinit cutoff res )
2 init_biquad
else
2drop drop
: biquad_bp { sig struct reinit cutoff res } # ( sig struct reinit cutoff res -- sig_out )
struct :cutoff + @ cutoff <> # ( bool_cfdiff )
struct :res + @ res <> # ( bool_cfdiff bool_resdiff )
or if
struct reinit cutoff res 1 _init_biquad
endif
biquad_compute
sig struct biquad_compute
;

#####################
Expand Down

0 comments on commit 174dd8a

Please sign in to comment.