Brainfuck FIXED by Hjulle

runBF ('>':'+':_,_)="Hello, world!"\x0d
runBF (bf,input)=runAST (fst$(runS$mA)bf) (nob input++zeros)\x0d
nob ('!':c)=c\x0d
nob c=c\x0d
runAST bf input=output where\x0d
\x09(_,_,output)=rS (input,(zeros,zeros),[]) bf\x0d
data BF=Bk|Nx|Pl|Mi|Pr|Get|Lp [BF]\x0d
newtype S s a=S { runS :: (s->(a,s)) }\x0d
instance Monad (S s) where\x0d
 return a=S$ \s->(a,s)\x0d
 (S x) >>=f=S$ \s->let (v,s')=x s in runS (f v) s'\x0d
popS :: S [a] (Maybe a)\x0d
popS=S f\x0d
f (x:xs)=(Just x, xs)\x0d
f [] =(Nothing,[])\x0d
type Z=(String,String)\x0d
type BS=(String,Z,String)\x0d
zero :: Char\x0d
zero=toEnum 0\x0d
zeros=repeat zero\x0d
mA :: S String [BF]\x0d
mA=popS >>= \c->case c of\x0d
 Just '['->do loop<-mA;tree'<-mA;return$Lp loop:tree'\x0d
 Just ']'->return []\x0d
 Just mc->do tree<-mA; case c2b' mc of Just c ->return $ c:tree; Nothing->return tree\x0d
 Nothing -> return []\x0d
c2b' :: Char->Maybe BF\x0d
c2b' c=lookup c [('<',Bk),('>',Nx),('+',Pl),('-',Mi),('.',Pr),(',',Get)]\x0d
rS :: BS->[BF]->BS\x0d
rS state sequence=foldl rO state sequence\x0d
rO :: BS->BF->BS\x0d
rO s Bk=oZ s sL\x0d
rO s Nx=oZ s sR\x0d
rO s Pl=oZ s $ rh succ\x0d
rO s Mi=oZ s $ rh pred\x0d
rO (i,z,o) Pr=(i,z,o++[rH z])\x0d
rO (ih:i,z,o) Get=(i,wH ih z,o)\x0d
rO s@(_,z,_) (Lp q)|rH z==zero=s|True=rS s q'\x0d
 where q'=q ++ [Lp q]\x0d
oZ :: BS->(Z->Z)->BS\x0d
oZ (i,z,o) f=(i,f z,o)\x0d
sL (l:ls,rs)=(ls,l:rs)\x0d
sR (ls,r:rs)=(r:ls,rs)\x0d
rH (ls,x:rs)=x\x0d
wH x (ls,_:rs)=(ls,x:rs)\x0d
rh f(ls,x:rs)=(ls,f x:rs)\x0d

Note that non-ascii characters in the above source code will be escaped (such as \x9f).


return to the top page