############################################################################
#
#	File:     expander.icn
#
#	Subject:  Procedures to convert character pattern expressions
#
#	Author:   Ralph E. Griswold
#
#	Date:     May 2, 2001
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  pfl2str(pattern) expands pattern-form expressions, which have the form
#
#	[<expr><op><expr>]
#
#  to the corresponding string.
#
#  The value of <op> determines the operation to be performed.
#
#  pfl2gxp(pattern) expands pattern-form expressions into generators
#  that, when compiled and evaluated, produce the corresponding
#  string.
#
#  pfl2pwl(pattern) converts pattern-form expressions to Painter's
#  weaving language.
#
###########################################################################n
#
#  Links:  strings, weaving
#
############################################################################

link strings
link weaving

procedure pfl2str(pattern)		#: pattern-form to plain string
   local result, expr1, expr2, op
   static operator, optbl

   initial {
      operator := '*-!|+,/~:?%<>#`'

      optbl := table()

      optbl["*"] := repl
      optbl["<"] := Upto
      optbl[">"] := Downto
      optbl["-"] := UpDown
      optbl["|"] := Palindrome
#     optbl["!"] := Palindroid
      optbl["+"] := Block
      optbl["~"] := Interleave
      optbl["->"] := Extend
      optbl[":"] := Template
      optbl["?"] := Permute
      optbl["%"] := Pbox
      optbl["<>"] := UpDown
      optbl["><"] := DownUp
      optbl["#"] := rotate
      optbl["`"] := reverse
      optbl[","] := proc("||", 2)
      }

   result := ""

   pattern ? {
      while result ||:= tab(upto('[')) do {
         move(1)
#        expr1 := pfl2str(tab(bal(operator, '[', ']'))) | return error("1", pattern)
         expr1 := pfl2str(tab(bal(operator, '[', ']'))) | {
            result ||:= pfl2str(tab(bal(']', '[', ']')))
            move(1)
            next
            }
         op := tab(many(operator)) | return error("2", pattern)
         expr2 := pfl2str(tab(bal(']', '[', ']'))) | return error("3", pattern)
         result ||:= \optbl[op](expr1, expr2) | return error("4", pattern)
         move(1)
         }
      if not pos(0) then result ||:= tab(0)
      }

   return result

end

procedure pfl2pwl(pattern)		#: pattern form to Painter expression
   local result, i, j, slist, s, expr1, expr2, op, head
   static operator, optbl

   initial {
      operator := '*-!|+,;/~:?%<>#`'

      optbl := table()

      optbl["*"] := "*"
      optbl["<"] := "<"
      optbl[">"] := ">"
      optbl["-"] := "-"
      optbl["|"] := "|"
      optbl["!"] := "!"		# not supported in PWL
      optbl["+"] := "[]"
      optbl["->"] := "->"
      optbl["~"] := "~"
      optbl[":"] := ":"
      optbl["?"] := " perm "
      optbl["%"] := " pbox "
      optbl["<>"] := "<>"
      optbl["><"] := "><"
      optbl["#"] := "#"
      optbl["`"] := "`"
      optbl[","] := ","
      }

   result := ""

   pattern ? {
      while head :=  tab(upto('[')) do {
         if *head > 0 then result ||:= "," || head
         move(1)
         expr1 := pfl2pwl(tab(bal(operator, '[', ']'))) | return error()
         op := tab(many(operator)) | return error()
         expr2 := pfl2pwl(tab(bal(']', '[', ']'))) | return error()
         result ||:= "," ||  "(" || expr1 || \optbl[op] || expr2 || ")" |
            return error()
         move(1)
         }
      if not pos(0) then result ||:= "," || tab(0)
      }

   return result[2:0]

end

procedure error(expr1, expr2)

   write(&errout, "*** error ", expr1, " ", expr2)

   fail

end

procedure pfl2gxp(pattern, arg)		#: pattern form to generating expression
   local result, i, j, slist, s, expr1, expr2, op
   static operator, optbl, argtbl

   initial {

      operator := ',.*-!|+;/~:?%<>#`'

      optbl := table()

      optbl["*"] := "Repl{"
      optbl["<"] := "Upto{"
      optbl[">"] := "Downto{"
      optbl["-"] := "UpDownto{"
      optbl["|"] := "TileMirror{"
      optbl["!"] := "Palin{"
      optbl["+"] := "Valrpt{"
      optbl["~"] := "Inter{"
      optbl["->"] := "ExtendSeq{"
      optbl["~"] := "Parallel{"
      optbl[":"] := "Template{"
      optbl["?"] := "Permut{"
      optbl["%"] := "Pbox{"
      optbl["<>"] := "UpDown{"
      optbl["><"] := "DownUp{"
      optbl["#"] := "Rotate{"
      optbl["`"] := "Reverse{"
      optbl["*"] := repl
      }

   /arg := str

      # Handling of literal arguments

      argtbl := table(str)
      argtbl["*"] := 1
      argtbl["#"] := 1
      argtbl["->"] := 1

   if /pattern | (*pattern = 0) then return image("")

   result := ""

   pattern ? {
      while result ||:= arg(tab(upto('['))) do {
         move(1)
         expr1 := pfl2gxp(tab(bal(operator, '[', ']')), arg) | {
            result ||:= tab(bal(']', '[', ']')) || " | "	# no operator
            move(1)
            next
            }
         if ="." then result ||:= tab(bal(']', '[', ']')) || " | "
         else {
            op := tab(many(operator))  | return error()
            expr2 := pfl2gxp(tab(bal(']', '[', ']')), argtbl[op]) | return error()
            result ||:= \optbl[op] || expr1 || "," || expr2 || ") | " |
              return error()
            }
         move(1)
         }
      if not pos(0) then result ||:= arg(tab(0))
      }

   return trim(result, '| ')

end

procedure lit(s)

   return "!" || image(s)

end

procedure str(s)

   return lit(s) || " | "

end

procedure galt(s)

   return "Galt{" || collate(s, repl(",", *s - 1)) || "}"

end

procedure pwl2pfl(wexpr)		#: Painter expression to pattern form

   return pwlcvt(prepare(wexpr))

end

procedure prepare(wexpr)		# preprocess pwl
   local inter, result
   static names, names1

   initial {
      names := [
         "",				# expression placeholder
         " block ", "[]",
         " repeat ", "*",
         " rep ", "*",
         " extend ", "==",
         " ext ", "==",
         " concat ", ",",
         " interleave ", "~",
         " int ", "~",
         " upto ", ">",
         " downto ", "<",
         " template ", ":",
         " temp ", ":",
         " palindrome ", "|",
         " pal ", "|",
         " pal", "|",
         " permute ", "?",
         " perm ", "?",
         " pbox ", "%",
         " updown ", "<>",
         " downup ", "><",
         " rotate ", "#",
         " rot ", "#",
         " reverse ", "`",
         " rev ", "`",
         " rev", "`",
         ]

      names1 := [
         "",				# expression placeholder
         "pal", "|",
         "rev", "`"
         ]

      }

   result := ""

   wexpr ? {
      while result ||:= tab(upto('[')) do {
         move(1)
         inter := tab(bal(']'))
         if *inter > 0 then result ||:= spray(inter)
         else result ||:= "[]"
         move(1)
         }
      result ||:= tab(0)
      }

   if upto(result, ' ') then {
      if upto(result, &letters) then {
         names[1] := result
         result := (replacem ! names)
         }
      }

   if upto(result, &letters) then {
      names1[1] := result
      result := (replacem ! names1)
      }

   return deletec(map(result, "[]", "=="), ' ')

end

procedure pwlcvt(wexpr)
   local result, inter

   wexpr ?:= {
      2(="(", tab(bal(')')), pos(-1))
      }
      
   result := ""

   wexpr ? {
      while result ||:= form1(pwlcvt(tab(bal('|`', '([', ']('))), move(1))
      result ||:= tab(0)
      }

   wexpr := result
   result := ""

   wexpr ? {
      while result ||:= form2(pwlcvt(tab(bal('->:#*=~', '([', ')]'))),
         =("#" | "*" | "->" | "~" | ":" | "=="), pwlcvt(tab(0)))
      result ||:= tab(0)
      }

   wexpr := result
   result := ""
 
   wexpr ? {
      while result ||:= form2(pwlcvt(tab(bal('<>', '([', ')]'))),
         =("><" | "<>"), pwlcvt(tab(0)))
      result ||:= tab(0)
      }

   wexpr := result
   result := ""
 
   wexpr ? {
      while result ||:= form2(pwlcvt(tab(bal('<->,', '([', ')]'))),
         =(">" | "<" | "-" | ","), pwlcvt(tab(0)))
      result ||:= tab(0)
      }
      
   return result

end

procedure form1(wexpr, op)

   return "[" || wexpr || op || "]"

end

procedure form2(wexpr1, op, wexpr2)

   return "[" || wexpr1 || op || wexpr2 || "]"

end

procedure spray(inter)
   local count, s1, s2, s3, colors

   s1 := s2 := s3 := ""

   inter ?:= {		# only palindome and reflection allowed, it seems
      1(tab(upto('|`') | 0), s3 := tab(0))
      }

   inter ? {
      while s1 ||:= colors := tab(upto(' ')) do {
         tab(many(' '))
         count := tab(upto(' ') | 0)
         if *count = 1 then s2 ||:= repl(count, *colors)
         else s2 ||:= repl("{" || count || "}", *colors)
         move(1) | break
         }
      }
   
   return "((" || s1 || s3 || ")" || "[]" || s2 || ")"

end