{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DerivingVia #-}
module Numeric.YHSeq.V0201 where
import Prelude
import Data.Monoid (Sum (..))
import Data.IntSet ( IntSet )
import qualified Data.IntSet as S
import Data.Vector ( Vector )
import qualified Data.Vector as V
genVec :: (Ord i, Integral i) => i -> (i -> a) -> Vector a
genVec x f = case x `compare` 0 of
LT -> undefined
EQ -> V.empty
GT -> V.map f (V.enumFromTo 1 x)
newtype Sequence = Sequence { unSequence :: Vector Int }
deriving stock (Eq, Ord, Show, Read)
deriving newtype (Semigroup, Monoid)
ixSeq :: Sequence -> Int -> Int
ixSeq s x = unSequence s V.! (x - 1)
makeSeqFromList :: [Int] -> Sequence
makeSeqFromList sl = Sequence (V.fromList sl)
newtype Difference = Difference { unDifference :: Int }
deriving stock (Eq, Ord, Bounded)
deriving newtype (Enum, Show, Read, Num, Real, Integral)
deriving (Semigroup, Monoid) via Sum Int
newtype Index = Index { unIndex :: Int }
deriving stock (Eq, Ord, Bounded)
deriving newtype (Enum, Show, Read, Num, Real, Integral)
deriving (Semigroup, Monoid) via Sum Int
newtype IndexSet = IndexSet { unIndexSet :: IntSet }
deriving stock (Eq, Ord)
deriving newtype (Show, Read, Semigroup, Monoid)
newtype Depth = Depth { unDepth :: Int }
deriving stock (Eq, Ord, Bounded)
deriving newtype (Enum, Show, Read, Num, Real, Integral)
deriving (Semigroup, Monoid) via Sum Int
data Mountain = Mountain
{
sMt :: Int
,
dMt :: Vector (Vector Difference)
,
pMt :: Vector (Vector Index)
,
aMt :: Vector (Vector IndexSet)
} deriving stock (Eq, Ord, Show, Read)
ixMtToDiff :: Mountain -> Index -> Depth -> Difference
ixMtToDiff z x n = dMt z V.! (unIndex x - 1) V.! (unDepth n - 1)
ixMtToPaet :: Mountain -> Index -> Depth -> Index
ixMtToPaet z x n = pMt z V.! (unIndex x - 1) V.! (unDepth n - 1)
ixMtToAnce :: Mountain -> Index -> Depth -> IndexSet
ixMtToAnce z x n = aMt z V.! (unIndex x - 1) V.! (unDepth n - 1)
calcDiffOnMtFromSeqWiM :: Mountain -> Sequence -> Index -> Depth -> Difference
calcDiffOnMtFromSeqWiM z s x n = case n `compare` 1 of
LT -> undefined
EQ -> Difference (s `ixSeq` unIndex x)
GT -> case ixMtToPaet z x (n - 1) `compare` 0 of
LT -> undefined
EQ -> 0
GT -> case ixMtToDiff z (ixMtToPaet z x (n - 1)) (n - 1) `compare` 0 of
LT -> undefined
EQ -> 0
GT -> ixMtToDiff z x (n - 1) - ixMtToDiff z (ixMtToPaet z x (n - 1)) (n - 1)
calcPaetOnMtFromSeqWiM :: Mountain -> Index -> Depth -> Index
calcPaetOnMtFromSeqWiM z x n = calcPaetOnMtWiM' (x - 1)
where
calcPaetOnMtWiM' :: Index -> Index
calcPaetOnMtWiM' p = case p `compare` 0 of
LT -> undefined
EQ -> 0
GT -> if ixMtToDiff z p n < ixMtToDiff z x n && isAnceAtSh z x n p
then p
else calcPaetOnMtWiM' (p - 1)
calcAnceOnMtFromSeqWiM :: Mountain -> Index -> Depth -> IndexSet
calcAnceOnMtFromSeqWiM z x n = case ixMtToPaet z x n `compare` 0 of
LT -> undefined
EQ -> IndexSet (S.singleton (unIndex x))
GT -> IndexSet (S.insert (unIndex x) (unIndexSet (ixMtToAnce z (ixMtToPaet z x n) n)))
isAnceAtSh :: Mountain -> Index -> Depth -> Index -> Bool
isAnceAtSh z x n p = case n `compare` 1 of
LT -> undefined
EQ -> True
GT -> unIndex p `S.member` unIndexSet (ixMtToAnce z x (n - 1))
calcMtFromSeq :: Sequence -> Mountain
calcMtFromSeq s =
let
l = V.length (unSequence s)
z = Mountain
{ sMt = l
, dMt = genVec l (\x -> genVec (l + 1) (\n -> calcDiffOnMtFromSeqWiM z s (Index x) (Depth n)))
, pMt = genVec l (\x -> genVec (l + 1) (\n -> calcPaetOnMtFromSeqWiM z (Index x) (Depth n)))
, aMt = genVec l (\x -> genVec (l + 1) (\n -> calcAnceOnMtFromSeqWiM z (Index x) (Depth n)))
}
in
z
newtype Class = Class { unClass :: Int }
deriving stock (Eq, Ord, Bounded)
deriving newtype (Enum, Show, Read, Num, Real, Integral)
deriving (Semigroup, Monoid) via Sum Int
data CofType = IsZero | IsSucc | IsLim Class
deriving stock (Eq, Ord, Show, Read)
instance Bounded CofType where
minBound = IsZero
maxBound = IsLim maxBound
calcBottom :: Mountain -> Index -> Depth
calcBottom z x = calcBottom' 0
where
calcBottom' :: Depth -> Depth
calcBottom' n = case ixMtToDiff z x (n + 1) `compare` 0 of
LT -> undefined
EQ -> n
GT -> calcBottom' (n + 1)
calcCofType :: Mountain -> CofType
calcCofType z = case sMt z `compare` 0 of
LT -> undefined
EQ -> IsZero
GT -> case ixMtToPaet z (Index (sMt z)) (calcBottom z (Index (sMt z))) `compare` 0 of
LT -> undefined
EQ -> IsSucc
GT -> IsLim (Class (unDifference (ixMtToDiff z (Index (sMt z)) (calcBottom z (Index (sMt z))))))
data DPN = DPN
{ sDPN :: Int
, dDPN :: Vector Difference
, pDPN :: Vector (Vector Index)
, nDPN :: Vector Depth
} deriving stock (Eq, Ord, Show, Read)
ixDpnToDiff :: DPN -> Index -> Difference
ixDpnToDiff z x = dDPN z V.! (unIndex x - 1)
ixDpnToPaet :: DPN -> Index -> Vector Index
ixDpnToPaet z x = pDPN z V.! (unIndex x - 1)
ixDpnToNpth :: DPN -> Index -> Depth
ixDpnToNpth z x = nDPN z V.! (unIndex x - 1)
calcLimitDepth :: Mountain -> Depth
calcLimitDepth z = calcBottom z (Index (sMt z)) - 1
calcMaxDepth :: Mountain -> Index -> Depth
calcMaxDepth z x = calcBottom z x `min` calcLimitDepth z
calcDiffOnDpn :: Mountain -> Index -> Difference
calcDiffOnDpn z x = ixMtToDiff z x (calcMaxDepth z x)
calcPaetOnDpn :: Mountain -> Index -> Vector Index
calcPaetOnDpn z x = genVec (calcMaxDepth z x) (\n -> ixMtToPaet z x n)
calcNpthOnDpn :: Mountain -> Index -> Depth
calcNpthOnDpn z x = calcMaxDepth z x
calcDpn :: Mountain -> DPN
calcDpn z = DPN
{ sDPN = sMt z
, dDPN = genVec (sMt z) (\x -> calcDiffOnDpn z (Index x))
, pDPN = genVec (sMt z) (\x -> calcPaetOnDpn z (Index x))
, nDPN = genVec (sMt z) (\x -> calcNpthOnDpn z (Index x))
}
calcBadRoot :: Mountain -> Index
calcBadRoot z = ixMtToPaet z (Index (sMt z)) (calcBottom z (Index (sMt z)) - 1)
calcDiffAtExp :: Mountain -> Index -> Difference
calcDiffAtExp z x =
let
xz = sMt z
rz = unIndex (calcBadRoot z)
in case x >= 1 of
False -> undefined
True -> case x >= Index rz of
False -> calcDiffOnDpn z x
True ->
let
m = (unIndex x - rz) `div` (xz - rz)
y = Index ((unIndex x - rz) `mod` (xz - rz) + 1)
in
calcDiffOnDpn z ((Index rz - 1) + y)
calcPaetAtExp :: Mountain -> Index -> Vector Index
calcPaetAtExp z x =
let
xz = sMt z
rz = unIndex (calcBadRoot z)
in case x >= 1 of
False -> undefined
True -> case x >= Index rz of
False -> calcPaetOnDpn z x
True ->
let
m = (unIndex x - rz) `div` (xz - rz)
y = Index ((unIndex x - rz) `mod` (xz - rz) + 1)
in
case m `compare` 0 of
LT -> undefined
EQ -> calcPaetOnDpn z ((Index rz - 1) + y)
GT -> case y `compare` 1 of
LT -> undefined
EQ -> genVec (calcNpthOnDpn z ((Index rz - 1) + y)) (\n ->
if rz `S.member` unIndexSet (ixMtToAnce z ((Index rz - 1) + y) n)
then ixMtToPaet z (Index xz) n + Index ((xz - rz) * (m - 1))
else ixMtToPaet z (Index xz) n)
GT -> genVec (calcNpthOnDpn z ((Index rz - 1) + y)) (\n ->
if rz `S.member` unIndexSet (ixMtToAnce z ((Index rz - 1) + y) n)
then ixMtToPaet z ((Index rz - 1) + y) n + Index ((xz - rz) * m)
else ixMtToPaet z ((Index rz - 1) + y) n)
calcNpthAtExp :: Mountain -> Index -> Depth
calcNpthAtExp z x =
let
xz = sMt z
rz = unIndex (calcBadRoot z)
in case x >= 1 of
False -> undefined
True -> case x >= Index rz of
False -> calcNpthOnDpn z x
True ->
let
m = (unIndex x - rz) `div` (xz - rz)
y = Index ((unIndex x - rz) `mod` (xz - rz) + 1)
in
calcNpthOnDpn z ((Index rz - 1) + y)
expandMtAtLim1 :: Mountain -> Int -> DPN
expandMtAtLim1 z n =
let
xz = sMt z
rz = unIndex (calcBadRoot z)
in
DPN
{ sDPN = (rz - 1) + (xz - rz) * (n + 1)
, dDPN = genVec ((rz - 1) + (xz - rz) * (n + 1)) (\x -> calcDiffAtExp z (Index x))
, pDPN = genVec ((rz - 1) + (xz - rz) * (n + 1)) (\x -> calcPaetAtExp z (Index x))
, nDPN = genVec ((rz - 1) + (xz - rz) * (n + 1)) (\x -> calcNpthAtExp z (Index x))
}
calcDiffOnMtFromDpnWiM :: Mountain -> DPN -> Index -> Depth -> Difference
calcDiffOnMtFromDpnWiM zm zd x n = case n >= 1 of
False -> undefined
True -> case n >= ixDpnToNpth zd x of
False -> ixMtToDiff zm (ixMtToPaet zm x n) n + ixMtToDiff zm x (n + 1)
True -> case n >= ixDpnToNpth zd x + 1 of
False -> ixDpnToDiff zd x
True -> 0
calcPaetOnMtFromDpnWiM :: DPN -> Index -> Depth -> Index
calcPaetOnMtFromDpnWiM zd x n = case n >= 1 of
False -> undefined
True -> case n >= (ixDpnToNpth zd x + 1) - Depth (V.length (ixDpnToPaet zd x)) of
False -> ixDpnToPaet zd x V.! 0
True -> case n >= ixDpnToNpth zd x + 1 of
False -> ixDpnToPaet zd x V.! (unDepth n - (unDepth (ixDpnToNpth zd x + 1) - V.length (ixDpnToPaet zd x)))
True -> x - 1
calcAnceOnMtFromDpnWiM :: Mountain -> Index -> Depth -> IndexSet
calcAnceOnMtFromDpnWiM zm x n = case ixMtToPaet zm x n `compare` 0 of
LT -> undefined
EQ -> IndexSet (S.singleton (unIndex x))
GT -> IndexSet (S.insert (unIndex x) (unIndexSet (ixMtToAnce zm (ixMtToPaet zm x n) n)))
calcMtFromDpn :: DPN -> Mountain
calcMtFromDpn zd =
let
l = sDPN zd
zm = Mountain
{ sMt = l
, dMt = genVec l (\x -> genVec (l + 1) (\n -> calcDiffOnMtFromDpnWiM zm zd (Index x) (Depth n)))
, pMt = genVec l (\x -> genVec (l + 1) (\n -> calcPaetOnMtFromDpnWiM zd (Index x) (Depth n)))
, aMt = genVec l (\x -> genVec (l + 1) (\n -> calcAnceOnMtFromDpnWiM zm (Index x) (Depth n)))
}
in
zm
calcSeqFromMt :: Mountain -> Sequence
calcSeqFromMt z = Sequence (genVec (sMt z) (\x -> unDifference (ixMtToDiff z (Index x) 1)))
expandSeqAtLim1 :: Sequence -> Int -> Sequence
expandSeqAtLim1 s n = calcSeqFromMt (calcMtFromDpn (expandMtAtLim1 (calcMtFromSeq s) n))
data ExpandingError
= OutOfIndexOnFunSeq
| OutOfClass
deriving (Eq, Ord, Bounded, Enum, Show, Read)
expandSeq :: Sequence -> Int -> Either ExpandingError Sequence
expandSeq s n = case calcCofType (calcMtFromSeq s) of
IsZero -> Left OutOfIndexOnFunSeq
IsSucc -> case n `compare` 0 of
LT -> undefined
EQ -> Right (Sequence (genVec (V.length (unSequence s) - 1) (\x -> ixSeq s x)))
GT -> Left OutOfIndexOnFunSeq
IsLim c -> case c `compare` 1 of
LT -> undefined
EQ -> Right (expandSeqAtLim1 s n)
GT -> Left OutOfClass
makeListFromSeq :: Sequence -> [Int]
makeListFromSeq s = V.toList (unSequence s)
expandList :: [Int] -> Int -> Either ExpandingError [Int]
expandList s n = fmap makeListFromSeq (expandSeq (makeSeqFromList s) n)