#! /usr/bin/perl

################################################################
# This program by M. Litherland                                #
# http://nule.org/                                             #
#                                                              #
# Special thanks to Denis Hruza                                #
# http://users.neotechus.com/~hruzaden/betabrite/betabrite.htm #
# for his program bb-stockticker.pl which showed me that       #
# this wouldn't work without the RUNLIST code.                 #
################################################################

# This code may be distibuted under the same terms as Perl
# itself.

use strict;
use warnings;

use Tk;
use Tk::DialogBox;

# Change this to be your comm port if needed.
use constant COMPORT => '/dev/ttyS0';

# This varies by model
use constant MAXSIZE => 8192;

# Header and footer sent to the unit.
use constant HEADER => qw/00 00 00 00 00 00 01 5a 30 30 02 41 41/;
use constant FOOTER => qw/04/;

# This tells the unit to run the command list.
use constant RUNLIST => qw/00 00 00 00 00 00 01 5a 30 30 02 45 2e 53 55 41 04/;

# There are *lots* of these codes.
use constant CODES => {
	ROTATE    => [ qw/1b 20 61/ ],
	RIGHT     => [ qw/1b 20 68/ ],
	LEFT      => [ qw/1b 20 67/ ],
	UP        => [ qw/1b 20 65/ ],
	DOWN      => [ qw/1b 20 66/ ],
	SPRAY     => [ qw/1b 20 6e 35/ ],
	AUTO      => [ qw/1b 20 6f/ ],
	SNOW      => [ qw/1b 20 6e 32/ ],
	TWINKLE   => [ qw/1b 20 6e 30/ ],
	SPARKLE   => [ qw/1b 20 6e 31/ ],
	INTER     => [ qw/1b 20 6e 33/ ]
};

# There are more colors, but who cares?
use constant COLOR => {
	RED     => [ qw/1c 31/ ],
	GREEN   => [ qw/1c 32/ ],
	AMBER   => [ qw/1c 33/ ],
	RAINBOW => [ qw/1c 39/ ],
	MIX     => [ qw/1c 42/ ],
};

# Some initialization stuff
$\ = "";
$/ = "";
$|++;
my $w = {};
$w->{confirm} = 0;

$w->{main} = MainWindow->new(-title => 'Beta-Brite Controller');

# Main widgets
$w->{buttons} = $w->{main}->Frame->pack(-fill => 'x');
$w->{control} = $w->{main}->Frame(-border => 2,-relief => 'groove')->pack(-fill => 'x');
$w->{text} = $w->{main}->Text(-width => 80, -height => 25)->pack(-fill => 'both', -expand => 1);

# Various generic commands
$w->{buttons}->Button(-text => 'Send', -command => [\&send, $w])->pack(-side => 'left');
$w->{buttons}->Button(-text => 'Clear', -command => sub {$w->{text}->delete('1.0', 'end')})->pack(-side => 'left');
$w->{buttons}->Button(-text => 'Exit', -command => sub {exit})->pack(-side => 'right');

# These buttons generate command sequences sent to the unit
$w->{control}->Label(-text => 'Modes: ')->pack(-side => 'left');

# Frames for two rows of buttons.
$w->{modes} = $w->{control}->Frame->pack(-side => 'left');
$w->{modest} = $w->{modes}->Frame->pack;
$w->{modesb} = $w->{modes}->Frame->pack;

# Top row.
$w->{modest}->Button(
	-text => 'Rotate',
	-command => sub {$w->{text}->insert('insert', "/*ROTATE*/")}
)->pack(-side => 'left');
$w->{modest}->Button(
	-text => 'Left',
	-command => sub {$w->{text}->insert('insert', "/*LEFT*/")}
)->pack(-side => 'left');
$w->{modest}->Button(
	-text => 'Right',
	-command => sub {$w->{text}->insert('insert', "/*RIGHT*/")}
)->pack(-side => 'left');
$w->{modest}->Button(
	-text => 'Up',
	-command => sub {$w->{text}->insert('insert', "/*UP*/")}
)->pack(-side => 'left');
$w->{modest}->Button(
	-text => 'Down',
	-command => sub {$w->{text}->insert('insert', "/*DOWN*/")}
)->pack(-side => 'left');
$w->{modest}->Button(
	-text => 'Spray',
	-command => sub {$w->{text}->insert('insert', "/*SPRAY*/")}
)->pack(-side => 'left');

# Bottom row.
$w->{modesb}->Button(
	-text => 'Auto',
	-command => sub {$w->{text}->insert('insert', "/*AUTO*/")}
)->pack(-side => 'left');
$w->{modesb}->Button(
	-text => 'Snow',
	-command => sub {$w->{text}->insert('insert', "/*SNOW*/")}
)->pack(-side => 'left');
$w->{modesb}->Button(
	-text => 'Twinkle',
	-command => sub {$w->{text}->insert('insert', "/*TWINKLE*/")}
)->pack(-side => 'left');
$w->{modesb}->Button(
	-text => 'Sparkle',
	-command => sub {$w->{text}->insert('insert', "/*SPARKLE*/")}
)->pack(-side => 'left');
$w->{modesb}->Button(
	-text => 'Interlock',
	-command => sub {$w->{text}->insert('insert', "/*INTER*/")}
)->pack(-side => 'left');

# These buttons generate color sequences sent to the unit
$w->{control}->Label(-text => 'Colors: ')->pack(-side => 'left');

# Frames for two rows of buttons.
$w->{color} = $w->{control}->Frame->pack(-side => 'left');
$w->{colort} = $w->{color}->Frame->pack;
$w->{colorb} = $w->{color}->Frame->pack;

# Top row.
$w->{colort}->Button(
	-text => 'Red',
	-command => sub {$w->{text}->insert('insert', "/*RED*/")}
)->pack(-side => 'left');
$w->{colort}->Button(
	-text => 'Green',
	-command => sub {$w->{text}->insert('insert', "/*GREEN*/")}
)->pack(-side => 'left');
$w->{colort}->Button(
	-text => 'Amber',
	-command => sub {$w->{text}->insert('insert', "/*AMBER*/")}
)->pack(-side => 'left');

# Bottom row.
$w->{colorb}->Button(
	-text => 'Rainbow',
	-command => sub {$w->{text}->insert('insert', "/*RAINBOW*/")}
)->pack(-side => 'left');
$w->{colorb}->Button(
	-text => 'Automix',
	-command => sub {$w->{text}->insert('insert', "/*MIX*/")}
)->pack(-side => 'left');

# An initial phrase to set it.
$w->{text}->insert('1.0', "/*SPARKLE*//*RED*/Just /*GREEN*/another /*AMBER*/Perl /*GREEN*/hacker,");
MainLoop;
exit;

sub send
{
	my $w = shift;

	if (!$w->{confirm})
	{
		my $dialog = $w->{main}->DialogBox(-title => "Using ".COMPORT, -buttons => ['OK', 'Cancel']);
		$dialog->Label(-text => 'Are you sure you have your comm port set correctly?')->pack;
		$dialog->Label(-text => 'Something like: stty 9600 -opost -ocrnl -onlcr cs7 parenb -parodd < /dev/ttyS0')->pack;
		$dialog->Label(-text => 'Make sure you can write to the device too: chmod 777 /dev/ttyS0')->pack;
		my $popup = $dialog->Show;

		return unless ($popup eq 'OK');

		$w->{confirm} = 1;
	}

	# Process text from window.
	my $text = $w->{text}->get('1.0', 'end');
	$text =~ s/\r//g;
	$text =~ s/\n//g;

	# Make sure the text has required attributes.
	my $init = "";
	if ($text =~ /^\/\*(\w+)\*\//)
	{
		$init = $1;

		if (!defined(&CODES->{$init}))
		{
			my $dialog = $w->{main}->DialogBox(-title => "Error", -buttons => ['OK']);
			$dialog->Label(-text => 'Sorry - you have to start the text with a command.')->pack;
			my $popup = $dialog->Show;

			return;
		}
	}
	else
	{
		my $dialog = $w->{main}->DialogBox(-title => "Error", -buttons => ['OK']);
		$dialog->Label(-text => 'Sorry - you have to start the text with a command.')->pack;
		my $popup = $dialog->Show;

		return;
	}

	# Process codes and colors embedded in text.
	for (keys %{&CODES})
	{
		if ($text =~ /\/\*$_\*\//)
		{
			my $repl = join "", map{pack("H*", $_)} @{&CODES->{$_}};
			$text =~ s/\/\*$_\*\//$repl/g;
		}
	}
	for (keys %{&COLOR})
	{
		if ($text =~ /\/\*$_\*\//)
		{
			my $repl = join "", map{pack("H*", $_)} @{&COLOR->{$_}};
			$text =~ s/\/\*$_\*\//$repl/g;
		}
	}

	my $command = join "", map{pack("H*", $_)} HEADER;
	$command .= $text;
	$command .= join "", map{pack("H*", $_)} FOOTER;
	open COMM, ">".COMPORT || die "Could not open comport($!): ".COMPORT." !\n";
	#open COMM, ">out" || die "Could not open tempfile($!): out!\n";
	binmode COMM;
	print COMM $command;
	print COMM RUNLIST;
	close COMM;
}