############################################################################
#
#	File:     weavutil.icn
#
#	Subject:  Procedures to support numerical weavings
#
#	Author:   Ralph E. Griswold
#
#	Date:     March 20, 1999
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  Links:  expander, tables, tieutils
#
############################################################################

link expander
link tables
link tieutils

$include "weavdefs.icn"

#  PFL weaving parameters

record PflParams(P, T)

#  Weaving specification

record weaving(
   name,
   width,
   height,
   modulus,
   threading,
   treadling,
   palette,
   warp_colors,
   weft_colors,
   tieup,
   defns,
   links,
   comments
   )

record draft(
   name,
   threading,
   treadling,
   warp_colors,
   weft_colors,
   palette,
   tieup, 
   liftplan,
   shafts,
   treadles
   )

procedure readpfd(input)		# read PFD
   local pfd

   pfd := draft()

   pfd.name := read(input) &
   pfd.threading := read(input) &
   pfd.treadling := read(input) &
   pfd.warp_colors := read(input) &
   pfd.weft_colors := read(input) &
   pfd.palette := read(input) &
   pfd.tieup := read(input) &
   pfd.liftplan := read(input) | fail

   pfd.tieup ? {
      pfd.shafts := integer(tab(upto(';'))) | 8
      move(1)
      pfd.treadles := integer(tab(upto(';'))) | 8
      }

   pfd.tieup := tie2tier(pfd.tieup)
   if *\pfd.liftplan > 0 then pfd.liftplan := tie2tier(pfd.liftplan)

   return pfd

end

procedure writepfd(output, pfd)		#: write PFD

   write(output, pfd.name)
   write(output, pfd.threading)
   write(output, pfd.treadling)
   write(output, pfd.warp_colors)
   write(output, pfd.weft_colors)
   write(output, pfd.palette)
   write(output, tier2string(pfd.tieup))
   if *\pfd.liftplan > 0 then write(tier2string(pfd.liftplan)) else write()

   return

end

procedure expandpfd(pfd)		#: expand PFD

   pfd := copy(pfd)

   pfd.threading := pfl2str(pfd.threading)
   pfd.treadling := pfl2str(pfd.treadling)

   pfd.warp_colors := map(pfl2str(pfd.warp_colors, C1In, C1Ex))
   pfd.weft_colors := map(pfl2str(pfd.weft_colors, C1In, C1Ex))

   if *pfd.warp_colors = 0 then
      pfd.warp_colors := repl("0", *pfd.threading)
   else if *pfd.warp_colors < *pfd.threading then
      pfd.warp_colors := Extend(pfd.warp_colors, *pfd.threading)
   if *pfd.weft_colors = 0
      then pfd.weft_colors := repl("1", *pfd.threading)
   else if *pfd.weft_colors < *pfd.treadling then
      pfd.weft_colors := Extend(pfd.weft_colors, *pfd.treadling)

   return pfd

end


#  Write include file for weavgenr

procedure write_spec(name, spec, opt)	#: write weaving include file
   local n, output, v
   static bar

   initial bar := repl("#", 72)

   /opt := "w"

   output := open(name, opt) | fail

   if member(spec.defns, "Pattern_form") then v := image else v := 1

   every write(output, "link ", !sort(spec.links))

   #  Literals are output with image().  Other definitions are
   #  Icon experssions, enclosed in parentheses.

   write(output, "$define Comments ", image(spec.comments))
   write(output, "$define Name ", image(spec.name))
   write(output, "$define Palette ", image(spec.palette))
   write(output, "$define WarpColors (", v(spec.warp_colors), ")")
   write(output, "$define WeftColors (", v(spec.weft_colors), ")")
   write(output, "$define Width (", spec.width, ")")
   write(output, "$define Height (", spec.height, ")")
   write(output, "$define Modulus (", spec.modulus, ")")
   write(output, "$define Threading (", v(spec.threading), ")")
   write(output, "$define Treadling (", v(spec.treadling), ")")
   if upto(&letters, spec.tieup) then
      write(output, "$define Tieup tieups[", image(spec.tieup), "]")
   else
      write(output, "$define Tieup ", image(spec.tieup))
   
   every n := !keylist(spec.defns) do
      write(output, "$define ", n, " (", spec.defns[n], ")")

   write(output, bar)

   close(output)

   return

end

procedure display()

   write(&errout, "name=", name)
   write(&errout, "threading=", threading)
   write(&errout, "treadling=", treadling)
   write(&errout, "warp colors=", warp_colors)
   write(&errout, "weft colors=", weft_colors)
   write(&errout, "tie up=", limage(tieup))
   write(&errout, "palette=", palette)

   return

end

procedure sympos(sym)		#: position of symbol in symbol list
   static mask

   initial mask := Mask

   return upto(sym, mask)	# may fail

end

procedure possym(i)		#: symbol in position i of symbol list
   static mask

   initial mask := Mask

   return mask[i]		# may fail

end