Write a little guyHEADmain

This program is in a weird state right now, but I'm checking it in to
git so that I can back it up, since I want to reinstall again.

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