//EmPressParse.bcpl	parse Press files for merging
//Rick Tiberi

//as of October 21, 1977  10:33 AM

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

external
[
//outgoing:
isPressFile; pagePosition;
DoubleShift
CopyPressFile; MergePressFile
addresseesFinished

//from O.S.:
FileLength; FilePos; SetFilePos; PositionPage;
ReadBlock; WriteBlock;
Allocate; Free; MoveBlock; DoubleSub;
OpenFile; Gets; Puts; Closes; Endofs
Ws; Wo; Wns; Wss;
dsp; keys; sysZone

//from packages:
DoubleCop; DoubleAdd;
CreateStringStream; StringCompare;

//from Empress1:
WritePart; WriteCommand; PutCommandByte;
AddFontEntry; PutEntityTrailer;
pressFile; inputNames; currentInputName; partDir;
addresseeName

//from Empress:
numCopies; keyString; titleString; docName
]

manifest
[
EHlen = size EH/16
maxEntities = 100
EShortShowMax = #37
EShortSpaceMax = #7
FontMax = #17
controlZ = $Z-$A+1
maxAddresseeLines = 10
maxCopies = 120
]

static
[
DoubleStack
DoubleStackLength
DoubleStackPtr
addresseeStream
addresseeLine
addresseeLines
addresseesFinished = false
alreadySetUp = false
lastX
lastY
]

//-------------------------------------------------------------------
// a Part Directory is composed of Part Entries:
structure PD ^1,99: @PE
//-------------------------------------------------------------------
structure String: [ length byte; char^1,255 byte ]
//-------------------------------------------------------------------

//-------------------------------------------------------------------
let isPressFile(stream,buffer,lvLastPage;numargs N) = valof
//-------------------------------------------------------------------
[
let fPos = vec 1
if (FileLength(stream,fPos) & #777) eq 0 then
  [  //it has a likely length...
  let lastPage = pagePosition(fPos)
  if N ge 3 then @lvLastPage = lastPage
  DoubleSub(fPos,table [ 0; 512 ])
  SetFilePos(stream,fPos)
  ReadBlock(stream,buffer,256)
  if buffer>>DDV.Passwd eq PressPasswd
    then resultis true
  ]
resultis false
]

//-------------------------------------------------------------------
and pagePosition(fPos) = fPos!1 rshift 9 + fPos!0 lshift 7
//-------------------------------------------------------------------

//-------------------------------------------------------------------
and DoubleShift(dblwordlv,amount) = valof	//from SpruceUtils
//-------------------------------------------------------------------
[
test amount ls 0
ifso	//Left shift
  [
  amount = -amount
  let temp=(dblwordlv!1) rshift (16-amount)
  @dblwordlv=(@dblwordlv lshift amount)+temp
  dblwordlv!1=(dblwordlv!1) lshift amount
  ]
ifnot
  [
  let temp=@dblwordlv lshift (16-amount)
  @dblwordlv=@dblwordlv rshift amount
  dblwordlv!1=((dblwordlv!1) rshift amount)+temp
  ]
resultis dblwordlv!1
]

//-------------------------------------------------------------------
and InitDoubleStack(length) be
//-------------------------------------------------------------------
[
DoubleStack = Allocate(sysZone,length)
DoubleStackLength = length
DoubleStackPtr = DoubleStack
]

//-------------------------------------------------------------------
and FinishDoubleStack() be Free(sysZone,DoubleStack)
//-------------------------------------------------------------------

//-------------------------------------------------------------------
and DoublePush(doublet) = valof
//-------------------------------------------------------------------
[
if DoubleStackPtr ge DoubleStack+DoubleStackLength
 then resultis false
DoubleCop(DoubleStackPtr,doublet)
DoubleStackPtr=DoubleStackPtr+2
resultis true
]

//-------------------------------------------------------------------
and DoublePop(doublet) = valof
//-------------------------------------------------------------------
[
if DoubleStackPtr le DoubleStack
 then resultis false
DoubleStackPtr=DoubleStackPtr-2
DoubleCop(doublet,DoubleStackPtr)
resultis true
]

//-------------------------------------------------------------------
and MergePressFile(outputStream,inputStream,auxInputStream) be
//-------------------------------------------------------------------
[
let docDir = Allocate(sysZone,256)
unless isPressFile(inputStream,docDir)
 do error("[MergePressFile] Not a Press file: ", inputNames!currentInputName)

let partDirectory = Allocate(sysZone,256*docDir>>DDV.pdRecs)
PositionPage(inputStream,(docDir>>DDV.pdStart)+1)
ReadBlock(inputStream,partDirectory,256*docDir>>DDV.pdRecs)

let numParts = docDir>>DDV.nParts
unless numParts eq 2
 do error("[MergePressFile] Must have exactly one page: ", inputNames!currentInputName)
Free(sysZone, docDir)

//search for font directory:
for p = 1 to numParts do
  [
  if partDirectory>>PD^p.Type eq PETypeFont then
    [
    CopyFonts(lv (partDirectory>>PD^p),inputStream)
    break
    ]
  ]

//do all pages:
for p = 1 to numParts do
  [
  if partDirectory>>PD^p.Type eq PETypePage
   then CopyPage(lv (partDirectory>>PD^p), inputStream,auxInputStream)
  ]

Free(sysZone, partDirectory)
]

//-------------------------------------------------------------------
and CopyPressFile(stream,pressFile,DLstream) be
//-------------------------------------------------------------------
[
let docDir = Allocate(sysZone,256)
unless isPressFile(stream,docDir)
 do error("[CopyPressFile] Not a Press file.")

let partDirectory = Allocate(sysZone,256*docDir>>DDV.pdRecs)
PositionPage(stream,(docDir>>DDV.pdStart)+1)
ReadBlock(stream,partDirectory,256*docDir>>DDV.pdRecs)

let numParts = docDir>>DDV.nParts
Free(sysZone, docDir)

//search for font directory:
for p = 1 to numParts do
  [
  if partDirectory>>PD^p.Type eq PETypeFont then
    [
    CopyFonts(lv (partDirectory>>PD^p),stream)
    break
    ]
  ]

//do all pages:
for p = 1 to numParts do
  [
  if partDirectory>>PD^p.Type eq PETypePage then
    [
    CopyPage(lv (partDirectory>>PD^p),stream,DLstream)
    WritePart(partDir,pressFile,false)
    ]
  ]

Free(sysZone, partDirectory)
]

//-------------------------------------------------------------------
and CopyPage(part, ELstream, DLstream) be
//-------------------------------------------------------------------
[
//part is a PE structure, with type = PETypePage
if part>>PE.Type ne PETypePage then error("[CopyPage] Entry not a page")

PositionPage(ELstream, (part>>PE.pStart)+(part>>PE.pRecs)+1)
let ePos = vec 1; FilePos(ELstream,ePos)

let pad = vec 1; pad!0 = 0; pad!1 = part>>PE.Padding+1
DoubleShift(pad,-1) //*2
DoubleSub(ePos,pad)
SetFilePos(ELstream,ePos) //now pointing at length of last entity

InitDoubleStack(maxEntities*2)
  [
  let length = vec 1; length!0 = 0
  ReadBlock(ELstream,length+1,1)
  if length!1 eq 0 then break
  FilePos(ELstream,ePos)
  unless DoublePush(ePos) //now pointing past entity
   do error("[CopyPage] Too many Entities")

  DoubleShift(length,-1) //*2
  DoubleSub(ePos,length)
  DoubleSub(ePos,table[ 0; 2 ] ) //before length
  SetFilePos(ELstream,ePos)
  ] repeat

// Process all entities in order
let entity = Allocate(sysZone, EHlen)
while DoublePop(ePos) do
  [
  DoubleSub(ePos,table[ 0; EHlen*2 ])
  SetFilePos(ELstream,ePos)
  let trailerPos = vec 1
  DoubleCop(trailerPos,ePos)
  ReadBlock(ELstream,entity,EHlen)
  CopyEntity(part,entity,trailerPos,ELstream,DLstream)
  ]
Free(sysZone,entity)
FinishDoubleStack()
]

//-------------------------------------------------------------------
and CopyEntity(part,entity,trailerPos,ELstream,DLstream) be
//-------------------------------------------------------------------
[
//set ELstream to start of commands:
let ePos = vec 1
DoubleCop(ePos,trailerPos)
DoubleAdd(ePos,table[ 0; EHlen*2 ])
let length = vec 1
length!0 = 0; length!1 = entity>>EH.Length
DoubleShift(length,-1) //*2
DoubleSub(ePos,length)
SetFilePos(ELstream,ePos)

//set DLstream to start of DL:
PositionPage(DLstream, (part>>PE.pStart)+1)
let dPos = vec 1; FilePos(DLstream,dPos)
let start = lv entity>>EH.Dstart
DoubleAdd(dPos,start)
SetFilePos(DLstream,dPos)

let entityStart = vec 1
FilePos(pressFile,entityStart)

until ePos!0 eq trailerPos!0 & ePos!1 eq trailerPos!1 do
  [
  let command = Gets(ELstream)
  unless intercepted(command,ELstream,DLstream,ePos,trailerPos)
   do CopyCommand(command,ELstream,DLstream,pressFile)
  FilePos(ELstream,ePos)
  ]
PutEntityTrailer(entity,pressFile)
]


//-------------------------------------------------------------------
and CopyCommand(command,ELstream,DLstream,pressFile) be
//-------------------------------------------------------------------
[
  PutCommandByte(command)
  switchon command into
    [
    case EShow:
    case ESkip:
      [ //one-byte count of bytes in DL
      let count = Gets(ELstream)
      PutCommandByte(count)
      for i = 1 to count do Puts(pressFile,Gets(DLstream))
      endcase
      ]
    case EShowShort to EShowShort+EShortShowMax:
    case ESkipShort to ESkipShort+EShortShowMax:
      [ //embedded count of bytes in DL
      let count = command-EShowShort+1
      for i = 1 to count do Puts(pressFile,Gets(DLstream))
      endcase
      ]
    case EShowSkip to EShowSkip+EShortShowMax:
      [ //embedded count of bytes in DL + one DL byte
      let count = command-EShowSkip+2
      for i = 1 to count do Puts(pressFile,Gets(DLstream))
      endcase
      ]
    case ESkipControl:
      [ //two-byte count of bytes in DL + type
      let count = CopyELWord(ELstream)
      for i = 1 to count do Puts(pressFile,Gets(DLstream))
      PutCommandByte(Gets(ELstream))
      endcase
      ]
    case ESkipControlImmediate:
      [ //one-byte count of bytes in EL
      let count = Gets(ELstream)
      PutCommandByte(count)
      for i = 1 to count do PutCommandByte(Gets(ELstream))
      endcase
      ]
    case EShowRectangle:
      [ //2 two-byte literals
      PutCommandByte(Gets(ELstream))
      PutCommandByte(Gets(ELstream))
      PutCommandByte(Gets(ELstream))
      PutCommandByte(Gets(ELstream))
      endcase
      ]
    case ESetX:
      [ //two-byte literal
      let high = Gets(ELstream)
      PutCommandByte(high)
      let low = Gets(ELstream)
      PutCommandByte(low)
      lastX = high lshift 8 + low
      endcase
      ]
    case ESetY:
      [ //two-byte literal
      let high = Gets(ELstream)
      PutCommandByte(high)
      let low = Gets(ELstream)
      PutCommandByte(low)
      lastY = high lshift 8 + low
      endcase
      ]
    case ESpaceX:
    case ESpaceY:
      [ //two-byte literal
      PutCommandByte(Gets(ELstream))
      PutCommandByte(Gets(ELstream))
      endcase
      ]
    case EOnlyOnCopy:
    case ESetBright:
    case ESetHue:
    case ESetSat: 
    case EShowImmediate:
    case ESpaceXShort to ESpaceXShort+EShortSpaceMax:
    case ESpaceYShort to ESpaceYShort+EShortSpaceMax:
      [ //one-byte literal
      PutCommandByte(Gets(ELstream))
      endcase
      ]
    case EShowObject:
      [ //two-byte count of DL words
      let count = vec 1;
      count!0 = 0
      count!1 = CopyELWord(ELstream)
      CopyDLWords(pressFile,DLstream,count)
      endcase
      ]
    case EShowDots:
    case EShowDotsOpaque:
      [ //four-byte count of DL words
      let count = vec 1;
      count!0 = CopyELWord(ELstream)
      count!1 = CopyELWord(ELstream)
      CopyDLWords(pressFile,DLstream,count)
      endcase
      ]
    case EAlternative:
      [ //two-byte EL literal + four-byte count of EL bytes + four-byte count of DL bytes
      let count = vec 1;
      count!0 = CopyELWord(ELstream)
      count!1 = CopyELWord(ELstream)
      until count!0 eq 0 & count!1 eq 0 do
        [
        PutCommandByte(Gets(ELstream))
        DoubleSub(count,table[ 0; 1 ])
        ]
      count!0 = CopyELWord(ELstream)
      count!1 = CopyELWord(ELstream)
      until count!0 eq 0 & count!1 eq 0 do
        [
        Puts(pressFile,Gets(DLstream))
        DoubleSub(count,table[ 0; 1 ])
        ]
      endcase
      ]
    ]
]

//-------------------------------------------------------------------
and CopyFonts(part,stream) be
//-------------------------------------------------------------------
[
PositionPage(stream, (part>>PE.pStart)+1)
let length = nil; ReadBlock(stream,lv length,1)
while length ne 0 do
  [
  let font = Allocate(sysZone,length)
  ReadBlock(stream,font+1,length-1)
  font!0 = length
  AddFontEntry(font)
  Free(sysZone,font)
  ReadBlock(stream,lv length,1)
  ]
]

//-------------------------------------------------------------------
and CopyELWord(stream) = valof
//-------------------------------------------------------------------
[
let wordHigh = Gets(stream)
PutCommandByte(wordHigh)
let wordLow = Gets(stream)
PutCommandByte(wordLow)
resultis (wordHigh lshift 8) + wordLow
]

//-------------------------------------------------------------------
and CopyDLWords(outputStream,inputStream,count) be
//-------------------------------------------------------------------
[
//count is double-word count of words of DL to copy

structure [ LH byte; RH byte ]
let buffer = Allocate(sysZone,256)
until count!0 eq 0 & (count!1)<<LH eq 0 do
  [
  ReadBlock(inputStream,buffer,256)
  WriteBlock(outputStream,buffer,256)
  DoubleSub(count,table[ 0; 256 ])
  ]
unless (count!1)<<RH eq 0 do
  [
  ReadBlock(inputStream,buffer,(count!1)<<RH)
  WriteBlock(outputStream,buffer,(count!1)<<RH)
  ] 
Free(sysZone,buffer)
]

//-------------------------------------------------------------------
and intercepted(command,ELstream,DLstream,startPos,trailerPos) = valof
//-------------------------------------------------------------------
[
if addresseeName eq 0 then resultis false
let count = nil
switchon command into
    [
    case EShow:
      count = Gets(ELstream)
      endcase
    case EShowShort to EShowShort+EShortShowMax:
      count = command-EShowShort+1
      endcase
    default: resultis false
    ]
let string = Allocate(sysZone,128)
test MatchesKey(DLstream,count,string)
ifso InsertAddressees(ELstream,DLstream,startPos,trailerPos)
ifnot test StringCompare(string,titleString) eq 0
      ifso 
	[
	let string = docName eq 0? " ",docName
	Wss(pressFile,string)
	WriteCommand(EShow,string>>String.length)
	]
      ifnot 
	[
	Wss(pressFile,string)
	WriteCommand(EShow,string>>String.length)
	]
Free(sysZone,string)
resultis true
]

//-------------------------------------------------------------------
and InsertAddressees(ELstream,DLstream,startPos,trailerPos) be
//-------------------------------------------------------------------
[
let string = Allocate(sysZone,128)
let endPos = vec 1; FilePos(ELstream,endPos)
let DLPos = vec 1
until endPos!0 eq trailerPos!0 & endPos!1 eq trailerPos!1 do
  [
  FilePos(DLstream,DLPos)
  let command = Gets(ELstream)
  switchon command into
    [
    case EShow:
      unless MatchesKey(DLstream,Gets(ELstream),string) break
      endcase
    case EShowShort to EShowShort+EShortShowMax:
      unless MatchesKey(DLstream,command-EShowShort+1,string) break
      endcase
    case ESetX:
    case ESetY:
      Gets(ELstream)
      Gets(ELstream)
      endcase
    case EFont:
      endcase
    default: break
    ]
  FilePos(ELstream,endPos)
  ]
SetFilePos(DLstream,DLPos)  //to where non-match started
Free(sysZone,string)

//now that we've found where, go back and insert addressees
SetUpAddressees()
let copy = 1
until addresseesFinished % copy gr maxCopies do
  [
  WriteCommand(EOnlyOnCopy,copy)
  WriteCommand(ESetX, lastX)
  WriteCommand(ESetY, lastY)
  SetFilePos(ELstream,startPos)
  let pos = vec 1; DoubleCop(pos,startPos)
  until pos!0 eq endPos!0 & pos!1 eq endPos!1 do
    [
    let command = Gets(ELstream)
    switchon command into
      [
      case EShow:
        ShowAddressee(Gets(ELstream),DLstream)
        endcase
      case EShowShort to EShowShort+EShortShowMax:
        ShowAddressee(command-EShowShort+1,DLstream)
        endcase
      case ESetX:
      case ESetY:
        PutCommandByte(command)
        PutCommandByte(Gets(ELstream))
        PutCommandByte(Gets(ELstream))
        endcase
      case EFont:
        PutCommandByte(command)
        endcase
      ]
    FilePos(ELstream,pos)
    ]
  NextAddressee()
  copy = copy+1
  ]
WriteCommand(EOnlyOnCopy,0)
numCopies = copy-1
CloseAddressees()
]

//-------------------------------------------------------------------
and MatchesKey(stream,count,string) = valof
//-------------------------------------------------------------------
[
let ss=CreateStringStream(string,255)
for i = 1 to count do Puts(ss,Gets(stream))
Closes(ss)
resultis StringCompare(string,keyString) eq 0
]

//-------------------------------------------------------------------
and SetUpAddressees() be
//-------------------------------------------------------------------
[
if alreadySetUp return
alreadySetUp = true
addresseeLines=Allocate(sysZone,maxAddresseeLines)
let name = CreateStringStream(addresseeName)
test Gets(name) eq $"
 ifnot addresseeStream = OpenFile(addresseeName, ksTypeReadOnly, charItem)
 ifso
    [
    let string = Allocate(sysZone,128)
    addresseeStream = CreateStringStream(string,255)
    until Endofs(name) do
      [
      let ch = Gets(name)
      if ch eq $" break
      if ch eq $- then ch = $*S
      Puts(addresseeStream,ch)
      ]
    Puts(addresseeStream,$*N)
    Closes(addresseeStream)
    addresseeStream = CreateStringStream(string)
    ]
Closes(name)
for i = 0 to maxAddresseeLines-1
 do addresseeLines!i = Allocate(sysZone,128)
addresseesFinished=false
NextAddressee()
]

//-------------------------------------------------------------------
and ShowAddressee(count,stream) be
//-------------------------------------------------------------------
[
if addresseeLine eq maxAddresseeLines
 then error("[ShowAddressee] Too many lines for addressee")
//for i = 1 to count do Gets(stream)
Wss(pressFile,addresseeLines!addresseeLine)
WriteCommand(EShow,(addresseeLines!addresseeLine)>>String.length)
addresseeLine=addresseeLine+1
]

//-------------------------------------------------------------------
and NextAddressee() be
//-------------------------------------------------------------------
[
if Endofs(addresseeStream)
 then [ addresseesFinished = true; return ]
let ch = 0
for i = 0 to maxAddresseeLines-1 do
  [
  let ss = CreateStringStream(addresseeLines!i,255)
  test Endofs(addresseeStream) % ch eq controlZ
   ifso Puts(ss,$*S)
   ifnot
     [
     ch = Gets(addresseeStream)
     until Endofs(addresseeStream)
        % ch eq $*N % ch eq controlZ do
       [
       Puts(ss,ch)
       ch = Gets(addresseeStream)
       ]
     Puts(ss,$*S)
     ]
  Closes(ss)
  ]
until Endofs(addresseeStream) % ch eq $*N
  do ch = Gets(addresseeStream)
addresseeLine=0
]

//-------------------------------------------------------------------
and CloseAddressees() be
//-------------------------------------------------------------------
[
unless addresseesFinished return
for i = 0 to maxAddresseeLines-1
 do Free(sysZone,addresseeLines!i)
Closes(addresseeStream)
alreadySetUp = false
]

//-------------------------------------------------------------------
and error(s1,s2;numargs N) be
//-------------------------------------------------------------------
[
Ws(s1)
if N ge 2 then Ws(s2)
abort
]




z20460k0e12(2116)