Factor out some of the postscript generation code to the PS prolog.

1 files changed, 112 insertions, 1 deletions

diff --git a/library/mkpsenc.tcl b/library/mkpsenc.tcl
index 7f82182..dea846b 100644
--- a/library/mkpsenc.tcl
+++ b/library/mkpsenc.tcl
@@ -1121,7 +1121,7 @@ namespace eval ::tk {
 	%%BeginProlog
 	% This is a standard prolog for Postscript generated by Tk's canvas
 	% widget.
-	% RCS: @(#) $Id: mkpsenc.tcl,v 1.4 2008/12/05 10:27:50 dkf Exp $
+	% RCS: @(#) $Id: mkpsenc.tcl,v 1.5 2009/05/01 15:03:17 dkf Exp $
     }
     ps_literal [CreatePostscriptEncoding [encoding system]]
     ps_literal {50 dict begin}
@@ -1360,6 +1360,117 @@ namespace eval ::tk {
 	} forall
     }
 
+    # Define the "TkPhoto" function variants, which are modified versions of
+    # the original "transparentimage" function posted by ian@five-d.com (Ian
+    # Kemmish) to comp.lang.postscript. For a monochrome colorLevel this is a
+    # slightly different version that uses the imagemask command instead of
+    # image.
+
+    ps_function TkPhotoColor {
+	gsave
+	32 dict begin
+	/tinteger exch def
+	/transparent 1 string def
+	transparent 0 tinteger put
+	/olddict exch def
+	olddict /DataSource get dup type /filetype ne {
+	    olddict /DataSource 3 -1 roll
+	    0 () /SubFileDecode filter put
+	} {
+	    pop
+	} ifelse
+	/newdict olddict maxlength dict def
+	olddict newdict copy pop
+	/w newdict /Width get def
+	/crpp newdict /Decode get length 2 idiv def
+	/str w string def
+	/pix w crpp mul string def
+	/substrlen 2 w log 2 log div floor exp cvi def
+	/substrs [ {
+	    substrlen string
+	    0 1 substrlen 1 sub {
+		1 index exch tinteger put
+	    } for
+	    /substrlen substrlen 2 idiv def
+	    substrlen 0 eq {exit} if
+	} loop ] def
+	/h newdict /Height get def
+	1 w div 1 h div matrix scale
+	olddict /ImageMatrix get exch matrix concatmatrix
+	matrix invertmatrix concat
+	newdict /Height 1 put
+	newdict /DataSource pix put
+	/mat [w 0 0 h 0 0] def
+	newdict /ImageMatrix mat put
+	0 1 h 1 sub {
+	    mat 5 3 -1 roll neg put
+	    olddict /DataSource get str readstring pop pop
+	    /tail str def
+	    /x 0 def
+	    olddict /DataSource get pix readstring pop pop
+	    {
+		tail transparent search dup /done exch not def
+		{exch pop exch pop} if
+		/w1 exch length def
+		w1 0 ne {
+		    newdict /DataSource
+		    pix x crpp mul w1 crpp mul getinterval put
+		    newdict /Width w1 put
+		    mat 4 x neg put
+		    /x x w1 add def
+		    newdict image
+		    /tail tail w1 tail length w1 sub getinterval def
+		} if
+		done {exit} if
+		tail substrs {
+		    anchorsearch {pop} if
+		} forall
+		/tail exch def
+		tail length 0 eq {exit} if
+		/x w tail length sub def
+	    } loop
+	} for
+	end
+	grestore
+    }
+    ps_function TkPhotoMono {
+	gsave
+	32 dict begin
+	/dummyInteger exch def
+	/olddict exch def
+	olddict /DataSource get dup type /filetype ne {
+	    olddict /DataSource 3 -1 roll
+	    0 () /SubFileDecode filter put
+	} {
+	    pop
+	} ifelse
+	/newdict olddict maxlength dict def
+	olddict newdict copy pop
+	/w newdict /Width get def
+	/pix w 7 add 8 idiv string def
+	/h newdict /Height get def
+	1 w div 1 h div matrix scale
+	olddict /ImageMatrix get exch matrix concatmatrix
+	matrix invertmatrix concat
+	newdict /Height 1 put
+	newdict /DataSource pix put
+	/mat [w 0 0 h 0 0] def
+	newdict /ImageMatrix mat put
+	0 1 h 1 sub {
+	    mat 5 3 -1 roll neg put
+	    0.000 0.000 0.000 setrgbcolor
+	    olddict /DataSource get pix readstring pop pop
+	    newdict /DataSource pix put
+	    newdict imagemask
+	    1.000 1.000 1.000 setrgbcolor
+	    olddict /DataSource get pix readstring pop pop
+	    newdict /DataSource pix put
+	    newdict imagemask
+	} for
+	end
+	grestore
+    }
+
     ps_literal %%EndProlog
 
     rename ps_function {}