path: root/ipl/gprocs/patxform.icn

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