// RSilPress.bcpl . Creates the PRESS file RSIL.PRESS
//C. Thacker modified on August 24, 1977 add option to send to the press printer
//R. Bates modified on February 15, 1978 to print color
//R. Bates modified on March 16, 1978 to put file name in Sil.Press+new time standard
//R. Bates modified on June 16, 1978 added font faces
//R. Bates modified on June 16, 1978 renamed program to SilToPress
//P. Lam modified on January 11, 1981 
//		added user defined xmargin , bottommargin , two fontsets & font rotations

get "sysdefs.d"
get "Sil.defs"

external [ PUTB ]  //from this file
external MulDiv  //from FontWidths.bcpl

manifest
[
//press commands:
SetX = #356
SetY = #357
ShowRectangle = #376
ShowCharacters = #360
Nop = #377
SetFont = #160
]

external
[
WSSB
UserName
DayTime; UNPACKDT; CONVUDT
dsp
]

external
[
CurrentPassNumber
@FontUsed
FontUsedTwo
FontSet
@FontNames
]

static
[ 
ncopies
PressS
@BackGndEn
@DoFnt15 = false
@ScanCvrt = false
@fheight
@fontsel
@EntityBytesSent
@FirstDLByte
@DLBytesSent
@ByteCarry =0
@PartDir
@PDptr
@BytesOut = 0
@CurrentRecord = 0
@Nparts = 0
@FontNames
@FontUsed = 0
BottomMargin = 0				// normal = 0; UMI (define in User.cm) = 2
//@Xmargin = 28					// normal = 28; UMI (define in User.cm) = 0
@Ymargin = 0
C1778 = C1778dflt
C50 = C50dflt

@prXmin; @prXmax; @prYmin;@prYmax
rotation
FontAlign
FontSet = 1			// = 1 if le 4 fonts defined in user.cm 
PressPass = 1			// = Number of passes needed to generate the font dir
FontUsedTwo
CurrentPassNumber
Font16Flag
Font16Sub
]

structure FDentry:
[(635)\809b72B296b64B
el word
set byte
font byte
m byte
n byte
fam^1,20 byte
face byte
source byte
siz word
rotation wordl4268
]


let MakePress(PrintSw,InitSwitch,comcm) be
[
Ws("*n*n*n*n*n"); Ws(Herrald)
//Xmargin = LeftMargin
FontNames = GetSomeMem(200)
InitColorTable(0) 
FNameObject = GetSomeMem(280)
let fn = lv FNameObject>>item.string
SilInitCode(InitSwitch,0,FontNames)
let v = vec 50; InitCursor(v,50,0,0)
WriteCursor(Wss,"pg")

l4269
//initialize a zone for the file system
let v = vec 2000
SilZone = InitializeZone(v,2000)

//set up the part directory
let v = vec 256
PartDir = v
PDptr = PartDir
Zero(PartDir,256)

//initialize the Macro Definition Table
//Zero(Mact,Mtsize)


//use remaining space for the objects
SpaceBase = @#335 //EndCode
@#335 = lv PrintSw -2000 //set EndCode - leave 2000 words for the stack
SpaceTop = @#335-128 //leave margin for error
if (SpaceTop-SpaceBase-10000) ls 0 then CallSwat("Insufficient Object Storage")


let PressName = vec 100
let PressFile = vec 50; PressFile!0 = 0; AppendS("RSil.Press",PressFile)
let Host = vec 50; Host!0 = 0
OneLevel = false  //ask for full macro expansion
PressS = 0
l4268
//THE MAIN FILE INPUT LOOPl2998

let Page = 0
[l4268
WriteCursor(Wns,Page+1,2)
WriteCursor($i)
InitStorage()
if not ReadCmEntry(comcm,fn) then break //no more files
CheckColorCmmd(comcm,fn,Host,PressFile)
if not fn>>str.length then break //command line error
FileIn(0)
let InOK = " "
if Message!0 ne InOK!0 then
	[ Ws("*n");Ws(Message);Ws(fn);@#420 = Dcb; loop ]
if not PressS then
[l5538
PressS=OpenFile(PressFile,ksTypeWriteOnly,1,verLatestCreate,0,0,SilZone)
if PressS eq 0 then CallSwat("Can't Open RSil.Press")
MoveBlock(PressName, fn, 100)//save the name of the first filel6808
]
WriteCursor($o)
@#420 = 0 //turn off display again
PressOut(PressS)
Page = Page+1
l5538
] repeat
if ncopies ls 1 then ncopies = 1
if ncopies ne 1 then PrintSw = true
if Page gr 1 then AppendS("  etc.",PressName)
WriteCursor(Wss,"dn")
Closes(comcm)
if PressS ne 0 then //send out the parts directories
[l4268
//make Font Descriptors for the fonts used and send to out file
SendFDEntries(PressS,0)
if FontSet eq 2 then SendFDEntries(PressS,1)
//Output the font directory
//for i = 0 to 255 do PUTW(PressS,FontDir!i)

//add an entry to the part directory for the font directory
PDptr!0 = 1 //type font directory part
PDptr!1 = CurrentRecord
//PDptr!2 =1// FDptr ge 255? 2,1 //font directory is one page long
PDptr!2 =FontSet				 //font directory is one/two pages long
PDptr = PDptr+3
Nparts = Nparts+1
//CurrentRecord = CurrentRecord+1
CurrentRecord = CurrentRecord+FontSet

//Output the part directory
for i = 0 to 255 do PUTW(PressS,PartDir!i)
CurrentRecord = CurrentRecord+1

//Output the Document Directory
let dd=PartDir
for i = 0 to 127 do dd!i = -1
Zero(dd+128,128)
dd!0=27183  //password
dd!1=CurrentRecord+1  //total number of records
dd!2=Nparts  //total number of parts
dd!3=CurrentRecord-1  // part directory begins here
dd!4=1  //part directory is 1 record long
//dd!5=-1 
DayTime(dd+6)  //put 1 sec timer into dd!6 and dd!7
dd!8=1  //first page to print
dd!9=1  //last page
//dd!10=-1  
//dd!11=-1  
dd!12 = ScanCvrt ne 0? ScanCvrt,-1  //Flag to get full software scan conversion  
MoveBlock(dd+200b, PressName, 26)//put in the name of the first file
MoveBlock(dd+232b, UserName, UserName!-1)
let v = vec 6  //now get the Date and Time
UNPACKDT(0,v)
CONVUDT(dd+252b,v)
for i = 0 to 255 do PUTW(PressS,dd!i)
Closes(PressS)l5538
]
test (PrintSw eq true) % Host!0 ifso
[ // Now write command on Rem.Cm and preserve old contents.l4268
WriteRemcm(Host,PressFile) 
]
//CounterJunta(SpeakVersion)
ifnot [ Ws("*n"); Ws(PressFile); Ws(" may be sent directly with use of 'RSil/h'") ]
finishl4268
] 


and PUTW(stream,wurd) be
[
PUTB(stream,wurd rshift 8)
PUTB(stream,wurd & #377)l4268
]

and PUTB(stream,bite) be
[
Puts(stream,bite)
EntityBytesSent = EntityBytesSent+1
BytesOut = BytesOut+1
if BytesOut eq 0 then ByteCarry = ByteCarry+1l4268
]

and WSSB(stream,string) be
[
for i=1 to string>>str.length do PUTB(stream, string>>str.char^i)l4269
]

and InitStorage() be
[
NewItem= SpaceBase
FirstItem = 0
Zero(Mact,Mtsize)
]



and PressOut(st) be //takes a stream open for bytes
[
let v = vec 7
FontAlign = v
Zero(FontAlign,7)
FontSet = FontUtil(FontAlign)		// returns the number of font sets needed 
let link = FirstItem
// This code test for two passes to generate the press file
if FontSet eq 2 then
[
until link eq 0 do //build PressPass
	[
if link>>item.macro then
//macro --expand it and output any strings it contains
[l5538
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(link,0,0)
let tl = FirstItem
until tl eq 0 do
[l6808
MarkFontUsed(tl) 
tl=tl>>item.linkl8078
]
FirstItem = sfi
NewItem = snil6808
]
MarkFontUsed(link) 
link = link>>item.linkl5538
	]
let count = 0
Font16Sub = -1
for i = 0 to 15 do
			[
			let Filled = (FontUsed & 1 lshift i)
			if Filled then count = count + 1
			if not Filled & Font16Sub eq -1 then Font16Sub = i
			let n = (FontUsedTwo & 1 lshift i)
			if n then count = count + 1
			]
if count ge 16 then PressPass = 2
]

if (FontSet eq 1 & FontUsed eq -1) % ( FontUsed eq -1 & FontUsedTwo eq -1 ) then CallSwat("To many font & faces in file")
if FontSet eq 2 & FontUsedTwo eq 0 & FontUsed ne -1 then FontSet = 1
Font16Flag = (FontUsed & #100000) eq #100000
if FontSet eq 2 then Font16Flag = false 
// Now actually do it
DoPressOut(st) 
]
l4268


and DoPressOut(st) be //takes a stream open for bytes
[
let DLone =0
let DLtwo = 0
test FontSet eq 1
ifso CurrentPassNumber = 0
ifnot CurrentPassNumber = 1
BytesOut = 0; ByteCarry = 0
//initial color conditions for start of press page
InitColorTable(true)
DoFnt15=false
let link = FirstItem

// may loop twice for FontSet = 2
[
link = FirstItem
until link eq 0 do //build DL
	[x0
//if ((link>>item.font ge 8)&(link>>item.font ls 14)) then
if link>>item.macro then
//macro --expand it and output any strings it contains
[l5538
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(link,0,0)
let tl = FirstItem
until tl eq 0 do
[l6808
//if tl>>item.font ls 8 then WSSB(st,lv(tl>>item.string))
//if tl>>item.font eq 15 then DoFnt15 = true
PutString(tl ,st) 
if tl>>item.area then DoFnt15 = true
tl=tl>>item.linkl8078
]
FirstItem = sfi
NewItem = snil6808
]

//if link>>item.font ls 8 then WSSB(st, lv(link>>item.string))
//if link>>item.font eq 15 then DoFnt15 = true
PutString(link ,st) 
if link>>item.area then DoFnt15 = true
link = link>>item.linkl5538
		]
	if FontSet eq 1 then break
	if CurrentPassNumber eq 1 then DLone = BytesOut
	if CurrentPassNumber eq 2 then DLtwo = BytesOut
//	BytesOut = 0
	if CurrentPassNumber eq 2 then break
	CurrentPassNumber = CurrentPassNumber + 1
] repeat


if (BytesOut & 1) ne 0 then PUTB(st,0) //pad to word boundary
let BytesInDL = BytesOut
if (BytesInDL ls 0)%(ByteCarry ne 0) then
  CallSwat("DL too large- type ^K to exit")
BytesOut = 0; ByteCarry = 0
//now we are sending EL
PUTW(st,0) //send a 0 word
StartEntity()
FirstDLByte = 0
if BackGndEn ne true then DoFnt15 = false//skip backgrounds to print on Dover
//the following loop may be executed once or twice
//if the previous pass through the item lists found no items of font 15
//then only one pass is needed
//if areas are painted some color, then for objects OVER background,
//backgrounds must be output first - hence two passes


test FontSet eq 1
ifso CurrentPassNumber = 0
ifnot CurrentPassNumber = 1
// may loop twice for FontSet = 2
[
	[
	if CurrentPassNumber eq 2 then DoFnt15 = false
link = FirstItem //go through again and output entity list
until link eq 0 do
[l5538
let tl = link; link = link>>item.link
let fnt = tl>>item.font
//if ((fnt ge 8)&(fnt ls 14)) then  //macro 
if tl>>item.macro then
[l6808
let sfi = FirstItem
FirstItem = 0
let sni = NewItem
Expand(tl,0,0)
let xtl = FirstItem
until xtl eq 0 do 
[l8078
if (xtl>>item.area eq 1) eq DoFnt15 then MakeEntity(st,tl,xtl)
xtl = xtl>>item.linkl9348
]

FirstItem = sfi
NewItem = sni
loopl8078
]
//not a macro
if (tl>>item.area eq 1) eq DoFnt15 then MakeEntity(st,tl,tl)
]
if DoFnt15 eq 0 then break
if not ScanCvrt then ScanCvrt = $s  //dont set $s if nPPR/f said "fast print"
DoFnt15 = 0l5538
	] repeat

if FontSet eq 1 then break
if CurrentPassNumber eq 1 then PumpOutEntity(st)
if CurrentPassNumber eq 2 then break
CurrentPassNumber = CurrentPassNumber + 1
] repeat

//send the last entity
PumpOutEntity(st)

//pad
let elp = 0 //entity list padding
until ((BytesOut+BytesInDL) & #777) eq 0 do 
[l4268
PUTW(st,0)
elp = elp+1l5538
]



//make an entry in the part directory for this page
PDptr!0 = 0 //type printed page
PDptr!1 = CurrentRecord
let rlen = (BytesOut rshift 9)+(BytesInDL rshift 9)+(((BytesOut & #777)+(BytesInDL & #777))rshift 9)+(ByteCarry lshift 7) //from bytes to pages
PDptr!2 = rlen
CurrentRecord = CurrentRecord+rlen
PDptr!3 = elp
PDptr = PDptr+4
Nparts = Nparts+1

]

and StartEntity() be
[
fontsel=0; fheight=AlFaceVec!(fontsel/4)
EntityBytesSent = 0 //don't count the zero word
DLBytesSent = 0
prXmin=ScreenXmax; prXmax=-1
prYmin=ScreenYmax; prYmax=-1l4268
]

and MakeEntity(st,tl,xtl) be
[
// CurrentPassNumber = 0 ---> write everything
// CurrentPassNumber = 1 ---> write fonts le 15
// CurrentPassNumber = 2 ---> write fonts ge 16 &  le 28
let xfnt = xtl>>item.font
let LineOrArea = xtl>>item.line %  xtl>>item.area
let xfnt = xtl>>item.font
test LineOrArea
	ifso [ if CurrentPassNumber eq 2 then return ]
	ifnot [ 	
			if (CurrentPassNumber eq 1) & (xfnt gr 7)  then return
			if (CurrentPassNumber eq 2) & (xfnt ls 8) then return
		 ]
SetEntityColor(st,tl,xtl)
//test xfnt ge 14 ifso //rectangle
test LineOrArea ifso //rectangle
[
//crop lines at ScreenMax boundaries
if xtl>>item.xmax gr ScreenXmax then xtl>>item.xmax = ScreenXmax
if xtl>>item.ymax gr ScreenYmax then xtl>>item.ymax = ScreenYmax

let w=xtl>>item.xmax - xtl>>item.xmin
let h=xtl>>item.ymax - xtl>>item.ymin
if w ge 0 & h ge 0 then	//Guard against unsanitized Sil files
[l5538
PUTB(st,SetX)
PUTW(st,MulDiv(xtl>>item.xmin, C1778, C50) )
PUTB(st,SetY)
PUTW(st,MulDiv(ScreenYmax-xtl>>item.ymax, C1778, C50) )
PUTB(st,ShowRectangle)
PUTW(st,MulDiv(w ,C1778,C50))
PUTW(st,MulDiv(h ,C1778,C50))l6808
]
l5538
]

ifnot
[l4268
//the object is a string
xfnt = xtl>>item.fullfont
//FontUsed = FontUsed % (1 lshift xfnt)
let delx = FontAlign!(xfnt/4)
PUTB(st,SetX)
PUTW(st,MulDiv(xtl>>item.xmin + delx , C1778, C50) )
if xfnt ne fontsel then
[l5538
fontsel = xfnt  //external font with bold/italics bits
fheight = AlFaceVec!(fontsel/4)
let fontnumber = fontsel
if CurrentPassNumber eq 2 then fontnumber = fontnumber - #20
if CurrentPassNumber ls 2 &  Font16Flag & fontsel eq 15 then fontnumber = Font16Sub
PUTB(st,SetFont+fontnumber)
//PUTB(st,SetFont+fontsel)
l6808
]

let FontItem = FontOrientation!( xfnt/4 )
let rot = FontItem & #377
//The following kludge is in to line up Gates and Template font definitions with sil lines on the printers.
let fudge = fheight ge 32? 16,0  //should be Gates32 or Template64
let pressPosn = ScreenYmax-xtl>>item.ymin-fheight
if rot eq 1 then pressPosn = ScreenYmax-xtl>>item.ymax
if pressPosn ls 0 then pressPosn = 0
PUTB(st,SetY)
PUTW(st,MulDiv(pressPosn, C1778, C50) + fudge)
PUTB(st,ShowCharacters)
let bcout =xtl>>item.string.length
PUTB(st,bcout)
DLBytesSent = DLBytesSent+bcoutl5538
]
if prXmin gr xtl>>item.xmin then prXmin=xtl>>item.xmin
if prXmax ls xtl>>item.xmax then prXmax=xtl>>item.xmax
if prYmin gr xtl>>item.ymin then prYmin=xtl>>item.ymin
if prYmax ls xtl>>item.ymax then prYmax=xtl>>item.ymax
if EntityBytesSent gr 20000 then PumpOutEntity(st) l4268
]

and PumpOutEntity (st) be
[
if (BytesOut & 1) ne 0 then PUTB(st,Nop) //pad to word boundary
//send entity trailer
PUTB(st,0)  //type
if CurrentPassNumber eq 2 then PUTB(st,1) //font set
if CurrentPassNumber ls 2 then PUTB(st,0) //font set
PUTW(st,0); PUTW(st,FirstDLByte) //begin-byte
PUTW(st,0); PUTW(st,DLBytesSent) //byte-length
//PUTW(st,MulDiv(Xmargin,C1778,C50)) //Xe
PUTW(st,MulDiv(LeftMargin,C1778,C50)) //Xe
PUTW(st,MulDiv(-Ymargin,C1778,C50)) //Ye
PUTW(st,MulDiv(prXmin,C1778,C50)) //left
PUTW(st,MulDiv(ScreenYmax+BottomMargin-prYmax,C1778,C50)) //bottom
PUTW(st,MulDiv(prXmax-prXmin ,C1778,C50)) //width
PUTW(st,MulDiv(prYmax-prYmin ,C1778,C50)) //height
PUTW(st,1+EntityBytesSent/2)  //entity length
FirstDLByte = FirstDLByte+DLBytesSent
StartEntity()
l4268
]


and SendFDEntries(S,set) be			// set is 0/1
[
let FontDir = vec 256
let FDptr = FontDir
Zero(FontDir,256)
if (FontSet eq 1 & FontUsed eq -1) % ( FontUsed eq -1 & FontUsedTwo eq -1 ) then CallSwat("To many font & faces in file")
let startfont, endfont = 0, 3
if set eq 1 then  [ startfont = 4; endfont = 6 ]
for font = startfont to endfont do
[l4268
let name = FontNames + 25*font
if name>>str.length eq 0 then loop
let ssi = 1 //remove leading "X" in name if there
if ((name>>str.char^1 eq $X) % (name>>str.char^1 eq $x)) then ssi=2
let FontItem = FontOrientation!font
let r = FontItem & #377
rotation = 90*r*60
//if font ge 2 then rotation = 90*60
let siz = GetNum(name,0)
if siz eq 0 then CallSwat("No point size in font:",name)
let face = 0; let gotsize = false; let sei = 1
for chrptr = 1 to name>>str.length do
[l5538
let lastchar = name>>str.char^chrptr
if gotsize then switchon lastchar into
[l6808
case $I: case $i: face = face%1; endcase

case $R: case $r:
case $M: case $m:   endcase

case $B: case $b: face = face%2;   endcase

case $L: case $l:  face = face%4;  endcase

case $0: case $1: case $2: case $3: case $4:
case $5: case $6: case $7: case $8: case $9: endcase

default:  CallSwat("Malformed Font Name:",name)
l8078
]
if (lastchar ge $0) & (lastchar le$9) then if gotsize eq false do
	[ sei = chrptr-1; gotsize = true ]l6808
]

//fill in the font directory entry for this font
for f = 0 to 3 do
[l5538
let ff = font*4 + f
let FontFaceUsed = 0
test set eq 0 
	ifso [ 
			FontFaceUsed = FontUsed &  (1 lshift ff)
		 ]
	ifnot [ 
			ff = ff - #20
			FontFaceUsed = FontUsedTwo &  (1 lshift ff)
		 ]

let NoEntry = (set eq 1) & (ff eq 15)
if not NoEntry then
[l6808
FDptr>>FDentry.el = 16
FDptr>>FDentry.set = set
FDptr>>FDentry.font = ff
FDptr>>FDentry.m = 0
FDptr>>FDentry.n = 127
FDptr>>FDentry.fam^1 = sei-ssi+1 //string length
let i = 2
for j = ssi to sei do
[l8078
FDptr>>FDentry.fam^i = name>>str.char^j
i = i+1l9348
]

if FontFaceUsed then FDptr>>FDentry.face = f xor face
FDptr>>FDentry.source = 0
FDptr>>FDentry.siz = MulDiv(siz, C50dflt, C50 )
FDptr>>FDentry.rotation = rotation
FDptr= FDptr+16l8078
]l6808
]l5539
]
if Font16Flag & set eq 0 then
	[
	FDptr = FontDir + 240
	FDptr>>FDentry.font = Font16Sub
	MoveBlock(FontDir + Font16Sub *16, FontDir + 240, 16)
	]
if FontSet eq 1 then Zero(FontDir+240,16)
//
for i = 0 to 255 do PUTW(S,FontDir!i)l4269
]