// ScanDots.bcpl

// last modified by Ramshaw, December 11, 1980  12:42 PM
// - synch halftone screen in B as well as in S direction

// last modified by Butterfield, October 13, 1980  3:57 PM
// - ResolutionB, ResolutionS, 1X instead of 10X - 10/13/80

//   errors 1600
//
//ScanDots(s,v,LeftOver)
// Called to process a BEDots entry (v is pointer).
// LeftOver is true if entry came from a LeftOver table.
//
//ScanDotsInit()
//ScanDotsClose()
// Called at beginning and end of scan conversion pass.
//
//

get "PressInternals.df"
get "PressParams.df"

// outgoing procedures
external
	[
	ScanDotsInit
	ScanDotsClose
	ScanDots
	InitScreen
	GCD
	]

// outgoing statics
//external
//	[
//	]
//static
//	[
//	]

// incoming procedures
external
	[
//FREESTORAGE
	FSGet

//WINDOWS
	WindowInit
	WindowClose
	WindowSetPosition
	WindowNext
	WindowReadBlock

//PRESS
	PressError;PressErrorV
	DblShift
	FSGetX
	FSPut

//PRESSML
	Ugt
	DoubleAdd; DoubleSub; DoubleCop
	MulDiv;MulMod;DoubleAddV;DivFull;MulFull

//PUTDOTS
	ScanPutDots
	ScanPutHalfTone

//OS
	MoveBlock
	SetBlock
	Zero
//FILES
	FileReadPage
	]

// incoming statics
external
	[
	ScanBuf			//Core Buffer
	ScanBitWc		//Size of scan line
	ScanBitMargin
	mpSBuf		//Map from scan-line to buffer
	ScanS			//Beginning scanline
	ScanMin
	ScanMax
	Transparent
	ResolutionS;ResolutionB	//for determining halftone screen size
	PressFile
	ScratchFile

	UseMicroCode
	currentScanColor
	ScanColorTable
	]

// internal statics
static
	[
	ScanDotsWindowTable	//Table of windows on dots files
	nDotsWindowsToAllocate	//Number of available windows
	TempSLBuf			//Buffer to make incoming dots contiguous
	]

// File-wide structure and manifest declarations.

// Procedures

let ScanDotsInit() be
 [
   let a=FSGetX(nDotsRegionsB)
   ScanDotsWindowTable=a
   SetBlock(a,-1,nDotsRegionsB)	//-1 => available
   nDotsWindowsToAllocate=-nDotsBuffers
   TempSLBuf=FSGetX(lTempSL)
   if UseMicroCode then 
	[ @ScanPutDots=ScanPutDotsTrap
	  @ScanPutHalfTone=ScanPutDotsTrap
	]
 ]

and ScanDotsClose() be
 [
   FSPut(ScanDotsWindowTable)
 ]

and ScanDots(v,LeftOver) = valof
 [ if (currentScanColor eq 255)&
	((v>>BEDots.Code ne 0)%	//never print halftones if color setting is white
	 Transparent) //print white bitmaps unless Transparent
	then resultis 0	//do nothing
   let S=0
   let SLWC=v>>BEDots.BitFileSLWC
   let ScreenAngle=v>>BEDots.ScreenAngle
   let ScreenLPI=v>>BEDots.ScreenModulus	//Lines per inch
   let ScreenMagnitude=v>>BEDots.ScreenAmplitude

//Do first-time processing, including allocating a slot for window entry
   unless LeftOver then
     [				//First time!
      v>>BEDots.Scount=DotsDeltaConst		//Initial phase
      S=(v>>BEDots.Sstart)&(BANDWidth-1)

      let avail=-1
      for i=0 to nDotsRegionsB-1 do
	if ScanDotsWindowTable!i eq -1 then
	   [
	   avail=i
	   break
	   ]
      if avail eq -1 then [ PressError(1600); resultis 0 ]	//No more!
      ScanDotsWindowTable!avail=0	//No present window
      v>>BEDots.WindowNumber=avail

      if v>>BEDots.Code ne 0 then	//grab error distribution buffer, etc.
       [ test v>>BEDots.ScreenStart then	//user specified dot
	   [ let scratch=vec 1024
  	     FileReadPage(ScratchFile,v>>BEDots.ScreenStart,scratch)
	     let nCells=scratch!0
	     let nLines=scratch!1
	     let nShifts=scratch!2
	     let sDef=FSGet(3+nCells+nCells/nLines)
	     if sDef eq 0 then [ PressError(1620);resultis 0]
	     MoveBlock(sDef,scratch,3+nCells)
	     //store in BEDots vector
	     v>>BEDots.ScreenStart=sDef
	     v>>BEDots.ScreenAddress=sDef+3+nCells
	     v>>BEDots.ScreenModulus=nCells/nLines
	     //and rescale for funny press values	    
	     let scale=v>>BEDots.IMax-v>>BEDots.IMin
	     let half=scale*2
	     for i=3 to nCells+3 do sDef!i=((scale-sDef!i)*4)-half
	   ]
	  or //custom made while you wait
	   if ScreenLPI ne 0 then
		unless InitScreen(v) do [ PressError(1620);resultis 0]
	 //let errorbuffsize=(-v>>BEDots.Bdim)+1
	 //let errorptr=FSGet(errorbuffsize)
	 //if errorptr eq 0 then	//not enough room
	 // [ PressError(1620);resultis 0]
	 //v>>BEDots.ErrorBuffer=errorptr
	 //let thresh=v>>BEDots.IMax-v>>BEDots.IMin
	 //SetBlock(errorptr,thresh,errorbuffsize)
       ]

      if SLWC gr lTempSL then [ PressError(1621); resultis 0 ]
     ]

//Find the window for this dots region
   let wi=v>>BEDots.WindowNumber
   let w=ScanDotsWindowTable!wi
   unless w then
     [
      test nDotsWindowsToAllocate eq 0 then
	[			//Must kick one out.
	for i=0 to nDotsRegionsB-1 do
	   [
	   let s=ScanDotsWindowTable!i
	   if s ne -1 & s ne 0 then
		[
		WindowClose(s)
		ScanDotsWindowTable!i=0	//Kicked out
		break
		]
	   ]
	] or nDotsWindowsToAllocate=nDotsWindowsToAllocate+1
      let f=v>>BEDots.File
      if (f le FILEPress)&(f ge 0) then f=((f eq FILEPress)? PressFile,ScratchFile)
//Get two pages of buffering here because a typical scan-line will cross
// a page boundary.  Because we are almost always blowing the picture
// up, we will backtrack a lot.  Extra buffer will prevent another disk
// reference.  Note that someday this might be a good place to put
// PageAhead and PageBack strategies, depending on the direction we
// are going in the file!
      w=WindowInit(f,2)
      ScanDotsWindowTable!wi=w
     ]

   let Sdim=v>>BEDots.Sdim		//- # scan lines to go
   let Smagnify=v>>BEDots.Smagnify
   let Scount=v>>BEDots.Scount
   let PutDots=nil
   test v>>BEDots.Code eq 0 
	ifso PutDots=(currentScanColor eq 0)?ScanPutDots,ScanPutShadedDots
	ifnot PutDots=ScanPutHalfTone
   let bufferPosChanged=true
[
   [
   if S eq BANDWidth then
	[				//More to go.
	v>>BEDots.Sdim=Sdim
	v>>BEDots.Scount=Scount
	resultis size BEDots/16		//Leave leftover for next time
	]

   if bufferPosChanged then
	[						//May need to update buffer info
	let wp=vec 1
	DoubleCop(wp,lv v>>BEDots.BitFilePos)	//Current position
	v>>BEDots.BitPhase=(wp!1)&(#17)		//Position in word
	DblShift(wp,4)				//Word position

	WindowSetPosition(w,wp)		//Reset input line
	test -w>>W.Offset ge SLWC
	   ifso v>>BEDots.BitBuf=w>>W.Base+w>>W.Offset
	   ifnot
		[
		WindowReadBlock(w, TempSLBuf, SLWC)
		v>>BEDots.BitBuf=TempSLBuf
		]
	bufferPosChanged=false
	]

//if halftone, set up screen
   let mod=v>>BEDots.ScreenModulus
   unless mod eq 0 do
    [ let sDef=v>>BEDots.ScreenStart
	 let A=sDef!0
	 let p=sDef!1
	 let D=sDef!2
	 let Base=sDef+3+mod*((ScanS+S) rem p)
	 let firstElement=(MulMod((ScanS+S)/p,D,mod)+(v>>BEDots.Bstart)) rem mod
	 let thisScreen=v>>BEDots.ScreenAddress
	 MoveBlock(thisScreen,Base+firstElement,mod-firstElement)
	 MoveBlock(thisScreen+mod-firstElement,Base,firstElement)
    ]

//if opaque, zero appropriate output bit range
   let Bdim=-(v>>BEDots.Bdim)   // # bits to output
   let Bstart=v>>BEDots.Bstart
   if v>>BEDots.Bincr ls 0 then Bstart=Bstart-Bdim+1 //"start" at bottom
   let Bend=Bstart+Bdim-1

   if v>>BEDots.Opaque then
    [ 	let BaseAddr=mpSBuf!S
	let r1word=Bstart rshift 4
	let r2word=Bend rshift 4
	let r1mask=-1 lshift (#20-(Bstart&#17))
	let r2mask=-1 rshift ((Bend&#17)+1)
  	BaseAddr!r1word=BaseAddr!r1word&r1mask
	if r2word ne r1word then Zero(BaseAddr+r1word+1,(r2word-r1word)-1)
	BaseAddr!r2word=BaseAddr!r2word&r2mask 
    ]
   if Bstart ls ScanMin then ScanMin=Bstart
   if Bstart gr ScanMax then ScanMax=Bstart
   if Bend ls ScanMin then ScanMin=Bend
   if Bend gr ScanMax then ScanMax=Bend


//Now do all the work:
   PutDots(S,v)				//Go do a scan line

   Sdim=Sdim+1
   if Sdim eq 0 then
	[				//End of bits region
	WindowClose(w)			//Delete the window.
	nDotsWindowsToAllocate=nDotsWindowsToAllocate-1
	ScanDotsWindowTable!wi=-1		//Available
	//if v>>BEDots.Code ne 0 then FSPut(v>>BEDots.ErrorBuffer)
	if v>>BEDots.ScreenModulus ne 0 then FSPut(v>>BEDots.ScreenStart)
	resultis 0			//No leftovers
	]
   S=S+1

   unless Smagnify then break		//If reducing, only display once.
   Scount=Scount-v>>BEDots.Sdelta
   if Scount ls 0 then
	[
	Scount=Scount+DotsDeltaConst
	break
	]
   ] repeat

   [
   DoubleAdd(lv v>>BEDots.BitFilePos,lv v>>BEDots.BitFileInc) //Get a bit
   bufferPosChanged=true
   if Smagnify then break
   Scount=Scount-v>>BEDots.Sdelta
   if Scount ls 0 then
	[
	Scount=Scount+DotsDeltaConst
	break
	]
   ] repeat

] repeat					//Many,many scan lines!

 ]

and ScanPutShadedDots(S,v) be
 [ let thisS=ScanS+S
   let savedSBuf=mpSBuf!S
   let tempSBuf=FSGet(ScanBitWc+1)	//+1 because we're off by one somewhere
						// in computing scan length
   if tempSBuf eq 0 then [ ScanPutDots(S,v);return]
   Zero(tempSBuf,ScanBitWc+1)
   tempSBuf=tempSBuf-ScanBitMargin/16
   mpSBuf!S=tempSBuf
   ScanPutDots(S,v)
   mpSBuf!S=savedSBuf
   //and now, update color
   let cycleLen=ScanColorTable!0
   let cyclePerBlock=ScanColorTable!1
   let linesPerBlock=ScanColorTable!2
   let blockNum=thisS/linesPerBlock
   let lineNum=thisS rem linesPerBlock
   let colorLine=ScanColorTable+3+lineNum*cycleLen
   let lineIndex=(blockNum*cyclePerBlock+(ScanMin rshift 4)) rem cycleLen
   test Transparent then
      for i=ScanMin rshift 4 to ScanMax rshift 4 do
        [  savedSBuf!i=savedSBuf!i%(tempSBuf!i&(colorLine!lineIndex))
	   lineIndex=lineIndex+1
	   if lineIndex eq cycleLen then lineIndex=0
        ]
   or //solid
      for i=ScanMin rshift 4 to ScanMax rshift 4 do
        [  let bitsWord=tempSBuf!i
	   savedSBuf!i=
		(savedSBuf!i&(not bitsWord))%(bitsWord&(colorLine!lineIndex))
	   lineIndex=lineIndex+1
	   if lineIndex eq cycleLen then lineIndex=0
        ]

   FSPut(tempSBuf+ScanBitMargin/16)
 ]

//InitScreen(ptr)
// initialize halftone screen (returns false if no room left)
// v is a pointer to a BEDots entry, containing
//	LinesPerInch in ScreenModulus
//	Angle in ScreenAngle
// the screen rotation algorithm was inspired by Thomas M. Holladay's
//	internal report "Creation of Variable Angles of Dot Screens for
//	Application in Serial Halftoning Techniques."

and InitScreen(v) = valof
 [ //first, initialize some tables for calculating xrot,yrot from LPI,ang

   //here is Sqrt(1+theta**2) for theta=0 to 89
   //entries are multiplies by 1000
   //xrot=Resolution/(Sqrt(1+theta**2)*LinesPerInch)
   let Sqrt1PlusThetaSq=table
	[ 1000;1000;1001;1001;1002
	  1004;1006;1007;1010;1012
	  1015;1019;1022;1026;1031
	  1035;1040;1046;1051;1058
	  1064;1071;1079;1086;1095
	  1103;1113;1122;1133;1143
	  1155;1167;1179;1192;1206
	  1221;1236;1252;1269;1287
	  1305;1325;1346;1367;1390
	  1414 
	]
   //now, we set up a table of tangents
   //again, entries are multiplied by 1000
   //yrot=xrot*Tan(theta)
   let Tan=table
	[ 0000;0017;0035;0052;0070
	  0088;0105;0123;0141;0158
 	  0176;0194;0213;0231;0249
 	  0268;0287;0306;0325;0344
 	  0364;0384;0404;0424;0445
	  0466;0488;0510;0532;0554
	  0577;0601;0625;0650;0675
	  0700;0727;0754;0781;0810
	  0839;0869;0900;0933;0966
	  1000
	]

   let LPI=v>>BEDots.ScreenModulus
   let theta=v>>BEDots.ScreenAngle;if theta gr 45 then theta=90-theta
   if ResolutionS ne ResolutionB then PressErrorV(1624,ResolutionS)
   let t1 = MulDiv(ResolutionS, 100, LPI);
   let xrot=MulDiv(t1,10,Sqrt1PlusThetaSq!theta)
   let yrot=MulDiv(xrot,Tan!theta,1000)
   if v>>BEDots.ScreenAngle gr 45 then //swap xrot, yrot
	[ let t=xrot;xrot=yrot;yrot=t]

   let xyMat=MakeXYMatrix(xrot,yrot)	//0's on unused spots,
							//good stuff elsewhere
   if xyMat eq 0 then resultis false	//no room

   //now, do the magic transformation
   let A=xrot*xrot+yrot*yrot	//Area of halftone dot
   let p=GCD(xrot,yrot)	//p is # of repeating strings
					//each string is of length A/p
					//since p|x and p|y, clearly p|(x**2+y**2)
   //to calculate D, the horizontal shift, we have two modular equations:
   // (x/p)*D=(mod L) -y	!!BUG: was y
   // (y/p)*D=(mod L) x	!!BUG: was -x
   //the fastest way to solve for is 
   //  1) find k (0 le k ls (x/p)) such that (y+kL) rem (x/p) eq 0
   //		(that is, D=(y+kL)/(x/p) is a solution to the first equation)
   //  2) test that choice of D in the second equation: if it works,
   //		we're done
   //note that this takes at most x/p trials (and typically x/p ls 20)
   // even though there are L <=(x**2+y**2)/p> possible values for D
   let D=valof	
	[ if yrot eq 0 then resultis 0	//without this test, we need to have
							//xrot rem L in the eq statement
	  let L=A/p
	  let xp=xrot/p
	  let yp=yrot/p
	  for k=0 to yp-1 do
		if ((xrot+MulMod(k,L,yp)) rem yp) eq 0 then	//part 1 OK
		   [ let dv=vec 1
		     MulFull(k,L,dv)
		     DoubleAddV(dv,xrot)
		     let d=DivFull(dv,yp)
		     if MulMod(xp,d,L) eq (L-yrot) then resultis d
		   ]
	  PressError(1622)	//never happens
	]

   //the format for a screen definition is:
   //  Header (3 wds) A,p,D
   //  string of A elements (permanent)
   //  A/p blanks in which to store appropriate screen for each line
   //note ScreenModulus=A/p
   let sDef=FSGet(3+A+A/p)
   if sDef eq 0 then resultis false	//no room
   sDef!0=A
   sDef!1=p
   sDef!2=D

   //re-form xyMat into the linear repeating sequence
   let i=3	//index into sDef
   let side=xrot+yrot	//size of xyMat

   let initOff=valof
	[ for k=0 to side-1 do if xyMat!k gr 0 then resultis k
	  resultis 0
	]

   for z=0 to p-1 do	//there are p repeating strings
    [ let j=z
	 let off=initOff
	 [ //tack on elements from rvec line j
	   let xyPtr=xyMat+j*side
	   for k=off to side-1 do
		if xyPtr!k gr 0 then
		 [ sDef!i=xyPtr!k;i=i+1]
	   j=(j+yrot) rem side
	   off=0
	 ] repeatuntil j eq z
	 let xyPtr=xyMat+j*side
	 for k=0 to initOff-1 do
		if xyPtr!k gr 0 then [ sDef!i=xyPtr!k;i=i+1] 
    ]
unless i eq (A+3) do PressError(1623)	//never happens

   //update sequence so:
   //  1) sum=0
   //  2) scaled for IMin,IMax
   let even=(A&1) eq 0
   let scale=(A+1)/2
   let black=v>>BEDots.IMin
   let range=MulDiv(v>>BEDots.IMax-black,v>>BEDots.ScreenAmplitude,50)-1
   for i=3 to A+2 do
	[ sDef!i=sDef!i-scale
	  if even&(sDef!i le 0) then sDef!i=sDef!i-1
	  test sDef!i ge 0 then sDef!i=MulDiv(range,sDef!i,scale)+black
	   or sDef!i=-MulDiv(range,-(sDef!i),scale)+black
	]

   //store in BEDots vector
   v>>BEDots.ScreenStart=sDef
   v>>BEDots.ScreenAddress=sDef+3+A
   v>>BEDots.ScreenModulus=A/p

   //free up the temporary storage used
   FSPut(xyMat)
   resultis true
 ]

//Euclidean algorithm, Knuth vol. 2, p297
and GCD(u,v)=valof
 [ if v eq 0 then resultis u
   let r=u rem v
   u=v
   v=r
 ] repeat

and Min(a,b)=(a ls b)?a,b
and Max(a,b)=(a gr b)?a,b

and MakeXYMatrix(x,y)=valof
 [ let side=x+y
   let rvec=FSGet(side*side+1)
   if rvec eq 0 then resultis 0	//no room

   //set up middle section (all active)
   let a=(y gr x)?(y-x),(x-y)
   let z=Min(x,y)
   for j=z to z+a-1 do
	for i=z to z+a-1 do
		rvec!(j*side+i)=32000
   
   //now, set up surrounding rectangles
   let Avec=FSGet(x*y+1)
   if Avec eq 0 then [ FSPut(rvec);resultis 0]

   //first, set the rectangle elements to on or off (32000,-32000)
   for i=0 to x-1 do
    [	let area=((i*2+1)*y+x)/(x*2)	//((i*y+(i+1)*y+x))/(2*x)
	let sep=y-area
	for j=0 to sep-1 do [ Avec!(j*x+i)=-32000]		//OFF
	for j=sep to y-1 do [ Avec!(j*x+i)=32000]	//ON
    ]

   //rotate 90 degrees for side elements
   let Bvec=FSGet(x*y+1)
   if Bvec eq 0 then [ FSPut(Avec);FSPut(rvec);resultis 0]
   for i=0 to x-1 do
	for j=0 to y-1 do
		[ let roti=(y-1)-j
		  let rotj=i
		  Bvec!(roti+rotj*y)=Avec!(i+j*x)
		]

   //schlong the appropriate rectangles in their places in rvec
   Store(Avec,rvec,x,y,true)		//store it starting at (0,0) 
   Store(Avec,rvec+x*side+y,x,y,false)	//start at (y,x)
   Store(Bvec,rvec+x,y,x,true)		//start at (x,0)
   Store(Bvec,rvec+y*side,y,x,false)	//start at (0,y)

   FSPut(Avec)
   FSPut(Bvec)

   //OK, all "active" squares in rvec are set to 32000
   //now, set the active guys to appropriate counter values
   let off=side/2
   let ylim=(3*side)/2	//1.5 > sqrt(2)
   let counter=1
   let slim=side-1

   for yt=0 to ylim do
    [ let i=0
	 let j=yt
	 let yt1sq=(yt+1)*(yt+1)
	  [ //for the eight points (i,j),(slim-i,j),(i,slim-j),(slim-i,slim-j),
	    // (j,i),(slim-j,i),(j,slim-i),(slim-j,slim-i) do:
	    // if point eq "active" (32000) then set it to counter
	    Set(rvec,off+j,off+i,side,lv counter)
	    Set(rvec,off+i,off+j,side,lv counter)
	    Set(rvec,slim-(off+i),off+j,side,lv counter)
	    Set(rvec,slim-(off+j),off+i,side,lv counter)
	    Set(rvec,slim-(off+j),slim-(off+i),side,lv counter)
	    Set(rvec,slim-(off+i),slim-(off+j),side,lv counter)
	    Set(rvec,off+i,slim-(off+j),side,lv counter)
	    Set(rvec,off+j,slim-(off+i),side,lv counter)

	    i=i+1
	    if (i*i+j*j) ge yt1sq then [ j=j-1;i=i-1]
	  ] repeatuntil j ls i
    ]

   resultis rvec
 ]
 
and Store(inVec,destVec,xlen,ylen,pos) be
 [ let side=xlen+ylen	//size of destination vector
   for j=0 to ylen-1 do
	for i=0 to xlen-1 do
	 [ let z=inVec!(j*xlen+i)
	   unless pos do z=-z
	   if z ls 0 then z=0
	   destVec!(j*side+i)=z
	 ]
 ]

and Set(v,i,j,side,counterlv) be
 [ if (i ge side)%(j ge side)%(i ls 0)%(j ls 0) then return
   let p=v+i+j*side
   let counter=@counterlv
   if @p eq 32000 then [ @p=counter;@counterlv=counter+1]
  ]

(1270)\254f1