DECLARE FUNCTION InstallPlayer% ()
DECLARE SUB SetVolume (v%, vol%)
DECLARE SUB settimerfrq (hz%)
DECLARE SUB EraseAll ()
DECLARE SUB opl.playnote (v%, frq%, oct%)
DECLARE SUB opl.stopvoice (v%)
DECLARE FUNCTION readb% (fh%)
DECLARE SUB opl.out (reg%, vlu%)
DECLARE SUB opl.setinstr (v%, ini%)
DECLARE SUB ems.freepages (handle%)
DECLARE SUB ems.mappage (phy%, lgc%, handle%)
DECLARE FUNCTION ems.pageframe% ()
DECLARE SUB ErasePtn (ptn%)
DECLARE FUNCTION ems.allocpages% (npages%)
DECLARE FUNCTION opl.detect% ()
DEFINT A-Z
'$INCLUDE: 'QB.BI'

CONST cOffIns = &HFDC0&
DIM SHARED regs AS RegTypeX
DIM SHARED ems.status
DIM SHARED emsh, emsseg
DIM SHARED modptr(0 TO 8)

DIM SHARED vocoff(0 TO 8)
DIM SHARED frqtab(0 TO 11)

DIM SHARED length
DIM SHARED ord(0 TO 8, 0 TO 255)
DIM SHARED edpos, edrow

DIM SHARED speed
DIM SHARED ptnjmp, ptnbrk

DIM SHARED vocnte(0 TO 8)
DIM SHARED vocini(0 TO 8)
DIM SHARED vocvol(0 TO 8)
DIM SHARED vocfrq(0 TO 8)
DIM SHARED vococt(0 TO 8)
DIM SHARED frqinc(0 TO 8)
DIM SHARED arpfrq(0 TO 2, 0 TO 8)
DIM SHARED arpoct(0 TO 2, 0 TO 8)
DIM SHARED e6, e6start, e6end, e6count, e6max

dVocOff:
DATA 0,1,2,8,9,10,16,17,18

dFrqTab:
DATA &H157,&H16B,&H181,&H198,&H1B0,&H1CA
DATA &H1E5,&H202,&H220,&H241,&H263,&H287

SCREEN 0
CLS
PRINT "OOPS! The player routine must be called only from the TIMER event."
END

'NEW AND IMPROVET PLAYER ROUTINE FOR BENI TRACKER MODULES
'Supportet effects so far:
'(it is rather improbable that there are more to come)
'
'0xx: Arpeggio
'1xx: Pitch slide up
'2xx: Pitch slide down
'Bxx: Position jump
'Cxx: Volume
'Dxx: Pattern break
'E6x: Repeat x times from E60
'F0x: Set speed
'
BT.Play:
count = count + 1
IF count = speed THEN
	DEF SEG = emsseg
	FOR v = 0 TO 8
		arpfrq(0, v) = 0

		n = PEEK(modptr(v)): modptr(v) = modptr(v) + 1
		o = PEEK(modptr(v)): modptr(v) = modptr(v) + 1
		i = PEEK(modptr(v)): modptr(v) = modptr(v) + 1
		eh = PEEK(modptr(v)): modptr(v) = modptr(v) + 1
		el = PEEK(modptr(v)): modptr(v) = modptr(v) + 1
		IF i THEN
			IF n < 12 THEN
			'n+i
				opl.out &HB0 + v, 0
				IF vocini(v) <> i THEN
					opl.setinstr v, i
					vocini(v) = i
				ELSEIF eh <> &HC THEN
					SetVolume v, 63
				END IF
				IF eh = &HC THEN
					IF el < 2 THEN el = 2
					SetVolume v, el
					vocvol(v) = el
				ELSEIF eh <> &H3 THEN
					vocvol(v) = 63
				END IF
				frq = frqtab(n)
				opl.playnote v, frq, o
				vocnte(v) = n
				vocfrq(v) = frq
				vococt(v) = o
				frqinc(v) = 0
			ELSE
			'i
				IF vocini(v) <> i THEN
					opl.setinstr v, i
					vocini(v) = i
					IF eh = &HC THEN
						IF el < 2 THEN el = 2
						SetVolume v, el
						vocvol(v) = el
					ELSEIF vocvol(v) < 63 THEN
						SetVolume v, vocvol(v)
					END IF
				END IF
			END IF
		ELSE
			IF n < 12 THEN
			'n
				IF eh = &HC THEN
					IF el < 2 THEN el = 2
					SetVolume v, el
					vocvol(v) = el
				ELSEIF vocvol(v) < 63 THEN
					SetVolume v, vocvol(v)
				END IF
				frq = frqtab(n)
				opl.playnote v, frq, o
				vocnte(v) = n
				vocfrq(v) = frq
				vococt(v) = o
				frqinc(v) = 0
			ELSE
				IF eh = &HC THEN
					IF el < 2 THEN el = 2
					SetVolume v, el
					vocvol(v) = el
				END IF
			END IF
		END IF
		SELECT CASE eh
		CASE &H0:
			IF el THEN
				vn = vocnte(v)
				vo = vococt(v)
				arpfrq(0, v) = vocfrq(v)
				arpoct(0, v) = vo
				an1 = vn + (el \ 16)
				an2 = vn + (el AND 15)
				IF an1 > 11 THEN
					an1 = an1 - 12
					arpoct(1, v) = vo + 1
				ELSE
					arpoct(1, v) = vo
				END IF
				IF an2 > 11 THEN
					an2 = an2 - 12
					arpoct(2, v) = vo + 1
				ELSE
					arpoct(2, v) = vo
				END IF
				arpfrq(1, v) = frqtab(an1)
				arpfrq(2, v) = frqtab(an2)
				arp = 1
			END IF
		CASE &H1:
			frqinc(v) = frqinc(v) + el
			frq = vocfrq(v) + frqinc(v)
			opl.playnote v, frq, vococt(v)
		CASE &H2:
			frqinc(v) = frqinc(v) - el
			frq = vocfrq(v) + frqinc(v)
			opl.playnote v, frq, vococt(v)
		CASE &HB:
			ptnjmp = el
		CASE &HD:
			ptnbrk = el
		CASE &HE:
			hn = el \ 16
			IF hn = 6 THEN
				ln = el AND 15
				IF e6 = 0 THEN
					IF ln = 0 THEN
						e6start = edrow
					ELSE
						e6count = ln
						e6 = 1
					END IF
				END IF
				IF e6 = 1 THEN
					IF ln THEN
						e6count = e6count - 1
						IF e6count >= 0 THEN
							edrow = e6start
							GOSUB ModPtrsRofl
							GOTO DoneRow
						ELSE
							e6 = 0
						END IF
					END IF
				END IF
			END IF
		CASE &HF:
			speed = el
		END SELECT
	NEXT v

	IF ptnjmp >= 0 THEN
		edpos = ptnjmp
		IF ptnbrk >= 0 THEN
			edrow = ptnbrk
			GOSUB ModPtrsRofl
			ptnbrk = -1
		ELSE
			edrow = 0
			GOSUB ModPtrs
		END IF
		ptnjmp = -1
		GOTO DoneRow
	END IF

	IF ptnbrk >= 0 THEN
		edpos = edpos + 1
		IF edpos = length THEN edpos = 0
		edrow = ptnbrk
		GOSUB ModPtrsRofl
		ptnbrk = -1
		GOTO DoneRow
	END IF


	edrow = edrow + 1
	IF edrow = 64 THEN
		edpos = edpos + 1
		IF edpos = length THEN edpos = 0
		GOSUB ModPtrs
		edrow = 0
	END IF

DoneRow:
	count = 0
END IF

FOR v = 0 TO 8
	IF arpfrq(0, v) THEN
		frq = arpfrq(arppos, v) + frqinc(v)
		opl.playnote v, frq, arpoct(arppos, v)
	END IF
NEXT v
arppos = arppos + 1
IF arppos = 3 THEN arppos = 0
RETURN

ModPtrs:
modptr(0) = 320& * ord(0, edpos)
modptr(1) = 320& * ord(1, edpos)
modptr(2) = 320& * ord(2, edpos)
modptr(3) = 320& * ord(3, edpos)
modptr(4) = 320& * ord(4, edpos)
modptr(5) = 320& * ord(5, edpos)
modptr(6) = 320& * ord(6, edpos)
modptr(7) = 320& * ord(7, edpos)
modptr(8) = 320& * ord(8, edpos)
RETURN

ModPtrsRofl:
rofl = 5 * edrow
modptr(0) = (320& * ord(0, edpos)) + rofl
modptr(1) = (320& * ord(1, edpos)) + rofl
modptr(2) = (320& * ord(2, edpos)) + rofl
modptr(3) = (320& * ord(3, edpos)) + rofl
modptr(4) = (320& * ord(4, edpos)) + rofl
modptr(5) = (320& * ord(5, edpos)) + rofl
modptr(6) = (320& * ord(6, edpos)) + rofl
modptr(7) = (320& * ord(7, edpos)) + rofl
modptr(8) = (320& * ord(8, edpos)) + rofl
RETURN

FUNCTION ems.allocpages (npages)
	regs.ax = &H4300
	regs.bx = npages
	InterruptX &H67, regs, regs
	ems.status = regs.ax \ 256
	ems.allocpages = regs.dx
END FUNCTION

SUB ems.freepages (handle)
	regs.ax = &H4500
	regs.dx = handle
	InterruptX &H67, regs, regs
	ems.status = regs.ax \ 256
END SUB

SUB ems.mappage (phy, lgc, handle)
	regs.ax = &H4400 OR phy
	regs.bx = lgc
	regs.dx = handle
	InterruptX &H67, regs, regs
	ems.status = regs.ax \ 256
END SUB

FUNCTION ems.pageframe
	regs.ax = &H4100
	InterruptX &H67, regs, regs
	ems.status = regs.ax \ 256
	ems.pageframe = regs.bx
END FUNCTION

SUB EraseAll
	DIM rofl AS LONG

	FOR ptn = 0 TO 202
		ErasePtn ptn
	NEXT ptn
	DEF SEG = emsseg
	rofl = cOffIns
	FOR a = 0 TO 351
		POKE rofl, 0
		rofl = rofl + 1
	NEXT a
END SUB

SUB ErasePtn (ptn)
	DIM rofl AS LONG

	rofl = 320& * ptn
	DEF SEG = emsseg
	FOR row = 0 TO 63
		POKE rofl, 12: rofl = rofl + 1
		POKE rofl, 0: rofl = rofl + 1
		POKE rofl, 0: rofl = rofl + 1
		POKE rofl, 0: rofl = rofl + 1
		POKE rofl, 0: rofl = rofl + 1
	NEXT row
END SUB

FUNCTION InstallPlayer
	IF opl.detect = 0 THEN
		PRINT "No Adlib-compatible sound card"
		InstallPlayer = 0
		EXIT FUNCTION
	END IF
	emsh = ems.allocpages(4)
	IF ems.status THEN
		PRINT "EMS allocation problem"
		InstallPlayer = 0
		EXIT FUNCTION
	END IF
	ems.mappage 0, 0, emsh
	ems.mappage 1, 1, emsh
	ems.mappage 2, 2, emsh
	ems.mappage 3, 3, emsh
	emsseg = ems.pageframe
	IF ems.status THEN
		ems.freepages emsh
		PRINT "EMS mapping problem"
		InstallPlayer = 0
		EXIT FUNCTION
	END IF
	RESTORE dVocOff
	FOR a = 0 TO 8: READ vocoff(a): NEXT a
	RESTORE dFrqTab
	FOR a = 0 TO 11: READ frqtab(a): NEXT a
	DEF SEG = emsseg
	rofl& = cOffIns + (11 * 32) + 2
	POKE rofl&, 63
	POKE rofl& + 1, 63
	POKE rofl& + 2, 255
	POKE rofl& + 3, 255
	POKE rofl& + 4, 15
	POKE rofl& + 5, 15
	speed = 6
	InstallPlayer = 1
END FUNCTION

SUB LoadMod (filenm$)
	DIM rofl AS LONG

	OPEN filenm$ FOR BINARY ACCESS READ AS #1
	EraseAll
	length = readb(1)
	nptns = readb(1)
	ninstrs = readb(1)
	DIM ptnmap(0 TO nptns - 1)
	DIM insmap(0 TO ninstrs - 1)
	FOR a = 0 TO nptns - 1
		ptnmap(a) = readb(1)
	NEXT a
	FOR a = 0 TO ninstrs - 1
		insmap(a) = readb(1)
	NEXT a
	FOR ps = 0 TO length - 1
		FOR v = 0 TO 8
			ord(v, ps) = readb(1)
		NEXT v
	NEXT ps
	DEF SEG = emsseg
	FOR a = 0 TO nptns - 1
		ptn = ptnmap(a)
		rofl = 320& * ptn
		FOR row = 0 TO 63
			b1 = readb(1)
			b2 = readb(1)
			el = readb(1)
			n = b1 \ 16
			o = (b1 \ 2) AND 7
			i = (16 * (b1 AND 1)) OR (b2 \ 16)
			eh = b2 AND 15
			POKE rofl, n: rofl = rofl + 1
			POKE rofl, o: rofl = rofl + 1
			POKE rofl, i: rofl = rofl + 1
			POKE rofl, eh: rofl = rofl + 1
			IF eh = &HC THEN
				IF el > 63 THEN el = 63
			END IF
			POKE rofl, el: rofl = rofl + 1
		NEXT row
	NEXT a
	FOR a = 0 TO ninstrs - 1
		ini = insmap(a)
		rofl = cOffIns + (11 * ini)
		FOR rept = 0 TO 10
			POKE rofl, readb(1)
			rofl = rofl + 1
		NEXT rept
	NEXT a
	CLOSE #1
END SUB

FUNCTION opl.detect
	opl.out 4, &H60
	opl.out 4, &H80
	statusa = INP(&H388)
	opl.out 2, &HFF
	opl.out 4, &H21
	FOR delay = 0 TO 150
		statusb = INP(&H388)
	NEXT delay
	opl.out 4, &H60
	opl.out 4, &H80
	IF (statusa AND &HE0) = 0 THEN
		IF (statusb AND &HE0) = &HC0 THEN
			opl.detect = 1
		END IF
	END IF
END FUNCTION

SUB opl.out (reg, vlu)
	OUT &H388, reg
	a = INP(&H388)
	OUT &H389, vlu
	a = INP(&H388)
	a = INP(&H388)
	a = INP(&H388)
	a = INP(&H388)
	a = INP(&H388)
	a = INP(&H388)
	a = INP(&H388)
END SUB

SUB opl.playnote (v, frq, oct)
	opl.out &HA0 + v, frq AND 255
	opl.out &HB0 + v, 32 OR (4 * oct) OR (frq \ 256)
END SUB

SUB opl.setinstr (v, ini)
	DIM rofl AS LONG

	rofl = cOffIns + (11 * ini)
	reg = &H20 + vocoff(v)
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 3
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 29
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 3
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 29
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 3
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 29
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 3
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 93
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1: reg = reg + 3
	opl.out reg, PEEK(rofl)
	rofl = rofl + 1
	opl.out &HC0 + v, PEEK(rofl)
END SUB

SUB opl.stopvoice (v)
	opl.out &HB0 + v, 0
END SUB

SUB PlayMod (position, row)
	edpos = position
	edrow = row
	FOR v = 0 TO 8
		vocini(v) = -1
		modptr(v) = (320& * ord(v, edpos)) + (5 * edrow)
	NEXT v
	ptnjmp = -1
	ptnbrk = -1
	e6 = 0
	ON TIMER(1) GOSUB BT.Play
	TIMER ON
	settimerfrq 911
END SUB

FUNCTION readb (fh)
	b$ = CHR$(0)
	GET fh, , b$
	readb = ASC(b$)
END FUNCTION

SUB RemovePlayer
	ems.freepages emsh
END SUB

SUB settimerfrq (hz)
	OUT &H43, &H34
	IF hz = 0 THEN
		OUT &H40, 0
		OUT &H40, 0
	ELSE
		count = &H1234DD \ hz
		OUT &H40, count AND 255
		OUT &H40, count \ 256
	END IF
END SUB

SUB SetVolume (v, vol)
	rofl& = cOffIns + (11 * vocini(v)) + 2
	l1 = PEEK(rofl&): rofl& = rofl& + 1
	l2 = PEEK(rofl&)
	l1 = 64 - (vol * (64 - l1) \ 64)
	l2 = 64 - (vol * (64 - l2) \ 64)
	voff = vocoff(v)
	opl.out &H40 + voff, l1
	opl.out &H43 + voff, l2
END SUB

SUB StopMod
	settimerfrq 0
	TIMER OFF
	FOR v = 0 TO 8
		opl.setinstr v, 32
		vocini(v) = 32
		opl.stopvoice v
	NEXT v
END SUB