1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151

------------------------------------------------------------------------------
--- Module with operations to simplify patterns (like
--- functional patterns, as patterns, lazy patterns).
--- 
--- @author Lasse Folger (with changes by Michael Hanus)
--- @version September 2015
------------------------------------------------------------------------------

module Reduction where

import AbstractCurry.Build
import AbstractCurry.Types
import List
import VariableGenerator

{- In diesem Modul sind Funktionen definiert, die zur Reduktion von
Funktionspattern, As-Pattern und LazyPattern auf Variablen und
Konstruktoren benoetigt werden, definiert.
-}




--Mittels dieser Funktion koennen in ein Modul alle Funktions und Aspattern
--reduziert werden.
newprog:: CurryProg -> CurryProg
newprog (CurryProg a b c fl d) = CurryProg a b c (replaceFuncPattern fl) d

--Reduziert die Pattern jeder Funktion der uebergebenen Liste
replaceFuncPattern:: [CFuncDecl] -> [CFuncDecl]
replaceFuncPattern funclist = map redefinefuncp funclist
 where
  redefinefuncp (CFunc     b c d e rules) =
                 CFunc b c d e (map transRule rules)
  redefinefuncp (CmtFunc a b c d e rules) =
                 CmtFunc a b c d e (map transRule rules)


--Reduziert die Pattern einer einzelnen Regel
transRule :: CRule -> CRule
transRule (CRule pats (CSimpleRhs rhs ldecls)) =
  transRule (CRule pats (CGuardedRhs [noGuard rhs] ldecls))
transRule r@(CRule pl (CGuardedRhs gl ld)) =
  guardedRule pl' gl' (ld ++ nub lva)
  where (_, npl)        = mapAccumL transPattern vars' pl
        vars'           = vars r
        pl'             = getP npl
        getP []         = []
        getP ((p,_):xs) = p : (getP xs)
        gl'             = if (null (simplifyrep replaced))
                                then gl
                                else mkGuardL gl guardExpr
        (guardExpr,lva) = pToExp (simplifyrep replaced)
        replaced        = filter notnull (snd (unzip npl))

notnull :: [a] -> Bool
notnull x       = not (null x)

--Hier werden im Pattern durch Variablen ersetzt und die entsprechende Ersetzung
--werden mit zurueckgegeben 
transPattern :: [CVarIName] -> CPattern -> ([CVarIName],(CPattern, [(CVarIName,CPattern)]))
transPattern v (CPComb qn pl)           = (uv,((CPComb qn np'),replaced))
  where (uv,npl)    = mapAccumL transPattern v pl
        np'             = getP npl
        getP []         = []
        getP ((p,_):xs) = p : (getP xs)
        replaced        = simplifyrep (filter notnull (snd (unzip npl)))
transPattern (v:vs) fp@(CPFuncComb _ _) = (vs,((CPVar v),[(v,fp)]++asre))
        where asre = findAs fp
transPattern v x@(CPLit _)              = (v,(x,[]))
transPattern v x@(CPVar _)              = (v,(x,[]))
transPattern v (CPAs n p)               = (uv,((CPAs n np),rl))
  where (uv,(np,rl)) = transPattern v p
transPattern v (CPLazy p)               = (uv,(np,rl))
  where (uv,(np,rl)) = transPattern v p
transPattern _ (CPRecord _ _)           = error "Records are not supported in this version"

--Erweitert alle Guards um eine Bedingung des Typs Success      
mkGuardL:: [(CExpr,CExpr)] -> CExpr -> [(CExpr,CExpr)]
mkGuardL [] _           = []
mkGuardL ((g,e):gs) exp = if (g == (CSymbol (pre "success")))
                           then [(exp,e)]
                           else ((applyF (pre "&>") [exp,g]),e): (mkGuardL gs exp)

--Fast eine Liste von Listen zu einer Liste zusammen
simplifyrep :: [[(CVarIName,CPattern)]] -> [(CVarIName,CPattern)]
simplifyrep []     = []
simplifyrep (x:xs) = x ++ (simplifyrep xs)

--Hier findet die syntaktische Uebersetzung eines Patterns in einen Ausdruck statt.
pToExp :: [(CVarIName,CPattern)] -> (CExpr,[CLocalDecl])
pToExp rep = ((pToExp' rep),freevars)
  where pat             = snd (unzip rep)
        freevars        = getV' pat
        pToExp' ((va,pa):ys)
          | null ys     = uni pa va
          | otherwise   = applyF (pre "&>") [uni pa va , pToExp' ys]
        uni pate vn     = applyF (pre "=:<=") [translate pate, CVar vn]
        getV pater      = case pater of
                          (CPVar n)
                            | (snd n) == "_" -> []
                            | otherwise      -> [CLocalVars [n]]
                          (CPFuncComb _ pl)  -> getV' pl
                          (CPComb _ pl)      -> getV' pl
                          (CPAs n pa)        -> [CLocalVars [n]] ++ getV pa
                          (CPLazy lp)        -> getV lp
                          _                  -> []
        getV' []        = []
        getV' (y:ys)    = (getV y) ++ (getV' ys)

--Findet alle (verschachtelten) As-Pattern
findAs:: CPattern -> [(CVarIName,CPattern)]
findAs (CPVar _)         = []
findAs (CPLit _)         = []
findAs (CPComb _ pl)     = find' pl
  where find' []     = []
        find' (x:xs) = (findAs x) ++ (find' xs)
findAs (CPAs n p)        = (n,simplified p) : (findAs p)
  where simplified x = case x of
                        (CPComb cn ps)     -> CPComb cn (map simplified ps)
                        (CPAs an _)        -> CPVar an
                        (CPFuncComb fn ps) -> CPFuncComb fn (map simplified ps)
                        (CPLazy pa)        -> simplified pa
                        _                 -> x
findAs (CPFuncComb _ pl) = find' pl
  where find' []     = []
        find' (x:xs) = (findAs x) ++ (find' xs)
findAs (CPLazy p)    = findAs p
findAs (CPRecord _ _) = error "Records are not supported in this version"

--Hilfsfunktion zu pToExp
translate:: CPattern -> CExpr
translate (CPComb qn pl)     = applyF qn (map translate pl)
translate (CPVar n)          = CVar n
translate (CPLit v)          = CLit v
translate (CPAs n _)         = CVar n
translate (CPFuncComb qn pl) = applyF qn (map translate pl)
translate (CPLazy p)         = translate p
translate (CPRecord _ _)     = error "Records are not supported in this version of the sequential rule translator!"