#include <tk.h>
static int
PhotoTrans(clientdata, interp, argc, argv)
     ClientData clientdata;
     Tcl_Interp *interp;
     int argc;
     char **argv;
{
  Tk_PhotoHandle si,di;
  XColor *col;
  int r,g,b;
  Tk_PhotoImageBlock src,dst;
  int i,j;

  if (argc!=4) {
    Tcl_AppendResult(interp, "usage: ", argv[0],
		     " destImage srcImage transColour", (char *) NULL);
    return TCL_ERROR;
  }
  si = Tk_FindPhoto(argv[2]); di = Tk_FindPhoto(argv[1]);
  if (si == NULL || di == NULL) {
    Tcl_AppendResult(interp, "both source and destination images "
		     "must exist", (char *) NULL);
    return TCL_ERROR;
  }
  col = Tk_GetColor(interp, Tk_MainWindow(interp), argv[3]);
  if (col == NULL) {
    Tcl_AppendResult(interp, "unable to parse colour", (char *) NULL);
    return TCL_ERROR;
  }
  r=col->red>>8; g=col->green>>8; b=col->blue>>8;
  Tk_FreeColor(col);

  Tk_PhotoBlank(di);
  Tk_PhotoGetImage(si, &src);

  dst.width = 1; dst.height = 1;
  dst.pitch = src.pitch;
  dst.pixelSize = src.pixelSize;
  dst.offset[0] = src.offset[0];
  dst.offset[1] = src.offset[1];
  dst.offset[2] = src.offset[2];

#define readsrc(x,y,f) \
	(src.pixelPtr[(x)*src.pixelSize + (y)*src.pitch + src.offset[(f)]])
  for (i=0; i<src.width; i++) {
    for (j=0; j<src.height; j++) {
      if (r!=readsrc(i,j,0) || g!=readsrc(i,j,1) || b!=readsrc(i,j,2)) {
	dst.pixelPtr = src.pixelPtr + i*src.pixelSize + j*src.pitch;
	Tk_PhotoPutBlock(di, &dst, i,j, 1,1);
      }
    }
  }

  return TCL_OK;
}

int
Phototrans_Init(interp)
     Tcl_Interp *interp;
{
  static char loadtranscmd[] = "\
    proc photo-transparent {args} {\
	if {[llength $args]} {\
	    if {![string match -* [lindex $args 0]]} {\
		set imgname [lindex $args 0]\
		set args [lrange $args 1 end]\
	    }\
	    if {[llength $args]&1} {\
		return -code error \"must match options and values\"\
	    }\
	    array set opts $args\
	}\
\
	set userspecs {}\
	foreach spec {-format -gamma -height -palette -width} {\
	    if {[info exist opts($spec)]} {\
		lappend userspecs $spec $opts($spec)\
		unset opts($spec)\
	    }\
	}\
\
	if {[info exist opts(-tempimage)]} {\
	    set source $opts(-tempimage)\
	    unset opts(-tempimage)\
	} else {\
	    set source {transparency temporary image - should not be seen}\
	}\
\
	global TRANSPARENT_GIF_COLOR\
	if {[info exist TRANSPARENT_GIF_COLOR]} {\
	    set oldtransparent $TRANSPARENT_GIF_COLOR\
	}\
	if {[info exist opts(-transparent)]} {\
	    set TRANSPARENT_GIF_COLOR $opts(-transparent)\
	    unset opts(-transparent)\
	} elseif {![info exist TRANSPARENT_GIF_COLOR]} {\
	    # Hmm. Have to hazard a guess at what color to make transparent\
	    # Choose something fairly dark and just off grey, so it is unlikely\
	    # to be chosen as a colour in itself. (Crosses fingers behind back)\
	    set TRANSPARENT_GIF_COLOR \"#414243\"\
	}\
\
	if {[info exist opts(-channel)]} {\
	    set ch $opts(-channel)\
	    unset opts(-channel)\
	    if {[llength [array names opts]]} {\
		if {[info exist oldtransparent]} {\
		    set TRANSPARENT_GIF_COLOR $oldtransparent\
		} else {\
		    unset TRANSPARENT_GIF_COLOR\
		}\
		return -code error \"unknown or bad option(s): [array names opts]\"\
	    }\
	    set delsource 1\
	    eval [list image create photo $source -channel $ch] $userspecs\
	} if {[info exist opts(-file)]} {\
	    set f $opts(-file)\
	    unset opts(-file)\
	    if {[llength [array names opts]]} {\
		if {[info exist oldtransparent]} {\
		    set TRANSPARENT_GIF_COLOR $oldtransparent\
		} else {\
		    unset TRANSPARENT_GIF_COLOR\
		}\
		return -code error \"unknown or bad option(s): [array names opts]\"\
	    }\
	    set delsource 1\
	    eval [list image create photo $source -file $f] $userspecs\
	} elseif {[info exist opts(-data)]} {\
	    set d $opts(-data)\
	    unset opts(-data)\
	    if {[llength [array names opts]]} {\
		if {[info exist oldtransparent]} {\
		    set TRANSPARENT_GIF_COLOR $oldtransparent\
		} else {\
		    unset TRANSPARENT_GIF_COLOR\
		}\
		return -code error \"unknown or bad option(s): [array names opts]\"\
	    }\
	    set delsource 1\
	    eval [list image create photo $source -data $d] $userspecs\
	} elseif {[info exist opts(-image)]} {\
	    set source $opts(-image)\
	    unset opts(-image)\
	    if {[llength [array names opts]]} {\
		if {[info exist oldtransparent]} {\
		    set TRANSPARENT_GIF_COLOR $oldtransparent\
		} else {\
		    unset TRANSPARENT_GIF_COLOR\
		}\
		return -code error \"unknown or bad option(s): [array names opts]\"\
	    }\
	    set delsource 0\
	} else {\
	    return -code error \\
		    \"must specify one of -channel, -data, -file or -image\"\
	}\
\
	if {[info exist imgname]} {\
	    image create photo $imgname \\
		    -height [image height $source] \\
		    -width [image width $source]\
	} else {\
	    set imgname [image create photo \\
		    -height [image height $source] \\
		    -width [image width $source]]\
	}\
\
	PhotoTrans $imgname $source $TRANSPARENT_GIF_COLOR\
	if $delsource {image delete $source}\
\
	if {[info exist oldtransparent]} {\
	    set TRANSPARENT_GIF_COLOR $oldtransparent\
	} else {\
	    unset TRANSPARENT_GIF_COLOR\
	}\
\
	set imgname\
    }\
";
  Tcl_CreateCommand(interp, "PhotoTrans", PhotoTrans,
		    (ClientData)0, (Tcl_CmdDeleteProc *)NULL);
  /* Using Tcl_VarEval() gets round the restriction that strings must be
   * writable in Tcl_Eval() since this definition is a global one anyway.
   */
  return Tcl_VarEval(interp, loadtranscmd, (char *)NULL);
}