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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210

import Prelude hiding (lookup)
import System.Random
import Control.Monad
import Graphics.GD
import Foreign.C.Types
import Data.Bits
import Data.Map hiding (map)
import Data.Time
import Text.Printf
 
type Rectangle = (Point, Point, Color)
type DNA = [Rectangle]
 
numberOfObjects :: Int
numberOfObjects = 5
 
numberOfAdditions :: Int
numberOfAdditions = 1
 
additionProbability :: Int
additionProbability = 1
 
mutationProbability :: Int
mutationProbability = 10
 
numberOfIterations :: Int
numberOfIterations = 1000000
 
snapshotEvery :: Int
snapshotEvery = 10
 
jpegQuality :: Int
jpegQuality = 90
 
targetPath :: String
targetPath = "monalisa.jpg"
 
-- =======================================================================================================================
 
targetImage :: IO Image
targetImage = loadJpegFile targetPath
 
targetPixelColors :: Int -> Int -> IO [(Point, Color)]
targetPixelColors width height = do image <- targetImage
                                    mapM (\point -> mapColor image point) [(x, y) | x <- [1..width], y <- [1..height]]
                                 where mapColor image point = do color <- getPixel point image
                                                                 return (point, color)
 
randomNumberGenerator = randomR (0, 100)
randomRGBGenerator = randomR (0, 255)
randomAlphaGenerator = randomR (0, 127)
 
randomColor :: IO Color
randomColor = do red <- getStdRandom randomRGBGenerator
                 green <- getStdRandom randomRGBGenerator
                 blue <- getStdRandom randomRGBGenerator
                 alpha <- getStdRandom randomAlphaGenerator
                 return $ rgba red green blue alpha
 
alpha :: Num a => Color -> a
alpha color = fromIntegral $ color `shiftR` 24
 
red :: Num a => Color -> a
red color = fromIntegral $ (color .&. 16711680) `shiftR` 16
 
green :: Num a => Color -> a
green color = fromIntegral $ (color .&. 65280) `shiftR` 8
 
blue :: Num a => Color -> a
blue color = fromIntegral $ color .&. 255
 
randomPoint :: Int -> Int -> IO Point
randomPoint maxX maxY = do x <- getStdRandom $ randomR (0, maxX)
                           y <- getStdRandom $ randomR (0, maxY)
                           return (x, y)
 
randomRectangle :: Int -> Int -> IO Rectangle
randomRectangle maxX maxY = do start <- randomPoint maxX maxY
                               end <- randomPoint maxX maxY
                               color <- randomColor
                               return (start, end, color)
 
drawRectangle :: Rectangle -> Image -> IO ()
drawRectangle (start, end, color) image = drawFilledRectangle start end color image
 
initialDNA :: Int -> Int -> Int -> IO DNA
initialDNA objects maxX maxY = sequence [randomRectangle maxX maxY | _ <- [1..objects]]
 
drawDNAImage :: Int -> Int -> IO DNA -> IO Image
drawDNAImage width height ioDNA = do image <- newImage (width, height)
                                     dna <- ioDNA
                                     mapM_ (\rectangle -> drawRectangle rectangle image) dna
                                     return image
 
mutatedValue :: Int -> Int -> IO Int
mutatedValue original max = do offset <- getStdRandom $ randomR (0, max)
                               return $ (original + offset) `mod` max
 
maybeMutateValue :: Int -> Int -> IO Int
maybeMutateValue original max = do randomNumber <- getStdRandom randomNumberGenerator
                                   case randomNumber < mutationProbability of
                                     True -> mutatedValue original max
                                     False -> return original
 
maybeMutatePoint :: Point -> Int -> Int -> IO Point
maybeMutatePoint (x, y) maxX maxY = do newX <- maybeMutateValue x maxX
                                       newY <- maybeMutateValue y maxY
                                       return (newX, newY)
 
maybeMutateColor :: Color -> IO Color
maybeMutateColor original = do possiblyMutatedRed <- maybeMutateValue (red original) 255
                               possiblyMutatedGreen <- maybeMutateValue (green original) 255
                               possiblyMutatedBlue <- maybeMutateValue (blue original) 255
                               possiblyMutatedAlpha <- maybeMutateValue (alpha original) 127
                               return $ rgba possiblyMutatedRed possiblyMutatedGreen possiblyMutatedBlue possiblyMutatedAlpha
 
maybeMutateRectangle :: Rectangle -> Int -> Int -> IO Rectangle
maybeMutateRectangle rectangle maxX maxY = do randomNumber <- getStdRandom randomNumberGenerator
                                              case randomNumber < mutationProbability of
                                                True -> mutateRectangle rectangle maxX maxY
                                                False -> return rectangle
 
mutateRectangle :: Rectangle -> Int -> Int -> IO Rectangle
mutateRectangle (start, end, color) maxX maxY = do possiblyMutatedStart <- maybeMutatePoint start maxX maxY
                                                   possiblyMutatedEnd <- maybeMutatePoint end maxX maxY
                                                   possiblyMutatedColor <- maybeMutateColor color
                                                   return (possiblyMutatedStart, possiblyMutatedEnd, possiblyMutatedColor)
 
maybeNewRectangles :: Int -> Int -> IO [Rectangle]
maybeNewRectangles maxX maxY = do randomNumber <- getStdRandom randomNumberGenerator
                                  case randomNumber < additionProbability of
                                    True -> mapM (\i -> randomRectangle maxX maxY) [1..numberOfAdditions]
                                    False -> return []
mutateDNA :: DNA -> Int -> Int -> IO DNA
mutateDNA (rectangle:rectangles) maxX maxY = do possiblyMutatedRectangle <- maybeMutateRectangle rectangle maxX maxY
                                                possiblyMutatedRectangles <- mutateDNA rectangles maxX maxY
                                                possiblyNewRectangles <- maybeNewRectangles maxX maxY
                                                return $ (possiblyMutatedRectangle : possiblyMutatedRectangles) ++ possiblyNewRectangles
mutateDNA _ _ _ = return []
 
colorDifference :: Color -> Color -> Float
colorDifference color1 color2 = let redDelta = (red color1) - (red color2)
                                    greenDelta = (green color1) - (green color2)
                                    blueDelta = (blue color1) - (blue color2)
                                in sum $ map (** 2.0) [redDelta, greenDelta, blueDelta]
 
comparePixel :: Point -> Map Point Color -> Image -> IO Float
comparePixel point target image = do case lookup point target of
                                       Just color -> do candidateColor <- getPixel point image
                                                        return $ colorDifference color candidateColor
                                       Nothing -> return 0.0
 
fitness :: Map Point Color -> Image -> Int -> Int -> IO Float
fitness target image width height = do deltas <- mapM (\point -> comparePixel point target image)
                                                      [(x, y) | x <- [1..width], y <- [1..height]]
                                       return $ sum deltas
 
printStatus :: Int -> Float -> [Float] -> Int -> IO ()
printStatus iteration fit previousFits objects = do currentTime <- getCurrentTime
                                                    printf "%30s: iteration: %8d, objects: %5d, fit: %14.0f, fit delta: %12.0f, percent improvement: %5.1f%%\n"
                                                           (show currentTime) iteration objects fit delta percentImprovement
 
                                                 where findLastSeenFit [] = 0.0
                                                       findLastSeenFit fits = fits !! (snapshotEvery `mod` (length fits))
 
                                                       lastSeenFit = findLastSeenFit previousFits
                                                       delta = lastSeenFit - fit
                                                       percentImprovement = 100.0 * (delta / lastSeenFit)
 
nextGeneration :: Map Point Color -> Int -> Int -> DNA -> Float -> Int -> IO (DNA, Float)
nextGeneration target width height currentDNA currentFit iteration =
  do case iteration `mod` snapshotEvery of
       0 -> do image <- drawDNAImage width height $ return currentDNA
                       saveJpegFile jpegQuality ("iteration" ++ (show iteration) ++ ".jpg") image
       otherwise -> return ()
 
     mutatedDNA <- mutateDNA currentDNA width height
     mutatedImage <- drawDNAImage width height $ return mutatedDNA
     mutatedFit <- fitness target mutatedImage width height
 
     case (mutatedFit < currentFit) of
       True -> return (mutatedDNA, mutatedFit)
       False -> return (currentDNA, currentFit)
 
simulationStep :: Map Point Color -> Int -> Int -> DNA -> Int -> Int -> [Float] -> IO [Float]
simulationStep target width height currentDNA iteration totalIterations fits@(currentFit:_)
  | iteration == totalIterations = return fits
  | otherwise = do (nextDNA, nextFit) <- nextGeneration target width height currentDNA currentFit iteration
 
                                      case iteration `mod` snapshotEvery of
                                        0 -> printStatus iteration currentFit fits $ length currentDNA
                                        otherwise -> return ()
 
                                      simulationStep target width height nextDNA (iteration + 1) totalIterations (nextFit:fits)
 
runSimulation :: Map Point Color -> Int -> Int -> DNA -> Int -> IO [Float]
runSimulation target width height ivDNA iterations = simulationStep target width height ivDNA 0 iterations [1e12]
 
main :: IO ()
main = do startTime <- getCurrentTime
          putStrLn $ (show startTime) ++ ": processing started; initial objects = " ++ (show numberOfObjects) ++
                     ", increment = " ++ (show numberOfAdditions) ++
                     ", increment probability = " ++ (show additionProbability) ++
                     ", mutation probability = " ++ (show mutationProbability)
 
          (width, height) <- withImage targetImage imageSize
          target <- targetPixelColors width height
          dna <- initialDNA numberOfObjects width height
          fits <- runSimulation (fromList target) width height dna numberOfIterations
          putStrLn $ show fits