moo-1.2: examples/ExampleMain.hs

-- | The boring part common to many examples: command line options
-- and pretty-printing the results.
module ExampleMain
    ( exampleMain
    , ExampleDefaults(..)
    , exampleDefaults
    ) where


import Moo.GeneticAlgorithm.Binary
import Moo.GeneticAlgorithm.Continuous
import Moo.GeneticAlgorithm.Multiobjective
import Moo.GeneticAlgorithm.Statistics


import Control.Monad (liftM, when)
import Data.List (intercalate)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import System.Exit (exitSuccess)
import Text.Printf


data Flag = RunGenerations Int
          | PrintBest Bool
          | PrintStats Bool
          | DumpAll Bool
          | ShowHelp
            deriving (Show, Eq)


data ExampleDefaults = ExampleDefaults
    { numGenerations :: Int
    , printBest :: Bool
    , printStats :: Bool
    , dumpAll :: Bool
    } deriving (Show, Eq)


exampleDefaults = ExampleDefaults {
                    numGenerations = 100
                  , printBest = True
                  , printStats = False
                  , dumpAll = False
                  }


exampleOptions :: ExampleDefaults -> [OptDescr Flag]
exampleOptions c =
    [ Option "gn" ["generations"]
                 (ReqArg (RunGenerations . read) "N")
                 ("number of generations (default: " ++ show (numGenerations c) ++ ")")
    , Option "b" ["best"]
                 (NoArg $ PrintBest True)
                 ("print the best solution" ++ (isDefault (printBest c)))
    , Option ""  ["no-best"]
                 (NoArg $ PrintBest False)
                 ("don't print the best solution" ++ (isDefault (not . printBest $ c)))
    , Option "d" ["dump"]
                 (NoArg $ DumpAll True)
                 ("dump the entire population and its objective values" ++ isDefault (dumpAll c))
    , Option ""  ["no-dump"]
                 (NoArg $ DumpAll False)
                 ("don't dump the entire population" ++ isDefault (not . dumpAll $ c))
    , Option "s" ["stats"]
                 (NoArg $ PrintStats True)
                 ("print population statistics" ++ isDefault (printStats c))
    , Option ""  ["no-stats"]
                 (NoArg $ PrintStats False)
                 ("don't print population statistics" ++ isDefault (not . printStats $ c))
    , Option "h" ["help"]
                 (NoArg ShowHelp)
                 "show help"
    ]
   where
   isDefault :: Bool -> String
   isDefault True = " (default)"
   isDefault False = ""


updateDefaults :: ExampleDefaults -> [Flag] -> ExampleDefaults
updateDefaults d (RunGenerations n:opts) = updateDefaults (d { numGenerations = n }) opts
updateDefaults d (PrintBest b:opts) = updateDefaults (d { printBest = b }) opts
-- --stats overrid --dump, and vice versa
updateDefaults d (DumpAll b:opts) =
    let ps = printStats d
    in  flip updateDefaults opts (d { dumpAll = b, printStats = ps && (not b)})
updateDefaults d (PrintStats b:opts) =
    let da = dumpAll d
    in  flip updateDefaults opts (d { printStats = b, dumpAll = da && (not b)})
updateDefaults d [] = d



printHeader conf = do
  when (printStats conf) $ putStrLn "# best, median"
  when (dumpAll conf) $ putStrLn "# x1, x2, ..., objective1, objective2, ..."


printSnapshot conf sorted = do
  when (printBest conf) $
    if null sorted
       then putStrLn "# no solutions"
       else putStrLn $ "# best found: " ++ fmtPt (head sorted)

  when (printStats conf) $ do
    printHeader conf
    let ovs = map takeObjectiveValue sorted
    let obest = head ovs
    let omedian = median ovs
    putStrLn $ fmtXs " " [obest, omedian]

  when (dumpAll conf) $ do
    printHeader conf
    -- print the best solution last;
    -- (for scatter-plotting it above the others)
    flip mapM_ (reverse sorted) $ \p -> putStrLn $ fmtPtOneline p
    putStrLn ""

  where

    fmtPt :: (Show a, Real a, PrintfArg a) => Phenotype a -> String
    fmtPt (xs, v) = (printf "%.3g @ [" v) ++ fmtXs ", " xs ++ "]"

    fmtPtOneline :: (Show a, Real a, PrintfArg a) => Phenotype a -> String
    fmtPtOneline p = let xs = map (fromRational.toRational) . takeGenome $ p
                         vs = [takeObjectiveValue p]
                     in  fmtXs " " $ xs ++ vs

    fmtXs :: (Show a, Real a, PrintfArg a) => String -> [a] -> String
    fmtXs sep xs =  intercalate sep $ map (printf "%.3g") xs



-- | Run a genetic algorithm defined by @problemtype@, and @step@.
-- Process command line options to change the number of iterations
-- and logging behaviour.
exampleMain :: (Show a, Real a, PrintfArg a)
            => ExampleDefaults -> ProblemType -> Rand [Genome a] -> StepGA Rand a -> IO ()
exampleMain defaults problemtype initialize step = do

  let options = exampleOptions defaults
  (opts, args, msgs) <- liftM (getOpt Permute options) getArgs
  when (ShowHelp `elem` opts) $ do
    progname <- getProgName
    let header = "usage: " ++ progname ++ " [options]\n\nOptions:\n"
    putStrLn (usageInfo header options)
    exitSuccess

  let conf = updateDefaults defaults opts
  let gens = numGenerations conf
  result <- runGA initialize (loop (Generations gens) step)
  let sorted = bestFirst problemtype $ result
  printSnapshot conf sorted