[Indigo]<AltoSource>EMPRESSSOURCES.DM!2>Empress1.bcpl

// Rick Tiberi July 30, 1979 5:58 PM duplex format
// DCS, June 13, 1978 11:23 AM, new date field in DDV

get "Streams.d"
get "AltoFileSys.d"
get "PressFile.d"

external
[
//outgoing procedures
InitCompose; ComposePressFile; WritePart; PutEntityTrailer;
AddFontEntry; PutCommandByte; WriteCommand

//outgoing statics
partDir; headerName

//incoming procedures from OS
OpenFile; WriteBlock; ReadBlock
FilePos; SetFilePos; FileLength
Endofs; Gets; Resets; Puts; Closes
Ws; Wss; Wns; CallSwat; MoveBlock; DoubleAdd; Zero
Allocate; Free; RetryCall; SysErr
InitializeFstream; SetupFstream; SetEof; ReadCalendar

//incoming procedure from Empress
SendToPrinter

//incoming procedures from EmPressParse
isPressFile; pagePosition; MergePressFile; CopyPressFile

//incoming procedure from Template
PutTemplate

//incoming procedure from FontWidths
LookupFontName; EncodeFace

//incoming procedures from PressMl
DoubleCop; DoubleShr; DoubleSub; MulFull; MulDiv

//incoming statics from OS
dsp; sysZone

//incoming statics from Empress
breakPageName; printedBy; headerDate
widthTab; pointSize; fontName; numCopies
numInputNames; currentInputName; inputNames; inputDVs
merging; docName; heading; duplex
weight; slope; expansion
]

static
[
entityBuffer; entityIndex //hold commands here until page is done
boxBottom; boxTop; charWidths
recordStart
XMin; YMin; XMax; YMax
heightLine //in micas
currentPos; lineNumber; maxLines
headerName; headerPageNum
fs; fastBuffer
fontDir; partDir; AddedFontSets; maxFontSets
entityStartPos; entityStartIndex;
noFontWidths = false
face; rotation
]

manifest
[
lenFastBuffer = 256*40

EHlen = size EH/16
PElen = size PE/16
lenEntityBuffer = 4000
maxParts = 200
maxFonts = 32

MicasPerInch = 2540
PointsPerInch = 72
MicaHeight = MicasPerInch*11//11 inch page height
MicaWidth = (MicasPerInch/2)*17//8 1/2 inch page width
TopMarg = MicasPerInch//1 inch top margin
BottomMarg = MicasPerInch/2//1/2 inch bottom margin
LeftMarg = MicasPerInch//1 inch left margin
RightMarg = MicasPerInch/2//1/2 inch right margin
maxPos = MicaWidth - RightMarg
HeaderMarg = MicasPerInch/2//1/2 inch from the top
TimeMarg = MicasPerInch*3+MicasPerInch/2//3 1/2 inches from left edge
CopyMarg = MicasPerInch*5//5 inches from left edge
PageMarg = MicaWidth - (RightMarg+MicasPerInch)
NameMarg = MicaWidth - (RightMarg+3*(MicasPerInch/2))

fontNotInFontWidths = 2
]

//----------------------------------------------------------------------------
structure [ lh byte; rh byte ]
//----------------------------------------------------------------------------
structure Bytes↑0,99:[ blank byte ]
//----------------------------------------------------------------------------
structure String: [ length byte; char↑1,255 byte ]
//----------------------------------------------------------------------------
structure Position: [ blank word; blank bit 7; Bytes bit 9 ]
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
let InitCompose() be
//----------------------------------------------------------------------------
[
fs = Allocate(sysZone,lFS)
fastBuffer = Allocate(sysZone,lenFastBuffer)

heightLine = MulDiv(pointSize,MicasPerInch,PointsPerInch)
let leading = heightLine/8 //leading is 1/8 of the font height
heightLine = heightLine + leading
maxLines = (MicaHeight-(TopMarg+BottomMarg))/heightLine

let fontStream = OpenFile("Fonts.Widths",ksTypeReadOnly)
if fontStream eq 0 then
[
noFontWidths = noFontsWidthsFile
return
]
charWidths = Allocate(sysZone,256)
let bufy = vec 256
let boundbox = vec 4
rotation = 0
face = EncodeFace(weight, slope, expansion)
if face eq -1 then face = 0
unless LookupFontName(fontStream,fontName,face,pointSize,rotation,
charWidths,bufy,boundbox) do
[ PutTemplate(dsp,"*NIllegal font name: $S",fontName); noFontWidths = fontNotInFontWidths; return ]
Closes(fontStream)
boxBottom = boundbox!1
boxTop = boundbox!3

partDir = Allocate(sysZone,PElen*(maxParts+2))
fontDir = Allocate(sysZone,FElen*maxFonts+2) //2 overhead
entityBuffer = Allocate(sysZone,lenEntityBuffer)
entityStartPos = Allocate(sysZone,2)
]

//----------------------------------------------------------------------------
and ComposePressFile(outputFile,transmitting) = valof
//----------------------------------------------------------------------------
[
partDir!0, fontDir!0, fontDir!1 = 0, 0, 0
maxFontSets,AddedFontSets = 0,0
AddFont(fontName,face,pointSize,rotation,fontDir)
XMin = 32000; XMax = 0
YMin = 32000; YMax = 0
entityIndex,entityStartIndex = 0,0; Zero(entityStartPos,2)
recordStart = 0

Resets(outputFile)
[ //file loop
//before starting another input file,
//see if this press file is getting too large.
//spruce seems to blow up on press files > 512 pages,
//but we limit things here to a smaller number to
//gain some pipelining: while Spruce is munching on the
//first 200 or so pages, we are pressing the next batch
if transmitting then
[
let fPos = vec 1; FilePos(outputFile,fPos)
if pagePosition(fPos) gr 200 break
]

//open next input file
if currentInputName eq numInputNames break //no more files
headerName = inputNames!currentInputName
let fp = lv (inputDVs+lDV*currentInputName)>>DV.fp
currentInputName = currentInputName +1

PutTemplate(dsp,"*NFile: $S",headerName)
let inputFile = OpenFile(headerName,ksTypeReadOnly,charItem,0,fp)
if inputFile eq 0 then [ Ws(" - does not exist"); loop ]

if merging then
[
let aux = OpenFile(headerName,ksTypeReadOnly,charItem,0,fp)
AddedFontSets=maxFontSets + 1
MergePressFile(outputFile, inputFile, aux)
Closes(aux)
Closes(inputFile)
loop
]

WriteFile(inputFile,outputFile,transmitting)
Closes(inputFile)
] repeat //file loop

if merging then
[
WritePart(partDir,outputFile,false)
unless docName eq 0 do
[
breakPageName = docName
headerName = docName
PutTemplate(dsp,"*NDocument: $S",docName)
let inputFile = OpenFile(docName,ksTypeReadOnly,charItem)
test isPressFile(inputFile,fastBuffer)
ifso
[
let aux = OpenFile(docName,ksTypeReadOnly,charItem)
AddedFontSets=maxFontSets + 1
CopyPressFile(inputFile,outputFile,aux)
Closes(aux)
]
ifnot WriteFile(inputFile,outputFile)
Closes(inputFile)
]
]
let fPos = vec 1; FilePos(outputFile,fPos)
if fPos!0 ne 0 % fPos!1 ne 0 then //we pressed at least one file
WriteDirs(fontDir,partDir,1,numCopies,outputFile)
]

//----------------------------------------------------------------------------
and WriteFile(inputFile,outputFile,transmitting) be
//----------------------------------------------------------------------------
[
let lastPage = nil
if isPressFile(inputFile,fastBuffer,lv lastPage) then
[
test transmitting
ifso
[
Ws(" - already in Press format")
SendToPrinter(inputFile,lastPage,false)
]
ifnot Ws(" - skipped. Already in Press format")
return
]

switchon noFontWidths into

inputFile = SetupFastInput(inputFile)

currentPos = LeftMarg
let XStart = LeftMarg
let YStart = MicaHeight-TopMarg
headerPageNum = 1
lineNumber = 0
let count = 0 //count of characters in a run
let controlZ = false

until Endofs(inputFile) do
[ //character loop
let char = Gets(inputFile)
if controlZ & char ne $*N loop //ignore bravo trailer
controlZ = false
switchon char into //take care of special cases
[
case $*014: //form feed
[
count = FlushLine(count)
WritePart(partDir,outputFile)
currentPos = LeftMarg
XStart = LeftMarg
YStart = MicaHeight-TopMarg
endcase
]
case $*032: //control-Z (for Bravo files)
[
controlZ = true
endcase
]
case $*N:
[
count = FlushLine(count)
lineNumber = lineNumber +1
if lineNumber ge maxLines then WritePart(partDir,outputFile)
XStart = LeftMarg
currentPos = LeftMarg
YStart = (MicaHeight-TopMarg)-heightLine*lineNumber
endcase
]
case $*T:
[
count = FlushLine(count)
let tab = (charWidths!$*S)*widthTab
currentPos = ((currentPos-LeftMarg)/tab+1)*tab+LeftMarg
XStart = currentPos
endcase
]
case $*S:
[
unless XStart eq 0 do
[
currentPos = currentPos + charWidths!$*S
XStart = currentPos
loop
]
//falls through
]
default:
[
if XStart ne 0 then [ WriteCommand(ESetX,XStart); XStart = 0 ]
if YStart ne 0 then [ WriteCommand(ESetY,YStart); YStart = 0 ]
Puts(outputFile,char)
count = count +1
currentPos = currentPos + charWidths!char
endcase
]
]
if currentPos gr maxPos then
[
FlushLine(count)
lineNumber = lineNumber +1
if lineNumber ge maxLines then WritePart(partDir,outputFile)
WriteCommand(ESetX,LeftMarg); XStart = 0
WriteCommand(ESetY,(MicaHeight-TopMarg)-heightLine*lineNumber)
Wss(outputFile,"****")
currentPos = LeftMarg + (charWidths!$**)*2
count = 2
]
] //character loop
//flush out last line and last page
FlushLine(count)
if count ne 0 % lineNumber ne 0
then WritePart(partDir,outputFile)
if duplex & Even(headerPageNum) then
[
let h = heading; heading = false
count = 0
currentPos = LeftMarg
XStart = LeftMarg
YStart = MicaHeight-TopMarg
WritePart(partDir,outputFile)
heading = h
]

]
]

//----------------------------------------------------------------------------
and Even(val) = (val & 1) eq 0
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and FlushLine(count) = valof
//----------------------------------------------------------------------------
[
if count ne 0 then WriteCommand(EShow,count)
resultis 0
]

//set up a giant fast input stream to make it go faster

//----------------------------------------------------------------------------
and SetupFastInput(stream) = valof
//----------------------------------------------------------------------------
[
InitializeFstream(fs,charItem,SysErr,FastOverflow)
fs>>ST.close = FastClose
fs>>ST.par3 = stream
SetupFstream(fs,fastBuffer,0,0)
Resets(stream)
resultis fs
]

//----------------------------------------------------------------------------
and FastOverflow(stream,item) be
//----------------------------------------------------------------------------
[
test Endofs(stream>>ST.par3)
ifso SetEof(stream,true)
ifnot
[
let nc = ReadBlock(stream>>ST.par3,fastBuffer,lenFastBuffer) lshift 1
if (FilePos(stream>>ST.par3) & 1) eq 1 then nc = nc -1
SetupFstream(stream,fastBuffer,0,nc)
]
RetryCall(stream,item)
]

//----------------------------------------------------------------------------
and FastClose(stream) be Closes(stream>>ST.par3)
//----------------------------------------------------------------------------

//----------------------------------------------------------------------------
and WriteCommand(command,param) be
//----------------------------------------------------------------------------
[
let comm = vec 20
let numBytes = 0
switchon command into //check for short command possibility
[
case ENop:
[
comm!1 = ENop
numBytes = 1
endcase
]
case ESetX:
[
if param ls XMin then XMin = param
comm!1 = ESetX; comm!2 = param<<lh; comm!3 = param<<rh
numBytes = 3
endcase
]
case ESetY:
[
comm!1 = ESetY; comm!2 = param<<lh; comm!3 = param<<rh
numBytes = 3
endcase
]
case EShow:
[
if currentPos gr XMax then XMax = currentPos
while param gr 255 do
[
WriteCommand(EShow,255)
param = param-255
]
test param gr 32
ifso [ comm!1 = EShow; comm!2 = param; numBytes = 2 ]
ifnot [ comm!1 = EShowShort+param-1; numBytes = 1 ]
endcase
]
case EOnlyOnCopy:
[
comm!1 = EOnlyOnCopy; comm!2 = param
numBytes = 2
endcase
]
default:
[
CallSwat("[WriteCommand] Unknown command",command)
finish
]
]
let e = entityIndex
entityIndex = entityIndex+numBytes
if entityIndex gr lenEntityBuffer*2 then
[
CallSwat("[WriteCommand] Entity buffer overflow")
finish
]
for i = 1 to numBytes do
entityBuffer>>Bytes↑(e+i-1) = comm!i
]

//----------------------------------------------------------------------------
and PutCommandByte(Byte) be
//----------------------------------------------------------------------------
[
let e = entityIndex
entityIndex = entityIndex+1
if entityIndex gr lenEntityBuffer*2 then
[
CallSwat("[PutCommandByte] Entity buffer overflow")
finish
]
entityBuffer>>Bytes↑e = Byte
]

//----------------------------------------------------------------------------
and PutEntityTrailer(entity,pressFile) be
//----------------------------------------------------------------------------
[
if (entityIndex & 1) ne 0 then WriteCommand(ENop)
let buffer = lv(entityBuffer>>Bytes↑entityIndex)
entityIndex = entityIndex+(EHlen*2)
entity>>EH.Length = (entityIndex-entityStartIndex)/2

entityStartIndex=entityIndex // for next entity

let DLlength = vec 1; FilePos(pressFile,DLlength)
let startPos = vec 1; MulFull(recordStart,512,startPos)
DoubleAdd(startPos,entityStartPos)
DoubleSub(DLlength,startPos)
DoubleCop(lv(entity>>EH.Dstart),entityStartPos)
DoubleCop(lv(entity>>EH.Dlength),DLlength)

DoubleAdd(entityStartPos,DLlength) // for next entity

entity>>EH.Fontset = entity>>EH.Fontset + AddedFontSets
MoveBlock(buffer,entity,EHlen)
]

//----------------------------------------------------------------------------
and WriteHeader(headerPageNum,pressFile) be
//----------------------------------------------------------------------------
[
unless heading return
let pageMarg = duplex & Even(headerPageNum)?
LeftMarg,PageMarg
let nameMarg = duplex & Even(headerPageNum)?
NameMarg,LeftMarg

//for i = 1 to numCopies do
// [
// WriteCommand(EOnlyOnCopy,i)

WriteCommand(ESetY,MicaHeight-HeaderMarg)

WriteCommand(ESetX,nameMarg)
Wss(pressFile,headerName)
WriteCommand(EShow,headerName>>String.length)

WriteCommand(ESetX,TimeMarg)
Wss(pressFile,headerDate)
WriteCommand(EShow,headerDate>>String.length)

// WriteCommand(ESetX, CopyMarg)
// PutTemplate(pressFile,"Copy $3UD",i)
// WriteCommand(EShow,8)

WriteCommand(ESetX,pageMarg)
PutTemplate(pressFile,"Page $3UD",headerPageNum)
WriteCommand(EShow,8)
// ]
//WriteCommand(EOnlyOnCopy,0)
]

//----------------------------------------------------------------------------
and WritePart(partDir,pressFile,doTrailer;numargs N) be
//----------------------------------------------------------------------------
[
if N ls 3 then doTrailer = true
if doTrailer then
[
//first, put out page header
WriteHeader(headerPageNum,pressFile)

PutTemplate(dsp,"*N Page $UD",headerPageNum)
headerPageNum = headerPageNum +1
if currentPos gr XMax then XMax = currentPos
YMax = MicaHeight-HeaderMarg
YMin = YMax-heightLine*lineNumber
if (entityIndex & 1) ne 0 then WriteCommand(ENop)
]

//start EL on word boundary:
let byteLen = vec 1
FilePos(pressFile,byteLen)
if (byteLen!1 & 1) ne 0 then
[
Puts(pressFile,0)
FilePos(pressFile,byteLen)
]

let startPos = vec 1
MulFull(recordStart,512,startPos)
DoubleAdd(startPos,entityStartPos)
DoubleSub(byteLen,startPos)

let zero = vec 0; zero!0 = 0 //obviously!
WriteBlock(pressFile,zero,1) //0 word to separate DL from EL

//now, store entity commands
WriteBlock(pressFile,entityBuffer,entityIndex/2)

if doTrailer then //if not, trailers are in entityBuffer
[
//and, write entity trailer
let ECommand = vec EHlen
ECommand>>EH.Type = 0
ECommand>>EH.Fontset = 0
DoubleCop(lv(ECommand>>EH.Dstart),entityStartPos)
DoubleCop(lv(ECommand>>EH.Dlength),byteLen)
ECommand>>EH.Xe = 0
ECommand>>EH.Ye = 0
ECommand>>EH.Xleft = XMin
ECommand>>EH.Ybottom = YMin-boxBottom
ECommand>>EH.Width = XMax-XMin
ECommand>>EH.Height = (YMax-YMin)+boxTop
ECommand>>EH.Length = EHlen + (entityIndex/2)
WriteBlock(pressFile,ECommand,EHlen)
]

//compute and write padding:
let pos = vec 1; FilePos(pressFile,pos)
let padding = 0
until pos>>Position.Bytes eq 0 do
[
WriteBlock(pressFile,zero,1)
padding=padding+1
FilePos(pressFile,pos)
]

//update part directory;
let numParts = partDir!0
if numParts eq maxParts then
[
CallSwat("[WritePart] Too many pages")
finish
]
let Part = partDir+(numParts*PElen) +1 //index into partDir vector
Part>>PE.Type = PETypePage
Part>>PE.pStart = recordStart
Part>>PE.pRecs = pagePosition(pos)-recordStart
Part>>PE.Padding = padding

//set up for next part:
recordStart = pagePosition(pos)
entityIndex,entityStartIndex = 0,0; Zero(entityStartPos,2)
lineNumber = 0
partDir!0 = numParts+1
XMin = 32000; XMax = 0
YMin = 32000; YMax = 0
]

//----------------------------------------------------------------------------
and AddFont(name,face,pointSize,rotation,fontDir,set;numargs N) be
//----------------------------------------------------------------------------
[
if N ls 6 then set = 0

let numFonts = fontDir!0
let FBuf = fontDir+2+fontDir!1

FBuf>>FE.length = FElen//entry length
FBuf>>FE.set = set + AddedFontSets
FBuf>>FE.fno = numFonts//font #
FBuf>>FE.destm, FBuf>>FE.destn = 0,127 //m; n
MoveBlock(lv(FBuf>>FE.fam),name,size FE.fam/16)
FBuf>>FE.face, FBuf>>FE.source = face,0 //face; source
FBuf>>FE.siz = pointSize //size
FBuf>>FE.rotn = rotation //rotation
FBuf!FElen = 0 //no more entries
if FBuf>>FE.set gr maxFontSets then maxFontSets=FBuf>>FE.set

fontDir!0 = numFonts+1
fontDir!1 = (fontDir!1)+FElen
if fontDir!1 gr FElen*maxFonts then
[ CallSwat("[AddFont] Too many fonts defined"); finish ]
]

//----------------------------------------------------------------------------
and AddFontEntry(font) be
//----------------------------------------------------------------------------
[
font>>FE.set = font>>FE.set + AddedFontSets
let numFonts = fontDir!0
let FBuf = fontDir+2+fontDir!1
let length = font>>FE.length
MoveBlock(FBuf,font,length)
FBuf!FElen = 0 //no more entries
if FBuf>>FE.set gr maxFontSets then maxFontSets=FBuf>>FE.set

fontDir!0 = numFonts+1
fontDir!1 = (fontDir!1)+length
if fontDir!1 gr FElen*maxFonts then
[ CallSwat("[AddFontEntry] Too many fonts defined"); finish ]
]

//----------------------------------------------------------------------------
and WriteDirs(fontDir,partDir,firstCopy,lastCopy,pressFile) be
//----------------------------------------------------------------------------
[
//write Font Directory:
let lenFont = ((fontDir!1) + 1 + 255)/256 //one for terminator
WriteBlock(pressFile,fontDir+2,lenFont*256)
// add font part to document directory:
let numParts = partDir!0
let fontEntry = partDir + numParts*PElen + 1
fontEntry>>PE.Type = PETypeFont
fontEntry>>PE.pStart = recordStart
fontEntry>>PE.pRecs = lenFont
fontEntry>>PE.Padding = 0 //not applicable
numParts = numParts+1

//write Part Directory:
let lenPart = (numParts*PElen + 255)/256 //length in records
WriteBlock(pressFile,partDir+1,lenPart*256)

//write Document Directory:
let docDir = Allocate(sysZone,256)
Zero(docDir,256)
docDir>>DDV.Passwd = PressPasswd
docDir>>DDV.nRecs = recordStart + lenFont + lenPart + 1
docDir>>DDV.nParts = numParts
docDir>>DDV.pdStart = recordStart + lenFont //part dir start
docDir>>DDV.pdRecs = lenPart //part dir length
docDir>>DDV.Backp = -1 //spare
docDir>>DDV.fCopy = firstCopy
docDir>>DDV.lCopy = lastCopy
ReadCalendar(lv docDir>>DDV.date) // machine-readable date field
MoveBlock(lv(docDir>>DDV.FileStr), breakPageName, size DDV.FileStr/16)
MoveBlock(lv(docDir>>DDV.CreatStr),printedBy,size DDV.CreatStr/16)
MoveBlock(lv(docDir>>DDV.DateStr),headerDate,size DDV.DateStr/16)
WriteBlock(pressFile,docDir,256)
Free(sysZone,docDir)
]