-----------------------------------------------------------------------------
-- |
-- 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 miscellaneous 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.Exception
import Control.Monad.Writer

import Safe
import Data.List.Split

-- ** Lists

-- | Unzips a list into two lists (creating empty tail lists by default)
unzipPut :: (Monad m,Eq a,Eq b) => PutlensM m ([a],[b]) [(a,b)]
unzipPut = (innPut ><< innPut) .< undistsPut .< coassocrPut .< (newPut c -|-< distpPut .< (idPut ><< unzipPut)) .< outPut
	where c = Left $ Left ((),())

-- | Putlens version of @map@
mapPut :: (Monad m) => 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)

-- | Putlens version of @unfoldr@
foldrPut :: Monad m => PutlensM m b (Either () (a,b)) -> PutlensM m b [a]
foldrPut f = f .< (idPut -|-< idPut ><< foldrPut f) .< outPut

-- | Putlens version of @mfilter@
mfilterPut :: MonadPlus m => (s -> Bool) -> PutlensM m s v -> PutlensM m s v
mfilterPut p f = PutlensM getput' create' where
	getput' s = let (v,putf) = getputM f s in (v,mfilter p . putf)
	create' v' = mfilter p (createM f v')

-- | 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 -|-< r) .< (injPut p)
	where r = 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 :: Eq a => PutlensM Identity ([a],[a]) [a]
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 -|-< r) .< (injPut (\s vs -> p s (head vs) >>= \b -> return $ null vs || not b))
	where r = (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)

catPutSameMb :: Eq a => PutlensM Identity ([a],[a]) [a]
catPutSameMb = catPutSame
exCatPutSame1 = get (put2lens catPutSameMb) ([1,2],[3,4])
exCatPutSame2 = put (put2lens catPutSameMb) ([1,2],[3,4]) [5,5,5,5,6,7,8]
exCatPutSame3 = put (put2lens catPutSameMb) ([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))

catPutPredMb :: Ord a => a -> PutlensM Identity ([a],[a]) [a]
catPutPredMb = catPutPred
exCatPutPred1 = get (put2lens $ catPutPredMb 1) ([1,2],[3,4])
exCatPutPred2 = put (put2lens $ catPutPredMb 1) ([1,2],[3,4]) [-2,-1,0,1,2,3,4]
exCatPutPred3 = put (put2lens $ catPutPredMb 1) ([1,2,3,4],[]) [0,1,2]
exCatPutPred4 = put (put2lens $ catPutPredMb 1) ([1,2],[3,4]) [0,1]

-- | Left list filtering lens (but will drop some right elements if the view list is smaller).
-- The argument passed to @keepfstOrPut@ can be undefined because it will never be used
filterlPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [a]
filterlPut = innPut .< (idPut -|-< (idPut ><< filterlPut) .< undistlPut) .< coassocrPut .< (outPut -|-< keepfstPut) .< injlsPut
	
-- | Right list filtering lens (but will drop some left elements if the view list is smaller).
-- The argument passed to @keepsndOrPut@ can be undefined because it will never be used
filterrPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [b]
filterrPut = innPut .< (idPut -|-< (idPut ><< filterrPut) .< undistlPut .< coswapPut) .< coassocrPut .< (outPut -|-< keepfstPut) .< injlsPut

-- | List filtering lens that splits a list of eithers into a list two lists.
-- The boolean argument allows controlling the priority of left/right values in the source list.
partitionPut :: (Monad m,Eq a,Eq b) => Bool -> PutlensM m [Either a b] ([a],[b])
partitionPut b = innPut .< (idPut -|-< (idPut ><< partitionPut b) .< undistlPut) .< (remfstOnePut -|-< f) .< coassocrPut .< distsPut .< (outPut ><< outPut)
	where f = (assocrPut .< (idPut ><< innPut) .< undistrPut -|-< subrPut .< (innPut ><< idPut) .< undistlPut) .< coassoclPut .< (idPut -|-< g) .< cosubrPut
	      g = cosubrPut .< (idPut -|-< h)
	      h = if b then injrsPut else injlsPut

-- | Left list filtering lens (that recovers all right elements).
filterleftPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [a]
filterleftPut = partitionPut True .< keepsndOrPut (\l -> return [])

filterPut :: (Monad m,Eq a) => (a -> Bool) -> PutlensM m [a] [a]
filterPut p = mapPut (phiPut p `eitherPutUnsafe` phiPut (not . p)) .< filterleftPut

-- | Right list filtering lens (that recovers all left elements).
filterrightPut :: (Monad m,Eq a,Eq b) => PutlensM m [Either a b] [b]
filterrightPut = partitionPut False .< keepfstOrPut (\r -> return [])

-- ** 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 .\/< r) .< distlPut .< (outPut ><< idPut)
    where stop = (phiPut (==0) .< newPut 0 ><< idPut)
          r = (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) -> 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' = if (x+y-z == 0) then 0 else 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 (\(x,y) v' -> return $ div (v' - (x+y)) 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 (\(x,y) v' -> State.get >>= return . div (v' - (x+y)))

-- | Updates the sum of a list (distributes the difference by dividing it by the length of the original list, always preserving the size of 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 (\(x,y) v' -> do {st <- State.get; return $ div (v' - (x+y)) 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 .\/< r) .< distrPut .< (idPut ><< outPut)) .< outPut
    where zero = keepfstPut .< phiPut (==0) .< newPut 0
          one = idPut ><< phiPut (==1) .< newPut 1
          r = (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 r
    where p (Just ((a,0):xs)) = True
          p _ = False
          zero = phiPut (p . Just) .< consPut .< (idPut ><< recoverzerosPut) .< addfstPut (\(Just (x,xs)) v -> return x)
          r = 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

halvePutMb :: Eq a => a -> PutlensM Identity [a] [a]
halvePutMb = halvePut
exHalvePut1 = put (put2lens $ halvePutMb ' ') "abcde" "xy"
exHalvePut2 = put (put2lens $ halvePutMb '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 .\/< r) .< 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)
          r = (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,[]) = True
         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,[]) = True
         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 -|-< qpartitionPut .< (idPut ><< (qsortPut ><< qsortPut)) .< subrPut .< (idPut ><< unconsPut) .< catPutNonEmptyRight) .< (injPut (\e -> return . null))

-- | Partition a list into smaller and bigger elements than a given element
qpartitionPut :: (Monad m,Ord a) => PutlensM m (a,[a]) (a,([a],[a]))
qpartitionPut = 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 = runIdentity $ put (put2lens qsortPut) [4,1,3,2] [-4,-3,-2,-1,0,7]
exQsortPut3 = runIdentity $ 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] [(Int,a)]
positionsPut = positionsPut' 0

positionsPut' :: (Monad m,Eq a) => Int -> PutlensM m [a] [(Int,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] [(Int,a)]                                              
positionsPut2 = remfstPut (const 0) .< runReaderPutV' positionsPut2' 
positionsPut2' :: (Monad m,Eq a) => PutlensReaderM m [(Int,a)] (Int,[a]) [(Int,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')

exIntitions1 = get (put2lens positionsPut) "abcd"
exIntitions2 = runIdentity $ put (put2lens positionsPut) "abcd" [(0,'x'),(1,'y')]
exIntitions3 = 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 = (return $ 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)