**********************************************************************
* Name:		BZ
* Desc:		General purpose compresser w/ uncompressor
* Notes:
*
*	Patterns:
*	^^^^^^^^^
*	1[MBITS][OBITS]		Match
*	0[NBITS]		Literals
*
*	The bit count for offset is determined by the max possible
*	offset, limited by traversed size.
*	The 1-bit ID for matches is unnecessary after a literal since
*	a match always follows.
**********************************************************************
ASSEMBLE
	NIBASC /HPHP49-C/

* undocumented entry, picked up from 1.10, 1.18, 1.19-3 ROM
=OffNoBlush	EQU	#01B1C


RPL

ASSEMBLE

sMNEXT	EQU 9	Match expected?
sGARB	EQU 10

NBITS	EQU 4	Literal length
NMASK	EQU 2^(NBITS)-1
NBITS2	EQU 6
NMASK2	EQU 2^(NBITS2)-1
MBITS	EQU 5	Match length
MMASK	EQU 2^(MBITS)-1
MBITS2	EQU 7
MMASK2	EQU 2^(MBITS2)-1

RPL
::
  CK1NOLASTWD
  DUPTYPECSTR? ITE
  :: DUP #1 #2 SUB$ "BZ" EQUAL ;
  FALSE
  case
  CODE

*	Preparation

		ST=0	sGARB
reungz		GOSBVL	=SAVPTR
		A=DAT1	A
		D1=A
		D1=D1+	10
		A=DAT1	4
		D1=D1+	4
		LCSTR	'BZ'
		P=	3
		?C=A	WP
		GOYES	upkok
		P=	0
		LC(5)	=SETTYPEERR
getptrevalc	A=C     A
		GOSBVL	=GETPTR
		PC=(A)
upkok		P=	0
		C=DAT1	A
		RSTK=C
		GOSBVL	=CREATETEMP
		GONC	ugzmemok
		?ST=1	sGARB
		GOYES	ugzmerr
		GOSUB	PassGC
		CON(5)	=DOCOL
		CON(5)	=GARBAGE
		CON(5)	=COLA
		CON(5)	=DOCODE
		REL(5)	UGZEND
		ST=1	sGARB
		GOTO	reungz
PassGC		C=RSTK
		GOTO	getptrevalc
ugzmerr		GOVLNG	=GPMEMERR
ugzmemok	C=RSTK
		AD0EX
		R0=A	A
		C=C+A	A
		R1=C	A	->obend
		GOSBVL	=D1=DSKTOP
		C=DAT1	A
		D0=C
		D0=D0+	5+5
		D0=D0+	4+5
		C=DAT0	A
		AD0EX
		D0=A
		D0=D0+	5	->pats
		C=C+A	A
		R2=C.F	A	->lits

		A=R0	A
		DAT1=A	A	->stk1
		R3=A.F	A	->ob
		D1=A

*	Uncompress Loop

		ST=0	sMNEXT
		A=0	S
		R3=A.F	S	bits
UPKLOOP		GOSUB	Decod
		?D#0	A
		GOYES	upkpat
* Safety:
*		AD1EX
*		C=R1.F	A
*		C=C-A	A
*		AD1EX
*		?A<=C	A
*		GOYES	blaa
*		A=C	A
*blaa
		CD0EX
		CR2EX.F	A
		CD0EX
		C=A	A
		GOSBVL	=MOVEDOWN
		CD0EX
		CR2EX.F	A
		CD0EX
upkcont		AD1EX
		D1=A
		C=R1.F	A
		?A<C	A
		GOYES	UPKLOOP
		GOVLNG	=GETPTRLOOP

upkpat
* Safety:
*		AD1EX
*		C=R1.F	A
*		C=C-A	A
*		AD1EX
*		?D<=C	A
*		GOYES	buh
*		D=C	A
*buh
		CD1EX
		D1=C
		C=C-A	A	->src
		CD0EX
		CDEX	A
		A=0	P
		?A=0	A
		GOYES	upslow
		GOSBVL	=MOVEDOWN
uppcnt		C=D	A
		D0=C
		GOTO	upkcont
upslow		C=C-1	A
upkplp		A=DAT0	B
		DAT1=A	1
		D0=D0+	1
		D1=D1+	1
		C=C-1	A
		GONC	upkplp
		GOC	uppcnt
UGZEND
  ENDCODE

  ZERO FOURTEEN BLANKIT
  ABUFF #42 #7
  "BZ V1.2 (400)" BINT_131d
  CENTER$3x5 DROP

  DUP OSIZE SWAP
  SysTime 1LAMBIND
  GARBAGE
  SysTime 1PUTLAM

  CODE

*	Compressor

*	Effect of HSHSIZE:	(sample file was an earlier BZ.S )
*
*	HSHSIZE	Time	MemNeed:
*	#1000	14.54	26624
*	 #800	15.77	16384
*	 #400	17.56	11264 !!
*	 #200	21.26	 8704
*	 #100	28.59	 7424
*	  #80	42.78	 6784
*	  #40	69.97	 6464

HSHSIZE	EQU #400	See source before changing!
WINSIZE	EQU #1000

RINGMEM	EQU 3*(WINSIZE)
HASHMEM	EQU 10*(HSHSIZE)
ALLMEM	EQU (RINGMEM)+(HASHMEM)
MINMEM	EQU 200+(ALLMEM)
MINADD	EQU 100+(ALLMEM)

MINMAT	EQU 6	Minimum match lenght

*********************************
* For speed following registers
* have priority over anything else
* R0[A]	->out
* R2[A] ->buffer
* R3[A] ->ob
* Assiging other improtant variables
* to [A] fields we get:
* R0	->out	->$start
* R1	free
* R2	->buffer
* R3	->ob		bits
* R4	->obend	->obsave
* D0	->obptr
* bits determines how many bits
* are valid in current ->out
* eg 0 <= bits <= 2
*********************************

		GOSBVL	=SAVPTR
*		GOSBVL	=GARBAGECOL
		CLRST
*		ST=0	sMNEXT
		A=0	W
		R0=A
		R1=A
		R2=A
		R3=A		R3[S]=0!
		R4=A

		GOSBVL	=D1=DSKTOP
		A=DAT1	A
		R3=A.F	A	->ob	(temporary)
		D0=A
		GOSBVL	=SKIPOB
		AD0EX
		R4=A.F	A	->obend
		C=R3.F	A	->ob
		A=A-C	A	obsize
		GOC	argerr
		LC(5)	10
		?A>=C	A
		GOYES	argok
argerr		LC(5)	=SETTYPEERR
gpevalc		GOTO	getptrevalc

memerr		GOSBVL	=DispOn
		GOVLNG	=GPMEMERR

argok		GOSBVL	=ROOM
		A=C	A
		LC(5)	MINMEM
		A=A-C	A
		GOC	memerr
		LC(5)	MINADD
		C=C+A	A
		R1=C.F	A	free
		GOSBVL	=MAKE$N
		A=R0.F	A
		GOSBVL	=ASLW5
		AD0EX
		R0=A
		D1=A		->out
		C=R1.F	A	free
		GOSBVL	=WIPEOUT
		AD1EX
		LC(5)	HASHMEM
		A=A-C	A
		R2=A.F	A	->buffer
		A=R1.F	A	free
		LC(5)	ALLMEM	THIS WAS BUGGED! (only HASHMEM substracted)
		A=A-C	A
		A=A-CON	A,16	buffering safety!
		R1=A.F	A
		GOSBVL	=DisableIntr
		GOSBVL	=OffNoBlush
		GOSBVL	=AllowIntr
		GOTO	packnow

*********************************
* R0	->out	->$start
* R1	free	(adjusted for buffer)
* R2	->buffer
* R3	->ob		bits
* R4	->obend	(->obsave)
*********************************
packnow		C=R1.F	A
		C=C-CON	A,4+5+5	"BZ" and oblen
		R1=C.F	A
*		GOC	memerr	Never
		C=R0.F	A
		D0=C
		LCSTR	'BZ'
		DAT0=C	4
		D0=D0+	4
		A=R4.F	A	->obend
		C=R3.F	A	->ob
		A=A-C	A	obsize
		DAT0=A	A
		D0=D0+	10
		CD0EX		D0 = ->ob
		R0=C.F	A	->out

*	Compressor Loop
*********************************
* R0	->out	->$start
* R1	free
* R2	->buffer
* R3	->ob		bits
* R4	->obend	(->obsave)
*********************************

PackLoop	GOSUB	PackInfo
		GOSUB	PackAbort?
* Save start address of scan
		AD0EX
		D0=A
		GOSBVL	=ASLW5
		A=R4.F	A
		R4=A
		GOSUB	FindMax
		C=R4
		GOSBVL	=CSRW5	->obsave
		AD0EX		->match
		D0=A
		A=A-C	A	skipped nibbles
		GOSUB	Encod
* Pattern is out, update history
		?D=0	A
		GOYES	packcont
		D0=D0+	1	1st one is in already
		D=D-1	A	1st not included
		D=D-1	A	GONC test
patadd		GOSUB	RemoveOld
		GOSUB	AddNew
		D0=D0+	1
		D=D-1	A
		GONC	patadd
* Prepare next loop
packcont	AD0EX
		D0=A
		C=R4.F	A	->obend
		?A>=C	A
		GOYES	PackNibs
		GOTO	PackLoop

*********************************
* Append literal nibbles
* according to packed directives
*********************************
PackNibs	C=R0
		A=R3.F	S
		?A=0	S
		GOYES	outok!
		C=C+1	A
		R0=C
outok!		GOSBVL	=CSRW5
		D0=C
		D0=D0+	5+5
		D0=D0+	4+5
		C=R0.F	A	->out
		AD0EX
		D0=A
		C=C-A	A	off to lit
		DAT0=C	A
		D0=D0+	5	->pats

		C=R3.F	A	->ob
		D1=C
		A=R1.F	A	free++
		LC(5)	ALLMEM
		A=A+C	A
		R1=A.F	A
		ST=0	sMNEXT
		A=0	S
		R3=A.F	S	bits
NibsLoop	GOSUB	Decod
		?D#0	A
		GOYES	apppat
		CR1EX.F	A
		C=C-A	A
		CR1EX.F	A
		GOC	apperr
		C=R0.F	A
		CD1EX
		CD0EX
		R0=C.F	A
		C=A	A
		GOSBVL	=MOVEDOWN
		C=R0.F	A
		CD0EX
		CD1EX
		R0=C.F	A
		GONC	appcont
apperr		GOTO	memerr
apppat		CD1EX
		C=C+D	A
		CD1EX

appcont		C=R4.F	A	->obend
		AD1EX
		D1=A
		?A<C	A
		GOYES	NibsLoop
* Exit compressor
PackDone	GOSBVL	=DispOn
		C=R0
		D0=C
		GOSBVL	=CSRW5
		R0=C
		GOSBVL	=Shrink$
		GOVLNG	=GPOverWrR0Lp

*	Match Encoder
*********************************
* Output match
*	D[A]  = length
*	D[A1] = match loc
*	D0    = ->match
*	R0[A] = ->out
*	R3[A] = ->ob
*	R3[S] = bits
*	R1[A] = free
*	A[A]  = skipped
*********************************
Encod		?A#0	A
		GOYES	outlit
		GOTO	outmat?
outlit		ST=1	sMNEXT
		LC(5)	NMASK
		?A>C	A
		GOYES	outlit2
		A=A+A	A
		P=	(NBITS)+1
		GOSUB	OutBits
		GOTO	outmat?
outlit2		A=A-C	A
		B=A	A
		A=0	A
		P=	(NBITS)+1
		GOSUB	OutBits
		LC(5)	NMASK2
		?B>C	A
		GOYES	outlit5
		A=B	A
		P=	NBITS2
		GOSUB	OutBits
		GOTO	outmat?
outlit5		A=0	A
		P=	NBITS2
		GOSUB	OutBits
		A=B	A
		GOSUB	OutA[A]
********
outmat?		?D=0	A
		RTNYES
		D=D-CON	A,(MINMAT)-1
		LC(5)	MMASK
		?D>C	A
		GOYES	outmat2
		C=D	A
		A=C	A
		P=	MBITS
		?ST=1	sMNEXT
		GOYES	otm1
		A=A+A	A
		A=A+1	A
		P=	(MBITS)+1
otm1		GOSUB	OutBits
		GOTO	outoff
outmat2		D=D-C	A
		A=0	A
		P=	MBITS
		?ST=1	sMNEXT
		GOYES	otm3
		A=A+1	A
		P=	(MBITS)+1
otm3		GOSUB	OutBits
		LC(5)	MMASK2
		?D>C	A
		GOYES	outmat5
		C=D	A
		A=C	A
		P=	MBITS2
		GOSUB	OutBits
		GOTO	outfxm
outmat5		A=0	A
		P=	MBITS2
		GOSUB	OutBits
		C=D	A
		A=C	A
		GOSUB	OutA[A]
outfxm		LC(5)	MMASK
		D=D+C	A

outoff		D=D+CON	A,(MINMAT)-1
		ST=0	sMNEXT
		C=D	W
		GOSBVL	=CSRW5	->matchloc
		AD0EX
		D0=A
		A=A-C	A	offset

		C=R3.F	A	->ob
		AD0EX
		C=A-C	A	maxoff
		AD0EX
		B=C	A	maxoff
		LC(5)	#7FF
		P=	12
otoflp		?B>C	A
		GOYES	OutBits
		CSRB.F	A
		P=P-1
		GONC	otoflp	BET

*********************************
OutA[A]		B=A	A
		P=	8
		GOSUB	OutBits
		A=B	A
		ASR	A
		ASR	A
		P=	12
*********************************
OutBits		A=R3.F	S
		C=P	15
		C=C+A	S
		A=C	S
		C=0	A
		P=	3
		CPEX	15
		CPEX	0
		A=A&C	S
		AR3EX.F	S
		P=	0
		CSRB.F	P
		CSRB.F	P
		AR1EX.F	A
		A=A-C	A
		AR1EX.F	A
		GOC	outerr
		AR0EX.F	A
		D1=A
		A=A+C	A
		AR0EX.F	A
		A=A-1	S
		GOC	noshf
shflp		A=A+A	A
		A=A-1	S
		GONC	shflp
noshf		C=0	A
		C=DAT1	P
		C=C!A	A
		DAT1=C	A
		RTN
outerr		GOTO	memerr
*********************************

*	Match Decoder
*********************************
* Decode directive from stream
* In:	D0	= ->in
*	D1	= ->obptr
*	R3[S]	= bits (used)
*	R3[A]	= ->ob
* Out:	A[A]=nlen D[A]=0
*	A[A]=offs D[A]=mlen
*********************************
Decod		?ST=1	sMNEXT
		GOYES	dcmat
		P=	1
		GOSUB	GetBits
		?ABIT=1	0
		GOYES	dcmat
		ST=1	sMNEXT
		P=	NBITS
		GOSUB	GetBits
		D=0	A
		?A#0	A
		RTNYES
		P=	NBITS2
		GOSUB	GetBits
		?A#0	A
		GOYES	fxlit
		GOSUB	GetA[A]
fxlit		LC(5)	NMASK
		A=A+C	A
		RTN

dcmat		ST=0	sMNEXT
		P=	MBITS
		GOSUB	GetBits
		?A#0	A
		GOYES	dcoff
		P=	MBITS2
		GOSUB	GetBits
		?A#0	A
		GOYES	fxmat
		GOSUB	GetA[A]
fxmat		LC(5)	MMASK
		A=A+C	A
dcoff		C=A	A
		D=C	A	mlen
		D=D+CON	A,(MINMAT)-1
		AD1EX
		D1=A
		C=R3.F	A	->ob
		A=A-C	A	maxoff
		LC(5)	#7FF
		P=	12
dcoflp		?A>C	A
		GOYES	GetBits
		CSRB.F	A
		P=P-1
		GONC	dcoflp	BET

*********************************
GetA[A]		P=	12
		GOSUB	GetBits
		B=A	X
		P=	8
		GOSUB	GetBits
		ASL	A
		ASL	A
		ASL	A
		A=B	X
		RTN
*********************************
* Get P bits
*********************************
GetBits		A=DAT0	A
		A=R3.F	S
		A=A-1	S
		GOC	gb0
gbshf		ASRB.F	A
		A=A-1	S
		GONC	gbshf
gb0		C=P	15
		C=C-1	S
		C=0	A
gbmlp		C=C+C	A
		C=C+1	A
		C=C-1	S
		GONC	gbmlp
		A=A&C	A

		A=R3.F	S
		C=P	15
		C=C+A	S
		A=C	S
		C=0	A
		P=	3
		CPEX	15
		CPEX	0
		A=A&C	S
		R3=A.F	S
		P=	0
		CSRB.F	P
		CSRB.F	P
		AD0EX
		A=A+C	A
		AD0EX
		RTN

*********************************

*	Match Finder
*********************************
* Find next match causing a pack
* In:
*	D0	->pos
*	R2[A]	->buffer
*	R3[A]	->ob
*	R4[A]	->obend
* Out:
*	D0	->newpos
*	D[A]	matchlen
*	D[A1]	matchpos
* Uses:	A[W] B[A] C[W] D[W]
*********************************
FindMax		GOSUB	RemoveOld
		GOSUB	AddNew
		GOC	nxtmat
		GOSUB	ScanThis
		?D#0	A
		GOYES	gotmax?
nxtmat		AD0EX
		A=A+1	A
		D0=A
		C=R4.F	A
		?C>A	A
		GOYES	FindMax
		D=0	W
		RTNSC
gotmax?		LC(5)	MINMAT
		?D<C	A
		GOYES	nxtmat
		AD0EX
		D0=A
		C=R4.F	A
		C=C-A	A
		?D<=C	A
		RTNYES
		D=C	A
		LC(5)	MINMAT
		?D<C	A
		GOYES	nxtmat
		RTN

*	Ring Buffer Match Finder
*********************************
* Scan buffer for the longest
* match for D0. Note that no
* obend test is needed
* In:
*	D0	->pos
*	B[A]	->FLlink
*	R2[A]	->buffer
*	R3[A]	->ob
* Out:	D[A,A1]	match
* Uses:	A[W] B[A] C[W] D[W]
*********************************
ScanThis	D=0	W
		C=B	A
		D1=C		->FLlink
		A=DAT1	A
scanloop	D1=A
		GOSUB	Count
		?D>C	A
		GOYES	nextmat
*		?C=0	A
*		GOYES	nextmat
		CD1EX
		D=C	A
		CD1EX
		P=	9
		DSL	WP
		DSL	WP
		DSL	WP
		DSL	WP
		DSL	WP
		P=	0
		D=C	A
* Get next loc from buffer
nextmat		AD1EX
		B=0	A
		B=A	X
		C=R2.F	A
		C=C-B	A
		C=C-B	A
		C=C-B	A	->slot
		D1=C
		D1=D1-	3	Nonzero!
		C=A	A
		A=DAT1	X
		?C<A	A
		GOYES	scaok
		LC(5)	WINSIZE
		A=A+C	A
scaok		CD0EX
		D0=C
		?C>A	A
		GOYES	scanloop
		RTN

*	Match Length Counter
*********************************
* Compare nibbles
* In:	D0 D1
* Out:	C[A] = match length
* Uses:	A[W] B[A] C[A]
*********************************
Count		B=0	A
		A=DAT0	W
		C=DAT1	W
		?C#A	W
		GOYES	cntwp
cntwlp		D0=D0+	16
		D1=D1+	16
		B=B+1	A
		A=DAT0	W
		C=DAT1	W
		?C=A	W
		GOYES	cntwlp
		BSL	A
		CD0EX
		C=C-B	A
		CD0EX
		CD1EX
		C=C-B	A
		CD1EX
cntwp		P=	8-1
		?C=A	WP
		GOYES	cntP8
		P=	4-1
		?C=A	WP
		GOYES	cntPlp
		P=	1-1
		GONC	cnpP+
cntP8		P=	12-1
		?C=A	WP
		GOYES	cntPlp
		P=	8-1
cntPlp		P=P+1
cnpP+		?C=A	P
		GOYES	cntPlp
		C=B	A
		CPEX	0
		RTNCC

*	Ring Buffer Addition
*********************************
* Add current location to ring
* In:	D0
*	R2[A]	->buffer
* Out:	B[A]	->FLlink
*	CS:	no previous ones
* Uses:	A[A] B[A] C[A] D1
*********************************
AddNew
* Compute hash
		A=DAT0	A
		C=A	A
		CSR	A
		CSR	A
		CSRB.F	X
		CSRB.F	X
		B=A	X
		A=A!C	X
		C=C&B	X
		A=A-C	X	hash
* Uncomment if less than 12 bits:
		LC(3)	(HSHSIZE)-1
		C=C&A	X

		A=R2.F	A
		C=C+C	A	2*
		A=A+C	A
		C=C+C	A	4*
		C=C+C	A	8*
		A=A+C	A	10*
		B=A	A	->FLlink
		D1=A
		D1=D1+	5
		A=DAT1	A	LastAddr
		CD0EX
		DAT1=C	A	New LastAddr
		D0=C
		?A=0	A
		GOYES	add1st
* Add to end
addok		C=0	A
		C=A	X
		A=R2.F	A
		A=A-C	A
		A=A-C	A
		A=A-C	A	->lastslot
		D1=A
		D1=D1-	3	Nonzero!
		AD0EX
		DAT1=A	X	link it to D0
		D0=A
		RTNCC
* No previous ones
add1st		D1=D1-	5
		DAT1=C	A
		RTNSC

*	Ring Buffer Remove
*********************************
* Remove old location from buffer
* In:	D0	->obptr
*	R3[A]	->ob
* Uses:	A[A] B[A] C[A] D1
*********************************
RemoveOld
		AD0EX
		D0=A
		LC(5)	WINSIZE
		A=A-C	A
		C=R3.F	A	->ob
		?C>A	A
		RTNYES
* Old one is in ring, remove it
		D1=A
* Compute hash
		A=DAT1	A
		C=A	A
		CSR	A
		CSR	A
		CSRB.F	X
		CSRB.F	X
		B=A	X
		A=A!C	X
		C=C&B	X
		A=A-C	X	hash
* Uncomment if less than 12 bits:
		LC(3)	(HSHSIZE)-1
		C=C&A	X

		A=R2.F	A
		C=C+C	A	2*
		A=A+C	A
		C=C+C	A	4*
		C=C+C	A	8*
		A=A+C	A	10*
		AD1EX
		B=A	A	->oldpos
		A=DAT1	A
		D1=D1+	5
		C=DAT1	A
		?C<=A	A
		GOYES	removeall
		D1=D1-	5
		C=0	A
		C=B	X
		A=R2.F	A	->buffer
		A=A-C	A
		A=A-C	A
		A=A-C	A	->1stslot
		AD1EX
		D1=D1-	3	Nonzero!
		C=B	A
		C=DAT1	X	1stlink
		D1=A
		?B<C	A
		GOYES	remok
		B=C	A
		LC(5)	WINSIZE
		C=C+B	A
remok		DAT1=C	A
		RTNCC
removeall
		C=0	A
		DAT1=C	A
		D1=D1-	5
		DAT1=C	A
		RTN

*	Annunciator Flash
*********************************
PackInfo	D1=(5)	=ANNCTRL
		A=DAT1	B
		A=A+A	B
		ABIT=0	6
		?A#0	B
		GOYES	inf00
		A=A+1	B
inf00		ABIT=1	7
		DAT1=A	B
		RTNCC

*	Abort Check
*********************************
PackAbort?	D1=(5)	=ATTNFLG
		A=DAT1	A
		?A=0	A
		RTNYES
		A=R0
		GOSBVL	=ASRW5
		R0=A
		D0=A
		D0=D0+	10
		GOSBVL	=Shrink$
		GOSBVL	=DispOn
		LC(5)	=ABORT
		GOTO	gpevalc
*********************************
ENDCODE

  SysTime 1GETLAM bit-
  SysTime 1PUTLAM
  SysTime 1GETLAM bit- bit-
  ABND
  HXS>% % 8192 %/ %3 RNDXY UNROT
  DUP4UNROLL OSIZE
  ( $bz %time #len1 #len2 )
  UNCOERCE2 2DUP %CH
  %2 RNDXY a%>$
  "%CH: " !insert$
  4ROLL a%>$ "   Time: " !insert$
  !append$
  ZERO FOURTEEN BLANKIT
  ABUFF FOURTWO TEN 4ROLL BINT_131d
  CENTER$3x5 DROP
  %2 %/ a%>$ SWAP %2 %/ a%>$
  "Size: " !insert$
  " \8D " !append$ !insert$
  ABUFF FOURTWO ZERO 4ROLL BINT_131d
  CENTER$3x5 DROP
  SetDA1Temp
;

**********************************************************************