use strict;
use warnings;

package Oh;

use subs qw/error env string_fh find search put get get2 get3 get4 getn read_word interpret_element interpret_list interpret_atom interpret_word interpret_colon interpret_fh interpret_string interpret_file compile_element compile_atom compile_list compile_colon compile_word reft deref/;

use DB_File;
use Scalar::Util qw/reftype blessed/;
use List::Util 'sum0';
use Data::Dumper;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 0;

my $env = env;

$env->{immediate} = { map { $_ => 1 } qw/( " ` { [/ };
$env->{immediate}->{':'} = 0;
$env->{immediate}->{'::'} = 0;
$env->{immediate}->{'declare'} = 0;

my $root = $env;

my @stack;

my $source;

my %special = map { $_ => 1 } qw/( ) { } [ ] " `/, '#';

sub error { die "@_\n" }

sub env
{
  { parent => shift(), map { $_ => {} } qw/temp var word immediate/ };
}

sub read_word
{
  my $word = '';
  my $char = $source->getc;

  while (defined $char and $char =~ /\s/s)
  {
    $char = $source->getc;
  }
  while (defined $char and $char !~ /\s/s)
  {
    if ($special{$char})
    {
      if ($word eq '')
      {
        return $char;
      }
      else
      {
        $source->ungetc(ord $char);
        return $word;
      }
    }
    $word .= $char;
    $char = $source->getc;
  }
  $word;
}

sub string_fh
{
  my $string = shift;
  open my $fh, '<', \$string or error 'cannot create a string filehandle', $string;
  $fh;
}

sub find
{
  my ($type, $name) = @_;
  if (exists $env->{$type}->{$name})
  {
    $env->{$type}->{$name};
  }
  elsif ($env->{parent})
  {
    my $e = $env;
    while ($e = $e->{parent})
    {
      if (exists $e->{$type}->{$name})
      {
        return $e->{$type}->{$name};
      }
    }
  }
}

sub search
{
  my ($type, $name) = @_;
  if (exists $env->{$type}->{$name})
  {
    $env;
  }
  elsif ($env->{parent})
  {
    my $e = $env;
    while ($e = $e->{parent})
    {
      if (exists $e->{$type}->{$name})
      {
        return $e;
      }
    }
  }
}

sub put
{
  push @stack, @_;
}

sub get
{
  if (@stack)
  {
    pop @stack;
  }
  else
  {
    error 'stack underflow', 1;
  }
}
 
sub get2
{
  if (@stack > 1)
  {
    splice @stack, -2;
  }
  else
  {
    error 'stack underflow', 2;
  }
}
 
sub get3
{
  if (@stack > 2)
  {
    splice @stack, -3;
  }
  else
  {
    error 'stack underflow', 3;
  }
}
 
sub get4
{
  if (@stack > 3)
  {
    splice @stack, -4;
  }
  else
  {
    error 'stack underflow', 4;
  }
}
 
sub getn
{
  my $num = shift;
  return () unless $num;

  if (@stack < $num)
  {
    error 'stack underflow', $num;
  }
  else
  {
    splice @stack, -$num;
  }
}

sub interpret_element
{
  my $element = $_[0];
  return put(undef) unless defined $element;
  my $type = ref $element;
  if ($type)
  {
    if ($type eq 'ARRAY')
    {
      interpret_list $element;
    }
    elsif ($type eq 'colon')
    {
      interpret_colon $element;
    }
    elsif ($type eq 'CODE')
    {
      $element->();
    }
    else
    {
      put $element;
    }
  }
  else
  {
    my $word = find 'word', $element;
    if ($word)
    {
      interpret_word $word;
    }
    else
    {
      interpret_atom $element;
    }
  }
}

sub compile_element
{
  my $element = $_[0];
  return sub { put(undef) } unless defined $element;
  my $type = ref $element;
  if ($type)
  {
    if ($type eq 'ARRAY')
    {
      compile_list $element;
    }
    elsif ($type eq 'colon')
    {
      compile_colon $element;
    }
    elsif ($type eq 'CODE')
    {
      $element;
    }
    else
    {
      sub { put $element };
    }
  }
  else
  {
    my $word = find 'word', $element;
    if ($word)
    {
      compile_word $word;
    }
    else
    {
      compile_atom $element;
    }
  }
}

sub interpret_list
{
  for my $element (@{$_[0]})
  {
    if (ref $element eq 'ARRAY')
    {
      put $element;
    }
    else
    {
      interpret_element $element;
    }
  }
}

sub compile_list
{
  my @code;
  for my $element (@{$_[0]})
  {
    if (ref $element eq 'ARRAY')
    {
      push @code, sub { put $element };
    }
    else
    {
      push @code, compile_element $element;
    }
  }
  sub { for my $code (@code) { $code->() } };
}

sub interpret_colon
{
  my $old = $env;
  $env = $_[0]->{env};
  interpret_list $_[0]->{code};
  $_[0]->{env}->{temp} = {};
  $env = $old;
}

sub compile_colon
{
  my $old = $env;
  $env = $_[0]->{env};
  my $e = $env;
  my $code = compile_list $_[0]->{code};
  $_[0]->{env}->{temp} = {};
  $env = $old;
  sub { my $old = $env; $env = $e; $code->(); $env = $old };
}

sub interpret_word
{
  my $type = ref $_[0];
  if ($type eq 'colon')
  {
    interpret_colon $_[0];
  }
  elsif ($type eq 'CODE')
  {
    $_[0]->();
  }
  else
  {
    error 'wrong word type', $_[0], $type;
  }
}

sub compile_word
{
  my $type = ref $_[0];
  if ($type eq 'colon')
  {
    compile_colon $_[0];
  }
  elsif ($type eq 'CODE')
  {
    $_[0];
  }
  else
  {
    error 'wrong word type', $_[0], $type;
  }
}

#ats

sub interpret_atom
{
  my $atom = $_[0];
  if ($atom =~ /^-?\d+\.?\d*$/)
  {
    put $atom;
  }
  elsif ($atom =~ /^0x[a-f0-9]+$/i)
  {
    put hex $atom;
  }
  elsif ($atom =~ /^'/)
  {
    put substr $atom, 1;
  }
  elsif ($atom =~ /^:/)
  {
    my $value = get;
    if ($atom =~ /:$/)
    {
      put $env->{temp}->{substr($atom, 1, -1)} = $value;
    }
    else
    {
      $env->{temp}->{substr($atom, 1)} = $value;
    }
  }
  elsif ($atom =~ /:$/)
  {
    put find('temp', substr $atom, 0, -1);
  }
  elsif ($atom =~ /^"(.+)"$/s)
  {
    put $1;
  }
  elsif ($atom =~ /^!/)
  {
    my $key = substr $atom, 1;
    my ($obj, $value) = get2;
    my $type = reft $obj;
    if ($type eq 'ARRAY')
    {
      $obj->[$key] = $value;
    }
    elsif ($type eq 'HASH')
    {
      $obj->{$key} = $value;
    }
    else
    {
      error "$atom tring to set an object not a hash or list", $type, $obj, $value;
    }
  }
  elsif ($atom =~ /^\./)
  {
    my $key = substr $atom, 1;
    my $obj = get;
    my $type = reft $obj;
    if ($type eq 'ARRAY')
    {
      put($obj->[$key]);
    }
    elsif ($type eq 'HASH')
    {
      put($obj->{$key});
    }
    else
    {
      error "$atom tring to get an element from an object not a hash or list", $type, $obj;
    }
  }
  else
  {
    error 'atom not recognized', $atom;
  }
}
#ets

#cts
sub compile_atom
{
  my $atom = $_[0];
  if ($atom =~ /^-?\d+\.?\d*$/)
  {
    sub { put $atom };
  }
  elsif ($atom =~ /^0x[a-f0-9]+$/i)
  {
    my $hex = hex $atom;
    sub { put $hex }
  }
  elsif ($atom =~ /^'/)
  {
    my $string = substr $atom, 1;
    sub { put $string };
  }
  elsif ($atom =~ /^:/)
  {
    if ($atom =~ /:$/)
    {
      my $name = substr($atom, 1, -1);
      my $e = $env;
      sub { put $e->{temp}->{$name} = get };
    }
    else
    {
      my $name = substr($atom, 1);
      my $e = $env;
      sub { $e->{temp}->{$name} = get };
    }
  }
  elsif ($atom =~ /:$/)
  {
    my $e = $env;
    my $name = substr $atom, 0, -1;
    sub { my $old = $env; $env = $e; put find('temp', $name); $env = $old };
  }
  elsif ($atom =~ /^"(.+)"$/s)
  {
    my $string = $1;
    sub { put $string };
  }
  elsif ($atom =~ /^!/)
  {
    my $key = substr $atom, 1;
    sub
    {
      my ($obj, $value) = get2;
      my $type = reft $obj;
      if ($type eq 'ARRAY')
      {
        $obj->[$key] = $value;
      }
      elsif ($type eq 'HASH')
      {
        $obj->{$key} = $value;
      }
      else
      {
        error "$atom tring to set an object not a hash or list", $type, $obj, $value;
      }
    }
  }
  elsif ($atom =~ /^\./)
  {
    my $key = substr $atom, 1;
    sub
    {
      my $obj = get;
      my $type = reft $obj;
      if ($type eq 'ARRAY')
      {
        put($obj->[$key]);
      }
      elsif ($type eq 'HASH')
      {
        put($obj->{$key});
      }
      else
      {
        error "$atom tring to get an element from an object not a hash or list", $type, $obj;
      }
    }
  }
  else
  {
    error 'compiling: atom not recognized', $atom;
  }
}

#cte

sub interpret_fh
{
  my $old = $source;
  $source = $_[0];
  while ((my $word = read_word) ne '')
  {
    interpret_element $word;
  }
}

sub interpret_string
{
  interpret_fh string_fh $_[0];
}

sub interpret_file
{
  open my $fh, '<', $_[0] or error 'cannot load file', $_[0];
  my $char = $fh->getc;
  if ($char eq '#')
  {
    $fh->getline;
  }
  else
  {
    $fh->ungetc(ord $char);
  }
  interpret_fh $fh;
}

sub word (&$)
{
  $env->{word}->{$_[1]} = $_[0];
}

sub reft ($) { reftype($_[0]) || '' }

sub deref ($)
{
  my $type = reft $_[0];
  if ($type eq 'ARRAY')
  {
    @{$_[0]};
  }
  elsif ($type eq 'HASH')
  {
    %{$_[0]};
  }
  elsif ($type eq 'SCALAR')
  {
    ${$_[0]};
  }
  else
  {
    $_[0];
  }
}

sub print_stack
{
  print Dumper(\@stack), "\n";
}

sub repl
{
  my $line;
  while (defined($line = <STDIN>) and $line ne "\n")
  {
    interpret_string $line;
    print_stack;
  }
}

sub interpolate_list
{
  my @list;
  for my $element (@_)
  {
    if (defined $element)
    {
      my $type = ref $element;
      if ($type)
      {
        if ($type eq 'ARRAY')
        {
          push @list, [interpolate_list(@$element)];
        }
        else
        {
          push @list, $element;
        }
      }
      else
      {
        if ($element eq ',')
        {
          push @list, get;
        }
        elsif ($element eq '@')
        {
          my $value = pop @list;
          if (ref $value eq 'ARRAY')
          {
            push @list, @$value;
          }
          else
          {
            error ',@ did not receive a list', $value;
          }
        }
        elsif ($element eq ',@')
        {
          my $value = get;
          if (ref $value eq 'ARRAY')
          {
            push @list, @$value;
          }
          else
          {
            error ',@ did not receive a list', $value;
          }
        }
        elsif ($element =~ /^,@/)
        {
          my $word = substr $element, 2;
          interpret_element($word);
          my $value = get;
          if (ref $value eq 'ARRAY')
          {
            push @list, @$value;
          }
          else
          {
            error ",@ $word did not receive a list", $value;
          }
        }
        elsif ($element =~ /^,/)
        {
          interpret_element(substr $element, 1);
          push @list, get;
        }
        elsif ($element eq '#')
        {
          interpret_element(pop @list);
          push @list, get;
        }
        elsif ($element eq '!')
        {
          @list = reverse @list;
        }
        else
        {
          push @list, $element;
        }
      }
    }
    else
    {
      push @list, undef;
    }
  }
  @list;
}
  

#wds

word
{
  my $name = read_word;
  error ':: did not read a name' if $name eq '';
  my @code;
  my $e = env $env;
  my $old = $env;
  $env = $e;
  while ((my $word = read_word) ne ';')
  {
    error ':: did not find a terminating ;' if $word eq '';
    my $immediate_env = search 'immediate', $word;
    if ($immediate_env)
    {
      interpret_word $immediate_env->{word}->{$word};
      if ($immediate_env->{immediate}->{$word})
      {
        if ($word eq '"')
        {
          push @code, '"' . get() . '"';
        }
        elsif ($word eq '{' or $word eq '[')
        {
          my $lambda = get;
          push @code, sub { put $lambda };
        }
        else
        {
          push @code, get;
        }
      }
    }
    else
    {
      push @code, $word;
    }
  }
  $env = $old;
  $env->{word}->{$name} = bless { code => \@code, env => $e }, 'colon';
} '::';

word
{
  my @code;
  my $e = env $env;
  my $old = $env;
  $env = $e;
  while ((my $word = read_word) ne ']')
  {
    error '[ did not find a terminating ]' if $word eq '';
    my $immediate_env = search 'immediate', $word;
    if ($immediate_env)
    {
      interpret_word $immediate_env->{word}->{$word};
      if ($immediate_env->{immediate}->{$word})
      {
        if ($word eq '"')
        {
          push @code, '"' . get() . '"';
        }
        elsif ($word eq '{' or $word eq '[')
        {
          my $lambda = get;
          push @code, sub { put $lambda };
        }
        else
        {
          push @code, get;
        }
      }
    }
    else
    {
      push @code, $word;
    }
  }
  $env = $old;
  put(bless { code => \@code, env => $e }, 'colon');
} '[';
word
{
  my $name = read_word;
  error ': did not read a name' if $name eq '';
  my @code;
  my $e = env $env;
  my $old = $env;
  $env = $e;
  while ((my $word = read_word) ne ';')
  {
    error ': did not find a terminating ;' if $word eq '';
    my $immediate_env = search 'immediate', $word;
    if ($immediate_env)
    {
      interpret_word $immediate_env->{word}->{$word};
      if ($immediate_env->{immediate}->{$word})
      {
        if ($word eq '"')
        {
          my $str = '"' . get() . '"';
          push @code, sub { put $str };
        }
        elsif ($word eq '{' or $word eq '[')
        {
          my $lambda = get;
          push @code, sub { put $lambda };
        }
        else
        {
          push @code, compile_element get;
        }
      }
    }
    else
    {
      push @code, $word;
    }
  }
  $env = $old;
  $env->{word}->{$name} = compile_colon(bless { code => \@code, env => $e }, 'colon');
} ':';

word
{
  my @code;
  my $e = env $env;
  my $old = $env;
  $env = $e;
  while ((my $word = read_word) ne '}')
  {
    error '{ did not find a terminating }' if $word eq '';
    my $immediate_env = search 'immediate', $word;
    if ($immediate_env)
    {
      interpret_word $immediate_env->{word}->{$word};
      if ($immediate_env->{immediate}->{$word})
      {
        if ($word eq '"')
        {
          my $str = '"' . get() . '"';
          push @code, sub { put $str };
        }
        elsif ($word eq '{' or $word eq '[')
        {
          my $lambda = get;
          push @code, sub { put $lambda };
        }
        else
        {
          push @code, compile_element get;
        }
      }
    }
    else
    {
      push @code, $word;
    }
  }
  $env = $old;
  put(compile_colon(bless { code => \@code, env => $e }, 'colon'));
} '{';

word
{
  my @list;
  while ((my $word = read_word) ne ')')
  {
    error '( did not find a terminating )' if $word eq '';
    my $immediate_env = search 'immediate', $word;
    if ($immediate_env)
    {
      interpret_word $immediate_env->{word}->{$word};
      if ($immediate_env->{immediate}->{$word})
      {
        if ($word eq '"')
        {
          push @list, '"' . get() . '"';
        }
        else
        {
          push @list, get;
        }
      }
    }
    else
    {
      push @list, $word;
    }
  }
  put \@list;
} '(';

word
{
  my ($name, $value) = get2;
  my $e = $env;
  $e->{var}->{$name} = $value;
  $e->{word}->{$name} = sub { put $e->{var}->{$name} };
} 'var';

word
{
  my ($name, $value) = get2;
  my $e = search 'var', $name;
  if ($e)
  {
    $e->{var}->{$name} = $value;
  }
  else
  {
    error 'variable does not exist', $name, $value;
  }
} 'set-var';

word
{
  my $name = read_word;
  error 'declare did not read a variable name' if $name eq '';
  my $e = $env;
  $e->{var}->{$name} = 0;
  $e->{word}->{$name} = sub { put $e->{var}->{$name} };
} 'declare';

word { put(find 'var', get) } 'get-var';
word { put compile_element get } 'compile';
word { put compile_list get } 'compile-list';
word { put compile_word get } 'compile-word';
word { put compile_colon get } 'compile-colon';
word { put find(get2) } 'find';
word { put search(get2) } 'search';
word { interpret_element get } 'eval';
word
{
  my $str = get;
  eval $str;
} 'perl-eval';
word
{
  my ($name, $code) = get2;
  my $sub = eval "sub { $code }";
  error "perl word $name code failed: $@" if $@;
  if (ref $sub eq 'CODE')
  {
    $env->{word}->{$name} = $sub;
  }
  else
  {
    error 'the perl word was not created', $name, $@, $code;
  }
} 'perl-word';

word
{
  my ($test, $code) = get2;
  if ($test)
  {
    interpret_element $code;
  }
} 'if';

word
{
  my ($test, $code, $else) = get3;
  if ($test)
  {
    interpret_element $code;
  }
  else
  {
    interpret_element $else;
  }
} 'if-else';

word
{
  my $str = '';
  my $char = $source->getc;
  error '" at the end of source code' unless defined $char;
  while ($char ne '"')
  {
    if ($char eq '\\')
    {
      $char = $source->getc;
      error '\\ escape sequence at the end of "' unless defined $char;
      if ($char eq 'a')
      {
        $str .= "\a";
      }
      elsif ($char eq 't')
      {
        $str .= "\t";
      }
      elsif ($char eq 'n')
      {
        $str .= "\n";
      }
      elsif ($char eq 'e')
      {
        $str .= "\e";
      }
      elsif ($char eq '0')
      {
        $str .= "\0";
      }
      elsif ($char eq 'r')
      {
        $str .= "\r";
      }
      elsif ($char eq 'b')
      {
        $str .= "\b";
      }
      else
      {
        $str .= $char;
      }
    }
    else
    {
      $str .= $char;
    }
    $char = $source->getc;
    error '" did not find a terminating "' unless defined $char;
  }
  put $str;
} '"';

word
{
  my $str = '';
  my $char = $source->getc;
  error '` at the end of source code' unless defined $char;
  while ($char ne '`')
  {
    if ($char eq '\\')
    {
      $char = $source->getc;
      error '\\ escape sequence at the end of `' unless defined $char;
      if ($char eq 'a')
      {
        $str .= "\a";
      }
      elsif ($char eq 't')
      {
        $str .= "\t";
      }
      elsif ($char eq 'n')
      {
        $str .= "\n";
      }
      elsif ($char eq 'e')
      {
        $str .= "\e";
      }
      elsif ($char eq '0')
      {
        $str .= "\0";
      }
      elsif ($char eq 'r')
      {
        $str .= "\r";
      }
      elsif ($char eq 'b')
      {
        $str .= "\b";
      }
      else
      {
        $str .= $char;
      }
    }
    else
    {
      $str .= $char;
    }
    $char = $source->getc;
    error '` did not find a terminating `' unless defined $char;
  }
  put $str;
} '`';


word
{
  my ($name, $code) = get2;
  error 'colon did not receive a list as code', unless ref $code eq 'ARRAY';
  $env->{word}->{$name} = compile_colon(bless { code => $code, env => env($env) }, 'colon');
} 'colon'; 

word
{
  my ($name, $code) = get2;
  error 'colon* did not receive a list as code', unless ref $code eq 'ARRAY';
  $env->{word}->{$name} = bless { code => $code, env => env($env) }, 'colon';
} 'colon*'; 

word
{
  my ($name, $value) = get2;
  $env->{temp}->{$name} = $value;
} 'temp';

word
{
  my $name = get;
  put(find('temp', $name));
} 'get-temp';

word
{
  my ($obj, $key, $value) = get3;
  my $type = reft $obj;
  if ($type eq 'ARRAY')
  {
    $obj->[$key] = $value;
  }
  elsif ($type eq 'HASH')
  {
    $obj->{$key} = $value;
  }
  else
  {
    error 'set received an element not a hash or array', $obj, $key, $value;
  }
} 'set';
  

word
{
  my ($obj, $key) = get2;
  my $type = reft $obj;
  if ($type eq 'ARRAY')
  {
    put($obj->[$key]);
  }
  elsif ($type eq 'HASH')
  {
    put($obj->{$key});
  }
  else
  {
    error 'get received an element not a hash or array', $obj, $key;
  }
} 'get';
 
word
{
  my $name = get;
  tie my %db, 'DB_File', $name or error 'cannot create a magic hash', $name;
  put(\%db);
} 'magic-hash';

word
{
  my $list = get;
  error 'hash did not receive a list' unless ref $list eq 'ARRAY';
  error 'hash did not receive a list with elements multiple of two' if @$list % 2;
  put({@$list});
} 'hash';

word { tied(%{get()})->sync } 'magic-flush';
word { put(undef) } 'nil';
word { put [interpolate_list(@{get()})] } '~';
word { my ($one, $two) = get2; put($one + $two) } '+';
word { my ($one, $two) = get2; put($one - $two) } '-';
word { my ($one, $two) = get2; put($one / $two) } '/';
word { my ($one, $two) = get2; put($one * $two) } '*';
word { my ($one, $two) = get2; put($one . $two) } '.';
word { @stack = () } 'r';
repl;