package Rel2;

# TODO compose / join Rels
#   represent as directed graph of rels connected via their nodes
#   given list of inputs and outputs, generate limited DAG to achieve it
#   given DAG, generate serial task schedule to achieve it, run it
#     also parallel, but that's just the DAG really

# then look at building a pure make-like tool which can handle multi-mode
# relations, and streams / stream/file combos

use strict; use warnings;

use Lib;
use L;

sub new {
	my ($class, @fields) = @_;
	my $i = 0;
	my $self = {
		fields => \@fields,
	};
	$self->{field_i} = order($self->{fields});
	bless $self, $class;
	return $self;
}

sub fields {
	my ($self) = @_;
	return wantarray ? @{$self->{fields}} : $self->{fields};
}

# this is a shallow clone
sub clone {
	my ($self) = @_;
	my $class = ref $self;
	my $rel = bless {%$self}, $class;
	$rel->{fields} = [@{$rel->{fields}}];
	return $rel;
}

sub where_to_hash {
	my ($self, $where) = @_;
	if (ref $where eq "ARRAY") {
		$where = $self->ary_to_hash($where);
	}
	return $where;
}

sub ary_to_hash {
	my ($self, $where) = @_;
	return { map {$self->{fields}[$_] => $where->[$_]} 0..$#$where };
}

# FIXME rename works inplace for now.
# so be careful with some functions that might have returned the original data set not a new one!!
sub rename {
	my ($self, %name_map) = @_;
	my $rel = $self->clone;
	for (@{$rel->{fields}}) {
		if (defined $name_map{$_}) {
			$_ = $name_map{$_};
		}
	}
	return $rel;
}

sub fields_to_name_map_fields_fields_out {
	my ($self, $fields, $options) = @_;
	my ($name_map, $fields_out);
	if ($options->{rename}) {
		$name_map = { @$fields };
		$fields_out = evens($fields);
		$fields = odds($fields);
	} else {
		$name_map = { map {$_=>$_} @$fields };
		$fields_out = $fields;
	}
	return ($name_map, $fields, $fields_out);
}

sub map {
	my ($self, $fields, $where, $options) = @_;
	my $rows_wide = $self->where($where, $options);
	my $rows = $rows_wide->cut($fields, $options);
	return $rows;
}


package Table;

use strict; use warnings;

use Lib;
use L;

use base 'Rel2';

sub new {
	my ($class, @fields) = @_;
	my $self = $class->SUPER::new(@fields);
	$self->{rows} = [];
	$self->{indexes} = {};
	return $self;
}

sub rows {
	my ($self) = @_;
	return wantarray ? @{$self->{rows}} : $self->{rows};
}

sub rows_hash {
	my ($self) = @_;
	my @hashes = map {$self->row_to_hash($_)} @{$self->{rows}};
	return wantarray ? @hashes : \@hashes;
}

sub col_i {
	my ($self, $i) = @_;
	$i ||= 0;
	my @col = map {$_->[$i]} @{$self->rows};
	return wantarray ? @col : \@col;
}

sub col {
	my ($self, $name) = @_;
	return $self->col_i($self->{field_i}{$name});
}

sub print_tsv {
	my ($self) = @_;
	print join "\t", @{$self->{fields}};
	print "\n";
	print join "\t", map {'-' x length($_)} @{$self->{fields}};
	print "\n";
	for my $row (@{$self->{rows}}) {
		print join "\t", @$row;
		print "\n";
	}
	print "\n";
}

sub print_records {
	my ($self) = @_;
	for my $row (@{$self->{rows}}) {
		for my $i (0..$#{$self->{fields}}) {
			print "$self->{fields}[$i]: $row->[$i]\n";
		}
		print "\n";
	}
	print "\n";
}

sub insert {
	my ($self, @args) = @_;
	my $row = $args[0];
	if (@args > 1) {
		$row = $self->hash_to_row({@args});
	} elsif (ref($row) eq "HASH") {
		$row = $self->hash_to_row($row);
	}
	push @{$self->{rows}}, $row;
}

sub hash_to_row {
	my ($self, $hash) = @_;
	my @row;
	for my $k (@{$self->{fields}}) {
		push @row, $hash->{$k};
	}
	return \@row;
}

sub row_to_hash {
	my ($self, $row) = @_;
	my %hash;
	for my $i (0..$#{$self->{fields}}) {
		$hash{$self->{fields}[$i]} = $row->[$i];
	}
	return \%hash;
}

sub select {
	my ($self, $fields, $where, $options) = @_;
	my $rows_wide = $self->where($where, $options);
	my $rows = $rows_wide->cut($fields, $options);
	return $rows;
}

sub true { return 1; }
sub false { return 0; }

sub cut {
	my ($self, $fields, $options) = @_;
	if (!$fields) { return $self }
	my ($name_map, $fields_out);
	($name_map, $fields, $fields_out) = $self->fields_to_name_map_fields_fields_out($fields, $options);
	my $result = (ref $self)->new(@$fields_out);  # do in method
	my @cut_slice = map {$self->{field_i}{$_}} @$fields;
	if (grep {!defined $_} @cut_slice) {
		die "unknown field/s: @$fields";
	}
	$result->{rows} = [map { [@{$_}[@cut_slice]] } @{$self->{rows}}];
	return $result;
}

sub where {
	my ($self, $where, $options) = @_;
	if (!$where) { return $self }
	if (defined $options->{from} || defined $options->{to}) {
		die "from - to not done yet";
	}
	$where = $self->where_to_sub($where);
	# TODO try to use indexes!  in order
	my $rows = [grep { $where->($_) } @{$self->{rows}}];
	my $result = (ref $self)->new(@{$self->{fields}});  # do in method
	$result->{rows} = $rows;
	return $result;
}

sub where_to_sub {
	my ($self, $where) = @_;
	$where = $self->where_to_hash($where);
	if (ref $where eq "HASH") {
		$where = $self->hash_to_sub($where);
	}
	return $where;
}

sub hash_to_sub {
	my ($self, $where) = @_;
	my $match_row = $self->hash_to_row($where);
	my @match_slice = grep {defined $match_row->[$_]} 0..$#$match_row;
	my @match = @{$match_row}[@match_slice];
	$where = sub {
		my @slice = @{$_[0]}[@match_slice];
		for my $i (0..$#match) {
			if (defined $match[$i] && $match[$i] ne $slice[$i]) {
				return;
			}
		}
		return $_[0];
	};
	return $where;
}

sub index_hash {
	my ($self, $unique, $key_fields) = @_;
	my $type = {
		unique=>'ixhu',
		multi=>'ixhm',
	  }->{$unique};
	$type or die "unknown hash index type: $type";
	# TODO key_fields_how ?  (i.e. how to index)
	# This uses hash indexing, so no sorting or ranges are supported :/
	my $key_name = join ",", @$key_fields;
	my %key_field_exists = map {$_=>1} @$key_fields;
	my @key_slice = map {$self->{field_i}{$_}} @$key_fields;
	my $index = {};
	my $i = 0;
	for my $row (@{$self->{rows}}) {
		my $ix = $index;
		my @key_data = @{$row}[@key_slice];
		my $key_data_last = pop @key_data;
		for my $k (@key_data) {
			$ix = $ix->{$k} ||= {};
		}
		if ($type eq "ixhu") {
			$ix->{$key_data_last} = $i;
		} else {
			push @{$ix->{$key_data_last}}, $i;
		}
		++$i;
	}

	$self->{$type}{$key_name} = $index;
}

sub sort {
	my ($self, $func) = @_;
	$self->{rows} = [sort {$func->($a, $b)} @{$self->{rows}}];
	return $self;
}

# TODO make tree index

package FuncSet;

use strict; use warnings;

use Lib;
use L;

use base 'Rel2';

sub new {
	my ($class, @fields) = @_;
	my $self = $class->SUPER::new(@fields);
	$self->{funcs} = [];
	return $self;
}

# design:
# $func_attr = {
#	sub =>    # sub implementing the function
#	mode =>   # input fields, output fields
#          { field => i/o/io }
#	args =>   # prefix args ary for the func, for binding methods
#	cost =>	  # complexity measure - a scalar, or a function of inputs
#	det =>    # does it always give same outputs for same inputs
#	rand =>   # is the algorithm randomized?  (unbound time)
#	approx => # is the result approximate?  (TODO expected accuracy?)
#	rely =>   # does the algorithm always give the correct answer?
#	fail =>   # can it fail?  (die)
#	mod =>    # does it modify any arguments provided?
#	fx =>     # does it have side-effects?  (will this ever happen?)
#	input =>  # does the algorithm perform input (e.g. from a user)
#	output => # does the algorithm perform output (e.g. to a user)
#	user =>   # does the algorithm interact with a person?
# }
# func_attr=>args can be easier to use than closures, for binding methods
# TODO use arg / -option format like a shell command?
sub add_func {
	my ($self, @func_attr) = @_;
	my $attr = {@func_attr};
	if ($attr->{sub} && !ref $attr->{sub}) {
		$attr->{sub} = $self->text_sub_to_perl($attr->{sub});
	}
	if (!ref $attr->{mode}) {
		my @modes = split //, $attr->{mode};
		$attr->{mode} = {map {$self->{fields}[$_] => $modes[$_]} 0..$#modes};
	}
	push @{$self->{funcs}}, $attr;
	# TODO use an internal indexed Table of functions
}

sub text_sub_to_perl {
	my ($self, $sub) = @_;
	my $field_names = join ', ', map {"\$$_"} @{$self->{fields}};
	my $code = $sub;
	$code =~ s{(^|\s)((?!\d|IF\b|OR\b)\w+)(\s|$)}{$1\$$2$3}g;
	unless ($code =~ s{IF (.*)}{if \($1\) { return [\\\@_]; }\n}) {
		$code =~ s{( OR |$)}{;\npush \@ret, [$field_names];\n}gs;
		$code .= "return \\\@ret;\n";
	}
	$code .= "return [];\n";
	$code = qq{sub {
		my ($field_names) = \@_;
		my \@ret;
		$code;
	}};
#	warn "\n$code\n\n-----------\n";
	$sub = eval $code;
	$sub or die "text_sub_to_perl failed: $@\n$code\n\n";
	return $sub;
}

sub select {
	my ($self, $fields, $where, $options) = @_;
	if (defined $options->{from} || defined $options->{to}) {
		die "from - to not done yet";
	}

	my ($name_map, $fields1, $fields_out);
	($name_map, $fields1, $fields_out) = $self->fields_to_name_map_fields_fields_out($fields, $options);
	$where = $self->where_to_hash($where);

	# What function to use?  first that matches input provided and gives
	# output needed.

	my ($sub, $attr) = $self->find_sub($fields1, $where);

	if (!$sub) {
		die "FuncSet::select failed: no suitable function: ".hash2json($where)." -> ".join(',',@$fields1);
	}

	my $mode = $attr->{mode};
	my $func_fields = [grep {$mode->{$_}} @{$self->{fields}}];

	my @args = map {$where->{$_}} @$func_fields;
	my @prefix = $attr->{args} ? @{$attr->{args}} : ();
	my $rows = $sub->(@prefix, @args);

	my $result = Table->new(@$func_fields);
	$result->{rows} = $rows;
	$result = $result->cut($fields, $options);
#	print "@{$result->{fields}} -> @$fields_out\n";

	$result->{fields} = $fields_out;
	return $result;
}

sub find_sub {
	my ($self, $fields, $where) = @_;
	my ($sub, $attr);
	for my $func_attr (@{$self->{funcs}}) {
		my $match = 1;
		for (keys %{$func_attr->{mode}}) {
			if ($func_attr->{mode}{$_} eq "i" && !defined $where->{$_}) {
				$match = 0; last;
			}
			if ($func_attr->{mode}{$_} eq "o" && defined $where->{$_}) {
				$match = 0; last;
			}
		}
		if ($match) {
			for (@$fields) {
				unless (($func_attr->{mode}{$_}||'') eq 'o' || defined $where->{$_}) {
					$match = 0; last;
				}
			}
		}
		if ($match) {
			$sub = $func_attr->{sub};
			$attr = $func_attr;
			last;
		}
	}
	return ($sub, $attr);
}

sub where {
	my ($self, $where, $options) = @_;
	return $self->select($self->{fields}, $where, $options);
}

sub cut {
	# would have to return another FuncSet somehow.
	die "FuncSet::cut not implemented\n";
}

# TODO check if a certain mode can be calculated or not
# sub can

# TODO joins / lambda

package Join;

use strict; use warnings;

use Lib;
use L;


# TODO package View; ?

# TODO implement Where, Select and Rename not as functions but as view-style
# classes (sub-classes of Rel), so can have persistent Where / Select setups,
# Joins involving those etc.

# This would be harder because to do it efficiently, caching the view data,
# would have to handle insert / update events etc on the original Table and
# update the view efficiently.  This needs some relationship system working
# already.  So I'll stick with the static methods first.  They are needed
# anyway.


package Rel2;

sub test {
	my $animals = Table->new('species', 'legs');

	$animals->insert(species => 'cow', legs => 4);
	$animals->insert([qw(dog 4)]);
	$animals->insert({species => 'man', legs => 2});
	$animals->insert(species => 'e\'phant', legs => 4);
	$animals->insert(species => 'octopus', legs => 8);
	$animals->insert(species => 'spider', legs => 8);
	$animals->insert(species => 'ant', legs => 6);

	$animals->sort(sub { $_[0][0] cmp $_[1][0] });

	$animals->index_hash("unique", [qw(species legs)]);
	$animals->index_hash("multi", [qw(legs)]);

	$animals->print_tsv;
	warn "\nhaving 4 legs:\n\n";
	$animals->where({legs=>4})->print_records;
	warn "man:\n\n";
	$animals->where(['man'])->print_tsv;
	warn "\nwith an 'o':\n\n";
	print D $animals->where(sub { $_->[0] =~ /o/ })->cut(['species'])->rows_hash;
	print D $animals->where(sub { $_->[0] =~ /o/ })->col('species');

	my $add = FuncSet->new('sum', 'a1', 'a2');
	$add->add_func(sub => 'sum = a1 + a2', mode => 'oii');
	$add->add_func(sub => 'a1 = sum - a2', mode => 'ioi');
	$add->add_func(sub => 'a2 = sum - a1', mode => 'iio');
#	$add->add_func(sub => sub { $_[0] == $_[1] + $_[2] ? [\@_] : []; }, mode => 'iii');
	$add->add_func(sub => 'IF sum == a1 + a2', mode => 'iii');

	my $mul = FuncSet->new('prod', 'a1', 'a2');
	$mul->add_func(sub => sub { $_[0] = $_[1] * $_[2]; [\@_] }, mode => 'oii');
	$mul->add_func(sub => sub { $_[1] = $_[0] / $_[2]; [\@_] }, mode => 'ioi');
	$mul->add_func(sub => sub { $_[2] = $_[0] / $_[1]; [\@_] }, mode => 'iio');
#	$mul->add_func(sub => 'IF prod == a1 * a2', mode => 'iii');
	$mul->add_func(sub => sub { $_[0] == $_[1] * $_[2] ? [\@_] : []; }, mode => 'iii');

	my $square = FuncSet->new('square', 'root');
	$square->add_func(sub => 'square = root * root', mode => 'oi');
#	$square->add_func(sub => 'x = sqrt(square) ; root = x OR root = -x', mode => 'oi');
	$square->add_func(sub => sub { $_[1] = sqrt($_[0]); [\@_, [$_[0], -$_[1]]]}, mode => 'io');
	$square->add_func(sub => sub { $_[0] == $_[1] * $_[1] ? [\@_] : []; }, mode => 'ii');

	$add->where({a1 => 4, a2 => 7})->print_tsv;
	$add->where({a1 => 1, a2 => 2, sum => 3})->print_tsv;
	$add->where([4, 1, 2])->print_tsv;
	$mul->where({prod => 10, a2 => 4})->print_records;
	$square->where({root => 12})->print_tsv;
	$square->where({square => 64})->rename(root=>'sqrt(n)', square=>'n')->print_tsv;
	$square->select(['root'=>'rt', 'square'=>'sq'], [9, -3], {rename=>1})->print_tsv;

	# old / perl style subs
#	$add->add_func(sub => sub { $_[0] = $_[1] + $_[2]; [\@_] }, mode => 'oii');
#	$square->add_func(sub => sub { $_[0] = $_[1] * $_[1]; [\@_] }, mode => 'oi');
}

1
