############################################################################
#
#	File:     weaving.icn
#
#	Subject:  Procedures to implement weaving expressions
#
#	Author:   Ralph E. Griswold
#
#	Date:     October 22, 1999
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  These procedures implement the weaving expressions supported by Painter
#  and described in the PDF document "Advanced Weaving" that accompanies
#  that application.
#
############################################################################
#
#  Links:  strings
#
############################################################################

$define Domain		"12345678"
$define DomainForward	"1234567812345678"
$define DomainBackward  "8765432187654321"

procedure Between(p1, p2)

   DomainForward ? {
      tab(upto(p1[-1]) + 1)
      return tab(upto(p2[1]))
      }

end

procedure Block(p1, p2)			#: weaving block
   local i, s, p3, counts

   if *p1 < *p2 then p1 := Extend(p1, *p2) | fail
   else if *p2 <  *p1 then p2 := Extend(p2, *p1) | fail

   counts := []

   p2 ? {
      while s := tab(upto('{')) do {
         every put(counts, !s)
         move(1)
         put(counts, tab(upto('}')))
         move(1)
         }
      every put(counts, !tab(0))
      }

   p3 := ""

   every i := 1 to *p1 do
      p3 ||:= repl(p1[i], counts[i]) 

   return p3

end

procedure DownRun(c1, c2)		#: weaving downrun

   DomainBackward ? {
       tab(upto(c1))
       return tab(upto(c2) + 1)
       }

end

#  CYCLES WRONG

procedure DownUp(p1, p2, cycles)	#: weaving downup
   local i, p3

   /cycles := 0

   if *p1 < *p2 then p1 := Extend(p1, *p2) | fail
   else if *p2 <  *p1 then p2 := Extend(p2, *p1) | fail

   p3 := p1[1]

   if cycles > 0 then {
      DomainForward ? {
         tab(upto(p1[-1]) + 1)
         p3 ||:= repl(move(8), cycles)
         }
      }

   every i := 1 to *p1 do {
      p3 ||:= DownRun(p1[i], p2[i])[2:0]
      p3 ||:= UpRun(p2[i], p1[i + 1])[2:0]		# might fail
      }

   return p3

end

procedure Downto(p1, p2, cycles)	#: weaving downto
   local p3

   p3 := p1

   /cycles := 0

   if cycles > 0 then {
      DomainBackward ? {
         tab(upto(p1[-1]) + 1)
         p3 ||:= repl(move(8), cycles)
         }
      }

   DomainBackward ? {
      tab(upto(p1[-1]) + 1)
      return p3 || tab(upto(p2[1])) || p2
      }

end

procedure Extend(p, i)			#: weaving extension

   if *p = 0 then fail

   i := integer(i)

   return case i of {
      *p > i   :  left(p, i)
      *p < i   :  left(repl(p, (i / *p) + 1), i)
      default  :  p
      }

end

procedure Interleave(p1, p2)		#: weaving interleave
   local i, p3

   if *p1 < *p2 then p1 := Extend(p1, *p2) | fail
   else if *p2 <  *p1 then p2 := Extend(p2, *p1) | fail

   p3 := ""

   every i := 1 to *p1 do
      p3 ||:= p1[i] || p2[i]

   return p3

end

procedure Palindrome(p)			#: weaving palindrome

   if *p = 1 then return p
   else return p || reverse(p[2:-1])

end

procedure Pbox(p1, p2)			#: weaving pbox
   local p3, i

   if *p2 ~= *p1 then p2 := Extend(p2, *p1) | fail

   p3 := ""
   
   every i := !p1 do
      p3 ||:= p1[p2[i]]

   return p3

end

procedure Permute(p1, p2)		#: weaving permutation
   local p3, chunk, i, j

   j := *p1 % *p2
   if j ~= 0 then p1 := Extend(p1, *p1 + *p2 - j) | fail

   p3 := ""

   p1 ? {
      while chunk := move(*p2) do
         every i := !p2 do
            p3 ||:= chunk[i]
      }

   return p3

end

procedure Run(p, count)

   DomainForward ? {
      tab(upto(p[-1]) + 1)
      return repl(move(*Domain), count)
      }

end

procedure Template(p1, p2)		#: weaving Template
   local p3, dlist, i, j, k

   dlist := []

   every i := 1 to *p1 do
      put(dlist, p1[i] - p1[1])

   p3 := ""

   every j := 1 to *dlist do
      every i := 1 to *p2 do {
         k := p2[i] + dlist[j]
         if k > 8 then k -:= 8
         p3 ||:= k
         }

   return p3

end

#  CYCLES WRONG

procedure UpDown(p1, p2, cycles)	#: weaving updown
   local p3, i

   /cycles := 0

   if *p1 < *p2 then p1 := Extend(p1, *p2) | fail
   else if *p2 <  *p1 then p2 := Extend(p2, *p1) | fail

   p3 := p1[1]

   if cycles > 0 then {
      DomainForward ? {
         tab(upto(p1[-1]) + 1)
         p3 ||:= repl(move(8), cycles)
         }
      }

   every i := 1 to *p1 do {
      p3 ||:= UpRun(p1[i], p2[i])[2:0]
      p3 ||:= DownRun(p2[i], p1[i + 1])[2:0]		# might fail
      }

   return p3

end

procedure UpRun(c1, c2)			#: weaving uprun

   DomainForward ? {
       tab(upto(c1))
       return tab(upto(c2) + 1)
       }

end

procedure Upto(p1, p2, cycles)		#: weaving upto
   local p3

   /cycles := 0

   p3 := p1

   return p1 || Run(p1, cycles) || Between(p1, p2) || p2

end