# tkMOO, a MOO client for TCL/Tk.
# Copyright 1993, by Jay Carlson.
#
# This file may be freely distributed in unmodified form.
#
# This program is in alpha, and there are many rough edges.  It may be
# possible that a host could issue arbitrary commands to your TCL
# interpreter; I don't think this is possible, but I'm not a TCL expert.
#
# I'm sorry for the lack of documentation, but this is changing too fast
# to document, and I'm only distributing this under duress.
#
# You should set the telnet session to character mode to use M-x getVerb and
# M-x getText; I do this with ^]mode char RET.
#
# Invoke with tkmoo -f tkmoo.tk

wm title . "tkMOO v0.0"
wm iconname . "tkMOO"
source emacs.tk

text .t -relief sunken -bd 3 -yscrollcommand ".s set" -setgrid true \
	-width 80 -height 24 -padx 3 -pady 2 -wrap word
scrollbar .s -relief flat -command ".t yview"
frame .buttons
button .buttons.hangup -text "Hangup" -command {rawSend +++}

set newlineForm "cr"

frame .newline
radiobutton .newline.cr -relief flat -text "CR" -variable newlineForm -value cr
radiobutton .newline.lf -relief flat -text "LF" -variable newlineForm -value lf
pack append .newline .newline.cr {left padx 4} .newline.lf {left padx 4}
pack append .buttons .buttons.hangup {left padx 4} .newline {right padx 4}

entry .command -relief sunken -bd 3 

bind .command <Return> {
  set str [list [%W get]];
  catch "eval $str" result;
  %W delete @0 end;
  %W insert @0 $result;
  focus .t
}

bind .t <Mod1-x> { .command delete @0 end; focus .command }

pack append . .buttons {bottom fillx pady 4} .command {bottom fillx pady 4 padx 4} .s {right filly} .t {pady 2 expand fill}

set output [open "|telnet theory.cs.mankato.msus.edu 1709" "r+"]
fcntl $output NOBUF 1
fcntl $output NONBLOCK 1
nameMyPipe $output

.t insert insert ">"
.t mark set process {insert linestart}

proc rawSend line { global output; puts $output $line nonewline; flush $output }
proc sendLine line { 
  global output, newlineForm;
  if {$newlineForm == "cr"} {rawSend "$line\r"} {rawSend "$line\n"}
}

proc recLineHack {} {global hackLine; rec $hackLine}

set receiveState "main"
proc rec line { 
  global receiveState;
  set line [string trim $line "\r\n"];
  if {[regexp {prefixMOO([^ ]*)} $line throwaway bufname]} {
    set receiveState $bufname;
    return;
  }
  if {[regexp {suffixMOO([^ ]*)} $line throwaway bufname]} {
    set receiveState "main";
    return;
  }
  case $receiveState in {
    {main} {lineToMain $line}
    default {lineToSub $receiveState $line}
  };
}  

proc lineToMain line { 
  if {[regexp "^tkmootag: (.*)" $line throwaway tagLine]} {
    writeTextLine $tagLine .t process;
  } {
    .t insert process $line;
    .t insert process \n;
  }
  toInsert .t;
}

proc lineToSub {buffer line} {
  $buffer.t insert insert $line;
  $buffer.t insert insert \n;
  toInsert $buffer.t;
}
  

bind .t <Return> {
  set line [%W get {insert linestart+1c} {insert lineend}];
  sendLine $line;
  %W mark set insert {insert lineend};
  %W insert insert "\n>";
  %W mark set process {insert linestart};
  toInsert %W;
  }

proc makeWorkspace w {
  toplevel $w -class "Workspace";
  text $w.t -relief sunken -bd 3 -yscrollcommand "$w.s set" -setgrid true \
    -width 80 -height 24 -padx 3 -pady 2 -wrap char;
# -font clR5x10;
  scrollbar $w.s -relief flat -command "$w.t yview";
  frame $w.buttons;
  button $w.buttons.send -text "Send" -command "sendWorkspace $w";
  button $w.buttons.close -text "Close" -command "destroy $w";
  pack append $w.buttons $w.buttons.send {left padx 4} $w.buttons.close {right padx 4};
  entry $w.command -relief sunken -bd 3 
  bind $w.command <Return> {
    set str [list [%W get]];
    catch "eval $str" result;
    %W delete @0 end;
    %W insert @0 $result;
    focus $w.t;
  }
  bind $w.t <Mod1-x> "$w.command delete @0 end; focus $w.command";
  pack append $w $w.buttons {bottom fillx pady 4} $w.command {bottom fillx pady 4 padx 4} $w.s {right filly} $w.t {pady 2 expand fill};
}

set workspaceGensymCount 0
proc makeUnnamedWorkspace {} {
  global workspaceGensymCount;
  incr workspaceGensymCount;
  set name ".ws$workspaceGensymCount";
  makeWorkspace $name;
  return $name;
}

proc getVerb verbname {
  set w [makeUnnamedWorkspace];
  wm title $w $verbname;
  wm iconname $w $verbname;
  sendLine "PREFIX prefixMOO$w";
  sendLine "SUFFIX suffixMOO$w";
  sendLine [concat "@download " $verbname];
  sendLine "PREFIX";
  sendLine "SUFFIX";
}

proc getText commandname {
  set w [makeUnnamedWorkspace];
  wm title $w $commandname;
  wm iconname $w $commandname;
  sendLine "PREFIX prefixMOO$w";
  sendLine "SUFFIX suffixMOO$w";
  sendLine $commandname;
  sendLine "PREFIX";
  sendLine "SUFFIX";
}

proc sendWorkspace w {
  set last [$w.t index end];
  for {set n 1} {$n < $last} {incr n} {
    update;
    set line [$w.t get "$n.0" "$n.0 lineend"];
    sendLine $line;
  }
}

focus .t

proc car l { lindex $l 0 }
proc cdr l { concat [lrange $l 1 end] }

set lineTagList {}

proc writeText {section t mark} {
  global bar;
  set tagName [car $section];
  if {[cindex $tagName 0] == "~"} then {
    set start [$t index $mark];
    $t insert $mark [crange $section 3 [expr {[clength $section]-2}]];
    return $start;
  }
  set bar $section;
  set tagName [car [car $section]];
  return [writeText_$tagName [car $section] $t $mark];
}

proc writeText_bold {section t mark} {
  global lineTagList;
  set start [writeText [cdr $section] $t $mark];
  lappend lineTagList [list "bold" $start [$t index $mark]];
  return $start;
}
proc writeText_italic {section t mark} {
  global lineTagList;
  set start [writeText [cdr $section] $t $mark];
  lappend lineTagList [list "italic" $start [$t index $mark]];
  return $start;
}
proc writeText_header {section t mark} {
  global lineTagList;
  set start [writeText [cdr $section] $t $mark];
  lappend lineTagList [list "header" $start [$t index $mark]];
  return $start;
}

set tagGensymCount 0;
proc unnamedTag {} {
  global tagGensymCount;
  set name "g$tagGensymCount";
  incr tagGensymCount;
  return $name;
}

proc writeText_link {section t mark} {
  global lineTagList;
  set start [writeText [cdr [cdr $section]] $t $mark];
  set newTag [unnamedTag];
  set callback [car [cdr $section]];

# Oh boy, potential security hole here due to TCL parsing rules.  Just
# to be safe, rip all the backslashes out of the callback string to make
# sure we don't have any weird embedded characters (like, oh, say, a newline.)

  regsub -all {\\} $callback "" callback

  $t tag bind $newTag <3> "sendLine \"picktest $callback\"";
  $t tag configure $newTag -foreground black -background white -relief raised;

  lappend lineTagList [list $newTag $start [$t index $mark]];
  return $start;
}

proc writeText_hgroup {section t mark} {
  global lineTagList;
  set start [$t index $mark];
  foreach hbox [lrange $section 1 end] {
    writeText [list $hbox] $t $mark;
  }
  return $start;
}


# inefficient, fix later
proc applyLineTagList t {
  global lineTagList;
  foreach x $lineTagList {
    $t tag add [lindex $x 0] [lindex $x 1] [lindex $x 2];
  }
}

proc writeTextLine {section t mark} {
  global lineTagList;
  set lineTagList {};
  writeText $section $t $mark;
  $t insert $mark "\n";
  applyLineTagList $t;
  toInsert $t;
}

.t tag configure bold -font "-*-courier-bold-r-*-*-*-*-*-*-*-*-*-*"
.t tag configure italic -font "-*-courier-medium-o-*-*-*-*-*-*-*-*-*-*"
.t tag configure header -font "-*-helvetica-bold-r-*-*-14-*-*-*-*-*-*-*"
.t tag configure link -foreground black -background white -relief raised