Calculadora em Tcl/Tk

Publicado por tiago 22/01/2006

[ Hits: 6.286 ]

Download calc.tcl




Essa calculadora foi feita no visual tcl que por sinal é uma ótima ferramenta para desenvolvimento em Tcl/Tk

  



Esconder código-fonte

#!/bin/sh
# the next line restarts using wish\
exec wish "$0" "$@" 

if {![info exists vTcl(sourcing)]} {

    package require Tk
    switch $tcl_platform(platform) {
   windows {
            option add *Button.padY 0
   }
   default {
            option add *Scrollbar.width 10
            option add *Scrollbar.highlightThickness 0
            option add *Scrollbar.elementBorderWidth 2
            option add *Scrollbar.borderWidth 2
   }
    }
    
}

#############################################################################
# Visual Tcl v1.60 Project
#




#############################################################################
## vTcl Code to Load Stock Images


if {![info exist vTcl(sourcing)]} {
#############################################################################
## Procedure:  vTcl:rename

proc ::vTcl:rename {name} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    regsub -all "\\." $name "_" ret
    regsub -all "\\-" $ret "_" ret
    regsub -all " " $ret "_" ret
    regsub -all "/" $ret "__" ret
    regsub -all "::" $ret "__" ret

    return [string tolower $ret]
}

#############################################################################
## Procedure:  vTcl:image:create_new_image

proc ::vTcl:image:create_new_image {filename {description {no description}} {type {}} {data {}}} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    # Does the image already exist?
    if {[info exists ::vTcl(images,files)]} {
        if {[lsearch -exact $::vTcl(images,files) $filename] > -1} { return }
    }

    if {![info exists ::vTcl(sourcing)] && [string length $data] > 0} {
        set object [image create  [vTcl:image:get_creation_type $filename]  -data $data]
    } else {
        # Wait a minute... Does the file actually exist?
        if {! [file exists $filename] } {
            # Try current directory
            set script [file dirname [info script]]
            set filename [file join $script [file tail $filename] ]
        }

        if {![file exists $filename]} {
            set description "file not found!"
            ## will add 'broken image' again when img is fixed, for now create empty
            set object [image create photo -width 1 -height 1]
        } else {
            set object [image create  [vTcl:image:get_creation_type $filename]  -file $filename]
        }
    }

    set reference [vTcl:rename $filename]
    set ::vTcl(images,$reference,image)       $object
    set ::vTcl(images,$reference,description) $description
    set ::vTcl(images,$reference,type)        $type
    set ::vTcl(images,filename,$object)       $filename

    lappend ::vTcl(images,files) $filename
    lappend ::vTcl(images,$type) $object

    # return image name in case caller might want it
    return $object
}

#############################################################################
## Procedure:  vTcl:image:get_image

proc ::vTcl:image:get_image {filename} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    set reference [vTcl:rename $filename]

    # Let's do some checking first
    if {![info exists ::vTcl(images,$reference,image)]} {
        # Well, the path may be wrong; in that case check
        # only the filename instead, without the path.

        set imageTail [file tail $filename]

        foreach oneFile $::vTcl(images,files) {
            if {[file tail $oneFile] == $imageTail} {
                set reference [vTcl:rename $oneFile]
                break
            }
        }
    }
    return $::vTcl(images,$reference,image)
}

#############################################################################
## Procedure:  vTcl:image:get_creation_type

proc ::vTcl:image:get_creation_type {filename} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    switch [string tolower [file extension $filename]] {
        .ppm -
        .jpg -
        .bmp -
        .gif    {return photo}
        .xbm    {return bitmap}
        default {return photo}
    }
}

foreach img {

        {{[file join / usr bin images edit remove.gif]} {} stock {}}

            } {
    eval set _file [lindex $img 0]
    vTcl:image:create_new_image\
        $_file [lindex $img 1] [lindex $img 2] [lindex $img 3]
}

}
#################################
# VTCL LIBRARY PROCEDURES
#

if {![info exists vTcl(sourcing)]} {
#############################################################################
## Library Procedure:  Window

proc ::Window {args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    global vTcl
    foreach {cmd name newname} [lrange $args 0 2] {}
    set rest    [lrange $args 3 end]
    if {$name == "" || $cmd == ""} { return }
    if {$newname == ""} { set newname $name }
    if {$name == "."} { wm withdraw $name; return }
    set exists [winfo exists $newname]
    switch $cmd {
        show {
            if {$exists} {
                wm deiconify $newname
            } elseif {[info procs vTclWindow$name] != ""} {
                eval "vTclWindow$name $newname $rest"
            }
            if {[winfo exists $newname] && [wm state $newname] == "normal"} {
                vTcl:FireEvent $newname <<Show>>
            }
        }
        hide    {
            if {$exists} {
                wm withdraw $newname
                vTcl:FireEvent $newname <<Hide>>
                return}
        }
        iconify { if $exists {wm iconify $newname; return} }
        destroy { if $exists {destroy $newname; return} }
    }
}
#############################################################################
## Library Procedure:  vTcl:DefineAlias

proc ::vTcl:DefineAlias {target alias widgetProc top_or_alias cmdalias} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    global widget
    set widget($alias) $target
    set widget(rev,$target) $alias
    if {$cmdalias} {
        interp alias {} $alias {} $widgetProc $target
    }
    if {$top_or_alias != ""} {
        set widget($top_or_alias,$alias) $target
        if {$cmdalias} {
            interp alias {} $top_or_alias.$alias {} $widgetProc $target
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:DoCmdOption

proc ::vTcl:DoCmdOption {target cmd} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## menus are considered toplevel windows
    set parent $target
    while {[winfo class $parent] == "Menu"} {
        set parent [winfo parent $parent]
    }

    regsub -all {\%widget} $cmd $target cmd
    regsub -all {\%top} $cmd [winfo toplevel $parent] cmd

    uplevel #0 [list eval $cmd]
}
#############################################################################
## Library Procedure:  vTcl:FireEvent

proc ::vTcl:FireEvent {target event {params {}}} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    ## The window may have disappeared
    if {![winfo exists $target]} return
    ## Process each binding tag, looking for the event
    foreach bindtag [bindtags $target] {
        set tag_events [bind $bindtag]
        set stop_processing 0
        foreach tag_event $tag_events {
            if {$tag_event == $event} {
                set bind_code [bind $bindtag $tag_event]
                foreach rep "\{%W $target\} $params" {
                    regsub -all [lindex $rep 0] $bind_code [lindex $rep 1] bind_code
                }
                set result [catch {uplevel #0 $bind_code} errortext]
                if {$result == 3} {
                    ## break exception, stop processing
                    set stop_processing 1
                } elseif {$result != 0} {
                    bgerror $errortext
                }
                break
            }
        }
        if {$stop_processing} {break}
    }
}
#############################################################################
## Library Procedure:  vTcl:Toplevel:WidgetProc

proc ::vTcl:Toplevel:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }
    set command [lindex $args 0]
    set args [lrange $args 1 end]
    switch -- [string tolower $command] {
        "setvar" {
            foreach {varname value} $args {}
            if {$value == ""} {
                return [set ::${w}::${varname}]
            } else {
                return [set ::${w}::${varname} $value]
            }
        }
        "hide" - "show" {
            Window [string tolower $command] $w
        }
        "showmodal" {
            ## modal dialog ends when window is destroyed
            Window show $w; raise $w
            grab $w; tkwait window $w; grab release $w
        }
        "startmodal" {
            ## ends when endmodal called
            Window show $w; raise $w
            set ::${w}::_modal 1
            grab $w; tkwait variable ::${w}::_modal; grab release $w
        }
        "endmodal" {
            ## ends modal dialog started with startmodal, argument is var name
            set ::${w}::_modal 0
            Window hide $w
        }
        default {
            uplevel $w $command $args
        }
    }
}
#############################################################################
## Library Procedure:  vTcl:WidgetProc

proc ::vTcl:WidgetProc {w args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    if {[llength $args] == 0} {
        ## If no arguments, returns the path the alias points to
        return $w
    }

    set command [lindex $args 0]
    set args [lrange $args 1 end]
    uplevel $w $command $args
}
#############################################################################
## Library Procedure:  vTcl:toplevel

proc ::vTcl:toplevel {args} {
    ## This procedure may be used free of restrictions.
    ##    Exception added by Christian Gavin on 08/08/02.
    ## Other packages and widget toolkits have different licensing requirements.
    ##    Please read their license agreements for details.

    uplevel #0 eval toplevel $args
    set target [lindex $args 0]
    namespace eval ::$target {set _modal 0}
}
}


if {[info exists vTcl(sourcing)]} {

proc vTcl:project:info {} {
    set base .top60
    namespace eval ::widgets::$base {
        set set,origin 1
        set set,size 1
        set runvisible 1
    }
    namespace eval ::widgets::$base.but62 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but63 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.lab60 {
        array set save {-justify 1 -relief 1}
    }
    namespace eval ::widgets::$base.but61 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but64 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but65 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but60 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but66 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but67 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but68 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but69 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but70 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but71 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but72 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but73 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but74 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but75 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but76 {
        array set save {-command 1 -text 1}
    }
    namespace eval ::widgets::$base.but77 {
        array set save {-command 1 -image 1 -text 1}
    }
    namespace eval ::widgets::$base.m78 {
        array set save {-tearoff 1}
    }
    namespace eval ::widgets_bindings {
        set tagslist _TopLevel
    }
    namespace eval ::vTcl::modules::main {
        set procs {
            init
            main
        }
        set compounds {
        }
        set projectType single
    }
}
}

#################################
# USER DEFINED PROCEDURES
#
#############################################################################
## Procedure:  main

proc ::main {argc argv} {}

#############################################################################
## Initialization Procedure:  init

proc ::init {argc argv} {}

init $argc $argv

#################################
# VTCL GENERATED GUI PROCEDURES
#

proc vTclWindow. {base} {
    if {$base == ""} {
        set base .
    }
    ###################
    # CREATING WIDGETS
    ###################
    wm focusmodel $top passive
    wm geometry $top 1x1+0+0; update
    wm maxsize $top 1009 738
    wm minsize $top 1 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm withdraw $top
    wm title $top "vtcl.tcl"
    bindtags $top "$top Vtcl.tcl all"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    ###################
    # SETTING GEOMETRY
    ###################

    vTcl:FireEvent $base <<Ready>>
}

proc vTclWindow.top60 {base} {
    if {$base == ""} {
        set base .top60
    }
    if {[winfo exists $base]} {
        wm deiconify $base; return
    }
    set top $base
    ###################
    # CREATING WIDGETS
    ###################
    vTcl:toplevel $top -class Toplevel \
        -menu "$top.m78" -background #000000 -highlightcolor black 
    wm focusmodel $top passive
    wm geometry $top 208x272+342+260; update
    wm maxsize $top 1009 738
    wm minsize $top 1 1
    wm overrideredirect $top 0
    wm resizable $top 1 1
    wm deiconify $top
    wm title $top "New Toplevel 1"
    vTcl:DefineAlias "$top" "Toplevel1" vTcl:Toplevel:WidgetProc "" 1
    bindtags $top "$top Toplevel all _TopLevel"
    vTcl:FireEvent $top <<Create>>
    wm protocol $top WM_DELETE_WINDOW "vTcl:FireEvent $top <<DeleteWindow>>"

    button $top.but62 \
        \
        -command {set val1 [ .top60.lab60 cget -text ]
set tiago [ .top60.but62 cget -text ]
Label1 configure -text "$val1$tiago"} \
        -text 1 
    vTcl:DefineAlias "$top.but62" "Button1" vTcl:WidgetProc "Toplevel1" 1
    button $top.but63 \
        \
        -command {set val2 [ .top60.lab60 cget -text ]
set text2 [ .top60.but63 cget -text ]
Label1 configure -text "$val2$text2"} \
        -text 2 
    vTcl:DefineAlias "$top.but63" "Button2" vTcl:WidgetProc "Toplevel1" 1
    label $top.lab60 \
        -justify right -relief sunken 
    vTcl:DefineAlias "$top.lab60" "Label1" vTcl:WidgetProc "Toplevel1" 1
    button $top.but61 \
        \
        -command {set vala [ .top60.lab60 cget -text ]
set con "+"
Label1 configure -text ""} \
        -text + 
    vTcl:DefineAlias "$top.but61" "Button3" vTcl:WidgetProc "Toplevel1" 1
    button $top.but64 \
        \
        -command {set valb [ .top60.lab60 cget -text ]

if {$con == "+" } {
set val [expr $vala + $valb ]

Label1 configure -text "$val"
}

if {$con == "x"} {
set val [expr $vala * $valb]
Label1 configure -text "$val"
}

if {$con == "-" } {
set val [expr $vala - $valb ]
Label1 configure -text "$val"
}

if {$con == "/" } {
set val [expr $vala / $valb ]
Label1 configure -text "$val"
}} \
        -text = 
    vTcl:DefineAlias "$top.but64" "Button4" vTcl:WidgetProc "Toplevel1" 1
    button $top.but65 \
        \
        -command {set vala [ .top60.lab60 cget -text ]
set con ""
set con "x"
Label1 configure -text ""} \
        -text x 
    vTcl:DefineAlias "$top.but65" "Button5" vTcl:WidgetProc "Toplevel1" 1
    button $top.but60 \
        \
        -command {set val3 [ .top60.lab60 cget -text ]
set text3 [ .top60.but60 cget -text ]
Label1 configure -text "$val3$text3"} \
        -text 3 
    vTcl:DefineAlias "$top.but60" "Button6" vTcl:WidgetProc "Toplevel1" 1
    button $top.but66 \
        \
        -command {set zakk [ .top60.lab60 cget -text ]
set ozzy [ .top60.but66 cget -text ]
Label1 configure -text "$zakk$ozzy"} \
        -text . 
    vTcl:DefineAlias "$top.but66" "Button7" vTcl:WidgetProc "Toplevel1" 1
    button $top.but67 \
        \
        -command {set vala [ .top60.lab60 cget -text ]
set con "-"
Label1 configure -text ""} \
        -text - 
    vTcl:DefineAlias "$top.but67" "Button8" vTcl:WidgetProc "Toplevel1" 1
    button $top.but68 \
        \
        -command {set vala [ .top60.lab60 cget -text ]
set con "/"
Label1 configure -text ""} \
        -text / 
    vTcl:DefineAlias "$top.but68" "Button9" vTcl:WidgetProc "Toplevel1" 1
    button $top.but69 \
        \
        -command {set val0 [ .top60.lab60 cget -text ]
set text0 [ .top60.but69 cget -text ]
Label1 configure -text "$val0$text0"} \
        -text 0 
    vTcl:DefineAlias "$top.but69" "Button10" vTcl:WidgetProc "Toplevel1" 1
    button $top.but70 \
        \
        -command {set val4 [ .top60.lab60 cget -text ]
set text4 [ .top60.but70 cget -text ]
Label1 configure -text "$val4$text4"} \
        -text 4 
    vTcl:DefineAlias "$top.but70" "Button11" vTcl:WidgetProc "Toplevel1" 1
    button $top.but71 \
        \
        -command {set val5 [ .top60.lab60 cget -text ]
set text5 [ .top60.but71 cget -text ]
Label1 configure -text "$val5$text5"} \
        -text 5 
    vTcl:DefineAlias "$top.but71" "Button12" vTcl:WidgetProc "Toplevel1" 1
    button $top.but72 \
        \
        -command {set val6 [ .top60.lab60 cget -text]
set text6 [ .top60.but72 cget -text]
Label1 configure -text "$val6$text6"} \
        -text 6 
    vTcl:DefineAlias "$top.but72" "Button13" vTcl:WidgetProc "Toplevel1" 1
    button $top.but73 \
        \
        -command {set val7 [ .top60.lab60 cget -text ]
set text7 [ .top60.but73 cget -text ]
Label1 configure -text "$val7$text7"} \
        -text 7 
    vTcl:DefineAlias "$top.but73" "Button14" vTcl:WidgetProc "Toplevel1" 1
    button $top.but74 \
        \
        -command {set val8 [ .top60.lab60 cget -text ]
set text8 [ .top60.but74 cget -text ]
Label1 configure -text "$val8$text8"} \
        -text 8 
    vTcl:DefineAlias "$top.but74" "Button15" vTcl:WidgetProc "Toplevel1" 1
    button $top.but75 \
        \
        -command {set val9 [ .top60.lab60 cget -text ]
set text9 [ .top60.but75 cget -text ]
Label1 configure -text "$val9$text9"} \
        -text 9 
    vTcl:DefineAlias "$top.but75" "Button16" vTcl:WidgetProc "Toplevel1" 1
    button $top.but76 \
        -command {Label1 configure -text ""} -text CE 
    vTcl:DefineAlias "$top.but76" "Button17" vTcl:WidgetProc "Toplevel1" 1
    button $top.but77 \
        -command exit \
        -image [vTcl:image:get_image [file join / usr bin images edit remove.gif]] \
        -text Sair 
    vTcl:DefineAlias "$top.but77" "Button18" vTcl:WidgetProc "Toplevel1" 1
    menu $top.m78 \
        -tearoff 1 
    ###################
    # SETTING GEOMETRY
    ###################
    place $top.but62 \
        -in $top -x 15 -y 190 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but63 \
        -in $top -x 60 -y 190 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.lab60 \
        -in $top -x 15 -y 25 -width 173 -height 30 -anchor nw \
        -bordermode ignore 
    place $top.but61 \
        -in $top -x 150 -y 190 -width 38 -height 63 -anchor nw \
        -bordermode ignore 
    place $top.but64 \
        -in $top -x 105 -y 225 -anchor nw -bordermode ignore 
    place $top.but65 \
        -in $top -x 150 -y 120 -width 38 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but60 \
        -in $top -x 105 -y 190 -anchor nw -bordermode ignore 
    place $top.but66 \
        -in $top -x 60 -y 225 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but67 \
        -in $top -x 150 -y 155 -width 38 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but68 \
        -in $top -x 150 -y 85 -width 37 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but69 \
        -in $top -x 15 -y 225 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but70 \
        -in $top -x 15 -y 155 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but71 \
        -in $top -x 60 -y 155 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but72 \
        -in $top -x 105 -y 155 -anchor nw -bordermode ignore 
    place $top.but73 \
        -in $top -x 15 -y 120 -width 35 -anchor nw -bordermode ignore 
    place $top.but74 \
        -in $top -x 60 -y 120 -width 35 -anchor nw -bordermode ignore 
    place $top.but75 \
        -in $top -x 105 -y 120 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but76 \
        -in $top -x 105 -y 85 -width 35 -height 28 -anchor nw \
        -bordermode ignore 
    place $top.but77 \
        -in $top -x 15 -y 85 -width 82 -height 28 -anchor nw \
        -bordermode ignore 

    vTcl:FireEvent $base <<Ready>>
}

#############################################################################
## Binding tag:  _TopLevel

bind "_TopLevel" <<Create>> {
    if {![info exists _topcount]} {set _topcount 0}; incr _topcount
}
bind "_TopLevel" <<DeleteWindow>> {
    if {[set ::%W::_modal]} {
                vTcl:Toplevel:WidgetProc %W endmodal
            } else {
                destroy %W; if {$_topcount == 0} {exit}
            }
}
bind "_TopLevel" <Destroy> {
    if {[winfo toplevel %W] == "%W"} {incr _topcount -1}
}

Window show .
Window show .top60

main $argc $argv

Scripts recomendados

Calculadora em Tcl/Tk

Script em Tcl para descompactar arquivos

O mundo do Polinômio

Corretagem 0.1 - calcula corretagem padrão de operações da Bovespa

Cadeias aleatórias


  

Comentários

Nenhum comentário foi encontrado.


Contribuir com comentário




Patrocínio

Site hospedado pelo provedor RedeHost.
Linux banner

Destaques

Artigos

Dicas

Tópicos

Top 10 do mês

Scripts