working on contraction

3 files changed, 34 insertions, 18 deletions

diff --git a/examples/pru.hs b/examples/pru.hs
index d6dc5d4..bddc08f 100644
--- a/examples/pru.hs
+++ b/examples/pru.hs
@@ -55,24 +55,23 @@ rd = (2><2)
 
 main = do
     print $ r |=| rd
+    print $ foldl part t [("p",1),("q",0),("r",2)]
     print $ foldl part t [("p",1),("r",2),("q",0)]
+    print $ foldl part t $ reverse [("p",1),("r",2),("q",0)]
 
 t = T [(4,(Covariant,"p")),(2,(Covariant,"q")),(3,(Contravariant,"r"))] $ fromList [1..24::Double]
 
 
 findIdx name t = ((d1,d2),m) where
     (d1,d2) = span (\(_,(_,n)) -> n /=name) (dims t)
-    c = product (map fst (tail d2))
+    c = product (map fst d2)
     m = matrixFromVector RowMajor c (ten t)
 
-
-putFirstIdx name t =
-    if null d1
-        then (nd,m)
-        else (nd,m')
+putFirstIdx name t = (nd,m')
     where ((d1,d2),m) = findIdx name t
-          m' = trans $ matrixFromVector RowMajor (fst $ head d2) $ dat m
+          m' = matrixFromVector RowMajor c $ cdat $ trans m
           nd = d2++d1
+          c = dim (ten t) `div` (fst $ head d2)
 
 part t (name,k) = if k<0 || k>=l
                     then error $ "part "++show (name,k)++" out of range in "++show t
@@ -88,8 +87,13 @@ parts t name = map f (toRows m)
 t1 = T [(4,(Covariant,"p")),(4,(Contravariant,"q")),(2,(Covariant,"r"))] $ fromList [1..32::Double]
 t2 = T [(4,(Covariant,"p")),(4,(Contravariant,"q"))] $ fromList [1..16::Double]
 
---contract1 t name1 name2 = map head $ zipWith drop [0..] (map (flip parts name2) (parts t name1))
+contract1 t name1 name2 = map head $ zipWith drop [0..] (map (flip parts name2) (parts t name1))
+
+sumT ls = foldl (zipWith (+)) [0,0..] (map (toList.ten) ls)
 
---sumT ls = foldl (zipWith (+)) [0,0..] (map (toList.ten) ls)
+on f g = \x y -> f (g x) (g y)
 
-on f g = \x y -> f (g x) (g y)
\ No newline at end of file
+contract t1 n1 t2 n2 = T (tail d1++tail d2) (cdat m)
+    where (d1,m1) = putFirstIdx n1 t1
+          (d2,m2) = putFirstIdx n2 t2
+          m = multiply RowMajor (trans m2) m1
\ No newline at end of file
diff --git a/lib/Data/Packed/Internal/Matrix.hs b/lib/Data/Packed/Internal/Matrix.hs
index 2c57c07..a6f7f0c 100644
--- a/lib/Data/Packed/Internal/Matrix.hs
+++ b/lib/Data/Packed/Internal/Matrix.hs
@@ -107,13 +107,17 @@ transdataR = transdataAux ctransR
 transdataC :: Int -> Vector (Complex Double) -> Int -> Vector (Complex Double)
 transdataC = transdataAux ctransC
 
-transdataAux fun c1 d c2 = unsafePerformIO $ do
-    v <- createVector (dim d)
-    let r1 = dim d `div` c1
+transdataAux fun c1 d c2 =
+    if noneed
+        then d
+        else unsafePerformIO $ do
+            v <- createVector (dim d)
+            fun r1 c1 (ptr d) r2 c2 (ptr v) // check "transdataAux" [d]
+            putStrLn "---> transdataAux"
+            return v
+  where r1 = dim d `div` c1
         r2 = dim d `div` c2
-    fun r1 c1 (ptr d) r2 c2 (ptr v) // check "transdataAux" [d]
-    --putStrLn "---> transdataAux"
-    return v
+        noneed = r1 == 1 || c1 == 1
 
 foreign import ccall safe "aux.h transR"
     ctransR :: Double ::> Double ::> IO Int
diff --git a/lib/Data/Packed/Internal/Tensor.hs b/lib/Data/Packed/Internal/Tensor.hs
index 11101a9..960e3c5 100644
--- a/lib/Data/Packed/Internal/Tensor.hs
+++ b/lib/Data/Packed/Internal/Tensor.hs
@@ -17,16 +17,24 @@ module Data.Packed.Internal.Tensor where
 
 import Data.Packed.Internal.Vector
 import Data.Packed.Internal.Matrix
-
+import Foreign.Storable
 
 data IdxTp = Covariant | Contravariant deriving Show
 
 data Tensor t = T { dims   :: [(Int,(IdxTp,String))]
                   , ten    :: Vector t
-                  } deriving Show
+                  }
 
 rank = length . dims
 
 outer u v = dat (multiply RowMajor r c)
     where r = matrixFromVector RowMajor 1 u
           c = matrixFromVector RowMajor (dim v) v
+
+instance (Show a,Storable a) => Show (Tensor a) where
+    show T {dims = [], ten = t} = "scalar "++show (t `at` 0)
+    show T {dims = ds, ten = t} = "("++shdims ds ++") "++ show (toList t)
+
+
+shdims [(n,(t,name))] = name++"["++show n++"]"
+shdims (d:ds) = shdims [d] ++ "><"++ shdims ds
\ No newline at end of file