############################################################################
#
#	File:     support.icn
#
#	Subject:  Procedures to support charpatt actions
#
#	Author:   Ralph E. Griswold
#
#	Date:     September 18, 1998
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  This file contains support procedures
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################

$include "defines.icn"

#  Provide short string for long pattern.

procedure abbrev(pattern)

   if *pattern < 30 then return pattern
   else return pattern[1:14] || ".." || pattern[0:-14]

end

#  Handle bad grammar.

procedure bad_grammar(input)

   Notice("Invalid grammar.")

   close(input)

   undo()

   fail

end

#  Change goal symbol

procedure change_goal()

   repeat {
      if TextDialog("Change goal symbol to:", , goal, 1) == "Cancel" then fail
      if member(set(symbols_list), dialog_value[1]) then break
      Notice("Symbol not available.")
      }

      save_state(undo_list)

      symbol_tbl[dialog_value[1]] := symbol_tbl[goal]

      delete(symbol_tbl, goal)

      symbol := map(symbol, goal, dialog_value[1])

      goal := dialog_value[1]

      remove_symbol(goal)

      refresh(1)

      return

end

procedure edit_tokens()
   local token_list, value_list, k, i, toks

   if *token_tbl = 0 then return FailNotice("No tokens.")

   value_list := []
   token_list := []

   toks := sort(token_tbl, 4)

   while put(value_list, get(toks)) do
      put(token_list, get(toks))

   if TextDialog("Tokens:", token_list,  value_list, 20) ==
      "Cancel" then fail

   save_state(undo_list)

   token_tbl := table()

   every i := 1 to *value_list do
      token_tbl[dialog_value[i]] := token_list[i]

   refresh(1)

   return

end

#  Clear saved grammars.

procedure clear_saved()

   undo_list := []
   redo_list := []

   return

end

#  Remove all definitions except for the goal and expand.

procedure collapse()
   local slist, rsym, rdef, sym

   if AskDialog("Remove all symbols except the goal?") == "No" then fail

   slist := keylist(symbol_tbl)

   every rsym := !slist do {
      if rsym == goal then next			# don't remove the goal
      rdef := symbol_tbl[rsym]
      delete(symbol_tbl, rsym)
      every sym := !keylist(symbol_tbl) do
         symbol_tbl[sym] := replace(symbol_tbl[sym], rsym, rdef)
      push(symbols_list, rsym)			# make removed symbol available
      }

   symbol := goal
   workspace_string := symbol_tbl[symbol]

   return

end

procedure comment()

   if TextDialog("Comment:", , [note], 50) == "Cancel" then fail
   note := dialog_value[1]

   touched := 1

   return

end

#  Decollate s into i parts

procedure decol(s, i)
   local parts, j, form, header

   parts := list(i, ",")

   s ? {
      repeat {
         every j := 1 to i do {
            (parts[j] ||:= move(1)) | break break
            }
         }
      }

   form := ""

   every form ||:= !parts

   return "{" || form[2:0] || "}"

end

#  Produce bound on depth of grammar (number of generations required
#  to reach the string of all terminals.  Note this is a bound; the
#  number required might be less.

procedure gdepth()
   local sym_set, var, vars, keys

   keys := keylist(symbol_tbl)

   vars := ""
   every vars ||:= !keys

   sym_set := set(keys)

   every var := !vars do
      if *(symbol_tbl[var] ** vars) = 0 then delete(sym_set, var)

   return *sym_set + 1			# One for the all-terminal definitions

end

#  Edit workspace.  WORK IN PROGRESS

procedure edit_workspace()

   return

end

#  Replace value by one-character symbol and use pattern as its representation.

procedure encode(value, pattern)
   local k, sym, rev, revsym

   save_state(undo_list)

   if value == workspace_string then {		# just update definition
      symbol_tbl[symbol] := pattern
      workspace_string := pattern
      refresh(1)
      return
      }

   repeat {
      sym := get(symbols_list) | {
         return FailNotice("Symbols exhausted.")
         }
      if /symbol_tbl[sym] then break		# found unused one
      }

   # set up for reversals

   if value ~== reverse(value) then {
      rev := reverse(value)
      if *value > 1 then revsym := "<" || sym || ">" else revsym := rev
      }

   workspace_string := replace(workspace_string, value, sym)

   if \rev then
      workspace_string := replace(workspace_string, rev, revsym)

   every k := key(symbol_tbl) do
      symbol_tbl[k] := replace(symbol_tbl[k], value, sym)

   if \rev then {
      every k := key(symbol_tbl) do
         symbol_tbl[k] := replace(symbol_tbl[k], rev, revsym)
      }

   symbol_tbl[sym] := pattern

   refresh(1)

   return

end

#  Allow user to enter string for the workspace (handy for testing).

#  Quit the application.

procedure exit_app()

   if \touched then {
      if not save_grammar() then fail
      }

   exit()

end

#  Get goal symbol

procedure get_goal()
   
   repeat {
      if TextDialog("Specify goal symbol:", , goal, 1) == "Cancel" then
         fail
      if (*dialog_value[1] = 0) | upto(MetaCharacters, dialog_value[1])
         then {
            Notice("Invalid goal symbol.")
            next
            }
      goal := dialog_value[1]
      remove_symbol(goal)
      return
      }

end

#  Check for integer or empty field; n indexes dialog_value

procedure intorempty(n)

   if *dialog_value[n] > 0 then return integer(dialog_value[n])
   else return ""

end

#  Check for user interrupt

procedure interrupt()

   interrupt_signal := 1

   Notice("Search interrupted.")	# ALLOW USER TO RESUME

   return

end

#  Locate positions of a string.

procedure locate()
   local loc, old_loc

   if TextDialog("Locate:", , find_string, FindWidth) == "Cancel" then fail

   find_string := dialog_value[1]

   old_loc := 1

   workspace_string ? {
      while tab(find(find_string)) do {
         loc := &pos
         move(*find_string)
         if TextDialog(
            ["location: " || loc, "delta: " || loc - old_loc],
            ,
            ,
            ,
            ["Next", "Done"],
            ) == "Done" then {
                maxl := minl := loc - \old_loc
                return
                }
         old_loc := loc
         }
      }

   Notice("Search failed.")

   fail

end

#  Display information about the workspace.

procedure metrics()
   local info, chars , c

   WAttrib("pointer=watch")

   chars := cset(workspace_string)

   info := []
   put(info,
      "Workspace:",
      "",
      "length: " || *workspace_string,
      "",
      *chars || " different characters",
      ""
      )

   every c := !chars do
      put(info, c || ": " || right(charcnt(workspace_string, c), 7))

   Notice ! info

   WAttrib("pointer=arrow")

   return

end

#  Get ngrams

procedure ngrams(min, max)
   local grams, s, i

   grams := set()

   interrupt_signal := &null

   every s := !symbol_tbl do {
      every i:= min to max do {
         if *s < i then break next
         else if *s = i then {
            insert(grams, s)
            break next
            }
         s ? {
            every tab(1 to i) do
               while insert(grams, move(i)) do {
                  if *Pending() > 0 then {
                     ProcessEvent(root_cur, , interrupt)
                     if \interrupt_signal then break break break break
                     }
                  }
               }
            }
         }

   return grams

end

#  Set up state for opening a file via navitrix.

procedure open_file(p)

   if \touched then save_grammar()

   WAttrib(nav_window, "canvas=normal")

   open_proc := p

   return

end

#  Get approval to overwrite file.

procedure overwrite(file)

   if exists(file) then {
      if AskDialog("Overwrite existing file?") == "No" then fail
      }

   return
   
end

#  Count occurrences of a pattern (including overlaps)

procedure pat_count(value)
   local count, s

   count := 0

   every s := !symbol_tbl do {
      s ? {
         every find(value) do count +:= 1
         }
      }

   return count

end

#  Compute savings for a pattern.

procedure pat_fom(value, pattern)
   local count, rev, fom, str

   count := 0

   every count +:= strcnt(value, !symbol_tbl)

   fom := (*value - 1) * count - (4 + *pattern)

   rev := reverse(value)

   count := 0

   if rev ~== value then {
      every str := !symbol_tbl do {
         str := replace(str, value, goal)
         count +:= strcnt(rev, str)
         }
      }

   if count > 0 then fom +:= (*value - 3) * count - (6 + *pattern)

   return fom

end

#  Check for positive integer from dialog; n indexes dialog_value.

procedure pint(n)

   return (0 < integer(dialog_value[n]))

end

#  Restore previous saved state

procedure redo()

   goal := pop(redo_list) | {
      return FailNotice("No previous grammar.")
      }

   save_state(undo_list)

   symbol_tbl := pop(redo_list)
   symbol := pop(redo_list)
   workspace_string := pop(redo_list)
   symbols_list := pop(redo_list)

   refresh()

   return

end

#  Update text-list vidget's list and other data.  Then set touched to
#  switch.

procedure refresh(switch)
   local k, defns_list
   static pos, x, y, symbol_old, X, Y, name_old, left_old, vx, vy, fx, fy, px
   static size_old, defns_old, depth_old, spacing, sx, sy, gx, gy, dx, dy, py

   initial {				# RENAME IDENTIFIERS
      pos := list(1)
      spacing := WAttrib("leading") - 2		# ad hoc
      vx := variable.ax + TextWidth("variable: ")
      vy := variable.ay + spacing
      fx := filename.ax + TextWidth("file name: ")
      fy := filename.ay + spacing
      sx := symsleft.ax + TextWidth("symbols left: ")
      sy := symsleft.ay + spacing
      gx := gsize.ax + TextWidth("grammar size: ")
      gy := gsize.ay + spacing
      dx := definitions.ax + TextWidth("definitions: ")
      dy := definitions.ay + spacing
      px := depth.ax + TextWidth("depth: ")
      py := depth.ay + spacing
      symbol_old := name_old := left_old := size_old := defns_old :=
         depth_old := ""
      }

   symbol_tbl[symbol] := workspace_string

   VSetItems(plist, str2lst(workspace_string, LineWidth))

   defns_list := []

   every k := !keylist(symbol_tbl) do
      put(defns_list, k || "->" || symbol_tbl[k])

   VSetItems(slist, defns_list)

   pos[1] := *symbol_tbl

   VSetState(slist, pos)

   WAttrib("drawop=reverse")
   DrawString(vx, vy, symbol_old)		# update variable display
   DrawString(vx, vy, symbol_old := symbol)
   DrawString(fx, fy, name_old)
   DrawString(fx, fy, name_old := (\nav_file | ""))
   DrawString(sx, sy, left_old)
   DrawString(sx, sy, left_old := *symbols_list)
   DrawString(gx, gy, size_old)
   DrawString(gx, gy, size_old := size())
   DrawString(dx, dy, defns_old)
   DrawString(dx, dy, defns_old := *symbol_tbl)
   DrawString(px, py, depth_old)
   DrawString(px, py, depth_old := gdepth())
   WAttrib("drawop=copy")

   touched := switch

   return

end

procedure remap()
   local terms, i, t1, t2, tmp, values

   save_state(undo_list)

   terms := keylist(symbol_tbl)
   values := copy(terms)

   t1 := ""
   every t1 ||:= !terms

   repeat {
      if TextDialog("Remap terminal symbols:", terms, values, 1) ==
         "Cancel" then fail
      t2 := ""
      values := dialog_value
      every t2 ||:= !values
      if cset(t1) == cset(t2) then break
      else {
         Notice("Invalid remapping.")
         next
         }
      }

   tmp := table()

   every i := 1 to *terms do
      tmp[dialog_value[i]] := map(symbol_tbl[terms[i]], t1, t2)

   symbol_tbl := tmp

   symbol := map(symbol, t1, t2)
   goal := map(goal, t1, t2)
   workspace_string := map(workspace_string, t1, t2)

   refresh(1)

   return

end

procedure remove_symbol(s)
    local symbols_tmp, c

    symbols_tmp := []				# Note that order must be retained

    every c := !symbols_list do
       if c == s then next
       else put(symbols_tmp, c)			# DO MORE EFFICIENTLY

    symbols_list := symbols_tmp

    return

end

procedure revert()
   local input, line, symbol, count

   if /grammar then {
      return FailNotice("No grammar.")
      }

   if /touched then {
      return FailNotice("No changes since grammar last saved.")
      }

   if AskDialog("Revert to last saved?") == "No" then fail

   load_grammar() | fail

   return

end

procedure save_state(list)

   push(list, copy(symbols_list), workspace_string, symbol,
      copy(symbol_tbl), goal)

   return

end

#  Save current definition as a string.

procedure save_string()
   local output, file

   repeat {
      if SaveDialog("Save string:") ~== "Yes" then fail
      file := dialog_value
      if not overwrite(file) then next
      output := open(file, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      write(output, workspace_string)
      close(output)
      return
      }

end

#  Set up selection option.

procedure selections()

   return

end

#  Set up range specification.

procedure setup(range)
   local lo, hi, separator

   range ? {
      (lo := integer(tab(upto('+-:'))) &
      separator := =(":" | "+:" | "-:") &
      hi := integer(tab(0))) | fail
      }

   if lo < 1 then lo +:= *workspace_string + 1

   case separator of {
      ":"      :  if hi < 1 then hi +:= *workspace_string + 1
      "+:"     :  hi +:= lo
      "-:"     :  hi := lo - hi
      }
   workspace_string ? {
      tab(lo) &
      mid := tab(hi)
      } | fail

   return

end

#  Show results of a successful search

procedure show_results(caption, info, selector, match_lst, val_tbl) 
   local i, value

   if ToggleDialog(caption, info, selector) == "Cancel"
         then fail

   every i := 1 to *dialog_value do {
      if \dialog_value[i] then {
         info[i] ? {
            tab(many(' '))
            value := match_lst[tab(upto('.'))]
            }
         if pat_count(val_tbl[value]) > 0 then
            encode(val_tbl[value], value) | fail
         }
      }

   return

end

#  Compute file size for grammar.

procedure size()
   local result, k

   result := 0

   every k := key(symbol_tbl) do
      result +:= 3 + TerminatorWidth + *symbol_tbl[k]

   return result

end

# Show information on variables

procedure symbol_information()
   local result, symbols, usage

   symbols := ""

   every symbols ||:= !keylist(symbol_tbl)

   usage := if *symbols = 1 then " variable:" else " variables:"
   result := ["Grammar:", "", *symbols || usage, ""]

   result |||:= str2lst(symbols, 30)

   symbols := ""

   every symbols ||:= !vallist(token_tbl)

   usage := if *symbols = 1 then " token:" else " tokens:"

   put(result, "", *symbols || usage, "")

   result |||:= str2lst(symbols, 30)

   symbols := ""

   every symbols ||:= !symbols_list

   usage := if *symbols = 1 then " symbol available:" else " symbols available:"

   put(result, "", *symbols || usage, "")

   result |||:= str2lst(symbols, 30)

   Notice ! result

   return

end

# Tokenize reserved characters.

procedure tokenize()
   local symbol, tset, c, tstr, i, mlist, olist

   tset := string((MetaCharacters ++ goal) ** workspace_string)

   if *tset = 0 then return	# nothing to do

   if TextDialog("Tokenize meta-characters?", , , , ["No", "Yes"]) == "No"
      then return

   mlist := []
   every put(mlist, !tset)

   olist := list(*tset, 1)

   if ToggleDialog("Select meta-characters for encoding:", mlist, olist) ==
      "Cancel" then return

   tset := ""
  
   every i := 1 to *olist do
      if \dialog_value[i] then tset ||:= mlist[i]

   if *tset = 0 then return

   tstr := ""

   every c := !tset do {
      symbol := get(symbols_list) | {
         Notice("Symbols exhausted.") 
         fail
         }
      token_tbl[c] := symbol
      tstr ||:= symbol
      }

   workspace_string := map(workspace_string, tset, tstr)

   Notice("The reserved characters " || image(tset) ||
      " have been assigned to the symbols " || image(tstr) || ".")

   return

end

#  Restore last saved state

procedure undo()

   goal := pop(undo_list) | {
      Notice("No previous grammar.")
      fail
      }

   save_state(redo_list)

   symbol_tbl := pop(undo_list)
   symbol := pop(undo_list)
   workspace_string := pop(undo_list)
   symbols_list := pop(undo_list)

   refresh(1)

   return

end

#  See if match is syntactically valid.  Can be used to omit patterns
#  that are split pattern forms.  FOR NOW, ACCEPT ALL.

procedure valid(s)

   return 1			# nonnull valid, null invalid

end

#  Write out tokens

procedure write_tokens()
   local output, file, toks, token

   if *token_tbl = 0 then {
      Notice("No tokens.")
      fail
      }

   repeat {
      if SaveDialog("Write tokens:") ~== "Yes" then fail
      file := dialog_value
      if not overwrite(file) then next
      output := open(file, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      break
      }
      
   toks := sort(token_tbl, 4)

   while token := get(toks) do
      write(output, symbol := get(toks), "->", token)

   close(output)

   return

end