-----------------------------------------------------------------------------
-- |
-- Module      :  Generics.Pointless.DLenses.RecursionPatterns
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Pointless Lenses:
-- bidirectional lenses with point-free programming
-- 
-- This module provides catamorphism and anamorphism bidirectional combinators for the definition of recursive delta-lenses.
--
-----------------------------------------------------------------------------

module Generics.Pointless.DLenses.RecursionPatterns where

import Data.Relation
import Data.Shape
import Data.Diff
import Generics.Pointless.DLenses
import Generics.Pointless.DLenses.Combinators
import Generics.Pointless.DLenses.ShapeCombinators
import Generics.Pointless.HFunctors

import Generics.Pointless.Functors
import Generics.Pointless.Combinators

import Data.Set (Set)
import qualified Data.Set as Set

-- | Inn isomorphism delta lens
hinn_dlns :: (Hu s,Shapely s,Shapely (H s s)) => DLens (H s s) a s a
hinn_dlns = DLens get' getd' put' putd' create' created'
    where get' s = hinn s
          getd' s = locsR s
          put' (v,s) dV = hout v
          putd' v s dV = inlPosR (v,s)
          create' v = hout v
          created' v = locsR v

-- | Out isomorphism delta lens
hout_dlns :: (Hu s,Shapely s,Shapely (H s s)) => DLens s a (H s s) a
hout_dlns = DLens get' getd' put' putd' create' created'
    where get' s = hout s
          getd' s = locsR s
          put' (v,s) dV = hinn v
          putd' v s dV = inlPosR (v,s)
          create' v = hinn v
          created' v = locsR v

class SHFunctor (f :: (* -> *) -> (* -> *)) (g :: * -> *) (h :: * -> *) where
	-- | Higher-order functor mapping (on shapes)
	hmap_dlns  :: (Shapely (HRep f g),Shapely (HRep f h)) => AnnH f -> DLens g a h a -> DLens (HRep f g) a (HRep f h) a
	-- | Higher-order functor strength (on shapes)
	hstrength  :: Shapely g => AnnH f -> ((HRep f h) a,g a) -> DLens g a h a -> Delta ((HRep f h) a) (h a) -> (HRep f g) a
	-- | Horizontal delta produced by the higher-order functor strength combinator
	hstrengthd :: Shapely g => AnnH f -> (HRep f h) a -> g a -> DLens g a h a -> Delta ((HRep f h) a) (h a) -> Delta ((HRep f g) a) ((HRep f h) a,g a)

instance SHFunctor HId x y where
	hmap_dlns _ l = l
	hstrength _ (fv,s) l dV = put l (fv,s) dV
	hstrengthd _ fv s l dV = putd l fv s dV
instance SHFunctor (HConst c) x y where
	hmap_dlns _ l = id_dlns
	hstrength _ (fv,s) l dV = fv
	hstrengthd _ fv s l dV = inlPosR (fv,s)
instance SHFunctor HParam x y where
	hmap_dlns _ l = id_dlns
	hstrength _ (fv,s) l dV = fv
	hstrengthd _ fv s l dV = inlPosR (fv,s)
instance Shapely f => SHFunctor (HFun f) x y where
	hmap_dlns _ l = id_dlns
	hstrength _ (fv,s) l dV = fv
	hstrengthd _ fv s l dV = inlPosR (fv,s)
instance (Shapely (HRep f y),Shapely (HRep f x),Shapely (HRep g y),Shapely (HRep g x),SHFunctor f x y,SHFunctor g x y) => SHFunctor (f :*~: g) x y where
	hmap_dlns (_::AnnH (f:*~:g)) l = hmap_dlns (ann::AnnH f) l ><<~ hmap_dlns (ann::AnnH g) l
	hstrength (_::AnnH (f:*~:g)) (ProdF fv gv,s) l dV = ProdF (hstrength (ann::AnnH f) (fv,s) l d1) (hstrength (ann::AnnH g) (gv,s) l d2)
	  where d1 = dV .~ inlPosR (fv,gv)
	        d2 = dV .~ inrPosR (fv,gv)
	hstrengthd (_::AnnH (f:*~:g)) p@(ProdF fv gv) s l dV = eitherPosR (hstrength (ann::AnnH f) (fv,s) l d1,hstrength (ann::AnnH g) (gv,s) l d2)
	    (sumPosR (fv,s) (p,s) (inlPosR (fv,gv)) (locsR s) .~ hstrengthd (ann::AnnH f) fv s l d1)
	    (sumPosR (gv,s) (p,s) (inrPosR (fv,gv)) (locsR s) .~ hstrengthd (ann::AnnH g) gv s l d2)
	  where d1 = dV .~ inlPosR (fv,gv)
	        d2 = dV .~ inrPosR (fv,gv)
instance (Shapely (HRep f y),Shapely (HRep f x),Shapely (HRep g y),Shapely (HRep g x),SHFunctor f x y,SHFunctor g x y) => SHFunctor (f :+~: g) x y where
	hmap_dlns (_::AnnH (f:+~:g)) l = hmap_dlns (ann::AnnH f) l -|-<~ hmap_dlns (ann::AnnH g) l
	hstrength (_::AnnH (f:+~:g)) (InlF fv,s) l dV = InlF $ hstrength (ann::AnnH f) (fv,s) l dV
	hstrength (_::AnnH (f:+~:g)) (InrF gv,s) l dV = InrF $ hstrength (ann::AnnH g) (gv,s) l dV
	hstrengthd (_::AnnH (f:+~:g)) (InlF fv) s l dV = hstrengthd (ann::AnnH f) fv s l dV
	hstrengthd (_::AnnH (f:+~:g)) (InrF gv) s l dV = hstrengthd (ann::AnnH g) gv s l dV

-- | Higher-order catamorphism delta lens
cata_dlns :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
             , SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
             , Shapely (H s s),Shapely (H s v),Shapely (HRep (HF s) (Const One))
             )
          => Ann (Fix s) -> DLens (H s v) a v a -> DLens s a v a
cata_dlns (anns::Ann (Fix s)) l = DLens get' getd' put' putd' create' created'
    where get' x = get cata x
          getd' x = getd cata x
          put' (y::v a,x) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrink_cata anns l (y,x) dV
                             | Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = grow_cata anns l (y,x) dV
                             | otherwise = put cata (y,x) dV
			where -- all the elements at the head of the original source not deleted by get
				  setS = rng $ inv (getd' x) .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> s a))) (hout x)
				  -- all the elements at the head of the modified view
				  setV = rng $ created l y .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> v a))) (create l y)
          putd' (y::v a) x dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrinkd_cata anns l y x dV
                              | Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = growd_cata anns l y x dV
                              | otherwise = putd cata y x dV
              where setS = rng $ inv (getd' x) .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> s a))) (hout x)
              	    setV = rng $ created l y .~ getd (hmap_dlns annf (bang_dlns (_L :: Const One a -> v a))) (create l y)
          create' y = create cata y
          created' y = created cata y
          cata = l .<~ hmap_dlns annf (cata_dlns anns l) .<~ hout_dlns
          annf = ann :: AnnH (HF s)

shrink_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
               , SHFunctor (HF s) s v,SHFunctor (HF s) v (Const One),SHFunctor (HF s) s (Const One)
               , Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One)),Shapely (HRep (HF s) s)
               )
            => Ann (Fix s) -> DLens (H s v) a v a -> (v a,s a) -> Delta (v a) (v a) -> s a
shrink_cata (anns::Ann (Fix s)) l (y,x) dG = put (cata_dlns anns l) (y,x') dV
    where -- reduced source
          x' = reduce' annf anns (hout x)
          reduceh = dnat (reduce' annf anns) (hout x)
          dV = inv (getd (cata_dlns anns l) x') .~ inv reduceh .~ getd (cata_dlns anns l) x .~ dG
          annf = ann :: AnnH (HF s)

shrinkd_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
               , SHFunctor (HF s) s v,SHFunctor (HF s) v (Const One),SHFunctor (HF s) s (Const One)
               , Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One)),Shapely (HRep (HF s) s)
               )
             => Ann (Fix s) -> DLens (H s v) a v a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
shrinkd_cata (anns::Ann (Fix s)) l y x dG = sumPosR (y,x') (y,hout x) (locsR y) reduceh .~ putd (cata_dlns anns l) y x' dV
    where -- reduced source
          x' = reduce' annf anns (hout x)
          reduceh = dnat (reduce' annf anns) (hout x)
          dV = inv (getd (cata_dlns anns l) x') .~ inv reduceh .~ getd (cata_dlns anns l) x .~ dG
          annf = ann :: AnnH (HF s)

grow_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
             , SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
             , Shapely (H s s),Shapely (H s v),Shapely (H s (Const One))
             )
          => Ann (Fix s) -> DLens (H s v) a v a -> (v a,s a) -> Delta (v a) (v a) -> s a
grow_cata (anns::Ann (Fix s)) l (y,x) dG = hinn $ hstrength annf (create l y,x) (cata_dlns anns l) dG
    where dV = dG .~ created l y
          annf = ann :: AnnH (HF s)

growd_cata :: ( FMonoid s,HFoldable (HF s),Hu s,Shapely s,Shapely v
              , SHFunctor (HF s) s v,SHFunctor (HF s) s (Const One),SHFunctor (HF s) v (Const One)
              , Shapely (HRep (HF s) s),Shapely (HRep (HF s) v),Shapely (HRep (HF s) (Const One))
              )
           => Ann (Fix s) -> DLens (H s v) a v a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
growd_cata (anns::Ann (Fix s)) l y x dG = sumPosR (create l y,x) (y,x) (created l y) (locsR x) .~ hstrengthd annf (create l y) x (cata_dlns anns l) dG
    where dV = dG .~ created l y
          annf = ann :: AnnH (HF s)
	
-- | Higher-order anamorphism delta lens
ana_dlns :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
            , SHFunctor (HF v) s v,SHFunctor (HF v) v (Const One),SHFunctor (HF v) s (Const One)
            , Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
            )
         => Ann (Fix v) -> DLens s a (H v s) a -> DLens s a v a
ana_dlns (annv::Ann (Fix v)) l = DLens get' getd' put' putd' create' created'
    where get' x = get ana x
          getd' x = getd ana x
          put' (y,x::s a) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrink_ana annv l (y,x) dV
                             | Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = grow_ana annv l (y,x) dV
                             | otherwise = put ana (y,x) dV
            where -- all the elements at the head of the original source not abstracted by get
                  setS = rng $ inv (getd ana x) .~ getd l x .~ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> s a))) (get l x)
                  -- all the elements at the head of the modified view
                  setV = rng $ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> v a))) (hout y)
          putd' y (x::s a) dV | Set.size setS > 0 && Set.null (setS `Set.intersection` (rng dV)) = shrinkd_ana annv l y x dV
                              | Set.size setV > 0 && Set.null (setV `Set.intersection` (dom dV)) = growd_ana annv l y x dV
                              | otherwise = putd ana y x dV
            where setS = rng $ inv (getd ana x) .~ getd l x .~ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> s a))) (get l x)
                  setV = rng $ getd (hmap_dlns anng (bang_dlns (_L :: Const One a -> v a))) (hout y)
          create' y = create ana y
          created' y = created ana y
          ana = hinn_dlns .<~ hmap_dlns anng (ana_dlns annv l) .<~ l
          anng = ann :: AnnH (HF v)

shrink_ana :: ( Hu v,FMonoid s,HFoldable (HF v),Shapely s,Shapely v
              , SHFunctor (HF v) s v,SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One)
              , Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
              )
           => Ann (Fix v) -> DLens s a (H v s) a -> (v a,s a) -> Delta (v a) (v a) -> s a
shrink_ana (annv::Ann (Fix v)) l (y,x::s a) dG = put (ana_dlns annv l) (y,x') dV
    where -- reduced source
          x' = reduce' anng anns (get l x)
          reduceh = dnat (reduce' anng anns) (get l x)
          dV = inv (getd (ana_dlns annv l) x') .~ inv reduceh .~ inv (getd l x) .~ getd (ana_dlns annv l) x .~ dG
          anng = ann :: AnnH (HF v)
          anns = ann :: Ann (Fix s)

shrinkd_ana :: ( Hu v,FMonoid s,HFoldable (HF v),Shapely s,Shapely v
               , SHFunctor (HF v) s v,SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One)
               , Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
               )
            => Ann (Fix v) -> DLens s a (H v s) a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
shrinkd_ana (annv::Ann (Fix v)) l y (x::s a) dG = sumPosR (y,x') (y,x) (locsR y) (getd l x .~ reduceh) .~ putd (ana_dlns annv l) y x' dV
    where -- reduced source
          x' = reduce' anng anns (get l x)
          reduceh = dnat (reduce' anng anns) (get l x)
          dV = inv (getd (ana_dlns annv l) x') .~ inv reduceh .~ inv (getd l x) .~ getd (ana_dlns annv l) x .~ dG
          anng = ann :: AnnH (HF v)
          anns = ann :: Ann (Fix s)

grow_ana :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
            , SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One),SHFunctor (HF v) s v
            , Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
            )
         => Ann (Fix v) -> DLens s a (H v s) a -> (v a,s a) -> Delta (v a) (v a) -> s a
grow_ana (annv::Ann (Fix v)) l (y,x) dG = create l $ hstrength anng (hout y,x) (ana_dlns annv l) dV
    where dV = dG
          anng = ann :: AnnH (HF v)

growd_ana :: ( Hu v,Shapely s,Shapely v,FMonoid s,HFoldable (HF v)
             , SHFunctor (HF v) s (Const One),SHFunctor (HF v) v (Const One),SHFunctor (HF v) s v
             , Shapely (H v s),Shapely (H v v),Shapely (H v (Const One))
             )
          => Ann (Fix v) -> DLens s a (H v s) a -> v a -> s a -> Delta (v a) (v a) -> Delta (s a) (v a,s a)
growd_ana (annv::Ann (Fix v)) l y x dG = hstrengthd anng (hout y) x (ana_dlns annv l) dV .~ created l y'
    where -- grown view
          y' = hstrength anng (hout y,x) (ana_dlns annv l) dV
          dV = dG
          anng = ann :: AnnH (HF v)