Godegolf Fish interpreter. In haskell.

fish-1.hs

import qualified Data.Map as M
import System.Environment
import Data.Char
import Control.Monad
import System.Random

type StackT = Int
type Pos = (Int, Int)
data Mode = StringParse | Normal deriving Show

data State = State {
    pointer :: Pos
  , direction :: Int
  , mode :: Mode
  , stack :: [StackT]
  , register :: State -> State
  , mp :: M.Map Pos Char
}

data Flag = Debug deriving Eq

ignoreFlags opr = (\flags s -> opr s)

operators :: [(Char, [Flag] -> State -> IO State)]
operators = [
  -- operators that use flags
  ] ++ map (\(c, opr) -> (c, ignoreFlags opr)) ([
  -- operators that ignores flags
   ('>', changeDir 0)
  ,('v', changeDir 1)
  ,('<', changeDir 2)
  ,('^', changeDir 3)
  ,('\\', dirMapping [1, 0, 3, 2])
  ,('/', dirMapping [3, 2, 1, 0])
  ,('_', dirMapping [0, 3, 2, 1])
  ,('|', dirMapping [2, 1, 0, 3])
  ,('x', (\s -> do x <- randomRIO (0, 3);return$ s{ direction = x }))
  ,('+', arthOpr (+))
  ,('-', arthOpr (-))
  ,('*', arthOpr (*))
  ,(',', arthOpr div)
  ,('%', arthOpr mod)
  ,('(', cmpOpr (<))
  ,(')', cmpOpr (>))
  ,('=', cmpOpr (==))
  ,(':', stackOpr (\(x:xs) -> x:x:xs))
  ,('~', stackOpr tail)
  ,('!', return.step.step)
  ,('?', (\s -> let stk = stack s in 
            return$if null stk || head stk == 0 then step s else s))
  ,('$', stackOpr (\(x:y:xs) -> (y:x:xs)))
  ,('@', stackOpr (\(x:y:z:w) -> (y:z:x:w)))
  ,('&', (\s -> return$ (register s) s))
  ,('r', stackOpr reverse)
  ,('{', stackOpr (\s -> last s : init s))
  ,('}', stackOpr (\s -> tail s ++ [head s]))
  ,('g', (\s -> let (i:j:xs) = stack s
                    c = ord$maybe ' ' id$ M.lookup (i, j) (mp s)
                in return$ s{ stack = c:xs }))
  ,('p', (\s -> let (i:j:c:xs) = stack s
                    mp' = M.insert (i, j) (chr c) (mp s)
                in return$ s{ stack = xs, mp = mp' }))
  ,('o', outputWith$ putChar.chr)
  ,('n', outputWith$ putStr.show)
  ,('i', (\s -> do c <- getChar; return$ s{ stack = ord c : stack s }))
  ] ++ zip (['0'..'9']++['a'..'f']) (map (\x -> return.push x) [0..15]))

changeDir d = dirMapping [d,d..]
dirMapping ds s = return$ s{ direction = ds!!(direction s) }

arthOpr f s = let (b:a:xs) = stack s in return$ s{ stack = f b a : xs }

cmpOpr f s = let
  (b:a:xs) = stack s 
  stk' = (if f b a then 1 else 0) : xs
  in return$ s{stack = stk'}

stackOpr f s = let stk' = f (stack s) in return$ s{ stack = stk' }

step s = let 
  dirs = [(0, 1), (1, 0), (0, -1), (-1, 0)]
  pointer' = go (pointer s) (dirs!!direction s)
  go (i, j) (di, dj) = (i + di, j + dj)
  in s { pointer = pointer' }

outputWith f s = do
  let (x:xs) = stack s
  f x
  return$ s { stack = xs }

readField s = let
  p = pointer s
  m = mp s
  in maybe ' ' id (M.lookup p m)

registerPut s = let
  (x:xs) = stack s
  r' = registerGet x 
  in s{ stack = xs, register = r' }

registerGet x s = s { stack = x:stack s, register = registerPut }

push x s = s{stack = x : stack s}

run :: [Flag] -> State -> IO ()
run flags s = do
    when (elem Debug flags) $ do
      print (x, pointer s, stack s, mode s)
    case mode s of
      StringParse -> run'.step$ 
          if elem x "'\"" then s{mode = Normal} else push (ord x) s
      Normal -> if elem x "'\"" 
          then run'.step$ s{mode = StringParse}
          else if x == ';' 
               then return ()
               else run'.step=<<opr flags s
  where
    x = readField s
    opr = maybe (ignoreFlags$return.id) id $ lookup x operators
    run' = run flags

readCode code = M.fromList . concat$[
  map (\(j, c) -> ((i, j), c)) line | (i, line) <- zip [0,1..]$map (zip [0,1..])$ lines code
  ]

parseFlags :: [String] -> (String, [Flag])
parseFlags [] = ("", [])
parseFlags (x:xs) = if isOption then (file, flag:flags) else (x, flags)
  where 
    (file, flags) = parseFlags xs
    isOption = (head x) == '-'
    optionName = (tail x)
    flag = case optionName of
      "d" -> Debug
      _ -> error$ "Unknown option " ++ optionName

makeState code = State {
   pointer = (0, 0)
  ,direction = 0
  ,mode = Normal
  ,stack = []
  ,register = registerPut
  ,mp = readCode code
  }

main = do
  args <- getArgs
  let (file, flags) = parseFlags args
  code <- readFile file
  run flags$ makeState code

fish.hs

import qualified Data.Map as M
import System.Environment
import Data.Char
import System.Random
type I=Integer
data S=S{p::(I,I),d,e::Int,s::[I],r::S->S,m::M.Map(I,I)Char}
a=zip">v<^\\/_|x+-*,%()=:~!?$@&r{}gponi"[q 0,q 1,q 2,q 3,
 i[1,0,3,2],i[0,3,2,1],i[0,3,2,1],i[2,1,0,3],\s->do x<-randomRIO(0,3);t$s{d=x},
 h(+),h(-),h(*),h div,h mod,h$j(<),h$j(>),h$j(==),
 o(\(x:y)->x:x:y),o tail,t.g.g,\q->t$if s q==[]||head(s q)==0 then g q else q,
 o(\(x:y:z)->(y:x:z)),o(\(x:y:z:w)->(y:z:x:w)),\q->t$(r q)q,
 o reverse,o(\s->last s:init s),o(\s->tail s++[head s]),
 \q->let(i:j:x)=s q in t$q{s=l(b(i,j)q):x},
 \q->let(i:j:k:x)=s q in t$q{s=x,m=M.insert(i,j)(n k)(m q)},
 y$putChar.n,y$putStr.show,\q->do c<-getChar;t(q{s=l c:(s q)})
 ]++[(x,t.c i)|(x,i)<-zip['0'..'9'][0..9]++zip['a'..'f'][10..15]]
b p q=maybe ' 'id$M.lookup p(m q)
c x q=q{s=x:s q}
f(i,j)0=(i,j+1)
f(i,j)1=(i+1,j)
f(i,j)2=(i,j-1)
f(i,j)3=(i-1,j)
g q=q{p=f(p q)(d q)}
h f=o(\(b:a:k)->f b a:k)
i a s=t$s{d=a!!(d s)}
j f a b|f a b=1|1<2=0
k=zip[0,1..]
l=toInteger.ord
n=chr.fromInteger
o f q=t$q{s=f(s q)}
q x=i[x,x..]
t=return
u s=M.fromList.foldr1(++)$[map(\(j,x)->((i,j),x))l|(i,l)<-k$map k$lines s]
v q=let(x:y)=s q in q{r=w x,s=y}
w x q=q{s=x:(s q),r=v}
y o q=let(i:x)=s q in o i>>t(q{s=x})
z q=[[[y=<<(maybe t id$lookup x a)q,t()]!!j(==)x ';',y$c(l x)q]!!k,w]!!j elem x"'\""
 where k=e q;x=b(p q)q;w=y$q{e=1-k};y=z.g
main=z.S(0,0)0 0[]v.u=<<readFile.head=<<getArgs

for.fish

mm  v                           
   >              v
   ~>1f+00p       v                     
    ;v?)+afg00    <             #<-- Condition of loop 1
   p>>~ 410p      v             
   0vv?)+cfg01    <  <          #<-- Condition of loop 2
   00>~10g00gg'.'=?v~     v     #<-- Go this route when 
   +0    vp01+1g01~<            #    we find a digit.
   1g    >           ^   
   ^<                      
   v                      <   
                          >       >~      ;
0  >10g0cg"0"$-+00gg:" "=?^~:"."=?^v   
   ^     pc0+1gc0 n-$"0"          ~<
                               
    .......................  
    .......................  
    ......112233...........   This program prints 
    .......................   the number on this field.
    .......................     <------------
    .......................  
    .......................      
    .......................       
    .......................