{-# LANGUAGE DeriveGeneric #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Putlenses.Examples.Examples
-- Copyright   :  (C) 2013 Hugo Pacheco
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Hugo Pacheco <hpacheco@nii.ac.jp>
-- Stability   :  provisional
--
-- Collection of put-based programming examples
-- 
--
--
----------------------------------------------------------------------------

module Generics.Putlenses.Examples.Examples where

import Generics.Putlenses.Putlens
import Generics.Putlenses.Language
import Generics.Putlenses.TH
import GHC.Generics
import Data.Char as Char
import Data.Maybe as Maybe
import Data.List as Map
import Data.Map (Map(..))
import qualified Data.Map as Map
import Control.Monad.State (State,MonadState,StateT)
import qualified Control.Monad.State as State
import Control.Monad.Identity
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Monad.Writer

import Safe
import Data.List.Split

-- ** Lists

-- | Putlens version of @map@
mapPut :: (Monad m,Eq a) => PutlensM m b a -> PutlensM m [b] [a]
mapPut f = innPut .< (idPut -|-< f ><< mapPut f) .< outPut

-- | Putlens version of @foldr@ 
unfoldrPut :: (Monad m,Eq a,Eq b) => PutlensM m (b,a) a -> a -> PutlensM m [b] a
unfoldrPut f x = innPut .< (ignorePut x -|-< (idPut ><< unfoldrPut f x) .< f) .< injPut (\e v -> return $ v==x)

-- | Variant of @unfoldrPut@ that tries to present the original source branching even when the view value matches the stop condition
-- Useful for example for cases when we want to always preserve the length of the original source list.
unfoldrsPut :: (Monad m,Eq a,Eq b) => PutlensM m (b,a) a -> a -> PutlensM m [b] a
unfoldrsPut f x = innPut .< (ignorePut x -|-< (idPut ><< unfoldrsPut f x) .< f) .< injsOrPut (return . (==x))

-- *** Constructor/destructor putlenses for lists
nilPut :: Monad m => PutlensM m [a] ()
nilPut = innPut .< injlPut

consPut :: Monad m => PutlensM m [a] (a,[a])
consPut = innPut .< injrPut

unnilPut :: Monad m => PutlensM m () [a]
unnilPut = uninjlPut .< outPut

unconsPut :: Monad m => PutlensM m (a,[a]) [a]
unconsPut = uninjrPut .< outPut

unheadPut :: (Monad m,Eq a) => PutlensM m [a] a
unheadPut = consPut .< keepsndPut

untailPut :: (Monad m,Eq a) => PutlensM m [a] [a]
untailPut = consPut .< keepfstPut

wrapPut :: (Monad m,Eq a) => PutlensM m [a] a
wrapPut = consPut .< (idPut ><< nilPut) .< addsndOnePut

unwrapPut :: (Monad m,Eq a) => PutlensM m a [a]
unwrapPut = remsndOnePut .< (idPut ><< unnilPut) .< unconsPut

-- ** example of automatically deriving constructor/destructor putlenses for binary trees
data Tree a = Empty | Node a (Tree a) (Tree a) deriving Generic
$( makePutlensConstructors ''Tree)

-- ** List concatenation

-- | List concatenation (positional)
catPut :: (Monad m,Eq a) => PutlensM m ([a],[a]) [a]
catPut = (innPut ><< idPut) .< undistlPut .< (addfstOnePut -|-< assoclPut .< (idPut ><< catPut) .< unconsPut) .< choiceNil
	where choiceNil = ifVthenelsePut null injlPut injlsPut

exCatPut1 = get (put2lens catPut) ([1,2],[3,4])
exCatPut2 = put (put2lens catPut) ([1,2],[3,4]) [0,1,2,3,4]
exCatPut3 = put (put2lens catPut) ([1,2,3,4],[]) [0,1,2]
exCatPut4 = put (put2lens catPut) ([1,2],[3,4]) [0,1]

-- | List concatenation (split the view list at position n-1)
catPutN :: (Monad m,Eq a) => (Maybe ([a],[a]) -> [a] -> Int) -> PutlensM m ([a],[a]) [a]
catPutN f = runStatePut (\s v -> return $ f s v) catPutN'

catPutN' :: (Monad m,Eq a) => PutlensStateM m Int ([a],[a]) [a]
catPutN' = (innPut ><< idPut) .< undistlPut .< (addfstOnePut -|-< rec) .< (injPut p)
	where rec = withStatePut (\_ _ st -> return (pred st)) (assoclPut .< (idPut ><< catPutN') .< unconsPut)
	      p _ _ = do { st <- State.get;  return $ st == 0 }

-- | List concatenation (split the view list in half)
catPut2 = catPutN (\s v -> length v `div` 2)

exCatPut21 = get (put2lens catPut2) ([1,2],[3,4])
exCatPut22 = put (put2lens catPut2) ([1,2],[3,4]) [-2,-1,0,1,2,3,4]
exCatPut23 = put (put2lens catPut2) ([1,2,3,4],[]) [0,1,2]
exCatPut24 = put (put2lens catPut2) ([1,2],[3,4]) [0,1]

-- | List concatenation (puts elements to the left while satisfying a predicate)
catPutP :: (Monad m,Eq a) => (Maybe (Either [a] [a]) -> a -> m Bool) -> PutlensM m ([a],[a]) [a]
catPutP p = (innPut ><< idPut) .< undistlPut .< (addfstOnePut -|-< rec) .< (injPut (\s vs -> p s (head vs) >>= \b -> return $ null vs || not b))
	where rec = (assoclPut .< (idPut ><< catPutP p) .< unconsPut)
	
-- | List concatenation (puts elements to the left while being equal)
catPutSame :: (Monad m,Eq a) => PutlensM m ([a],[a]) [a]
catPutSame = runReaderPutV' $ catPutP (\s v -> ask >>= \v' -> p s v v')
    where p s v [] = return False
          p s v (x:xs) = return (x==v)

exCatPutSame1 = get (put2lens catPutSame) ([1,2],[3,4])
exCatPutSame2 = put (put2lens catPutSame) ([1,2],[3,4]) [5,5,5,5,6,7,8]
exCatPutSame3 = put (put2lens catPutSame) ([1,2],[3,4]) [0,1,2]

-- | List concatenation (puts elements to the left while smaller than a particular value)
catPutPred :: (Monad m,Ord a) => a -> PutlensM m ([a],[a]) [a]
catPutPred x = catPutP (\i v -> return (v <= x))

exCatPutPred1 = get (put2lens $ catPutPred 1) ([1,2],[3,4])
exCatPutPred2 = put (put2lens $ catPutPred 1) ([1,2],[3,4]) [-2,-1,0,1,2,3,4]
exCatPutPred3 = put (put2lens $ catPutPred 1) ([1,2,3,4],[]) [0,1,2]
exCatPutPred4 = put (put2lens $ catPutPred 1) ([1,2],[3,4]) [0,1]

-- | Left list filtering lens.
-- The argument passed to @keepfstOrPut@ can be undefined because it will never be used
filterleftPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [a]
filterleftPut = innPut .< (idPut -|-< (idPut ><< filterleftPut) .< undistlPut) .< coassocrPut .< (outPut -|-< keepfstPut) .< injlsPut
	
-- | Right list filtering lens.
-- The argument passed to @keepsndOrPut@ can be undefined because it will never be used
filterrightPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [b]
filterrightPut = innPut .< (idPut -|-< (idPut ><< filterrightPut) .< undistlPut .< coswapPut) .< coassocrPut .< (outPut -|-< keepfstPut) .< injlsPut

-- ** Integers

succPut :: Monad m => PutlensM m Int Int
succPut = customPut (\s -> return . succ) pred

predPut :: Monad m => PutlensM m Int Int
predPut = customPut (\s -> return . pred) succ

-- ** Naturals

data Nat = ZeroN | SuccN Nat deriving (Eq,Show,Generic)
$( makePutlensConstructors ''Nat)

natPut :: Monad m => PutlensM m Nat Int
natPut = ifVthenelsePut (==0) (zeroNPut .< ignorePut 0) (succNPut .< natPut .< predPut)

int = get (put2lens natPut)
nat = runIdentity . put (put2lens natPut) ZeroN

-- ** List length

-- | Length as a natural number
lengthNatPut :: (Monad m,Eq a) => (Int -> a) -> PutlensM m [a] Nat
lengthNatPut f = innPut .< (idPut -|-< (idPut ><< lengthNatPut f) .< addfstPut restoreVal) .< outPut
    where restoreVal Nothing n = return $ f (int n)
          restoreVal (Just (x,_)) _ = return x

exLengthNatPut1 = get (put2lens $ lengthNatPut $ \i -> chr (ord 'A' + i)) "abcd"
exLengthNatPut2 = put (put2lens $ lengthNatPut $ \i -> chr (ord 'A' + i)) "abcd" (nat 10)
exLengthNatPut3 = put (put2lens $ lengthNatPut $ \i -> chr (ord 'A' + i)) "abcd" (nat 2)

-- ** List lookup

-- | Embeds a value at a fixed position in a list
embedAtPut :: (Monad m,Eq a) => Int -> PutlensM m [a] a
embedAtPut 0 = unheadPut
embedAtPut n = untailPut .< embedAtPut (n-1)

-- | Embeds a value at a fixed position in a list (supports extending the length original list)
embedAtPut1 :: (Monad m,Eq a) => Int -> PutlensM m [a] a
embedAtPut1 0 = consPut .< keepsndOrPut (\v -> return [])
embedAtPut1 n = consPut .< keepfstOrPut (\v -> return $ head v) .< embedAtPut1 (n-1)

-- | Embeds a value at a fixed position in a list (source induction)
embedAtPut2 :: (Monad m,Eq a) => Int -> PutlensM m [a] a
embedAtPut2 i = fixedi .< embedAtPut2'
    where fixedi = remfstPut (\x -> ()) .< (ignorePut i ><< idPut)
embedAtPut2' :: (Monad m,Eq a) => PutlensM m (Int,[a]) a
embedAtPut2' = ifSthenelsePut (\(i,l) -> i == 0) stop it
    where stop = addfstPut (\m v -> return 0) .< unheadPut
          it = (succPut ><< untailPut) .< embedAtPut2'

-- | Embeds a value at a fixed position in a list (supports extending the length original list) (source induction)
embedAtPut3 :: (Monad m,Eq a) => Int -> PutlensM m [a] a
embedAtPut3 i = fixedi .< runStatePut (\e v' -> return v') embedAtPut3'
    where fixedi = remfstPut (\x -> ()) .< (ignorePut i ><< idPut)
embedAtPut3' :: (Monad m,Eq a) => PutlensStateM m a (Int,[a]) a
embedAtPut3' = ifSthenelsePut (\(i,l) -> i == 0) stop it
    where stop = addfstPut (\m v -> return 0) .< unheadPut'
          it = (succPut ><< untailPut') .< embedAtPut3'
          unheadPut' = consPut .< keepsndOrPut (\v -> return [])
          untailPut' = consPut .< keepfstOrPut (\v -> State.get)

exEmbedAtPut1 = get (put2lens $ embedAtPut 2) "abcd"
exEmbedAtPut2 = put (put2lens $ embedAtPut 2) "abcd" 'x'
exEmbedAtPut3 = put (put2lens $ embedAtPut 2) "a" 'x'
exEmbedAtPut4 = get (put2lens $ embedAtPut1 2) "a"
exEmbedAtPut5 = put (put2lens $ embedAtPut1 2) "a" 'x'

-- | Embeds a value at a fixed position in a list (splitAt approach)
embedAtPut4 :: (Monad m,Eq a) => Int -> PutlensM m [a] a
embedAtPut4 i = fixedi .< splitAtPut .< keepfstPut .< unheadPut
    where fixedi = remfstPut (\x -> ()) .< (ignorePut i ><< idPut)

splitAtPut :: (Monad m,Eq a) => PutlensM m (Int,[a]) ([a],[a])
splitAtPut = (stop .\/< rec) .< distlPut .< (outPut ><< idPut)
    where stop = (phiPut (==0) .< newPut 0 ><< idPut)
          rec = (succPut ><< consPut) .< subrPut .< (idPut ><< splitAtPut) .< assocrPut

exEmbedAtPut41 = get (put2lens $ embedAtPut4 3) "abcde"
exEmbedAtPut42 = put (put2lens $ embedAtPut4 3) "abcde" 'x'
exEmbedAtPut43 = put (put2lens $ embedAtPut4 3) "a" 'x'

-- ** List summation

-- | Splits a view number into two summands (by adding an offset to the original first value)
splitPut :: (Monad m,Integral a) => (a -> a -> m a) -> PutlensM m (a,a) a
splitPut offset = customPut put' (uncurry (+))
    where put' (Just (x,y)) z = do
	 	    off <- offset (x + y) z
	 	    let x' = x + off
	 	    return (x',z - x')
          put' Nothing z = return (z,0)

-- | Updates the sum of a list (preserves the original source and appends the difference to the end)
summandsPut1 :: (Monad m,Integral a) => PutlensM m [a] a
summandsPut1 = (unfoldrPut splitBy 0)
    where splitBy = splitPut (\e v -> return 0)

-- | Updates the sum of a list (distributes the difference by dividing it by two at each recursive step)
-- half of the difference is added to the first element of the source, a quarter to the second, and so on until the remainder is 0
summandsPut2 :: (Monad m,Integral a) => PutlensM m [a] a
summandsPut2 = (unfoldrPut splitBy 0)
    where splitBy = (splitPut (\v v' -> return $ div (v' - v) 2))

-- | Updates the sum of a list (distributes the difference by dividing it by the length of the original list)
-- distributes the difference evenly among original list numbers
summandsPut3 :: (Monad m,Integral a) => PutlensM m [a] a
summandsPut3 = runStatePut (\s v -> return $ toEnum (maybe 1 length s)) summandsPut3'
summandsPut3' :: (Monad m,Integral a) => PutlensStateM m a [a] a
summandsPut3' = unfoldrPut (updateStatePut (\s v st -> return $ pred st) splitBy) 0
    where splitBy = splitPut (\v v' -> State.get >>= return . div (v' - v))

-- | Updates the sum of a list (distributes the difference by dividing it by the length of the original list, always preserving the size f the original list even when the view is zero)
summandsPut4 :: (Monad m,Integral a) => PutlensM m [a] a
summandsPut4 = runStatePut (\s v -> return $ toEnum (maybe 1 length s)) summandsPut4'
summandsPut4' :: (Monad m,Integral a) => PutlensStateM m a [a] a
summandsPut4' = unfoldrsPut (updateStatePut (\s v st -> return $ pred st) splitBy) 0
    where splitBy = (splitPut (\v v' -> do {st <- State.get; return $ div (v' - v) st }))

exSummandsPut1 = get (put2lens summandsPut1) [1,2,3,4]
exSummandsPut2 = runIdentity $ put (put2lens summandsPut1) [1,2,3,4] 15
exSummandsPut3 = runIdentity $ put (put2lens summandsPut2) [1,2,3,4] 15
exSummandsPut4 = runIdentity $ put (put2lens summandsPut3) [1,2,3,4] 15
exSummandsPut5 = runIdentity $ put (put2lens summandsPut3) [1,2,3,4] 0
exSummandsPut6 = runIdentity $ put (put2lens summandsPut4) [1,2,3,4] 15
exSummandsPut7 = runIdentity $ put (put2lens summandsPut4) [1,2,3,4] 0

-- ** Replicate

-- | Replicate
replicatePut :: (Monad m,Eq a) => PutlensM m (a,Int) [a]
replicatePut = (zero .\/< (one .\/< rec) .< distrPut .< (idPut ><< outPut)) .< outPut
    where zero = keepfstPut .< phiPut (==0) .< newPut 0
          one = idPut ><< phiPut (==1) .< newPut 1
          rec = (idPut ><< succPut) .< remfstPut fst .< (idPut ><< replicatePut .< consPut)

exReplicatePut1 = put (put2lens replicatePut) ('b',2) "aaaa"
exReplicatePut2 = put (put2lens replicatePut) ('b',2) ""

-- | Replicates a list of elements into a sequence of replicated elements
replicateListPut :: (Monad m,Eq a) => PutlensM m [(a,Int)] [a]
replicateListPut = recoverzerosPut .< mapPut replicatePut .< splitListPut

recoverzerosPut :: (Monad m,Eq a) => PutlensM m [(a,Int)] [(a,Int)]
recoverzerosPut = ifthenelsePut (\s v -> return $ p s) zero rec
    where p (Just ((a,0):xs)) = True
          p _ = False
          zero = phiPut (p . Just) .< consPut .< (idPut ><< recoverzerosPut) .< addfstPut (\(Just (x,xs)) v -> return x)
          rec = innPut .< (idPut -|-< idPut ><< recoverzerosPut) .< outPut

splitListPut :: (Monad m,Eq a) => PutlensM m [[a]] [a]
splitListPut = innPut .< (idPut -|-< ifVthenelsePut p eq neq .< (idPut ><< splitListPut)) .< outPut
    where p (x,(x':xs):xss) = x == x'
          p (x,xss) = False
          eq = (consPut ><< idPut) .< assoclPut .< (idPut ><< unconsPut)
          neq = wrapPut ><< idPut

exReplicateListPut1 = get (put2lens replicateListPut) [('a',4),('b',0),('c',3)]
exReplicateListPut2 = put (put2lens replicateListPut) [('a',4),('b',0),('c',3)] "xxyyz"

-- ** Halve

-- | Takes the first half of a list (with a default empty element)
halvePut :: (Monad m,Eq a) => a -> PutlensM m [a] [a]
halvePut x = remfstPut half .< splitAtPut .< addsndPut right
    where half xs = let d = length xs
	                in if even d then d `div` 2 else (d `div` 2)+1
          right (Just (l,r)) v = let s = take (length v) r
                                 in return $ s ++ replicate (length v - length s - 1) x

exHalvePut1 = put (put2lens $ halvePut ' ') "abcde" "xy"
exHalvePut2 = put (put2lens $ halvePut '0') "xyz" "abcde"

-- | Takes the first half of a list (using an increasing counter with each consumed element in the forward direction)
halvePut2 :: (Monad m,Eq a) => a -> PutlensM m [a] [a]
halvePut2 x = remsndPut (const 0) .< halvePut2' x .< addsndPut (\e -> return . length)
	
halvePut2' :: (Monad m,Eq a) => a -> PutlensM m ([a],Int) ([a],Int)
halvePut2' x = (phiPut ifcond .< empty .\/< rec) .< distlPut .< (outPut ><< idPut)
    where ifcond (xs,k) = k >= length xs
          empty = addfstPut appendRight .< remfstOnePut
          appendRight (Just (rs,_)) k = return $ if k >= length rs then take (pred k) (rs++repeat x) else take k rs
          appendRight Nothing k = return $ take (pred k) (repeat x)
          rec = (consPut ><< predPut) .< assoclPut .< (idPut ><< halvePut2' x) .< assocrPut
          
exHalvePut21 = put (put2lens $ halvePut2 ' ') "abcde" "xy"
exHalvePut22 = put (put2lens $ halvePut2 '0') "xyz" "abcde"
exHalvePut23 = put (put2lens $ halvePut2 ' ') "abc" "xy"

-- | Takes the first half of a list (using a decreasing counter with the size of the input list, decreased 2 by 2, in the forward direction)
halvePut3 :: (Monad m,Eq a) => a -> PutlensM m [a] [a]
halvePut3 x = runStatePut (\_ _ -> return 0) $ remsndPut length .< halvePut3' x

halvePut3' :: (Monad m,Eq a) => a -> PutlensStateM m Int ([a],Int) [a]
halvePut3' x = ifVthenelsePut null (nil .< unnilPut) (cons .< unconsPut)
    where nil = phiPut (\(xs,k) -> k <= 0) .< pntPut appendRight
          appendRight (Just (rs,_)) = do
			k <- State.get
			return $ if k >= length rs then (take (pred k) (rs++repeat x),-1) else (take k rs,0)
          appendRight Nothing = do
			k <- State.get
			return $ (take (pred k) (repeat x),-1)
          cons = (consPut ><< succPut .< succPut) .< assoclPut .< (withStatePut (\_ _ i -> return $ succ i) idPut ><< halvePut3' x)

exHalvePut31 = put (put2lens $ halvePut3 ' ') "abcde" "xy"
exHalvePut32 = put (put2lens $ halvePut3 '0') "xyz" "abcde"
exHalvePut33 = put (put2lens $ halvePut3 ' ') "abc" "xy"

-- | Incremental summation
isumPut :: Monad m => PutlensM m [Int] [Int]
isumPut = innPut .< (idPut -|-< (idPut ><< isumPut) .< paramfstPut dec) .< outPut
	where dec i = mapPut (subtractPut i)

subtractPut :: Monad m => Int -> PutlensM m Int Int
subtractPut i = customPut (\s x -> return $ x-i) (+i)

exIsumPut1 = get (put2lens isumPut) [1,2,3,4]
exIsumPut2 = put (put2lens isumPut) [1,2,3,4] [3,4]

-- ** Sorting

-- | Insertion sort (put according to the original relative source order)
iunsortPut1 :: (Monad m,Ord a) => PutlensM m [a] [a]
iunsortPut1 = ifVthenelsePut null (nilPut .< unnilPut) it
	where it = consPut .< (idPut ><< iunsortPut1) .< delPut1

delPut1 :: (Monad m,Ord a) => PutlensM m (a,[a]) [a]
delPut1 = ifVthenelsePut (null . snd) idPut disarrange .< unconsPut
  where  disarrange = ifSthenelsePut p idPut it
         p (x,ys) = x <= head ys
         it = (idPut ><< consPut) .< subrPut .< (idPut ><< delPut1)

-- | Insertion sort (identity backward transformation)
iunsortPut2 :: (Monad m,Ord a) => PutlensM m [a] [a]
iunsortPut2 = ifVthenelsePut null (nilPut .< unnilPut) swap
	where swap = consPut .< (idPut ><< iunsortPut2) .< delPut2

delPut2 :: (Monad m,Ord a) => PutlensM m (a,[a]) [a]
delPut2 = ifVthenelsePut (null . snd) idPut disarrange .< unconsPut
  where  disarrange = ifthenelsePut test (phiPut p) swap
         p (x,ys) = x <= head ys
         swap = (idPut ><< consPut) .< subrPut .< (idPut ><< delPut2)
         test (Just v) v' = if p v && v == v' then return False else return True
         test _ v' = return True

exIunsortPut1 = runIdentity $ put (put2lens iunsortPut1) [4,1,3,2] [5,6,7,8,9,10]
exIunsortPut2 = runIdentity $ put (put2lens iunsortPut2) [4,1,3,2] [5,6,7,8,9,10]
exIunsortPut3 = runIdentity $ put (put2lens iunsortPut2) [4,1,3,2] [1,2,3,4]

-- | Quicksort (put according to the original relative source order)
qsortPut :: (Monad m,Ord a) => PutlensM m [a] [a]
qsortPut = innPut .< (unnilPut -|-< partitionPut .< (idPut ><< (qsortPut ><< qsortPut)) .< subrPut .< (idPut ><< unconsPut) .< catPutNonEmptyRight) .< (injPut (\e -> return . null))

-- | Partition a list into smaller and bigger elements than a given element
partitionPut :: (Monad m,Ord a) => PutlensM m (a,[a]) (a,([a],[a]))
partitionPut = customPut (\s (y,(xs,ys)) -> return $ (y,xs++ys)) (\(x,xs) -> (x,partition (<x) xs))

-- List concatenation (put guarantees that the right side has always one element)
catPutNonEmptyRight :: (Monad m,Eq a) => PutlensM m ([a],[a]) [a]
catPutNonEmptyRight = catPutN f
	where f Nothing v = 0
	      f (Just (xs,y)) v = if length xs > length v then 0 else length xs

exQsortPut1 = get (put2lens qsortPut) [4,3,1,2]
exQsortPut2 = put (put2lens qsortPut) [4,1,3,2] [-4,-3,-2,-1,0,7]
exQsortPut3 = put (put2lens qsortPut) [4,1,3,2] [5,6,7,8,9,10]

-- | Adds positions to a list (using an higher-order function)
positionsPut :: (Monad m,Eq a) => PutlensM m [a] [(Pos,a)]
positionsPut = positionsPut' 0

positionsPut' :: (Monad m,Eq a) => Pos -> PutlensM m [a] [(Pos,a)]
positionsPut' i = innPut .< (idPut -|-< remfstPut (const i) ><< positionsPut' (succ i)) .< outPut

-- | Adds positions to a list (using environment)
positionsPut2 :: (Monad m,Eq a) => PutlensM m [a] [(Pos,a)]                                              
positionsPut2 = remfstPut (const 0) .< runReaderPutV' positionsPut2' 
positionsPut2' :: (Monad m,Eq a) => PutlensReaderM m [(Pos,a)] (Int,[a]) [(Pos,a)]                              
positionsPut2' = (idPut ><< innPut) .< undistrPut .< (empty -|-< it) .< outPut          
  where  empty = addfstPut (\s v -> ask >>= \m -> return $ length m)                                       
         it = (remsndPut succ ><< idPut) .< distpPut .< (idPut ><< positionsPut2')

exPositions1 = get (put2lens positionsPut) "abcd"
exPositions2 = runIdentity $ put (put2lens positionsPut) "abcd" [(0,'x'),(1,'y')]
exPositions3 = runIdentity $ put (put2lens positionsPut) "abcd" [(0,'x'),(1,'y'),(2,'a'),(3,'b'),(4,'c'),(5,'d')]

-- ** Exception handling

-- | Appends two strings with a separating space
appendWithSepPut :: Monad m => String -> PutlensM m (String,String) String
appendWithSepPut sep = customPut put (\(s1,s2) -> s1++sep++s2)
    where put s v = case splitOn sep v of
          				(x:y:xs) -> return (x,y ++ concat (map (sep++) xs))
          				otherwise -> fail "qwe"

-- | Parsing/pretty-printing lens version using @read@/@show@
readPut :: (MonadPlus m,Read a,Show a) => PutlensM m a String
readPut = PutlensM getputM createM
    where createM v = case readMay v of { Just s -> return s; Nothing -> fail "failed to cast string" }
          getputM s = (Just $ show s,createM)

-- | Parses a string into a sequence of @Int@ or @Bool@ values separated by a single space
unwordsIntBool :: PutlensM Maybe [Either Int Bool] String
unwordsIntBool = mapPut (injunionPut readPut readPut) .< unwordsPut

-- | Putlens inverse of @unwords@
unwordsPut :: PutlensM Maybe [String] String
unwordsPut = unionPut (nilPut .< ignorePut "") (unfoldr1Put (appendWithSepPut " "))

-- | Putlens inverse of @foldr1@, a specialization of @foldr@ for non-empty lists
unfoldr1Put :: (MonadPlus m,Eq a) => PutlensM m (a,a) a -> PutlensM m [a] a
unfoldr1Put f = unionPut wrapPut (consPut .< (idPut ><< unfoldr1Put f) .< f)

-- ** Maximum segment sum

type Pos = Int

segments :: [a] -> [[a]]
segments = concat . map inits . tails

-- | Updating maximum segment sum
-- when the sum increases, update only the largest segment
-- when the sum decreases, update all segments that surpass the new maximum, from smallest to largest
mssPut :: Monad m => PutlensM m [Int] Int
mssPut = runReaderPutV (ifKthenelsePut (\s v' -> ask >>= \v -> return $ v < v') (mssPut' True) (mssPut' False))
mssPut' b = positionsPut .< remsndPut (sortedsegments b) .< (fromListPut ><< idPut) .< maxSumSegsPut
  where sortedsegments b = sortBy (comparelength b) . filter (/=[]) . segments . map fst
        comparelength b x y = if b then compare (length y) (length x) else compare (length x) (length y)
                                                                                     
maxSumSegsPut :: Monad m => PutlensReaderM m Int (Map Pos Int,[[Pos]]) Int                             
maxSumSegsPut = runStatePut (\e m' -> return False) maxSumSegsPut'      
maxSumSegsPut' :: Monad m => PutlensStateM (ReaderT Int m) Bool (Map Pos Int,[[Pos]]) Int                      
maxSumSegsPut' = (idPut ><< innPut) .< undistrPut .< (empty -|-< it) .< injlsPut          
  where  empty = keepfstPut .< modifyV' (\e v -> return 0) (ignorePut 0)
         it = unforkPut ((idPut ><< keepsndPut) .< lookupSegPut .< summandsPut4) ((idPut ><< keepfstPut) .< maxSumSegsPut') .< maxPut

lookupSegPut :: (Monad m,Eq a) => PutlensM m ((Map Int a,[Int])) [a]
lookupSegPut = (idPut ><< innPut) .< undistrPut .< (keepfstPut -|-< it) .< outPut
    where it = unforkPut ((idPut ><< keepsndPut) .< swapPut .< lookupIntMapPut) ((idPut ><< keepfstPut) .< lookupSegPut)

lookupIntMapPut :: (Monad m,Eq a) => PutlensM m ((Int,Map Int a)) a
lookupIntMapPut = (idPut ><< toListPut) .< embedAtPut2' .< keepfstPut

maxPut :: (Monad m) => PutlensStateM (ReaderT Int m) Bool ((Int,Int)) Int
maxPut = runReaderPutMbS $ ifthenelsePut (\s m -> do { st <- State.get; xmax <- lift ask; cond st xmax s m }) left right
  where  left = phiPut (\(x,y) -> x < y) .< addfstPut (\_ m -> do { Just (x,y) <- ask; return x }) 
         right = addsndPut (\e m -> return m)
         cond st xmax Nothing m = State.put True >> return True
         cond st xmax (Just (x,y)) m | not st && x == xmax = State.put True >> return False -- if the maximum has decreased, this condition will eventually be activated
                                     | x >= m = State.put True >> return False -- if x is larger, we need to truncate it
                                     | x < m = return True -- if x is smaller, just proceed recursively

fromListPut :: (Monad m,Eq a,Ord k) => PutlensM m [(k,a)] (Map k a)
fromListPut = customPut (\s -> return . Map.toList) Map.fromList

toListPut :: (Monad m,Eq a,Ord k) => PutlensM m (Map k a) [(k,a)]
toListPut = customPut (\s -> return . Map.fromList) Map.toList

exMssPut1 = get (put2lens mssPut) [1,2,-3,4]
exMssPut2 = runIdentity $ put (put2lens mssPut) [1,2,-3,4] 6
exMssPut3 = runIdentity $ put (put2lens mssPut) [1,2,-3,4] 2
exMssPut4 = runIdentity $ put (put2lens mssPut) [1,2,-3,4] (-4)
exMssPut5 = runIdentity $ put (put2lens mssPut) [1,2,-3,4] 0