#!/usr/bin/env tclsh

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public
# License along with this program.  If not, see
# <http://www.gnu.org/licenses/>.

set binpath [file dirname [file normalize [info script]]]
set libdir [file join $binpath lib]
set auto_path [linsert $::auto_path 0 $libdir]

package require getopt
package require uriencode
package require can2svg

set VERSION 0.5
set COPYRIGHT "Copyright (C) 2021-2026 Claude Rubinson"
set NAME Fiss
set DESCR "Fiss Chart Generator"
set DETAIL "Produce publication-quality Fiss configuration charts."

# defaults
set myfont Times
set myfontsize 10
set myheader Recipes
set output_eps 0

source [file join $binpath libfiss.tcl]

# commandline processing
getopt arg $argv {
    -y: - --input:FILE {
	# when FILE is -, read standard input
	if {[string trim $arg] == {-}} {
	    set infile -
	} {
	    set infile $arg
	}
    }
    -h? - --help {
	# display this help and exit
	help
	exit 0
    }
    --version {
	# output version information and exit
	global VERSION
	global COPYRIGHT
	puts "fisschart $VERSION\n$COPYRIGHT"
	exit 0
    }
    --ephemeral-config {
	# config file is temporary and removed on exit (internal use)
	set ephemeral_config 1
    }
}

# need to delay loading of Tk to avoid commandline argument errors
package require Tk

# create canvas
tk::canvas .c -height 600 -width 400 -yscrollcommand {.sy set} -xscrollcommand {.sx set} -bg white

# scrollbars
scrollbar .sx -command ".c xview" -orient horizontal
scrollbar .sy -command ".c yview" -orient vertical

# main menu
option add *tearOff 0
menu .menubar
. configure -menu .menubar
set m .menubar

menu $m.export
$m add cascade -menu $m.export -label "Export as..."

$m.export add command -label "Postscript" -underline 0 -command {
    set f [tk_getSaveFile -initialfile fiss.eps]
    if {[string equal $f ""] == 0} {
	foreach {x0 y0 x1 y1} [.c bbox all] {}
	set w [expr $x1-$x0]
	set h [expr $y1-$y0]
	set ch [open $f w]
	puts $ch [.c postscript -x $x0 -y $y0 -width $w -height $h]
	close $ch
    }
}

# because I build the header up from the origin, I need to (a)
# manually specify the viewBox y coordinate and (b) recalculate the
# image height.  without (b) the image size shrinks.
$m.export add command -label "SVG" -underline 0 -command {
    set f [tk_getSaveFile -initialfile fiss.svg]
    if {[string equal $f ""] == 0} {
	lassign [.c cget -scrollregion] x y width height
	set y_ [expr {$y-10}] ;# some padding for aesthetics
	set height_ [expr {abs($y_)+$height}]
	can2svg::canvas2file .c $f -width $width -height $height_ -viewBox "0 $y_ $width $height_"
    }
}

$m.export add separator

$m.export add command -label "Close" -command {destroy .}

# grid the widgets
grid .c -sticky nwes -column 0 -row 0
grid columnconfigure . 0 -weight 1
grid rowconfigure . 0 -weight 1
grid .sx -column 0 -row 1 -sticky ew 
grid .sy -column 1 -row 0 -sticky ns

font create MyDefaultFont -family $myfont -size $myfontsize
font create MyHeadingFont -family $myfont -size $myfontsize -weight bold

proc about [] {
    global VERSION
    global COPYRIGHT
    global NAME
    global DESCR
    global DETAIL
    tk_messageBox -title "About $NAME" -message "$DESCR" -detail "$DETAIL\n\nVersion $VERSION\n$COPYRIGHT"
}

proc stubWidth {} {
    set rowHeaders "[stubConds] [stubSubheads] Consistency {Raw Coverage} {Unique Coverage}"
    return [expr {25 + [tcl::mathfunc::max {*}[lmap x $rowHeaders {font measure MyDefaultFont $x}]]}]
}

# Column width logic
#
# All recipe columns use the SAME width (w). This keeps the table layout
# simple and predictable. We compute w from the recipe labels:
#
#   1. Split recipe names by newlines and measure the pixel width of
#      each recipe name.  Only the longest line of each label matters.
#
#   2. Take the maximum of those widths across all recipes.
#
#   3. Also enforce a global minimum width so glyphs don’t look cramped.
#
# Final rule:
#       w = max(global_minimum, longest_recipe_label_width)
#
# Group labels do NOT influence the column width. Instead, group names
# are soft-wrapped inside the total span they cover:
#
#       available_width = span * w
#
# When a group label is too long, we'll automatically wrap
# it. Embedded \n in group names are also respected, giving the user
# explicit control over breaks.
#
# This approach avoids columns blowing out to huge widths because of long
# group names, and keeps the visual structure regular. The only things
# that grow are the *heights* of the header rows when wrapping is needed.
#
# (If we ever want user overrides or max/min bounds, those can be
# added later without changing the basic idea.)

# return actual width and height of supplied text in specified font;
# inspired by https://wiki.tcl-lang.org/page/font+measure
proc text_dimensions {text {font MyDefaultFont}} {
    label ._x -bd 0 -padx 0 -pady 0 -highlightthickness 0 -font $font -text $text
    set width [winfo reqwidth ._x]
    set height [winfo reqheight ._x]
    destroy ._x
    return "$width $height"
}

proc recipe_label_width {} {
    # minColWidth is specified by the user in the config file
    global minHeaderColWidth
    if {![info exists minHeaderColWidth]} {
	set minHeaderColWidth 0
    }

    set pad 25
    
    # globalMin is width of 3 digits, plus padding
    set globalMin [expr {$pad + [font measure MyDefaultFont 0.99]}]
    
    # recipeMax is width of maximum line w/in a recipe label, plus padding
    set l [lmap x [recipeNames] {lindex [text_dimensions $x] 0}]
    set recipeMax [expr {$pad + [::tcl::mathfunc::max {*}$l]}]

    return [::tcl::mathfunc::max $globalMin $recipeMax $minHeaderColWidth]
}

proc boxhead_widths {} {
    global fissDict
    set w [recipe_label_width]
    foreach headerRow [dict get $fissDict boxhead] {
	set x {}
	foreach {header span} $headerRow {
	    lappend x [list $header [expr {$w * $span}]]
	}
	lappend out $x
    }
    return $out
}

proc makeHeader {canvas stubWidth} {

    # boxhead label
    global myheader
    set boxHeadWidth [expr {[llength [recipeNames]] * [recipe_label_width]}]
    set boxHeadMidpoint [expr {($stubWidth + $boxHeadWidth/2.0)}]

    set defaultRowHeight 0
    set currRowHeight $defaultRowHeight

    # header rows can vary in height, and I compute the height along
    # the way.  Becuse of this, I don't know how much vertical space
    # the following row will need until after processing the row.
    # Therefore, I build up the header in reverse order, starting with
    # the recipes.  This is why the ypos parameters below (for both
    # the header labels and the recipes label are first multiplied by
    # -1.
    foreach headerRow [lreverse [boxhead_widths]] {
	set xpos $stubWidth
	incr ypos [::tcl::mathfunc::max $defaultRowHeight $currRowHeight]
	set currRowHeight $defaultRowHeight
	foreach {headerSpan} $headerRow {
	    set headerName [lindex $headerSpan 0]
	    set spanWidth [lindex $headerSpan 1]
	    set xpos [expr {$xpos + $spanWidth/2.0}]
	    set id [$canvas create text $xpos [expr {-1 * $ypos}] -text "$headerName" -font MyDefaultFont -width $spanWidth -anchor s -justify center -tags bhead]
	    set xpos [expr {$xpos + $spanWidth/2.0}]

	    # set row height, which should be either the default row
	    # height or the height of the tallest header
	    update
	    set b [$canvas bbox $id]
	    lassign $b x1 y1 x2 y2
	    set currRowHeight [::tcl::mathfunc::max $currRowHeight [expr {$y2 - $y1}]]
	}
    }
    set yposHeader [expr {-1 * $ypos - $currRowHeight - 15}]
    $canvas create text $boxHeadMidpoint $yposHeader -text $myheader -font MyDefaultFont -tags bhead

    # return boxheader bounding box (leading space due to stubWidth is
    # not included)
    return [.c bbox bhead]
}

set lineHeight 20
set vSpace 10
proc makeStub {canvas ypos} {
    global fissDict
    global lineHeight
    global vSpace
    set xpos 20
    foreach stubEntry [dict get $fissDict stub] {
	set rowHead [lindex $stubEntry 0]
	set type [lindex $stubEntry 1]
	incr ypos $lineHeight
	if {$type eq {subhead}} {
	    incr ypos $vSpace
	    $canvas create text $xpos $ypos -text $rowHead -anchor w -font MyHeadingFont -tags bstub
	}
	if {$type eq {cond}} {
	    $canvas create text $xpos $ypos -text $rowHead -anchor w -font MyDefaultFont -tags bstub
	}
    }
    incr ypos $vSpace
    foreach metricEntry {Consistency "Raw Coverage" "Unique Coverage"} {
	incr ypos $lineHeight
	$canvas create text $xpos $ypos -text $metricEntry -anchor w -font MyDefaultFont -tags bstub
    }

    return [.c bbox bstub]

}

proc makeSol {canvas xpos ypos} {
    global fissDict
    global lineHeight
    global vSpace

    if {[catch {dict get $fissDict solcon} solcon]} {
	set shortMsg "Missing or invalid solcon entry"
	set longMsg "The solution consistency metric must be specified as `solcon` followed by a value between 0.0 and 1.0.\n\nFor example: `solcon 0.85`"
	showFatalError Error $shortMsg $longMsg
    }

    if {[catch {dict get $fissDict solcov} solcov]} {
	set shortMsg "Missing or invalid solcov entry"
	set longMsg "The solution coverage metric must be specified as `solcov` followed by a value between 0.0 and 1.0.\n\nFor example: `solcov 0.65`"
	showFatalError Error $shortMsg $longMsg
    }
    
    set ypos [expr {$ypos + $vSpace + $vSpace}]
    if {[string is double -strict $solcon]} {
	set solcon [format %1.2f $solcon]
    }
    .c create text $xpos $ypos -text "Solution consistency: $solcon" -anchor w -font MyDefaultFont
    
    set ypos [expr {$ypos + $lineHeight}]
    if {[string is double -strict $solcov]} {
	set solcov [format %1.2f $solcov]
    }
    .c create text $xpos $ypos -text "Solution coverage: $solcov" -anchor w -font MyDefaultFont
}


#
# glyphs
#

# solid glyphs are sized slightly bigger than empty glyphs to
# accommodate the illustion of the larger emptiness.
#
# the magic is in setting the adjustment and offset values.  I first
# define a reference glyph size.  adjust scales the glyph according to
# the column data width (not column header width).  offset allows the
# glyphs to be set at the origin (rather than upper-left, which is the
# standard approach).  the necessity glyphs are a bit different,
# because we're just drawing diamonds.

# same formula as base_width_size, above.  refactor later.
set base_glyph_size [expr {20 + [font measure MyDefaultFont 0.99]}]
proc corepos {canvas x y} {
    global base_glyph_size
    set adjust [expr {$base_glyph_size * 0.24}]
    set offset [expr {$adjust / 2}]
    set x [expr $x - $offset]
    set y [expr $y - $offset]
    $canvas create oval $x $y [expr {$x + $adjust}] [expr {$y + $adjust}] -fill black
}

proc coreneg {canvas x y} {
    # global col_width
    global base_glyph_size
    set adjust [expr {$base_glyph_size * 0.21}]
    set offset [expr {$adjust / 2}]
    set x [expr $x - $offset]
    set y [expr $y - $offset]
    set x2 [expr {$x+$adjust}]
    set y2 [expr {$y+$adjust}]
    $canvas create oval $x $y [expr {$x + $adjust}] [expr {$y + $adjust}] -width 0.5
    $canvas create line $x [expr {($y+$y2)/2}] $x2 [expr {($y+$y2)/2}]
}

proc contribpos {canvas x y} {
    # global col_width
    global base_glyph_size
    set adjust [expr {$base_glyph_size * 0.14}]
    set offset [expr {$adjust / 2}]
    set x [expr $x - $offset]
    set y [expr $y - $offset]
    $canvas create oval $x $y [expr {$x + $adjust}] [expr {$y + $adjust}] -fill black
}

proc contribneg {canvas x y} {
    # global col_width
    global base_glyph_size
    set adjust [expr {$base_glyph_size * 0.14}]
    set offset [expr {$adjust / 2}]
    set x [expr $x - $offset]
    set y [expr $y - $offset]
    set x2 [expr {$x+$adjust}]
    set y2 [expr {$y+$adjust}]
    $canvas create oval $x $y [expr {$x + $adjust}] [expr {$y + $adjust}] -width 0.5
    $canvas create line $x [expr {($y+$y2)/2}] $x2 [expr {($y+$y2)/2}]
}

proc nec_ {obj canvas x y} {
    global base_glyph_size
    set adj 0.15
    if {$obj eq "line"} {
	set adj [expr {$adj - 0.02}]
    }
    set adjust [expr {$base_glyph_size * $adj}]
    set x1 $x
    set y1 [expr {$y-$adjust}]
    set x2 [expr {$x-$adjust}]
    set y2 $y
    set x3 $x
    set y3 [expr {$y+$adjust}]
    set x4 [expr {$x+$adjust}]
    set y4 $y
    $canvas create $obj $x1 $y1 $x2 $y2 $x3 $y3 $x4 $y4 $x1 $y1
}

proc necpos {canvas x y} {
    nec_ polygon $canvas $x $y
}

proc necneg {canvas x y} {
    nec_ line $canvas $x $y
}

proc necdeg {canvas x y} {
    global base_glyph_size
    set adj 0.14
    set adjust [expr {$base_glyph_size * $adj}]
    set x1 [expr {$x+$adjust}]
    set y1 [expr {$y+$adjust}]
    set x2 [expr {$x-$adjust}]
    set y2 [expr {$y+$adjust}]
    set x3 [expr {$x+$adjust}]
    set y3 [expr {$y-$adjust}]
    $canvas create polygon $x1 $y1 $x2 $y2 $x3 $y3
}

# no-op
proc irr {canvas x y} {}

# current version doesn't do any length check or word wrapping; we'll
# need to see if this is a problem or not.
proc textglyph {canvas s x y} {
    $canvas create text $x $y -text $s -anchor center -font MyDefaultFont
}

proc makeBody {canvas xpos ypos} {
    global fissDict
    global lineHeight
    global vSpace
    set w [recipe_label_width]
    set initial_ypos $ypos
    set stub [dict get $fissDict stub]
    foreach recipeName [boxheadRecipeNames] {
	set recipe [dict get $fissDict recipes $recipeName]
	set ypos $initial_ypos
	# conditions
	foreach stubEntry $stub {
	    # determine how much row spacing is needed
	    set rowHead [lindex $stubEntry 0]
	    set type [lindex $stubEntry 1]
	    set ypos [expr {$ypos + $lineHeight}]
	    if {$type eq "subhead"} {set ypos [expr {$ypos + $vSpace}]}

	    # what type of glyph? traditional, text or blank; text
	    # glyphs are indicated by prefixing with an equals sign sigil
	    catch {dict get [dict get $recipe conds] $rowHead} res opts
	    if {[dict get $opts -code] == 0} {
		# not sure why this additional y-adjustment is needed
		# here but glyphs are all too high.
		set yadj [expr {$ypos + 11}]
		set xadj [expr {$xpos + $w/2.0}]
		if {[string range $res 0 0] eq "="} {
		    # is a text glyph
		    textglyph $canvas [string range $res 1 end] $xadj $yadj
		} {
		    # is a traditional glyph; I need either a catch or
		    # a try here
		    try {
			[string tolower $res] $canvas $xadj $yadj
		    } on 1 {} {
			# I don't like manually setting the glyph
			# names here.  Can I extract them from the
			# code somewhere?
			set glyph_name_list [join "Corepos Coreneg Contribpos Contribneg Necpos Necneg Negdeg Irr" \n]
			set shortMsg "Bad glyph name"
			set longMsg "Valid glyph names are:\n\n$glyph_name_list"
			showFatalError Error $shortMsg $longMsg
		    }
		}
	    } {
		irr $canvas $xpos $ypos
	    }
	}
	# concov scores
	set xpos [expr {$xpos + $w/2.0}]
	set ypos [expr {$ypos + $vSpace + $vSpace}]
	foreach metric "con cov ucov" {
	    # set val [dict get $recipe metrics $metric]
	    catch {dict get $recipe metrics $metric} val ropt
	    if {$val eq "missing value to go with key"} {
		set shortMsg "Error in metrics stanza"
		set longMsg "The metrics stanza for recipe `$recipeName` has an incomplete entry for `$metric`.  Each metric must include both a name and a value."
		showFatalError Error $shortMsg $longMsg
	    }

	    # concov scores are also just a touch too high.  why?
	    set ypos [expr {$ypos + $lineHeight + 1}]

	    # recipe metrics (con, cov, ucov) are treated as display
            # values and not validated.  when the value is a number,
            # it's formatted to two decimals.  (anything more than
            # that is overly precise.)  if the user enters a hyphen,
            # print an endash (–) to signal that the metric is
            # intentionally omitted. anything else is assumed to be
            # deliberate text and is printed as-is.
	    if {[string is double -strict $val]} {
		$canvas create text $xpos $ypos -text [format %1.2f $val] -anchor center -font MyDefaultFont
	    } elseif {$val eq "-"} {
		$canvas create text $xpos $ypos -text "\u2013" -anchor center -font MyDefaultFont
	    } else {
		$canvas create text $xpos $ypos -text "$val" -anchor center -font MyDefaultFont
	    }
	}
	set xpos [expr {$xpos + $w/2.0}]
    }
}

proc makeVrules {canvas xpos y1 y2} {
    global fissDict

    set xpos [expr {$xpos + [recipe_label_width]}]
    foreach candidate [boxheadRecipeNames] {
	foreach style_match [dict get $fissDict vrules] {
	    set style [lindex $style_match 0]
	    set match [lindex $style_match 1]
	    if {$candidate eq $match} {
		switch -glob $style {
		    dash* {
			for {set y $y1} {$y < $y2} {incr y 10} {
			    $canvas create line $xpos $y $xpos [expr {$y+6}]
			}
		    }
		    dot* {
			for {set y $y1} {$y < $y2} {incr y 4} {
			    $canvas create line $xpos $y $xpos [expr {$y+2}]
			}
		    }
		    default {
			$canvas create line $xpos $y1 $xpos $y2
		    }
		    
		}
	    }
	}
	set xpos [expr {$xpos + [recipe_label_width]}]
    }
}

proc makeKey {canvas xpos ypos} {
    global fissDict
    global lineHeight

    set initial_xpos $xpos

    # find which glyphs are present in the chart
    set y [lmap x [dict get $fissDict recipes] {string tolower $x}]
    set nec [lsearch -regexp $y "necpos|necneg"]
    set core [lsearch -regexp $y "corepos|coreneg"]
    set contrib [lsearch -regexp $y "contribpos|contribneg"]
    set necdeg [lsearch -regexp $y "necdeg"]
    
    # only include if there's a necessary condition in the chart
    if {$nec >= 0} {
	necpos .c $xpos $ypos
	.c create text [incr xpos 15] $ypos -text "/" -font MyDefaultFont
	necneg .c [incr xpos 12] $ypos
	.c create text [incr xpos 30] $ypos -text "Presence/absence of condition is necessary" -anchor w -font MyDefaultFont
	set ypos [expr {$ypos + $lineHeight}]
    }

    # use different sufficiency keys, depending on if both core and
    # contributory conditions are present
    if {$core >= 0 && $contrib >= 0} {
	set xpos $initial_xpos
	corepos .c $xpos $ypos
	.c create text [incr xpos 15] $ypos -text "/" -font MyDefaultFont
	contribpos .c [incr xpos 12] $ypos
	.c create text [incr xpos 30] $ypos -text "Core/contributory condition is present" -anchor w -font MyDefaultFont

	set xpos $initial_xpos
	set ypos [expr {$ypos + $lineHeight}]
	coreneg .c $xpos $ypos
	.c create text [incr xpos 15] $ypos -text "/" -font MyDefaultFont
	contribneg .c [incr xpos 12] $ypos
	.c create text [incr xpos 30] $ypos -text "Core/contributory condition is absent" -anchor w -font MyDefaultFont
    } else {
	# if not distinguishing between core/contributory condiitons
	set xpos $initial_xpos
	corepos .c $xpos $ypos
	.c create text [incr xpos 15] $ypos -text "/" -font MyDefaultFont
	coreneg .c [incr xpos 12] $ypos
	.c create text [incr xpos 30] $ypos -text "Explanatory condition is present/absent" -anchor w -font MyDefaultFont
    }

    # include if necessity in degree present the chart
    if {$necdeg >= 0} {
	set xpos [expr {$initial_xpos + 17}]
	set ypos [expr {$ypos + $lineHeight}]
	necdeg .c $xpos $ypos
	.c create text [incr xpos 40] $ypos -text "Condition is necessary in degree" -anchor w -font MyDefaultFont
    }
}


if {[info exists infile]} {
    # create fissDict as global variable
    if {$infile eq "-"} {
	if {[catch {eval [read stdin]} res ropts]} {
	    set detail [dict get $ropts -errorinfo]
	    set errFile [file join [pwd] "ERROR-REPORT.txt"]
	    set f [open $errFile w]
	    puts $f $detail
	    close $f
	    tk_messageBox -icon error -title "Invalid Configuration File" -message "The configuration file appears to be invalid.\n\nPlease check the file for errors or regenerate it.\n\nA report was saved as: $errFile\n"  -detail "Technical details:\n\n$detail"
	}
    } {
	if {[catch {source $infile} res ropts]} {
	    set detail [dict get $ropts -errorinfo]
	    set errFile [file join [pwd] "ERROR-REPORT.txt"]
	    set f [open $errFile w]
	    puts $f $detail
	    close $f
	    tk_messageBox -icon error -title "Invalid Configuration File" -message "The configuration file appears to be invalid.\n\nPlease check the file for errors or regenerate it.\n\nA report was saved as: $errFile\n"  -detail "Technical details:\n\n$detail"
	}
	# temporary workaround to clean up temp session config files
	if {[info exists ephemeral_config] && $ephemeral_config} {file delete $infile}
    }
    
    # puts $fissDict

    # titlebar
    if {[dict exists $fissDict title]} {
	set t "- [dict get $fissDict title]"
    } {
	set t ""
    }
    if {$infile eq "-" || [info exists ephemeral_config]} {
	set f ""
    } {
	set f "- $infile"
    }
    wm title . "Fiss Chart $t $f"
    
    set myStubWidth [stubWidth]
    lassign [makeHeader .c $myStubWidth] header(x1) header(y1) header(x2) header(y2)
    lassign [makeStub .c $header(y2)] stub(x1) stub(y1) stub(x2) stub(y2)

    # make top rule
    set toprule_y [expr {$header(y2)+9}]
    set toprule_x1 [expr {$stub(x1)-5}]
    set toprule_x2 [expr {$header(x2)+10}]
    .c create line $toprule_x1 $toprule_y $toprule_x2 $toprule_y
    
    # slight horizontal and vertical adjustment to tweak alignment
    makeBody .c $stub(x2) [expr {$header(y2) - 12.0}]

    makeSol .c $stub(x1) $stub(y2)

    # make bottom rule
    set bottomrule_y [expr {$stub(y2)+4}]
    set bottomrule_x1 [expr {$stub(x1)-5}]
    set bottomrule_x2 [expr {$header(x2)+10}]
    .c create line $bottomrule_x1 $bottomrule_y $bottomrule_x2 $bottomrule_y

    # vrules stanza is optional
    if {[llength [dict keys $fissDict vrules]]} {
	makeVrules .c [expr {$stub(x2)+5}] [expr {$toprule_y + 5}] [expr {$bottomrule_y - 5}]
    }

    if {[string is true $showLegend]} {
	makeKey .c $stub(x1) [expr {$bottomrule_y + 70}]
    }

    update
}

# define scroll region, now that we know it
.c configure -scrollregion [.c bbox all]

