Skip to content

Instantly share code, notes, and snippets.

@takeouchida
Created October 6, 2012 09:50
Show Gist options
  • Save takeouchida/3844511 to your computer and use it in GitHub Desktop.
Save takeouchida/3844511 to your computer and use it in GitHub Desktop.
Tetroid recognition
module Main where
import Control.Monad (mapM_)
import Control.Arrow ((***))
import Data.List (find, sort)
import Data.Maybe (maybe)
import Test.HUnit (Test(..), runTestTT, (~=?))
findTetroid :: [Int] -> Char
findTetroid = match . normalize . toCoord
toCoord :: [Int] -> [(Int, Int)]
toCoord = map (`divMod` 10)
normalize :: [(Int, Int)] -> [(Int, Int)]
normalize = toRelative . sort
toRelative :: [(Int, Int)] -> [(Int, Int)]
toRelative [] = error "toRelative: logic error"
toRelative ((x, y) : ps) = (0, 0) : map (subtract x *** subtract y) ps
match :: [(Int, Int)] -> Char
match ps = maybe '-' snd $ find (matchOne ps . fst) patterns
matchOne :: [(Int, Int)] -> [(Int, Int)] -> Bool
matchOne lhs rhs = any (== lhs)
[ rhs
, rotate rhs
, rotate $ rotate rhs
, rotate $ rotate $ rotate rhs
, mirror rhs
, mirror $ rotate rhs
, mirror $ rotate $ rotate rhs
, mirror $ rotate $ rotate $ rotate rhs
]
rotate :: [(Int, Int)] -> [(Int, Int)]
rotate = normalize . map (\(x, y) -> (y, -x))
mirror :: [(Int, Int)] -> [(Int, Int)]
mirror = normalize . map (\(x, y) -> (y, x))
patterns :: [([(Int, Int)], Char)]
patterns =
[ ( [ (0, 0), (0, 1), (0, 2), (1, 2) ], 'L' )
, ( [ (0, 0), (0, 1), (0, 2), (0, 3) ], 'I' )
, ( [ (0, 0), (1, 0), (1, 1), (2, 0) ], 'T' )
, ( [ (0, 0), (0, 1), (1, 0), (1, 1) ], 'O' )
, ( [ (0, 0), (0, 1), (1, 1), (1, 2) ], 'S' )
]
--------
main :: IO ()
main = print =<< runTestTT (TestList $ map toTest testdata)
--main = mapM_ print $ zip testdata $ map (findTetroid . fst) testdata
toTest :: ([Int], Char) -> Test
toTest (input, expected) = expected ~=? findTetroid input
testdata :: [([Int], Char)]
testdata =
[ ([55,55,55,55], '-')
, ([07,17,06,05], 'L')
, ([21,41,31,40], 'L')
, ([62,74,73,72], 'L')
, ([84,94,74,75], 'L')
, ([48,49,57,47], 'L')
, ([69,89,79,68], 'L')
, ([90,82,91,92], 'L')
, ([13,23,03,24], 'L')
, ([24,22,25,23], 'I')
, ([51,41,21,31], 'I')
, ([64,63,62,65], 'I')
, ([49,69,59,79], 'I')
, ([12,10,21,11], 'T')
, ([89,99,79,88], 'T')
, ([32,41,43,42], 'T')
, ([27,16,36,26], 'T')
, ([68,57,58,67], 'O')
, ([72,62,61,71], 'O')
, ([25,24,15,14], 'O')
, ([43,54,53,42], 'S')
, ([95,86,76,85], 'S')
, ([72,73,84,83], 'S')
, ([42,33,32,23], 'S')
, ([66,57,67,58], 'S')
, ([63,73,52,62], 'S')
, ([76,68,77,67], 'S')
, ([12,11,22,01], 'S')
, ([05,26,06,25], '-')
, ([03,11,13,01], '-')
, ([11,20,00,21], '-')
, ([84,95,94,86], '-')
, ([36,56,45,35], '-')
, ([41,33,32,43], '-')
, ([75,94,84,95], '-')
, ([27,39,28,37], '-')
, ([45,34,54,35], '-')
, ([24,36,35,26], '-')
, ([27,27,27,27], '-')
, ([55,44,44,45], '-')
, ([70,73,71,71], '-')
, ([67,37,47,47], '-')
, ([43,45,41,42], '-')
, ([87,57,97,67], '-')
, ([49,45,46,48], '-')
, ([63,63,52,72], '-')
, ([84,86,84,95], '-')
, ([61,60,62,73], '-')
, ([59,79,69,48], '-')
, ([55,57,77,75], '-')
]
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment