#!/usr/bin/perl -w


###############
## Libraries ##
###############
use strict;
use warnings;
use Tk;
use Tk::Font;
use Tk::Photo;
use Tk::ROText;
use Tk::DialogBox;
use Win32::Sound;


##################
## User-defined ##
##################
my $prog_title  = "SoundOff v1.0 -- Dec. 2011 by John C. Norton";
my $min_mute    = 5;
my $dflt_mute   = 15;

# GUI Look & Feel
my $a_timer_bg   = [ '#ffafef', '#ffbf7f' ];
my $a_timer_txt  = [ 'Timer Inactive (Esc)', 'Timer Active (Esc)' ];
my $bg_button    = '#afcfff';
my $bg_label     = '#ffbf7f';
my $bg_meter     = '#ffdf3f';
my $bg_help      = '#cfff9f';
my $fo_slider    = 'Lucida Sans:9/*';
my $fo_button    = 'Comic Sans MS:10*';
my $fo_label     = 'Arial:10*';
my $fo_help      = 'Lucida Sans:8';
my $a_can_geo    = [ 128, 256 ];
my $a_meter_x    = [ 48,  90  ];
my $a_meter_y    = [ 32,  220 ];
my $a_bg_meter   = [ '#ffffcf', '#ff3f3f' ];
my $a_btn_geo    = [ 280, 317, 3 ];
my $a_on_off_geo = [ 280, 317, 3 ];
my $h_on_xpm     = { '0' => '#7fcf7f', '2' => '#000000', '1' => '#87f717' };
my $h_off_xpm    = { '0' => '#ffbf7f', '2' => '#000000', '1' => '#ff3f3f' };


#############
## Globals ##
#############
my $volume    = '100';
my $b_resume  = 1;
my $b_mute    = 0;
my $c_tick    = 0;
my $mute_time = my $resume = $dflt_mute;
my ($btn_on, $btn_off, $cv_meter, $id_meter, $id_text, $mute_ent, $c_timer);


##################
## Main Program ##
##################
create_gui();


#################
## Subroutines ##
#################
sub create_gui {
    my $mw   = new MainWindow(-title => $prog_title);
    my $fr1  = frame($mw, '^0x');   # Help, Master Volume, Quit
    my $fr2  = frame($mw, '^1b');   # Main frame
    my $fr3  = frame($fr2, '<0b');  # Large On/Off button
    my $fr4  = frame($fr2, '<1b');  # Timer Active, Mute Time, Meter

    main_options($fr1);

    $btn_on   = sound_on_button($fr3);
    $btn_off  = sound_off_button($fr3);
    $c_timer  = togglebtn($fr4, \$b_resume, $a_timer_txt, $a_timer_bg);
    lbl_entry($fr4, 'Mute Time', \$mute_time);
    resume_meter($fr4);

    my $c_idle = sub { ($b_mute and $b_resume and $c_tick) and $c_tick->(1) };
    $mw->repeat(1000 => $c_idle);
    MainLoop;
}


sub main_options {
    my ($w) = @_;

    my $mw  = $w->toplevel;
    my $fr1 = frame($w, '<0bg1');
    my $fr2 = frame($w, '<1xg1');
    my $fr3 = frame($w, '>0bg1');

    my $b1  = button($fr1, 'Help (F1)', '<1b');
    my $b2  = button($fr3, 'Quit (^Q)', '<1b');

    volume_slider($fr2);

    $b1->configure(-command => sub { give_help($mw) });
    $b2->configure(-command => sub { exit });

    $mw->bind("<F1>"              => sub { $b1->invoke });
    $mw->bind("<Control-q>"       => sub { $b2->invoke });
    $mw->bind("<Return>"          => sub { toggle_mute() });
    $mw->bind("<KeyPress-Left>"   => sub { adjust_mute_time(-5) });
    $mw->bind("<KeyPress-Right>"  => sub { adjust_mute_time(5)  });
    $mw->bind("<KeyPress-Down>"   => sub { adjust_volume('-') });
    $mw->bind("<KeyPress-Up>"     => sub { adjust_volume('+')  });
    $mw->bind("<Escape>"          => sub { $c_timer->() });
}


sub resume_meter {
    my ($w) = @_;
    $cv_meter = $w->Canvas(-bg => 'gray', -takefocus => 0);
    $cv_meter->configure(-width  => $a_can_geo->[0]);
    $cv_meter->configure(-height => $a_can_geo->[1]);
    my ($x0, $x1, $y0, $y1) = ( @$a_meter_x, @$a_meter_y );
    my @rect = ( $x0, $y0, $x1, $y1, -fill => $a_bg_meter->[0] );
    $cv_meter->createRectangle(@rect);
    packit($cv_meter, '1bg2');
}


sub volume_slider {
    my ($w) = @_;
    my $a_vol = [ '-orient' => 'horizontal', -label => '~ Master Volume ~' ];
    my $vol   = $w->Scale(@$a_vol, -variable => \$volume, -bg => $bg_meter);
    $vol->configure(-command => [ \&adjust_volume, '*' ]);
    $vol->configure(-takefocus => 0, -font => create_font($w, $fo_slider));
    packit($vol, '<1b');
}


sub adjust_mute_time {
    my ($incr) = @_;
    $mute_time =~ s/\D//g;
    $mute_time ||= $dflt_mute;
    ($incr eq '*') and $incr = 0;
    $mute_time += $incr;
    ($mute_time < $min_mute) and $mute_time = $min_mute;
    return $mute_time;
}


sub button {
    my ($w, $text, $pack) = @_;
    my $btn  = $w->Button(-bg => $bg_button, -text => $text, -takefocus => 0);
    $btn->configure(-font => create_font($w, $fo_button));
    return packit($btn, $pack || '<');
}


sub create_font {
    my ($w, $font_spec) = @_;
    my $weight = ($font_spec =~ s/[*]//)? 'bold':   'normal';
    my $slant  = ($font_spec =~ s:[/]::)? 'italic': 'roman';
    my ($fam, $size, $bold) = $font_spec =~ /(.+):(\d+)([*])?$/;
    my $mw     = $w->toplevel;
    my @args   = ( -weight => $weight, -slant => $slant );
    my $font = $mw->Font(-family => $fam, -size => $size, @args);
    return $font;
}


sub lbl_entry {
    my ($w, $label, $s_var) = @_;
    my $frm   = frame($w, '0xg2');
    my $lbl   = $frm->Label(-bg => $bg_label, -text => $label);
    $lbl->configure(-font => create_font($w, $fo_label));
    $mute_ent = $frm->Entry(-width => 1, -justify => 'center');
    my $c_validate = sub { return ($_[0] =~ /^\d*$/)? 1: 0 };
    $mute_ent->configure(-textvar => $s_var);
    $mute_ent->configure(-validate => 'all', -validatecommand => $c_validate);
    $lbl->pack($mute_ent, -side => 'left');
    $mute_ent->pack(-expand => 1, -fill => 'both');
    $mute_ent->focus;
    $mute_ent->selectionRange(0, 15);
}


sub togglebtn {
    my ($w, $s_var, $a_text, $a_bg) = @_;

    my $frm  = frame($w, '0xg2');
    my $btn  = $frm->Button();

    my $c_toggle = sub {
        my $text = $a_text->[$$s_var = 1 - $$s_var];
        my $bg   = $a_bg->[$$s_var];
        $btn->configure(-text => $text, -bg => $bg);
    };

    $btn->configure(-text => $a_text->[$$s_var], -bg => $a_bg->[$$s_var]);
    $btn->configure(-command => $c_toggle, -takefocus => 0);
    $btn->configure(-font => create_font($w, $fo_button));
    packit($btn, '1b');
    return $c_toggle;
}


sub frame {
    my ($w, $pack, $bg) = @_;
    my $frm = $w->Frame;
    ($bg || "") and $frm->configure(-bg => $bg);
    return packit($frm, $pack);
}


sub packit {
    my ($w, $pack) = @_;
    $pack ||= '^0n';

    my $h_sides = {qw{ < left > right ^ top v bottom}};
    my $h_fill  = {qw{n none b both x x y y }};
    my $h_rel   = {qw{ - flat g groove r ridge s solid ^ raised v sunken }};
    my $side    = ($pack =~ s/^([<v^>])//)?   $h_sides->{$1}: 'top';
    my $b_exp   = ($pack =~ s/^([01])//)?     $1:             0;
    my $fill    = ($pack =~ s/^([nbxy])//)?   $h_fill->{$1}:  'none';
    my $rel     = ($pack =~ s/^([-grs^v])//)? $h_rel->{$1}:   '';
    my $bw      = ($pack =~ s/^(\d+)//)?      $1:             2;

    $rel and $w->configure(-relief => $rel, -borderwidth => $bw);
    $w->pack(-expand => $b_exp || 0, -fill => $fill, -side => $side);
}


sub toggle_mute {
    my ($btn) = @_;
    return ($b_mute = 1 - $b_mute)? mute_on(): mute_off();
}


sub mute_on {
    adjust_volume(0);
    $btn_on->packForget;
    $btn_off->pack;
    $resume = my $curr_mute = adjust_mute_time(0);
    $b_mute = 1;

    $c_tick = sub {
        my ($nsecs) = @_;
        $resume -= $nsecs;
        ($resume <= 0) and return mute_off();
        my $pcnt = (100 * $resume / $curr_mute);
        meter_level($pcnt);
        meter_label($resume);
    };

    $c_tick->(0);
}


sub mute_off {
    $resume = $mute_time || $dflt_mute;
    $btn_on->pack;
    $btn_off->packForget;
    meter_level(0);
    meter_label('On');
    $b_mute = $c_tick = 0;
    adjust_volume('*');
}


sub meter_level {
    my ($pcnt) = @_;
    $pcnt = 100 - $pcnt;
    my ($x0, $x1, $y0, $y1) = ( @$a_meter_x, @$a_meter_y );
    $y0 += ($pcnt * ($y1 - $y0)) / 100;
    my @rect  = ( $x0, $y0, $x1, $y1, -fill => $a_bg_meter->[1] );
    $id_meter and $cv_meter->delete($id_meter);
    $id_meter = $cv_meter->createRectangle(@rect);
}


sub meter_label {
    my ($text) = @_;
    my ($x0, $x1, $y0, $y1) = ( @$a_meter_x, @$a_meter_y );
    my ($textx, $texty) = (($x0 + $x1) / 2, $y1 + 4);
    my @args = ( $textx, $texty, -anchor => 'n', -text => $text);
    $id_text and $cv_meter->delete($id_text);
    $id_text = $cv_meter->createText(@args);
}


sub adjust_volume {
    my ($vol) = @_;
    ($vol eq '*') and $vol = $volume;
    ($vol eq '-') and $vol = ($volume > 0)?   --$volume: $volume;
    ($vol eq '+') and $vol = ($volume < 100)? ++$volume: $volume;
    if (0 == $vol or !$b_mute) {
        my $val = int(65535 * $vol / 100) & 0x0000ffff;
        Win32::Sound::Volume(($val << 16) | $val);
       }
}


sub create_xpm {
    my ($a_geo, $h_xpm, $data) = @_;

    my ($w, $h, $nsyms) = @$a_geo;
    my ($lb, $rb)       = (chr(123), chr(125));  # Don't mess up '%' in vim

    # Create XPM header
    my $xpm = qq{
        :/* XPM */
        :static char *xpm[] = $lb
        :"$w $h $nsyms 1",
    };

    # Fill in XPM color symbols
    foreach my $key (keys %$h_xpm) {
        my $line = sprintf "%s c %s", $key, $h_xpm->{$key};
        $xpm .= qq{\n\t\t:"$line",};
    }
    $xpm =~ s/(^\s+:)|((?<=\n)\s+:)|(\s+$)//g;

    my $c_dec = sub {
        my $N = ord($_[0]);
        return 126 == $N? 0: 124 == $N? 75: $N < 92? $N-17: $N-92;
    };

    # Decode XPM data
    $data     =~ s/(^[^:]+:)|((?<=\n)\s+(?=:))|(:[^:]+$)//gs;
    $data     =~ s/:\n://g;
    my $nhuff = $c_dec->(substr($data, 0, 1, ""));
    my $size  = $c_dec->(substr($data, 0, 1, ""));

    for (my $i = 0; $i < $nhuff; $i++) {
        my $sym = substr($data, 0, $size, "");
        my $rep = substr($data, 0, 1, "");
        $data =~ s/\Q$rep\E/$sym/g;
    }

    substr($data, 0, $c_dec->(substr($data, 0, 1, "")), "");

    my $decode = "";
    while ($data) {
        my $symbol    = substr($data, 0, 1, "");
        my ($b1, $b2) = substr($data, 0, 2, "") =~ /^(.)(.)$/;
        $decode .= $symbol x (76 * $c_dec->($b1) + $c_dec->($b2));
    }

    # Merge XPM header and data
    for (my $i = 1; $i <= $h; $i++) {
        my $line = substr($decode, 0, $w, "");
        $xpm .= qq{\n"$line"} . (($i < $h)? ",": "$rb;");
    }

    return $xpm;
}


sub sound_on_button {
    my ($w) = @_;
    my $data = on_off_data();
    my $xpm  = create_xpm($a_on_off_geo, $h_on_xpm, $data);
    my $btn  = image_button($xpm, $w);
    $btn->configure(-command => \&toggle_mute);
    return packit($btn);
}


sub sound_off_button {
    my ($w) = @_;
    my $data = on_off_data();
    my $xpm  = create_xpm($a_on_off_geo, $h_off_xpm, $data);
    my $btn  = image_button($xpm, $w);
    $btn->configure(-command => \&toggle_mute);
    return $btn;
}


sub image_button {
    my ($xpm, $w) = @_;
    my $mw  = $w->toplevel;
    my $img = $mw->Photo(-format => 'xpm', -data => $xpm);
    my $btn = $w->Button();
    $btn->configure(-image => $img, -takefocus => 0);
    return $btn;
}


sub give_help {
    my ($mw) = @_;
    my $title = "Help Menu";
    my $db  = $mw->DialogBox(-title => $title, -buttons => [ "Dismiss" ]);
    my $frm = $db->add('Frame');
    packit($frm, '0xr4');
    my $text = qq{
        :
        : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        : SoundOff is a simple Windows application that mutes the computer
        : speaker for a given timer interval, after which the volume is
        : automatically restored (unless the timer is inactive).
        :
        : The modules 'Tk' and 'Win32::Sound' are both required.
        :
        : The following features exist:
        :
        :   1.  Help button (or F1)
        :
        :       Displays this help menu.  (Same as the <F1> key).
        :
        :   2.  Master Volume slider (or <Up Arrow> and <Down Arrow>)
        :
        :       Selects the speaker volume when unmuted.  The keyboard
        :       accelerator keys <Up Arrow> and <Down Arrow> may be used
        :       to respectively raise or lower the volume.
        :
        :   3.  Quit button (or ^Q)
        :
        :       Exits the program.  (Same as the <Control-Q> key).
        :
        :   4.  Speaker Off/On Button (or <Enter>)
        :
        :       Mutes or unmutes the speaker for the duration of the
        :       current Mute Time.  The <Enter> key does the same thing.
        :
        :   5.  Timer Active button (or <Escape>)
        :
        :       Disables the timer so the speaker is not automatically
        :       unmuted, even after the mute time interval has elapsed.
        :       This lets the user mute/unmute the speaker manually.
        :       The <Escape> key can be used as a shortcut for this.
        :
        :   6.  Mute Time (or <Left Arrow> and <Right Arrow>)
        :
        :       Selects the exact number of seconds after which the speaker
        :       volume is restored.  The <Left Arrow> and <Right Arrow> keys
        :        respectively subtract or add 5-second intervals to the time.
        :
        :   7.  Progress meter
        :
        :       A meter which displays a visual indication of the number
        :       of seconds left until the speaker is unmuted.
        : ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
        : $prog_title
    };
    $text =~ s/(^\s+:)|((?<=\n)\s+:)|(\s+$)//g;
    my @text = split /\n/, $text;
    my @dim  = ( -width => 64, -height => 1 + @text );
    my $txt  = $db->add('ROText', -bg => $bg_help, @dim);
    packit($txt, '1b');
    $txt->configure(-font => create_font($mw, $fo_help));
    map { $txt->insert('end', "     $_\n") } @text;
    $txt->see('end');
    $db->Show;
}


sub on_off_data {
    return q{
        :l^0~ ~t!1~"1^#~r$~s%0]&1_'`2(1])0_*~q+x2,b2-~u.~2/_1020eg2~f*92~:
        :j*62~l*42~n*22~p*02$*z2$*y2!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!:
        :*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*,!*v"^2!"^*k"g2:
        :!"g*]"l2!"l0^T"q2!"q0^K"u2!"u0^D",!"x0^>"02!"00^8"32!"30^22~c"z2:
        :!"z2~c0^,~g",!",~g0^s2~k"w2!"w2~k0^n2~n"v2!"v2~n0^j2+"u2!"u2+0^f:
        :2!1!2!1!2!0^-~v1!2!1!2~v0^^2~y"s2!"s2~y&[2~0"s2!"s2~0&W2/"s2!"s2:
        :/&S2~4"s2!"s2~4&O2~6"s2!"s2~6&L2~7"s2!"s2~7&I2~9"s2!"s2~9&F2~91!:
        :2!1!2~9&C2~;1!2!1!2~;&@2~;"u2!"u2~;&=2~<"v2!"v2~<&:2~<"w2!"w2~<&:
        :72~=",!",~=&42~<"z2!"z2~<&22~;"12!"12~;&z2~;"32!"32~;&w2~;"42!"4:
        :2~;&u2~:"62!"62~:&s2~9"82!"82~9&q2~8":2!":2~8&o2~7"<2!"<2~7&m2~6:
        :">2!">2~6&k2~6"?2!"?2~6&h2~6"A2!"A2~6&e2~6"B2!"B2~6&c2~5"D2!"D2~:
        :5&a2~5"E2!"E2~5&(~3"G2!"G2~3&_2~3"H2!"H2~3&]2/"J2!"J2/ |2/"K2!"K:
        :2/ Z2/"L2!"L2/ X2~1"N2!"N2~1 V2~1"O2!"O2~1 T2~1"P2!"P2~1 R2~1"Q2:
        :!"Q2~1 Q2~0"R2!"R2~0 P2~0"S2!"S2~0 N2~0"T2!"T2~0 L2~0"U2!"U2~0 K:
        :2~y"W2!"W2~y J2~y"X2!"X2~y H2~z"X2!"X2~z G2~y"Y2!"Y2~y F2~y"Z2!":
        :Z2~y D2~y"[2!"[2~y C2~x"|2!"|2~x B2~x)/!)/~x @2~x)]2!)]2~x ?2~w):
        :^2!)^2~w >2~w)_2!)_2~w <2~x)_2!)_2~x ;2~w)a2$)a2~w :2~w)-$)-~w 9:
        :2~v)d2~p)d2~v 82~w)e2~n)e2~w 72~v)g2~l)g2~v 62~v)i2~j)i2~v 52~v):
        :k2~f)k2~v 42~v#;2~v 32.#=2. 22~v#=2~v 12.#?2. 02.#A2. z2.#A2. y2:
        :.#C2. ,!#E2! w2.#E2. v2!#G2! u2.#G2. t2!#I2! t2!#I2! s2!#K2! r2!:
        :#K2! q2!#M2! p2!#M2! p2%#O2% o2!#O2! n2!#O2! n2%#Q2% m2!#Q2! l2%:
        :#S2% l2%#S2% k2!#S2! j2%#U2% j2%#U2% i2!#U2! h2%#W2% h2%#W2% h2%:
        :#W2% g2%#Y2% f2%#Y2% f2%#Y2% f2$#[2$ f2$#[2$ e2%#[2% d2%#[2% d2$:
        :'/$ d2$'/$ d2$'/$ c2%'/% -%'/% -$'^2$ -$'^2$ -$'^2$ -$'^2$ -$'^2:
        :$ -+'(+ -+'(+ a2$'($ ($'($ ($'($ ($'($ ($'($ ($'($ ($'($ (+'-+ (:
        :+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+ (+'-+:
        : (+'-+ (+'-+ ($'($ ($'($ ($'($ ($'($ ($'($ ($'($ ($'($ a2+'(+ -+:
        :'(+ -$'^2$ -$'^2$ -$'^2$ -$'^2$ -$'^2$ -%'/% -%'/% c2$'/$ d2$'/$:
        : d2$'/$ d2%#[2% d2%#[2% e2$#[2$ f2$#[2$ f2%#Y2% f2%#Y2% f2%#Y2% :
        :g2%#W2% h2%#W2% h2%#W2% h2!#U2! i2%#U2% j2%#U2% j2!#S2! k2%#S2% :
        :l2%#S2% l2!#Q2! m2%#Q2% n2!#O2! n2!#O2! o2%#O2% p2!#M2! p2!#M2! :
        :q2!#K2! r2!#K2! s2!#I2! t2!#I2! t2.#G2. u2!#G2! v2.#E2. w2!#E2! :
        :,.#C2. y2.#A2. z2.#A2. 02.#?2. 12~v#=2~v 22.#=2. 32~v#;2~v 42~v#:
        :92~v 52~v#92~v 62~v#72~v 72~w#52~w 82~v#52~v 92~w#32~w :2~w#12~w:
        : ;2~x#z2~x <2~w#z2~w >2~w#,~w ?2~x#v2~x @2~x#t2~x B2~x#r2~x C2~y:
        :#p2~y D2~y#n2~y F2~y#l2~y G2~z#j2~z H2~y#j2~y J2~y#h2~y K2~0#d2~:
        :0 L2~0#-~0 N2~0#(~0 P2~0#^2~0 Q2~1#/~1 R2~1)[2~1 T2~1)Y2~1 V2~1):
        :W2~1 X2/)S2/ Z2/)Q2/ |2/)O2/&]2~3)K2~3&_2~3)I2~3&(~5)E2~5&a2~5)C:
        :2~5&c2~6)?2~6&e2~6)=2~6&h2~6)92~6&k2~6)72~6&m2~7)32~7&o2~8)z2~8&:
        :q2~9)v2~9&s2~:)r2~:&u2~;)n2~;&w2~=)h2~=&z2~=)d2~=&22~?)^2~?&42~A:
        :"Y2~A&72~B"S2~B&:2~D"M2~D&=2~F"E2~F&@2~J";2~J&C2~M"12~M&F2~U"j2~:
        :U&I2]W&L2]U&O2]Q&S2]M&W2]I&[2]E0^^2]A0^-]=0^f2]90^j2]50^n2]10^s2:
        :]v0^,]r0^22]l0^82]f0^>2]`0^D2~[0^K2~S0^T2~I*]2~?*k2~x0e^:
    };
}