{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Codec.QRCode.Mode.Mixed
  ( mixed
  ) where

import           Codec.QRCode.Base

import qualified Data.DList                           as DL
import qualified Data.Map.Strict                      as M

import qualified Codec.QRCode.Data.ByteStreamBuilder  as BSB
import           Codec.QRCode.Data.QRSegment.Internal
import           Codec.QRCode.Data.Result
import           Codec.QRCode.Data.TextEncoding
import           Codec.QRCode.Data.ToInput
import           Codec.QRCode.Data.Version
import           Codec.QRCode.Mode.Alphanumeric
import           Codec.QRCode.Mode.Byte
import           Codec.QRCode.Mode.ECI
import           Codec.QRCode.Mode.Kanji
import           Codec.QRCode.Mode.Numeric

-- | Encode a string using any mode that seems fit, will encode the input in parts, each as
--   `numeric`, `alphanumeric`, `kanji` and `Codec.QRCode.Mode.Byte.text` based on the contents.
--
--   Please refer to the specific documentations for details.
--
--   Should result in the shortest encoded data.

mixed :: ToText a => TextEncoding -> a -> Result QRSegment
mixed :: TextEncoding -> a -> Result QRSegment
mixed TextEncoding
te a
s =
  case [Char]
s' of
    [] ->
      QRSegment -> Result QRSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteStreamBuilder -> QRSegment
constStream ByteStreamBuilder
forall a. Monoid a => a
mempty)
    [Char]
_ ->
      case TextEncoding
te of
        TextEncoding
Iso8859_1                 -> Result QRSegment
encIso1
        TextEncoding
Utf8WithoutECI            -> Result QRSegment
encUtf8
        TextEncoding
Utf8WithECI               -> Result QRSegment
encUtf8Eci
        TextEncoding
Iso8859_1OrUtf8WithoutECI -> Result QRSegment
encIso1 Result QRSegment -> Result QRSegment -> Result QRSegment
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Result QRSegment
encUtf8
        TextEncoding
Iso8859_1OrUtf8WithECI    -> Result QRSegment
encIso1 Result QRSegment -> Result QRSegment -> Result QRSegment
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Result QRSegment
encUtf8Eci
  where
    encIso1 :: Result QRSegment
    encIso1 :: Result QRSegment
encIso1 = EightBitEncoding -> [TypedSegment] -> QRSegment
run EightBitEncoding
EncISO1 ([TypedSegment] -> QRSegment)
-> Result [TypedSegment] -> Result QRSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Char] -> Result [TypedSegment]
toIso1 Bool
ci [Char]
s'
    encUtf8 :: Result QRSegment
    encUtf8 :: Result QRSegment
encUtf8 = EightBitEncoding -> [TypedSegment] -> QRSegment
run EightBitEncoding
EncUtf8 ([TypedSegment] -> QRSegment)
-> Result [TypedSegment] -> Result QRSegment
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> [Char] -> Result [TypedSegment]
toUtf8 Bool
ci [Char]
s'
    encUtf8Eci :: Result QRSegment
    encUtf8Eci :: Result QRSegment
encUtf8Eci = QRSegment -> QRSegment -> QRSegment
forall a. Semigroup a => a -> a -> a
(<>) (QRSegment -> QRSegment -> QRSegment)
-> Result QRSegment -> Result (QRSegment -> QRSegment)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Result QRSegment
eci Int
26 Result (QRSegment -> QRSegment)
-> Result QRSegment -> Result QRSegment
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Result QRSegment
encUtf8
    s' :: [Char]
    s' :: [Char]
s' = a -> [Char]
forall a. ToText a => a -> [Char]
toString a
s
    ci :: Bool
ci = a -> Bool
forall a. ToText a => a -> Bool
isCI a
s

--
-- Internal types
--

data Type
  = TNumeric
  | TAlphanumeric
  | TKanji
  | T8Bit
  deriving (Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq)

data EightBitEncoding
  = EncUtf8
  | EncISO1
  deriving (EightBitEncoding -> EightBitEncoding -> Bool
(EightBitEncoding -> EightBitEncoding -> Bool)
-> (EightBitEncoding -> EightBitEncoding -> Bool)
-> Eq EightBitEncoding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EightBitEncoding -> EightBitEncoding -> Bool
$c/= :: EightBitEncoding -> EightBitEncoding -> Bool
== :: EightBitEncoding -> EightBitEncoding -> Bool
$c== :: EightBitEncoding -> EightBitEncoding -> Bool
Eq)

data Segment
  = S
    !Int -- Number of characters in the string
    !Int -- Number of bytes required to encode the string segment in `EightBitEncoding`
         -- (never used for Kanji characters when in `EncISO1` mode)
    !(DL.DList Char) -- String of the Segment

instance Semigroup Segment where
  {-# INLINE (<>) #-}
  (S Int
i1 Int
j1 DList Char
s1) <> :: Segment -> Segment -> Segment
<> (S Int
i2 Int
j2 DList Char
s2) = Int -> Int -> DList Char -> Segment
S (Int
i1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
i2) (Int
j1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
j2) (DList Char
s1 DList Char -> DList Char -> DList Char
forall a. DList a -> DList a -> DList a
`DL.append` DList Char
s2)

type TypedSegment = (Type, Segment)

--
-- parse input
--

toIso1 :: Bool -> String -> Result [TypedSegment]
toIso1 :: Bool -> [Char] -> Result [TypedSegment]
toIso1 Bool
ci = (Char -> Result TypedSegment) -> [Char] -> Result [TypedSegment]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Char -> Result TypedSegment
toSeg
  where
    toSeg :: Char -> Result TypedSegment
    toSeg :: Char -> Result TypedSegment
toSeg Char
c =
      let
        tyc :: Type
tyc = Bool -> Char -> Type
typeOfChar Bool
ci Char
c
        oc :: Int
oc = Char -> Int
ord Char
c
      in
        if Type
tyc Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
T8Bit Bool -> Bool -> Bool
&& (Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
256) -- in case of numeric, aplhanumeric or kanji it's aready proven that it's a valid char
          then Result TypedSegment
forall (f :: * -> *) a. Alternative f => f a
empty
          else TypedSegment -> Result TypedSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
tyc, Int -> Int -> DList Char -> Segment
S Int
1 Int
1 (Char -> DList Char
forall a. a -> DList a
DL.singleton Char
c))

toUtf8 :: Bool -> String -> Result [TypedSegment]
toUtf8 :: Bool -> [Char] -> Result [TypedSegment]
toUtf8 Bool
ci = (Char -> Result TypedSegment) -> [Char] -> Result [TypedSegment]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Char -> Result TypedSegment
toSeg
  where
    toSeg :: Char -> Result TypedSegment
    toSeg :: Char -> Result TypedSegment
toSeg Char
c =
      let
        tyc :: Type
tyc = Bool -> Char -> Type
typeOfChar Bool
ci Char
c
        oc :: Int
oc = Char -> Int
ord Char
c
      in
        case () of
          ()
_ | Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<        Int
0 -> Result TypedSegment
forall (f :: * -> *) a. Alternative f => f a
empty
          ()
_ | Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<     Int
0x80 -> TypedSegment -> Result TypedSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
tyc, Int -> Int -> DList Char -> Segment
S Int
1 Int
1 (Char -> DList Char
forall a. a -> DList a
DL.singleton Char
c))
          ()
_ | Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<    Int
0x800 -> TypedSegment -> Result TypedSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
tyc, Int -> Int -> DList Char -> Segment
S Int
1 Int
2 (Char -> DList Char
forall a. a -> DList a
DL.singleton Char
c))
          ()
_ | Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
0x10000 -> TypedSegment -> Result TypedSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
tyc, Int -> Int -> DList Char -> Segment
S Int
1 Int
3 (Char -> DList Char
forall a. a -> DList a
DL.singleton Char
c))
          ()
_ | Int
oc Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x110000 -> TypedSegment -> Result TypedSegment
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
tyc, Int -> Int -> DList Char -> Segment
S Int
1 Int
4 (Char -> DList Char
forall a. a -> DList a
DL.singleton Char
c))
          ()
_ | Bool
otherwise     -> Result TypedSegment
forall (f :: * -> *) a. Alternative f => f a
empty

typeOfChar :: Bool -> Char -> Type
typeOfChar :: Bool -> Char -> Type
typeOfChar Bool
ci Char
c
  | Char -> Bool
isDigit Char
c = Type
TNumeric
  | Char
c Char -> Map Char Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Bool -> Map Char Int
alphanumericMap Bool
ci = Type
TAlphanumeric
  | Char
c Char -> Map Char Word16 -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Char Word16
kanjiMap = Type
TKanji
  | Bool
otherwise = Type
T8Bit

--
-- optimise segments and encode output
--

run :: EightBitEncoding -> [TypedSegment] -> QRSegment
run :: EightBitEncoding -> [TypedSegment] -> QRSegment
run EightBitEncoding
te [TypedSegment]
sg = (VersionRange -> Result ByteStreamBuilder) -> QRSegment
QRSegment ((VersionRange -> Result ByteStreamBuilder) -> QRSegment)
-> (VersionRange -> Result ByteStreamBuilder) -> QRSegment
forall a b. (a -> b) -> a -> b
$ \VersionRange
vr -> VersionRange -> [TypedSegment] -> Result ByteStreamBuilder
go VersionRange
vr [TypedSegment]
sg'
  where
    go :: VersionRange -> [TypedSegment] -> Result BSB.ByteStreamBuilder
    go :: VersionRange -> [TypedSegment] -> Result ByteStreamBuilder
go VersionRange
vr =
      ([ByteStreamBuilder] -> ByteStreamBuilder)
-> Result [ByteStreamBuilder] -> Result ByteStreamBuilder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteStreamBuilder] -> ByteStreamBuilder
forall a. Monoid a => [a] -> a
mconcat (Result [ByteStreamBuilder] -> Result ByteStreamBuilder)
-> ([TypedSegment] -> Result [ByteStreamBuilder])
-> [TypedSegment]
-> Result ByteStreamBuilder
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (TypedSegment -> Result ByteStreamBuilder)
-> [TypedSegment] -> Result [ByteStreamBuilder]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (EightBitEncoding
-> VersionRange -> TypedSegment -> Result ByteStreamBuilder
encode EightBitEncoding
te VersionRange
vr) ([TypedSegment] -> Result [ByteStreamBuilder])
-> ([TypedSegment] -> [TypedSegment])
-> [TypedSegment]
-> Result [ByteStreamBuilder]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      EightBitEncoding
-> VersionRange -> [TypedSegment] -> [TypedSegment]
mergeTwo EightBitEncoding
te VersionRange
vr ([TypedSegment] -> [TypedSegment])
-> ([TypedSegment] -> [TypedSegment])
-> [TypedSegment]
-> [TypedSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int
-> EightBitEncoding
-> VersionRange
-> [TypedSegment]
-> [TypedSegment]
mergeMiddle Int
3 EightBitEncoding
te VersionRange
vr ([TypedSegment] -> [TypedSegment])
-> ([TypedSegment] -> [TypedSegment])
-> [TypedSegment]
-> [TypedSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int
-> EightBitEncoding
-> VersionRange
-> [TypedSegment]
-> [TypedSegment]
mergeMiddle Int
2 EightBitEncoding
te VersionRange
vr ([TypedSegment] -> [TypedSegment])
-> ([TypedSegment] -> [TypedSegment])
-> [TypedSegment]
-> [TypedSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int
-> EightBitEncoding
-> VersionRange
-> [TypedSegment]
-> [TypedSegment]
mergeMiddle Int
1 EightBitEncoding
te VersionRange
vr
    sg' :: [TypedSegment]
    sg' :: [TypedSegment]
sg' = [TypedSegment] -> [TypedSegment]
mergeEqual [TypedSegment]
sg

--
-- encode output
--

encode :: EightBitEncoding -> VersionRange -> TypedSegment -> Result BSB.ByteStreamBuilder
encode :: EightBitEncoding
-> VersionRange -> TypedSegment -> Result ByteStreamBuilder
encode EightBitEncoding
te VersionRange
vr (Type
ty, S Int
i Int
j DList Char
s) =
  case (Type
ty, EightBitEncoding
te) of
    (Type
TNumeric,      EightBitEncoding
_) -> Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
0b0001 Int
i (ByteStreamBuilder -> Result ByteStreamBuilder)
-> Result ByteStreamBuilder -> Result ByteStreamBuilder
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Result ByteStreamBuilder
forall a. ToNumeric a => a -> Result ByteStreamBuilder
numericB (DList Char -> [Char]
forall a. DList a -> [a]
DL.toList DList Char
s)
    (Type
TAlphanumeric, EightBitEncoding
_) -> Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
0b0010 Int
i (ByteStreamBuilder -> Result ByteStreamBuilder)
-> Result ByteStreamBuilder -> Result ByteStreamBuilder
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool -> [Char] -> Result ByteStreamBuilder
alphanumericB Bool
True (DList Char -> [Char]
forall a. DList a -> [a]
DL.toList DList Char
s)
    (Type
T8Bit,   EightBitEncoding
EncISO1) -> Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
0b0100 Int
j ([Word8] -> ByteStreamBuilder
BSB.fromList ([Word8] -> ByteStreamBuilder) -> [Word8] -> ByteStreamBuilder
forall a b. (a -> b) -> a -> b
$ (Char -> Word8) -> [Char] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Char -> Int) -> Char -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord) (DList Char -> [Char]
forall a. DList a -> [a]
DL.toList DList Char
s))
    (Type
T8Bit,   EightBitEncoding
EncUtf8) -> Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
0b0100 Int
j (ByteStreamBuilder -> Result ByteStreamBuilder)
-> Result ByteStreamBuilder -> Result ByteStreamBuilder
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Word8] -> ByteStreamBuilder
BSB.fromList ([Word8] -> ByteStreamBuilder)
-> Result [Word8] -> Result ByteStreamBuilder
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Result [Word8]
encodeUtf8 (DList Char -> [Char]
forall a. DList a -> [a]
DL.toList DList Char
s)
    (Type
TKanji,        EightBitEncoding
_) -> Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
0b1000 Int
i (ByteStreamBuilder -> Result ByteStreamBuilder)
-> Result ByteStreamBuilder -> Result ByteStreamBuilder
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> Result ByteStreamBuilder
kanjiB (DList Char -> [Char]
forall a. DList a -> [a]
DL.toList DList Char
s)
  where
    go :: Int -> Int -> BSB.ByteStreamBuilder -> Result BSB.ByteStreamBuilder
    go :: Int -> Int -> ByteStreamBuilder -> Result ByteStreamBuilder
go Int
mode Int
l ByteStreamBuilder
sb
      | Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
pl) = ByteStreamBuilder -> Result ByteStreamBuilder
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Int -> ByteStreamBuilder
BSB.encodeBits Int
4 Int
mode ByteStreamBuilder -> ByteStreamBuilder -> ByteStreamBuilder
forall a. Semigroup a => a -> a -> a
<> Int -> Int -> ByteStreamBuilder
BSB.encodeBits Int
pl Int
l ByteStreamBuilder -> ByteStreamBuilder -> ByteStreamBuilder
forall a. Semigroup a => a -> a -> a
<> ByteStreamBuilder
sb)
      | Bool
otherwise = Result ByteStreamBuilder
forall (f :: * -> *) a. Alternative f => f a
empty
      where
        pl :: Int
pl = VersionRange -> Type -> Int
pfxLen VersionRange
vr Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
4 -- subtract the 4 bits for the mode from the length of the prefix

--
-- check sub/super relation between types
--

isSuper :: EightBitEncoding -> Type -> Type -> Bool
isSuper :: EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
_       Type
TAlphanumeric Type
TNumeric      = Bool
True
isSuper EightBitEncoding
_       Type
T8Bit         Type
TNumeric      = Bool
True
isSuper EightBitEncoding
_       Type
T8Bit         Type
TAlphanumeric = Bool
True
isSuper EightBitEncoding
EncUtf8 Type
T8Bit         Type
TKanji        = Bool
True
isSuper EightBitEncoding
_       Type
_             Type
_             = Bool
False

commonSuper :: EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper :: EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
_     Type
a       Type
b
  | Type
a Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
b = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
a
commonSuper EightBitEncoding
_       Type
TNumeric      Type
TAlphanumeric = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
TAlphanumeric
commonSuper EightBitEncoding
_       Type
TAlphanumeric Type
TNumeric      = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
TAlphanumeric
commonSuper EightBitEncoding
_       Type
TNumeric      Type
T8Bit         = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
_       Type
T8Bit         Type
TNumeric      = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
_       Type
TAlphanumeric Type
T8Bit         = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
_       Type
T8Bit         Type
TAlphanumeric = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
EncUtf8 Type
TKanji        Type
_             = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
EncUtf8 Type
_             Type
TKanji        = Type -> Maybe Type
forall a. a -> Maybe a
Just Type
T8Bit
commonSuper EightBitEncoding
_       Type
_             Type
_             = Maybe Type
forall a. Maybe a
Nothing

--
-- calculate length of a TypedSegment
--

-- length of prefix (mode and length bits, depends on version range and type)

pfxLen :: VersionRange -> Type -> Int
pfxLen :: VersionRange -> Type -> Int
pfxLen VersionRange
Version1to9   Type
TNumeric      = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
pfxLen VersionRange
Version10to26 Type
TNumeric      = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12
pfxLen VersionRange
Version27to40 Type
TNumeric      = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
14
pfxLen VersionRange
Version1to9   Type
TAlphanumeric = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+  Int
9
pfxLen VersionRange
Version10to26 Type
TAlphanumeric = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
11
pfxLen VersionRange
Version27to40 Type
TAlphanumeric = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
13
pfxLen VersionRange
Version1to9   Type
TKanji        = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+  Int
8
pfxLen VersionRange
Version10to26 Type
TKanji        = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
pfxLen VersionRange
Version27to40 Type
TKanji        = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
12
pfxLen VersionRange
Version1to9   Type
T8Bit         = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+  Int
8
pfxLen VersionRange
Version10to26 Type
T8Bit         = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16
pfxLen VersionRange
Version27to40 Type
T8Bit         = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
16

-- length of the data (depends on type)

encLen :: Type -> Segment -> Int
encLen :: Type -> Segment -> Int
encLen Type
TNumeric      (S Int
i Int
_ DList Char
_) = let (Int
j,Int
k) = Int
i Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
3 in Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Int
0,Int
4,Int
7] [Int] -> Int -> Int
forall a. [a] -> Int -> a
!! Int
k)
encLen Type
TAlphanumeric (S Int
i Int
_ DList Char
_) = let (Int
j,Int
k) = Int
i Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
2 in Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
11 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
6
encLen Type
TKanji        (S Int
i Int
_ DList Char
_) = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
13
encLen Type
T8Bit         (S Int
_ Int
j DList Char
_) = Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8

-- length of a full segment (mode, length and data bits)

pfxEncLen :: VersionRange -> Type -> Segment -> Int
pfxEncLen :: VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
ty Segment
g = VersionRange -> Type -> Int
pfxLen VersionRange
vr Type
ty Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Segment -> Int
encLen Type
ty Segment
g

--
-- functions for merging segments
--

-- merge segments of equal type (not dependent on version range end encoding)

mergeEqual :: [TypedSegment] -> [TypedSegment]
mergeEqual :: [TypedSegment] -> [TypedSegment]
mergeEqual ((Type
t1, Segment
g1):(Type
t2, Segment
g2):[TypedSegment]
xs)
  | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t2 = [TypedSegment] -> [TypedSegment]
mergeEqual ((Type
t1, Segment
g1Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g2)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
mergeEqual (TypedSegment
x:[TypedSegment]
xs) = TypedSegment
xTypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment] -> [TypedSegment]
mergeEqual [TypedSegment]
xs
mergeEqual [] = []

-- merge tree neighboring segments (left, middle and right)

mergeMiddle :: Int -> EightBitEncoding -> VersionRange -> [TypedSegment] -> [TypedSegment]
mergeMiddle :: Int
-> EightBitEncoding
-> VersionRange
-> [TypedSegment]
-> [TypedSegment]
mergeMiddle Int
mt EightBitEncoding
te VersionRange
vr = [TypedSegment] -> [TypedSegment]
go
  where
    go :: [TypedSegment] -> [TypedSegment]
go (e1 :: TypedSegment
e1@(Type
t1, Segment
g1):e2 :: TypedSegment
e2@(Type
t2, Segment
g2):e3 :: TypedSegment
e3@(Type
t3, Segment
g3):[TypedSegment]
xs)
      -- (Phase 1-3) left and right are identical and are a super type of middle
      | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Type
t3 Bool -> Bool -> Bool
&& EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
te Type
t1 Type
t2 =
        if VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t2 Segment
g2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Int
pfxLen VersionRange
vr Type
t1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Type -> Segment -> Int
encLen Type
t1 Segment
g2
          then TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
          else [TypedSegment] -> [TypedSegment]
go ((Type
t1, Segment
g1Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g2Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g3)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
      -- (Phase 2-3) left and right are super of middle, left and right have a common super
      | Int
mt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
te Type
t1 Type
t2 Bool -> Bool -> Bool
&& EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
te Type
t3 Type
t2 Bool -> Bool -> Bool
&& Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t1 Type
t3) =
        let
          g12 :: Segment
g12 = Segment
g1 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g2
          g23 :: Segment
g23 = Segment
g2 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g3
          g123 :: Segment
g123 = Segment
g1 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g2 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g3
          Just Type
tn = EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t1 Type
t3
          x1 :: Int
x1 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t1 Segment
g12 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t3 Segment
g3
          x2 :: Int
x2 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t1 Segment
g1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t2 Segment
g2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t3 Segment
g3
          x3 :: Int
x3 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t1 Segment
g1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t3 Segment
g23
          xn :: Int
xn = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
tn Segment
g123
        in
          if Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x1 Bool -> Bool -> Bool
&& Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x3 Bool -> Bool -> Bool
&& Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
xn
            then TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
            else
              if Int
xn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x1 Bool -> Bool -> Bool
&& Int
xn Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x3
                then [TypedSegment] -> [TypedSegment]
go ((Type
tn, Segment
g123)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
                else
                  if Int
x1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x3
                    then [TypedSegment] -> [TypedSegment]
go ((Type
t1,Segment
g12)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
                    else [TypedSegment] -> [TypedSegment]
go (TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:(Type
t3,Segment
g23)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
      -- (Phase 2-3) left, middle and right have a common super
      | Int
mt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& Maybe Type -> Bool
forall a. Maybe a -> Bool
isJust (EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t2 (Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t1 Type
t3) =
        let
          Just Type
tn = EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t2 (Type -> Maybe Type) -> Maybe Type -> Maybe Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t1 Type
t3
          x2 :: Int
x2 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t1 Segment
g1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t2 Segment
g2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t3 Segment
g3
          g123 :: Segment
g123 = Segment
g1 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g2 Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<> Segment
g3
          xn :: Int
xn = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
tn Segment
g123
        in
          if Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
xn
            then TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
            else [TypedSegment] -> [TypedSegment]
go ((Type
tn, Segment
g123)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
      -- (Phase 3) left and right are super of middle
      | Int
mt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
te Type
t1 Type
t2 Bool -> Bool -> Bool
&& EightBitEncoding -> Type -> Type -> Bool
isSuper EightBitEncoding
te Type
t3 Type
t2 =
        let
          x1 :: Int
x1 = Type -> Segment -> Int
encLen Type
t1 Segment
g2
          x2 :: Int
x2 = VersionRange -> Type -> Int
pfxLen VersionRange
vr Type
t2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Type -> Segment -> Int
encLen Type
t2 Segment
g2
          x3 :: Int
x3 = Type -> Segment -> Int
encLen Type
t3 Segment
g2
        in
          if Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x1 Bool -> Bool -> Bool
&& Int
x2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x3
            then TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
            else
              if Int
x1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x3
                then [TypedSegment] -> [TypedSegment]
go ((Type
t1, Segment
g1Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g2)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:TypedSegment
e3TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
                else [TypedSegment] -> [TypedSegment]
go (TypedSegment
e1TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:(Type
t3, Segment
g2Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g3)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
    go (TypedSegment
e1:[TypedSegment]
xs) = TypedSegment
e1 TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
: [TypedSegment] -> [TypedSegment]
go [TypedSegment]
xs
    go [] = []

-- merge two neighboring segments when they use less space combined
mergeTwo :: EightBitEncoding -> VersionRange -> [TypedSegment] -> [TypedSegment]
mergeTwo :: EightBitEncoding
-> VersionRange -> [TypedSegment] -> [TypedSegment]
mergeTwo EightBitEncoding
te VersionRange
vr = [TypedSegment] -> [TypedSegment]
go
  where
    go :: [TypedSegment] -> [TypedSegment]
go (e1 :: TypedSegment
e1@(Type
t1,Segment
g1):e2 :: TypedSegment
e2@(Type
t2,Segment
g2):[TypedSegment]
xs) =
      case EightBitEncoding -> Type -> Type -> Maybe Type
commonSuper EightBitEncoding
te Type
t1 Type
t2 of
        Just Type
t3 ->
          let
            x12 :: Int
x12 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t1 Segment
g1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t2 Segment
g2
            g12 :: Segment
g12 = Segment
g1Segment -> Segment -> Segment
forall a. Semigroup a => a -> a -> a
<>Segment
g2
            x3 :: Int
x3 = VersionRange -> Type -> Segment -> Int
pfxEncLen VersionRange
vr Type
t3 Segment
g12
          in
            if Int
x12 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
x3
              then TypedSegment
e1 TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
: [TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
              else [TypedSegment] -> [TypedSegment]
go ((Type
t3,Segment
g12)TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
        Maybe Type
Nothing -> TypedSegment
e1 TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
: [TypedSegment] -> [TypedSegment]
go (TypedSegment
e2TypedSegment -> [TypedSegment] -> [TypedSegment]
forall a. a -> [a] -> [a]
:[TypedSegment]
xs)
    go [TypedSegment]
xs = [TypedSegment]
xs