summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore1
-rw-r--r--BrainFuck.hs123
-rw-r--r--CHANGELOG.md5
-rw-r--r--EditDistance.hs27
-rw-r--r--Evolve.hs45
-rw-r--r--Main.hs20
-rw-r--r--Par.hs27
-rw-r--r--RandomState.hs14
-rw-r--r--Setup.hs2
-rw-r--r--evolution.cabal26
10 files changed, 290 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..48a004c
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1 @@
+dist-newstyle
diff --git a/BrainFuck.hs b/BrainFuck.hs
new file mode 100644
index 0000000..aa724b8
--- /dev/null
+++ b/BrainFuck.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE FlexibleInstances #-}
+module BrainFuck (runBF, BF(..), strToBF) where
+
+import qualified Data.Sequence as Sequence
+import Data.Foldable (toList)
+import qualified System.Random as Random
+import qualified Evolve
+import RandomState (splitG)
+import qualified Control.Monad.State as State
+import System.IO.Unsafe (unsafePerformIO)
+import Control.Concurrent (yield)
+import qualified EditDistance
+import Data.List (intercalate)
+
+data BF = Plus | Minus | ML | MR | Print | Loop [BF] deriving Eq
+
+instance Show BF where
+ show Plus = "+"
+ show Minus = "-"
+ show ML = "<"
+ show MR = ">"
+ show Print = "."
+ show (Loop bf) = '[' : intercalate "" (map show bf) ++ "]"
+
+mutateString :: Random.RandomGen g => String -> State.State g String
+mutateString [] = do r <- fst . Random.random <$> splitG
+ if r < Evolve.mutateProbability
+ then (: []) . fst . Random.randomR ('+', ']') <$> splitG
+ else return []
+mutateString (x : xs) = do i <- insert
+ d <- delete
+ r <- rest
+ return $ i ++ d ++ r
+ where insert = do r <- fst . Random.random <$> splitG
+ if r < Evolve.mutateProbability
+ then (: []) . fst . Random.randomR ('+', ']') <$> splitG
+ else return []
+ delete = do r <- fst . Random.random <$> splitG
+ if r < Evolve.mutateProbability
+ then return []
+ else return [x]
+ rest = mutateString xs
+
+instance Evolve.Evolvable [BF] where
+ mutate bf = BrainFuck.strToBF <$> mutateString (intercalate "" (map show bf))
+ score bf = 100 - fromIntegral (EditDistance.dist (BrainFuck.runBF bf) "Hello World!")
+
+randomBF :: Random.RandomGen g => State.State g BF
+randomBF = do r <- fst . Random.randomR (0, 5 :: Int) <$> splitG
+ case r of
+ 0 -> return Plus
+ 1 -> return Minus
+ 2 -> return ML
+ 3 -> return MR
+ 4 -> return Print
+ _ -> Loop <$> Evolve.mutate []
+
+instance Random.Random BF where
+ -- TODO: may as well have a correct implementation here
+ randomR _ _ = undefined
+ random g = State.runState randomBF g
+
+extend :: a -> Int -> Sequence.Seq a -> Sequence.Seq a
+extend def i s
+ | i < length s = s
+ | otherwise = s Sequence.>< Sequence.replicate (i - length s + 1) def
+
+safeAdjust :: a -> (a -> a) -> Int -> Sequence.Seq a -> Sequence.Seq a
+safeAdjust def f i s = Sequence.adjust f i (extend def i s)
+
+iAdj :: Num a => (a -> a) -> Int -> Sequence.Seq a -> Sequence.Seq a
+iAdj = safeAdjust 0
+
+safeIndex :: a -> Sequence.Seq a -> Int -> a
+safeIndex def s i = (extend def i s) `Sequence.index` i
+
+iInd :: Num a => Sequence.Seq a -> Int -> a
+iInd = safeIndex 0
+
+safeEnumToChar :: Enum e => e -> Char
+safeEnumToChar e = toEnum $ i `mod` (fromEnum '~' - spc + 1) + spc
+ where i = fromEnum e
+ spc = fromEnum ' '
+
+runBF :: [BF] -> String
+runBF bf = let (_, _, s) = foldl go (Sequence.singleton 0, 0, Sequence.empty) bf
+ in toList s
+ where go :: (Sequence.Seq Integer, Int, Sequence.Seq Char) -> BF
+ -> (Sequence.Seq Integer, Int, Sequence.Seq Char)
+ go (a, dp, s) Plus = (iAdj succ dp a, dp, s)
+ go (a, dp, s) Minus = (iAdj pred dp a, dp, s)
+ go (a, dp, s) ML = (a, max (pred dp) 0, s)
+ go (a, dp, s) MR = (a, succ dp, s)
+ go (a, dp, s) Print = (a, dp, s Sequence.|> safeEnumToChar (a `iInd` dp))
+ go st@(a, dp, _) cmd@(Loop inner)
+ | 0 <- a `iInd` dp = st
+ | otherwise = unsafePerformIO yield `seq` go (foldl go st inner) cmd
+
+strToBF' :: String -> ([BF], String)
+strToBF' [] = ([], [])
+strToBF' ('[':ss) =
+ case strToBF' ss of
+ (bf, ']':rest) -> let (bf', extra) = strToBF' rest
+ in (Loop bf : bf', extra)
+ -- Failure case, but we tolerate it
+ (bf, rest) -> ([Loop bf], rest)
+strToBF' rest@(']':_) = ([], rest)
+strToBF' (x:ss)
+ | Just cmd <- conv x = let (bf, extra) = strToBF' ss
+ in (cmd : bf, extra)
+ | otherwise = strToBF' ss
+
+conv :: Char -> Maybe BF
+conv '+' = Just Plus
+conv '-' = Just Minus
+conv '<' = Just ML
+conv '>' = Just MR
+conv '.' = Just Print
+conv _ = Nothing
+
+strToBF :: String -> [BF]
+strToBF s = let (bf, _) = strToBF' s
+ in bf
diff --git a/CHANGELOG.md b/CHANGELOG.md
new file mode 100644
index 0000000..4902a3d
--- /dev/null
+++ b/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for evolution
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/EditDistance.hs b/EditDistance.hs
new file mode 100644
index 0000000..124d968
--- /dev/null
+++ b/EditDistance.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE FlexibleContexts #-}
+module EditDistance (dist) where
+
+import qualified Data.Sequence as Sequence
+import qualified Data.Map as Map
+import qualified Control.Monad.State as State
+
+dist :: Eq a => [a] -> [a] -> Int
+dist a b = State.evalState (d (pred $ length aSeq) . pred $ length bSeq) Map.empty
+ where d :: Int -> Int -> State.State (Map.Map (Int, Int) Int) Int
+ d i (-1) = return (succ i)
+ d (-1) j = return (succ j)
+ d i j = do m <- State.get
+ case Map.lookup (i, j) m of
+ Just res -> return res
+ Nothing
+ | aSeq `Sequence.index` i == bSeq `Sequence.index` j -> do res <- d (pred i) (pred j)
+ State.modify (Map.insert (i, j) res)
+ return res
+ | otherwise -> do left <- succ <$> d (pred i) j
+ right <- succ <$> d i (pred j)
+ middle <- succ <$> d (pred i) (pred j)
+ let res = min (min left right) middle
+ State.modify (Map.insert (i, j) res)
+ return res
+ aSeq = Sequence.fromList a
+ bSeq = Sequence.fromList b
diff --git a/Evolve.hs b/Evolve.hs
new file mode 100644
index 0000000..a34a382
--- /dev/null
+++ b/Evolve.hs
@@ -0,0 +1,45 @@
+module Evolve (Evolvable, evolve, mutate, score, mutateProbability) where
+
+import qualified System.Random as Random
+import Data.List (maximumBy)
+import qualified Par
+import qualified Control.Monad.State as State
+import RandomState (splits)
+import Data.Function (on)
+import qualified Control.Concurrent.Chan as Chan
+import System.Timeout (timeout)
+import Control.Exception (evaluate)
+
+class Evolvable e where
+ mutate :: Random.RandomGen g => e -> State.State g e
+ score :: e -> Double
+
+numChildren :: Int
+numChildren = 100
+
+printModCount :: Int
+printModCount = 100
+
+scoreTimeout :: Int
+scoreTimeout = 1000
+
+mutateProbability :: Double
+mutateProbability = 0.005
+
+evolve :: (Evolvable e, Show e) => Chan.Chan e -> e -> IO ()
+evolve c e = evolve' 0 c e 0
+
+timeoutScore :: Evolvable e => e -> IO Double
+timeoutScore e = maybe (-1) id <$> timeout scoreTimeout (evaluate (score e))
+
+evolve' :: (Evolvable e, Show e) => Int -> Chan.Chan e -> e -> Double -> IO ()
+evolve' generation chan startState myScore = do gs <- take numChildren . State.evalState splits <$> Random.newStdGen
+ childrenScores <- ((myScore, startState) :) <$> Par.mapIO scoreChild gs
+ let (bestScore, bestChild) = maximumBy (compare `on` fst) childrenScores
+ if generation `mod` printModCount == 0
+ then Chan.writeChan chan bestChild
+ else return ()
+ evolve' (succ generation) chan bestChild bestScore
+ where scoreChild g = do let myChild = State.evalState (mutate startState) g
+ realScore <- timeoutScore myChild
+ return (realScore, myChild)
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..20413f7
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,20 @@
+module Main where
+
+import qualified BrainFuck
+import System.Environment (getArgs)
+import qualified Evolve
+import qualified Control.Concurrent.Chan as Chan
+import Control.Concurrent (forkIO)
+import Data.List (intercalate)
+
+type BF = [BrainFuck.BF]
+
+main :: IO ()
+main = do a <- getArgs
+ s <- readFile (head a)
+ let bf = BrainFuck.strToBF s
+ c <- Chan.newChan
+ _ <- forkIO $ Evolve.evolve c bf
+ generations <- Chan.getChanContents c
+ mapM_ display generations
+ where display e = putStrLn $ BrainFuck.runBF e ++ "\ncode: (" ++ intercalate "" (map show e) ++ ")"
diff --git a/Par.hs b/Par.hs
new file mode 100644
index 0000000..1465956
--- /dev/null
+++ b/Par.hs
@@ -0,0 +1,27 @@
+module Par (map, mapIO, mapIO_) where
+
+import Control.Parallel (par, pseq)
+import Control.Concurrent (forkIO)
+import qualified Control.Concurrent.MVar as MVar
+import Prelude hiding (map)
+
+map :: (a -> b) -> [a] -> [b]
+map _ [] = []
+map f (x:xs) =
+ let this = f x
+ that = Par.map f xs
+ in that `par` this `pseq` this : that
+
+mapIO :: (a -> IO b) -> [a] -> IO [b]
+mapIO _ [] = return []
+mapIO f (x:xs) = do restMVar <- MVar.newEmptyMVar
+ _ <- forkIO (do rest <- mapIO f xs
+ MVar.putMVar restMVar rest)
+ this <- f x
+ rest <- MVar.takeMVar restMVar
+ return (this : rest)
+
+mapIO_ :: (a -> IO ()) -> [a] -> IO ()
+mapIO_ _ [] = return ()
+mapIO_ f (x:xs) = do _ <- forkIO (mapIO_ f xs)
+ f x
diff --git a/RandomState.hs b/RandomState.hs
new file mode 100644
index 0000000..9466b49
--- /dev/null
+++ b/RandomState.hs
@@ -0,0 +1,14 @@
+module RandomState (splitG, splits) where
+
+import qualified Control.Monad.State as State
+import qualified System.Random as Random
+import Data.List (unfoldr)
+
+splitG :: Random.RandomGen g => State.State g g
+splitG = do g <- State.get
+ let (g1, g2) = Random.split g
+ State.put g1
+ return g2
+
+splits :: Random.RandomGen g => State.State g [g]
+splits = unfoldr (Just . Random.split) <$> splitG
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/evolution.cabal b/evolution.cabal
new file mode 100644
index 0000000..6856079
--- /dev/null
+++ b/evolution.cabal
@@ -0,0 +1,26 @@
+cabal-version: >=1.10
+-- Initial package description 'evolution.cabal' generated by 'cabal init'.
+-- For further documentation, see http://haskell.org/cabal/users-guide/
+
+name: evolution
+version: 0.1.0.0
+-- synopsis:
+-- description:
+-- bug-reports:
+-- license:
+license-file: LICENSE
+author: Ray Hogenson
+maintainer: rhogenson@posteo.net
+-- copyright:
+-- category:
+build-type: Simple
+extra-source-files: CHANGELOG.md
+
+executable evolution
+ main-is: Main.hs
+ other-modules: BrainFuck Par Evolve RandomState EditDistance
+ -- other-extensions:
+ build-depends: base >=4.12 && <4.13, containers>=0.6, parallel>=3.2, random, mtl
+ -- hs-source-dirs:
+ default-language: Haskell2010
+ ghc-options: -Wall -Werror -threaded -with-rtsopts=-N
generated by cgit v1.3.1 (git 2.54.0) at 2026-09-04 03:41:55 +0000