package require Tk
proc getBestFitFontSize {win fontFamilyName words} {
    # Get the size of the screen.  Allow some room on the sides to ensure 
    # the word doesn't wrap
    set maxWidth [expr [winfo screenwidth $win] - 15]
    
    # Initial size guess based on the number of letters in the given words.  
    # The -1 is to make sure the initial guess is too big
    set avgLetters [expr [string length [join $words {}]] / [llength $words] - 1]
    if {$avgLetters == 0} {incr avgLetters}
    set sizeGuess [expr $maxWidth / $avgLetters]
    set font [list $fontFamilyName $sizeGuess]
    set sizes {}
    
    # Find the word that takes the most space and find how much space it take
    foreach word $words {
        lappend sizes [font measure $font $word]
    }
    set maxSize [lindex [lsort -integer -decreasing $sizes] 0]
    set maxIdx [lsearch $sizes $maxSize]
    set biggestWord [lindex $words $maxIdx]
    
    # Shrink the size until the width of the biggest word fits
    while {$maxSize > $maxWidth} {
        incr sizeGuess -10  ;# Binary search would be more efficient.  Not interested in making the effort
        set font [list $fontFamilyName $sizeGuess]
        set maxSize [font measure $font $biggestWord]
    }
    
    # If all the words are short (3 letters or so), then the result will tend 
    # to be a bit too large height-wise.  Adjust if needed.
    set height [expr [font metrics $font -ascent] + [font metrics $font -descent]]
    set maxHeight [expr [winfo screenheight .] - 100] ;# 100 was chosen without any investigation if it is reasonable
    while {$height > $maxHeight} {
        incr sizeGuess -10
        set font [list $fontFamilyName $sizeGuess]
        set height  [expr [font metrics $font -ascent] + [font metrics $font -descent]]
    }
    return $sizeGuess
    }
proc ::showNextWord {wordList} {
    # Replace the text in the text widget with the next word on the list
    .words.t delete 1.0 end
    .words.t insert 1.0 [lindex $wordList 0] centered
    
    # Remove that word from the list.  Rewrite the button callback so it 
    # contains the updated word list.  Give a hint of the next word in the 
    # button text
    set newWordList [lrange $wordList 1 end]
    if {[llength $newWordList] > 0} {
        .words.next configure -text "Next: [lindex $newWordList 0]" -command [list showNextWord $newWordList]
    } else {
        .words.next configure -text Close -command {destroy .words}
    }
}
proc showWordSlideShow {wordList} {
    toplevel .words
    focus -force .words
    
    # Maximize the window.  From https://wiki.tcl-lang.org/2233
    wm overrideredirect .words 1; wm geometry .words [join [wm maxsize .] x]+0+0
    
    # Pick the font and size and create widgets
    set font {Times New Roman}
    set fontSize [getBestFitFontSize .words $font $wordList]
    pack [::text .words.t -font [list $font $fontSize] -foreground red -height 1]
    pack [button .words.next]
    
    # Convenient, mouse-free operation
    bind .words <Return> {.words.next invoke}
    
    .words.t tag configure centered -justify center
    
    # Start the slideshow
    showNextWord $wordList
}

# Some test code
wm withdraw .
showWordSlideShow {applesauce banana car house pig}