1 files changed, 132 insertions, 0 deletions
diff --git a/ipl/gprocs/weavegif.icn b/ipl/gprocs/weavegif.icn
new file mode 100644
index 0000000..97c948f
--- /dev/null
+++ b/ipl/gprocs/weavegif.icn
@@ -0,0 +1,132 @@
+############################################################################
+#
+#	File:     weavegif.icn
+#
+#	Subject:  Procedure to produce a woven image from a draft
+#
+#	Author:   Ralph E. Griswold
+#
+#	Date:     June 10, 2001
+#
+############################################################################
+#
+#  This file is in the public domain.
+#
+############################################################################
+#
+#  This procedure produces a woven image from a pattern-form draft, which
+#  is passed to it as it's first argument.  Window attributes may be
+#  passed as a list in the second argument
+#
+############################################################################
+#
+#  Requires:  Version 9 graphics  
+#
+############################################################################
+#
+#  Links: tables, wopen
+#
+############################################################################
+#
+#  Links: wopen
+#
+############################################################################
+
+link wopen
+
+link tables, wopen
+
+procedure weavegif(draft, attribs)	#: create GIF from ISD
+   local x, y, color, treadle, i, j, treadle_list, k
+   local win, treadle_colors, lst, s
+
+   /attribs := []
+
+   /draft.width := *draft.threading
+   /draft.height := *draft.treadling
+
+   put(attribs, "label=" || draft.name, "size=" || draft.width || "," ||
+      draft.height)
+
+   win := (WOpen ! attribs) | {
+      write(&errout, "Cannot open window for woven image.")
+      fail
+      }
+
+   #  Draw warp threads as "background".
+
+   if \draft.color_list then {
+      if *set(draft.warp_colors) = 1 then {		# solid warp ground
+         Fg(draft.color_list[draft.warp_colors[1]])
+         FillRectangle()
+         }
+      every i := 1 to draft.width do {
+         Fg(win, draft.color_list[draft.warp_colors[i]])
+         DrawLine(win, i - 1, 0, i - 1, *draft.treadling - 1)
+         }
+      }
+   else {
+      every i := 1 to draft.width do {
+         Fg(win, draft.warp_colors[i])
+         DrawLine(win, i - 1, 0, i - 1, *draft.treadling - 1)
+         }
+      }
+
+   #  Precompute points at which weft threads are on top.
+
+   treadle_list := list(draft.treadles)
+   
+   every !treadle_list := [win]
+
+   every i := 1 to draft.treadles do {
+      every j := 1 to draft.shafts do
+         if draft.tieup[j, i] == "0" then
+            every k := 1 to *draft.threading do
+               if draft.threading[k] = j then
+                  put(treadle_list[i], k - 1, 0)
+      }
+
+   if \draft.color_list then {
+      treadle_colors := list(*draft.color_list)
+      every !treadle_colors := []
+      every i := 1 to draft.height do {
+         j := draft.weft_colors[i]
+         put(treadle_colors[j], i)
+         }
+      }
+   else {
+      treadle_colors := table()
+      every i := 1 to draft.width do {
+         j := draft.weft_colors[i]
+         /treadle_colors[j] := []
+         put(treadle_colors[j], i)
+         }
+      }
+   
+      #  "Overlay" weft threads.
+   
+   if \draft.color_list then {
+      every i := 1 to *treadle_colors do {
+         Fg(win, draft.color_list[i]) | stop("bogon")
+         every y := !treadle_colors[i] do {
+            WAttrib(win, "dy=" || (y - 1))
+            if *treadle_list[draft.treadling[y]] = 1 then next	# blank pick
+            DrawPoint ! treadle_list[draft.treadling[y]]
+            }
+         }
+      }
+   else {
+      every s := !keylist(treadle_colors) do {
+         Fg(win, s) | stop("bogon")
+         lst := treadle_colors[s]
+         every y := !lst do {
+            WAttrib(win, "dy=" || (y - 1))
+            if *treadle_list[draft.treadling[y]] = 1 then next	# blank pick
+            DrawPoint ! treadle_list[draft.treadling[y]]
+            }
+         }
+      }
+
+   return win
+
+end