[ create a new paste ] login | about

Link: http://codepad.org/urRSDMLi    [ raw code | output | fork | 1 comment ]

NeoCat - Haskell, pasted on Nov 29:
{-
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


Output:
1
++++++++[>++++++++++++<-]>+.


Create a new paste based on this one


Comments:
posted by aaaaaa on Mar 2
test
reply