#!/usr/bin/wish -f
#
# sam2p.tk
# by pts@fazekas.hu at Sat Apr  6 13:14:37 CEST 2002
#
# OK:  confirm quit
# Imp: don't update widgets when error in job file
# Imp: newline mangling when loading/saving files
# Imp: /DCT, ability to type literal MiniPS code to an `entry'
# Imp: Perl parser should signal error on <hex123> etc.
# Imp: B2Press + Move + B2Release; inserts twice
# Imp: initial `focus'
# Imp: default values
# Imp: tk-start with sh
# Imp: to center of the resized window
# Imp: tooltips (mouse button 2, 3)
# Imp: less vertical padding
# Imp: really detect what kind of -*-fixed fonts we have
# Dat: TCL 8.0 doesn't have `string equal'
# Dat: never do `.text mark set sel.first 1.5', beacuse this will override tag `sel'
# Dat: `entry' widgets don't accept "insert + 1 chars" as a character index
# Dat: tag-parser treats comments as legal tokens
# Dat: <Insert> matches <Shift-Insert>, <Key-Insert> does not.
# Dat: <Motion> is mouse motion event over the sub-window
# Dat: <Enter> and <Leave> is an event sent when
# SUXX: Tcl: 8.0 doesn't have [string map ...]
# SUXX: Tk: radio and checkbuttons cannot be made smaller or larger
# SUXX: Tk: color for -relief cannot be specified
# SUXX: Tk: on UNIX, Tk converts "Times New Roman" to "times" unless specified as "-*-times new roman-*-*-*-*-*-*-*-*-*-*-iso8859-1"
# SUXX: Tk: .text cursor width cannot be extended to the right only (not to the left)
# SUXX: Tk: .text cannot show the last line on the top unless first==last
# SUXX: Tk bug: echo `bind . <ButtonRelease-2> {put got}' | wish
#       Test: 1. press button2 2. move mouse 3. release button 4. move mouse
#       `got' is printed twice. Strange: works fine with button 1 and 3.
#       Even the following doesn't help:
#       echo `bind . <B2-ButtonRelease-2> {put got}' | wish
#       Even event parameters are useless to distinguish normal and duplicate
#       events. This is a bug even on all other X11 clients. May be a GPM bug
#       or an xlib bug??

# puts [file type alma]

proc pts_PATH_sep {} {
  global tcl_platform
  if {0==[string compare windows $tcl_platform(platform)]} {return ;}
  return :
  # Imp: `macintosh'
}

proc pts_read_ok {filename} {
  if {0==[string length $filename]} {return 0}
  if {[catch {set t [file type $filename]}]} {
    if {[catch {set t [file type [file dirname $filename]]}]} {return !d}
    return !e
  }
  if {0!=[string compare $t file]} {return !f}
  if {![file readable $filename]} {return !r}
  return OK
}

proc pts_write_ok {filename} {
  if {0==[string length $filename]} {return 0}
  if {[catch {set t [file type $filename]}]} {
    if {[catch {set t [file type [set dir [file dirname $filename]]]}]} {return !d}
    if {0==[string compare $t directory] && [file writable $dir]} {return ++}
    return !dw
  }
  if {0!=[string compare $t file]} {return !f}
  if {![file writable $filename]} {return !w}
  return OK
}

proc pts_direct_bindtags {w} {
  #** Moves all binds associated with widget $w to directly widget itself.
  ## Half idea: bindtags $w "$w [bindtags $w]"
  # Dat: this assumes [lindex [bindtags $w] 0] == $w
  foreach tag [bindtags $w] {
    if {0!=[string compare $tag $w]} {
      foreach evtseq [bind $tag] {
        bind $w $evtseq [bind $w $evtseq]\n[bind $tag $evtseq]
      }
    }
  }
  bindtags $w $w
}

proc pts_readonly {w} {
  #** @param $w text or entry
  #** Makes the specified widget read-only. [$w configure -state disabled]
  #** is not OK, because it makes the insertion cursor invisible.
  pts_direct_bindtags $w
  # SUXX: cannot be avoided. Example: we must disable <Key> (typing letters),
  # but allow <Key-Left>
  bind $w <Meta-Key-d> break
  bind $w <Meta-Key-f> break
  bind $w <Meta-Key-Delete> break
  bind $w <Meta-Key-BackSpace> break
  bind $w <Control-Key-d> break
  bind $w <Control-Key-i> break
  bind $w <Control-Key-k> break
  bind $w <Control-Key-h> break
  bind $w <Control-Key-t> break
  bind $w <Key-BackSpace> break
  bind $w <Key-Delete> break
  bind $w <Key-Return> break
  bind $w <Key-KP_Enter> break
  bind $w <Key> break
  bind $w <<PasteSelection>> break
  bind $w <<Paste>> break
  bind $w <<Cut>> break
  bind $w <<Clear>> break
}

proc pts_readonly_color {w} {
  #** Calls [pts_readonly $w], and sets widget colors etc. to make the user
  #** see that it's a read-only widget.
  pts_readonly $w
  $w configure -background [[winfo toplevel $w] cget -background] -relief sunken
}

proc pts_listrev {list} {
  # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
  set i [llength $list]
  set ret {}
  while {$i>0} {incr i -1; lappend ret [lindex $list $i]}
  return $ret
}

proc pts_listrev1 {list} {
  #** Chops the 1st element of list, and returns the reverse of the rest.
  # by pts@fazekas.hu at Sun Apr 21 21:08:20 CEST 2002
  set i [llength $list]
  set ret {}
  while {$i>1} {incr i -1; lappend ret [lindex $list $i]}
  return $ret
}

## puts [pts_listrev {1 2 {3 4}}]; exit

set pts_unknown_font [font actual ..unknown..]
proc pts_has_font {f} {
  # by pts@fazekas.hu at Sat Apr  6 16:26:24 CEST 2002
  # This is rather dirty, because there is no clean way to test whether a font
  # exists in Tk.
  #** return 1 or 0
  global pts_unknown_font
  if {0==[string compare fixed $f]} {return 1}
  if {[string match -*-fixed-* $f]} {return 1} ;# Imp: first `*' shouldn't contain `-'
  # Dat: pts_unknown_font is `fixed' on UNIX systems...
  if {0==[string compare $pts_unknown_font [font actual $f]]} {return 0}
  return 1
}

proc pts_last_font {first args} {
  #** @param first,args list of font names (suitable arg for `-font' of widgets)
  #** @return the last font name that is available
  for {set i [llength $args]} {$i>0} {} {
    incr i -1
    if {[pts_has_font [set f [lindex $args $i]]]} {return $f}
  }
  return $first
}

proc pts_fix_shift_tab {} {
  # by pts@fazekas.hu at Sat Apr  6 15:22:58 CEST 2002
  set tmp [bind all <Shift-Key-Tab>]
  ## puts $tmp
  if {[string length $tmp]==0} {set tmp {tkTabToWindow [tk_focusPrev %]}}
  bind all <Shift-Key-Tab> $tmp
  catch {bind all <Key-ISO_Left_Tab> $tmp}
  # ^^^ Dat: catch is here because some systems don't have ISO_Left_Tab
}

proc pts_fix_one_tab {wPath} {
  # by pts@fazekas.hu at Sat Apr  6 15:38:43 CEST 2002
  # pts_fix_shift_tab() should be called.
  bind $wPath <Key-Tab> "[bind all <Key-Tab>]; break"
  bind $wPath <Shift-Key-Tab> "[bind all <Shift-Key-Tab>]; break"
  bind $wPath <Key-ISO_Left_Tab> "[bind all <Shift-Key-Tab>]; break"
}

proc pts_tag_set_first {w tagName index} {
  if {[$w tag nextrange $tagName 1.0 end] != ""} {
    if {[$w compare $index < $tagName.last]} {
      if {[$w compare $index < $tagName.first]} \
        {$w tag add    $tagName $index $tagName.first} \
        {$w tag remove $tagName $tagName.first $index}
    } {
      set tmp [$w index $tagName.last]
      $w tag remove $tagName 1.0 end
      $w tag add $tagName $tmp $index
    }
  }
}
proc pts_tag_set_last {w tagName index} {
  if {[$w tag nextrange $tagName 1.0 end] != ""} {
    if {[$w compare $index > $tagName.first]} {
      if {[$w compare $index > $tagName.last]} \
        {$w tag add    $tagName $tagName.last $index} \
        {$w tag remove $tagName $index $tagName.last}
    } {
      set tmp [$w index $tagName.first]
      $w tag remove $tagName 1.0 end
      $w tag add $tagName $index $tmp
    }
  }
}

proc pts_paste {w} {catch {
  set tmp [$w index insert]
  $w insert insert [selection get -displayof $w -selection CLIPBOARD]
  $w tag remove sel 0.1 end
  $w tag add sel $tmp insert
}}

proc pts_text_insert_newline {w autoindent} {
  #** Doesn't respect overstrike mode (neither does Turbo Pascal).
  #** Does auto-indenting of spaces and tabs.
  if {[$w cget -state] == "disabled"} {return}
  if $autoindent {
    if {![string length [set tmp [$w search -regexp "\[^ \t]" {insert linestart} {insert lineend}]]]} {set tmp "insert lineend"}
    $w insert insert \n[$w get {insert linestart} $tmp]
  } {$w insert insert \n}
  $w see insert
}
proc pts_text_autoindent {w bool} {
  if $bool {} ;# early error message if bool is malformed
  bind $w <Return> "pts_text_insert_newline %W $bool; break"
}

# vvv Overriding text.tcl, so we won't clobber the visible selection.
proc tkTextInsert {w s} {
  if {($s == "") || ([$w cget -state] == "disabled")} {return}
  if {[string match "* 1" [bind $w <Insert>]]} {
    # vvv in overstrike mode, overstrike only in the middle of the line
    if {[$w compare insert != "insert lineend"]} {$w delete insert}
  }
  $w insert insert $s; $w see insert
}

#proc pts_text_insert {w s overstrike} {
#  if {($s == "") || ([$w cget -state] == "disabled")} {return}
#  set tmp [$w index insert]
#  # vvv in overstrike mode, overstrike only in the middle of the line
#  if {$overstrike && [$w compare insert != "insert lineend"]} {$w delete insert}
#  $w insert insert $s; $w see insert
#}
proc pts_text_overstrike {w bool} {
  #puts [$w configure -insertontime]
  #puts [$w configure -insertofftime]
  if {$bool} {$w configure -insertofftime 0} \
             {$w configure -insertofftime [lindex [$w configure -insertofftime] 3]}
  # Dat: we cannot override the widget's <KeyPress> method here, because then
  #      we won't be able to receive cursor movement etc. events, see docs in
  #      bindtags(n) and bind(n). So support must be built into tkTextInsert,
  #      since `bind Text <KeyPress> {tkTextInsert %W %A}' is the default.
  # bind Text <KeyPress> "pts_text_insert %W %A $bool; break ;#alma"
  focus .; focus $w ;# trick to avoid non-reblinking bug in Tk8.0 Linux.
}
proc pts_text_toggle_overstrike {w bool} {
  if {$bool} {set bool 0} {set bool 1}
  pts_text_overstrike $w $bool
  bind $w <Insert> "pts_text_toggle_overstrike %W $bool"
}
proc pts_text_auto_overstrike {w bool} {
  #** Sets overstrike mode, and binds Insert to do the switching. A
  #** non-blinking cursor indicates overstrike mode. (Tk is too stupid to draw
  #** a block cursor.)
  #** @param w a text widget
  pts_text_overstrike $w $bool
  bind $w <Key-Insert> "pts_text_toggle_overstrike %W $bool"
}

# redefine tkScrollButtonDown, so it won't `sunken' the slider
# (se tcl8.2/scrlbar.tcl)
proc tkScrollButtonDown {w x y} {
  global tkPriv
  set tkPriv(relief) [$w cget -activerelief]
  if {0==[string compare slider [set element [$w identify $x $y]]]} {
    tkScrollStartDrag $w $x $y
  } else {
    $w configure -activerelief sunken
    tkScrollSelect $w $element initial
  }
}
proc tkScrollButton2Down {w x y} {
  global tkPriv
  set element [$w identify $x $y]
  if {0==[string compare $element arrow1]||0==[string compare $element arrow2]} {
    tkScrollButtonDown $w $x $y
    return
  }
  tkScrollToPos $w [$w fraction $x $y]
  set tkPriv(relief) [$w cget -activerelief]
  update idletasks
  # $w configure -activerelief sunken
  $w activate slider
  tkScrollStartDrag $w $x $y
}

option add *Dialog.msg.wrapLength 3i widgetDefault
proc pts_message_box {args} {
    global sa_normfont
    #** similar to tkMessageBox; ignores platform's native MessageBox support.
    global tkPriv tcl_platform

    set w tkPrivMsgBox
    upvar #0 $w data

    #
    # The default value of the title is space (" ") not the empty string
    # because for some window managers, a
    #		wm title .foo ""
    # causes the window title to be "foo" instead of the empty string.
    #
    set specs {
	{-default "" "" ""}
        {-icon "" "" "info"}
        {-message "" "" ""}
        {-parent "" "" .}
        {-title "" "" " "}
        {-type "" "" "ok"}
    }

    tclParseConfigSpec $w $specs "" $args

    if {[lsearch {info warning error question} $data(-icon)] == -1} {
	error "invalid icon \"$data(-icon)\", must be error, info, question or warning"
    }
    if {$tcl_platform(platform) == "macintosh"} {
	if {$data(-icon) == "error"} {
	    set data(-icon) "stop"
	} elseif {$data(-icon) == "warning"} {
	    set data(-icon) "caution"
	} elseif {$data(-icon) == "info"} {
	    set data(-icon) "note"
	}
    }

    if {![winfo exists $data(-parent)]} {
	error "bad window path name \"$data(-parent)\""
    }

    switch -- $data(-type) {
	abortretryignore {
	    set buttons {
		{abort  -width 6 -text Abort -under 0}
		{retry  -width 6 -text Retry -under 0}
		{ignore -width 6 -text Ignore -under 0}
	    }
	}
	ok {
	    set buttons {
		{ok -width 6 -text OK -under 0}
	    }
	    if {$data(-default) == ""} {
		set data(-default) "ok"
	    }
	}
	okcancel {
	    set buttons {
		{ok     -width 6 -text OK     -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	retrycancel {
	    set buttons {
		{retry  -width 6 -text Retry  -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	yesno {
	    set buttons {
		{yes    -width 6 -text Yes -under 0}
		{no     -width 6 -text No  -under 0}
	    }
	}
	yesnocancel {
	    set buttons {
		{yes    -width 6 -text Yes -under 0}
		{no     -width 6 -text No  -under 0}
		{cancel -width 6 -text Cancel -under 0}
	    }
	}
	default {
	    error "invalid message box type \"$data(-type)\", must be abortretryignore, ok, okcancel, retrycancel, yesno or yesnocancel"
	}
    }

    if {[string compare $data(-default) ""]} {
	set valid 0
	foreach btn $buttons {
	    if {![string compare [lindex $btn 0] $data(-default)]} {
		set valid 1
		break
	    }
	}
	if {!$valid} {
	    error "invalid default button \"$data(-default)\""
	}
    }

    # 2. Set the dialog to be a child window of $parent
    #
    #
    if {[string compare $data(-parent) .]} {
	set w $data(-parent).__tk__messagebox
    } else {
	set w .__tk__messagebox
    }

    # 3. Create the top-level window and divide it into top
    # and bottom parts.

    catch {destroy $w}
    toplevel $w -class Dialog
    wm title $w $data(-title)
    wm iconname $w Dialog
    wm protocol $w WM_DELETE_WINDOW { }
    wm transient $w $data(-parent)
    if {$tcl_platform(platform) == "macintosh"} {
	unsupported1 style $w dBoxProc
    }

    frame $w.bot
    pack $w.bot -side bottom -fill both
    frame $w.top
    pack $w.top -side top -fill both -expand 1
    if {$tcl_platform(platform) != "macintosh"} {
	$w.bot configure -relief raised -bd 1
	$w.top configure -relief raised -bd 1
    }

    # 4. Fill the top part with bitmap and message (use the option
    # database for -wraplength so that it can be overridden by
    # the caller).

    label $w.msg -justify left -text $data(-message)
    #catch {$w.msg configure -font \
    #		-Adobe-Times-Medium-R-Normal--*-180-*-*-*-*-*-*
    #}
    pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
    if {$data(-icon) != ""} {
	label $w.bitmap -bitmap $data(-icon)
	pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
    }

    # 5. Create a row of buttons at the bottom of the dialog.

    set i 0
    foreach but $buttons {
	set name [lindex $but 0]
	set opts [lrange $but 1 end]
	if {![string compare $opts {}]} {
	    # Capitalize the first letter of $name
	    set capName \
		[string toupper \
		    [string index $name 0]][string range $name 1 end]
	    set opts [list -text $capName]
	}

	eval button $w.$name $opts -font $sa_normfont -borderwidth 1 -pady 2 -underline 0  -command [list "set tkPriv(button) $name"]

	if {![string compare $name $data(-default)]} {
	    $w.$name configure -default active
	}
	pack $w.$name -in $w.bot -side left -expand 1 \
	    -padx 3m -pady 2m

	# create the binding for the key accelerator, based on the underline
	#
	set underIdx [$w.$name cget -under]
	if {$underIdx >= 0} {
	    set key [string index [$w.$name cget -text] $underIdx]
	    bind $w <Alt-[string tolower $key]>  "$w.$name invoke"
	    bind $w <Alt-[string toupper $key]>  "$w.$name invoke"
	}
	incr i
    }

    # 6. Create a binding for <Return> on the dialog if there is a
    # default button.

    if {[string compare $data(-default) ""]} {
	bind $w <Return> "tkButtonInvoke $w.$data(-default)"
    }

    # 7. Withdraw the window, then update all the geometry information
    # so we know how big it wants to be, then center the window in the
    # display and de-iconify it.

    wm withdraw $w
    update idletasks
    set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx [winfo parent $w]]}]
    set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
	    - [winfo vrooty [winfo parent $w]]}]
    wm geom $w +$x+$y
    wm deiconify $w

    # 8. Set a grab and claim the focus too.

    set oldFocus [focus]
    set oldGrab [grab current $w]
    if {$oldGrab != ""} {
	set grabStatus [grab status $oldGrab]
    }
    grab $w
    if {[string compare $data(-default) ""]} {
	focus $w.$data(-default)
    } else {
	focus $w
    }

    # 9. Wait for the user to respond, then restore the focus and
    # return the index of the selected button.  Restore the focus
    # before deleting the window, since otherwise the window manager
    # may take the focus away so we can't redirect it.  Finally,
    # restore any grab that was in effect.

    tkwait variable tkPriv(button)
    catch {focus $oldFocus}
    destroy $w
    if {$oldGrab != ""} {
	if {$grabStatus == "global"} {
	    grab -global $oldGrab
	} else {
	    grab $oldGrab
	}
    }
    return $tkPriv(button)
}


# ---

proc sa_radio {framePath variable value labelCaption args} {
  global $variable sa_normfont
  # Imp: use -text
  set $variable ""
  frame $framePath
  lappend args -variable $variable -value $value -indicatoron true -borderwidth 1
  # lappend args -value $value -indicatoron true -borderwidth 1
  eval "radiobutton $framePath.r $args"

  $framePath.r configure -activebackground [$framePath.r cget -background]
  label $framePath.l -text $labelCaption -font $sa_normfont ;# Imp: Why doesn't -anchor work??
  bind $framePath.l <ButtonRelease-1> "$framePath.r invoke"
  pack $framePath.r $framePath.l -side left
  # bind $framePath.r <Key-ISO_Left_Tab> {tkTabToWindow [tk_focusPrev %W]}
}
#proc sa_radio_pack {framePath} {}
proc sa_check {wPath variable labelCaption args} {
  global sa_boldfont
  # Imp: clicking to the right from the caption shouldn't have effect
  lappend args -font $sa_boldfont -text $labelCaption -anchor w -borderwidth 1 -variable $variable
  eval "checkbutton $wPath $args"
  $wPath configure -activebackground [$wPath cget -background]
}

proc sa_check_update {wPath variable labelCaption} {
  sa_check $wPath $variable $labelCaption -command "update_check $variable $wPath"
}

proc sa_int {framePath variable labelCaption entryWidth args} {
  # Imp: clicking to the right from the caption shouldn't have effect
  # Imp: check for int...
  global sa_normfont sa_boldfont
  frame $framePath ;# may already exist??
  label $framePath.l -text $labelCaption -font $sa_boldfont
  lappend args -relief sunken -width $entryWidth -font $sa_normfont \
    -borderwidth 1 -foreground black -background white \
    -selectbackground yellow -selectforeground black -selectborderwidth 0
  eval "entry $framePath.i $args"
  pack $framePath.l $framePath.i -side left
  # $framePath configure -activebackground [$framePath cget -background]
}

proc sa_w_text {args} {
  lappend args -relief solid -highlightcolor gray30 \
    -borderwidth 1 -foreground black -background white \
    -selectbackground gray85 -selectforeground black -selectborderwidth 0
  eval "text $args"
}

proc sa_w_entry {args} {
  lappend args -relief sunken -borderwidth 1 -foreground black -background white \
    -selectbackground yellow -selectforeground black -selectborderwidth 0
  eval "entry $args"
}

set sa_frame 0
proc sa_vframe {parentPath} {
  #** Creates and packs vertical frame, which is 5 pixel high
  global sa_frame
  set w $parentPath.saf[incr sa_frame]
  frame $w -height 5 -width 1
  pack $w -fill x
}

# vvv The mouse must be used to insert visible selection (of other apps)
bind Text <Insert> {}

bind Text <B2-Motion> {}
bind Text <Button-2> {}
# puts T[bind Text]T


# vvv allow the well-known (almost indrustry standard) Windows/Borland/GTK
#     cliboard key bindings on all platforms
event add <<Cut>> <Control-Key-x> <Shift-Key-Delete>
event add <<Copy>> <Control-Key-c> <Control-Key-Insert>
event add <<Paste>> <Control-Key-v> <Shift-Key-Insert>
# event add <<PasteSelection>> <ButtonRelease-2>
# Dat: <<Paste>> is normal, <Control-Key-v> paste, which requires prior
#      <Control-Key-c>. Works across applications.
# Dat: <<PasteSelection>> is xterm/netscape-like paste, which does not
#      require <Control-Key-c>. Also works across applications.

# vvv this <<Paste>> deletes current selection even on UNIX; but we don't like that
# bind Text <<Paste>> {catch {%W delete sel.first sel.last}; catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
# vvv this <<Paste>> leaves visible selection intact
# bind Text <<Paste>> {catch {%W insert insert [selection get -displayof %W -selection CLIPBOARD]}}
# vvv this <<Paste>> sets visible selection to the newly pasted data
bind Text <<Paste>> {pts_paste %W}

# vvv our <<PasteSelection>> doesn't move the cursor (like xterm, unlike Motif)
bind Text <<PasteSelection>> {pts_text_paste_selection %W %x %y}

bind Text <B2-Motion> {}
bind Text <Button-2> {}

# bind Text <ButtonRelease-2> {puts evt; pts_text_paste_selection %W %x %y}
#catch {
#event delete <<PasteSelection>> <ButtonRelease-2>
#}
#catch {
#event add <<PasteSelection>> <B2-ButtonRelease-2>
#event add <<PasteSelection>> <Button-2>
#}

# puts EI[event info <<PasteSelection>>]
# puts A[event info <<PasteSelection>>]BN

proc pts_text_paste_selection {w x y} {
  #** If has focus, than pastes visible selection to the unchanged cursor
  #** position; otherwise claims focus and sets cursor position to mouse.
  if {0==[string compare $w [focus -displayof $w]]} {
    catch {$w insert insert [selection get -displayof $w]}
    if {0==[string compare normal [$w cget -state]]} {focus $w}
  } {$w mark set insert [tkTextClosestGap $w $x $y]; focus $w}
}


# vvv overrides text.tcl, doesn't clobber the selection.
bind Text <1> {tkTextButton1 %W %x %y}

proc ptsTextDelLn W {
  # puts [%W index {insert linestart}]..[%W index {insert lineend + 1 chars}]
  if {[$W compare {insert lineend + 1 chars} == end]} {
    # <Control-y> in the last line must not move the cursor
    $W delete {insert linestart} {insert lineend}
  } {
    $W delete {insert linestart} {insert lineend + 1 chars}
  }
}

# vvv Overriding text.tcl, so we won't clobber the visible selection when moving
#     the cursor or just inserting
proc tkTextSetCursor {w pos} {
  if {[$w compare $pos == end]} {set pos {end - 1 chars}}
  $w mark set insert $pos
  # $w tag remove sel 1.0 end
  $w see insert
}

# vvv Overriding text.tcl, so PageUp and PageDown will jump within the page.
proc tkTextScrollPages {w count} {
  set tmp [expr {([$w cget -height]-1)*$count}]
  $w yview scroll $tmp units
  return "insert + $tmp lines"
}

# vvv Overrides text.tcl with Turbo Pascal-style Shift+Arrow selection:
#     Shift+Movement-key, when moved _from_ either end of the selection,
#     updates that end appropriately. Otherwise, it clobbers the selection,
#     and creates a new selection from the current `insert' position to the
#     position the cursor is moved to.
proc tkTextKeySelect {w newIndex} {
  # puts "[$w index insert] -> [$w index $newIndex] ([$w index end])"
  if {[$w compare end == $newIndex]} {set newIndex "end - 1 char"}
  $w mark set anchor insert
  if {[$w tag nextrange sel 1.0 end] == ""} {
    if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
  } { # already have a selection
    # puts "a=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
    if {[$w compare insert == sel.first]} {pts_tag_set_first $w sel $newIndex} \
    elseif {[$w compare insert == sel.last]} {pts_tag_set_last $w sel $newIndex} \
    { $w tag remove sel 1.0 end
      if {[$w compare $newIndex < insert]} {$w tag add sel $newIndex insert} {$w tag add sel insert $newIndex}
    }
  }
  $w mark set insert $newIndex; $w see insert
  update idletasks
  # puts "[$w tag ranges sel]"
  # puts "b=[$w index sel.first]-[$w index sel.last] i=[$w index insert]"
}

# Imp: ^K B: Control-Space, ^K K: Control-Shift-Space

bind Text <Control-Key-y> {ptsTextDelLn %W}
bind Text <Control-Key-Y> [bind Text <Control-Key-y>]
bind Text <Control-Key-d> {if {[%W compare {insert + 1 chars} != end]} {%W delete insert}}
# ^^^ ensures that pressing `Delete' on the last empty line is a no-op
bind Text <Key-Delete> [bind Text <Control-Key-d>]
# ^^^ don't clobber visible selection
bind Text <Key-BackSpace> {if {[%W compare insert != 1.0]} {%W delete insert-1c; %W see insert}}
# ^^^ don't clobber visible selection

proc pts_entry_Delete {w} {
  set i 0
  set j -1
  set k -1
  set i [$w index insert]
  catch {set j [$w index sel.first]}
  catch {set k [$w index sel.last]}
  if {0==[string compare $i $j] || 0==[string compare $i $k]} \
    {$w delete sel.first sel.last} \
    {$w delete insert}
}

bind Entry <B2-Motion> {}
bind Entry <Button-2> {}

# vvv Overrides entry.tcl, so it won't clobber the selection.
bind Entry <Key-Delete> {pts_entry_Delete %W}
# vvv Overrides entry.tcl, so it won't clobber the selection.
bind Entry <Control-Key-d> {pts_entry_Delete %W}
bind Entry <Control-Key-i> {%W insert insert \t}

# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntrySetCursor {w pos} {$w icursor $pos; tkEntrySeeInsert $w}
# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntryInsert {w s} {if {[string length $s]} {
  $w insert insert $s
  tkEntrySeeInsert $w
}}
# vvv Overrides entry.tcl with Turbo Pascal look and feel.
proc tkEntryKeySelect {w new} {
  if {[$w selection present]} {
    set i [$w index insert]
    if {[$w index sel.first]==$i}    {$w selection from sel.last} \
    elseif {[$w index sel.last]==$i} {$w selection from sel.first} \
    {$w selection from insert}
  } {$w selection from insert}
  $w selection to $new
  $w icursor $new
  # tkEntrySeeInsert will be called by our caller.
}
# vvv Overrides entry.tcl, so it won't clobber the selection.
proc tkEntryBackspace w {
  set x [expr {[$w index insert] - 1}]
  if {$x >= 0} {$w delete $x}
  if {[$w index @0] >= [$w index insert]} {
    set range [$w xview]
    set left [lindex $range 0]
    set right [lindex $range 1]
    $w xview moveto [expr {$left - ($right - $left)/2.0}]
  }
}

proc pts_entry_paste_selection {w x y} {
  #** If has focus, than pastes visible selection to the unchanged cursor
  #** position; otherwise claims focus and sets cursor position to mouse.
  if {0==[string compare $w [focus -displayof $w]]} {
    catch {$w insert insert [selection get -displayof $w]}
    if {0==[string compare normal [$w cget -state]]} {focus $w}
  } {$w icursor [tkEntryClosestGap $w $x]; focus $w}
}
bind Entry <<PasteSelection>> {pts_entry_paste_selection %W %x %y}
bind Entry <Insert> {} ;# <Shift-Insert> already OK.


# vvv override tk.tcl, so it won't select the whole Entry when tab is pressed}
proc tkTabToWindow w {focus $w}

# ---

# vvv Imp: improve this on Windows
set sa_normfont [pts_last_font \
  system variable helvetica \
  arial {arial -12 normal} \
  -adobe-helvetica-medium-r-normal--11-*-100-100-*-*-iso8859-* \
  -adobe-helvetica-medium-r-normal--12-*-75-75-*-*-iso8859-* \
  sansserif dialog}]
set sa_boldfont [pts_last_font \
  sansserif system variable helvetica \
  arial {arial -12 bold} \
  -adobe-helvetica-bold-r-normal--12-*-75-75-*-*-iso8859-1 \
  -adobe-helvetica-bold-r-normal--11-80-100-100-p-60-iso8859-1 \
  dialogb]
set sa_fixfont [pts_last_font \
  fixed systemfixed fixsedsys monospaced monospace \
  -*-fixed-*-*-*--13-*-*-*-*-*-iso8859-1 \
  -misc-fixed-medium-r-semicondensed--13-*-75-75-*-*-iso8859-1 \
  6x13]
# puts sa_normfont=$sa_normfont; puts sa_boldfont=$sa_boldfont
# Dat: 100 DPI, 14-point Helvetica is too large, 11-point is somewhat small

option add *Dialog.msg.font $sa_normfont ;# respected
option add *Dialog.Button*font $sa_boldfont ;# respected

wm title . {sam2p Job Editor}
set tk_StrictMotif 0
pts_fix_shift_tab
# . configure -bg red


frame .gtop

set g .gtop.g0
frame $g

label $g.lFileFormat -text FileFormat -anchor w -font $sa_boldfont
sa_radio $g.fPSL1 FileFormat PSL1 "PS L1" -command {update_radio FileFormat PSL1}
sa_radio $g.fPSLC FileFormat PSLC "PS LC" -command {update_radio FileFormat PSLC}
sa_radio $g.fPSL2 FileFormat PSL2 "PS L2" -command {update_radio FileFormat PSL2}
sa_radio $g.fPSL3 FileFormat PSL3 "PS L3" -command {update_radio FileFormat PSL3}
sa_radio $g.fPDFB10 FileFormat PDFB1.0 "PDF B 1.0" -command {update_radio FileFormat PDFB1.0}
sa_radio $g.fPDFB12 FileFormat PDFB1.2 "PDF B 1.2" -command {update_radio FileFormat PDFB1.2}
sa_radio $g.fPDF10 FileFormat PDF1.0 "PDF 1.0" -command {update_radio FileFormat PDF1.0}
sa_radio $g.fPDF12 FileFormat PDF1.2 "PDF 1.2" -command {update_radio FileFormat PDF1.2}
sa_radio $g.fGIF89a FileFormat GIF89a "GIF 89a" -command {update_radio FileFormat GIF89a}
sa_radio $g.fEmpty FileFormat Empty Empty -command {update_radio FileFormat Empty}
sa_radio $g.fMeta FileFormat Meta Meta -command {update_radio FileFormat Meta}
sa_radio $g.fPNM FileFormat PNM PNM -command {update_radio FileFormat PNM}
sa_radio $g.fPAM FileFormat PAM PAM -command {update_radio FileFormat PAM}
sa_radio $g.fPIP FileFormat PIP PIP -command {update_radio FileFormat PIP}
sa_radio $g.fJPEG FileFormat JPEG JPEG -command {update_radio FileFormat JPEG}
sa_radio $g.fTIFF FileFormat TIFF TIFF -command {update_radio FileFormat TIFF}
sa_radio $g.fPNG FileFormat PNG PNG -command {update_radio FileFormat PNG}

pack $g.lFileFormat -fill x
pack $g.fPSL1 $g.fPSLC $g.fPSL2 $g.fPSL3 $g.fPDFB10 $g.fPDFB12 $g.fPDF10 $g.fPDF12 $g.fGIF89a \
 $g.fEmpty $g.fMeta $g.fPNM $g.fPAM $g.fPIP $g.fJPEG $g.fTIFF $g.fPNG -fill x
frame $g.pFileFormat -height 5 -width 1
pack $g.pFileFormat -fill x


set g .gtop.g1
frame $g

label $g.lSampleFormat -text SampleFormat -anchor w -font $sa_boldfont
sa_radio $g.fOpaque SampleFormat Opaque Opaque -command {update_radio SampleFormat Opaque}
sa_radio $g.fTransparent SampleFormat Transparent Transparent -command {update_radio SampleFormat Transparent}
sa_radio $g.fGray1 SampleFormat Gray1 "Gray 1" -command {update_radio SampleFormat Gray1}
sa_radio $g.fIndexed1 SampleFormat Indexed1 "Indexed 1" -command {update_radio SampleFormat Indexed1}
sa_radio $g.fMask SampleFormat Mask Mask -command {update_radio SampleFormat Mask}
sa_radio $g.fTransparent2 SampleFormat Transparent2 "Transparent 2" -command {update_radio SampleFormat Transparent2}
sa_radio $g.fGray2 SampleFormat Gray2 "Gray 2" -command {update_radio SampleFormat Gray2}
sa_radio $g.fIndexed2 SampleFormat Indexed2 "Indexed 2" -command {update_radio SampleFormat Indexed2}
sa_radio $g.fTransparent4 SampleFormat Transparent4 "Transparent 4" -command {update_radio SampleFormat Transparent4}
sa_radio $g.fRGB1 SampleFormat RGB1 "RGB 1" -command {update_radio SampleFormat Rgb1}
sa_radio $g.fGray4 SampleFormat Gray4 "Gray 4" -command {update_radio SampleFormat Gray4}
sa_radio $g.fIndexed4 SampleFormat Indexed4 "Indexed 4" -command {update_radio SampleFormat Indexed4}
sa_radio $g.fTransparent8 SampleFormat Transparent8 "Transparent 8" -command {update_radio SampleFormat Transparent8}
sa_radio $g.fRgb2 SampleFormat Rgb2 "RGB 2" -command {update_radio SampleFormat Rgb2}
sa_radio $g.fGray8 SampleFormat Gray8 "Gray 8" -command {update_radio SampleFormat Gray8}
sa_radio $g.fIndexed8 SampleFormat Indexed8 "Indexed 8" -command {update_radio SampleFormat Indexed8}
sa_radio $g.fRgb4 SampleFormat Rgb4 "RGB 4" -command {update_radio SampleFormat Rgb4}
sa_radio $g.fRgb8 SampleFormat Rgb8 "RGB 8" -command {update_radio SampleFormat Rgb8}
pack $g.lSampleFormat -fill x
pack $g.fOpaque $g.fTransparent $g.fGray1 $g.fIndexed1 $g.fMask $g.fTransparent2 $g.fGray2 $g.fIndexed2 $g.fTransparent4 \
 $g.fRGB1 $g.fGray4 $g.fIndexed4 $g.fTransparent8 $g.fRgb2 $g.fGray8 \
 $g.fIndexed8 $g.fRgb4 $g.fRgb8 -fill x
frame $g.pSampleFormat -height 5 -width 1
pack $g.pSampleFormat -fill x

set g .gtop.g2
frame $g

proc find_val_range {key} {
  #** @param key for example "/Compression", "/InputFile", of type tKey
  #** @return "" or [beg end] abs.index of the value associated with that key
  #**   (may span multiple tokens)
  global jtw ;# text widget containing the tagged job file
  set end 1.0
  while {[llength [set lst [$jtw tag nextrange tKey $end]]]} {
    set beg [lindex $lst 0]
    set end [lindex $lst 1]
    ##puts "key=<[$jtw get $beg $end]>"
    set ikey [$jtw get $beg $end]
    if {0==[string compare $ikey $key]} {

      ## puts prev=[$jtw tag prevrange tAny $end]
      set lst [$jtw tag prevrange tAny $end]
      if {0!=[llength $lst] && [$jtw compare [lindex $lst 0] < $end]
                            && [$jtw compare $end < [lindex $lst 1]]} {
        set lst [list $end [lindex $lst 1]]
      } {
        if {![llength [set lst [$jtw tag nextrange tAny $end]]]} return ""
        # ^^^ Imp: show error: found, but no value
      }
      ##puts "lst=$lst end=$end."
      ##eval "puts \[$jtw get $lst\]"
      if {2!=[llength [set tns [$jtw tag names [lindex $lst 0]]]]} return ""
      # ^^^ Imp: show error: found, but untagged value
      ##puts LT=[lindex $tns 1]:$tns:
      if {![llength [set lst [$jtw tag nextrange [lindex $tns 1] $end]]]} return ""
      # ^^^ This trick is used to find only a single tag. A single tag often
      #     means a single PostScript token, but -- for example `(a)(b)' and
      #     `[]' contain a single tag, but two tokens.
      # Imp: show better error message
      set white [$jtw get $end [lindex $lst 0]]
      ##puts aaa($white)
      if {[regexp "\[^\\000\011-\015 ]" $white]} return ""
      # ^^^ Imp: show error: key and value separated by non-whitespace
      ##puts bbb
      set beg [lindex $lst 0]
      set end [lindex $lst 1]
      set val [$jtw get $beg $end]
      set openc [expr {2*[string match <<* $val]+[string match \\\[* $val]}] ;# ]
      ## puts "openc=$openc; val=<$val>"
      if {$openc} {
        set end "$beg + $openc chars"
        set openc 1
        while {1} {
          if {![llength [set lst [$jtw tag nextrange tBrac $end]]]} return ""
          # ^^^ Imp: show error: unclosed >>
          set val [$jtw get [lindex $lst 0] [lindex $lst 1]]
          if {[string match <<* $val]} {incr openc; set end 2} \
          elseif {[string match \\\[* $val]} {incr openc; set end 1} \
          elseif {[string match >>* $val]} {incr openc -1; set end 2} \
          elseif {[string match \]* $val]} {incr openc -1; set end 1} \
          {return ""}
          # ^^^ Imp: show error: invalid tBrac
          set end "[lindex $lst 0] + $end chars"
          if {!$openc} {return "$beg [$jtw index $end]"}
        }
      }
      # puts "val=<$val>"
      # return [$jtw get $beg $end]
      return $lst
    }
  }
  return ""
}

proc update_psval {key newval} {
  #** return oldval or ""
  global jtw
  if {![llength [set found [find_val_range $key]]]} {return ""}
  set oldval [eval "$jtw get $found"]
  eval "$jtw delete $found"
  set found [lindex $found 0]
  if {[string match /* $newval]} {$jtw insert $found $newval {tAny tNameval}} \
  elseif {[string match (* $newval]} {$jtw insert $found $newval {tAny tString}} \
  elseif {[string match \[-0-9\]* $newval]} {$jtw insert $found $newval {tAny tInt}} \
  {$jtw insert $found $newval {tAny tSing}}
  $jtw mark set insert "$found + 1 chars"; $jtw see insert
  return $oldval
}

proc update_radio {key newval} {
  global jtw
  # puts "got=([find_val_range /Compression])"
  #set found [find_val_range /Hints]
  # set found [find_val_range /Profile]
  #puts "found=$found."
  #puts "is=([$jtw get [lindex $found 0] [lindex $found 1]])."
  if {![string length [update_psval /$key /$newval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc update_check {key wPath} {
  set varname [$wPath cget -variable]
  global $varname
  if {[set $varname]} {update_psval /$key true} {update_psval /$key false}
}

#set psstr_map ""
#proc psstr_map_init {} {
#  for {set i 0} {$i<32} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
#  for {set i 127} {$i<256} {incr i} {lappend psstr_map [format %c $i] [format \\%02o $i]}
#}
#(\\)'
#psstr_map_init
#regexp {^[] -'+-[^]+} str

proc pts_psstr_q {str} {
  #** This would be <60 chars in Perl. TCL is stupid, lame and sloow.
  set ret ""
  while {1} {
    regexp {^[] -'+-[^-~]*} $str head
    # ^^^ rejects low-unprintable, >=127, backslash, lparen and rparen
    set ret $ret$head
    if {[string length $str]==[set headlen [string length $head]]} break
    scan [string index $str $headlen] %c charcode
    set ret $ret[format \\%03o [expr {$charcode&255}]]
    set str [string range $str [expr {1+$headlen}] end]
  }
  return $ret
}

proc update_str {key newval empty} {
  # Imp: regsub...
  # set newval [string map $psstr_map $newval]
  if {[string length $newval]} {set newval ([pts_psstr_q $newval])} {set newval $empty}
  if {![string length [update_psval /$key $newval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc update_int {key newval empty} {
  if {[catch {set intval [expr {0+$newval}]}] || [string compare $intval $newval]} {set intval $empty}
  if {![string length [update_psval /$key $intval]]} {
    bell
    pts_message_box -title Warning -message "Cannot find key /$key. Please verify that the .job file is correct."
  }
}

proc but_save {} {
  global jtw jfn
  set f [open [$jfn get] w]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  puts -nonewline $f [$jtw get 1.0 end]
  close $f
  # bell
}

set tmpfnb "sam2p_tmp_[pid]"

proc but_relight {} {
  # Imp: error checks
  # Imp: \n transl
  # set f [open |[list tr a-z A-Z >tmp.tmp] w]
  global jtw tmpfnb
  set f [open "|perl -I. -Msam2ptol -e sam2ptol::highlight $jtw >$tmpfnb.tjb" w]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  puts -nonewline $f [$jtw get 1.0 end]
  close $f
  set f [open $tmpfnb.tjb r]
  catch {fconfigure $f -encoding binary} ;# TCL 8.2
  fconfigure $f -translation binary
  # puts [read $f]
  eval [read $f]
  close $f
  file delete -- $tmpfnb.tjb
}

proc but_load {} {
  global jtw jfn tmpfnb
  if {[catch {set f [open [$jfn get] r]} err]} {
    pts_message_box -message "Load failed: $err"
  } {
    catch {fconfigure $f -encoding binary} ;# TCL 8.2
    fconfigure $f -translation binary
    $jtw delete 1.0 end
    $jtw insert end [read $f]
    close $f
    but_relight
    # bell

    global InputFile InputFileOK
    set InputFile ""
    if {[llength [set found [find_val_range /InputFile]]]} {
      set val [eval "$jtw get $found"]
      if {[string match (*) $val]} {
        # vvv Imp: real PS backslash interpolation, not TCL
        set InputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
      }
    }
    set InputFileOK [pts_read_ok $InputFile]

    global OutputFile OutputFileOK
    set OutputFile ""
    if {[llength [set found [find_val_range /OutputFile]]]} {
      set val [eval "$jtw get $found"]
      if {[string match (*) $val]} {
        # vvv Imp: real PS backslash interpolation, not TCL
        set OutputFile [subst -nocommands -novariables [string range $val 1 [expr {[string length $val]-2}]]]
      }
    }
    set OutputFileOK [pts_write_ok $OutputFile]

    global FileFormat
    set FileFormat ""
    if {[llength [set found [find_val_range /FileFormat]]]} {
      set FileFormat [string range [eval "$jtw get $found"] 1 end]
    }

    global SampleFormat
    set SampleFormat ""
    if {[llength [set found [find_val_range /SampleFormat]]]} {
      set SampleFormat [string range [eval "$jtw get $found"] 1 end]
    }

    global Compression
    set Compression ""
    if {[llength [set found [find_val_range /Compression]]]} {
      set Compression [string range [eval "$jtw get $found"] 1 end]
    }

    global TransferEncoding
    set TransferEncoding ""
    if {[llength [set found [find_val_range /TransferEncoding]]]} {
      set TransferEncoding [string range [eval "$jtw get $found"] 1 end]
    }

    global Predictor
    set Predictor ""
    if {[llength [set found [find_val_range /Predictor]]]} {
      set Predictor [eval "$jtw get $found"]
    }

    global TransferCPL
    set TransferCPL ""
    if {[llength [set found [find_val_range /TransferCPL]]]} {
      set TransferCPL [eval "$jtw get $found"]
    }

    global Effort
    set Effort ""
    if {[llength [set found [find_val_range /Effort]]]} {
      set Effort [eval "$jtw get $found"]
    }

    global RecordSize
    set RecordSize ""
    if {[llength [set found [find_val_range /RecordSize]]]} {
      set RecordSize [eval "$jtw get $found"]
    }

    global K
    set K ""
    if {[llength [set found [find_val_range /K]]]} {
      set K [eval "$jtw get $found"]
    }

    global Quality
    set Quality ""
    if {[llength [set found [find_val_range /Quality]]]} {
      set Quality [eval "$jtw get $found"]
    }

    global WarningOK
    set WarningOK ""
    if {[llength [set found [find_val_range /WarningOK]]]} {
      if {[string compare true [eval "$jtw get $found"]]} {set WarningOK 1} {set WarningOK 1}
    }

    global TmpRemove
    set TmpRemove ""
    if {[llength [set found [find_val_range /TmpRemove]]]} {
      if {[string compare true [eval "$jtw get $found"]]} {set TmpRemove 1} {set TmpRemove 1}
    }

  }
}

proc but_quit {} {
  if {0==[string compare yes [pts_message_box -type yesno -title {Confirm quit} -message "Quit now, without saving?"]]} exit
}

proc but_run {} {
  # by pts@fazekas.hu at Fri Apr 26 23:43:17 CEST 2002
  global JobFile
  sa_debug_append "exec sam2p $JobFile:\n"
  # if {[catch {set ret [exec sam2p $JobFile 2>@ stdout]} ret]} {}
  if {[catch {set ret [exec sh -c {exec sam2p $1 2>&1} sam2p. $JobFile]} ret]} {
    set ret "Error running sam2p:\n$ret"
  }
  # puts ($ret)
  sa_debug_append $ret\n\n
}

# option add *Dialog*Label*font fixed
# option add *Label*Font times
#option add *font times
#option add *$g*font times
#option add *Dialog.msg.background red

label $g.lCompression -text Compression -anchor w -font $sa_boldfont
sa_radio $g.fNone Compression None None -command {update_radio Compression None}
sa_radio $g.fLZW Compression LZW LZW -command {update_radio Compression LZW}
sa_radio $g.fZIP Compression ZIP ZIP -command {update_radio Compression ZIP}
sa_int $g.fZIP.fEffort Effort Effort 2 -textvariable Effort
bind $g.fZIP.fEffort.i <FocusOut> {update_int Effort [%W get] pop}
pack $g.fZIP.fEffort -side left
sa_radio $g.fRLE Compression RLE RLE -command {update_radio Compression RLE}
sa_int $g.fRLE.fRecordSize RecordSize R.S 3 -textvariable RecordSize
bind $g.fRLE.fRecordSize.i <FocusOut> {update_int RecordSize [%W get] pop}
pack $g.fRLE.fRecordSize -side left
sa_radio $g.fFax Compression Fax Fax -command {update_radio Compression Fax}
sa_int $g.fFax.fK K K 5 -textvariable K
bind $g.fFax.fK.i <FocusOut> {update_int K [%W get] pop}
pack $g.fFax.fK -side left
sa_radio $g.fDCT Compression DCT DCT -command {update_radio Compression DCT}
sa_radio $g.fIJG Compression IJG IJG -command {update_radio Compression IJG}
sa_int $g.fIJG.fQuality Quality Q'lty 3 -textvariable Quality
bind $g.fIJG.fQuality.i <FocusOut> {update_int Quality [%W get] pop}
pack $g.fIJG.fQuality -side left
sa_radio $g.fJAI Compression JAI JAI -command {update_radio Compression JAI}
#label $g.fJAI.haha -text haha
#pack $g.fJAI.haha -side left
pack $g.lCompression -fill x
pack $g.fNone $g.fLZW $g.fZIP $g.fRLE $g.fFax $g.fDCT $g.fIJG $g.fJAI -fill x
sa_vframe $g

sa_int $g.lPredictor Predictor Predictor 3 -textvariable Predictor
bind $g.lPredictor.i <FocusOut> {update_int Predictor [%W get] pop}
pack $g.lPredictor -fill x
sa_vframe $g

sa_check_update $g.cWarningOK WarningOK WarningOK
# -textvariable WarningOK
pack $g.cWarningOK -fill x
sa_vframe $g

label $g.lTransferEncoding -text TransferEncoding -anchor w -font $sa_boldfont
sa_radio $g.fBinary TransferEncoding Binary Binary -command {update_radio TransferEncoding Binary}
sa_radio $g.fASCII TransferEncoding ASCII ASCII -command {update_radio TransferEncoding ASCII}
sa_radio $g.fHex TransferEncoding Hex Hex -command {update_radio TransferEncoding Hex}
sa_radio $g.fA85 TransferEncoding A85 A85 -command {update_radio TransferEncoding A85}
pack $g.lTransferEncoding -fill x
pack $g.fBinary $g.fASCII $g.fHex $g.fA85 -fill x
frame $g.pTransferEncoding -height 5 -width 1
pack $g.pTransferEncoding -fill x

sa_int $g.fTransferCPL TransferCPL TransferCPL 3 -textvariable TransferCPL
bind $g.fTransferCPL.i <FocusOut> {update_int TransferCPL [%W get] pop}

pack $g.fTransferCPL -fill x
sa_vframe $g

sa_check_update $g.cTmpRemove TmpRemove {Tmp Remove}
pack $g.cTmpRemove -fill x
sa_vframe $g


set g .gtop.g3
frame $g

sa_w_text $g.t -width 58 -height 18 -wrap none -font $sa_fixfont
pts_fix_one_tab $g.t
pts_text_autoindent $g.t 1
pts_text_auto_overstrike $g.t 0
# $g.t insert end "<<%sam2p job file\n  /InputFile (alma)\n  /OutputFile (korte)\n  /Profile \[\n    /Compression /LZW/Predictor 13\n    /Hints<</DCT <</a true /b (>>)>> >>\n  ]\n>>\n"
# $g.t insert end [read [open template.job r]]
# Imp: close file...
$g.t mark set insert 1.0; $g.t see insert
$g.t tag configure tAny; $g.t tag lower tAny sel
$g.t tag configure tSing -foreground "#003f7f"; $g.t tag raise tSing sel
$g.t tag configure tString -foreground "#007f7f"; $g.t tag raise tString sel
$g.t tag configure tKey -foreground "#00007f"; $g.t tag raise tKey sel
$g.t tag configure tNameval -foreground "#0000ff"; $g.t tag raise tNameval sel
$g.t tag configure tBrac -foreground "#ff0000"; $g.t tag raise tBrac sel
$g.t tag configure tComment -foreground "#007f00"; $g.t tag raise tComment sel
$g.t tag configure tInt -foreground "#3f0000"; $g.t tag raise tInt sel
$g.t tag configure tError -background "#ffdddd"; $g.t tag lower tError sel

# puts X[bindtags $g.t]X
# puts X[bind $g.t]X
# puts XZ[bind all]X

set jtw $g.t

# Imp: delete tmp.tmp

# -font sansserif
# puts [$g.t tag ranges tSing]
# reground blue

# update idletasks; puts [winfo geometry $g.t] ;# not ready, has to be packed first

frame $g.f
sa_w_text $g.f.td -width 1 -height 13 -wrap char -font $sa_fixfont \
  -yscrollcommand "$g.f.sd set" -spacing3 2
$g.f.td configure -selectbackground yellow ;# override
scrollbar $g.f.sd -command "$g.f.td yview" -width 11 -elementborderwidth 2 \
  -relief flat -borderwidth 1 -takefocus 0 -troughcolor gray65
$g.f.sd configure -activebackground [$g.f.sd cget -background]

# OK: non-editable, but not disabled (we need the cursor!)
# $g.f.td configure -background [lindex [$g.f.td configure -background] 3]
pts_readonly_color $g.f.td
# puts $g.f.td
# puts TD:[bind .gtop.g3.f.td <Key-Return>]

pts_fix_one_tab $g.f.td
$g.f.td insert end "Debug messages, sam2p output:\n\n"
# $g.f.td insert end "0\n1\n2\n3\n4\n5\n6\n7\n8\n9\n10\n11\n12\n13\n14\n15\n16\n17\n18\n19\n"
# $g.f.td insert end "21\n22\n23\n24\n25\n26\n27\n28\n29\n30\n31\n32\n33\n34\n35\n36\n37\n38\n39\n"
$g.f.td mark set insert 1.0; $g.f.td see insert
set debugtext $g.f.td

pack $g.t -expand 0 -fill x
pack $g.f.td -expand 1 -fill both -side left
pack $g.f.sd -fill both -side left
pack $g.f -expand 1 -fill both

pack .gtop.g0 .gtop.g1 .gtop.g2 -side left
pack .gtop.g3 -expand 1 -fill both -side left

frame .gbot
frame .gbot.gbl

set g .gbot.gbl.fCurdir
frame $g
label $g.l -text "Current dir" -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont
# bind $g.e <FocusOut> {update_str e [%W get] pop}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
$g.e insert 0 [pwd]

# puts [bind .gbot.gbl.fCurdir.e]

bind Text <B2-Motion> {}
bind Text <Button-2> {}
# puts T[bind Text]T
# puts [bind Text <Button-2>]
#puts ([bind Entry <Tab>])

#foreach evtseq [bind Entry] {
#  if {[string match <Key-*> $evtseq]
#   || [string match <*-Key-*> $evtseq]
#   || [string match <*-Key> $evtseq]
#     } {
#    bind $g.e $evtseq {break}
#    puts +:$evtseq
#  } {
#    #puts -:$evtseq
#  }
#}

# Dat: this assumes [lindex [bindtags $g.e] 0] == $g.e
#foreach tag [bindtags $g.e] {
#  foreach evtseq [bind $tag] {
#    # if {0==[string length [bind $g.e $evtseq]]} {bind $g.e $evtseq [bind $tag $evtseq]}
#  }
#}

pts_readonly_color $g.e


# event info <<Clear>>
#bind $g.e <Key-Tab> {# nothing}
#bind $g.e <Key-ISO_Left_Tab> {# nothing}
# puts /[bind $g.e]
# puts :[bind $g.e <Key-Return>]

set g .gbot.gbl.fJobFile
frame $g
label $g.l -text JobFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable JobFile
label $g.r -text OK -font $sa_normfont -textvariable JobFileOK -width 2
bind $g.e <FocusOut> {set JobFileOK [pts_write_ok $JobFile]}
set jfn $g.e
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left


set g .gbot.gbl.fInputFile
frame $g
label $g.l -text InputFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable InputFile
label $g.r -text OK -font $sa_normfont -textvariable InputFileOK -width 2
bind $g.e <FocusOut> {update_str InputFile [%W get] pop; set InputFileOK [pts_read_ok $InputFile]}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left
set InputFileOK [pts_read_ok $InputFile]

set g .gbot.gbl.fOutputFile
frame $g
label $g.l -text OutputFile -font $sa_boldfont
sa_w_entry $g.e -font $sa_normfont -textvariable OutputFile
label $g.r -text OK -font $sa_normfont -textvariable OutputFileOK -width 2
bind $g.e <FocusOut> {update_str OutputFile [%W get] pop; set OutputFileOK [pts_write_ok $OutputFile]}
pack $g.l -side left
pack $g.e -expand 1 -fill x -side left
pack $g.r -side left

pack .gbot.gbl.fCurdir .gbot.gbl.fJobFile .gbot.gbl.fInputFile .gbot.gbl.fOutputFile -expand 1 -fill x

frame .gbot.ha
button .gbot.ha.bLoad -text {Load Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_load
bind . <Alt-Key-l> but_load
button .gbot.ha.bSave -text {Save Job} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_save
bind . <Alt-Key-s> but_save

frame .gbot.hb
button .gbot.hb.bRun -text {Run} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_run
bind . <Alt-Key-r> but_run
button .gbot.hb.bQuit -text {Quit} -font $sa_normfont -borderwidth 1 -pady 2 -underline 0 \
  -command but_quit
bind . <Alt-Key-q> but_quit
pack .gbot.gbl -expand 1 -fill x -side left
pack .gbot.ha.bLoad .gbot.ha.bSave
pack .gbot.hb.bRun .gbot.hb.bQuit
pack .gbot.ha .gbot.hb -side left

pack .gtop -expand 1 -fill both
pack .gbot -expand 0 -fill x
update idletasks ;# a sima [update] helyett, hogy a "geometry" jó legyen
scan [wm geometry .] "%dx%d%s" width height tmp
wm minsize . $width $height


set env(PATH) $env(PATH)[pts_PATH_sep].
#if {[catch {set ret [exec sam2p --help 2>&1]} ret]} {}
if {[catch {set ret [exec sh -c {exec sam2p --help 2>&1}]} ret]} {
  set ret "Error:\n$ret"
}

proc sa_debug_append msg {
  global debugtext
  $debugtext insert end $msg
  $debugtext mark set insert end
  $debugtext see insert
}

sa_debug_append $ret\n\n
# puts ($ret)


$jfn delete 0 end
if {[llength $argv]} {$jfn insert 0 [lindex $argv 0]; but_load} {
  $jfn insert 0 template.job; but_load; $jfn delete 0 end
  set InputFileOK 0
  set OutputFileOK 0
  set JobFileOK 0
}
# set InputFile hello
# but_load
# puts $argv
# puts TD:[bind .gtop.g3.f.td <Key-Return>]


#__END__