// M E R G E D E L E T E (PREPRESS)
//
// MergeDelete(f,mflg,...)
//Performs merge, supercede, delete, and
// compact operations on file f.

//Modified by Lyle Ramshaw December 25, 1980 10:49 AM:
// Made the new mica size take precedence over the old when
// merging Orbit into (Orbit or MultiChars), in case the
// sizes differ by one; also added more typeout. Finally,
// changed ordering relationship of IX’es so that TEX fonts
// work better.

//Modified by Lyle Ramshaw September 26, 1980 10:45 AM:
// Added Verify flag to the dictionary commands.
// Setting the Verify flag set on a dictionary command
// will cause each character raster block to be recopied
// independently, and in order of increasing character code.
// Hence, if some font segments were produced with MetaFont,
// the rasters will get sorted. Also, for each character,
// the claims about raster dimensions in the CharWidth block
// are checked against the claims in the raster block itself.
// If there are inconsistent, Swat is called with a sprightly
// message (such inconsistencies will send Spruce into Sway, by
// the way). If the Verify flag is true, then the Fast flag
// is forced to false.

//Modified by Lyle Ramshaw September 12, 1980 8:01 PM:
// Change storage allocation of linked list to get only as
// many words as the particular flavor of IX really needs;
// should allow larger dictionaries to be Merged.

//Modified by Lyle Ramshaw July 31, 1980 11:16 AM:
// Guarantee that family names are in all caps, and all
// trailing bytes are zeros.

//Modified by Lyle Ramshaw July 6, 1980 10:03 PM:
// I put a "Beginning a dictionary command..." message in.

//ReWritten completely by Lyle Ramshaw on May 20, 1980 3:58 PM
// -fixed bug in Merge that sometimes garbaged fonts produced with
// the ReviseWidths flag set.
// -there are now two modes of operation for these commands, fast and
// slow. In slow mode, the new dictionary is first written on
// PrePress.Scratch as before, and then copied. This slow process
// is very safe, since some good copy of your input always exists.
// The output of a slow operation will always be a compact file as
// well, with the data segments in the same order as their index
// entries, and contiguous.
// In fast mode, the dictionary file will be written in place.
// This will go much faster, but has two minor drawbacks: first,
// is it more risky, since there is a short "critical section" during
// which no valid copy of the dictionary appears on disk. Secondly,
// the output file may have holes in it, and its data segments may
// be in a different order than the corresponding index entries.

get "Ix.dfs"
get "AltoFileSys.D"//for STRING stuff
get "Streams.d"
get "MergeLists.D"

// outgoing procedures
external
[
MergeDelete
]

// incoming procedures
external
[
MergeDeleteOutput

//WINDOW
WindowSetPosition
WindowGetPosition
WindowReadBlock
WindowWriteBlock
WindowRead
WindowWrite
WindowCopy
WindowEnd
WindowClose
WindowFlush
WindowLength

//UTIL
PrePressWindowInit
FSGetX
FSPut

ReadIX
WriteIX
CompareIX
PrintIX
ReadIXTempFile
WriteIXTempFile
TypeChar
CheckParams
Scream
IllFormat
IllCommand

//SCAN
StrEq
StrCop
TypeForm

//OS
OpenFile
DoubleAdd
Min
Max
Zero
SetBlock
MoveBlock
ReadCalendar
Usc

//PressML
DoubleAddV

//Filops
FillIX
]

//outgoing statics
external
[
@ReviseWidths
@verifyFlag
]
static
[
@ReviseWidths=false
@verifyFlag=false
]

// incoming statics
external
[
@fam
@face
@siz
@rotation
@resolutionx
@resolutiony
@params
@bigfilename
]

// internal statics
//static
//[
//]

// Procedures

//MergeDelete -- for the COMPACT, MERGE, SUPERSEDE or DELETE commands
//f = 1,2,3 merge or delete segments of SD,CD,WD
//mergeFlag= :
// 0Delete segment mentioned in command line.
// 1Standard merge (any stuff in file -f merged into file f)
// 2Supersede (same as merge, but spline widths in -f supercede fixed
//versions in f)
// 3Compact: copy input back to input with all data blocks
//contiguous, and in the same order as the corresponding IX’es

let MergeDelete(f,mergeFlag,careful,oldName,newName;numargs na) be
[ if na le 3 then
[ newName=-f//little file (SDtemp,ACtemp, or WDtemp)
oldName=f//big file: SD,CD,WD,
if bigfilename!0 then oldName=bigfilename //or FileName/B
]

let DPZero=table [ 0;0 ]
let wOld=PrePressWindowInit(oldName)//Dict file (index is 0)
let wNew=nil//Source file (index is 1)
let maxFile=0
switchon mergeFlag into
[
case 0: //delete
if na eq 3 then unless CheckParams(gotname) then IllCommand()
endcase
case 1: //standard merge
case 2: //supersede
wNew=PrePressWindowInit(newName,false) //Source file
if wNew eq 0 then
[
Scream("Source file does not exist!")
return
]
maxFile=1
endcase
case 3: //compact
careful=true//compacts are always careful
endcase
default:
Scream("Bug in MergeDelete")
]
if verifyFlag then careful=true //have to be careful to verify

//for delete case,
let deleteMe=vec IXLMax
FillIX(deleteMe)//Get parameters
let foundIt=false

let e=vec IXLMax
let inNameList=0//List of all name IX’s
let maxOldCode=vec 1//Largest old name code in each file
maxOldCode!0=-1; maxOldCode!1=-1

TypeForm("Beginning a dictionary command: ")

//Look through both files to get all the name IX’es in one sorted
// list (reverse order), recording the old codes as we go.
for file=0 to maxFile do
[
let wi=(file eq 0)? wOld, wNew
WindowSetPosition(wi, DPZero)
if WindowEnd(wi) then
TypeForm(0,"Warning: An input file has length zero!",0)
until WindowEnd(wi) do
[
ReadIX(wi, e, true)
switchon e>>IXH.Type into
[
case IXTypeEnd: break
case IXTypeName:
[
//first, sanitize the name by making all chars upper case,
//and all trailing bytes zero:
let newFamName=lv e>>IXN.Name
let newFamLen=newFamName>>STRING.length
for i=1 to newFamLen do
newFamName>>STRING.char↑i=UpperCase(newFamName>>STRING.char↑i)
for i=newFamLen+1 to (size IXN/8)-5 do
newFamName>>STRING.char↑i=0
//[The 5 non-char bytes in an IXN are:
// 2 in header, 2 in Code, 1 as Length of Name.]
let p=lv inNameList
let newNameFlag=nil
//loop through to find IX after which e should be
// inserted; inNameList is built in reverse sorted order
while true do
[
let pn=@p//pn is address of current node
if pn eq 0 then [ newNameFlag=true; break ]
switchon StrOrder(lv e>>IXN.Name, lv pn>>NNode.ix.Name) into
[
case 1: newNameFlag=true; break
case 0:
[
// family names are equal, set the oldCode
newNameFlag=false
if pn>>NNode.oldCode↑file ne -1 then
Scream("Input file contained two name IX’es with the same name!")
let c=e>>IXN.Code
pn>>NNode.oldCode↑file=c
maxOldCode!file=Max(c,maxOldCode!file)
break
]
case -1: p=@p; loop
]
]
if newNameFlag then //insert after p
[
let n=FSGetX(size NNode/16)
n>>NNode.next=@p; @p=n //link it in
n>>NNode.oldCode↑0=-1; n>>NNode.oldCode↑1=-1
let c=e>>IXN.Code
n>>NNode.oldCode↑file=c
maxOldCode!file=Max(c,maxOldCode!file)
MoveBlock(lv n>>NNode.ix, e, IXLName)
]
]
endcase
default: loop
] //of "switchon..."
] //of "until WindowEnd(wi)..."
] //of "for file..."

//Reverse the inNameList to put it in increasing order (easier to think
// about):
Reverse(lv inNameList)

//Next step is to assign new codes for all family names, and build
// oldcode to newcode translation tables.

let codeTable0=FSGetX(maxOldCode!0+1) //+1 since 0 is a legal code
let codeTable1=FSGetX(maxOldCode!1+1)
SetBlock(codeTable0,-1,maxOldCode!0+1)
SetBlock(codeTable1,-1,maxOldCode!1+1)
let codeTables=vec 1
codeTables!0=codeTable0
codeTables!1=codeTable1

let p=inNameList
let maxNewCode=0;
while p do
[
maxNewCode=maxNewCode+1
p>>NNode.ix.Code=maxNewCode
for file=0 to maxFile do
[
let c=p>>NNode.oldCode↑file
if c ne -1 then (codeTables!file)!c=maxNewCode
]
p=@p
]

//Next, go through each file, building sorted lists
// of data IX’es, and filling in the new codes
let inDataList=vec 1
inDataList!0=0; inDataList!1=0
for file=0 to maxFile do
[
let wi=(file eq 0)? wOld, wNew
WindowSetPosition(wi, DPZero)
until WindowEnd(wi) do
[
ReadIX(wi, e, true)
switchon e>>IXH.Type into
[
case IXTypeEnd: break
case IXTypeName: loop
default:
[
let p=lv inDataList!file

//fill in new family code value
let oldcode=e>>IX.fam
let newcode=(codeTables!file)!oldcode
if newcode eq -1 then Scream("Input file contained data segment with an undefined family name code!")
e>>IX.fam=newcode

//loop through to find IX after which e should be
// inserted; dataLists are built in reverse sorted order
while true do
[
let pn=@p//pn points at current DNode
if pn eq 0 then break
switchon IxOrder(e, lv pn>>DNode.ix) into
[
case 1: break
case 0:
Scream("An input file contains several Data Segments that describe the same font!")
// and on into the next case
case -1: p=@p; loop
]
]
//insert the new data IX in place, with new fam code
let n=FSGetX(lDNodeHdr+e>>IXH.Length)
n>>DNode.next=@p; @p=n //link it in
n>>DNode.file=file
MoveBlock(lv n>>DNode.ix, e, e>>IXH.Length)
]

] //of "switchon..."
] //of "until WindowEnd(wi)..."
Reverse(lv inDataList!file)
] //of "for file..."
FSPut(codeTables!0); FSPut(codeTables!1)


//One little detail to fix up at this point: the deleteMe IX
// is a pattern that tells us what to delete. But its family code
// is garbage, while its family name is stored in "fam". We now
// look through the family names once again, to see if we can find
// that family name; if we do, we set the code appropriately.
if mergeFlag eq 0 then
[
p=inNameList
while p do
[
let thisFam=lv p>>NNode.ix.Name
if StrEq(thisFam, fam) then
[ deleteMe>>IX.fam = p>>NNode.ix.Code; break ]
p=@p
]
if p eq 0 then
[
TypeForm(0,"Couldn’t find specified segment to delete: nothing written.", 0)
return
]
]

//Now, merge the two dataLists and decide upon what goes into the
// final output file, and put that onto outDataList
let outDataList=0
while inDataList!0 & inDataList!1 do
[
//There is something at the head of each list, so decide who
//is smaller; if they are equal, the newer one (from file 1)
//wins.
let oldNode=inDataList!0
let newNode=inDataList!1
let oldIx=lv oldNode>>DNode.ix
let newIx=lv newNode>>DNode.ix
let comp=IxOrder(oldIx,newIx)
if comp eq 1 then
[
// remove newIx from inDataList, and put on outDataList
inDataList!1=newNode>>DNode.next
newNode>>DNode.next=outDataList
outDataList=newNode
loop
]
if comp eq -1 then
[
// remove oldIx from inDataList
inDataList!0=oldNode>>DNode.next
//now, if deleting, check if this segment gets the axe!
if mergeFlag eq 0 & CompareIX(oldIx, deleteMe) then
[ foundIt=true; FSPut(oldNode); loop ]
//and if Superseding, check again for axe; the
// superseding spline width segment, if such exists,
// will be smaller than oldIx in the ordering, since
// spline blocks have 0 size and 0 rotation. Thus,
// we only need search through the outDataList.
if mergeFlag eq 2 & oldIx>>IX.Type eq IXTypeWidths then
[
let q=outDataList
let killIt=false
while q do
[
let splineIx=lv q>>DNode.ix
if splineIx>>IX.Type eq IXTypeWidths &
oldIx>>IX.famface eq splineIx>>IX.famface &
splineIx>>IX.siz eq 0 then
[ killIt=true; break ]
q=@q
]
if killIt then [ FSPut(oldNode); loop ]
]
//else put oldIx on outDataList
oldNode>>DNode.next=outDataList
outDataList=oldNode
loop
]
//Well, the heads of the two lists match;
//In general, the newIx replaces the oldIx;
//but there are complex cases here in case of MultiChars....
//Start out by removing both from the in lists, linking both
//to the rest of the outDataList, and pointing outDataList
//at the newer.
inDataList!0=oldNode>>DNode.next
inDataList!1=newNode>>DNode.next
oldNode>>DNode.next=outDataList
newNode>>DNode.next=outDataList
outDataList=newNode

//but now decide whether to do funny things depending upon types
//if new is Multi, just do the replacement
if newIx>>IX.Type eq IXTypeMultiChars then [ FSPut(oldNode); loop ]

//if old is Multi, new had better be ORbit, and
// the scheme is: ReviseWidths?Push, Smash
if oldIx>>IX.Type eq IXTypeMultiChars then
[
if newIx>>IX.Type ne IXTypeOrbitChars then
Scream("Illegal merge: non-Orbit into MultiChars")
//we wil patch the old MultiChars IX in oldNode to bring it
// up to snuff; so change outDataList to point there.
outDataList=oldNode
oldNode>>DNode.file=2//special code meaning first seg comes
// from new file (1) while others come from old (0)
if ReviseWidths then //push down width stack
[
let n=oldIx>>IXM.numSegs
if n ge 4 then Scream("Too many width blocks!")
oldIx>>IXM.numSegs = n+1
for i=n to 1 by -1 do
[
MoveBlock(lv oldIx>>IXM.segs↑(i+1).sa,
lv oldIx>>IXM.segs↑i.sa, 2)
MoveBlock(lv oldIx>>IXM.segs↑(i+1).len,
lv oldIx>>IXM.segs↑i.len, 2)
MoveBlock(lv oldIx>>IXM.segs↑(i+1).date,
lv oldIx>>IXM.segs↑i.date, 2)
]
//adjust date on the new second segment from infinite future
// to right now
ReadCalendar(lv oldIx>>IXM.segs↑2.date)
]
//now, smash first entry with newIx data, and adjust for
// different ec, bc, size (might be off by 1)
MoveBlock(lv oldIx>>IXM.segs↑1.sa, lv newIx>>IX.sa, 2)
MoveBlock(lv oldIx>>IXM.segs↑1.len, lv newIx>>IX.len, 2)
//set the expiration date of this first block to the infinite future
SetBlock(lv oldIx>>IXM.segs↑1.date, -1, 2)
let charOff=(oldIx>>IXM.bc - newIx>>IX.bc)*CharWidthsize
oldIx>>IXM.bc=newIx>>IX.bc
oldIx>>IXM.ec=newIx>>IX.ec
oldIx>>IXM.siz=newIx>>IX.siz
let widthLen=vec 1
widthLen!0=0
widthLen!1=(newIx>>IX.ec-newIx>>IX.bc+1)*CharWidthsize
for i=2 to oldIx>>IXM.numSegs do
[
DoubleAddV(lv oldIx>>IXM.segs↑i.sa, -charOff)
MoveBlock(lv oldIx>>IXM.segs↑i.len, widthLen, 2)
]
FSPut(newNode)
loop
]
//final case to check is Orbit+Orbit+ReviseWidths->Multi
unless ReviseWidths & oldIx>>IX.Type eq IXTypeOrbitChars then
[ FSPut(oldNode); loop ]
if newIx>>IX.Type ne IXTypeOrbitChars then
Scream("Illegal merge: non-Orbit into Orbit with ReviseWidths")
//well, we now have to build a new MultiChars IX, with two
// data blocks, the new and the old
let mn=FSGetX(lDNodeHdr+IXLMulti)
mn>>DNode.next=oldNode>>DNode.next
outDataList=mn
mn>>DNode.file=2//special code for multi-merge
let mx=lv mn>>DNode.ix
mx>>IXM.Type=IXTypeMultiChars
mx>>IXM.Length=IXLMulti
mx>>IXM.fam=newIx>>IX.fam
mx>>IXM.face=newIx>>IX.face
mx>>IXM.siz=newIx>>IX.siz
mx>>IXM.bc=newIx>>IX.bc
mx>>IXM.ec=newIx>>IX.ec
mx>>IXM.rotation=newIx>>IX.rotation
mx>>IXM.resolutionx=newIx>>IX.resolutionx
mx>>IXM.resolutiony=newIx>>IX.resolutiony
mx>>IXM.numSegs=2
MoveBlock(lv mx>>IXM.segs↑1.sa, lv newIx>>IX.sa, 2)
MoveBlock(lv mx>>IXM.segs↑1.len, lv newIx>>IX.len, 2)
//now, set the expiration date of this first block to the infinite future
SetBlock(lv mx>>IXM.segs↑1.date, -1, 2)
MoveBlock(lv mx>>IXM.segs↑2.sa, lv oldIx>>IX.sa, 2)
let charOff=(oldIx>>IX.bc - newIx>>IX.bc)*CharWidthsize
DoubleAddV(lv mx>>IXM.segs↑2.sa, -charOff)
let widthLen=vec 1
widthLen!0=0; widthLen!1=(mx>>IXM.ec-mx>>IXM.bc+1)*CharWidthsize
MoveBlock(lv mx>>IXM.segs↑2.len, widthLen, 2)
ReadCalendar(lv mx>>IXM.segs↑2.date)
//Now, the new node is all ready, so free the old ones
FSPut(oldNode); FSPut(newNode)
]

//One list is now exhausted, so handle the other list
while inDataList!1 do
[
let newNode=inDataList!1
inDataList!1=newNode>>DNode.next
newNode>>DNode.next=outDataList
outDataList=newNode
]
while inDataList!0 do
[
let oldNode=inDataList!0
let oldIx=lv oldNode>>DNode.ix
inDataList!0=oldNode>>DNode.next
//now, if deleting, check if this segment gets the axe!
if mergeFlag eq 0 & CompareIX(oldIx, deleteMe) then
[ foundIt=true; FSPut(oldNode); loop ]
//and if Superseding, check again for axe; the
// superseding spline width segment, if such exists,
// will be smaller than oldIx in the ordering, since
// spline blocks have 0 size and 0 rotation. Thus,
// we only need search through the outDataList.
if mergeFlag eq 2 & oldIx>>IX.Type eq IXTypeWidths then
[
let q=outDataList
let killIt=false
while q do
[
let splineIx=lv q>>DNode.ix
if splineIx>>IX.Type eq IXTypeWidths &
oldIx>>IX.famface eq splineIx>>IX.famface &
splineIx>>IX.siz eq 0 then
[ killIt=true; break ]
q=@q
]
if killIt then [ FSPut(oldNode); loop ]
]
oldNode>>DNode.next=outDataList
outDataList=oldNode
]
Reverse(lv outDataList)

//Next, we go through the outDataList and count how many times
// each family name is used, since we only want to keep the families
// that we have to.
let used=FSGetX(maxNewCode+1)
Zero(used,maxNewCode+1)
p=outDataList
while p do
[
let ix=lv p>>DNode.ix
let fam=ix>>IX.fam
used!fam=true
p=@p
]
//And throw away the names that have no uses
let outNameList=0
p=inNameList
while p do
[
let fam=p>>NNode.ix.Code
test used!fam
ifso
[
//put on outNameList
let temp=p>>NNode.next
p>>NNode.next=outNameList
outNameList=p
p=temp
]
ifnot
[
//flush this useless name
let temp=p>>NNode.next
FSPut(p)
p=temp
]
]
Reverse(lv outNameList)

//Now its time to start thinking about outputing the new dictionary;
//first, check that there is at least one data Ix to be output

if mergeFlag eq 0 & foundIt eq false then
[
TypeForm(0,"Couldn’t find specified segment to delete: nothing written.", 0)
return
]

if outDataList eq 0 then
[ Scream("Empty output file specified: nothing written."); return ]


MergeDeleteOutput(outNameList, outDataList, wOld, wNew, careful, oldName)

] //of MergeDelete

and Reverse(lvList) be
[
//destructively reverse a list
// p points at a head of the initial
// input list that has been reversed already,
// q points at tail of the initial input
// still to be reversed.

let p=@lvList
if p eq 0 then return //empty list
let q=@p
@p=0
while q do
[
let r=@q
@q=p
p=q
q=r
]
@lvList=p
]

and IxOrder(a,b) = valof
[
//first discriminate on type, all Char type are the same
let atype=a>>IXH.Type
if IsCharsType(atype) then atype=IXTypeChars
let btype=b>>IXH.Type
if IsCharsType(btype) then btype=IXTypeChars
let d=Usc(atype, btype)
if d then resultis d

//next, on rotation
d=Usc(a>>IX.rotation, b>>IX.rotation)
if d then resultis d

//next on family code value (new code value, so already sorted
d=Usc(a>>IX.fam, b>>IX.fam)
if d then resultis d

let aface=a>>IX.face
let bface=b>>IX.face
manifest [ Tex=1; Plain=0 ]
let afaceType=(aface ge 18?Tex,Plain)
let bfaceType=(bface ge 18?Tex,Plain)
d=Usc(afaceType,bfaceType)
if d then resultis d

test afaceType eq Tex
ifso[
//next on face, in backwards order
d=Usc(bface,aface)
if d then resultis d
//then on size, with slop of 1 mica
let sizDiff=a>>IX.siz-b>>IX.siz
if sizDiff gr 1 then resultis 1
if sizDiff ls -1 then resultis -1
]
ifnot[
//next on size, with slop of 1 mica
let sizDiff=a>>IX.siz-b>>IX.siz
if sizDiff gr 1 then resultis 1
if sizDiff ls -1 then resultis -1
//then on face
d=Usc(a>>IX.face, b>>IX.face)
if d then resultis d
]

//and finally, if CharType, then on resolutions
if atype ne IXTypeChars then resultis 0 //atype known to equal btype
let aresx,aresy,bresx,bresy=nil,nil,nil,nil
test a>>IX.Type eq IXTypeMultiChars then
[ aresx=a>>IXM.resolutionx;aresy=a>>IXM.resolutiony ]
or[ aresx=a>>IX.resolutionx;aresy=a>>IX.resolutiony ]
test b>>IX.Type eq IXTypeMultiChars then
[ bresx=b>>IXM.resolutionx;bresy=b>>IXM.resolutiony ]
or[ bresx=b>>IX.resolutionx;bresy=b>>IX.resolutiony ]
d=Usc(aresx,bresx)
if d then resultis d
d=Usc(aresy, bresy)
if d then resultis d
resultis 0
]

and StrOrder(a,b) = valof
[
let lena=a>>STRING.length
let lenb=b>>STRING.length
let len=Min(lena, lenb)
for i=1 to len do
[
let ca=a>>STRING.char↑i
let cb=b>>STRING.char↑i
if ca ls cb then resultis -1
if ca gr cb then resultis 1
]
resultis Usc(lena, lenb)
]

and UpperCase(c) = valof
[
if $a le c & c le $z then resultis c+$A-$a
resultis c
]


and IsCharsType(typ) =
(typ eq IXTypeChars)%(typ eq IXTypeOrbitChars)%(typ eq IXTypeMultiChars)