.title	theme fit
	.enabl	lc
;++
;
; Program to fit a theme against itself.
;
; By John Wilson, Bennington College '91.
;
; 10/12/90	JMBW	Created.
; 11/09/90	JMBW	Random melody code.
; 11/11/90	JMBW	Play over MIDI port.
; 12/07/90	JMBW	Cares about key signature now.
;
;--
	.mcall	.exit,.gtlin,.print,.rsum,.spnd,.ttyout
.gtim=	emt+375
.mrkt=	emt+375
;
; MIDI port locations (DL11 w/MIDI board)
midcsr=	175610	;control/status register
midvec=	300	;interrupt vector
;
numhis=	5	;# of high scores to save
;
tab=	11
lf=	12
cr=	15
;
	.asect
;
; high score list entry:
.=	0
score:	.blkw	;score for this string
numnot:	.blkw	;# of notes in string
notstr:	.blkw	;note string
scrlen=	.	;length of score entry
;
; define intervals (in semitones):
.=	0
unison:	.blkb	;unison
min2:	.blkb	;minor second
maj2:	.blkb	;major second
min3:	.blkb	;minor third
maj3:	.blkb	;major third
perf4:	.blkb	;perfect 4th
trtone:	.blkb	;tritone
perf5:	.blkb	;perfect 5th
min6:	.blkb	;minor 6th
maj6:	.blkb	;major 6th
min7:	.blkb	;minor 7th
maj7:	.blkb	;major 7th
oct:	.blkb	;octave
;
; note durations:
breve=	200	;breve (double whole)
sbreve=	100	;semi-breve (whole)
minim=	40	;minim (half)
crtcht=	20	;crotchet (quarter)
quaver=	10	;quaver (eighth)
sqvr=	4	;semi-quaver (sixteenth)
dsqvr=	2	;demi-semi-quaver (thirty-second)
;
; chords we know (ignore inversions):
	.macro	ch	name,mask
b'name=	^B'mask
ch'name=foo
foo=	foo+1
	.endm
foo=	1
;
	ch	dim, 000001001001	;diminished triad
	ch	dim7,001001001001	;diminished 7th
	ch	min, 000010001001	;minor triad
	ch	min7,010010001001	;minor 7th
	ch	maj, 000010010001	;major triad
	ch	dom7,010010010001	;dominant 7th
	ch	maj7,100010010001	;major 7th
	ch	min6,000100100001	;minor 6th
	ch	maj6,001000100001	;major 6th
;
sw6=	<chmin6!chmaj6>&^C<chmin6&chmaj6> ;convert chmin6 to chmaj6 & v.v.
;
; notes are stored as follows:
.=	0
value:	.blkb	;note value (standard MIDI values)
duratn:	.blkb	;duration (half, quarter, etc.)
prev:	.blkw	;previous note in line
next:	.blkw	;next note in line
chprev:	.blkw	;prev note in chord
chnext:	.blkw	;next note in chord
flags:	.blkw	;flags
cont=	100000	;note is continued in next chord
length=	.	;length of a note record
;
; MIDI octaves
.=	0
oct0:	.blkb	12.
oct1:	.blkb	12.
oct2:	.blkb	12.
oct3:	.blkb	12.
oct4:	.blkb	12.
oct5:	.blkb	12.	;oct5+c is middle C
oct6:	.blkb	12.
oct7:	.blkb	12.
oct8:	.blkb	12.
oct9:	.blkb	12.
oct10:	.blkb	8.
;
; offsets of each note into the octave ($ means #)
.=	0
c:	.blkb
c$:	.blkb
d:	.blkb
d$:	.blkb
e:	.blkb
f:	.blkb
f$:	.blkb
g:	.blkb
g$:	.blkb
a:	.blkb
a$:	.blkb
b:	.blkb
;
; MIDI port regs
rcsr=	midcsr		;rcvr csr
; b7=rdy		;char is ready
; b6=ie			;interrupt enable
rbuf=	midcsr+2	;rcvr buf
; b15=err		;error bit, one of the following:
; b14=or		;overrun error (not read in time)
; b13=fer		;framing error (stop bit was not 1)
; b12=per		;parity error
xcsr=	midcsr+4	;xmtr csr
; b7=rdy		;rdy to xmit
; b6=ie			;interrupt enable
; b1=maint		;maintenance mode
; b0=break		;continuous break (may be jumpered out)
xbuf=	midcsr+6	;xmtr buf
.=	midvec
rvec:	.blkw	2	;rcvr vector
xvec:	.blkw	2	;xmtr vector
;
	.macro	retblk	reg
	mov	freblk,(reg)
	mov	reg,freblk
	.endm
;
	.sbttl	beginning of code
;
	.psect
reent:	nop			;re-entry addr is s.a. -2
start:	; set up free block list
	mov	#blocks,r5	;pt at them
	mov	#blklen/length-1,r3 ;length of area
	clr	(r5)		;first one is end of list
10$:	mov	r5,r4		;copy
	add	#length,r4	;skip to next
	mov	r5,(r4)		;link it
	mov	r4,r5		;skip
	sob	r3,10$		;loop
	mov	r5,freblk	;head of list
	; init random #'s
	mov	#gtim,r0	;get time
	.gtim			;for randomness
;	.print	#hello
aa:	; test random string routine
	call	clrscr		;clear scoreboard
	call	notein
	mov	r0,r5		;copy
	mov	r0,(pc)+	;save
10$:	.word
	; string is at (r5)
	; find length
	mov	r5,r4		;copy
	clr	r3		;zap
20$:	inc	r3		;count
	mov	next(r4),r4	;link
	bne	20$		;loop
	mov	r3,-(sp)	;save length
	mov	#500.,r2	;loop count
30$:	mov	r2,-(sp)	;save
	; get notes to match
	mov	2(sp),r0	;length
	clr	r1		;below our voice
	call	rndnot		;gets random string
	mov	2(sp),r0	;length
	call	chekhi		;check high score
	mov	(sp)+,r2	;restore count
	sob	r2,30$		;loop
	; print high score list
	mov	#hiscor,r4	;pt at high score list
	mov	#numhis,r3	;length
40$:	mov	r3,-(sp)	;save
	; clean the original theme
	mov	10$,r0		;get ptr
50$:	clr	chnext(r0)	;zap
	mov	next(r0),r0	;link
	bne	50$		;loop
	; display score and string
	mov	score(r4),r1	;score
	call	prnum
	.ttyout	#tab
	mov	notstr(r4),r5	;point
	mov	r4,-(sp)	;save
	call	dispst		;display
	mov	(sp)+,r4
	; input
	.gtlin	#kbbuf,#playit	;ask whether to play it
	cmpb	kbbuf,#'N	;don't play it?
	beq	60$		;right
	; play it - link to theme
	mov	r4,-(sp)	;save
	mov	10$,r5		;top
	mov	notstr(r4),r4	;bottom
	call	link		;link it
	call	play		;play
	mov	(sp)+,r4
60$:	add	#scrlen,r4	;skip
	mov	(sp)+,r3
	sob	r3,40$		;loop
	br	aa
playit:	.ascii	/Play? /<200>
	.even
;
bb:	.rem	_
; display the results
40$:	mov	(r0)+,r2	;get parms
	mov	r0,-(sp)
	mov	r1,-(sp)
	mov	r2,r1		;copy
	clrb	r1
	swab	r1
	call	prnum		;print
	bic	#^C377,r2	;isolate
	mov	#chtab,r0
50$:	cmp	r2,(r0)+	;is this it?
	beq	60$		;yes
	tst	(r0)+
	br	50$
60$:	mov	(r0)+,r0
	.print
	mov	(sp)+,r1
	mov	(sp)+,r0
	sob	r1,40$		;loop
	br	20$
;
_
chtab:	.word	chdim,xdim
	.word	chdim7,xdim7
	.word	chmin,xmin
	.word	chmin7,xmin7
	.word	chmaj,xmaj
	.word	chdom7,xdom7
	.word	chmaj7,xmaj7
	.word	chmin6,xmin6
	.word	chmaj6,xmaj6
;
xdim:	.asciz	/ dim/
xdim7:	.asciz	/ dim7/
xmin:	.asciz	/ min/
xmin7:	.asciz	/ min7/
xmaj:	.asciz	/ maj/
xdom7:	.asciz	/ dom7/
xmaj7:	.asciz	/ maj7/
xmin6:	.asciz	/ min6/
xmaj6:	.asciz	/ maj6/
	.even
;+
;
; Get a char from KB buf into r0, skipping blanks and ctrl chars.
;
; C=1 if eol or comma.
;
;-
getc:	movb	(r5)+,r0	;get a char
	beq	10$		;eol
	cmp	r0,#<' >	;blank or cc?
	blos	getc		;loop if so
	cmp	r0,#',		;comma?
	beq	10$		;yes, treat like eol
	clc			;C=0
	rts	pc
10$:	dec	r5		;unget
	sec			;C=1
	rts	pc
;
gtnum:	clr	r1		;init #
10$:	movb	(r5)+,r0	;get a char
	beq	20$		;whoops
	cmp	r0,#<' >	;blank or cc?
	blos	10$		;ignore
	sub	#'0,r0		;convert
	cmp	r0,#9.		;decimal?
	bhi	20$		;no
	mul	#10.,r1		;*10
	add	r0,r1		;add it in
	br	10$		;loop
20$:	dec	r5		;unget
	rts	pc
;
	.sbttl	search stuff
;+
;
; Clear high score list.
;
;-
clrscr:	mov	#hiscor,r0	;pt at list
	mov	#numhis*scrlen/2,r1 ;length
10$:	clr	(r0)+		;zap
	sob	r1,10$		;loop
	rts	pc
;+
;
; Check string against high score list, possibly add it.
;
; r4	string to add
; r3	score
; r0	# of notes
;
; r5 is preserved.
;
;-
chekhi:	mov	r5,-(sp)	;may have note string
	mov	r0,newscr+numnot ;save
	mov	r3,newscr+score
	mov	r4,newscr+notstr
	; scan the list to make sure we're not on it already
	mov	#hiscor,r5	;pt at list
	mov	#numhis,r4	;length
10$:	tst	notstr(r5)	;something here?
	beq	30$		;no
	cmp	newscr+numnot,numnot(r5) ;same # of notes?
	bne	30$		;no
	cmp	newscr+score,score(r5) ;same score?
	bne	30$		;no
	mov	newscr+notstr,r0 ;get 1st string
	mov	notstr(r5),r1	;2nd string
	mov	numnot(r5),r2	;length
20$:	cmp	(r0),(r1)	;same value/duratn fields?
	bne	30$		;no, skip
	mov	next(r0),r0	;deref
	mov	next(r1),r1
	sob	r2,20$		;loop
	br	60$		;they're equal, flush the new entry
30$:	add	#scrlen,r5	;skip to next
	sob	r4,10$		;loop
	; not on scoreboard, insert it if it belongs there
	mov	#newscr-scrlen,r5 ;ptr
	mov	#numhis,r3	;count
40$:	; since we want to compare score per note (entries with more
	; notes will tend to have higher scores since there are more intervals),
	; we will cross multiply the total scores and string lengths
	tst	notstr(r5)	;is this an empty entry?
	beq	50$		;yes, don't bother comparing, we win
	mov	(r5),r1		;get score
	mul	scrlen+numnot(r5),r1 ;yep
	mov	r1,r0		;copy
	mov	scrlen+score(r5),r1 ;from both
	mul	numnot(r5),r1
	cmp	r0,r1		;(r5)>=scrlen(r5)?  (*signed*)
	bge	60$		;yep, we're done
50$:	mov	r5,r4		;copy
	mov	(r5)+,r0	;exchange
	mov	(r5)+,r1
	mov	(r5)+,r2
	mov	(r5)+,(r4)+
	mov	(r5)+,(r4)+
	mov	(r5)+,(r4)+
	mov	r0,(r4)+
	mov	r1,(r4)+
	mov	r2,(r4)+
	sub	#scrlen*3,r5	;back up
	sob	r3,40$		;loop
60$:	; now flush whoever lost
	mov	newscr+notstr,r0 ;get note list
	beq	80$		;none, must have been a free slot in list
70$:	mov	next(r0),r1	;copy
	retblk	r0		;lost it
	mov	r1,r0		;copy
	bne	70$		;loop unless done
80$:	mov	(sp)+,r5	;restore
	rts	pc
;+
;
; Pump out a few random notes.
;
; r5	string to match
; r1	NZ if new voice should be above r5, Z if below
; r0	# notes to generate
;
; Returns:
; r5	unchanged
; r4	string we found
; r3	score
;
;-
rndnot:	mov	r5,-(sp)	;save string
	mov	r0,-(sp)	;save # notes
	mov	r1,-(sp)	;save flag
	call	getblk		;get a block
	mov	r0,r4		;pt with r4
10$:	; pick a starting note which is a happy interval away
	; from the starting note we're matching
	; (why not cut our losses)
	mov	#oct,r0		;look within an octave
	call	random		;get a random #
	movb	(r5),r1		;get curr note
	tst	(sp)		;which way?
	bne	20$		;above
	sub	r0,r1		;below
	br	30$
20$:	add	r0,r1		;above
30$:	movb	r1,(r4)		;save value
	movb	duratn(r5),duratn(r4) ;copy duration
	call	rate2		;get new score
	tst	r3		;what do you think?
	bmi	10$		;too sucky, try again
	tst	(sp)+		;lose flag
	mov	r4,-(sp)	;throw this on stack too
	mov	r3,-(sp)	;save score
	mov	r3,-(sp)	;twice
40$:	; do next note
	dec	6(sp)		;done?
	beq	110$		;yes
	call	getblk		;get a block
	mov	r4,prev(r0)	;link it in
	mov	r0,next(r4)
	mov	r0,r4		;pt with r4
	mov	next(r5),r5	;skip to next
	movb	duratn(r5),duratn(r4) ;copy length
50$:	; decide how far to move now
	mov	#4,r0		;get [0,3]
	call	random
	tst	r0		;stepwise for sure 3/4 of the time
	bne	80$		;yep
	; find out how far we may jump
	mov	#oct,r0		;up to an octave
	call	random		;get max interval in r0
	inc	r0		;+1 (fix bounds)
	call	random		;get the interval
	mov	r0,-(sp)	;save
	mov	#2,r0		;up or down?
	call	random
	mov	(sp)+,r1	;recover
	mov	prev(r4),r2	;prev note
	movb	(r2),r2		;value
	tst	r0		;down?
	beq	60$		;yep
	add	r1,r2		;up
	br	70$		;skip
60$:	sub	r1,r2		;down
70$:	movb	r2,(r4)		;go
	br	90$		;skip
80$:	; stepwise motion (half or whole tone either way, or repeat)
	mov	#5,r0		;-2, -1, 0, +1, +2
	call	random		;[0,4]
	sub	#2,r0		;[-2,2]
	mov	prev(r4),r1	;prev note
	movb	(r1),r1		;value
	add	r0,r1		;add it
	movb	r1,(r4)		;new value
90$:	; rate it
	call	rate2		;how's it look?
	tst	r3		;negative?
	bpl	100$		;no
	tst	2(sp)		;was prev score negative?
	bmi	50$		;yes, throw this note away
100$:	add	r3,(sp)		;add it in
	br	40$		;loop
110$:	; done
	mov	(sp)+,r3	;score
	tst	(sp)+		;lose prev interval score
	mov	(sp)+,r4	;starting pos
	tst	(sp)+		;lose count (0 by now)
	mov	(sp)+,r5	;old r5
	rts	pc
;+
;
; Rate a position.
;
; r5	ptr to top note in current chord
; r4	running score
;
;-
rate:	.rem	_
	mov	r5,r3		;copy
	mov	#chbuf,r2	;pt at buffer
10$:	movb	(r3)+,(r2)+	;get note
	mov	5(r3),r3	;get next in chord
	bne	10$		;loop for all
	clrb	(r2)		;mark end
	mov	#chbuf,r5	;pt at chord
	call	chord		;look it up
_
;+
;
; Rate a pair of voices.
;
; r5	upper voice
; r4	lower voice
;
; r3	returns score
;
;-
rate2:	clr	r3		;zap
	; see if there's a preceding interval
	; (there won't be if one of the voices is a new entrance)
	mov	#-1,r2		;no prev interval yet
	mov	prev(r5),r0	;get preceding upper voice
	beq	50$		;none, never mind
	mov	prev(r4),r1	;same for lower
	beq	50$		;none, don't worry about it
	; there is is preceding interval
	movb	(r0),r0		;get the notes themselves
	movb	(r1),r1
	; check motion and adjust score:
	; contrary or one note stayed the same: +5
	; similar: -5
	cmpb	(r5),r0		;has upper voice gone up or down?
	bhi	10$		;up
	beq	30$		;same
	cmpb	(r4),r1		;down, see if lower voice went up
	bhis	30$		;yes
	br	20$
10$:	cmpb	(r4),r1		;u.v. went up, see if l.v. went down
	blo	30$		;yes
20$:	sub	#10.,r3		;score -5 (-10.+5)
30$:	add	#5,r3		;score +5
40$:	; get previous interval into r2
	sub	r1,r0		;find interval
	movb	intrvl(r0),r2	;normalize to .lt. 1 octave
50$:	; get current interval
	movb	(r5),r0		;upper
	movb	(r4),r1		;lower
	sub	r1,r0		;absolute interval
	movb	intrvl(r0),r0	;normalized to one octave
	; prev interval in r2, current in r0
	mov	r2,r1		;copy
	asl	r1		;*2
	jmp	@prvint(r1)	;maybe it's a special case
	.word	cntcur		;there was no preceding interval
prvint:	.word	cntcur		;unison
	.word	cntcur		;minor 2nd
	.word	pmaj2		;major 2nd (lower resolves down to min3)
	.word	cntcur		;minor 3rd
	.word	cntcur		;major 3rd
	.word	pperf4		;perfect 4th (upper resolves down to maj3)
	.word	cntcur		;tritone
	.word	pperf5		;perfect 5th
	.word	cntcur		;minor 6th
	.word	cntcur		;major 6th
	.word	cntcur		;minor 7th (upper resolves down to maj6)  ????
	.word	cntcur		;major 7th (upper resolves up to octave)  ????
;
pperf5:	; perfect fifth
	asl	r3		;contrary motion is more important
	br	cntcur		;continue processing
;
; basically we want to make sure 5/4/1 resolves to 5/3/1
	.enabl	lsb
pmaj2:	cmp	r0,#min3	;resolved to minor 3rd?
	bne	10$		;no, points off
	cmpb	@prev(r5),(r5)	;upper voice the same?
	bne	10$		;no
	add	#30.,r3		;yes, bump their score
	br	cntcur
;
pperf4:	cmp	r0,#maj3	;resolved to maj3?
	bne	10$		;no
	cmpb	@prev(r4),(r4)	;lower voice the same?
	bne	10$		;no
	add	#30.,r3		;yes, bump score
	br	cntcur
;
10$:	; they blew it, points off (but keep trying just in case)
	sub	#50.,r3		;screw their score
	;br	cntcur		;drop through to continue with curr interval
	.dsabl	lsb
;
cntcur:	; continue with current interval
	cmpb	(r5),(r4)	;make sure voices are in right order
	bhis	10$		;yep
	sub	#50.,r3		;bad otherwise
10$:	; see both notes are in key signature
	clr	r1		;0's
	bisb	(r5),r1		;get one
	movb	colaps(r1),r1	;collapse to 1 octave
	tstb	keysig(r1)	;in key sig?
	bne	20$		;yes
	 sub	#20.,r3		;no, take off points
20$:	clr	r1		;0's
	bisb	(r4),r1		;get other
	movb	colaps(r1),r1	;collapse to 1 octave
	tstb	keysig(r1)	;in key sig?
	bne	30$		;yes
	 sub	#5,r3		;no, take off
30$:	mov	r0,r1		;copy current interval
	asl	r1		;*2
	jmp	@curint(r1)	;vector
curint:	.word	cunsn		;unison or octave - good (opposite directions)
	.word	min20		;min2 - bad
	.word	plus20		;maj2 - good but must resolve
	.word	third		;min3 - good (no more than 3 in a row)
	.word	third		;maj3 - good (no more than 3 in a row)
	.word	plus20		;perf4 - good but must resolve
	.word	min20		;tritone - bad
	.word	fifth		;perf5 - good but no similar or || motion
	.word	sixth		;min6 - good (no more than 3 in a row)
	.word	sixth		;maj6 - good (no more than 3 in a row)
	.word	min10		;min7 - should we let it resolve to maj6?
	.word	min10		;maj7 - should we let it resolve to octave?
;
min10:	sub	#10.,r3		;points off
	rts	pc
;
min20:	sub	#20.,r3		;points off
	rts	pc
;
plus20:	add	#20.,r3		;+20.
	rts	pc
;
cunsn:	tst	r2		;parallel octaves?
	beq	10$		;yes, no change in score
	add	#10.,r3		;+10.
10$:	rts	pc
;
third:	add	#30.,r3		;good
	rts	pc
;
fifth:	cmp	r2,#perf5	;parallel 5ths?
	beq	10$		;ding ding ding ding ding
	add	#25.,r3		;+10.
	rts	pc
10$:	sub	#50.,r3		;-50.
	rts	pc
;
sixth:	add	#20.,r3		;good
	rts	pc
;+
;
; Name that chord.
;
; On entry:
; r5	ptr to 0-terminated sorted note list
;
; On return:
; r0	ptr to list of possibilities <note,,chord>
; r1	number of possibilities found
;
; For each note in the chord:
; collapse the others into the octave above that note,
; and build a mask of all the notes that appear at least once.
; since a word is 16 bits we can fit the whole octave (12 notes)
; in a single word.  each bit represents a note, with the lowest
; note in the 1's bit, so that the word reads right to left
; (just because this is easier on the PDP-11).
;
; For chords of more than two distinct notes, there will usually
; be only one possible chord found.
;
;-
chord:	mov	#chdlst,-(sp)	;init ptr
	mov	r5,r4		;copy addr of begn of list
10$:	movb	(r4)+,r0	;get next bass note
	beq	80$		;none, skip
	clr	r1		;init mask
	mov	r5,r3		;pt at begn of list
20$:	movb	(r3)+,r2	;get a note
	beq	50$		;none, skip
	; calculate interval, normalize to octave above bass note
	sub	r0,r2		;subtract bass note
	bmi	40$		;negative, skip
30$:	sub	#oct,r2		;down an octave
	bpl	30$		;loop until negative (1 too many)
40$:	add	#oct,r2		;up an octave
	bmi	40$		;loop until positive
	asl	r2		;*2
	bis	bits(r2),r1	;set that bit in mask
	br	20$		;loop
50$:	; r0=bass note, r1=mask for chord
	; search chord table for first chord of which
	; ours is a proper subset (i.e. missing notes are OK)
	; (we check triads before 7ths so this won't add any
	; new ambiguities)
	mov	#chords,r3	;point at list
60$:	mov	(r3),r2		;get mask
	beq	10$		;end of table, guess not (try next bass note)
	bis	r1,r2		;set our bits
	cmp	r2,(r3)+	;same (is our chord improper subset)?
	beq	70$		;yes
	tst	(r3)+		;no, skip chord name
	br	60$		;loop
70$:	; found a match
	swab	r0		;swap to high byte
	bisb	(r3),r0		;get type
	mov	(sp)+,r2	;get ptr
	mov	r0,(r2)+	;save chord 
	mov	r2,-(sp)	;save
	br	10$		;next note
80$:	mov	#chdlst,r0	;get ptr
	mov	(sp)+,r1	;curr ptr
	sub	r0,r1		;find # bytes saved
	asr	r1		;/2=# words
	rts	pc
	.sbttl	terminal I/O routines
;+
;
; Note input routine.
;
; Return note list in r0 (0 if none).
;
;-
notein:	clr	-(sp)		;zap note list
	clr	r4		;no prev yet
	mov	#crtcht,r2	;previous note value = crotchet
	mov	#kbbuf,r5	;pt at buf
	.gtlin	r5,#ntprmp	;first prompt
	br	30$		;skip
10$:	.print	#invinp		;pr msg
20$:	mov	#kbbuf,r5	;pt at kbbuf
	.gtlin	r5,#ntprm2	;get a line
30$:	call	getc		;get a char
	bcs	20$		;need another line
	bic	#40,r0		;cvt to upper
	sub	#'A,r0		;convert
	cmp	r0,#6		;A-G?
	bhi	10$		;err
	movb	offs(r0),r1	;get offset
	call	getc		;get a char
	bcs	10$		;err
	cmp	r0,#'#		;sharp?
	beq	40$
	cmp	r0,#'+		;hm?
	bne	50$
40$:	; sharp
	inc	r1		;yes, +1
	br	60$		;skip
50$:	cmp	r0,#'-		;flat?
	bne	70$
	; flat
	dec	r1		;-1
60$:	call	getc		;get another
	bcs	10$		;error
70$:	; must be octave
	mov	r1,-(sp)	;save
	sub	#'0,r0		;subtract base
	cmp	r0,#9.		;good digit?
	bhi	10$		;complain
	mov	r0,r1		;copy
	call	getc		;another
	bcs	90$		;skip
	sub	#'0,r0		;convert
	cmp	r0,#9.		;good?
	bhi	80$		;nope, skip
	mul	#10.,r1		;yes, high dig *10
	add	r0,r1		;add this in
	inc	r5		;fakeout
80$:	dec	r5		;unget
90$:	mov	r1,r0		;copy back
	clr	r1		;zap
	bisb	octs(r0),r1	;get base
	add	(sp)+,r1	;find note
	; get duration
	call	getc		;get duration
	bcs	110$		;use default
	bic	#40,r0		;cvt to upper
	mov	r2,-(sp)	;save
	mov	#durtab,r3	;pt at table
100$:	mov	(r3)+,r2	;get next
	beq	150$		;err
	cmpb	r0,r2		;is this it?
	bne	100$		;loop if not
	clrb	r2		;zap
	swab	r2		;low byte
	tst	(sp)+		;flush stack
110$:	; note duration in r2
	call	getc		;any more chars?
	bcs	120$		;no
	; . = multiply duration by 1.5
	cmp	r0,#'.		;dotted?
	bne	150$		;no
	mov	r2,r0		;copy
	asr	r0		;/2
	add	r0,r2		;*1.5
120$:	; store note
	call	getblk		;get a block
	movb	r1,(r0)		;save value
	movb	r2,duratn(r0)	;duration
	mov	r4,prev(r0)	;set prev
	beq	130$		;none, skip
	mov	r0,next(r4)	;save
	br	140$		;skip
130$:	mov	r0,(sp)		;begn of list
140$:	mov	r0,r4		;new prev
	cmpb	(r5)+,#',	;comma?
	beq	30$		;yes, get more
	mov	(sp)+,r0	;get begn of list
	rts	pc
150$:	mov	(sp)+,r2	;recover value
	br	10$		;complain
;
offs:	.byte	a,b,c,d,e,f,g
octs:	.byte	oct0,oct1,oct2,oct3,oct4,oct5,oct6,oct7,oct8,oct9,oct10
	.even
durtab:	.byte	'D,breve	;double whole
	.byte	'W,sbreve	;whole
	.byte	'H,minim	;half
	.byte	'Q,crtcht	;quarter
	.byte	'E,quaver	;eighth
	.byte	'S,sqvr		;sixteenth
	.byte	'T,dsqvr	;thirty-second
	.word	0
;+
;
; Display a note string.
; Same format used by NOTEIN.
;
; r5	ptr to head of voice
;
;-
dispst:	mov	r5,r4		;copy
10$:	movb	(r4),r3		;get value
	clr	r2		;sxt
	div	#12.,r2		;divide
	asl	r3		;*2
	.print	ntnam(r3)	;print name
	mov	r2,r1		;get octave
	call	prnum		;display
	movb	duratn(r4),r2	;get value
	mov	#durtab,r1	;pt at table
20$:	movb	(r1)+,r0	;get letter
	beq	30$		;whoops
	cmpb	r2,(r1)+	;is this it?
	bne	20$		;loop if not
	br	40$		;skip
30$:	mov	#'?,r0		;don't know duration
40$:	.ttyout			;display it
	mov	next(r4),r4	;get next note
	beq	50$		;none, skip
	.ttyout	^!#',!		;comma
	.ttyout	<#' >		;blank
	br	10$		;loop
50$:	.print	#crlf		;end of string
	rts	pc
;
ntnam:	.word	1$,2$,3$,4$,5$,6$,7$,8$,9$,10$,11$,12$
1$:	.ascii	/C/<200>
2$:	.ascii	/C#/<200>
3$:	.ascii	/D/<200>
4$:	.ascii	/D#/<200>
5$:	.ascii	/E/<200>
6$:	.ascii	/F/<200>
7$:	.ascii	/F#/<200>
8$:	.ascii	/G/<200>
9$:	.ascii	/G#/<200>
10$:	.ascii	/A/<200>
11$:	.ascii	/A#/<200>
12$:	.ascii	/B/<200>
	.even
	.sbttl	MIDI routines
;+
;
; Play a note string.
;
; r5	ptr to head of note string
;
;-
play:	; next time slice
	mov	r5,r4		;copy
10$:	; start next note in chord
	mov	prev(r4),r0	;get prev ptr
	beq	20$		;none, skip
	tst	flags(r0)	;is this note continued from prev?
	bmi	30$		;yes, don't restrike
20$:	mov	#220,r0		;note on
	call	mput
	movb	(r4),r0		;(key)
	call	mput
	mov	#177,r0		;max velocity
	call	mput
30$:	mov	chnext(r4),r4	;next in chord
	bne	10$		;loop
	; wait
	clr	r0		;zap
	bisb	duratn(r5),r0	;get duration
	mul	#3,r0		;* multiplier
	mov	r0,delay	;save
	mov	r1,delay+2
	mov	#mrkt,r0	;pt at blk
	.mrkt			;start delay
	.spnd			;wait
	; turn off all non-continued notes
	mov	r5,r4		;copy
40$:	; stop next note in chord
	tst	flags(r4)	;continued?
	bmi	50$		;yes, skip this one
	mov	#200,r0		;note off
	call	mput
	movb	(r4),r0		;(key)
	call	mput
	mov	#177,r0		;max velocity
	call	mput
50$:	mov	chnext(r4),r4	;get next chord
	bne	40$		;loop until done
	; around for next chord
	mov	next(r5),r5	;defer
	bne	play		;loop
	rts	pc
;+
;
; Put a MIDI byte.
;
;-
mput:	tstb	@#xcsr		;ready?
	bpl	mput		;loop if not
	movb	r0,@#xbuf	;write
	rts	pc		;later
;
tcrtn:	; timer completion routine
	.rsum			;restart mainline
	rts	pc
;
	.sbttl	utility routines
;+
;
; Link a voice in below another voice.
;
; r5	existing voice
; r4	voice to link in
;
;-
link:	mov	r5,-(sp)	;save
	; link to end of preceding voice in this position
	mov	prev(r5),r0	;see if prev voice
	beq	10$		;none, skip
	mov	chnext(r0),r0	;get its lower neighbor
	beq	10$		;none
	mov	r4,next(r0)	;link this to it
	mov	r0,prev(r4)
10$:	; go through note by note and synchronize
	cmpb	duratn(r4),duratn(r5) ;duration the same?
	beq	30$		;yes, skip
	blo	60$		;smaller, split everyone else
	; larger, split our note in two pieces
	clr	r0		;get durations
	bisb	duratn(r5),r0
	clr	r1
	bisb	duratn(r4),r1
	sub	r0,r1		;find # left over
	movb	r0,duratn(r4)	;truncate this note
	call	getblk		;get another blk
	movb	(r4),(r0)	;set pitch
	movb	r1,duratn(r0)	;duration
	mov	r4,prev(r0)	;link this in
	mov	next(r4),r1	;get next note
	beq	20$		;none
	mov	r1,next(r0)	;link it in
	mov	r0,prev(r1)	;yep
20$:	mov	flags(r4),flags(r0) ;copy flags
	bis	#cont,flags(r4)	;previous note is continued
30$:	; equal, just link us in
	mov	r5,chprev(r4)	;yep
	mov	chnext(r5),r0	;get their lower neighbor
	beq	40$		;skip
	mov	r0,chnext(r4)	;link it in
	mov	r4,chprev(r0)	;us to them too
40$:	mov	r4,chnext(r5)	;link us to u.n.
	mov	next(r5),r5	;skip
	beq	50$		;whoops
	mov	next(r4),r4	;link
	bne	10$		;loop
50$:	mov	(sp)+,r5	;restore r5
	rts	pc
60$:	; our note is too short to fit
	; hack up the other notes
	bpt
;+
;
; Get and zero a note block, return ptr in r0.
;
; All other regs preserved.
;
;-
getblk:	mov	r1,-(sp)	;save
	mov	freblk,r0	;get a blk
	beq	30$		;whoops
	mov	(r0),freblk	;save
10$:	mov	#length/2,r1	;length
20$:	clr	(r0)+		;zap
	sob	r1,20$		;loop
	sub	#length,r0	;back up
	mov	(sp)+,r1	;restore
	rts	pc
30$:	; allocate more core
	bpt			;punt
;+
;
; Print # in r1.
;
;-
prnum:	tst	r1		;negative?
	bpl	10$		;no
	.ttyout	#'-		;yes
	neg	r1		;|r1|
10$:	clr	r0		;sxt
	div	#10.,r0		;divide
	bis	#'0,r1		;cvt
	tst	r0		;more?
	beq	20$		;no
	mov	r1,-(sp)	;save
	mov	r0,r1		;copy
	call	10$		;recurse
	mov	(sp)+,r1	;restore
20$:	.ttyout	r1		;display
	rts	pc
;+
;
; Random number from 0 to r0.
;
; Return in r0.
;
;-
random:	tst	r0		;nothing?
	beq	10$		;yep
	mov	seed,r1		;get seed
	mul	#257.,r1	;this never works...
	add	#11.,r1
	mov	r1,seed		;store it back
	mov	r0,r2		;save
	clr	r0		;sxt
	div	r2,r0		;divide
	mov	r1,r0		;copy remainder
10$:	rts	pc
;
chords:	.word	bmaj,chmaj
	.word	bmaj7,chmaj7
	.word	bdom7,chdom7
	.word	bmin,chmin
	.word	bmin7,chmin7
	.word	bdim,chdim
	.word	bdim7,chdim7
	.word	bmaj6,chmaj6
	.word	bmin6,chmin6
	.word	0
;
bits:	.word	1,2,4,10,20,40,100,200,400,1000,2000,4000 ;1st 12 bits
; collapsing lookup table.  collapses all notes into one octave
colaps:	.byte	0,1,2,3		;rest is from INTRVL
; interval lookup table.  collapses all intervals into one octave.
	.byte	4,5,6,7,10,11,12,13
	.rept	10.
	.byte	0,1,2,3,4,5,6,7,10,11,12,13
	.endr
intrvl:	.rept	10.
	.byte	0,1,2,3,4,5,6,7,10,11,12,13
	.endr
	.byte	0,1,2,3,4,5,6,7
;
hello:	.asciz	/Themefit   by John Wilson/
;
crlf:	.byte	0
;
ntprmp:	.ascii	'string: '<200>
ntprm2:	.ascii	'      : '<200>
invinp:	.asciz	'Invalid input'
;
	.even
gtim:	.byte	0,21	;.GTIM
	.word	time	;put it at TIME
;
mrkt:	.byte	0,22	;.MRKT
	.word	delay	;addr of time
	.word	tcrtn	;completion routine
	.word	1	;ID
;
keysig:	.byte	1,0,1,0,1,1,0,1,0,1,0,1 ;1 for notes in key sig
;
	.even
freblk:	.blkw			;free block list
;
time:	.blkw			;time in 60th's (high order first)
seed:	.blkw			;low word of time (should be random enough)
;
delay:	.blkw	2		;delay for .MRKT
;
hiscor:	.blkw	numhis*scrlen/2	;high score list
newscr:	.blkw	scrlen/2	;new entry to maybe add - must follow HISCOR
;
chdlst:	.blkw	10.		;chord list
kbbuf:	.blkb	80.		;KB buffer
blocks:	.blkw	1000.		;block buffer
blklen=	.-blocks
;
	.end	start