Initial commit
[darcs-mirror-talk-kfpg-haskell-roadshow.git] / circles.lhs
1 A Haskell Roadshow
2 ==================
3
4 By [Joachim Breitner], for [The Karlsruhe Functional Programmers Meetup Group], December 18, 2012.
5
6 The following is a rough transcript of the code that I develop duing the talk.
7 It does not contain all the steps and the comments, but gives a good overview.
8 Also, while here I append numbers to function names when I improve them, during
9 the talk, the functions are just modified. So when reading the code, just
10 ignore the appended numbers. Also ignore any ocurrence of `undefined`; these
11 are there to fill in fields that I would not have added at that point during
12 the talk. Stage directions are in *italics*.
13
14 Step 1: First picture
15 ---------------------
16
17 > import Data.List
18 > import Data.Char
19 > import Data.Ord
20 > import Data.Function
21 > import Data.List.Split
22 > import Data.Data
23 > import Graphics.Gloss
24 > -- Add in step 8
25 > import Optimisation.CirclePacking
26 > -- Add in step 10
27 > import Graphics.Gloss.Interface.Pure.Game
28
29 Develop `findNames` with ghci feedback
30
31 > findNames :: String -> [String]
32 > findNames input =
33 >     [ surname |
34 >         l <- lines input ,
35 >         let fullname = (endBy ":" l) !! 4, 
36 >         not (null (words fullname)),
37 >         let surname = last (words fullname),
38 >         head surname `elem` ['A'..'Z']]
39
40 Next develop `frequencies` in GHCi
41
42 > frequencies :: [Char] -> [(Char, Int)]
43 > frequencies = map (\l -> (head l, length l)) . group . sort
44
45 We will have to put more data in, so lets create a data type. *At first, no color, no pos, no nextPos!*
46
47 > data CharCircle = CharCircle {
48 >     char :: Char,
49 >     col :: Color,
50 >     count :: Int,
51 >     pos :: (Double, Double),
52 >     nextPos :: (Double, Double)
53 >     }
54
55 Every circle needs a radius. Do not put this in the value, but store it separately.
56
57 > radius :: CharCircle -> Double
58 > radius c = sqrt (fromIntegral (count c))
59
60 We can convert our stats to a CharCircle. *Ignore undefined*
61
62 > toCircle1 :: (Char, Int) -> CharCircle
63 > toCircle1 (c,n) = CharCircle c undefined n undefined undefined
64
65 Time to get drawing. Looking through hackage for something relating *vector
66 graphics* and *simple*, we stumble on [gloss]. Judging from the docs, this code
67 should do it. *Add Text and center bit by bit, draw one circle first. Use
68 `snippet-centerText.txt`*
69
70 > drawCircle1 :: CharCircle -> Picture
71 > drawCircle1 c =
72 >     pictures [ circleSolid (realToFrac (radius c)) ,
73 >                color black $ circle (realToFrac (radius c)) ,
74 >                centerText (char c) ]
75
76 > centerText :: Char -> Picture
77 > centerText c = 
78 >     color black $
79 >     scale 0.1 0.1 $
80 >     translate (-50) (-50) $
81 >     text [c]
82
83 > main1 = do
84 >     input <- readFile "passwd"
85 >     let stats = frequencies $ map head $ findNames input
86 >     let circles = map toCircle1 stats
87 >     let pic = color blue $ pictures $ map drawCircle1 circles
88 >     display (FullScreen (1024,768)) white pic
89
90 Step 2: Positioning circles
91 ---------------------------
92
93 Clearly not satisfiying. We need position the circles better. So lets add a
94 function for placing a circle, storing the position in the circle and lets put
95 them all on a line:
96
97 > putAt2 :: Double -> Double -> CharCircle -> CharCircle
98 > putAt2 x y c = c { pos = (x,y) }
99
100 > toCircle2 :: (Char, Int) -> CharCircle
101 > toCircle2 (c,n) = CharCircle c undefined n (0,0) undefined
102
103 > drawCircle2 :: CharCircle -> Picture
104 > drawCircle2 c =
105 >     let (x,y) = pos c in
106 >     translate (realToFrac x) (realToFrac y) $
107 >     pictures [ circleSolid (realToFrac (radius c)) ,
108 >                color black $ circle (realToFrac (radius c)) ,
109 >                centerText (char c) ]
110
111 > placeLine2 :: Double -> [CharCircle] -> [CharCircle]
112 > placeLine2 dist = zipWith
113 >     (\i c -> putAt2 (dist * fromIntegral i) 0 c)
114 >     [0..]
115
116 > main2 = do
117 >     input <- readFile "passwd"
118 >     let stats = frequencies $ map head $ findNames input
119 >     let circles = map toCircle2 stats
120 >     let placed = placeLine2 30 $ circles
121 >     let pic = color blue $ pictures $ map drawCircle2 placed
122 >     display (FullScreen (1024,768)) white pic
123
124 Step 3: Adding color
125 --------------------
126
127 The coloring gives me the creeps. We need more colors! Lets define some (`snippet-colors.txt`):
128
129 > colors :: [Color]
130 > colors = [red, green, blue, yellow, cyan, magenta,
131 >           violet, azure, aquamarine, orange]
132
133 We also want to store them. So let us extend the data type and assign them to
134 the circles.
135
136 > toCircle3 :: (Char, Int) -> Color -> CharCircle
137 > toCircle3 (c,n) col = CharCircle c col n (0,0) undefined
138
139 > drawCircle3 :: CharCircle -> Picture
140 > drawCircle3 c =
141 >     let (x,y) = pos c in
142 >     translate (realToFrac x) (realToFrac y) $
143 >     pictures [ color (col c) $ circleSolid (realToFrac (radius c)) ,
144 >                color black $ circle (realToFrac (radius c)) ,
145 >                centerText (char c) ]
146
147 > main3 = do
148 >     input <- readFile "passwd"
149 >     let stats = frequencies $ map head $ findNames input
150 >     let circles = zipWith toCircle3 stats colors
151 >     let placed = placeLine2 30 $ circles
152 >     let pic = pictures $ map drawCircle3 placed
153 >     display (FullScreen (1024,768)) white pic
154
155 Step 4: Infinite lists!
156 -----------------------
157
158 Looks better! But we are missing some letters. Looks like we have not enough
159 colors. So lets make sure we have enough, no matter how many cycles we are
160 drawing!
161
162
163 > main4 = do
164 >     input <- readFile "passwd"
165 >     let stats = frequencies $ map head $ findNames input
166 >     let circles = zipWith toCircle3 stats (cycle colors)
167 >     let placed = placeLine2 30 $ circles
168 >     let pic = pictures $ map drawCircle3 placed
169 >     display (FullScreen (1024,768)) white pic
170
171 Step 5 and 6: More dimensions
172 -----------------------------
173
174 This layout clearly does not use the space well. Let us try to use the second
175 dimention:
176
177 > placeRectangle5 :: [CharCircle] -> [CharCircle]
178 > placeRectangle5 = zipWith
179 >     (\(i,j) -> putAt2 (-250 + 100 * i) (250 - 100 * j))
180 >     [ (i,j) | j <- [0..5] , i <- [0..5] ]
181
182 And we can make the code a bit more fancy -- pure vanity
183
184 > placeRectangle6 :: [CharCircle] -> [CharCircle]
185 > placeRectangle6 = zipWith id
186 >     [ putAt2 (-250 + 100 * i) (250 - 100 * j) | j <- [0..5] , i <- [0..5] ]
187
188 > main6 = do
189 >     input <- readFile "passwd"
190 >     let stats = frequencies $ map head $ findNames input
191 >     let circles = zipWith toCircle3 stats (cycle colors)
192 >     let placed = placeRectangle6 circles
193 >     let pic = pictures $ map drawCircle3 placed
194 >     display (FullScreen (1024,768)) white pic
195
196 Step 7: No overlaps, please.
197 ----------------------------
198
199 Much better. But we dont want overlapping circles. Lets try to arrange them
200 without overlap, one after another, on a row:
201
202 > placeAutoLine7 :: Double -> [CharCircle] -> [CharCircle]
203 > placeAutoLine7 _ [] = []
204 > placeAutoLine7 x (c:cs) =
205 >       putAt2 (x + radius c) 0 c :
206 >       placeAutoLine7 (x + 2*radius c) cs
207
208 > main7 = do
209 >     input <- readFile "passwd"
210 >     let stats = frequencies $ map head $ findNames input
211 >     let circles = zipWith toCircle3 stats (cycle colors)
212 >     let placed = placeAutoLine7 (-512) circles
213 >     let pic = pictures $ map drawCircle3 placed
214 >     display (FullScreen (1024,768)) white pic
215
216 Step 8: Fancy layout!
217 ---------------------
218
219 Good, but again we only use one dimension. Can we pack them tightly, but
220 without overlap? Sounds not trivial anymore, lets see if there is a ready-made
221 package. What a coincidence, there is one, [circle-packing]! The API looks simple enough, so here we go:
222
223 > placePacked8 :: [CharCircle] -> [CharCircle]
224 > placePacked8 cs = map (\(c,(x,y)) -> putAt2 x y c) $ packCircles radius cs
225
226 > main8 = do
227 >     input <- readFile "passwd"
228 >     let stats = frequencies $ map head $ findNames input
229 >     let circles = zipWith toCircle3 stats (cycle colors)
230 >     let placed = placePacked8 circles
231 >     let pic = pictures $ map drawCircle3 placed
232 >     display (FullScreen (1024,768)) white pic
233
234 Step 9: Lets have it all.
235 -------------------------
236
237 Beautiful! But I cannot really decide which layout I like the most; I want them
238 all. Luckily gloss makes it easy to also create interactive programs in the game mode, so lets try that:
239
240 First we assemble a list of all our circle placers. We use this as the state of
241 our program. The simulation step does nothing, so we need to handle key events
242 to select the next place from the list, and also provide a draw function.
243
244 > placers9 = cycle [ placeLine2 30, placeAutoLine7 (-500),
245 >                    placePacked8, placeRectangle6 ]
246
247 > change9 (EventKey (SpecialKey KeySpace) Up _ _) ps = tail ps
248 > change9 _ circles = circles
249
250 > main9 = do
251 >     input <- readFile "passwd"
252 >     let names = findNames input
253 >     let stats = frequencies (map head names)
254 >     let circles = zipWith toCircle3 stats (cycle colors)
255
256 >     let draw (placer:_) = 
257 >             pictures $ map drawCircle3 $ placer circles
258
259 >     play (FullScreen (1024,768)) white 25
260 >          placers9
261 >          draw
262 >          change9
263 >          (const id)
264
265 Step 10: Animation
266 ------------------
267
268 That works fine. But it could look even slicker. Lets try to animate the transition.
269 For that we need to extend the datatype to store the current and the desired
270 position, and set only the latter in the placers. *Placers code does not change
271 besides updating the names of the used functions.*
272
273 > toCircle10 :: (Char, Int) -> Color -> CharCircle
274 > toCircle10 (c,n) col = CharCircle c col n (0,0) (0,0)
275
276 > putAt10 :: Double -> Double -> CharCircle -> CharCircle
277 > putAt10 x y c = c { nextPos = (x,y) }
278
279
280 > placeLine10 :: Double -> [CharCircle] -> [CharCircle]
281 > placeLine10 dist = zipWith
282 >     (\i c -> putAt10 (dist * fromIntegral i) 0 c)
283 >     [0..]
284 > placeAutoLine10 :: Double -> [CharCircle] -> [CharCircle]
285 > placeAutoLine10 _ [] = []
286 > placeAutoLine10 x (c:cs) = putAt10 (x + radius c) 0 c : placeAutoLine10 (x + 2*radius c) cs
287 > placePacked10 :: [CharCircle] -> [CharCircle]
288 > placePacked10 cs = map (\(c,(x,y)) -> putAt10 x y c) $ packCircles radius cs
289 > placeRectangle10 :: [CharCircle] -> [CharCircle]
290 > placeRectangle10 = zipWith id
291 >     [ putAt10 (-250 + 100 * i) (250 - 100 * j) | j <- [0..5] , i <- [0..5] ]
292 > placers10 = cycle [placeLine10 30, placeAutoLine10 (-500), placePacked10, placeRectangle10 ]
293
294 Then we need a fuction that advances the circles towards their target position,
295 depending on the time passed since the last advancement. A little geometry:
296
297 > moveCircle10 seconds c =
298 >       if dist <= adv
299 >       then c { pos = nextPos c }
300 >       else c { pos = (x',y')}
301 >   where 
302 >     (x1,y1) = pos c
303 >     (x2,y2) = nextPos c
304 >     dist = sqrt ((x2 - x1)^2 + (y2-y1)^2)
305 >     adv = speed * realToFrac seconds
306 >     x' = x1 + (x2 - x1) * adv / dist
307 >     y' = y1 + (y2 - y1) * adv / dist
308 >     speed = 150
309
310 Our state is now both the placer list and the list of circles
311
312 In the change event, we not only pop the placer from the list, but also apply
313 it. And we sort by character, as that influences the stacking order.
314
315 > change10 (EventKey (SpecialKey KeySpace) Up _ _) (p:ps, circles) =
316 >       (ps, sortBy (comparing char) $ p circles)
317 > change10 _ state = state
318
319 > moveCircles10 seconds (p, cs) = (p, map (moveCircle10 seconds) cs)
320
321 > main10 = do
322 >     input <- readFile "passwd"
323 >     let names = findNames input
324 >     let stats = frequencies (map head names)
325 >     let circles = zipWith toCircle10 stats (cycle colors)
326
327 >     let draw = pictures . map drawCircle3 . snd
328
329 >     play (FullScreen (1024,768)) white 25
330 >          (placers10, circles)
331 >          draw
332 >          change10
333 >          moveCircles10
334
335 *What main function to test at the moment.*
336
337 > main = main8
338
339 [Joachim Breitner]: http://www.joachim-breitner.de/
340 [The Karlsruhe Functional Programmers Meetup Group]: http://www.meetup.com/The-Karlsruhe-Functional-Programmers-Meetup-Group/events/93934702/
341 [circle-packing]: http://hackage.haskell.org/package/circle-packing
342 [gloss]: http://hackage.haskell.org/package/gloss