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
|
############################################################################
#
# File: cross.icn
#
# Subject: Program to display intersection of words
#
# Author: William P. Malloy
#
# Date: June 10, 1988
#
############################################################################
#
# This file is in the public domain.
#
############################################################################
#
# This program takes a list of words and tries to arrange them
# in cross-word format so that they intersect. Uppercase letters
# are mapped into lowercase letters on input. For example, the
# input
#
# and
# eggplants
# elephants
# purple
#
# produces the output
# +---------+
# | p |
# | u e |
# | r g |
# | p g |
# |elephants|
# | e l |
# | and |
# | n |
# | t |
# | s |
# +---------+
#
# Diagnostics: The program objects if the input contains a nonal-
# phabetic character.
#
# Comments: This program produces only one possible intersection
# and it does not attempt to produce the most compact result. The
# program is not very fast, either. There is a lot of room for
# improvement here. In particular, it is natural for Icon to gen-
# erate a sequence of solutions.
#
############################################################################
global fast, place, array, csave, fsave, number
procedure main()
local words, nonletter, line
nonletter := ~&letters
words := []
while line := map(read()) do
if upto(nonletter,line) then stop("input contains nonletter")
else put(words,line)
number := *words
kross(words)
end
procedure kross(words)
local one, tst, t
array := [get(words)]
t := 0
while one := get(words) do {
tst := *words
if fit(one,array,0 | 1) then
t := 0
else {
t +:= 1
put(words,one)
if t > tst then
break
}
}
if *words = 0 then Print(array)
else write(&errout,"cannot construct puzzle")
end
procedure fit(word,matrix,where)
local i, j, k, l, one, test, t, s
s := *matrix
t := *matrix[1]
every k := gen(*word) do
every i := gen(s) do
every j := gen(t) do
if matrix[i][j] == word[k] then {
# test for vertical fit
if where = 0 then {
test := 0
every l := (i - k + 1) to (i + (*word - k)) do
if tstv(matrix,i,j,l,s,t) then {
test := 1
break
}
if test = 0 then
return putvert(matrix,word,i,j,k)
}
if where = 1 then {
test := 0
every l := (j - k + 1) to (j + (*word - k)) do
if tsth(matrix,i,j,l,s,t) then {
test := 1
break
}
if test = 0 then
return puthoriz(matrix,word,i,j,k)
}
}
end
procedure tstv(matrix,i,j,l,s,t)
return ((matrix[(l ~= i) & (s >= l) & (0 < l)][0 < j-1] ~== " ") |
(matrix[(l ~= i) & (s >= l) & (0 < l)][t >= j + 1] ~== " ") |
(matrix[(i ~= l-1) & (s >= l-1) & (0 < l-1)][j] ~== " ") |
(matrix[(i ~= l + 1) & (s >= l+1) & (0 < l + 1)][j] ~== " ") |
(matrix[(l ~= i) & (s >= l) & (0 < l)][j] ~== " "))
end
procedure tsth(matrix,i,j,l,s,t)
return ((matrix[0 < i-1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
(matrix[s >= i + 1][(l ~= j) & (t >= l) & (0 < l)] ~== " ") |
(matrix[i][(j ~= l-1) & (t >= l-1) & (0 < l-1)] ~== " ") |
(matrix[i][(j ~= l + 1) & (t >= l + 1) & (0 < l + 1)] ~== " ") |
(matrix[i][(l ~= j) & (t >= l) & (0 < l)] ~== " "))
end
procedure gen(i)
local tmp, up, down
tmp := i / 2
if (i % 2) = 1 then
tmp +:= 1
suspend tmp
up := tmp
down := tmp
while (up < i) do {
suspend up +:= 1
suspend (down > 1) & (down -:= 1)
}
end
# put `word' in vertically at pos(i,j)
procedure putvert(matrix,word,i,j,k)
local hdim, vdim, up, down, l, m, n
vdim := *matrix
hdim := *matrix[1]
up := 0
down := 0
up := abs(0 > (i - k))
down := abs(0 > ((vdim - i) - (*word - k)))
every m := 1 to up do
push(matrix,repl(" ",hdim))
i +:= up
every m := 1 to down do
put(matrix,repl(" ",hdim))
every l := 1 to *word do
matrix[i + l - k][j] := word[l]
return matrix
end
# put `word' in horizontally at position i,j in matrix
procedure puthoriz(matrix,word,i,j,k)
local hdim, vdim, left, right, l, m, n
vdim := *matrix
hdim := *matrix[1]
left := 0
right := 0
left := (abs(0 > (j - k))) | 0
right := (abs(0 > ((hdim - j) - (*word - k)))) | 0
every m := 1 to left do
every l := 1 to vdim do
matrix[l] := " " || matrix[l]
j +:= left
every m := 1 to right do
every l := 1 to vdim do
matrix[l] ||:= " "
every l := 1 to *word do
matrix[i][j + l - k] := word[l]
return matrix
end
procedure Print(matrix)
local i
write("+",repl("-",*matrix[1]),"+")
every i := 1 to *matrix do
write("|",matrix[i],"|")
write("+",repl("-",*matrix[1]),"+")
end
|
