.

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