# jtexttags.tcl - tagged typing and tagging the selection for Text bindings
#
######################################################################
# Copyright 1992-1995 by Jay Sekora.  This file may be freely        #
# distributed, modified or unmodified, for any purpose, provided     #
# that this copyright notice is retained verbatim in all copies and  #
# no attempt is made to obscure the authorship of this file.  If you #
# distribute any modified versions, I ask, but do not require, that  #
# you clearly mark any changes you make as such and that you provide #
# your users with instructions for getting the original sources.     #
######################################################################

# TO DO: clear_tags, clear_marks

# see also j:text:insert_string in jtext.tcl

#
# tags used by these functions are of the form $category:$attribute:$value,
# where you can always say "$w tag configure -$attribute $value".
# two potential tags conflict if their $attribute is the same.
#

######################################################################
# insert text into w at insert,
#   possibly honouring current tag list for widget
#   partly lifted from insertWithTags in mkStyles.tcl demo
#   used by jtext.tcl if a tag list is specified
######################################################################

proc j:tag:insert_string { w text } {
  global j_tag
  
  if {! [info exists j_tag(tags,$w)]} {
    set j_tag(tags,$w) {}
  }
  
  set start [$w index insert]
  $w insert insert $text
  $w yview -pickplace insert
  #
  # apply styles from tag list
  foreach tag [$w tag names $start] {
    $w tag remove $tag $start insert
  }
  foreach i $j_tag(tags,$w) {
    $w tag add $i $start insert
  }
}

######################################################################
# set tags to use when inserting typed text
#   if $tags is the empty list, inserted text will be plain.
######################################################################

proc j:tag:set_tags { w args } {
  global j_tag
  
  set j_tag(tags,$w) $args
  
  # now configure any display tags in $args to display properly:
  
  foreach tag $args {
    set split_tag [split $tag ":"]
    set category [lindex $split_tag 0]		;# e.g. display, command
    if {"x$category" == "xdisplay"} {
      set attribute [lindex $split_tag 1]	;# e.g. foreground, font
      set value [lindex $split_tag 2]		;# e.g. blue, 12x24
      
      catch {
        $w tag configure $tag -$attribute $value
      }
      $w tag lower $tag				;# so sel e.g. overrides
    }
  }

}

######################################################################
# clear tag list for inserting typed text; 
#   when used with jtext.tcl, restores normal Tk behaviour of 
#   inheriting tag from surrounding text
######################################################################

proc j:tag:clear_tags { w } {
  global j_tag
  
  catch {
    unset j_tag(tags,$w)
  }
}

######################################################################
# j:tag:set_tag w tag -
#   add a tag to list, overriding any conflicting tag
######################################################################

proc j:tag:set_tag { w tag } {
  global j_tag
  
  set split_tag [split $tag ":"]
  set category [lindex $split_tag 0]		;# e.g. display, command
  set attribute [lindex $split_tag 1]		;# e.g. foreground, font
  set value [lindex $split_tag 2]		;# e.g. blue, 12x24
  
  if {"x$category" == "xdisplay"} {
    catch {
      $w tag configure $tag -$attribute $value
    }
    $w tag lower $tag				;# so sel e.g. overrides
  }
  
  if {! [info exists j_tag(tags,$w)]} {		;# make sure list exists
    set j_tag(tags,$w) $tag
    return
  }
  
  set new_tags $tag				;# start with tag argument,
  
  foreach old_tag $j_tag(tags,$w) {		;# append compatible old tags
    set old_split_tag [split $old_tag ":"]
    set old_category [lindex $old_split_tag 0]
    set old_attribute [lindex $old_split_tag 1]
    if {"$category:$attribute" != "$old_category:$old_attribute"} {
      lappend new_tags $old_tag
    }
  }
  
  set j_tag(tags,$w) $new_tags
  
  return
}


######################################################################
# j:tag:clear_tag w pattern -
#   remove tags matching pattern from list
######################################################################

proc j:tag:clear_tag { w pattern } {
  global j_tag
  
  if {! [info exists j_tag(tags,$w)]} {		;# make sure list exists
    return
  }
  
  set new_tags {}				;# start with empty list
  
  foreach old_tag $j_tag(tags,$w) {		;# append old tags unless match
    if {! [string match $pattern $old_tag]} {
      lappend new_tags $old_tag
    }
  }
  
  set j_tag(tags,$w) $new_tags
  
  return
}

######################################################################
# j:tag:tag_text w tag first last -
#   apply tag to text, overriding any conflicting tag
######################################################################

proc j:tag:tag_text { w tag first last } {
  if [$w compare $first > $last] {
    error [j:ldb texttags:first_gt_last \
      "Text index \"first\" ($first) > \"last\" ($last)."]
  }
  
  set split_tag [split $tag ":"]
  set category [lindex $split_tag 0]		;# e.g. display, command
  set attribute [lindex $split_tag 1]		;# e.g. foreground, font
  set value [lindex $split_tag 2]		;# e.g. blue, 12x24
  
  foreach possible_tag [$w tag names] {
    set split_old [split $possible_tag ":"]
    set old_category [lindex $split_old 0]
    set old_attribute [lindex $split_old 1]
    
    if {"$old_category:$old_attribute" == "$category:$attribute"} {
      $w tag remove $possible_tag $first $last
    }
  }
  
  $w tag add $tag $first $last
  
  if {"x$category" == "xdisplay"} {
    $w tag configure $tag -$attribute $value	;# should be catch'ed
    $w tag lower $tag				;# so sel e.g. overrides
  }
}


######################################################################
# j:tag:untag_text w pattern first last -
#   remove tags matching pattern from text between first and last in w
######################################################################

proc j:tag:untag_text { w pattern first last } {
  if [$w compare $first > $last] {
    error [j:ldb texttags:first_gt_last \
      "Text index \"first\" ($first) > \"last\" ($last)."]
  }
  
  foreach possible_tag [$w tag names] {
    if [string match $pattern $possible_tag] {
      $w tag remove $possible_tag $first $last
    }
  }
}

######################################################################
# configure all current display tags in widget w
######################################################################

proc j:tag:configure_display_tags { w } {
  foreach tag [$w tag names] {
    set split_tag [split $tag ":"]
    set category [lindex $split_tag 0]		;# e.g. display, command
    if {"x$category" == "xdisplay"} {
      set attribute [lindex $split_tag 1]	;# e.g. foreground, font
      set value [lindex $split_tag 2]		;# e.g. blue, 12x24
      
      catch {
        $w tag configure $tag -$attribute $value
      }
      $w tag lower $tag				;# so sel e.g. overrides
    }
  }
}

######################################################################
# return non-text content (tags and marks) of a text widget
######################################################################

proc j:tag:get_annotation {t} {
  set tags {}
  set marks {}
  foreach tag [$t tag names] {
    set ranges [$t tag ranges $tag]
    if {"x$ranges" != "x"} {
      lappend tags [list $tag $ranges]
    }
  }
  foreach mark [$t mark names] {
    lappend marks [list $mark [$t index $mark]]
  }
  return [list $tags $marks]
  close $file
}

######################################################################
# set non-text content (tags and marks) of a text widget
######################################################################

proc j:tag:set_annotation { {t} {state} } {
  set tags [lindex $state 0]
  set marks [lindex $state 1]
  foreach pair $marks {
    $t mark set [lindex $pair 0] [lindex $pair 1]
  }
  foreach pair $tags {
    set tag [lindex $pair 0]
    set ranges [lindex $pair 1]
    set length [llength $ranges]
    for {set i 0; set i1 1} {$i1 < $length} {incr i 2; incr i1 2} {
      $t tag add $tag [lindex $ranges $i] [lindex $ranges $i1]
    }
  }
  j:tag:configure_display_tags $t	;# make sure things look right
  $t yview -pickplace insert
}

######################################################################
# archive text widget to file, including state
######################################################################

proc j:tag:archive_text_widget { {t} {filename} } {
  j:tk3 {set text [$t get 1.0 end]}
  j:tk4 {set text [$t get 1.0 end-1c]}
  set state [j:tag:get_annotation $t]
  
  j:fileio:write $filename [list $text $state]
}

######################################################################
# read entire contents of text widget from file, including state
######################################################################

proc j:tag:restore_text_widget { {t} {filename} } {
  set archive [j:fileio:read $filename]
  
  set text [lindex $archive 0]
  set state [lindex $archive 1]
  
  set state_option \
    [lindex [$t configure -state] 4]		;# in case it's disabled
  $t configure -state normal			;# make sure we can change
  
  $t delete 1.0 end
  $t insert end $text
  j:tag:set_annotation $t $state
  
  $t configure -state $state_option		;# might have been disabled
}

######################################################################
# apply "state" to text starting at a given offset
#   this is used for inserting tagged text into a text widget
#   someplace other than the beginning.  by default, ignores "sel" tag
#   and "insert" and "current" marks.  DOESN'T YET WORK!
######################################################################

proc j:tag:apply_annotation { args } {
  j:parse_args {
    {offset 1.0}
    {ignoretags {sel}}
    {ignoremarks {insert current}}
  }
  
  if {[llength $args] < 2} {
    error [j:ldb texttags:anno_args \
      "wrong # args: should be j:tag:apply_annotation ?options? widget state"]
  }
  
  set widget [lindex $args 0]
  set state [lindex $args 1]
  
  set tags [lindex $state 0]
  set marks [lindex $state 1]
  
  foreach pair $marks {
    set mark [lindex $pair 0]
    set index [lindex $pair 1]
    if {[lsearch $ignoremarks $mark] != -1} {
      $widget mark set $mark [j:tag:offset_index $index $offset]
    }
  }
  foreach pair $tags {
    set tag [lindex $pair 0]
    set ranges [lindex $pair 1]
    set length [llength $ranges]
    for {set i 0; set i1 1} {$i1 < $length} {incr i 2; incr i1 2} {
      if {[lsearch $ignoretags $tag] != -1} {
        set from [j:tag:offset_index [lindex $ranges $i] $offset]
        set to [j:tag:offset_index [lindex $ranges $i1] $offset]
        
        $widget tag add $tag $from $to
      }
    }
  }
  j:tag:configure_display_tags $widget	;# make sure things look right
}

######################################################################
# offset a text index by a given amount
#   the line offset is always added, but the character offset is only
#   changed on the first line
######################################################################

proc j:tag:offset_index { index offset } {
  set offset_split [split $offset "."]
  set line_offset [expr [lindex $offset_split 0] - 1]
  
  if [string match "1.*" $index] {
    # first line - need to offset both line and character
    set char_offset [lindex $offset_split 1]
    set index_split [split $index "."]
    set index_line [lindex $index_split 0]
    set index_char [lindex $index_split 1]
    return [expr $index_line + $line_offset].[expr $index_char + $char_offset]
  } else {
    # subsequent line - only need to offset the line number
    # can pretend it's real arithmetic
    return [expr $index + $line_offset]
  }
}

