■

大学院の願書を提出
Haskell、splitすら標準ライブラリにないのか…wordsとか、あまり汎用的でないものはあるのになあ。ああ不便。
Data.HashTableによって、IO汚染というものを初めて実感しました。今までHaskellプログラムを書いていなかっただけなのだけど…
そもそもHashTableなんて使うのが悪いのだ。Data.Mapに切り替え。しかしこれでも何度もはまる。はまる原因は、引数の順序ミス。あー統一性がない！

import Data.Map as M

main = do stm <- getContents
          let st = (concatMap splitSymbol).Main.split ':' $ concat $ lines stm in
              do
                  step st [] empty

step c e s = case am c e s of
                 Nothing -> putStrLn "Terminated."
                 Just (c, e, s) -> do putStrLn $ show c
                                      putStrLn $ show e
                                      putStrLn $ show s
                                      putStrLn ""
                                      step c e s

data Stack = A Int | B Bool deriving Show

am :: [String] -> [Stack] -> (Map String Stack) -> Maybe ([String], [Stack], (Map String Stack))

am ("PUSH":"-":n:c') e s  = Just (c', [A $ read n] ++ e, s)

am ("TRUE":c') e s = Just (c', [B True] ++ e, s)

am ("FALSE":c') e s = Just (c', [B False] ++ e, s)

am ("FETCH":"-":x:c') e s  =  Just (c', [getValue x] ++ e, s)
    where getValue :: String -> Stack
          getValue key = case M.lookup key s of
                             Just val -> val
                             Nothing -> A 0

am ("STORE":"-":x:c') (elm:e') s  = Just (c', e', insert x elm s)

am ("ADD":c') (a1:a2:e') s = arithmeticOp (+) a1 a2 c' e' s

am ("MULT":c') (a1:a2:e') s = arithmeticOp (*) a1 a2 c' e' s

am ("SUB":c') (a1:a2:e') s = arithmeticOp (-) a1 a2 c' e' s

am ("EQ":c') (a1:a2:e') s = arith2boolOp (==) a1 a2 c' e' s

am ("LE":c') (a1:a2:e') s = arith2boolOp (<=) a1 a2 c' e' s

am ("AND":c') (a1:a2:e') s = booleanOp (&&) a1 a2 c' e' s

am ("NEG":c') (a:e') s = booleanOp1 not a c' e' s

am ("BRANCH":c') (elm:e') s  = let (c1, c2, c) = splitComma c' in
                                   case elm of
                                       B True -> Just (c1 ++ c, e', s)
                                       _      -> Just (c2 ++ c, e', s)

am ("LOOP":c') e s  = let (c1, c2, c) = splitComma c' in
                          Just $ (c1 ++ ["BRANCH"] ++ ["("] ++ c2 ++ ["LOOP"] ++ ["("] ++ c1 ++ [","] ++ c2 ++ [")"] ++ [","] ++ ["NOOP"] ++ [")"] ++ c, e, s)

am ("NOOP":c') e s  = Just $ (c', e, s)

am ("COPY":c') (a:e') s  = Just $ (c', [a,a] ++ e', s)

am [] e s = Nothing

am _ _ _ = Nothing

arithmeticOp func (A a) (A b) c e s = operator $ Just  (A (a `func` b), c, e, s)
arithmeticOp _ _ _ _ _ _ = operator Nothing

arith2boolOp func (A a) (A b) c e s = operator $ Just (B (a `func` b), c, e, s)
arith2boolOp _ _ _ _ _ _ = operator Nothing

booleanOp func (B a) (B b) c e s = operator $ Just (B (a `func` b), c, e, s)
booleanOp _ _ _ _ _ _ = operator Nothing

booleanOp1 func (B a) c e s = operator $ Just (B (func a), c, e, s)
booleanOp1 _ _ _ _ _ = operator Nothing

operator func = case func of
                    Just (x, c, e, s) -> Just (c, [x] ++ e, s)
                    Nothing -> Nothing

splitComma insts = f [] insts 0
    where f lhs (head:rhs) cn | head == "(" = if cn == 0
                                                  then f lhs rhs (cn+1)
                                                  else f (lhs ++ [head]) rhs (cn+1)
                              | head == ")" = f (lhs ++ [head]) rhs (cn-1)
                              | head == "," = if cn == 1
                                                  then (lhs, fst $ g [] rhs 1, snd $ g [] rhs 1)
                                                  else f (lhs ++ [head]) rhs cn
                              | otherwise   = f (lhs ++ [head]) rhs cn
          g lhs (head:rhs) cn | head == "(" = g (lhs ++ [head]) rhs (cn+1)
                              | head == ")" = if cn == 1
                                                  then (lhs, rhs)
                                                  else g (lhs ++ [head]) rhs (cn-1)
                              | otherwise   = g (lhs ++ [head]) rhs cn

split :: Char -> String -> [String]
split delim str = f "" str
    where
        f elm (c:str') | c == delim = [elm] ++ f [] str'
                       | otherwise  = f (elm ++ [c]) str'
        f [] [] = []
        f elm [] = [elm]

splitSymbol :: String -> [String]
splitSymbol str = f "" str
    where
        f elm (c:str') | c == ',' || c == '(' || c == ')' || c == '-' = if elm == ""
                                                                            then [[c]] ++ f "" str'
                                                                            else [elm, [c]] ++ f "" str'
                       | otherwise = f (elm ++ [c]) str'
        f [] [] = []
        f elm [] = [elm]

use strict;

my $stm = join '', map{chomp;$_} <>;

print &cs($stm);

sub ca($){
  my $elm = shift;
  
  if($elm =~ /^(\d+)$/){
    return "PUSH-$1";
    
  }elsif($elm =~ /^([a-z]\d*)$/){
    return "FETCH-$1";
    
  }else{
    my @elmchar = split '', $elm;
    my $paren = 0;
    
    for(0..$#elmchar){
      $paren += paren_shift($elmchar[$_]);
      
      if($elmchar[$_] =~ /[-+*]/ && $paren == 0){
        my $lhs = join '', @elmchar[0..$_-1];
        my $rhs = join '', @elmchar[$_+1..$#elmchar];
        
        if($elmchar[$_] eq '+'){
          return ca($rhs) . ':' . ca($lhs) . ':ADD';
        }elsif($elmchar[$_] eq '*'){
          return ca($rhs) . ':' . ca($lhs) . ':MULT';
        }elsif($elmchar[$_] eq '-'){
          return ca($rhs) . ':' . ca($lhs) . ':SUB';
        }
      }
    }
    
    if($paren == 0){
      my $body;
      return ca($body) if(length($body = remove_paren($elm)));
      return ca($body) if(length($body = remove_space($elm)));
    }
    
    die "parse error";
  }
}

sub cb($){
  my $elm = shift;

  if($elm =~ /^true$/){
    return "TRUE";
    
  }elsif($elm =~ /^false$/){
    return "FALSE";
    
  }elsif($elm =~ /^!(.*)/){
    return cb($1) . ':NEG';
    
  }else{
    my @elmchar = split '', $elm;
    my $paren = 0;
    
    for(0..$#elmchar){
      $paren += paren_shift($elmchar[$_]);
      
      if($elmchar[$_] =~ /[<=&]/ && $paren == 0){
        my $lhs = join '', @elmchar[0..$_-1];
        my $rhs = join '', @elmchar[$_+1..$#elmchar];
        
        if($elmchar[$_] eq '='){
          return ca($rhs) . ':' . ca($lhs) . ':EQ';
        }elsif($elmchar[$_].$elmchar[$_+1] eq '<='){
          return ca(substr($rhs, 1)) . ':' . ca($lhs) . ':LE';
        }elsif($elmchar[$_] eq '&'){
          return cb($rhs) . ':' . cb($lhs) . ':AND';
        }
      }
    }
    
    if($paren == 0){
      my $body;
      return cb($body) if(length($body = remove_paren($elm)));
      return cb($body) if(length($body = remove_space($elm)));
    }
    
    die "parse error";
  }
}

sub cs($){
  my $elm = shift;

  my @elmchar = split '', $elm;
  my $paren = 0;

  for(0..$#elmchar){
    $paren += paren_shift($elmchar[$_]);

    if($elmchar[$_] eq ';' && $paren == 0){
      my $lhs = join '', @elmchar[0..$_-1];
      my $rhs = join '', @elmchar[$_+1..$#elmchar];
      return css($lhs) . ':' . cs($rhs);
    }
  }
  return css($elm) if($paren == 0);
  
  die "parse error";
}

sub css($){
  my $elm = shift;
  
  if($elm =~ /^skip$/){
    return "NOOP";
    
  }elsif($elm =~ /^([a-z]\d*)\s*:=\s*(.*)$/){
    return ca($2) . ':' . "STORE-$1";
    
  }elsif($elm =~ /^while(.*)/){
    my $tmpwhile = $1;
    if($tmpwhile =~ /^(.*?)do(.*)$/){
      return 'LOOP(' . cb($1) . ',' . cs($2) . ')';
    }else{
      die "parse error";
    }
    
  }elsif($elm =~ /^if(.*?)then(.*)$/){
    my $cond = $1;
    
    my $paren = 0;
    my $yetread = $2;
    my $alreadyread = '';
    
    while($yetread =~ s/(.*?)(if|else)(.*)/$3/){
      $alreadyread .= $1;
      
      if($2 eq 'if'){
        $paren++;
      }elsif($2 eq 'else'){
        last if($paren == 0);
        $paren--;
      }
      
      $alreadyread .= $2;
    }
    
    return cb($cond) . ':BRANCH(' . cs($alreadyread) . ',' . cs($yetread) . ')';
    
  }elsif($elm =~ /^repeat(.*)/){
    my $cond;
    my $paren = 0;
    my $yetread = $1;
    my $alreadyread = '';

    while($yetread =~ s/(.*?)(repeat|until)(.*)/$3/){
      $alreadyread .= $1;
      
      if($2 eq 'repeat'){
        $paren++;
      }elsif($2 eq 'until'){
        $cond = $3;
        last if($paren == 0);
        $paren--;
      }
      
      $alreadyread .= $2;
    }
    
    return cs($alreadyread) . ':LOOP(' . cb($cond) . ',' . cs($alreadyread) . ')';
    
  }elsif($elm =~ /^for(.*?):=(.*?)to(.*?)do(.*)/){
    my $tmpvar = $1;
    my $start = $2;
    my $end = $3;

    return cs($tmpvar . ':=' . $start) . ':LOOP(' . cb($tmpvar . '<=' . $end) . ',' . cs($4.';'.$tmpvar.':='.$tmpvar.'+1') . ')';
  }
  
  my $body;
  return cs($body) if(length($body = remove_paren($elm)));
  return css($body) if(length($body = remove_space($elm)));

  die "parse error";
}

sub paren_shift($){
  my $char = shift;
  
  if($char eq '('){
    return 1;
  }elsif($char eq ')'){
    return -1;
  }
  return 0;
}

sub remove_paren($){
  my $str = shift;
  
  if($str =~ /^\((.*)\)$/){
    return $1;
  }
  return '';
}

sub remove_space($){
  my $str = shift;
  
  if($str =~ /^(\s*)(.+?)(\s*)$/){
    return $2 if(length $1 || length $3);
  }
  return '';
}

x:=3;y:=1;while !(x=1) do (y:=y*x; x:=x-1)

x:=17;y:=5;z:=0; while y<=x do (z:=z+1; x:=x-y)