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

• Download calc.tcl
• Enviar nova versão

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

Calculadora em Tcl/Tk

Cadeias aleatórias

Relógio analógico

Script lixeira em Tcl

param - abre aplicativos com parâmetros no Blackbox e outros

Nenhum comentário foi encontrado.