#!/usr/bin/perl
use strict;
use warnings;

# eine kleine simple Programmiersprache
# Schleifen nur über goto!
# syntax:
#   BEFEHL Option Option ...
# Die Anzahl der Optionen sind vordefiniert und fest!
# eine Option kann ein Befehl sein, oder ein Block
#
# Blöcke werten über {...} definiert
# benannte Blöcke NAME{...}
# können mit "goto" angesprungen werden
# bei einem Block wird das Ergebnis des letzten Befehls zurück geliefert
#
# Zeichenketten sind Zahlen oder alles innerhalb von "" oder '' oder ``
# Die jeweiligen Marker dürfen nicht im String vorkommen!
#
# selbstdefinierte Funktionen sind nicht implementiert.
#
# Variablen sind Global.

########################################################################
########################################################################

# Beispiel:
my $prgstr=<<'EOC';
set "test" 0
set "test2" "5*5^5"
set "bla" 5
loop{
  if lt var "test" 5
  {
    set "test" add var "test" 1
    set "bla" mul var "bla" 5
    goto "loop"
  }
}
say var "test2"
print "ERGEBNIS: "
say var "bla"
EOC

########################################################################
########################################################################

my $command_now=[];
my $tree=[];
my %vars=();
my %marks=();
my %commands=();

# Kommandos bestehen aus eineam array mit
# - anzahl der parameter und ob sie automatsich interpreteirt werden sollen
#   wenn die parameter nicht interpretiert werden sollen,
#   werden die "Sprungmarken" übergeben
# - dem auszuführenden Befehl
# - einer Beschreibung
%commands=(
  'exit'  => [[],      sub{ exit(); },                      'Alles beenden'],
  'print' => [[1],     sub{ print $_[1]; },                 'Text ausgeben'],
  'say'   => [[1],     sub{ print "$_[1]\n"; },             'Text ausgeben mit \n'],
  'set'   => [[1,1],   sub{ $vars{$_[1]}=$_[2];return 1 }, 'Variable setzen'],
  'var'   => [[1],     sub{
                            return $vars{$_[1]} if($vars{$_[1]});
                            $vars{$_[1]}=0;
                            return 0;
                          },                                'Variable lesen'],

  'add'   => [[1,1],   sub{ return $_[1]+$_[2]},            'addiere zwei zahlen'],
  'sup'   => [[1,1],   sub{ return $_[1]-$_[2]},            'suptrahiere zwei zahlen'],
  'mul'   => [[1,1],   sub{ return $_[1]*$_[2]},            'multipliziere zwei zahlen'],
  'div'   => [[1,1],   sub{ return $_[1]/$_[2]},            'dividiere zwei zahlen'],

  'gt'    => [[1,1],   sub{ return $_[1] >  $_[2]},         'a > b'],
  'lt'    => [[1,1],   sub{ return $_[1] <  $_[2]},         'a < b'],
  'eq'    => [[1,1],   sub{ return $_[1] == $_[2]},         'a = b'],

  'app'   => [[1,1],   sub{
                            if($vars{$_[1]})
                            { $vars{$_[1]}.=$_[2]; }
                            else
                            { $vars{$_[1]}=$_[2]; }
                            return 1;
                          },                                'an variable anhängen'],

  'length'=> [[1],     sub{ return length($_[1]) },         'length string'],
  'cmp'   => [[1,1],   sub{ return $_[1] eq $_[2]},         'String a == b'],

  'goto'  => [[1],       sub{
                              if(exists($marks{$_[1]}))
                              {
                                @$command_now=@{$marks{$_[1]}};
                                runn();
                                return 1;
                              }
                              print "WARN(".join(',',@{$_[0]})."): mark: $_[1] not exists!\n";
                              return 0;
                            },                            'zu Marke springen'],

  'ifi'   => [[1,0,0], sub{
                            if($_[1])
                            {
                              @$command_now=@{$_[2]};
                              return runn();
                            }
                            @$command_now=@{$_[3]};
                            return runn();
                    },                                    'if Bedingung mit drei Parametern'],
  'if'    => [[1,0],   sub{
                            if($_[1])
                            {
                              @$command_now=@{$_[2]};
                              return runn();
                            }
                            return 0;
                          },                              'if Bedingung mit zwei Parametern'],
  'help'  => [[],      sub{
                            for my $name (sort(keys(%commands)))
                            { print "$name ".join(' ',map{'<CMD>'}@{$commands{$name}[0]})."\t=>\t$commands{$name}[2]\n"; }
                            return 1;
                          }, 'diese Hilfe']
  );

$tree=start_parse($prgstr);
$command_now=[];
runn();

########################################################################
########################################################################
########################################################################

sub start_parse
{
  my $lines=shift;
  my @commands=();
  while(length($lines) > 0)
  {
    my @add=parse(\$lines);
    if(@add==0 && length($lines) > 0)
    {
      die("ERROR PARSE String \"$lines\" \n");
    }
    push(@commands, @add);
  }
  return ['blk','',\@commands];
}

sub parse
{
  my $lines=shift;
  $$lines=~s#^\s+##s;

  if($$lines=~s#^(\w+)?{##s)
  {
    my @cmds=();
    my $name=$1 || '';
    my $runn=1;
    while(length($$lines) > 0 && $runn)
    {
      push(@cmds,parse($lines));
      $runn=0 if($$lines=~s#^}##s);
    }
    return ['blk',$name,\@cmds];
  }

  if($$lines=~s#^([a-z]+)##s)
  {
    my $cmd=$1;
    if(exists($commands{$cmd}))
    {
      my @opts;
      while(@{$commands{$cmd}->[0]}>@opts && length($$lines)>0)
      { push(@opts,parse($lines)); }
      return ['cmd',$cmd,\@opts];
    }

    die "Parse ERROR! unknown command $cmd\n";
  }

  if(
      $$lines=~s#^"([^"]*)"##s ||
      $$lines=~s#^'([^']*)'##s ||
      $$lines=~s#^`([^`]*)`##s ||
      $$lines=~s#^(\d+(?:\.\d+)?)##s
    )
  { return ['var',$1,[]]; }

  return ();
}

sub runn
{
  my @path=@$command_now;

  my $elm=$tree;
  $elm=$elm->[$_] for(@path);

  my $ret='';
  if(@$elm)
  {
    my $type=$elm->[0];
    if($type eq 'cmd')
    {
      my $code=$commands{$elm->[1]}->[1];
      my @opts=@{$elm->[2]};
      for my $pp (0..$#opts)
      {
        if($commands{$elm->[1]}->[0]->[$pp])
        {
          @$command_now=(@path,2,$pp);
          $opts[$pp]=runn();
        }
        else
        { $opts[$pp]=[@path,2,$pp]; }
      }
      @$command_now=(@path,2);
      $ret=$code->([@path],@opts);
    }
    elsif($type eq 'var')
    { $ret=$elm->[1]; }
    elsif($type eq 'blk')
    {
      if($elm->[1])
      { $marks{$elm->[1]}=[@path]; }
      for my $p (0..$#{$elm->[2]})
      {
        @$command_now=(@path,2,$p);
        $ret=runn();
      }
    }
  }
  else
  { print "ERROR runn tree elm(".join(',',@path).")\n"; }
  return $ret;
}