1 files changed, 269 insertions, 0 deletions
diff --git a/ipl/procs/weaving.icn b/ipl/procs/weaving.icn
new file mode 100644
index 0000000..df8f8b2
--- /dev/null
+++ b/ipl/procs/weaving.icn
@@ -0,0 +1,269 @@
+############################################################################
+#
+#	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