Calculadora em Tcl/Tk
Publicado por tiago 22/01/2006
[ Hits: 6.286 ]
Essa calculadora foi feita no visual tcl que por sinal é uma ótima ferramenta para desenvolvimento em Tcl/Tk
#!/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
Script em Tcl para descompactar arquivos
Corretagem 0.1 - calcula corretagem padrão de operações da Bovespa
Nenhum comentário foi encontrado.
Compartilhando a tela do Computador no Celular via Deskreen
Como Configurar um Túnel SSH Reverso para Acessar Sua Máquina Local a Partir de uma Máquina Remota
Configuração para desligamento automatizado de Computadores em um Ambiente Comercial
Efeito "livro" em arquivos PDF
Como resolver o erro no CUPS: Unable to get list of printer drivers
Flatpak: remover runtimes não usados e pacotes
Mudar o gerenciador de login (GDM para SDDM e vice-versa) - parte 2
Como atualizar o Debian 8 para o 10 (10)
Dica sobre iptables ACCEPT e DROP (6)
NGNIX - Aplicar SNAT para evitar roteamento assimetrico (29)
[Python] Automação de scan de vulnerabilidades
[Python] Script para analise de superficie de ataque
[Shell Script] Novo script para redimensionar, rotacionar, converter e espelhar arquivos de imagem
[Shell Script] Iniciador de DOOM (DSDA-DOOM, Doom Retro ou Woof!)
[Shell Script] Script para adicionar bordas às imagens de uma pasta