/*
 * $Id: scout.eden,v 1.1 2002/02/27 16:27:43 cssbz Exp $
 */
/****************************************************************
 *								*
 *   This file is the function library of the SCOUT system	*
 *   It contains definitions of attributes, EDEN version of	*
 *   some SCOUT functions, screen updating functions and	*
 *   its sub-functions and initialization procedures		*
 *								*
 ****************************************************************/

/**********************
     Initialise EX
 **********************/

/* luckily these first two are the same as required by donald in
   donald.init.e.  These must be the same values as are defined in the
   Scout namespace in Scout/lex.c (init_scout).  Also define these in
   builtinf.h [Ash] */
OFF = 0;
ON = 1;
MOTION = 2;
ENTER = 4;
LEAVE = 8;

CLIENT_LIST = [];  /* declare a list for server end to list all
                      connected clients */
DFfont = "{courier 10}";
DFscreen = "screen";		/* should not change this */
DFalign = 0;	/* 0 - no, 1 - left, 2 - right, 3 - centre,
                   4 - left & right */
DFbgcolor = tcl(". cget -background");
DFfgcolor = "black";
DFbdcolor = "black";
DFborder = 0;
DFrelief = "raise";
DFxmin = 0;
DFymin = 0;
DFxmax = 1000;
DFymax = 1000;
DFhighlight = 1;
DFsensitive = OFF;
DFwidth = 500;
DFheight = 500;

proc HandleDisplayResizeEvent {
  para widget, name, width, height;

  /* Ignore messages about child widgets */
  if (widget == "." // name) {
    /* Don't redefine if the values haven't changed.  This will cause
       "reference to undefined variable" notices if they are enabled
       the first time this is done. */
    if ((`name//"_width"` != width) ||
	(`name//"_height"` != height)) {
      execute("%scout\ninteger "//name//"_width="//str(width)//
	    "; integer "//name//"_height="//str(height)//";");
    }
  }
}

proc OpenDisplay { para name, width, height;
  if (name[1] >= 'A' && name[1] <= 'Z')
    name = "_"//name;
  tcl("toplevel ."//name//" -background "//DFbgcolor//
    " -width "//str(width)//" -height "//str(height));
  tcl("wm protocol ."//name//" WM_DELETE_WINDOW { set show_"//name//
    " 0; show "//name//" 0;}");
  tcl("wm title ."//name//" \""//name//" ($variantversion)\"");
  tcl("uplevel #0 {set show_"//name//" 1}");
/* the -underline here should really look through the other items in the
 * menu and find the first unique character to use as a key shortcut
 * [Ash], April 2001 */
  tcl(".menu.show add checkbutton -label "//name//
    " -variable show_"//name//" -command {show "//name//
    " $show_"//name//"} -underline 1");
  tcl("bind ."//name//" <Configure> { " //
    "eden {~HandleDisplayResizeEvent(\"%W\", \""//name//"\", %w, %h);}" //
    " }");
  HandleDisplayResizeEvent("."//name, name, width, height);
  execute("%scout\ndisplay ~" // name // ";\n%eden\n");
  tcl("tkwait visibility ."//name);
}

proc DestroyDisplay { para name;
	if (name[1] >= 'A' && name[1] <= 'Z')
		name = "_"//name;
	tcl("destroy ."//name);
	tcl(".menu.show delete "//name);
	tcl("unset show_"//name);
}

func StringWidth {
	para win, font, string;

	if ((win == @) || (font == @) || (string == @)) return @;

	return int(tcl("font measure " // font //
		" -displayof ." // win // " " // "{" // string // "}"));
}

func FontWidth {
	para win, font;
	/* Measuring the width of the (wide) character 'W' */
	return StringWidth(win, font, "W");
}

func FontHeight {
	para win, font;
	return int(tcl("font metrics " // font //
		" -displayof ." // win // " -linespace"));
}

func DisplayDepth {
	para win;
	return int(tcl("winfo depth ." // win));
}

/* This gets called when '%scout' is done for the first time */
proc scoutScreenInitOpen {
	OpenDisplay(DFscreen, DFwidth, DFheight);
	fontWidth is FontWidth(DFscreen, DFfont);
	fontHeight is FontHeight(DFscreen, DFfont);
	displayDepth is DisplayDepth(DFscreen);
}

/*******************
 * SCOUT functions *
 *******************/

func pt_add /* ( point, point) */
/* + (point addition) */
{
    return [$1[1] + $2[1], $1[2] + $2[2]];
}

func pt_subtract /* ( point, point) */
/* - (point subtraction) */
{
    return [$1[1] - $2[1], $1[2] - $2[2]];
}

func row { return $1 * fontHeight; }
func column { return $1 * fontWidth; }
proc update_row : fontHeight { touch(&row); }
proc update_column : fontWidth { touch(&column); }

func dotint /* ( list, int ) */
/*
   .1		(i.e. dotint(point, 1))
   .2		(i.e. dotint(point, 2))
   .type	(i.e. dotint(window, 1))
   .frame	(i.e. dotint(window, 2))
   .string	(i.e. dotint(window, 3))
   .box		(i.e. dotint(window, 4))
   .pict	(i.e. dotint(window, 5))
   .xmin	(i.e. dotint(window, 6))
   .ymin	(i.e. dotint(window, 7))
   .xmax	(i.e. dotint(window, 8))
   .ymax	(i.e. dotint(window, 9))
   .bg		(i.e. dotint(window, 10))
   .fg		(i.e. dotint(window, 11))
   .border	(i.e. dotint(window, 12))
   .align	(i.e. dotint(window, 13))
   .sensitive	(i.e. dotint(window, 14))
   .bordercolor (i.e. dotint(window, 15))
   .font	(i.e. dotint(window, 16))
   .relief	(i.e. dotint(window, 17))
   .(int)	(for frame and display)
*/
{
    return $1[int($2)];
}

func dotne /* ( box ) */
/* .ne */
{
    return [$1[3], $1[2]];
}

func dotnw /* ( box ) */
/* .nw */
{
    return [$1[1], $1[2]];
}

func dotse /* ( box ) */
/* .se */
{
    return [$1[3], $1[4]];
}

func dotsw /* ( box ) */
/* .sw */
{
    return [$1[1], $1[4]];
}

func dotn /* ( box ) */
/* .n */
{
    return [($1[1] + $1[3]) / 2, $1[2]];
}

func dote /* ( box ) */
/* .e */
{
    return [$1[3], ($1[2] + $1[4]) / 2];
}

func dots /* ( box ) */
/* .s */
{
    return [($1[1] + $1[3]) / 2, $1[4]];
}

func dotw /* ( box ) */
/* .w */
{
    return [$1[1], ($1[2] + $1[4]) / 2];
}

func boxshift /* ( box, x, y ) */
{
    para box, x, y;
    return [box[1] + x, box[2] + y, box[3] + x, box[4] + y];
}

func app /* ( list, position, element ) */
/* append (for both frame and display) */
{
    insert $1, int($2) + 1, $3;
    return $1;
}

func del /* ( list, position ) */
/* delete (for both frame and display) */
{
    delete $1, $2;
    return $1;
}

func list_append /* ( list, list ) */
/* & (for both frame and display) */
{

     return $1 // $2;
}

func formbox /* ( point, point ) */
/* constructor of box : < P1, P2 > */
{
    return [$1[1], $1[2], $2[1], $2[2]];
}

proc update_textbox : column, row { touch(&textbox); }
func textbox {
	return [$1[1], $1[2], $1[1] + column($3) + 1, $1[2] + row($2) - 1];
}

func box_width /* ( box ) */
/* return the width of the box in pixel */
{
    return $1[3] - $1[1] + 1;
}

func box_height /* ( box ) */
/* return the height of the box in pixel */
{
    return $1[4] - $1[2] + 1;
}

func capacity /* ( box ) */
/* return [r, c], no of row and no of col the box can hold */
{
    return [($1[4] - $1[2] - 1) / fontHeight,
	    ($1[3] - $1[1] - 1) / fontWidth];
}

/*********************************
 * string manipulating functions *
 *********************************/

/* this doesn't seem to be used anywhere [Ash] */
func Quote { para s;
    auto ret, i;

    if (type(s) != "string") { return str(s); }
    ret = "\"";
    for (i = 1; i <= s#; i++) {
        switch (s[i]) {
        case '"':
            ret = ret // "\\\"";
            break;
        case '\\':
            ret = ret // "\\\\";
            break;
        default:
            ret = ret // s[i];
            break;
        }
    }
    return ret // "\"";
}

/***************************
 * image related functions *
 ***************************/

/* return the height of an image */
func ImageHeight { return tcl("image height "//$1); }

/* return the width of an image */
func ImageWidth { return tcl("image width "//$1); }

/* read, name and return the image from file
   image format currently available are ppm and gif */
func ImageFile {
    para imageName, type, filename;
    xoutput("image create photo", imageName, "-format", type, "-file",
            filename);
    return imageName;
}

/* scale the srcImage, name and return the scaled image as imageName */
/* This function uses the external utility pnmscale to do the job as
   Tcl can only currently scale images by integer amounts, and
   requires "zoom" for positive and "subsample" for negative amounts.
   Unfortunately the pnm utilities seem to be quite a UNIX thing and
   getting this way of things to work on Windoz could be quite a
   headache.  :(.  Anyway - if you want to fudge a scaled image using
   only Tcl, use something like
     xoutput("image create photo ", imageName);
     xoutput(imageName, "copy", srcImage, "-subsample 3");
     return imageName
   here.  [Ash, Sept 2000] */
func ImageScale { para imageName, srcImage, xscale, yscale;
	tcl("image create photo "//imageName);
	xoutput(srcImage, "write /tmp/1"//imageName);
	xoutput("exec pnmscale -xscale", xscale, "-yscale", yscale,
		"/tmp/1"//imageName, "> /tmp/2"//imageName);
	xoutput(imageName, "read /tmp/2"//imageName);
	xoutput("exec rm /tmp/1"//imageName, "/tmp/2"//imageName);
	return imageName;
}

/* cut a rectangle out of the srcImage, name and return result as imageName */
func ImageCut { para imageName, srcImage, x, y, width, height;
	tcl("image create photo "//imageName);
	xoutput(srcImage, "write /tmp/1"//imageName);
	xoutput("exec pnmcut", x, y, width, height,
		"/tmp/1"//imageName, "> /tmp/2"//imageName);
	xoutput(imageName, "read /tmp/2"//imageName);
	xoutput("exec rm /tmp/1"//imageName, "/tmp/2"//imageName);
	return imageName;
}

/* create pattern using ppmpat */
/* ppmpat generates ascii PPM which cannot be recognised by Tk */
func ImagePat { para imageName, form, width, height;
	tcl("image create photo "//imageName);
	xoutput("exec ppmpat -"//form, width, height, "> /tmp/1"//imageName);
	xoutput(imageName, "read /tmp/1"//imageName);
	xoutput("exec rm /tmp/1"//imageName);
	return imageName;
}

/* procedure for displaying an image */
proc ShowImage { para I_source, source;
    auto command, i, width, height;
    for (i = 1; i <= (*source)#; i++) {
	command = "."//(*source)[i][1]//"."//(*source)[i][2];
	width = int(tcl(command//" cget -width"));
	height = int(tcl(command//" cget -height"));
	xoutput(command, "create image", width / 2, height / 2,
		"-tags image -image", *I_source);
    }
}

/***** screen updating actions *****/

func Position {
    para bd, width, just;
    auto x, j, anchor;

    switch (int(just)) {
    case 1:
        x = 0;
        j = "left";
        anchor = "nw";
        break;
    case 2:
        x = width;
        j = "right";
        anchor = "ne";
        break;
    case 3:
        x = width / 2;
        j = "center";
        anchor = "n";
        break;
    case 0:
    case 4: /* not supported by Tk */
    default:
        x = 0;
        j = "left";
        anchor = "nw";
        break;
    }
    return str(int(bd + x))//" "//str(int(bd))//" -anchor "//anchor
                //" -justify "//j;
}


proc scout_show_2D
/*
   display a DoNaLD/ARCA picture
*/
{
    para screen, winNo, boxName;

/*
    writeln("scout_show_2D: ", $);
*/

    scout_show_2D_window(`screen`[winNo],
	"."//screen//"."//boxName//"_1", boxName//"_1");
}

proc dobinding {
  para sensitive, widget, windowName, var, boxNumber;
  auto mouseName, keyName, mousePosName, mouseEnterName, mouseLeaveName,
    xCoord, yCoord;

  sensitive = int(sensitive); /* yuk - integerhonest hack [Ash] */

  if (boxNumber > 0) {
    /* TEXT - have the boxNumber within the frame to deal with */
    mouseName      = "~"//windowName//"_mouse_"//str(boxNumber);
    keyName        = "~"//windowName//"_key_"//str(boxNumber);
    mousePosName   = "~"//windowName//"_mousePos_"//str(boxNumber);
    mouseEnterName = "~"//windowName//"_mouseEnter_"//str(boxNumber);
    mouseLeaveName = "~"//windowName//"_mouseLeave_"//str(boxNumber);
    xCoord         = "%x";
    yCoord         = "%y";

  } else {
    /* not TEXT - no boxNumber but must correct for window
       coordinate system */
    mouseName      = "~"//windowName//"_mouse";
    keyName        = "~"//windowName//"_key";
    mousePosName   = "~"//windowName//"_mousePos";
    mouseEnterName = "~"//windowName//"_mouseEnter";
    mouseLeaveName = "~"//windowName//"_mouseLeave";
    xCoord         = "[expr (%x-$"//var//"_xOrigin)/$"//var//"_xScale]";
    yCoord         = "[expr (%y-$"//var//"_yOrigin)/$"//var//"_yScale]";

  }

  if (sensitive bitand ON) {
    /* the window is interested in mouse actions and key strokes */
    xoutput("bind", widget, "<Button> { interface \"" // mouseName //
	    " = \\[%b,%T,%s," // xCoord // ", " // yCoord //
	    "];\\n\" }");
    xoutput("bind", widget, "<ButtonRelease> { interface \"" // mouseName //
	    " = \\[%b,%T,%s," // xCoord // ", " // yCoord //
	    "];\\n\" }");
    xoutput("bind", widget, "<Key> { interface \"" // keyName //
	    " = \\[%N,%T,%s," // xCoord // ", " // yCoord //
	    "];\\n\" }");
    xoutput("bind", widget, "<KeyRelease> { interface \"" // keyName //
	    " = \\[%N,%T,%s," // xCoord // ", " // yCoord //
	    "];\\n\" }");
  } else {
    xoutput("bind", widget, "<Button> {}");
    xoutput("bind", widget, "<ButtonRelease> {}");
    xoutput("bind", widget, "<Key> {}");
    xoutput("bind", widget, "<KeyRelease> {}");
  }

  /* ... could use 'todo' instead of 'interface' to prevent this information
     going into the history window if desired */
  if (sensitive bitand MOTION) {
    xoutput("bind", widget, "<Motion> { interface \""// mousePosName //
	    " = \\[" // xCoord // ", " // yCoord //
	    "];\\n\" }");
  } else {
    xoutput("bind", widget, "<Motion> {}");
  }

  if (sensitive bitand ENTER) {
    xoutput("bind", widget, "<Enter> { interface \"" // mouseEnterName //
	    " = 1;\\n\" }");
  } else {
    xoutput("bind", widget, "<Enter> {}");
  }

  if (sensitive bitand LEAVE) {
    xoutput("bind", widget, "<Leave> { interface \"" // mouseLeaveName //
	    " = 1;\\n\" }");
  } else {
    xoutput("bind", widget, "<Leave> {}");
  }

}


proc scout_show_2D_window
{
    /* Three parameters:

       - win is a long list giving the attributes of the window as
       described by the user in Scout (see the function translate() in
       Scout/symbol.c for details).

       - command seems to be the tcl name of the widget to
       create/modify, for example .screen.b1_1

       - var seems to be the variable name within that widget, for
       example b1_1.  [Ash] */

    para win, command, var;

    auto box, w, h, xScale, yScale;
    auto width, height, thickness, bdwidth;

    box = win[4];
    /* thickness seems to depend on the 'sensitive' attribute
       (win[14]) [Ash] */
    thickness = (win[14] != 0) ? DFhighlight : 0;
    bdwidth = win[12] + thickness;
    width = box_width(box);
    height = box_height(box);

    /* no control over border colour */
    xoutput("place", command,
	"-x", int(box[1]-bdwidth),
	"-y", int(box[2]-bdwidth));
    xoutput(command, "configure",
	"-width", width,
	"-height", height,
	"-bg", win[10],
	"-bd", int(win[12]),
	"-relief", win[17],
	"-highlightthickness", thickness
    );
    xoutput(command, "delete text");
    xoutput(command, "delete image");

    /* Don't need to draw content, DoNaLD will */

    w = box_width(box);
    h = box_height(box);
    xScale = 1.0*w/(win[8]-win[6]);
    yScale = 1.0*h/(win[7]-win[9]);
    if (tcl("info exists "//var//"_xOrigin") == "1") {
	xoutput(command, "move all",
		"[expr - $"//var//"_xOrigin]",
		"[expr - $"//var//"_yOrigin]");
	xoutput(command, "scale all",
		"0 0 [expr 1.0 / $"//var//"_xScale]",
		"[expr 1.0 / $"//var//"_yScale]");
	xoutput(command, "scale all",
		"0 0", xScale, yScale);
	xoutput(command, "move all",
		-win[6]*xScale+bdwidth, -win[9]*yScale+bdwidth);
    }
    xoutput("set", var//"_xOrigin", -win[6]*xScale+bdwidth);
    xoutput("set", var//"_yOrigin", -win[9]*yScale+bdwidth);
    xoutput("set", var//"_xScale", xScale);
    xoutput("set", var//"_yScale", yScale);
    xoutput("set", var//"_fg", win[11]);
    xoutput("set", var//"_font", win[16]);
    if (win# >= 18) {
    xoutput("set", var//"_name", win[18]);
    xoutput("set", var//"_box", 0);
    }

    xoutput("refresh", command);

    dobinding(win[14], command, win[18], var, 0);
}

proc Xoutput{writeln($); apply(xoutput, $); }

proc scout_show_canvas
/* display a text window */
{
    para screen, winNo, boxName;

    auto win, box, frame, string;
    auto i, var, command;
    auto width, height, thickness, bdwidth;
    auto currstr, new_string;
    win = `screen`[winNo];
    frame = win[2];
    string = win[3];
    new_string = "";    /* fix a bug of which a string cannot
                           contain {}[] -sun */ 

    /*
    for (i = 1; i <= string#; i++) {
      currstr = substr(string, i, i);
      if (currstr == "{" || currstr == "}" ||
          currstr == "[" || currstr == "]") {
        new_string = strcat(new_string, "\\", currstr);
      } else {
        new_string = strcat(new_string, currstr);
      }
    }
    */
    new_string = string; /* [Ash] */
 
    box = win[4];
    thickness = (win[14] != 0) ? DFhighlight : 0;
    bdwidth = win[12] + thickness;
    /* display boxes */
    for (i = 1; i <= frame#; i++) {
      /* no control over border colour */
      var = boxName//"_"//str(i);
      command = "."//screen//"."//var;
      width = box_width(frame[i]);
      height = box_height(frame[i]);
      xoutput("place", command,
	  "-x", int(frame[i][1]-bdwidth),
	  "-y", int(frame[i][2]-bdwidth));
      xoutput(command, "configure",
	  "-width", width,
	  "-height", height,
	  "-bg", win[10],
	  "-bd", int(win[12]),
	  "-relief", win[17],
	  "-highlightthickness", thickness
      );
      xoutput(command, "delete text");
      xoutput(command, "delete image");
      xoutput(command, "create text",
	  Position(bdwidth, box_width(frame[i]), win[13]),
	  "-fill", win[11],
	  /* "-text \"" //new_string//"\"", */  /*  -sun */
	  "-text {" //new_string//"}",   /* [Ash] */
	  "-width", box_width(frame[i]),
	  "-font", win[16],
	  "-tags text"
     );

      if (win# >= 18) {
      xoutput("set", var//"_name", win[18]);
      xoutput("set", var//"_box", i);
      }

      xoutput("refresh", command);

      dobinding(win[14], command, win[18], var, i);
    }
}

proc scout_show_text  /* rename old scout_show_text to scout_show_canvas  */
                      /* this proc is to show TEXTBOX. It is a tcl text widget. --sun*/
/*
   display a text window
*/
{
    para screen, winNo, boxName;

    auto win, box, frame, string;
    auto i, var, command;
    auto width, height, thickness, bdwidth;
    auto alignment, currstr, new_string, command_string;

    win = `screen`[winNo];
    frame = win[2];
    string = win[3];
    new_string = "";    /*  fix a bug of which a string cannot contain {}[] -sun */ 
    for (i = 1; i <= string#; i++) {
      currstr = substr(string, i, i);
      if (currstr == "{" || currstr == "}" || currstr == "[" || currstr == "]") 
           new_string = strcat(new_string, "\\", currstr);
      else new_string = strcat(new_string, currstr);
      }

    box = win[4];
    thickness = (win[14] != 0) ? DFhighlight : 0;
    bdwidth = win[12] + thickness;

    /* display boxes */
    for (i = 1; i <= frame#; i++) {
	/* no control over border colour */
	var = boxName//"_"//str(i);
	command = "."//screen//"."//var;
	width = box_width(frame[i]);
	height = box_height(frame[i]);
	/* xoutput("pack", command); */

	xoutput("place", command,
	    "-x", int(frame[i][1]-bdwidth),
	    "-y", int(frame[i][2]-bdwidth));

	xoutput(command, "configure",
	    "-width", int(frame[i][3]),
	    "-height", int(frame[i][4]),
	    "-bg", win[10],
	    "-fg", win[11],
	    "-bd", int(win[12]),
	    "-relief", win[17],
	    "-highlightthickness", thickness,
	    "-font", win[16]
	);
    /*    switch (win[13]) {   /*  TEXTBOX alignment always is left */
	  case 3: { alignment="center"; break; }
	  case 2: { alignment="right"; break; }
	  default: { alignment="left"; break; }
	}
	xoutput(command, "tag add everywhere 1.0 end -justify", alignment);
    */
    /*
	if (win# >= 18) {
	xoutput("set", var//"_name", win[18]);
	xoutput("set", var//"_box", i);
	}
    */
	if (win[18] != "") {
	xoutput("set", win[18]//"_boxName", "\""//command//"\"");
	}
	xoutput("refresh", command);

	if (win[14] != 0) {
	    xoutput("bind", command, "<Button> { interface \""//
		"~"//win[18]//"_mouse_"//
		str(i)//" = \\[%b,%T,%s,%x,%y];\\n\" }");
	    /* supposed no drag, so we don't need consider Button Release */
	     xoutput("bind", command, "<ButtonRelease> { interface \""//
		"~"//win[18]//"_mouse_"//
		str(i)//" = \\[%b,%T,%s,%x,%y];\\n\" }"); 
	    command_string = "\\\""//command//" get 1.0 end"//"\\\"";
	    xoutput("bind", command, "<KeyRelease> { interfaceTEXT \""//
		"~"//win[18]//"_TEXT_"//
		str(i)//" = tcl("//command_string//");\\n\" }");
	} else {
	    xoutput("bind", command, "<Button> {}");
	    xoutput("bind", command, "<ButtonRelease> {}");
	    xoutput("bind", command, "<Key> {}");
	    xoutput("bind", command, "<KeyRelease> {}");
	}
    }
}

proc display_screen : screen { DisplayScreen(&screen, DFscreen); }

func vp_in_use { para screen;
    auto s, t, i, j, winlist;
    s = [];
    winlist = `screen`;
    if (winlist == @)
	return "";
    for (i = winlist#; i > 0; --i) {
	if (winlist[i][5] != "") {
	    for (j = s#; j > 0; --j) {
		if (s[j] == winlist[i][5])
		    break;
	    }
	    if (j == 0)
		append s, winlist[i][5];
	}
    }
    t = s[1];
    for (i = s#; i > 1; --i)
	t = strcat(t, " ", s[i]);
    return t;
}
