home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.cs.arizona.edu
/
ftp.cs.arizona.edu.tar
/
ftp.cs.arizona.edu
/
icon
/
historic
/
v941.tgz
/
icon.v941src.tar
/
icon.v941src
/
ipl
/
progs
/
cross.icn
< prev
next >
Wrap
Text File
|
2000-07-29
|
5KB
|
197 lines
############################################################################
#
# 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