Business Applications written in Tcl:
======
proc addspace { str } {
set len [string length $str]

set count 0 
while { $count < $len } {
if {[string index $str $count] == " "} {set str [string replace $str $count $count "_"];}
incr count
}
return $str
}

proc dim {color factor} {
  foreach i {r g b} n [winfo rgb . $color] d [winfo rgb . white] {
     set $i [expr int(255.*$n/$d*$factor)]
  }
  format #%02x%02x%02x $r $g $b
}


proc formatcor { str n } {
set len [string length $str]
if { $len < $n } {
set count 0
set a ""
set space " "
while { $count < [expr $n - $len]} {
set a $a$space
incr count
}}
set str $str$a
return [string toupper $str]
}
##########################################################################################################################################################################
##########################################################################################################################################################################
proc validatepasswd { p1 p2 } {
return [string compare $p1 $p2]
}

proc validatename { name } {
set name [string toupper $name]
set flag 0
set len [string length $name]
set count 0
if { $len == 0 } {return 100}
while { $count < $len } {
set ascii  [scan [string index $name $count] "%c"]
incr count
if { $ascii < 65 || $ascii > 90 } {
if { $ascii != 32 && $ascii != 46 } {incr flag} 
}}
return $flag}

proc custsignup {} {
forgetting
set y 200
foreach n {.custname .custaddr .custphon .custpwd1 .custpwd2 } {
set x  100
foreach z { l e } {
place $n$z -x $x -y $y
incr x 150
}
incr y 50
}
place .processsignup -x $x -y $y

}

proc processcustsignup {} {
forgetting
global custid
global custlist
if { [validatename [.custnamee get]] == 0 && [validatepasswd [.custpwd1e get] [.custpwd2e get]] == 0} {
set n  [addspace [.custnamee get]]
set a  [addspace [.custaddre get]]
set p  [.custphone get]
set pd [.custpwd1e get]
set attrs {}
lappend attrs $custid $n $a $p $pd
lappend custlist $attrs
.custsignupsuc configure -text "SIGN UP SUCCESSFUL:: YOUR UNIQUE ID IS:   $custid \n NOW YOU CAN LOGIN WITH UR LOGIN DETAILS"
foreach n {.custnamee .custaddre .custphone .custpwd1e .custpwd2e} {$n delete 0 end}
place .custsignupsuc -x 100 -y 200
incr custid
} else { .custsignupsuc configure -text "SIGN-UP NOT SUCCESSFUL:  SORRY"}
place .custsignupsuc -x 100 -y 200
place .custexit -x 100 -y 250
}

proc custsignin {} {
forgetting
.enteride  delete 0 end
.enterpwde delete 0 end
place .enteridl  -x 100 -y 200
place .enterpwdl -x 100 -y 250
place .enteride  -x 350 -y 200
place .enterpwde -x 350 -y 250
bind .enterpwde <Return> {processsignin}
}

proc processsignin {} {
forgetting
global custorderlist
global custlist
global globalid
set id [.enteride  get]
set pd [.enterpwde get]
set len [llength $custlist]
set count 0
if { $len == 0 } {
.custsigninsuc configure -text "USER-ID IS INCORRECT: LOGIN AGAIN:"
place .custexit -x 100 -y 250
}
while { $count < $len } {
set atts [lindex $custlist $count]
if {[lindex $atts 0] == $id } {
if { [string compare [lindex $atts 4] $pd] == 0  } {
.custsigninsuc configure -text "SIGNIN SUCCESSFUL"
set globalid $id
global custorder$globalid
set custorder$globalid {}
place .custmenucont -x 100 -y 250
} else {
.custsigninsuc configure -text "PASSWORD IS INCORRECT LOGIN AGAIN:"
place .custexit -x 100 -y 250

}
break
} else {
.custsigninsuc configure -text "USER-ID IS INCORRECT: LOGIN AGAIN:"
place .custexit -x 100 -y 250
}
incr count
}
place .custsigninsuc -x 100 -y 200
}


proc custseepro {} {
forgetting
.textarea delete 0 end
global products
if { [llength $products] != 0 } {
set count 0
.textarea insert end "ITEM-ID   PRODUCT-NAME        PRODUCT-TYPE   PRICE QUANTITY"
.textarea insert end "-----------------------------------------------------------"
while { $count < [llength $products]} {
set id   [formatcor [lindex [lindex $products $count] 0] 10]
set name [formatcor [lindex [lindex $products $count] 1] 20]
set type [formatcor [lindex [lindex $products $count] 2] 15]
set pric [formatcor [lindex [lindex $products $count] 3] 6]
set quan [formatcor [lindex [lindex $products $count] 4] 4]
.textarea insert end $id$name$type$pric$quan
incr count
}
place .prohead -x 100 -y 150
place .textarea -x 100 -y 200 
place .srl_y -x 745 -y 200 -height 203
place .srl_x -x 100 -y 402 -width 650
place .placeorder -x 100 -y 460
place .custmenuback -x 100 -y 510
} else {
place .noitems -x 100 -y 350
place .custmenucont -x 100 -y 400
}
}

proc getquantity { atts id count } {
forgetting
custseepro
global products
global globalid
global custorder$globalid
place forget .placeorder
place forget .custmenuback
place .enterproqtl -x 100 -y 460
place .enterproqte -x 100 -y 510
bind .enterproqte <Return> {
set q [.enterproqte get]
if { $q <= [lindex $atts 4]} {
.enterproqte delete 0 end;
place forget .enterproqtl
place forget .enterproqte
forgetting
set ol {}
set atts [lreplace $atts 4 4 [expr [lindex $atts 4] - $q]]
set products [lreplace $products $count $count $atts]
lappend ol $id $q [lindex $atts 1]
lappend  custorder$globalid  $ol
upvar #0 custorder$globalid ord
place .ordersuc -x 100 -y 200
place .ordercon -x 100 -y 250
place .orderenu -x 100 -y 300
} else { .enterproqte delete 0 end; forgetting; place .quanerror -x 100 -y 350; place .orderagain -x 100 -y 400 }}}




proc placeorder {} {
forgetting
custseepro
global products
global globalid
global custorder$globalid
place forget .placeorder
place forget .custmenuback
place .enterproidl -x 100 -y 460
place .enterproide -x 100 -y 510
bind .enterproide <Return> {
forgetting
set id [.enterproide get]
set count 0
.enterproide delete 0 end
set len [llength $products]
while { $count < $len } {
set atts [lindex $products $count]
if {[lindex $atts 0] == $id } {
getquantity $atts $id $count
break
}  
incr count
}
if { $len == $count } {
forgetting
place .itemerror -x 100 -y 460
place .orderagain -x 100 -y 510
}
}}

proc custseeord {} {
forgetting
global globalid 
.textarea delete 0 end
global custorderlist
set count 0
set flag 0
set len [llength $custorderlist]
while { $count < $len } {

if {$globalid == [lindex [lindex [lindex $custorderlist $count] end] end]} {
.textarea insert end "ORDER ID:[lindex [lindex [lindex $custorderlist $count] end] 1] ---  TIME:[lindex [lindex [lindex $custorderlist $count] end] 0]"
prepareorderdisp [lindex $custorderlist $count]
incr flag
}
incr count
}
if { $flag > 0 } {
place .textarea -x 100 -y 200 
place .srl_y -x 745 -y 200 -height 203
place .srl_x -x 100 -y 402 -width 650 
place .custmenucont -x 100 -y 510
} else { 
place .noordermsg -x 100 -y 250
place .custmenucont -x 100 -y 300
}
}

proc prepareorderdisp { order } {
set len [expr [llength $order] - 1]
set count 0
global products
.textarea insert end "----------------------------------------------------------"
.textarea insert end "PRODUCT-ID  QUANTITY  PRODUCT-NAME      "
while { $count < $len } {
set atts [lindex $order $count]
set id [formatcor [lindex $atts 0] 12]
set qt [formatcor [lindex $atts 1] 10]
set nm [formatcor [lindex $atts 2] 20]
.textarea insert end $id$qt$nm
incr count
}
.textarea insert end "----------------------------------------------------------"
}
proc customerfuncts {} {
forgetting
place .custseepro -x 100 -y 200
place .custseeord -x 100 -y 250
place .custlogout -x 100 -y 300
}

proc customermenu {} {
forgetting
place forget .about
place forget .exittoexit
place .exittohome   -x 575 -y 550
place .newcustlog -x 100 -y 200
place .oldcustlog -x 100 -y 400
}


proc forgetting {} {
place forget .management
place forget .ordernill
place forget .prohead
place forget .orderagain
place forget .custseepro
place forget .custseeord
place forget .custlogout
place forget .enteride
place forget .enterpwde
place forget .enteridl
place forget .enterpwdl
place forget .custcont
place forget .custexit
place forget .customer
place forget .newcustlog
place forget .oldcustlog
place forget .newcustlog
place forget .oldcustlog
place forget .custsignupsuc
place forget .custsigninsuc
place forget .processsignup
place forget .custmenucont
place forget .srl_x
place forget .srl_y
place forget .textarea
place forget .noitems
place forget .enterproidl
place forget .enterproqtl
place forget .enterproide
place forget .enterproqte
place forget .placeorder
place forget .ordersuc
place forget .orderenu
place forget .ordercon
place forget .quanerror
place forget .custmenuback
place forget .noordermsg
set q e
foreach n {.custname .custaddr .custphon .custpwd1 .custpwd2} {
set x  200
foreach z { l e } {
place forget $n$z}}
}
##########################################################################################################################################################################

##########################################################################################################################################################################
##########################################################################################################################################################################
proc addpro {} {
global itemid
set atts {}
forgettings
set name  [addspace [.namee get]]
set type  [addspace [.typee get]]
set pric  [addspace [.price get]]
set quan  [addspace [.quane get]]
.namee delete 0 end
.typee delete 0 end
.price delete 0 end
.quane delete 0 end
if { [string compare $name ""] == 1 && [string compare $name ""] == 1 && [string compare $name ""] == 1 && [string compare $name ""] == 1 } {
lappend atts $itemid
lappend atts $name
lappend atts $type
lappend atts $pric
lappend atts $quan
global products
lappend products $atts
incr itemid
place .addsuc -x 100 -y 200
} else {
place .adduns -x 100 -y 200
}

place .mgmtcont -x 100 -y 250
}

proc delete {} {
forgettings
global products
set flag 0
set count 0
set len [llength $products]
if { [string compare [.mgmtitemdelide get] ""] != 0 } {
while { $count <= $len } {
set atts [lindex $products $count]
if {[lindex $atts 0] == [.mgmtitemdelide get]} {set products [lreplace $products $count $count]; incr flag;}
incr count
}
place forget .mgmtdelcont
if { $flag != 0 } {
place .deletesuccess -x 100 -y 200
} else {
place .deleteunsucce -x 100 -y 200
}} else { 
place forget .mgmtdelcont
place .givid -x 100 -y 200
}
place .mgmtcont -x 100 -y 250
}

proc mgmtseecus {} {
.textarea delete 0 end
forgettings
global custlist
if { [llength $custlist] != 0 } {
set count 0
.textarea insert end "ID    CUSTOMER-NAME       ADDRESS             PHONE       "
.textarea insert end "----------------------------------------------------------"
while { $count < [llength $custlist]} {
set id   [formatcor [lindex [lindex $custlist $count] 0] 6]
set name [formatcor [lindex [lindex $custlist $count] 1] 20]
set type [formatcor [lindex [lindex $custlist $count] 2] 20]
set pric [formatcor [lindex [lindex $custlist $count] 3] 12]
.textarea insert end $id$name$type$pric
incr count
}
place .cushead -x 100 -y 150
place .textarea -x 100 -y 200 
place .srl_y -x 745 -y 200 -height 203
place .srl_x -x 100 -y 402 -width 650
place .mgmtcont -x 100 -y 510
} else {
place .noitems -x 100 -y 350
place .mgmtcont -x 100 -y 400
}
}

proc mgmtseeord {} {
forgetting
forgettings
.textarea delete 0 end
global custorderlist
if { [llength $custorderlist] != 0 } {
set count 0
set flag 0
set len [llength $custorderlist]
while { $count < $len } {
.textarea insert end "CUSTOMER ID:[lindex [lindex [lindex $custorderlist $count] end] 2] ----\
 ORDER ID:[lindex [lindex [lindex $custorderlist $count] end] 1] ---  TIME:[lindex [lindex [lindex $custorderlist $count] end] 0]" 
prepareorderdisp [lindex $custorderlist $count]
.textarea insert end "**********************************************************************"
incr count
}
place .textarea -x 100 -y 200 
place .srl_y -x 745 -y 200 -height 203
place .srl_x -x 100 -y 402 -width 650 
place .mgmtcont -x 100 -y 510
} else { 
place .noordermsg -x 100 -y 250
place .mgmtcont -x 100 -y 300
}
}


proc mgmtdelpro {} {
global products
forgettings
mgmtseepro
.mgmtitemdelide delete 0 end
place forget .mgmtcont
if { [llength $products] > 0 } {
place .mgmtitemdelidl -x 100 -y 460
place .mgmtitemdelide -x 100 -y 510
place .mgmtdelcont -x 400 -y 510
} else {
place .noitems -x 100 -y 200
place .mgmtcont -x 100 -y 250
}}

proc mgmtaddpro {} {
global itemid
forgettings
set yval 200
foreach n {.name .type .pric .quan} {
set xval 150
foreach z {l e} {
place $n$z -x $xval -y $yval
incr xval 180
}
incr yval 50
}
place .mgmtaddcont -x $xval -y $yval
}


proc mgmtseepro {} {
.textarea delete 0 end
forgettings
global products
if { [llength $products] != 0 } {
set count 0
.textarea insert end "ITEM-ID   PRODUCT-NAME        MANUFACTURER    PRICE QUANTITY"
.textarea insert end "-----------------------------------------------------------"
while { $count < [llength $products]} {
set id   [formatcor [lindex [lindex $products $count] 0] 10]
set name [formatcor [lindex [lindex $products $count] 1] 20]
set type [formatcor [lindex [lindex $products $count] 2] 15]
set pric [formatcor [lindex [lindex $products $count] 3] 6]
set quan [formatcor [lindex [lindex $products $count] 4] 4]
.textarea insert end $id$name$type$pric$quan
incr count
}
place .cushead -x 100 -y 150
place .textarea -x 100 -y 200 
place .srl_y -x 745 -y 200 -height 203
place .srl_x -x 100 -y 402 -width 650
place .mgmtcont -x 100 -y 510
} else {
place .nocusts -x 100 -y 350
place .mgmtcont -x 100 -y 400
}
}

proc managementfunctions {} {
forgettings
place .mgmtaddpro -x 100 -y 200
place .mgmtdelpro -x 100 -y 250
place .mgmtseepro -x 100 -y 300
place .mgmtseecus -x 100 -y 350
place .mgmtseeord -x 100 -y 400
place .exits      -x 100 -y 450
}

proc managementlogin {} {
forgettings
set id [.logine  get]
set pw [.passwde get]
.logine  delete 0 end
.passwde delete 0 end
if { [string compare $id "M"] == 0 && [string compare $pw "P"] == 0 } {
place .mgmtlogsuccess0 -x 100 -y 200
place .mgmtcont -x 100 -y 250
} else {
place .mgmtlogsuccess1 -x 100 -y 200
place .management -x 100 -y 250
}
}

proc  managementloginscreen { } {
forgettings
place forget .exittoexit
place forget .about
place .exittohome  -x 575 -y 550
place .loginl -x 100 -y 200
place .logine  -x 350 -y 200
place .passwdl -x 100 -y 250
place .passwde -x 350 -y 250
bind .passwde <Return> {managementlogin}
}
proc start {} {
forgettings
forgetting
place forget .exittohome
place .exittoexit  -x 575 -y 550
place .about       -x 15 -y 550
place .customer -x 200 -y 350
place .management -x 200 -y 250
}

proc forgettings {} {
place forget .customer
place forget .management
place forget .mgmtlogsuccess1
place forget .logine
place forget .loginl
place forget .passwdl
place forget .passwde
place forget .mgmtaddcont
foreach n {.name .type .pric .quan} {
foreach z {l e} {
place forget $n$z
}
}
place forget .mgmtseeord
place forget .nocusts
place forget .cushead
place forget .mgmtseecus
place forget .mgmtitemdelide
place forget .mgmtitemdelidl
place forget .mgmtdelpro
place forget .exits
place forget .textarea
place forget .srl_x
place forget .srl_y
place forget .mgmtaddpro
place forget .mgmtdelpro
place forget .exits
place forget .mgmtseepro
place forget .mgmtlogsuccess0
place forget .mgmtcont
place forget .deletesuccess
place forget .deleteunsucce
place forget .noitems
place forget .textarea
place forget .srl_x
place forget .srl_y
place forget .addsuc
place forget .adduns
place forget .givid
place forget .prohead1
}
global orderid
set orderid 10000
global itemid
set itemid 100007
global globalid
set globalid 0
global custlist
global products
global custorderlist
set custorderlist {{{100001 5 Television} {12:14-Mar-16-2009 10000 1000}} {{100001 5 Television} \
 {12:14-Mar-16-2009 10001 1000}} {{100002 8 laptop} {12:15-Mar-16-2009 10002 1001}}}
set products {{100001 Television onida 15000 50} \
{100002 laptop sony 55000 54} {100003 desktop_computer hp 35000 35} \
{100004 pendrives transcend 500 36} {100005 digital_cameras kodak 15000 150}\
 {100006 Microwave_owen lg 15000 30}}
set custlist {{1000 Sreemannarayana Mahabubabad 9988803302 avin} {1001 Avinash Thandur 9888125335 sree}}
global custid
set custid 1002
wm title . "*****************************  BEST_BUY SUPERMARKET  ******************************"
canvas .sreeman -width 800 -height 600 -bg gray30
label .title -text  "WELCOME TO THE BEST-BUY SUPER MARKET \n ONLINE PURCHASE SYSTEM:" -font { helvetica 25 }  

place .title -x 40 -y 50
button .mgmtseeord -text "VIEW ALL THE ORDERS MADE BY CUSTS:" -command "mgmtseeord"   
button .mgmtseepro -text "VIEW THE PRODUCTS IN  STOCK LIST :" -command "mgmtseepro"   
button .mgmtseecus -text "VIEW  THE  REGISTERED CUSTOMERS  :" -command "mgmtseecus"   
button .mgmtaddpro -text "ADD  NEW  PRODUCT TO  STOCK LIST :" -command "mgmtaddpro"   
button .mgmtdelpro -text "DELETE A PRODUCT FROM STOCK LIST :" -command "mgmtdelpro"   
button .mgmtcont -text "CONTINUE TO MANAGENENT FUNCTIONS:" -command "managementfunctions"   
button .mgmtaddcont -text "CONTINUE:" -command "addpro"   
button .mgmtdelcont -text "CONTINUE:" -command "delete"   
button .exits -text      "                         LOG OUT:" -command "start"   
button .management -text "ARE YOU THE MANAGER: CLICK HERE:" -command "managementloginscreen"   
button .customer   -text "ARE YOU A CUSTOMER : CLICK HERE:" -command "customermenu"   
button .newcustlog -text "NEW CUSTOMERS    : SIGN UP TO GET ID AND PASSWORD:" -command "custsignup"   
button .oldcustlog -text "EXISTING CUSTOMER: LOGIN WITH YOUR CREDENTIALS   :" -command "custsignin"
button .processsignup -text "CONTINUE:" -command "processcustsignup"   
button .custexit -text "CONTINUE:" -command "start"   
button .custcont -text "CONTINUE:" -command "custsignin"   

button .custmenuback -text "BACK TO CUSTOMER MENU:" -command "customerfuncts"   
button  .placeorder  -text "PLACE A NEW ORDER NOW:" -command "placeorder"   
label .ordersuc -text "ORDER RECEIVED:"   
label .ordernill -text "NO ORDERS PLACED BY TILL NOW:"   
label .prohead -text "PRODUCTS AVAILABLE FOR YOU TO BUY:"   
label .enterproidl -text "ENTER THE PRODUCT ID FROM ABOVE LIST YOU WISH TO PURCHASE"   
label .enterproqtl -text "ENTER THE QUANTITY OF THE PRODUCT YOU SELECTED PREVIOUSLY"   
label .custnamel -text "ENTER YOUR NAME :"   
label .custaddrl -text "ENTER ADDRESS   :"   
label .custphonl -text "ENTER PHONE NUM :"   
label .custpwd1l -text "ENTER PASSWORD  :"   
label .custpwd2l -text "REENTER PASSWORD:"    
label .noordermsg -text "SORRY: YOU HAVEN'T PLACED ANY ORDERS YET:"   
label .custsignupsuc   
label .custsigninsuc   
label .enteridl  -text "ENTER YOUR UNIQUE USER ID:"   
label .enterpwdl -text "ENTER YOUR PASSWORD      :"   
label .itemerror -text "ITEM NOT FOUND.... PLEASE ENTER AGAIN:"   
label .quanerror -text "QUANTITY EXCEEDS.. PLEASE ENTER AGAIN:"   

set msg "Developed by A.Sreemannarayana Raju\nPhone No: +919966603320\nEmail Id: ambati.raju@tcs.com"

entry .custident -width 4   
entry .custpwd1e -show *   
entry .custpwd2e -show *   
entry .custnamee -width 25   
entry .custaddre -width 25   
entry .enteride -width 4   
entry .enterpwde -show *   
entry .custphone -width 11   
entry .enterproide   
entry .enterproqte   
grid .sreeman -in . -row 1 -column 1
button .custmenucont -text "CONTINUE TO CUSTOMER MENU:" -command "customerfuncts"   
button .custseepro -text "VIEW ALL THE PRODUCTS AVAILABLE:" -command "custseepro"   
button .custseeord -text "VIEW THE ORDERS PLACED BY YOU  :" -command "custseeord"   
button .custlogout -text "LOG OUT:"                            -command "start"   
button .orderagain -text "ORDER AGAIN:" -command "place forget .orderagain; place forget .itemerror; placeorder"
button .ordercon -text "ORDER FOR ANOTHER PRODUCT:" -command "placeorder"
button .orderenu -text "EXIT FROM ORDER MENU:" -command {global globalid
                                                        global orderid
                                                        global custorder$globalid
                                                       if { $globalid != 0 } {
                                                         upvar #0 custorder$globalid ord
                                                       if {[llength  $ord] > 0 } {
                                                           set gst {}
                                                           lappend gst   [clock format [clock sec] -format %R-%b-%d-%Y] $orderid  $globalid
                                                             lappend ord $gst
                                                             lappend custorderlist $ord 
                                                          }}
                                                          incr orderid 
                                                        
                                                          set custorder$globalid {}
                                                          customerfuncts
                                                       }
button .exittohome -text "RETURN TO HOME  PAGE" -command "start"                                                       
button .exittoexit -text "EXIT FROM THE WIZARD" -command exit                                                       
button .about  -text "DEVELOPER" -highlightthickness 0 -command {
        tk_messageBox -title "DEVELOPER" -message $msg}
  

listbox .textarea -yscrollcommand ".srl_y set" -xscrollcommand ".srl_x set" -width 70 -height 11
scrollbar .srl_y -command ".textarea yview" -orient v
scrollbar .srl_x -command ".textarea xview" -orient h
label .cushead -text "CUSTOMERS REGISTERED FOR ONLINE PURCHASAL SYSTEM:"
label .nocusts -text "NO CUSTOMERS REGISTERED YET:"
label .loginl -text "ENTER YOUR UNIQUE USER ID:"
label .passwdl -text "ENTER YOUR PASSWORD:"
label .mgmtlogsuccess1 -text "LOGIN NOT SUCCESSFUL:"
label .mgmtlogsuccess0 -text "SUCCESSFULLY LOGGED IN:"
label .mgmtitemdelidl -text "ENTER THE ID OF ITEM TO DELETE:"
label .deletesuccess -text "ITEM DELETED SUCCESSFULLY:"
label .deleteunsucce -text "ITEM NOT FOUND"
label .noitems -text "NO ITEMS IN STOCK LIST :"
label .addsuc -text "ITEM ADDED SUCCESSFULLY:"
label .adduns -text "ITEM NOT ADDED: ERROR IN THE DETAILS:"
label .givid -text "ID OF THE ITEM TO BE DELETED IS NOT GIVEN:"
label .namel -text "PRODUCT NAME    " 
label .typel -text "MANUFACTURER    "
label .pricl -text "PRODUCT PRICE   "
label .quanl -text "PRODUCT QUANTITY"
label .prohead1 -text "PRODUCTS AVAILABLE IN THE STOCK:"
entry .namee
entry .typee
entry .price
entry .quane

entry .logine
entry .passwde -show *
entry .mgmtitemdelide -width 6
.sreeman create rect 0 0 800 600 -width 30 -outline gray70
grid .sreeman -in . -row 1 -column 1
start
     wm resizable . 0 0
======