Migrated source code from Simantics SVN

[simantics/platform.git] / bundles / org.simantics.scl.runtime / scl / Vector.scl

diff --git a/bundles/org.simantics.scl.runtime/scl/Vector.scl b/bundles/org.simantics.scl.runtime/scl/Vector.scl
new file mode 100644 (file)
index 0000000..51ec078
--- /dev/null
+++ b/bundles/org.simantics.scl.runtime/scl/Vector.scl
@@ -0,0 +1,173 @@
+import "Prelude"
+import "IterN"
+
+infixl 7  (**), dotp
+
+importJava "java.lang.System" where
+    @JavaName arraycopy
+    copyFromVector :: Vector a -> Integer -> MVector a -> Integer -> Integer -> <Proc> ()
+    
+    @JavaName arraycopy
+    copyFromMVector :: MVector a -> Integer -> MVector a -> Integer -> Integer -> <Proc> ()
+
+@inline
+mvector :: VecComp a => [a] -> <Proc> MVector a
+mvector l = do
+    len = length l 
+    result = createMVector len
+    iterIList (setMVector result) l
+    result
+    
+@inline
+vector :: VecComp a => [a] -> Vector a
+vector l = runProc (freezeMVector (mvector l))
+
+@inline
+vectorF :: VecComp a => Integer -> (Integer -> <e> a) -> <e> Vector a
+vectorF l f = runProc do
+     result = createMVector l
+     forN l $ \i -> setMVector result i (f i)
+     freezeMVector result
+
+@inline
+singletonVector :: VecComp a => a -> Vector a
+singletonVector v = runProc do
+    result = createMVector 1
+    setMVector result 0 v
+    freezeMVector result
+
+@inline
+@private
+subVector :: Vector a -> Integer -> Integer -> Vector a
+subVector src begin end = runProc do
+    len = end-begin
+    result = createMVectorProto src len
+    copyFromVector src begin result 0 len
+    freezeMVector result
+
+@inline
+concatVector :: Vector a -> Vector a -> Vector a
+concatVector a b = runProc do
+    lenA = lengthVector a
+    lenB = lengthVector b    
+    result = createMVectorProto a (lenA + lenB)
+    copyFromVector a 0 result 0 lenA
+    copyFromVector b 0 result lenA lenB
+    freezeMVector result
+
+@inline
+mapVector :: VecComp a => VecComp b => (a -> b) -> Vector a -> Vector b
+mapVector f a = vectorF (length a) (\i -> f (a!i))
+
+@inline
+zipVectorsWith :: VecComp a => VecComp b => VecComp c => (a -> b -> c) -> Vector a -> Vector b -> Vector c
+zipVectorsWith f a b = vectorF (length a) (\i -> f (a!i) (b!i))
+     
+instance (VecComp a, Additive a) => Additive (Vector a) where
+    @inline
+    zero = runProc (freezeMVector (createMVector 0))
+    @inline
+    a + b = runProc do
+        lenA = lengthVector a
+        lenB = lengthVector b    
+        if lenA < lenB
+        then do
+            result = createMVectorProto a lenB
+            forN lenA $ \i -> setMVector result i (a!i + b!i)
+            copyFromVector b lenA result lenA (lenB-lenA)
+            freezeMVector result
+        else if lenA > lenB
+        then do
+            result = createMVectorProto a lenA
+            forN lenB $ \i -> setMVector result i (a!i + b!i)
+            copyFromVector a lenB result lenB (lenA-lenB)
+            freezeMVector result
+        else do
+            result = createMVectorProto a lenA
+            forN lenA $ \i -> setMVector result i (a!i + b!i)
+            freezeMVector result
+
+instance (VecComp a, Ring a) => Ring (Vector a) where
+    @inline
+    a - b = runProc do
+        lenA = lengthVector a
+        lenB = lengthVector b    
+        if lenA < lenB
+        then do
+            result = createMVectorProto a lenB
+            forN lenA $ \i -> setMVector result i (a!i - b!i)
+            forN (lenB-lenA) $ \i -> setMVector result (lenA+i) (- b!(lenA+i))
+            freezeMVector result
+        else if lenA > lenB
+        then do
+            result = createMVectorProto a lenA
+            forN lenB $ \i -> setMVector result i (a!i - b!i)
+            copyFromVector a lenB result lenB (lenA-lenB)
+            freezeMVector result
+        else do
+            result = createMVectorProto a lenA
+            forN lenA $ \i -> setMVector result i (a!i - b!i)
+            freezeMVector result
+    @inline
+    neg = mapVector (\x -> -x)
+    one = fail "Unsupported operation one for Vector"
+    (*) = fail "Unsupported operation (*) for Vector"
+    fromInteger = fail "Unsupported operation fromInteger for Vector"
+
+@inline
+dotp :: Ring a => VecComp a => Vector a -> Vector a -> a
+dotp a b = foldlN (\sum i -> sum + a!i * b!i) 0 (min (length a) (length b)) 
+
+@inline
+normSq a = foldlN (\sum i -> do v = a!i ; sum + v*v) 0 (length a)
+
+@inline
+norm a = sqrt (normSq a)
+
+maxNorm a = foldlN (\cur i -> max cur (abs (a!i))) 0 (length a)
+
+l1Norm a = foldlN (\cur i -> cur + abs (a!i)) 0 (length a)
+
+@inline
+(**) :: Ring a => VecComp a => a -> Vector a -> Vector a
+s ** a = mapVector (\x -> s*x) a
+
+instance (Show a, VecComp a) => Show (Vector a) where
+    s <+ v = s << "vector " <+ [v!i | i <- [0..lengthVector v-1]]
+
+instance (VecComp a) => Sequence (Vector a) where
+    @inline
+    length = lengthVector
+    @inline
+    sub = subVector
+
+instance IndexedSequence Vector where
+    (!) = getVector
+    
+@inline
+iterVector :: (a -> <e> b) -> Vector a -> <e> ()
+iterVector f v = forN (lengthVector v) (\i -> f (getVector v i))
+
+@inline
+foldlVector :: (a -> b -> <e> a) -> a -> Vector b -> <e> a
+foldlVector f initial v = foldlN (\cur i -> f cur (getVector v i)) initial (lengthVector v)
+
+@inline
+anyVector :: (a -> <e> Boolean) -> Vector a -> <e> Boolean
+anyVector f v = anyN (\i -> f (getVector v i)) (lengthVector v)
+
+@inline
+allVector :: (a -> <e> Boolean) -> Vector a -> <e> Boolean
+allVector f v = allN (\i -> f (getVector v i)) (lengthVector v)
+
+@inline
+mapFirstVector :: (a -> <e> Maybe b) -> Vector a -> <e> Maybe b
+mapFirstVector f v = mapFirstN (\i -> f (getVector v i)) (lengthVector v)
+
+@inline
+containsVector :: Eq a => a -> Vector a -> Boolean
+containsVector x v = foldlN (\result i -> result || (v!i == x)) False (lengthVector v)
+
+@inline
+vectorToList :: Vector a -> [a]
+vectorToList v = foldlN (\l i -> addList l (v ! i)) [] (lengthVector v)