// February 21, 1978 11:22 AM *** overlay B ***
//Edited by Lyle Ramshaw September 8, 1980 9:01 PM:
// On to version 5.0, with a new file format to get text positioning
// done reasonably (and consistent with ReDRaw).
// Compile with STATS/M to get STATISTICS code [command <ctrl>Y]
// Compile with BITMAP/M to get BITMAP code [command <ctrl>B]
get "zpDefs.bcpl"
// outgoing procedures:
external [
readPicture
writePicture
writeStatistics
writeBitmap
changeTextMode
readHelp
readFont
]
// outgoing static:
external [
@help
]
static [
@help=0
]
// incoming procedures:
external [
Gets // SYSTEM
Puts
Endofs
Resets
Closes
OpenFile
OpenFileFromFp
FindFdEntry
FileLength
ReadBlock
WriteBlock
Zero
MoveBlock
giveUp // ZPUTIL
confirm
sTypeForm
typeForm
getLine
openRead
openWrite
abortMessage
capitalize
equal
makeSpline // ZPMAKE
makeText // ZPTEXT
writeText
eraseText
showText
obtainBlock // ZPBLOCK
putBlock
flushDTTstack
MakeFontEntry // ZPFONTIO
adjustText // ZPADJUST
]
// incoming statics:
external [
fpSysDir // SYSTEM
keys
@splineTable // ZPINIT
@textTable
@maxSplineID
@maxTextID
@fontDefTable
@fontFile
@font
@dspFont
@bitmap
@height
@width
@scanlineWidth
@bitmapSize
FLDI; FST // FLOAT
@posTextMode // ZPEDIT
@colorOn
]
// local definitions:
manifest [
getStatistics= not newname STATS
getBitmap= not newname BITMAP
]
// local statics:
static [
@BMheight=0
@BMwordWidth=0
]
// local definitions
structure CHAIN [
run↑1, 1000 byte
]
structure RUN [
blank byte
octant bit 3
count bit 5
]
// old file format
structure OFfirstWord [
fp bit
M bit 15
]
structure OFheader [
dashed bit
cyclic bit
blank bit 2
shape bit 2
thickness bit 2
nKnots byte
]
// new file formats (after version 3.0, first two words are 0;
// after version 5.0, first two words are -1)
structure NFheader1 [
blank bit 3
[ dashed bit
shape bit 2
thickness bit 2 ] = [ brush bit 5 ]
blank bit 5
color bit 3
]
structure NFheader2 [
cyclic bit
nKnots bit 15
]
//****************************************************************
// Special commands: statistics & bitmap output
//****************************************************************
let writeStatistics() be [writeStatistics
compileif getStatistics then [
let statFile=openWrite("*NWrite statistics on text file: ", charItem)
unless statFile return
let histVec= vec 256
Zero(histVec, 256)
typeForm(0, "Type comments terminated with 2 <return>s:*N")
[ let c=getLine()
unless c break
sTypeForm(statFile, 0, c, 1, $*N)
putBlock(c)
] repeat
let k, c=0, 0
for id=1 to maxSplineID do [
let splinePointer=splineTable!id
unless splinePointer loop
let nKnots=splinePointer>>SPLINE.nKnots
k=k+SPLINEknotBase+4*nKnots
let nBeads=splinePointer>>SPLINE.nBeads
unless nBeads loop
sTypeForm(statFile, 0, "*NSPLINE ", 10, id, 1, $*N,
10, nKnots, 0, " knots*N", 10, nBeads, 0, " beads*N")
let chainPointer=splinePointer>>SPLINE.chain
let chainCountPointer=chainPointer+nBeads*(BEADsize+2)
let runCount=@(chainCountPointer-1)
let countBlockSize=(runCount+1)/2
sTypeForm(statFile, 0, "chain storage: ", 10, BEADsize*nBeads, 1, $+,
10, 2*nBeads, 1, $+, 10, countBlockSize)
let s=nBeads*(BEADsize+2)+countBlockSize
c=c+s
sTypeForm(statFile, 1, $=, 10, s, 1, $*N)
let r=(chainCountPointer>>CHAIN.run↑1)<<RUN.count
let q=(chainCountPointer>>CHAIN.run↑1)<<RUN.octant
for k=2 to runCount do [
let r1=(chainCountPointer>>CHAIN.run↑k)<<RUN.count
let q1=(chainCountPointer>>CHAIN.run↑k)<<RUN.octant
test q1 eq q
ifso r=r+r1
ifnot [
if r gr 255 then r=255
histVec!r=histVec!r+1
r=r1
q=q1
]
]
if r gr 255 then r=255
histVec!r=histVec!r+1
]
let t=0
for id=1 to maxTextID do [
let textPointer=textTable!id
unless textPointer loop
t=TEXTblockSize+(textPointer+TEXTblockSize)>>STRING.length/2+1
]
sTypeForm(statFile, 0, "*N*NTotal storage:*NKnots: ", 10, k,
0, "*NChain: ", 10, c, 0, "*NText: ", 10, t)
sTypeForm(statFile, 0, "*NTotal: ", 10, k+c+t, 1, $*N)
Closes(statFile)
let histFile=openWrite("*NWrite histogram on binary file: ", wordItem)
unless histFile return
WriteBlock(histFile, histVec, 256)
Closes(histFile)
typeForm(0, "Done*N")
]
]writeStatistics
and writeBitmap() be [writeBitmap
compileif getBitmap then [
typeForm(0, "[Set statics BMheight & BMwordWidth]")
let file=openWrite("*NWrite BITMAP on file: ", wordItem)
unless file return
let bm=bitmap+margin+(height-BMheight)*scanlineWidth
Puts(file, BMheight)
Puts(file, BMwordWidth)
for s=1 to BMheight do [
WriteBlock(file, bm, BMwordWidth)
bm=bm+scanlineWidth
]
Closes(file)
typeForm(0, "Done*N")
]
]writeBitmap
//****************************************************************
// Standard spline input/output
//****************************************************************
and readPicture(file; numargs n) be [readPicture
let M,T=nil,nil
let newIdTable=0
flushDTTstack()
unless n then
file=openRead("*NRead picture from file: ", wordItem)
unless file return
let word1=Gets(file)
let word2=Gets(file)
let convertText=true //iff text must be converted to >=5.0 format
if (word1 eq -1) & (word2 eq -1) then convertText=false
test (word1 eq word2) & ((word2 eq 0)%(word2 eq -1))
ifso [
// new file format
M=Gets(file)
for m=1 to M do [
let header1=Gets(file)
let header2=Gets(file)
let n=header2<<NFheader2.nKnots
unless n gr 0 loop
let xTable=obtainBlock(4*n)
test xTable ne 0
ifso [
ReadBlock(file, xTable, 4*n)
makeSpline(n, xTable, xTable+2*n,
header1<<NFheader1.brush,
header1<<NFheader1.color,
header2<<NFheader2.cyclic)
putBlock(xTable)
]
ifnot [
giveUp("[readPicture.1]")
for i=1 to 4*n do Gets(file)
]
]
T= Endofs(file) ? 0, Gets(file)
if T ne 0 then [
newIdTable=obtainBlock(T)
if newIdTable eq 0 then [
giveUp("[readPicture.2]")
Closes(file)
return
]
]
for t=0 to T-1 do [
let textString= vec maxChar
let left=Gets(file)
let top=Gets(file)
let font=Gets(file)
let color=Gets(file)
let s=Gets(file)
ReadBlock(file, textString, s)
newIdTable!t=
makeText(textString, left, top, font, color, false)
]
]
ifnot [
// old file format
Resets(file)
word1=Gets(file)
let fp=word1<<OFfirstWord.fp
M=word1<<OFfirstWord.M
if M then [
let hTable=obtainBlock(M)
unless hTable then [
giveUp("[readPicture.3]")
Closes(file)
return
]
ReadBlock(file, hTable, M)
for i=0 to M-1 do [
let header=hTable!i
let n=header<<OFheader.nKnots
unless n gr 0 loop
let xTable=obtainBlock(4*n)
test xTable ne 0
ifso [
test fp
ifso ReadBlock(file, xTable, 4*n)
//for old integer format files!
ifnot for k=0 to 2*n-1 do
FST(FLDI(0, Gets(file)), xTable+2*k)
let brush=0
brush<<BRUSH.dashed=header<<OFheader.dashed
brush<<BRUSH.shape=header<<OFheader.shape
brush<<BRUSH.thickness=header<<OFheader.thickness
makeSpline(n, xTable, xTable+2*n, brush, black,
header<<OFheader.cyclic)
putBlock(xTable)
]
ifnot [
giveUp("[readSpline.4]")
for i=1 to (fp ? 4*n, 2*n) do Gets(file)
]
]
putBlock(hTable)
]
// then read text
T= Endofs(file) ? 0, Gets(file)
if T then [
newIdTable=obtainBlock(T)
unless newIdTable then [
giveUp("[readPicture.5]")
Closes(file)
return
]
ReadBlock(file, newIdTable, T)
for t=0 to T-1 do [
let tTable=vec (maxChar+4)
ReadBlock(file, tTable, newIdTable!t+4)
newIdTable!t= makeText(tTable+4, tTable!0,
tTable!1, tTable!2, black, false)
]
]
]
Closes(file)
// now, display text!
if T ne 0 then for f=0 to maxFont-1 do [
for t=0 to T-1 do [
let textPointer=textTable!(newIdTable!t)
unless textPointer loop
unless textPointer>>TEXT.font eq f loop
if convertText then adjustText(textPointer)
writeText(textPointer)
]
]
putBlock(newIdTable)
typeForm(0, "Done!*N")
]readPicture
and writePicture(file; numargs n) be [writePicture
let M=splineTable!0
let T=textTable!0
unless M % T return
unless n then
file=openWrite("*NWrite picture on file: ", wordItem)
unless file return
Puts(file, -1)
Puts(file, -1)
// splines
Puts(file, M)
if M then for id=1 to maxSplineID do [
let splinePointer=splineTable!id
unless splinePointer loop
let header1=0
header1<<NFheader1.brush=splinePointer>>SPLINE.brush
header1<<NFheader1.color=splinePointer>>SPLINE.color
Puts(file, header1)
let header2=splinePointer>>SPLINE.nKnots
header2<<NFheader2.cyclic=splinePointer>>SPLINE.cyclic
Puts(file, header2)
WriteBlock(file, splinePointer+SPLINEknotBase,
4*splinePointer>>SPLINE.nKnots)
]
// text
Puts(file, T)
if T then for f=0 to maxFont-1 do [
for t=1 to maxTextID do [
let textPointer=textTable!t
unless textPointer loop
if textPointer>>TEXT.font ne f loop
Puts(file, textPointer>>TEXT.left)
Puts(file, textPointer>>TEXT.top)
Puts(file, textPointer>>TEXT.font)
Puts(file, textPointer>>TEXT.color)
let s=((textPointer+TEXTblockSize)>>STRING.length)/2 + 1
Puts(file, s)
WriteBlock(file, textPointer+TEXTblockSize, s)
]
]
Closes(file)
typeForm(0, "Done!*N")
]writePicture
//****************************************************************
// Text centering mode
//****************************************************************
and changeTextMode() be [changeTextMode
typeForm(0, "Text positioning mode [Center, Top, Left, Bottom, Right]: ")
posTextMode=0
until posTextMode do posTextMode=selecton capitalize(Gets(keys)) into [
case $B: posTextBottom;
case $C: posTextCenter;
case $L: posTextLeft;
case $R: posTextRight;
case $T: posTextTop;
default: 0
]
typeForm(0, selecton posTextMode into [
case posTextCenter: "Center*N";
case posTextTop: "Top*N";
case posTextBottom: "Bottom*N";
case posTextLeft: "Left*N";
case posTextRight: "Right*N"
])
]changeTextMode
//****************************************************************
// HELP!
//****************************************************************
and readHelp() be [readHelp
unless help return
let fileName=vec 8
let nextFileName=vec 8
manualPage(help, fileName)
help=help+1
manualPage(help, nextFileName)
let systemDir=OpenFileFromFp(fpSysDir, ksTypeReadOnly)
if FindFdEntry(systemDir, nextFileName) eq -1 then help=1
Closes(systemDir)
let file=OpenFile(fileName, ksTypeReadOnly)
test file
ifso [
readPicture(file)
typeForm(0, "*N*N*NTo obtain next manual page (",
10, help, 0, ") type line-feed (<LF>)*N",
0, "To disable on-line manual, type <ctrl>? again.*N")
]
ifnot typeForm(0, "On-line manual is not there! Disable help mode with <ctrl>?*N")
]readHelp
and manualPage(n, fileName) be [manualPage
let moreThan10= n ge 10
MoveBlock(fileName, (moreThan10 ? "MANUAL10.DRAW", "MANUAL0.DRAW"), 8)
fileName>>STRING.char↑(moreThan10 ? 8, 7)=$0+(moreThan10 ? (n-10), n)
]manualPage
//****************************************************************
// Font
//****************************************************************
and readFont() = valof [readFont
typeForm(0, "Load font ")
for f=0 to maxFont-1 do if f ne dspFont then
typeForm(8, f, 0, ((f eq maxFont-1) ? " ? ", ", "))
let f=nil
[ f=Gets(keys)-$0
if (f ne dspFont) & (f ge 0) & (f le 3) break
if (f ls 0) % (f gr 9) resultis abortMessage()
] repeat
typeForm(10, f)
if not readFontFile(f) & (f eq font) then font=dspFont
for id=1 to maxTextID do [
let textPointer=textTable!id
unless textPointer loop
if textPointer>>TEXT.font eq f then [
eraseText(id)
showText(id)
]
]
typeForm(0, "Done!*N")
]readFont
and readFontFile(f) = valof [readFontFile
let numberCodeTable= table [
#400+$0; #400+$1; #400+$2; #400+$3 ]
fontFile>>FONTFILE.current=-1
fontFile>>FONTFILE.length↑f=0
let fontName=0
let fontFileFp=vec lFP
let file=openRead("*NRead font file: ", wordItem, lv fontName, fontFileFp)
if file ne 0 then [
let fontLength=FileLength(file)/2+1
Resets(file)
let ALheader=vec 2
ReadBlock(file, ALheader, 2)
Closes(file)
fontFile>>FONTFILE.height↑f=ALheader>>AL.height
fontFile>>FONTFILE.baseline↑f=ALheader>>AL.baseline
fontFile>>FONTFILE.length↑f=fontLength
MoveBlock(lv(fontFile>>FONTFILE.fp↑f), fontFileFp, lFP)
]
// get new buffer, as appropriate
let maxLength=0
let oldLength=fontFile>>FONTFILE.bufferLength
for i=0 to maxFont-1 do
if maxLength ls fontFile>>FONTFILE.length↑i then
maxLength=fontFile>>FONTFILE.length↑i
if maxLength ne oldLength then [
putBlock(fontFile>>FONTFILE.buffer)
let newBuffer=0
if maxLength ne 0 then [
newBuffer=obtainBlock(maxLength)
if newBuffer eq 0 then [
// forget it, keep old buffer
giveUp("[readFont]")
fontFile>>FONTFILE.length↑f=0
newBuffer=obtainBlock(oldLength)
maxLength=oldLength
]
]
fontFile>>FONTFILE.buffer=newBuffer
fontFile>>FONTFILE.bufferLength=maxLength
]
let r= file eq 0 ? 0, MakeFontEntry(fontName, fontDefTable!f, f)
putBlock(fontName)
resultis r
]readFontFile