Calculadora em Tcl/Tk
Publicado por tiago 22/01/2006
[ Hits: 6.302 ]
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
Calculadora com funções básicas
Nenhum comentário foi encontrado.
Enviar mensagem ao usuário trabalhando com as opções do php.ini
Meu Fork do Plugin de Integração do CVS para o KDevelop
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
Criando uma VPC na AWS via CLI
Multifuncional HP imprime mas não digitaliza
Dica básica para escrever um Artigo.
Como Exibir Imagens Aleatórias no Neofetch para Personalizar seu Terminal
Pegar a ultima ocorrencia viva (1)
Pq me aparece isso quando fui atualizar o Ubuntu 24.10 no terminal? (1)
como coloco para instalar com esse erro. (13)
Alguém sabe de documentos de texto e /ou vídeo aulas de certificações ... (1)