#!/bin/sh
# the next line restarts using tclsh \
exec wish "$0" "$@"

if {[file isdirectory /usr/local/lib/polypuzzle]} {cd  /usr/local/lib/polypuzzle}

# wish8.5.2 still occasionally has problems for polypuzzle without this hack:
set tcl_precision 12

source colours
set colour(bg)  azure3		;# background colour
set colour(fill) grey75		;# tray fill colour
set colour(grid) grey55		;# tray grid colour

set flag(check_finished) 1	;# check for finished and show 'reward'
set flag(report_finished) 0	;# stops checking between double-clicks & loads
set flag(bold_outline) 1	;# bold outline of overlapping pieces on grid
set flag(piece_ridges) 1	;# display the ridges inside the pieces
set flag(tray_ridges) 1		;# display the ridges inside the tray
set flag(drag_ok) 0		;# stops piece being dragged after being reset
set flag(debug) 0

# R=20 gives even R,W and accurate integer values for r,w. (also 14,22,28)
# For most other radii, the "/2" should be replaced with "/2.0"
# to give more accurate floating point values.
set R 20			;# radius/side
set W [expr int($R * sqrt(3))]	;# width of hexagon
set r [expr $R/2]		;# half radius
set w [expr $W/2]		;# half width
set S 26			;# side of square
set s 13

# used by new help widgets

set data(font_default)   {Arial -16}
set data(font_medium) {Arial -18}
set data(font_large) {Arial -20}
set data(version) 1.8.4
set data(date) 28/06/2014
set data(name) "Poly Puzzle $data(version)"

wm title	. $data(name)
wm iconname	. PolyPuzzle
wm iconbitmap	. @icon.xbm
wm iconmask	. @iconmask.xbm
wm resizable	. 0 0

set savedir "~/.polypuzzle"
if ![file isdirectory "$savedir"] {
    file mkdir "$savedir"
}

if [file readable $savedir/options] {
    if { [catch {source $savedir/options}] != 0 } {
	puts stderr {polypuzzle: error in "$savedir/options".}
    }
}
if {![info exists gamemode]} { set gamemode square } ;# default is square

if {[lindex $argv 0]=="-debug"} {
  set flag(debug) 1
} elseif {[lindex $argv 0]!=""} {
  puts "polypuzzle: args ignored."
}

######## PROCEDURES ########

proc InitCanvas {} {
  global R r W w S s height width p cells gamemode gametype colour flag deleted

  set p(count) 0	;# number of pieces in game
  set cells 0		;# number of elements in tray
  set deleted {}	;# list of deleted n

  switch $gamemode {
    small  { set dim(x) 5 ; set dim(y) 4 ; set width 350 ; set height 300 }
    medium { set dim(x) 8 ; set dim(y) 6 ; set width 520 ; set height 400 }
    large  { set dim(x) 11; set dim(y) 10; set width 748 ; set height 532 }
    bonus  { set width 748; set height 532 }
    783  {
	set dim(x) 8 ; set dim(y) 5; set width 405 ; set height 255
	set colour(current) turquoise
        set dx 10 ; set dy 5
    }
    chessboard {
	set dim(x) 8 ; set dim(y) 8 ; set width 450 ; set height 450
	set colour(current) mixed
	set dx 100 ; set dy 100
    }
    square  {
	set dim(x) 6 ; set dim(y) 10 ; set width 550 ; set height 300
	set colour(current) green
        set dx 185 ; set dy 10
    }
    3x20  {
	set dim(x) 20 ; set dim(y) 3; set width 550 ; set height 300
	set colour(current) green
        set dx 7 ; set dy 80
    }
    monster {
	set dim(x) 19; set dim(y) 11; set width 800 ; set height 560
	set colour(current) turquoise
        set dx 10 ; set dy 5
    }
    triangle {
	set width 520 ; set height 400
	set colour(current) gold
        set dx 110; set dy 40
	set X      {3 5 7 9 11 13 13 11}
	set OFFSET {5 4 3 2  1  0  0  1}
        set SLOPE  {1 1 1 1  1  1  0  0}
    }
    flower  {
	set width 520 ; set height 400
        set colour(current) thistle
        set dx 60; set dy 50
	set X      {3 9 12 12 12 12 9 3}
	set OFFSET {7 6  3  3  4  4 4 9}
        set SLOPE  {1 1  1  0  0  1 0 0}
    }
    star {
	set width 800 ; set height 560
	set colour(current) purple
        set dx 10; set dy 10
	set X      {5 7 17 19 19 17 17 19 19 17 7 5}
	set OFFSET {7 6  1  0  0  1  1  0  0  1 6 7}
        set SLOPE  {1 1  1  1  0  0  1  1  0  0 0 0}
    }
    round {
	set width 700 ; set height 460
	set colour(current) green
        set dx 120; set dy 115
	set X      {17 17 21 21 17 17}
	set OFFSET {2 2 0 0 2 2}
        set SLOPE  {0 1 0 1 0 1}
	set POINTS {2 6 10 14}
    }
    krazy {
	set width 700 ; set height 600
	set colour(current) colourful
        set dx 120; set dy 115
	set X      {13 13 17 17 21 21 17 17 13 13}
	set OFFSET {4 4 2 2 0 0 2 2 4 4}
        set SLOPE  {0 1 0 1 0 1 0 1 0 1}
	set POINTS {4 8 12}
    }
    default {puts stderr "polypuzzle: wrong gamemode" ; Die }
  }

  canvas .c -background $colour(bg) -height $height -width $width

  ### draw tray
  # The tray is made up of many indentical polygons and are the glue that
  # allows us to snap to the grid and test if the tray is full.
  # Extensive use is made of Tk's ability to find overlapping canvas items
  # and have multiple tags to group together small polygons and their single
  # larger outline to form a piece.

  if {$flag(tray_ridges) && $gamemode != "round" && $gamemode != "krazy"} {
    set colour(outline) $colour(grid)
  } else {
    set colour(outline) {}
  }

  switch $gamemode {
    
    small - medium - large {
      set colour(current) gold
      set gametype hexagon
      for {set y 1} {$y <= $dim(y)} { incr y } {
	for {set x 1} {$x <= $dim(x) } { incr x } {
	  incr cells
	  OneHexagon [expr $x*$W + $y*$w - 20] [expr $y*$R*1.5 + 5]
	}
      }
    }
    bonus {
      set colour(current) orange
      set gametype hexagon
      set oldx 3; set dx 5; set y 0; set offset -1.5

      # these are the widths of each row
      foreach x {4 5 6 7 8 9 10 11 12 11 10 9 8} {
	incr y
	if {$x < $oldx} {set offset 1.5}
	set dx [expr $dx + $offset]

	for {set i 1} {$i <= $x} {incr i} {
	  incr cells
	  OneHexagon [expr ($x+$i+$dx)*$W - 20] [expr $y*$R*1.5 + 5]
	}
	set oldx $x
      }
    }
    
    783 - square - chessboard - 3x20 - monster {
      set gametype square
      for {set y 1} {$y <= $dim(y)} { incr y } {
	for {set x 1} {$x <= $dim(x) } { incr x } {
	  incr cells
	  OneSquare [expr $x*$S + $dx] [expr $y*$S + $dy]
	}
      }
      if {$gamemode == "monster"} {
        incr cells
        OneSquare [expr 10*$S + $dx] [expr 12*$S + $dy]
      }
    }
    
    triangle - flower - star - round - krazy {
      set gametype triangle
      set y 0

      # round has extra pointy triangles top and bottom
      if {$gamemode == "round" || $gamemode == "krazy"} {
        foreach i $POINTS {
          incr cells
          OneTriangle  [expr $dx + (3+$i)*$R] [expr $dy+$y*$W] 1
	}
      }

      foreach x $X offset $OFFSET slope $SLOPE {
        incr y 1
        set z $slope
	for {set i 1} {$i <= $x} {incr i} {
          incr cells
          OneTriangle [expr $dx + ($offset+$i)*$R] [expr $dy+$y*$W] $z
          set z [expr !$z]
        }
      }

      if {$gamemode == "round" || $gamemode == "krazy"} {
        incr y
        foreach i $POINTS {
          incr cells
          OneTriangle  [expr $dx + (3+$i)*$R] [expr $dy+$y*$W] 0
	}
      }
    }
  }
  .c config -cursor plus
  pack .c
}
################### draw a piece of the tray at window location x,y
proc OneHexagon {x y} {
  global colour R r W w
  # tk's canvas : x positive is down, y positive is right  %^|
  .c move [.c create polygon $w $r 0 $R -$w $r -$w -$r 0 -$R $w -$r \
    -outline $colour(outline) -tag tray -width 2 -fill $colour(fill) ] $x $y
}

proc OneSquare {x y} {
  global colour s
  .c move [.c create polygon -$s -$s $s -$s $s $s -$s $s \
    -outline $colour(outline) -tag tray -width 2 -fill $colour(fill) ] $x $y
}

proc OneTriangle {x y z} {
  global colour R r W w

  if {$z} {
    .c move [.c create polygon 0 -$w -$R $w $R $w \
    -outline $colour(outline) -width 1 -fill $colour(fill) -tag tray ] $x $y
  } else {
    .c move [.c create polygon 0 $w $R -$w -$R -$w \
    -outline $colour(outline) -width 1 -fill $colour(fill) -tag tray ] $x $y
  }
}
#############
proc InitPieces {} {
  global gamemode

  #	global variable p()
  #
  #	bool	p(colour,1..22)	; either 1 or 2, for dual colour pieces
  #	list	p(coords,1..22)	; each list is 6 x,y pairs (hexagon) = 12
  #	int	p(x,1..22)	; tile's initial off-tray X value
  #	int	p(y,1..22)	; tile's initial off-tray Y value

  SetPieceColours
  source pieces.$gamemode
}
################### restore piece to it's original position
proc ResetPiece {x y} {
  global p flag

  # which piece
  regexp {piece[0-9]+} [join [.c gettags [.c find withtag current]]] current_piece
  regexp {[0-9]*$} $current_piece n

  set coords [.c coords $current_piece]

  set midcoords [GetMidCoords $coords]
  .c move $current_piece [expr $p(x,$n) - [lindex $midcoords 0]] \
	 [expr $p(y,$n) - [lindex $midcoords 1]]

  UnBoldPieceOutline
  set flag(drag_ok) 0 
  set flag(report_finished) 0
}

### Try to make a duplicate piece feature!

# Currently this is fucked S.A.
# The pieces aren't re-initialised properly from the savegame,
# and colour isn't handled properly... Needs effort.

proc DuplicatePiece {x y} {
  global p flag deleted

  regexp {piece[0-9]+} [join [.c gettags [.c find withtag current]]] current_piece
  regexp {[0-9]*$} $current_piece n

  set coords $p(coords,$n)
  set xpos $p(x,$n)
  set ypos $p(y,$n)
  set col $p(colour,$n)

  MakePiece $col $xpos $ypos $coords

  ReInitText
  set flag(drag_ok) 0 
  set flag(report_finished) 0
}

proc DeletePiece {x y} {
  global p deleted

  regexp {piece[0-9]+} [join [.c gettags [.c find withtag current]]] current_piece
  regexp {[0-9]*$} $current_piece n

  .c delete $current_piece 
  lappend deleted $n

  ReInitText
  set flag(drag_ok) 0 
  set flag(report_finished) 0
}

##################
proc MakePiece {col xpos ypos coords} {
  global p

  incr p(count)
  InitPiece $p(count) $col $xpos $ypos $coords
  DrawPiece $p(count) $xpos $ypos
}
##################
proc InitPiece {n col xpos ypos coords} {
  global p colour gamemode

  set p(colour,$n) $col
  set p(coords,$n) $coords
  set p(x,$n) $xpos
  set p(y,$n) $ypos

  SetColourN $n
}

##################
# the tags are  "piece": all puzzle pieces
#               "pieceX": piece number X
#               "piececolN" : all piece hexagons colour N
#		"piecepolyX": piece polygon number X
#               "piecepolycolN" : complex outlines colour N
#		"tray" the little polygons of the tray

proc DrawPiece {n xpos ypos} {
  global R r W w S s p colour gamemode gametype flag

  # Set piece colours
  # This is a little over-complicated... sorry
  # - see "colours" file for more info.
  set col $p(colour,$n);
  set c1 $p(col1,$n)
  set c2 $p(col2,$n)
  set c3 $p(col3,$n)
  set c4 $p(col4,$n)

  if {$flag(piece_ridges)} {
    set outline $c2
  } else {
    set outline {}
  }

  ### assemble piece at origin then move to xpos,ypos
  # holy mathematics batman
  if {$gametype == "square"} {
    foreach {x y} [split $p(coords,$n)] {
      .c move [.c create polygon -$s -$s $s -$s $s $s -$s $s \
	-fill $c1 -outline $outline -width 1 \
	-tags "piece$n piece piececol$col" ] \
      [expr $x * $S] [expr $y * $S]
    }
  } elseif {$gametype == "hexagon"} {
    foreach {x y} [split $p(coords,$n)] {
      .c move [.c create polygon $w $r 0 $R -$w $r -$w -$r 0 -$R $w -$r \
	-fill $c1 -outline $outline -width 1 \
	-tags "piece$n piece piececol$col" ] \
      [expr $x * $W + $y * $w] [expr $y * $R * 1.5]
    }
  } else { ;# triangle
    foreach {x y z} [split $p(coords,$n)] {
      if {$z} {
	.c move [.c create polygon 0 -$w -$R $w $R $w \
	  -fill $c1 -outline $outline -width 1 \
	  -tags "piece$n piece piececol$col" ] \
      [expr $x*$R] [expr $y * $W]
      } else {
	.c move [.c create polygon 0 $w $R -$w -$R -$w \
	  -fill $c1 -outline $outline -width 1 \
	  -tags "piece$n piece piececol$col" ] \
      [expr $x*$R] [expr $y * $W]
      }
    }
  }

  # Place this piece on top (but underneath text, which is our ceiling)
  # Catch if error (recent tk changes redefined default behaviour of canvas lower)
  catch {
    .c lower piece$n text
  }

  .c move piece$n $xpos $ypos

  ### Make a list of points that define the outline. good luck!!!

  set L {}
  foreach i [.c find withtag piece$n] {
    set coords [.c coords $i]
    set coordlist ""

    foreach {x y} "$coords" {
      lappend coordlist "$x $y"
    }
    if {$L=="" } {
      set L $coordlist
    } else {
      # $L is a list of points that represent the outline polygon
      # $coordlist is the coords of the new piece to be added to $L
      # (they are if the form {{x1 y1} {x2 y2}..} rather than {x1 y1 x2 y2..})
      # We must find the common end points and remove any extra common points.
      # For both $coordlist and $L there are two cases:
      # 1) common points are in the middle of the list
      # 2) common points span over the end of the array
      # for both $L and $coordlist, we eliminate case 2) by reordering the list

      # remove case 2) for $L
      set i 0
      set Lold $L
      set L1 [lindex $L 0]
      while {[lsearch -exact $coordlist $L1]!="-1"} {
        set L [concat [lrange $L 1 end] [list $L1]]
        set L1 [lindex $L 0]
	incr i 
        if {$i>30} {puts stderr "polypuzzle: while1 not terminated"; Die }
      }

      # now parse L for start and end points
      # Lstart is the start of the part to remove, Lend the end point
      set Llength [llength $L]
      set i 0 
      set L1 [lindex $L $i] 
      set Lstart $i 
      set Lpart1 [lrange $L 0 $Lstart]
      # walk through L till first match
      while {[lsearch -exact $coordlist $L1]=="-1"} {
        incr i
        set L1 [lindex $L $i]
        if {$i>50} { puts stderr "polypuzzle: while2 not terminated"; Die }
      }
      set Lstart $L1 
      set Lpart1 [lrange $L 0 $i]
      # Lpart1 includes the connecting point
      
      # walk through L till no match
      incr i
      set L1 [lindex $L $i]
      while {[lsearch -exact $coordlist $L1]!="-1" & $i<$Llength} {
        incr i
        set L1 [lindex $L $i]
      }
      incr i -1
      set Lend [lindex $L $i]
      set Lpart2 [lrange $L $i end]
      # Lpart2 includes the connecting point

      # remove coordlist case 2
      set i [llength $coordlist]
      set C1 [lindex $coordlist 0]
      while {[lsearch -exact $Lold $C1] != -1 & $i > 0 } {
        incr i -1
        set coordlist [concat [lrange $coordlist 1 end] [list $C1]]
        set C1 [lindex $coordlist 0]
      }

      # for a hexagon polyiamond, the last piece doesn't have any new points
      if {$i>0} {
        set Cpart1 \
        [lrange $coordlist [expr [lsearch -exact $coordlist $Lstart] +1] end]
        set Cpart2 \
        [lrange $coordlist 0 [expr [lsearch -exact $coordlist $Lend] -1]]
      } else {
        set Cpart1 {} ; set Cpart2 {}
      }

      set L [concat $Lpart1 $Cpart1 $Cpart2 $Lpart2]

      }		;# else
    }		;# foreach



  ### fiddle with the outline polygon of the round game
  ### to make the apexes pointy
  if {$gamemode == "round" || $gamemode == "krazy"} {
    set l [llength $L]
    set i [lindex $L end]
    set x0 [lindex $i 0]
    set y0 [lindex $i 1]
    set i [lindex $L 0]
    set x1 [lindex $i 0]
    set y1 [lindex $i 1]
    set xfirst $x1		;# remember the first coords
    set yfirst $y1

    set M {}
    for {set N 1} {$N <= $l} {incr N} {
      # examine point x1,y1 to see if it's an apex
      if {$N < $l} {
        set next [lindex $L $N]
	set x2 [lindex $next 0]
	set y2 [lindex $next 1]
      } else {
	set x2 $xfirst
	set y2 $yfirst
      }
      ### if |x2-x0|<2R & |y2-y0|<2R then duplicate the apex to stop smoothing
      if {[expr abs($x2 - $x0)/2]<=$R && [expr abs($y2 - $y0)/2]<=$R} {

	### extra point to drag the curvature in,
	set xm [expr ($x0+$x1)/2]; set ym [expr ($y0+$y1)/2] 
	lappend M "[expr int($xm+($x2-$xm)/6)] [expr int($ym+($y2-$ym)/6)]"

	### duplicating a point in tk:polygons stops smoothin
        lappend M $i
        lappend M $i
	
	### extra point to drag the curvature in,
	set xm [expr ($x2+$x1)/2]; set ym [expr ($y2+$y1)/2] 
	lappend M "[expr int($xm+($x0-$xm)/6)] [expr int($ym+($y0-$ym)/6)]"
      } else {
        ### extra mid points that are broken atm.
        # lappend M "[expr int($x0+$x1)/2] [expr int($y0+$y1)/2]"
        lappend M $i
        # lappend M "[expr int($x2+$x1)/2] [expr int($y2+$y1)/2]"
      }	
      set i $next
      set x0 $x1
      set y0 $y1
      set x1 $x2
      set y1 $y2
    }
    set L $M
    set smooth 1 ; set width 4
    ### could make the round outline 5 thick &&&
  } else {
    set smooth 0 ; set width 3
  }
# &&&

  # draw polygon defined by $L - rejoice!
  # ( the "pieceN" tag must come first )
  .c create polygon [join $L] -fill $c4 -outline $c3 -width $width \
    -smooth $smooth -tags "piece$n piece piecepoly$n piecepolycol$col outlines" -state disabled
  # may want to add -splinesteps 20 for round gamemode
}
##################
proc StartDrag {x y} {
    global lastX lastY current_piece flag
    set flag(drag_ok) 1
    set lastX [.c canvasx $x]
    set lastY [.c canvasy $y]
    set current_piece {}
    regexp {piece[0-9]+} [join [.c gettags [.c find withtag current]]] current_piece
    if {$flag(debug)} {
        puts "dragging piece $current_piece x,y $x,$y"
    }
    .c lower $current_piece text
}
##################
proc Drag {x y} {
    global lastX lastY current_piece flag
    if {!$flag(drag_ok)} {return}
    set x [.c canvasx $x]
    set y [.c canvasy $y]

    .c move $current_piece [expr $x-$lastX] [expr $y-$lastY]
    set lastX $x
    set lastY $y
    set flag(report_finished) 1
}
##################
proc Snap {xpos ypos} {
    global current_piece cells flag width height

    if {!$flag(drag_ok)} {return}

    # check piece is not off screen
    if {$xpos<0 || $xpos>$width || $ypos<0 || $ypos>$height} {
	Unlose $xpos $ypos
	return
    }

    ### Hmmm... these disables interfere with the key bindings
    # # momentarily disable canvas to help stop crazy mouse events from breaking
    # .c configure -state disabled

    # without the following +/-1, sometimes all we get is the polygon (bad).
    set hexes [.c find overlapping \
    [expr $xpos-1] [expr $ypos-1] [expr $xpos+1] [expr $ypos+1]]

    # find "from" - the segment of the piece we are moving
    for { set i 0 } { 1 } { incr i } {
        set from [lindex $hexes $i] 
	if {$from<=$cells} {continue}
	# if this hex is a member of the current piece, we've found it
	if {[string match "${current_piece}*" [.c gettags $from]]} {break}
    }

    # find "to" - the hex of the grid under (the middle of) "from"
    set fromcoords [.c coords $from]
    set midcoords [GetMidCoords $fromcoords]
    set x [lindex $midcoords 0]
    set y [lindex $midcoords 1]
    set to [lindex [.c find overlapping $x $y $x $y] 0 ]

    if {$to <= $cells} {
	set tocoords [.c coords $to]
    } else {
	# not on grid, but keep going and determine if ongrid at all
	# tocoords should not be referenced again, but to be safe:
	set tocoords {}
    }

    # now we'll only snap if every piece_hex is going to a vacant grid hex
    # (excepting the last piece_hex which is the polygon)
    set piece_hexes [.c find withtag $current_piece]
    set snap 1
    set ongrid_any 0
    foreach hex [lreplace $piece_hexes end end] {
	set coords [.c coords $hex]
  	set midcoords [GetMidCoords $coords]
	set x [lindex $midcoords 0]
	set y [lindex $midcoords 1]
	set hexes [.c find overlapping $x $y $x $y]

	# hexes are the canvas items overlapping this "hex"
	# one overlapping item must be a piece of the grid,
	set ongrid_this 0
	foreach i $hexes {
	    if {$i<=$cells} {
		set ongrid_this 1
		set ongrid_any 1
	    } elseif {$current_piece != "[lindex [.c gettags $i] 0]"} {
	        # oops, this overlapping hex belongs to another piece
	        set snap 0
	        break
            }
	}
	if { ! $ongrid_this } {set snap 0}
    }

    if { $snap && $tocoords != "" } {
	# I used to snap according to the top left corner,
	# but must use midpints since triangle pieces alternate up&down
	 set tomidcoords [GetMidCoords $tocoords]
	set frommidcoords [GetMidCoords $fromcoords]
	set dx [expr [lindex $tomidcoords 0] - [lindex $frommidcoords 0]]
	set dy [expr [lindex $tomidcoords 1] - [lindex $frommidcoords 1]]
	.c move $current_piece $dx $dy
	UnBoldPieceOutline
	update idletasks
	if {$flag(check_finished) && $flag(report_finished)} CheckTrayFull
    } else {
        if {$ongrid_any} {BoldPieceOutline} else {UnBoldPieceOutline}
    }
    # .c configure -state normal
}

################## put wayward piece back on canvas
proc Unlose {xpos ypos} {
    global current_piece width height
    set dx 0
    set dy 0
    set tab 40	;# indentation from canvas edge
    if { $xpos < 0 } {set dx [expr $tab - $xpos]}
    if { $ypos < 0 } {set dy [expr $tab - $ypos]}
    if { $xpos > $width } {set dx [expr $width - $tab - $xpos]}
    if { $ypos > $height } {set dy [expr $height - $tab - $ypos]}
    .c move $current_piece $dx $dy
}
##################
proc BoldPieceOutline {} {
    global current_piece flag gamemode

    regexp {[0-9]+} $current_piece n
    set tags [.c gettags piecepoly$n]
    if {[lsearch $tags outlinebold]==-1} {
      lappend tags outlinebold
      .c itemconfig piecepoly$n -tag $tags
    }

    if {$flag(bold_outline)} {
      if {$gamemode  == "round" || $gamemode == "krazy"} {
        set width 6 
      } else {
        set width 5
      }
      .c itemconfig piecepoly$n -width $width
    }
}

proc UnBoldPieceOutline {} {
    global current_piece flag gamemode

    if { ! [regexp {[0-9]+} $current_piece n] } { return }

    set tags [.c gettags piecepoly$n]
    set i [lsearch  $tags outlinebold]
    if {$i != -1} {
      set tags [lreplace $tags $i $i] 
      if {$gamemode  == "round" || $gamemode == "krazy"} {
        set width 4 
      } else {
        set width 3
      }
      .c itemconfig piecepoly$n -width $width -tag $tags
    }
}

proc ToggleBold {} {
    global gamemode flag
    if {$gamemode  == "round" || $gamemode == "krazy"} {
      set width [expr 4 + $flag(bold_outline)*2]
    } else {
      set width [expr 3 + $flag(bold_outline)*2]
    }
    .c itemconfig outlinebold -width $width
}

proc TogglePieceRidges {} {
    global gamemode colour flag

    if {$gamemode  == "round" || $gamemode == "krazy"} return

    # The '7' below is actually the max number of coloured pieces,
    # and the fancy expr also is about when we have lots of colours.
    # for {set i 1} {$i <= $colour(currentN)} {incr i}
    for {set i 1} {$i <= 7} {incr i} {
      if {$flag(piece_ridges)} {set outline $colour([expr ($i-1)%$colour(currentN)+1]-2)} else {set outline {}}
      .c itemconfig piececol$i -outline $outline
    }
    update
}

proc ToggleTrayRidges {} {
    global gamemode colour flag
    if {$gamemode  == "round" || $gamemode == "krazy"} return
    if {$flag(tray_ridges)} {set outline  $colour(grid)} else {set outline {}}
    .c itemconfig tray -outline $outline
}

##################
proc PieceRotate-	{xpos ypos} { PieceRotate $xpos $ypos 120 }
proc PieceRotate+	{xpos ypos} { PieceRotate $xpos $ypos -120 }
proc PieceRotate        {xpos ypos delta} { 
    if {$delta < 0} {
        PieceAction $xpos $ypos rotate
    } else {
        PieceAction $xpos $ypos rotate-
    }
}
proc PieceFlip		{xpos ypos} { PieceAction $xpos $ypos flip }
##################
proc PieceAction	{xpos ypos action} {
    global p colour current_piece flag gamemode gametype

    set current_piece ""
    set clist [.c coords current]

    if {[llength $clist] < 2} return
    # key pressed but no piece 'focused'

    set midcoords [GetMidCoords $clist]
    set xpos [lindex $midcoords 0]
    set ypos [lindex $midcoords 1]
    set newcoordlist ""

    regexp {piece[0-9]+} \
      [join [.c gettags [.c find withtag current]]] current_piece
    if {$current_piece == ""} return

    ### Hmmm... these disables interfere with the key bindings
    # # momentarily disable canvas to help stop crazy mouse events from breaking
    # .c configure -state disabled

    regexp {[0-9]*$} $current_piece n

    .c delete $current_piece	;# do we need to recursively delete subpieces

    ### transform each co-ordinate pair (this took some brain scratching ;->.)
    # since tk's y-cord points down, the rotate60/-60 gets a bit mixed up
    set coords $p(coords,$n)
    if {$gametype == "hexagon"} {
      foreach {x y} $coords {
	switch $action {
	  flip {
	    set x [expr -$x-$y]		;# flip horizontally
	  }
	  rotate {
	    set x1 [expr -$y]		;# rotate by 60 deg
	    set y [expr $y + $x]
	    set x $x1
	  }
	  rotate- {
	    set x1 [expr $x + $y]	;# rotate by -60 deg
	    set y [expr -$x]
	    set x $x1
	  }
	}
	append newcoordlist "$x $y "
      }
    } elseif {$gametype == "square"} {
      foreach {x y} $coords {
	switch $action {
	  flip {
	    set x [expr -$x]
	  }
	  rotate {
	    set x1 [expr -$y]
	    set y $x
	    set x $x1
	  }
	  rotate- {
	    set x1 $y
	    set y [expr -$x]
	    set x $x1
	  }
	}
	append newcoordlist "$x $y "
      }
    } else {
      ### hallelujah ! big fight to rotate the triangular pieces
      # if not first z=0 and doing a rotate, move to 1,0)
      # to make the old rotate algorithm happy
      if {[lindex $coords 2]!="0" & ($action=="rotate"|$action=="rotate-")} {
	foreach {x y z} $coords { append newcoordlist "[expr $x+1] $y $z " }
	set coords [string trimright $newcoordlist]
      }
      set newcoordlist {}

      foreach {x y z} $coords {
	switch $action {
	  flip {
	    # holy cow flip is easy here
	    set x [expr -$x]
	  }
	  rotate {
	  ### translate new coords to old coord system, rotate, then move back
	  #- my theoretical y-axis is +-up, while tk makes it +-down
	  #- the z setting of the piece doesn't have to match that of the tray
	  #
	  #new:                   old:
	  #     ______________	      ______________
	  #    /\211 /\411 /\ 	     /\011 /\111 /\
	  #   /  \  /  \  /  \	    /  \  /  \  /  \
	  #  /110 \/310 \/510 	   /010 \/110 \/210
	  # ------------------	  ------------------
	  #  \101 /\301 /\501 	   \001 /\101 /\201 /
	  #   \  /  \  /  \  /	    \  /  \  /  \  /
	  # 000\/200 \/400 \/ 	  000\/100 \/200 \/
	  # ------------------	  ------------------

	  set x1 [expr int(($x-$y)/2)]
	  set z1 [expr ($x+$y)%2]
	  set y1 $y

	  set x2 [expr -$y1]
	  set y2 [expr $x1+$y1+$z1]
	  set z2 [expr !$z1]

	  set x [expr $x2*2+$z2+$y2]
	  set y $y2
	  set z [expr !$z]
	  }
	  rotate- {
	  set x1 [expr int(($x-$y)/2)]
	  set z1 [expr ($x+$y)%2]
	  set y1 $y

	  set x2 [expr $x1+$y1+$z1]
	  set y2 [expr -$x1]
	  set z2 [expr !$z1]

	  set x [expr $x2*2+$z2+$y2]
	  set y $y2
	  set z [expr !$z]
	  }
	}
	append newcoordlist "$x $y $z "
      }
      # if the first coord is not the origin, translate back to 0,0
      set coords $newcoordlist
      set dx [lindex $coords 0]
      set dy [lindex $coords 1]
      if {$dx != "0" | $dy != "0"} {
	set newcoordlist {}
	foreach {x y z} $coords {
	  append newcoordlist "[expr $x-$dx] [expr $y-$dy] $z "
	}
      }
    }
    set p(coords,$n) [string trimright $newcoordlist]

    DrawPiece $n $xpos $ypos
    update
    # .c configure -state normal

    .c lower piece$n text	;# place (almost) on top
    set flag(report_finished) 1
    Snap $xpos $ypos
}
##################
proc CheckTrayFull {} {
    global cells p flag

    # run throught the cells of the grid
    # problem is solved if all have an overlapping piece
    # (this algorithm is simple but slow,
    #  it is possible to rewrite this algorithm using Snap and an array)

    for {set i 1} {$i<$cells} {incr i 2} {
      set clist [.c coords $i]
      set midcoords [GetMidCoords $clist]
      set x [lindex $midcoords 0]
      set y [lindex $midcoords 1]
      if {[llength [.c find overlapping $x $y $x $y]] < 2} {return}
    }
    for {set i 2} {$i<$cells} {incr i 2} {
      set clist [.c coords $i]
      set midcoords [GetMidCoords $clist]
      set x [lindex $midcoords 0]
      set y [lindex $midcoords 1]
      if {[llength [.c find overlapping $x $y $x $y]] < 2} {return}
    }

    # success !!
    # delay of 1000 milli-seconds may be too fast on a new pc.
    set numsteps 6
    set delay [expr int(1000 / ($p(count)^2) / $numsteps )]
    for {set i 1} {$i <= $p(count) } {incr i} {
      set clist [.c coords piece$i]
      set midcoords [GetMidCoords $clist]
      set x [lindex $midcoords 0]
      set y [lindex $midcoords 1]
      .c lower piece$i text
      for {set j 1} {$j<=$numsteps} {incr j} {
        .c scale piece$i $x $y 1.08 1.08
        update idletasks
        after $delay
      }
      for {set j 1} {$j<=$numsteps} {incr j} {
        .c scale piece$i $x $y .925925 .925925 ;# =1/1.08
        update idletasks
        after $delay
      }
    }

    set flag(report_finished) 0
}
##################
proc GetMidCoords c {
    global gamemode gametype
    
    if {$gametype == "hexagon" } {
      # center.x is x coord of second apex (top of hexagon)
      # center.y is avg of y(3) and y(4) (list elements 5 and 7)
      return	"[expr int([lindex $c 2])] \
		 [expr int(([lindex $c 5]+[lindex $c 7])/2)]"
    } elseif {$gametype == "square"} {
      return	"[expr int(([lindex $c 0]+[lindex $c 2])/2)] \
		 [expr int(([lindex $c 3]+[lindex $c 5])/2)]"
    } else {
      return	"[expr int([lindex $c 0])] \
      		 [expr int(([lindex $c 1]+[lindex $c 3])/2)]"
    }
}
##################
proc SetPieceColours {} {
    global colour

    set colour(currentN) [llength $colour(scheme,$colour(current))]

    for {set j 1} {$j <= $colour(currentN)} {incr j} {
        set Set [lindex $colour(scheme,$colour(current)) [expr $j - 1]]
        foreach i {1 2 3} {
          set colour($j-$i) [lindex $colour(set,$Set) [expr $i - 1]]
        }
    }
}
##################
proc SetColourN {n} {

    global p colour gamemode

    set col [expr ($p(colour,$n) - 1) % $colour(currentN) + 1]

# rgb: 52/92/ce - SteelBlue3
# rgb: 21/20/21 - gray12
# rgb: 9c/be/ce - LightBlue3
# rgb: 29/41/8c - RoyalBlue4
# rgb: 39/5d/ce - RoyalBlue3
# rgb: 7b/be/ef - SkyBlue2
# rgb: ad/aa/ad - gray67
    set c1 $colour($col-1)
    set c2 $colour($col-2)
    set c3 $colour($col-3)

    # Round pieces don't get filled (col1) or have a section outline (col2),
    #   but do have the polygon filled (col4)
    if {$gamemode == "round" || $gamemode == "krazy"} {
      set p(col1,$n) {} 
      set p(col2,$n) {}
      set p(col4,$n) $c1
    } else {
      set p(col1,$n) $c1
      set p(col2,$n) $c2
      set p(col4,$n) {}
    }
    set p(col3,$n) $c3

}

##################
proc RefreshPieceColours {} {
    global colour gamemode flag p

    for {set n 1} {$n <= $p(count)} { incr n } {

      SetColourN $n

      .c itemconfig piece$n -fill $p(col1,$n)
      if {$flag(piece_ridges)} {
	.c itemconfig piece$n -outline $p(col2,$n)
      }
      .c itemconfig piecepoly$n -outline $p(col3,$n) -fill $p(col4,$n)

    }
}
##################
proc ReInitText {} {
	.c delete text
	InitText
}

proc InitText {} {
	global width cells p deleted

	.c create text [expr $width - 100] 40 -justify right \
		-state disabled \
		-text	"Poly Puzzle\n\
			------------\n\
			Pieces: [expr $p(count) - [llength $deleted]]\n\
			Tray: $cells" -anchor w -tags text
}
##################

proc Quit {} {
    global gamemode flag colour savedir

    # save user's options
    if {![file isdirectory $savedir]} {file mkdir $savedir}
    if {[catch {set fid [open $savedir/options w]}] == 0} {
	foreach i {gamemode flag(bold_outline) flag(check_finished) flag(piece_ridges) flag(tray_ridges)} {
	    puts $fid "set $i [set $i]"
	}
	close $fid
    }
    bind . <Destroy> {}
    destroy .
}

proc Die {} {
    global savedir

    # oops - don't want to save options
    bind . <Destroy> {}
    file delete $savedir/options
    exit 1
}

##################
proc InitBindings {} {
	bind . <KeyPress-q> {Quit}
	bind . <Destroy> {if {"%W" == "."} Quit}
	.c bind piece <Double-ButtonPress-1>		"ResetPiece %x %y"
	.c bind piece <Shift-Double-ButtonPress-1>	"DuplicatePiece %x %y"
	.c bind piece <Control-Double-ButtonPress-1>	"DeletePiece %x %y"
	.c bind piece <Button-1>		"StartDrag %x %y"
	.c bind piece <B1-Motion>		"Drag %x %y"
	.c bind piece <ButtonRelease-1>		"Snap %x %y"
	.c bind piece <Button-3>		"PieceFlip %x %y"
	.c bind piece <Button-2>		"PieceRotate+ %x %y"
	.c bind piece <Button-4>		"PieceRotate- %x %y"
	.c bind piece <Button-5>		"PieceRotate+ %x %y"
	bind all <KeyPress-Right>		"PieceRotate+ %x %y"
	bind all <KeyPress-Left>		"PieceRotate- %x %y"
	bind all <KeyPress-Up>			"PieceFlip %x %y"
	bind all <KeyPress-space>		"PieceFlip %x %y"

	# windows only mouse wheel event
        bind all <MouseWheel>                   "PieceRotate %x %y %D"

	### We could also possibly use %W instead of %x,%y
	### Not sure why I don't always use ".c bind piece" , but -
	# I can't seem to bind the keyboard against the canvas or pieces alone
}
##################
proc NewCanvas {} {
	InitCanvas
	InitPieces
	InitText
	InitBindings
}
###### MAIN #######
source menus
NewCanvas
###################
