codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
{- Brainf*ck Code Generator - by @NeoCat Generate a Brainf*ck code that outputs specified string in commandline arg. -} import List import Char import Maybe import Array import System main = do cs <- getArgs putStrLn $ shorterBF $ head $ cs ++ ["a"] shorterBF cs = if length normalBF < length clusteredBF then normalBF else clusteredBF where normalBF = optimizeBF $ generateBF cs clusteredBF = optimizeBF $ generateBF2 cs -------- common -------- primes :: [Int] primes = 2:f [3] [3,5..] where f (x:xs) ys = let (ps, qs) = span (< x^2) ys in ps ++ f (xs ++ ps) [z | z <- qs, mod z x /= 0] factor :: Int->[Int] factor x = factor' x primes where factor' a (p:ps) | a <= 3 = [a] | p > a = [] | a `mod` p == 0 = [p] ++ factor' (a `div` p) (p:ps) | otherwise = factor' a ps gcd' (x:xs) | xs == [] = x | otherwise = gcd' $ (gcd (abs x) $ abs $ head xs):(drop 1 xs) minimumBy' f (x:(x':xs)) = if f x x' == LT then minimumBy' f (x:xs) else minimumBy' f (x':xs) minimumBy' f [x] = x sign a pos negzero = if a > 0 then pos else negzero signedChar x = if ord x > 128 then ord x - 256 else ord x unsignedChar x = if x < 0 then 256+x else x -------- manipulation of Fpairs (combinations of factors) -------- -- search for Fpairs fpairs :: Int->[[Int]] fpairs = makeFpairs . factor makeFpairs :: [Int]->[[Int]] makeFpairs [] = [] makeFpairs (x:[]) = [[x]] makeFpairs xs = nub $ xs : (cs >>= makeFpairs) where cs = [take y xs ++ [(xs!!y) * (xs!!(y+1))] ++ drop (y+2) xs | y <- [0..length xs - 2]] -- scoring of Fpairs data ScoredFpair = ScoredFpair { pscore :: Int, fpair :: [Int], diff :: Int, dir :: Int, addr :: Int } deriving Show score :: [Int]->Int score xs = length xs * 7 + sum xs - 7 scoredFpairs :: Int->Int->Int->[ScoredFpair] scoredFpairs d x a = map (\p -> ScoredFpair (score p + abs d) p d dir a) $ sortedFpairs x where sortedFpairs = sortBy (\s t -> (score s) `compare` (score t)) . fpairs . abs dir = sign x 1 (-1) bestFpair a 0 = ScoredFpair 0 [] 0 0 a bestFpair a x = head $ sortBy (\s t -> (pscore s) `compare` (pscore t)) $ sortBy (\s t -> abs (diff s) `compare` abs (diff t)) $ [head $ scoredFpairs d (x+d) a | d <- [-9..9], abs (x+d) > 0] bestFpairScore = pscore . bestFpair 0 -- convert string into Fpairs which represents memory operations processChar :: Int->Int->([Int],[ScoredFpair])->([Int],[ScoredFpair]) processChar x a (mem,out) = (mem', out') where mem' = take a mem ++ x : drop (a+1) mem out' = bestFpair a (x - mem!!a) : out processString :: [Int]->String->[ScoredFpair] processString mem cs = reverse $ (\(mem,out) -> out) $ processNext cs (mem,[]) where processNext (c:cs) (mem,out) = processNext cs $ processChar (ord c) (nearest (ord c) mem) (mem,out) processNext [] x = x distance x m = min (abs (x-m)) (256 - abs (x-m)) nearest x mem = let ds = map (distance x) mem in fromJust $ elemIndex (minimum ds) ds -- make BF code (like >> +++ [<+++ [<++>-] >-] <<. ) generateBF :: String->String generateBF = generateBF' . processString [0,0,0,0] generateBF' :: [ScoredFpair]->String generateBF' xs = convertFpairs 0 xs where len = max 1 . length . fpair setDir dir xs = let (ps,rs) = span (== '+') (reverse xs) in sign dir xs $ reverse $ replicate (length ps) '-' ++ rs convertFpairs a [] = [] convertFpairs a (x:xs) = convertFpair (addr x-a) x ++ convertFpairs (addr x) xs convertFpair a x = replicate (abs a * 3) (sign a '>' '<') ++ replicate (3 - len x) '>' ++ setDir (dir x) (concat $ intersperse "[>" $ map (\f -> replicate f '+') $ fpair x) ++ (concat $ replicate (len x-1) "<-]") ++ replicate (len x-1) '>' ++ replicate (abs $ diff x) (sign (diff x) '-' '+') ++ ".<<" -------- clustering for initialization of memory -------- clMax = 4 :: Int clDist = 12 :: Int clScanRange = 5 :: Int cluster :: String -> String cluster xs = if length xs == 1 || length xs <= clMax && (\(x,y,d) -> d) (nearestElem xs) > clDist then xs else cluster $ xs \\ [(\(x,y,d) -> y) $ nearestElem xs] where nearestElem xs = minimumBy' (\(x1,y1,d1) (x2,y2,d2) -> d1 `compare` d2) [(a,b,distance (ord a) (ord b)) | a <- xs, b <- xs, a /= b] -- search the best initializer cluster scoreCluster (xs,c) = let g = gcd' xs in (bestFpairScore g) + sum (map (\x -> abs x `div` g) xs) + sum (map (\(a,b)->distance a b) $ zip xs c) + length xs scanCluster :: [Int]->[[Int]] scanCluster [] = [[]] scanCluster (x:xs) = [x':xs' | x' <- [x-clScanRange..x+clScanRange], xs' <- scanCluster xs] scanCluster' xs = [(c,xs) | c <- scanCluster xs] bestCluster :: [Int]->[Int] bestCluster = (\((x,y),a) -> x) . minimumBy' (\(x,a) (y,b) -> a `compare` b) . map (\x -> (x,scoreCluster x)). scanCluster' -- make the initializer cluster into BF code convertCluster xs = let g = gcd' xs cs = map (\x -> x `div` g) xs cinit = init $ reverse $ dropWhile ('.' /=) $ reverse $ generateBF' [bestFpair 0 g] in cinit ++ "[" ++ (xs >>= (\x -> ">>>" ++ replicate (abs x `div` g) (sign x '+' '-'))) ++ (xs >> "<<<") ++ "-]>" generateBF2 xs = let cs = bestCluster $ map signedChar $ cluster $ nub xs in convertCluster cs ++ (generateBF' $ processString (map unsignedChar cs ++ [0,0,0,0]) xs) -------- BF optimizer -------- usedMemory :: String->[Int] usedMemory cs = usedMemory' 0 [] cs where usedMemory' addr ls ('>':cs) = usedMemory' (addr+1) ls cs usedMemory' addr ls ('<':cs) = usedMemory' (addr-1) ls cs usedMemory' addr ls (_:cs) = usedMemory' addr (nub $ addr:ls) cs usedMemory' addr ls [] = sort ls optimizeBF :: String->String optimizeBF cs = optimizeBF3 $ optimizeBF2 start $ optimizeBF1 cs' where mems = usedMemory cs start = head $ usedMemory cs cs' = replicate start '<' ++ cs optimizeBF1 cs = if optimizeBF1' cs == cs then cs else optimizeBF1 $ optimizeBF1' cs where optimizeBF1' (a:(b:cs)) = if [a,b] == "<>" || [a,b] == "><" then optimizeBF1' cs else (a : optimizeBF1' (b:cs)) optimizeBF1' [a] = [a] optimizeBF1' [] = [] optimizeBF2 addr ('>':cs) = (if any (== addr+1) mems then ">" else "") ++ optimizeBF2 (addr+1) cs optimizeBF2 addr ('<':cs) = (if any (== addr-1) mems then "<" else "") ++ optimizeBF2 (addr-1) cs optimizeBF2 addr (c:cs) = c : optimizeBF2 addr cs optimizeBF2 addr [] = [] optimizeBF3 = reverse . dropWhile (\x -> x == '>' || x == '<') . reverse
Private
[
?
]
Run code
Submit