# A simple window manager in Tcl/Tk for use with CloudTk
# Copyright (c) Schelte Bron.  Freely redistributable.

namespace eval wm {
    package require Tk

    # Move the original toplevel and wm commands into the wm namespace
    if {[namespace which toplevel] eq "::toplevel"} {
        rename toplevel toplevel
    }
    if {[namespace which wm] eq "::wm"} {
        rename wm wm
    }
    # Get rid of the tk::toplevel command
    catch {rename ::tk::toplevel {}}

    # Create a new wm command
    namespace ensemble create -unknown ::wm::unknown -subcommands {
        deiconify geometry iconphoto maxsize minsize
        overrideredirect stackorder title withdraw
    }

    namespace export toplvl

    variable map {}

    # A default icon
    variable icon [image create photo -data {
        iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAYAAAAf8/9hAAABy0lEQVQ4y42TzWvT
        cBjHv8kvMUvS6nBrY23pVhCEefLgkIEd7KB0h122m3p2HgQd/gdzd8d69OBfIAju
        INSefIHpYC+ttbPsfUZsFtKmaWaa7OfFw+hSkuf2vH2+38PzEAQHc/FSdHpwIPo4
        nRoca1l/t1zXMxE2YrHLM/mXz9T3b57S10vTNDYgPz/b54KWF+Zn87dGiNJuqrjA
        MfC8U+bsDNtrWZbFyYUXT/JjN/uVanUXHZfi08q+qhv22zAAOTs++ih7O62UNkow
        Gg7cjodSVfsK4CgQIMnixMP7uQlT30Plp46hpIjNH/VWuaq/AmAFApJXlTs3rscj
        5e874AjA88ByoVbUjo1i96wf4Eoul50SeQflioprw1FsVuqtb2tH59R7AYgk8rKm
        aTAtF2Ifi+VC7YPRsIp+brsBDCEkEYlI5PefNgTeRW1HP/m8sv0OoFYYgJBKJR7c
        vZeN7f7qgOc5SJJAWJYdAdDnByBdudtoNNfb7ZNRz6PDHbuJvUPz4+ra/twppYYf
        wO8SM4XCFzGZVEyOMDg4rIuu52UAqGHPvx9AQhCExXg8vggg8b+GsA4MAAal1LRt
        G0HKPZ/JcZyS4zjpILv/AO1ascYM+PVRAAAAAElFTkSuQmCC
    }]
}

# Create a new toplevel command
proc wm::toplvl {name args} {
    variable toplvl
    variable map
    variable icon
    if {[dict exists $args -class]} {
        if {[dict get $args -class] in {ComboboxPopdown}} {
            tailcall toplevel $name {*}$args
        }
    }
    # Create a temporary frame to do all of the error checking and be able
    # to use the winfo command to obtain useful bits of information
    frame $name
    set parent [winfo parent $name]
    set child [winfo name $name]
    destroy $name
    set w [toplevel $parent.toplvl-[incr toplvl]]
    label $w.icon -image $icon
    label $w.title -text $child -font TkCaptionFont
    label $w.close -text \u274C
    frame $w.frame -container 1
    decorate $w
    toplevel $name {*}$args -use [winfo id $w.frame]
    frame $name.__wm__canary -class WmCanary
    wm overrideredirect $w 1
    bindtags $w.title [list $w.title WmTitlebar $w all]
    bindtags $w.close [list $w.close WmClose $w all]
    dict set map $name $w
    return $name
}

namespace import wm::toplvl
rename toplvl toplevel

proc wm::window {window} {
    variable map
    if {[dict exists $map $window]} {
        return [dict get $map $window]
    } else {
        return $window
    }
}

proc wm::unmanage {win} {
    # Grid
    set slaves [grid slaves $win]
    if {[llength $slaves]} {grid forget {*}$slaves}
    lassign [grid size $win] cols rows
    for {set i 0} {$i < $rows} {incr i} {
        grid rowconfigure $win $i -minsize 0 -pad 0 -uniform {} -weight 0
    }
    for {set i 0} {$i < $rows} {incr i} {
        grid columnconfigure $win $i -minsize 0 -pad 0 -uniform {} -weight 0
    }
    grid propagate $win 1
    # Pack
    set slaves [pack slaves $win]
    if {[llength $slaves]} {pack forget {*}$slaves}
    pack propagate $win 1
    # Place
    set slaves [place slaves $win]
    if {[llength $slaves]} {place forget {*}$slaves}
}

proc wm::decorate {win} {
    unmanage $win
    grid $win.icon $win.title $win.close -sticky ew
    grid $win.icon $win.close -padx 4 -pady 4
    grid $win.frame - - -padx 4 -pady {0 4} -sticky nsew
    grid rowconfigure $win $win.frame -weight 1
    grid columnconfigure $win $win.title -weight 1
}

proc wm::strip {win} {
    unmanage $win
    grid $win.frame -sticky nsew
    grid rowconfigure $win $win.frame -weight 1
    grid columnconfigure $win $win.frame -weight 1
}

# wm command implementation
proc wm::unknown {cmd sub args} {
    # Forward any unknown subcommands to the original wm command
    return [list wm::wm $sub]
}

proc wm::deiconify {window} {
    wm deiconify [window $window]
}

proc wm::geometry {window {geometry ""}} {
    if {[llength [info level 0]] > 2} {
        tailcall wm geometry [window $window] $geometry
    } else {
        tailcall wm geometry [window $window]
    }
}

proc wm::iconphoto {window args} {
    if {[lindex $args 0] eq "-default"} {
        variable icon
        set args [lrange $args 1 end]
    } else {
        set icon ""
    }
    # Find the first matching icon
    foreach img $args {
        if {[image width $img] <= 24 && [image height $img] <= 24} {
            set icon $img
            break
        }
    }
    set win [window $window]
    if {$win ne $window} {
        $win.icon configure -image $icon
    } else {
        tailcall wm {*}[info level 0]
    }
}

proc wm::maxsize {window {width ""} {height ""}} {
    # Not yet implemented
    tailcall wm {*}[info level 0]
}

proc wm::minsize {window {width ""} {height ""}} {
    # Not yet implemented
    tailcall wm {*}[info level 0]
}

proc wm::overrideredirect {window {boolean ""}} {
    set win [window $window]
    if {$win ne $window} {
        if {$boolean eq ""} {
            lassign [grid size $win] cols rows
            return [expr {$cols == 1 && $rows == 1}]
        } elseif {$boolean} {
            strip $win
        } else {
            decorate $win
        }
    } else {
        tailcall wm {*}[info level 0]
    }
}

proc wm::stackorder {window args} {
    variable map
    set revmap {}
    dict for {k v} $map {dict set revmap $v $k}
    return [lmap w [wm stackorder $window {*}$args] {
        if {[dict exists $revmap $w]} {dict get $revmap $w} else {set w}
    }]
}

proc wm::title {window {string ""}} {
    variable map
    if {[dict exists $map $window]} {
        set w [dict get $map $window]
        if {[llength [info level 0]] > 2} {
            $w.title configure -text $string
        } else {
            return [$w.title cget -text]
        }
    } else {
        tailcall wm {*}[info level 0]
    }
}

proc wm::withdraw {window} {
    wm withdraw [window $window]
}

# Bindings
proc wm::Select {w x y} {
    variable State
    set top [winfo toplevel $w]
    raise $top
    set State(toplevel) $top
    set State(pressX) $x
    set State(pressY) $y
    set State(x) [winfo rootx $top]
    set State(y) [winfo rooty $top]
    set State(pressed) 1
    set State(cursor) [$w cget -cursor]
    set State(id) [after 500 [list $w configure -cursor fleur]]
}

proc wm::Drag {w x y} {
    variable State
    if {!$State(pressed)} return

    $w configure -cursor fleur
    set dx [expr {$x - $State(pressX)}]
    set dy [expr {$y - $State(pressY)}]
    set State(pressX) $x
    set State(pressY) $y
    set x [incr State(x) $dx]
    set y [incr State(y) $dy]
    wm geometry $State(toplevel) [format +%d+%d $x $y]
}

proc wm::Release {w x y} {
    variable State
    after cancel $State(id)
    $w configure -cursor $State(cursor)
    set State(pressed) 0
}

proc wm::Close {w} {
    variable map
    set top [winfo toplevel $w]
    destroy $top
}

proc wm::Destroy {w} {
    variable map
    set top [winfo toplevel $w]
    if {[dict exists $map $top]} {
        set win [dict get $map $top]
        dict unset map $top
        # Destroying immediately causes a BadWindow X error
        after idle [list destroy $win]
    }
}

bind WmTitlebar <Button-1> {wm::Select %W %X %Y}
bind WmTitlebar <B1-Motion> {wm::Drag %W %X %Y}
bind WmTitlebar <ButtonRelease-1> {wm::Release %W %X %Y}
bind WmClose <Button-1> {wm::Close %W}
bind WmCanary <Destroy> {wm::Destroy %W}