add round 1B's solutions

- A: passed
- B: incorrect
- C: incorrect

googlecodejam2016-hs.cabal

@@ -35,6 +35,27 @@ executable q1a-c
                      , containers
   default-language:    Haskell2010
 
+executable q1b-a
+  hs-source-dirs:      src/q1b
+  main-is:             A.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+  default-language:    Haskell2010
+
+executable q1b-b
+  hs-source-dirs:      src/q1b
+  main-is:             B.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+  default-language:    Haskell2010
+
+executable q1b-c
+  hs-source-dirs:      src/q1b
+  main-is:             C.hs
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N
+  build-depends:       base
+  default-language:    Haskell2010
+
 executable 2010africa-a
   hs-source-dirs:      src/2010africa
   main-is:             A.hs

src/q1b/A.hs

@@ -0,0 +1,40 @@
+import           Data.List
+
+main :: IO ()
+main = interact io
+
+{-|
+-}
+io :: String -> String
+io = unlines . addPrefixes . map solve . tail . lines
+
+{-|
+-}
+solve :: String -> String
+solve = concatMap show . sort . conv
+
+conv :: String -> [Int]
+conv "" = []
+conv s | exist "EIGHT" s = 8 : (conv . reduce "EIGHT") s
+       | exist "ZERO"  s = 0 : (conv . reduce "ZERO") s
+       | exist "TWO"   s = 2 : (conv . reduce "TWO") s
+       | exist "SIX"   s = 6 : (conv . reduce "SIX") s
+       | exist "THREE" s = 3 : (conv . reduce "THREE") s
+       | exist "SEVEN" s = 7 : (conv . reduce "SEVEN") s
+       | exist "FOUR"  s = 4 : (conv . reduce "FOUR") s
+       | exist "FIVE"  s = 5 : (conv . reduce "FIVE") s
+       | exist "NINE"  s = 9 : (conv . reduce "NINE") s
+       | exist "ONE"   s = 1 : (conv . reduce "ONE") s
+
+exist :: String -> String -> Bool
+exist ""     t = True
+exist (s:ss) t | s `elem` t = exist ss (delete s t)
+               | otherwise  = False
+
+reduce :: String -> String -> String
+reduce dels target = foldl (flip delete) target dels
+
+addPrefixes :: [String] -> [String]
+addPrefixes = zipWith addPrefix [1..] where
+  addPrefix :: Int -> String -> String
+  addPrefix i s = "Case #" ++ show i ++ ": " ++ s

src/q1b/B.hs

@@ -0,0 +1,57 @@
+module Main where
+import           Data.List
+
+main :: IO ()
+main = interact io
+
+{-|
+-}
+io :: String -> String
+io = unlines . addPrefixes . map (unwords' . solve) . parse . tail . lines
+
+parse :: [String] -> [(String,String)]
+parse = map words'
+
+words' :: String -> (String,String)
+words' s = (left,right) where
+  left = takeWhile (/=' ') s
+  right = (tail . dropWhile (/=' ')) s
+
+unwords' :: (String,String) -> String
+unwords' (s,t) = s ++ " " ++ t
+
+{-|
+-}
+solve :: (String,String) -> (String,String)
+solve ([],[])                 = ([],[])
+solve (s:ss,t:ts)
+  | s=='?' && t=='?'          = offset ('0','0') `tcat` solve (ss,ts)
+  | s==t                      = offset (s, t)    `tcat` solve (ss,ts)
+  | s/='?' && t/='?' && s'<t' = offset (s, t)    `tcat` (fill9 ss, fill0 ts)
+  | s/='?' && t/='?' && s'>t' = offset (s, t)    `tcat` (fill0 ss, fill9 ts)
+  | s=='?'                    = offset (t, t)    `tcat` solve (ss,ts)
+  | t=='?'                    = offset (s, s)    `tcat` solve (ss,ts) where
+    s' = read [s] :: Int
+    t' = read [t] :: Int
+    offset (c,d) = (show (read [c] + os), show (read [d] + ot))
+    os = if nt' - ns' > 5 then 1 else 0
+    ot = if ns' - nt' > 5 then 1 else 0
+    ns' = if ns/='?' then read [ns] :: Int else 0
+    nt' = if nt/='?' then read [nt] :: Int else 0
+    ns = if ss/=[] then head ss else '0'
+    nt = if ts/=[] then head ts else '0'
+
+tcat (x,y) (z,w) = (x++z, y++w)
+
+fill0 = replace '?' '0'
+fill9 = replace '?' '9'
+
+replace :: Eq a => a -> a -> [a] -> [a]
+replace _ _ [] = []
+replace from to (s:ss) | s==from = to : replace from to ss
+                       | s/=from = s  : replace from to ss
+
+addPrefixes :: [String] -> [String]
+addPrefixes = zipWith addPrefix [1..] where
+  addPrefix :: Int -> String -> String
+  addPrefix i s = "Case #" ++ show i ++ ": " ++ s

src/q1b/C.hs

@@ -0,0 +1,54 @@
+import           Data.List
+
+main :: IO ()
+main = interact io
+
+{-|
+-}
+io :: String -> String
+io = unlines . addPrefixes . map (show . solve) . parse . tail . lines
+
+type TString = (String,String)
+type TInt = (Int,Int)
+type Problem = [TString]
+type DupInfo = (TString,TInt)
+
+parse :: [String] -> [Problem]
+parse [] = []
+parse s = parsed : remaining where
+  parsed = (map twords . take size . tail) s
+  remaining = (parse . drop size . tail) s
+  size = (read . head) s
+
+twords :: String -> TString
+twords s = ((head . words) s, ((!! 1) . words) s)
+
+{-|
+-}
+solve :: Problem -> Int
+solve ps = if (isNotDup . snd . head) ps' then 0
+           else 1 + (solve . map fst . tail) ps' where
+  ps' = (sortDup . zipDups) ps
+
+isNotDup :: TInt -> Bool
+isNotDup (d1,d2) = d1*d2==0
+
+sortDup :: [DupInfo] -> [DupInfo]
+sortDup = sortOn (negate . uncurry (*) . snd)
+
+zipDups :: Problem -> [DupInfo]
+zipDups ps = zip ps (tdups ps)
+
+tdups :: [TString] -> [TInt]
+tdups = tzip . tdups' . unzip where
+  tdups' :: ([String],[String]) -> ([Int],[Int])
+  tdups' (xs,ys)= (dups xs, dups ys) where
+    dups xs = map (dup xs) xs
+    dup xs y = (decrement . length . filter (==y)) xs
+    decrement x = x - 1
+  tzip (xs,ys) = zip xs ys
+
+addPrefixes :: [String] -> [String]
+addPrefixes = zipWith addPrefix [1..] where
+  addPrefix :: Int -> String -> String
+  addPrefix i s = "Case #" ++ show i ++ ": " ++ s