#!/usr/local/bin/wish8.0
#!/usr/bin/wish
#
#NAME
#  DC - Desk Calculator
#
#SYNOPSIS
#  DC &
#
DESCRIPTION
#  This is a tcl version of the dc command.  It's my own  calculator,
#  with  buttons  however  I  feel like arranging them at the moment.
#  It's often handy to have this one around when the  fancy  ones  in
#  the  library  won't  do what you want.  Just add another button or
#  three, and bind them to a proc ...
#
#AUTHOR
# John Chambers <jc@trillian.mit.edu>

set me [lindex [wm title .] 0]
wm title . "JC's RPN Calculator"
if [info exists env(D_$me)] {set D $env(D_$me)} else {set D 0}
if [info exists env(B_$me)] {set B $env(B_$me)} else {set B 1}
if [info exists env(R_$me)] {set R $env(R_$me)} else {set R raised}
puts "me=\"$me\" B=\"$B\" D=\"$D\""

set EF {-expand 1 -fill x}
set FB {-bd $B -relief ridge}	;# Frame borders
set BB {-bd 3 -relief raised}	;# Button borders

set Apfx {}
set Base 10
set Bshow 0		;# The display value in the current base.
set Bstack {}	;# The stack converted to the current base.
set Dshow 0		;# The current display value in decimal.
set Dstack {}	;# The stack in decimal.
set new 1

proc Base {b x} {
	global D Apfx
	if {$D>1} {puts "Base $b x=\"$x\""}
	if {$x == {}} {
		set v [set Bshow [set Dshow $Apfx]]
	} else {
		set xx {}
		regexp {(.*)(\.)(.*)} $x xx xi xd xf
		switch $b {
		{8}  {set v [format {0%o}  $x]}
		{16} {set v [format {0x%X} $x]}
		{10} {if {$xx == {}} {set v [format {%d} $x]} else {set v $x}}
		default	{set v $x}
		}
		if {$D>1} {puts "Base $b x=\"$x\" v=\"$v\""}
	}
	return $v
}

proc Show {v} {
	global D Base Bshow new Dshow Dstack
	if {$D} {puts "Show \"$v\""}
	set Dshow $v
		set Bshow [Base $Base $v]
	if {$D} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 0
}

eval frame .v  -bd 3 -relief ridge
eval entry .v.dshow -textvariable Bshow
eval pack .v.dshow -in .v -side bottom $EF
eval pack .v -side top $EF

proc B_show {name element op} {
	global D Base
	if {$D>1} {puts "B_show: name=\"$name\""}
	upvar #0 $name x
	if {$D>1} {puts "Var $name set to \"$x\""}
	Show $x
}

proc BaseVar {name element op} {
	global D Base
	if {$D>1} {puts "BaseVar: name=\"$name\""}
	if {$element != {}} {
		set name ${name}($element)
		if {$D>1} {puts "BaseVar: Array name=\"$name\""}
	}
	if {$D>1} {puts "BaseVar: name=\"$name\""}
	upvar #0 $name x
	if {$D>1} {puts "Var $name set to \"$x\""}
	upvar #0 b_$name y
#	set y $x
	set y [Base $Base $x]
	if {$D>1} {puts "Var $name set to $x = $y"}
}

set errmsg {}
eval frame .m  -bd 3 -relief ridge
eval entry .m.msg -textvariable errmsg -fg orange -highlightthickness 0 -width 0
eval pack .m.msg -in .m $EF
eval pack .m -side bottom $EF

eval frame .t  -bd 3 -relief ridge
#eval button .t.bPop $BB -text Pop -command Pop
#pack .t.bPop -in .t -side left
#eval button .t.bClear $BB -text Clear -command Clear
#pack .t.bClear -in .t -side left

eval menubutton .t.bStack -bd 3 -relief ridge -text Stack -menu .t.bStack.menu
pack .t.bStack -in .t -side left
eval menubutton .t.bBase -bd 3 -relief ridge -text Base -menu .t.bBase.menu
pack .t.bBase -in .t -side left
eval button .t.bQUIT $BB -text QUIT -command exit
pack .t.bQUIT -in .t -side right
eval pack .t -side top $EF
#eval button .t.bEnter $BB -text ENTER -command Enter
#pack .t.bEnter -in .t -side left

eval frame .t.dbg $FB
pack .t.dbg -in .t -side left
eval menubutton .t.dbg.l -bd 3 -relief ridge -text Dbg -menu .t.dbg.l.menu
eval menu .t.dbg.l.menu 
.t.dbg.l.menu add command -label Up    -command {incr D}
.t.dbg.l.menu add command -label Down  -command {incr D -1}
.t.dbg.l.menu add command -label Clear -command {set D 0}
eval entry .t.dbg.v -textvariable D -width 1
pack .t.dbg.l .t.dbg.v -in .t.dbg -side left

menu .t.bBase.menu
.t.bBase.menu add command -label Hex -command HexBase
.t.bBase.menu add command -label Dec -command DecBase
.t.bBase.menu add command -label Oct -command OctBase
.t.bBase.menu add command -label Bin -command BinBase

menu .t.bStack.menu
.t.bStack.menu add command -label Show -command ShowStack
.t.bStack.menu add command -label Hide -command HideStack
.t.bStack.menu add command -label Scroll -command ScrollStack

set stacksize 4
proc ScrollStack {} {
	global B D EF BB FB new Dshow stacksize
	if {$D>1} {puts "ScrollStack called."}
	ShowStack
	if ![winfo exists .v.st.sb] {
		scrollbar .v.st.sb -command {.v.st.ck yview}
		pack .v.st.sb -in .v.st -side right -fill y
		.v.st.ck config -yscrollcommand {.v.st.sb set}
		.v.st.ck config -height $stacksize
	}
	FillStack
	if {$D>1} {puts "ScrollStack done."}
}

proc ShowStack {} {
	global B D EF BB FB new Bshow Bstack Dshow Dstack
	if {$D>1} {puts "ShowStack called."}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	if [winfo exists .v.st] {destroy .v.st}
	eval frame .v.st -bd 0
	eval pack .v.st -in .v -side top -expand 1 -fill both
	if ![winfo exists .v.st.ck] {
		eval listbox .v.st.ck $FB
		eval pack .v.st.ck -in .v.st -side left $EF
	}
	FillStack
	.v.st.ck config -height 0
	if {$D>1} {puts "ShowStack done."}
}

proc FillStack {} {
	global B D BB FB new Bshow Bstack Dshow Dstack
	.v.st.ck delete 0 end
	set n 0
	foreach x $Bstack {
		.v.st.ck insert 0 $x
		incr n
	}
}

proc HideStack {} {
	global D new Bshow Bstack Dshow Dstack
	if {$D>1} {puts "HideStack called."}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	if [winfo exists .v.st] {destroy .v.st}
}

proc ReBase {} {
	global B D Base Bshow Bstack Dshow Dstack
	if {$D>4} {puts "ReBase ..."}
	set Bstack {}
	foreach x $Dstack {
		lappend Bstack [Base $Base $x]
		if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
		if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	}
	if [winfo exists .v.st.ck] {FillStack}
}

proc OctBase {} {
	global D Base Dshow
	set Base 8
	set Apfx 0
	decbuts right
	Show $Dshow
	ReBase
}
proc DecBase {} {
	global D Apfx Base Dshow
	set Base 10
	set Apfx {}
	decbuts right
	Show $Dshow
	ReBase
}
proc HexBase {} {
	global D Base Dshow
	set Base 16
	set Apfx 0x
	hexbuts right
	Show $Dshow
	ReBase
}
proc BinBase {} {global errmsg; set errmsg "Bin not implemented yet."}

proc Args {n} {
	global D a args new Dshow Dstack
	set a(1) $Dshow
	set a(2) [Pop]
	set args $n
	if {$D}  {puts "args $args a(1) \"$a(1)\" a(2) \"$a(2)\" Dshow \"$Dshow\" Dstack {$Dstack}"}
}

proc Swap {} {
	global D new Dshow Dstack a
	if {$D>1} {puts "Swap called."}
	Args 2
	Push $a(1)
	Show $a(2)
	set new 1
}

proc Add {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "Add called."}
	Args 2
	Show [expr $Apfx$a(1) + $Apfx$a(2)]
	if {$D>1} {puts "Add $Apfx$a(1) + $Apfx$a(2) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc Sub {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "Sub called."}
	Args 2
	Show [expr $Apfx$a(2) - $Apfx$a(1)]
	if {$D>1} {puts "Sub $Apfx$a(2) - $Apfx$a(1) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc Mul {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "Mul called."}
	Args 2
	Show [expr $Apfx$a(1) * $Apfx$a(2)]
	if {$D>1} {puts "Mul $Apfx$a(1) * $Apfx$a(2) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc Div {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "Div called."}
	Args 2
	Show [expr $Apfx$a(2) / $Apfx$a(1)]
	if {$D>1} {puts "Div $Apfx$a(2) / $Apfx$a(1) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc div {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "div called."}
	Args 2
	Show [expr $Apfx$a(2) / $Apfx$a(1)]
	if {$D>1} {puts "div int($a(2) / int($a(1)) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc lsh {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "lsh called."}
	Args 2
	Show [expr int($a(2)) << int($a(1))]
	if {$D>1} {puts "lsh int($a(2)) << int($a(1)) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc rsh {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "rsh called."}
	Args 2
	Show [expr int($a(2)) >> int($a(1))]
	if {$D>1} {puts "rsh int($a(2)) >> int($a(1)) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc mod {} {
	global D Apfx a new Dshow Dstack
	if {$D>1} {puts "mod called."}
	Args 2
	Show [expr int($a(2)) % int($a(1))]
	if {$D>1} {puts "mod int($a(2) % int($a(1)) = $Dshow"}
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 1
}

proc App {c} {
	global D Bshow new Dshow
	if {$D>1} {puts "App c=\"$c\" Dshow=\"$Dshow\" new=\"$new\""}
	if {$new} {Show {}}
	Show ${Bshow}$c
}

proc Erase {} {
	global D new Dshow Dstack
	regsub {.$} $Dshow {} x
	Show $x
	if {$D}  {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	set new 0
}

proc Clear {} {
	global D Apfx new Dshow
	Show {}
	set new 1
}

proc Enter {} {
	global D new Bshow Bstack Dshow Dstack
	if {$D}  {puts "Enter called."}
	set Dshow [expr 0 + $Bshow]	;# Convert displayed value to decimal.
	set Dstack [linsert $Dstack 0 $Dshow]
	set Bstack [linsert $Bstack 0 $Bshow]
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	if [winfo exists .v.st.ck] {FillStack}
	if [winfo exists .v.st.sb] {.v.st.ck see end}
	set new 1
}

proc Pop {} {
	global D new Bshow Bstack Dshow Dstack
	if {[llength $Dstack] > 0} {
		Show [lindex $Dstack 0]
		set Dstack [lreplace $Dstack 0 0]
		set Bstack [lreplace $Bstack 0 0]
		if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
		if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	} else {
		if {$D}  {puts "Empty Dstack"}
	}
	set new 1
	if [winfo exists .v.st.ck] {FillStack}
	if [winfo exists .v.st.sb] {.v.st.ck see end}
	return $Dshow
}

proc Push {args} {
	global D new Bshow Bstack Dshow Dstack
	if {$D>1} {puts "Push {$args} called."}
	set Dstack [linsert $Dstack 0 $args]
	set Bstack [linsert $Bstack 0 $args]
	if {$D>2} {puts "Dshow \"$Dshow\" Dstack {$Dstack}"}
	if {$D>3} {puts "Bshow \"$Bshow\" Bstack {$Bstack}"}
	Show [lindex $Dstack 0]
	if [winfo exists .v.st.ck] {FillStack}
	if [winfo exists .v.st.sb] {.v.st.ck see end}
	set new 1
}

eval frame .b  -bd 3 -relief ridge
eval pack .b -side top $EF

# Build the function-button frame and fill it with buttons.
proc cmdbuts {where} {
	global B D EF BB FB
	if [winfo exists .b.cmd] {destroy .b.cmd}
	eval frame .b.cmd $FB
	eval pack .b.cmd -in .b -side $where -expand 1
	eval frame .b.cmd.ca $FB
	eval frame .b.cmd.c1 $FB
	eval pack .b.cmd.ca -in .b.cmd -side left
	eval pack .b.cmd.c1 -in .b.cmd -side left
	eval button .b.cmd.bMul $BB -text * -command Mul
	eval pack .b.cmd.bMul -in .b.cmd.ca -side top
	eval button .b.cmd.bDiv $BB -text / -command Div
	eval pack .b.cmd.bDiv -in .b.cmd.ca -side top
	eval button .b.cmd.bAdd $BB -text + -command Add
	eval pack .b.cmd.bAdd -in .b.cmd.ca -side top
	eval button .b.cmd.bSub $BB -text - -command Sub
	eval pack .b.cmd.bSub -in .b.cmd.ca -side top
	eval button .b.cmd.bClear $BB -text Clear -command Clear
	eval pack .b.cmd.bClear -in .b.cmd.c1 -side top
	eval button .b.cmd.bPop $BB -text Pop -command Pop
	eval pack .b.cmd.bPop -in .b.cmd.c1 -side top
	eval button .b.cmd.bNeg $BB -text Neg -command bNeg
	eval pack .b.cmd.bNeg -in .b.cmd.c1 -side top
	eval button .b.cmd.bEnter $BB -text ENTER -command Enter
	eval pack .b.cmd.bEnter -in .b.cmd.c1 -side top
}

# Build the function-button frame and fill it with buttons.
proc fctbuts {where} {
	global B D EF BB FB
	if [winfo exists .b.fct] {destroy .b.fct}
	eval frame .b.fct $FB
	eval pack .b.fct -in .b -side $where
	eval frame .b.fct.ca $FB
	eval frame .b.fct.c1 $FB
	eval frame .b.fct.c2 $FB
	eval frame .b.fct.c3 $FB
	eval pack .b.fct.ca -in .b.fct -side right
	eval pack .b.fct.c1 -in .b.fct -side left
	eval pack .b.fct.c2 -in .b.fct -side left
	eval pack .b.fct.c3 -in .b.fct -side left
	eval button .bdiv $BB -text {div} -command div
	eval pack .bdiv -in .b.fct.c2 -side top
	eval button .bmod $BB -text {mod} -command mod
	eval pack .bmod -in .b.fct.c2 -side top
	eval button .bErase $BB -text {<==} -command Erase
	eval pack .bErase -in .b.fct.c2 -side top
	eval button .bSwap $BB -text {<->} -command Swap
	eval pack .bSwap -in .b.fct.c2 -side top
	eval button .bint $BB -text {int} -command {{Show [expr int($Dshow)]}}
	eval pack .bint -in .b.fct.c3 -side top
	eval button .bdec $BB -text {dec} -command {{Show [expr double($Dshow)]}}
	eval pack .bdec -in .b.fct.c3 -side top
	eval button .blsh $BB -text {<<} -command lsh
	eval pack .blsh -in .b.fct.c3 -side top
	eval button .brsh $BB -text {>>} -command rsh
	eval pack .brsh -in .b.fct.c3 -side top
}

# Produce the decimal digit-button frame and fill it.
proc decbuts {where} {
	global B D EF BB FB
	if [winfo exists .b.digs] {destroy .b.digs}
	eval frame .b.digs $FB
	eval pack .b.digs -in .b -side $where
	set n 0
	for {set r 0} {$r < 4} {incr r} {
		eval frame .b.digs.r$r
		for {set c 0} {$c < 3} {incr c} {
			set n [expr 9 - ($r * 3 + $c)]
			if {$n > 0} {
				if ![winfo exists .b$n] {eval button .b$n $BB -text $n -command b$n}
				eval pack .b$n -in .b.digs.r$r -side right $EF
			}
		}
		eval pack .b.digs.r$r -in .b.digs -side top
	}
	if ![winfo exists .bdot] {eval button .bdot $BB -text . -command bDot}
	if ![winfo exists .b0]   {eval button .b0   $BB -text 0 -command b0}
	if ![winfo exists .bneg] {eval button .bneg $BB -text - -command bNeg}
	eval pack .bdot -in .b.digs.r3 -side left $EF
	eval pack .b0 -in .b.digs.r3 -side left $EF
	eval pack .bneg -in .b.digs.r3 -side right $EF
}

# Produce the hexadecimal digit-button frame and fill it.
proc hexbuts {where} {
	global B D EF BB FB
	if [winfo exists .b.digs] {destroy .b.digs}
	eval frame .b.digs $FB
	eval pack .b.digs -in .b -side $where
	set n 0
	for {set r 0} {$r < 4} {incr r} {
		eval frame .b.digs.r$r
		for {set c 0} {$c < 4} {incr c} {
			set i [expr 15 - ($r * 4 + $c)]
			set n [format {%X} $i]
			if {$D>1} {puts "hexbuts: r=$r c=$c i=$i n=$n"}
			if ![winfo exists .b$n] {eval button .b$n $BB -text $n -command b$n}
			eval pack .b$n -in .b.digs.r$r -side right $EF
		}
		eval pack .b.digs.r$r -in .b.digs -side top
	}
}

fctbuts left
cmdbuts left
decbuts right

proc bDot {} {
	global D Dshow Dstack
	if {$D>1} {puts "bDot called."}
	App .
}

proc bNeg {} {
	global D new Dshow Dstack
	if {$D>1} {puts "bNeg called."}
	Show [expr - $Dshow]
	set new 0
}

proc b0 {} {
	global D
	if {$D>1} {puts "b0 called."}
	App 0
}

proc b1 {} {
	global D
	if {$D>1} {puts "b1 called."}
	App 1
}

proc b2 {} {
	global D
	if {$D>1} {puts "b2 called."}
	App 2
}

proc b3 {} {
	global D
	if {$D>1} {puts "b3 called."}
	App 3
}

proc b4 {} {
	global D
	if {$D>1} {puts "b4 called."}
	App 4
}

proc b5 {} {
	global D
	if {$D>1} {puts "b5 called."}
	App 5
}

proc b6 {} {
	global D
	if {$D>1} {puts "b6 called."}
	App 6
}

proc b7 {} {
	global D
	if {$D>1} {puts "b7 called."}
	App 7
}

proc b8 {} {
	global D
	if {$D>1} {puts "b8 called."}
	App 8
}

proc b9 {} {
	global D
	if {$D>1} {puts "b9 called."}
	App 9
}

proc bA {} {
	global D
	if {$D>1} {puts "bA called."}
	App A
}

proc bB {} {
	global D
	if {$D>1} {puts "bB called."}
	App B
}

proc bC {} {
	global D
	if {$D>1} {puts "bC called."}
	App C
}

proc bD {} {
	global D
	if {$D>1} {puts "bD called."}
	App D
}

proc bE {} {
	global D
	if {$D>1} {puts "bE called."}
	App E
}

proc bF {} {
	global D
	if {$D>1} {puts "bF called."}
	App F
}

# Set up some Help-key bindings, if we can find Help.w:
if [file exists Help.w] {
	set helpmod Help.w
} elseif [file exists $env(HOME)/sh/Help.w] {
	set helpmod $env(HOME)/sh/Help.w
} elseif [file exists ~jc/sh/Help.w] {
	set helpmod ~jc/sh/Help.w
} else {
	set errmsg {Help.w not found; help feature disabled}
	set helpmod {}
}
if {$helpmod != {}} {
	source ~jc/sh/Help.w
	bind all <Help> {
		set widget [winfo containing %X %Y]
		if {$D} {puts "~jc/sh/Help: %%X=%X %%Y=%y %%x=%x %%y=%y $widget"}
		Help $widget %X %Y
	}
	bind all <F1> {
		set widget [winfo containing %X %Y]
		if {$D} {puts "~jc/sh/Help: %%X=%X %%Y=%y %%x=%x %%y=%y $widget"}
		Help $widget %X %Y
	}
	set errmsg {Press Help or F1 for info}
}

trace variable Bshow w B_show