Initial commit

1 files changed, 200 insertions, 0 deletions

diff --git a/Crosswords.icl b/Crosswords.icl
new file mode 100644
index 0000000..7489545
--- /dev/null
+++ b/Crosswords.icl
@@ -0,0 +1,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 :== "dict-3-6.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