(* File: mp5-sol.ml *) open Mp5common (* Problem 1 *) let rec import_list lst = match lst with [] -> ConstExp NilConst | (m,n) :: rest -> BinOpAppExp(ConsOp, BinOpAppExp(CommaOp, ConstExp (IntConst m), ConstExp (IntConst n)), import_list rest) (* Problem 2 *) let pair_sum = let ps = VarExp "pair_sum" in let lst = VarExp "lst" in let nil = ConstExp NilConst in let lsteqnil = BinOpAppExp(EqOp, lst, nil) in let hdlst = MonOpAppExp(HdOp,lst) in let tllst = MonOpAppExp(TlOp,lst) in let x = VarExp "x" in let fstx = MonOpAppExp(FstOp, x) in let sndx = MonOpAppExp(SndOp, x) in let fpluss = BinOpAppExp(IntPlusOp,fstx,sndx) in let app_ps = AppExp(ps, tllst) in let cons = BinOpAppExp(ConsOp, fpluss, app_ps) in let letx = LetInExp("x", hdlst, cons) in let ifexp = IfExp(lsteqnil, nil, letx) in let final = AppExp(ps, import_list [(7,1);(4,2);(6,3)]) in LetRecInExp("pair_sum", "lst", ifexp, final) (* let pair_sum : exp = LetRecInExp ("pair_sum", "lst", IfExp (BinOpAppExp (EqOp, VarExp "lst", ConstExp NilConst), ConstExp NilConst, LetInExp ("x", MonOpAppExp (HdOp, VarExp "lst"), BinOpAppExp (ConsOp, BinOpAppExp (IntPlusOp, MonOpAppExp (FstOp, VarExp "x"), MonOpAppExp (SndOp, VarExp "x")), AppExp (VarExp "pair_sum", MonOpAppExp (TlOp, VarExp "lst"))))), AppExp (VarExp "pair_sum", BinOpAppExp (ConsOp, BinOpAppExp (CommaOp, ConstExp (IntConst 7), ConstExp (IntConst 1)), BinOpAppExp (ConsOp, BinOpAppExp (CommaOp, ConstExp (IntConst 4), ConstExp (IntConst 2)), BinOpAppExp (ConsOp, BinOpAppExp (CommaOp, ConstExp (IntConst 6), ConstExp (IntConst 3)), ConstExp NilConst))))) *) (* Problem 3 *) let rec cal_max_exp_height exp = match exp with VarExp x -> 1 | ConstExp c -> 1 | MonOpAppExp (m,e) -> 1 + cal_max_exp_height e | BinOpAppExp (b,e1,e2) -> 1 + (max (cal_max_exp_height e1) (cal_max_exp_height e2)) | IfExp (e1,e2,e3) -> 1 + (max (cal_max_exp_height e1) (max (cal_max_exp_height e2) (cal_max_exp_height e3))) | AppExp (e1,e2) -> 1 + (max (cal_max_exp_height e1) (cal_max_exp_height e2)) | FunExp (f,e) -> 1 + cal_max_exp_height e | LetInExp (x,e1,e2) -> 1 + (max (cal_max_exp_height e1) (cal_max_exp_height e2)) | LetRecInExp (f,x,e1,e2) -> 1 + (max (cal_max_exp_height e1) (cal_max_exp_height e2)) (* Problem 4 *) let rec freeVarsInExp exp = (*raise (Failure "Not implemented yet")*) match exp with VarExp x -> [x] | ConstExp c -> [] | MonOpAppExp (m,e) -> freeVarsInExp e | BinOpAppExp (b,e1,e2) -> freeVarsInExp e1 @ freeVarsInExp e2 | IfExp (e1,e2,e3) -> freeVarsInExp e1 @ (freeVarsInExp e2 @ freeVarsInExp e3) | AppExp (e1,e2) -> freeVarsInExp e1 @ freeVarsInExp e2 | FunExp (f,e) -> List.filter (fun y -> not(y = f)) (freeVarsInExp e) | LetInExp (x,e1,e2) -> (freeVarsInExp e1) @ (List.filter (fun y -> not(y = x)) (freeVarsInExp e2)) | LetRecInExp (f,x,e1,e2) -> (List.filter (fun y -> not((y = f) || (y = x))) (freeVarsInExp e1)) @ (List.filter (fun y -> not(y = f)) (freeVarsInExp e2)) (* Problem 5 *) let rec cps_exp e k kx = match e with (*[[x]]k = k x*) VarExp x -> (VarCPS (k, x), kx) (*[[c]]k = k x*) | ConstExp n -> (ConstCPS (k, n), kx) (*[[~ e]]k = [[e]]_(fun r -> k (~ r)) *) | MonOpAppExp (m, e) -> let r = freshFor (freeVarsInContCPS k) in cps_exp e (FnContCPS (r, MonOpAppCPS (k, m, r))) kx (*[[(e1 + e2)]]k = [[e2]]_ fun s -> [[e1]] _ fun r -> k (r + s)*) | BinOpAppExp (b, e1, e2) -> let v2 = freshFor (freeVarsInContCPS k @ freeVarsInExp e1) in let v1 = freshFor (v2 :: (freeVarsInContCPS k)) in let (e2CPS, ky) = cps_exp e1 (FnContCPS (v1, BinOpAppCPS(k, b, v1, v2))) kx in cps_exp e2 (FnContCPS (v2, e2CPS)) ky (*[[if e1 then e2 else e3]]k = [[e1]]_(fun r -> if r then [[e2]]k else [[e3]]k)*) | IfExp (e1,e2,e3) -> let r = freshFor (freeVarsInContCPS k @ freeVarsInExp e2 @ freeVarsInExp e3) in let (e2cps, n2) = cps_exp e2 k kx in let (e3cps, n3) = cps_exp e3 k n2 in cps_exp e1 (FnContCPS(r, IfCPS(r, e2cps, e3cps))) n3 (*[[e1 e2]]k = [[e2]]_fun v2 -> [[e1]]_fun v1 -> k (v1 v2)*) | AppExp (e1,e2) -> let v2 = freshFor (freeVarsInContCPS k @ freeVarsInExp e1) in let v1 = freshFor (v2 :: freeVarsInContCPS k) in let (e1cps, n2) = cps_exp e1 (FnContCPS (v1, AppCPS(k, v1, v2))) kx in cps_exp e2 (FnContCPS (v2, e1cps)) n2 (*[[fun x -> e]]k = k(fnk x kx -> [[e]]kx) *) | FunExp (x,e) -> let (ecps, ky) = cps_exp e (ContVarCPS kx) (kx + 1) in (FunCPS (k, x, kx, ecps), ky) (*[[let x = e1 in e2]]k = [[e1]]_fun x -> [[e2]]k) *) | LetInExp (x,e1,e2) -> let (e2cps, ky) = cps_exp e2 k kx in let fx = FnContCPS (x, e2cps) in cps_exp e1 fx ky (*[[let rec f x = e1 in e2]]k = (FN f -> [[e2]]_k))(FIX f. FUN x -> fn kx => [[e1]]kx) *) | LetRecInExp(f,x,e1,e2) -> let (e1cps,ky) = cps_exp e1 (ContVarCPS kx) (kx + 1) in let (e2cps,kz) = cps_exp e2 k ky in (FixCPS(FnContCPS (f,e2cps),f,x,kx,e1cps) , kz)