{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
             FunctionalDependencies, FlexibleContexts,
             UndecidableInstances #-}

{-

Commuting array access and structuring.

-}

module SArray (SArray(..)) where
import Data
import Control
import Struct
import Array

{-  Relate these:

 r   representation (of anyting)
 a   array (of anything)
 s   structure (of base types)
 sa  structure of arrays (of base types)
 as  array of structurs (of base types)
 sra structure of representations of arrays (of base types)
 sr  structure of representations (of base types)
-}



{- Transposing dereference (interchange structure and array deref).
   A.k.a. get/set structured.

   The class above can express:
   
     get  :: r (a (t1, t2)) -> r Tint -> m (r (t1, t2))
     get  :: r (a (L t))    -> r Tint -> m (r (L t))

   But for the following, which allows "distributing" Array's indexing
   over Struct's structuring, we need a separate approach.

     gets :: r (a t1, a t2) -> r Tint -> m (r (t1, t2))
     gets :: r (L (a t))    -> r Tint -> m (r (L t))


   Small reminder: the obsession with binary trees (as opposed to
   i.e. lists) is because forming products of data structures needs to be
   straightfoward for Arrow-like composition of state space systems.

-}

{-  The following used this naming scheme for types

 r   representation (of anyting)
 a   array (of anything)
 s   structure (of base types)
 sa  structure of arrays (of base types)
 as  array of structurs (of base types)
 sra structure of representations of arrays (of base types)
 sr  structure of representations (of base types)
-}
class (Data m r,
       Struct r sa sra,   -- structure of (a t_i)
       Struct r s sr)     -- structure of t_i
      => SArray m r s sa sr sra | -- r s -> sa sra,
                                  -- sra -> r s sa, 
                                  -- r sa -> sra s,
                                  -- sr -> r s sra
                                  s -> sa,
                                  sa -> s
                                  where
  

  gets ::  r sa -> r Tint -> m (r s)
  sets ::  r sa -> r Tint -> r s -> m (r ())
  

-- Base case delegates to Array instance.
instance (DataWord t,
          StructRepr r,
          Array m r a t)
         => SArray m r (L t) (L (a t)) (L (r t)) (L (r (a t))) where 
  
  gets r_sa i = do
    (L a) <- return $ unrep1 r_sa
    v     <- get a i
    return $ rep1 $ L v

  sets r_sa i v = do
    (L a) <- return $ unrep1 r_sa
    (L v) <- return $ unrep1 v
    set a i v
                   
  
-- Inductive case.
instance (SArray m r s1 sa1 sr1 sra1,
          SArray m r s2 sa2 sr2 sra2)
         => SArray m r (s1,s2) (sa1,sa2) (sr1,sr2) (sra1, sra2) where
  
  gets r_sa i = do
    (a1, a2) <- return $ unrep2 r_sa
    v1       <- gets a1 i
    v2       <- gets a2 i
    return $ rep2 (v1, v2)
    
  sets r_sa i v = do
    (a1, a2) <- return $ unrep2 r_sa
    (v1, v2) <- return $ unrep2 v
    sets a1 i v1
    sets a2 i v2
    
  
  
  
{- Class that encodes the isomorphism between: 
     struct { float a;  float b; }  *array_of_struct;
     struct { float *a; float *b; }  struct_of_array;

   (r st)   representation of struct
   rst      struct of representation

   (a st)   array of struct
   sat      struct of array
-}

{-
class (Loop stx m r,
       Struct stx r st rst)
      => TArray stx m r a st sat rst | a st -> sat,
                                       sat -> a st,
                                       st sat -> a where
  
  -- Convert struct of array(pointer) to array of struct..
  _aPack   :: r sat -> m (r (a st))
  
  -- .. and back.
  _aUnpack :: r (a st) -> m (r sat)
-}