added unary encoding

CHANGELOG.md

@@ -1,5 +1,13 @@
 Revision history for based
 
+0.4.5.0 -- 2024-09-25
+
+    Added tap code
+    Removed some bugs of the solve functions
+    Added bindings for morse code, bug fix
+    Simplified functions, ignore non ascii characters
+    Added test for rotate function and yencode/decode
+
 0.4.4.0 -- 2024-06-09
 
     Added tests for every encode function included

app/Main.hs

@@ -5,8 +5,6 @@
 module Main where
 import System.Console.CmdArgs 
 import qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BC
-import Text.Regex.TDFA
 import Encoding.Base2           (enc2, dec2)
 import Encoding.Base8           (enc8, dec8)
 import Encoding.Base10          (enc10, dec10)
@@ -23,7 +21,11 @@ import Encoding.Xx              (encxx, decxx)
 import Encoding.QuotedPrintable (encqp, decqp)
 import Encoding.UnixToUnix      (encuu, decuu)
 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)
 
 
 data Based = Decode { 
@@ -44,7 +46,10 @@ data Based = Decode {
              uu  :: Bool,
              xx  :: Bool,
              yenc :: Bool,
+             a1z26 :: Bool,
              rot :: Maybe Int,
+             morse :: Bool,
+             tap :: Bool,
              solve :: Bool
                    }
           | Encode { 
@@ -65,45 +70,13 @@ data Based = Decode {
              uu  :: Bool,
              xx  :: Bool,
              yenc :: Bool,
+             a1z26 :: Bool,
+             morse :: Bool,
+             tap :: Bool,
              rot :: Maybe Int
                    } 
             deriving(Show, Data, Typeable) 
 
-base91Regex = "^[!-~]*$"
-base85Regex = "^[0-9A-Za-z!#$%&()*+,-;<=>?@^_`{|}~]+$"
-base64Regex = "^([A-Za-z0-9+/]{4})*([A-Za-z0-9+/]{3}=|[A-Za-z0-9+/]{2}==)?$"
-base58Regex = "^[1-9A-HJ-NP-Za-km-z]+$" -- incorrect
-base32Regex = "^(?:[A-Z2-7]{8})*(?:[A-Z2-7]{2}={6}|[A-Z2-7]{4}={4}|[A-Z2-7]{5}={3}|[A-Z2-7]{7}=)?$"
-base16Regex = "^[0-9A-FXx]*$"
-base10Regex = "^[0-9]*$"
-base8Regex = "^[0-7]*$"
-base2Regex = "^[01]*$"
-urlRegex = "^[a-zA-Z0-9%]*$"
-
-solveEnc :: BC.ByteString -> BC.ByteString
-solveEnc input =
-   let isBase91 = input =~ base91Regex :: Bool
-       isBase85 = input =~ base85Regex :: Bool
-       isBase64 = input =~ base64Regex :: Bool
-       isBase58 = input =~ base58Regex :: Bool
-       isBase32 = input =~ base32Regex :: Bool
-       isBase16 = input =~ base16Regex :: Bool
-       isBase10 = input =~ base10Regex :: Bool
-       isBase8  = input =~ base8Regex  :: Bool
-       isBase2  = input =~ base2Regex  :: Bool
-       isURL = input =~ urlRegex :: Bool
-       base91Result = if isBase91 then BC.pack "\nTrying base91:\n" `BC.append` dec91 input else BC.empty
-       base85Result = if isBase85 then BC.pack "\nTrying base85:\n" `BC.append` dec85 input else BC.empty
-       base64Result = if isBase64 then BC.pack "\nTrying base64:\n" `BC.append` dec64 input else BC.empty
-       base58Result = if isBase58 then BC.pack "\nTrying base58:\n" `BC.append` dec58 input else BC.empty
-       base32Result = if isBase64 then BC.pack "\nTrying base32:\n" `BC.append` dec32 input else BC.empty
-       base16Result = if isBase16 then BC.pack "\nTrying base16:\n" `BC.append` dec16 input else BC.empty
-       base10Result = if isBase10 then BC.pack "\nTrying base10:\n" `BC.append` dec10 input else BC.empty
-       base2Result  = if isBase2  then BC.pack "\nTrying base2:\n"  `BC.append` dec2  input else BC.empty
-       base8Result  = if isBase8  then BC.pack "\nTrying base8:\n"  `BC.append` dec8  input else BC.empty
-       urlResult    = if isURL    then BC.pack "\nTrying URL decode:\n" `BC.append` decurl input else BC.empty
-   in BC.concat [base91Result, base85Result, base64Result, base58Result, base32Result, base16Result, base10Result, base8Result, base2Result,  urlResult]
-
 
 optionHandler :: Based ->  B.ByteString -> B.ByteString
 optionHandler Decode{b91=True} = dec91
@@ -140,8 +113,14 @@ optionHandler Decode{xx=True}  = decxx
 optionHandler Encode{xx=True}  = encxx
 optionHandler Decode{yenc=True}  = decy
 optionHandler Encode{yenc=True}  = ency
-optionHandler Encode{rot=Just n} = rotate n
+optionHandler Decode{a1z26=True} = decltn
+optionHandler Encode{a1z26=True} = encltn
 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
@@ -163,7 +142,10 @@ decodeMode = Decode {
            uu  = def &= help "decode UnixToUnix",
            xx  = def &= help "decode xx, without padding",
            yenc = def &= help "decode yEncode",
+           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
 
@@ -186,7 +168,10 @@ encodeMode = Encode {
            uu  = def &= help "encode UnixToUnix",
            xx  = def &= help "encode xx, without padding",
            yenc = def &= help "encode yEncode",
-           rot = def &= help "rotate characters by n positions" 
+           a1z26 = def &= help "encode letter to number",
+           rot = def &= help "rotate characters by n positions",
+           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()

based.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.4
 name:                based
-version:             0.4.4.0
+version:             0.4.5.0
 license-file:        LICENSE
 extra-source-files:  CHANGELOG.md
 author: Stefan Friese
@@ -25,6 +25,10 @@ library
     Encoding.Xx
     Encoding.Yenc
     Encoding.Rotate
+    Encoding.LetterToNumber
+    Encoding.Morse
+    Encoding.Tap
+    Encoding.Solve
   other-modules:
     -- Data.Bytes.Text.Ascii
   build-depends:
@@ -42,7 +46,11 @@ library
     haskoin-core,
     text,
     primitive,
-    base64-bytestring
+    regex-tdfa,
+    base64-bytestring,
+    containers,
+    split,
+    MorseCode
   default-language:    Haskell2010
 
 executable based

src/Encoding/Base2.hs

@@ -31,6 +31,7 @@
 module Encoding.Base2
   ( enc2
   , dec2
+  , binaryToChar
   ) where
 
 import Data.Char (ord, chr, digitToInt, intToDigit)

src/Encoding/LetterToNumber.hs

@@ -0,0 +1,30 @@
+
+module Encoding.LetterToNumber
+  ( encltn
+  , decltn
+  ) where 
+
+import Data.Char (ord, chr, isAscii, isAlpha, isSpace, isDigit, toUpper)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+
+-- This encodes ASCII characters only and ignores all other characters
+
+charToNumber :: Char -> ByteString
+charToNumber c
+  | not (isAscii c) = BC.pack ""
+  | isAlpha c = BC.pack $ show $ ord (toUpper c) - ord 'A' + 1
+  | isSpace c = BC.pack "0"
+  | otherwise = BC.singleton c
+
+numberToChar :: ByteString -> ByteString
+numberToChar s
+  | s == BC.pack "0" = BC.singleton ' '
+  | BC.all isDigit s = BC.singleton $ chr $ (read $ BC.unpack s) + ord 'A' - 1
+  | otherwise = s
+
+encltn :: ByteString -> ByteString
+encltn input = BC.unwords $ filter (not . BC.null) $ map charToNumber $ BC.unpack input
+
+decltn :: ByteString -> ByteString
+decltn input = BC.concat $ map numberToChar $ BC.words input

src/Encoding/Morse.hs

@@ -0,0 +1,21 @@
+module Encoding.Morse 
+  ( encmorse
+  , decmorse
+  ) where
+
+import Text.Morse as M
+import Data.ByteString (ByteString)
+import Data.Char (isSpace)
+import qualified Data.ByteString.Char8 as BC
+
+encmorse :: ByteString -> ByteString
+encmorse input = BC.pack $ encodeValidMorseChars (BC.unpack input)
+  where
+    encodeValidMorseChars :: String -> String
+    encodeValidMorseChars = concatMap (\c ->  M.encodeMorse [c])
+
+decmorse :: ByteString -> ByteString
+decmorse input = case M.decodeMorse (BC.unpack input) of
+                   "" -> BC.pack "Invalid Morse Code"
+                   decoded -> BC.pack decoded
+

src/Encoding/Solve.hs

@@ -0,0 +1,58 @@
+module Encoding.Solve
+  (solveEnc) where
+
+import qualified Data.ByteString.Char8 as BC
+import Text.Regex.TDFA
+import Encoding.Base2           (enc2, dec2)
+import Encoding.Base8           (enc8, dec8)
+import Encoding.Base10          (enc10, dec10)
+import Encoding.Base16          (enc16, dec16)
+import Encoding.Base32          (enc32, dec32)
+import Encoding.Base45          (enc45, dec45)
+import Encoding.Base58          (enc58, dec58)
+import Encoding.Base62          (enc62, dec62)
+import Encoding.Base64          (enc64, dec64, enc64url, dec64url)
+import Encoding.Base85          (enc85, dec85)
+import Encoding.Base91          (enc91, dec91)
+import Encoding.Url             (encurl, decurl)
+import Encoding.Xx              (encxx, decxx)
+import Encoding.QuotedPrintable (encqp, decqp)
+import Encoding.UnixToUnix      (encuu, decuu)
+import Encoding.Yenc            (ency, decy)
+import Encoding.Rotate          (rotate)
+
+
+base91Regex = "^[!-~]*$"
+base85Regex = "^[0-9A-Za-z!#$%&()*+,-;<=>?@^_`{|}~]+$"
+base64Regex = "^([A-Za-z0-9+/]{4})*([A-Za-z0-9+/]{3}=|[A-Za-z0-9+/]{2}==)?$"
+base58Regex = "^[1-9A-HJ-NP-Za-km-z]+$" -- incorrect
+base32Regex = "^(?:[A-Z2-7]{8})*(?:[A-Z2-7]{2}={6}|[A-Z2-7]{4}={4}|[A-Z2-7]{5}={3}|[A-Z2-7]{7}=)?$"                                                                                                  
+base16Regex = "^[0-9A-FXx]*$"
+base10Regex = "^[0-9 ]*$"
+base8Regex = "^[0-7 ]*$"
+base2Regex = "^[01 ]*$"
+urlRegex = "^[a-zA-Z0-9%]*$"
+
+solveEnc :: BC.ByteString -> BC.ByteString
+solveEnc input =
+   let isBase91 = input =~ base91Regex :: Bool
+       isBase85 = input =~ base85Regex :: Bool
+       isBase64 = input =~ base64Regex :: Bool
+       isBase58 = input =~ base58Regex :: Bool
+       isBase32 = input =~ base32Regex :: Bool
+       isBase16 = input =~ base16Regex :: Bool
+       isBase10 = input =~ base10Regex :: Bool
+       isBase8  = input =~ base8Regex  :: Bool
+       isBase2  = input =~ base2Regex  :: Bool
+       isURL = input =~ urlRegex :: Bool
+       base91Result = if isBase91 then BC.pack "\nBase91:\n" `BC.append` dec91 input else BC.empty
+       base85Result = if isBase85 then BC.pack "\nBase85:\n" `BC.append` dec85 input else BC.empty
+       base64Result = if isBase64 then BC.pack "\nBase64:\n" `BC.append` dec64 input else BC.empty
+       base58Result = if isBase58 then BC.pack "\nBase58:\n" `BC.append` dec58 input else BC.empty
+       base32Result = if isBase64 then BC.pack "\nBase32:\n" `BC.append` dec32 input else BC.empty
+       base16Result = if isBase16 then BC.pack "\nBase16:\n" `BC.append` dec16 input else BC.empty
+       base10Result = if isBase10 then BC.pack "\nBase10:\n" `BC.append` dec10 input else BC.empty
+       base2Result  = if isBase2  then BC.pack "\nBase2:\n"  `BC.append` dec2  input else BC.empty
+       base8Result  = if isBase8  then BC.pack "\nBase8:\n"  `BC.append` dec8  input else BC.empty
+       urlResult    = if isURL    then BC.pack "\nTrying URL decode:\n" `BC.append` decurl input else BC.empty
+   in BC.concat [base91Result, base85Result, base64Result, base58Result, base32Result, base16Result, base10Result, base8Result, base2Result,  urlResult]

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
+

src/Encoding/Unary.hs

@@ -0,0 +1,63 @@
+module Encoding.Unary
+  ( encunary
+  , decunary
+  ) where
+
+import Data.ByteString (ByteString)
+import Data.List (group)
+import qualified Data.ByteString.Char8 as BC
+import Encoding.Base2 (dec2, enc2, binaryToChar)
+import Debug.Trace (trace)
+
+encodeChuckNorris :: ByteString -> ByteString
+encodeChuckNorris binary = 
+  let cleanBinary = BC.filter (/= ' ') binary
+   in BC.unwords . concatMap encodeRunLength . group $ BC.unpack cleanBinary
+  where
+    encodeRunLength :: String -> [ByteString]
+    encodeRunLength xs@(x:_) = [prefix x, BC.pack (replicate (length xs) '0')]
+    encodeRunLength [] = []
+
+    prefix '0' = BC.pack "00"
+    prefix '1' = BC.pack "0"
+    prefix  c  = error $ "Invalid binary character encoding" ++ show c
+    
+pairs :: [a] -> [(a, a)]
+pairs (x:y:rest) = (x, y) : pairs rest
+pairs _ = []
+
+encunary :: ByteString -> ByteString
+encunary input = encodeChuckNorris $ enc2 input
+
+decodeChuckNorris :: ByteString -> ByteString
+decodeChuckNorris encoded = BC.pack . concatMap (BC.unpack . decodeRunLength) . pairs . BC.words $ encoded
+  where
+    decodeRunLength :: (ByteString, ByteString) -> ByteString
+    decodeRunLength (prefix, zeros)
+      | prefix == BC.pack "00" = BC.replicate (BC.length zeros) '0'
+      | prefix == BC.pack "0" = BC.replicate (BC.length zeros) '1'
+      | otherwise = error "Invalid Unary encoding"
+    -- pairs (x:y:rest) = (x, y) : pairs rest
+    -- pairs _ = []
+
+    -- decodeRunLength ("00", zeros) = replicate (BC.length zeros) '0'
+    -- decodeRunLength ("0", zeros) = replicate (BC.length zeros) '1'
+    -- decodeRunLength _ = error "Invalid Unary encoding"
+
+decunary :: ByteString -> ByteString
+decunary encoded =
+  let binaryStr = decodeChuckNorris encoded
+  in BC.pack $ map binaryToChar (chunkBinaryString binaryStr)
+  where
+    chunkBinaryString :: ByteString -> [ByteString]
+    chunkBinaryString bs
+      | BC.null bs = []
+      | otherwise  = let (chunk, rest) = BC.splitAt 8 bs
+                     in chunk : chunkBinaryString rest
+
+-- encunary input = 
+--   let binaryStr = enc2 input
+--    in trace (show binaryStr) $ encodeChuckNorris binaryStr
+
+-- decunary :: ByteString -> ByteString
+-- decunary encoded = dec2 $ decodeChuckNorris encoded

test/Main.hs

@@ -17,6 +17,8 @@ import Encoding.Base2  (enc2,  dec2)
 import Encoding.QuotedPrintable (encqp, decqp)
 import Encoding.UnixToUnix      (encuu, decuu)
 import Encoding.Xx     (encxx, decxx)
+import Encoding.Yenc   (ency,  decy)
+import Encoding.Rotate (rotate)
 import System.Exit (exitFailure, exitSuccess)
 
 helloWorldBS :: B.ByteString
@@ -218,6 +220,23 @@ testDecXx = TestCase $ do
     assertEqual "for (decxx \"NaxjMa3m\")," (BSU.fromString "foobar") (decxx $ BSU.fromString "NaxjMa3m")
     assertEqual "for (decxx \"w7yMUU\")," (BSU.fromString "😂") (decxx $ BSU.fromString "w7yMUU")
 
+testEncYenc :: Test
+testEncYenc = TestCase $ do
+    assertEqual "for (ency \"Hello, World!\")," (B.pack [114, 143, 150, 150, 153, 86, 74, 129, 153, 156, 150, 142, 75]) (ency helloWorldBS)
+    assertEqual "for (ency \"😂\")," (B.pack [26, 201, 194, 172] ) (ency emojiBS)
+
+testDecYenc:: Test
+testDecYenc= TestCase $ do
+    assertEqual "for (decy \"r<8f><96><96><99>VJ<81><99><9c><96><8e>K\")," helloWorldBS (decy $ B.pack [114, 143, 150, 150, 153, 86, 74, 129, 153, 156, 150, 142, 75] )
+    assertEqual "for (decy \"^Z<c9>¬\")," (BSU.fromString "😂") (decy $ B.pack [26, 201, 194, 172])
+
+testRotate :: Test
+testRotate = TestCase $ do
+    assertEqual "for (rotate 13 \"Hello, World!\")," (BSU.fromString "Uryyb, Jbeyq!") (rotate 13 (BSU.fromString "Hello, World!"))
+    assertEqual "for (rotate 8 \"Hello, World!\")," (BSU.fromString "Pmttw, Ewztl!") (rotate 8 (BSU.fromString "Hello, World!"))
+    assertEqual "for (rotate 2 \"😂\")," (BSU.fromString "😂") (rotate 2 (BSU.fromString "😂"))
+
+
 tests :: Test
 tests = TestList [TestLabel "Test enc91" testEnc91,
                   TestLabel "Test dec91" testDec91,
@@ -248,7 +267,9 @@ tests = TestList [TestLabel "Test enc91" testEnc91,
                   TestLabel "Test decuu" testDecUu,
                   TestLabel "Test encuu" testEncUu,
                   TestLabel "Test decuu" testDecXx,
-                  TestLabel "Test encuu" testEncXx]
+                  TestLabel "Test encuu" testEncXx,
+                  TestLabel "Test ency"  testEncYenc,
+                  TestLabel "Test rot"   testRotate]
 
 
 -- main :: IO Counts