##+##########################################################################
#
# ChooseDir -- my version of tk_chooseDir
# by Keith Vetter, April 2010
#

package require Tk

namespace eval ChooseDir {
    variable S
    unset -nocomplain S
    set S(windows) [string equal $::tcl_platform(platform) "windows"]
    set S(undo) {}

    variable I
    unset -nocomplain I
}
##+##########################################################################
#
# ChooseDir::ChooseDir -- Main entry point
# ChooseDir ?-title x? ?-parent x? ?-initialdir x? \
#           ?-mustexist 1? ?-createfolder 1?
#
proc ChooseDir::ChooseDir {args} {
    variable S

    set w .__chooseDir_kpv
    set emsg [ChooseDir::_ParseArgs {*}$args]
    if {$emsg ne ""} {
        error $emsg
        return
    }
    destroy $w
    toplevel $w
    wm title $w $S(-title)
    if {$S(-parent) ne ""} {
        if {[winfo viewable [winfo toplevel $S(-parent)]] } {
            wm transient $w $S(-parent)
        }
    }

    ChooseDir::_DoDisplay $w
    set S(path) $S(-initialdir)
    ChooseDir::_Fill $w $S(-initialdir)
    set S(value) ""
    tkwait window $w
    return $S(value)
}
set ChooseDir::I(navUp) [image create photo -data {
    R0lGODlhEAAQAOYAANnZ2fyCfMSSbMSKbCyiLKSWXPSKfKymjOyKhKSCXCySLDS+NCyqLOzmtPzu
    tPTurPTilKyijIyKXCSCJDS6NKSSXKyejKSejBROFBxWHCR6JCyeLDS2NCyWLCymLNSCfPzyvPzy
    tPzurPzqpPzmlBxmHCyuLKzCVPTCXHxyZPTyrPzupPzijPzefCR2JDSyNOS6RMyaHKSahPTWbCSK
    JOSqNMSODGxiVJyWhPzmnPzWdHyiRCyaLCSOJHSOLOSmLLyKDFxSTJyShPzqnPzehIymRBxuHCSG
    JDyGJNSiNOSeJLSCFExCPJyOfPTqtEx2LBRSFBRWFFx6JOyqNOSiLNyWHKx+FDw2LJSKfPTqrPTS
    bPTGXPS+VOy2RNyaJNSSFJx2HCwmJJSGdPTepOzOdOS6TNyuNNyqLNSiJMSaJLyOJKyCHKx+HJRy
    HCQeFIyGdIR6bHRuZGReVFROREQ6NDQqJBwSDP///////////////////////////////////yH5
    BAEAAAAALAAAAAAQABAAAAfGgACCg4MBAoSIiAMEBYQGB5CQCAAJCgsMjYIHDQ4ODxAREhOWFAQV
    ghGpqRYXGBkaGxwdHh8AESC4ICEiIyQlJgwnKCkAFyCdKiskLC0uLwQwMcQyxw69zDM0HB41NjcA
    OCDJOcw6Ozw9Pj9AQQBCDiJDLEQ6RUZHSElKS0wATU5DSNB7AiWKlClUqli5AgBLFoE6tGzh0mXK
    Dy9fwIQBIGYMmTJmzqBJo2YNGytg2rgB8AZOHDlz6NRxY6emTTuJcurcOSgQADs=}]
set ChooseDir::I(folder) [image create photo -data {
    R0lGODlhEAAQAOYAANnZ2eTe3KymjOTe1NzSpPTyrPzupPzqnKyijPTupPzWdKSejKSahJyWhJyS
    fJSOfJSKdPTqpPzafPzWZPTmnLyujLSqjLSmjKyihKyehKSWfJyOfJSKfPTilNzGhPzehPzihPze
    fPzadPzWbNSqVKSajPTejPzijMS6jPzSXPzOVPzGTPS6RNyiLHRmVMTCtJyShOzWhOTGfPzSbPzS
    ZPzOXPS+RPS2POyuNIRqJOzSfMzCjPzKVPzCTPS6POyyNOyqLMyGFFxKJNS+fPSyNOSiJNSOFIRm
    JGxqXJSGdNSybMyOBMSOBLyKDLSCDKx+FJx2HJRyHLSunIyGdIyCZIR6ZHxuVGxiTGRWRFRKPEQ6
    LDQuJCwiHBwaFBQSDBwSDP//////////////////////////////////////////////////////
    /////////////////////////////////////////////////////////////////////////yH5
    BAEAAAAALAAAAAAQABAAAAetgACCg4SFhoeEAQKLiwOIAAIEBQUGBwiOhwgJlAcHCgsMDQ4PEIMI
    EZUHEhOsraWCCxSdFRUWFxgZDBoOGxwQDB0HHhcfIMYgHyEiIyQlDSYnFigirSkqKywtLi8wMTLE
    MxM0NSs2Nzg5GgAbOgI7IuM8PT4/QEFCLwAcQwIhNTzliAApYuQIEkFJEChZwpBJEydPoEQRIkXQ
    FCpVrFzBkkXLFi5dvHx5RLJkoUAAOw==}]
set ChooseDir::I(computer) [image create photo -data {
    R0lGODlhEAAQALMAANnZ2YSChPz+/AQCBMTCxAT+/ASChAQC/ASCBAT+BP//////////////////
    /////yH5BAEAAAAALAAAAAAQABAAAARHEMhJq7026M1DDUIoisMnDGg6ECUFroVQEAFrDvFs1O30
    ygTDzuY66QwH3q2jdBGeUGgPoFFZAz3QaIv1ERAJZpViLWPOkggAOw==}]
set ChooseDir::I(navBack) [image create photo -data {
    R0lGODlhEAAQAOYAANnZ2dzmzJzWlETCRMzivEzKRJTahKTejJTSbHzKTGS+LDSyFES2RITWdKzi
    nJzWdITOXHTGPGzCLFy+LCSeHKTahIzSZHzKRKTafPT69KzejCyWJMTitKTWnDy+NJTWdITOVHTG
    NPz+/LzmpDyWNKTGlES6RGTGROT23GTCLFy+JFS+JCyKJGzCNLTilKzelES6HBR+BDy6FBR+DESy
    RJzejDS2FCy2FBR2BFy6LLzmrCy2DByyDCR6JKTSnDSmFCSyDBSOBIyqhNzizEymRFS2JIzSbLzq
    tCS2DByyBAyuBBRqFNzaxMTSrCSOFES2HFTCPCy2HBSuBARmBMTOtDSONCSaDBSyBASSBBRmFNTe
    xIy2fDR+LAxqBAReBCRiJHyebP//////////////////////////////////////////////////
    /////////////////////////////////////////////////////////////////////////yH5
    BAEAAAAALAAAAAAQABAAAAfFgACCAQIDhoYCAYKLAAQDBQYHCAkKCwwEjI4NDg8QERKgExSYAAED
    DRUWFxgZGqASChscAB0eHyAhGCIiI68SJCUAJiefuiIonxIpKisswi0Sxrwu1C8rMDHCEgm73d4w
    MjMANKDGGS8vBwc1Njc44znluzow4DY7PD0APj/KKh+7HLQDwiOIEABDiBRhBsOIiCNIeCRRsoSJ
    oCZOntiDEoWHFCVTqDBqUsXKjYhXlGDJIpIRAC1buHSZ4uULGIsuc+oEEAgAOw==}]


##+##########################################################################
#
# ChooseDir::_ParseArgs -- Handles command line options
#
proc ChooseDir::_ParseArgs {args} {
    variable S

    set S(-title) "Browse For Folder"
    set S(-initialdir) [pwd]
    set S(-mustexist) 0
    set S(-parent) ""
    set S(-createfolder) 0

    foreach {arg opt} $args {
        if {$arg ni {-title -initialdir -mustexist -parent -createfolder}} {
            set emsg "bad option \"$arg\": must be -title, -initialdir, "
            append emsg "-mustexist, -parent or -createfolder"
            return $emsg
        }
        if {$opt eq ""} {
            return "value for \"$arg\" missing"
        }
        switch -exact -nocase -- $arg {
            "-title" { set S($arg) $opt }
            "-initialdir" {
                if {[file isdirectory $opt]} { set S($arg) $opt }}
            "-mustexist" {
                if {! [string is boolean -strict $opt]} {
                    return "expected boolean value bug got \"$opt\""
                }
                set S($arg) $opt
            }
            "-parent" {
                if {! [winfo exists $opt]} {
                    return "bad window path name \"$opt\""
                }
                set S($arg) $opt
            }
            "-createfolder" {
                if {! [string is boolean -strict $opt]} {
                    return "expected boolean value bug got \"$opt\""
                }
                set S($arg) $opt
            }
        }
    }
    return ""
}
##+##########################################################################
#
# ChooseDir::_DoDisplay -- Creates our display
#
proc ChooseDir::_DoDisplay {w} {
    variable S

    # set themes [::ttk::themes]
    # set current $::ttk::currentTheme
    # ::ttk::setTheme clam

    pack [::ttk::frame $w.top] -side top -fill both -expand 1

    ::ttk::frame $w.f1
    ::ttk::label $w.f1.lab -text "Directory:"
    ::ttk::menubutton $w.f1.menu -textvariable ChooseDir::S(path) \
        -direction below -menu $w.f1.menu.menu
    menu $w.f1.menu.menu -tearoff 0 \
        -postcommand [list ChooseDir::_MenuPost $w]
    set S(menu) $w.f1.menu.menu
    ::ttk::button $w.f1.back -image $ChooseDir::I(navBack) \
        -style Toolbutton -command [list ChooseDir::_Back $w]
    ::ttk::button $w.f1.up -image $ChooseDir::I(navUp) -style Toolbutton \
        -command [list ChooseDir::_Up $w]
    pack $w.f1.lab $w.f1.menu $w.f1.back $w.f1.up -side left -padx 4 -fill both
    pack config $w.f1.menu -expand 1
    pack $w.f1 -side top -in $w.top -fill x -pady 4

    ################################################################
    ::ttk::frame $w.f2
    ::ttk::label $w.f2.lab -text "Folder name:" -underline 0 -anchor e
    ::ttk::entry $w.f2.ent -textvariable ChooseDir::S(entry)
    ::ttk::button $w.f2.ok -text OK -underline 0 \
        -command [list ChooseDir::_Ok $w]
    ::ttk::button $w.f2.cancel -text Cancel -underline 0 \
        -command [list destroy $w]
    ::ttk::button $w.f2.new -text "Make New folder" -underline 5 \
        -command [list ChooseDir::_New $w]

    grid $w.f2.lab $w.f2.ent $w.f2.ok -sticky ew -pady 3 -padx 4
    grid config $w.f2.ent -padx 2
    grid columnconfigure $w.f2 1 -weight 1
    grid x $w.f2.new $w.f2.cancel -sticky ew -pady 0 -padx 4
    grid config $w.f2.new -sticky w
    pack $w.f2 -side bottom -in $w.top -fill x -pady 4
    if {! $S(-createfolder)} { grid forget $w.f2.new }

    ################################################################
    set S(canvas) $w.f.c
    ::ttk::entry $w.f
    canvas $w.f.c -width 550 -height 260 -highlightthickness 0 \
        -xscrollcommand [list $w.f.sbar set] -takefocus 1 -background white
    ::ttk::scrollbar $w.f.sbar -orient horizontal -command [list $w.f.c xview]
    pack $w.f.sbar -side bottom -fill x -padx 2 -pady {0 2}
    pack $w.f.c -side bottom -fill both -expand 1 -padx 2 -pady {2 0}
    pack $w.f -in $w.top -side top -fill both -expand 1 -pady 1 -padx 4

    bind $w <Alt-Key-f> [list tk::TabToWindow $w.f2.ent]
    bind $w <Alt-Key-o> [list $w.f2.ok invoke]
    bind $w <Alt-Key-c> [list $w.f2.cancel invoke]
    bind $w <Alt-Key-n> [list $w.f2.new invoke]
    bind $w.f2.ent <Key-Return> [list ChooseDir::_EnterKey $w]
    bind $w.f.c <1> [list ChooseDir::_Click %W %x %y]
    bind $w.f.c <Double-Button-1> [list ChooseDir::_DoubleClick $w %W %x %y]
    bind $w.f.c <3> [list ChooseDir::_Selected %W]
    bind $w.f.c <Up> [list ChooseDir::_KeyMove %W up]
    bind $w.f.c <Down> [list ChooseDir::_KeyMove %W down]
    bind $w.f.c <Left> [list ChooseDir::_KeyMove %W left]
    bind $w.f.c <Right> [list ChooseDir::_KeyMove %W right]
    bind $w.f.c <Home> [list ChooseDir::_KeyMove %W home]
    bind $w.f.c <End> [list ChooseDir::_KeyMove %W end]
    update
    bind $w.f.c <Configure> [list ChooseDir::_Resize $w]
}
##+##########################################################################
#
# ChooseDir::_Fill -- Fills in the directory list section of the dialog
#
proc ChooseDir::_Fill {w path} {
    variable S

    if {! [winfo exists $w]} return
    set path [file nativename $path]
    set S(path) $path
    set S(entry) $path
    if {$path ne [lindex $S(undo) end]} {
        lappend S(undo) $path
    }
    $w.f1.back config -state \
        [expr {[llength $S(undo)] == 1 ? "disabled" : "normal"}]

    set c $S(canvas)
    $c delete all
    $c xview moveto 0
    $c yview moveto 0

    set n [$c create text -1000 -1000]
    set font [$c itemcget $n -font]
    $c delete $n
    set linespace [font metrics $font -linespace]
    incr linespace 2

    if {$path eq "|"} {
        set S(path) "My Computer"
        set S(entry) ""
        set dirs [file volumes]
        set icon $ChooseDir::I(computer)
    } else {
        set dirs [glob -nocomplain -directory $path -tail -type d -- *]
        set dirs [lsort -dictionary $dirs]
        set icon $ChooseDir::I(folder)
    }

    set colWidth 0
    foreach dir $dirs {
        set width [font measure $font $dir]
        set colWidth [expr {max($colWidth,$width)}]
    }
    incr colWidth 30
    set colWidth [expr {max($colWidth,200)}]
    set S(colHeight) [expr {[llength $dirs]-1}]

    set cWidth [winfo width $c]
    set cHeight [winfo height $c]
    set row 0
    set col 0
    set x 3
    set y 3
    foreach dir $dirs {
        set tag "@$row,$col"
        set tag2 "@$row,$col,txt"
        $c create image $x $y -image $icon -anchor nw -tag $tag
        $c create text [expr {$x+16+3}] $y -text $dir -anchor nw \
            -tag [list $tag $tag2 txt]
        set S(endPos) [list $row $col]

        incr y $linespace
        if {$y + $linespace >= $cHeight} {
            incr x $colWidth
            set y 3
            set S(colHeight) $row
            set row -1
            incr col
        }
        incr row
    }
    if {$dirs eq {}} {
        $c create text [expr {$cWidth/2}] 3 -tag empty \
            -text "This folder is empty." -anchor n
    }
    lassign [$c bbox all] . . width height
    set width [expr {max($width,$cWidth)}]
    set height [expr {max($height,$cHeight)}]
    $c config -scrollregion [list 0 0 $width $height]
}
##+##########################################################################
#
# ChooseDir::_Up -- Navigates up
#
proc ChooseDir::_Up {w} {
    variable S

    if {$S(path) eq "My Computer"} return

    set newPath [file nativename [file dirname $S(path)]]
    if {$newPath ne $S(path)} {
        ChooseDir::_Fill $w $newPath
    } else {
        if {$S(windows)} {
            ChooseDir::_Fill $w "|"
        }
    }
}
##+##########################################################################
#
# ChooseDir::_Back -- Handles navigating back in history
#
proc ChooseDir::_Back {w} {
    variable S

    if {[llength $S(undo)] < 1} return
    set newDir [lindex $S(undo) end-1]
    set S(undo) [lrange $S(undo) 0 end-2]
    ChooseDir::_Fill $w $newDir
}
##+##########################################################################
#
# ChooseDir::_EnterKey -- Handles pressing the enter key
#
proc ChooseDir::_EnterKey {w} {
    variable S

    set newPath [file join $S(path) $S(entry)]
    if {[file isdirectory $newPath]} {
        ChooseDir::_Fill $w $newPath
    }
}
##+##########################################################################
#
# ChooseDir::_MenuPost -- Called when menubutton is pressed, fills
# in menu with hierarchy to the root
#
proc ChooseDir::_MenuPost {w} {
    variable S

    set m $S(menu)
    $m delete 0 end

    set depth -1
    if {$S(windows)} {
        $m add command -label "My Computer" -image $ChooseDir::I(computer) \
            -compound left -command [list ChooseDir::_Fill $w "|"]
        set depth 0
    }
    if {$S(path) eq "My Computer"} return

    set partial {}
    foreach part [file split $S(path)] {
        set partial [file join $partial $part]
        set native [file nativename $partial]
        set img [ChooseDir::_GetFolderImage [incr depth]]
        $m add command -label $native -image $img -compound left \
            -command [list ChooseDir::_Fill $w $partial]
    }
}
##+##########################################################################
#
# ChooseDir::_Resize -- Called when dialog gets resized
# NB. we loose selection after this call
#
proc ChooseDir::_Resize {w} {
    variable S
    if {! [winfo exists $w]} return
    ChooseDir::_Fill $w $S(path)
}
##+##########################################################################
#
# ChooseDir::_GetFolderImage -- Returns image to use for menu
# with appropriate indenting.
#
proc ChooseDir::_GetFolderImage {depth} {
    variable I
    if {$depth == 0} { return $ChooseDir::I(folder) }

    set iname folder,$depth
    if {[info exists I($iname)]} { return $I($iname) }

    set w [expr {16 + $depth*8}]
    set I($iname) [image create photo -width $w -height 16]
    $I($iname) copy $I(folder) -to [expr {$w-16}] 0
    return $I($iname)
}
##+##########################################################################
#
# ChooseDir::_Ok -- Called when user thinks he's done
#
proc ChooseDir::_Ok {w} {
    variable S

    set newDir $S(entry)
    if {$S(path) ne "My Computer"} {
        set newDir [file join $S(path) $S(entry)]
    }
    if {$S(-mustexist) && ! [file isdirectory $newDir]} {
        set emsg "The folder '[file nativename $newDir]' does not exists."
        tk_messageBox -icon info -title "PreFlight" -message $emsg
        return
    }
    set S(value) $newDir
    destroy $w
}
##+##########################################################################
#
# ChooseDir::_Click -- Click in directory list, selects that item
#
proc ChooseDir::_Click {c x y} {
    variable S

    set closest [$c find closest [$c canvasx $x] [$c canvasy $y]]
    if {$closest eq ""} return
    set tag [lindex [$c itemcget $closest -tag] 0]
    if {$tag eq "select" || $tag eq "empty"} return
    ChooseDir::_Highlight $c $tag
    focus $c
}
##+##########################################################################
#
# ChooseDir::_DoubleClick -- double click in directory list,
# we open that directory, Windows treats this as "Ok"
#
proc ChooseDir::_DoubleClick {w c x y} {
    variable S

    $c delete select
    $c itemconfig txt -fill black
    set closest [$c find closest [$c canvasx $x] [$c canvasy $y]]
    if {$closest eq ""} return
    set tag [lindex [$c itemcget $closest -tag] 0]
    if {$tag eq "select" || $tag eq "empty"} return

    set dir [$c itemcget $tag,txt -text]
    set newPath [file nativename [file join $S(path) $dir]]
    ChooseDir::_Fill $w $newPath
}
##+##########################################################################
#
# ChooseDir::_Highlight -- Highlights a entry in the directory list
#
proc ChooseDir::_Highlight {c tag} {
    variable S

    $c delete select
    $c itemconfig txt -fill black
    $c create rect [$c bbox $tag,txt] -tag select \
        -fill \#349afc -outline \#349afc
    $c raise $tag select
    $c itemconfig $tag,txt -fill white
    set dir [$c itemcget $tag,txt -text]
    set S(entry) [file nativename [file join $S(path) $dir]]
    ChooseDir::_See $c $tag
}
##+##########################################################################
#
# ChooseDir::_Selected -- Returns which item is selected
#
proc ChooseDir::_Selected {c} {
    set xy [$c bbox select]
    if {$xy eq ""} {
        return
    }
    foreach id [$c find enclosed {*}$xy] {
        if {[$c type $id] eq "text"} {
            set tag [lindex [$c itemcget $id -tag] 0]
            return $tag
        }
    }
    return ""
}
##+##########################################################################
#
# ChooseDir::_KeyMove -- Handles direction key movements
#
proc ChooseDir::_KeyMove {c dir} {
    variable S

    set tag [ChooseDir::_Selected $c]
    if {$tag eq "" || $dir eq "home"} {
        set row 0
        set col 0
    } elseif {$dir eq "end"} {
        lassign $S(endPos) row col
    } else {
        if {! [string match "@*" $tag]} return
        scan $tag "@%d,%d" row col
        if {$dir eq "up"} {
            if {$row > 0} {
                incr row -1
            } elseif {$col > 0} {
                incr col -1
                set row $S(colHeight)
            } else return
        } elseif {$dir eq "down"} {
            incr row
            if {$row > $S(colHeight)} {
                set row 0
                incr col
            }
        } elseif {$dir eq "right"} {
            incr col 1
        } elseif {$dir eq "left"} {
            incr col -1
        }
    }
    set newTag "@$row,$col"
    if {[$c find withtag $newTag] eq {}} return
    ChooseDir::_Highlight $c $newTag
}
##+##########################################################################
#
# ChooseDir::_See -- Make sure we can see given item
#
proc ChooseDir::_See {c tag} {
    set scroll [$c cget -scrollregion]
    if {$scroll eq ""} return
    foreach {sl st sr sb} $scroll break

    set sw [expr {$sr - $sl}]                   ;# Scroll width
    set sh [expr {$sb - $st}]                   ;# Scroll height

    # Get canvas info (could have used scrollbar for this)
    lassign [$c xview] xl xr
    lassign [$c yview] yt yb

    set l [expr {round($sl + $xl * $sw)}]
    set r [expr {round($sl + $xr * $sw)}]
    set t [expr {round($st + $yt * $sh)}]
    set b [expr {round($st + $yb * $sh)}]

    set bbox [$c bbox $tag]
    if {$bbox eq ""} return
    lassign $bbox x0 y0 x1 y1

    if {$x1 <= $r && $x0 >= $l} return          ;# Visible

    # Here we know its off the screen
    set cw [winfo width $c]
    set x [expr {($x0+$x1)/2}]
    set xview [expr {(($x - $cw/2.0) - $sl) / ($sr - $sl)}]

    $c xview moveto $xview
}
##+##########################################################################
#
# ChooseDir::_New -- Creates a new directory/
# NB. we loose selection after this call
#
proc ChooseDir::_New {w} {
    variable S

    set newDir $S(entry)
    if {$S(path) ne "My Computer"} {
        set newDir [file join $S(path) $S(entry)]
    }
    set fname [file nativename $newDir]
    if {[file isdirectory $newDir]} {
        set emsg "A folder '$fname' already exists. "
        append emsg "Type another name for the folder."
        tk_messageBox -icon info -title "PreFlight" -message $emsg
        return
    }
    if {[file exists $newDir]} {
        set emsg "A new folder named '$fname' cannot be "
        append emsg "created because a file with this name already exists. "
        append emsg "Type another name for the folder."
        tk_messageBox -icon info -title "PreFlight" -message $emsg
        return
    }
    set n [catch {file mkdir $newDir} err]
    if {$n} {
        set emsg "Error creating new folder '$fname': $err"
        tk_messageBox -icon error -title "PreFlight" -message $emsg
        return
    }
    if {$n} {
        set emsg "Error: couldn't create new folder '$fname'"
        tk_messageBox -icon error -title "PreFlight" -message $emsg
        return
    }
    ChooseDir::_Fill $w $S(path)
}
#
# Demo code
#
wm withdraw .
set dir [ChooseDir::ChooseDir -title "Select Directory" \
             -mustexist 1 -createfolder 1 \
             -initialdir [file dirname [pwd]]]
puts "dir: '$dir'"
return