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
|
module Crosswords
import StdEnv, StdDebug, StdOverloadedList
import MersenneTwister
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
dictionary :== "dictionary.txt"
// 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
# (rand,w) = time 0 w
# (fillwords,w) = readFillWords w
# fillwords = sortl fillwords
# (io,w) = stdio w
# (words,io) = readWords [] io
# (ok,w) = fclose io w
# cw = makeCrossword rand words
# cw = fill rand fillwords cw
# cw = trace_n ("\nResult:\n" + toString cw) cw
= toLaTeX cw
where
readFillWords :: *World -> *([[#Char]], *World)
readFillWords w
# (ok,f,w) = fopen dictionary 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 :: Crossword -> String
toLaTeX 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] = "|* " + 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
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 <- [{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
|
