#
# Operations for Lisp function/comment manipulation in Text widgets.
#


# Function boundary routines

# Ensures that index is 2nd from the beginning of a valid LISP function.
proc th_defun_check {w index} {
  scan [$w index $index] "%d.%d" row column
  if {$column != 1} {return 0}
  set op "\(" ;   set cp "\)"
  if {[$w get "$row.0"] != $op} {return 0}
  return 1
}

# These deal with LISP functions, and return another index or "" if
# unsuccessful.

proc th_defun_begin {w index} {
  global TH
  if {[catch "set TH(File,$w)"]} {set function_begin "defun"
  } elseif {[file extension $TH(File,$w)] == ".scm"} {set function_begin "define"
  } else {set function_begin "defun"}
  set index [$w index "$index +3c"]
  while {[set index [$w search -backward -- $function_begin "$index-1c" 1.0]] != ""} {
    if {[th_defun_check $w $index]} {  return "$index -1c"}
  }
  return ""
}

proc th_defun_end {w index} {
  if {[set begin [th_defun_begin $w $index]] == ""} {return ""}
  if {[set e [th_Text_right_exp $w $begin "(" ")" 1]] == ""} {return ""}
  return $e
}

proc th_defun_next {w index} {
  global TH
  if {[catch "set TH(File,$w)"]} {set function_begin "defun"
  } elseif {[file extension $TH(File,$w)] == ".scm"} {set function_begin "define"
  } else {set function_begin "defun"}
  while {[set index [$w search -forward -- $function_begin "$index +2c" end]] != ""} {
    if {[th_defun_check $w $index]} {return "$index -1c"}
  }
  return ""
}

proc th_defun_prev {w index} {
  if {[set begin [th_defun_begin $w $index]] == ""} {return ""}
  if {[$w compare $begin != $index]} {
    return $begin 
  } else {return [th_defun_begin $w "$index -1c"]
}}


# Comment boundary routines
# These work like the function routines above, except they deal with comments.

proc th_lispcomment_begin {w index} {
  scan [$w index $index] "%d.%d" i dummy
  if {[$w get "$i.0"] != ";"} {return ""}
  for {} {$i > 0} {incr i -1} {
    if {([$w get "$i.0"] == ";") && ([$w get "$i.0 -1 line"] != ";")} {
      return "$i.0"
  }}
  if {[$w get 1.0] == ";"} {return 1.0} else {return ""}
}

proc th_lispcomment_end {w index} {
  scan [$w index $index] "%d.%d" i dummy
  scan [$w index end] "%d.%d" e dummy
  if {[$w get "$i.0"] != ";"} {return ""}
  for {} {$i < $e} {incr i} {
    if {([$w get "$i.0"] != ";")} {return $i.0}}
  if {[$w get "$e.0"] == ";"} {return end} else {return ""}
}

proc th_lispcomment_next {w index} {
  scan [$w index $index] "%d.%d" i dummy
  scan [$w index end] "%d.%d" e dummy
  for {} {$i < $e} {incr i} {
    if {([$w get "$i.0"] != ";") &&
      ([$w get "$i.0 +1l"] == ";")} {return "$i.0 +1l"}}
  return ""
}

proc th_lispcomment_prev {w index} {
  if {[set begin [th_lispcomment_begin $w $index]] == ""} {return ""}
  if {[$w compare $begin != $index]} {
    return $begin 
  } else {return [th_lispcomment_begin $w "$index -1c"]
}}


# Adjusts selected region to fit in $length columns, so that no lines wrap
# If unspecified, length defaults to window width.
proc th_lispcomment_format {w start end {length ""}} {
  if {[catch {$w index sel.first}]} {
    set selected 0
    if {[set start [th_lispcomment_begin $w insert]] == ""} {bell ; return}
    if {[$w compare [set end [th_lispcomment_end $w $start]] < insert]} {bell ; return}
  } else {
    set start sel.first ; set end sel.last
    set selected 1
  }
  set chars [$w get $start $end]
  $w mark set th_lispcomment_end "$end -1l lineend"
  if {($length == "")} {set length [$w cget -width]}

  set prefix ""
  for {set i 0} {[string first [$w get "$start +$i c"] "; "] >= 0} {incr i} {
    append prefix [$w get "$start +$i c"]
  }
  th_Text_delete_prefix $w $start th_lispcomment_end $prefix
  th_Text_format $w $start th_lispcomment_end [expr $length - [string length $prefix]] 0
  th_Text_add_prefix $w $start th_lispcomment_end $prefix
  $w mark set $start "$start linestart"

  if $selected {set end sel.last} else {set end [th_lispcomment_end $w $start]}
  th_Text_tag_regions $w comment th_lispcomment_begin th_lispcomment_end th_lispcomment_next $start th_lispcomment_end
  set e [$w index th_lispcomment_end] ; $w mark unset th_lispcomment_end
  th_Text_undoable_replace $w $start $e $chars "Reformat"
}

