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 module Env ( 26 Cont, Ncont, Econt, Vcont, Xcont, Xscont, 27 Answer, 28 Env, make_Env, 29 upto, choose, choosew, 30 Output, default_output, 31 get_constructors, get_val_names, get_type_names, get_all_type_names, 32 get_all_type_decls, get_all_val_decls, get_all_lambdas, get_type, 33 get_output, 34 push_lambda, pop_lambda, extend_type_env, extend_val_env, set_output 35 ) where 36 37 import Config 38 import Types 39 import IO -- 1.3 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 type Cont = Env -> Answer 62 63 type Xcont x = x -> Cont 64 type Xscont x = [x] -> Cont 65 66 type Ncont = Xcont Int 67 type Econt = Xcont Expression 68 type Vcont = Xcont Value 69 70 71 72 73 74 75 76 type Answer = IO () --Dialogue 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 random_numbers :: (Int, Int, Int) -> [Float] 98 random_numbers (s1,s2,s3) 99 = map (snd . properFraction . combine) (iterate f (s1,s2,s3)) 100 where 101 combine :: (Int,Int,Int) -> Float 102 combine (a,b,c) = 103 fromIntegral(a)/30269 + fromIntegral(b)/30307 104 + fromIntegral(c)/30323 105 f (a,b,c) = 106 ((171*a) `mod` 30269, (172*b) `mod` 30307, (170*c) `mod` 30323) 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 upto :: Int -> Ncont -> Cont 125 upto n nc (MkEnv (r:rs) cs ts vs te ve le op) 126 = hPutStr stderr (show x ++ " ") >> nc x (MkEnv rs cs ts vs te ve le op) 127 -- = appendChan stderr (show x ++ " ") exit ((nc x) (MkEnv rs cs ts vs te ve le op)) 128 where 129 x :: Int 130 x = fromIntegral (fst (properFraction (r * (fromIntegral (n+one))))) 131 132 133 134 135 136 137 138 choose :: [x] -> (Xcont x) -> Cont 139 choose xs xc = upto (length xs - one) (\n -> xc (xs !! n)) 140 141 142 143 144 145 146 147 148 149 150 choosew :: [(Int,x)] -> (Xcont x) -> Cont 151 choosew ps xc 152 = upto (sum [i | (i,x) <- ps] - one) (f ps) 153 where 154 f ((i,x):ps') n | n < i = xc x 155 | True = f ps' (n-i) 156 157 158 159 160 161 162 163 164 165 idnum :: String -> [String] 166 idnum id = [id ++ show n | n <- [one..]] 167 168 constructors :: [Constructor] 169 constructors = idnum constructor_name 170 171 type_names :: [Type_name] 172 type_names = idnum type_name 173 174 val_names :: [Val_name] 175 val_names = idnum val_name 176 177 178 179 180 181 182 183 184 185 type Type_env = [Type_decl] 186 187 initial_type_env :: Type_env 188 initial_type_env = [] 189 190 type Val_env = [Val_decl] 191 192 initial_val_env :: Val_env 193 initial_val_env = [] 194 195 type Lambda_env = [(Val_name, Value)] 196 197 initial_lambda_env :: Lambda_env 198 initial_lambda_env = [] 199 200 201 202 203 204 205 206 207 208 209 --type Output = String -> FailCont -> SuccCont -> Dialogue 210 type Output = String -> IO () 211 212 213 214 215 216 default_output :: Output 217 default_output str = putStr str 218 219 220 221 222 223 224 225 set_output :: String -> Output 226 set_output str = appendFile str 227 228 229 230 231 232 233 234 235 data Env = MkEnv [Float] [Constructor] [Type_name] [Val_name] 236 Type_env Val_env Lambda_env Output 237 238 239 240 241 242 243 244 make_Env :: (Int,Int,Int) -> Output -> Env 245 make_Env (s1,s2,s3) op = MkEnv (random_numbers (s1,s2,s3)) 246 constructors type_names val_names 247 initial_type_env initial_val_env 248 initial_lambda_env op 249 250 251 252 253 254 255 256 257 258 get_constructors :: Int -> (Xscont Constructor) -> Cont 259 get_constructors n csc (MkEnv rs cs tns vns te ve le op) 260 = csc (take n cs) (MkEnv rs (drop n cs) tns vns te ve le op) 261 262 get_val_names :: Int -> (Xscont Val_name) -> Cont 263 get_val_names n vnsc (MkEnv rs cs tns vns te ve le op) 264 = vnsc (take n vns) (MkEnv rs cs tns (drop n vns) te ve le op) 265 266 get_type_names :: Int -> (Xscont Type_name) -> Cont 267 get_type_names n tnsc (MkEnv rs cs tns vns te ve le op) 268 = tnsc (take n tns) (MkEnv rs cs (drop n tns) vns te ve le op) 269 270 get_all_type_names :: (Xscont Type_name) -> Cont 271 get_all_type_names tnsc e@(MkEnv _ _ _ _ te _ _ _) 272 = tnsc [tn | (tn,t) <- te] e 273 274 get_all_type_decls :: (Xscont Type_decl) -> Cont 275 get_all_type_decls tdsc e@(MkEnv _ _ _ _ te _ _ _) 276 = tdsc te e 277 278 get_all_val_decls :: (Xscont Val_decl) -> Cont 279 get_all_val_decls vdsc e@(MkEnv _ _ _ _ _ ve _ _) 280 = vdsc ve e 281 282 get_all_lambdas :: (Xcont Lambda_env) -> Cont 283 get_all_lambdas lec e@(MkEnv _ _ _ _ _ _ le _) 284 = lec le e 285 286 get_type :: Type_name -> (Xcont Htype) -> Cont 287 get_type tn tc e@(MkEnv _ _ _ _ te _ _ _) 288 = tc (head [t | (tn',t) <- te , tn == tn']) e 289 290 get_output :: (Xcont Output) -> Cont 291 get_output oc e@(MkEnv _ _ _ _ _ _ _ op) = oc op e 292 293 294 295 296 297 298 299 300 extend_type_env :: [Type_decl] -> Cont -> Cont 301 extend_type_env tds c (MkEnv rs cs tns vns te ve le op) 302 = c (MkEnv rs cs tns vns (tds++te) ve le op) 303 304 305 306 307 308 309 310 extend_val_env :: [Val_decl] -> Cont -> Cont 311 extend_val_env vds c (MkEnv rs cs tns vns te ve le op) 312 = c (MkEnv rs cs tns vns te (vds++ve) le op) 313 314 315 316 317 318 319 320 321 322 push_lambda :: (Val_name, Value) -> Cont -> Cont 323 push_lambda (vn,v) c (MkEnv rs cs tns vns te ve le op) 324 = c (MkEnv rs cs tns vns te ve ((vn,v):le) op) 325 326 327 328 329 330 331 332 333 pop_lambda :: Xcont (Val_name,Value) -> Cont 334 pop_lambda lc (MkEnv rs cs tns vns te ve ((vn,v):le) op) 335 = lc (vn,v) (MkEnv rs cs tns vns te ve le op) 336 337