diff --git a/4/solution.hs b/4/solution.hs
index 11d0e7b..9f98676 100644
--- a/4/solution.hs
+++ b/4/solution.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TupleSections #-}
 import Data.List
 import Debug.Trace
 
@@ -8,67 +9,54 @@ type Input = ([Int], [Board])
 
 parse :: [String] -> Input
 parse (l : ls) = (n, b)
-    where
-        n = map read (words [ if c == ',' then ' ' else c | c <- l ])
-        b = parseBoards (filter (/= "") ls)
-
-solve :: Input -> (Int, Int)
-solve input = (f input, g input)
-    where f = uncurry winBingo
-          g = uncurry loseBingo
+    where n = map read $ words [ if c == ',' then ' ' else c | c <- l ]
+          b = parseBoards (filter (/= "") ls)
 
 parseBoards :: [String] -> [Board]
-parseBoards []   = []
-parseBoards list = Board (map (map (Unmarked . read) . words) a) : parseBoards b
-    where
-        (a, b) = splitAt 5 list
+parseBoards [] = []
+parseBoards l  = parse a : parseBoards b
+    where (a,b) = splitAt 5 l 
+          parse = map $ map (Unmarked . read) . words
 
-newtype Board = Board [[Cell]]
-    deriving
-        Show
+type Board = [[Cell]]
+
+rows :: Board -> [[Cell]]
+rows = id
+
+cols :: Board -> [[Cell]]
+cols = transpose
+
+hasWon :: Board -> Bool
+hasWon b = check (rows b) || check (cols b)
+    where check = any $ all marked
+
+score :: Int -> Board -> Int
+score n b = n * sum [ x | c <- b, Unmarked x <- c ]
+
+call :: Int -> Board -> Board
+call n = map (map mark)
+    where mark (Unmarked x) | x == n = Marked x
+          mark x = x
 
 data Cell = Unmarked Int
           | Marked Int
-    deriving
-        Show
 
-hasWon :: Board -> Bool
-hasWon (Board b) = completed b || completed (transpose b)
-    where
-        completed = any (all isMarked)
+marked :: Cell -> Bool
+marked (Marked _) = True
+marked _          = False
 
-isMarked :: Cell -> Bool
-isMarked (Marked _) = True
-isMarked _          = False
+solve :: Input -> (Int, Int)
+solve input = (f input, g input)
+    where wins extr (n,b) = uncurry score $ extr $ bingo n b
+          f = wins head
+          g = wins last
 
-winBingo :: [Int] -> [Board] -> Int
-winBingo (n : ns) (b : bs) =
-    if any hasWon r
-        then score n $ head (filter hasWon r)
-        else winBingo ns r
-    where
-        r = iter n (b : bs)
-
-loseBingo :: [Int] -> [Board] -> Int
-loseBingo (n : ns) [board]
-    | hasWon b  = score n b
-    | otherwise = loseBingo ns [b]
-    where
-        [b] = iter n [board]
-loseBingo (n : ns) (b : bs) =
-    loseBingo ns (filter (not . hasWon) r) 
-    where
-        r = iter n (b : bs)
+bingo :: [Int] -> [Board] -> [(Int, Board)]
+bingo _ []              = []
+bingo (n : ns) (b : bs) = map (n,) w ++ bingo ns l
+    where (w,l) = partition hasWon r
+          r     = iter n (b : bs)
 
 iter :: Int -> [Board] -> [Board]
-iter n (b : bs) = callNumber n b : iter n bs
 iter _ []       = []
-
-callNumber :: Int -> Board -> Board
-callNumber n (Board b) = Board (map (map mark) b)
-    where
-        mark (Unmarked x) | x == n = Marked x
-        mark v = v
-
-score :: Int -> Board -> Int
-score n (Board b) = n * sum [ x | c <- b, Unmarked x <- c ]
+iter n (b : bs) = call n b : iter n bs