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