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
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
|
\begin{code}
module StepGen ( Code, Expression, gencode,
doexp, docode, doline, doblock, dodebug, comment,
if_, ifelse_, (|?|), (|:|),
ifdef, ifdefelse, casedef, casedefined,
whether_or_not, declare, for_loop,
for_true_false, for_any_one_of, sum_for_any_one_of,
sum_true_false,
(|+|), (|-|), (|*|), (|+=|), (|-=|), (|=|), (<<),
) where
import FiniteMap
import Monad ( liftM )
\end{code}
\begin{code}
newtype CC a = CC (FiniteMap String Bool -> (FiniteMap String Bool, a))
instance Monad CC where
(CC a) >>= b = CC f where f st = let (st', x) = a st
CC bb = b x
in bb st'
return a = CC $ \st -> (st, a)
type Expression = CC String
type Code = CC [String]
gencode :: Code -> String
gencode (CC code) = unlines $ snd $ code emptyFM
\end{code}
\begin{code}
for_true_false :: CODE a => String -> a -> Code
for_true_false s x = do check <- istrueCC s
if check == Nothing
then do docode [withCC s False $ docode x,
withCC s True $ docode x]
else docode x
for_any_one_of :: CODE a => [String] -> a -> Code
for_any_one_of [] x = docode x
for_any_one_of [b] x = withCC b True $ docode x
for_any_one_of (b:bs) x =
do check <- istrueCC b
if check == Just False
then for_any_one_of bs $ docode x
else docode [withCC b True $ with_all_false bs $ docode x,
withCC b False $ for_any_one_of bs $ docode x]
sum_true_false :: EXPRESSION a => String -> a -> Expression
sum_true_false b e =
do check <- istrueCC b
if check == Nothing
then (withCC b True $ expression e) |+| (withCC b False $ expression e)
else expression e
sum_for_any_one_of :: EXPRESSION a => [String] -> a -> Expression
sum_for_any_one_of [] e = expression "0"
sum_for_any_one_of [b] e = withCC b True $ expression e
sum_for_any_one_of (b:bs) e =
do check <- istrueCC b
if check == Just False
then sum_for_any_one_of bs $ expression e
else (withCC b True $ with_all_false bs $ expression e)
|+| (withCC b False $ sum_for_any_one_of bs e)
with_all_false [] x = x
with_all_false (b:bs) x = withCC b False $ with_all_false bs x
for_loop :: CODE a => String -> String -> a -> Code
for_loop i num inside =
ifelse_ (num++"==1") (
docode [doexp $ "const int "<<i<<" = 0",
docode inside]
) (
docode [doline $ "for (int "<<i<<"=0; "<<i<<"<"<<num<<"; "<<i<<"++) {",
liftM (map (" "++)) (docode inside),
doline "}"]
)
if_ :: CODE a => String -> a -> Code
if_ b thendo = ifelseCC b (docode thendo) (return []) $ \thethen _ ->
if is_empty thethen then return []
else docode [doline $ "if (" ++ b ++ ") {",
return $ map (" "++) thethen,
doline "}"
]
ifdef :: CODE a => String -> a -> Code
ifdef b thendo = ifdefelse b (docode thendo) (doexp "")
ifdefelse :: CODE a => String -> a -> a -> Code
ifdefelse b thendo elsedo = do check <- istrueCC b
if check == Just True
then docode thendo
else docode elsedo
casedef :: EXPRESSION a => [String] -> (String -> a) -> a -> Expression
casedef [] _ other = expression other
casedef (b:bs) e other = do check <- istrueCC b
if check == Just True
then expression $ e b
else casedef bs e other
casedefined :: EXPRESSION a => [String] -> (String -> a) -> a -> Expression
casedefined [] _ other = expression other
casedefined (b:bs) e other = do check <- istrueCC b
if check /= Nothing
then expression $ e b
else casedef bs e other
ifelse_ :: (CODE a, CODE b) => String -> a -> b -> Code
ifelse_ b thendo elsedo =
ifelseCC b (docode thendo) (docode elsedo) $ \thethen theelse ->
case (is_empty thethen, is_empty theelse) of
(True,True) -> return []
(True,_) -> return theelse
(_,True) -> return thethen
_ -> docode [doline $ "if (" ++ b ++ ") {",
return $ map (" "++) thethen,
doline $ "} else { // not "++b,
return $ map (" "++) theelse,
doline "}"
]
is_empty [] = True
is_empty _ = False
whether_or_not :: CODE a => String -> a -> Code
whether_or_not s x = ifelse_ s x x
(|?|) :: (EXPRESSION a, EXPRESSION b) => String -> a -> b -> Expression
infixl 8 |?|
(|?|) b x y = ifelseCC b (expression x) (expression y) $ \xx yy ->
return $ "("++b++") ? "++p xx++" : "++p yy
(|:|) :: a -> a
infixr 4 |:|
(|:|) a = a
declare :: CODE a => String -> Bool -> a -> Code
declare s b x = do check <- istrueCC s
if check == Just (not b)
then return []
else do setCC s b
docode x
\end{code}
\begin{code}
(<<) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 8 <<
(<<) x y = do xe <- expression x
ye <- expression y
return $ xe++ye
(|-|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 5 |-|
(|-|) x y = do xe <- expression x
ye <- expression y
if xe == "0"
then if ye == "0" then return "0"
else return $ " - "++ye
else if ye == "0" then return xe
else return $ padd xe++" - "++padd ye
(|+|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 5 |+|
(|+|) x y = do xe <- expression x
ye <- expression y
if xe == "0" then return ye
else if ye == "0" then return xe
else return $ padd xe++" + "++p ye
(|+=|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 3 |+=|
x |+=| y = do xe <- expression x
ye <- expression y
if ye == "0" then return ""
else return $ xe++" += "++ye
(|-=|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 3 |-=|
x |-=| y = do xe <- expression x
ye <- expression y
if ye == "0" then return ""
else return $ xe++" -= "++ye
(|=|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 3 |=|
x |=| y = do xe <- expression x
ye <- expression y
return $ xe++" = "++ye
(|*|) :: (EXPRESSION a, EXPRESSION b) => a -> b -> Expression
infixr 6 |*|
(|*|) x y = do xe <- expression x
ye <- expression y
case (xe,ye) of
("0",_) -> return "0"
(_,"0") -> return "0"
("1",_) -> return ye
(_,"1") -> return xe
_ -> return $ padd xe++"*"++padd ye
p s | '?' `elem` s = "("++s++")"
p s = s
padd s | '+' `elem` s = "("++s++")"
padd s | '-' `elem` s = "("++s++")"
padd s | '?' `elem` s = "("++s++")"
padd s = s
\end{code}
\begin{code}
class EXPRESSION s where
expression :: s -> Expression
instance EXPRESSION Expression where
expression x = x
instance EXPRESSION String where
expression s = return s
dodebug :: EXPRESSION a => a -> Code
dodebug e = do o <- expression e
d <- deb
return ["// "++o,
"// "++d]
where deb = CC $ \st -> (st, show $ fmToList st)
comment :: CODE a => String -> a -> Code
comment c x = docode [return ["// "++c], docode x]
doline :: EXPRESSION a => a -> Code
doline e = do o <- expression e
return [o]
doexp :: EXPRESSION a => a -> Code
doexp e = do o <- expression e
if o == "" then return []
else return $ linebreak $ o++";"
linebreak s | length (dropWhile (==' ') s) < 40 = [s]
linebreak s = let spaces = takeWhile (==' ') s
body = dropWhile (==' ') s in -- (
case break (==' ') $ drop 55 body of
(_,"") -> [s]
("",_) -> [s]
(first,second) -> (spaces++take 55 body++first) :
linebreak (spaces++" "++second)
doexps :: EXPRESSION a => [a] -> Code
doexps es = do os <- sequence $ map expression es
return $ map (++";") os
\end{code}
\begin{code}
class CODE s where
docode :: s -> Code
instance CODE Code where
docode x = x
instance CODE a => CODE [a] where
docode co = do c <- sequence $ map docode co
return $ concat c
doblock :: (EXPRESSION a, CODE b) => a -> b -> Code
doblock thefor job = do j <- docode job
if is_empty j
then return j
else docode [doline $ add_brace $ expression thefor,
indent job,
doline "}"]
where add_brace :: Expression -> Expression
add_brace = liftM (++" {")
indent :: CODE a => a -> Code
indent c = liftM (map (" "++)) $ docode c
\end{code}
\begin{code}
istrueCC :: String -> CC (Maybe Bool)
istrueCC s = CC $ \st -> (st, lookupFM st s)
setCC :: String -> Bool -> CC ()
setCC s b = CC $ \st -> (addToFM (delFromFM st s) s b, ())
withCC :: String -> Bool -> CC a -> CC a
withCC s b (CC x) = CC $ \st -> (st, snd $ x $ addToFM (delFromFM st s) s b)
ifelseorCC :: String -> CC a -> CC a -> CC a -> CC a
ifelseorCC s thendo elsedo eitherdo = do istrue <- istrueCC s
case istrue of
Just True -> thendo
Just False -> elsedo
Nothing -> eitherdo
ifelseCC :: Eq a => String -> CC a -> CC a -> (a -> a -> CC a) -> CC a
ifelseCC s thendo elsedo doif =
do istrue <- istrueCC s
case istrue of
Just True -> thendo
Just False -> elsedo
Nothing -> do tt <- tryWith s True thendo
ee <- tryWith s False elsedo
if tt == ee then return tt
else doif tt ee
tryWith :: String -> Bool -> CC a -> CC a
tryWith s b (CC x) = CC $ \st -> (st, snd $ x (addToFM (delFromFM st s) s b))
\end{code}
|
