diff options
author | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-29 15:27:53 +0100 |
---|---|---|
committer | Csaba Hruska <csaba.hruska@gmail.com> | 2016-01-29 15:27:53 +0100 |
commit | fe9a7c6d0af59227ff34b098f2a5ba1359790ae8 (patch) | |
tree | 3bb7170620c4b914d8bc39127af1e4fb4627fab3 /lambdacube-ir.haskell/src/LambdaCube | |
parent | 0c885c5c6bfb69c543635fd08d697ce44f24642d (diff) |
add Schema to IR module, also use namespace
Diffstat (limited to 'lambdacube-ir.haskell/src/LambdaCube')
l--------- | lambdacube-ir.haskell/src/LambdaCube/IR.hs | 1 | ||||
-rw-r--r-- | lambdacube-ir.haskell/src/LambdaCube/Linear.hs | 60 | ||||
l--------- | lambdacube-ir.haskell/src/LambdaCube/Mesh.hs | 1 | ||||
l--------- | lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs | 1 | ||||
-rw-r--r-- | lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs | 20 |
5 files changed, 83 insertions, 0 deletions
diff --git a/lambdacube-ir.haskell/src/LambdaCube/IR.hs b/lambdacube-ir.haskell/src/LambdaCube/IR.hs new file mode 120000 index 0000000..7b90d33 --- /dev/null +++ b/lambdacube-ir.haskell/src/LambdaCube/IR.hs | |||
@@ -0,0 +1 @@ | |||
../../../ddl/out/LambdaCube.IR.hs \ No newline at end of file | |||
diff --git a/lambdacube-ir.haskell/src/LambdaCube/Linear.hs b/lambdacube-ir.haskell/src/LambdaCube/Linear.hs new file mode 100644 index 0000000..286cc93 --- /dev/null +++ b/lambdacube-ir.haskell/src/LambdaCube/Linear.hs | |||
@@ -0,0 +1,60 @@ | |||
1 | {-# LANGUAGE DeriveFunctor, OverloadedStrings #-} | ||
2 | module LambdaCube.Linear where | ||
3 | |||
4 | import Data.Int | ||
5 | import Data.Word | ||
6 | import Data.Map | ||
7 | |||
8 | import Data.Text | ||
9 | import Data.Aeson | ||
10 | import Control.Monad | ||
11 | |||
12 | data V2 a = V2 !a !a deriving (Eq,Ord,Show,Read,Functor) | ||
13 | data V3 a = V3 !a !a !a deriving (Eq,Ord,Show,Read,Functor) | ||
14 | data V4 a = V4 !a !a !a !a deriving (Eq,Ord,Show,Read,Functor) | ||
15 | |||
16 | -- matrices are stored in column major order | ||
17 | type M22F = V2 V2F | ||
18 | type M23F = V3 V2F | ||
19 | type M24F = V4 V2F | ||
20 | type M32F = V2 V3F | ||
21 | type M33F = V3 V3F | ||
22 | type M34F = V4 V3F | ||
23 | type M42F = V2 V4F | ||
24 | type M43F = V3 V4F | ||
25 | type M44F = V4 V4F | ||
26 | |||
27 | type V2F = V2 Float | ||
28 | type V3F = V3 Float | ||
29 | type V4F = V4 Float | ||
30 | type V2I = V2 Int32 | ||
31 | type V3I = V3 Int32 | ||
32 | type V4I = V4 Int32 | ||
33 | type V2U = V2 Word32 | ||
34 | type V3U = V3 Word32 | ||
35 | type V4U = V4 Word32 | ||
36 | type V2B = V2 Bool | ||
37 | type V3B = V3 Bool | ||
38 | type V4B = V4 Bool | ||
39 | |||
40 | instance ToJSON a => ToJSON (V2 a) where | ||
41 | toJSON (V2 x y) = object ["x" .= x, "y" .= y] | ||
42 | |||
43 | instance ToJSON a => ToJSON (V3 a) where | ||
44 | toJSON (V3 x y z) = object ["x" .= x, "y" .= y, "z" .= z] | ||
45 | |||
46 | instance ToJSON a => ToJSON (V4 a) where | ||
47 | toJSON (V4 x y z w) = object ["x" .= x, "y" .= y, "z" .= z, "w" .= w] | ||
48 | |||
49 | instance FromJSON a => FromJSON (V2 a) where | ||
50 | parseJSON (Object obj) = V2 <$> obj .: "x" <*> obj .: "y" | ||
51 | parseJSON _ = mzero | ||
52 | |||
53 | instance FromJSON a => FromJSON (V3 a) where | ||
54 | parseJSON (Object obj) = V3 <$> obj .: "x" <*> obj .: "y" <*> obj .: "z" | ||
55 | parseJSON _ = mzero | ||
56 | |||
57 | instance FromJSON a => FromJSON (V4 a) where | ||
58 | parseJSON (Object obj) = V4 <$> obj .: "x" <*> obj .: "y" <*> obj .: "z" <*> obj .: "w" | ||
59 | parseJSON _ = mzero | ||
60 | |||
diff --git a/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs b/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs new file mode 120000 index 0000000..9dfc009 --- /dev/null +++ b/lambdacube-ir.haskell/src/LambdaCube/Mesh.hs | |||
@@ -0,0 +1 @@ | |||
../../../ddl/out/LambdaCube.Mesh.hs \ No newline at end of file | |||
diff --git a/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs new file mode 120000 index 0000000..afe52ef --- /dev/null +++ b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchema.hs | |||
@@ -0,0 +1 @@ | |||
../../../ddl/out/LambdaCube.PipelineSchema.hs \ No newline at end of file | |||
diff --git a/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs new file mode 100644 index 0000000..a5eac55 --- /dev/null +++ b/lambdacube-ir.haskell/src/LambdaCube/PipelineSchemaUtil.hs | |||
@@ -0,0 +1,20 @@ | |||
1 | {-# LANGUAGE FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-} | ||
2 | module LambdaCube.PipelineSchemaUtil where | ||
3 | |||
4 | import Control.Monad.Writer | ||
5 | import qualified Data.Map as Map | ||
6 | import LambdaCube.PipelineSchema | ||
7 | |||
8 | a @: b = tell [(a,b)] | ||
9 | defObjectArray n p m = mapM_ tell [PipelineSchema (Map.singleton n $ ObjectArraySchema p $ Map.singleton a t) mempty | (a,t) <- execWriter m] | ||
10 | defUniforms m = tell $ PipelineSchema mempty $ Map.fromList $ execWriter m | ||
11 | makeSchema a = execWriter a :: PipelineSchema | ||
12 | |||
13 | unionObjectArraySchema (ObjectArraySchema a1 b1) (ObjectArraySchema a2 b2) = | ||
14 | ObjectArraySchema (if a1 == a2 then a1 else error $ "object array schema primitive mismatch " ++ show (a1,a2)) | ||
15 | (Map.unionWith (\a b -> if a == b then a else error $ "object array schema attribute type mismatch " ++ show (a,b)) b1 b2) | ||
16 | |||
17 | instance Monoid PipelineSchema where | ||
18 | mempty = PipelineSchema mempty mempty | ||
19 | mappend (PipelineSchema a1 b1) (PipelineSchema a2 b2) = | ||
20 | PipelineSchema (Map.unionWith unionObjectArraySchema a1 a2) (Map.unionWith (\a b -> if a == b then a else error $ "schema type mismatch " ++ show (a,b)) b1 b2) | ||