\ pulse_tracker
\
\ pulse.tracker class: A generalization (and probably the simplest) of the
\ half dozen or so tempo trackers built over the years. This is essentially
\ an "additive" rhythm tracker with many compromises due to having to work
\ in a performance context (i.e. it has to be as fast as possible).
\
\ note: hmsl's default clock rate of 60 ticks per second isn't high enough
\ for tracking the pulse from a (humyn) performer -- try, say, 400 ticks.
\
\ thanks to Murray Campbell, Joel Ryan, io, Pedro Rebelo and Paul Berg.
\
\ code: Han-earl Park
\ copyright 2004 buster & friends' C-ALTO Labs
\ (Valencia, February 1999 -
\ (Southampton, September 2000 -
\
\ MOD: HeP 02/17/99	Started project.
\ MOD: HeP 10/01/99	Make subclass of ob.device, and not object.
\					Add subclass ob.pulse.tracker+
\ MOD: HeP 03/02/00 PUT.RANGE: checks that minimum pulse value is greater
\					than 0.
\ MOD: HeP 03/17/00	Remove ?INPUT: method declaration.
\					This class longer takes into account velocity, this
\					should be handled in the pulse.tracker+ class.
\ MOD: HeP 03/29/00	Add methods (PUT.DUR.DIM: GET.TIME: etc) to support use
\					with the parser class.
\ MOD: HeP 04/05/00	Change behavior of NOTE.ON: and NOTE.OFF: methods from
\					( note# vel time --  ) to ( note# vel --  ) since we
\					have the PUT.TIME: method.
\					User on and off functions can override behavior of the
\					ELEMENT.ON: and ELEMENT.OFF: methods.
\ MOD: HeP 05/08/00	As with the parser class, we rename the GET.TIME: as
\					TIME:, and add a _new_ GET.TIME: method returns the time
\					of the most recent event.
\ MOD: HeP 05/20/00	Specify behavior of the standard device class methods
\					UPDATE: RESET: and REFRESH:
\ MOD: HeP 11/03/00	Complete rewrite of PTRK.CALC.PULSE which should make the
\					code easier to read. The new design seems more responsive
\					and reliable with a pitch tracker (but maybe worse with a
\					midi keyboard?).
\					Clarify and rename "...-time" instance variables.
\					Rename HIT: as ON:, and add OFF: method.
\					Use TIME: rather than automatically using midi.time@.
\					Add dynamic "error" margin.
\ MOD: HeP 11/04/00	Even simpler pulse tracking algorithm (delete another
\					conditional).
\					Tested: Works well with monophonic pitch tracker.
\ MOD: HeP 11/05/00	GET.TIME: returns time of update rather than time of
\					last event.
\ MOD: HeP 11/06/00	Use midi.rtc.time@ rather than midi.time@.
\					Add some useful words including PTRK.NEXT.ON.DUR and
\					PTRK.NEXT.RTC.TIME.
\ MOD: HeP 11/12/00	Check if opened in the ELEMENT.ON: and ELEMENT.OFF:
\					methods.
\ MOD: HeP 03-23-04	Rewrite PTRK.WITHIN.ERROR.MARGIN? and better handling of
\					"rubato" and multiples of the base pulse.
\
\ ToDo:	Std methods DEFAULT: OPEN: CLOSE: UPDATE: RESET: and REFRESH:

include?  task-device  myt:device


anew task-pulse_tracker


method ON:				method OFF:

method TIME:
method PUT.TIME:		method GET.TIME:

method PUT.RANGE:		method PUT.ERROR.FACTOR:


:class  OB.PULSE.TRACKER  <super  OB.DEVICE
	
	iv.long  iv-ptrk-elm#
	iv.long  iv-ptrk-shape
	
	iv.byte  iv-ptrk-time-set?
	iv.long  iv-ptrk-set-time		\ user specified time value
	
	iv.long  iv-ptrk-dur-dim
	
	iv.long  iv-ptrk-prev-time
	iv.long  iv-ptrk-cur-time		\ time of current event being processed
	iv.long  iv-ptrk-updt-time		\ time of last update of pulse value
	
	iv.long  iv-ptrk-pulse-min
	iv.long  iv-ptrk-pulse-max
	
	iv.long  iv-ptrk-raw-pulse
	iv.long  iv-ptrk-pulse
	
	iv.long  iv-ptrk-error-factor
	
	
:m INIT:	(  --  )
	init: super
\
	0  iv=> iv-ptrk-elm#
	0  iv=> iv-ptrk-shape
\
	0  iv=> iv-ptrk-prev-time
	0  iv=> iv-ptrk-cur-time
	0  iv=> iv-ptrk-raw-pulse
	0  iv=> iv-ptrk-pulse
\
	0  iv=> iv-ptrk-dur-dim
;m

:m DEFAULT:	(  --  , set limits of pulse based on current clock rate )
	default: super
\
	rtc.rate@ 16 /  5 max  iv=> iv-ptrk-pulse-min
	rtc.rate@              iv=> iv-ptrk-pulse-max
\
	10  iv=> iv-ptrk-error-factor
;m

:m RESET:	(  --  , clear current pulse value )
	reset: super
\
	0  iv=> iv-ptrk-raw-pulse
;m

:m UPDATE:	(  --  , clear memory of previous values )
	
	\ ???
	
;m

:m REFRESH:	(  --  , clear memory of previous values )
	
	\ ???
	
;m


\ time

:m PUT.DUR.DIM:	( dim# | -1 --  , set shape dimension for time value )
	iv=> iv-ptrk-dur-dim
;m


:m PUT.TIME:	( ticks --  , user set time value )
	iv=> iv-ptrk-set-time
	true  iv=> iv-ptrk-time-set?
;m

:m GET.TIME:	(  -- ticks , return time of most recent event )
	iv-ptrk-updt-time
;m


: PTRK.TIME@	(  -- ticks , retrieve user specified or midi time value )
	iv-ptrk-time-set?
	IF
		iv-ptrk-set-time	\ user specified time
	ELSE
		midi.rtc.time@		\ use rtc time of last MIDI input
	THEN
;

:m TIME:	(  -- ticks , get time of current event )
	iv-ptrk-dur-dim 0<
	IF
		PTRK.TIME@
	ELSE
		iv-ptrk-shape
		IF
			iv-ptrk-elm# iv-ptrk-dur-dim  iv-ptrk-shape ed.at: []
		ELSE
			PTRK.TIME@
		THEN
	THEN
;m


\ tracker settings

:m PUT.RANGE:	( min max --  , set minimum and maximum pulse value )
	-2sort		\  -- max min
	dup 0<=
	IF	" put.range:"
		" minimum pulse must be greater than 0. Automatically setting minimum value to 1."
		er_warning  ob.report.error
	\
		drop  1
	THEN
	iv=> iv-ptrk-pulse-min  iv=> iv-ptrk-pulse-max
;m

:m PUT.ERROR.FACTOR:	( n --  , set "uncertainty" factor )
	dup 1 <
	IF
		" put.error.factor:"
		" error factor must be greater than 1 (probably 2 or greater)."
		er_return  ob.report.error
	\
		drop
	ELSE
		iv=> iv-ptrk-error-factor
	THEN
;m


\ pulse value
\
\	* Q/ Is dtime not less than iv-ptrk-pulse-min?
\			True  --> continue
\			False --> retain old pulse value
\
\	* Q/ Is dtime greater than the current pulse value?
\			True  --> continue
\			False --> store dtime as new pulse
\
\	* Q/ Is dtime a simple multiple of the current pulse value?
\			True  --> update pulse value
\			False --> store dtime as new pulse
\

: PTRK.UPDATE.PULSE	( dtime --  , update pulse value )
	dup  iv=> iv-ptrk-raw-pulse
	iv-ptrk-pulse-min iv-ptrk-pulse-max  clipto  iv=> iv-ptrk-pulse
\
	iv-ptrk-cur-time  iv=> iv-ptrk-updt-time
;

: PTRK.WITHIN.ERROR.MARGIN?	{ dtime -- flag , check if "rubato" }
	dtime iv-ptrk-raw-pulse /mod				\  -- rem dtime/pulse
	/											\  -- r/(dtime/pulse)
	iv-ptrk-raw-pulse iv-ptrk-error-factor /	\  -- r/(dtime/pulse) error
	<=
;

: PTRK.HANDLE.MULTIPLE	{ dtime -- pulse , dtime = N * pulse }
	dtime iv-ptrk-raw-pulse /mod	\  -- rem N
\
\ round up/down the remainder
\
	swap iv-ptrk-raw-pulse 2/
	>= -							\ ">= -" is the same as ">= IF 1 + THEN"
\
\ new pulse = dtime / N
\
	dtime swap /
;

: PTRK.CALC.PULSE	{ dtime --  , determine pulse of input }
	iv-ptrk-raw-pulse
	IF
		dtime iv-ptrk-raw-pulse >
		IF
			dtime  ptrk.within.error.margin?
			IF
				dtime  PTRK.HANDLE.MULTIPLE  ptrk.update.pulse
			ELSE
				dtime  ptrk.update.pulse
			THEN
		ELSE
			dtime  ptrk.update.pulse
		THEN
	ELSE
		dtime  ptrk.update.pulse
	THEN
;

:m GET:	(  -- ticks | 0 , current pulse if available )
	iv-ptrk-pulse
;m


\ input event

: PTRK.DTIME@	(  -- ticks | 0 , time between last events )
	iv-ptrk-cur-time iv-ptrk-prev-time -	\ time since last event
	dup  iv-ptrk-pulse-min <				\ too small?
	IF
		drop
		iv-ptrk-cur-time iv-ptrk-updt-time -	\ time since update
		dup  iv-ptrk-pulse-min <				\ too small?
		IF
			drop  0								\ give up
		THEN
	THEN
;

:m ON:	(  --  )
	iv-ptrk-cur-time  iv=> iv-ptrk-prev-time
	self  TIME: []    iv=> iv-ptrk-cur-time
\
	PTRK.DTIME@		\  -- ticks | 0
\
	?dup
	IF	dup  iv-ptrk-pulse-max  >
		IF
			drop
			0  iv=> iv-ptrk-raw-pulse
		ELSE
			PTRK.CALC.PULSE
		THEN
	THEN
;m

:m OFF:	(  --  , dummy method )
	" off:"
	" this method is an unimplemented stub"
	er_warning  ob.report.error
;m


\ for use with mp vector

:m NOTE.ON:		( note# vel --  )
	2drop  ON: self
;m

:m NOTE.OFF:	( note# vel --  )
	2drop
;m


\ for use with parser object

:m ELEMENT.ON:	( elm# sh --  )
	iv-dev-#opened
	IF
		iv=> iv-ptrk-shape
		iv=> iv-ptrk-elm#
	\
		iv-dev-on-cfa
		IF
			iv-ptrk-elm# iv-ptrk-shape  self  iv-dev-on-cfa  -3 exec.stack?
		ELSE
			ON: self
		THEN
	ELSE
		2drop
	THEN
;m

:m ELEMENT.OFF:	( elm# sh --  )
	iv-dev-#opened
	IF
		iv=> iv-ptrk-shape
		iv=> iv-ptrk-elm#
	\
		iv-dev-off-cfa
		IF	iv-ptrk-elm# iv-ptrk-shape  self  iv-dev-off-cfa  -3 exec.stack?
		THEN
	ELSE
		2drop
	THEN
;m


\ print

:m PRINT:	(  --  )
	print: super
	." Pulse:"                                           cr
	space ." Pulse        ="  iv-ptrk-pulse        4 .r  cr
	space ." Raw pulse    ="  iv-ptrk-raw-pulse    4 .r  cr
	space ." Minimum      ="  iv-ptrk-pulse-min    4 .r  cr
	space ." Maximum      ="  iv-ptrk-pulse-max    4 .r  cr
	space ." Error factor ="  iv-ptrk-error-factor 4 .r  cr
	." Time:"                                            cr
	space ." Last     ="     iv-ptrk-cur-time      8 .r  cr
	space ." Previous ="     iv-ptrk-prev-time     8 .r  cr
	space ." Update   ="     iv-ptrk-updt-time     8 .r  cr
	." Shape:"                                           cr
	space ." Last shape   = " iv-ptrk-shape  ob.name     cr
	space ." Last elm#    ="  iv-ptrk-elm#         4 .r  cr
	space ." DUR dim#     ="  iv-ptrk-dur-dim      4 .r  cr
;m

;class



\ useful words

: PTRK.NEXT.RTC.TIME	( ptrk -- ticks | 0 , rtc time of predicted on event )
	dup get: []				\  -- addr pulse
	dup
	IF
		swap get.time: []	\  -- pulse time
		BEGIN
			over +
			dup  rtc.time@  >=
		UNTIL
		+					\  -- time , add one more time just in case!
							\ there should be a more scientific way of doing this
	ELSE
		nip		\  -- 0
	THEN
;

: PTRK.NEXT.TIME	( ptrk -- ticks | 0 , advance time of predicted on event )
	ptrk.next.rtc.time
	dup
	IF	time-advance @ +
	THEN
;

: PTRK.NEXT.ON.DUR	( ptrk -- ticks | 0 , time until predicted on event )
	ptrk.next.rtc.time
	dup
	IF	rtc.time@ -
	THEN
;


\ test
\
\ aka the "free jazz bass player emulator"
\ set your synth to a acoustic bass preset

false .IF
	
	variable  predicted-time
	
	ob.pulse.tracker  test-tracker
	
	: PTRK.JOB.FUNC1	{ job --  }
		midi.lastoff
		get: test-tracker
		?dup
		IF	put.duration: job
			12 choose 45 + 60 midi.noteon
		THEN
	;
	
	: PTRK.JOB.FUNC2	{ job --  }
		midi.lastoff
		test-tracker PTRK.NEXT.ON.DUR
		?dup
		IF	put.duration: job
			24 choose 30 + 60 midi.noteon
		THEN
	;
	
	: CHECK.PREDICTION	(  --  )
		." off by = " predicted-time @  rtc.time@ - 4 .r
		test-tracker PTRK.NEXT.RTC.TIME  predicted-time !
	;
	
	: PTRK.TEST.ON	( note vel --  )
		note.on: test-tracker
		CHECK.PREDICTION
		."      Pulse = "  get: test-tracker 4 .r  cr
	;
	
	: PTRK.TEST.INIT	(  --  )
		400 rtc.rate!
		default: test-tracker
	\
		stuff{ 'c ptrk.job.func1 }stuff: job-1
		200 put.duration: job-1
	\
		stuff{ 'c ptrk.job.func2 }stuff: job-2
		200 put.duration: job-2
	\
		stuff{ job-1 job-2 }stuff: coll-p-1
	\
		mp.reset
		'c ptrk.test.on mp-on-vector !
		midi.clear
		midi.parser.on
		hmsl-graphics off
	;
	
	: PTRK.TEST.TERM	(  --  )
		mp.reset
		free.hierarchy: coll-p-1
	;
	
	if.forgotten  ptrk.test.term
	
	
	: PTRK.TEST	(  --  )
		ptrk.test.init  coll-p-1 hmsl.play  ptrk.test.term
	;
	
	cr cr  ." Enter PTRK.TEST to test the pulse.tracker class..."  cr cr
	
.THEN