optkern.ps

% PostScript Kerning Procedures
% by scriptit.co.uk

% constants
/SP (\0 ) def % space
/NL (\0\n) def % new line

% analyse inner edges and reject optical outliers
% <[left right] array> <left> <right> _koptoutliers <fenced array>
/_koptoutliers {
	1 index (left) get
	1 index (right) get 3 index (advance) get add round cvi
	4 2 roll pop pop
	% find inner optical limits for the height in common
	2 copy % l1 r2 r1 l2
	0 1 6 index length 1 sub {
		5 index exch get aload pop
		dup 3 index lt { 3 -1 roll pop exch }{ pop } ifelse % l2
		dup 3 index gt { 3 -1 roll pop exch }{ pop } ifelse % r1
	} for % each row
	% calc fences halfway through characters
	3 -1 roll
	0.5 % width of char to shift outliers by (bigger for tighter fencing)
	5 1 roll
	4 2 roll
	2 copy add 2 div % left fence
	3 1 roll exch sub 4 index mul % left outlier shift
	4 2 roll
	2 copy add 2 div % right fence
	3 1 roll exch sub 5 -1 roll mul % right outlier shift
	% build optically fenced array
	0 1 6 index length 1 sub {
		5 index 1 index get aload pop
		dup 5 index gt { 3 index sub } if exch
		dup 7 index lt { 5 index add } if exch
		round cvi exch round cvi exch
		[ 3 1 roll ]
		6 index 3 1 roll put
	} for % each row
	pop pop pop pop
} bind def

% analyse inner edges and reject statistical outliers
% <gap array> _kstatoutliers <fenced array>
/_kstatoutliers {
	{} insertionsort % sort
	0
	1 index median
	2 index 1 index mad % use median absolute deviation if nonzero
	dup 0 eq {
		pop pop
		1 index mean
		2 index 1 index sd % use standard deviation if zero MAD
	} if
	dup 0 ne {
		0 1 5 index length 1 sub {
			4 index exch get
			dup 3 index sub abs 2 index div % abs(x - m) / d
			2 le { % within 2 MADs or SDs
				4 index 4 index 3 -1 roll put
				3 -1 roll 1 add 3 1 roll
			}{
				pop
			} ifelse
		} for % each row
		pop pop
		0 exch getinterval % trim
	}{
		pop pop pop
	} ifelse
} bind def

% get kerning values for adjacent characters
% <left char data> <right char data> _kpair <pair data dict>
/_kpair {
%newpath 0 0 moveto
%1 index (char) get true charpath flattenpath pathbbox % left char
%currentpoint newpath moveto
%4 index (char) get true charpath flattenpath pathbbox % right char
	1 index (advance) get round cvi
	dup 2 index (right) get add 3 index (right) get sub neg % distance to align rightmost points
	3 index (top) get 3 index (top) get max
	4 index (bottom) get 4 index (bottom) get min
	sub 1 add % outer height
	1000 % minimum optical gap
	4 -1 roll
	5 index (points) get
	5 index (points) get
	7 index (bottom) get 7 index (bottom) get max
	8 index (top) get 8 index (top) get min
	2 copy exch sub 1 add % common height
	array % [L R] pairs
	0 % index
	7 2 roll
	1 exch {
		dup 3 index exch get 1 get % left char right edge
		exch 2 index exch get 0 get % right char left edge
		1 index null ne 1 index null ne and {
			4 index add % right + advance
			2 copy 2 array astore % [L R] pair
			7 index 7 index 3 -1 roll put % save in array
			6 -1 roll 1 add 6 1 roll % ++index
			exch sub 1 sub % optical gap
			dup 7 index lt { 7 -1 roll pop 6 1 roll }{ pop } ifelse % minimum
		}{
			pop pop
		} ifelse
	} for % each row
	pop pop pop
	0 exch getinterval % trim
	% limit optical outliers
	5 index
	5 index
	_koptoutliers
	% convert to gaps
	0 1 2 index length 1 sub {
		dup 2 index exch get aload pop
		exch sub 1 sub % gap
		2 index 3 1 roll put
	} for % each row
	% remove statistical outliers
	_kstatoutliers
	% pair data
	10 dict
	7 1 roll
	6 index (maxkern) 6 -1 roll put % rightmost points
	5 index (height) 5 -1 roll put % outer
	4 index (mingap) 4 -1 roll put % of all rows
	3 1 roll
	[ 2 index (char) get 2 index (char) get ] 4 index (pair) 3 -1 roll put
	(bbox) get 0 get 1 index (advance) get add exch (bbox) get 2 get sub
	2 index (chargap) 3 -1 roll put
	dup median
	dup 3 index (median) 3 -1 roll put
	1 index exch mad
	2 index (mad) 3 -1 roll put
	dup mean
	dup 3 index (mean) 3 -1 roll put
	1 index exch sd
	2 index (sd) 3 -1 roll put
	length
	1 index (rows) 3 -1 roll put % sample
} bind def

% gather data for glyph
% <char> _kglyph <char data dict>
/_kglyph {
	0 dict % data
	exch
	2 copy (char) exch put
	newpath 0 0 moveto
	true charpath
	dup (advance) x put
	dup (bbox) flattenpath [ pathbbox ] put
	dup (left) 2 index (bbox) get 0 get floor cvi put
	dup (bottom) 2 index (bbox) get 1 get floor cvi put
	dup (right) 2 index (bbox) get 2 get ceiling cvi put
	dup (top) 2 index (bbox) get 3 get ceiling cvi put
	% trace edges
	dup (points) 0 dict put
	dup (bottom) get 1 2 index (top) get {
		2 array % left right
		2 index (left) get 1 4 index (right) get {
			dup 3 index infill {
				1 index 0 3 -1 roll put exit
			} if
			pop
		} for % trace left side
		dup 0 get null ne {
			2 index (right) get -1 4 index (left) get {
				dup 3 index infill {
					1 index 1 3 -1 roll put exit
				} if
				pop
			} for % trace right side
		} if % filled
		2 index (points) get
		3 1 roll put
	} for % each row
	% trim top & bottom
	dup (points) get
	1 index (top) get
	2 index (bottom) get
	3 -1 roll {
		aload pop
		pop null ne {
			dup 2 index gt { exch pop dup } if
			dup 3 index lt { 3 -1 roll pop exch }{ pop } ifelse
		}{
			pop
		} ifelse
	} forall % each row
	2 index (top) 3 -1 roll put
	1 index (bottom) 3 -1 roll put
	% trim left & right
	dup (points) get
	dup 2 index (bottom) get get aload pop % any pair
	3 -1 roll {
		exch pop aload pop
		dup null ne {
			dup 3 index gt { 3 -1 roll pop exch }{ pop } ifelse
			dup 3 index lt { 3 -1 roll pop exch }{ pop } ifelse
		}{
			pop pop
		} ifelse
	} forall % each row
	2 index (right) 3 -1 roll put
	1 index (left) 3 -1 roll put
} bind def

% gather kerning data for string
% <char array> _kdata <pairs data dict>
/_kdata {
	0 dict % pair data
	0 dict % char data
	3 -1 roll utf16chars
	[ exch { dup //NL eq { pop //SP } if } forall ] % newlines to spaces
	dup {
		dup //SP ne {
			dup hash % key
			dup 4 index exch known not { % not done
				exch _kglyph
				3 index 3 1 roll put
			}{
				pop pop
			} ifelse
		}{
			pop
		} ifelse
	} forall % each char
	utf16string
	//SP split { % words
		utf16chars % word
		dup length 1 sub % limit
		exch
		0 1 3 index {
			dup 3 index lt { % at least 2 chars left
				1 index exch 2 getinterval % pair
				aload 3 1 roll cat hash % key
				dup 6 index exch known not { % not done
					exch
					aload pop
					exch hash 5 index exch get % left glyph
					exch hash 5 index exch get % right glyph
					1 index (top) get 1 index (bottom) get gt
					2 index (bottom) get 2 index (top) get lt
					and % test both have > 1 row overlap
					2 index (points) get length 1 gt
					3 index (points) get length 1 gt
					and % test both have > 1 row with infill
					and {
						_kpair
						5 index 3 1 roll put
					}{
						pop pop pop
					} ifelse
				}{
					pop pop
				} ifelse
			}{
				pop
			} ifelse
		} for % each char position
		pop pop
	} forall % each word
	pop
} bind def

% get kerning pair adjustments
% <pairs data dict> _kchars <pair data dict>
/_kchars {
	dup
	% use MAD outlier detection on mean gaps
	[ exch { exch pop (mean) get } forall ] % gap means
	{} insertionsort % sort
	dup median
	2 copy mad
	3 -1 roll
	1 index 0 eq {
		dup mean sd exch pop % if zero MAD use standard deviation
	}{
		pop
	} ifelse
	1 % acceptable # deviations, n
	3 index {
		exch pop
		dup (mean) get % x
		dup 5 index sub abs 4 index dup 0 ne { div }{ pop pop 0 } ifelse % abs(x - m) / d
		3 index le % within n MADs or SDs
		(kern) exch {
			0
		}{
			4 index 4 index mul 6 index add % target = nd + m
			2 index sub % distance = target - x
		} ifelse
		3 -1 roll pop
		put
	} forall % each pair
	pop pop pop
} bind def

% scale and limit kerning distance
% <data> <font em> <kern em> <min gap overall> _kscale <distance>
/_kscale {
	3 index (mingap) get % gap for this pair
	sub % maximum distance to move
	3 index (kern) get % kern distance
	dup 0 lt { % -ve kern only
		max % kern limit
		3 index (rows) get 4 index (height) get div % sample fraction, f
		-10 mul //E exch exp neg 1 add % 1 - e^-10f
		mul % shift punctuation less
		3 index (maxkern) get max % limit shift to align rightmost points
		3 1 roll
		div % scale
		mul % scaled distance
	}{
		pop pop pop pop 0
	} ifelse
	exch pop
} bind def

% get kerning pair adjustments for string
% <char array> <em> kerning <scaled kern distance dict>
/kerning {
	gsave
	currentfont
	dup /FontMatrix get 0 get 0 lt % flip
	1 index /FontName get 100 false tfont %em
	5 -1 roll
	% get pair data
	_kdata
	dup length 0 ne {
		_kchars
		% get minimum char gap for all pairs
		dup { exch pop (mingap) get exit } forall
		1 index { exch pop (mingap) get min } forall
		0 max % zero gap limit
		0 dict % dest
		6 -1 roll
		7 2 roll
		5 -2 roll exch
		5 1 roll
		3 -1 roll {
			5 index 5 index 5 index _kscale
			dup 0 ne {
				2 index { neg } if % flip
				7 index 3 1 roll put
			}{
				pop pop
			} ifelse
		} forall % each pair
		pop pop pop pop
	}{
		5 1 roll
		4 -1 roll
		pop pop pop
	} ifelse
	setfont
	grestore
} bind def

% add path for glyph after doing kerning shift
% <char> <kerns> kcharpath -
/kcharpath {
	dup (lastchar) known {
		dup (lastchar) get 2 index cat hash % key
		1 index 1 index known {
			1 index 1 index get % kern distance
			dup 0 rmoveto % kern
			pop
		} if
		pop
	} if
	(lastchar) 2 index put
	true charpath
} bind def