1 files changed, 196 insertions, 0 deletions
diff --git a/ipl/gprogs/gif2wif.icn b/ipl/gprogs/gif2wif.icn
new file mode 100644
index 0000000..37678b1
--- /dev/null
+++ b/ipl/gprogs/gif2wif.icn
@@ -0,0 +1,196 @@
+############################################################################
+#
+#	File:     gif2wif.icn
+#
+#	Subject:  Program to produce a WIF from black & white image
+#
+#	Author:   Ralph E. Griswold
+#
+#	Date:     May 7, 2001
+#
+############################################################################
+#
+#  This file is in the public domain.
+#
+############################################################################
+#
+#  This program takes the name of a GIF file for a black & white image
+#  and outputs a WIF for a corresponding draft.  If the GIF is not
+#  strictly black & white, all non-black pixels are interpreted as
+#  white.
+#
+############################################################################
+#
+#  Links:  graphics
+#
+############################################################################
+#
+#  Requires:  Version 9 graphics
+
+############################################################################
+
+link graphics
+
+procedure main(args)
+   local rows, cols, treadling, threading, count, tieup, y, width, height
+   local shafts, treadles, i, tie_line, row, treadle, draft, p
+
+   WOpen("image=" || args[1], "canvas=hidden") |
+      stop("*** cannot open image")
+
+   width := WAttrib("width")
+   height := WAttrib("height")
+
+   rows := []			# start with empty list
+
+   every y := 0 to height - 1 do {
+      row := ""
+      every p := Pixel(0, y, width, 1) do
+         if ColorValue(p) == "0,0,0" then row ||:= "1"
+            else row ||:= "0"
+      put(rows, row)
+      }
+
+   cols := rot(rows)		# rotate to get columns
+
+   treadles := examine(rows)	# get treadles
+   shafts := examine(cols)	# get shafts
+
+   treadling := []		# construct treadling sequence
+   every put(treadling, treadles[!rows])
+
+   threading := []		# construct threading sequence
+   every put(threading, shafts[!cols])
+
+   tieup := table()
+
+   every row := key(treadles) do {		# get unique rows
+      treadle := treadles[row]			# assigned treadle number
+      tie_line := repl("0", *shafts)		# blank tie-up line
+      every i := 1 to *row do			# go through row
+         if row[i] == "1" then			#    if warp on top
+            tie_line[threading[i]] := "1"	#       mark shaft position
+      tieup[treadle] := tie_line		# add line to tie-up
+      }
+
+   #  Now output the WIF.
+
+   write("[WIF]")
+   write("Version=1.1")
+   write("Date=" || &dateline)
+   write("Developers=ralph@cs.arizona.edu")
+   write("Source Program=gif2wif.icn")
+
+   write("[CONTENTS]")
+   write("Color Palette=yes")
+   write("Text=yes")
+   write("Weaving=yes")
+   write("Tieup=yes")
+   write("Color Table=yes")
+   write("Threading=yes")
+   write("Treadling=yes")
+   write("Warp colors=yes")
+   write("Weft colors=yes")
+   write("Warp=yes")
+   write("Weft=yes")
+
+   write("[COLOR PALETTE]")
+   write("Entries=2")
+   write("Form=RGB")
+   write("Range=0," || 2 ^ 16 - 1)
+
+   write("[TEXT]")
+   write("Title=example")
+   write("Author=Ralph E. Griswold")
+   write("Address=5302 E. 4th St., Tucson, AZ 85711")
+   write("EMail=ralph@cs.arizona.edu")
+   write("Telephone=520-881-1470")
+   write("FAX=520-325-3948")
+
+   write("[WEAVING]")
+   write("Shafts=", *shafts)
+   write("Treadles=", *treadles)
+   write("Rising shed=yes")
+
+   write("[WARP]")
+   write("Threads=", *threading)
+   write("Units=Decipoints")
+   write("Thickness=10")
+   write("Color=1")
+
+   write("[WEFT]")
+   write("Threads=", *treadling)
+   write("Units=Decipoints")
+   write("Thickness=10")
+   write("Color=2")
+
+   write("[COLOR TABLE]")
+   write("1=0,0,0")
+   write("2=65535,65535,65535")
+
+   write("[THREADING]")
+   every i := 1 to *threading do
+      write(i, "=", threading[i])
+
+   write("[TREADLING]")
+   every i := 1 to *treadling do
+      write(i, "=", treadling[i])
+
+   write("[TIEUP]")
+   every i := 1 to *tieup do
+      write(i, "=", tromp(tieup[i]))
+
+end
+
+#procedure tromp(treadle)
+#   local result
+#
+#   result := ""
+#   
+#   treadle ? {
+#      every result ||:= upto("1") || ","
+#      }
+#
+#   return result[1:-1]
+#
+#end
+#
+procedure tromp(treadle)
+   local result, i
+
+   result := ""
+   
+   every i := 1 to *treadle do
+      if treadle[i] == 1 then result ||:= i || ","
+
+   return result[1:-1]
+
+end
+
+procedure examine(array)
+   local count, lines, line
+
+   lines := table()			# table to be keyed by line patterns
+   count := 0
+
+   every line := !array do		# process lines
+      /lines[line] := (count +:= 1)	# if new line, insert with new number
+
+   return lines
+
+end
+
+procedure rot(rows)
+   local cols, row, grid, i
+
+   cols := list(*rows[1], "")
+
+   every row := !rows do {
+      i := 0
+      every grid := !row do
+         cols[i +:= 1] := grid || cols[i]
+      }
+
+   return cols
+
+end