# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Library General Public
# License as published by the Free Software Foundation; either
# version 2 of the License, or (at your option) any later version.
#
# This library 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 Library General Public License for more details.
#
# You should have received A copy of the GNU Library General
# Public License along with this library; if not, write to the
# Free Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA  02111-1307  USA

# Copyrights (C)
# for this R-port:
#   1999 - 2008, Diethelm Wuertz, Rmetrics Foundation, GPL
#   Diethelm Wuertz <wuertz@itp.phys.ethz.ch>
#   www.rmetrics.org
# for the code accessed (or partly included) from other R-ports:
#   see R's copyright and license files
# for the code accessed (or partly included) from contributed R-ports
# and other sources
#   see Rmetrics's copyright file


################################################################################
# FUNCTION:                 SLIDER MENU:
#  .sliderMenu               Opens a teching demo slider menu
#  .tdSliderMenu             Opens a teching demo slider and button menu
################################################################################


.slider.env = new.env()


# ------------------------------------------------------------------------------


.sliderMenu <-
    function(refresh.code, names, minima, maxima, resolutions, starts,
    title = "Slider", no = 0, set.no.value = 0)
{
    # A function implemented by Diethelm Wuertz

    # Description:
    #   Starts a slider menu

    # Source:
    #   Built on code written by Peter Wolf

    # FUNCTION:

    # Requirement:
    if (!require(tcltk, quietly = TRUE))
        stop("\n -- Package tcltk not available -- \n\n")

    # Environment:
    if (!exists(".slider.env")) {
        .slider.env <<- new.env()
    }
    if (no != 0) {
        options(show.error.messages = FALSE)
        ans = as.numeric(tclvalue(get(paste("slider", no, sep = ""),
            env = .slider.env)))
        options(show.error.messages = TRUE)
        return(ans)
    }
    if (set.no.value[1] != 0) {
        try(eval(parse(text = paste("tclvalue(slider", set.no.value[1],
            ")<-", set.no.value[2], sep = "")), env = .slider.env),
            silent = TRUE)
        return(set.no.value[2])
    }

    # Toplevel:
    nt = tktoplevel()
    tkwm.title(nt, title)


    # Slider:
    for (i in seq(names)) {
        eval(parse(text = paste("assign(\"slider", i, "\",
            tclVar(starts[i]), env = .slider.env)", sep = "")))
        tkpack(fr<-tkframe(nt), anchor = "sw")
        lab = tklabel(fr, text = names[i], anchor = "sw")
        sc = tkscale(fr, command = refresh.code, from = minima[i],
            to = maxima[i], showvalue = TRUE, resolution =
            resolutions[i], orient = "horiz")
        assign("sc", sc, env = .slider.env)
        tkgrid(sc, lab)
        eval(parse(text = paste("tkconfigure(sc, variable = slider", i, ")",
            sep = "")), env = .slider.env)
    }
    tkpack(fr<-tkframe(nt), anchor = "sw")

    # Quit:
    quitButton = tkbutton(fr, text = "   Quit   ",
        command = function() {
            tkdestroy(nt)
        } )

    # Reset:
    resetButton = tkbutton(fr, text = "   Start | Reset   ",
        command = function() {
            for (i in seq(starts)) eval(parse(text =
                paste("tclvalue(slider", i, ")<-", starts[i], sep = "")),
                env = .slider.env)
            refresh.code()
        }  )

    # Compose:
    tkgrid(resetButton, quitButton, sticky = "sew")
}


# ------------------------------------------------------------------------------


.tdSliderMenu <-
    function(sl.functions, names, minima, maxima, resolutions, starts,
    but.functions, but.names, no, set.no.value, obj.name, obj.value,
    reset.function, title)
{
    # A function implemented by Diethelm Wuertz

    # Description
    #   Opens a teching demo slider menu

    # Notes:
    #   Build on ideas and code from:
    #   R Package: TeachingDemos
    #   Title: Demonstrations for teaching and learning
    #   Version: 1.5
    #   Author: Greg Snow
    #   Description: This package is a set of demonstration functions
    #       that can be used in a classroom to demonstrate statistical
    #       concepts, or on your own to better understand the concepts
    #       or the programming.
    #   Maintainer: Greg Snow <greg.snow@intermountainmail.org>
    #   License: Artistic

    # FUNCTION:

    # Requirement:
    if (!require(tcltk, quietly = TRUE))
        stop("\n -- Package tcltk not available -- \n\n")

    # Setup:
    if(!missing(no)) {
        return(as.numeric(tclvalue(get(paste(".tdSlider", no, sep=""),
            env = .slider.env))))
    }
    if(!missing(set.no.value)){
        try(eval(parse(text=paste("tclvalue(.tdSlider", set.no.value[1],")<-",
            set.no.value[2], sep = "")), env = .slider.env))
        return(set.no.value[2])
    }
    if(!exists(".slider.env")) {
        .slider.env <<- new.env()
    }
    if(!missing(obj.name)){
        if(!missing(obj.value)) {
            assign(obj.name, obj.value, env = .slider.env)
        } else {
            obj.value <- get(obj.name, env = .slider.env)
        }
        return(obj.value)
    }
    if(missing(title)) {
        title = "Control Widget"
    }

    # GUI Settings:
    nt <- tktoplevel()
    tkwm.title(nt, title)
    tkwm.geometry(nt, "+0+0")

    # Buttons:
    tkpack(
        f.but <- tkframe(nt), fill = "x")

    # Quit Button:
    quitCMD = function() {
        tkdestroy(nt)
    }
    tkpack(
        tkbutton(f.but, text = "Quit", command = quitCMD, anchor = "sw"),
        side = "right",
        fill = "y")

    # Reset Button:
    if(missing(reset.function)) {
        reset.function <- function(...) print("relax")
    }
    if(!is.function(reset.function)) {
        reset.function<-eval(parse(text =
            paste("function(...){",reset.function,"}")))
    }
    resetCMD = function()
    {
        for(i in seq(names))
            eval(parse(text = paste("tclvalue(.tdSlider",i,")<-",
                starts[i], sep = "")),
            env = .slider.env)
        reset.function()
    }
    tkpack(
        tkbutton(f.but, text = "Reset", command = resetCMD, anchor = "sw"),
        side = "right",
        fill = "y")
    if (missing(but.names)) {
        but.names <- NULL
    }
    for (i in seq(but.names)) {
        but.fun <-
            if (length(but.functions) > 1)
                but.functions[[i]]
            else
                but.functions
        if (!is.function(but.fun)) {
            but.fun <-
                eval(parse(text = paste("function(...){", but.fun, "}")))
        }
        tkpack(
            tkbutton(f.but, text = but.names[i], command = but.fun,
                anchor = "nw"),
            # side = "right",
            fill = "x"
            )
    }

    # Sliders:
    if(missing(names)) {
        names <- NULL
    }
    if(missing(sl.functions)) {
        sl.functions <- function(...){}
    }
    for(i in seq(names)){
        eval(parse(text = paste("assign('.tdSlider",i,"',
            tclVar(starts[i]), env = .slider.env)", sep = "")))
        tkpack(fr <- tkframe(nt))
        lab <- tklabel(fr,
            text = names[i],
            anchor = "sw",
            width = "35")
        sc <- tkscale(fr,
            from = minima[i],
            to = maxima[i],
            showvalue = TRUE,
            resolution = resolutions[i],
            orient = "horiz")
        tkpack(lab,
            sc,
            anchor = "sw",
            side = "right");
        assign("sc", sc, env = .slider.env)

        eval(parse(text=paste("tkconfigure(sc,variable=.tdSlider",i,")",
            sep="")), env = .slider.env)
        sl.fun <-
            if(length(sl.functions)>1)
                sl.functions[[i]]
            else
                sl.functions
        if(!is.function(sl.fun))
            sl.fun<-eval(parse(text=paste("function(...){", sl.fun,"}")))

        tkconfigure(sc, command = sl.fun)
    }
    assign("slider.values.old", starts, env = .slider.env)

    # Return Value:
    invisible(nt)
}


################################################################################