From 48b8a1345ad599cc95b03b27864da366fca23671 Mon Sep 17 00:00:00 2001
From: aarne <aarne@cs.chalmers.se>
Date: Sun, 25 Mar 2007 19:16:47 +0000
Subject: [PATCH] param encoding

---
 devel/compiler/Param.hs | 38 ++++++++++++++++++++++++++++++++++++++
 1 file changed, 38 insertions(+)
 create mode 100644 devel/compiler/Param.hs

diff --git a/devel/compiler/Param.hs b/devel/compiler/Param.hs
new file mode 100644
index 000000000..06de62058
--- /dev/null
+++ b/devel/compiler/Param.hs
@@ -0,0 +1,38 @@
+type Param  = (Id,[Constr])
+type Constr = (Id,[Id])
+type Source = [Param] 
+type Id     = String
+
+type Target = [(Id,((Int,Int),[Id]))]
+
+compile :: Source -> Target
+compile src = ctyps ++ incss where
+  ctyps = map compT src
+  (typs,cons) = unzip src
+  compT (ty,cs) = 
+    (ty,((sum [product [size t | t <- ts] | (_,ts) <- cs],length cs),[]))
+  size ty = maybe undefined (fst . fst) $ lookup ty ctyps
+  incss = concat $ map (incs 0) cons
+  incs k cs = case cs of
+    (c,ts):cs2 -> 
+      let s = product (map size ts) in (c,((s,k),ts)) : incs (k+s) cs2
+    _ -> []
+
+newtype Value = V (Id,[Value])
+
+value :: Target -> Value -> Int
+value tg (V (f,xs)) = maybe undefined (snd . fst) (lookup f tg) + posit xs where
+  posit xs = 
+    sum [value tg x * product [size p | (_,p) <- xs2] | 
+                                i         <- [0..length xs -1], 
+                                let (x,_):xs2 = drop i (zip xs args)
+        ]
+  args = maybe undefined snd $ lookup f tg
+  size p = maybe undefined (fst . fst) $ lookup p tg
+
+ex1 :: Source
+ex1 = [
+  ("B",[("T",[]),("F",[])]),
+  ("G",[("M",[]),("Fe",[]),("N",[])]),
+  ("Q",[("Q1",["B"]),("Q2",["B","B"]),("Q3",["B","B","B"])])
+  ]