API tools faq
paste
yingpotter

[99p]CrossWords

yingpotter
Sep 1st, 2011
535
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Haskell 11.61 KB | None | 0 0
raw download clone embed print report
  1. import Data.List
  2. import Data.Function
  3.  
  4. ----- predefined types and inputs
  5. type Matrix a = [[a]]
  6. type WList = [[Char]]
  7. type Coordinate = (Int, Int)
  8. type Site = [Coordinate]  -- from start to end
  9.  
  10. test = [0,0,1,0,1,1,1,0,1,1,0]
  11. test2 = ([[(6,3),(7,3),(8,3)],[(4,4),(5,4),(6,4)],[(1,5),(2,5),(3,5)],
  12.           [(4,2),(4,3),(4,4)],[(5,0),(5,1),(5,2)],[(6,2),(6,3),(6,4)]]
  13.          ,["MAC","SQL","WEB","GNU","NFS","XML"])
  14. test3 = [[[([(4,2),(4,3),(4,4),(4,5)],"ARES")]]
  15.         ,[[([(0,2),(1,2),(2,2),(3,2),(4,2)],"ALPHA"),([(2,0),(2,1),(2,2),(2,3),(2,4)],"POPPY")]
  16.          ,[([(0,2),(1,2),(2,2),(3,2),(4,2)],"POPPY"),([(2,0),(2,1),(2,2),(2,3),(2,4)],"ALPHA")]]]
  17. test4 = [([(4,2),(4,3),(4,4),(4,5)],"ARES")
  18.         ,([(0,2),(1,2),(2,2),(3,2),(4,2)],"ALPHA")
  19.         ,([(2,0),(2,1),(2,2),(2,3),(2,4)],"POPPY")]
  20. teststatz1 :: [(Site, [Char])]
  21. teststatz1 = [([(4,2),(4,3),(4,4),(4,5)],"ARES")]
  22.  
  23. wlist1 = ["ALPHA","ARES","POPPY"]
  24. frame1 :: Matrix Int
  25. frame1 = [[0,0,1,0,0]
  26.          ,[0,0,1,0,0]
  27.          ,[1,1,1,1,1]
  28.          ,[0,0,1,0,1]
  29.          ,[0,0,1,0,1]
  30.          ,[0,0,0,0,1]]
  31.  
  32. wlist2 = ["PROLOG","LINUX","MAC","SQL","WEB","PERL","ONLINE","GNU","NFS","XML","EMACS"]
  33. frame2 :: Matrix Int
  34. frame2 = [[1,1,1,1,1,1,0,0,1]
  35.          ,[1,0,1,0,0,1,0,0,1]
  36.          ,[1,0,1,1,1,1,1,0,1]
  37.          ,[1,0,1,0,1,0,1,1,1]
  38.          ,[0,0,1,0,1,1,1,0,1]
  39.          ,[0,1,1,1,0,0,0,0,0]]
  40.          
  41. wlist3 = ["AAL","DER","TAL","TAT","ISEL","TELL","ZANK","ZEUS","ALSEN","BLASE","EOSIN","ETTAL","KARRE","LIANE","NEEFS","NONNE","OSTEN"
  42.          ,"STUHL","TIARA","ANKARA","EGERIA","GRANAT","HIRTEN","MISERE","SAMPAN","TILSIT","WAGGON","FORTUNA","ITALIEN","MADONNA","MELASSE"
  43.          ,"REAUMUR","RIVIERA","SEKUNDE","SERBIEN","SKELETT","SKRUPEL","STETTIN","STOIKER","HANNIBAL","REGISTER","RELIGION","STANNIOL"
  44.          ,"TRUEFFEL","UNTERTAN","USAMBARA","VENDETTA","TUEBINGEN","TURKMENEN","ALLENSTEIN","ATTRAKTION","BRIEFTAUBE","TATTERSALL"
  45.          ,"PROTEKTORAT","TEMPERAMENT","KRANKENKASSE","CHRONOGRAPHIE","TRAUBENZUCKER","WALZER"]
  46. frame3 :: Matrix Int
  47. frame3 = [[1,0,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1,1,1,1,1,1]
  48.          ,[1,0,1,0,0,0,0,0,0,0,1,0,1,0,0,0,0,0,0,0,0,0,1,0,1]
  49.          ,[1,0,1,1,1,1,1,1,1,1,1,1,1,0,0,0,1,1,1,1,1,1,1,0,1]
  50.          ,[1,0,1,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0,1,0,1]
  51.          ,[1,1,1,1,1,1,0,1,1,1,1,0,1,0,1,1,1,1,1,1,0,0,1,0,1]
  52.          ,[1,0,1,0,0,0,0,0,0,0,0,0,1,0,1,0,0,0,1,0,0,0,1,0,1]
  53.          ,[1,0,1,0,1,1,1,1,1,1,0,0,1,1,1,1,1,0,1,1,1,1,1,1,1]
  54.          ,[1,0,1,0,1,0,0,1,0,0,1,1,1,0,1,0,0,0,1,0,0,0,1,0,0]
  55.          ,[1,1,1,1,1,1,1,1,0,0,1,0,0,0,1,0,0,0,1,0,1,1,1,1,1]
  56.          ,[1,0,1,0,1,0,0,1,0,0,1,0,0,0,1,0,1,0,0,0,1,0,1,0,0]
  57.          ,[1,0,0,0,1,0,0,0,0,0,1,0,1,1,1,1,1,1,1,0,1,0,1,0,0]
  58.          ,[0,1,1,1,1,1,1,0,0,0,1,0,0,0,1,0,1,0,0,1,1,1,1,1,0]
  59.          ,[0,0,1,0,0,0,0,0,1,0,1,0,0,0,0,0,1,0,0,0,1,0,0,0,1]
  60.          ,[0,0,1,0,0,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1,0,1]
  61.          ,[0,0,1,0,1,0,1,0,1,0,1,0,0,0,0,0,1,0,0,0,0,0,1,0,1]
  62.          ,[0,1,1,1,1,0,1,0,1,0,0,1,0,1,1,1,1,1,1,1,0,0,1,0,1]
  63.          ,[1,0,1,0,1,0,1,0,1,0,0,1,0,0,0,1,0,0,0,0,1,1,1,0,1]
  64.          ,[1,0,1,0,1,0,1,0,1,0,1,1,1,1,1,1,1,1,1,1,0,0,1,0,1]
  65.          ,[1,1,1,1,1,0,1,0,1,0,0,1,0,0,0,1,0,0,0,0,1,0,1,0,1]
  66.          ,[1,0,0,0,0,0,1,0,0,0,0,1,0,1,1,1,0,1,0,0,1,0,1,0,1]
  67.          ,[1,0,1,1,1,1,1,1,1,1,1,1,0,0,1,0,0,1,0,0,1,0,1,0,1]
  68.          ,[1,0,1,0,0,0,0,1,0,0,0,0,0,0,1,0,0,1,0,0,1,0,1,0,1]
  69.          ,[1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,0,1]
  70.          ,[0,0,1,0,0,0,0,1,0,0,0,0,0,0,1,0,0,1,0,0,1,0,0,0,1]
  71.          ,[1,1,1,1,1,1,1,1,0,0,0,1,1,1,1,1,1,1,0,0,1,1,1,1,1]]
  72.  
  73. wlist4 = ["BANI","HAUS","NETZ","LENA","ANKER","ARIEL","GASSE","INNEN","ORADE","SESAM","SIGEL","ANGOLA","AZETAT","EKARTE","NATTER"
  74.          ,"NENNER","NESSEL","RITTER","SOMMER","TAUNUS","TRANIG","AGENTUR","ERRATEN","ERREGER","GELEISE","HAENDEL","KAROSSE","MANAGER"
  75.          ,"OSTEREI","SIDERIT","TERRIER","ANATOMIE","ANPASSEN","BARKASSE","BEDANKEN","DEKADENT","EINLADEN","ERLASSEN","FRAGMENT"
  76.          ,"GARANTIE","KRAWATTE","MEISTERN","REAKTION","TENTAKEL","TRIANGEL","UEBERALL","VERGEBEN","AFRIKANER","BESTELLEN","BULLAUGEN"
  77.          ,"SANTANDER","VERBERGEN","ALLENSTEIN","AUSTRALIEN","BETEILIGEN","NATALITAET","OBERHAUSEN","UNTERSTAND","LEUMUND"]
  78. frame4 :: Matrix Int
  79. frame4 = [[1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1]
  80.          ,[1,0,0,0,1,0,0,0,0,1,0,0,0,1,0,0,0,0,1,0,1,0,0,0,1]
  81.          ,[1,0,1,0,1,0,1,1,1,1,1,1,1,1,1,1,0,0,1,0,1,0,0,0,1]
  82.          ,[1,1,1,1,1,1,1,0,0,1,0,0,0,1,0,1,0,1,1,1,1,1,1,1,1]
  83.          ,[1,0,1,0,1,0,1,0,0,1,0,1,0,1,0,1,0,0,1,0,1,0,1,0,1]
  84.          ,[1,0,1,0,1,0,1,0,1,1,1,1,1,1,0,1,0,0,0,0,1,0,1,0,1]
  85.          ,[1,0,1,0,1,0,1,0,0,0,0,1,0,1,1,1,1,1,1,1,1,0,1,0,0]
  86.          ,[1,0,1,0,1,1,1,1,1,1,0,1,0,1,0,1,0,1,0,0,1,0,1,0,1]
  87.          ,[1,0,1,0,0,1,0,0,1,0,0,1,0,0,0,1,0,1,0,0,0,0,1,0,1]
  88.          ,[1,1,1,1,1,1,0,0,1,1,1,1,1,1,0,1,0,1,0,1,1,1,1,1,1]
  89.          ,[0,0,0,0,0,1,0,0,1,0,0,1,0,1,0,1,0,1,0,1,0,0,1,0,1]
  90.          ,[1,1,1,1,1,1,1,0,1,0,0,1,0,1,0,1,1,1,1,1,1,1,0,0,1]
  91.          ,[1,0,0,0,0,1,0,0,1,0,0,0,0,1,0,0,0,0,0,1,0,0,0,0,1]
  92.          ,[1,0,1,0,0,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1,0,0,0,1]
  93.          ,[1,0,1,0,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,0,1]
  94.          ,[1,1,1,1,1,1,0,1,0,1,1,1,1,1,1,1,0,1,1,1,1,1,1,1,1]
  95.          ,[1,0,1,0,0,0,0,1,0,1,0,0,0,0,0,0,0,0,1,0,1,0,0,0,1]
  96.          ,[1,0,1,0,1,1,1,1,1,1,1,1,1,0,0,0,1,0,1,0,1,0,0,0,0]
  97.          ,[1,0,1,0,0,0,0,1,0,1,0,0,1,0,0,0,1,0,1,0,1,1,1,1,1]
  98.          ,[0,0,1,0,0,0,0,1,0,0,1,1,1,1,1,1,1,0,1,0,1,0,0,0,1]
  99.          ,[1,1,1,1,1,1,1,1,1,1,0,0,1,0,0,0,1,0,0,0,0,1,0,0,1]
  100.          ,[1,0,1,0,0,0,0,1,0,0,1,0,0,1,1,1,1,1,1,1,1,1,0,0,1]
  101.          ,[1,0,0,1,1,1,1,1,1,1,1,1,0,1,0,0,1,0,0,0,0,1,0,0,1]
  102.          ,[1,0,0,0,0,0,0,1,0,0,1,0,0,1,0,0,1,0,0,0,0,1,0,0,1]
  103.          ,[1,1,1,1,1,1,1,1,0,0,1,1,1,1,1,1,1,1,1,0,1,1,1,1,1]]
  104.  
  105. ----- imported from problem 28
  106. -- sortlength
  107. sortlength :: Ord a => [[a]] -> [[a]]
  108. sortlength [] = []
  109. sortlength (x:xs) = sortlength small ++ (x : sortlength large)
  110.    where small = [ y | y <- xs, length y <= length x]
  111.          large = [ y | y <- xs, length y > length x]
  112. -- sortfreq
  113. lenfreq :: [[a]] -> [a] -> Int
  114. lenfreq [] x = 0
  115. lenfreq (y:ys) x = (if length x == length y then 1 else 0) + lenfreq ys x
  116. sortfreq :: [[a]] -> [[a]]
  117. sortfreq [] = []
  118. sortfreq (x:xs) =  sortfreq small ++ (x : sortfreq large)
  119.          where small = [ y | y <- xs, lenfreq (x:xs) y < lenfreq (x:xs) x]
  120.                large = [ y | y <- xs, lenfreq (x:xs) y >= lenfreq (x:xs) x]
  121.  
  122. ----- crossword validation
  123. lenlist :: [[a]] -> [Int]
  124. lenlist wlist = map length wlist
  125. siteCnt :: [Int] -> [Int]
  126. siteCnt [] = []
  127. siteCnt row = filter ( > 1) $ map length (filter (\x -> (head x == 1)) (group row))
  128. allSeq :: Matrix Int -> [Int]
  129. allSeq frame = (concatMap siteCnt frame) ++ (concatMap siteCnt $transpose frame)
  130. validCross :: [[a]] -> Matrix Int -> Bool
  131. validCross wlist frame = (sort $lenlist wlist) == (sort $allSeq frame)
  132.  
  133. ----- convert obtain block lists from frame into co-ordinate format
  134. sitescanRow :: [Int] -> [(Int, Int)]
  135. sitescanRow row = sitescanRow' 0 (group row)
  136.                  where sitescanRow' :: Int -> [[Int]] -> [(Int, Int)]
  137.                         sitescanRow' _ [] = []
  138.                        sitescanRow' x (r:rs) = if ((head r == 1) && (length r > 1)) then (x, length r) : (sitescanRow' (x + length r) rs)
  139.                                                                                     else sitescanRow' (x + length r) rs
  140. sitescanFrame :: Matrix Int -> Int -> [Site]
  141. sitescanFrame frame direction = concat (siteform 0 (map sitescanRow frame))
  142.                                 where siteform _ [] = []
  143.                                       siteform x (r:rs) = (map siteform' r) : (siteform (x+1) rs)
  144.                                                           where siteform' (a, b)
  145.                                                                           | direction == 0  = [ (hori, x) | hori <- [a..a+b-1] ]
  146.                                                                           | direction == 1  = [ (x, verti) |verti <- [a..a+b-1] ]
  147. sitescanFull :: Matrix Int -> [Site]
  148. sitescanFull frame = sortfreq $ (sitescanFrame frame 0) ++ (sitescanFrame (transpose frame) 1)
  149.  
  150. ----- states properties
  151. noDup :: Eq a => [a] -> Bool
  152. noDup [] = True
  153. noDup (x:xs) = (x `notElem` xs) && (noDup xs)
  154. failSol :: [(Site, [Char])] -> Bool
  155. failSol statz = not (noDup [ fst x | x <- statz' ])
  156.                where statz' = nub $ concatMap (\x -> zip (fst x) (snd x)) statz
  157. validSol :: [Coordinate] -> [(Site, [Char])] -> Bool
  158. validSol plist statz = (all  (`elem` [ fst x | x <- statz' ]) plist) && (noDup [ fst x | x <- statz'])
  159.                         where statz' = nub $ concatMap (\x -> zip (fst x) (snd x)) statz
  160. waytoSol :: [Coordinate] -> [(Site, [Char])] -> Bool
  161. waytoSol plist statz = (any  (`notElem` [ fst x | x <- statz' ]) plist) && (noDup [ fst x | x <- statz'])
  162.                        where statz' = nub $ concatMap (\x -> zip (fst x) (snd x)) statz
  163.  
  164.  
  165. ----- solution permutation
  166. pairbyLen :: Matrix Int -> WList -> [([Site], WList)]
  167. pairbyLen frame wlist = zip (gbLen $ sitescanFull frame) (gbLen $ sortfreq wlist)
  168.                         where gbLen = groupBy (\x y -> length x == length y)
  169. fullPermu :: [([Site], WList)] -> [[(Site, [Char])]]
  170. fullPermu swpbl = map concat $ cartProd (map permuinLen swpbl)
  171.                   where permuinLen swp = [ zip (fst swp) temp | temp <- permutations (snd swp) ]
  172.                         cartProd :: [[a]] -> [[a]]
  173.                         cartProd [] = [[]]
  174.                         cartProd (ls:lss) = [ x:xs | x <- ls, xs <- cartProd lss ]
  175. permuSolver :: Matrix Int -> WList -> [[(Site, [Char])]]
  176. permuSolver frame wlist = filter (validSol plist) $ fullPermu (pairbyLen frame wlist)
  177.                           where plist = nub (concat $ sitescanFull frame)
  178.  
  179. ----- deterministic guess according to number of possible choices.
  180. conjuComp :: Site -> [Char] -> [(Site, [Char])] -> Bool
  181. conjuComp site word statz = and (map f (zip site word))
  182.                             where f x = (fst x `notElem` plist) || (x `elem` statz')
  183.                                  statz' = nub $ concatMap (\x -> zip (fst x) (snd x)) statz
  184.                                   plist = [ fst x | x <- statz' ]
  185. sortedBranch :: Matrix Int -> WList -> [(Site, [Char])] -> [(Site, [[Char]])]
  186. sortedBranch frame wlist statz = sortBy (compare `on` (length . snd)) [ (site, (possible site)) | site <- remainsites ]
  187.                               where remainsites = (sitescanFull frame) \\ [ fst x | x <- statz ]
  188.                                     remainwords = wlist \\ [ snd x | x <- statz ]
  189.                                     possible site = filter (\word -> (length word == length site) && (conjuComp site word statz)) remainwords
  190. detGuess :: Matrix Int -> WList -> [(Site, [Char])] -> [[(Site, [Char])]]
  191. detGuess frame wlist statz = [ statz ++ [s] | s <- pickup (sortedBranch frame wlist statz) ]
  192.                             where pickup [] = []
  193.                                   pickup templist = extract (head templist)
  194.                                                     where extract x = [ (fst x, b) | b <- snd x ]
  195. cwSolver :: Matrix Int -> WList -> [(Site, [Char])] -> [[(Site, [Char])]]
  196. cwSolver frame wlist statz
  197.    | failSol statz          = []
  198.    | validSol plist statz   = [statz]
  199.    | waytoSol plist statz   = concatMap (cwSolver frame wlist) (detGuess frame wlist statz)
  200.    where plist = nub (concat $ sitescanFull frame)
  201. cwSolve :: Matrix Int -> WList -> [[(Coordinate, Char)]]
  202. cwSolve frame wlist = map transform (cwSolver frame wlist [])
  203.                      where transform solution = nub $ concatMap (\x -> zip (fst x) (snd x)) solution
Advertisement
Add Comment
Please, Sign In to add comment
Public Pastes
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!