############################################################################
#
#	File:     mondrian.icn
#
#	Subject:  Program to design on a non-linear grid
#
#	Author:   Ralph E. Griswold
#
#	Date:     September 6, 2000
#
############################################################################
#
#  This file is in the public domain.
#
############################################################################
#
#  This program provides a grid in which the sizes of the rectangles are
#  derived from the evaluation of generators.
#
############################################################################
#  
#  April 13, 2000
#  
#  mondrian allows block design on a non-linear grid.  It optionally
#  can limit designs to those that are weavable.
#  
#  The mouse is used for design, with a color associated with each of
#  the mouse buttons.
#  
#  There are four windows:  interface, design, palette, and legal colors.
#  Legal colors ordinarily are hidden; the button "show legal colors"
#  on the interface toggles the visibility of this window.
#  
#  The interface has three colored regions that show the colors
#  currently assigned to the left, middle, and right mouse buttons.
#  
#  The interface symmetry pad functions like Penelope's.
#  
#  There are radio buttons to allow quickly setting symmetries to
#  all or none.  There are three toggle buttons:
#  
#  	enforce weavability	do not allow colorings that render
#  				  design unweavable
#  
#  	show legal colors	display window with cells from last
#  				  weavability test
#  
#  	show weavability	display unravel results when testing
#  				  weavability
#  
#  The design window is a grid.  Initially it is a linear grid,
#  but that can be changed as described later.  The design window
#  always has grid lines separating the cells.
#  
#  Clicking or dragging on a cell on the design window fills that cell
#  with the color associated with the button pressed.
#  
#  The palette window displays the current palette (default "c1").
#  Clicking on a cell in the palette window assigns the corresponding
#  color to the button used.  Custom palettes have partial support.  An
#  attempt is made to load the "standard" custom palette database on
#  start up.  If this fails, notice is given and program execution
#  continues as usual.
#  
#  Clicking on a button color on the interface finds all cells of that
#  color that possibly could be used for a legal (weavable) design.
#  (If the design is unweavable at the time, the results from unravel show
#  that.)
#  
#  The legal colors window, intially all in the right-button color, shows
#  possibly legal colors for the design window.  Clicking on a cell in the
#  legal colors window colors the corresponding cell in the design window
#  with the selected color.  Any mouse click does this and only the colors
#  in the legal design window can be copied to the design window.  Note:
#  The legal design window is only updated as the result of producing an
#  unravel solution as described in the preceding paragraph.  In addition,
#  in some cases, colors in the legal colors window when copied may not
#  produce a weavable design.
#  
#  The interface menus provide facilities as follows:
#  
#  	File
#  
#  		save image   @I		save design window in a file
#  
#  		save pattern @P		save pattern as image string
#  
#  		save design  @S		saves the current design structure
#  					  as an xencoded file
#  
#  		load design  @L		load a saved design
#  
#  		load pattern @M		load image string to chane design colors
#  					  (not implemented yet)
#  
#  		load palette		load custom palette database
#  
#  		quit         @Q		quit the application
#  
#  		undo         @U		undo last operation
#  
#  		redo	     @T		redo last operation (not implemented yet)
#  
#  		clear stack  @X		clear undo stack
#  
#  	Design
#  
#  		new     @N		specify a new grid design (see
#  					  below)
#  
#  	Patterns
#  
#  		clear to ...		leads to a submenu in which
#  					  you can specify which color
#  					  to used to clear then entire
#  					  pattern
#  
#  		checkerboard @C		fills the design grid with a
#  					  checkerboard pattern according
#  					  to the colors associated with
#  					  the left and right mouse buttons
#  
#  		random       @R		fills the grid design with random
#  					  choices among the three colors
#  
#  	Help				presently gives snide comment
#  
#  Patterns saved as image strings have one pixel for each cell and no
#  geometry information.  They are suitable as input to unravel.
#  
#  Creating a new design (@N) brings up a dialog with six fields:
#  
#  	width sequence		An Icon generator that specifies the
#  				  *widths* of cells from left to right
#  
#  	height sequence		An Icon generator that specifies the
#  				  *height* of cells from top to bottom
#  
#  	scale			A multipication factor for cell dimensions
#  
#  	horizontal cells	The maximum number of horizontal cells
#  
#  	vertical cells		The maximum number of vertical cells
#  
#  	palette			The palette to be used for the design
#  
#  A new design produces a new design window will all cells in the right-button
#  color.
#  
#  Note:  If the design specification would produce a window with a dimension of
#  greater than 800 pixels, a warning is issued and the number of cells is
#  reduced to bring the window within the limits.
#  
#  The "enforce weavability" toggle, when on, prevents changes to the design
#  window that would result in a unweavable pattern.  If a change would, there
#  is an audible alert and the design is undone.  Note:  If an unweavable
#  design is created prior to enabling enforced weavability, there many
#  be many undos to get back to the last weavable design.  The audible and
#  visual artifacts in this case are unpleasant.
#  
#  Design window shortcuts mostly mimic those for the interface:
#  
#	"l"		Load design as for @D
#  	"i"		Save image as for @I
#       "p"		Save pattern as for @P
#       "m"		Load pattern as for @M (not implemented yet)
#  	"q"		Raise interace window
#  	"s"		Save design as for @S
#       "u"		Undo last design operation as for @U
#  	"t"		Redo last design operation (not implemented yet)
#  	"w"		Test pattern for weavability
#  	"x"		Clear undo stack as for @X
#  	"l"		Clear to left color
#  	"m"		Clear to middle color
#  	"r"		Clear to right color
#  
#  Testing the pattern for weavability calls a packaged version of
#  unravel.icn which displays its results in a separate window and
#  is dismissed with "q".  If the pattern is not weavable, an
#  alert is sounded.
#  
#  Notes:
#  
#  Only light testing has been done.
#  
#  Testing for weavability generally is fast, since the necessary
#  procedures are incorporated in the application.  In addition, a
#  miniature version of the design pattern with one-pixel cells is
#  used (the grid lines, which do not affect weavability, are not
#  included).  An image string is for the miniature pattern is passed
#  to the procedures that test for weavability.
#
############################################################################
#
#  Problems:
#
#	1.  If the grid is nonlinear, testing weavability seems to be wrong.
#
#	2.  Error checking is almost nonexistent.
#
#  To be implemented:
#
#	1.  redo
#
#	2.  load pattern
#
#	3.  load pdb
#
#  New Features:
#
#	1.  give choice of colors on checkerboard
#
#	2.  do three-color checkerboard (?)
#
#	3.  provide way to crop and enlarge pattern
#
#	4.  support legal colors windows for all buttons (?)
#
#	5.  provide way to change grid layout without changing colors
#
#	6.  suppress multiple alerts when undoing an unweavable design
#
#	7.  provide indication of solvability in legal color windows 
#
#	8.  provide other packaged patterns (?)
#
############################################################################
#
#  Requires:  Version 9 graphics  
#
############################################################################
#
#  Links:  interact, io, palettes, random, tables, unrav, vsetup, xcode
#
############################################################################

link interact
link io
link palettes
link random
link tables
link unrav
link vsetup
link xcode

global PDB_			# palette database
global bg			# background color
global blocks			# design structure
global palette_chars		# palette characters
global palette_win		# palette window
global try_vis			# visibility attribute for try_win
global try_win			# window for legal colorings
global colors			# design colors
global poss_colors		# potentially weavable design colors
global enforce			# toggle to enforce weavability
global fg			# foreground color
global grid_color		# color for grid lines
global interface		# interface window
global mg			# "midground" color
global mondrian			# design window
global palette			# palette in use
global root
global save_stack		# stack of saved records for undo
global scale			# design scale
global touched			# modified design toggle
global vidgets
global x_coords			# x-coordinates
global y_coords			# y-coordinates
global unv_mode			# unravel display mode

global sym_image_current	# current drawing images
global sym_image_next		# next drawing images
global sym_state		# drawing state
global symmet_xpos
global symmet_yoff
global symmetries		# general symmetry state

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_rot_180		# highlighted icon for 180 rot
global hi_rot_90		# highlighted icon for 90-rot
global hi_rot_m90		# highlighted icon for -90 rot
global hi_horiz			# highlighted icon for h-flip
global hi_vert			# highlighted icon for v-flip
global rotate_180		# icon for 180-degree rotation
global rotate_90		# icon for 90-degree rotation
global rotate_m90		# icon for -90-degree rotation
global flip_horiz		# icon for horizontal flip
global flip_left		# icon for left flip
global flip_right		# icon for right flip
global flip_vert		# icon for vertical flip

record design(
   blocks,
   colors,
   palette,
   fg,
   mg,
   bg,
   grid_color,
   x_coords,
   y_coords,
   scale
   )

$define ExprWidth   80		# width of expression field
$define IconSize    16		# size of button icons
$define MaxDim     800		# maximum dimension of design window

procedure main()
   local atts

   atts := ui_atts()

   put(atts, "posx=0", "posy=0")

   interface := (WOpen ! atts) | stop("can't open window")
   vidgets := ui()
   root := vidgets["root"]

   init()

   repeat {
      case Active() of {
         interface    :  {
            while *Pending(interface) > 0 do
               ProcessEvent(root, , shortcuts)
            }
         mondrian     :  {
            while *Pending(mondrian) > 0 do
               dabble()
            }
         palette_win  :  {
            while *Pending(palette_win) > 0 do
               palkey()
            }
         try_win      :  {
            while *Pending(try_win) > 0 do
               transfer()
            }
         }
      }

   GetEvents(root, , shortcuts)

end

procedure button_cb(vidget, e)

   if  e == (&lpress | &mpress | &rpress) then
      try_color(
         case vidget.id of {
            "left"    :  fg
            "middle"  :  mg
            "right"   :  bg
            }
         )
   else fail

   new_try(vidget.id)

   return

end

procedure edit_cb(vidget, value)

   case value[1] of {
      "undo  @U"  :  undo_design()
      "redo  @T"  :  redo_design()
      "clear stack  @X"  :  clear_stack()
      }

   return

end

procedure checkerboard()
   local i, j, clr

   every i := 1 to *blocks[1] do
      every j := 1 to *blocks do {
         if (i + j) % 2 = 0 then clr := fg else clr := bg
         Fg(mondrian, PaletteColor(palette, clr))
         blocks[j, i][1] := mondrian
         FillRectangle ! blocks[j, i]
         colors[j, i] := clr
         }

   Fg(mondrian, PaletteColor(palette, fg))

   return

end

procedure clear(value)
   local i, j, clr, key

   key := case value of {
      "left"    :  fg
      "middle"  :  mg
      "right"   :  bg
      }

   clr := PaletteColor(palette, key)

   every i := 1 to *blocks[1] do
      every j := 1 to *blocks do {
         Fg(mondrian, clr)
         blocks[j, i][1] := mondrian
         FillRectangle ! blocks[j, i]
         }

   colors := list(*y_coords, repl(key, *x_coords))

   poss_colors := copy(colors)

   Fg(mondrian, PaletteColor(palette, fg))

   return

end

procedure clear_stack()

   save_stack := []

end

procedure color(key)
   local i, j

   every i := 1 to *x_coords + 1 do
      if &x < x_coords[i] then break

   if i = *x_coords + 1 then fail

   every j := 1 to *y_coords + 1 do
      if &y < y_coords[j] then break

   if j = *y_coords + 1 then fail

   Fg(mondrian, PaletteColor(palette, key))

   if sym_state[1, 1] = 1 then {		# cell itself
      colors[j, i] := key
      blocks[j, i][1] := mondrian
      FillRectangle ! blocks[j, i]
      }
   if sym_state[1, 2] = 1 then {		# 90 degrees
      if colors[i, -j] := key then {		# may be out of bounds
         blocks[i, -j][1] := mondrian
         FillRectangle ! blocks[i, -j]
         }
      }
   if sym_state[1, 3] = 1 then {		# -90 degrees
      if colors[-i, j] := key then {		# may be out of bounds
         blocks[-i, j][1] := mondrian
         FillRectangle ! blocks[-i, j]
         }
      }
   if sym_state[1, 4] = 1 then {		# 180 degrees
      colors[-j, -i] := key
      blocks[-j, -i][1] := mondrian
      FillRectangle ! blocks[-j, -i]
      }
   if sym_state[2, 1] = 1 then {		# left diagonal
      if colors[i, j] := key then {		# may be out of bounds
         blocks[i, j][1] := mondrian
         FillRectangle ! blocks[i, j]
         }
      }
   if sym_state[2, 2] = 1 then {		# right diagonal
      if colors[-i, -j] := key then {		# may be out of bounds
         blocks[-i, -j][1] := mondrian
         FillRectangle ! blocks[-i, -j]
         }
      }
   if sym_state[2, 3] = 1 then {		# vertical
      colors[-j, i] := key
      blocks[-j, i][1] := mondrian
      FillRectangle ! blocks[-j, i]
      }
   if sym_state[2, 4] = 1 then {		# horizontal
      colors[j, -i] := key
      blocks[j, -i][1] := mondrian
      FillRectangle ! blocks[j, -i]
      }

   touched := 1

   return

end

procedure color_cells(win, colors)
   local i, j, x, y

   x := 0

   every i := 1 to *x_coords do {
      y := 0
      every j := 1 to *y_coords do {
         blocks[i, j][1] := win
         Fg(win, PaletteColor(palette, colors[i, j]))
         blocks[i, j][1] := win
         FillRectangle ! blocks[i, j]
         }
      }

   return

end

procedure create_grid()
   local output, input
   static horizontal, vertical, w_limit, h_limit

   initial {
      horizontal := "|1"
      vertical := "|1"
      w_limit := 20
      h_limit := 20
      }

   if \touched then
      case TextDialog("Save design?", , , , ["Yes", "No", "Cancel"]) of {
         "Cancel"  :  fail
         "Yes"     :  save_design()
      }

   repeat {
      if TextDialog(
         "Layout:",
         [
            "width sequence",		# 1
            "height sequence",		# 2
            "scale",			# 3
            "horizonal cells",		# 4
            "vertical cells",		# 5
            "palette"			# 6
            ],
         [
            horizontal,
            vertical,
            scale,
            w_limit,
            h_limit,
            palette
            ],
         ExprWidth
         ) == "Cancel" then fail
   
      clear_stack()

      horizontal := dialog_value[1]		# VALIDITY CHECKS NEEDED
      vertical := dialog_value[2]
      scale := dialog_value[3]
      w_limit := dialog_value[4]
      h_limit := dialog_value[5]
      palette := dialog_value[6]
      PaletteChars(palette) | {
         Notice("Invalid palette.")
         next
         }
      break
      }

   x_coords := evaluate(horizontal, w_limit, scale) | fail

   y_coords := evaluate(vertical, h_limit, scale) | fail

   if (x_coords[-1] | y_coords[-1]) > MaxDim then
      Notice("Design too large; truncating.")

   until x_coords[-1] <= MaxDim do
      pull(x_coords)

   until y_coords[-1] <= MaxDim do
      pull(y_coords)

   if *(x_coords | y_coords) < 2 then {
      Notice("Too few cells for design.")
      fail
      }

   WClose(\mondrian)

   fg := PaletteKey(palette, "red")
   mg := PaletteKey(palette, "green")
   bg := PaletteKey(palette, "blue")

   fill_region("left", fg)
   fill_region("middle", mg)
   fill_region("right", bg)

   mondrian := new_design()

   paletier(palette)

   return

end

procedure dabble()

   case Event(mondrian) of {
      &lpress  :  {
         save_state()
         color(fg)
         }
      &mpress  :  {
         save_state()
         color(mg)
         }
      &rpress  :  {
         save_state()
         color(bg)
         }
      &ldrag   :  color(fg)
      &mdrag   :  color(mg)
      &rdrag   :  color(bg)
      &lrelease | &mrelease | &rrelease  :  if \enforce then {
         while not test_image(unv_mode) do {
            undo_design()
            Alert := 1
            }
         Alert := proc("Alert", 0)
         }
      "d"      :  load_design()
      "i"      :  save_image()
      "p"      :  save_pattern()
      "q"      :  Raise(interface)
      "t"      :  redo_design()
      "u"      :  undo_design()
      "w"      :  test_image(unv_mode)
      "x"      :  clear_stack()
      }

   return

end

procedure design_cb(vidget, value)

   case value[1] of {
      "new   @N"  :  create_grid()
      "save  @S"  :  save_design()
      "load  @D"  :  load_design()
      "clear @C"  :  {
         if SelectDialog("Color:", ["left", "middle", "right"]) == "Cancel" then
            fail
         clear(dialog_value)
         }
      }

   return

end

procedure design_record()
   local old_blocks, i, j

   old_blocks := copy(blocks)

   every i := 1 to *x_coords do
      every j := 1 to *y_coords do
         old_blocks[i, j] := copy(blocks[i, j])

   return design(copy(blocks), copy(colors), palette, fg, mg, bg,
      grid_color, copy(x_coords), copy(y_coords), scale)

end

procedure draw(win, p)		# draw palette, etc.

   EraseArea(win)

   drawpalette(win, p, , , , , "o") | {
      Notice("Could not get all colors.")
      fail
      }

   return

end

procedure draw_grids(win)
   local x, y

   Fg(win, "black")

   every x := 0 | !x_coords do
      DrawLine(win, x, 0, x, y_coords[-1] + 1)

   every y := 0 | !y_coords do
      DrawLine(win, 0, y, x_coords[-1] + 1, y)

   Fg(win, fg)

   return

end

procedure evaluate(exp, limit, scale)
   local input, output, coords, x

   output := open("/tmp/mexpr.icn", "w") | {
      Notice("Cannot open file for design expression.")
      Raise(interface)
      fail
      }

   write(output, "link seqfncs")
   write(output, "procedure main()")
   write(output, "   every write(", exp, ") \\ ", limit)
   write(output, "end")

   close(output)

   remove("/tmp/mondrian.err")

   WAttrib(interface, "pointer=watch")

   if system("icont -s /tmp/mexpr >/dev/null 2>/tmp/mondrian.err") ~= 0 then {
      show_error("/tmp/mondrian.err")
      Raise(interface)
      WAttrib(interface, "pointer=arrow")
      fail
      }

   if system("mexpr > /tmp/mondrian.out 2>/tmp/mondrian.err") ~= 0 then {
      show_error("/tmp/mondrian.err")
      Raise(interface)
      WAttrib(interface, "pointer=arrow")
      fail
      }

   input := open("/tmp/mondrian.out") | {
      Notice("Evaluation file missing.")
      Raise(interface)
      WAttrib(interface, "pointer=arrow")
      fail
      }

   x := 0
   coords := []

   every put(coords, x +:= scale * (0 < integer(!input)))

   close(input)

   WAttrib(interface, "pointer=arrow")

   remove("mexpr")

   return coords

end

procedure file_cb(vidgets, value)

   case value[1] of {
      "save image   @I"  :  save_image()
      "load palette @P"  :  load_pdb()
      "quit         @Q"  :  quit()
      }

   return

end

procedure fill_region(vidget, key)
   local fg

   fg := Fg(interface)

   vidget := vidgets[vidget]

   Fg(interface, PaletteColor(palette, key))

   FillRectangle(interface, vidget.ux, vidget.uy, vidget.uw, vidget.uh)

   Fg(interface, fg)

   return

end

procedure help_cb(vidget, value)

   Notice("There is no help to be had.")

   return

end

procedure init()
   local i, input

   Palette_				# protect from linker
   Color_

   palette := "c1"

   palette_chars := PaletteChars(palette)

   scale := 10

   fg := PaletteKey(palette, "red")
   mg := PaletteKey(palette, "green")
   bg := PaletteKey(palette, "blue")

   grid_color := PaletteKey(palette, "black")

   fill_region("left", fg)
   fill_region("middle", mg)
   fill_region("right", bg)

   VSetState(vidgets["weavability"], 1)

   symmet_xpos := vidgets["symregion"].ux
   symmet_yoff := vidgets["symregion"].uy

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

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

   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"

   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"

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

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

   VSetState(vidgets["symstate"], "none ")

   x_coords := []

   every put(x_coords, 10 * seq(1) \ 20)

   y_coords := copy(x_coords)

   mondrian := new_design()

   poss_colors := copy(colors)

   try_vis := "canvas=hidden"

   new_try("right")

   paletier(palette)

   clear_stack()

   input := dopen("standard.pdb") | {
      Notice("Cannot open custom palette database.",
         "Only built-in palettes can be used.")
      fail
      }

   PDB_ := xdecode(input) | {
      Notice("Cannot decode palette database.")
      close(input)
      fail
      }

   close(input)

   if type(PDB_) ~== "table" then {
      Notice("Invalid  palette database.")
      fail
      }

   return

end

procedure legal_cb(vidget, value)

   if \value then try_vis := "canvas=normal"
   else try_vis := "canvas=hidden"

   WAttrib(try_win, try_vis)

   return

end

procedure load_design()
   local input, design
   static file

   repeat {
      if OpenDialog("Load design:", file) == "Cancel" then fail
      file := dialog_value
      input := open(file) | {
         Notice("Cannot open file.")
         next
         }
      design := xdecode(input) | {
         Notice("Cannot decode design.")
         next
         }
      close(input)
      break
      }

   reset_design(design)

   touched := &null

   return

end

procedure load_pattern()

   Notice("Loading patterns is not yet supported.")

   fail

end

procedure load_pdb()
   local input, npdb

   repeat {
      if OpenDialog("Load palette database:") == "Cancel" then fail
      input := open(dialog_value) | {
         Notice("Cannot open file.")
         next
      }
      npdb := xdecode(input) | {
         Notice("Cannot decode palette database.")
         close(input)
         next
         }
      break
      }

   if TextDialog("Merge?", , , , ["No", "Yes"]) == "Yes" then
      PDB_ := tblunion(PDB_, npdb)
   else PDB_ := npdb

   close(input)

   return

end

procedure new_design()
   local x, y, i, j, win

   win := WOpen(
      "label=design",
      "width=" || x_coords[-1] + 1,
      "height=" || y_coords[-1] + 1,
      "fg=black",
      "bg=" || PaletteColor(palette, mg),
      "posy=0",
      "posx=" || (WAttrib(interface, "width") + 10)
      ) | {
         Notice("Cannot open design window.")
         stop()
         }

   colors := list(*y_coords, repl(mg, *x_coords))

   blocks := []

   every j := 1 to *y_coords do
      put(blocks, list(*x_coords))

   x := 0

   every i := 1 to *x_coords do {
      y := 0
      every j := 1 to *y_coords do {
         blocks[j, i] := [win, x + 1, y + 1, x_coords[i] - x - 1,
            y_coords[j] - y - 1]
         y := y_coords[j]
         }
      x := x_coords[i]
      }

   draw_grids(win)

   Raise(interface)

   touched := &null

   return win

end

procedure new_try(button)

   WClose(\try_win)

   try_win := WOpen(
      try_vis,
      "width=" || WAttrib(mondrian, "width"),
      "height=" || WAttrib(mondrian, "height"),
      "bg=white",
      "fg=black",
      "label=possible " || button || " colors",
      "posy=0",
      "posx=" || (WAttrib(interface, "width") + WAttrib(mondrian, "width") + 20)
      ) | {
         Notice("Cannot open window for legal coloring.")
         fail
         }

   color_cells(try_win, poss_colors)

   draw_grids(try_win)

   Raise(interface)

   return

end

procedure paletier(p)
   local e

   PaletteChars(p) | {
      Notice("Palette not found.")
      fail
      }

   WClose(\palette_win)

   palette_win := WOpen(
      "width=125",
      "height=250",
      "font=lucidasans-bold-12",
      "label=" || p,
      "posx=0",
      "posy=" || (WAttrib(interface, "height") + 25)
      )

   WAttrib(palette_win, "resize=on")

   draw(palette_win, p) | fail

   Raise(interface)
   
   return

end

procedure palkey()
   local color, clr, e

   e := Event(palette_win)

   clr := pickpalette(palette_win, palette, &x, &y)

   case e of {
      &lpress  :  {
         fg := clr
         fill_region("left", fg)
         }
      &mpress  :  {
         mg := clr
         fill_region("middle", mg)
         }
      &rpress  :  {
         bg := clr
         fill_region("right", bg)
         }
      &resize  :  draw(palette_win, palette)
      }

   touched := 1

   return

end

#  This is a vestige of an earlier menu.  It is being retained for
#  possible reconsideration.

procedure patterns_cb(vidget, value)

   case value[1] of {
      "checkerboard @C"  :  checkerboard()
      "random       @R"  :  randomboard()
      }

   touched := 1

   return

end

#  Place icon

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

   DrawImage(interface, xoff + col * IconSize, 
     yoff + row * IconSize, pattern)

   return

end

procedure quit()

   if /touched then exit()

   case TextDialog("Save design?", , , , ["Yes", "No", "Cancel"]) of {
      "Cancel"  :  fail
      "No"      :  exit()
      "Yes"     :  {
         save_design()
         exit()
         }
      }

end

procedure randomboard()
   local i, j, clr, clrs

   initial randomize()

   clrs := [fg, mg, bg]

   every i := 1 to *blocks[1] do
      every j := 1 to *blocks do {
         clr := ?clrs
         Fg(mondrian, PaletteColor(palette, clr))
         blocks[j, i][1] := mondrian
         FillRectangle ! blocks[j, i]
         colors[j, i] := clr
         }

   Fg(mondrian, PaletteColor(palette, fg))

   return

end

procedure redo_design()

   return

end

procedure reset_design(design)

   blocks := design.blocks
   colors := design.colors
   palette := design.palette
   fg := design.fg
   mg := design.mg
   bg := design.bg
   grid_color := design.grid_color
   x_coords := design.x_coords
   y_coords := design.y_coords
   scale := design.scale

   fill_region("left", fg)
   fill_region("middle", mg)
   fill_region("right", bg)

   WAttrib(mondrian, "width=" || x_coords[-1] + 1, "height=" || y_coords[-1] + 1)

   color_cells(mondrian, colors)

   draw_grids(mondrian)

   Raise(interface)

   return

end

procedure save_design()
   local output
   static file

   repeat {
      if OpenDialog("Save design:", file) == "Cancel" then fail
      file := dialog_value
      if exists(file) then
         if TextDialog("Overwrite existing file?") == "Cancel" then fail
      output := open(file, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      break
      }

   xencode(design_record(), output)

   close(output)

   touched := &null

   return

end

procedure save_image()

   snapshot(mondrian)

   return

end

procedure save_pattern()
   local output, keys
   static file

   repeat {
      if SaveDialog("Save pattern:") == "Cancel" then fail
      output := open(dialog_value, "w") | {
         Notice("Cannot open file for writing.")
         next
         }
      file := dialog_value
      break
      }

   keys := ""

   every keys ||:= !colors

   write(output, *x_coords || "," || palette || "," || keys)

   close(output)

   return

end

procedure save_state()

   push(save_stack, design_record(), touched)

   return

end

#  Keyboard shortcuts.

procedure shortcuts(e)

   if &meta then case map(e) of {
      "l"  :  load_design()		# Design menu
      "i"  :  save_image()		# File menu
      "n"  :  create_grid()		# Design menu
      "q"  :  quit()			# File menu
      "s"  :  save_design()		# Design menu
      "u"  :  undo_design()		# Edit menu
      "t"  :  redo_design()		# Edit menu
      "x"  :  clear_stack()		# Edit menu
      "m"  :  clear("middle")
      "r"  :  clear("right")
      }

   return

end

procedure show_error(file)
   local input, log

   input := open(file) | {
      Notice("Cannot open error log.")
      fail
      }

   log := ["Error log:", ""]

   while put(log, read(input))

   close(input)

   Notice ! log

   return

end

#  symmetry buttons

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

   if e === (&lpress | &rpress | &mpress) then {
      col := (&x - symmet_xpos) / IconSize + 1
      row := (&y - symmet_yoff) / IconSize + 1
      sym_state[row, col] *:= -1
      sym_image_current[row, col] :=: sym_image_next[row, col]
      place(symmet_xpos, symmet_yoff, 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.")
         fail
         }
      else if (sym_state[1, 1] = 1) & (symcount = -6) then symmetries := 0
      else symmetries := 1

      return
      }

   fail

end

procedure symstate_cb(vidget, value)
   local row, col

   #  Note:  the blanks at the end of these radio-button labels are
   #  for interface formatting.

   sym_state := case value of {
      "none "  :  [[1, -1, -1, -1], [-1, -1, -1, -1]]
      "all  "   :  [[1, 1, 1, 1], [1, 1, 1, 1]]
      }

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

   if value == "all  " then sym_image_next :=: sym_image_current

   every col := 1 to 4 do
      every row := 1 to 2 do
         place(symmet_xpos, symmet_yoff, col - 1, row - 1,
            sym_image_current[row, col])
   return

end

procedure test_image(mode)
   local keys

   keys := ""

   every keys ||:= !colors

   if unv_main(*x_coords || "," || palette || "," || keys, mode) = 0 then { 
      Alert()
      fail
      }

   return

end

procedure transfer()
   local clr

   case Event(try_win) of {
      &lpress | &mpress | &rpress  :  {
         if &x = (0 | !x_coords) then fail		# on grid line
         if &y = (0 | !y_coords) then fail
         clr := PaletteKey(palette, Pixel(try_win, &x, &y)) | fail
         save_state()
         color(clr)
         }
      &ldrag | &mdrag | &rdrag  :  {
         if &x = (0 | !x_coords) then fail		# on grid line
         if &y = (0 | !y_coords) then fail
         clr := PaletteKey(palette, Pixel(try_win, &x, &y)) | fail
         color(clr)
         }
      &lrelease | &mrelease | &rrelease  :  if \enforce then {
         while not test_image(unv_mode) do undo_design()
         }
      "q"  :  Raise(interface)
      }

   return

end

procedure try_color(clr)
   local keys, i, new_keys, prefix

   prefix := *x_coords || "," || palette || ","

   keys := ""

   every keys ||:= !colors
   new_keys := keys

   WAttrib(interface, "pointer=watch")

   every i := 1 to *keys do {
      if keys[i] == clr then next
      keys[i] :=: clr 
      if unv_main(prefix || keys) = 1 then {
         new_keys[i] := keys[i]
         }
      keys[i] :=: clr
      }

   poss_colors := copy(colors)

   new_keys ? {
      i := 1
      while poss_colors[i] := move(*x_coords) do
         i +:= 1
      }

   unv_main(prefix || new_keys, unv_mode)

   WAttrib(interface, "pointer=arrow")
      
   return

end

procedure undo_design()

   touched := get(save_stack)

   reset_design(get(save_stack)) | {
      Notice("Nothing to undo.")
      fail
      }

   return

end

procedure unravel_cb(vidget, value)

   unv_mode := value

   return

end

procedure weavability_cb(vidget, value)

   enforce := value

   return

end

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

procedure ui(win, cbk)
return vsetup(win, cbk,
   [":Sizer:::0,0,274,226:",],
   ["design:Menu:pull::72,0,50,21:Design",design_cb,
      ["new   @N","save  @S","load  @L","clear @C"]],
   ["edit:Menu:pull::36,0,36,21:Edit",edit_cb,
      ["undo        @U","redo        @T","clear stack @X"]],
   ["file:Menu:pull::0,0,36,21:File",file_cb,
      ["save image   @I","load palette @P","quit         @Q"]],
   ["label1:Label:::61,77,28,13:left",],
   ["label2:Label:::114,77,42,13:middle",],
   ["label3:Label:::173,77,35,13:right",],
   ["label4:Label:::87,30,91,13:button colors",],
   ["label5:Label:::23,114,70,13:symmetries",],
   ["legal:Button:regular:1:115,152,140,20:show legal colors",legal_cb],
   ["line1:Line:::0,22,275,22:",],
   ["line2:Line:::0,100,275,100:",],
   ["symstate:Choice::2:25,177,64,42:",symstate_cb,
      ["all  ","none "]],
   ["unravel:Button:regular:1:115,191,140,20:show weavability",unravel_cb],
   ["weavability:Button:regular:1:115,113,140,20:enforce weavability",weavability_cb],
   ["left:Rect:grooved::60,50,32,20:",button_cb],
   ["middle:Rect:grooved::119,50,32,20:",button_cb],
   ["right:Rect:grooved::175,50,32,20:",button_cb],
   ["symregion:Rect:grooved::23,136,68,36:",symmet_cb],
   )
end
#===<<vib:end>>===	end of section maintained by vib