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: [email protected]"
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