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
|
module Main where
import Data.Array (Array, array, bounds, (!), (//))
import Data.Functor ((<$>))
import Data.Maybe
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Char (toUpper)
import System.Random (RandomGen, getStdGen, split, randomR, randomRs)
import System.Random.Shuffle
-- Vectors to represent position and orientation.
data Vec = Vec { x::Int, y::Int } deriving (Show, Eq)
origin = Vec 0 0
left = Vec (-1) 0
right = Vec 1 0
up = Vec 0 (-1)
down = Vec 0 1
add :: Vec -> Vec -> Vec
add a b = Vec (x a + x b) (y a + y b)
index :: Vec -> (Int, Int)
index p = (x p, y p)
-- Pose is a tuple of position and orientation.
data Pose = Pose { position::Vec, orientation::Vec } deriving (Show, Eq)
advance :: Pose -> Pose
advance p = p {position = add (position p) (orientation p)}
-- We just use Char for each field.
empty = '.'
-- Board is an immutable array.
type Board = Array (Int, Int) Char
showBoard :: Board -> String
showBoard arr =
unlines $ map (map (arr !)) indices
where indices = [[(x, y) | x <- [sX..eX]] | y <- [sY..eY]]
((sX, sY), (eX, eY)) = bounds arr
mkBoard :: (Int, Int) -> Array (Int, Int) Char
mkBoard (d, e) = array ((0, 0), (m, n)) [((x, y), empty) | x<-[0..m], y<-[0..n]]
where m = d-1
n = e-1
charAt :: Board -> Vec -> Maybe Char
charAt b p =
if x p >= 0 && y p >= 0 && x p <= eX && y p <= eY then
Just (b ! index p)
else
Nothing
where ((sX, sY), (eX, eY)) = bounds b
-- Test whether it's possible to insert a string at the given pose.
-- Return the associated cost or Nothing, if the string didn't fit.
tryInsert :: String -> Pose -> Board -> Maybe Int
tryInsert [] _ _ = Just 0
tryInsert (w:ws) p b =
case charAt b (position p) of
Nothing -> Nothing
Just c ->
if c /= empty && c /= w then
Nothing
else do
t <- tryInsert ws (advance p) b
return ((if c == w then 0 else 1) + t)
-- Given a string and a pose, return a list of updates for a board to
-- insert the string.
mkPatch :: String -> Pose -> [((Int, Int), Char)]
mkPatch [] _ = []
mkPatch (w:ws) p = (index $ position p, w) : mkPatch ws (advance p)
-- Actually insert the string returning a new board.
insert :: String -> Pose -> Board -> Maybe Board
insert [] _ b = Just b
insert w p b =
if isNothing (tryInsert w p b) then
Nothing
else
Just (b // mkPatch w p)
insertAll :: RandomGen gen => gen -> [String] -> Board -> Maybe Board
insertAll _ [] b = Just b
insertAll rnd (w:ws) b = do
b' <- insert w pose b
insertAll rnd' ws b'
where
pose = fst (sortBy (comparing snd) (map (\t -> (fst t, fromJust $ snd t)) weightedMoves) !! nth)
(nth, rnd') = randomR (0, min 10 (length weightedMoves)) rnd
weightedMoves = filter (\x -> case snd x of Just x' -> x' > 0; Nothing -> False) [(po, tryInsert w po b) | po <- posOrientation']
posOrientation' = shuffle' posOrientation (length posOrientation) rnd
posOrientation = [Pose (Vec x y) o | x <- [sX..eX], y <- [sY..eY], o <- [right, down]]
((sX, sY), (eX, eY)) = bounds b
fill :: RandomGen gen => gen -> Board -> Board
fill rnd b = b // zip [(x, y) | x <- [sX..eX], y <- [sY..eY], (b ! (x, y)) == empty] (randomRs ('A', 'Z') rnd)
where
((sX, sY), (eX, eY)) = bounds b
main :: IO ()
main = do
rnd <- getStdGen
c <- getContents
let guests = lines (map toUpper c) in
case (showBoard . fill rnd) <$> insertAll rnd guests (mkBoard (40, 30)) of
Just s -> putStr s
Nothing -> putStr "goesnt"
|
