{- encoding=utf-8
author: Aleš Novák (alesak@jikos.cz)
	
Program na tvorbu křížovek
--------------------------

Tento program generuje křížovky. Nejprve si položme otázku, co to
vlastně je křížovka? Na zadních stránkách novin bývá to, čemu se 
říká "Švédská křížovka", pokud hledáme na webu heslo "crossword", 
nejvíc odkazů jsem (alespoň já) dostával na něco, co znám jako 
"osmisměrka", tj. matice NxN znaků, ve které se má najít množina
slov, která je vypsaná pod ní. Druhým nejrozšířenějším typem 
byla "mřížová" křížovka, kde jsou mezi slovy mezery.

Já jsem se pokusil napsat program, který hledá první typ křížovek.
Algoritmus jsem zvolil triviální - brutální backtracking. Brát slova 
a umisťovat je nahodile do mřížky je příliš brutální, je třeba
postupovat směrem od "největší shody", tj. aby pozice, kterou chci 
zaplnit, měla největší shodu s již zaplněnými pozicemi.

Jako datovou strukturu pro uložení slovníku jsem zvolil trii. To do
předchozího algoritmu klade navíc tu podmínku, že hledané slovo by
mělo mít shodu co nejvíc u prefixu.

Problém byl ve slovníku - našel jsem cca 250k slov pro češtinu a
stejně tak pro angličtinu, nakonec jsem, abych zvýšil úspěšnost hledání
je spojil dohromady. Nemám žádný převod na jejich sémantickou hodnotu
(tj. něco, co by se dalo vepsat do stran křížovky).

Nehledám slova kratší než 3. Autoři křížovek stejně využívají podvodů
jako např.: staročeská předložka, iniciály herce Oldřicha Nového, zkratka
židozednářsko-bratrské jednoty ...

Algoritmus vypadá následovně:

- načte křížovku - tj. obdélníkovou matrici, ve které mohou být 
  vepsána slova (tajenka)

- z křížovky vybere "seznam směrů", tj. pozic, kam budou pasovat slova.
  pro efektivitu backtrackingu je pořadí v tomto seznamu dost důležité 
  (inteligentní algoritmus jsem ale nevymyslel, je však jasné, že se musí
  střídat směry, a např. postup LT do BR rohu je ideální)
  
- načte slovník - roztřídí slova dle velikosti, pak projde stromy
  ještě jednou a přiřadí slovům jednoznačná id

- opakuje tuto funkci:
    vezme první "pozici" ze seznamu "směrů"
    načte obsah polí křížovky na této "pozici" (výsledkem je řetězec K)
    udělá seznam slov ze slovníku, které na tuto pozici pasují, tj.:
      * mají stejnou délku jako K
      * na pozicích, kde má K mezery, mají cokoliv
      * na pozicích, kde má K nemezeru, mají stejný znak
    (tvorba seznamu může trvat dlouho, ale je lazy)
    pro každé slovo ze seznamu, které zároveň není v seznamu použitých slov,
    ho zkusí umístit do křížovky, umístí ho do seznamu použitých slov,
    a zavolá sama sebe na zbytek "seznamu směrů". Pokud se něco 
    vrátí - končíme.
    Pokud ne, pokračuji dalším slovem ze seznamu "pasujících" slov.

    Pokud v něm už žádné slovo není, vracím se s neúspěchem.


Realizace:

Algoritmus jsem si nejprve nastřelil v C. Sice nakonec v algoritmech
v obou jazycích nemám shodu 1:1, ale bylo zajímavé porovnat výkonnost.
Pro jednoduchost jsem si v C použil "bucketovou" strukturu trie, kdy 
každá struktura obsahuje pole pointerů v celém rozsahu abecedy,
Haskell používá inteligentnější (a pomalejší) mapu.

Program v Haskellu využívá unboxed array pro udržování stavu křížovky.
Důležité struktury jsou:

Crossword - popisuje křížovku: [width] [height] [pole charů]
Direction - popisuje pozici, tj. pozici, délku, orientaci sekvence
  znaků křížovky. Každé "Direction" by mělo odpovídat jedno slovo.
Trie - popisuje strukturu trie - může být kořen, trie uprostřed a 
  výstupní - tam kde končí nějaké slovo

Výkon:

Žádných hvězdných výkonů tento algoritmus nedosahuje. Na testovacím 
stroji (Intel(R) Core(TM) i3-2367M CPU @ 1.40GHz; 4GB RAM;
64-bit Linux) vypadaly časy takto:

# # # # # # # # |
# b l b o s t i |
# a i a # a e g |
# a b a # a d a |
# l e s # b a d |
real	0m5.824s
user	0m5.477s
sys	0m0.345s

# # # # # # # # # # # # # |
# p a b l o # n a b b e d |
# a v a i l # e c a d s # |
# m r t v y # s h r i # b |
# p i t i m # p a d #   a |
# a l a a p # i t # a b a |
real	1m1.926s
user	1m1.466s
sys	0m0.441s

    #   #   #   #   # |
    k   i   b   r   s |
# d a l a i _ l a m a |
    b   m   m   b   b |
# z a o b l o v a n a |
    r   i   v   t   h |
# s e i s m i c i t a |
    t   t   e   n   n |
# s u b s y s t e m s |
real	0m12.520s
user	0m11.773s
sys	0m0.743s

# # # # # # # # |
# c a b a j k a |
# u v u l a # w |
# b a b a # s a |
# a d a # s a i |
# t a l i p a t |
# u v i v a n i |
# r a n a # e n |
# e t e n # n g |
real	3m50.467s
user	3m49.114s
sys	0m1.287s


-}

import Prelude hiding (Right)
import qualified Data.Map as Map
import System.IO
import Control.Monad 
import Data.Array.Unboxed
import Data.Maybe
import Data.List
-- import Debug.Trace

-- | Mapa znak -> trie (v každé struktuře trie)
type Branches = Map.Map Char Trie

-- | Struktura definuje trie - 'Root' je kořenová, 'Trie' je někde uprostřed, 
--   'Output' je výstupní (tj. končí v ní slovo, není nutně listová)
data Trie = Root Int Branches
	| Trie Int Branches 
	| Output Int Branches String
	deriving (Show)

-- | Struktura definuje seznam trií podle délky slov (výrazně to
--   šetří čas a mírně plýtvá místem
data Tries = Tries (Map.Map Int Trie)

-- | Struktura popisuje orientaci, pozici a délku slova v křížovce.
--   Dělat to teď, neudělám to jako dvě struktury...
data Direction = 
--      |    ori. x   y   délka
	Down Int Int Int
	| Right Int Int Int

-- | Struktura křížovky - rozměry a pole se znaky (mezera je prázdný
-- znak, @ je plný znak, # je plný znak, za kterým/pod kterým může být slovo
data Crossword = Crossword Int Int (Array (Int, Int) Char)

-- | Funkce na vykreslení křížovky
instance Show Crossword 
	where show (Crossword m n a) = 
		concat [
			concat [
				concat [ (a ! (x,y)) : " " | x <- [1..m]], "|\n"
			] | y <- [1..n]]

-- | Rovnost trií lze posoudit jen podle 'id'
instance Eq Trie where
	(Output id1 _ _) == (Output id2 _ _) = (id1 == id2)
	_== _ = False

instance Show Direction
	where 	show (Right x y l) = concat [ "[", show x, ",", show y, "]-> ", show l, "\n"]
		show (Down x y l) = concat [ "[", show x, ",", show y, "]-v ", show l, "\n"]

-- | Dostane seznam slov a udělá z nich mapu trií (mapa podle délky slov)
mkTries :: [String] -> Tries
mkTries lst = foldl mkWordTries (Tries Map.empty) lst

mkWordTries :: Tries -> String -> Tries
mkWordTries (Tries tries) s = Tries (Map.insert l trieU tries)
	where 
		trie = if (Map.member l tries) then tries Map.! l else mkRoot
		trieU = mkWord trie s
		l = length s	

-- | Vrátí prázdnou křížovku zadaných rozměrů (prázdná == vyplněná mezerami)
mkCrossword :: Int -> Int -> Crossword
mkCrossword m n = Crossword m n (array ((1,1),(m,n))([((x,y),' ') | x <- [1..m], y <- [1..n]]))

-- | Vrátí souřadnice znaku zadaného pořadí (jedničkou počínaje)
--   v zadaném směru.
dir :: Direction -> Int -> (Int, Int)
dir (Down x y len) step = (x, y + step - 1)
dir (Right x y len) step = (x + step - 1, y)

-- | Vrátí délku zadaného 'směru'
directionLength :: Direction -> Int
directionLength (Down _ _ l) = l
directionLength (Right _ _ l) = l

-- | Vytáhne obsah křížovky v zadaném 'směru'
crossGetWord :: Crossword -> Direction -> String
crossGetWord (Crossword xs ys a) d = [ a ! (dir d i) | i <- [1..(directionLength d)]]

-- | Vrátí křížovku v zadaném 'směru' vyplněnou zadaným slovem
crossSetWord :: Crossword -> Direction -> String -> Crossword
crossSetWord (Crossword xs ys a) d w = Crossword xs ys (a // [((dir d i), w !! (i - 1)) | i <- [1..(directionLength d)]])

-- | Hlavní funkce (verze pro univerzální trii)
fill :: Crossword -> Trie -> [Trie] -> [Direction] -> Maybe Crossword
fill c  _ _ [] = Just c
fill c tr used (d:fx) = tryEach wo
	where
		-- ew je aktuální obsah křížovky na pozici, kterou mám vyplnit
		ew = crossGetWord c d
		-- wo je seznam všech slov, pasujících do daného 
		wo = findMatchWords tr 0 ew
		setWord w = crossSetWord c d (getWord w)
		tryWord word = fill (setWord word) tr (word:used) fx
		tryEach (word:sfx) = if (((elem word used) == False) && isJust (tryWord word)) then tryWord word else tryEach sfx
		tryEach [] = Nothing

-- | Hlavní funkce (verze pro seznam trií)
fill' :: Crossword -> Tries -> [Trie] -> [Direction] -> Maybe Crossword
fill' c  _ _ [] = Just c
--fill' c tr used (d:fx) = trace (concat [show c, show d])  (tryEach wo 0)
fill' c tr used (d:fx) = (tryEach wo 0)
	where
		ew = crossGetWord c d
		wo = findTriesMatchWords tr 0 ew
		setWord w = crossSetWord c d (getWord w)
		tryWord word = fill' (setWord word) tr (word:used) fx
		tryEach (word:sfx) ij = (if (((elem word used) == False) && isJust (tryWord word)) then tryWord word else tryEach sfx (ij + 1))
		--tryEach (word:sfx) ij = trace (concat [show d, ew, "(", show ij, ")--->>", show (getWord word)]) (if (((elem word used) == False) && isJust (tryWord word)) then tryWord word else tryEach sfx (ij + 1))
		tryEach [] _ = Nothing
		--tryEach [] _ = trace "EOL" Nothing

-- | Vytvoří prázdnou trii
mkRoot = Root 0 Map.empty


-- | Do dané mapy větví vloží zadané slovo
--   [mapa větví] [celé slovo] [zbývající suffix slova] [výsledná mapa větví]
mkWordBr :: Branches -> String -> String -> Branches
mkWordBr b (pfx:sfx) wo = 
	if (Map.member pfx b) 
	-- na daný znak už existuje větev - takže stačí vložit suffix slova
	-- do této větve
	then (Map.insert pfx (mkWord2 (b Map.! pfx) sfx wo) b)
	else (mkWordRun b (pfx:sfx) wo)
	where
		mkWord2 :: Trie -> String -> String -> Trie 
		mkWord2 (Trie id b) w wo = Trie id (mkWordBr b w wo)
		mkWord2 (Output id b sl) w wo = Output id (mkWordBr b w wo) sl

		mkWordRun :: Branches -> String -> String -> Branches 
		mkWordRun b (pfx:[]) wo = Map.insert pfx (Output 0 Map.empty wo) b
		mkWordRun b (pfx:sfx) wo = Map.insert pfx (Trie 0 (mkWordRun Map.empty sfx wo) ) b

mkWord :: Trie -> String -> Trie 
mkWord (Root id b) w = Root id (mkWordBr b w w)

-- | Z daného seznamu slov vytvoří trii
mkTrie :: [String] -> Trie
mkTrie lst =
	foldl (mkWord) (mkRoot) lst

-- | Vrátí větve dané struktury trie
getBranches :: Trie -> Branches
getBranches (Root _ br) = br
getBranches (Trie _ br) = br
getBranches (Output _ br _) = br

-- | Vrátí id dané struktury trie
getId :: Trie -> Int
getId (Root id _) = id
getId (Trie id _) = id
getId (Output id _ _) = id

-- | Vrátí řetězec, který odpovídá zadanému výstupnímu uzlu trie
getWord :: Trie -> String
getWord (Output _ _ w) = w

-- | Prochází trii, vytváří kopii a přitom položkám přiřazuje id
mkCopyId :: Trie -> Int -> (Trie, Int)
mkCopyId teri mid = 
	case teri of 
	(Root id br) -> (Root (mid + 1) nbr, did)
	(Trie id br) -> (Trie (mid + 1) nbr, did)
	(Output id br word) -> (Output (mid + 1) nbr word, did)
	where
		oldlist = Map.toList (getBranches teri)
		nbr = Map.fromList newlist
		(newlist,did) = gennew oldlist (mid + 1)
			where 
				gennew :: [(Char, Trie)] -> Int -> ([(Char, Trie)], Int)
				gennew ((kchar, trie):rest) gid = ((kchar,fst gepr):fst gegi, snd gegi)
					where
					gepr = mkCopyId trie gid
					gegi = gennew rest (snd gepr)
				gennew [] id = ([], id)

-- | Prochazí seznam trií a každ 
mkTriesCopyId :: Tries -> Int -> (Tries, Int)
mkTriesCopyId (Tries tries) id = (Tries ntries, nid)
	where
		(ntries, nid) = Map.foldlWithKey step (Map.empty, id) tries 
		step (ntri, id) key trie = (Map.insert key (fst copy) ntri, snd copy)
			where copy = mkCopyId trie id

-- | V zadané trii zkusí najít zadané slovo, vrátí slovo nebo Nothing
findWord :: Trie -> String -> Maybe Trie
findWord tr (pfx:sfx) = 
	if Map.member pfx (getBranches tr) then findWord ((getBranches tr) Map.! pfx) sfx else Nothing

findWord tr [] = 
	case tr of 
	-- našel jsem slovo - pokud stojím ve výstupním uzlu, mám nalezeno,
	(Output _ _ _) -> Just tr
	-- jinak nic
	otherwise -> Nothing

-- | Načte ze souboru zadaného jména řádky a vrátí je jako seznam
getLines = liftM lines . readFile

getMapToIds :: Trie -> Map.Map Int String
getMapToIds trie = getMapToIds' trie Map.empty
	where
		getMapToIds' :: Trie -> Map.Map Int String -> Map.Map Int String
		getMapToIds' trie map = case trie of 
			(Root id br) -> appendBranches map br
			(Trie id br) -> appendBranches map br
			(Output id br wo) -> Map.insert id wo (appendBranches map br)
			where 
				appendBranches map br = gogo map (Map.elems br)
				gogo map (hed:tail) = gogo (getMapToIds' hed map) tail
				gogo map [] = map
			

findMatchWord :: Trie -> Int -> String -> Maybe Trie
findMatchWord trie id (' ':fx) = findFirst [ t | t <- Map.elems (getBranches trie), (getId t) > id ] id fx
	where
		findFirst (l:st) id fx = 
			if isJust (findMatchWord l id fx) 
			then findMatchWord l id fx 
			else findFirst st id fx
		findFirst [] _ _ = Nothing

findMatchWord trie id (p:fx) = 
	if Map.member p bran 
	then findMatchWord (bran Map.! p) id fx 
	else Nothing
	where
		bran = getBranches trie


findMatchWord a@(Output oid _ wo) id [] = if oid /= id then Just a else Nothing
findMatchWord x _ [] = Nothing

-- | Funkce 'findMatchWords' vrátí ze zadané trie seznam všech slov s 
--   id > parametr, která odpovídají zadanému vzoru.
findMatchWords :: Trie -> Int -> String -> [Trie]
findMatchWords tr id w = case fw of 
	(Just x)  -> x : findMatchWords tr (getId x) w
	Nothing -> []
	where 
		fw = findMatchWord tr id w  :: Maybe Trie

-- | Funkce 'findTriesMatchWord' vrátí ze zadaného seznamu trií slovo 
--   odpovídající vzoru s id > parametr
findTriesMatchWord :: Tries -> Int -> String -> Maybe Trie
findTriesMatchWord tries@(Tries mp) id word = findMatchWord trie id word
	where
		trie = if Map.member (l) mp then mp Map.! l else mkRoot
		l = length word

-- | 'findTriesMatchWords' vrátí ze zadaného seznamu trií seznam všech 
--    slov odpovídajících zadanému vzoru.
findTriesMatchWords :: Tries -> Int -> String -> [Trie]
findTriesMatchWords tries@(Tries mp) id word = findMatchWords trie id word
	where
		trie = if Map.member (l) mp then mp Map.! l else mkRoot
		l = length word

-- | Vrátí řetězcovou reprezentaci seznamu trií (bere v potaz jen 'Output')
showWords :: [Trie] -> String
showWords [] = ""
showWords ((Output _ _ w):fx) = concat [ w,"\n", showWords fx]

-- | Načte křížovku ze zadaného seznamu řádku (pravděpodobně ze souboru)
--   výška = počet řádků, šířka = délka nejdelšího řetězce
mkCrosswordFrom :: [String] -> Crossword
mkCrosswordFrom pl = Crossword width height ncwa
	where
		width = maximum [length p | p <- pl ]
		height = length pl
		(Crossword _ _ cwa) = mkCrossword width height
		ncwa = cwa // [((x,y),
			-- aby to neprudilo - když řádek není dost dlouhý 
			-- (i.e. soubor není "čtvercový"), předpokládám mezeru
			if length (pl !! (y - 1)) < (x ) 
			then ' ' 
			else pl !! (y-1) !! (x-1)) | x <- [1..width], y <- [1..height]]
		
-- | K zadanému poli (čekám, že na něm je '#') zkusí najít dost velké (>=3) volné místo, kam by se 
--   dalo vrznout slovo.
getDirection :: (Array (Int, Int) Char) -> Int -> Int -> Int -> Int -> [Direction]
getDirection ar width height x y = getDown (getRight [])
	where
		getRight l = get (Right x y 0) l 
		getDown l = get (Down x y 0) l
		get d l = if misi < 3 then l else (dirCopy d misi):l
			where
			     	-- najdu nejmenší počet kroků (v zadaném směru), který z pole musím udělat, abych
				-- narazil na okraj křížovky / na '#' nebo '@' pole				       
				misi = minimum [ l | l <- [2..(width + height)], outOfBounds (dir d l) || (ar ! (dir d l)) == '#' || (ar ! (dir d l)) == '@'] - 2
				-- testuje překročení křížovky (i doleva nahoru, což nenastane)
				outOfBounds (lx, ly) = lx > width || ly > height || lx < 1 || ly < 1
				-- kopíruje direction (se zadanou délkou)
				dirCopy (Right x y _) l = (Right (x + 1) y l)
				dirCopy (Down x y _) l = (Down x (y + 1) l)
				{-
				misi = minimum [(case d of (Right _ _ _) -> x - width case d of (Down _ _ _) -> y - height),
					maximum [st | st <- [1.. ]] ]
				-}
		
-- | Zkusí vygenerovat seznam "směrů" k zadané křížovce
mkDlistFrom :: Crossword -> [Direction]
mkDlistFrom (Crossword width height cwa) = dirStridej $ sortBy srt ncwa
	where
		ncwa = concat [ getDirection cwa width height x y | x <- [1..width], y <- [1..height], cwa ! (x,y) == '#']
		-- třídící funkce
		srt a b = cmp (get a) (get b)
		-- cmp (x1, y1) (x2, y2) = cmpd (compare x1 x2) (compare y1 y2)
		cmp (x1, y1) (x2, y2) = compare (x1^2 + y1^2) (x2^2 + y2^2)--cmpd (compare x1 x2) (compare y1 y2)
		-- třídím nejdřív podle y, pak x, díky debilní struktuře 'Direction' musím takhle zdlouhavě
		cmpd xd yd = if yd /= EQ then yd else xd
		get (Right x y l) = (x, y)
		get (Down x y l) = (x, y)

dirStridej :: [Direction] -> [Direction]
dirStridej d = stridej [p | p@(Right _ _ _) <- d] [p | p@(Down _ _ _) <- d]
	where
		stridej (d1:fx1) (d2:fx2) = d1:d2:stridej fx1 fx2
		stridej (d1:fx1) [] = d1:fx1
		stridej [] (d1:fx1) = d1:fx1
		stridej [] [] = []
{-
main :: IO ()
main = do
	--list <- getLines "words2.txt" 
	--list <- getLines "slovnik.txt"
	list <- getLines "czen.txt"
	cwplan <- getLines "cw4.txt"

	let tries = mkTries list

	let cw = crossSetWord (mkCrossword 10 10) (Right 1 8 5) "zamilovany"
	let cw = mkCrosswordFrom cwplan
	let uw = 10
	let dlist = [(Right 1 1 uw), (Down 1 1 uw), (Right 1 2 uw), (Down 2 1 8), (Right 1 3 8), (Down 3 1 8), (Right 1 4 8), (Down 4 1 8), (Right 1 5 8) --, (Down 5 1 8), (Right 1 6 8), (Down 6 1 8) -- , (Right 1 7 8), (Down 7 1 8)
		--, (Right 1 8 8), (Down 8 1 8)
		]
	let dlist = [(Right 1 2 uw), (Down 2 1 uw), (Down 3 2 (uw-2)), (Right 1 4 uw), (Down 4 1 uw), (Right 2 5 (uw-2)), (Down 5 2 (uw-2)), (Right 1 6 uw), (Down 6 1 uw), (Right 1 8 uw), (Down 8 1 uw)]

	
	let dlist = mkDlistFrom cw
	-- let dlist = [(Right 2 2 7), (Down 2 2 5), (Right 2 3 6), (Down 3 2 5), (Right 2 4 5), (Down 4 2 5), (Right 2 5 4), (Down 5 2 4), (Down 6 2 3), (Down 7 2 2), (Down 10 2 5), (Right 8 4 3), (Down 9 3 4), (Right 7 5 4), (Down 8 4 3), (Right 6 6 5)]
	let v = show dlist
	putStrLn v
	let triesid = fst (mkTriesCopyId tries 1)
	let (Tries tls) = triesid
	putStrLn (show (getId (tls Map.! 7)))
	putStrLn (show (length (findTriesMatchWords triesid 0 "abc")))
	let new = fill' cw triesid [] dlist
	let v = if isNothing new then "--" else show (let (Just a) = new in a)
	--let new = fill cw tri [] dlist
	--let v = ""
	putStrLn v

	return ()
-}
main :: IO ()
main = do
	--list <- getLines "words2.txt" 
	--list <- getLines "slovnik.txt"
	
	-- načtení slovníku
	list <- getLines "czen.txt"
	-- načtení křížovky
	cwplan <- getLines "cw4.txt"

	-- postavím mapu trií ze slovníku
	let tries = mkTries list

	-- rozparsuju křížovku
	let cw = mkCrosswordFrom cwplan
	
	-- určím seznam slov, která budu vyplňovat
	let dlist = mkDlistFrom cw
	
	putStrLn $ show dlist

	-- přiřadím slovům id 
	let triesid = fst $ mkTriesCopyId tries 1

	-- spustím hlavní funkci backtrackingu
	let new = fill' cw triesid [] dlist

	let v = if isNothing new then "-- crossword cannot be created --" else show (let (Just a) = new in a)

	putStrLn v

	return ()