summaryrefslogtreecommitdiff
path: root/90-94
diff options
context:
space:
mode:
Diffstat (limited to '90-94')
-rw-r--r--90-94/92.hs24
-rw-r--r--90-94/93.hs34
-rw-r--r--90-94/94.hs33
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