# jtexttags.tcl - tagged typing and tagging the selection for Text bindings
#
###############################################################################
#  Copyright 1992-2001 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 in jtext.tcl

#
# Tags used by these functions are of the form $category:$attribute:$value.
# If $category is "display", then you should be able to say
#    "$w tag configure -$attribute $value".
# Two potential tags conflict if their $attribute and $category are the same.
#

package provide aq 0.1

# following has side-effect of making sure ::aq namespace is defined
namespace eval ::aq {
  namespace export {[a-z]*}
}

# following also makes sure ::aq::tag namespace is defined
namespace eval ::aq::tag {
  namespace export {[a-z]*}
}

######################################################################
# 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 ::aq::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
  }
}

######################################################################
# move to $index in $w, setting current tags to tags prevalent there
######################################################################

proc ::aq::tag::move { w index } {
  global j_tag
  
  set j_tag(tags,$w) {}
  
  $w mark set insert $index
  $w yview -pickplace insert
  set tags_after [$w tag names insert]
  set tags_before [$w tag names insert-1char]
  if [$w compare $index == 1.0] {
    # if we're at the beginning of the widget, pretend the preceding
    #   character has the same tags
    set tags_before $tags_after
  }
  
  foreach tag $tags_before {
    switch -glob $tag {
      special:list_item:* -
      special:hr:* {
        # don't pick up list_item or horizontal rule tags
      }
      richtext:* -
      display:* {
        # pick up all ordinary font and display tags on preceding character
        lappend j_tag(tags,$w) $tag
      }
      default {
        # pick up other tags only when both preceding and following 
        #   characters share them
        if {[lsearch -exact $tags_after $tag] >= 0} {
          lappend j_tag(tags,$w) $tag
        }
      }
    }
  }
}

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

proc ::aq::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 ::aq::tag::clear_tags { w } {
  global j_tag
  
  catch {
    unset j_tag(tags,$w)
  }
}

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

proc ::aq::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
}


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

proc ::aq::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
}

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

proc ::aq::tag::tag_text { w tag first last } {
  if [$w compare $first > $last] {
    error "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
  }
}


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

proc ::aq::tag::untag_text { w pattern first last } {
  if [$w compare $first > $last] {
    error "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 ::aq::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
    }
  }
}

######################################################################
# configure standard fonts per user's preferences
######################################################################

proc ::aq::tag::configure_fonts { w } {
  global J_PREFS
  
  foreach pair {
    {roman screen_roman_font}
    {italic screen_italic_font}
    {bold screen_bold_font}
    {bolditalic screen_bolditalic_font}
    {typewriter screen_monospace_font}
    {heading0 screen_heading0_font}
    {heading1 screen_heading1_font}
    {heading2 screen_heading2_font}
    {heading3 screen_heading3_font}
    {heading4 screen_heading4_font}
    {heading5 screen_heading5_font}
    {l_em screen_italic_font}
    {l_cite screen_italic_font}
    {l_var screen_italic_font}
    {l_dfn screen_italic_font}
    {l_strong screen_bold_font}
    {l_kbd screen_bold_font}
    {l_code screen_monospace_font}
    {l_samp screen_monospace_font}
  } {
    set tag richtext:font:[lindex $pair 0]
    set font $J_PREFS([lindex $pair 1])
    ::aq::configure_tag_font $w $tag $font}
}

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

proc ::aq::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 ::aq::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]
    }
  }
  ::aq::tag::configure_display_tags $t	;# make sure things look right
  $t yview -pickplace insert
}

######################################################################
# get a piece of metainfo associated with a text widget by key
# if no key is specified, return whole list of metainfo
######################################################################

proc ::aq::tag::get_metainfo { args } {
  ::aq::parse_args {
    {default {}}
  }
  
  set t [lindex $args 0]
  set key [lindex $args 1]		;# {} if not given
  
  global j_textinfo
  
  append j_textinfo($t) {}		;# make sure it exists
  
  if [string match "" $key] {
    return $j_textinfo($t)
  }
  
  foreach pair $j_textinfo($t) {
    if {[string compare $key [lindex $pair 0]] == 0} {
      return [lindex $pair 1]
    }
  }
  return $default
}

######################################################################
# set a piece of metainfo associated with a text widget by key
######################################################################

proc ::aq::tag::set_metainfo { t key value} {
  global j_textinfo
  
  append j_textinfo($t) {}		;# make sure it exists
  
  # start with a new list containing only the new key and value
  set new_textinfo [list [list $key $value]]
  
  # now copy the rest of the list into the new list, skipping key that matches
  foreach pair $j_textinfo($t) {
    if {[string compare $key [lindex $pair 0]] != 0} {
      lappend new_textinfo $pair
    }
  }
  
  # now replace the old list with the new one
  set j_textinfo($t) $new_textinfo
  return
}

######################################################################
# delete a piece of metainfo associated with a text widget by key
######################################################################

proc ::aq::tag::delete_metainfo { t key} {
  global j_textinfo
  
  append j_textinfo($t) {}		;# make sure it exists
  
  # start with a new empty list
  set new_textinfo {}
  
  # now copy the rest of the list into the new list, skipping key that matches
  foreach pair $j_textinfo($t) {
    if {[string compare $key [lindex $pair 0]] != 0} {
      lappend new_textinfo $pair
    }
  }
  
  # now replace the old list with the new one
  set j_textinfo($t) $new_textinfo
  return
}

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

proc ::aq::tag::archive_text_widget { {t} {filename} } {
  global j_textinfo
  
  if ![info exists j_textinfo($t)] {
    set j_textinfo($t) {}
  }
  set text [$t get 1.0 end-1c]
  set state [::aq::tag::get_annotation $t]
  set metainfo $j_textinfo($t)
  ::aq::write_file $filename [list $text $state $metainfo]
}

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

proc ::aq::tag::restore_text_widget { {t} {filename} } {
  global j_textinfo
  
  set archive [::aq::read_file $filename]
  
  set text [lindex $archive 0]
  set state [lindex $archive 1]
  set metainfo [lindex $archive 2]
  
  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
  ::aq::tag::set_annotation $t $state		;# set tags and marks
  
  $t configure -state $state_option		;# might have been disabled
  set j_textinfo($t) $metainfo			;# set out-of-band metainfo
}

######################################################################
# 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 ::aq::tag::apply_annotation { args } {
  ::aq::parse_args {
    {offset 1.0}
    {ignoretags {sel}}
    {ignoremarks {insert current}}
  }
  
  if {[llength $args] < 2} {
    error \
      "wrong # args: should be ::aq::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 [::aq::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 [::aq::tag::offset_index [lindex $ranges $i] $offset]
        set to [::aq::tag::offset_index [lindex $ranges $i1] $offset]
        
        $widget tag add $tag $from $to
      }
    }
  }
  ::aq::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 ::aq::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]
  }
}
