diff options
| -rw-r--r-- | 90-94/92.hs | 24 | ||||
| -rw-r--r-- | 90-94/93.hs | 34 | ||||
| -rw-r--r-- | 90-94/94.hs | 33 |
3 files changed, 91 insertions, 0 deletions
diff --git a/90-94/92.hs b/90-94/92.hs new file mode 100644 index 0000000..0f6f7a0 --- /dev/null +++ b/90-94/92.hs @@ -0,0 +1,24 @@ +import Data.List (sortBy) +import Data.Ord (comparing) + +vonKoch :: [(Int, Int)] -> [[(Int, Int)]] + +vonKoch edges = koch (reverse adj) [] [] [] + where koch [] _ _ vplan = return vplan + koch ((v, us):vs) eused vused vplan = + do (vn, eused') <- [(x, eused') + | x <- [1..maxvn], + x `notElem` vused, + let en = map (abs . (x-)) (map (findn vplan) us), + let (eused', f) = foldl (\(l, f) d -> + (d:l, f && d `notElem` l + && 1 <= d && d <= maxen)) + (eused, True) en, f] + koch vs eused' (vn:vused) ((v, vn):vplan) + maxen = length edges + maxvn = maxen + 1 + deg x = length $ filter (\(a, b) -> a == x || b == x) edges + genAdj [] = [] + genAdj (v:vs) = (v, [u | u <- vs, (v, u) `elem` edges || (u, v) `elem` edges]):genAdj vs + findn vplan u = snd $ head $ filter ((== u) . fst) vplan + adj = genAdj $ sortBy (comparing deg) [1..maxvn] diff --git a/90-94/93.hs b/90-94/93.hs new file mode 100644 index 0000000..c031e7b --- /dev/null +++ b/90-94/93.hs @@ -0,0 +1,34 @@ +puzzle :: [Integer] -> [String] + +puzzle l = do i <- [1..length l-1] + let (subl, subr) = splitAt i l + (sl, vl, _) <- gen subl + (sr, vr, _) <- gen subr + if vl == vr then + return (sl ++ " = " ++ sr) + else [] + +gen :: [Integer] -> [(String, Rational, String)] +gen (x:[]) = return (show x, fromInteger x, "_") + +gen l = do i <- [1..length l-1] + let (subl, subr) = splitAt i l + (sl, vl, opsl) <- gen subl + (sr, vr, opsr) <- gen subr + (ops, op) <- [("+", (+)), ("-", (-)), ("*", (*)), ("/", (/))] + if (ops == "/" && vr == 0) || + (ops == "+" && (opsr == "+" || opsr == "-")) || + (ops == "*" && (opsr == "*" || opsr == "/")) then [] + else + return ((if opsl /= "_" && + (ops == "*" || ops == "/") && + (opsl == "+" || opsl == "-") then + "(" ++ sl ++ ")" + else sl) + ++ " " ++ ops ++ " " ++ + (if opsr /= "_" && + ((ops == "-" && opsr /= "*" && opsr /= "/") || + (ops == "*" && (opsr == "+" || opsr == "-")) || + ops == "/") then + "(" ++ sr ++ ")" + else sr), op vl vr, ops) diff --git a/90-94/94.hs b/90-94/94.hs new file mode 100644 index 0000000..29c310b --- /dev/null +++ b/90-94/94.hs @@ -0,0 +1,33 @@ +import Data.List (permutations, sort) + +iso vs e1 e2 = + let perm = permutations vs + t = takeWhile id $ scanl (\acc perm -> + let tab = zip vs perm + trans x = snd . head $ filter ((== x) . fst) tab in + acc && (sort (map (\(u, v) -> (trans u, trans v)) e1') /= e2'')) + True perm in length t /= length perm + 1 + where adjust e = e >>= (\(u, v) -> [(u, v), (v, u)]) + e1' = adjust e1 + e2'' = sort $ adjust e2 + +select _ 0 = [[]] +select [] _ = [] +select (x:xs) k = (map (x:) $ select xs (k - 1)) ++ select xs k + +regular :: Int -> Int -> [[(Int, Int)]] +regular n k = elim $ reg [] 0 [] + where elim [] = [] + elim (p:ps) + | length ps + 1 == length (takeWhile id $ + scanl (\f p' -> f && not (iso' p p')) + True ps) = p:elim ps + | otherwise = elim ps + where iso' = iso [0..n-1] + reg e i plan + | i == n = [plan] + | otherwise = do vs <- select rv (k - k') + let plan' = [(i, v) | v <- vs] ++ plan + reg (vs ++ e) (i + 1) plan' + where (_, k'):r = map (\v -> (v, length $ filter (== v) e)) [i..n-1] + rv = map fst $ filter ((<k) . snd) r |