use strict;
use warnings;

package oh;


# I thank God for allowing me to program

immediate(qw/; if then else do loop +loop [ .( ( does> postpone/);

use Data::Dumper;
$Data::Dumper::Terse = 1;
$Data::Dumper::Indent = 0;

my @stack;

my %dictionary;

my %immediate;

my @definition;

my @compiling = 0;

my $source;

my @args;

my @loop;

my $out = *STDOUT;

my @aux;

my @memory;

my $here = 0;

my $last;

#vbs


sub error
{
  die join(' ', map { ref? Dumper($_): $_ } @_), "\n", Dumper(\@stack), "\n";
}
  
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 read_word
{
  my $char;
  my $word = '';

  while (defined($char = $source->getc) and $char =~ /\s/s)
  {

  }

  while (defined $char and $char !~ /\s/s)
  {
    $word .= $char;
    $char = $source->getc;
  }

  $word;
}
  
sub source
{
  my $string = shift;
  error 'cannot create a string from ', $string if ref $string;
  open my $fh, '<', \$string;
  $source = $fh;
}

sub interpret
{
  my $word = lc shift;

  if ($compiling[-1])
  {
    compile_element($word);
  }
  else
  {
    interpret_element($word);
  }
}

sub interpret_element
{
  my $element = shift;
  return push @stack, undef unless defined $element;

  if ($dictionary{$element})
  {
    $dictionary{$element}->();
  }
  elsif ($element =~ /^-?\d+\.?\d*$/)
  {
    push @stack, $element;
  }
  else
  {
    error 'word does not exist', $element;
  }
}

sub compile_element
{
  my $element = shift;
  return push @{$definition[-1]}, sub { push @stack, undef } unless defined $element;

  if ($dictionary{$element})
  {
    if ($immediate{$element})
    {
      $dictionary{$element}->();
    }
    else
    {
      push @{$definition[-1]}, $dictionary{$element};
    }
  }
  elsif ($element =~ /^-?\d+\.?\d*$/)
  {
    push @{$definition[-1]}, sub { push @stack, $element };
  }
  else
  {
    error 'word does not exist', $element;
  }
}

sub interpret_words
{
  while ((my $word = read_word) ne '')
  {
    interpret $word;
  }
}
    
sub word (&$)
{
  $dictionary{$_[1]} = $_[0];
}

sub repl
{
  my $line;
  my $old = $source;
  $dictionary{prompt}->();
  while (defined($line = <STDIN>) and $line ne "\n")
  {
    source $line;
    eval { interpret_words $line };

    print $@ if $@;
    
    if ($compiling[-1])
    {
      print "$compiling[-1] ... ";
    }
    else
    {
      print "\n", Dumper(\@stack), "\n";
    }
    $dictionary{prompt}->();
  }
  $source = $old;
}
  
sub immediate
{
  for my $word (@_)
  {
    $immediate{$word} = 1;
  }
}
    
sub interpret_string
{
  my $old = $source;
  source shift;
  interpret_words;
  $source = $old;
}

sub interpret_file
{
  my $filename = shift;
  my $old = $source;
  open my $fh, '<', $filename or error 'cannot open', $filename;
  $source = $fh;
  interpret_words;
  $source = $old;
}
  
sub process_args
{
  if (@ARGV)
  {
    my $flag;
    my @commands = grep
    {
      if ($flag)
      {
        push @args, $_;
      }
      elsif ($_ eq '-')
      {
        $flag = 1;
      }
      not $flag;
    } @ARGV;

    if (@commands)
    {
      while (@commands)
      {
        my $command = shift @commands;
        if ($command eq 'e')
        {
          interpret_string shift @commands;
        }
        elsif ($command eq 'f')
        {
          interpret_file shift @commands;
        }
        elsif (-e $command)
        {
          interpret_file $command;
        }
        else
        {
          error $command, 'not a file or recognized command';
        }
      }
    }
    else
    {
      repl;
    }
  }
  else
  {
    repl;
  }
}

sub pr
{
  print $out join(' ', map { ref? Dumper($_): $_ } @_);
}

#wds


word
{
  my $name = read_word;
  error ': did not read a name' if $name eq '';

  push @definition, [];
  push @compiling, $name;
} ':';

word
{
  my $code = pop @definition;
  my $name = pop @compiling;

  error '; did not find code' unless defined $code and ref $code eq 'ARRAY';
  error '; did not find a name' unless defined $name;

  if ($name eq ':does:')
  {
    error 'found does flag outside compilation' unless $compiling[-1];
    push @{$definition[-1]}, sub
    {

      my $var = $dictionary{$last};
      $dictionary{$last} = sub
      {
        $var->();
        for my $sub (@$code)
        {
          $sub->();
        }
      }
    };
    $dictionary{';'}->();
  }
  else
  {
    my @code = @$code;
    $dictionary{$name} = sub
    {
      for my $sub (@code)
      {
        $sub->();
      }
    };
  }
} ';';

word
{
  push @definition, [];
  push @compiling, ':if:';
} 'if';

word
{
  push @definition, [];
  push @compiling, ':else:';
} 'else';

word
{
  my $flag = pop @compiling;
  error 'then did not find a flag' unless defined $flag;

  my $code;

  if ($flag eq ':else:')
  {
    my $else = pop @definition;
    error 'then found else flag without code' unless defined $else;
    my $if_flag = pop @compiling;
    error 'then found an else flag without an if flag' unless defined $if_flag and $if_flag eq ':if:';
    my $if_code = pop @definition;
    error 'then found else and if flag without if code' unless defined $if_code;
    $code = sub
    {
      if (get)
      {
        for my $sub (@$if_code)
        {
          $sub->();
        }
      }
      else
      {
        for my $sub (@$else)
        {
          $sub->();
        }
      }
    };
  }
  elsif ($flag eq ':if:')
  {
    my $if = pop @definition;
    error 'then found if flag without code' unless defined $if;

    $code = sub
    {
      if (get)
      {
        for my $sub (@$if)
        {
          $sub->();
        }
      }
    };
  }
  else
  {
    error 'then did not find an if flag', $flag;
  }
  
  if ($compiling[-1])
  {
    push @{$definition[-1]}, $code;
  }
  else
  {
    $code->();
  }
  
} 'then';

word { pr "oh...\n" } 'oh';
word { pr "meh\n" } 'meh';

word { push @stack, $loop[-1] } 'i';
word { push @stack, $loop[-2] } 'j';
word { push @stack, $loop[-3] } 'k';

word
{
  push @definition, [];
  push @compiling, ':do:';
} 'do';

word
{
  my $flag = pop @compiling;
  error 'loop did not find a do flag' unless defined $flag and $flag eq ':do:';

  my $do = pop @definition;
  error 'loop found a do flag but not code' unless defined $do;

  my $code = sub
  {
    my ($end, $start) = get2;
    push @loop, $start;
    if ($start > $end)
    {
      for (my $i = $start; $i > $end; $i--)
      {
        $loop[-1] = $i;
        for my $sub (@$do)
        {
          $sub->();
        }
      }
    }
    else
    {
      for (my $i = $start; $i < $end; $i++)
      {
        $loop[-1] = $i;
        for my $sub (@$do)
        {
          $sub->();
        }
      }
    }
    pop @loop;
  };

  if ($compiling[-1])
  {
    push @{$definition[-1]}, $code;
  }
  else
  {
    $code->();
  }
} 'loop';

word
{
  push @definition, [];
  push @compiling, ':do:';
} 'do';

word
{
  my $flag = pop @compiling;
  error 'loop did not find a do flag' unless defined $flag and $flag eq ':do:';

  my $do = pop @definition;
  error 'loop found a do flag but not code' unless defined $do;

  my $code = sub
  {
    my ($end, $start) = get2;
    push @loop, $start;
    if ($start > $end)
    {
      for (my $i = $start; $i > $end; $i -= abs get)
      {
        $loop[-1] = $i;
        for my $sub (@$do)
        {
          $sub->();
        }
      }
    }
    else
    {
      for (my $i = $start; $i < $end; $i += abs get)
      {
        $loop[-1] = $i;
        for my $sub (@$do)
        {
          $sub->();
        }
      }
    }
    pop @loop;
  };

  if ($compiling[-1])
  {
    push @{$definition[-1]}, $code;
  }
  else
  {
    $code->();
  }
} '+loop';

word { pr get(), '' } '.';

word { pr "\n" } 'cr';

word { push @compiling, 0 } '[';

word { pop @compiling } ']';

word
{
  my $string = '';
  my $char = $source->getc;
  error '" at the end of source code' unless defined $char;

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

  if ($compiling[-1])
  {
    push @{$definition[-1]}, sub { push @stack, $string };
  }
  else
  {
    push @stack, $string;
  }
} '"';

word
{
  my $string = '';
  my $char = $source->getc;
  error '." at the end of source code' unless defined $char;

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

  if ($compiling[-1])
  {
    push @{$definition[-1]}, sub { pr $string };
  }
  else
  {
    pr $string;
  }
} '."';

word
{
  my $string = '';
  my $char = $source->getc;
  error '.( at the end of source code' unless defined $char;

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

  pr $string;
} '.(';

word { if ($>) { print '> ' } else { print '# ' } } 'prompt';

word
{
  my $char = $source->getc;
  error '( at the end of source code' unless defined $char;

  while ($char ne ')')
  {
    $char = $source->getc;
    error '( did not find a terminating )' unless defined $char;
  }
} '(';

word { @stack = () } 'r';

word { push @stack, $source } 'source';

word
{
  my $fh = get;
  my $line = <$fh>;
  chomp $line if $line;
  push @stack, $line;
} 'line';

word
{
  my $fh = get;
  my $line = <$fh>;
  push @stack, $line;
} 'line*';

word
{
  my $name = read_word;
  if ($compiling[-1])
  {
    push @{$definition[-1]}, sub
    {
      my $value = get;
      $dictionary{$name} = sub { push @stack, $value };
    };
  }
  else
  {
    my $value = get;
    $dictionary{$name} = sub { push @stack, $value };
  }
} 'constant';    
  
word { push @aux, get } '>r';

word { push @stack, pop @aux } 'r>';

word { push @stack, $aux[-1] } 'r@';

word { print Dumper(\@aux), "\n" } '.r';

word { print Dumper(\@aux), "\n" } '.s';

word { pr sort keys %dictionary } 'words';


word { my ($one, $two) = get2; push @stack, $one + $two } '+';
word { my ($one, $two) = get2; push @stack, $one - $two } '-';
word { my ($one, $two) = get2; push @stack, $one / $two } '/';
word { my ($one, $two) = get2; push @stack, $one % $two } '%';
word { my ($one, $two) = get2; push @stack, $one * $two } '*';
word { my ($one, $two) = get2; push @stack, $one . $two } '..';
word { my ($one, $two) = get2; push @stack, $one == $two } '=';
word { my ($one, $two) = get2; push @stack, $one != $two } '<>';
word { my ($one, $two) = get2; push @stack, $one <= $two } '<=';
word { my ($one, $two) = get2; push @stack, $one >= $two } '>=';
word { my ($one, $two) = get2; push @stack, $one < $two } '<';
word { my ($one, $two) = get2; push @stack, $one > $two } '>';
word { my ($one, $two) = get2; push @stack, $one eq $two } 'eq';

word { push @stack, $here } 'here';

word { $here += get } 'allot';

word
{
  my $pointer = $here;
  my $name = read_word;
  error 'create did not read a name' if $name eq '';
  $dictionary{$name} = sub { push @stack, $pointer };
  $last = $name;
} 'create';

word { $memory[$here++] = get } ',';

word { push @stack, $memory[get()] } '@';

word { my ($value, $addr) = get2; $memory[$addr] = $value } '!';
word { my ($value, $addr) = get2; $memory[$addr] += $value } '+!';

word
{
  my $name = read_word;
  error 'variable did not read a name' if $name eq '';
  my $pointer = $here++;
  $dictionary{$name} = sub { push @stack, $pointer };
} 'variable';

word { push @stack, get() + 1 } '++';
word { push @stack, get() - 1 } '--';
word { push @stack, get() + 1 } '1+';
word { push @stack, get() - 1 } '1-';
word { push @stack, get() + 2 } '2+';
word { push @stack, get() - 2 } '2-';

word { push @definition, []; push @compiling, ':does:' } 'does>';
  
word
{
  error 'postpone called outside compiling state' unless $compiling[-1];
  my $name = read_word;
  error 'postpone did not read a name' if $name eq '';

  error 'postpone received a non existing word name' unless $dictionary{$name};

  push @{$definition[-1]}, $dictionary{$name};
} 'postpone';

word { push @stack, not get } 'not';

process_args;

1;