{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-}
{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-}
module Math.Algebra.Code.Linear
( LinearCode (..)
, Generator, CheckMatrix
, codeFromA, codeFromAD
, standardForm, standardFormGenerator
, Vector, encode, isCodeword, hasError, weight, codewords
, allVectors, fullVectors, hammingWords, lighterWords
, syndrome, decode, syndromeDecode, calcSyndromeTable, recalcSyndromeTable
, SyndromeTable
, dualCode, dualCodeD, permuteCode, extendCode
, trivialCode, simplex, hamming, golay
, BinaryCode
, randomPermMatrix
, codeLength
, rank
, eVec, e1, e2, e3, e4, e5, e6, e7, e8, e9, e10
, char
, matrix, zero, transpose, fromList, fromLists
, F2, F3, F5, F7, F11
, F4, F8, F16, F9
) where
import GHC.TypeLits
( Nat, KnownNat, natVal
, type (<=), type (+), type (-), type (^)
)
import Data.Bifunctor (first)
import Data.Monoid ((<>))
import Data.List (permutations)
import qualified Data.Map.Strict as M
import Data.Proxy (Proxy (..))
import System.Random (Random, RandomGen, random, randomR, split)
import System.Random.Shuffle (shuffle')
import Math.Core.Utils (FinSet, elts)
import Math.Common.IntegerAsType (IntegerAsType)
import Math.Algebra.Field.Base (Fp, F2, F3, F5, F7, F11)
import Math.Algebra.Field.Static (Size, Characteristic, char)
import Math.Algebra.Field.Extension (F4, F8, F16, F9)
import Math.Algebra.Field.Instances ()
import Math.Algebra.Matrix
( Matrix, matrix, transpose, (<|>), (<->), (.*)
, identity, zero, fromList, fromLists, Vector, rref, submatrix
)
type Generator (n :: Nat) (k :: Nat) = Matrix k n
type CheckMatrix (n :: Nat) (k :: Nat) = Matrix (n-k) n
data LinearCode (n :: Nat) (k :: Nat) (f :: *)
= LinearCode { generatorMatrix :: Generator n k f
, checkMatrix :: CheckMatrix n k f
, distance :: Maybe Int
, syndromeTable :: SyndromeTable n k f
}
natToInt :: forall k. KnownNat k => Proxy k -> Int
natToInt = fromInteger . natVal
instance forall n k f. (Eq f, Fractional f, KnownNat n, KnownNat k, k <= n)
=> Eq (LinearCode n k f) where
c == d = standardFormGenerator c == standardFormGenerator d
instance forall n k f.
(KnownNat n, KnownNat k, KnownNat (Characteristic f))
=> Show (LinearCode n k f) where
show LinearCode{distance=md} =
'[':show n<>","<>show k<>dist<>"]_"<>show c<>"-Code"
where c = char (Proxy :: Proxy f)
n = natToInt @n Proxy
k = natToInt @k Proxy
dist = maybe "" (\d -> ',':show d) md
instance forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> Bounded (LinearCode n k f) where
minBound = trivialCode
maxBound = codeFromAD (Just 1) $ matrix (const $ last elts)
randomPermMatrix :: forall g n r. (KnownNat n, Num r, RandomGen g)
=> g -> (Matrix n n r, g)
randomPermMatrix g =
let n = natToInt @n Proxy
delta i j = if i == j then 1 else 0
(g1,g2) = split g
perm = shuffle' [1..n] n g1
in (fromLists [ [ delta i (perm !! (j-1))
| j <- [1..n] ]
| i <- [1..n] ],g2)
randomStandardFormCode :: forall n k f g.
( KnownNat n, KnownNat k, k <= n
, Eq f, FinSet f, Num f, Ord f, Random f, RandomGen g)
=> g -> (LinearCode n k f, g)
randomStandardFormCode = first codeFromA . randomAMatrix
where
randomAMatrix :: RandomGen g => g -> (Matrix k (n-k) f,g)
randomAMatrix = random
instance forall n k f.
( KnownNat n, KnownNat k, k <= n
, Eq f, FinSet f, Num f, Ord f, Random f)
=> Random (LinearCode n k f) where
random g = uncurry shuffleCode $ randomStandardFormCode g
randomR (hc,lc) g =
let k = natToInt @k Proxy
extractA = submatrix 1 k . generatorMatrix
(rmat,g2) = randomR (extractA hc, extractA lc) g
rcode = codeFromA rmat
in shuffleCode rcode g2
standardForm :: forall n k f.
(Eq f, Fractional f, KnownNat n, KnownNat k, k <= n)
=> Generator n k f -> Generator n k f
standardForm = rref
standardFormGenerator :: forall n k f.
(Eq f, Fractional f, KnownNat n, KnownNat k, k <= n)
=> LinearCode n k f -> Generator n k f
standardFormGenerator = standardForm . generatorMatrix
codeLength :: forall n k f. KnownNat n => LinearCode n k f -> Int
codeLength _ = natToInt @n Proxy
rank :: forall n k f. KnownNat k => LinearCode n k f -> Int
rank _ = natToInt @k Proxy
weight :: forall f m. (Eq f, Num f, Functor m, Foldable m) => m f -> Int
weight = sum . fmap (\x -> if x==0 then 0 else 1)
codeFromA :: forall k n f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> Matrix k (n-k) f
-> LinearCode n k f
codeFromA = codeFromAD Nothing
codeFromAD :: forall k n f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> Maybe Int
-> Matrix k (n-k) f
-> LinearCode n k f
codeFromAD d a = recalcSyndromeTable LinearCode
{ generatorMatrix = identity <|> a
, checkMatrix = (-transpose a) <|> identity
, distance = d
, syndromeTable = undefined
}
encode :: forall n k f. Num f => LinearCode n k f -> Vector k f -> Vector n f
encode code vs = vs .* generatorMatrix code
allVectors :: forall n f. (KnownNat n, FinSet f, Num f, Eq f) => [Vector n f]
allVectors = fromList <$> allVectorsI (natToInt @n Proxy)
allVectorsI :: forall f. (FinSet f, Num f, Eq f) => Int -> [[f]]
allVectorsI n = iterate addDim [[]] !! n
where addDim vs = [ x:v | v <- vs, x <- elts ]
fullVectors :: forall n f. (KnownNat n, FinSet f, Num f, Eq f) => [Vector n f]
fullVectors = fromList <$> fullVectorsI (natToInt @n Proxy)
fullVectorsI :: forall f. (FinSet f, Num f, Eq f) => Int -> [[f]]
fullVectorsI n = iterate addDim [[]] !! n
where addDim vs = [ x:v | v <- vs, x <- elts, x /= 0 ]
hammingWords :: forall n f. (KnownNat n, FinSet f, Num f, Eq f)
=> Int -> [Vector n f]
hammingWords w = fromList <$> shuffledVecs
where
n = natToInt @n Proxy
orderedVecs :: [[f]]
orderedVecs = (++) (replicate (n-w) 0) <$> fullVectorsI w
shuffledVecs :: [[f]]
shuffledVecs = orderedVecs >>= permutations
lighterWords :: forall n f. (KnownNat n, FinSet f, Num f, Eq f)
=> Int -> [Vector n f]
lighterWords w = concat [ hammingWords l | l <- [1..w] ]
codewords :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Num f, Eq f, FinSet f)
=> LinearCode n k f -> [Vector n f]
codewords c = map (encode c) allVectors
syndrome :: forall n k f. Num f
=> LinearCode n k f -> Vector n f -> Syndrome n k f
syndrome c w = w .* transpose (checkMatrix c)
syndromeDecode :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Ord f, Num f)
=> LinearCode n k f -> Vector n f -> Maybe (Vector n f)
syndromeDecode c w =
let syn = syndrome c w
e = M.lookup syn $ syndromeTable c
in (w+) <$> e
decode :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Ord f, Num f)
=> LinearCode n k f -> Vector n f -> Maybe (Vector n f)
decode = syndromeDecode
type Syndrome n k f = Vector (n-k) f
type SyndromeTable n k f = M.Map (Syndrome n k f) (Vector n f)
calcSyndromeTable :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f -> SyndromeTable n k f
calcSyndromeTable c = M.fromListWith minWt allSyndromes
where minWt x y = if weight x < weight y then x else y
n = natToInt $ Proxy @n
k = natToInt $ Proxy @k
w = maybe (n-k+1) (\d -> div (d-1) 2) $ distance c
allSyndromes :: [(Syndrome n k f, Vector n f)]
allSyndromes = [(syndrome c e,e) | e <- lighterWords w]
recalcSyndromeTable :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f -> LinearCode n k f
recalcSyndromeTable c = c { syndromeTable = calcSyndromeTable c }
isCodeword :: forall n k f. (Eq f, Num f, KnownNat n, KnownNat k, k <= n)
=> LinearCode n k f -> Vector n f -> Bool
isCodeword c w = syndrome c w == zero
hasError :: forall n k f. (Eq f, Num f, KnownNat n, KnownNat k, k <= n)
=> LinearCode n k f -> Vector n f -> Bool
hasError g = not . isCodeword g
dualCode :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f -> LinearCode n (n-k) f
dualCode = dualCodeD Nothing
dualCodeD :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> Maybe Int
-> LinearCode n k f -> LinearCode n (n-k) f
dualCodeD d c = recalcSyndromeTable
LinearCode { generatorMatrix = checkMatrix c
, checkMatrix = generatorMatrix c
, distance = d
, syndromeTable = undefined
}
permuteCode :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f -> Matrix n n f -> LinearCode n k f
permuteCode c p = recalcSyndromeTable
LinearCode { generatorMatrix = generatorMatrix c .* p
, checkMatrix = checkMatrix c .* p
, distance = distance c
, syndromeTable = undefined
}
shuffleCode :: forall n k f g.
(KnownNat n, KnownNat k, k <= n, RandomGen g, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f -> g -> (LinearCode n k f, g)
shuffleCode c g =
let (p,g') = randomPermMatrix g
in (permuteCode c p, g')
extendCode :: forall n k f r.
(KnownNat n, KnownNat k, KnownNat r, k <= n, 1 <= r, k <= n+r
, Num f, Ord f, FinSet f)
=> LinearCode n k f -> LinearCode (n+r) k f
extendCode c = recalcSyndromeTable LinearCode
{ generatorMatrix = generatorMatrix c <|> zero :: Generator (n+r) k f
, checkMatrix = (checkMatrix c <|> (zero :: Matrix (n-k) r f))
<->
((zero :: Matrix r n f) <|> (identity :: Matrix r r f))
, distance = distance c
, syndromeTable = undefined
}
type BinaryCode n k = LinearCode n k F2
trivialCode :: forall n k f.
(KnownNat n, KnownNat k, k <= n, Eq f, FinSet f, Num f, Ord f)
=> LinearCode n k f
trivialCode = codeFromA (zero :: Matrix k (n-k) f)
simplex :: forall k p s.
( KnownNat s, KnownNat k , IntegerAsType p
, 1 <= s^k, k <= s^k, 1+k <= s^k, Size (Fp p) ~ s)
=> LinearCode (s^k-1) k (Fp p)
simplex = codeFromA . transpose $ fromLists nonUnit
where
k = natToInt @k Proxy
nonUnit = filter ((>1) . weight) $ allVectorsI k
hamming :: (KnownNat m, 2 <= m, m <= 2^m, 1+m <= 2^m)
=> LinearCode (2^m-1) (2^m-m-1) F2
hamming = dualCodeD (Just 3) simplex
golay :: LinearCode 23 12 F2
golay = codeFromAD (Just 7) golayA
where
golayA = fromList
[0,1,1,1,1,1,1,1,1,1,1
,1,1,1,0,1,1,1,0,0,0,1
,1,1,0,1,1,1,0,0,0,1,0
,1,0,1,1,1,0,0,0,1,0,1
,1,1,1,1,0,0,0,1,0,1,1
,1,1,1,0,0,0,1,0,1,1,0
,1,1,0,0,0,1,0,1,1,0,1
,1,0,0,0,1,0,1,1,0,1,1
,1,0,0,1,0,1,1,0,1,1,1
,1,0,1,0,1,1,0,1,1,1,0
,1,1,0,1,1,0,1,1,1,0,0
,1,0,1,1,0,1,1,1,0,0,0
]
eVec :: forall n f. (KnownNat n, Num f) => Int -> Vector n f
eVec i = fromList $ replicate (i-1) 0 ++ 1 : replicate (n-i) 0
where
n = natToInt @n Proxy
e1 :: forall n f. (KnownNat n, Num f) => Vector n f
e1 = eVec 1
e2 :: forall n f. (KnownNat n, Num f) => Vector n f
e2 = eVec 2
e3 :: forall n f. (KnownNat n, Num f) => Vector n f
e3 = eVec 3
e4 :: forall n f. (KnownNat n, Num f) => Vector n f
e4 = eVec 4
e5 :: forall n f. (KnownNat n, Num f) => Vector n f
e5 = eVec 5
e6 :: forall n f. (KnownNat n, Num f) => Vector n f
e6 = eVec 6
e7 :: forall n f. (KnownNat n, Num f) => Vector n f
e7 = eVec 7
e8 :: forall n f. (KnownNat n, Num f) => Vector n f
e8 = eVec 8
e9 :: forall n f. (KnownNat n, Num f) => Vector n f
e9 = eVec 9
e10 :: forall n f. (KnownNat n, Num f) => Vector n f
e10 = eVec 10