Kreuzworträtsel
Schreiben Sie eine kleine Bibliothek zum Generieren von Kreutworträtseln.
> module Cross where
> import Data.List
> data Direction = Horizontal|Vertical deriving (Eq,Show)
> changeDirection Horizontal = Vertical
> changeDirection Vertical = Horizontal
> data Grid a = Grid Int Int [Q a][[Maybe (Maybe Int,Border,a)]]
> deriving (Eq,Show)
> data Border = None|Right|Bottom|RightBottom
> deriving (Eq,Show)
> data Q a = Q Int (Int,Int) Direction String [a]
> deriving (Eq,Show)
> --instance Show a => Show (Grid a) where
> showMe (Grid _ _ ws xss) =
> show ws ++"\n\n"
> ++(concat
> $intersperse "\n"
> $map (\xs-> concat
> $map (\x->maybe "' '" (\(_,_,c)->show c) x) xs) xss)
> create :: Eq a => Int -> [(String,[a])] -> [Grid a]
> create w (x:xs)
> = map addNumbering
> $foldl (\rs y -> (selectBest$concat$map (insertWord y) rs))
> [(firstWord x (newGrid w))] xs
> ex = create 10
> [("Begrüßung","HALLO")
> ,("Wo wir alle leben","WELT")
> ,("Örtchen","LOKUS")
> ,("Heizvorrichtug","OFEN")
> ,("Zu beachten!","WICHTIG")
> ,("Ganz Großartig","SUPER")
> ,("Nahestehende doch nicht verwandr","FREUNDE")
> ,("Antikes Volk und moderne Städter","ROEMER")
> ,("Nicht unbedingt der Preis","WERT")
> ,("In einem Land lebend","LANDSLEUTE")
> ,("Kann auch schwere Arbeit sein, so zu konstruieren.","LEICHTBAU")
> ,("Limes","GRENZE")
> ,("Persönliches Fürwort","ICH")
> ,("Pronomen","IHR")
> ,("Da tappen manche falsch herum im Nebel","LEBEN")
> ,("Oder doch lieber tun?","LASSEN")
> ,("Fährt unter dem Pflaster","UBAHN")
> ,("Weiblicher Artikel","DIE")]
writeFile "ex.tex"$toLaTeX $head ex
> class ToLaTeX a where
> toLaTeX :: a -> String
> instance ToLaTeX Border where
> toLaTeX None = ""
> toLaTeX Cross.Right = "[r]"
> toLaTeX Bottom = "[b]"
> toLaTeX RightBottom = "[rb]"
> instance Show a => ToLaTeX (Grid a) where
> toLaTeX (Grid w h ws gss) =
> "\\begin{Puzzle}{"++show w++"}{"++show h++"}% \n"
> ++latexGrid gss++"\\end{Puzzle}\n\n"
> ++"\\paragraph*{Horizontal}~\\\\\n"
> ++(concat $map showQuestion hors)
> ++"\\paragraph*{Vertikal}~\\\\\n"
> ++(concat $map showQuestion vers)
> where
> latexGrid = concat.(map latexRow)
> latexRow rs = "|"++
> (intercalate "|"
> $map (maybe "*"
> (\(a,b,c) -> ((maybe "[]" (\x->"["++show x++"]") a)
> ++toLaTeX b++[(show c!!1)]))) rs)
> ++"|.\\\\\n"
>
> (ver,hor) = partition (\(Q _ _ d _ _)->d==Vertical) ws
> hors = sortOn (\(Q nr _ _ _ _)->nr) hor
> vers = sortOn (\(Q nr _ _ _ _)->nr) ver
> showQuestion (Q nr _ _ q _)
> = "{\\bfseries "++show nr++": }"++q++"\\\\\n"
> replaceAt :: (Eq t1, Num t1) => t1 -> t2 -> [t2] -> [t2]
> replaceAt i y xs = []
> clusterBy :: (t -> t -> Bool) -> [t] -> [[t]]
> clusterBy eq xs = []
*Cross> clusterBy (==) "mississippi"
["m","iiii","ssss","pp"]
Cross> groupBy (==) "mississippi"
["m","i","ss","i","ss","i","pp","i"]
> newGrid :: Int -> Grid a
> newGrid _ = Grid 0 0 [][]
> firstWord :: (String,[a]) -> Grid a -> Grid a
> firstWord _ g = g
*Cross> firstWord ("Frage","ANTWORT") $newGrid 10
[Q 0 (1,5) Horizontal "Frage" "ANTWORT"]
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' ''A''N''T''W''O''R''T'' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
' '' '' '' '' '' '' '' '' '' '
> transposeGrid :: Grid a -> Grid a
> transposeGrid g = g
> insertWordInLine
> :: (Eq a1, Eq a2, Num a3) =>
> [a2]
> -> [Maybe (Maybe a1, Border, a2)]
> -> [(a3, [Maybe (Maybe a1, Border, a2)])]
> insertWordInLine _ _ = []
*Cross> insertWordInLine "lok" [Just (Nothing,None,'h'),Just (Nothing,None,'a'
),Just (Nothing,None,'l'),Just (Nothing,None,'l'),Just (Nothing,None,'o'),Noth
ing,Nothing,Nothing,Nothing]
[(3,[Just (Nothing,None,'h'),Just (Nothing,None,'a'),Just (Nothing,None,'l'),J
ust (Nothing,None,'l'),Just (Nothing,None,'o'),Just (Nothing,None,'k'),Nothing
,Nothing,Nothing]),(5,[Just (Nothing,None,'h'),Just (Nothing,None,'a'),Just (N
othing,None,'l'),Just (Nothing,None,'l'),Just (Nothing,None,'o'),Just (Nothing
,None,'l'),Just (Nothing,None,'o'),Just (Nothing,None,'k'),Nothing]),(6,[Just
(Nothing,None,'h'),Just (Nothing,None,'a'),Just (Nothing,None,'l'),Just (Nothi
ng,None,'l'),Just (Nothing,None,'o'),Nothing,Just (Nothing,None,'l'),Just (Not
hing,None,'o'),Just (Nothing,None,'k')])]
*Cross> map (map (maybe ' ' (\(_,_,c)->c)))$map snd line
["hallok ","hallolok ","hallo lok"]
> insertWord :: Eq a => (String, [a]) -> Grid a -> [Grid a]
> insertWord ws g = filter (not.hasOverlappings)
> (insertWordHorizontal ws g
> ++(map transposeGrid$insertWordHorizontal ws$transposeGrid g))
> insertWordHorizontal :: Eq a =>
> (String, [a]) -> Grid a -> [Grid a]
> insertWordHorizontal :: _ g = [g]
> hasOverlappings :: Grid a -> Bool
> hasOverlappings _ = False
> selectBest :: Eq a => [Grid a] -> [Grid a]
> selectBest gs = = gs
> addNumbering :: Grid a -> Grid a
lhs
You are not logged in and therefore you cannot submit a solution.