summaryrefslogtreecommitdiff
path: root/ipl/gprocs/patxform.icn
diff options
context:
space:
mode:
Diffstat (limited to 'ipl/gprocs/patxform.icn')
-rw-r--r--ipl/gprocs/patxform.icn504
1 files changed, 504 insertions, 0 deletions
diff --git a/ipl/gprocs/patxform.icn b/ipl/gprocs/patxform.icn
new file mode 100644
index 0000000..fb5ba97
--- /dev/null
+++ b/ipl/gprocs/patxform.icn
@@ -0,0 +1,504 @@
+############################################################################
+#
+# File: patxform.icn
+#
+# Subject: Procedures to transform patterns in row form
+#
+# Author: Ralph E. Griswold
+#
+# Date: June 26, 2002
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# pborder(rows, l, r, t, b, c)
+# pcaten(rows1, rows2, dir)
+# pcenter(rows, w, h)
+# pcrop(rows, l, r, t, b)
+# pdisplay(rows)
+# pdouble(rows, dir)
+# pflip(rows, dir)
+# phalve(rows, dir, choice)
+# pinvert(rows)
+# pminim(rows)
+# por(rows1, rows2)
+# protate(rows, dir)
+# pscramble(rows, dir)
+# pshift(rows, shift, dir)
+# ptrim(rows, c)
+#
+############################################################################
+#
+# Requires: Version 9 graphics
+#
+############################################################################
+#
+# Links: patutils, random, strings
+#
+############################################################################
+
+link patutils
+link random
+link strings
+
+#
+# Place a border around a pattern. l, r, t, and b specify the number of bits
+# to add at the left, right, top, and bottom, respectively. c specifies
+# the color of the border, "0" for white, "1" for black.
+
+procedure pborder(rows, l, r, t, b, c) #: place border around pattern
+ local i, row, left, right
+
+ /l := 1
+ /r := 1
+ /t := 1
+ /b := 1
+ /c := "0"
+
+ if l = r = t = b = 0 then return rows
+
+ row := repl(c, *rows[1] + l + r)
+ left := repl(c, l)
+ right := repl(c, r)
+
+ every i := 1 to *rows do
+ rows[i] := left || rows[i] || right
+
+ every 1 to t do
+ push(rows, row)
+
+ every 1 to b do
+ put(rows, row)
+
+ return rows
+
+end
+
+#
+# Concatenate patterns
+
+procedure pcaten(rows1, rows2, dir) #: concatenate patterns
+ local rows, i
+
+ # if art is nonnull, delete duplicate line at boundary
+
+ if (*rows1 ~= *rows2) | (*rows1[1] ~= *rows2[1]) then
+ stop("nonconformal patterns in pcaten()")
+
+ /dir := "h"
+
+ case dir of {
+ "h" : {
+ rows := []
+ every i := 1 to *rows1 do
+ put(rows, rows1[i] || rows2[i])
+ }
+ "v" : {
+ rows := copy(rows1)
+ every put(rows, !rows2)
+ }
+ default: stop("invalid direction specification in pcaten()")
+ }
+
+ return rows
+
+end
+
+#
+# Concatenate patterns pattern style
+
+procedure pcatenp(rows1, rows2, dir)
+ local rows, i
+
+ if (*rows1 ~= *rows2) | (*rows1[1] ~= *rows2[1]) then
+ stop("nonconformal patterns in pcaten()")
+
+ /dir := "h"
+
+ rows2 := copy(rows2) # may delete row or column
+
+ case dir of {
+ "h" : {
+ repeat {
+ every i := 1 to *rows1 do
+ if rows1[i][-1] ~== rows2[i][1] then break break
+ every i := 1 to *rows2 do
+ rows2[i][1] := ""
+ break
+ }
+ rows := []
+ every i := 1 to *rows1 do
+ put(rows, rows1[i] || rows2[i])
+ }
+ "v" : {
+ if rows1[-1] == rows2[1] then # eliminate duplicate
+ get(rows2)
+ rows := copy(rows1)
+ every put(rows, !rows2)
+ }
+ default: stop("invalid direction specification in pcaten()")
+ }
+
+ return rows
+
+end
+
+#
+# Centers non-white portion of pattern
+
+procedure pcenter(rows, w, h) #: center pattern
+ local rw, rh, vert, horz, t, l
+
+ rows := ptrim(rows)
+
+ rw := *rows[1]
+ rh := *rows
+
+ if (rh = h) & (rw = w) then return rows
+ if (rh > h) | (rw > w) then fail
+
+ horz := w - rw
+ vert := h - rh
+ l := horz / 2
+ t := vert / 2
+
+ return pborder(rows, l, horz - l, t, vert - t)
+
+end
+
+#
+# Crop a pattern. l, r, t, and b specify the number of bits
+# to crop at the left, right, top, and bottom, respectively.
+
+procedure pcrop(rows, l, r, t, b) #: crop pattern
+ local i
+
+ /l := 0
+ /r := 0
+ /t := 0
+ /b := 0
+
+ if l = r = t = b = 0 then return rows
+
+ if ((*rows[1] - l - r) | (*rows - t - b)) < 2 then fail
+
+ every 1 to t do
+ get(rows)
+
+ every 1 to b do
+ pull(rows)
+
+ every i := 1 to *rows do
+ rows[i] := rows[i][l + 1 : -r]
+
+ return rows
+
+end
+
+#
+# Display pattern
+
+procedure pdisplay(rows, pat) #: display pattern
+
+ /pat := "01" # mapping string
+
+ every write(map(!rows, "01", pat))
+
+ return
+
+end
+
+#
+# Creates a tile in which each pixel doubled. dir determines the
+# direction in which the doubling is done. If dir is "b" or null, it's
+# done both horizontally and vertically. If dir is "v", it's only done
+# vertically, while if dir is "h", it's done only horizontally.
+
+procedure pdouble(rows, dir) #: double pattern
+ local row, newrows
+
+ newrows := []
+
+ case dir of {
+ "v": {
+ every row := !rows do
+ put(newrows, row, row)
+ }
+ "h": {
+ every row := !rows do
+ put(newrows, collate(row, row))
+ }
+ "b" | &null: return pdouble(pdouble(rows, "v"), "h")
+ }
+
+ return newrows
+
+end
+
+#
+# Flip pattern. The possible values of dir are "h" (horizontal flip),
+# "v" (vertical flip), "l" (left diagonal), and "r" (right diagonal).
+# (The left diagonal extends from the upper left corner to the bottom
+# right corner; the right diagonal from the upper right to the lower
+# left.
+
+procedure pflip(rows, dir) #: flip pattern
+ local newrows, x, y, i
+
+ case dir of {
+ "l": {
+ newrows := list(*rows[1], repl("0", *rows))
+ every y := 1 to *rows do
+ every x := 1 to *rows[1] do
+ if rows[y, x] == "1" then
+ newrows[-x, -y] := "1"
+ }
+ "r": {
+ newrows := list(*rows[1], repl("0", *rows))
+ every y := 1 to *rows do
+ every x := 1 to *rows[1] do
+ if rows[y, x] == "1" then
+ newrows[x, y] := "1"
+ }
+ "h": {
+ newrows := copy(rows)
+ every i := 1 to *rows do
+ newrows[i] := reverse(newrows[i])
+ }
+ "v": {
+ newrows := copy(rows)
+ every i := 1 to *rows / 2 do
+ newrows[i] :=: newrows[-i]
+ }
+ default: stop("*** illegal flip specification in pflip()")
+ }
+
+ return newrows
+
+end
+
+# Creates a tile in every other pixel is discarded. dir determines the
+# direction is which the halving is done. If dir is "b" or null, it's
+# done both vertically and horizontally. If dir is "v", it's only done
+# vertically, while if dir is "v", it's done only vertically.
+# If choice is "o" or null, odd-numbered rows or columns are kept;
+# if "e", the even-numbered ones.
+
+procedure phalve(rows, dir, choice) #: halve pattern by bits
+ local newrows, i
+
+ choice := if choice === ("o" | &null) then 1 else 0
+ newrows := []
+
+ case dir of {
+ "v": {
+ every i := choice to *rows by 2 do
+ put(newrows, rows[i])
+ }
+ "h": every put(newrows, decollate(!rows, choice))
+ "b" | &null: return phalve(phalve(rows, "v", choice), "h", choice)
+ }
+
+ return newrows
+
+end
+
+#
+# Invert white and black bits in pattern specification
+
+procedure pinvert(rows) #: invert B&W pattern
+ local i
+
+ rows := copy(rows)
+
+ every i := 1 to *rows do
+ rows[i] := map(rows[i], "10", "01")
+
+ return rows
+
+end
+
+#
+# Reduce pattern to its smallest equivalent form (with at least 4 columns).
+# Limited to square patterns for portability -- other possibilities exist
+# for operating on and/or producing patterns that are not square.
+
+
+procedure pminim(rows) #: minimize pattern
+ local halfw, halfh, i
+
+# if (*rows ~= *rows[1]) | (*rows % 2 ~= 0) then return rows
+
+ repeat {
+
+ if *rows[1] < 4 then break
+
+ halfw := *rows[1] / 2
+ halfh := *rows / 2
+
+ every i := 1 to halfh do # check rows in top and bottom
+ if (rows[i] ~== rows[i + halfh]) |
+ (rows[i][1+:halfw] ~== rows[i][0-:halfw]) then break break
+
+ every 1 to halfh do # reducible; remove rows
+ pop(rows)
+
+ every i := 1 to halfh do # truncate rows
+ rows[i] := rows[i][1+:halfw]
+
+ }
+
+ return rows
+
+end
+
+# For the logical "or" of two row bit patterns
+
+procedure por(rows1, rows2) #: "or" patterns
+ local rows, i
+
+ if *rows1 ~= *rows2 then fail # nonconformal
+ if *rows1[1] ~= *rows2[1] then fail # nonconformal
+
+ rows := copy(rows1)
+
+ every i := 1 to *rows do {
+ rows2[i] ? { # overlay 1s of row2 on row1
+ while tab(upto('1')) do {
+ rows[i][&pos] := "1"
+ move(1) | break
+ }
+ }
+ }
+
+ return rows
+
+end
+
+# Create rotated copy of a pattern. If dir is "cw" or "90", rotation is 90
+# degrees clockwise; if "ccw" or "-90", 90 degrees counter-clockwise.
+# If dir is "180", rotation is 180 degrees. The default is "cw".
+
+procedure protate(rows, dir) #: rotate pattern
+ local newrows, i, row, pix
+
+ /dir := "cw"
+
+ case string(dir) of {
+ "ccw" | "-90": { # counter-clockwise
+ newrows := list(*rows[1], "")
+ every row := !rows do {
+ i := 0
+ every pix := !row do
+ newrows[i -:= 1] ||:= pix
+ }
+ }
+ "cw" | "90" | &null: { # clockwise
+ newrows := list(*rows[1], "")
+ every row := !rows do {
+ i := 0
+ every pix := !row do
+ newrows[i +:= 1] := pix || newrows[i]
+ }
+ }
+ "180": {
+ newrows := []
+ every push(newrows, reverse(!rows))
+ }
+ default: stop("*** illegal rotation specification in protate()")
+ }
+
+ return newrows
+
+end
+
+#
+# Scrambles a pattern by shuffling it. If dir is "h", the columns of each row
+# are scrambled; if "v", the the rows are scrambled. If "b", bits are
+# scrambled throughout the pattern.
+
+procedure pscramble(rows, dir) #: scramble pattern
+ local i, all
+
+ case dir of {
+ "h": {
+ every i := 1 to *rows do
+ rows[i] := shuffle(rows[i])
+ }
+ "v": rows := shuffle(rows)
+ "b" | &null: {
+ all := ""
+ every all ||:= !rows
+ all := shuffle(all)
+ every i := 1 to *rows do {
+ rows[i] := left(all, *rows[1])
+ all[1 +: *rows[1]] := ""
+ }
+ }
+ default: stop("*** illegal specification in scramble()")
+ }
+
+ return rows
+
+end
+
+
+#
+# Create bit-shifted copy of a pattern. If dir is "h", then the
+# shift is horizontal; if "v", vertical. The default is horizontal.
+# Positive shift is to the right for horizontal shifts, downward for vertical
+# shifts. The default shift is 0 and the default direction is horizontal.
+
+procedure pshift(rows, shift, dir) #: bit shift pattern
+ local i
+
+ /shift := 0
+
+ case dir of {
+ "h" | &null: { # horizontal shift
+ every i := 1 to *rows do
+ rows[i] := rotate(rows[i], -shift)
+ }
+ "v": { # vertical shift
+ if shift > 0 then
+ every 1 to shift do
+ push(rows, pull(rows))
+ else if shift < 0 then
+ every 1 to -shift do
+ put(rows, pop(rows))
+ }
+ default: stop("*** illegal specification in pshift()")
+ }
+
+ return rows
+
+end
+
+#
+# Trim border from pattern; c gives color; default "1"
+
+procedure ptrim(rows, c) #: trim pattern
+
+ /c := '1'
+ c := cset(c)
+
+ while (*rows > 2) & not(upto(c, rows[1])) do
+ get(rows)
+
+ while (*rows > 2) & not(upto(c, rows[-1])) do
+ pull(rows)
+
+ rows := protate(rows, "cw")
+
+ while (*rows > 2) & not(upto(c, rows[1])) do
+ get(rows)
+
+ while (*rows > 2) & not(upto(c, rows[-1])) do
+ pull(rows)
+
+ return protate(rows, "ccw")
+
+end
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-08 07:18:57 +0000