Utils.hs

{-# OPTIONS_GHC -cpp #-}
---------------------------------------------------------------------------------------------------
---- Âñïîìîãàòåëüíûå ôóíêöèè: ðàáîòà ñî ñòðîêàìè, ñïèñêàìè, ðåãóëÿðíûìè âûðàæåíèÿìè,           ----
----   àëëîêàòîð ïàìÿòè. óïðîùåíèå ìàíèïóëÿöèé ñ IORef-ïåðåìåííûìè,                            ----
----   îïðåäåëåíèå óäîáíûõ îïåðàöèé è óïðàâëÿþùèõ ñòðóêòóð ïðîãðàììû.                          ----
---------------------------------------------------------------------------------------------------
module Utils (module Utils, module CompressionLib) where

import Prelude hiding (catch)
import Control.Concurrent
import Control.OldException
import Control.Monad
import Data.Array
import Data.Bits
import Data.Char
import Data.Either
import qualified Data.HashTable
import Data.IORef
import Data.List
import Data.Maybe
import Data.Ratio
import Data.Word
import Debug.Trace
import Foreign.Marshal.Utils
import Foreign.Ptr

import CompressionLib (MemSize,b,kb,mb,gb,tb)

---------------------------------------------------------------------------------------------------
---- Ïðîâåðèì define's ----------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

#if !defined(FREEARC_WIN) && !defined(FREEARC_UNIX)
#error "You must define OS!"
#endif

#if !defined(FREEARC_INTEL_BYTE_ORDER) && !defined(FREEARC_MOTOROLA_BYTE_ORDER)
#error "You must define byte order!"
#endif

#ifndef HAMSTER
aFreeArc = "FreeArc"
aFreeArcExt = aFreeArcInternalExt
aFreeArcExtensions = [aFreeArcExt]
#else
aFreeArc = "Hamster Free Archiver"
aFreeArcExt = aZipExt
aFreeArcExtensions = [] :: [String]
#endif

aFreeArcInternalExt = "arc"
aZipExt             = "zip"
aRarExt             = "rar"
a7zExt              = "7z"


---------------------------------------------------------------------------------------------------
---- Ðàçíîå :) ------------------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

-- |Ñîáðàòü 4-áàéòîâîå ÷èñëî èç îòäåëüíûõ áàéòîâ
#if defined(FREEARC_INTEL_BYTE_ORDER)
make4byte b0 b1 b2 b3 = b0+256*(b1+256*(b2+256*b3)) :: Word32
#else
make4byte b0 b1 b2 b3 = b3+256*(b2+256*(b1+256*b0)) :: Word32
#endif

-- |Ðàçáîðùèê ÷èñåë, óêàçûâàåìûõ âî âñÿêèõ îïöèÿõ. Òîëêîâàíèå ÷èñëà îïðåäåëÿåòñÿ ñèìâîëàìè,
-- íàïèñàííûìè ïîñëå íåãî (b/k/f/...), åñëè èõ íåò - èñïîëüçóåòñÿ `default_specifier`.
-- Ðåçóëüòàò âîçâðàùàåòñÿ â âèäå ïàðû, âòîðîé ýëåìåíò â êîòîðîé - `b`, åñëè ðåçóëüòàò âûðàæåí â áàéòàõ,
-- èëè äðóãîé ñèìâîë, çàïèñàííûé ïîñëå ÷èñëà, èëè ïåðåäàííûé êàê `default_specifier`.
parseNumber num default_specifier =
  case (spanRational$ strLower$ num++[default_specifier]) of
    (digits, 'b':_)  ->  (truncate$ readR digits      , 'b')
    (digits, 'k':_)  ->  (truncate$ readR digits * kb , 'b')
    (digits, 'm':_)  ->  (truncate$ readR digits * mb , 'b')
    (digits, 'g':_)  ->  (truncate$ readR digits * gb , 'b')
    (digits, 't':_)  ->  (truncate$ readR digits * tb , 'b')
    (digits, '^':_)  ->  (2 ^ (truncate$ readR digits), 'b')
    (digits,  c :_)  ->  (truncate$ readR digits      ,  c )

-- |Ðàçáèâàåò ñòðîêó íà ðàöèîíàëüíîå ÷èñëî (ddd[.ddd]) è îñòàòîê
spanRational s  =  splitAt (length s - length(go False s)) s
  where go b (x:xs) | isDigit x = go b xs
        go False ('.':xs)       = go True xs
        go _ xs                 = xs

-- |×òåíèå ðàöèîíàëüíîãî ÷èñëà
readR s  =  case (span isDigit s) of
    (digits, '.':more_digits)  ->  readI digits + readI more_digits % 10^length more_digits
    (digits, "")               ->  readI digits

-- |Ðàñøèôðîâàòü çàïèñü ðàçìåðà, ïî óìîë÷àíèþ - â áàéòàõ
parseSize default_specifier memstr =
    case (parseNumber memstr default_specifier) of
        (bytes, 'b')  ->  bytes
        _             ->  error$ memstr++" - unrecognized size specifier"

-- |Ðàñøèôðîâàòü çàïèñü îáú¸ìà ïàìÿòè: "512b", "32k", "8m" è òàê äàëåå. "24" îçíà÷àåò 24mb
parseMem memstr =
    case (parseNumber memstr 'm') of
        (bytes, 'b')  ->  clipToMaxMemSize bytes
        _             ->  error$ memstr++" - unrecognized size specifier"

-- |Àíàëîãè÷íî parseMem, íî ñ äîáàâëåíèåì ïîääåðæêè çàïèñè â âèäå 75%/75p (îò îáùåãî îáú¸ìà ïàìÿòè)
parseMemWithPercents memory memstr = clipToMaxMemSize$
    case (parseNumber memstr 'm') of
        (bytes,    'b')  ->  bytes
        (percents, c) | c `elem` "%p"
                         ->  (toInteger memory * percents) `div` 100
        _                ->  error$ memstr++" - unrecognized size specifier"

-- Äîëæíà óñåêàòü ê ìàêñèìàëüíîìó ïîçâîëåííîìó â MemSize ÷èñëó èëè ìîæåò âîîáùå âûäàâàòü îøèáêó?
clipToMaxMemSize x | x < i(maxBound::MemSize) = i x
                   | otherwise                = i(maxBound::MemSize)

readI = foldl f 0
  where f m c | isDigit c  =  fromIntegral (ord c - ord '0') + (m * 10)
              | otherwise  =  error ("Non-digit "++[c]++" in readI")

readInt :: String -> Int
readInt = readI

readSignedInt ('-':xs) = - readInt xs
readSignedInt      xs  =   readInt xs

isSignedInt = all isDigit.tryToSkip "-"

lb :: Integral a =>  a -> Int
lb 0 = 0
lb 1 = 0
lb n = 1 + lb (n `div` 2)


{-# NOINLINE parseNumber          #-}
{-# NOINLINE parseSize            #-}
{-# NOINLINE parseMem             #-}
{-# NOINLINE parseMemWithPercents #-}
{-# NOINLINE readI                #-}
{-# NOINLINE readInt              #-}


-- |Íåêîòîðûå îïåðàöèè äëÿ áîëåå èçÿùíîé çàïèñè ïðîãðàìì
infixl 9  .$
infixl 1  >>==, ==<<, =<<., .>>=, .>>, .>>==, ==<<.
a.$b         =  b a                -- âàðèàíò $ ñ ïåðåâ¸ðíóòûì ïîðÿäêîì àðãóìåíòîâ
a>>==b       =  a >>= return.b     -- âàðèàíò >>=, â êîòîðîì âòîðîé àðãóìåíò íóæäàåòcÿ â ëèôòèíãå
a==<<b       =  return.a =<< b     -- âàðèàíò =<<, â êîòîðîì ïåðâûé àðãóìåíò íóæäàåòcÿ â ëèôòèíãå
(a=<<.b) c   =  a =<< b c          -- âàðèàíò =<< äëÿ ïðèìåíåíèÿ â mapM è òîìó ïîäîáíûõ ìåñòàõ
(a.>>=b) c   =  a c >>= b          -- âàðèàíò >>= äëÿ ïðèìåíåíèÿ â mapM è òîìó ïîäîáíûõ ìåñòàõ
(a.>>b)  c   =  a c >> b           -- âàðèàíò >> äëÿ ïðèìåíåíèÿ â mapM è òîìó ïîäîáíûõ ìåñòàõ
(a==<<.b) c  =  return.a =<< b c   -- âàðèàíò ==<< äëÿ ïðèìåíåíèÿ â mapM è òîìó ïîäîáíûõ ìåñòàõ
(a.>>==b) c  =  a c >>= return.b   -- âàðèàíò >>== äëÿ ïðèìåíåíèÿ â mapM è òîìó ïîäîáíûõ ìåñòàõ

-- Òèïû äàííûõ, èìåþùèå çíà÷åíèÿ ïî óìîë÷àíèþ
class    Defaults a      where defaultValue :: a
instance Defaults ()     where defaultValue = ()
instance Defaults Bool   where defaultValue = False
instance Defaults [a]    where defaultValue = []
instance Defaults (a->a)               where defaultValue = id
instance Defaults (Maybe a)            where defaultValue = Nothing
instance Defaults (a->IO a)            where defaultValue = return
instance Defaults a => Defaults (IO a) where defaultValue = return defaultValue
instance Defaults Int                  where defaultValue = 0
instance Defaults Integer              where defaultValue = 0
instance Defaults Double               where defaultValue = 0

class    TestDefaultValue a       where isDefaultValue :: a -> Bool
instance TestDefaultValue Bool    where isDefaultValue = not
instance TestDefaultValue [a]     where isDefaultValue = null
instance TestDefaultValue Int     where isDefaultValue = (==0)
instance TestDefaultValue Integer where isDefaultValue = (==0)
instance TestDefaultValue Double  where isDefaultValue = (==0)

infixr 3  &&&
infixr 2  |||

-- |Äàòü âåëè÷èíå çíà÷åíèå ïî óìîë÷àíèþ
a ||| b | isDefaultValue a = b
        | otherwise        = a

-- |Âîçâðàòèòü âòîðîå çíà÷åíèå, åñëè ïåðâîå íå ÿâëÿåòñÿ çíà÷åíèåì ïî óìîë÷àíèþ
a &&& b | isDefaultValue a = defaultValue
        | otherwise        = b

-- |Âûïîëíèòü b åñëè a (óñëîâíîå âûïîëíåíèå ñ óñëîâèåì â êîíöå ñòðîêè)
infixr 0 `on_`, `onM`
on_ b a | isDefaultValue a = return ()
        | otherwise        = b >> return ()

-- |`on_` ñ ìîíàäè÷åñêèì óñëîâèåì
action `onM` conditionM = do condition <- conditionM
                             action `on_` condition

-- |Ïðèìåíèòü ôóíêöèþ f ê ñïèñêó òîëüêî åñëè îí íå ïóñòîé
unlessNull f xs  =  xs &&& f xs

-- |Ìîíàäè÷åñêèé âàðèàíò concatMap
concatMapM :: Monad io => (a -> io [b]) -> [a] -> io [b]
concatMapM f x  =  mapM f x  >>==  concat

-- |Óñëîâíîå âûïîëíåíèå
whenM cond action = do
  allow <- cond
  when allow
    action

unlessM = whenM . liftM not

-- |Âûïîëíèòü `action` íàä çíà÷åíèåì, âîçâðàù¸ííûì `x`, åñëè îíî íå Nothing
whenJustM  x action  =  x >>= (`whenJust` action)

whenJustM_ x action  =  x >>= (`whenJust_` action)

whenJust   x action  =  x .$ maybe (return Nothing) (action .>>== Just)

whenJust_  x action  =  x .$ maybe (return ()) (action .>> return ())

-- |Âûïîëíèòü `action` íàä çíà÷åíèåì, âîçâðàù¸ííûì `x`, åñëè îíî "Right _"
whenRightM_ x action  =  x >>= either doNothing (action .>> return ())

-- |Âûïîëíèòü onLeft/onRight íàä çíà÷åíèåì, âîçâðàù¸ííûì `x`
eitherM_ x onLeft onRight  =  x >>= either (onLeft  .>> return ())
                                           (onRight .>> return ())

-- |Âûïîëíèòü äëÿ êàæäîãî ýëåìåíòà èç ñïèñêà è âîâçðàòèòü ðåçóëüòàò êàê ñïèñîê
foreach = flip mapM

-- |Âûïîëíèòü äëÿ êàæäîãî ýëåìåíòà èç ñïèñêà
for = flip mapM_

-- |Àíàëîã `foreach` ñî ñïèñêîì, âîçâðàùàåìûì âûïîëíÿåìîé ïðîöåäóðîé
foreachM list action  =  list >>= mapM action

-- |Àíàëîã `for` ñî ñïèñêîì, âîçâðàùàåìûì âûïîëíÿåìîé ïðîöåäóðîé
for' list action  =  list >>= mapM_ action

-- |Óäîáíûé ñïîñîá çàïèñàòü ñíà÷àëà òî, ÷òî äîëæíî îáÿçàòåëüíî áûòü âûïîëíåíî â êîíöå :)
doFinally = flip finally

-- |Âûïîëíèòü onError ïðè îøèáêå â acquire, è action â ïðîòèâíîì ñëó÷àå
handleErrors onError acquire action = do
  x <- try acquire
  case x of
    Left  err -> onError
    Right res -> action res

-- |Çàïèñàòü â íà÷àëå òî, ÷òî íóæíî âûïîëíèòü â êîíöå
atExit a b = (b>>a)

-- |Âûïîëíèòü äåéñòâèå òîëüêî îäèí ðàç, ïðè var=True
once var action = do whenM (val var) action; var =: False
init_once       = ref True

-- |Çàãëóøêè íà ìåñòî êîìàíä, êîòîðûå íå äîëæíû íè÷åãî âûïîëíÿòü
doNothing0       = return ()
doNothing  a     = return ()
doNothing2 a b   = return ()
doNothing3 a b c = return ()

-- |Èãíîðèðîâàòü èñêëþ÷åíè
ignoreErrors  =  handle doNothing

-- |Ñîçäàòü íîâûé Channel è çàïèñàòü â íåãî íà÷àëüíûé ñïèñîê çíà÷åíèé
newChanWith xs = do c <- newChan
                    writeList2Chan c xs
                    return c

-- |Êîíñòàíòíûå ôóíêöèè
const2 x _ _ = x
const3 x _ _ _ = x
const4 x _ _ _ _ = x

-- |Íàôèãà âàì ýòîò ThreadId??
forkIO_ action = forkIO action >> return ()

-- |Ïîâòîðÿòü áåñêîíå÷íî
foreverM action = do
  action
  foreverM action

-- |Óïðàâëÿþùàÿ ñòðóêòóðà, àíàëîãè÷íàÿ öèêëó 'while' â îáû÷íûõ ÿçûêàõ
repeat_while inp cond out = do
  x <- inp
  if (cond x)
    then do out x
            repeat_while inp cond out
    else return x

-- |Óïðàâëÿþùàÿ ñòðóêòóðà, àíàëîãè÷íàÿ repeat-until â Ïàñêàëå
repeat_until action = do
  done <- action
  when (not done) $ do
    repeat_until action

-- |Óïðàâëÿþùàÿ ñòðóêòóðà, ðàçáèâàþùàÿ âûïîëíåíèå îïåðàöèè ðàçìåðîì size
-- íà îòäåëüíûå îïåðàöèè ðàçìåðîì íå áîëåå chunk êàæäà
doChunks size chunk action =
  case size of
    0 -> return ()
    _ -> do let n = minI size chunk
            action (fromIntegral n)
            doChunks (size-n) chunk action

-- |Óïðàâëÿþùàÿ ñòðóêòóðà, ðàçáèâàþùàÿ âûïîëíåíèå îïåðàöèè íàä áóôåðîì ðàçìåðîì size
-- íà îòäåëüíûå îïåðàöèè ðàçìåðîì íå áîëåå chunk êàæäàÿ.
doBufChunks buf size chunk action =
  case size of
    0 -> return ()
    _ -> do let n = minI size chunk
            action buf (fromIntegral n)
            doBufChunks (buf+:n) (size-n) chunk action

-- |Âûïîëíèòü `action` íàä x, çàòåì íàä êàæäûì ýëåìåíòîì ñïèñêà, âîçâðàù¸ííîãî èç `action`, è òàê äàëåå ðåêóðñèâíî
recursiveM action x  =  action x >>= mapM_ (recursiveM action)

-- |Âûïîëíèòü ðåêóðñèâíî, åñëè âåðíî óñëîâèå `cond`, è îäíîêðàòíî â ïðîòèâíîì ñëó÷àå
recursiveIfM cond action x  =  if cond  then recursiveM action x  else (action x >> return ())

-- |Âûïîëíÿåò äåéñòâèå `action` íàä ýëåìåíòàìè ñïèñêà `list` ïîî÷åð¸äíî, âîçâðàùàÿ
-- ñïèñîê ðåçóëüòàòîâ, âîçâðàù¸ííûõ `action` - â îáùåì, àíàëîãè÷íî mapM.
-- Íî äîïîëíèòåëüíî ê ýòîìó ïðîâåðÿåò îáðàáîòàííûå äàííûå ïî êðèòåðèþ `crit_f` è âûõîäèò èç öèêëà,
-- åñëè ýòîò êðèòåðèé óäîâëåòâîð¸í. Ïîýòîìó äîïîëíèòåëüíî âîçâðàùàåòñÿ ñïèñîê íåîáðàáîòàííûõ
-- çíà÷åíèé èç `list`
mapMConditional (init,map_f,sum_f,crit_f) action list = do
  let go []     ys summary = return (reverse ys, [])     -- çàâåðøåíî èç-çà èñ÷åðïàíèÿ ñïèñêà
  let go (x:xs) ys summary = do
        y <- action x
        let summary  =  sum_f summary (map_f y)
        if (crit_f summary)
          then return (reverse$ y:ys, xs)                -- çàâåðøåíî ñîãëàñíî êðèòåðèþ
          else go xs (y:ys) summary
  go list [] init

-- |Execute action with background computation
withThread thread  =  bracket (forkIO thread) killThread . const

-- |Âûïîëíèòü äåéñòâèå â äðóãîì òðåäå è âîçâðàòèòü êîíå÷íûé ðåçóëüòàò
bg action = do
  resultVar <- newEmptyMVar
  forkIO (action >>= putMVar resultVar)
  takeMVar resultVar

#ifdef FREEARC_GUI
isGUI = True
#else
isGUI = False
#endif

{-# NOINLINE foreverM #-}
{-# NOINLINE repeat_while #-}
{-# NOINLINE repeat_until #-}
{-# NOINLINE mapMConditional #-}
{-# NOINLINE bg #-}


-- |Îòôèëüòðîâàòü ñïèñîê ñ ïîìîùüþ ìîíàäè÷åñêîãî (âûïîëíÿåìîãî) ïðåäèêàòà
filterM :: (Monad m) => (a -> m Bool) -> [a] -> m [a]
filterM p  =  go []
  where go accum []      =  return$ reverse accum
        go accum (x:xs)  =  p x  >>=  bool (go    accum  xs)
                                           (go (x:accum) xs)

-- |mapMaybe, ïåðåíåñ¸ííàÿ â êëàññ Monad
mapMaybeM :: Monad m => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f  =  go []
  where go accum []      =  return$ reverse accum
        go accum (x:xs)  =  f x  >>=  maybe (      go    accum  xs)
                                            (\r -> go (r:accum) xs)

-- |@firstJust@ takes a list of @Maybes@ and returns the
-- first @Just@ if there is one, or @Nothing@ otherwise.
firstJust :: [Maybe a] -> Maybe a
firstJust [] = Nothing
firstJust (Just x  : ms) = Just x
firstJust (Nothing : ms) = firstJust ms

-- |Âåðíóòü ïåðâûé óñïåøíûé (Just) ðåçóëüòàò ïðèìåíåíèÿ f ê ñïèñêó èëè Nothing
firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe f  =  firstJust . map f

-- |Çàìåíèòü Nothing íà çíà÷åíèå ïî óìîë÷àíèþ
defaultVal = flip fromMaybe

-- |Çàìåíèòü Nothing íà çíà÷åíèå ïî óìîë÷àíèþ - äëÿ èìïåðàòèâíîé îïåðàöèè
defaultValM = liftM2 defaultVal

-- |Âûáðàòü îäíî èç äâóõ çíà÷åíèé â çàâèñèìîñòè îò ïîñëåäíåãî àðãóìåíòà
bool onFalse onTrue False  =  onFalse
bool onFalse onTrue True   =  onTrue

-- |if áåç ñèíò. îâåðõåäà
iif True  onTrue onFalse  =  onTrue
iif False onTrue onFalse  =  onFalse

-- Ïðèìåíèòü ê ñïèñêó îäíó èç äâóõ ôóíêöèé â çàâèñèìîñòè îò òîãî, ïóñò ëè îí
list onNotNull onNull [] = onNull
list onNotNull onNull xs = onNotNull xs

-- |Âîçâðàòèòü True, åñëè çíà÷åíèå - íå Nothing
maybe2bool (Just _) = True
maybe2bool Nothing  = False

-- |Ïðîâåðêà íà Left
isLeft (Left _) = True
isLeft _        = False

-- |Ïðîâåðêà íà Right
isRight (Right _) = True
isRight _         = False

-- |Óäàëèòü ýëåìåíòû, îòâå÷àþùèå çàäàííîìó ïðåäèêàòó
deleteIf p = filter (not.p)

-- |Óäàëèòü ýëåìåíòû, ñîîòâåòñòâóþùèå ëþáîìó èç ñïèñêà ïðåäèêàòîâ
deleteIfs = deleteIf.anyf

-- |Îáíîâëåíèå lookup-ñïèñêà
update list a@(key,value)  =  a : [x | x@(k,v)<-list, k/=key]

-- |Çàìåíà çíà÷åíèé ïî ñïèñêó
changeTo list value  =  lookup value list `defaultVal` value

-- |Íàïå÷àòàòü è âîçâðàòèòü îäíî çíà÷åíèå
trace2 s = trace (show s) s

-- |Evaluate list elements
evalList (x:xs) = x `seq` evalList xs
evalList []     = ()

{-
-- Cale Gibbard

A useful little higher order function. Some examples of use:

swing map :: forall a b. [a -> b] -> a -> [b]
swing any :: forall a. [a -> Bool] -> a -> Bool
swing foldr :: forall a b. b -> a -> [a -> b -> b] -> b
swing zipWith :: forall a b c. [a -> b -> c] -> a -> [b] -> [c]
swing find :: forall a. [a -> Bool] -> a -> Maybe (a -> Bool) -- applies each of the predicates to the given value, returning the first predicate which succeeds, if any
swing partition :: forall a. [a -> Bool] -> a -> ([a -> Bool], [a -> Bool])

-}

swing :: (((a -> b) -> b) -> c -> d) -> c -> a -> d
swing f = flip (f . flip ($))


-- |Map on functions instead of its' arguments!
map_functions []     x  =  []
map_functions (f:fs) x  =  f x : map_functions fs x

-- |Ïðîâåðèòü, ÷òî âñå ôóíêöèè èç ñïèñêà äàþò True íà (îïóùåííîì çäåñü) àðãóìåíòå. Ýôôåêòèâíåé, ÷åì swing all
allf x = all_functions x
all_functions []  = const True
all_functions [f] = f
all_functions fs  = and . map_functions fs

-- |Ïðîâåðèòü, ÷òî õîòü îäíà ôóíêöèÿ èç ñïèñêà äà¸ò True íà (îïóùåííîì çäåñü) àðãóìåíòå. Ýôôåêòèâíåé, ÷åì swing any
anyf x = any_function x
any_function []  = const False
any_function [f] = f
any_function fs  = or . map_functions fs

-- |Ïðèìåíèòü ê àðãóìåíòó ïîñëåäîâàòåëüíî âñå ôóíêöèè èç ñïèñêà
applyAll []     x = x
applyAll (f:fs) x = applyAll fs (f x)

(f>>>g) x = g(f x)


---------------------------------------------------------------------------------------------------
---- Îïåðàöèè íàä ñòðîêàìè ------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

-- |Ðàçáèòü ñòðîêó íà äâå ïîäñòðîêè, ðàçäåë¸ííûå çàäàííûì ñèìâîëîì
split2 :: (Eq a) => a -> [a] -> ([a],[a])
split2 c s  =  (chunk, drop 1 rest)
  where (chunk, rest) = break (==c) s

-- |Ñîåäèíèòü èõ íàçàä êàê áûëî :)
join2 :: [a] -> ([a],[a]) -> [a]
join2 between (a,b) = a++between++b

-- |Ðàçáèòü ñòðîêó íà ïîäñòðîêè, ðàçäåë¸ííûå çàäàííûìè ñèìâîëàìè, èãíîðèðóÿ èõ ëèøíèå âõîæäåíèÿ â íà÷àëå/ñåðåäèíå/êîíöå ñòðîêè
split_by_any separators s =
  case break (`elem` separators) (dropWhile (`elem` separators) s) of
    ([],[])        -> []
    (chunk, rest)  -> chunk : split_by_any separators rest

-- |Ðàçáèòü ñòðîêó íà ïîäñòðîêè, ðàçäåë¸ííûå çàäàííûì ñèìâîëîì
split :: (Eq a) => a -> [a] -> [[a]]
split c s =
  let (chunk, rest) = break (==c) s
  in case rest of  []     -> [chunk]
                   _:rest -> chunk : split c rest

-- |Ñîåäèíèòü ñïèñîê ñòðîê â åäèíûé òåêñò ñ ðàçäåëèòåëåì: "one, two, three"
joinWith :: [a] -> [[a]] -> [a]
joinWith x  =  concat . intersperse x

-- |Ñîåäèíèòü ñïèñîê ñòðîê â åäèíûé òåêñò, èñïîëüçóÿ äâà ðàçíûõ ðàçäåëèòåëÿ:
-- joinWith2 ", " " and " ["one","two","three","four"]  -->  "one, two, three and four"
joinWith2 :: [a] -> [a] -> [[a]] -> [a]
joinWith2 a b []    =  []
joinWith2 a b [x]   =  x
joinWith2 a b list  =  joinWith a (init list) ++ b ++ last list

-- |Ïîñòàâèòü x ìåæäó s1 è s2, åñëè îáå ñòðîêè íåïóñòûå
between s1 x [] = s1
between [] x s2 = s2
between s1 x s2 = s1++x++s2

-- |Äîáàâèòü äâîéíûå êàâû÷êè âîêðóã ñòðîêè, ýêðàíèðóÿ êàâû÷êè âíóòðè íå¸ è "\" â êîíöå ñòðîêè
quote :: String -> String
quote str  =  "\"" ++ (str.$replaceAll "\"" "\\\"" .$replaceAtEnd "\\" "\\\\") ++ "\""

-- |Óäàëèòü äâîéíûå êàâû÷êè âîêðóã ñòðîêè (åñëè îíè åñòü)
unquote :: String -> String
unquote ('"':str) | str>"" && x=='"'  =  xs     where (x:xs) = reverse str
unquote str = str

contains = flip elem

-- |Óäàëèòü n ýëåìåíòîâ â êîíöå ñïñèêà
dropEnd n  =  reverse . drop n . reverse

-- |Èñòèíà, åñëè `s` ñîäåðæèò õîòÿ áû îäèí èç ýëåìåíòîâ ìíîæåñòâà `set`
s `contains_one_of` set  =  any (`elem` set) s

-- |Ïîñëåäíèå n ýëåìåíòîâ
n `lastElems` xs  =  drop (length xs - n) xs

-- |Çàìåíèòü n'é ýëåìåíò (ñ÷èòàÿ ñ 0) â ñïèñêå `xs` íà `x`
replaceAt n x xs  =  hd ++ x : drop 1 tl
    where (hd,tl) = splitAt n xs

-- |Èçìåíèòü n'é ýëåìåíò (ñ÷èòàÿ ñ 0) â ñïèñêå `xs` ñ `x` íà `f x`
updateAt n f xs  =  hd ++ f x : tl
    where (hd,x:tl) = splitAt n xs

-- |Âñòàâèòü ïåðåä n'ì ýëåìåíòîì (ñ÷èòàÿ ñ 0)
insertAt n sublist xs  =  hd ++ sublist ++ tl
    where (hd,tl) = splitAt n xs

-- |Çàìåíèòü â ñïèñêå âñå âõîæäåíèÿ ýëåìåíòà 'from' íà 'to'
replace from to  =  map (\x -> if x==from  then to  else x)

-- |Åñëè ïåðâàÿ ñòðîêà ÿâëÿåòñÿ ïðåôèêñîì âòîðîé - âîçâðàòèòü îñòàòîê âòîðîé ñòðîêè, èíà÷å Nothing
startFrom (x:xs) (y:ys) | x==y  =  startFrom xs ys
startFrom [] str                =  Just str
startFrom _  _                  =  Nothing

-- |Ïðîâåðêà, ÷òî ñòðîêà íà÷èíàåòñÿ èëè çàêàí÷èâàåòñÿ çàäàííûìè ñèìâîëàìè
beginWith s = isJust . startFrom s
endWith   s = beginWith (reverse s) . reverse

-- |Ïîïûòàåìñÿ óäàëèòü ñòðîêó substr â íà÷àëå str
tryToSkip substr str  =  (startFrom substr str) `defaultVal` str

-- |Ïîïûòàòüñÿ óäàëèòü ñòðîêó substr â êîíöå str
tryToSkipAtEnd substr str = reverse (tryToSkip (reverse substr) (reverse str))

-- | The 'substr' function takes two lists and returns 'True'
-- if the second list is contained, wholy and intact,
-- anywhere within the first.
substr str substr  =  any (substr `isPrefixOf`) (tails str)

-- |Ñïèñîê ïîçèöèé ïîäñòðîêè â ñòðîêå
strPositions str substr  =  elemIndices True$ map (substr `isPrefixOf`) (tails str)

-- |Çàìåíèòü â ñòðîêå `s` âñå âõîæäåíèÿ `from` íà `to`
replaceAll from to = repl
  where repl s      | Just remainder <- startFrom from s  =  to ++ repl remainder
        repl (c:cs)                                       =  c : repl cs
        repl []                                           =  []

-- |Çàìåíèòü %1 íà çàäàííóþ ñòðîêó
format msg s  =  replaceAll "%1" s msg

-- |Çàìåíèòü %1..%9 íà çàäàííûå ñòðîêè
formatn msg s  =  go msg
  where go ('%':d:rest) | isDigit d = (s !! (digitToInt d-1)) ++ go rest
        go (x:rest)                 = x : go rest
        go ""                       = ""

-- |Çàìåíèòü â ñòðîêå `s` ïðåôèêñ `from` íà `to`
replaceAtStart from to s =
  case startFrom from s of
    Just remainder  -> to ++ remainder
    Nothing         -> s

-- |Çàìåíèòü â ñòðîêå `s` ñóôôèêñ `from` íà `to`
replaceAtEnd from to s =
  case startFrom (reverse from) (reverse s) of
    Just remainder  -> reverse remainder ++ to
    Nothing         -> s

-- |Âåðíóòü øåñòíàäöàòåðè÷íóþ çàïèñü ñòðîêè ñèìâîëîâ ñ êîäàìè <=255
encode16 (c:cs) | n<256 = [intToDigit(n `div` 16), intToDigit(n `mod` 16)] ++ encode16 cs
                             where n = ord c
encode16 "" = ""

-- |Äåêîäèðîâàòü øåñòíàäöàòåðè÷íóþ çàïèñü ñòðîêè ñèìâîëîâ ñ êîäàìè <=255
decode16 (c1:c2:cs) = chr(digitToInt c1 * 16 + digitToInt c2) : decode16 cs
decode16 ""         = ""

-- |Âçÿòü ïåðâûõ n ýëåìåíòîâ ñïèñêà è äîáàâèòü ê íèì more äëÿ èíäèêàöèè òîãî, ÷òî ÷òî-òî áûëî îïóùåíî
takeSome n more s | (y>[])    = x ++ more
                  | otherwise = x
                  where  (x,y) = splitAt n s

-- |Âûðîâíÿòü ñòðîêó âëåâî/âïðàâî, äîïîëíèâ å¸ äî çàäàííîé øèðèíû ïðîáåëàìè èëè ÷åì-íèáóäü åù¸
right_fill  c n s  =  s ++ replicate (n-length s) c
left_fill   c n s  =  replicate (n-length s) c ++ s
left_justify       =  right_fill ' '
right_justify      =  left_fill  ' '

-- Óäàëèòü ïðîáåëû â íà÷àëå/êîíöå ñòðîêè èëè ïî îáîèì ñòîðîíàì
trimLeft  = dropWhile (==' ')
trimRight = reverse.trimLeft.reverse
trim      = trimLeft.trimRight

-- |Ïåðåâåñòè ñòðîêó â íèæíèé ðåãèñòð
strLower = map toLower

-- |Ñðàâíèòü äâå ñòðîêè, èãíîðèðóÿ ðåãèñòð
strLowerEq a b  =  strLower a == strLower b

-- |break íà÷èíàÿ ñî âòîðîãî ýëåìåíòà
break1 f (x:xs)  =  mapFst (x:) (break f xs)

-- |Âîçâðàòèòü çíà÷åíèå ïî óìîë÷àíèþ âìåñòî ãîëîâû ñïèñêà, åñëè îí ïóñò
head1 [] = defaultValue
head1 xs = head xs

-- Àíàëîã tail, ñïîêîéíî ðåàãèðóþùèé íà ïóñòûå ñïèñêè
tail1 [] = []
tail1 xs = tail xs

-- Àíàëîã init, ñïîêîéíî ðåàãèðóþùèé íà ïóñòûå ñïèñêè
init1 [] = []
init1 xs = init xs

-- Àíàëîã last, ñïîêîéíî ðåàãèðóþùèé íà ïóñòûå ñïèñêè
last1 [] = defaultValue
last1 xs = last xs

-- |Map various parts of list
mapHead f []      =  []
mapHead f (x:xs)  =  f x : xs

mapTail f []      =  []
mapTail f (x:xs)  =  x : map f xs

mapInit f []      =  []
mapInit f xs      =  map f (init xs) ++ [last xs]

mapLast f []      =  []
mapLast f xs      =  init xs ++ [f (last xs)]

processTail f []      = []
processTail f (x:xs)  =  x : f xs

{-# NOINLINE replaceAll #-}
{-# NOINLINE replaceAtEnd #-}



---------------------------------------------------------------------------------------------------
---- Îïåðàöèè íàä ñïèñêàìè ------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

-- |Sort list by function result (use Schwarznegian transform)
sortOn  f  =  map snd . sortOn' fst . map (keyval f)

-- |Sort list by function result (don't use Schwarznegian transform!)
sortOn' f  =  sortBy (map2cmp f)

-- |Group list by function result
groupOn f  =  groupBy (map2eq f)

-- |Sort and Group list by function result
sort_and_groupOn  f  =  groupOn f . sortOn  f
sort_and_groupOn' f  =  groupOn f . sortOn' f

-- |Ñãðóïïèðîâàòü âñå ýëåìåíòû (a.b) ñ îäèíàêîâûì çíà÷åíèåì 'a'
groupFst :: (Ord a) =>  [(a,b)] -> [(a,[b])]
groupFst = map (\xs -> (fst (head xs), map snd xs)) . sort_and_groupOn' fst

-- |Óäàëÿåò äóáëèêàòû èç ñïèñêà
removeDups = removeDupsOn id

-- |Îñòàâëÿåò òîëüêî ïî îäíîìó ýëåìåíòó èç êàæäîé ãðóïïû ñ îäèíàêîâûì çíà÷åíèåì f
removeDupsOn f = map head . sort_and_groupOn f

-- |Ïðîâåðèòü, ÷òî âñå ïîñëåäîâàòåëüíûå çíà÷åíèÿ â ñïèñêå óäîâëåòâîðÿþò çàäàííîìó ñîîòíîøåíèþ
isAll f []       = True
isAll f [x]      = True
isAll f (x:y:ys) = f x y  &&  isAll f (y:ys)

-- |Ïðîâåðèòü, ÷òî õîòÿ áû äâà êàêèõ-íèáóäü ïîñëåäîâàòåëüíûõ çíà÷åíèÿ â ñïèñêå óäîâëåòâîðÿþò çàäàííîìó ñîîòíîøåíèþ
isAny f []       = False
isAny f [x]      = False
isAny f (x:y:ys) = f x y  ||  isAny f (y:ys)

-- |Check that list is sorted by given field/critery
isSortedOn f  =  isAll (<=) . map f

-- |Check that all elements in list are equal by given field/critery
isEqOn f      =  isAll (==) . map f

-- |Find maximum element by given comparison critery
maxOn f (x:xs) = go x xs
  where go x [] = x
        go x (y:ys) | f x > f y  =  go x ys
                    | otherwise  =  go y ys

-- |Merge two lists, sorted by `cmp`, in one sorted list
merge :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
merge cmp xs [] = xs
merge cmp [] ys = ys
merge cmp (x:xs) (y:ys)
 = case x `cmp` y of
        GT -> y : merge cmp (x:xs)   ys
        _  -> x : merge cmp    xs (y:ys)

-- |Ðàçáèòü ñïèñîê íà `numGroups` ïîäñïèñêîâ â ñîîòâåòñòâèè ñî çíà÷åíèåì, âîçâðàùàåìûì `crit_f`
partitionList numGroups crit_f list =
  elems $ accumArray (flip (:)) [] (0, numGroups-1) (map (keyval crit_f) (reverse list))

-- partitionList numGroups crit_f list =
--   let xs = map (keyval crit_f) list
--       go 0 [] all = all
--       go n list prev = let (this, next) = partition (\(a,b) -> a==n-1) list
--                        in go (n-1) next (map snd this:prev)
--   in go numGroups xs []

-- |Ðàçáèòü ñïèñîê íà ãðóïïû â ñîîòâåòñòâèè ñ ïðåäèêàòàìè èç ñïèñêà `groups`:
--   splitList [(=='a'), (=='c')] 2 "cassa"  ->  ["aa","c","ss"]
--
splitList groups default_group filelist =
  let go [] filelist sorted  =  replaceAt default_group filelist (reverse sorted)
      go (group:groups) filelist sorted =
        let (found, notfound)  =  partition group filelist
        in go groups notfound (found:sorted)
  in go groups filelist []

-- |Íàéòè íîìåð ïåðâîãî ïðåäèêàòà èç ñïèñêà `groups`, êîòîðîìó óäîâëåòâîðÿåò çíà÷åíèå `value`
findGroup groups default_group value  =  (findIndex ($ value) groups) `defaultVal` default_group

-- Utility functions for list operations
keyval  f x    =  (f x, x)                -- |Return pair containing computed key and original value
map2cmp f x y  =  (f x) `compare` (f y)   -- |Converts "key_func" to "compare_func"
map2eq  f x y  =  (f x) == (f y)          -- |Converts "key_func" to "eq_func"


-- |Ðåêóðñèâíàÿ îáðàáîòêà ñïèñêà
recursive :: ([a]->(b,[a])) -> [a] -> [b]
recursive f list  =  list &&& (x:recursive f xs)   where (x,xs) = f list

-- |Ðàçáèòü ñïèñîê íà ïîäñïèñêè, äëèíà êîòîðûõ îïðåäåëÿåòñÿ âûçîâîì ôóíêöèè `len_f` íà îñòàòêå ñïèñêà
splitByLen :: ([a]->Int) -> [a] -> [[a]]
splitByLen len_f  =  recursive (\xs -> splitAt (len_f xs) xs)

-- |Ýòà ôóíêöèÿ ïîëó÷àåò ñïèñîê äëèí ïîäñïèñêîâ è ðàçáèâàåò `xs` â ñîîòâåòñòâèè ñ íèì
splitByLens (len:lens) list  =  (x:splitByLens lens xs)    where (x,xs) = splitAt len list
splitByLens []         []    =  []

-- |Âîçâðàùàåò äëèíó íà÷àëüíîãî ñåãìåíòà ñïèñêà, óäîâëåòâîðÿþùåãî êîìáèíèðîâàííîìó óñëîâèþ,
-- íàïðèìåð "groupLen (fiSize) (+) (<16*mb) files" âîçâðàùàåò äëèíó íà÷àëüíîãî ñåãìåíòà ñïèñêà,
-- ñîäåðæàùóþ ôàéëû ñóììàðíûì îáú¸ìîì íå áîëåå 16 ìåãàáàéò
groupLen mapper combinator tester  =  length . takeWhile tester . scanl1 combinator . map mapper

-- |Îáúåäèíèòü ðåçóëüòàòû span è break: spanBreak isDigit "100a10b2c" = ("100a", "10b2c")
spanBreak crit xs  = let (s1,tail1) = span  crit xs
                         (s2,tail2) = break crit tail1
                     in (s1++s2, tail2)

-- |Ðàçáèòü ñïèñîê íà ãðóïïû, çàãîëîâêè êîòîðûõ - ýëåìåíòû, îòâå÷àþùèå êðèòåðèþ 'crit'
makeGroups              :: (a -> Bool) -> [a] -> [[a]]
makeGroups crit []      =  []
makeGroups crit (x:xs)  =  (x:ys) : makeGroups crit zs
                             where (ys,zs) = break crit xs

-- |Ðàçáèòü ñïèñîê íà ãðóïïû, ðàçäåë¸ííûå ýëåìåíòàìè, îòâå÷àþùèìè êðèòåðèþ 'crit':
-- splitOn even [1,2,4,8,3,5,7] == [[1],[2],[4],[8],[3,5,7]]
splitOn crit []  =  []
splitOn crit xs  =  (not(null ys)  &&&  (ys :))
                    (not(null zs)  &&&  ([head zs] : splitOn crit (tail zs)))
                      where (ys,zs) = break crit xs

-- |Óäàëèòü â ñïèñêå äóáëèêàòû ïî çàäàííîìó êðèòåðèþ. O(n^2), çàòî ñîõðàíÿåò ïîðÿäîê ýëåìåíòîâ â ñïèñêå
keepOnlyFirstOn f [] = []
keepOnlyFirstOn f (x:xs) = x : keepOnlyFirstOn f (filter (\a -> f x /= f a) xs)

-- |Îñòàâèòü â ñïèñêå òîëüêî ïîñëåäíèé èç äóáëèêàòîâ ïî çàäàííîìó êðèòåðèþ
keepOnlyLastOn f = reverse . keepOnlyFirstOn f . reverse

-- |Óäàëèòü ýëåìåíòû ñ çàäàííûìè íîìåðàìè èç ñïèñêà
deleteElems = go 0
  where go n xs [] = xs  -- Óäàëÿòü áîëüøå íå÷åãî
        go n (x:xs) iis@(i:is) | n<i  = x:go (n+1) xs iis  -- ìû åù¸ íå äîøëè äî i-ãî ýëåìåíòà
                               | n==i =   go (n+1) xs is   -- äîøëè - óäàëÿåì!


-- |Ïðåâðàùàåò âîçðàñòàþùèé ñïèñîê ÷èñåë â ñïèñîê äèàïàçîíîâ:
-- 1,2,3,10,21,22 -> (1,3),(10,10),(21,22)
makeRanges (x:y:zs) | x+1==y    =  makeRanges1 x (y:zs)
                    | otherwise =  (x,x) : makeRanges (y:zs)
makeRanges [x]                  =  [(x,x)]
makeRanges []                   =  []

-- Âñïîìîãàòåëüíîå îïðåäåëåíèå äëÿ makeRanges
makeRanges1 start (x:y:zs) | x+1==y    =  makeRanges1 start (y:zs)
                           | otherwise =  (start,x) : makeRanges (y:zs)
makeRanges1 start [x]                  = [(start,x)]


{-# NOINLINE partitionList #-}
{-# NOINLINE splitList #-}


---------------------------------------------------------------------------------------------------
---- Îïåðàöèè ñ ìàññèâàìè -------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

-- |Ïðåâðàòèòü ñïèñîê â 0-based array
listArray0 list  =  listArray (0,length(list)-1) list

-- |Íàéòè ìèíèì. è ìàêñ. èíäåêñû â ñïèñêå ïàð è ñîçäàòü èç íèõ ìàññèâ,
populateArray defaultValue castValue pairs =
  accumArray (\a b -> castValue b) defaultValue (minimum indexes, maximum indexes) pairs
  where indexes = map fst pairs


---------------------------------------------------------------------------------------------------
---- Îïåðàöèè ñ tuples ----------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

-- Îïåðàöèè íàä tuple/2
mapFst    f (a,b)  =  (f a,   b)
mapSnd    f (a,b)  =  (  a, f b)
mapFstSnd f (a,b)  =  (f a, f b)
map2      (f,g) a  =  (f a, g a)
map5      (f1,f2,f3,f4,f5) a  =  (f1 a,f2 a,f3 a,f4 a,f5 a)
mapFsts = map . mapFst
mapSnds = map . mapSnd
map2s   = map . map2

-- |Ñëèòü âòîðûå ýëåìåíòû ïàð â ñïèñêå è îñòàâèòü îäèí (îáùèé) ïåðâûé ýëåìåíò
concatSnds xs = (fst (head xs), concatMap snd xs)

-- Îïåðàöèè íàä tuple/3
fst3 (a,_,_)    =  a
snd3 (_,a,_)    =  a
thd3 (_,_,a)    =  a
map3 (f,g,h) a  =  (f a, g a, h a)

-- Îïåðàöèè íàä tuple/4
fst4 (a,_,_,_)    =  a
snd4 (_,a,_,_)    =  a
thd4 (_,_,a,_)    =  a
fth4 (_,_,_,a)    =  a


---------------------------------------------------------------------------------------------------
---- Pure hash tables -----------------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

class Hashable a where
  stdHashFunc :: a -> Int

instance Hashable String where
  stdHashFunc = fromEnum . Data.HashTable.hashString


data HT a b = HT (a->Int) (Array Int [(a,b)])

-- size is the size of array (we implement a closed hash)
-- hash is the hash function (a->Int)
-- list is assoclist of items to put in hash
htCreateHash' size hash list = HT hashfunc
                              (accumArray (flip (:))
                                          []
                                          (0, arrsize-1)
                                          (map (\(a,b) -> (hashfunc a,(a,b))) list)
                              )

  where arrsize     =  head$ filter (>size)$ iterate (\x->3*x+1) 1
        hashfunc a  =  hash a `mod` arrsize

htCreateHash hash list  =  htCreateHash' (length list) hash list

htCreate' size list  =  htCreateHash' size stdHashFunc list
htCreate       list  =  htCreateHash       stdHashFunc list

htLookup (HT hash arr) a  =  lookup a (arr!hash a)


-- Fast set implementation
htCreateSet list   =  htCreate$ map (\a -> (a,True)) list
htLookupSet set a  =  isJust$ htLookup set a



---------------------------------------------------------------------------------------------------
---- Ýìóëÿöèÿ îáû÷íûõ ïåðåìåííûõ ------------------------------------------------------------------
---------------------------------------------------------------------------------------------------

infixl 0 =:, +=, -=, ++=, =::, .=, .<-, <<=, <=>

-- Simple variables
class Variable v a | v->a where
  new  :: a -> IO v
  val  :: v -> IO a
  (=:) :: v -> a -> IO ()
  (.=) :: v -> (a->a) -> IO ()
  (=::) :: v -> IO a -> IO ()
  (.<-) :: v -> (a->IO a) -> IO ()
  -- Default implementations
  a.=f = do x<-val a; a=:f x
  a=::b = (a=:) =<< b
  a.<-f = do x<-val a>>=f; a=:x

ref = newIORef
instance Variable (IORef a) a where
  new = newIORef
  val = readIORef
  a=:b = writeIORef a b
  a.=b = modifyIORef a b
  a.<-b = modifyIORefIO a b

mvar = newMVar
instance Variable (MVar a) a where
  new = newMVar
  val = readMVar
  a=:b = swapMVar a b >> return ()
  a.=b = modifyMVar_ a (return.b)
  a.<-b = modifyMVar_ a b

a+=b = a.=(\a->a+b)
a-=b = a.=(\a->a-b)
a++=b = a.=(\a->a++b)
a<=>b = do x <- val a; a =: b; return x
withRef init  =  with' (ref init) val


-- Accumulation lists
newtype AccList a = AccList [a]
newList   = ref$ AccList []
a<<=b     = a .= (\(AccList x) -> AccList$ b:x)
pushList  = (<<=)
listVal a = val a >>== (\(AccList x) -> reverse x)
withList  =  with' newList listVal
onList   a b  =  listVal a >>= b
forL     a b  =  listVal a >>= mapM_ b
foreachL a b  =  listVal a >>= mapM b


-- |Äîáàâèòü çíà÷åíèå â ñïèñîê, õðàíèìûé ïî ññûëêå IORef
addToIORef :: IORef [a] -> a -> IO ()
addToIORef var x  =  var .= (x:)

-- |Èñïîëüçîâàòü çíà÷åíèå, õðàíÿùååñÿ ïî ññûëêå IORef, â ïðîöåäóðå,
-- è çàïèñàòü íà åãî ìåñòî íîâîå çíà÷åíèå, âîçâðàù¸ííîå ýòîé ïðîöåäóðîé
modifyIORefIO :: IORef a -> (a -> IO a) -> IO ()
modifyIORefIO var action = do
  readIORef var  >>=  action  >>=  writeIORef var

-- |Åù¸ îäíà ïîëåçíàÿ óïðàâëÿþùàÿ ñòðóêòóðà
with' init finish action  =  do a <- init;  action a;  finish a

-- |Âûïîëíèòü îïåðàöèþ è âîçâðàòèòü å¸ ðåçóëüòàò âíóòðè îáðàìëåíèÿ init/finish îïåðàöèé
inside init finish action  =  do init;  x <- action;  finish; return x

-- |Âûïîëíèòü "add key" c êåøèðîâàíèåì ðåçóëüòàòîâ
lookupMVarCache mvar add key = do
  modifyMVar mvar $ \assocs -> do
    case (lookup key assocs) of
      Just value -> return (assocs, value)
      Nothing    -> do value <- add key
                       return ((key,value):assocs, value)


-- JIT-ïåðåìåííûå èíèöèàëèçèðóþòñÿ òîëüêî â ìîìåíò èõ ïåðâîãî èñïîëüçîâàíè
newJIT init        = ref (Left init)
delJIT a    finish = whenRightM_ (val a) finish
valJIT a           = do x <- val a
                        case x of
                          Left init -> do x<-init; a=:Right x; return x
                          Right x   -> return x

withJIT init finish action = do a <- newJIT init;  action a  `finally`  delJIT a finish


---------------------------------------------------------------------------------------------------
---- Ññûëî÷íàÿ àðèôìåòèêà è îïåðàöèé íàä öåëûìè ---------------------------------------------------
---------------------------------------------------------------------------------------------------

infixl 6 +:, -:
ptr+:n   = ptr `plusPtr` (fromIntegral n)
ptr-:buf = fromIntegral  (ptr `minusPtr` buf)
copyBytesI dst src len  =  copyBytes dst src (i len)
minI a b                =  i$ min (i a) (i b)
maxI a b                =  i$ max (i a) (i b)
clipToMaxInt            =  i. min (i (maxBound::Int))
atLeast                 =  max
minusPositive a b       =  if a>b  then a-b  else 0
i                       =  fromIntegral
clipTo low high         =  min high . max low
divRoundUp   x chunk    =  ((x-1) `div` i chunk) + 1
roundUp      x chunk    =  divRoundUp x chunk * i chunk
divRoundDown x chunk    =  x `div` i chunk
roundDown    x chunk    =  divRoundDown x chunk * i chunk
roundTo      x chunk    =  i (((((toInteger(x)*2) `divRoundDown` chunk)+1) `divRoundDown` 2) * i chunk) `asTypeOf` x


---------------------------------------------------------------------------------------------------
---- Ðàñïðåäåëåíèå ïàìÿòè â öèêëè÷åñêîì áóôåðå ----------------------------------------------------
---------------------------------------------------------------------------------------------------

-- |Ðàñïðåäåëåíèå ïàìÿòè â öèêëè÷åñêîì áóôåðå ñ âûðàâíèâàíèåì âûäåëÿåìûõ áëîêîâ
--   heapsize     - ðàçìåð áóôåðà
--   aBUFFER_SIZE - ìàêñèìàëüíûé ðàçìåð ðàñïðåäåëÿåìîãî áëîêà
--   aALIGN       - âñå âûäåëÿåìûå áëîêè âûðàâíèâàþòñÿ íà ãðàíèöó, êðàòíóþ ýòîìó ÷èñëó
--   returnBlock  - ïðîöåäóðà ïîëó÷åíèÿ áóôåðà, îñâîáîæä¸ííîãî ïîòðåáèòåëåì. Âûçûâàåòñÿ,
--                    êîãäà ïàìÿòè ñòàíîâèòñÿ íåäîñòàòî÷íî äëÿ óäîâëåòâîðåíèÿ î÷åðåäíîãî çàïðîñà
--
allocator heapsize aBUFFER_SIZE aALIGN returnBlock = do
  let aHEAP_START = 0          -- íà÷àëî áóôåðà, äîëæíî áûòü = 0
      aHEAP_END   = heapsize   -- êîíåö áóôåðà

  start <- ref aHEAP_START     -- óêàçàòåëü íà÷àëà ñâîáîäíîãî ìåñòà â áóôåðå
  end   <- ref aHEAP_END       -- óêàçàòåëü êîíöà ñâîáîäíîãî ìåñòà
                               -- åñëè ýòè óêàçàòåëè ðàâíû, òî ñâîáîäíîãî ìåñòà íåò
#if 0
  let debug = putStr         -- îòëàäî÷íàÿ ïå÷àòü

  let printStats s = do      -- Íàïå÷àòàòü ñîñòîÿíèå áóôåðà ïðè îòëàäêå
        astart <- val start
        aend <- val end
        debug$ left_justify 48 s++"STATE start:"++show astart++", end:"++show aend++", avail:"++show ((aend-astart) `mod` aHEAP_END)++"\n"

  debug "\n"
#else
  let debug      = return
      printStats = return
#endif

  -- Âûðàâíÿòü çíà÷åíèå íà áëèæàéøóþ âåëè÷èíó, êðàòíóþ aALIGN
  let align n  =  (((n-1) `div` aALIGN) + 1) * aALIGN

  -- Âîçâðàùàåò àäðåñ áëîêà: >=n, âûðîâíåííîãî íà aALIGN è èìåþùåãî êàê ìèíèìóì aBUFFER_SIZE áàéò äî êîíöà áóôåðà
  let nextAvail n = if (aHEAP_END-aligned<aBUFFER_SIZE)
                      then aHEAP_END
                      else aligned
                    where aligned = align n

  -- Âîçâðàòèòü êîëè÷åñòâî ñâîáîäíîé ïàìÿòè â áóôåðå
  let available = do
        astart <- val start
        aend   <- val end
        if (astart<=aend) then
           return (aend-astart)
         else if (astart<aHEAP_END) then
           return (aHEAP_END-astart)
         else do
           -- Ïåðåâåñòè óêàçàòåëü íà÷àëà ñâîáîäíîé ïàìÿòè íà íà÷àëî áóôåðà
           start =: aHEAP_START
           debug "===================================\n"
           printStats ""
           available

  -- Äîæäàòüñÿ îñâîáîæäåíèÿ áëîêà ïàìÿòè è îòìåòèòü åãî îñâîáîæäåíèå
  let waitReleasingMemory = do
        (addr,size) <- returnBlock
        astart <- val start
        aend   <- val end
        unless (addr == aend || (addr==aHEAP_START && (aHEAP_END-aend<aBUFFER_SIZE)))$  fail "addToAvail!"
        let new_end = nextAvail(addr+size)
        if new_end == astart
          then do start=:aHEAP_START; end=:aHEAP_END -- now all memory is free
          else end =: new_end
        printStats$ "*** returned buf:"++show addr++" size:"++show size++"   "

  -- Ïîëó÷èòü î÷åðåäíîé áëîê ðàçìåðà aBUFFER_SIZE. Åñëè ñâîáîäíûõ áëîêîâ íåò - äîæäàòüñ
  --   âîçâðàùåíèÿ íåîáõîäèìîãî êîëè÷åñòâà âûäåëåííîé ïðåæäå ïàìÿòè
  let getBlock = do
        avail <- available
        if (avail >= aBUFFER_SIZE) then do
           block <- val start
           start =: error "Block not shrinked"
           return block
         else do
           waitReleasingMemory
           getBlock

  -- Óêîðîòèòü âûäåëåííûé áëîê äî ðàçìåðà `size`. Äîëæíà áûòü îáÿçàòåëüíî âûçâàíà ïîñëå getBlock
  let shrinkBlock block size = do
        astart <- val start
        --unless (astart == block)$      fail "Tried to shrink another block"
        unless (size <= aBUFFER_SIZE)$  fail "Growing instead of shrinking :)"
        start =: nextAvail(block+size)
        printStats$ "getBlock buf:"++show block++", size: "++show aBUFFER_SIZE++" --> "++show size++"    "

  -- Âîçâðàòèòü èíòåðôåéñ ê èñïîëüçîâàíèþ öèêëè÷åñêîãî áóôåðà
  return (getBlock, shrinkBlock)


-- |Öèêëè÷åñêèé àëëîêàòîð, èñïîëüçóþùèé áëîê ïàìÿòè `heap`.
-- Ïðåîáðàçóåò ôóíêöèè, ñ êîòîðûìè ðàáîòàåò ôóíêöèÿ `allocator`
memoryAllocator heap size chunksize align returnBlock = do
  let returnBlock2            =  do (buf,len) <- returnBlock; return (buf-:heap, len)
  (getBlock2, shrinkBlock2)  <-  allocator size chunksize align returnBlock2
  let getBlock                =  do block <- getBlock2; return (heap+:block)
      shrinkBlock buf len     =  do shrinkBlock2 (buf-:heap) len
  return (getBlock, shrinkBlock)


---------------------------------------------------------------------------------------------------
---- Ïîääåðæêà ðåãóëÿðíûõ âûðàæåíèé.                                                           ----
---- todo: #define FULL_REGEXP âêëþ÷àåò èñïîëüçîâàíèå ðàñøèðåííûõ ðåã. âûðàæåíèé: r[0-9][0-9]  ----
---------------------------------------------------------------------------------------------------

-- |Ñêîìïèëèðîâàííîå ïðåäñòàâëåíèå ðåãóëÿðíîãî âûðàæåíèÿ                            ÏÐÈÌÅÐ
data RegExpr = RE_End                     -- êîíåö ìàñêè                            ""
             | RE_Anything                -- ëþáàÿ ñòðîêà                           "*"
             | RE_AnyStr  RegExpr         -- '*', ïîñëå êîòîðîé áóäóò åù¸ '*'       '*':"bc*"
             | RE_FromEnd RegExpr         -- ïðîâåðèòü ñîîòâåòñòâèå RE êîíöà ñòðîêè '*':"bc"
             | RE_AnyChar RegExpr         -- ëþáîé ñèìâîë, çàòåì RE                 '?':"bc"
             | RE_Char    Char RegExpr    -- çàäàííûé ñèìâîë, çàòåì RE              'a':"bc"

-- |Ïðîâåðèòü, ÷òî ñòðîêà ñîäåðæèò îäèí èç ñèìâîëîâ,
-- èìåþùèõ ñïåöèàëüíîå çíà÷åíèå â ðåãóëÿðíûõ âûðàæåíèÿõ
is_wildcard s  =  s `contains_one_of` "?*"

-- |Ñêîìïèëèðîâàòü òåêñòîâîå ïðåäñòàâëåíèå ðåãóëÿðíîãî âûðàæåíèÿ â ñòðóêòóðó RegExpr
compile_RE s  =  case s of
  ""                         -> RE_End
  "*"                        -> RE_Anything
  '*':cs | cs `contains` '*' -> RE_AnyStr   (compile_RE  cs)
         | otherwise         -> RE_FromEnd  (compile_RE$ reverse s)
  '?':cs                     -> RE_AnyChar  (compile_RE  cs)
  c  :cs                     -> RE_Char   c (compile_RE  cs)

-- |Ïðîâåðèòü ñîîòâåòñòâèå ñòðîêè ñêîìïèëèðîâàííîìó ðåãóëÿðíîìó âûðàæåíèþ
match_RE r = case r of
  RE_End        -> null
  RE_Anything   -> const True
  RE_AnyStr   r -> let re = match_RE r in \s -> any re (tails s)
  RE_FromEnd  r -> let re = match_RE r in re . reverse
  RE_AnyChar  r -> let re = match_RE r in \s -> case s of
                     ""   -> False
                     _:xs -> re xs
  RE_Char   c r -> let re = match_RE r in \s -> case s of
                     ""   -> False
                     x:xs -> x==c && re xs

-- |Ïðîâåðèòü ñîîòâåòñòâèå ñòðîêè `s` ðåãóëÿðíîìó âûðàæåíèþ `re`
match re {-s-}  =  match_RE (compile_RE re) {-s-}

-- Perl-like names for matching routines
infix 4 ~=, !~
(~=)    = flip match
a !~ b  = not (a~=b)