#!/usr/bin/wish

if {[file isdirectory /usr/share/hexpuzzle]} {cd  /usr/share/hexpuzzle}

source pieces.colours
set colour(bg)  azure3;		# background fill
set colour(hex) grey75;		# hexagon fill
set colour(tray) grey55;	# grid outline

set flag(check_finished) 1;	# check for finished and show 'reward'
set flag(report_finished) 0;	# stops checking between double-clicks & loads
set flag(black_outline) 1;	# black outline of overlapping pieces on grid
set flag(drag_ok) 0;		# stops a piece being dragged after being reset

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

wm resizable	. 0 0
wm title	. {hexpuzzle 22 (1.1)}

set savedir "~/.hexpuzzle"
if [file readable $savedir/options] {
    if { [catch {source $savedir/options}] != 0 } {
	puts stderr {hexpuzzle: error in "$savedir/options".}
    }
}

# if gamemode not set by $savedir/options, then use:
if {![info exists gamemode]} { set gamemode bonus }

if {[lindex $argv 0]!=""} { puts "Hexpuzzle: all args ignored." }

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

proc InitCanvas {} {
  global R r W w height width p cells gamemode colour

  set p(count) 0
  set cells 0		; # number of hexagons in grid

  # regular tray sizes are: (11,10),(8,6),(5,4)
  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 ; \
	    wm geometry . +15+15 }
    bonus  { set width 748 ; set height 532 ; wm geometry . +15+15 }
    default {puts "hexpuzzle: wrong gamemode" ; exit 1}
  }
  
  canvas .c -background $colour(bg) -height $height -width $width

  if {$gamemode != "bonus"} {
    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]
      }
    }
  } else {
    # bonus is a triangular tray
    set oldx 3
    set dx 5
    set y 0
    # 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} else {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
    }
  }
  .c config -cursor plus
  pack .c
}
################### draw a hex 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(tray) -width 3 -fill $colour(hex) ] $x $y
}
#############
proc InitPieces {} {
  global gamemode

  #	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 off-tray X value
  #	int	p(y,1..22)	; tile's off-tray Y value

  SetPieceColours
  switch $gamemode {
    small  { source pieces.small  }
    medium { source pieces.medium }
    large  { source pieces.large }
    bonus  { source pieces.bonus }
    default { puts "errorInitPieces: wrong gamemode" ; exit 1 }
  }
}
################### restore piece to it's original off-board 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]

  .c move $current_piece [expr $p(x,$n) - [lindex $coords 2]] \
	 [expr $p(y,$n) - ([lindex $coords 5]+[lindex $coords 7])/2]

  BlackPieceOutline 0
  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

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

# the tags are  "piece": all puzzle pieces
#               "pieceX": piece number X
#               "piececolN" : all piece hexagons colour N
#		"piecepolyX": piece polygon number X (CURRENTLY NOT USED)
#               "piecepolycolN" : complex outlines colour N

##################
proc DrawPiece {n xpos ypos} {
  global R r W w p colour

  set col $p(colour,$n)
  set c1 $colour($col-1)
  set c2 $colour($col-2)
  set c3 $colour($col-3)

  ### assemble piece at origin then move to xpos,ypos

  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 $c2 -width 1 \
      -tags "piece$n piece piececol$col" ] \
    [expr $x * $W + $y * $w] [expr $y * $R * 1.5]
  }

  # Place this piece on top (but underneath text, which is our ceiling)
  #   in windows tcl 8.2 this generates an error on initiation
  #   as text is not defined - ooh noo (but is ok in tcl832)
  .c lower piece$n text

  .c move piece$n $xpos $ypos

  # Make a list of points that define the outline. good luck!!!
  # This algorithm is in two parts.
  # The first part removes a single link and joins the two lists.
  # Unfortunately, some redundancies are longer than one link (duh!) so 
  # I wrote the second part to scan the list and remove dead-ends of the polygon
  # The second part makes some of the first redundant.

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

    foreach {x y} "$coords" {
      lappend coordlist "$x $y"
    }
    if {$L=="" } {
      foreach {x y} "$coords" {lappend L "$x $y"}
    } else {
      # find where we insert the new segment
      foreach  {x y} "$coords" {
        set where_L [lsearch -exact $L "$x $y"]
        if {$where_L != -1} {
          # we have a match: $x $y
          # join the lists $L and $coords !!!!

          # first rearrange $coords so as the two common points are out
          # and the back half (after the matches) comes first
          set where_co [lsearch -exact $coordlist "$x $y"]

          # if where_co==0 and the last coords also match we have 
          #    put the last first before we proceed
          if {$where_co==0 && [lsearch -exact $L [lindex $coordlist end]]!= -1} {
            incr where_L ; # this is needed !! took me ages to find this
            set len [llength $coordlist]; incr len -1
            set coordlist [concat \
                           [lrange $coordlist $len $len] \
                           [lrange $coordlist 0 [expr $len - 1]] \
                          ]
          }
          set coordlistnew [ concat \
                            [lrange $coordlist [expr $where_co + 2] end] \
                            [lrange $coordlist 0 [expr $where_co - 1]] \
                           ]

          # Insert coordlistnew into L
          # if where_L = 0 then we may have to insert before it,
          # otherwise, after it and before the other match 
          if {$where_L==0 && [lsearch -exact $coordlist [lindex $L 1]] == -1} {
	    set L [concat $coordlistnew $L ]
          } else {
            set L [concat \
                    [lrange $L 0 [expr $where_L-1]] \
                    $coordlistnew \
                    [lrange $L [expr $where_L+0] end] \
                  ]
          }

          ##########################
          # Remove redundant links #
          ##########################

          # do a few passes until all "dead-ends" removed
          set loop 2
          while {$loop>0} {
            set changed 0
            set l [llength $L]
            set lminus [expr $l - 1]
            for {set i 0} {$i<$lminus} {incr i} {
              if {[string compare [lindex $L $i] [lindex $L [expr $i+2]]]==0} {
                # shouldn't be redundant points, remove two of these three
                set L [concat [lrange $L 0 $i] [lrange $L [expr $i+3] end]]
                incr l -2
                incr lminus -2
                set changed 1
              }
            }
            if {$changed==0} {
              incr loop -1
	      if {$loop==1} {
		 # turn the list inside-out and try again
		 # to remove "loops" at the end of the list
		 set m [expr int($l/2)]
		 set L [concat  [lrange $L [expr $m+1] end] [lrange $L 0 $m]]
	      }
            }
          };	# while
          break;# we only need one pair of coords at which to join
        }
      };	# foreach
    };		# else
  }
 
  # draw polygon defined by $L - rejoice!
  # ( the "pieceN" tag must come first )
  eval .c create polygon [join $L] -fill {{}} -outline $c3 -width 3 \
    -tags \"piece$n piece piecepoly$n piecepolycol$col\" -state disabled
}
##################
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
    .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

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

    # 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 x [lindex $fromcoords 2]
    set y [expr int(([lindex $fromcoords 5]+[lindex $fromcoords 7])/2)]
    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 x [lindex $coords 2]
	set y [expr int(([lindex $coords 5]+[lindex $coords 7])/2)]
	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 } {
	set dx [expr [lindex $tocoords 0] - [lindex $fromcoords 0]]
	set dy [expr [lindex $tocoords 1] - [lindex $fromcoords 1]]
	.c move $current_piece $dx $dy
	BlackPieceOutline 0
	update idletasks
	if {$flag(check_finished) && $flag(report_finished)} CheckTrayFull
    } else {
        BlackPieceOutline $ongrid_any
    }
}

##################

proc BlackPieceOutline maybe {
    global current_piece flag

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

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

    if { $maybe } {
	set w 5
    } else {
	set w 3
    }
    .c itemconfig piecepoly$n -width $w
}

##################

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 x [lindex $clist 2]
      set y [expr int(([lindex $clist 5]+[lindex $clist 7])/2)]
      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 x [lindex $clist 2]
      set y [expr int(([lindex $clist 5]+[lindex $clist 7])/2)]
      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) / $numsteps)]
    for {set i 1} {$i <= $p(count) } {incr i} {
      set clist [.c coords piece$i]
      set x [lindex $clist 2]
      set y [expr int(([lindex $clist 5]+[lindex $clist 7])/2)]
      .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 PieceRotate-	{xpos ypos} { PieceAction $xpos $ypos rotate- }
proc PieceRotate	{xpos ypos} { PieceAction $xpos $ypos rotate }
proc PieceFlip		{xpos ypos} { PieceAction $xpos $ypos flip }
##################
proc PieceAction	{xpos ypos action} {
    global p colour current_piece flag

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

    if {[llength $clist] < 2} return
    # key pressed but no piece 'focused'
    # in this case clist=="]". the "join [.c coords current]" seems to return a
    # surfluous ']' at the end of the list!!

    # 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)
    set xpos [lindex $clist 2]
    set ypos [expr int(([lindex $clist 5]+[lindex $clist 7])/2)]

    regexp {piece[0-9]+} \
      [join [.c gettags [.c find withtag current]]] current_piece
    if {$current_piece == ""} return
    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 ;->.)
    set newcoordlist ""
    foreach {x y} $p(coords,$n) {
      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
	}
      };  # my first switch in tcl - slightly wierd syntax
      append newcoordlist "$x $y "
    }
    set p(coords,$n) [string trimright $newcoordlist]
    DrawPiece $n $xpos $ypos

    .c lower piece$n text;		# place (almost) on top
    set flag(report_finished) 1
    Snap $xpos $ypos
}
##################
proc SetPieceColours {} {
    global colour
    foreach i {1 2 3} {
      foreach j {1 2} {
        set colour($j-$i) $colour($colour(current)-$j-$i)
      }
    }
}
##################
proc RefreshPieceColours {} {
    global colour
    # redraw the pieces
    foreach i {1 2} {
    .c itemconfig piececol$i -outline $colour($i-2) -fill $colour($i-1)
    .c itemconfig piecepolycol$i -outline $colour($i-3)
    }
}
##################
proc InitText {} {
	global width cells p

	.c create text [expr $width - 100] 40 -justify right \
		-state disabled \
		-text	"Hex Puzzle 22\n\
			--------------\n\
			Pieces: $p(count)\n\
			Cells: $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 {colour(current) gamemode \
		   flag(black_outline) flag(check_finished)} {
	    puts $fid "set $i [set $i]"
	}
	close $fid
    }
destroy . 
}
##################
proc InitBindings {} {
	bind all <KeyPress-q> {Quit}
	.c bind piece <Double-ButtonPress-1>	"ResetPiece %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-2>		"PieceFlip %x %y"
	.c bind piece <Button-3>		"PieceRotate %x %y"
	bind all <KeyPress-Right>		"PieceRotate %x %y"
	bind all <KeyPress-Left>		"PieceRotate- %x %y"
	bind all <KeyPress-Up>			"PieceFlip %x %y"
	# I can't seem to bind the keyboard against the canvas or pieces alone
}
##################
proc NewCanvas {} {
	InitCanvas
	InitPieces
	InitText
	InitBindings
}
###### MAIN #######
source menus
NewCanvas
###################
