// Caret Module CARET.SR

get "BRAVO.DF";
get "CHAR.DF"
get "DISPLAY.DF"
get "GINN.DF"

// Incoming Procedures

external [
	enww
	finddl
	formatx
	move
	swat
	pollstripe
	visible
	abs
	cpc
	ult
	ugt
	];

// Incoming Statics

external [
	xleftmargstd
	vblackout
	vwindows
	rgcpfirst
	rgcplast
	rgdlfirst
	rgdllast;
	rgxlast;
	rgpbm;
	rgxfirst;
	rgcpfdispl;
	vulmode;
	vcpatx;
	vx;
	vcplast;
	vheight;
	vwidth
	rgdoc
	vstripe
	linkCursorToMouse
	mpdldcb
	];

// Outgoing Procedures

external [
	setbug
	invertcaret
	linemark
	updatelinemark
	bubblesort
	min
	max
	drawunderline
	wwmark
	updatewwmark
	];

// Outgoing statics

external
	[
	rgmask // NOT USED IN GYPSY
	rgul
	cnrgul // NOT USED IN GYPSY
	bugstate; // NOT USED IN GYPSY ?
	cursorstate;
	vwwon
	vwwoff
	vwwcurrent
	]

// Local statics

static
	[
	rgmask // NOT USED IN GYPSY
	rgul
	cnrgul // NOT USED IN GYPSY
	vwwon
	vwwoff
	vwwcurrent
	bugstate; // NOT USED IN GYPSY ?
	cursorstate;
	gcp1
	gcp2
	gulmode
	gcpfirst
	gcplast
	gww
	gsel;
	gflipflop
	gcpon
	gcpoff
	gscanline
	]

// Local manifests

manifest [
	masktab = #460;
	OffOff = 0;
	OffOn = 1;
	OnOff = 2;
	OnOn = 3;
	];

// L I N E M A R K

let linemark(onoff,sel) be
[
let tmode = sel >> SEL.ulmode gr 0 & onoff? 1, 0 ;
if sel >> SEL.ulmodewas eq tmode then return;
sel >> SEL.ulmodewas = tmode;
let tcpfirst = sel >> SEL.cpfirst ;
let tcplast = sel >> SEL.cplast ;
if cpc(tcplast, tcpfirst-1) ls 0 then // sloppy coding elsewhere
	[
	tcplast = tcpfirst - 1 ;
	sel >> SEL.cplast = tcplast ;
	];
if not tmode then
	[
	sel >> SEL.ulcpfirstoff = tcpfirst ;
	sel >> SEL.ulcplastoff = tcplast ;
	sel >> SEL.uldocoff = sel >> SEL.doc ;
	]
] // end linemark

// U P D A T E L I N E M A R K

and updatelinemark(sel) be
[
gsel = sel;
gww = sel >> SEL.ww
gcpfirst = sel >> SEL.cpfirst ;
gcplast = sel >> SEL.cplast ;
gulmode = abs(sel >> SEL.ulmode) ;
let tdocoff = sel >> SEL.uldocoff ;
let tcpfirstoff = sel >> SEL.ulcpfirstoff ;
let tcppastoff = sel >> SEL.ulcplastoff + 1 ;
gcpoff = tcpfirstoff ;
let tdocon = sel >> SEL.doc ;
let tcpfirston = sel >> SEL.ulmodewas? gcpfirst, -2 ;
let tcppaston = gcplast+1 ;
gcpon = tcpfirston ;
let ff1 = tcpfirstoff ne -2? OnOff,OffOff ;
let ff2 = OffOff ;
let ff3 = tcpfirston ne -2? OffOn,OffOff ;
let caretshowingoff, caretshowingon = true, true
if vblackout then
	[
	caretshowingoff = cpc(tcpfirstoff, tcppastoff) ge 0
	caretshowingon = cpc(tcpfirston, tcppaston) ge 0
	]
gflipflop = OnOff ;
if gulmode eq 1 & ff1 & caretshowingoff then
	[
	if ff3 & tdocon eq tdocoff & gcpon eq gcpoff & caretshowingon then
		gflipflop = OnOn;
	gcp1 = gcpoff ;
	enww(caret1, tdocoff) ;
	]
if gulmode eq 1 & ff3 & gflipflop eq OnOff & caretshowingon then
	[
	gflipflop = OffOn ;
	gcp1 = gcpon ;
	enww(caret1, tdocon) ;
	]
if ff1 & ff3 & tdocon eq tdocoff
    then // intersections?
	[
	order(lv tcpfirstoff, lv tcpfirston, lv ff1); 
	order(lv tcppastoff,  lv tcppaston,  lv ff3);
	order(lv tcppastoff,  lv tcpfirston, lv ff2);
	]
if ff1 then linemark1(tdocoff, tcpfirstoff, tcppastoff-1, ff1)
if ff2 then linemark1(tdocoff, tcppastoff, tcpfirston-1, ff2)
if ff3 then linemark1(tdocon, tcpfirston, tcppaston-1, ff3)
gflipflop = gcpon ne -2 ;
if gflipflop then enww(markupdated, tdocon) ;
if gcpoff ne -2 then
	[
	unless gflipflop & tdocon eq tdocoff do
		[
		gflipflop = false ;
		gcpfirst = gcpoff ;
		gcplast = sel >> SEL.ulcplastoff ;
		enww(markupdated, tdocoff) ;
		]
	sel >> SEL.ulcpfirstoff = -2 ;
	]
]

and markupdated(ww) be
for dl = rgdlfirst!ww to rgdllast!ww do
	test gflipflop & cpc(gcpfirst, rgcplast!dl) le 0 &
	    (cpc(gcpfirst, rgcpfirst!dl) ge 0 %
	     cpc(gcplast, rgcpfirst!dl) ge 0)
		ifso	rgul!dl = rgul!dl % gulmode
		ifnot	rgul!dl = rgul!dl & not gulmode

// L I N E M A R K 1

and linemark1(doc, cp1, cp2, flipflop) be
[
if cpc(cp1, cp2) gr 0 then return ;
gcp1 = cp1;
gcp2 = cp2;
gflipflop = flipflop ;
enww(linemark2, doc) ;
]

// L I N E M A R K 2

and linemark2(ww) be
[

// Similar to UNDERLINE1

let dlfrom,txfirst,dlto,txlast = nil,nil,nil,nil;

if rgdllast ! ww ls rgdlfirst ! ww %
	cpc(gcp1, rgcplast ! (rgdllast ! ww)) gr 0 %
	cpc(gcp2, rgcpfdispl ! ww -1) ls 0 then return;
dlfrom = finddl(ww,gcp1);
dlto = finddl(ww,gcp2);
txfirst = ww eq gww & gcpfirst eq gcp1 ?
	gsel >> SEL.xfirst, -1;
txlast = ww eq gww & gcplast eq gcp2 ?
	gsel >> SEL.xlast, -1;

test dlfrom ls 0
ifso	[
	dlfrom = rgdlfirst ! ww;
	txfirst = rgxfirst ! dlfrom;
	];
ifnot	test ulneed(gflipflop, dlfrom)
	ifso	if txfirst ls 0 % ww ne gww %
				ulneed(OnOn, dlfrom) then
			[ vcpatx = gcp1;
			formatx(ww,dlfrom,0);
			txfirst = vx;
			if ww eq gww & gcp1 eq gcpfirst then
				gsel >> SEL.xfirst = txfirst;
			] 
	ifnot	txfirst = -1 ;
test dlto ls 0
ifso	test cpc(gcp2, rgcpfdispl ! ww) ls 0
		ifso	[
			dlto = dlfrom;
			txlast = txfirst;
			]
		ifnot	[
			dlto = rgdllast ! ww;
			txlast = rgxlast ! dlto ;
			]
ifnot	test ulneed(gflipflop, dlto)
	ifso	if txlast ls 0 % ww ne gww % ulneed(OnOn, dlto) then
		[ vcpatx = gcp2;
		formatx(ww,dlto,0);
		txlast = vx+vwidth-1;
		if ww eq gww & gcp2 eq gcplast then
			gsel >> SEL.xlast = txlast;
		] 
	ifnot	txlast = -1 ;

test dlfrom eq dlto ifso drawlinemark(dlfrom,txfirst,txlast)
ifnot	[
	drawlinemark(dlfrom,txfirst,rgxlast ! dlfrom);
	for i = dlfrom+1 to dlto-1 do
		drawlinemark(i,rgxfirst ! i,rgxlast ! i);
	drawlinemark(dlto,rgxfirst ! dlto,txlast);
	];

] // end linemark2

and ulneed(flipflop, dl) = valof
[
let keptmark = rgul ! dl & gulmode ;
resultis selecton flipflop into
	[
	case OffOff: false // should not occur!
	case OffOn: true
	case OnOff: keptmark ne 0
	case OnOn: keptmark eq 0
	] 
]

// D R A W L I N E M A R K

and drawlinemark(dl, fxfirst, fxlast) be
[
unless ulneed(gflipflop, dl) do return ;
if fxfirst ge fxlast then return ;
if fxlast eq rgxlast ! dl then fxlast = fxlast-1 ;

let tscanline = selecton gulmode into
	[
	case 1: vheight-1 // crossout
	case 2: vheight-1 // undermark
	];

let thickness = selecton gulmode into
	[
	case 1: vheight
	case 2: 1
	];

let tmask = selecton gulmode into
	[
	case 1: #177777
	case 2: #031463
	];

let xfirst = xleftmargstd & #177760
		// ** was rgxfirst ! dl & #177760;

drawunderline(fxfirst-xfirst, fxlast-xfirst, rgpbm ! dl, tscanline,
	(mpdldcb ! dl) >> DCB.nwrds, thickness, tmask, true)
]

and drawunderline(fxfirst, fxlast, pwceil, scanline, pwby,
	thickness, mask, exor ; numargs N) be
[
if N ls 6 then thickness = 1
if N ls 7 then mask = -1
if N ls 8 then exor = false

let pwbase = pwceil + pwby*scanline;
let pwfrom = pwbase+fxfirst << X.wordindex;
let pwto   = pwbase+fxlast << X.wordindex;

let change,change2 = nil,nil;
test pwfrom eq pwto ifso
	[
	let shift = 15- fxlast << X.bitindex;
	let width = fxlast-fxfirst;
	change = mask & ((masktab ! width) lshift shift);
	]
ifnot	[
	let width = 15- fxfirst << X.bitindex;
	change = mask & (masktab ! width) ;
	let shift = 15-fxlast << X.bitindex;
	width = fxlast << X.bitindex;
	change2 = mask & ((masktab ! width) lshift shift);
	];
let locn = nil;
for j = 1 to thickness do
	[
	rv pwfrom = exor? change xor rv pwfrom, change % rv pwfrom;
	if ult(pwfrom, pwto) then
		[
		for locn = pwfrom+1 to pwto-1 by 1 do
		    rv locn = exor? mask xor rv locn, mask % rv locn
		rv pwto = exor? change2 xor rv pwto,
		    change2 % rv pwto
		];
	pwfrom = pwfrom - pwby ;
	pwto = pwto - pwby ;
	];

] // end drawlinemark


// W W M A R K

and wwmark(onoff) be
[
test onoff
	ifso vwwon = vwwcurrent
	ifnot vwwoff = vwwcurrent ;
]

and updatewwmark() be
[
let wwon, wwoff = vwwon, vwwoff ;
vwwon = -1 ;
vwwoff = -1 ;
gulmode = 4 ;
if wwoff ge 0 then
	[
	test wwoff eq wwon
	ifso	if (rgul!(rgdlfirst!wwon) & gulmode) ne 0 then
			return ;
	ifnot	wwmark1(wwoff, 0) ;
	]
if wwon ge 0 then wwmark1(wwon, gulmode) ;
]

and wwmark1(ww, onoff) be
[
let tdl = rgdlfirst ! ww ;
if tdl gr rgdllast ! ww then return ;
if (rgul ! tdl & gulmode) ne onoff then drawwwmark(tdl, onoff) ;
for dl = tdl + 1 to rgdllast ! ww do
	if (rgul ! dl & gulmode) ne 0 then drawwwmark(dl, false) ;
]

and drawwwmark(dl, onoff) be
[
unless vwindows do return
let pat1 = #125000 ;
let pat2 = #52000 ;
let pwby = (mpdldcb ! dl) >> DCB.nwrds
let pw = rgpbm ! dl;
for i = 2 to vheight rshift 1 do
	[
	@pw = (i << odd ? pat1, pat2) xor @pw ;
	pw = pw + pwby ;
	];
rgul ! dl = onoff? rgul ! dl % gulmode, rgul ! dl & not gulmode ;
]

// I N V E R T C A R E T

and invertcaret(sel) be
[
gulmode = sel >> SEL.ulmode ;
if gulmode ls 0 then return ;
if vblackout & cpc(sel >> SEL.cpfirst, sel >> SEL.cplast) le 0 then
	return ;
gsel = sel ;
gcp1 = sel >> SEL.cpfirst ;
gflipflop = OnOff ;
enww(caret1, sel >> SEL.doc) ;
]

// C A R E T 1
// SPE catalogue no.

and caret1(ww) be
[

let dl,tx = nil,nil;

dl = finddl(ww,gcp1);
if dl ls 0 % not ulneed(gflipflop, dl) then return;

tx = gcp1 eq gsel >> SEL.cpfirst? gsel >> SEL.xfirst, -1;

if tx ls 0 % ww ne gsel >> SEL.ww then
	[ vcpatx = gcp1 ;
	formatx(ww,dl,0);
	tx = vx;
	if ww eq gsel >> SEL.ww  & gcp1 eq gsel >> SEL.cpfirst then
		gsel >> SEL.xfirst = tx;
	]; 

drawcaret(dl,tx-4,tx+2);

] // end caret1

// D R A W C A R E T

and drawcaret(dl,fxfirst,fxlast) be
[

let xfirst = xleftmargstd & #177760 ;
		// ** was rgxfirst ! dl & #177760;
fxfirst = fxfirst-xfirst;
fxlast = fxlast-xfirst;

let pwby = (mpdldcb ! dl) >> DCB.nwrds
let pwceil = rgpbm ! dl;
let pwbase = pwceil + pwby*(vheight-1);
let pwfrom = pwbase+fxfirst << X.wordindex;
let pwto   = pwbase+fxlast << X.wordindex;

let shiftfrom = 1 + (fxlast << X.bitindex);
let shiftto = 15-(fxlast << X.bitindex);

let tmask = table [ #143; #66; #66; #34; #34; #10 ] ;

for i = 0 to 5 do
	[
	if pwfrom ne pwto then
		rv pwfrom = ((tmask ! i ) rshift shiftfrom) xor
			(rv pwfrom);
	rv pwto = ((tmask ! i) lshift shiftto) xor (rv pwto);
	pwfrom = pwfrom - pwby;
	pwto = pwto - pwby;
	];

] // end drawcaret

// S E T B U G
// SPE catalogue no.

and setbug(newcursorstate) be
[
	if newcursorstate eq -1 then
		[
		vstripe = pollstripe() ;
		switchon vstripe into
			[
			case sstripe:
				newcursorstate = snoline ;
				endcase
			default: vstripe = sstripe+1
			case sstripe+1: newcursorstate = snone
			];
		];
	if cursorstate ne newcursorstate then
		[
		cursorstate = newcursorstate;
		let st = cursorstate ls 0?
			sinvert-cursorstate, cursorstate
		let cursor = selecton st into
			[
case snoline:
case sline:	table
			[
			#000000 // para symbol
			#003700
			#007200
			#007200
			#007200
			#007200
			#007200
			#003200
			#001200
			#001200
			#001200
			#001200
			#001200
			#000000
			#000000
			#000000
			]

case snone:
case schar:	table
			[
			#177776 // Two-bar T
			#177776
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#000400
			#177776
			#177776
			#000000

//			#100004 // X
//			#040010
//			#020020
//			#010040
//			#004100
//			#002200
//			#001400
//			#001400
//			#002200
//			#004100
//			#010040
//			#020020
//			#040010
//			#100004
//			#000000
//			#000000
			]

case smenu:	table	[
			#000400 // diamond button
			#001200
			#002500
			#005240
			#012520
			#025250
			#052524
			#025250
			#012520
			#005240
			#002500
			#001200
			#000400
			#000000
			#000000
			#000000
			]

case swindow:	table	[
			#000000 //window command
			#000000
			#177770
			#125250
			#152530
			#125250
			#152530
			#125250
			#152530
			#125250
			#152530
			#125250
			#152530
			#125250
			#177770
			#000000
			]

case spage:	table	[
			#000700 // eagle
			#103041
			#146443
			#122105
			#151513
			#125265
			#152553
			#127265
			#152553
			#127325
			#075276
			#001200
			#002520
			#014040
			#000000
			#000000
			]

case sbound:	table	[
			#000000 // move boundary
			#000000
			#177770
			#100010
			#101010
			#103410
			#107610
			#101010
			#177770
			#101010
			#107610
			#103410
			#101010
			#100010
			#177770
			#000000
			]

case snew:	table	[
			#000000 //new window
			#000000
			#177770
			#125250
			#152530
			#125250
			#152530
			#125250
			#177770
			#100010
			#100010
			#100010
			#100010
			#100010
			#177770
			#000000
			]

case ssplit:	table	[
			#000000 //split window
			#000000
			#177770
			#100010
			#100010
			#100010
			#100010
			#100010
			#177770
			#100010
			#100010
			#100010
			#100010
			#100010
			#177770
			#000000
			]

			] // end selecton

		move(cursor,curmap,16);

		if cursorstate ls 0 then
			for i = 0 to 15 do curmap!i = not curmap!i

		] // end if

] // end setbug

and min(a, b) = a le b? a, b

and max(a, b) = a ge b? a, b

and order(pa, pb, pff) be
	[
	let a = @pa ;
	let b = @pb ;
	if cpc(a, b) ls 0 then return ;
	if a eq b then
		[
		@pff = OffOff ;
		return ;
		];
	@pa = b ;
	@pb = a ;
	@pff = 3-@pff ;
	]