// 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 ;
]