{-# LANGUAGE NamedFieldPuns, DeriveTraversable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  XMonad.Util.History
  Description :   Track history in /O(log n)/ time .
  Copyright    :   ( c ) 2022   
-- License     :  BSD3-style (see LICENSE)
--
  Maintainer   :   @LSLeary ( on github )
-- Stability   :  unstable
-- Portability :  unportable
--
-- Provides 'History', a variation on a LIFO stack with a uniqueness property.
-- In order to achieve the desired asymptotics, the data type is implemented as
-- an ordered Map.
--
-----------------------------------------------------------------------------

module XMonad.Util.History (
  History,
  origin,
  event,
  erase,
  recall,
  ledger,
  transcribe,
  ) where

-- base
import Data.Function (on)
import Text.Read
  ( Read(readPrec, readListPrec), Lexeme(Ident)
  , parens, prec, lexP, step, readListPrecDefault
  )

-- containers
import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as I
import Data.Map (Map)
import qualified Data.Map.Strict as M


  | A history of unique @k@-events with @a@-annotations .
--
    @History k a@ can be considered a ( LIFO ) stack of @(k , a)@ values with the
    property that each @k@ is unique . From this point of view , ' event ' pushes
--   and 'ledger' pops/peeks all.
--
--   The naive implementation has /O(n)/ 'event' and 'erase' due to the
--   uniqueness condition, but we can still use it as a denotation:
--
-- > mu :: History k a -> [(k, a)]
--
    As an opaque data type with strict operations , @History k a@ values are all
--   finite expressions in the core interface: 'origin', 'erase' and 'event'.
    Hence we define @mu@ by structural induction on these three cases .
--
data History k a = History
  { annals   :: !(IntMap (k, a))
  , recorded :: !(Map k Int)
  } deriving (Functor, Foldable, Traversable)

instance (Eq  k, Eq  a) => Eq  (History k a) where (==)    = (==)    `on` ledger
instance (Ord k, Ord a) => Ord (History k a) where compare = compare `on` ledger

instance (Show k, Show a) => Show (History k a) where
  showsPrec d h
    = showParen (d > app_prec)
    $ showString "transcribe "
    . showsPrec (app_prec+1) (ledger h)
    where app_prec = 10

instance (Read k, Read a, Ord k) => Read (History k a) where
  readPrec = parens . prec app_prec $ do
    Ident "transcribe" <- lexP
    l <- step readPrec
    pure (transcribe l)
    where app_prec = 10
  readListPrec = readListPrecDefault


-- | /O(1)/. A history of nothing.
--
-- > mu origin := []
--
origin :: History k a
origin = History I.empty M.empty

-- | /O(log n)/. A new event makes history; its predecessor forgotten.
--
-- > mu (event k a h) := (k, a) : mu (erase k h)
--
event :: Ord k => k -> a -> History k a -> History k a
event k a History{annals,recorded} = History
  { annals   = I.insert ik (k, a) . maybe id I.delete mseen $ annals
  , recorded = recorded'
  }
  where
    ik = maybe 0 (\((i, _), _) -> pred i) (I.minViewWithKey annals)
    (mseen, recorded') = M.insertLookupWithKey (\_ x _ -> x) k ik recorded

-- | /O(log n)/. Erase an event from history.
--
-- > mu (erase k h) := filter ((k /=) . fst) (mu h)
--
erase :: Ord k => k -> History k a -> History k a
erase k History{annals,recorded} = History
  { annals   = maybe id I.delete mseen annals
  , recorded = recorded'
  }
  where (mseen, recorded') = M.updateLookupWithKey (\_ _ -> Nothing) k recorded


-- | /O(log n)/. Recall an event.
recall :: Ord k => k -> History k a -> Maybe a
recall k History{annals,recorded} = do
  ik     <- M.lookup k recorded
  (_, a) <- I.lookup ik annals
  pure a

  | /O(n)/. Read history , starting with the modern day . @ledger@ is @mu@.
ledger :: History k a -> [(k, a)]
ledger = I.elems . annals

-- | /O(n * log n)/. Transcribe a ledger.
transcribe :: Ord k => [(k, a)] -> History k a
transcribe = foldr (uncurry event) origin

# LANGUAGE NamedFieldPuns, DeriveTraversable #
---------------------------------------------------------------------------
 |
 Module      :  XMonad.Util.History
 License     :  BSD3-style (see LICENSE)

 Stability   :  unstable
 Portability :  unportable

 Provides 'History', a variation on a LIFO stack with a uniqueness property.
 In order to achieve the desired asymptotics, the data type is implemented as
 an ordered Map.

---------------------------------------------------------------------------
 base
 containers

   and 'ledger' pops/peeks all.

   The naive implementation has /O(n)/ 'event' and 'erase' due to the
   uniqueness condition, but we can still use it as a denotation:

 > mu :: History k a -> [(k, a)]

   finite expressions in the core interface: 'origin', 'erase' and 'event'.

 | /O(1)/. A history of nothing.

 > mu origin := []

 | /O(log n)/. A new event makes history; its predecessor forgotten.

 > mu (event k a h) := (k, a) : mu (erase k h)

 | /O(log n)/. Erase an event from history.

 > mu (erase k h) := filter ((k /=) . fst) (mu h)

 | /O(log n)/. Recall an event.
 | /O(n * log n)/. Transcribe a ledger.

  Description :   Track history in /O(log n)/ time .
  Copyright    :   ( c ) 2022   
  Maintainer   :   @LSLeary ( on github )

module XMonad.Util.History (
  History,
  origin,
  event,
  erase,
  recall,
  ledger,
  transcribe,
  ) where

import Data.Function (on)
import Text.Read
  ( Read(readPrec, readListPrec), Lexeme(Ident)
  , parens, prec, lexP, step, readListPrecDefault
  )

import Data.IntMap (IntMap)
import qualified Data.IntMap.Strict as I
import Data.Map (Map)
import qualified Data.Map.Strict as M


  | A history of unique @k@-events with @a@-annotations .
    @History k a@ can be considered a ( LIFO ) stack of @(k , a)@ values with the
    property that each @k@ is unique . From this point of view , ' event ' pushes
    As an opaque data type with strict operations , @History k a@ values are all
    Hence we define @mu@ by structural induction on these three cases .
data History k a = History
  { annals   :: !(IntMap (k, a))
  , recorded :: !(Map k Int)
  } deriving (Functor, Foldable, Traversable)

instance (Eq  k, Eq  a) => Eq  (History k a) where (==)    = (==)    `on` ledger
instance (Ord k, Ord a) => Ord (History k a) where compare = compare `on` ledger

instance (Show k, Show a) => Show (History k a) where
  showsPrec d h
    = showParen (d > app_prec)
    $ showString "transcribe "
    . showsPrec (app_prec+1) (ledger h)
    where app_prec = 10

instance (Read k, Read a, Ord k) => Read (History k a) where
  readPrec = parens . prec app_prec $ do
    Ident "transcribe" <- lexP
    l <- step readPrec
    pure (transcribe l)
    where app_prec = 10
  readListPrec = readListPrecDefault


origin :: History k a
origin = History I.empty M.empty

event :: Ord k => k -> a -> History k a -> History k a
event k a History{annals,recorded} = History
  { annals   = I.insert ik (k, a) . maybe id I.delete mseen $ annals
  , recorded = recorded'
  }
  where
    ik = maybe 0 (\((i, _), _) -> pred i) (I.minViewWithKey annals)
    (mseen, recorded') = M.insertLookupWithKey (\_ x _ -> x) k ik recorded

erase :: Ord k => k -> History k a -> History k a
erase k History{annals,recorded} = History
  { annals   = maybe id I.delete mseen annals
  , recorded = recorded'
  }
  where (mseen, recorded') = M.updateLookupWithKey (\_ _ -> Nothing) k recorded


recall :: Ord k => k -> History k a -> Maybe a
recall k History{annals,recorded} = do
  ik     <- M.lookup k recorded
  (_, a) <- I.lookup ik annals
  pure a

  | /O(n)/. Read history , starting with the modern day . @ledger@ is @mu@.
ledger :: History k a -> [(k, a)]
ledger = I.elems . annals

transcribe :: Ord k => [(k, a)] -> History k a
transcribe = foldr (uncurry event) origin
