package Language::INTERCAL::Interface::X;

# Graphical (Gtk2) interface for sick and intercalc

# This file is part of CLC-INTERCAL

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-X INTERCAL/Interface/X.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use Gtk2;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Interface::common '1.-94.-2';
use vars qw(@ISA);
@ISA = qw(Language::INTERCAL::Interface::common);

my %keymap = (
    ' ' => 'space',
    '!' => 'exclam',
    '"' => 'quotedbl',
    '#' => 'numbersign',
    "'" => 'apostrophe',
    '$' => 'dollar',
    '%' => 'percent',
    '&' => 'ampersand',
    '(' => 'parenleft',
    ')' => 'parenright',
    '*' => 'asterisk',
    '+' => 'plus',
    ',' => 'comma',
    '-' => 'minus',
    '.' => 'period',
    '/' => 'slash',
    ':' => 'colon',
    ';' => 'semicolon',
    '<' => 'less',
    '=' => 'equal',
    '>' => 'greater',
    '?' => 'question',
    '@' => 'at',
    '[' => 'bracketleft',
    '\\' => 'backslash',
    ']' => 'bracketright',
    '^' => 'asciicircum',
    '_' => 'underscore',
    '`' => 'grave',
    '{' => 'braceleft',
    '|' => 'bar',
    '}' => 'braceright',
    '~' => 'asciitilde',
    '¢' => 'cent',
    '¥' => 'yen',
    'Enter' => 'KP_Enter',
);

sub new {
    @_ == 2 or croak "Usage: Language::INTERCAL::Interface::X->new(SERVER)";
    my ($class, $server) = @_;
    $server or croak "Must provide SERVER";
    $ENV{DISPLAY} or return undef;
    Gtk2->init();
    # XXX there's probably a better way of doing this
    Glib::Timeout->add(100, sub { $server->progress(0); 1 });
    my $toplevel = Gtk2::Window->new();
    my $X = bless {
	keylist => {},
	wid => 0,
	toplevel => $toplevel,
	topused => 0,
    }, $class;
    $X->_initialise;
    $X;
}

sub has_window { 1 }
sub is_interactive { 1 }
sub is_terminal { 1 }
sub can_paste { 1 }

sub stdread {
    croak "X interface should not use stdread directly";
}

sub getline {
    @_ == 2 or croak "Usage: X->getline(PROMPT)";
    my ($X, $prompt) = @_;
    my $d = Gtk2::Dialog->new($prompt, undef,
			      [qw(modal destroy-with-parent)],
			      'Go ahead'   => 'accept',
			      'Give up'    => 'reject');
    my $vbox = $d->vbox;
    my $t = Gtk2::Label->new($prompt);
    $vbox->add($t);
    my $e = Gtk2::Entry->new;
    $vbox->add($e);
    $e->signal_connect(activate => sub {$d->response('accept')});
    $d->show_all;
    my $resp = $d->run;
    my $line = undef;
    if ($resp eq 'accept') {
	$line = $e->get_text() . "\n";
    }
    $d->destroy;
    return $line;
}

sub window {
    @_ == 4 || @_ == 5 || @_ == 6
	or croak "Usage: X->window(NAME, DESTROY, DEFINITION [, MENUS [, ACT]])";
    my ($X, $name, $destroy, $def, $menus, $act) = @_;
    my $window;
    if ($X->{topused}) {
	$window = Gtk2::Window->new();
    } else {
	$window = $X->{toplevel};
	$window->resize(1, 1);
	$X->{toplist} = [];
    }
    $window->set_title($name);
    $X->{_accel} = Gtk2::AccelGroup->new();
    $X->{_act} = $act;
    $X->{_alter} = undef;
    delete $X->{_skip_table};
    my $wid = ++$X->{wid};
    my $table = undef;
    if (defined $menus) {
	$X->{_menubar} = Gtk2::MenuBar->new;
	$X->_parse_menus($wid, @$menus);
	$table = Gtk2::Table->new(2, 1);
	if (! $X->{topused}) {
	    unshift @{$X->{toplist}}, $table;
	    unshift @{$X->{toplist}}, $X->{_menubar};
	}
	$table->set_border_width(0);
	$table->attach_defaults($X->{_menubar}, 0, 1, 0, 1);
	$window->add($table);
	delete $X->{_menubar};
    }
    my $content = $X->_parse_def($wid, @$def);
    if ($table) {
	$table->attach_defaults($content->[0], 0, 1, 1, 2);
    } else {
	$window->add($content->[0]);
    }
    $window->add_accel_group($X->{_accel});
    my $alter = $X->{_alter} ? $X->{_alter}[0] : undef;
    delete $X->{_alter};
    delete $X->{_accel};
    delete $X->{_act};
    my $code;
    if ($act) {
	$code = sub {
	    my $res = eval { &$destroy; };
	    $act->($X, $@ || $res, @_);
	    1;
	}
    } elsif ($destroy) {
	$code = sub {
	    &$destroy;
	    0;
	}
    } else {
	$code = sub { 1 };
    }
    $window->signal_connect(delete_event => $code);
    $window->show_all;
    $X->{topused} = 1;
    [$window, $wid, $alter];
}

sub alter_data {
    @_ == 3 or croak "Usage: X->alter_data(WINDOW, DATA)";
    my ($X, $window, $data) = @_;
    $window->[2] or croak "Not alterable";
    my $table = $window->[2];
    $X->{_alter} = undef;
    $X->{_skip_table} = 1;
    my $content = $X->_parse_def(0, @$data);
    $X->{_alter} or croak "Must provide a new alterable item";
    my @goner = $table->get_children;
    for my $goner (@goner) {
	$table->remove($goner);
    }
    my ($newtable, $newrows, $newcols, $newelements) = @{$X->{_alter}};
    delete $X->{_alter};
    delete $X->{_skip_table};
    $table->resize($newrows, $newcols);
    for my $te (@$newelements) {
	my ($e, $c0, $c1, $r0, $r1) = @$te;
	$table->attach_defaults($e->[0], $c0, $c1, $r0, $r1);
    }
    $table->show_all;
    $X;
}

sub show {
    @_ == 2 or croak "Usage: X->show(WINDOW)";
    my ($X, $window) = @_;
    $window->[0]->set_keep_above(1);
    $window->[0]->deiconify;
    $window->[0]->show_all;
    $window->[0]->set_keep_above(0);
    $window;
}

sub start {
    @_ == 1 or croak "Usage: X->start";
    my ($X) = @_;
    Gtk2->main_iteration() while Gtk2->events_pending();
}

sub run {
    @_ == 1 or croak "Usage: X->run";
    my ($X) = @_;
    Gtk2->main;
}

sub stop {
    @_ == 1 or croak "Usage: X->stop";
    my ($X) = @_;
    Gtk2->main_quit if Gtk2->main_level > 0;
}

sub pending_events {
    @_ == 1 or croak "Usage: X->pending_events";
    return 0; # XXX
    return Gtk2->events_pending();
}

sub update {
    @_ == 1 or croak "Usage: X->update";
    my ($X) = @_;
    Gtk2->main_iteration() while Gtk2->events_pending();
}

sub has_paste {
    @_ == 1 or croak "Usage: X->has_paste";
    my ($X) = @_;
    my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY'));
    return $clipboard->wait_is_text_available;
}

sub do_paste {
    @_ == 1 or croak "Usage: X->do_paste";
    my ($X) = @_;
    my $clipboard = Gtk2::Clipboard->get(Gtk2::Gdk::Atom->new('PRIMARY'));
    $clipboard->wait_is_text_available or return;
    my $text = $clipboard->wait_for_text;
    while ($text ne '') {
	my $k = substr($text, 0, 1, '');
	&{$X->{keylist}{$k}} if exists $X->{keylist}{$k};
	Gtk2->main_iteration() while Gtk2->events_pending();
    }
}

sub _set_text {
    my ($X, $text, $value) = @_;
    $text->[0]->set_label($value);
}

sub _get_text {
    @_ == 2 or croak "Usage: X->get_text(NAME)";
    my ($X, $text) = @_;
    $text->[0]->get_label();
}

sub close {
    @_ == 2 or croak "Usage: X->close(WINDOW)";
    my ($X, $window) = @_;
    if ($window->[0] == $X->{toplevel}) {
	# we never close the main window - otherwise when they change mode
	# or reload the compiler the main window gets closed and may be
	# reopened in a different screen / location which I find annoying
	# and I assume other people may find annoying too.
	$_->destroy for @{$X->{toplist}};
	$X->{topused} = 0;
    } else {
	$X->_close($window->[1]);
	$window->[0]->destroy;
    }
}

sub enable {
    @_ == 2 or croak "Usage: X->enable(BUTTON)";
    my ($X, $button) = @_;
    ref $button->[1] or die "Cannot enable this element\n";
    $button->[0]->set_relief('normal');
    ${$button->[1]} = 1;
}

sub disable {
    @_ == 2 or croak "Usage: X->disable(BUTTON)";
    my ($X, $button) = @_;
    ref $button->[1] or die "Cannot disable this element\n";
    $button->[0]->set_relief('none');
    ${$button->[1]} = 0;
}

sub file_dialog {
    @_ == 5 or croak "Usage: X->file_dialog(TITLE, NEW?, OK, CANCEL)";
    my ($X, $title, $new, $ok, $cancel) = @_;
    my $window = Gtk2::Window->new();
    my @acts = (
	(defined $new ? 'save' : 'open'),
	$ok => 'accept',
	$cancel => 'cancel',
    );
    my $dialog = Gtk2::FileChooserDialog->new($title, $window, @acts);
    $new and $dialog->set_filename($new);
    my $resp = $dialog->run;
    my $file = undef;
    if ($resp eq 'accept') {
	$file = $dialog->get_filename;
    }
    $dialog->destroy;
    $file;
}

sub _make_table {
    my ($X, $rows, $cols, $elements, $border, $alter) = @_;
    my $table = $alter && $X->{_skip_table}
	      ? undef
	      : Gtk2::Table->new($rows, $cols);
    unshift @{$X->{toplist}}, $table if ! $X->{topused};
    $X->{_alter} = [$table, $rows, $cols, $elements] if $alter;
    defined $table or return [0, 0];
    $table->set_border_width($border);
    for my $te (@$elements) {
	my ($e, $c0, $c1, $r0, $r1) = @$te;
	$table->attach_defaults($e->[0], $c0, $c1, $r0, $r1);
    }
    [$table, 0];
}

sub _make_text {
    my ($X, $value, $align, $size) = @_;
    my $text = Gtk2::Label->new($value);
    unshift @{$X->{toplist}}, $text if ! $X->{topused};
    $text->set_width_chars($size) if $size;
    $text->set_max_width_chars($size) if $size;
    $text->set_alignment(0.0, 0.0) if $align =~ /^l/i;
    $text->set_alignment(0.5, 0.0) if $align =~ /^c/i;
    $text->set_alignment(1.0, 0.0) if $align =~ /^r/i;
    [$text, 0];
}

sub _make_key {
    my ($X, $label, $action, $keys) = @_;
    my $key = Gtk2::Button->new_with_label($label);
    unshift @{$X->{toplist}}, $key if ! $X->{topused};
    my $acode;
    my $enabled = 1;
    if ($X->{_act}) {
	my $act = $X->{_act};
	$acode = sub {
	      $@ = '';
	      $enabled or return;
	      my $res = eval { $action->(@_); };
	      $act->($X, $@ || $res, @_);
	};
    } else {
	$acode = sub {
	      $@ = '';
	      $enabled or return;
	      $action->(@_);
	};
    }
    $key->signal_connect(clicked => $acode);
    for my $k (@$keys) {
	$X->{keylist}{$k} = $action;
	$k =~ s/^([\c@-\c_])$/sprintf("<control>%c", 64 + ord($1))/e;
	$k =~ s/^([A-Z])$/sprintf("<shift>%c", 32 + ord($1))/e;
	$k = $keymap{$k} if exists $keymap{$k};
	my ($a, $m) = Gtk2::Accelerator->parse($k);
die "k=$k a=$a m=$m\n" if $a == 0; # XXX
	my $fs = sub { $key->activate };
	$X->{_accel}->connect($a, $m, [], $fs);
    };
    [$key, \$enabled];
}

sub _make_menu {
    my ($X, $name) = @_;
    my $menu = Gtk2::Menu->new;
    my $item = Gtk2::MenuItem->new_with_label($name);
    $item->show;
    $X->{_menubar}->append($item);
    $item->set_submenu($menu);
    [$menu, 0];
}

sub _make_menu_entry {
    my ($X, $action, $menu, $name, $entry, $ticks) = @_;
    my $item;
    if ($ticks) {
	$item = Gtk2::CheckMenuItem->new_with_label($entry);
    } else {
	$item = Gtk2::MenuItem->new_with_label($entry);
    }
    $menu->[0]->append($item);
    my $enabled = 1;
    my $acode;
    if ($X->{_act}) {
	my $act = $X->{_act};
	$acode = sub {
	      $@ = '';
	      $enabled or return;
	      my $res = eval { $action->($X, $name, $entry); };
	      $act->($X, $@ || $res, @_);
	};
    } else {
	$acode = sub {
	      $enabled or return;
	      $action->($X, $name, $entry);
	};
    }
    $item->signal_connect(activate => $acode);
    $item->show;
    [$item, \$enabled, $ticks];
}

sub _enable_menu {
    my ($X, $item, $state, $name, $entry) = @_;
    ref $item->[1] or die "Cannot enable this menu\n";
    ${$item->[1]} = $state;
    $state ? $item->[0]->show : $item->[0]->hide;
    1;
}

sub _tick_menu {
    my ($X, $item, $state, $name, $entry) = @_;
    $item->[2] or die "Cannot tick this menu\n";
    my $ov = ${$item->[1]};
    ${$item->[1]} = 0;
    $item->[0]->set_active($state);
    ${$item->[1]} = $ov;
    1;
}

sub _menu_action {
    my ($X, $item, $name, $entry) = @_;
    $item->activate;
}

1;