diff --git a/src/Scat/Schemas.hs b/src/Scat/Schemas.hs index e495f84..acff9ba 100644 --- a/src/Scat/Schemas.hs +++ b/src/Scat/Schemas.hs @@ -18,9 +18,12 @@ module Scat.Schemas -- * Pass phrases , pokemons , diceware + + -- * Pattern lock + , androidPatternLock ) where -import Data.List (intercalate) +import Data.List (intercalate, (\\)) import Data.Vector (Vector) import qualified Data.Vector as V import Data.Monoid @@ -75,6 +78,61 @@ alphanumeric = do pin :: Int -> Schema pin n = replicateM n digit + +-- | Generates an Android lock pattern, of specified length. +androidPatternLock :: Int -> Schema +androidPatternLock number = do + xs <- loop (min number (height * width)) [] + return $ intercalate " - " $ map showPosition xs + where + -- Gets `n` points. + loop :: Int -> [(Int, Int)] -> Builder [(Int, Int)] + loop n xs | n <= 0 = return $ reverse xs + loop n xs = do + x <- oneOf $ possibilities xs + loop (n - 1) (x : xs) + + -- Grid dimensions. + height = 3 + width = 3 + + -- Text representation for a position. + showPosition (1, 1) = "center" + showPosition (i, j) = vshow i ++ hshow j + where + vshow 0 = "north" + vshow 1 = "" + vshow _ = "south" + + hshow 0 = "west" + hshow 1 = "" + hshow _ = "east" + + -- All positions. + allPositions = [(i, j) | i <- [0 .. height - 1], j <- [0 .. width - 1]] + + {- Possible positions given a list of already used ones. + The head of the list is the last used position. -} + possibilities [] = allPositions + possibilities pps@(p : ps) = filter isPossible candidates + where + candidates = allPositions \\ pps + + isPossible q = all (`elem` ps) $ interfere p q + + -- The list of positions that are on the way between two positions. + interfere (i, j) (k, l) = do + r <- [1 .. steps - 1] + return (i + r * vstep, j + r * hstep) + where + vdiff = k - i + hdiff = l - j + + steps = gcd vdiff hdiff + + vstep = vdiff `div` steps + hstep = hdiff `div` steps + {- | Generates a password with 4 of the original Pokemons and their level. Entropy of about 55.5 bits. -} pokemons :: IO Schema