#!/usr/bin/wish
# ------------------------------- IRL editor --------------------------------
# Version 1.5   -   May 20, 2002   -   By Schelte Bron   -   sbron@wanadoo.nl
# ---------------------------------------------------------------------------
# Version 1.6   -   Aug 22, 2002   -   Ruud Linders
#		    added rc6 mode A, Onkyo & JVC codes
#         1.7   -   Repeat flag for Onkyo codes
# ---------------------------------------------------------------------------
# Version 1.8   -   Nov 21, 2002   -   Schelte Bron
#		    Adapted for use with Tclkits
# ---------------------------------------------------------------------------
# Version 1.9   -   Jan 04, 2003   -   Schelte Bron
#		    Adapted for tcl version 8.4
# ---------------------------------------------------------------------------

set version 1.9
set modified "January 4, 2003"

if {[catch {package require Tk}]} exit

append about "HomeVision Infrared Signal Editor\n" \
	"Version $version  ($modified)\n" \
	"By Schelte Bron\n<sbron@wanadoo.nl>"

if {$tcl_platform(platform) == "windows"} {
	set modifier Control
	option add *Font "{MS Sans Serif} -14 normal"
	font create Fixed -family {Lucida Console} -size -12 -weight normal
	set selname CLIPBOARD
} elseif {$tcl_platform(platform) == "macintosh"} {
	set modifier Command
	set selname CLIPBOARD
} else {
	set modifier Meta
	option add *Font "Helvetica -12 normal"
	font create Fixed -family lucidatypewriter -size -12 -weight normal
	set selname PRIMARY
}

if {[package vsatisfies $tk_patchLevel 8.4.0]} {
	# Expose old internal variables and commands
	::tk::unsupported::ExposePrivateCommand tkTabToWindow
}

option add *Entry.disabledBackground white
option add *Entry.disabledForeground black
option add *selectBackground darkblue
option add *selectForeground white

image create bitmap arrow -data {
	#define arrow_width 7
	#define arrow_height 3
	static char arrow_bits[] = {
	   0x3e,0x1c,0x08};
}

# wm withdraw .
wm title . "HomeVision Infrared Signal Editor - Version $version"

menu .m -tearoff 0 -bd 1 -relief raised

if {$tcl_platform(platform) == "macintosh"} {
	.m add cascade -label Apple -menu .m.apple
	menu .m.apple -tearoff -0
	.m.apple add command -label "About IRL EditorÉ" -underline 0 -command {tk_messageBox -message $about}
} else {
	.m add cascade -label Help -menu .m.help -underline 0
	menu .m.help -tearoff -0
	.m.help add command -label "About IRL Editor" -underline 0 -command {tk_messageBox -message $about}
}

.m add cascade -label File -menu .m.file -underline 0
.m add cascade -label Edit -menu .m.edit -underline 0
.m add cascade -label Tools -menu .m.tool -underline 0

menu .m.file -tearoff 0 -postcommand {filestate}
.m.file add command -label "Save" -command save -accelerator $modifier+S -underline 0
.m.file add separator
.m.file add command -label "Connect" -command connect -underline 0
.m.file add separator

if {$tcl_platform(platform) == "windows"} {
	.m.file add command -label "Exit" -command exit -underline 1

} elseif {$tcl_platform(platform) == "macintosh"} {
	.m.file add command -label "Quit" -command exit -accelerator $modifier+Q

} else {
	.m.file add command -label "Exit" -command exit

}
menu .m.edit -tearoff 0 -postcommand {editstate .t}
.m.edit add command -label "Cut" -accelerator $modifier+X -underline 2 \
	-command {event generate .t <<Cut>>}
.m.edit add command -label "Copy" -accelerator $modifier+C -underline 0 \
	-command {event generate .t <<Copy>>}
.m.edit add command -label "Paste" -accelerator $modifier+V -underline 0 \
	-command {event generate .t <<Paste>>}
.m.edit add command -label "Clear" -command {event generate .t <<Clear>>} \
	-accelerator Del -underline 4
.m.edit add separator
.m.edit add command -label "Clear All" -underline 4 -command {
	.t delete 1.0 end
	.f1.f.b1 configure -state disabled
	.f1.f.b2 configure -state disabled
	set time ""
	set irl_freq ""
}
menu .m.tool -tearoff 0
.m.tool add command -label "Enter RC5 code" -command {rccode 5}
.m.tool add command -label "Enter RC6 (mode 0) code" -command {rccode 6}
.m.tool add command -label "Enter RC6 (mode A) code" -command {rccode 6a}
.m.tool add command -label "Enter SIRCS code" -command {rccode sircs}
.m.tool add command -label "Enter Onkyo code" -command {rccode onkyo}
.m.tool add command -label "Enter JVC code" -command {rccode jvc}

if {[string equal $tcl_platform(platform) unix]} {
	# Modify the commands slightly in case of unix		
	.m.edit entryconfigure 0 -command {
		event generate .t <<Cut>>
		selection own .
	}
	.m.edit entryconfigure 1 -command {
		event generate .t <<Copy>>
		selection own .
	}
	.m.edit entryconfigure 2 -command {pasteinsert .t}

	# Setup the accelerator keys
	bind Text <Meta-x> {.m.edit invoke 0}
	bind Text <Meta-c> {.m.edit invoke 1}
	bind Text <Meta-v> {.m.edit invoke 2}

	# Install a paste handler
	selection handle . pasteclip
}

. configure -menu .m

label .l -text "Pronto infrared signal data:" -anchor w
text .t -background white -wrap word -width 56 -height 12 \
	-yscrollcommand {.v set} -xscrollcommand {.h set} \
	-font Fixed
scrollbar .v -command {.t yview}
scrollbar .h -command {.t xview} -orient horizontal

frame .f1 -bd 2 -relief groove
label .f1.l1 -text "Duty cycle:" -anchor w
entry .f1.e1 -background white -textvariable irl_duty -width 4 \
	-highlightthickness 1
label .f1.t1 -text "%" -anchor w
label .f1.l2 -text "Duration:" -anchor w
frame .f1.m2 -bd 2 -relief sunken -highlightthickness 1
label .f1.m2.m -textvariable time -bd 0	-relief flat -background white \
	 -pady 0 -padx 0 -width 6 -highlightthickness 0
bind .f1.m2.m <ButtonRelease-1> {.f1.m2.b invoke}
menu .f1.m2.m.m -tearoff 0 -relief sunken -background white
button .f1.m2.b -image arrow -width 9 -highlightthickness 0 \
	-command {
		set x [expr {[winfo rootx .f1.m2] + \
			[.f1.m2 cget -highlightthickness]}]
		set y [expr {[winfo rooty .f1.m2] + [winfo height .f1.m2] - \
			([.f1.m2 cget -highlightthickness] << 1)}]
		tk_popup .f1.m2.m.m $x $y
	}
grid .f1.m2.m .f1.m2.b -sticky news
grid rowconfigure .f1.m2 0 -weight 1

label .f1.t2 -text "ms" -anchor w
label .f1.l3 -text "Carrier:" -anchor w
entry .f1.e3 -background white -textvariable irl_freq -width 5 -state disabled \
	-highlightthickness 1
label .f1.t3 -text "kHz" -anchor w
grid .f1.l3 .f1.e3 .f1.t3 .f1.l2 .f1.m2 .f1.t2 .f1.l1 .f1.e1 .f1.t1 -sticky news
checkbutton .f1.c1 -anchor w -variable rc5toggle -state disabled \
	-text "Philips RC5/6 code format toggle bit" \
	-command {.f1.f.b2 configure -state disabled}
grid .f1.c1 -sticky ew -padx 4 -pady 2 -columnspan 9
frame .f1.f
button .f1.f.b1 -text "Load into\nHomeVision" -width 10 -state disabled \
	-command load
button .f1.f.b2 -text "Transmit\nTest" -width 10 -state disabled \
	-command test
button .f1.f.b3 -text "Analyze\nSignal" -width 10 -command analyze

frame .f3
label .f3.t -text "IR Signals" -anchor w
listbox .f3.l -yscrollcommand {.f3.s set} -background white -height 5 \
	-exportselection 0 -listvariable signals \
	-selectbackground darkblue -selectforeground white
scrollbar .f3.s -command {.f3.l yview}
grid .f3.t -sticky we
grid .f3.l .f3.s -sticky news
grid rowconfigure .f3 1 -weight 1
grid columnconfigure .f3 0 -weight 1

frame .f4 -bd 2 -relief groove
label .f4.l1 -text "Signal name:" -anchor w
entry .f4.e1 -background white -width 30 -textvariable name
label .f4.l2 -text "Description:" -anchor w
entry .f4.e2 -background white -width 40 -textvariable desc
button .f4.b1 -text "Add" -height 1 -width 6 -state disabled \
	-command addsignal
button .f4.b2 -text "Delete" -height 1 -width 6 -state disabled \
	-command delsignal
grid .f4.l1 .f4.b1 -sticky w -padx 4
grid .f4.e1 -sticky w -padx 4
grid .f4.l2 .f4.b2 -sticky w -padx 4
grid .f4.e2 -sticky w -padx 4
grid .f4.b1 .f4.b2 -rowspan 2 -sticky e -padx 4
grid columnconfigure .f4 1 -weight 1

grid .f1.f.b3 .f1.f.b1 .f1.f.b2
grid columnconfigure .f1.f {0 1 2} -weight 1

grid .f1.f -sticky news -pady 5 -columnspan 9
grid columnconfigure .f1 {2 5} -weight 1

frame .f2
button .f2.b -text Exit -height 2 -width 6 -command exit
button .f2.c -text Reset -height 2 -width 6 -command {
	.t delete 1.0 end
	.f1.f.b1 configure -state disabled
	.f1.f.b2 configure -state disabled
	.f4.b1 configure -state disabled
	set time ""
	set irl_freq ""
}

grid .f2.c .f2.b -pady 4
grid columnconfigure .f2 {0 1} -weight 1

frame .stat -bd 1 -relief raised
label .stat.l -textvariable irlstatus -anchor w -bd 1 -relief sunken
grid .stat.l -padx 2 -pady 2 -sticky news
grid columnconfigure .stat 0 -weight 1

grid .l -sticky w
grid .t - .v -sticky news
grid .h - -sticky news
grid .f1 .f3 - -sticky news -pady 4
grid .f4 -sticky news -pady 4 -padx 4 -ipady 4 -ipadx 4
grid .stat - - -sticky news
grid .f1 -pady 4 -padx 4 -ipady 4 -ipadx 4
grid .f3 -rowspan 2

grid columnconfigure . 1 -weight 1
grid rowconfigure . 1 -weight 1

wm protocol . WM_DELETE_WINDOW exit

set irl_duty 40
set sigcnt 0
set host localhost
set port 1043

set rccommand 0
set rcsystem 0
set rccustcode 0

proc pasteclip {offs len} {
	string range [selection get -selection CLIPBOARD] \
		$offs [expr {$offs + $len - 1}]
}

proc pasteinsert {w} {
	if {[catch {selection get}]} {
		event generate .t <<Paste>>
	} else {
		set bbox [$w bbox insert]
		set x [lindex $bbox 0]
		set y [lindex $bbox 1]
		event generate .t <<PasteSelection>> -x $x -y $y
	}
}

proc center {w1 {w2 .}} {
	update idletasks
	set width1 [winfo reqwidth $w1]
	set height1 [winfo reqheight $w1]
	scan [wm geometry $w2] "%dx%d+%d+%d" width2 height2 rootx rooty
	set x [expr {$rootx + (($width2 - $width1) >> 1)}]
	set y [expr {$rooty + (($height2 - $height1) >> 1)}]
	wm geometry $w1 +$x+$y
	wm deiconify $w1
}

proc filestate {} {
	global signals
	if {[llength $signals]} {
		.m.file entryconfigure 0 -state normal
	} else {
		.m.file entryconfigure 0 -state disabled
	}
}

proc editstate {w} {
	global selname
	if {![catch {selection get -displayof $w -selection $selname}]} {
		.m.edit entryconfigure 2 -state normal
	} elseif {![catch {selection get -displayof $w -selection CLIPBOARD}]} {
		.m.edit entryconfigure 2 -state normal
	} else {
		.m.edit entryconfigure 2 -state disabled
	}
	if {[catch {$w index sel.first}]} {
		.m.edit entryconfigure 0 -state disabled
		.m.edit entryconfigure 1 -state disabled
		.m.edit entryconfigure 3 -state disabled
	} else {
		.m.edit entryconfigure 0 -state normal
		.m.edit entryconfigure 1 -state normal
		.m.edit entryconfigure 3 -state normal
	}
}

proc analyze {} {
	global irlstatus hv ircseq1 ircseq2 irl_freq repeat count
	.f1.f.b1 configure -state disabled
	.f4.b1 configure -state disabled
	foreach n [split [string trim [.t get 1.0 end]]] {
		if {[scan $n %x%s x -] != 1} {
			set irlstatus "Invalid data"
			return
		}
		lappend rec $x
	}
	if {![info exists rec]} {
		set irlstatus "No data entered"
		return
	}
	if {[llength $rec] < 4} {
		set irlstatus "Data truncated"
		return
	}
	.f1.c1 configure -state disabled
	if {[lindex $rec 0] == 0} {
		analyze0 $rec
	} elseif {[lindex $rec 0] == 0x5000} {
		analyze5 $rec
	} elseif {[lindex $rec 0] == 0x6000} {
		analyze6 $rec
	} elseif {[lindex $rec 0] == 0x6001} {
		analyze6a $rec
	} else {
		set irlstatus "Not a supported Pronto signal format"
		return
	}
	set t1 0
	foreach n $ircseq1 {incr t1 $n}
	set t2 0
	foreach n $ircseq2 {incr t2 $n}
	.f1.m2.m.m delete 0 end
	set len [llength $ircseq1]
	set n 0
	set sel 0
	while {$len < 256} {
		set t [format %.1f [expr {$t1 / $irl_freq}]]
		.f1.m2.m.m add radiobutton -variable time -value $t \
			-label [format "%s    " $t] \
			-indicatoron 0 -hidemargin 1 -command [subst {
				set repeat $n
				.f1.f.b2 configure -state disabled
			}]
		if {$t <= 200.0} {set sel $n}
		incr t1 $t2
		incr len [llength $ircseq2]
		if {!$t2} break
		incr n
	}
	.f1.m2.m.m invoke $sel
	set count [expr {round(2764.8 / $irl_freq)}]
	if {[info exists hv]} {
		.f1.f.b1 configure -state normal
	}
	.f4.b1 configure -state normal
	set irlstatus "Data analyzed successfully"
}

proc analyze0 {rec} {
	global irlstatus irl_freq ircseq1 ircseq2
	set len1 [lindex $rec 2]
	set len2 [lindex $rec 3]
	if {[llength $rec] != 4 + ($len1 << 1) + ($len2 << 1)} {
		set irlstatus "Data corrupt"
		return -code return
	}
	set irl_freq [format %.1f [expr {1000 / ([lindex $rec 1]  * .241246)}]]
	set ircseq1 [lrange $rec 4 [expr {3 + ($len1 << 1)}]]
	set ircseq2 [lrange $rec [expr {4 + ($len1 << 1)}] end]
}

proc analyze5 {rec} {
	global irl_duty ircseq1 ircseq2 rc5toggle irl_freq irlstatus
	if {[llength $rec] != 6} {
		set irlstatus "Data corrupt"
		return -code return
	}
	set irl_freq 36.0
	set irl_duty 25
	.f1.c1 configure -state normal
	set ircseq1 ""
	set ircseq2 ""
	set system [lindex $rec 4]
	set command [lindex $rec 5]
	# Calculate the code into the 14 upper bits of a short
	set code [expr {0x8000 | (($command < 64) << 14) | ($rc5toggle << 13) | \
		(($system & 0x1f) << 8) | (($command & 0x3f) << 2)}]
	# Convert the code to a binary string
	binary scan [binary format S $code] B14 bits
	# Map the bits to falling or rising edges
	set bits [string range [string map {0 10 1 01} $bits] 1 end]0
	# Convert to list of half (0) or whole (1) period high/low indication
	set tmp [split [string map {00 1 11 1 1 0} $bits] ""]
	# Replace with number of pulses of the carrier wave
	set ircseq2 [string map {0 32 1 64} $tmp]
	# Add gap to last off time 
	set ircseq2 [lreplace $ircseq2 end end [expr {[lindex $ircseq2 end] + 3200}]]
}

proc analyze6 {rec} {
	global irl_duty ircseq1 ircseq2 rc5toggle irl_freq irlstatus
	if {[llength $rec] != 6} {
		set irlstatus "Data corrupt"
		return -code return
	}
	set irl_freq 36.0
	set irl_duty 25
	.f1.c1 configure -state normal
	set ircseq1 ""
	set ircseq2 ""
	set system [lindex $rec 4]
	set command [lindex $rec 5]
	# Start with the standard header
	set str 1111110010010101
	# Append the toggle bit pattern
	if {$rc5toggle} {
		append str 0011
	} else {
		append str 1100
	}
	# Calculate the system and command code
	set code [expr {(~$system & 0xff) << 8 | (~$command & 0xff)}]
	# Convert the code to a binary string
	binary scan [binary format S $code] B16 bits
	# Map the bits to falling or rising edges and append to the headers
	append str [string map {0 10 1 01} $bits] 0
	# Convert to list of high/low duration indication
	set tmp [split [string map {111111 6 111 3 11 2 1 1 000 3 00 2 0 1} $str] ""]
	# Replace with number of pulses of the carrier wave
	set ircseq2 [string map {1 16 2 32 3 48 6 96} $tmp]
	# Add gap to last off time
	set ircseq2 [lreplace $ircseq2 end end [expr {[lindex $ircseq2 end] + 3248}]]
}

proc analyze6a {rec} {
	global irl_duty ircseq1 ircseq2 rc5toggle irl_freq irlstatus
	if {[llength $rec] != 8} {
		set irlstatus "Data corrupt"
		return -code return
	}
	set irl_freq 36.0
	set irl_duty 25
	.f1.c1 configure -state normal
	set ircseq1 ""
	set ircseq2 ""
	set custcode [lindex $rec 4]
	set system [lindex $rec 5]
	set command [lindex $rec 6]
	# Start with the standard header 7 (or 6??) leading ones
	set str 11111110010101001
	# Append the toggle bit pattern
	if {$rc5toggle} {
		append str 0011
	} else {
		append str 1100
	}
	# If custcode < 128 we encode it using 8 bits, otherwise 16
	set code [expr {~$custcode}]
	if {$custcode < 128} {
		# Convert the code to a binary string
		binary scan [binary format c $code] B8 bits
		set gap 2976
	} elseif {$custcode >= 32768 && $custcode < 65536} {
		binary scan [binary format S $code] B16 bits
		set gap 2720
	} else {
		return -code error "Customer Code not in proper range: $custcode
"
	}
	# Map the bits to falling or rising edges and append to the headers
	append str [string map {0 10 1 01} $bits]
	# Calculate the system and command code
	set code [expr {(~$system & 0xff) << 8 | (~$command & 0xff)}]
	# Convert the code to a binary string
	binary scan [binary format S $code] B16 bits
	# Map the bits to falling or rising edges and append to the headers
	append str [string map {0 10 1 01} $bits] 0
	# Convert to list of high/low duration indication
	set tmp [split [string map {1111111 7 111111 6 111 3 11 2 1 1 000 3 00 2 0 1} $str] ""]
	# Replace with number of pulses of the carrier wave
	set ircseq2 [string map {1 16 2 32 3 48 6 96 7 112} $tmp]
	# Add gap to last off time
	set ircseq2 [lreplace $ircseq2 end end \
		[expr {[lindex $ircseq2 end] + $gap}]]
}

proc pulse {} {
	global count ircseq1 ircseq2 repeat irl_freq cnt
	set cnt 0
	foreach {n1 n2} $ircseq1 {
		set x [expr {$count * $n2 - 77}]
		set tim [expr {(0x10000 - ($x & 0xfff8)) | ($x >> 16)}]
		lappend data $n1 $tim
		incr cnt
	}
	set n 0
	while {$n < $repeat} {
		if {![llength $ircseq2]} break
		foreach {n1 n2} $ircseq2 {
			set x [expr {$count * $n2 - 77}]
			set tim [expr {(0x10000 - ($x & 0xfff8)) | ($x >> 16)}]
			lappend data $n1 $tim
			incr cnt
		}
		incr n
	}
	return $data
}

proc load {} {
	global irlstatus
	set irlstatus "Loading signal data"
	set data [pulse]
	if {[catch {hvdata [binary format S* $data]}]} {
		set irlstatus "Failed to load signal data"
		.f1.f.b2 configure -state disabled
	} else {
		set irlstatus "Signal data loaded successfully"
		.f1.f.b2 configure -state normal
	}
}

proc params {} {
	global irl_freq irl_duty irlstatus on off
	if {![string is digit -strict $irl_duty]} {
		set irlstatus "Invalid character in duty cycle value"
		return 0
	}
	scan $irl_duty %d irl_duty
	if {$irl_duty < 1 || $irl_duty > 99} {
		set irlstatus "Duty cycle must be between 1 and 99 %"
		return 0
	}
	set cycle [expr {round(2764.8 / $irl_freq)}]
	set on [expr {round($irl_duty * $cycle / 100.0)}]
	set off [expr {256 - ($cycle - $on)}]
	set on [expr {256 - $on}]
	return 1
}

proc test {} {
	global cnt on off irlstatus
	if {[params]} {
		set irlstatus "Transmitting IR signal"
		if {[catch {hvcmd _ [format %02X%02X%02X $cnt $on $off]}]} {
			set irlstatus "IR signal transmit failed"
		} else {
			set irlstatus "IR signal transmitted successfully"
		}
	}
}

proc addsignal {} {
	global on off cnt pulse data name desc irlstatus signals
	if {![string length $name]} {
		set irlstatus "Please enter a name for the IR signal"
		return
	}
	if {[info exists data($name)]} {
		set irlstatus "The specified signal already exists"
		return
	}
	set pulse($name) [pulse]
	if {[params]} {
		set data($name) [list $name 1 $on $off $cnt $desc]
		lappend signals $name
		set irlstatus "The signal has been added"
		set name ""
		set desc ""
	}
}

proc delsignal {} {
	global signals data pulse irlstatus
	set list [.f3.l curselection]
	while {[llength $list]} {
		set x [lindex $list end]
		unset data([lindex $signals $x])
		unset pulse([lindex $signals $x])
		set signals [lreplace $signals $x $x]
		set list [lrange $list 0 end-1]
	}
	event generate .f3.l <<ListboxSelect>>
	set irlstatus "The selected signals have been deleted"
}

proc save {} {
	global irlstatus data pulse signals
	set types {
		{{Homevision IR Files}	.irl}
		{{All Files}		*}
	}
	set file [tk_getSaveFile -filetypes $types -defaultextension .irl \
		-title "Save IR signals"]
	if {![string length $file]} {return}

	if {[catch {open $file w} f]} {
		set irlstatus "Could not open file '$file'"
	}
	fconfigure $f -translation binary
	set code ""
	set addr 0
	foreach n $signals {
		set ptr($n) $addr
		set code [concat $code $pulse($n)]
		incr addr [expr {2 * [llength $pulse($n)]}]
	}
	puts -nonewline $f [binary format si [llength $signals] $addr]
	foreach n $signals {
		puts -nonewline $f [eval binary format A30cccciA40 \
			[linsert $data($n) 5 $ptr($n)]]
	}
	puts -nonewline $f [binary format S* $code]
	close $f
	set irlstatus "File saved successfully"
}

proc connect {} {
	toplevel .c
	wm transient .c .
	wm title .c "Connect to HomeVision"
	wm withdraw .c
	label .c.l1 -text "Server host:" -anchor w
	entry .c.e1 -background white -textvariable host
	label .c.l2 -text "Port number:" -anchor w
	entry .c.e2 -background white -textvariable port -width 6
	label .c.l3 -text "Password:" -anchor w
	entry .c.e3 -background white -textvariable pass -show #

	frame .c.f
	button .c.f.b1 -text Cancel -width 6 -command {destroy .c}
	button .c.f.b2 -text OK -width 6 -command login
	grid .c.f.b1 .c.f.b2 -padx 12 -pady 4

	grid .c.l1 .c.e1 -sticky w -padx 2 -pady 1
	grid .c.l2 .c.e2 -sticky w -padx 2 -pady 1
	grid .c.l3 .c.e3 -sticky w -padx 2 -pady 1
	grid .c.f - -sticky news

	center .c
	tkTabToWindow .c.e1

	bind .c.e1 <Return> {tkTabToWindow .c.e2}
	bind .c.e2 <Return> {tkTabToWindow .c.e3}
	bind .c.e3 <Return> {.c.f.b2 invoke}
}

proc rccode {{type 5}} {
	global rccommand rcsystem rccustcode
	destroy .c
	toplevel .c
	set showcustcode 0
	set showrepeat   0
	set custvcmd {expr {[string is digit %P] && [scan %P %%d] < 1}}
	if {[string equal $type 6]} {
		wm title .c "Enter RC6 code"
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
	} elseif {[string equal $type 6a]} {
                set showcustcode 1
		wm title .c "Enter RC6a code"
	        # valid range for custcode  0-127 or 32768-65535
                set custvcmd {checkcustcode %P .c.f.b2}
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
	} elseif {[string equal $type 5]} {
		wm title .c "Enter RC5 code"
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 32}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 128}}
	} elseif {[string equal $type sircs]} {
		wm title .c "Enter SIRCS code"
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 8192}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 128}}
	} elseif {[string equal $type onkyo]} {
                set showrepeat 1
		wm title .c "Enter Onkyo code"
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
	} elseif {[string equal $type jvc]} {
		wm title .c "Enter JVC code"
		set sysvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
		set cmdvcmd {expr {[string is digit %P] && [scan %P %%d] < 256}}
	}
	wm transient .c .
	wm withdraw .c

	frame .c.f
	button .c.f.b1 -text Cancel -width 6 -command {destroy .c}
	button .c.f.b2 -text OK -width 6 -command [list makerc $type]
	grid .c.f.b1 .c.f.b2 -padx 12 -pady 4

	label .c.l1 -text "System:" -anchor w
	entry .c.e1 -background white -textvariable rcsystem \
		-width 6 -validate all -vcmd $sysvcmd
	label .c.l2 -text "Command:" -anchor w
	entry .c.e2 -background white -textvariable rccommand \
		-width 6 -validate all -vcmd $cmdvcmd
	label .c.l3 -text "Customer Code:" -anchor w
	entry .c.e3 -background white -textvariable rccustcode \
		-width 6 -validate all -vcmd $custvcmd
	checkbutton .c.c1 -anchor w -variable repeatflag -state normal \
		-text "Repeating signal (eg. Volume)" 

	grid .c.l1 .c.e1 -sticky w -padx 2 -pady 1
	grid .c.l2 .c.e2 -sticky w -padx 2 -pady 1

        if {$showcustcode} {
                grid .c.l3 .c.e3 -sticky w -padx 2 -pady 1
        }
        if {$showrepeat} {
		grid .c.c1 -sticky ew -padx 4 -pady 2 -columnspan 9
        }
	grid .c.f - -sticky news

	center .c
	tkTabToWindow .c.e1

	bind .c.e1 <Return> {tkTabToWindow .c.e2}
	bind .c.e2 <Return> {.c.f.b2 invoke}
}

proc state expr {
        if {[uplevel 1 expr $expr]} {
                return normal
        } else {
                return disabled
        }
}

proc checkcustcode {val win} {
        # 0-127 of 32768-65535
        set rc [expr {[string is digit $val] && [scan $val %d] < 65536}]
        if {$rc} {
                if {[string length $val]} {
                        $win configure \
			    -state [state {$val < 128 || $val >= 32768}]
                } else {
                        $win configure -state disabled
                }
        }
        set rc
}

proc makerc {{type 5}} {
	global rcsystem rccommand rccustcode
	.t delete 1.0 end
	if {![string length $rcsystem]} {set rcsystem 0}
	if {![string length $rccommand]} {set rccommand 0}
	if {![string length $rccustcode]} {set rccustcode 0}
	if {[string equal $type sircs]} {
		.t insert end [makesircs]
	} elseif {[string equal $type onkyo]} {
		.t insert end [makeonkyo]
	} elseif {[string equal $type jvc]} {
		.t insert end [makejvc]
        } elseif {[string equal $type 6a]} {
                .t insert end [format "%04x %04x %04x %04x %04x %04x %04x %04x" \
                        0x6001 0 0 2 [scan $rccustcode %d] [scan $rcsystem %d] \
                        [scan $rccommand %d] 0]
	} else {
		.t insert end [format "%04x %04x %04x %04x %04x %04x" \
			[expr {$type << 12}] 0 0 1 [scan $rcsystem %d] \
			[scan $rccommand %d]]
	}
	destroy .c
}

proc makesircs {} {
	global rcsystem rccommand
	# Raw format, 40kHz, No initial code
	set rc [list 0000 0068 0000]
	# Determine system code length
	if {$rcsystem == ($rcsystem & 0x1f)} {
		# Basic 5 bits code
		set syslen 5
	} elseif {$rcsystem == ($rcsystem & 0xff)} {
		# Extended 5+3 bit code
		set syslen 8
	} else {
		# Extended 5+3+5 bit code
		set syslen 13
	}
	lappend rc [format %04x [expr {$syslen + 8}]]
	# Total signal duration is 45ms @ 40kHz = 1800 periods
	set gap 1800
	# Start bit
	lappend rc 0060 0018
	incr gap -120
	binary scan [binary format cs $rccommand $rcsystem] b7b$syslen cmd sys
	foreach n [split "$cmd$sys" ""] {
		if {$n} {
			lappend rc 0030 0018
			incr gap -72
		} else {
			lappend rc 0018 0018
			incr gap -48
		}
	}
	set rc [lreplace $rc end end [format %04x [incr gap 24]]]
	join $rc
}

proc makeonkyo {} {
        global rcsystem rccommand repeatflag
        # Raw format, 39.1kHz, T=550us ~ 22pulses
        # startpulse - 32 bits - endpulse
        # 95000us between headers = 3784 pulses
        if {$repeatflag} {
                set rc [list 0000 006a 0000 0022]
        } else {
                set rc [list 0000 006a 0022 0002]
        }
        set gap 3784
        # Start bit 16T/8T
        lappend rc 0160 00b0
        incr gap -528
        # 4B <system> <command> <command XOR 0xFF>
        binary scan [binary format cc 0x4B $rcsystem] B16 sys
        binary scan [binary format cc $rccommand [expr {(~$rccommand & 0xFF)}]] \
	    B16 cmd
        foreach n [split "$sys$cmd" ""] {
                if {$n} {
                        # 1T/3T
                        lappend rc 0016 0042
                        incr gap -88
                } else {
                        # 1T/1T
                        lappend rc 0016 0016
                        incr gap -44
                }
        }
        # 1T pulse plus gap
        lappend rc 0016 [format %04x [incr gap -22]]
        #  16T/4T/1T stop repeater
        if {!$repeatflag} {
                lappend rc 0160 00b0
                lappend rc 0016 0cb8
        }
        join $rc
}

proc makejvc {} {
        global rcsystem rccommand
        # Raw format, 38.5kHz, T=520us ~ 20pulses
        # startpulse - 16 bits - endbit
        # 45 ms between headers = 1750 pulses
        set rc [list 0000 006c 0001 0011]
        # Start bit 16T/8T
        lappend rc 0140 00a0
        set gap 1750
        #  <system> <command> 
        binary scan [binary format cc $rcsystem $rccommand] b8b8 sys cmd
        foreach n [split "$sys$cmd" ""] {
                if {$n} {
                        # 1T/3T
                        lappend rc 0014 003c
                        incr gap -80
                } else {
                        # 1T/1T
                        lappend rc 0014 0014
                        incr gap -40
                }
        }
        # 1T pulse plus gap
        lappend rc 0014 [format %04x [incr gap -20]]
        join $rc
}

proc login {} {
	global hv port host irlstatus
	if {[info exists hv]} {close $hv}
	if {[catch {socket $host $port} hv]} {
		set irlstatus "Could not connect to HomeVision application"
		unset hv
	} else {
		fconfigure $hv -blocking 0 -translation binary
		fileevent $hv readable hvread
		.f1.f.b1 configure -state [.f4.b1 cget -state]
	}
}

proc authenticate {str} {
	global pass
	hvsend W $pass
}

proc hvsum {str {sum 0}} {
	binary scan $str c* data
	foreach n $data {
		incr sum -$n
	}
	return $sum
}

proc hvdata data {
	set addr 0x2400
	while {[string length $data] >= 13} {
		hvcmd b [binary format Sa13 $addr $data]
		set data [string range $data 13 end]
		incr addr 13
	}
	binary scan $data c* bytes
	foreach n $bytes {
		hvcmd {]} [format "%04X%02X" $addr [expr {$n & 0xff}]]
		incr addr
	}
}

proc hvgets {{delay 2000}} {
	global hvline timeout
	set id [after $delay set timeout 1]
	vwait timeout
	after cancel $id
	if {$timeout} {error "Timeout"}
	set hvline
}

proc hvcmd {cmd data} {
	global hvline
	set hvline ""
	hvsend S ",$cmd$data\r"
	binary scan $cmd c code
	set ack [format %02X [expr {$code - 0x30}]]
	while {![catch {hvgets} line]} {
		if {[string index $line end] != "\1"} continue
		if {[string equal -length 2 $line $ack]} {
			return
		}
		set hvline ""
	}
	error "Timeout"
}

proc hvsend {cmd {str ""}} {
	global hv hvlabel
	set len [string length $str]
	incr len 15
	set lenstr [format %07d $len]
	set data [binary format a*A*AA* $hvlabel $lenstr $cmd $str]
	set sum [hvsum $data 90]
	set data $data[binary format c $sum]
	binary scan $data H* hex
	puts -nonewline $hv $data
	flush $hv
}

proc hvread {} {
	global hv hvlabel hvdata hvcmd
	if {[eof $hv]} {
		close $hv
		unset hv
		.f1.f.b1 configure -state disabled
	} else {
		set data [read $hv]
		append hvdata $data
		while {[string length $hvdata] >= 14} {
			if {![string equal -length 6 $hvdata $hvlabel]} {
				set x [string first $hvlabel $hvdata]
				if {$x < 0} return
				set hvdata [string range $hvdata $x end]
			}
			if {[string length $hvdata] < 14} return
			binary scan $hvdata x6a7 lenstr
			scan $lenstr %d len
			if {[string length $hvdata] < $len} return
			binary scan $hvdata x13aa[expr {$len - 15}]c type str sum
			set hvdata [string range $hvdata $len end]
			if {[info exists hvcmd($type)]} {
				uplevel #0 $hvcmd($type) [list $str]
			}
		}
	}
}

proc response str {
	global hvline timeout
	append hvline $str
	set timeout 0
}

proc connected str {
	global irlstatus hv
	set irlstatus "Connected to HomeVision on [lindex [fconfigure $hv -peername] 1]"
	destroy .c
}

proc authfail str {
	global irlstatus hv
	set irlstatus "Invalid password - try again"
	close $hv
	unset hv
}

array set hvcmd {
	S	response
	1	connected
	W	authenticate
	I	authfail
}

set hvlabel [binary format cccccc -1 -5 -2 -4 -3 -7]

wm deiconify .

bind .f3.l <<ListboxSelect>> {
	if {[llength [.f3.l curselection]]} {
		.f4.b2 configure -state normal
	} else {
		.f4.b2 configure -state disabled
	}
}