-- Springer.hs type Pos = (Int,Int) sucs :: Int -> Pos -> [Pos] sucs n (x,y) = [p | p@(a,b) <- [(x+1,y+2),(x+1,y-2),(x-1,y+2),(x-1,y-2), (x+2,y+1),(x+2,y-1),(x-2,y+1),(x-2,y-1)], 0 < a, a <= n, 0 < b, b <= n] nextPoss :: Int -> Pos -> [Pos] -> [Pos] nextPoss n p visited = sort (f p) where f = filter (`notElem` visited) . sucs n r p q = length (f p) < length (f q) sort (x:s) = sort [y | y <- s, r y x]++x:sort [y | y <- s, not (r x y)] sort s = s import Graphics.SOE -- Springer-Wege: iterative statische Version path :: Int -> Pos -> Maybe [Pos] path n p = pathloop (n*n) [p] [nextPoss n p []] where pathloop :: Int -> [Pos] -> [[Pos]] -> Maybe [Pos] pathloop 1 ps _ = Just (reverse ps) pathloop k ps ((p:qs):pss) | p `elem` ps = pathloop k ps qss | True = pathloop (k-1) (p:ps) (nextPoss n p ps:qss) where qss = qs:pss pathloop k (_:ps) (_:pss) = pathloop (k+1) ps pss pathloop _ _ _ = Nothing {- path 6 (1,1) returns Just [(1,1), (2,3), (1,5), (3,6), (5,5), (6,3), (5,1), (3,2), (1,3), (2,1), (4,2), (6,1), (5,3), (6,5), (4,6), (3,4), (2,6), (1,4), (2,2), (4,1), (6,2), (5,4), (6,6), (4,5), (3,3), (2,5), (4,4), (5,6), (6,4), (5,2), (3,1), (1,2), (2,4), (1,6), (3,5), (4,3)] -} -- Springer-Wege: wechselseitig-rekursive statische Version pathR :: Int -> Pos -> Maybe [Pos] pathR n p = pathrec (n*n) [p] where pathrec :: Int -> [Pos] -> Maybe [Pos] pathrec 1 ps = Just (reverse ps) pathrec k ps@(p:_) = try (k-1) [q:ps | q <- nextPoss n p ps] try :: Int -> [[Pos]] -> Maybe [Pos] try k (ps:pss) = case pathrec k ps of ps@(Just _) -> ps _ -> try k pss try _ _ = Nothing -- Springer-Wege: iterative dynamische Version pathD :: Window -> Int -> Pos -> IO () pathD w n p = do drawPt w Cyan p drawNo w Blue p 1 pathloopD (n*n) [p] [nextPoss n p []] where pathloopD :: Int -> [Pos] -> [[Pos]] -> IO () pathloopD 1 ps _ = do drawPt w Yellow p drawNo w Blue p (n*n) where p = head ps pathloopD k ps ((p:qs):pss) | p `elem` ps = do drawLn w Black p (head qs) drawPt w Green p getLBP w pathloopD k ps qss | True = do drawLn w Red p (head ps) drawNo w Blue p (n*n-k+2) getLBP w pathloopD (k-1) (p:ps) (nextPoss n p ps:qss) where qss = qs:pss pathloopD k (p:ps) (_:pss) = do drawLn w Black p (head ps) drawPt w Green p getLBP w pathloopD (k+1) ps pss pathloopD _ _ _ = return () -- Springer-Kreise: iterative statische Version -- search f s searches for the first element of s satisfying f and returns its -- position within s. search f s = g s 0 where g (x:s) i = if f x then Just i else g s (i+1) g _ _ = Nothing nextPosst :: Int -> Pos -> [Pos] -> Pos -> [Pos] nextPosst n p visited init | init `elem` sucsp && null (f init) = [] -- (a) | init `notElem` sucsp = case search singlesuc fp of Just i -> case search singlesuc (take i fp++drop (i+1) fp) of Just _ -> [] -- (c) _ -> [fp!!i] -- (b) _ -> sort fp -- (d) | True = sort fp -- (d) where sucsp = sucs n p f = filter (`notElem` visited) . sucs n singlesuc p = length (f p) == 1 r p q = length (f p) < length (f q) sort (x:s) = sort [y | y <- s, r y x]++x:sort [y | y <- s,not (r x y)] sort s = s fp = f p -- (a)-(d) implementieren die gleichnamigen Regeln aus Rabhi, Lapalme, -- Algorithms, Addison-Wesley 1999, Exercise 8.7. tour :: Int -> Pos -> Maybe [Pos] tour n p = tourloop (n*n) [p] [nextPoss n p []] where tourloop :: Int -> [Pos] -> [[Pos]] -> Maybe [Pos] tourloop 1 ps@(p:qs) (_:pss) | q `elem` sucs n p = Just (reverse (q:ps)) | True = tourloop 2 qs pss where q = last ps -- last ps = init tourloop k ps ((p:qs):pss) | p `elem` ps = tourloop k ps qss | True = tourloop (k-1) (p:ps) (nextPosst n p ps (last ps):qss) where qss = qs:pss -- last ps = init tourloop k (_:ps) (_:pss) = tourloop (k+1) ps pss tourloop _ _ _ = Nothing {- tour 8 (1,1) returns Just [(1,1), (2,3), (3,1), (1,2), (2,4), (1,6), (2,8), (4,7), (6,8), (8,7), (7,5), (8,3), (7,1), (5,2), (7,3), (8,1), (6,2), (4,1), (2,2), (1,4), (2,6), (1,8), (3,7), (5,8), (7,7), (8,5), (6,6), (7,8), (8,6), (7,4), (8,2), (6,1), (4,2), (2,1), (3,3), (5,4), (3,5), (4,3), (5,1), (6,3), (8,4), (7,2), (6,4), (5,6), (4,8), (2,7), (1,5), (3,6), (1,7), (3,8), (5,7), (4,5), (5,3), (6,5), (4,6), (6,7), (8,8), (7,6), (5,5), (3,4), (1,3), (2,5), (4,4), (3,2)] -} -- Springer-Kreise: iterative dynamische Version tourD :: Window -> Int -> Pos -> IO () tourD w n p = do drawPt w Cyan p drawNo w Blue p 1 tourloopD (n*n) [p] [nextPoss n p []] where tourloopD :: Int -> [Pos] -> [[Pos]] -> IO () tourloopD 1 ps@(p:qs) (_:pss) | q `elem` sucs n p = do drawLn w Red p q drawPt w Yellow p drawNo w Blue p (n*n) | True = do drawLn w Black p (head qs) drawPt w Green p getLBP w tourloopD 2 qs pss where q = last ps tourloopD k ps ((p:qs):pss) | p `elem` ps = do drawLn w Black p (head qs) drawPt w Green p getLBP w tourloopD k ps qss | True = do drawLn w Red p (head ps) drawNo w Blue p (n*n-k+2) getLBP w tourloopD (k-1) (p:ps) (nextPosst n p ps (last ps):qss) where qss = qs:pss tourloopD k (p:ps) (_:pss) = do drawLn w Black p (head ps) drawPt w Green p getLBP w tourloopD (k+1) ps pss tourloopD _ _ _ = return () -- Graphische Ausgabe (nur mit hugs98) realPos (x,y) = (x*50,y*50) realTextPos (x,y) = (x*50-7,y*50-6) draw :: Window -> Color -> Graphic -> IO () draw w color = drawInWindow w . withColor color drawLn :: Window -> Color -> Pos -> Pos -> IO () drawLn w color p q = draw w color (line (realPos p) (realPos q)) drawPt :: Window -> Color -> Pos -> IO () drawPt w color p = draw w color (ellipse (x+12,y+12) (x-12,y-12)) where (x,y) = realPos p drawNo :: Window -> Color -> Pos -> Int -> IO () drawNo w color p n = draw w color (text (realTextPos p) (show n)) -- statische Ausgabe: drawPath path/pathR/tour size start drawPath :: (Int -> Pos -> Maybe [Pos]) -> Int -> Pos -> IO () drawPath path n p = case path n p of Just s -> runGraphics $ do let size = n*50 + 50 w <- openWindow "a knight's path" (size,size) draw w Red (polyline (map realPos s)) let size = n*n drawPt w Cyan (head s) mapM (drawPt w Green) (init (tail s)) drawPt w Yellow (last s) let textposs = map realTextPos s h (p,n) = text p (show n) mapM (draw w Blue . h) (zip textposs [1..n*n]) getRBP w closeWindow w _ -> putStr "There is no path." -- dynamische Ausgabe: drawPathD pathD/tourD size start drawPathD :: (Window -> Int -> Pos -> IO ()) -> Int -> Pos -> IO () drawPathD path n p = runGraphics $ do let size = n*50 + 50 w <- openWindow "a knight's path" (size,size) let s = [(x,y) | x <- [1..n], y <- [1..n]] mapM (drawPt w Green) s path w n p getRBP w closeWindow w