summaryrefslogtreecommitdiff
path: root/ipl/procs/weavutil.icn
diff options
context:
space:
mode:
Diffstat (limited to 'ipl/procs/weavutil.icn')
-rw-r--r--ipl/procs/weavutil.icn365
1 files changed, 365 insertions, 0 deletions
diff --git a/ipl/procs/weavutil.icn b/ipl/procs/weavutil.icn
new file mode 100644
index 0000000..9cb18e8
--- /dev/null
+++ b/ipl/procs/weavutil.icn
@@ -0,0 +1,365 @@
+############################################################################
+#
+# File: weavutil.icn
+#
+# Subject: Procedures to support numerical weavings
+#
+# Author: Ralph E. Griswold
+#
+# Date: April 13, 2002
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# Links: expander, tables
+#
+############################################################################
+
+link expander
+link tables
+
+$define Mask ("123456789" || &letters || &cset[162:-1]) # NEEDS FIXING
+
+record analysis(rows, sequence, patterns)
+
+# PFL weaving parameters
+
+record PflParams(P, T)
+
+# Sequence-drafting database record
+
+record sdb(table, name) # specification database
+record ldb(table, name) # specification database
+
+record ddb(table) # definition database
+record edb(table) # expression database
+record tdb(table) # tie-up database
+
+record pfd( # pattern-form draft
+ name,
+ threading,
+ treadling,
+ warp_colors,
+ weft_colors,
+ palette,
+ colors,
+ shafts,
+ treadles,
+ tieup,
+ liftplan,
+ drawdown
+ )
+
+record isd( # internal structure draft
+ name,
+ threading, # list of shaft numbers
+ treadling, # list of treadle numbers
+ warp_colors, # list of indexes into color_list
+ weft_colors, # list of indexes into color_list
+ color_list, # list of colors
+ shafts, # number of shafts
+ treadles, # number of treadles
+ width, # image width
+ height, # image height
+ tieup, # tie-up row list
+ liftplan # liftplan matrix
+ )
+
+procedure readpfd(input) # read PFD
+ local draft
+
+ draft := pfd()
+
+ draft.name := read(input) &
+ draft.threading := read(input) &
+ draft.treadling := read(input) &
+ draft.warp_colors := read(input) &
+ draft.weft_colors := read(input) &
+ draft.palette := read(input) &
+ draft.colors := read(input) &
+ draft.shafts := read(input) &
+ draft.treadles := read(input) &
+ draft.tieup := read(input) | fail
+ draft.liftplan := read(input) # may be missing
+ draft.drawdown := read(input) # may be missing
+
+ return draft
+
+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, pfd.colors)
+ write(output, pfd.shafts)
+ write(output, pfd.treadles)
+ write(output, pfd.tieup)
+ if *\pfd.liftplan > 0 then write(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 := pfl2str(pfd.warp_colors)
+ pfd.weft_colors := pfl2str(pfd.weft_colors)
+
+ pfd.warp_colors := Extend(pfd.warp_colors, *pfd.threading)
+ pfd.weft_colors := Extend(pfd.weft_colors, *pfd.treadling)
+
+ return pfd
+
+end
+
+# Write include file for seqdraft (old)
+
+procedure write_spec(name, spec, opt, mode) #: write weaving include file
+ local n, output
+ static bar
+
+ initial bar := repl("#", 72)
+
+ /opt := "w"
+
+ output := open(name, opt) | fail
+
+ if \mode == "drawdown" then write(output, "$define DrawDown")
+
+ # Literals are output with image(). Other definitions are
+ # Icon expressions, 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 (", check(spec.warp_colors), ")")
+ write(output, "$define WeftColors (", check(spec.weft_colors), ")")
+ write(output, "$define Breadth (", spec.breadth, ")")
+ write(output, "$define Length (", spec.length, ")")
+ write(output, "$define Threading (", check(spec.threading), ")")
+ write(output, "$define Treadling (", check(spec.treadling), ")")
+ write(output, "$define Shafts (", spec.shafts, ")")
+ write(output, "$define Treadles (", spec.treadles, ")")
+ write(output, "$define Tieup ", image(spec.tieup))
+ write(output, "$define Threads ", spec.links[1])
+ write(output, "$define Treads ", spec.links[2])
+
+ every n := !keylist(spec.defns) do
+ write(output, "$define ", n, " ", spec.defns[n])
+
+ write(output, bar)
+
+ close(output)
+
+ return
+
+end
+
+# Write include file for seqdraft (new)
+
+procedure write_spec1(name, spec, opt, mode, defns) #: weaving include file
+ local n, output
+ static bar
+
+ initial bar := repl("#", 72)
+
+ /opt := "w"
+
+ output := open(name, opt) | fail
+
+ if \mode == "drawdown" then write(output, "$define DrawDown")
+
+ # Literals are output with image(). Other definitions are
+ # Icon expressions, enclosed in parentheses.
+
+ write(output, "$define Comments ", image(spec.comments))
+ write(output, "$define Name ", image(spec.name))
+ write(output, "$define Palette ", image((\spec.palette).name))
+# write(output, "$define WarpPalette ", image((\spec.warp_palette).name))
+# write(output, "$define WeftPalette ", image((\spec.weft_palette).name))
+ write(output, "$define WarpColors (", check(spec.warp_colors), ")")
+ write(output, "$define WeftColors (", check(spec.weft_colors), ")")
+ write(output, "$define Breadth (", spec.breadth, ")")
+ write(output, "$define Length (", spec.length, ")")
+ write(output, "$define Threading (", check(spec.threading), ")")
+ write(output, "$define Treadling (", check(spec.treadling), ")")
+ write(output, "$define Shafts (", spec.shafts, ")")
+ write(output, "$define Treadles (", spec.treadles, ")")
+ write(output, "$define Tieup ", spec.tieup)
+ write(output, "$define Threads ", spec.links[1])
+ write(output, "$define Treads ", spec.links[2])
+
+ every n := !keylist(spec.defns) do
+ write(output, "$define ", n, " ", spec.defns[n])
+
+ if \defns then
+ every n := !keylist(defns) do
+ write(output, "$define ", n, " ", defns[n])
+
+ write(output, bar)
+
+ close(output)
+
+ return
+
+end
+
+# Write include file for lstdraft (new)
+
+procedure write_spec2(name, spec, opt, mode, defns) #: weaving include file
+ local n, output
+ static bar
+
+ initial bar := repl("#", 72)
+
+ /opt := "w"
+
+ output := open(name, opt) | fail
+
+ if \mode == "drawdown" then write(output, "$define DrawDown")
+
+ # Literals are output with image(). Other definitions are
+ # Icon expressions, 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 WarpPalette ", image((\spec.warp_palette)))
+ write(output, "$define WeftPalette ", image((\spec.weft_palette)))
+ write(output, "$define WarpColors (", spec.warp_colors, ")")
+ write(output, "$define WeftColors (", spec.weft_colors, ")")
+ write(output, "$define Breadth (", spec.breadth, ")")
+ write(output, "$define Length (", spec.length, ")")
+ write(output, "$define Threading (", spec.threading, ")")
+ write(output, "$define Treadling (", spec.treadling, ")")
+ write(output, "$define Shafts (", spec.shafts, ")")
+ write(output, "$define Treadles (", spec.treadles, ")")
+ write(output, "$define Tieup ", spec.tieup)
+ write(output, "$define Threads ", spec.links[1])
+ write(output, "$define Treads ", spec.links[2])
+
+ every n := !keylist(spec.defns) do
+ write(output, "$define ", n, " ", spec.defns[n])
+
+ if \defns then
+ every n := !keylist(defns) do
+ write(output, "$define ", n, " ", defns[n])
+
+ write(output, bar)
+
+ close(output)
+
+ return
+
+end
+
+procedure check(s) #: check for pattern form
+
+ if s[1] == "[" then s := "!pfl2str(" || image(s) || ")"
+
+ return s
+
+end
+
+procedure display(pfd)
+
+ write(&errout, "name=", pfd.name)
+ write(&errout, "threading=", pfd.threading)
+ write(&errout, "treadling=", pfd.treadling)
+ write(&errout, "warp colors=", pfd.warp_colors)
+ write(&errout, "weft colors=", pfd.weft_colors)
+ write(&errout, "tie up=", limage(pfd.tieup))
+ write(&errout, "palette=", pfd.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
+
+# Procedure to convert a tier to a list of productions
+
+$define Different 2
+
+procedure tier2prodl(tier, name)
+ local rows, row, count, unique, prodl, prod
+
+ unique := table()
+ rows := []
+ count := 0
+
+ every row := !tier.matrix do {
+ if /unique[row] then unique[row] := (count +:= 1)
+ put(rows, unique[row])
+ }
+
+ prod := name || "->"
+ every prod ||:= possym(!rows + Different)
+
+ prodl := [
+ "name:" || "t-" || name,
+ "comment: ex pfd2wpg " || &dateline,
+ "axiom:2",
+ "gener:1",
+ prod
+ ]
+ unique := sort(unique, 4)
+
+ while row := get(unique) do
+ put(prodl, possym(get(unique) + Different) || "->" || row)
+
+ put(prodl, "end:")
+
+ return prodl
+
+end
+
+procedure analyze(drawdown)
+ local sequence, rows, row, count, patterns
+
+ sequence := []
+ patterns := []
+
+ rows := table()
+
+ count := 0
+
+ every row := !drawdown do {
+ if /rows[row] then {
+ rows[row] := count +:= 1
+ put(patterns, row)
+ }
+ put(sequence, rows[row])
+ }
+
+ return analysis(rows, sequence, patterns)
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-01 18:39:48 +0000