############################################################################
#
#	File:     seqops.icn
#
#	Subject:  Procedures to manipulate T-sequences
#
#	Author:   Ralph E. Griswold
#
#	Date:     April 3, 2001
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  These procedures perform operations related to T-Sequences.
#
############################################################################
#
#  Requires:  Courage.
#
############################################################################
#
#  Links:  factors, numbers
#
############################################################################

link factors
link numbers
link get

global expressions
global node_gen
global saltparity
global scompact
global sfliph
global sflipv
global sflipr
global sflipl

record node(name, seqlist)

$define MaxTerms 300

procedure copyl(xargs[])		#: copy list of lists
   local new_xargs

   new_xargs := []

   every put(new_xargs, copy(spromote(!xargs)))

   return new_xargs

end

procedure eval_tree(n)
   local i

   n := integer(n)

   if type(n) ~== "node" then return n

   every i := 1 to *n.seqlist do
      n.seqlist[i] := eval_tree(n.seqlist[i])

   return n.name ! n.seqlist

end

procedure expression_tree(n)
   local result

   n := integer(n)

   case type(n) of {
      "list" | "integer"  :  return "[" || simage(n, MaxTerms) || "]"
      "string"            :  return n
      }

   result :=  n.name || "("

   every result ||:= expression_tree(!n.seqlist) || ","

   return result[1:-1] || ")"

end

procedure fragment(s, i, p, arg)
   local results, j, k

   if *s <= i then return s

   /p := 1

   results := list(i)

   every !results := []

   k := 0

   every j := 1 to i do
      every 1 to  *s / i do
         put(results[j], s[k +:= 1]) | break break

   every j := 1 to i do
      results[j] := p(results[j], arg)

   every j := 1 to i do
      results[j] := fragment(results[j], i, p, arg)

   return results

end

procedure is_scompact(x)		#: test sequence for compactness
   local bound

   x := spromote(x)

   bound := sbound ! x

   if bound = *set(x) then return bound
   else fail

end

procedure pimage(s)			# DOES THIS BELONG HERE?
   local result, x

   result := ""

   every x := !s do {
      if integer(x) then result ||:= x else
         result ||:= pimage(x)
      result ||:= ","
      }

   return "[" || result[1:-1] || "]"

end

procedure sanalout()
   local expression, var

   write("link seqops")
   write("procedure main()")

   expressions := sort(expressions, 4)

   while expression := get(expressions) do
      write(var := get(expressions), " := ", expression)

   write("every write(!", var, ")")

   write("end")

   expressions := table()

   return

end

procedure sanalysis(x)

#  sanalyze(x)

   sanalout()

   return

end

procedure sbinop(op, xargs[])	#: binary operation on terms
   local lseq, i, x1, x2

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2])

   op := proc(op, 2) | fail

   lseq := []

   every i := 1 to smin(*x1, *x2) do
      put(lseq, op(x1[i], x2[i]))

   return lseq

end

procedure sbound(xargs[])	#: compute sequence upper bound  FIX!

   return sort(xargs)[-1]

end

procedure scollate(xargs[])	#: sequence collation
   local lseq, i, order

   if \node_gen then return node("scollate", xargs)

   order := get(xargs)

   /order := srun(1, *xargs)

   xargs := copyl ! xargs

   lseq := []

   while i := get(order) do {
      put(order, i)
      put(lseq, get(xargs[i])) | break
      }

   put(lseq, get(xargs[get(order)]))		# ?????

   return lseq

end

procedure scompress(xargs[])		#: compact sequence
   local unique, target, x

   if \node_gen then return node("compress", xargs)

   x := spromote(xargs[1])

   unique := set(x)

   target := []

   every put(target, 1 to *unique)

   return smap(x, sort(unique), target)

end

procedure sconcat(xargs[])		#: concatenate sequences
   local lseq

   if \node_gen then return node("sconcat", xargs)

   lseq := []

   every lseq |||:= spromote(!xargs)

   return lseq

end

procedure scpal(xargs[])		#: closed sequence palindrome
   local lseq, x1, x2, i

   if \node_gen then return node("scpal", xargs)

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2]) | [1]

   i := 0

   every i +:= !x2

   lseq := srepeat(sopal(x1), i)

   put(lseq, lseq[1])

   return lseq

end

procedure sdistrib(x)
   local lseq, i

   x := copy(spromote(x))

   lseq := list(sbound ! x, 0)

   while i := get(x) do
      lseq[i] +:= 1

   return lseq

end

procedure sequiv(x1, x2)		# test for sequence equivalence
   local i

   x1 := spromote(x1)
   x2 := spromote(x2)

   if *x1 ~= *x2 then fail

   every i := 1 to *x1 do
      if x1[i] ~= x2[i] then fail

   return x2

end

procedure sextend(xargs[])		#: extend sequence
   local lseq, part, i, x1, x2

   if \node_gen then return node("sextend", xargs)

   x1 := spromote(xargs[1])

   lseq := []

   every i := !spromote(xargs[2]) do {
      part := []
      until *part >= i do
         part |||:= x1
      lseq |||:= part[1+:i]
      }

   return lseq

end

procedure sflatten(s)		# flatten packet sequence  BELONGS HERE?
   local lseq, x

   lseq := []

   every x := !s do
      if type(x) == "list" then lseq |||:= sflatten(x)
      else put(lseq, x)

   return lseq

end

procedure simage(x, limit)		#: string image of sequence
   local str

   x := spromote(x)

   if *x = 0 then return "[]"

   /limit := 2 ^ 16			# good enough

   str:= ""

   every str ||:= (!x \ limit) || ", "

   if *x > limit then str ||:= "...  "

   return str[1:-2]

end

procedure sinit()		#: initialize sequence operations

   saltparity := sparity
   scompact := scompress
   sfliph := sreflecth
   sflipv := sreflectv
   sflipr := sreflectr
#  sflipl := sreflectl

   return

end

procedure slayer(xargs[])	#: layer sequences
   local new_xargs, i, shift

   if \node_gen then return node("slayer", xargs)

   new_xargs := [xargs[1], xargs[2]] | fail

   if not integer(xargs[2][1]) then return scollate ! xargs

   shift := sbound ! xargs[2]

   every i := 3 to *xargs do {
      put(new_xargs, sshift(xargs[i], shift))
      shift +:= sbound ! xargs[i]
      }

   return scollate ! new_xargs

end

procedure slength(x)		#: compute sequence length

   return *spromote(x)

end

procedure slocate(xargs[])	#: sequences of first positions of terms
  local count, i, lseq, x1, x2

   if \node_gen then return node("slocate", xargs)

   x1 := copy(spromote(xargs[1]))
   x2 := set(spromote(xargs[2]))

   lseq := []

   count := 0

   while i := get(x1) do {
      count +:= 1
      if member(x2, integer(i)) then
         return count
      }

   fail

end

procedure smap(xargs[])		#: map terms in sequence
   local i, smaptbl, x1, x2, x3
   static tdefault

   initial tdefault := []

   x1 := copy(spromote(xargs[1]))
   x2 := spromote(xargs[2])
   x3 := spromote(xargs[3])

   if *x2 ~= *x3 then fail

   smaptbl := table(tdefault)		# mapping table

   every i := 1 to *x2 do		# build the map
      smaptbl[x2[i]] := x3[i]

   every i := 1 to *x1 do		# map the values
      x1[i] := (tdefault ~=== smaptbl[x1[i]])

   return x1

end

procedure smin(xargs[])		#: compute sequence lower bound	FIX

   return sort(xargs)[1]

end

procedure smissing(x)		#: missing terms in sequence  BUGUS??
   local lseq, i, result

   x := spromote(x)

   lseq := sorder(x)

   result := []

   every i := 1 to *lseq do
      if lseq[i] = 0 then put(result, i)

   return result

end

procedure smod(xargs[])		#: modular reduction
   local lseq, i, x1, x2

   if \node_gen then return node("smod", xargs)

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2])

   lseq := []

   every i := !x2 do
      every put(lseq, residue(!x1, i, 1))

   return lseq

end

procedure smutate(xargs[])	#: mutation
   local lseq, x1, x2

   if \node_gen then return node("smutate", xargs)

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2])

   lseq := []

   every put(lseq, x1[!x2])

   return lseq

end

procedure snormal(x)		#: normalize sequence
   local lseq, i, target, count	# maps shafts so they are numbered in order
				# first appearance
   x := spromote(x)

   lseq := []

   count := 0

   target := table()

   every i := !x do {
      /target[i] := (count +:= 1)
      put(lseq, target[i])
      }

   return lseq

end

procedure sopal(xargs[])		#: create open sequence palindrome
   local x

   if \node_gen then return node("sopal", xargs)

   x := spromote(xargs[1])

   return x ||| sreflecth(x)[2:-1]

end

procedure sorder(x)		#: positions of first occurrence
  local lseq, i, done		#  of terms in *compact* sequence

   x := copy(spromote(x))

   lseq := []

   done := set()

   while i := integer(get(x)) do {
      if member(done, i) then next
      else {
         put(lseq, i)
         insert(done, i)
         }
      }

   return lseq

end

procedure sparity(xargs[])		#: adust parity
   local lseq, i, j, k, x1, x2

   if \node_gen then return node("sparity", xargs)

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2])

   lseq := []

   every i := 1 to *x1 do {
      j := x1[i]
      k := x2[i]
      if (j % 2) = (k % 2) then put(lseq, j)
      else put(lseq, j + 1, j)
      }

   return lseq

end

procedure shaft_period(x1, x2)	#: shaft period
   local results

   x1 := spromote(x1)
   x2 := spromote(x2)

   return sconstant(sdelta(spositions(x1, x2)))

end

procedure splace(xargs[])	#: place motif along a path
   local lseq, i, x1, x2

   if \node_gen then return node("splace", xargs)

   x1 := copy(spromote(xargs[1]))
   x2:= spromote(xargs[2])

   lseq := []

   every i := !x2 do
      every put(lseq, !x1 + i - 1)

   return lseq

end

procedure splaceg(xargs[])	#: generalized motifs along a path
   local lseq, i, path, motif

   if \node_gen then return node("splaceg", xargs)

   path := copy(get(xargs))

   xargs := copyl ! xargs

   lseq := []

   while i := get(path) do {
      motif := get(xargs)
      put(xargs, motif)
      every put(lseq, !motif + i - 1)
      }

   return lseq

end

procedure spromote(x)		#: promote term to sequence

   if type(x) ~== "list" then x := [x]

   return x

end

procedure sreflecth(xargs[])		#: reflect sequence horizontally
   local lseq, x

   if \node_gen then return node("sreflecth", xargs)

   lseq := []

   every push(lseq, !spromote(xargs[1]))

   return lseq

end


procedure sreflectr(xargs[])
   local lseq, i, bound, x

   if \node_gen then return node("sreflectr", xargs)

   x := spromote(xargs[1])

   bound := sbound ! x

   lseq := []

   every i := !x do
      push(lseq, bound - i + 1)

   return lseq

end

procedure sreflectv(xargs[])		#: refect sequence vertically
   local lseq, m, x

   if \node_gen then return node("sreflectv", xargs)

   x := spromote(xargs[1])

   if not integer(x[1]) then return x

   m := sbound ! x

   lseq := []

   every put(lseq, m - !x + 1)

   return lseq

end

procedure sremdupl(xargs[])		#: remove duplicate adjacent terms
   local lseq, i, x

   if \node_gen then return node("sremdupl", xargs)

   x := copy(spromote(xargs[1]))

   lseq := [get(x)] | return []

   while i := get(x) do
      if lseq[-1] ~= i then
         put(lseq, i)

   return lseq

end

procedure srepeat(xargs[])		#: repeat sequence
   local lseq, count, x1, x2

   if \node_gen then return node("srepeat", xargs)

   x1 := spromote(xargs[1])

   count := 0

   every count +:= !spromote(xargs[2])

   lseq := copy(x1)

   every 2 to count do
         lseq |||:= x1

   return lseq

end

procedure srotatev(xargs[])		#: rotate sequence vertically
   local lseq, m, x

   if \node_gen then return node("srotatev", xargs)

   x := spromote(xargs[1])

   if not integer(x[1]) then return x

   m := sbound ! x

   lseq := []

   every put(lseq, residue(!x + 1, m, 1))

   return lseq

end

procedure srun(xargs[])		#: create connected runs
   local lseq, i, j, x

   if \node_gen then return node("srun", xargs)

   x := copy(spromote(xargs[1]))

   lseq := []

   i := get(x) | return lseq

   while j := get(x) do {
      lseq |||:= sruns(i, j, 1)
      pull(lseq)
      i := j
      }

   put(lseq, i)

   return lseq

end     

procedure srepl(xargs[])		# replicate sequence terms
   local lseq, i, j, x1, x2

   if \node_gen then return node("srepl", xargs)

   x1 := spromote(xargs[1])
   x2 := spromote(xargs[2])

   lseq := []

   every i := !x2 do
      every j := !x1 do
         every 1 to i do
            put(lseq, j)

   return lseq

end

procedure sruns(xargs[])		# disconnected runs
   local lseq, i, j, k, limit, x1, x2, x3

   if \node_gen then return node("sruns", xargs)

   x1 := copy(spromote(xargs[1]))
   x2 := copy(spromote(xargs[2]))
   x3 := copy(spromote(xargs[3]) | [1])

   lseq := []

   repeat {
      i := get(x1) | break
      j := get(x2) | break
      k := get(x3) | break
      put(x3, k)			# cycle
      if integer(j) < integer(i) then k := -k
      every put(lseq, i to j by k)
      }

   return lseq

end
 
procedure sscale(xargs[])		#: scale terms in sequence
   local lseq, j, i, x1, x2

   if \node_gen then return node("sscale", xargs)

   x1 := spromote(xargs[1])

   lseq := []

   every i := !spromote(xargs[2]) do
      every j := 1 to *x1 do
          put(lseq, (x1[j] - 1) * i + 1)

   return lseq	

end

procedure sselect(xargs[])		#: select terms from sequence
   local lseq, i, x1, x2

   if \node_gen then return node("sselect", xargs)

   x1 := spromote(xargs[1])
   x2 := copy(spromote(xargs[2]))

   lseq := []

   while i := get(x2) do
      put(lseq, x1[i])		# may fail

   return lseq

end

procedure sshift(x, i)		#: shift terms sequence
   local lseq

   lseq := []

   every put(lseq, !spromote(x) + i)

   return lseq

end

procedure sunmod(x)		#: modular expansion
   local base, bound, i, lseq, k

   x := copy(spromote(x))

   if not integer(x[1]) then return x

   base := 0

   bound := sbound ! x

   lseq := [get(x)] | fail

   while i := get(x) do {
      if (i = 1) & (lseq[-1] = base + bound) then
         base +:= bound
      else if (i = bound) & (lseq[-1] = base + 1) then
         base -:= bound
      put(lseq, base + i)
      }

   k := (smin ! lseq)

   if k > 0 then return lseq

   k := bound * (-k / bound + 1)

   every !lseq +:= k

   return lseq

end
procedure sunop(op, xargs[])		#: unary operation on terms
   local lseq, i, x

   if \node_gen then return node("sunop", xargs)

   x := spromote(xargs[1])

   op := proc(op, 1) | fail

   lseq := []

   every i := 1 to *x do
      put(lseq, op(x[i]))

   return lseq

end

procedure walk_tree(n, tree_list, tree_ptrs, depth)
   local indent

   /tree_list := []
   /tree_ptrs := []
   /depth := 0

   indent := repl(" ", 3 * depth)

   n := integer(n)

   case type(n) of {
      "integer" | "list"  :  {
         put(tree_list, indent || "[" || simage(n, MaxTerms) || "]")
         put(tree_ptrs, n)
         return [tree_list, tree_ptrs]
         }
      "string"            :  {
         put(tree_list, indent || n)
         put(tree_ptrs, n)
         return [tree_list, tree_ptrs]
         }
      }

   put(tree_list, indent || n.name)
   put(tree_ptrs, n)

   every walk_tree(!n.seqlist, tree_list, tree_ptrs, depth + 1)

   return [tree_list, tree_ptrs]

end