From 440dd38f24d1df150fb5b4c7965bb6e792c929fe Mon Sep 17 00:00:00 2001
From: Ray Hogenson <rhogenson@posteo.net>
Date: Sat, 7 Sep 2019 16:36:01 -0700
Subject: Write a little guy

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.
---
 .gitignore      |   1 +
 BrainFuck.hs    | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 CHANGELOG.md    |   5 +++
 EditDistance.hs |  27 +++++++++++++
 Evolve.hs       |  45 +++++++++++++++++++++
 Main.hs         |  20 +++++++++
 Par.hs          |  27 +++++++++++++
 RandomState.hs  |  14 +++++++
 Setup.hs        |   2 +
 evolution.cabal |  26 ++++++++++++
 10 files changed, 290 insertions(+)
 create mode 100644 .gitignore
 create mode 100644 BrainFuck.hs
 create mode 100644 CHANGELOG.md
 create mode 100644 EditDistance.hs
 create mode 100644 Evolve.hs
 create mode 100644 Main.hs
 create mode 100644 Par.hs
 create mode 100644 RandomState.hs
 create mode 100644 Setup.hs
 create mode 100644 evolution.cabal

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
-- 
cgit v1.3.1