#!/usr/local/bin/wish8.3

global SrcDir
# Global containing the source directory.
# [index] SrcDir!global

set SrcDir [file dirname [info script]]
if {[string compare "$SrcDir" {.}] == 0} {set SrcDir [pwd]}

lappend auto_path [file join $SrcDir MRR_TimeTable]

package require StdMenuBar 1.0

global WS WD ES ED WBR
set WS        1
set WD  [expr 1 << 1]
set ES  [expr 1 << 2]
set ED  [expr 1 << 3]
set WBR [expr 1 << 4]
set EBR [expr 1 << 5]

global E2LG E2UG
set E2LG        1
set E2UG  [expr 1 << 1]

global E1LG E1UG
set E1LG  [expr 1 << 2]
set E1UG  [expr 1 << 3]

global W2LG W2UG
set W2LG  [expr 1 << 4]
set W2UG  [expr 1 << 5]

global W1LG W1UG
set W1LG  [expr 1 << 6]
set W1UG  [expr 1 << 7]

global M1 M2
catch {unset M1}
catch {unset M2}

for {set i 0} {$i < 32} {incr i} {
  set M1($i) 0
  set M2($i) 0
}

set LJCCJ  [expr $WS | $ES]
set LJCCJR [expr $LJCCJ | $WBR]

set M1($LJCCJ) $W1UG
set M2($LJCCJ) $W1UG

set M1($LJCCJR) $E2UG
set M2($LJCCJR) $E2UG


set TYCCJ  [expr $WD | $ES]
set TYCCJR [expr $TYCCJ | $WBR]

set M1($TYCCJ) $W2UG
set M2($TYCCJ) $W2UG

set M1($TYCCJR) $E2LG
set M2($TYCCJR) $E2LG


set LJBS  [expr $WS | $ED]
set LJBSR [expr $LJBS | $WBR]

set M1($LJBS) $W1LG
set M1($LJBSR) $W1LG

set M2($LJBS) $E1UG
set M2($LJBSR) $E1UG


set TYBS  [expr $WD | $ED]
set TYBSR [expr $TYBS | $WBR]

set M1($TYBS) $W2LG
set M1($TYBSR) $W2LG

set M2($TYBS) $E1LG
set M2($TYBSR) $E1LG

proc Binary {i} {
  set result {}
  foreach x {1 2 3 4 5 6 7 8} {
    set result "[expr $i & 1]$result"
    set i [expr $i >> 1]
  }
  return "$result"
}

#puts "M1:"
#
#for {set i 0} {$i < 32} {incr i} {
#  puts "[Binary $i]: [Binary $M1($i)]"
#}
#
#puts "M2:"
#
#for {set i 0} {$i < 32} {incr i} {
#  puts "[Binary $i]: [Binary $M2($i)]"
#}
#

proc MainWindow {} {
  wm protocol . WM_DELETE_WINDOW {.quit invoke}
  wm title . {TJ Interlocking Simulator}

  MakeStandardMenuBar
  set fm [GetMenuByName File]
  $fm entryconfigure Exit -command {.quit invoke}
  $fm entryconfigure Close -command {.quit invoke}
  $fm entryconfigure Save -command {SaveHEXROM}
  $fm entryconfigure {Save As...} -command {SaveHEXROM}
  $fm entryconfigure New -state disabled
  $fm entryconfigure {Open...} -state disabled
  $fm entryconfigure {Print...} -state disabled

  set em [GetMenuByName Edit]
  for {set i 0} {$i <= [$em index end]} {incr i} {
    $em entryconfigure $i -state disabled
  }

  set hm [GetMenuByName Help]
  for {set i 0} {$i <= [$hm index end]} {incr i} {
    $hm entryconfigure $i -state disabled
  }

  # build widget .panel
  canvas .panel -height {400} -width {700} -borderwidth 4 \
		-relief groove -background white

  # build widget .quit
  button .quit -text {Quit} -command {CarefulExit}

  pack configure .panel -expand 1 -fill both
  pack configure .quit -fill x

  set w .
  wm withdraw $w
  update idletasks
  set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx $w]}]
  set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
	    - [winfo vrooty $w]}]
  wm geom $w +$x+$y
  wm minsize . [winfo reqwidth $w] \
	       [expr [winfo reqheight $w] + [winfo reqheight .menuBar]]
  wm deiconify $w
}

proc CarefulExit {} {
  if {[string compare \
	[tk_messageBox -default no -icon question -message {Really Quit?} \
		-title {Careful Exit} -type yesno] {yes}] == 0} {exit}
}


proc LED {x y LEDTag} {
  .panel create oval [expr $x - 5] [expr $y  - 5] [expr $x + 5] [expr $y  + 5] \
	-outline {} -fill red -tag $LEDTag
}

proc OneHead {x y LEDTag} {
  .panel create oval [expr $x - 15] [expr $y - 15] \
		     [expr $x + 15] [expr $y + 15] \
	-outline {} -fill black
  LED $x $y $LEDTag
}

proc TwoHead {x y GLEDTag RLEDTag} {
  .panel create oval [expr $x - 15] [expr $y - (15 + 10)] \
  		     [expr $x + 15] [expr $y + (15 - 10)] \
		     -outline {} -fill black
  .panel create oval [expr $x - 15] [expr $y - (15 - 10)] \
  		     [expr $x + 15] [expr $y + (15 + 10)] \
		     -outline {} -fill black
  .panel create rectangle [expr $x + 15] [expr $y - 10] \
  			  [expr $x - 15] [expr $y + 10] \
			  -outline {} -fill black
  LED $x [expr $y + 10] [list $GLEDTag Green]
  LED $x [expr $y - 10] [list $RLEDTag Red]
}

proc RotateXY {r angle XP YP} {
  upvar $XP xp
  upvar $YP yp

  set xp [expr $r * cos([radians $angle])]
  set yp [expr $r * sin([radians $angle])]
}

global PI
set PI [expr asin(1.0) * 2.0]

proc radians {degrees} {
  global PI

  return [expr (double($degrees)/180.0) * $PI]
}

proc RSwitch {x y tag orientation0 orientation1 value0 value1 l0 lc0 l1 lc1 
		stateVar updateProc} {
  upvar #0 $stateVar state

  .panel create oval [expr $x - 20] [expr $y - 20] \
		     [expr $x + 20] [expr $y + 20] \
		     -outline {} -fill black -tag $tag

  RotateXY  50 $orientation0 dxO0a dyO0a
  RotateXY -50 $orientation0 dxO0b dyO0b
  RotateXY  50 $orientation1 dxO1a dyO1a
  RotateXY -50 $orientation1 dxO1b dyO1b
  .panel itemconfigure $l0 -fill $lc0
  .panel itemconfigure $l1 -fill black
  set state $value0
  .panel create line [expr $x + $dxO0a] [expr $y + $dyO0a] \
  		     [expr $x + $dxO0b] [expr $y + $dyO0b] \
		     -arrow first -arrowshape {10 10 5} \
		     -fill black -width 10 -tag [list $tag ${tag}Pointer]
  eval [concat $updateProc $state]
  .panel bind $tag <1> [list ToggleRSwitch $x $y $tag $orientation0 \
			     $orientation1 $value0 $value1 $l0 $lc0 \
			     $l1 $lc1 $stateVar $updateProc \
			     $dxO0a $dyO0a $dxO0b $dyO0b \
			     $dxO1a $dyO1a $dxO1b $dyO1b]
}

proc ToggleRSwitch {x y tag orientation0 orientation1 value0 value1 l0 lc0 \
		    l1 lc1 stateVar updateProc dxO0a dyO0a dxO0b dyO0b \
		    dxO1a dyO1a dxO1b dyO1b} {
  upvar #0 $stateVar state

  if {$state == $value0} {
    .panel coords ${tag}Pointer [expr $x + $dxO1a] [expr $y + $dyO1a] \
				[expr $x + $dxO1b] [expr $y + $dyO1b] 
    .panel itemconfigure $l0 -fill black
    .panel itemconfigure $l1 -fill $lc1
    set state $value1
  } else {
    .panel coords ${tag}Pointer [expr $x + $dxO0a] [expr $y + $dyO0a] \
				[expr $x + $dxO0b] [expr $y + $dyO0b] 
    .panel itemconfigure $l1 -fill black
    .panel itemconfigure $l0 -fill $lc0
    set state $value0
  }
  eval [concat $updateProc $state]
}

proc TSwitch {x y tag value0 value1 stateVar updateProc} {
  upvar #0 $stateVar state

  .panel create oval [expr $x - 10] [expr $y - 10] \
		     [expr $x + 10] [expr $y + 10] \
		     -outline {} -fill black -tag $tag

   set state $value0
  .panel create line [expr $x + 30] [expr $y] \
  		     [expr $x     ] [expr $y] \
		     -arrow first -arrowshape {10 10 5} \
		     -fill black -width 10 -tag [list $tag ${tag}Pointer]
  eval [concat $updateProc $state]
  .panel bind $tag <1> [list ToggleTSwitch $x $y $tag $value0 $value1 \
					   $stateVar $updateProc]
}

proc ToggleTSwitch {x y tag value0 value1 stateVar updateProc} {
  upvar #0 $stateVar state

  if {$state == $value0} {
    .panel coords ${tag}Pointer [expr $x - 30] [expr $y] \
				[expr $x     ] [expr $y]
    set state $value1
    eval [concat $updateProc $state]
  } else {
    .panel coords ${tag}Pointer [expr $x + 30] [expr $y] \
				[expr $x     ] [expr $y]
    set state $value0
    eval [concat $updateProc $state]
  }
}

array set Greens [list \
  $E2LG E2LG \
  $E2UG E2UG \
  $E1LG E1LG \
  $E1UG E1UG \
  $W2LG W2LG \
  $W2UG W2UG \
  $W1LG W1LG \
  $W1UG W1UG
]

array set Reds [list \
  $E2LG E2LR \
  $E2UG E2UR \
  $E1LG E1LR \
  $E1UG E1UR \
  $W2LG W2LR \
  $W2UG W2UR \
  $W1LG W1LR \
  $W1UG W1UR
]

global InterLockState
set InterLockState 0

proc DoInterLock {bitmask updateBit} {
  global M1 M2 Greens Reds InterLockState

  set InterLockState [expr $InterLockState & ~$bitmask]
  set InterLockState [expr $InterLockState | $updateBit]

  foreach green {E2LG E2UG E1LG E1UG W2LG W2UG W1LG W1UG} {
    .panel itemconfigure Green -fill black
  }
  foreach red {E2LR E2UR E1LR E1UR W2LR W2UR W1LR W1UR} {
    .panel itemconfigure Red   -fill red
  }

  
  set address [expr $InterLockState % 32]
  set ROM [expr $InterLockState & 32]

  if {$ROM > 0} {
    set thegreen $M2($address)
  } else {
    set thegreen $M1($address)
  }

  if {$thegreen != 0} {
    .panel itemconfigure $Greens($thegreen) -fill green
    .panel itemconfigure $Reds($thegreen) -fill black
  }
}

global FileType
set FileType Intel
global WhichROM
set WhichROM M1


proc SaveHEXROM {} {
  global M1 M2 FileType WhichROM

# .saveHex
# The above line makes pasting MUCH easier for me.
# It contains the pathname of the cutted widget.
# Tcl version: 8.0 (Tcl/Tk/XF)
# Tk version: 8.0
# XF version: 4.0
#

  # build widget .saveHex
  if {"[info procs XFEdit]" != ""} {
    catch "XFDestroy .saveHex"
  } {
    catch "destroy .saveHex"
  }
  toplevel .saveHex 

  # Window manager configurations
  wm positionfrom .saveHex ""
  wm sizefrom .saveHex ""
  wm maxsize .saveHex 1009 738
  wm minsize .saveHex 1 1
  wm protocol .saveHex WM_DELETE_WINDOW {.saveHex.buttons.button17 invoke}
  wm title .saveHex {Save ROM Hex files}


  # build widget .saveHex.main
  frame .saveHex.main \
    -borderwidth {4} \
    -relief {groove}

  # build widget .saveHex.main.type
  frame .saveHex.main.type \
    -borderwidth {2}

  # build widget .saveHex.main.type.label5
  label .saveHex.main.type.label5 \
    -text {File type:}

  # build widget .saveHex.main.type.radiobutton6
  radiobutton .saveHex.main.type.radiobutton6 \
    -text {Motorola Hex} \
    -value {Motorola} \
    -variable {FileType}

  # build widget .saveHex.main.type.radiobutton7
  radiobutton .saveHex.main.type.radiobutton7 \
    -text {Intel Hex} \
    -value {Intel} \
    -variable {FileType}

  # build widget .saveHex.main.filename
  frame .saveHex.main.filename \
    -borderwidth {2}

  # build widget .saveHex.main.filename.label8
  label .saveHex.main.filename.label8 \
    -text {Filename:}

  # build widget .saveHex.main.filename.name
  entry .saveHex.main.filename.name

  # build widget .saveHex.main.filename.button10
  button .saveHex.main.filename.button10 \
    -command {set oldname "[.saveHex.main.filename.name get]"
set newname "[tk_getSaveFile -defaultextension .hex  -filetypes { {{Hex Files} {.hex} TEXT} {{All Files} * TEXT} }  -initialdir [file dirname $oldname]  -initialfile $oldname  -parent .saveHex  -title {File to save hex data to}]"
if {[string length "$newname"] > 0} {
  .saveHex.main.filename.name delete 0 end
  .saveHex.main.filename.name insert end "$newname"
}} \
    -padx {9} \
    -pady {3} \
    -text {Browse}

  # build widget .saveHex.main.which
  frame .saveHex.main.which \
    -borderwidth {2}

  # build widget .saveHex.main.which.label13
  label .saveHex.main.which.label13 \
    -text {Which ROM?}

  # build widget .saveHex.main.which.radiobutton14
  radiobutton .saveHex.main.which.radiobutton14 \
    -text {M1} \
    -value {M1} \
    -variable {WhichROM}

  # build widget .saveHex.main.which.radiobutton15
  radiobutton .saveHex.main.which.radiobutton15 \
    -text {M2} \
    -value {M2} \
    -variable {WhichROM}

  # build widget .saveHex.buttons
  frame .saveHex.buttons \
    -borderwidth {4}

  # build widget .saveHex.buttons.button16
  button .saveHex.buttons.button16 \
    -command {global SaveHEXButtons
set SaveHEXButtons 1} \
    -padx {9} \
    -pady {3} \
    -text {OK}

  # build widget .saveHex.buttons.button17
  button .saveHex.buttons.button17 \
    -command {global SaveHEXButtons
set SaveHEXButtons 0} \
    -padx {9} \
    -pady {3} \
    -text {Cancel}

  # pack master .saveHex.main
  pack configure .saveHex.main.type \
    -fill x
  pack configure .saveHex.main.filename \
    -fill x
  pack configure .saveHex.main.which \
    -fill x

  # pack master .saveHex.main.type
  pack configure .saveHex.main.type.label5 \
    -side left
  pack configure .saveHex.main.type.radiobutton6 \
    -expand 1 \
    -side left
  pack configure .saveHex.main.type.radiobutton7 \
    -expand 1 \
    -side left

  # pack master .saveHex.main.filename
  pack configure .saveHex.main.filename.label8 \
    -side left
  pack configure .saveHex.main.filename.name \
    -fill x \
    -side left
  pack configure .saveHex.main.filename.button10 \
    -side right

  # pack master .saveHex.main.which
  pack configure .saveHex.main.which.label13 \
    -side left
  pack configure .saveHex.main.which.radiobutton14 \
    -expand 1 \
    -side left
  pack configure .saveHex.main.which.radiobutton15 \
    -expand 1 \
    -side left

  # pack master .saveHex.buttons
  pack configure .saveHex.buttons.button16 \
    -expand 1 \
    -side left
  pack configure .saveHex.buttons.button17 \
    -expand 1 \
    -side right

  # pack master .saveHex
  pack configure .saveHex.main \
    -expand 1 \
    -fill both
  pack configure .saveHex.buttons \
    -fill x

  .saveHex.main.filename.name insert end {}


# end of widget tree

  set w .saveHex
  wm withdraw $w
  update idletasks
  set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
	    - [winfo vrootx $w]}]
  set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
	    - [winfo vrooty $w]}]
  wm geom $w +$x+$y
  wm deiconify $w

  set oldFocus [focus]
  set oldGrab [grab current $w]
  if {$oldGrab != ""} {
    set grabStatus [grab status $oldGrab]
  }
  grab $w
  focus $w.main.filename.name

  global SaveHEXButtons
  set SaveHEXButtons -1
  tkwait variable SaveHEXButtons

  set filename "[.saveHex.main.filename.name get]"
  catch {focus $oldFocus}
  catch {
	# It's possible that the window has already been destroyed,
	# hence this "catch".  Delete the Destroy handler so that
	# tkPriv(button) doesn't get reset by it.

	bind $w <Destroy> {}
	destroy $w
  }
  if {$oldGrab != ""} {
    if {$grabStatus == "global"} {
      grab -global $oldGrab
    } else {
      grab $oldGrab
    }
  }

  if {$SaveHEXButtons == 0} {return}

  switch -exact -- "$FileType" {
    Motorola {
      switch -exact -- "$WhichROM" {
	M1 {
	  SaveAsMotorola M1 "$filename"
	}
	M2 {
	  SaveAsMotorola M2 "$filename"
	}
      }
    }
    Intel {
      switch -exact -- "$WhichROM" {
	M1 {
	  SaveAsIntel M1 "$filename"
	}
	M2 {
	  SaveAsIntel M2 "$filename"
	}
      }
    }
  }
}

proc SaveAsMotorola {ROMVar filename} {
  upvar #0 $ROMVar rom
  if {[catch [list open "$filename" w] hfp]} {
    tk_messageBox -icon error -message "Error opening file $filename: $hfp" \
		  -parent . -title "File open error" -type ok
    return
  }
  puts -nonewline $hfp "[format {S1%02X0000} [expr 32 + 3]]"
  set csum [expr 32 + 3]
  for {set i 0} {$i < 32} {incr i} {
    puts -nonewline $hfp "[format {%02X} $rom($i)]"
    set csum [expr ($csum + $rom($i)) & 255]
  }
  puts $hfp "[format {%02X} [expr (~$csum) & 255]]"
  puts $hfp {S9020000FD}
  close $hfp
}

proc SaveAsIntel {ROMVar filename} {
  upvar #0 $ROMVar rom
  if {[catch [list open "$filename" w] hfp]} {
    tk_messageBox -icon error -message "Error opening file $filename: $hfp" \
		  -parent . -title "File open error" -type ok
    return
  }
  puts -nonewline $hfp "[format {:%02X000000} 32]"
  set csum 32
  for {set i 0} {$i < 32} {incr i} {
    puts -nonewline $hfp "[format {%02X} $rom($i)]"
    set csum [expr ($csum + $rom($i)) & 255]
  }
  puts $hfp "[format {%02X} [expr (-$csum) & 255]]"
  puts $hfp {:00000001FF}
  close $hfp
}

MainWindow

TwoHead 100  75 W1UG W1UR
TwoHead 100 125 W1LG W1LR

.panel itemconfigure W1UG -fill black
.panel itemconfigure W1LG -fill black

OneHead 100 250 fixed
TwoHead 100 300 W2UG W2UR
TwoHead 100 350 W2LG W2LR

.panel itemconfigure W2UG -fill black
.panel itemconfigure W2LG -fill black

OneHead 600  25 fixed
TwoHead 600  75 E1UG E1UR
TwoHead 600 125 E1LG E1LR

.panel itemconfigure E1UG -fill black
.panel itemconfigure E1LG -fill black

TwoHead 600 300 E2UG E2UR
TwoHead 600 350 E2LG E2LR

.panel itemconfigure E2UG -fill black
.panel itemconfigure E2LG -fill black

.panel create line 0   200 700 200 -width 10 -fill blue
.panel create line 0   230 250 200 -width 10 -fill blue
.panel create line 450 200 700 170 -width 10 -fill blue

LED 150 200 WS
LED 150 220 WD

.panel itemconfigure WS -fill black
.panel itemconfigure WD -fill black

LED 530 200 ES
LED 530 180 ED

.panel itemconfigure ES -fill black
.panel itemconfigure ED -fill black

RSwitch 230 200 W 180 165 $WS $WD WS green WD red WState "DoInterLock [expr $WS | $WD]"

RSwitch 450 200 E   0 345 $ES $ED ES green ED red EState "DoInterLock [expr $ES | $ED]"

TSwitch 600 200 WB  0 $WBR WBState "DoInterLock $WBR"
TSwitch 600 180 EB  0 $EBR EBState "DoInterLock $EBR"