factor out video
[maximus:bitbreeder.git] / bitbreeder.hs
1 module Main(main) where
2
3 import Control.Applicative (Applicative, (<$>), (<*>))
4 import Control.Exception (handle, SomeException)
5 import Control.Monad (liftM3, replicateM, forever, forM, forM_, when)
6 import Control.Monad.Random (MonadRandom, getRandomR, evalRandIO)
7 import Control.Concurrent (forkIO)
8 import GHC.Conc (numCapabilities)
9
10 import Data.Maybe (listToMaybe)
11 import Data.Time.Clock (getCurrentTime, diffUTCTime)
12 import Data.Vector.Storable ((//))
13 import System.IO (hSetBuffering, BufferMode(LineBuffering), hPutStrLn, stdout)
14
15 import Graphics.UI.Gtk
16 import Graphics.UI.Gtk.OpenGL
17 import Control.Concurrent.STM
18 import System.Process
19
20 import Expression
21 import Compile
22 import Video
23 import Database
24 import Genetics
25 import Metric (Metric, Stats)
26 import qualified Metric as M
27
28 gui :: (TVar [TVar (DB Item)], TVar Stats, TBQueue Metric, TBQueue (Maybe Double, E)) -> IO ()
29 gui (dbsV, statsV, toAudio, toVideo) = do
30   _ <- initGUI
31   _ <- initGL
32   wi <- windowNew
33   nb <- notebookNew
34   let addTab tabname = do
35         db <- atomically $ (readTVar . head) =<< readTVar dbsV
36         databaseV <- newTVarIO db
37         metricV <- newTVarIO M.emptyMetric
38         targetV <- newTVarIO M.zero
39         weightV <- newTVarIO M.zero
40         atomically $ modifyTVar dbsV (databaseV:)
41         v <- vBoxNew False 5
42         let resort = do
43               s <- readTVar statsV
44               t <- readTVar targetV
45               w <- readTVar weightV
46               modifyTVar metricV $ M.target w t s
47               m <- readTVar metricV
48               modifyTVar databaseV $ sortOn (M.score m . itemMetric)
49               writeTBQueue toAudio m
50             target k = do
51               t <- hScaleNewWithRange (-5) 5 0.01
52               scaleSetDrawValue t False
53               widgetSetSizeRequest t 512 24
54               rangeSetValue t 0
55               _ <- t `on` valueChanged $ do
56                 u <- rangeGetValue t
57                 atomically $ do
58                   modifyTVar targetV (// [(k, realToFrac u)])
59                   resort
60               return t
61             weight k = do
62               w <- hScaleNewWithRange 0 1 0.001
63               scaleSetDrawValue w False
64               widgetSetSizeRequest w 256 24
65               rangeSetValue w 0
66               _ <- w `on` valueChanged $ do
67                 u <- rangeGetValue w
68                 atomically $ do
69                   modifyTVar weightV (// [(k, realToFrac u)])
70                   resort
71               return w
72             row k n = do
73               h <- hBoxNew False 5
74               l <- labelNew (Just n)
75               widgetSetSizeRequest l 160 24
76               t <- target k
77               w <- weight k
78               boxPackStart h l PackNatural 0
79               boxPackEnd h w PackGrow 0
80               boxPackEnd h t PackGrow 0
81               boxPackStart v h PackNatural 0
82         forM_ (zip [0..] names) $ uncurry row
83         widgetShowAll v
84         page <- notebookAppendPage nb v tabname
85         notebookSetCurrentPage nb page
86         _ <- nb `on` switchPage $ \page' -> when (page == page') $ atomically $
87           writeTBQueue toAudio =<< readTVar metricV
88         return ()
89   namesV <- newTVarIO $ words "aardvark beaver chimp donkey elephant frog goat halibut iguana jackdaw kitten leopard manatee newt otter pigeon quail rabbit stoat tiger uncle velociraptor whale xtinct yow zzz"
90   let addTab' = do
91         name <- atomically $ do
92           (n:ns) <- readTVar namesV
93           writeTVar namesV ns
94           return n
95         addTab name
96   b <- buttonNewFromStock stockAdd
97   _ <- b `on` buttonActivated $ addTab'
98   widgetShowAll b
99   notebookSetActionWidget nb b PackStart
100   set nb [notebookScrollable := True, notebookHomogeneous := True]
101   set wi [windowTitle := "BitBreeder", containerChild := nb]
102   widgetSetSizeRequest wi 1024 576
103   _ <- wi `onDestroy` mainQuit
104   widgetShowAll wi
105   addTab'
106
107   eV <- newTVarIO (Just 0, I 0)
108   wi2 <- windowNew
109   da <- glDrawingAreaNew =<< glConfigNew [GLModeRGB, GLModeDouble]
110   let renderer = forever $ do
111         atomically $ writeTVar eV =<< readTBQueue toVideo
112         postGUISync $ widgetQueueDraw da
113   _ <- onRealize da $ do
114     _ <- withGLDrawingArea da $ \_ -> do
115       setupGL
116       _ <- forkIO renderer
117       return ()
118     return ()
119   _ <- onExpose da $ \_ -> do
120     (mn, e) <- atomically $ readTVar eV
121     _ <- withGLDrawingArea da $ \gl -> do
122       draw e
123       glDrawableSwapBuffers gl
124       case mn of
125         Just n -> do
126           captureToPNG (pngFilename (floor n))
127           atomically $ do
128             (mn', e') <- readTVar eV
129             when (mn == mn') $ writeTVar eV (Nothing, e')
130         _ -> return ()
131     return True
132   widgetSetSizeRequest da exprWidth exprHeight
133   set wi2 [windowTitle := "BitBreeder", containerChild := da, windowDecorated := False]
134   _ <- wi2 `onDestroy` mainQuit
135   widgetShowAll wi2
136
137   mainGUI
138
139 names :: [String]
140 names = [ m ++ " (" ++ p ++ ")" | m <- measurements, p <- parameters ] ++ ["novelty"]
141
142 measurements :: [String]
143 measurements =
144   [ "loudness"
145   , "tonality"
146   , "centroid"
147   , "variance"
148   , "skewness"
149   , "kurtosis"
150   ]
151
152 parameters :: [String]
153 parameters =
154   [ "average"
155   , "variability"
156   , "granularity"
157   ]
158
159 data Item = Item{ itemID :: !Int, itemExpr :: E, itemMetric :: M.Analysis }
160
161 mutateI :: (Applicative m, MonadRandom m) => E -> m E
162 mutateI X = return X
163 mutateI (I i) = do
164   k <- coin 0.1
165   if k
166     then do
167       j <- getRandomR (1, 64)
168       return (I j)
169     else return (I i)
170 mutateI (U u e) = U u <$> mutateI e
171 mutateI (B b e f) = B b <$> mutateI e <*> mutateI f
172 mutateI (T e f g) = T <$> mutateI e <*> mutateI f <*> mutateI g
173
174 coin :: (Functor m, MonadRandom m) => Double -> m Bool
175 coin p = (< p) <$> getRandomR (0, 1)
176
177 terminal :: (Functor m, MonadRandom m) => m E
178 terminal = do
179   c <- coin 0.5
180   if c then return X else I <$> getRandomR (1, 64)
181
182 data F
183   = FU U
184   | FB B
185   | FT
186   deriving (Read, Show, Eq)
187
188 getRandomE :: (Functor m, MonadRandom m, Enum e, Bounded e) => m e
189 getRandomE = self
190   where
191     self = do
192       mi <- return minBound `asTypeOf` self
193       ma <- return maxBound `asTypeOf` self
194       toEnum <$> getRandomR (fromEnum mi, fromEnum ma)
195
196 function :: (Functor m, MonadRandom m) => m F
197 function = do
198   c <- coin 0.05
199   if c then FU <$> getRandomE else do
200     d <- coin 0.05
201     if d then return FT else FB <$> getRandomE
202
203 grow :: (Applicative m, MonadRandom m) => Int -> m E
204 grow 0 = terminal
205 grow d = do
206   c <- coin 0.25
207   if c then terminal else do
208     f <- function
209     case f of
210       FU u -> U u <$> grow (d - 1)
211       FB b -> B b <$> grow (d - 1) <*> grow (d - 1)
212       FT   -> T   <$> grow (d - 1) <*> grow (d - 1) <*> grow (d - 1)
213
214 breed :: (Applicative m, MonadRandom m) => E -> E -> m [E]
215 breed e0 e1 = do
216   n0 <- getRandomR (0, nodes e0 - 1)
217   n1 <- getRandomR (0, nodes e1 - 1)
218   let (f0, f1) = exchange e0 n0 e1 n1
219   return [f0, f1]
220
221 main :: IO ()
222 main = do
223   hSetBuffering stdout LineBuffering
224   gui =<< evolution
225
226 breeder :: TVar [TVar (DB Item)] -> TBQueue E -> IO ()
227 breeder dbsV toJudge = loop
228   where
229     loop = do
230       dbS <- atomically $ readTVar dbsV
231       ws <- evalRandIO $ replicateM 2 $ getRandomR (0, length dbS - 1)
232       dbs <- atomically $ mapM (readTVar . (dbS !!)) ws
233       [e0, e1] <- forM dbs $ \db -> do
234         let pop = take minPopCount (toAscList db)
235         evalRandIO $ if length pop < minPopCount then grow 5 else do
236           n <- getRandomR (0, minPopCount - 1)
237           mutateI $ itemExpr (pop !! n)
238       es <- evalRandIO $ do
239         e2 <- grow 5
240         liftM3 (\a b c -> a++b++c) (breed e0 e1) (breed e0 e2) (breed e1 e2)
241       forM_ es $ atomically . writeTBQueue toJudge
242       loop
243
244 judge :: TVar [TVar (DB Item)] -> TVar Stats -> TBQueue E -> Int -> Int -> IO ()
245 judge dbsV statsV toJudge inc = loop
246   where
247     loop i = do
248       e <- atomically $ readTBQueue toJudge
249       ignoreErrors $ do
250         let so = "./o/" ++ show i ++ ".so"
251         compileSO e so
252         (_, Just hout, _, p) <- createProcess (proc "./judge" [so, show i]){ std_out = CreatePipe }
253         v <- M.read hout
254         _ <- waitForProcess p
255         let it = Item i e v
256         atomically $ do
257           dbs <- readTVar dbsV
258           forM_ dbs $ \db -> modifyTVar db (insert it)
259           modifyTVar statsV (M.accum (itemMetric it))
260       loop (i + inc)
261
262 ignoreErrors :: IO () -> IO ()
263 ignoreErrors = handle ((\_ -> return ()) :: SomeException -> IO ())
264
265 evolution :: IO (TVar [TVar (DB Item)], TVar Stats, TBQueue Metric, TBQueue (Maybe Double, E))
266 evolution = do
267   toJudge <- newTBQueueIO (2 * numCapabilities)
268   toAudio <- newTBQueueIO (2 * numCapabilities)
269   toVideo <- newTBQueueIO (2 * numCapabilities)
270   dbV <- newTVarIO empty
271   dbsV <- newTVarIO [dbV]
272   statsV <- newTVarIO M.emptyStats
273   _ <- forkIO $ breeder dbsV toJudge
274   _ <- forkIO $ audio dbV toVideo
275   _ <- forkIO $ forever $ atomically $ do
276     m <- readTBQueue toAudio
277     modifyTVar dbV $ sortOn (M.score m . itemMetric)
278   forM_ [0 .. numCapabilities - 1] $ forkIO . judge dbsV statsV toJudge numCapabilities
279   return (dbsV, statsV, toAudio, toVideo)
280
281 audio :: TVar (DB Item) -> TBQueue (Maybe Double, E) -> IO ()
282 audio dbV toVideo = do
283   (Just lh, _, _, _) <- createProcess (proc "./live" []){ std_in = CreatePipe }
284   hSetBuffering lh LineBuffering
285   start <- getCurrentTime
286   let loop n = do
287         (p, e) <- atomically $ do
288           chart <- readTVar dbV
289           case listToMaybe (toAscList chart) of
290             Just i | itemID i /= n -> return (itemID i, itemExpr i)
291             _ -> retry
292         now <- getCurrentTime
293         let frame = 25 * realToFrac (diffUTCTime now start + 4.5)
294         hPutStrLn lh ("./o/" ++ show p ++ ".so")
295         atomically $ writeTBQueue toVideo (Just frame, e)
296         print (frame, e)
297         loop p
298   loop (-1)
299
300 minPopCount :: Int
301 minPopCount = 64