title	'CRN v2.5 compressor, 8080 code.'
;
; Copyright (c) 1986 Nov. 30 by:
;	C.B. Falconer, 680 Hartford Tpk, Hamden, Conn.  (203) 281-1438
; all rights reserved.
;
; The original Z80 version from which this was developed is
; Copyright (c) 1986, Steven Greenberg			(201) 670-8724
;
; v25	Added trap for output sequence '0D,40,0D' (with possible hi
;	bits set) for comm. program compatibility. Injects nop.
;					cbf (86/12/19)
;
; This program may be copied and used freely for non-profit purposes.
; It may not be sold nor included in packages for sale without the
; express written consent of C.B. Falconer.
;
; NOTE: 8086 versions of CRN and UNC are under development.  Contact
; C.B. Falconer.  These will be available in .OBJ (linkable) form,
; and will be data compatible with 8080 CRN/UNC versions.
;
; Adaptation of Steve Greenberg's Crunch algorithm/code to a separate
; module.  This also enables the use of the algorithm on 8080s.  The
; adaptive reset criterion has to be different, since this module
; knows nothing about records, just byte streams.  A further differ-
; ence is that a 9 bit reset code is always the first thing emitted.
; I have tried to define a flexible set of interface conventions,
; with attention to efficiency and clarity.
;
; With the clutter of the file system and user interface removed, the
; elegant simplicity of Mr. Greenbergs algorithm becomes visible.
;
; All registers available to these externals.  They may implement
; any multi-processing desired, abort, monitor, etc.
	extrn	getchr;		next input char to (a). Cy for EOF
	extrn	outbyt;		output char (a). Every 256th output
;				call has Z flag set, for monitoring.
;
; Library linkages. Available in BUFFLIB, (see BUFFERS.LBR), or can
; be coded separately.  Unsigned arithmetic.
	extrn	.idiv;		de := dehl/bc; hl := dehl MOD bc
	extrn	.imul;		dehl := bc * de
;
; This entry is organized as an analogy to UNC. See below for parm.
	entry	crn;		a is parm, hl points to storage.
;
; Allow main program to monitor the status.
	entry	incnt, outcnt;	Can monitor counts.
	entry	nxtcod, ttotal;	Can monitor codes/reassignments
;
rev	equ	25h;	Program revision level
sigrev	equ	20h;	"significant" rev. lvl (compatibility)
;
; Bits in input argument "parm", strategy etc.
allfile	equ	080h;	Do not check for pre-squeezed/crunched. This
;			allows any bit pattern to be processed.
stkset	equ	040h;	Using incoming SP as memtop, no stack switch
csfield	equ	030h;	0..3, value of output checksum flag
;			0 = normal usage, as crunch/uncr. MOD 65k.
;			1 = CRC16 checksum, using BUFFLIB routine
;			2, 3.  Unassigned values.
;			NOTE: Existing systems will ignore chksums
;			for all non-zero arguments.
rafield	equ	0ch;	}
lghfld	equ	03h;	} Criteria for adaptive reset triggers
; 
; The useful discrete values in the low 4 bits, and their effects
; value	lgh fld	ra fld	reset allowed when
; -----	-------	------	------------------
; 0	0	0	codlen reaches 10
; 1	1=11	0	codlen reaches 11
; 2	2=12	0	codlen reaches 12
; 3	3=13	0	No adaptive resets allowed
; 4	0	1	table full and  1024 reassignments
; 8	0	2	  "	"	2048	"
; 12	0	3	  "	"	3072	"
; 14			Any time
; 15			Whenever table full
;
; Embedded in other programs.  Do not change.  Note that both
; "impred" and "nopred" include the "used" bit in their values.
nopred	equ	0ffffh;	"no predecessor"
impred	equ	07fffh;	Pred that can't be matched or bumped
tblsize	equ	5003
mincod	equ	9;	minimum bits per code
maxcod	equ	12;	maximum bits per code
crsqhd	equ	076h;	header byte, crunched/squeezed files
crhdr	equ	0feh;	2nd byte, for crunched files
sqhdr	equ	0ffh;	2nd byte, for squeezed files
vacant	equ	080h;	marker for vacant table entries
used	equ	020h;	"used" marker bit, in high order code.
escape	equ	090h;	Repeat encoding marker.
;
; Installation configurable values
slop	equ	11;	pages, 8 for CCP allowance
stksize	equ	0;	pages of 256 bytes, when assigned locally
;			(spare above last table area suffices)
@memtop	equ	6;	Where CPM keeps max memory pointer
;
; If both are set to 0 no overhead code is generated. 7 sig. bits.
trp1st	equ	0dh;  (0dh) 	Sequence on which to inject nulcod
trp2nd	equ	040h; (040h)	2nd char of sequence.
;
; Calculated values
tblroom	equ	(tblsize + 255) AND 0ff00h;	Round up to pages
trapit	equ	(trp1st OR trp2nd) ne 0
;
; allowance for 5 column table and stack
pages	equ	(tblroom shr 8) * 5 + stksize

; reserved codes - DO NOT CHANGE
eofcod	equ	100h;	EOF code
rstcod	equ	101h;	Adaptive reset code
nulcod	equ	102h;	Null code
sprcod	equ	103h;	Spare code
;
; Error codes.  Nothing sacred here
err1	equ	1;	input file empty
err2	equ	2;	input already squeezed/crunched
err3	equ	3;	memory/stack overflow
;
spare	equ	5;	filler for "spare" header byte
;
; Macro for "horizontal" movement through the table.
; See "Table structure" comment near "initbl" for more information.
;
; move "right" one column (same row)
right1	macro
	 mov	a,h
	 adi	tblroom shr 8
	 mov	h,a
	endm
;
;	----------
;
; Relocatable code module begins here.
	cseg
;
	db	rev;		At crn-1, for reference
;
; The caller has already emitted the header word, file name, stamp, 0
; (needed for crunched format files, optional for other applications).
; At entry a contains "stategy" byte, hl points to memory area (25k+).
; At exit the caller must output the checksum field (needed for files,
; optional for other applications, e.g. communication systems).
; a,f,b,c,d,e,h,l
crn:	sta	arg;		input arg, for strategy etc.
	xchg;			 (crunched checks, adaptive reset)
	lxi	h,0
	dad	sp
	shld	spsave;		for aborts, exit etc.
	call	malloc;		allocate memory
	mvi	a,err3
	rc;			memory overflow, stack not switched
	sphl;			nullop if stkset true
	lxi	h,zerobgn
	lxi	b,zeroend-zerobgn
	call	fillz;		Initialize this data area to 0
	mvi	a,rev;		Output rev level of this program
	call	outb
	mvi	a,sigrev;	Output "significant revision" level
	call	outb
	lda	arg
	ani	csfield;	Mask out checksum control field
	rar;			and reposition as 0..3
	rar
	rar
	rar
	call	outb;		to output stream
	mvi	a,spare
	call	outb;		Output a spare byte of "5"
	call	getc
	jc	xempty;		Input file is empty
	push	psw
	call	getc;		initializes "lastch"
	jc	xempty;		1 byte only, treat as empty
	pop	h;		1st byte to h
	mov	l,a;		2nd byte to l
	lda	arg
	ani	allfile
	jnz	crn1;		omit pre-squeezed/crunched check
	mov	a,h
	cpi	crsqhd
	jnz	crn1;		not squeezed/crunched
	mov	a,l
	cpi	crhdr
	jz	xsqzcr;		already crunched
	cpi	sqhdr
	jz	xsqzcr;		already squeezed
crn1:	mvi	a,01h
	sta	csave;		init "putcd" machine
	mvi	a,mincod
	sta	codlgh;		(crnch inits codlen)
	mov	a,h;		first byte (2nd in lastch)
	lxi	h,normal;	initial state for "nxtch"
	shld	istate
	call	crnch;		Initial reset, with 1st char in a
;	"	"
; If no error, checksum still to be output and files closed etc.
; Enter here with carry for error, a holding error code
exit:	lhld	spsave
	sphl
	ret
;
; Error connectors
xsqzcr:	mvi	a,err2;		already squeezed/crunched
	jmp	xexit
xempty:	mvi	a,err1;		"Input file empty"
xexit:	stc
	jmp	exit
;
; perform an adaptive reset and crunch the remaining input.
; Initial byte in (a).
; Unlike the original, this version always emits an initial "reset".
; I was going to suppress this, but on reconsideration this is
; probably useful to synchronize the uncruncher state.
crnch:	push	psw;		Save suffix which has yet to be output
	mvi	a,mincod;	Reset the code length
	sta	codlen;		(codlgh updated by putcd)
	lxi	h,rstcod;	Send (otherwise disallowed) reset code
	call	putcd
	xra	a
	sta	fulflg;		Clear the adaptive reset flag.
	mov	h,a
	mov	l,a;		hl := 0
	shld	nxtcod;		Reset entry # prior to table re-init.
	shld	ttotal;		Reset "codes reassigned"
	mvi	a,1 shl (mincod-8);	Reset target mask value.
	sta	trgmsk
	call	initbl;		Re-initialize the entire LZW table
	mvi	a,0ffh;		Init target compression ratio to max
	sta	lowper;		Goes there
	pop	psw;		Restore suffix char, patiently waiting
;	"	"
; *** Main encoding loop ***
;	"	"
crnch1:	lxi	h,nopred;	Beginning of string
;	"	"
; "Match" determines if the combination { <pred>, <suffix>  }, as
; supplied in { HL, A }, is already in the table.  If it is the
; matching index value is returned in DE.  If it isn't, it will be
; added to the table in an appropriate place (assuming the table is
; not yet filled).  If the table is filled, it may or may not still
; be added.  Carry flag set indicates NOT found.
crnch2:	push	h
	call	match;		Is { pred, suffix } in the table?
	pop	h
	jnc	crnch4;		found, try to extend string
crnch3:	call	putcd;		not found, send pred (a whole string)
	jnc	crnch1;		start a new string unless
	jmp	crnch;		adaptive reset requested, start over
;				(assumed to break any bad sequence)
crnch4:	xchg;			Match, discard old pred, replace w/new
	call	nxtch;		A := next byte from "logical" input
	jnc	crnch2;		not EOF
;	"	"
; *** End of main encoding loop ***
;	"	"
; end of input, flush everything
	call	putcd;		Output the "leftover" code
	lxi	h,eofcod;	Send (otherwise disallowed) "EOF" code
	call	putcd
	lda	csave;		Flush any remaining output
	cpi	01h;		The 1 in 8 chance we're on byte bndry
	mvi	a,0;		last 8 bits of EOF code are 0
	cnz	outb;		If output was not on byte boundary
	xra	a;		no error
	ret
;	________________________
;
; Initialize the table to contain the 256 "atomic" entries-
; { "NOPRED", <char> },  for all values of <char> from 0 thru 255
initbl:	call	preset;		"pre-init" the table (mostly zeroes)
	xra	a;		Start with 0
initlp:	push	psw
	lxi	h,nopred;	Use this value for all 256 loops
	call	match;		Make the entry  { hl, a }
	pop	psw;		(incrementing nxtcod for each)
	inr	a
	jnz	initlp;		Next suffix
;	"	"
; Reserve entries 100h thru 103h (EOF, RESET, NULL, & SPARE)
	call	resrv2
resrv2:	call	resrv;		(not bumpable or matchable)
;	"	"		(incrementing nxtcod for each)
; Reserve the next code (in nxtcod) by assigning with an impossible
; predecessor.  This makes it unmatchable & unbumpable (eof, etc)
; f,b,c,d,e,h,l
resrv:	lxi	h,impred
;	"	"
; Find a match for { <pred> <suffix> }, as supplied in { HL, A }.
;  Does one of the following two things:
;	"	"
;  (1) Returns the index # of a match in DE, with carry clear
;  (2) Sets carry & adds new combo to approp. place in "table".
; f,b,c,d,e,h,l (preserve a)
match:	mov	b,a;		b := suffix supplied
;	"	"
; When the table is full the first entry encountered which has been
; made, yet is still "available" (i.e. it has not been used since the
; entry was made, guaranteeing it is not referenced by another entry)
; is saved in "AVAIL".  So we initialize that [special value] zero,
; meaning "none".
	xchg
	lxi	h,0
	shld	avail;		Mark no re-assignment candidate yet
	push	d;		Save pred
	xchg;			hl := pred for hash
;	"	"
	call	hash;		hl := initial hash value
	pop	d;		de := pred
match1:	mov	c,h;		C  := extra copy of h
	mov	a,m;		Check if any entry exists at that locn
	cpi	vacant
	jz	insrt;		Empty, use spot to create new entry
;	"	"
	cpi	0ffh;		Check for a special "atomic" entry
	jz	match2;		If so leave "FF" for matching process
	ani	not used;	Else mask out used flag before match
match2:	cmp	d;		Does entry match pred (hi)
	jnz	match4;		No match here
	right1;			pred (lo)
	mov	a,e
	cmp	m
	jnz	match4;		no match
	right1;			move to suffix
	mov	a,b
	cmp	m
	jnz	match4;		no match
;	"	"
; We have a match! But there is one very important "but". If the table
; is full, and we are in "code reassignment" mode, we must pre-empt
; the possibility  of generating the WsWsW *** string here in the
; cruncher. This is because it is impossible to detect these in the
; uncruncher once all codes are defined.
	lda	fulflg
	ora	a
	jz	match3;		Table not full, not "reassign" phase
;	"	"
	lda	lpr;		If so, see if this pred/suffix combo
	cmp	e;		- is identical to last one generated
	jnz	match3;		Pred (lo) doesn't match, so all ok
	lda	lsufx;		Check suffix. Order of these 3 checks
	cmp	b;		- is intended to optimized speed (most
	jnz	match3;		- likely "non-matches" first)
	lda	lpr+1;		check pred (hi)
	cmp	d
	jz	match4;		Ugly situation - pretend no match
;	"	"
; <pred> <suffix> matched in table
match3:	right1;			3rd right so far
	mov	d,m;		Get entry #, hi byte, for return.
	right1;			and lo byte
	mov	e,m
	mov	h,c;		Normalize. Cancel all those "right"'s
	mov	a,m
	ori	used;		flag entry as "referenced"
	mov	m,a
	mov	a,b;		Restore "a" to its value on entry
	ana	a;		Clear cy flag (return status) & return
	ret
;
; No match yet. Norm. to beg of entry.
match4:	mov	h,c
	lda	fulflg
	ora	a
	jz	match5;		Not in code reassignment mode
	mov	a,m
	ani	used
	jnz	match5;		Entry not available for reassignment
	lda	avail+1
	ora	a;
	jnz	match5;		Already have re-assignment candidate
	shld	avail;		Else this physical loc is candidate
;	"	"
; Standard hash collision processing. Add "DISP", a variable displace-
; ment value, for the "secondary probe". DISP was precalculated at the
; time the original hash value was computed.
;	"	"
; Note that I (S.G) have implemented this secondary probe "backwards".
; Though identically effective (by symmetry), it has a number of speed
; advantages. When DISP is added, we are really subtracting (DISP was
; intentionally created to be "negative").  Not only is adding faster
; than subtracting, but the check for loop around (which is of course
; passing the beginning of the table) is a one-byte compare (table
; starts on a page boundary). Furthermore, when loop around occurs, we
; get to add once again instead of subtracting. (In fact, no subtract-
; ion is necessary for computing DISP either. See the "HASH" routine).
;	"	"
match5:	push	d;		Process standard hash collision.
	xchg
	lhld	disp;		Get pre-computed displacement value
	dad	d;		Add displacement to current phys loc
	mov	a,h
	push	h
	lxi	h,@table+1;	table page
	cmp	m;		And check for rollover to table beg
	pop	h
	jnc	match6;		no rollover
	lxi	d,tblsize
	dad	d;		Else tblsize for rollover
match6:	pop	d
	jmp	match1;		Repeat to see if this "link" matches
;
; Returns incremented "nxtcod" in de.
; Arms codlen/trgmsk as needed for any changes in output width.
; a,f,d,e
nextcd:	xchg
	lhld	nxtcod;		Pre-incr for next code.
	inx	h
	shld	nxtcod;		Save the new value
	xchg
	lda	trgmsk;		See if new code length is necessitated
	cmp	d;		Check hi-byte against target value
	rnz;			Simply return if not
	add	a;		Yes, code length will change
	sta	trgmsk;		Next target mask
	lda	codlen;		Previous code length value (#of bits)
	inr	a;		Increment code length
	cpi	maxcod+1
	jz	fullup;		Too long, table just filled.
	sta	codlen;		Else record new length
	ret

fullup:	mvi	a,0ffh;		Flag table full
	sta	fulflg
	ret;			don't update "CODLEN" past 12
;
; All "links" to the hashed entry have been checked and none have
; matched.  We therefore make a new entry if possible
; of pred de, suffix b.  Exit with a := b(entry)
; a,f,h,l
insrt:	lda	fulflg;		Is the table full?
	ora	a
	jz	insrt1;		table not full
	lhld	avail;		no empty space. Try for reassignment
	mov	a,h
	ora	l
	jz	insrt2;		No reassignment candidate available
;	"	"
	push	h
	lhld	ttotal;		Advance "codes reassigned"
	inx	h
	shld	ttotal
	xchg
	shld	lpr;		Save last entry made for "ugly" detect
	xchg
	mov	a,b;		"LPR" <-- last pred,
	sta	lsufx;		 "LSUFX" <-- last suffix
	pop	h
	mov	m,d;		Re-assign entry. Leave it's # alone.
	right1
	mov	m,e;		Pred (lo)
	right1
	mov	m,b;		Suffix
	stc
	mov	a,b
	ret

; Make entry into table.
insrt1:	mov	m,d;		Put in pred (hi)
	right1
	mov	m,e;		Pred (lo)
	right1
	mov	m,b;		Suffix
;	"	"
	call	nextcd;		advance, returns NEXT code
	dcx	d;		back to current entry
	right1;			Move to entry# (lo) column
	mov	m,d;		Put that in
	right1
	mov	m,e;		Likewise entry# (hi)
;	"	"
insrt2:	stc;			cy indicates new entry (no match)
	mov	a,b;		Return with cy set, "A" intact
	ret
;
; Steve Greenbergs input state machine.
;
; This creates the "logical" input stream. It gets its data from the
; "physical" input stream, bet performs repeat byte encoding.  Each
; call supplies one logical character out. In general there is a one
; character delay; this character is kept in "lastch".
;
; This subroutine is a state machine, where one call defines the state
; for the following call. It does this by leaving the address of the
; proper section (which implements the next state) in "istate".
;
; This looks a little complicated, but any given call immediately
; jumps to the appropriate small block of code and does what it
; should. This routine acts like a filter, taking in bytes one at a
; time through calls to "getc", and outputting them one at a time via
; calls to it.
;
; TYPE
;   inputstate = (eofile,     normal,
;		  duplicate,  repeating, dupsdone,
;		  realescape, emitzero);
; VAR
;   istate     : inputstate;
;   lastch     : char;
;
; FUNCTION getc : char;
;
;   BEGIN (* getc *)
;   read(lastch); getc := lastch;
;   END; (* getc *)
;
; (* 1---------------1 *)
;
; FUNCTION nxtch : char;	(* using Pascal flavor EOF signal *)
;
;   VAR
;     ch1      : char;
;     count    : integer;
;
;   BEGIN (* nxtch *)
;   ch1 := lastch; nxtch := ch1;	(* defaults *)
;   CASE istate OF
; normal:
;     BEGIN				   (* all cases emit lastch *)
;     IF      eof	    THEN istate := eofile
;     ELSE IF getc = escape THEN istate := realescape
;     ELSE IF lastch = ch1  THEN istate := duplicate;
;     END;
; duplicate:
;     BEGIN	      (* first emitted already, most cases emit 2nd *)
;     IF      eof	    THEN    istate := eofile
;     ELSE IF getc = escape THEN    istate := realescape
;     ELSE IF ch1 = lastch  THEN BEGIN
;	(* emit *) nxtch := escape; istate := repeating; END
;     ELSE  (* exactly 2 *)	    istate := normal;
;     END;
; repeating:
;     BEGIN   (* 3 up encountered. char, escape emitted. count next *)
;     count := 3;
;     REPEAT
;	IF	eof	      THEN istate := eofile
;	ELSE IF getc = escape THEN istate := realescape
;	ELSE IF lastch <> ch1 THEN istate := dupsdone
;       ELSE IF count = 255   THEN istate := dupsdone
;	ELSE count := succ(count);
;     UNTIL istate <> repeating;
;     nxtch := count;			(* emit the count *)
;     END;
; dupsdone:		      (* after count, cannot start a repeat *)
;     BEGIN    (* this emits the lastch that terminated "repeating" *)
;     IF      eof	    THEN istate := eofile
;     ELSE IF getc = escape THEN istate := realescape
;     ELSE			 istate := normal;
;     END;
; realescape: (* applying principle of not making funny connections *)
;     BEGIN		(* thus don't jam lastch to 0 & do dupsdone *)
;     nxtch := escape; istate := emitzero;
;     END;
; emitzero:
;     BEGIN
;     nxtch := 0;
;     IF eof		    THEN istate := eofile
;     ELSE IF getc = escape THEN istate := realescape
;     ELSE			 istate := normal;
;     END;
; eofile:
;       nxtch := endfilemark;
;     END; (* case *)
;   END; (* nxtch *)
;
; Get next (repeat encoded) byte from input stream.
; Unlike the coding in SQZ/UNSQ the "number" of repeats is the
; total number, not just the number added to the initial one.
; The input char <escape> is represented as <escape> <0> and
; <ch> <escape> <n> represents n occurences of <ch> (3 <= n <= 255).
; The expander treats <escape> <1> and <escape> <2> correctly.
; a,f,d,e
nxtch:	push	h
	lda	lastch
	mov	d,a;		save in d for all states
	lhld	istate
	call	xpchl;		Cases return next state in hl
	shld	istate
	pop	h
	ret
xpchl:	pchl;			implements "call (hl)"
;
; Normal state. hl contains "normal"
normal:	call	getc;		Get next byte from phys input stream
	jc	eof;		Br if no more data
	cpi	escape
	jz	escin
	cmp	d;		Compare to last char
	jnz	chgst;		chrs different, emit prev & continue
	lxi	h,duplic;	Set next state to duplic.
;	"	"
; Change state to hl (may not be a change)
chgst:	mov	a,d;		output previous lastch
	ora	a;		Clear any carry, not eof
	ret
;
; Special state change to delay EOF signal
eof:	lxi	h,eofile;	next state is eofile
	mov	a,d;		emit last char first
	ora	a
	ret
;
; A second occurrence of the same character has been detected.
; So far only one occurrence has been output.
duplic:	call	getc;		Get new byte from input stream
	jc	eof
	cpi	escape;		(Repeats of 90H cannonot be packed)
	jz	escin
	cmp	d;		Another repeat (3rd contiguous)?
	lxi	h,normal
	jnz	chgst;		Only 2, back to normal
	mvi	a,escape;	Jam output to escape
	lxi	h,repeat;	Next state counts
	ret;			cy is clear
;
; Three contiguous occurrences of a byte been detected. The byte
; itself and the escape have already been output. Now it is time to
; suck up characters (up to 255 of them).
repeat:	mov	e,d;		Byte to be matched will be kept in e
	mvi	d,3;		Init d, repeat byte counter, to 3
rept1:	call	getc;		Get next byte
	jc	eof
	inr	d;		test max repeat byte counter
	jz	rept2;		255 contiguous occurrences
	dcr	d;		form the real count so far
	cpi	escape;		*** watch order of events here! ***
	jz	escin
	inr	d;		finally count it, if still same
	cmp	e
	jz	rept1;		still same, test next input
rept2:	dcr	d;		re-adjust count
;	"	"
; Transfer to non-repeatable emission state
godun:	lxi	h,dupdun;	Change to dupdun (cleanup)
	mov	a,d
	ora	a
	ret
;
; Like normal state, but don't look for a match. Terminates repeat.
; (because the last byte output was a count).
dupdun:	call	getc;		Get next character
	jc	eof
	cpi	escape
	jz	escin;		escape encountered
	lxi	h,normal;	Next state
	mov	a,d
	ora	a
	ret
;
; "escape" has been encountered, byte before it has been output.
; Now output escape, followed by output 00h.
escout:	mvi	a,escape;	State doesn't get another phys char
	lxi	h,emit00;	Next state will emit the 0
	ora	a
	ret
;
; escape has been encountered and output.  Now output "00h"
emit00:	call	getc;		Get next physical char
	mvi	d,0
	jc	eof
	cpi	escape
	jnz	godun;		go emit the 0
;	"	"
; Escape char. appeared in input
escin:	lxi	h,escout;	Set next state to escout
	mov	a,d
	ora	a
	ret
;
; EOF has been encountered, and all bytes have been output.
; Set carry flag and return.
eofile:	stc
	ret
;
;	------ END of state machine ------
;
	if	trapit
; Emit a nul code.  prechk has stacked the actual output code.
; This assumes nulcode really does break up the evil sequence,
; which may not be warranted.  nulcode should have been 0, with
; a 2nd available nulcode of 0ffh to cater to all cases.
sndnul:	 lxi	h,trpflg
	 mvi	m,0;		reset the flag. Only 1 recursion
	 lxi	h,nulcod
	endif
;	 "	"
; Insert the pred now in HL into the output stream, length codlgh.
; This returns carry to indicate adaptive reset needed.  If trpflg
; is set to 01h on exit, the output sequence trp1st,trp2nd has been
; detected, and it is up to the cruncher to take steps.  Note that
; trpflg can take on other intermediate values (w/o ls bit set).
; Emits at least 1 (9 bit min codelgh), at most 2 (12 + 7 leftover)
; bytes of output code.  The 2 byte case creates problems, because
; an 'inject nulcode' signal reaches the main system too late. In
; this case the prewarning flag is already set
; f,b,c,h,l
putcd:	ora	a;		clear any carry
	push	psw
	if	trapit
	 lda	trpflg
	 ora	a
	 cnz	prechk;		If 01 must inject null, else watch out
	 jnc	putcd1;		no carry from prechk
	 pop	psw
	 stc;			preserve reset flag
	 push	psw
putcd1:
	endif
	call	setup
	mov	b,c;		b := codlgh
putcd2:	dad	h;		shift out bits
	ral;			from hl into a
	jnc	putcd4;		not yet time to dump the contents
	if	trapit;		check for bad output sequence
	 mov	c,a
	 call	trpchk
	 mov	a,c
	endif
	call	outb;		Dump assembled byte
	jnc	putcd3;		no reset signal found
	pop	psw;		Set the reset flag
	stc
	push	psw
putcd3:	mvi	a,01h;		re-init to flag bit only
putcd4:	dcr	b
	jnz	putcd2;		For as many bits as need to be output
	sta	csave;		save any bits left over
	lda	codlen;		"codlgh" always = "CODLEN" delayed
	sta	codlgh;		-by one code output call. Update here.
	pop	psw
	ret
;
; Setup a & hl to form next output byte(s). Set c := codlgh, b := 0
; a,f,b,c,h,l
setup:	lda	codlgh;		Compute number of pre-shifts
	mov	c,a;		c := codlgh
	cma
	adi	4+(maxcod+1)
	mov	b,a;		b := 16 - codlgh (4..7)
setup1:	dad	h;		position code at left of word
	dcr	b
	jnz	setup1;
	lda	csave;		Get "leftover" bits from last time
	ret
;
	if	trapit
; Check for anomolous sequence, next output in c (and a on entry)
; a,f (trpflg)
trpchk:	 ani	07fh
	 cpi	trp2nd
	 jnz	trpchk3;	not a bad sequence
	 lda	trpflg
	 ora	a
	 jp	trpchk3;	not bad sequence, reset flag
	 mvi	a,1;		trp1st,trp2nd detected
	 jmp	trpchk4;	set injection flag
trpchk3: xra	a
	 sta	trpflg;		clear any previous flag
	 mov	a,c
	 ani	07fh
	 cpi	trp1st
	 rnz;			not a trap startup
	 mvi	a,080h
trpchk4: sta	trpflg;		mark start of sequence
	 ret
;
; precheck.  trpflg in a, is non-zero.  New output code is in hl
prechk:	 push	h;		If minus then real precheck needed
	 jm	prechk1;	else trpflg=01, inject right now
	 call	sndnul;		which resets the flag
	 pop	h;		now this has to go
	 ret;			If cy, then need reset

prechk1: call	setup;		take advance look at the next code
prechk2: dad	h;		form the next code to ship
	 ral;			by shifting out from hl into a
	 jnc	prechk2;	For as many bits as need to be output
;	 "	"
; Now, if the look ahead byte a is 'trp2nd' must inject nulcode,
; else go back and let the main system proceed
	 ani	07fh
	 sui	trp2nd
	 ora	a;		make sure cy reset here
	 cz	sndnul;		which resets the flag, may return cy.
	 pop	h;		else leave it alone
	 ret;			and now do the real output operation
	endif
;
; Output byte (a) to output stream.  Every 256th  call to
; "outbyt" is made with the Z flag set, to signal any monitors.
; a,f
outb:	push	h
	push	d
	push	b
	lxi	h,outcnt;	Minimize calls here
	inr	m
	cz	dincma;		count output bytes
	call	outbyt
	ora	a;		clear any carry (errors up to outbyt)
	lxi	h,outct2
	inr	m
	cz	chkadp;		check adaptive reset
	pop	b
	pop	d
	pop	h
	ret
;
; Get byte (a) from the input stream.  Carry for eof
; a,f
getc:	push	h
	push	d
	push	b
	lxi	h,incnt
	inr	m
	cz	dincm;		Count input bytes
	lxi	h,incnt2;	This one may start over.
	inr	m
	cz	dincm;		for adaptive operations
	call	getchr;		Get a char into a
	sta	lastch;		For encoder system
	pop	b
	pop	d
	pop	h
	ret;			With any carry from "getchr"
;
; Dincm with z flag preserved.  Allows monitor signal to main
dincma:	push	psw
	call	dincm
	pop	psw
	ret
;
; Increment 24 bit word hl+1^.
; f,h,l
dincm:	inx	h
	inr	m;		carry, 2nd byte
	rnz
	inx	h
	inr	m;		carry, 3rd byte
	rnz
	inx	h
	inr	m;		MS byte.  No more propagation
	ret
;
;	------	 The following code may be reused in UNC	------
;
; Clear the table
; a,f,b,c,e,h,l
preset:	lhld	@table;		Beg of table (1st entry, first column)
	mvi	e,vacant;	Init whole 1st column to empty flags
	lxi	b,tblroom
	call	fill
	lxi	b,3*tblroom + tblsize;	Next 4 x 1400h locs all get 0s
;	"	"
; Fill hl^, length b, with 0
; a,f,b,c,e,h,l
fillz:	mvi	e,0
;	"	"
; Fill hl^, length b, with e
; a,f,b,c,h,l
fill:	mov	m,e
	inx	h
	dcx	b
	mov	a,b
	ora	c
	jnz	fill
	ret
;
; Notes about the hashing. The "open-addressing, double hashing"
; scheme used, where the actual codes output are the logical entry#,
; contained in the table along with the entry itself, would normally
; make the codes output independent of the exact hashing scheme used
; (codes are simply assigned in order - their physical location	is
; irrelevant).  However, with code reassignment implemented, the
; re-assignments are obviously not made in any particular order, and
; are hash function dependent. Thus hash function must not be changed.
;
; Called with pred in HL (3 nybble quantity) and suffix in A (2
; nybbles).  Exclusive or's the upper 2 nybbles of the pred with the
; suffix for the two ls nybbles of the result. The lower nybble of the
; pred becomes the highest of 3 nybble result. Adds one to that, as
; well as the table offset, resulting in a usable address, returned in
; HL.  Also compute "DIFF", the secondary hash displacement value, as
; a negative number.
;
hash:	mov	e,l;		Save low nybble of pred, used below
	dad	h
	dad	h
	dad	h
	dad	h;		Shift whole pred value left 4 bits
	xra	h;		Xor hi-byte of that with suffix
	mov	l,a;		Goes there as lo-byte of result
	mov	a,e;		Get pred(lo) saved above
	ani	0fh;		Want only low nybble of that
	push	h
	lxi	h,@table+1
	add	m;		Convenient time to add in table offset
	pop	h
	mov	h,a;		Goes here as hi-byte of result
	inx	h;		Except add 1. Eliminates poss. of 0.
	push	h;		Save hash val for return
	xchg
	lhld	delta;		holds -(5003 + (@table)).
	dad	d;		de := tblsize - hash (no table offset)
	shld	disp;		Secondary hash value, negative number.
	pop	h;		Return orig hash address
	ret
;
; Allocate memory, from de^ up. Minimum stk use (2 wds from call crn)
; to allow for main programs with insufficient stack allocation.
; Carry for any memory overflow.  Returns hl = new stack ptr
; a,f,b,c,d,e,h,l
malloc:	lxi	h,255
	dad	d
	mvi	l,0;		Round up to page boundary
	shld	@table
	xchg
	lxi	b,-tblsize
	mov	a,c
	sub	e
	mov	l,a
	mov	a,b
	sbb	d
	mov	h,a
	shld	delta;		-(tblsize+(@table))
	xchg;			hl := @table
	lda	arg
	ani	stkset
	jz	mallo1;		Not using SP as memtop marker
;	"	"
; Ensure sufficient memory available, SP marks top available
	mvi	a,5 * (tblroom shr 8)
	add	h
	mov	d,a;		top of table storage area + a bit
	lxi	h,2
	dad	sp;		to return stack ptr on "call malloc"
	lda	spsave+1;	proposed should be below existing
	sub	d;		carry if insufficient memory
	ret;			(run time does dynamic checking)
;
; General purpose allocation, assign our own stack space
mallo1:	mvi	a,pages;	for table and stack
	add	h
	mov	h,a;		proposed stack top
	lda	@memtop+1;	top page of memory +1
	sui	slop;		allow for CCP retention etc.
	sub	h
	rc;			Too big 
	lda	spsave+1
	sub	h
	rnc;			original stack above our area, ok
	xchg
	lhld	spsave
	xchg;			(@table was rounded up to fresh page)
	lda	@table+1;	Ensure orig stack below table area
	inr	d;		equal is not good enough
	sub	d;		carry if insufficient memory
	ret
;
;	--- END of reusable code area	---
;
; This implements the adaptive reset criteria.
;
; Advance OUTCT2 = hl^ (adaptive counter for output).  Can check
; INCNT2 if desired, may zero both counters, and returns carry
; to request an adaptive reset.  Called ONLY from outbyt when
; the ls byte of outct2 has just rolled over (to 0).  The carry
; has NOT been propagated yet. Carry is clear on entry.
;
; Since called only once per 256 output bytes, this can afford
; to use the full multiply divide cycle (about 1.5 Millisec at
; 2 Mhz clocks).  The delays will be trivial, especially since
; this usually corresponds to about 512 input bytes.
;
; This is designed to allow "fooling around" with the stategy
; at a higher coding level, to optimize the squeezing ratios.
; 
; The useful discrete values and their effects
; value	lgh fld	ra fld	reset allowed when
; -----	------	-------	------------------
; 0	0	0	codlen reaches 10
; 1	1=11	0	codlen reaches 11
; 2	2=12	0	codlen reaches 12
; 3	3=13	0	No adaptive resets allowed
; 4	0	1	table full and  1024 reassignments
; 8	0	2	  "	"	2048	"
; 12	0	3	  "	"	3072	"
; 14			Any time
; 15			Whenever table full
; a,f,b,c,d,e,h,l (available)
chkadp:	call	dincm;		outct2 pointer passed in
	lda	arg
	ani	0fh;		Strategy field
	cpi	0fh
	jz	chka1;		0fh = original strategy
	cpi	0eh
	jz	chka2;		Whenever ratio allows
	mov	b,a
	ani	lghfld
	adi	10;		Bits 0/1 are codelen field
	mov	c,a;		Range 10..13
;	"	"
; Use values 10..13 to inhibit reset unless (codlen >= value)
; i.e. 10 allows reset when codlgh reaches 10, 13 inhibits any
; resets being generated.
; or up, etc.
	lda	codlen;		9..12
	sub	c
	cmc
	rnc;			length not above criteria
;	"	"
; Field values 0..3 specify the minimum (* 1 k) number of code
; reassignments that must be performed before resetting.
; A non-zero value here effectively forces the above codlen=12
	mov	a,b
	ani	rafield
	mov	c,a;		range 0, 4, 8, 12
	lda	ttotal+1;	high byte
	sub	c
	cmc
	rnc;			count not at criterion
	jmp	chka2;		bypass fulflg check
		
chka1:	lda	fulflg;		original algorithm
	ora	a
	rz;			Not full, no reset
;	"	"
; Check the squeezing efficiency, incremental since last reset.
chka2:	lhld	incnt2+1;	In 256 byte blocks (truncated)
	push	h
	lhld	outct2+1
	xchg
	lxi	b,100
	call	.imul
	pop	b
	call	.idiv;		de := percentage, assumed < 255
	mov	a,d
	ora	a
	jnz	chka6;		>255%, reset it
	lda	lowper
	cmp	e
	jnc	chka9;		ratio got smaller, record it
	inr	a
	sub	e
	rnc;			change <= 1%, not enough
chka6:	lxi	h,incnt2
	lxi	b,ctrspc
	call	fillz;		zero the incrmental counters
	stc
	ret;			carry signals reset needed

chka9:	mov	a,e
	sta	lowper;		ratio got smaller	
	ret
;
;	-----------
;
	dseg;		DATA area.  Preserves any word alignment.
;
zerobgn	equ	$;		BEGIN of initially zeroed area
;
; Output machine
codlen:	ds	1;	mincod..maxcod only; Lgh after current output.
codlgh:	ds	1;	  "        "	".	Current output length
csave:	ds	1;	Bits (& marker) not yet emitted
;
; Input machine
lastch:	ds	1;	input awaiting use
istate:	ds	2;	Current state, a routine pointer.
;
; Encoding variables
disp:	ds	2;	-ve displacement for rehashing
nxtcod:	ds	2;	(formerly 'entry').  Next to be assigned.
trgmsk:	ds	1;	target mask. When code hi byte = advance lgh.
fulflg:	ds	1;	set when table full. Marks reassignment phase
;
; Counters.  Allow for CPM3 files and communications systems.
; Maintain the in/out order, may be used in code.
ttotal:	ds	2;	codes reassigned
incnt:	ds	4;	bytes received, total
outcnt:	ds	4;	bytes emitted, total
incnt2:	ds	4;	bytes received, incremental.
outct2:	ds	4;	bytes emitted, incremental.
ctrspc	equ	$-incnt2;	storage for incremental counters only
lowper:	ds	1;	For adaptive reset trigger calculations
;
; "Ugly" detection in re-assignment phase
lsufx:	ds	1;	last suffix
lpr:	ds	2;	last pred
;
; Communications. sequence trapping
	if	trapit;	also keep word aligned
trpflg:	 ds	1;	zero if no 0dh output detected
	 ds	1;	-ve if 0dh detected, but not trapped
	endif;		01  when sequence 0dh 040h detected
;
zeroend	equ	$;		END of initially zeroed area
;
; table storage location related variables
@table:	ds	2;	location of master table
avail:	ds	2;	for reassignment. 0 if none. An address.
delta:	ds	2;	Precalculated displacement for hashing
;			(-tblsize-table)
spsave:	ds	2;	entry sp
;
; Input argument, for strategy, allocation mechanism, etc.
arg:	ds	1;	0fh value is similar to CRUNCH23
	ds	1;	spare data byte, keep aligned.
	end