-
Notifications
You must be signed in to change notification settings - Fork 0
/
GenMasc.hs
136 lines (112 loc) · 4.26 KB
/
GenMasc.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
import Moo.GeneticAlgorithm.Binary
import Control.Arrow (first)
import Control.Monad (when)
import Data.List (intercalate, sortBy, permutations)
import Data.Ord (comparing)
import NaturalLanguageModule (naturalismDefault, naturalism, defaultCriterions)
import Moo.GeneticAlgorithm.Continuous (getRandomGenomes)
import BlindtextModule (cryptotext2)
import MascModule (Direction (..), MascKey, masc, initializeMascGenome)
import TypeModule
import Reordering (combineMutationOps, completeShiftMutate, swapMutate, listswapMutate, revMutate, blockSwapMutate, shuffelMutate, shiftMutate, initializeEnumGenome, edgeCrossover)
-- DANGER this of course is cheating and can not be used in a real usecase
import BlindtextModule (blindtext1Naturalism)
{-
Sorting a list (of Characters) using a genetic algorythm.
The output should be readable for human, but for a nice
plot with gnuplot you can paste this in "plot_output"...
set terminal postscript eps enhanced color font 'Helvetica,10'
set xlabel 'Generations'
set ylabel 'sorting fittnes'
set output 'output.eps'
set key bottom box
plot 'output.txt' using 1:2 with lines lc rgb 'red' lw 4 title 'best value',\
'output.txt' using 1:3 with lines lc rgb 'dark-grey' title 'median value',\
'output.txt' using 1:4 with lines lc rgb 'grey' title 'worst value'
...and this in "runGensort.sh"...
#!/bin/bash
ghc --make GenSort.hs
time ./GenSort > output.txt
gnuplot -p plot_output.plt
filelength=$(wc -l < output.txt)
echo "Final Generation: $(($filelength - 6))"
tail -5 output.txt
... and run it with ./runGensort
-}
-- stopconditions (they are very high)
maxiters = 50000
minFittness = blindtext1Naturalism defaultCriterions
timeLimit = 600 -- in seconds
problem :: Problem Char
problem = cryptotext2
popsize :: Int
popsize = 7
selection :: SelectionOp a
selection = withScale (\x -> x*x) (rouletteSelect 5)
crossover :: (Ord a) => CrossoverOp a
crossover =
edgeCrossover 2
--noCrossover
--orderCrossover 0.3
--uniformCrossover 0.3
mutation :: MutationOp a
mutation =
combineMutationOps [shiftMutate, swapMutate]
elitesize = 3
natFitnes :: Problem Char -> Genome Char -> Double
natFitnes problem genome =
naturalism defaultCriterions (masc Decrypt genome problem)
showGenome :: Problem Char -> Genome Char -> String
showGenome problem genome = "# Genome " ++ show genome
++ "\n# makes " ++ (begining . show) problem
++ "\n# to " ++ (begining . show . masc Decrypt genome) problem
++ "\n# (natFitnes: " ++ show (natFitnes problem genome) ++ ")"
where
showBits :: [Bool] -> String
showBits = concatMap (show . fromEnum)
-- run the real algorythm
geneticAlgorithm :: Problem Char -> IO (Population Char)
geneticAlgorithm problem = do
runIO (initializeMascGenome popsize) $ loopIO
[DoEvery 1 (logStats problem), TimeLimit timeLimit]
(Or (Generations maxiters) (IfObjective (any (>= minFittness))))
nextGen
where
nextGen :: StepGA Rand Char
--nextGen = nextSteadyState 8 Maximizing fitness selection crossover mutation
nextGen = nextGeneration Maximizing fitness selection elitesize crossover mutation
fitness :: [Genome Char] -> Population Char
fitness = map (\ genome -> (genome, natFitnes problem genome))
-- Gnuplotreadable statistics for 1 Generation
logStats :: Problem Char -> Int -> Population Char -> IO ()
logStats problem iterno pop = do
let gs = map takeGenome . bestFirst Maximizing $ pop -- genomes
let best = head gs
let median = gs !! (length gs `div` 2)
let worst = last gs
putStrLn $ unwords [ show iterno
, (show . natFitnes problem) best
, (braces . show) best
, (show . natFitnes problem) median
, (braces . show) median
, (show . natFitnes problem) worst
, (braces . show) worst
, (take 10 . show . masc Decrypt best) problem
]
where
braces :: String -> String
braces str = "(" ++ str ++ ")"
main :: IO()
main = do
putStrLn $ "# Fittnes to reach: " ++ (show) minFittness
putStrLn "# generation medianValue bestValue"
finalPop <- geneticAlgorithm problem
if (finalPop == [])
then error "finalpop is empty"
else do
let winner = takeGenome . head . bestFirst Maximizing $ finalPop
putStrLn $ showGenome problem winner
return ()
begining :: String -> String
begining xs = take n xs -- ++ "..."
where n = 6