#!/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]
lappend ::auto_path $libdir

package require getopt
package require uriencode
package require can2svg

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

# defaults
set myfont Helvetica
set myfontsize 12
set myheader Recipes
set output_eps 0

source 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
	}
    }
    -f: - --font:FONT {
	# font family (default is Helvetica)
	set myfont $arg
    }
    -s: - --size:SIZE {
	# font size (default is 12)
	set myfontsize $arg
    }
    -h: - --header:HEADER {
	# column header (default is "Recipes")
	set myheader $arg
    }
    --bellcurve {
	# dump example config file
	puts [read [open $binpath/bellcurve.fiss r]]
	exit 0
    }
    --greckhamer {
	# dump example config file
	puts [read [open $binpath/greckhamer.fiss r]]
	exit 0
    }
    --template {
	# dump template config file
	puts [read [open $binpath/template.fiss r]]
	exit 0
    }
    -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
    }
    --del-tmp-cfg {
	# delete temp config file after load (temporary workaround)
	set del_tmp_cfg 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
    }
}

$m.export add command -label "SVG" -underline 0 -command {
    set f [tk_getSaveFile -initialfile fiss.svg]
    if {[string equal $f ""] == 0} {
	can2svg::canvas2file .c $f
	# 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
    }
}

$m.export add separator

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


# file menu
menu $m.file

$m.file add command -label "Open" -underline 0 -command {
    set f [tk_getOpenFile]
    if {[string equal $f ""] == 0} {
	set ch [open $f r]
	renderChart $ch $f
    }
}

 $m.file add command -label "Export as 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
    }
}

$m.file add command -label "Export as SVG" -underline 0 -command {
    set f [tk_getSaveFile -initialfile fiss.svg]
    if {[string equal $f ""] == 0} {
	can2svg::canvas2file .c $f
	# 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
    }
}

$m.file add separator
$m.file add command -label "Close" -underline 0 -command {destroy .}

# help menu
menu $m.help
$m.help add command -label "Docs" -command {}

# should probably create/find a reusable widget for the About dialog
$m.help add command -label "About" -command {about}

# 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
	} {
	    $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
    
    set solcon [dict get $fissDict solcon]
    set solcov [dict get $fissDict solcov]
    set ypos [expr {$ypos + $vSpace + $vSpace}]
    .c create text $xpos $ypos -text "Solution consistency: [format %1.2f $solcon]" -anchor w -font MyDefaultFont
    set ypos [expr {$ypos + $lineHeight}]
    .c create text $xpos $ypos -text "Solution coverage: [format %1.2f $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 {25 + [font measure MyDefaultFont 0.99]}]
proc corepos {canvas x y} {
    global base_glyph_size
    set adjust [expr {$base_glyph_size * 0.25}]
    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.16
    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
}

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

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?
	    catch {dict get [dict get $recipe conds] $rowHead} res opts
	    if {[dict get $opts -code] == 0} {
		# not sure why this y-adjustment are needed here but
		# glyphs are all too high.
		set yadj 11

		# the horizontal alignment is also often and glyphs
		# aren't necessarily centered under column headers.  I
		# think I know what's going on.  I need to redo this
		# loop to follow the same logic as the boxhead.
		[string tolower $res] $canvas [expr {$xpos + $w/2.0}] [expr {$ypos + $yadj}]
	    } {
		irr $canvas $xpos $ypos
	    }
	}
	# concov scores
	set ypos [expr {$ypos + $vSpace + $vSpace}]
	foreach {_ metric} [dict get $recipe metrics] {
	    # concov scores are also just a touch too high.  why?
	    set ypos [expr {$ypos + $lineHeight + 1}]
	    $canvas create text [expr {$xpos + $w/2.0}] $ypos -text [format %1.2f $metric] -anchor center -font MyDefaultFont
	}
	
	set xpos [expr {$xpos + [recipe_label_width]}]
    }
}

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

    # 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
    }
}


if {[info exists infile]} {
    # create fissDict as global variable
    if {$infile eq "-"} {
	if {[catch {eval [read stdin]} res]} {
	    puts stderr $res
	    tk_messageBox -icon warning -title "Error" -message "The configuration file appears to be invalid.\n\nPlease check the file for errors or regenerate it."
	}
    } {
	if {[catch {source $infile} res]} {
	    puts stderr $res
	    tk_messageBox -icon warning -title "Error" -message "The configuration file appears to be invalid.\n\nPlease check the file for errors or regenerate it."
	}
	# temporary workaround to clean up temp session config files
	if {[info exists del_tmp_cfg] && $del_tmp_cfg} {file delete $infile}
    }
    
    # puts $fissDict

    # titlebar
    if {[dict exists $fissDict title]} {
	set t "- [dict get $fissDict title]"
    } {
	set t ""
    }
    if {$infile eq "-" || [info exists del_tmp_cfg]} {
	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}]
    }
    
    makeKey .c $stub(x1) [expr {$bottomrule_y + 70}]

    update
}

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

