path: root/ipl/gprogs/penelope.icn

############################################################################
#
#	File:     penelope.icn
#
#	Subject:  Program to edit graphic patterns
#
#	Authors:  Ralph E. Griswold and Gregg M. Townsend
#
#	Date:     May 25, 2001
#
############################################################################
#
#   This file is in the public domain.
#
############################################################################
#
#  This application provides a variety of facilities for creating and
#  editing graphic pattern specifications.  For a complete description,
#  see IPD234:
#	http://www.cs.arizona.edu/icon/docs/ipd234.htm
#
############################################################################
#
#  Requires:  Version 9 graphics with 32-column tiles
#
############################################################################
#
#  Links: sort, patxform, vdialog, vsetup, dialog, wopen, xcompat
#
############################################################################

link sort
link patxform
link vdialog
link vsetup
link dialog
link wopen
link xcompat

$define MaxCell   	24			# maximum size of grid cell

$define GridSize	(32 * 8)		# size of area for edit grid
$define GridXoff	(32 * 5)		# x offset of grid area
$define GridYoff	(32 * 2 + 6)		# y offset of grid area

$define PattXoff	(32 * 14)		# x offset of pattern area
$define PattYoff	(32 * 2)		# y offset of pattern area
$define PattWidth	(32 * 8)		# width of pattern area
$define PattHeight	(32 * 8)		# heigth of pattern area

$define IconSize	16			# size of button icons

$define XformXoff	(16 * 2)		# x offset of xform area
$define XformYoff	(16 * 4)		# y offset of xform area

$define SymmetXoff	(16 * 10)		# x offset of symmetry area
$define SymmetYoff	(16 * 23)		# y offset of symmetry area

$define InfoLength	40			# length of lines in info box

global allxform					# transform-all switch
global hbits					# number of bits horizontally
global vbits					# number of bits veritcally
global rows					# row repesentation of tile
global old_pat					# old pattern for undo
global cellsize					# size of cell in edit grid
global pattgc					# graphic context for pattern
global bordergc					# border for tile/pattern
global viewgc					# clipping area for viewing
global mode					# pattern/tile display mode
global zoom					# tile zoom factor
global loadname					# name of loaded pattern file
global plist					# pattern list
global pindex					# index in pattern list
global list_touched				# list modification switch
global tile_touched				# tile modification switch
global blank_pat				# 8x8 blank tile
global response					# switch for save dialog
global sym_state				# drawing state
global sym_image_current			# current drawing images
global sym_image_next				# next drawing images
global symmetries				# general symmetry state

global flip_right				# icon for right flip
global flip_left				# icon for left flip
global flip_vert				# icon for vertical flip
global flip_horiz				# icon for horizontal flip
global rotate_90				# icon for 90-degree rotation
global rotate_m90				# icon for -90-degree rotation
global rotate_180				# icon for 180-degree rotation
global ident					# icon for identity
global hi_ident					# highlighted icon for identity
global hi_left					# highlighted icon for l-flip
global hi_right					# highlighted icon for r-flip
global hi_vert					# highlighted icon for v-flip
global hi_horiz					# highlighted icon for h-flip
global hi_rot_90				# highlighted icon for 90-rot
global hi_rot_m90				# highlighted icon for -90 rot
global hi_rot_180				# highlighted icon for 180 rot

global MaxPatt					# maximum width for patterns

record pattrec(tile, note)

procedure main(args)
   local vidgets, e, i, j, x, y, v, h, input, mdigits

#  Initial state

   mdigits := '-' ++ &digits
   mode := 1					# initially pattern mode
   zoom := 1					# initially 1:1
   symmetries := 0				# initially no symmetries
   allxform := &null				# initially not all xforms

   sym_state := [				# initially no symmetries
      [1, -1, -1, -1],
      [-1, -1, -1, -1]
      ]

   blank_pat := "8,#0000000000000000"		# 8x8 blank tile

   list_touched := &null			# pristine state
   tile_touched := &null

#  Conservative assumption that only X can handle tiles up to 32 wide

   MaxPatt := if &features == "X Windows" then 32 else 8

#  Set up initial pattern list

   if loadname := args[1] then {
      input := open(loadname) | stop("*** cannot open ", loadname)
      if load_file(input) then old_pat := rows2pat(rows)
      else stop("*** no patterns in ", loadname)
      }
   else {
      loadname := "untitled.tle"
      rows := pat2rows(blank_pat)
      old_pat := rows2pat(rows)
      plist := [pattrec(rows2pat(rows), "")]
      pindex := 1
      }

#  Set up vidgets

   vidgets := ui(, vecho)

   WAttrib("label=" || loadname)

#  Set up graphic contexts

   pattgc := XBind(&window, "fillstyle=textured")	# for patterns
   bordergc := XBind(&window, "fg=red")			# for border
   viewgc := XBind(&window) 				# for tile view
   Clip(viewgc, PattXoff, PattYoff, PattWidth, PattHeight)
   Clip(bordergc, PattXoff - 1, PattYoff - 1, PattWidth + 2, PattHeight + 2)

#  Assign and draw the icons

   icons()

#  Initial and toggled editing images

   sym_image_next := [
      [ident, hi_rot_90, hi_rot_m90, hi_rot_180],
      [hi_right, hi_left, hi_vert, hi_horiz]
      ]
   sym_image_current := [
      [hi_ident, rotate_90, rotate_m90, rotate_180],
      [flip_right, flip_left, flip_vert, flip_horiz]
      ]

#  Initial setup of grid and view areas

   setup() | stop("*** cannot set up pattern")

#  Enter event loop

   GetEvents(vidgets["root"], ,  shortcuts)
   
end

############################################################################
#
#	Callback procedures
#
############################################################################

#  file menu

procedure file_cb(vidget, value)

   case value[1] of {
      "load  @L"  :  load()
      "save  @S"  :  save()
      "save as"   :  save_as()
      "read  @R"  :  read_tile()
      "write @W"  :  write_tile()
      "quit  @Q"  :  quit()
      }

   return

end

#  editing grid

procedure grid_cb(vidget, e)
   local x, y, i, j

   if e === (&lpress | &rpress | &ldrag | &rdrag) then {
      j := (&x - GridXoff) / cellsize
      i := (&y - GridYoff) / cellsize
      if j < 0 | j >= hbits | i < 0 | i >= vbits then return
      if e === (&lpress | &ldrag) then setbit(i, j, "1")
      else setbit(i, j, "0")
      tile_touched := 1
      }

   return

end

#  list menu

procedure list_cb(vidget, value)
   local i

   case value[1] of {
      "clear"    :  {			# should request confirmation
         plist := [pattrec(blank_pat, "")]
         }
      "reverse"  :  {
         every i := 1 to *plist / 2 do
            plist[i] :=: plist[-i]
         }
      "sort"     :  {
         refresh_tile()
         plist := isort(plist, case value[2] of {
            "by size":    tile_size
            "by bits":    tile_bits
            "by notes":   tile_note
            })
         }
      }

   pindex := 1

   rows := pat2rows(plist[1].tile)
   old_pat := rows2pat(rows)

   list_touched := 1

   return setup()

end

#  Penelope logo

procedure logo_cb(vidgets, event)

   if event === (&lpress | &mpress | &rpress) then
      Notice("Penelope", "Version 1.1",
         "Ralph E. Griswold and Gregg M. Townsend")

   return

end

#  note menu

procedure note_cb(vidget, value)
   local result, note, i

   case value[1] of {
      "edit @E"  :  edit_tile()
      "find @F"  :  find_tile()
      }

   return

end

#  symmetry buttons

procedure symmet_cb(vidget, e)
   local col, row, symcount

   if e === (&lpress | &rpress | &mpress) then {
      col := (&x - SymmetXoff) / IconSize + 1
      row := (&y - SymmetYoff) / IconSize + 1
      sym_state[row, col] *:= -1
      sym_image_current[row, col] :=: sym_image_next[row, col]
      place(SymmetXoff, SymmetYoff, col - 1, row - 1,
         sym_image_current[row, col])
      symcount := 0
      every symcount +:= !!sym_state
      if symcount = -8 then
         Notice("No drawing mode enabled; pattern cannot be edited")
      else if (sym_state[1, 1] = 1) & (symcount = -6) then symmetries := 0
      else symmetries := 1

      return
      }

   fail

end

#  tile menu

procedure tile_cb(vidget, value)
   local result

   case value[1] of {
      "next     @N"  :  next_tile()
      "previous @P"  :  previous_tile()
      "goto     @G"  :  goto_tile()
      "first"        :  {
         refresh_tile()
         pindex := 1
         rows := pat2rows(plist[pindex].tile)
         tile_touched := 1
         return setup()
         }
      "last"         :  {
         refresh_tile()
         pindex := *plist
         rows := pat2rows(plist[pindex].tile)
         tile_touched := 1
         return setup()
         }
      "copy     C"  :  copy_tile()
      "revert"      :  {
         rows := pat2rows(plist[pindex].tile)
         return setup()
         }
      "delete   D"  :  delete_tile()
      "new"         :  {
         case Dialog("New:", ["width", "height"], [*rows[1], *rows], 3,
            ["Okay", "Cancel"]) of {
               "Cancel"  :  fail
               "Okay"    :   {
                  icheck(dialog_value) | fail
                  refresh_tile()
                  rows := list(dialog_value[2], repl("0", dialog_value[1]))
                  put(plist, pattrec(rows2pat(rows), ""))
                  pindex := *plist
                  tile_touched := 1
                  return setup()
                  }
            }
         }
      "info     I"  :  tile_info()
      }

   return

end

#  view menu

procedure view_cb(vidget, value)
   static old_mode, old_zoom

   old_mode := mode
   old_zoom := zoom

   case value[1] of {
      "pattern"    :  mode := 1
      "tile"       :  mode := &null
      "tile zoom"  :  {
         mode := &null
         case value[2] of {
            "1:1"  :  zoom := 1
            "2:1"  :  zoom := 2
            "4:1"  :  zoom := 4
            "8:1"  :  zoom := 8
            }
         }
      }

   if (mode ~=== old_mode) | (zoom ~=== old_zoom) then {
      DrawRectangle(bordergc, PattXoff - 1, PattYoff - 1,
         PattWidth + 1, PattHeight + 1)
      EraseArea(PattXoff - 1, PattYoff - 1, PattWidth + 1, PattHeight + 1)
      return setup()
      }

   return

end

#  transformation buttons

procedure xform_cb(vidget, e)
   local col, row, save_pindex

   if e === (&lpress | &rpress | &mpress) then {
      old_pat := rows2pat(rows)
      col := (&x - XformXoff) / IconSize
      row := (&y - XformYoff) / IconSize

      if &shift then {
         refresh_tile()
         save_pindex := pindex
         every pindex := 1 to *plist do {
            rows := pat2rows((plist[pindex]).tile)
            rows := xform(col, row)  
            (plist[pindex]).tile := rows2pat(rows)
            allxform := 1				# all being done
            }
         allxform := &null				# one being done
         list_touched := 1
         pindex := save_pindex
         rows := pat2rows(plist[pindex].tile)
         }
      else rows := xform(col, row) | fail

      return setup()

      }

end

############################################################################
#
#  Support procedures
#
############################################################################

#  clear bits on current tile

procedure clear_tile()

   rows := list(vbits, repl("0", hbits))

   grid()

   drawpat()

   return

end

#  copy current tile

procedure copy_tile()

   refresh_tile()
   put(plist, pattrec(old_pat := rows2pat(rows), ""))
   rows := pat2rows(old_pat)
   pindex := *plist

   list_touched := 1

   return setup()

end

#  delete current tile

procedure delete_tile()
						# should ask confirmation
   if *plist = 1 then plist := [pattrec(blank_pat, "")]
   else {
      plist := plist[1 : pindex] ||| plist[pindex + 1 : 0]
      if pindex > *plist then pindex := *plist
      }

   rows := pat2rows((plist[pindex]).tile)

   list_touched := 1

   return setup()

end

#  draw view area

procedure drawpat()

   if \mode then {				# draw pattern
      DrawRectangle(bordergc, PattXoff - 1, PattYoff - 1,
         PattWidth + 1, PattHeight + 1) 
      Pattern(pattgc, rows2pat(rows))
      FillRectangle(pattgc, PattXoff, PattYoff, PattWidth, PattHeight)
      }
   else {					# draw tile
      EraseArea(PattXoff - 1, PattYoff - 1, PattWidth + 2, PattHeight + 2)
      DrawRectangle(bordergc, PattXoff - 1, PattYoff - 1, 
         (*rows[1] * zoom) + 1, (*rows * zoom) + 1)
      DrawRows(viewgc, PattXoff, PattYoff, rows, zoom)
      }
   return

end

#  edit annotation on current tile

procedure edit_tile()
   local result

   case Dialog("Edit:", "note", [plist[pindex].note], 80,
      ["Okay", "Cancel"]) of {
         "Cancel":  fail
         "Okay":  {
            plist[pindex].note := dialog_value[1] || " "
            list_touched := 1
            }
      }

   return

end

#  find tile with annotation

procedure find_tile()
   local note, i

   case Dialog("Find:", "note",  "", 80, ["Okay", "Cancel"]) of {
      "Cancel":  fail
      "Okay":  {
         note := dialog_value[1] || " "
         every i := ((pindex + 1 to *plist) | (1 to *pindex)) do
            plist[i].note ? {
               if find(note) then {
                  pindex := i
                  rows := pat2rows(plist[pindex].tile)
                  return setup()
                  }
           }
         }
      }

   Notice("Not found")
   
   fail

end

#  go to specified tile

procedure goto_tile()
   local i

   case Dialog("Go to:","#", 1, 5, ["Okay", "Cancel"]) of {
      "Cancel":  fail
      "Okay":    i := integer(dialog_value[1]) | {
          Notice("Invalid specification")
          fail
          }
      }
   refresh_tile()
   if i <= 0 then i +:= *plist + 1
   if i <= i <= *plist + 1 then {
      pindex := i
      old_pat := rows2pat(rows)
      rows := pat2rows(plist[pindex].tile)
      return setup()
      }
   else {
      Notice("Index out of bounds")
      fail
      }

end

#  draw editing grid

procedure grid()
   local x, y

   EraseArea(GridXoff, GridYoff, GridSize - 15, GridSize - 15)

   every x := 0 to hbits * cellsize by cellsize do
      DrawLine(GridXoff + x, GridYoff, GridXoff + x,
         GridYoff + vbits * cellsize)
   every y := 0 to vbits * cellsize by cellsize do
      DrawLine(GridXoff, GridYoff + y, GridXoff + hbits * cellsize,
         y + GridYoff)

   return

end

#  check for valid integers

procedure icheck(values)
   local i

   every i := !values do
      if not(integer(i)) | (i < 0) then {
         Notice("Invalid value")
         fail
         }

   return

end

#  assign and draw icons

procedure icons()
   local shift_up, shift_left, shift_right, shift_down, pixmap
   local clear, invert, scramble, trim, enlarge, resize, crop

   pixmap := XBind(, , "width=32", "height=32", "fillstyle=masked")

   Pattern(pixmap, "32,#7fffffff421f843f421f843f421f843f421f843f7fffff_
      ff421084214210842142108421421084217fffffff4210fc21_
      4210fc214210fc214210fc217fffffff421087e1421087e142_
      1087e1421087e17fffffff7e10fc217e10fc217e10fc217e10_
      fc217fffffff7e10843f7e10843f7e10843f7e10843f7fffff_
      ff00000000")					# Penelope logo

   FillRectangle(pixmap, 0, 0, 32, 32)

   CopyArea(pixmap, &window, 0, 0, 32, 32, 26, 373)

   Uncouple(pixmap)

   shift_up := "16,#3ffe6003408141c143e140814081408140814081408140_
      81408160033ffe0000"
   shift_left := "16,#3ffe6003400140014001401140195ffd40194011400140_
      01400160033ffe0000"
   shift_right := "16,#3ffe600340014001400144014c015ffd4c014401400140_
      01400160033ffe0000"
   shift_down := "16,#3ffe60034081408140814081408140814081408143e141_
      c1408160033ffe0000"
   flip_left := "16,#3ffe600340014079403940394049408149014e014e014f_
      01400160033ffe0000"
   flip_right := "16,#3ffe600340014f014e014e014901408140494039403940_
      79400160033ffe0000"
   flip_vert := "16,#3ffe6003408141c143e14081408140814081408143e141_
      c1408160033ffe0000"
   flip_horiz := "16,#3ffe600340014001400144114c195ffd4c194411400140_
      01400160033ffe0000"
   rotate_90 := "16,#3ffe6003400140f141014201420142014f814701420140_
      01400160033ffe0000"
   rotate_m90 := "16,#3ffe600340014781404140214021402140f94071402140_
      01400160033ffe0000"
   rotate_180 := "16,#3ffe6003400141c140214011401140114111432147c143_
      01410160033ffe0000"
   clear := "16,#3ffe600340014001400140014001400140014001400140_
      01400160033ffe0000"
   invert := "16,#3ffe60ff40ff40ff40ff40ff40ff7fff7f817f817f817f_
      817f817f833ffe0000"
   scramble := "16,#3ffe60034c014c0d418d41814001403159b1598140194c_
      194c0160033ffe0000"
   trim := "16,#3ffe60134011407d40394011400140fd48854c857e854c_
      8548fd60033ffe0000"
   enlarge := "16,#3ffe6083418143fd418148815c017efd48854885488548_
      8548fd60033ffe0000"
   resize := "16,#3ffe6093419943fd419948915c017efd488548857e855c_
      8548fd60033ffe0000"
   crop := "16,#3ffe60034011401147fd441144114411441144115ff144_
      01440160033ffe0000"

   ident := "16,#3ffe6003400140014001400141c141c141c14001400140_
      01400160033ffe0000"

   hi_ident := "16,#00001ffc3ffe3ffe3ffe3ffe3e3e3e3e3e3e3ffe3ffe3f_
      fe3ffe1ffc00000000"
   hi_rot_90 := "16,#00001ffc3ffe3f0e3efe3dfe3dfe3dfe307e38fe3dfe3f_
      fe3ffe1ffc00000000"
   hi_rot_m90 := "16,#00001ffc3ffe387e3fbe3fde3fde3fde3f063f8e3fde3f_
      fe3ffe1ffc00000000"
   hi_rot_180 := "16,#00001ffc3ffe3e3e3fde3fee3fee3fee3eee3cde383e3c_
      fe3efe1ffc00000000"
   hi_right := "16,#00001ffc3ffe30fe31fe31fe36fe3f7e3fb63fc63fc63f_
      863ffe1ffc00000000"
   hi_left := "16,#00001ffc3ffe3f863fc63fc63fb63f7e36fe31fe31fe30_
      fe3ffe1ffc00000000"
   hi_vert := "16,#00001ffc3f7e3e3e3c1e3f7e3f7e3f7e3f7e3f7e3c1e3e_
      3e3f7e1ffc00000000"
   hi_horiz := "16,#00001ffc3ffe3ffe3ffe3bee33e6200233e63bee3ffe3f_
      fe3ffe1ffc00000000"

#  now place the images

   place(XformXoff, XformYoff, 1, 0, shift_up)
   place(XformXoff, XformYoff, 0, 1, shift_left)
   place(XformXoff, XformYoff, 2, 1, shift_right)
   place(XformXoff, XformYoff, 1, 2, shift_down)
   place(XformXoff, XformYoff, 0, 4, flip_right)
   place(XformXoff, XformYoff, 0, 5, flip_left)
   place(XformXoff, XformYoff, 1, 4, flip_vert)
   place(XformXoff, XformYoff, 1, 5, flip_horiz)
   place(XformXoff, XformYoff, 0, 7, rotate_90)
   place(XformXoff, XformYoff, 0, 8, rotate_m90)
   place(XformXoff, XformYoff, 1, 7, rotate_180)
   place(XformXoff, XformYoff, 0, 10, clear)
   place(XformXoff, XformYoff, 1, 10, invert)
   place(XformXoff, XformYoff, 2, 10, scramble)
   place(XformXoff, XformYoff, 0, 12, trim)
   place(XformXoff, XformYoff, 1, 12, enlarge)
   place(XformXoff, XformYoff, 2, 12, resize)
   place(XformXoff, XformYoff, 0, 14, crop)

   place(SymmetXoff, SymmetYoff, 0, 0, hi_ident)
   place(SymmetXoff, SymmetYoff, 1, 0, rotate_90)
   place(SymmetXoff, SymmetYoff, 2, 0, rotate_m90)
   place(SymmetXoff, SymmetYoff, 3, 0, rotate_180)
   place(SymmetXoff, SymmetYoff, 0, 1, flip_right)
   place(SymmetXoff, SymmetYoff, 1, 1, flip_left)
   place(SymmetXoff, SymmetYoff, 2, 1, flip_vert)
   place(SymmetXoff, SymmetYoff, 3, 1, flip_horiz)

   return

end

#  invert bits on current pattern

procedure invert()

   rows := pinvert(rows)

   return

end

#  load tile list

procedure load()
   local input

   refresh_tile()

   if \list_touched then {		# check to see if list should be saved
      case SaveDialog(, loadname) of {
          "Yes": {
             loadname := dialog_value
             save()
             }
         }
      }

   repeat {
      case OpenDialog("Load: ") of {
         "Okay":  {
            loadname := dialog_value
            if input := open(loadname) then break
            else {
               Notice("Can't open " || loadname)
               next
               }
            }
         "Cancel":  fail
         }
      }
   load_file(input) | {
      Notice("No patterns in file")
      fail
      }
   WAttrib("label=" || loadname)
   list_touched := &null

   return setup()

end

#  load from file

procedure load_file(input)
   local line

   plist := []
   while put(plist, read_pattern(input))
   close(input)
   pindex := 1
   rows := pat2rows(plist[pindex].tile) | fail

   return

end

#  go to next tile

procedure next_tile()

   refresh_tile()
   rows := pat2rows(plist[pindex + 1].tile) | {
      Notice("No next tile")
      fail
      }

   pindex +:= 1

   return setup()

end

#  place icon

procedure place(xoff, yoff, col, row, pattern)

   Pattern(pattgc, pattern)
   FillRectangle(pattgc, xoff + col * IconSize, 
     yoff + row * IconSize, IconSize, IconSize)

   return

end

#  go to previous tile

procedure previous_tile()

   rows := pat2rows(plist[pindex - 1].tile) | {
      Notice("No previous tile")
      fail
      }

   refresh_tile()
   pindex -:= 1

   return setup()

end

#  terminate session

procedure quit()
   local result

   refresh_tile()

   if \list_touched then {
      case SaveDialog() of {
         "Cancel":  fail
         "No":      exit()
         "Yes": {
            loadname := dialog_value
            save()
            }
         }
      }

   exit()

end

#  read pattern specification

procedure read_pattern(file)
   local line

   line := readpattline(file) | fail

   return pattrec(legaltile(getpatt(line)), getpattnote(line))

end

#  read and add tile to tile list

procedure read_tile()

   refresh_tile()
   put(plist, read_pattern(&input)) | fail
   pindex := *plist
   rows := pat2rows((plist[pindex]).tile)

   list_touched := 1

   return setup()

end

#  refresh tile in list

procedure refresh_tile()

   if \tile_touched := &null then {
      plist[pindex].tile := rows2pat(rows)
      list_touched := 1
      }

   return

end

#  save tile list

procedure save()			# should ask if file is to be saved
   local output

   refresh_tile()

   if \list_touched then {
      output := open(loadname, "w") | {
         Notice("Can't open " || loadname)
         fail
         }
      every write_pattern(output, !plist)
      close(output)
      list_touched := &null
      }

   return

end

#  save tile list in new file

procedure save_as()
   local output

   refresh_tile()

   repeat {
      case OpenDialog("Save as:") of {
         "Okay": {
            if output := open(dialog_value, "w") then break else
               Notice("Can't open " || dialog_value)
            }
         "Cancel":  fail
         }
      }
   every write_pattern(output, !plist)
   close(output)

   loadname := dialog_value
   WAttrib("label=" || loadname)

   list_touched := &null

   return

end

#  scramble bits of current tile

procedure bscramble()

   rows := pscramble(rows, "b")

   return

end

#  set bits of tile

procedure setbit(i, j, c)
   local x, y, xu, yu, xv, yv, xt, yt, action

   if (symmetries = 0) & (rows[i + 1, j + 1] == c) then return	# optimization

   x := GridXoff + j * cellsize + 1		# the selected cell itself
   y := GridYoff + i * cellsize + 1
   xt := GridXoff + i * cellsize + 1
   yt := GridYoff + j * cellsize + 1

   i +:= 1					# for computational convenience
   j +:= 1

   xu := GridXoff + (hbits - j) * cellsize + 1	# opposite cells
   yu := GridYoff + (vbits - i) * cellsize + 1
   xv := GridXoff + (hbits - i) * cellsize + 1
   yv := GridYoff + (vbits - j) * cellsize + 1

   action := if c = 1 then FillRectangle else EraseArea

   if sym_state[1, 1] = 1 then {		# cell itself
      rows[i, j] := c
      action(x, y, cellsize - 1, cellsize - 1)
      }
   if sym_state[1, 2] = 1 then {		# 90 degrees
      if rows[j, -i] := c then			# may be out of bounds
         action(xv, yt, cellsize - 1, cellsize - 1)
      }
   if sym_state[1, 3] = 1 then {		# -90 degrees
      if rows[-j, i] := c then			# may be out of bounds
         action(xt, yv, cellsize - 1, cellsize - 1)
      }
   if sym_state[1, 4] = 1 then {		# 180 degrees
      rows[-i, -j] := c
      action(xu, yu, cellsize - 1, cellsize - 1)
      }
   if sym_state[2, 1] = 1 then {		# left diagonal
      if rows[j, i] := c then			# may be out of bounds
      action(xt, yt, cellsize - 1, cellsize - 1)
      }
   if sym_state[2, 2] = 1 then {		# right diagonal
      if rows[-j, -i] := c then			# may be out of bounds
      action(xv, yv, cellsize - 1, cellsize - 1)
      }
   if sym_state[2, 3] = 1 then {		# vertical
      rows[-i, j] := c
      action(x, yu, cellsize - 1, cellsize - 1)
      }
   if sym_state[2, 4] = 1 then {		# horizontal
      rows[i, -j] := c
      action(xu, y, cellsize - 1, cellsize - 1)
      }

   drawpat()

   return

end

#  set up editing grid and view area

procedure setup()
   local i, j

   hbits := *rows[1]
   vbits := *rows

   if (hbits | vbits) > 80 then {		# based on cell size >= 3
      Notice("Dimensions too large")
      fail
      }
   if hbits > MaxPatt then mode := &null	# too large for pattern

   cellsize := MaxCell				# cell size on window
   cellsize >:= GridSize / (vbits + 4)
   cellsize >:= GridSize / (hbits + 4)

   grid()

   every i := 1 to hbits do
      every j := 1 to vbits do
         if rows[j, i] == "1" then
            FillRectangle(GridXoff + (i - 1) * cellsize,
               GridYoff + (j - 1) * cellsize, cellsize, cellsize)

   drawpat()

   return

end

#  keyboard shortcuts

procedure shortcuts(e)

   if &meta then case map(e) of {
      "c"  :  copy_tile()
      "d"  :  delete_tile()
      "e"  :  edit_tile()
      "f"  :  find_tile()
      "g"  :  goto_tile()
      "i"  :  tile_info()
      "l"  :  load()
      "n"  :  next_tile()
      "p"  :  previous_tile()
      "q"  :  return quit()
      "r"  :  read_tile()
      "s"  :  save()
      "u"  :  undo_xform()
      "w"  :  write_tile()
      }

   return

end

#  return number of bits set in tile for sorting

procedure tile_bits(x)

   return tilebits(pat2rows(x.tile))

end

#  show information about tile

procedure tile_info()
   local line1, line2, line3, line4, pattern, bits, density

   pattern := rows2pat(rows)
   bits := tilebits(rows)
   density := left(bits / real(*rows[1] * *rows), 6)

   line1 := left(loadname ||" " ||  pindex || " of " || *plist, InfoLength)
   line2 := left(*rows[1] || "x" || *rows || " b=" || bits || " d=" ||
      density, InfoLength)
   line3 := if *pattern > InfoLength then pattern[1+:(InfoLength - 3)] ||
      "..." else left(pattern, InfoLength)
   line4 := left(plist[pindex].note, InfoLength)

   Notice(line1, line2, line3, line4)

   return

end

#  return annotation of tile for sorting

procedure tile_note(x)

   return x.note

end

#  return tile size for sorting

procedure tile_size(x)
   local dims

   dims := tiledim(x.tile)

   return dims.w * dims.h

end

#  undo transformation

procedure undo_xform()

   rows := pat2rows(old_pat)

   return setup()

end

#  write pattern

procedure write_pattern(file, pattern)

   if *pattern.note = 0 then write(file, pattern.tile)
   else write(file, pattern.tile, "\t# ", pattern.note)

   return

end

#  write tile

procedure write_tile()

   write_pattern(&output, pattrec(rows2pat(rows), (plist[pindex]).note))

   return

end

#  handle transformation

procedure xform(col, row)
   local result
   static params

   tile_touched := 1

   return case col of {
      0:   case row of {
         1:   pshift(rows, -1, "h")
         4:   pflip(rows, "r")
         5:   pflip(rows, "l")
         7:   protate(rows, 90)
         8:   protate(rows, -90)
         10:  list(vbits, repl("0", hbits))
         12:  ptrim(rows)
         14:  {
              if /allxform then {
                 case Dialog("Crop:", ["left", "right", "top", "bottom"],
                    0, 3, ["Okay", "Cancel"]) of {
                       "Cancel":   fail
                        "Okay": {
                           icheck(dialog_value) | fail
                           result := copy(params := dialog_value)
                           push(result, rows)
                           pcrop ! result
                           }
                    }
                 }
            }
         default:   fail
         }
      1: case row of {
         0:   pshift(rows, -1, "v")
         2:   pshift(rows, 1, "v")
         4:   pflip(rows, "v")
         5:   pflip(rows, "h")
         7:   protate(rows, 180)
         10:  pinvert(rows)
         12:  {
              if /allxform then {
                 case Dialog("Enlarge:", ["left", "right", "top", "bottom"],
                    0, 3, ["Okay", "Cancel"]) of {
                       "Cancel":  fail
                       "Okay":  {
                           icheck(dialog_value) | fail
                           result := copy(params := dialog_value)
                           push(result, rows)
                           pborder ! result
                           }
                       }
                    }
                 }
         default:   fail
         }
      2: case row of {
         1:   pshift(rows, 1, "h")
         10:  pscramble(rows, "b")
         12:  {
              if /allxform then {
                 case Dialog("Center:", ["width", "height"], [*rows[1], *rows], 
                    3, ["Okay", "Cancel"]) of {
                    "Cancel":  fail
                    "Okay": {
                       icheck(dialog_value) | fail
                       result := copy(params := dialog_value)
                       push(result, rows)
                       pcenter ! result
                       }
                    }
                 }
              }
         default:   fail
         }
      default:   fail
      }

end

#===<<vib:begin>>===	modify using vib; do not remove this marker line
procedure ui_atts()
   return ["size=730,420", "bg=pale gray", "label=Penelope"]
end

procedure ui(win, cbk)
return vsetup(win, cbk,
   [":Sizer:::0,0,730,420:Penelope",],
   ["file:Menu:pull::0,1,36,21:file",file_cb,
      ["load  @L","save  @S","save as","read  @R","write @W",
      "quit  @Q"]],
   ["line1:Line:::1,22,729,22:",],
   ["line2:Line:::133,32,133,420:",],
   ["line3:Line:::427,22,427,419:",],
   ["list:Menu:pull::73,1,36,21:list",list_cb,
      ["clear","reverse","delete range","sort",
         ["by size","by bits","by notes"]]],
   ["note:Menu:pull::145,1,36,21:note",note_cb,
      ["edit @E","find @F"]],
   ["symmetries:Label:::156,338,70,13:symmetries",],
   ["tile:Menu:pull::37,1,36,21:tile",tile_cb,
      ["next     @N","previous @P","first","last","goto     @G",
      "delete   @D","revert","copy     @C","new","info     @I"]],
   ["transformations:Label:::8,32,105,13:transformations",],
   ["view:Menu:pull::110,1,36,21:view",view_cb,
      ["pattern","tile","tile zoom",
         ["1:1","2:1","4:1","8:1"]]],
   ["logo:Rect:invisible::26,373,32,32:",logo_cb],
   ["symmet:Rect:grooved::155,363,74,42:",symmet_cb],
   ["xform:Rect:grooved::26,57,58,256:",xform_cb],
   ["grid:Rect:grooved::153,64,251,256:",grid_cb],
   )
end
#===<<vib:end>>===	end of section maintained by vib