diff --git a/app/Main.hs b/app/Main.hs index 6589eb7..028a822 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -24,6 +24,7 @@ import Encoding.Yenc (ency, decy) import Encoding.LetterToNumber (encltn, decltn) import Encoding.Rotate (rotate) import Encoding.Morse (encmorse, decmorse) +import Encoding.Tap (enctap, dectap) import Encoding.Solve (solveEnc) @@ -48,6 +49,7 @@ data Based = Decode { a1z26 :: Bool, rot :: Maybe Int, morse :: Bool, + tap :: Bool, solve :: Bool } | Encode { @@ -70,6 +72,7 @@ data Based = Decode { yenc :: Bool, a1z26 :: Bool, morse :: Bool, + tap :: Bool, rot :: Maybe Int } deriving(Show, Data, Typeable) @@ -116,6 +119,8 @@ optionHandler Decode{rot=Just n} = rotate n optionHandler Encode{rot=Just n} = rotate n optionHandler Decode{morse=True} = decmorse optionHandler Encode{morse=True} = encmorse +optionHandler Decode{tap=True} = dectap +optionHandler Encode{tap=True} = enctap optionHandler Decode{solve=True} = solveEnc decodeMode :: Based @@ -140,6 +145,7 @@ decodeMode = Decode { a1z26 = def &= help "decode letter to number", rot = def &= help "rotate characters by n positions", morse = def &= help "decode morse", + tap = def &= help "decode tap code using a Polybius square (5x5 grid Latin alphabet)", solve = def &= help "solve encoding" } &= help "Decode chosen base" &=auto @@ -164,7 +170,8 @@ encodeMode = Encode { yenc = def &= help "encode yEncode", a1z26 = def &= help "encode letter to number", rot = def &= help "rotate characters by n positions", - morse = def &= help "encode morse" + morse = def &= help "encode morse", + tap = def &= help "encode tap code using a Polybius square (5x5 grid Latin alphabet)" } &= help "Encode chosen base" main :: IO() diff --git a/based.cabal b/based.cabal index 90ed323..4672517 100644 --- a/based.cabal +++ b/based.cabal @@ -27,6 +27,7 @@ library Encoding.Rotate Encoding.LetterToNumber Encoding.Morse + Encoding.Tap Encoding.Solve other-modules: -- Data.Bytes.Text.Ascii @@ -47,6 +48,8 @@ library primitive, regex-tdfa, base64-bytestring, + containers, + split, MorseCode default-language: Haskell2010 diff --git a/src/Encoding/:w b/src/Encoding/:w new file mode 100644 index 0000000..f67c1ca --- /dev/null +++ b/src/Encoding/:w @@ -0,0 +1,76 @@ +-- This module's code leans heavily on Andy Stewarts' Morse Code implementation in Text.Morse +module Encoding.Tap + ( enctap + , dectap + ) where + +import Data.Char (toLower, isSpace) +import Data.Map (Map) +import Data.List.Split (split, dropDelims, dropFinalBlank, oneOf) +import Data.ByteString (ByteString) +import qualified Data.Map as M +import qualified Data.ByteString.Char8 as BC + +-- | Morse Code convert map. +tapCode :: Map Char String +tapCode = + M.fromList + [('a', ". .") + ,('b', ". ..") + ,('c', ". ...") + ,('d', ". ....") + ,('e', ". .....") + ,('f', ".. .") + ,('g', ".. ..") + ,('h', ".. ...") + ,('i', ".. ....") + ,('j', ".. .....") + ,('k', ". ...") + ,('l', "... .") + ,('m', "... ..") + ,('n', "... ...") + ,('o', "... ....") + ,('p', "... .....") + ,('q', ".... .") + ,('r', ".... ..") + ,('s', ".... ...") + ,('t', ".... ....") + ,('u', ".... .....") + ,('v', "..... .") + ,('w', "..... ..") + ,('x', "..... ...") + ,('y', "..... ....") + ,('z', "..... .....")] + +enctap :: ByteString -> ByteString +enctap = BC.pack . concatMap encodeChar . BC.unpack + where + encodeChar c + | isAlpha c = case M.lookup (toLower c) tapCode of + Just code -> code + Nothing -> [c] + | isSpace c = "/" + | otherwise = [c] + -- encodeChar x = + -- case findMinMatch tapCode (\k _ -> k == toLower x) of + -- Just (_, tap) -> tap + -- Nothing -> if isSpace x then "/" else "" + +dectap :: ByteString -> ByteString +dectap input = BC.pack $ concatMap decodeSegment $ split (oneOf "/" ) $ BC.unpack input + where + decodeSegment x + | x == "/" = " " + | otherwise = concatMap decodeTap (split (dropDelims $ dropFinalBlank $ oneOf " ") x) + + decodeTap lv = + case findMinMatch tapCode(\ _ v -> v == lv) of + Just (c, _) -> [c] + Nothing -> [] + +findMinMatch :: Ord k => Map k a -> (k -> a -> Bool) -> Maybe (k, a) +findMinMatch map fun = match + where filterMap = M.filterWithKey fun map + match = if M.null filterMap + then Nothing + else Just $ M.findMin filterMap diff --git a/src/Encoding/Tap.hs b/src/Encoding/Tap.hs new file mode 100644 index 0000000..089fd56 --- /dev/null +++ b/src/Encoding/Tap.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Encoding.Tap + ( enctap + , dectap + ) where + +import Data.Char (isAsciiUpper, isAsciiLower, toLower, chr, ord, toUpper) +import Data.List (find) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BC + +enctap :: ByteString -> ByteString +enctap = BC.concatMap encodeChar + where + encodeChar ' ' = BC.singleton ' ' + encodeChar 'K' = BC.pack "22" -- Special case: 'K' is encoded as "22" + encodeChar c + | isAsciiUpper c || isAsciiLower c = + let (row, col) = positionInGrid c + in BC.pack [chr (ord '0' + row), chr (ord '0' + col)] + | otherwise = BC.empty -- Handle non-alphabet characters or errors + + positionInGrid c = + let idx = ord (toUpper c) - ord 'A' + row = idx `div` 5 + 1 + col = idx `mod` 5 + 1 + in (row, col) + +dectap :: ByteString -> ByteString +dectap = BC.concat . map decodePair . chunkPairs . BC.filter (/= ' ') + where + chunkPairs :: ByteString -> [ByteString] + chunkPairs bs + | BC.null bs = [] + | otherwise = let (pair, rest) = BC.splitAt 2 bs in pair : chunkPairs rest + + decodePair pair + | pair == "22" = BC.singleton 'K' -- Special case: "22" is decoded as 'K' + | BC.length pair == 2 = + let [row, col] = BC.unpack pair + rowIdx = ord row - ord '0' + colIdx = ord col - ord '0' + idx = (rowIdx - 1) * 5 + (colIdx - 1) + in BC.singleton $ chr (ord 'A' + idx) + | otherwise = error $ "Invalid Tap Code sequence: " ++ show pair +