finish vol 10

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