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
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227

-----------------------------------------------------------------------------
--- This module contains a transformation from possibly
--- non-deterministically defined operations into purely deterministic
--- operations. The transformation is based on the "planned choices"
--- approach described in [this paper](http://dx.doi.org/10.4204/EPTCS.234.13):
--- 
--- S. Antoy, M. Hanus, and S. Libby:
--- _Proving non-deterministic computations in Agda_.
--- In Proc. of the 24th International Workshop on Functional and
--- (Constraint) Logic Programming (WFLP 2016),
--- volume 234 of Electronic Proceedings in Theoretical Computer Science,
--- pages 180--195. Open Publishing Association, 2017.
---
--- Thus, an additional "choice plan" argument is added to each
--- non-deterministic operation. This plan determines the
--- branches chosen by the operation to compute some value.
---
--- This transformation can be used to verify non-determinstic operations
--- by showing their correct behavior for all possible plans.
---
--- @author  Michael Hanus
--- @version September 2019
---------------------------------------------------------------------------

module FlatCurry.Typed.NonDet2Det
  ( nondetOfFuncDecls, addChoiceFuncDecl )
 where

import List ( maximum, nub )

-- Imports from dependencies:
import FlatCurry.Annotated.Goodies

import FlatCurry.Typed.Goodies ( funcsOfExpr, pre )
import FlatCurry.Typed.Types

----------------------------------------------------------------------------
--- Returns the non-determinism status for all functions in a
--- list of function declarations.
--- It is assumed that this list contains the declarations of all functions
--- occurring in these declarations.
--- It is implemented by a very simple fixpoint iteration.
--- This is sufficient for the small lists considered in this application.
nondetOfFuncDecls :: [TAFuncDecl] -> [(QName,Bool)]
nondetOfFuncDecls fds = ndIterate (map (\fd -> (funcName fd, False)) fds)
 where
  ndIterate nds =
    let newnds = map (\fd -> (funcName fd, isNonDetFunc nds fd)) fds
    in if newnds == nds then nds
                        else ndIterate newnds

  isNonDetFunc nds fdecl =
    choiceName `elem` fs || or (map (\f -> maybe False id (lookup f nds)) fs)
   where fs = choicesOfFuncDecl fdecl

--- Returns all operations occurring in a function declaration where
--- any occurrence of `Or` or `Free` is translated into an occurrence
--- of `Prelude.?`.
--- Thus, the result can be used to analyze whether a function definition
--- is non-deterministic or calls another non-deterministic operation.
choicesOfFuncDecl :: TAFuncDecl -> [QName]
choicesOfFuncDecl fd =
  nub (trRule (\_ _ e -> choicesOfExp e) (\_ _ -> []) (funcRule fd))
 where
  --- Returns all operations occurring in an expression where any occurrence
  --- of `Or` or `Free` is translated into an occurrence of `Prelude.?`.
  choicesOfExp =
    trExpr (\_ _ -> [])
           (\_ _ -> [])
           (\_ ct (qn,_) fs ->
              if isCombTypeFuncCall ct || isCombTypeFuncPartCall ct
                then qn : concat fs
                else concat fs)
           (\_ bs fs -> concatMap snd bs ++ fs)
           (\_ _ _ -> [choiceName])
           (\_ _ _ -> [choiceName])
           (\_ _ fs fss -> concat (fs:fss))
           (\_ -> id)
           (\_ fs _ -> fs)

choiceName :: QName
choiceName = pre "?"

hasNonDetInfo :: [(QName,Bool)] -> QName -> Bool
hasNonDetInfo ndinfo qn = maybe False id (lookup qn ndinfo)

----------------------------------------------------------------------------
--- Add a "choice plan" argument to a function declaration for all
--- non-deterministic functions (according to first argument).
--- The first argument maps qualified function names into a Boolean flag
--- which is true if the function is (or might be) non-deterministic.
--- The second argument is a tuple `(cpType,chooseF,lchoiceF,rchoiceF)`
--- describing the types and operations implementing the choice plan:
---
---     cpType -- the type of the choice plan
---     chooseF  :: cpType -> Bool   -- the name of the choose operation
---     lchoiceF :: cpType -> cpType -- the name of the lchoice operation
---     rchoiceF :: cpType -> cpType -- the name of the lchoice operation
---
--- For instance, these types and operations can be implemented as follows
--- in Curry:
---
---     data Choice = Plan Bool Choice Choice
---     
---     choose :: Choice -> Bool
---     choose (Plan True  _ _) = True
---     choose (Plan False _ _) = False
---     
---     lchoice :: Choice -> Choice
---     lchoice (Plan _ l _) = l
---     
---     rchoice :: Choice -> Choice
---     rchoice (Plan _ _ r) = r
---
--- As an example, consider the following operations:
---
---     insert :: a -> [a] -> [a]
---     insert x []     = [x]
---     insert x (y:ys) = x : y: ys ? y : insert x ys
---     
---     perm :: [a] -> [a]
---     perm []     = []
---     perm (x:xs) = insert x (perm xs)
---     
--- Since both operations are non-deterministic, they are transformed
--- into the following code:
---     
---     insert :: Choice -> a -> [a] -> [a]
---     insert _ x []     = [x]
---     insert c x (y:ys) = if choose c then x : y: ys
---                                     else y : insert (lchoice c) x ys
---     
---     perm :: Choice -> [a] -> [a]
---     perm _ []     = []
---     perm c (x:xs) = insert (lchoice c) x (perm (rchoice c) xs)
---
addChoiceFuncDecl :: [(QName,Bool)] -> (TypeExpr,QName,QName,QName)
                  -> TAFuncDecl -> TAFuncDecl
addChoiceFuncDecl _ _ fdecl@(AFunc _ _ _ _ (AExternal _ _)) = fdecl
addChoiceFuncDecl ndinfo (cpType,chooseF,lchoiceF,rchoiceF)
                  fdecl@(AFunc qn ar vis texp (ARule tr args rhs)) =
  if hasNonDetInfo ndinfo qn
    then AFunc qn (ar + 1) vis (FuncType cpType texp)
               (ARule tr (carg : args) (snd (choiceExp choices rhs)))
    else fdecl
 where
  cpVar  = maximum (0 : map fst args ++ allVars rhs) + 1
  carg   = (cpVar, cpType)
  -- number of non-deterministic operations in right-hand side:
  numnds = orOfExpr rhs +
           length (filter (hasNonDetInfo ndinfo) (funcsOfExpr rhs))
  choices = choicesFor numnds (AVar cpType cpVar)

  -- Add "choice plan" arguments for all non-deterministic operations
  -- and transform `Or` expressions into if-then-else w.r.t. a choice.
  -- The first argument is a list of disjoint choice expressions.
  choiceExp chs exp = case exp of
    ALit  _  _ -> (chs,exp)
    AVar  _  _ -> (chs,exp)
    AComb te ct (qf,qt) cargs ->
      if hasNonDetInfo ndinfo qf
        then let (ch1,targs) = choiceExps (tail chs) cargs in
             (ch1, AComb te ct (qf, FuncType cpType qt) (head chs : targs))
        else let (ch1,targs) = choiceExps chs cargs in
             (ch1, AComb te ct (qf,qt) targs)
    ACase te ct e brs ->
      let (ch1,e1:bes1) = choiceExps chs (e : map (\ (ABranch _ be) -> be) brs)
      in (ch1, ACase te ct e1
                 (map (\ (ABranch p _,be1) -> ABranch p be1) (zip brs bes1)))
    AOr te e1 e2 ->
      let (ch1,es) = choiceExps (tail chs) [e1,e2] in
      (ch1,
       AComb te FuncCall
             (pre "if_then_else",
              FuncType (TCons (pre "Bool") []) (FuncType te (FuncType te te)))
            (AComb boolType FuncCall (chooseF, chooseType) [head chs] : es))
    ALet te bs e ->
      let (ch1,e1:bes1) = choiceExps chs (e : map snd bs)
      in (ch1, ALet te (zip (map fst bs) bes1) e1)
    AFree  te fvs e -> let (ch1,e1) = choiceExp chs e
                       in (ch1, AFree  te fvs e1)
    ATyped te e ty  -> let (ch1,e1) = choiceExp chs e
                       in (ch1, ATyped te e1 ty)
   where
    boolType   = TCons (pre "Bool") []
    chooseType = FuncType cpType boolType

  choiceExps chs [] = (chs,[])
  choiceExps chs (e:es) = let (ch1,e1)  = choiceExp  chs e
                              (ch2,es1) = choiceExps ch1 es
                          in (ch2, e1:es1)

  -- Computes a list of disjoint choice plans for a given number of choices
  -- and a base choice variable.
  choicesFor :: Int -> TAExpr -> [TAExpr]
  choicesFor n ch
    | n <= 1
    = [ch]
    | otherwise
    = choicesFor (n `div` 2)
                 (AComb cpType FuncCall (lchoiceF, lrchType) [ch]) ++
      choicesFor (n - n `div` 2)
                 (AComb cpType FuncCall (rchoiceF, lrchType) [ch])
   where
    lrchType = FuncType cpType cpType


--- Returns the number of `Or` occurring in an expression.
orOfExpr :: TAExpr -> Int
orOfExpr = trExpr (\_ _ -> 0)
                  (\_ _ -> 0)
                  (\_ _ _ ns -> foldr (+) 0 ns)
                  (\_ bs n -> n + foldr (+) 0 (map snd bs))
                  (\_ _ n -> n)
                  (\_ n1 n2 -> 1 + n1 + n2)
                  (\_ _ n bs -> n + foldr (+) 0 bs)
                  (\_ n -> n)
                  (\_ n _ -> n)

--- Remove the given number of argument types from a (nested) functional type.
dropArgTypes :: Int -> TypeExpr -> TypeExpr
dropArgTypes n ty
  | n==0      = ty
  | otherwise = case ty of FuncType _ rt -> dropArgTypes (n-1) rt
                           _ -> error "dropArgTypes: too few argument types"

----------------------------------------------------------------------------