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
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
module Crosswords
import StdEnv, StdDebug, StdOverloadedList
import MersenneTwister
import ArgEnv
instance + String where (+) x y = x +++ y
:: HorVer = Hor | Ver
instance == HorVer
where (==) Hor Hor = True; (==) Ver Ver = True; (==) _ _ = False
:: WordPlacement
= { word :: [#Char]
, dir :: HorVer
, x :: Int
, y :: Int
}
:: Crossword :== [WordPlacement]
instance zero Crossword where zero = []
:: PlacementOK :== (WordPlacement Crossword -> Bool)
:: RandomSeed :== Int
// Reads words from stdin (end with empty line) and builds a crossword that
// connects all these words (if possible); then fills the crossword with words
// from dict-3-6.txt. Outputs LaTeX code (uses cwpuzzle.dtx from the crossword
// package).
Start w
// Read dictionary
# cmd = getCommandLine
# dictionary = if (size cmd > 1) cmd.[1] "dictionary.txt"
# (fillwords,w) = readFillWords dictionary w
# fillwords = sortl fillwords
// Read input
# (io,w) = stdio w
# (words,io) = readWords [] io
# (ok,w) = fclose io w
| not ok = abort "Couldn't close stdio\n"
// Make crossword
# (rand,w) = time 0 w
# rand = if (size cmd > 2) (toInt cmd.[2]) rand
# cw = makeCrossword rand words
# cw = trace_n ("\nIntermediate:\n" + toString cw) cw
# cw = fill rand fillwords cw
# cw = trace_n ("\nResult:\n" + toString cw) cw
= toLaTeX False cw
where
readFillWords :: String *World -> *([[#Char]], *World)
readFillWords fname w
# (ok,f,w) = fopen fname FReadText w
| not ok = ([], w)
# (words,f) = readWords [] f
# (ok,w) = fclose f w
= (words,w)
readWords :: [[#Char]] *File -> *([[#Char]], *File)
readWords acc f
# (s,f) = freadline f
| s == "" = (reverse (map (Map toUpper) acc), f)
# s = fromString` s
| (not o isAlpha o Hd) s = readWords acc f
= readWords [TakeWhile (not o isSpace) s:acc] f
where
fromString` :: String -> [#Char]
fromString` s = fromString s
time :: !Int !*World -> (!Int, !*World)
time i w = code inline {
ccall time "I:I:p"
}
minx cw :== minList [wp.x \\ wp <- cw]
miny cw :== minList [wp.y \\ wp <- cw]
maxx cw :== maxList [minx cw:[wp.x+Length wp.word-1 \\ wp<-cw | wp.dir==Hor]]
maxy cw :== maxList [miny cw:[wp.y+Length wp.word-1 \\ wp<-cw | wp.dir==Ver]]
toLaTeX :: Bool Crossword -> String
toLaTeX fillBorders cw
= "\\begin{Puzzle}{" + toString width + "}{" + toString height + "}%\n" +
tex (minx cw) (miny cw) 1 (fromString (toString cw)) +
"\\end{Puzzle}\n"
where
width = maxx cw - minx cw + 1
height = maxy cw - miny cw + 1
tex :: Int Int Int [Char] -> String
tex _ _ _ []
= ""
tex x y n [' ':cs]
| pathToBorder [] x y && not fillBorders
= "|{} " + tex (x+1) y n cs
= "|* " + tex (x+1) y n cs
tex x y n ['\n':cs]
= "|.\n" + tex (minx cw) (y+1) n cs
tex x y n [c:cs]
| occ (x+1) y && not (occ (x-1) y) || occ x (y+1) && not (occ x (y-1))
= "|[" + toString n + "]" + {c} + pad + " " + tex (x+1) y (n+1) cs
= "|" + {c} + " " + tex (x+1) y n cs
where pad = if (n>9) "" " "
occ :: Int Int -> Bool
occ x y = any (any (\(_,x`,y`) -> x`==x && y`==y) o poss) cw
pathToBorder :: [(Int,Int)] Int Int -> Bool
pathToBorder seen x y
| isMember (x,y) seen = False
| occ x y = False
| x <= minx cw || x >= maxx cw = True
| y <= miny cw || y >= maxy cw = True
= any
(app2 (pathToBorder [(x,y):seen]))
[(x-1,y),(x+1,y),(x,y-1),(x,y+1)]
where
app2 :: (a a -> b) (a,a) -> b
app2 f (x,y) = f x y
instance toString Crossword
where
toString cw = foldl (+) ""
[toString
[letter x y \\ x <- [minx cw..maxx cw]] + "\n"
\\ y <- [miny cw..maxy cw]]
where
letter :: Int Int -> Char
letter x y
| isEmpty letters = ' '
| otherwise = hd letters
where letters = [l \\ w <- cw, (l,x`,y`) <- poss w | x`==x && y`==y]
// Sort words by decreasing length
sortl :: ([[#Char]] -> [[#Char]])
sortl = sortBy (\a b -> Length a > Length b)
// All positions of this letter in this place
letterPositions :: Char WordPlacement -> [(Int,Int)]
letterPositions c wp = [(x,y) \\ (l,x,y) <- poss wp | c == l]
// All positions a word uses
poss :: WordPlacement -> [(Char,Int,Int)]
poss {word,dir,x,y}
= [if (dir == Hor) (l,x+i,y) (l,x,y+i) \\ l <|- word & i <- [0..]]
// Fill a crossword with extra words (don't make it bigger)
fill :: RandomSeed ![[#Char]] !Crossword -> Crossword
fill r fws cw = place r fits` (shufflesort r fws) 0 cw
// Shuffle, then sort on length
shufflesort :: RandomSeed -> [[#Char]] -> [[#Char]]
shufflesort r = sortl o (shuffle r)
// Shuffle a list of strings semi-randomly
shuffle :: RandomSeed -> [a] -> [a]
shuffle r = s (genRandInt r)
where
s :: [RandomSeed] [a] -> [a]
s _ [] = []
s [r:rs] xs = [last fsts:s rs (init fsts ++ rest)]
where (fsts,rest) = splitAt (abs (r rem (length xs)) + 1) xs
// Make a crossword, try to lay all words connected
makeCrossword :: RandomSeed [[#Char]] -> Crossword
makeCrossword r words = place r fits (sortl words) 0 zero
// Place a number of words in a crossword, satisfying a predicate
place :: RandomSeed PlacementOK [[#Char]] Int Crossword -> Crossword
place _ _ [] _ cw = cw
place r fits ws i cw
| isEmpty places
| i >= length ws - 1 = cw // Nothing can be placed
| otherwise = place r2 fits ws (i+1) cw // Try next words
= trace_n word (place r2 fits (removeMember word ws) 0 [hd places:cw])
where
word = ws!!i
places = placements r1 fits word cw
[r1,r2:_] = genRandInt r
// All placements of a word in a crossword that satisfy a predicate
placements :: RandomSeed PlacementOK [#Char] Crossword -> [WordPlacement]
placements _ fits word [] = [{word=word, dir=Hor, x=0, y=0}]
placements r fits word cw = (flatten o flatten)
[[[wp
\\ wp <- [if (fixedwp.dir == Ver) {word=word,dir=Hor,x=x-i,y=y} {word=word,dir=Ver,x=x,y=y-i}]
| fits wp cw]
\\ (x,y) <- letterPositions letter fixedwp]
\\ letter <|- word & i <- [0..], fixedwp <- shuffle r cw]
// Does a word fit on a crossword?
// Checks that (1) overlapping letters match, (2) no extra words are created,
// (3) words in the same direction are not connected.
fits :: WordPlacement Crossword -> Bool
fits wp cw = f wp cw
where
f :: WordPlacement Crossword -> Bool
f wp [] = True
f wp [wp`:wps]
| any (\(a,b) -> a <> b) overlap = False // (1)
| not (isEmpty overlap) && wp.dir == wp`.dir = False // (3)
| isEmpty overlap && not (isEmpty touching) = False // (2)
| otherwise = f wp wps
where
overlap
= [ (l1,l2)
\\ (l1,x1,y1) <- poss wp, (l2,x2,y2) <- poss wp`
| x1 == x2 && y1 == y2
]
touching
= [ 1 // only length is interesting
\\ (l1,x1,y1) <- poss wp, (l2,x2,y2) <- poss wp`
| (abs (x1-x2) == 1 && y1 == y2 || abs (y1-y2) == 1 && x1 == x2)
&& all (\wp -> not (isMember (l1,x1,y1) wp)) (map poss cw)
]
// Same as fits, but also checks that the crossword's size is not increased
fits` :: WordPlacement Crossword -> Bool
fits` wp=:{x,y,dir,word} cw
| x < minx cw = False
| y < miny cw = False
| dir == Hor && x + Length word - 1 > maxx cw = False
| dir == Ver && y + Length word - 1 > maxy cw = False
| otherwise = fits wp cw
|
