	program shrink
#
# fuehrt das Shrinking in einem Grauwertbild durch.
# Algorithmus nach: Zhang,T.Y. & C.Y.Suen  "A Fast Parallel Algorithm for
# Thinning Digital Patterns", CACM March 1984, Vol.27 No.3
#
# Externe Routinen, die nicht in FORLIB sind:
# Name		File,Bibliothek
# ibadr		SHRINK		berechnet Pixel-Adresse in Bank 1
# window	PLOTLIB		setzt das Plott-Fenster
# putp		PLOTLIB		setzt einen Plott-Punkt
# loadb		BANKLIB		liest ein Byte aus Bank 1
# storeb	BANKLIB		schreibt ein Byte in Bank 1
# loadw		BANKLIB		liest ein Wort aus Bank 1
#
# Entwurf und Programmierung	A.Herrmann
#
define	VERSION '1.1 vom 09.08.84'
#
define	BADR x'1000'	# Basisadresse in Bank 1
define	NEXT 999	# Sprungadresse
#
byte	g,gg		# Grauwerte
byte	p1,p2,p3,p4,	# Zentralpunkt u. 3x3-Nachbarschaft
	p5,p6,p7,p8,p9
byte	char,yes,bigyes
byte	getpix		# function; liefert Pixelwert
byte	inkey		# function; liefert Eingabezeichen
#
logical	wait		# auf Eingabe warten
#
integer	adr1,adr2	# Anfangsadressen der Bilder in Bank 1
integer	xanz,yanz,	# Bildgrenzen
	gwmax		# max.Grauwert
integer	axanz,ayanz,	# dto. Adressen in Bank 1
	agwmax
integer	iter,step	# Iterationsstufe und -schritt
integer	a,b,c		# Iterationszaehler
#
integer	i,j,k		# Laufindizes
integer	xi,yi		# Punktkoord.
integer	x1,y1,x2,y2
integer pon,pof		# Plott-Pen on/off
#
common	/bild/adr1,xanz,yanz,gwmax,gg	# Bild-Kenndaten
common	/nachb/p2,p3,p4,p5,p6,p7,p8,p9
#
data	yes,bigyes/'y','Y'/
data	xanz,yanz,gwmax/0,0,15/
data	pon,pof/1,0/
#
# Variablenadressen in Bank 1
#
axanz=BADR+8 ; ayanz=axanz+2 ; agwmax=ayanz+2
#
# Bilddaten aus Bank 1 holen
#
call loadw(xanz,axanz)
call loadw(yanz,ayanz)
call loadw(gwmax,agwmax)
#
adr1=BADR+x'100'		# Anf'adressen der beiden Bilder
adr2=adr1+xanz*yanz
#
write(1,08)
08 format(' B C  =7')	# Fenster 0 auf 0,0 bis 29,24
#
write(1,10)
10 format('1SHRINK ',VERSION,/)
gg=1
write(1,20) xanz,yanz,gwmax,gg
20 format(' Bildgrenzen ',2i4,/,' max.Grauwert',i3,/,' Schwelle bei',i3/)
write(1,22) adr1,adr2
22 format(' Anf.adr.',2i6)
#
# Plotte Original-Bild rechts unten 
#
x1=158-xanz ; y1=0 ; x2=x1+xanz+1 ; y2=y1+yanz+1
call window(x1,y1,x2,y2)
call frame
do yi=1,yanz
[	i=yanz-yi+1
	do xi=1,xanz
	[	k=ibadr(xi,yi,adr1)
		call loadb(g,k)
		if (g<<gg) call putp(xi,i,pon)
]	]
write(1,28)
28 format(' Press RETURN'/)
wait=.true. ; char=inkey(wait)
#
# ******************** Main Loop ********************
#
step=0 ; iter=0
repeat
[	step=mod(step,2)+1		# Iterations-Schritt 1,2
	c=0				# zaehlt Pixel-Aenderungen
	do yi=1,yanz
	[	do xi=1,xanz
		[	k=ibadr(xi,yi,adr1)
			call loadb(p1,k)		# Zentralpixel
			if (p1==0) goto NEXT
			if (yi==1 !! yi==yanz !! xi==1 !! xi==xanz )
				call randnb(xi,yi)	# Rand-Nachbarschaft
			else	call mittnb(xi,yi)	# Mitten-Nachb.
			b=p2+p3+p4+p5+p6+p7+p8+p9
			if (b<<2 !! b>>6) goto NEXT
			a=0				# 01-Uebergaenge
			if (p3-p2==1) a=a+1 ; if (p4-p3==1) a=a+1
			if (p5-p4==1) a=a+1 ; if (p6-p5==1) a=a+1
			if (p7-p6==1) a=a+1 ; if (p8-p7==1) a=a+1
			if (p9-p8==1) a=a+1 ; if (p2-p9==1) a=a+1
			if (a<>1) goto NEXT
			if (step==1)
			[	if (p2*p4*p6<>0 !! p4*p6*p8<>0) goto NEXT ]
			else [	if (p2*p4*p8<>0 !! p2*p6*p8<>0) goto NEXT ]
			c=c+1 ; p1=0			# Pixel loeschen
			i=yanz-yi+1 ; call putp(xi,i,pon)	# und plotten
		NEXT	k=ibadr(xi,yi,adr2)
			call storeb(p1,k)
	]	]
	if (step==1) iter=iter+1		# Iterationszaehler
	if (c>>0)
	[	j=adr2-1 ; k=j			# Bild 1 <- Bild 2
		do i=adr1,j
		[	k=k+1 ; call loadb(g,k) ; call storeb(g,i) ]
	]
	write(1,30) iter,step,c
	30 format(' Iter.',2i3,i6,' Aend.')
] until (c==0)
#
# ******************** End Main Loop ********************
#
write(1,90)
90 format(' *** SHRINK - Ende ***')
write(1,92)
92 format(' B C  o7')	# Fenster 0 auf 0,0 bis 79,24
end


	subroutine randnb(x,y)
#
# liefert die 3x3-Nachbarschaft des Randpunktes x,y in den Bytes p2,...,p9.
# Ein Byte ist =1, falls der Grauwert groesser-gleich dem Schwellwert gg ist;
# sonst =0. Punkte ausserhalb des Bildes sind immer =0.
#
byte	p1,p2,p3,p4,	# Zentralpunkt u. 3x3-Nachbarschaft
	p5,p6,p7,p8,p9
byte	getpix		# function; vergl.Grauwert aus Bild mit Schwellwert gg
#
integer	x,y		# Zentralpunktkoord.
integer	adr1,xanz,yanz	# Bildgrenzen
#
common	/bild/adr1,xanz,yanz			# Bild-Kenndaten
common	/nachb/p2,p3,p4,p5,p6,p7,p8,p9
#
if (y==1) [ p9=0 ; p2=0 ; p3=0 ]
else
[	if (x==1) p9=0
	else p9=getpix(x-1,y-1)
	p2=getpix(x,y-1)
	if (x==xanz) p3=0
	else p3=getpix(x+1,y-1)
]
if (x==1) p8=0
else p8=getpix(x-1,y)
if (x==xanz) p4=0
else p3=getpix(x+1,y)
#
if (y==yanz) [ p7=0 ; p6=0 ; p5=0 ]
else 
[	if (x==1) p7=0
	else p7=getpix(x-1,y+1)
	p6=getpix(x,y+1)
	if (x==xanz) p5=0
	else p5=getpix(x+1,y+1)
]
return
end


	subroutine mittnb(x,y)
#
# liefert die 3x3-Nachbarschaft des Mittenpunktes x,y in den Bytes p2,...,p9.
# Das Byte ist =1, falls der Grauwert groesser-gleich dem Schwellwert gg ist.
#
byte	p1,p2,p3,p4,	# Zentralpunkt u. 3x3-Nachbarschaft
	p5,p6,p7,p8,p9
byte	getpix		# function; vergl.Grauwert aus Bild mit Schwellwert gg
#
integer	x,y		# Zentralpunktkoord.
#
common	/nachb/p2,p3,p4,p5,p6,p7,p8,p9
#
p2=getpix(x  ,y-1)
p3=getpix(x+1,y-1)
p4=getpix(x+1,y  )
p5=getpix(x+1,y+1)
p6=getpix(x  ,y+1)
p7=getpix(x-1,y+1)
p8=getpix(x-1,y  )
p9=getpix(x-1,y-1)
return
end


	logical function getpix(x,y)
#
# liefert 1, falls der Grauwert von Pixel x,y groesser-gleich dem Schwellwert
# gg ist; sonst 0.
#
byte	g	# Grauwert
byte	gg	# Schwellwert
#
integer	x,y,k
integer	adr1	# Basisadresse von Bild 1
integer	xanz,yanz,gwmax
integer	ibadr	# function; liefert Pixel-Adresse in Bank
#
common	/bild/adr1,xanz,yanz,gwmax,gg
#
k=ibadr(x,y,adr1) ; call loadb(g,k)
if (g<<gg) getpix=0
else getpix=1
return
end


	integer function ibadr(x,y,adr)
#
# berechnet die Speicheradresse in Bank 1 fuer das Pixel x,y
# relativ zur Basisadresse adr.
#
integer	x,y,adr
integer	adr1,xanz,yanz
#
common	/bild/adr1,xanz,yanz
#
ibadr=adr+(x-1)*yanz+y-1
return
end


	logical function inkey(wait)
#
# liefert ein Eingabezeichen direkt vom Keyboard.
#
logical	wait		# true = auf Eingabe warten
byte	b		# Byte
byte	cport,dport	# Keyboard Ports (Sio-B)
byte	inp		# internal function
#
data cport,dport/7,5/
#
repeat
	b=inp(cport)
until (.not.wait !! mod(b,2)==1)
inkey=inp(dport)
end
