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
| 10.2 Surrounding algorithm
> type Rect = (Position,Size)
> algo_Surrounding :: Algorithm
> algo_Surrounding = Algorithm $ \(word:words) -> do
> size <- setting set_canvasSize
> (moveToCentre size `liftM` getWord word) >>= applyWord
> -- TODO: make foldM so it can lazily getWord
> tryUntilFail size words
> where tryUntilFail size (word:words) = do
> succeeds <- getWord word >>= tryApplyWord size
> when succeeds $ tryUntilFail size words
>
> moveToCentre :: (Int,Int) -> Word -> Word
> moveToCentre (cw,ch) w@Word{wrd_size=size} = moveWord (+x) (+y) w
> where (ww,wh) = size
> x = (cw `div` 2) - (ww `div` 2)
> y = (ch `div` 2) - (wh `div` 2)
> tryApplyWord :: CanvasSize -> Word -> WordCloud Bool
> tryApplyWord csize w@Word{wrd_size=size} = do
> words <- gets wcs_words
> let fittedWord = wordThatFits csize w words
> maybe (return False) (\w -> applyWord w >> return True) fittedWord
> wordThatFits :: CanvasSize -> Word -> [Word] -> Maybe Word
> wordThatFits csize w@word ws@alreadyPlacedWords =
> let alreadyPlacedWordBorders = map (borderWord csize w) ws
> wordsBordering = concat alreadyPlacedWordBorders
> okWords = filter (fits ws) wordsBordering
> in listToMaybe okWords
> fits :: [Word] -> Word -> Bool
> fits ws w = not $ any (overlap 0 (wordRect w) . wordRect) ws
> borderWord :: CanvasSize -> Word -> Word -> [Word]
> borderWord csize word wordToBorder =
> let rects = around csize (wordRect word) (wordRect wordToBorder)
> move w (x,y) = moveWord (+x) (+y) w
> words = map (move word) rects
> in words
> wordRect :: Word -> Rect
> wordRect Word{wrd_pos=pos,wrd_size=size} = (pos,size)
> around :: Size -> Rect -> Rect -> [Position]
> around (cw,ch) walker@((wx,wy),(ww,wh)) origin@((ox,oy),(ow,oh)) =
> [ (x,y) | x <- [ox-ww..ox+ow], y <- [oy-wh..oy+oh]
> , x+ww <= ox || y >= oy+oh || x >= ox+ow || y+wh <= oy
> , x >= 0 && x+wx <= cw && y >= 0 && y+wh <= ch
> ]
> applyWord :: Word -> WordCloud ()
> applyWord w = drawWord w >> saveWord w |