#!/usr/bin/perl
# Filename:	asq
# Author:	David Ljung Madison <DaveSource.com>
# See License:	http://MarginalHacks.com/License
  my $VERSION=  2.03;
# Description:	Mame Cabinet front end
#
#		Runs in a unix terminal window and is controlled by mame keys
#		(Hence the name - "asq" is buttons 1,2,3 for player 2)
#
#		Also reads ~/.asqrc or $0.rc for a list of non-mame games
#		to add to the top of the menu, format is:
#		<name> <tab> <command> <tab> <display title>
# Bugs:		Can't remap shifted keys

# Requires:	Curses::UI
#		SMALL PATCH TO CURSES::UI REQUIRED!
#
# Change Curses/UI/Listbox.pm (line 430 in v0.71) from:
#
#        $this->run_event('-onchange') if $changed;
# to:
#        $this->run_event('-onchange') if $changed || $this->{-select_again};
#
#		SMALL PATCH TO CURSES::UI REQUIRED!
use strict;
use Curses;	# Gives us KEY_UP, etc...
use Curses::UI;
# Also optionally uses Tk, see setup_Tk() below

##################################################
# Setup the variables
##################################################
my $PROGNAME = $0;
$PROGNAME =~ s|.*/||;

my $XMODMAP = "xmodmap";	# For key remapping

my %GAMES;

##################################################
# Usage
##################################################
sub usage {
  foreach my $msg (@_) { print STDERR "ERROR:  $msg\n"; }
  print STDERR "\n";
  print STDERR "Usage:\t$PROGNAME [-d] <file>\n";
  print STDERR "\tDoes something to the given file\n";
  print STDERR "\t-d\tSet debug mode\n";
  print STDERR "\n";
  exit -1;
}

sub parse_args {
  my $file;
  while (my $arg=shift(@ARGV)) {
    if ($arg =~ /^-h$/) { usage(); }
    if ($arg =~ /^-d$/) { $MAIN::DEBUG=1; next; }
    if ($arg =~ /^-/) { usage("Unknown option: $arg"); }
    usage("Too many files specified [$arg and $file]") if (defined($file));
    $file=$arg;
  }
  #usage("No file defined") if (!defined($file));

  ($file);
}

sub debug {
  return unless $MAIN::DEBUG;
  foreach my $msg (@_) { print STDERR "[$PROGNAME] $msg\n"; }
}

##################################################
# Image stuff (TK)
##################################################
my $MW;
my $PHOTO;
my %LOADED;
sub show_img {
  my ($img) = @_;
  return 0 unless $MW;
  $PHOTO->blank;
  if ($img && -f $img) {
    eval { $PHOTO->read($img, -shrink) };	# Avoid fatal errors
    my $w = $@;
    if ($w) {
      $w .= "\nMaybe you need a Tk::Loader for image type: [$img]?\n"
        if $w =~ /recognize data in image/;
      mywarn($w);
    }
  }
  $MW->update;
  return 1;
}

sub image_window {
  return if defined $MW;
  $MW = new Tk::MainWindow(-width => '290', -height => '290');
  my $canvas = $MW->Canvas(-height => 290, -width  => 290, -background => 'white');
  $PHOTO = $canvas->Photo();
  my $image = $canvas->createImage(5,5, -image => $PHOTO, -anchor => 'nw');
  $canvas->pack(-side => 'top');
  $MW->MapWindow;
  show_img();	# Blank it..
}

# "require" instead of "use" so we don't require Tk if they don't use images.
# And even cooler, we only load JPEG/PNG/.. loaders if they need them.  :)
use Tk;	# fix a bug..
sub setup_Tk {
  my ($types) = @_;

  require Tk unless $LOADED{Tk}++;

  # Also check "type" - and get that loader if we haven't yet.
  foreach my $type ( split(',',$types) ) {
    require Tk::JPEG if ($type =~ /jpe?g$/i) && !$LOADED{jpeg}++;
    require Tk::PNG if ($type =~ /png$/i) && !$LOADED{png}++;
    require Tk::TIFF if ($type =~ /tiff$/i) && !$LOADED{tiff}++;
  }
  # If you know of any other generic Tk::type loaders, let me know.

  # And bring up the window
  image_window();
}

# This is poking into Curses::UI::Listbox, so it might break..
sub get_listbox_active {
  my ($win) = @_;
  $win->{-values}->[$win->{-ypos}];
}

sub try_show_img {
  my ($dir,$name,$types) = @_;
  foreach my $type ( split(',',$types) ) {
    my $file = "$dir/$name.$type";
    return show_img($file) if -f $file;
  }
  return 0;
}

# Update the image window with the current active list item
sub update_img {
  my ($win,$name) = @_;

  return show_img() unless $win;
  return show_img() unless $GAMES{$name}{images};

  my $item = get_listbox_active($win);
  return show_img() unless $item;

  # Try to find the corresponding file
  my $dir = $GAMES{$name}{images};
  my $type = $GAMES{$name}{image_type};

  # Obvious attempt
  return if try_show_img($dir,$item,$type);

  # Remove path from item
  $item =~ s|.*/||;
  return if try_show_img($dir,$item,$type);

  # Remove .postfix from item
  $item =~ s|\..{0,4}$||;
  return if try_show_img($dir,$item,$type);

  # "Pacman (Japan)" -> "Pacman"
  my $try = $item;
  $try =~ s/\s*\([^\)]*\)$//;
  $try =~ s/\s*\[[^\]]*\]$//;
  return if try_show_img($dir,$try,$type);
  $try =~ s/\s*\([^\)]*\)//g;
  $try =~ s/\s*\[[^\]]*\]//g;
  return if try_show_img($dir,$try,$type);

  # Kludge:  "'88 Games.jpg" -> "`88 Games.jpg"
  $try =~ s/'/`/g;
  return if try_show_img($dir,$try,$type);

  # If it's mame, try the short name
  if ($GAMES{$name}{type} eq 'MAME' && ($try = $GAMES{_mame}{short}{$item})) {
    return if try_show_img($dir,$try,$type);
  }

  # Nope - just blank the window
  return show_img();
}

##################################################
# Curses utilities
##################################################
my $ROOT;
my $ROOTWIN;
my $MAIN_LIST;
sub curses_init {
  $ROOT = new Curses::UI ( -clear_on_exit => 0 );
  $ROOT->set_binding( sub{ exit }, "\cQ" );
  $ROOT->set_binding( sub{ exit }, "q" );
  $ROOTWIN = $ROOT->add('root', 'Window', -padtop=>0, -padbottom=>0, ipad=>0);
}

my $IN_CURSES = 0;
my %WARNINGS;
sub mywarn {
  my ($str,@args) = @_;
  return if $WARNINGS{$str}++;
  $IN_CURSES ?  $ROOT->error(sprintf "[$PROGNAME] ".$str."\n",@args) :
                printf STDERR "[$PROGNAME] ".$str."\n",@args;
}
sub fatal { mywarn(@_); exit(-1); }

#########################
# Bindings for all selectors
#########################
# hack!  escape looks like "" to curses.  Unfortunately it has a delay as well..
sub KEY_ESCAPE() { "" };
sub mame_bindings {
  my ($win,$name) = @_;
  $win->set_binding( sub { $win->option_first; update_img($win,$name) }, "5" );
  $win->set_binding( sub { $win->option_last; update_img($win,$name) }, "7" );
  $win->set_binding( sub { $win->option_prevpage; update_img($win,$name) }, KEY_LEFT() );
  $win->set_binding( sub { $win->option_nextpage; update_img($win,$name) }, KEY_RIGHT() );
  $win->set_binding( sub { $win->option_prev; update_img($win,$name) }, KEY_UP );
  $win->set_binding( sub { $win->option_next; update_img($win,$name) }, KEY_DOWN );
  $win->set_binding( sub { $win->option_prev; update_img($win,$name) }, "k" );
  $win->set_binding( sub { $win->option_next; update_img($win,$name) }, "j" );
  $win->set_binding( sub { $win->option_prev; update_img($win,$name) }, "r" );
  $win->set_binding( sub { $win->option_next; update_img($win,$name) }, "f" );
  $win->set_binding( sub { foreach (1..5) { $win->option_prevpage; } update_img($win,$name) }, "d");
  $win->set_binding( sub { foreach (1..5) { $win->option_nextpage; } update_img($win,$name) }, "g");
  $win->set_binding( sub { $win->option_select; update_img($win,$name) }, "1" );
  $win->set_binding( sub { $win->search_forward; update_img($win,$name) }, "/" );
  $win->set_binding( sub { $win->search_backward; update_img($win,$name) }, "?" );
  update_img($win,$name);
}

# For curses_system
sub add_text {
  my ($out,$height,@text) = @_;
  $height-=2;	# Space for border
  @text=splice(@text,$#text+1-$height) if $#text+1>$height;
  $out->text(join('',@text));
  $out->draw();
  @text;
}

#########################
# Keyboard remapping
#########################
my %KEYBOARD;	# Initial keyboard mapping
sub get_initial_map {
  return if %KEYBOARD;
  open(MAP,"$XMODMAP -pke|") ||
    fatal("Remapping keys and can't run xmodmap [$XMODMAP]");
  while (<MAP>) {
    chomp;
    fatal("Couldn't understand xmodmap output [$XMODMAP -pke]:\n  $_")
      unless /^\s*keycode\s+(\d+)\s*=\s*((\S+)(\s+\S+)?)?$/;
    my ($code,$key,$keys) = ($1,$3,$2);
    $KEYBOARD{$key}{code} = $code;
    $KEYBOARD{$key}{init} = $_;
  }
  close MAP;
}

sub do_map {
  my ($map) = @_;
  return unless $map;

  get_initial_map();

  my @change;
  my @fix;

  open(MAP,"<$map") || return mywarn("Can't read map file [$map]");
  while (<MAP>) {
    # Format should be "<key><space><key>"
    chomp;
    s/#.*//;		# Ignore comments
    next if /^\s*$/;	# Ignore whitespace

    fatal("Couldn't understand entry in key remap file [$map]:\n  $_")
      unless /^\s*(\S+)\s+(\S+)\s*$/;
    my ($from,$to) = ($1,$2);
# BUG: We can't remap shifted keys...
    fatal("[$map, $.] Unknown key [$from]\n".
          "See 'xmodmap -pk' for spelling.\n") unless $KEYBOARD{$from};
    fatal("[$map, $.] Unknown key [$to]\n".
          "See 'xmodmap -pk' for spelling.\n") unless $KEYBOARD{$to};
    my $code = $KEYBOARD{$from}{code};

    push(@fix,"-e",$KEYBOARD{$from}{init});
    push(@change,"-e","keycode $code = $to");
  }
  close MAP;

  system($XMODMAP,@change) if (@change);
  @fix;
}

#########################
# Run a command, output in a window
#########################
sub curses_system {
  my ($sys,$title,$map,$height) = @_;

  $height = $height || 20;
  $title = $title || "Run: $sys";

  my @text=("");

  my $out = $ROOTWIN->add('sys_output', 'Label', -title=>$title,
    -x => 2, -y => 2, -height=>$height, -width=>75, -border=>1);

  @text = add_text($out,$height,@text);

  # Remap keys
  my @fix = do_map($map);

  my $start = time;
  open(SYS,"$sys 2>&1 |") || fatal("Couldn't run $sys");

  select((select(SYS), $| = 1) [0]);    # Unbuffer output
  while(<SYS>) {
    @text = add_text($out,$height,@text,$_);
  }
  close SYS;

  # Unremap keys
  system($XMODMAP,@fix) if (@fix);

  # "Hit any key" if we ran for <10 seconds
  if (time-$start<10) {
    @text = add_text($out,$height,@text,"\n","Done.  Hit any key");
    my $ans;
    read(STDIN,$ans,1);
  }

  $ROOTWIN->delete('sys_output');
}

#########################
# Create a listbox of selections to run
#########################
my $SELECT_MENU;
sub handle_select() {
  my $select_run = shift;
  my $name = $select_run->get;
  return unless $name;

  my $g = $GAMES{$SELECT_MENU};
  fatal("Internal error: Can't find submenu info for $SELECT_MENU??\n")
    unless $g;

  my $cmd = $g->{command};
  if ($cmd =~ /%s/) {
    $cmd =~ s/\%s/$name/g;
  } else {
    $cmd .= " \Q$name\E";
  }

  curses_system($cmd,$g->{title},$g->{map});
  $select_run->focus();
  update_img($select_run,$SELECT_MENU);
}

sub select_run {
  my ($name,$cmd,$games,$labels) = @_;

  $SELECT_MENU = $name;

  my $height = $#$games+3;
  my $select_run = $ROOTWIN->add(
    'select_run', 'Listbox',
    -values    => \@$games,
    -labels    => \%$labels,
    -width      => 60,
    -height     => $height,
    -y          => 7,
    -x          => 3,
    -padbottom  => 0,
    -border     => 1,
    -title      => $name,
    -vscrollbar => 1,
    -wraparound => 1,
    -select_again => 1,
    -onchange   => \&handle_select,
  );
  mame_bindings($select_run,$name);

  $select_run->focus();
  $select_run->draw();

  my $quit = 0;
  $ROOT->set_binding( sub{ $quit = 1; }, "q" );
  while(!$quit) {
    Curses::UI::do_one_event($ROOT);
  }
  $ROOT->set_binding( sub{ exit }, "q" );
  $MAIN_LIST->focus();
  $MAIN_LIST->draw();
  $ROOTWIN->delete('select_run');
}

##################################################
# Handle a selection in the main menu
##################################################
sub main_select() {
  my $listbox = shift;
  my $name = $listbox->get;
  return unless $name;
  return if $name =~ /^--/;	# Separator

  my $g = $GAMES{$name};
  fatal("Internal error: Unknown game?? [$name]") unless $g;

  if ($g->{type} eq "MAME") {
    #get_mamelist($g->{mame});
    select_run($name,$g->{command},$GAMES{_mame}{games},$GAMES{_mame}{labels});
  } elsif ($g->{type} eq "DIR") {
    select_run($name,$g->{command},$g->{games},$g->{labels});
  } else {
    curses_system($g->{command},$g->{title},$g->{map});
  }
  $listbox->focus();
  update_img($listbox,"_main");
}

##################################################
# MENUS
##################################################

#########################
# Mame games (from 'mame -list')
#########################
sub get_mamelist {
  my ($mame) = @_;

  return if $GAMES{_mame};

  my @games;
  my %labels;

  # Get full gamelist for manufacturer/year info
  open(G,"$mame -listgames 2>/dev/null|") ||
    fatal("Couldn't run mame [$mame] to get gamelist");
  my @lg = <G>;
  close G;

  # Check header
  my $hdr = shift(@lg);
  shift(@lg);
  fatal("Output format of gamelist changed?? [$mame -listgames]")
    unless ($hdr =~ /^year (manufacturer\s+)name$/);
  my $manu_re = "."x(length($1)-1).'+?\s+';

  my $p = $ROOT->progress( -max => $#lg , -message => "Reading mame list..", );
  #$p->draw();

  # Read gamelist
  my $c = 0;
  foreach ( @lg ) {
    # Update progressbar every 50 games
    $ROOT->setprogress($c) unless (($c++)%50);
    next if /^\s*$/;
    next if /^Total Supported:/;
    if (/^([\d\?]{4})[\s\?]+(\S.+)$/) {
      my ($y,$mn,$m,$n) = ($1,$2);
      print STDERR "[$PROGNAME] WARNING: Unknown listgames line:\n  $_"
        unless ($mn =~ /^($manu_re)(.+)$/);
      ($m,$n) = ($1,$2);
# Stupid kludge for the fact that some manufacturer lines go way into
# the name column, and we have no way to figure this out...
($m,$n) = ($m.$1,$2) if $n =~ /^(license\))\s+(\S.+)/;
      $m =~ s/\s+$//;
      push(@games,$n);
      $labels{$n} = sprintf("%4.4d| $n",$y);
#
# We don't currently use this info...
#
#      $GAMES{_mame}{info}{$n}{manufacturer} = $m;
#      $GAMES{_mame}{info}{$n}{year} = $y;
#      $GAMES{_mame}{info}{$n}{line} = $.;
#      $GAMES{_mame}{info}{$n}{title} = "$mame $n [$y] ($m)";
    } else {
      print STDERR "[$PROGNAME] WARNING: Unknown gamelist line:\n  $_";
    }
  }

  # Get shortnames for each game
  open(G,"$mame -listfull 2>/dev/null|") ||
    fatal("Couldn't run mame -listfull [$mame] to get gamelist");
  # Ignore first two lines
  $_ = <G>;  $_ = <G>;
  $c = 0;
  $ROOT->noprogress;
  $p = $ROOT->progress( -max => $#lg , -message => "Getting mame aliases..", );
  while(<G>) {
    # Update progressbar every 50 games
    $ROOT->setprogress($c) unless (($c++)%50);
    last if /^\s*$/;
    $GAMES{_mame}{short}{$2} = $1 if (/^(\S+)\s*"([^"]+)"\s*$/);
  }
  close G;

  @games = sort @games;
  $GAMES{_mame}{games} = \@games;
  $GAMES{_mame}{labels} = \%labels;

  $ROOT->noprogress;

  scalar @games;
}

#########################
# A directory of selections
#########################
my %DIRLIST_CACHE;
sub get_dirlist {
  my ($name,$dir,$re) = @_;

  if ($DIRLIST_CACHE{$dir}{$re}) {
    my $cache = $DIRLIST_CACHE{$dir}{$re};
    $GAMES{$name}{games} = $cache->{games};
    $GAMES{$name}{labels} = $cache->{labels};
    return 0;
  }

  my @games;
  my %labels;

  opendir(DIR,$dir) || fatal("ERROR: Couldn't read directory [$dir]\n");
  my @dir = grep(!/^\.{1,2}$/, readdir(DIR));
  closedir(DIR);
  @dir = grep(/$re/i, @dir) if $re;

  foreach my $game ( sort @dir ) {
    my $name = $game;
    $name =~ s/\.z$//;
    $name =~ s/\.[^\.]+$//;

    #push(@games,$name);
    #$labels{$name} = "$dir/$game";
    push(@games,"$dir/$game");
    $labels{"$dir/$game"} = $name;
  }

  $GAMES{$name}{games} = \@games;
  $GAMES{$name}{labels} = \%labels;

  $DIRLIST_CACHE{$dir}{$re} = $GAMES{$name};

  scalar @games;
}

#########################
# Main menu (Games listed in the rc file)
#########################
sub get_gamelist {
	my ($rc) = @_;
  my (@games,%labels,$total);
  my $counted_mame;

  $rc = $ENV{HOME}."/.${PROGNAME}rc" unless -f $rc;
  $rc = "${0}.rc" unless -f $rc;
  $rc = "${PROGNAME}.rc" unless -f $rc;

  open(RC,"<$rc") || fatal("Can't read rc file: [$rc]\n");
  while(<RC>) {
    chomp;
    s/#.*//;		# Ignore comments
    next if /^\s*$/;	# Ignore whitespace

    #########################
    # Separator
    #########################
    if (/^\s*--(.*)/) {
      $_.="-"x(40-length($_));
      push(@games,$_);
      next;
    }

    #########################
    # IMAGES=<dir> for main menu
    #########################
    if (/^\s*IMAGES(\[(.*)\])?=(.*)/) {
      $GAMES{_main}{images} = $3;
      $GAMES{_main}{image_type} = $2;
      next;
    }

    #########################
    # Launch item
    #########################
    my @l = split(/\t+/);
    fatal("Couldn't parse rc line [$rc, line $.]:\n  $_\n") unless $#l>0;
    my ($name,$what,$opt,@args) = @l;
    fatal("Can't name a game '$name' - that's reserved!\n")
      if $name eq '_mame' || $name eq '_main';
    my $num;

    if ($what =~ /^MAME:(.*)/) {
      my ($cmd,$roms) = ($opt,$1);
      my ($mame,$args) = ($cmd);
      ($mame,$args) = ($1,$2) if $mame =~ /^\s*(\S+)\s+(\S.*)$/;
      fatal("ERROR [$rc, line $.]: Couldn't find mame rompath 'MAME:<roms>':\n  $_\n")
        unless -d $roms;
      fatal("ERROR [$rc, line $.]: Couldn't find mame executable $mame:\n  $_\n")
        unless -x $mame;
      $GAMES{$name}{mame} = $mame;
      $GAMES{$name}{command} = "$mame -rp $roms $args";
      $GAMES{$name}{type} = "MAME";
      $num = 0;
    } elsif ($what =~ /^DIR(\[(.*)\])?:(.*)/) {
      my ($cmd,$dir,$re) = ($opt,$3,$2);
      my $exec = $cmd;
      $exec =~ s/^esddsp\s*//;	# Ignore esddsp (real kludgy)
      $exec =~ s/\s.*//;	# Take first word (kinda kludgy)
      fatal("ERROR [$rc, line $.]: Couldn't find directory 'DIR:<directory>':\n  $_\n")
        unless -d $dir;
      fatal("ERROR [$rc, line $.]: Couldn't find executable [$exec]:\n  $_\n")
        unless -x $exec;
      $GAMES{$name}{command} = $cmd;
      $GAMES{$name}{type} = "DIR";
      $num = get_dirlist($name,$dir,$re);
    } else {
      $GAMES{$name}{command} = $what;
      $GAMES{$name}{title} = $opt || $name;
      $num = 1;
    }

    # Handle the optional arguments
    foreach my $arg ( @args ) {
      if ($arg =~ /^MAP=(.*)/) {
        $GAMES{$name}{map} = $1;
      } elsif ($arg =~ /^IMAGES(\[(.*)\])?=(.*)/) {
        my ($type,$dir) = ($2,$3);
        setup_Tk($type);
        $GAMES{$name}{images} = $dir;
        $GAMES{$name}{image_type} = $type;
      } else {
        fatal("ERROR [$rc, line $.]: Unknown option [$arg]:\n  $_\n");
      }
    }

    push(@games,$name);

    $num = $num>2 ? sprintf("%4d|",$num) : "    |";
    $labels{$name} = "$num $name";
    $total+=$num;
  }
  close RC;
  (\@games,\%labels,$total);
}

##################################################
# Main code
##################################################
sub main {
  my ($games,$labels,$tot) = get_gamelist(parse_args);

  curses_init();  $IN_CURSES=1;

  # Do we need to get mame games?
  foreach my $game ( @$games ) {
    if ($GAMES{$game}{mame}) {
      $tot += get_mamelist($GAMES{$game}{mame});
      $labels->{$game} = sprintf("%4d|", scalar @{$GAMES{_mame}{games}})." $game";
      last;
    }
  }

  $ROOTWIN->add('directions', 'Label', -text => <<DIRECTIONS);
MAME Cabinet Front End          http://MarginalHacks.com/
---------------------------------------------------------
Player 1 joystick= back, forward, page back, page forward
         button 1= select
Player 2 joystick= back, forward, 5*pg back, 5*pg forward
         button 3= exit menu
DIRECTIONS

  my %labels;	 # Unused - our values array has the right strings..
  my $height = $#$games+3;
  $MAIN_LIST = $ROOTWIN->add(
    'main_list', 'Listbox',
    -values    => $games,
    -labels    => $labels,
    -width      => 60,
    -height     => $height,
    -y          => 7,
    -x          => 3,
    -padbottom  => 0,
    -border     => 1,
    -title      => ' # - Games',
    -vscrollbar => 1,
    -wraparound => 1,
    -select_again => 1,
    -onchange   => \&main_select,
  );
  mame_bindings($MAIN_LIST,"_main");

  $ROOTWIN->add('total', 'Label', -y => 7+$height, -text =>
    sprintf("   %5d| Total games\n",$tot));

  $MAIN_LIST->focus();

	$ROOT->mainloop;
}
main();