// PreObjects.bcpl
// last modified by Butterfield, October 22, 1980 4:08 PM
// - ShowObject, turn off rectangle checking temporarily - 10/22
// - ShowObject, if a rectangle, use extended rectangle if necessary - 10/15
// - ShowRectangle, have 15 extended rectangles - 10/15
// - ShowObject, let sdirmin eq sdirmax & rdirmin eq rdirmax - 9/10/80
// errors 1000
//
//ShowRectangle(w,h)
// Called to put a rectangle description in the band list.
//ShowObject(n)
// Called with word count of object stuff in DL to put in
// band list.
// %%%% Note: variant needed to deal with characters that
// were so big that spline encodings were left %%%%
//
get "PressInternals.df"
get "PressParams.df"
get "PressFile.df"
get "Scv.dfs"
// outgoing procedures
external
[
ShowRectangle
ShowObject
]
// outgoing statics
//external
// [
// ]
//static
// [
// ]
// incoming procedures
external
[
//BAND
BandWrite
BandSync
//PRESCAN
CoordsConvert
CoordsConvertBox
CoordsConvertF
CoordsBound
//PARTS
CheckAvailinPart
SkipinPart
//WINDOWS
WindowRead
WindowReadBlock
//PRESS
PressError
PressErrorV
FSGet; FSGetX; FSPut
//PRESSML
DoubleCop
DoubleAdd
TGr
Ugt
//OS
MoveBlock; SetBlock; Zero
//FLOAT
FLD; FST; FTR; FLDI; FNEG; FAD; FSB; FML; FDV;
FCM; FSN; FLDV; FSTV; FLDDP; FSTDP
]
// incoming statics
external
[
Entity //Entity we are working on
DL
PreScratchW //Window on scratch file
BandFree
Report
printerDevice //for bits structure: ORbit only handles 12 bits of x
]
// internal statics
static
[
//fontpass has these guys already defined
nomoco //True if no more core available
sdirmin //Current min and max values
sdirmax
rdirmin
rdirmax
lasts //State for putsegment
firstpiece //True if new MoveTo
firstpieceflag //State for putsegment
firstpiecep // "
todolist //list of all things to scan convert
KlugeCycleColors
]
// File-wide structure and manifest declarations.
// Procedures
let ShowRectangle(w,h) be
[
compileif ReportSw then [ Report>>REP.nObjects=Report>>REP.nObjects+1 ]
let s,st,b,bt=nil,nil,nil,nil
unless CoordsConvertBox(w,h,lv s,lv st,lv b,lv bt) then
[ PressErrorV(1004); return ]
if b ge 4096 then //not printable in ORbit worldd
[ if b ge 8192 then //too big to handle
[ PressErrorV(1006);return]
if printerDevice le printerDurango then //ORbit, blown
[ PressErrorV(1007);return]
]
BandFree>>BERectangle.Type = (((b & #170000) eq 0)? BERectangleH,
BEExtendedRectangleH - 1 + b rshift 12);
BandFree>>BERectangle.Sr=s
BandFree>>BERectangle.Bit=b
BandFree>>BERectangle.nHeight=-(bt-b+1)
BandFree>>BERectangle.widthM1=st-s
BandWrite(s, size BERectangle/16)
]
and ShowObject(n,xoff,yoff;numargs na) = valof //returns true is simple object (rectangle)
[ let InFile=nil
test na eq 1 then [ InFile=DL;xoff=Entity>>EH.Xe;yoff=Entity>>EH.Ye]
or [ InFile=PreScratchW]
if InFile>>W.WhichByte then PressError(1005) //Not word-aligned
if KlugeCycleColors then
[
BandSync((KlugeCycleColors rem 256)) //Something non-white
KlugeCycleColors=KlugeCycleColors+153
]
compileif ReportSw then [ Report>>REP.nObjects=Report>>REP.nObjects+1 ]
if InFile eq DL then CheckAvailinPart(DL,1,n) //Make sure n words avail.
//******* From SCVBeginObject
todolist=0
firstpiece=true //Flag for MoveTo
firstpiecep=FSGetX(4*(orac-esd+1))
nomoco=(firstpiecep eq 0) //True if no more fs
rdirmin=plusinfinity; sdirmin=plusinfinity
rdirmax=minusinfinity; sdirmax=minusinfinity
//******* end from SCVBeginObject
let v=vec 20
FLDI(3,xoff)
FLDI(4,yoff)
while n gr 0 do
[
let a=WindowRead(InFile)
n=n-1
switchon a into
[
case DMoveTo:
[
unless firstpiece then ObjFlushit()
WindowReadBlock(InFile,v,2) //Get coords
n=n-2
FLDI(1,v!0); FLDI(2,v!1)
FAD(1,3); FAD(2,4) //Add Xe,Ye
CoordsConvertF(1,2,osac,orac,true)
FLD(fsac,osac)
FLD(frac,orac)
]
endcase
case DDrawTo:
[
WindowReadBlock(InFile,v,2)
n=n-2
FLDI(1,v!0); FLDI(2,v!1)
FAD(1,3); FAD(2,4) //Add Xe,Ye
CoordsConvertF(1,2,csac,crac,true)
putsegment(1)
FLD(osac,csac)
FLD(orac,crac)
]
endcase
case DDrawCurve:
[
WindowReadBlock(InFile,v,12)
n=n-12
FLD(esd,osac)
FLD(erd,orac) //Get 0Th derivative
for i=0 to 5 by 2 do
[
CoordsConvertF(v+i*2,v+2+i*2,esc+i,esc+i+1,false)
]
ObjDrawCurve() //Do it.
]
endcase
default:
[
PressError(1000)
if InFile eq DL then SkipinPart(DL,1,n) //Skip remaining words
n=0
]
]
]
if n ne 0 then PressError(1001)
//**** From SCVEndObject
if nomoco then
[
PressError(1002)
resultis true //nothing done, so still simple
]
ObjFlushit() //Flush object
FSPut(firstpiecep)
//**** End from SCVEndObject
//If no object results, min>max. CoordsBound might do the right thing
// if it were modified to use "true greater than", but it would probably
// expand several dimensions of the bounding box in the process, which
// is simply wasteful. However, because SCV itself uses Bcpl gr tests,
// we may have a non-zero todolist and still have an illegal object.
let GoodObj=(todolist ne 0)&
(TGr(sdirmax+1,sdirmin))&(TGr(rdirmax+1,rdirmin))
if GoodObj then GoodObj=CoordsBound(sdirmin,sdirmax,rdirmin,rdirmax)
let s=sdirmin
//first, check for a rectangle
if 0 & GoodObj&(@todolist ne 0)&(@@todolist eq 0)& // turned off
(todolist>>HD.type eq LINEtype)&
((@todolist)>>HD.type eq LINEtype)&
(todolist>>HD.smin eq (@todolist)>>HD.smin)&
(todolist>>HD.smax eq (@todolist)>>HD.smax)&
((lv todolist>>LINE.dx)!0 eq 0)&
((lv todolist>>LINE.dx)!1 eq 0)&
((lv (@todolist)>>LINE.dx)!0 eq 0)&
((lv (@todolist)>>LINE.dx)!1 eq 0) then //RECTANGLE!!!
[ let b1=lv todolist>>LINE.x
let b2=lv (@todolist)>>LINE.x
test b1!1 ls 0 then b1=b1!0+1 or b1=b1!0 //round up if fraction>1/2
test b2!1 ls 0 then b2=b2!0+1 or b2=b2!0
if Ugt(b1, b2) then [ let t = b1; b1 = b2; b2 = t; ]
BandFree>>BERectangle.Type = (((b1 & #170000) eq 0)? BERectangleH,
BEExtendedRectangleH - 1 + b1 rshift 12);
BandFree>>BERectangle.Type=BERectangleH
BandFree>>BERectangle.Sr=todolist>>HD.smin
BandFree>>BERectangle.Bit=b1
BandFree>>BERectangle.nHeight=-(b2-b1+1)
BandFree>>BERectangle.widthM1=todolist>>HD.smax-todolist>>HD.smin
BandWrite(s, size BERectangle/16)
while todolist do
[ let p=todolist
todolist=p>>HD.next
FSPut(p)
]
resultis true //still a simple page
]
//Now loop through all entries in todolist, putting out band stuff.
while todolist do
[
let p=todolist
todolist=p>>HD.next
BandFree>>SH.Sbegin=p>>HD.smin
BandFree>>SH.Send=p>>HD.smax
test p>>HD.type eq LINEtype then
[
BandFree>>BELine.H=BELineH //A line
DoubleCop(lv BandFree>>BELine.Bit,lv p>>LINE.x)
DoubleCop(lv BandFree>>BELine.dBit,lv p>>LINE.dx)
if GoodObj then BandWrite(s,size BELine/16)
] or
[
BandFree>>BESpline.H=BESplineH //A spline
MoveBlock(lv BandFree>>BESpline.Stuff,lv p>>RSPLINE.str,16)
if GoodObj then BandWrite(s,size BESpline/16)
]
FSPut(p)
]
BandFree>>BEEndObject.H=BEEndObjectH //And a terminator
test GoodObj then BandWrite(s,size BEEndObject/16)
or PressErrorV(1003)
resultis not GoodObj
]
and ObjDrawCurve() be
[
//Now bust the spline into sections
// that are monotonic in the scan direction.
//ROOT records the value of t in FPAC t1 as a spot on
// the curve that is an internal extremum in scan direction.
// it sorts this value into a table of floating point
// numbers, pointed to by PTR. PTR!0 is the number of roots
// so far (initially 2, t=0 and t=1).
// (If ptr=0, we are calculating r extrema)
let root(ptr) be [
if FSN(t1) eq 1 & FCM(t1,table [ #40300;0]) eq -1 then
test ptr ne 0 then
[ //Root lies between 0 and 1
let i=(@ptr)*2-1; let j=i
while FCM(t1,ptr+i) eq -1 do i=i-2
for k=j+1 to i+2 by -1 do ptr!(k+2)=ptr!k
FST(t1,ptr+i+2)
@ptr=@ptr+1
]
or
[
feval(1,t1,t2) //get r value
let r=Floor(t2) //truncate
if r ls rdirmin then rdirmin=r
if r gr rdirmax then rdirmax=r
]
]
and
findextrema(ptr,d) be [
let esbd=esb+d
test FSN(esa+d) ne 0 then
[ //A ne 0
FLDI(t2,-3); FML(t2,esa+d) //-3A
FLD(t1,esbd); FML(t1,esbd)
FLD(t3,t2); FML(t3,esc+d); FAD(t1,t3) //B↑2-3AC
let b=FSN(t1) //Sign of discriminant
if b ne -1 then [ //Possible root
test b eq 0 then
[ FLD(t1,esbd); FDV(t1,t2) ] //-B/3A
or [ //Take square root
let a=vec 3; FSTV(t1,a);a!1=a!1/2;FLDV(t3,a)
for i=0 to 2 do
[
FLD(t4,t1);FDV(t4,t3);FAD(t3,t4)
FLDI(t4,2);FDV(t3,t4)
]
FDV(t3,t2) //SQRT(b↑2-3ac)/-3a
FLD(t4,esbd);FDV(t4,t2) //B/-3A
FLD(t1,t4);FSB(t1,t3) //+root
root(ptr)
FLD(t1,t4);FAD(t1,t3) //-root
]
root(ptr) //Other root
] //Possible root
]
or
[ //A=0
if FSN(esbd) ne 0 then
[
FLD(t1,esc+d);FDV(t1,esbd);FNEG(t1)
FLDI(t2,2);FDV(t1,t2) //-C/2B
root(ptr)
]
]
]
//If we need bounding box, record extreme values of s and r
// at any interior extrema. Putsegment will take care of endpoint
// extrema.
//***** Edits near here *****
findextrema(0,1)
let ptr=vec 9; Zero(ptr,9); ptr!0=2; ptr!3=#40300
findextrema(ptr,0)
//***** End edits *****
//Now table ptr has values of t
// that cause junctions between monotonic segments.
//"Old" points already set up.
FLDI(tmaxac,0)
for i=1 to ptr!0-1 do
[
FLD(tminac,tmaxac) //New tmin is old tmax
FLD(tmaxac,ptr+i*2+1) //Get junction from table
feval(0,tmaxac,csac) //Evaluate current points
feval(1,tmaxac,crac)
putsegment(0) //Do the spline
FLD(osac,csac) //Set old points
FLD(orac,crac)
]
]
and
ObjFlushit() be [
unless firstpiece then
[
FLD(csac,fsac)
FLD(crac,frac)
putsegment(2) //Join up.
putsegment(-1) //Flush last piece.
firstpiece=true
]
]
and
//This function checks for closure and builds LINE and SPLINE
//blocks for later reference.
//Entry conditions:
//Line (lineflag=1 or 2):
// Draw a line from (osac,orac) to (csac,crac)
// Must leave csac,crac untouched because they are used
// to reset the "old" point for next time.
//Spline (lineflag=0):
// Draw a spline from (osac,orac) to (csac,crac) which
// corresponds to values of t, tminac le t le tmaxac.
// Coefficients are in esa...esd and era...erd
// Must leave csac, crac unchanged.
//Finish up call (lineflag=-1):
// There is global state in: firstpiece,
// firstpiecep and firstpieceflag..
// Firstpiece is true if this is the first segment of a closed curve.
putsegment(lineflag) be [
// external TypeForm
// let str=vec 2
// TypeForm(2,csac,32,2,crac,1,str)
if lineflag ls 0 then
[ //Restore accumulators
lineflag=firstpieceflag
let p=firstpiecep
for i=(lineflag? csac,esd) to orac do
[ FLDV(i,p); p=p+4 ]
]
let smin=Floor(osac) //Value of S at tmin
let smax=Floor(csac) //Value of S at tmax
//Update r direction extrema (must do before checking smin=smax because
// we only check "current" value of r direction, so we must check every
// leg of the closed curve).
let r=Floor(crac)
if r ls rdirmin then rdirmin=r
if r gr rdirmax then rdirmax=r
if smin eq smax then return //No intersections.
if firstpiece then
[
firstpiece=false
firstpieceflag=lineflag
let p=firstpiecep
for i=(lineflag? csac,esd) to orac do
[ FSTV(i,p); p=p+4 ]
lasts=smax //This is what we need to know.
return
]
let stop,sbot=nil,nil
//Thisdirection is 1 if increasing t gives decreasing s
let thisdirection=(smin gr smax)?1,-1
test thisdirection eq 1 then
[ stop=lasts; sbot=smax+1 ]
or
[ stop=smax; sbot=lasts+1 ]
//Update s direction extrema
if sbot ls sdirmin then sdirmin=sbot
if stop gr sdirmax then sdirmax=stop
//Save scan-line intersection state for next time.
lasts=smax
//Get free storage block to hold this line or spline
if nomoco then return //None available, return
//***** Edits near here to remove cond assy, FSGet *****
let nx=FSGet((lineflag? size LINE/16,size RSPLINE/16))
if nx eq 0 then
[ //Out of free storage
nomoco=true //Say so.
let p=todolist //
while p do //Release core
[
let np=p>>HD.next
FSPut(p)
p=np
]
return
]
//***** End of edits *****
//Build description of line or spline segment
test lineflag then
[ //LINE
nx>>LINE.type=LINEtype
FLD(t1,crac);FSB(t1,orac) //Delta r
FLD(t2,csac);FSB(t2,osac) //Delta s
FDV(t1,t2);FSTDP(t1,lv nx>>LINE.dx) //Increment each scan line
FLDI(t2,sbot);FSB(t2,osac)
FML(t1,t2);FAD(t1,orac) //Bottom point.
FSTDP(t1,lv nx>>LINE.x) //and save it.
] //LINE
or
[ //SPLINE
nx>>RSPLINE.type=SPLINEtype
test thisdirection ls 0 then
[
FLD(t1,tminac) //t1 is at low s end
FLD(t2,tmaxac)
]
or
[
FLD(t1,tmaxac)
FLD(t2,tminac)
]
// CEVAL computes and fills in F(tac) values and G(tac) values.
// Indx=0 for s direction, 1 for r.
let ceval(indx,tac,ptr) be [
feval(indx,tac,t4) //Get value of function.
FSTDP(t4,ptr) //Put down value.
FLDI(t4,3);FML(t4,esa+indx);FML(t4,tac) //3At
FAD(t4,esb+indx) //3At+B
FML(t4,t3) //(dt↑2)(3At+B)
FSTDP(t4,ptr+2) //Put it down.
]
FLD(t3,t2);FSB(t3,t1);FML(t3,t3) //(dt↑2)
ceval(0,t1,lv nx>>RSPLINE.stl)
ceval(1,t1,lv nx>>RSPLINE.rtl)
ceval(0,t2,lv nx>>RSPLINE.str)
ceval(1,t2,lv nx>>RSPLINE.rtr)
] //SPLINE
//Record some common information in the block.
nx>>HD.smin=sbot
nx>>HD.smax=stop
nx>>HD.next=todolist; todolist=nx
]
and
feval(indx,tac,rac) be [
//Evaluate the spline (indx=0, s direction; 1 r direction)
// tac=AC with value of t; rac=AC for result
FLD(rac,esa+indx)
FML(rac,tac)
FAD(rac,esb+indx)
FML(rac,tac)
FAD(rac,esc+indx)
FML(rac,tac)
FAD(rac,esd+indx)
]
and
Floor(ac) = valof [ //Standard floor function
let a=FTR(ac)
if FSN(ac) ls 0 then
[
let s1=vec 3
let s2=vec 3
FSTV(ac,s1) //Save some ac's
FSTV(31,s2)
a=-a+4 //Get number to make positive
FLDI(31,a)
FAD(ac,31) //Make it positive
a=FTR(ac)-a //Take floor and subtract offset
FLDV(31,s2)
FLDV(ac,s1)
]
resultis a
]