############################################################################
#
#	File:     qirplore.icn
#
#	Subject:  Program to explore square-root CF palindromes
#
#	Author:   Ralph E. Griswold
#
#	Date:     September 23, 2000
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  AD HOC.  This is an experimental program to allow the user to
#  explore quadirk databases.
#
############################################################################
#
#  Requires:  Version 9 graphics
#
############################################################################
#
#  Links:  graphics, io, lists, numbers, qirdb, xcode
#
############################################################################

link graphics
link io
link lists
link numbers
link qirdb
link xcode

global cexp
global comment
global diagout
global fexp
global ltrunc
global mexp
global nexp
global null
global prolist
global seqlist
global stack
global strunc

record palindrome(n, m, seq)

procedure main()
   local command

   palindrome			# hands off, linker!

   ltrunc := 50
   strunc := 30

   nexp := "1 to 10"
   mexp := "1 to 2 * n"
   cexp := "1"
   fexp := 1

   comment := ""

   seqlist := []
   prolist := []

   stack :=  []

   null := open("/dev/null", "w") |
      Notice("Cannot open null file for writing")

   diagout := &null

   while command := read() do {
      case command of {
         "c"      :  compute_seqs()
         "d"      :  show_seqs()
         "e"      :  edit_comment()
         "i"      :  Notice("number of sequences=" || *seqlist)
         "l"      :  load_db()  
         "p"      :  process_out()
         "q"      :  quit()
         "r"      :  select_seqs()
         "s"      :  save_db()
         "t"      :  set_truncs()
         "u"      :  undo()
         "v"      :  solve()
         "+"      :  diagout := &errout
         "-"      :  diagout := &null
         default  :  Notice("Invalid command")
         }
      }

end

procedure solve()
   local nseq, tseq, mseq, iseq, pseq, meqn, n, t, n1, t1, neqn
   local timage, teqn, d, pal, i, output, mode, m, m1, k, tmp_list

   static file

   nseq := []

   every put(nseq, (!seqlist).n)

   n := constant(delta(nseq)) | {
      Notice("n sequence does not have constant delta.")
      fail
      }

   if *nseq < 2 then {
      Notice("Insufficient data to solve.")
      fail
      }
   if *nseq < 4 then
      if TextDialog("Inadequate data to assure correct solution:  continue?",
         , , , ["No", "Yes"]) == "No" then fail

   pseq := []

   every put(pseq, *(!seqlist).seq)

   constant(pseq) | {
      Notice("palindrome sequence does not have constant size.")
      fail
      }

   if TextDialog("Positions of term:", , , 20) == "Cancel" then fail

   iseq := []

   dialog_value[1] ? {
      while tab(upto(&digits)) do
         put(iseq, integer(tab(many(&digits))))
      }

   k := iseq[1] | 1

   tseq := []

   every put(tseq, (!seqlist).seq[k])

   t := constant(delta(tseq)) | {
      Notice("term sequence does not have constant delta.")
      fail
      }

   mseq := []

   every put(mseq, (!seqlist).m)

   m := constant(delta(mseq)) | {
      Notice("m sequence does not have constant delta.")
      fail
      }

   n1 := (seqlist[1]).n - n
   t1 := seqlist[1].seq[k] - t
   m1 := (seqlist[1]).m - m

   neqn := eformat(n, n1)

   teqn := tformat(t, t1, n, n1)

   meqn := tformat(m, m1, n, n1)

   pal := copy(seqlist[1].seq)

   every i := !iseq do
      pal[i] := "X"

   image := 1

   timage := llimage(pal)

   image := proc("image", 0)

   repeat {
      case TextDialog(["n = " || neqn, "m = " || meqn,
         "t = " || teqn, "palindrome: " || timage], , , ,
         ["Write", "Verify", "Okay"]) of {
            "Okay"    :  fail
            "Write"   :  {
               mode := "w"
               repeat {
                  case TextDialog("File:", , file, 60, ["Append", "New", "Cancel"]) of {
                     "Cancel"  :  return
                     "Append"  :  mode := "a"
                     }
                  if mode == "w" & exists(dialog_value[1]) then {
                     if TextDialog("Overwrite existing file?", , , , ["No", "Yes"]) == "No"
                        then next
                     }
                  output := open(dialog_value[1], mode) | {
                     Notice("Cannot open file for writing.")
                     next
                     }
                  file := dialog_value[1]
                  break
                  }
               write(output, "\t", neqn, "\t\t", meqn, "\t\t", timage, "\t\t", teqn)
               close(output)
               }
            "Verify"  :  {
               nexp := map(neqn, "i", "I")
               mexp := meqn
               cexp := "1"
               fexp := "1"
               tmp_list := seqlist
               compute()
               if compare_seqs(tmp_list, seqlist) then
                  Notice("Okay")
               else seqlist := tmp_list
               next
               }
            }
         break
      }

   return

end

procedure compare_seqs(seq1, seq2)
   local rec1, rec2, i, k

   k := min(*seq1, *seq2)

   every i := 1 to k do {
      rec1 := seq1[i]
      rec2 := seq2[i]
      if rec1.m = rec2.m & rec1.n = rec2.n & lequiv(rec1.seq, rec2.seq) then
         next
      else {
         Notice(
            "Term mismatch at sequence " || i || ".",
            "Old sequence: n = " || rec1.n || " m = " || rec1.m ||
               " palindrome =" || limage(rec1.seq),
            "New sequence: n = " || rec1.n || " m = " || rec1.m ||
               " palindrome =" || limage(rec1.seq)
            )
         fail
         }
      }

end
      
procedure by_length()
   local rec, new_list
   static labels, value, last, op

   initial {
      labels := ["=", ">", "<", ">=", "<=", "~="]
      last := "="
      value := 3
      }

   if SelectDialog("Select by length:", labels, last) == "Cancel" then fail

   last := dialog_value

   repeat {
      if TextDialog("Value:", , value) == "Cancel" then fail
      if not (0 <= integer(dialog_value[1])) then | {
         Notice("Invalid value.")
         next
         }
      break
      }

   value := dialog_value[1]

   new_list := []

   save(seqlist)

   op := proc(last, 2)

   every rec := !seqlist do 
      if op(*rec.seq, value) then put(new_list, rec)

   seqlist := new_list

   return

end

procedure compute()
   local output, input

   output := open("/tmp/comqir.inc", "w") | {
      Notice("Cannot open header file.")
      fail
      }

   write(output, "$define NEXP (", nexp, ")")
   write(output, "$define MEXP (", mexp, ")")
   write(output, "$define CEXP (", cexp, ")")
   write(output, "$define FEXP (", fexp, ")")

   close(output)

   if system("icont -s comqir -x > /tmp/compdir.db") ~= 0 then fail

   input := open("/tmp/compdir.db") | {
      Notice("Cannot open database.")
      fail
      }

   seqlist := xdecode(input) | {
      Notice("Cannot decode database.")
      close(input)
      fail
      }

   close(input)

   return

end

procedure compute_seqs()

   repeat {
      if TextDialog(
         "Computation specification:",
         ["n:=", "m:=", "condition", "filter", "comment"],
         [nexp, mexp, cexp, fexp, comment], 60
         ) == "Cancel" then fail
      nexp := dialog_value[1]
      mexp := dialog_value[2]
      cexp := dialog_value[3]
      fexp := dialog_value[4]
      comment := dialog_value[5]
      compute() | {
         Notice("Invalid specification.")
         next
         }
      break
      }

   show_seqs()

   return

end

procedure edit_comment()

   if TextDialog("Edit comment:", , comment, 90) == "Cancel" then fail

   comment := dialog_value[1]

   return

end

procedure load_db()
   local input

   repeat {
      if OpenDialog("Load database:") == "Cancel" then fail
      input := open(dialog_value) | {
         Notice("Cannot open file.")
         next
         }
      seqlist := xdecode(input) | {
         Notice("Cannot decode database.")
         close(input)
         next
         }
      close(input)
      break
      }

   show_seqs()

   return

end

procedure process_out()
   local i
   static labels, last

   initial {
      labels := ["length", "pivot", "term sum", "term average",
         "largest term", "smallest term", "span", "smallest delta",
            "largest delta"]
      last := "length"
      }

   if SelectDialog("Process:", labels, last) == "Cancel" then fail

   last := dialog_value

   prolist := list(*seqlist)

   case last of {
      "length"  :  {
         every i := 1 to *seqlist do
            prolist[i] := *seqlist[i]
         }
      "pivot"           :  {
         every i := 1 to *seqlist do
            prolist[i] := if *seqlist[i] % 2 = 0 then 0 else seqlist[i][-1]
         }
      "term sum"        :  {
         every i := 1 to *seqlist do
            prolist[i] := sum ! seqlist[i]
         }
      "term average"    :  {
         every i := 1 to *seqlist do
            prolist[i] := frn(amean ! seqlist[i], 3, 2)
         }
      "largest term"    :  {
         every i := 1 to *seqlist do
            prolist[i] := max ! seqlist[i]
         }
      "smallest term"   :  {
         every i := 1 to *seqlist do
            prolist[i] := min ! seqlist[i]
         }
      "span"            :  &null
      "smallest delta"  :  &null
      "largest delta"   :  &null
      default           :  {
         Notice("Function not supported.")
         fail
         }
      }

   return

end  

procedure llimage(seq)
   local result

   if *seq <= ltrunc then return limage(seq)
   else {
      result := limage(seq[1+:ltrunc])
      result[-1] := ",...]"
      return result
      }

end

procedure quit()

   exit()			# PROMPT TO SAVE

end

procedure save(x)

   push(stack, x)

   if *stack > 5 then pull(stack)

   return

end

procedure save_db()
   local output

   repeat {
      if OpenDialog("Save database:") == "Cancel" then fail
      output := open(dialog_value, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      break
      }

   xencode(seqlist, output)

   close(output)

   return

end

procedure select_seqs()
   local new_list
   static labels, last, rec

   initial {
      labels := ["by length", "odd length", "even length"]
      last := "by length"
      }

   if SelectDialog("Select:", labels, last) == "Cancel" then fail

   last := dialog_value

   new_list := []

   save(seqlist)

   case last of {
      "even length"  :  {
         every rec := !seqlist do
            if *rec.seq % 2 = 0 then put(new_list, rec)
         seqlist := new_list
         }
      "odd length"   :  {
         every rec := !seqlist do
            if *rec.seq % 2 = 1 then put(new_list, rec)
         seqlist := new_list
         }
      "by length"    :  by_length()
      }

   show_seqs()

   return

end

procedure set_truncs()

   repeat {
      if TextDialog("Limits:", ["list terms", "sequences"], [ltrunc, strunc]) ==
         "Cancel" then fail
         (
            ltrunc := (integer(0 < dialog_value[1])) &
            strunc := (integer(0 < dialog_value[2]))
            ) | {
               Notice("Invalid value.")
               next
               }
      break
      }

   return

end

procedure show_seqs()
   local lines, output, all, rec, i

   lines := ["n := " || \nexp, "m := " || mexp, "condition: " || cexp,
      "filter: " || fexp, "comment: " || comment, "",
         "   i       n      m  palindrome", ""] | {
            Notice("No specifications have been made.")
            fail
            }

   every rec := seqlist[i := 1 to *seqlist] do
      put(lines, right(i, 4) || " " || right(rec.n, 7) || " " ||
         right(rec.m, 6) || "  " || llimage(rec.seq))

   all := copy(lines)

   if *seqlist > strunc then {
      lines := lines[1+:strunc]
      put(lines, "            ...")
      }

   case TextDialog(lines, , , , ["Okay", "Solve", "Write", "Write All", "Recalculate"]) of {
      "Okay"         :  return
      "Solve"        :  {
         solve()
         return
         }
      "Recalculate"  :  {
         compute_seqs()
         return
         }
      "Write All"    :  lines := all
      }

   repeat {
      if OpenDialog("File:") == "Cancel" then fail
      output := open(dialog_value, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      break
      }

   every write(output, !lines)

   close(output)

   return

end 

procedure show_out(results)
   local output
   static buttons

   initial buttons := ["Okay", "Write"]

   if TextDialog(llimage(results), , , , buttons) == "Okay" then return

   repeat {
      if OpenDialog("File:") == "Cancel" then fail
      output := open(dialog_value, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      break
      }

   every write(output, !results)

   close(output)

   return

end

procedure undo()

   seqlist := pop(stack) | {
      Notice("Stack empty.")
      fail
      }

   return

end

procedure delta(seq)
   local deltaseq, i

   deltaseq := []

   every i := 2 to *seq do
      put(deltaseq, seq[i] - seq[i - 1])

   return deltaseq

end

procedure constant(seq)

   if *set(seq) = 1 then return seq[1]
   else fail

end

procedure eformat(n, n1)
   local neqn

   if n = 0 then neqn := n1
   else if n > 1 then neqn := n || "*i"
   else neqn := "i"

   if n1 > 0 then neqn ||:= "+" || n1
   else if n1 < 0 then neqn ||:= "-" || -n1

   return neqn

end

procedure tformat(t, t1, n, n1)
   local mult, term, body, d

   if t = 0 then return t1

   d := gcd(n, t)
   n /:= d
   t /:= d

   if t = 1 then mult := "" else mult := t || "*"

   t1 *:= n
   n1 *:= t
   n1 -:= t1

   if n1 > 0 then term := "(" || mult || "n-" || n1 || ")"
   else if n1 < 0 then term := "(" || mult || "n+" || -n1 || ")"
   else term := "n"

   body := term

   if n = 1 then return body
   else return body || "/" || n

end