############################################################################
#
#	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
