// QCASS.SR

get "ginn.df"
get "char.df"
get "bravo.df"

// Incoming procedures

external
	[
	CASWRITE
	CASREAD
	CASSB
	qcheckstop
	setmenu
	setmessage
	establishww
	format
	cpmin
	ult
	disestablishww
	getvch
	invalidatewindow
	updatedisplay
	specstate
	nextspecstate
	]

// Incoming statics

external
	[
	vlook
	vlookremark
	vcp
	vchremain
	vwwcurrent
	rgdoc
	rgcpfdispl
	rgmaccp
	vdoc
	vcplastd
	vpara
	]

// Outgoing procedures

external
	[
	qwritecass
	]

// Outgoing statics

external
	[
	vcasson
	vcassstop
	]

// Local statics

static
	[
	vcasson
	vcassstop
	redactdel
	redactcr
	redactspeccr
	]

// Local manifests

manifest
	[
	command = 177770B
	status = 177771B
	datain = 177772B
	dataout = 177773B
	maxpy = 50
	]

structure REDACTCODE:
	[
	blank bit 8
	special bit 1
	char bit 7
	]


let qwritecass() = valof
[
let asciitoredact = table
[
// THE FORMAT FOR EACH LINE IN THE TABLE IS:
// REDACT - ASCII - CHAR - DIFFERENCES
// THE REDACT CODES MUST BE CORRECTED BY SHIFTING EACH RIGHT BY
// TWO PLACES.  THEY ARE WRITTEN THIS WAY IN ORDER TO FACILITATE
// READING OF THE CODE CONVERSION TABLE IN THE MANUAL.
// UNTRANSLATABLE CHARACTERS ARE CONVERTED TO PLUS/MINUS.
#0770	//	0
#0770	//	1
#0770	//	2
#0770	//	3
#0770	//	4
#0770	//	5
#0770	//	6
#0770	//	7

#0224	//	10	BS
#0424	//	11	TAB
#0770	//	12
#0770	//	13
#0770	//	14
#0724	//	15	CR
#0770	//	16
#0770	//	17

#0770	//	20
#0770	//	21
#0770	//	22
#0770	//	23
#0770	//	24
#0770	//	25
#0770	//	26
#0770	//	27

#0770	//	30
#0770	//	31
#0770	//	32
#0770	//	33
#0770	//	34
#0770	//	35
#0770	//	36
#0770	//	37

#0124	//	40	SP
#0770	//	41	!
#0250	//	42	"
#0760	//	43	#
#0710	//	44	$
#0650	//	45	%
#0750	//	46	&
#0254	//	47	'

#0600	//	50	(
#0610	//	51	)
#0740	//	52	*
#0060	//	53	+
#0144	//	54	,
#0004	//	55	-
#0264	//	56	.
#0114	//	57	/

#0614	//	60	0
#0774	//	61	1
#0664	//	62	2
#0764	//	63	3
#0714	//	64	4
#0654	//	65	5
#0644	//	66	6
#0754	//	67	7

#0744	//	70	8
#0604	//	71	9
#0150	//	72	:
#0154	//	73	;
#0770	//	74	<
#0064	//	75	=
#0770	//	76	>
#0110	//	77	?

#0660	//	100	@
#0340	//	101	A
#0400	//	102	B
#0540	//	103	C
#0550	//	104	D
#0450	//	105	E
#0160	//	106	F
#0170	//	107	G

#0410	//	110	H
#0240	//	111	I
#0070	//	112	J
#0440	//	113	K
#0510	//	114	L
#0370	//	115	M
#0460	//	116	N
#0310	//	117	O

#0050	//	120	P
#0040	//	121	Q
#0350	//	122	R
#0210	//	123	S
#0470	//	124	T
#0560	//	125	U
#0360	//	126	V
#0200	//	127	W

#0570	//	130	X
#0010	//	131	Y
#0670	//	132	Z
#0770	//	133	[
#0770	//	134	\
#0770	//	135	]
#0000	//	136	^	** redactron UL, photon em-dash **
#0274	//	137	_	** redactron half, photon bell **

#0254	//	140	'
#0344	//	141	a
#0404	//	142	b
#0544	//	143	c
#0554	//	144	d
#0454	//	145	e
#0164	//	146	f
#0174	//	147	g

#0414	//	150	h
#0244	//	151	i
#0074	//	152	j
#0444	//	153	k
#0514	//	154	l
#0374	//	155	m
#0464	//	156	n
#0314	//	157	o

#0054	//	160	p
#0044	//	161	q
#0354	//	162	r
#0214	//	163	s
#0474	//	164	t
#0564	//	165	u
#0364	//	166	v
#0204	//	167	w

#0574	//	170	x
#0014	//	171	y
#0674	//	172	z
#0770	//	173	{
#0770	//	174	|
#0770	//	175	}
#0770	//	176	~
#0324	//	177	DEL
]
redactdel = (asciitoredact ! $*177) rshift 2
redactcr = (asciitoredact ! $*C) rshift 2
redactspeccr = (asciitoredact ! $*C) rshift 2
vcassstop = false
setmenu()
setmessage(" Bug Stop to terminate writing")
qcasswrite1(asciitoredact, vwwcurrent)
vcasson = false
vcassstop = false
resultis 1
]

and qcasswrite1(convert, ww) be
[
let buffer = vec 256
let doc = rgdoc ! ww
let cp = rgcpfdispl ! ww
let cpl = rgmaccp!doc - 2
vchremain = 0
vdoc = doc
let ycur = 0
for i = 0 to 100 do @command = 100000B
@command = 0
	[
	if not ult(cp, cpl) then
		[
		setmessage(" Writing finished")
		return
		]
	establishww(ww, devdp)
	format(doc, cp, devdp)
	vcp = cp
	vchremain = 0
	cp = cpmin(vcplastd, cpl)+1
	vcp = specstate(vdoc, vcp, vpara)
	let changecp = nextspecstate()
	disestablishww()
	let i = 0
	let eop = false
	let parity = 0
	while vcp ls cp do
		[
		let char = getvch()
		if ((vlook & mvanish) ne 0) %
		    (((vlook & mremark) ne 0) & (not vlookremark))
			then loop
		if vcp-1 eq changecp then
			[
			changecp = nextspecstate()
			if changecp eq -1 then eop = true
			break
			]
		if vcp eq cp & char eq chsp then
			[
			eop = false
			break
			]
		if char eq chcr then
			[
			eop = true
			break
			]
		char = ((convert ! char) rshift 2) & #000377
		buffer ! i = char
		parity = parity xor char
		i = i+1
		]
	qcasswrite2(buffer, i, eop, parity)
	unless qcheckstop(lv vcassstop) do
		[
		setmessage(" Writing terminated")
		return
		]
	ycur = ycur+1
	if ycur eq maxpy then
		[
		invalidatewindow(ww)
		rgcpfdispl ! ww = cp
		updatedisplay()
		ycur = 0
		]
	] repeat
]

and qcasswrite2(buf, n, eop, parity) = valof
[
for i = 0 to 3 do
	[
	buf ! (n+i) = redactdel
	parity = parity xor redactdel
	]
let cr = eop? redactspeccr, redactcr
buf ! (n+4) = cr
parity = parity xor cr
test parity<<REDACTCODE.special
ifso	parity<<REDACTCODE.special = 0
ifnot	parity<<REDACTCODE.special = 1
buf ! (n+5) = parity & #000377
resultis CASWRITE(buf, n+6, false)
]