[基础软件理论与实践] 第五节作业实现 yhg2000

yhgu2000 2023-05-06 22:40:10

开学一直在上课，五一节期间才重新着手做这次作业，对于我这个类型系统零基础的选手来说，这次作业确实很有难度……

作业信息

作业内容描述：

  1. Complete the type inference ( two substitution functions )
  2. Complete the implementation for let-polymorphism
  3. Think about how to handle recursive functions

作业实现

和另外两位同学的实现差不多（绝对没有抄他们🤣），所以就不多解释了……

在任务2里我在实现inst函数时采用了不同的处理方法，引入了一个新的IVar类型来标记那些已经由QVar实例化过的变量，这样也能避免反复查上下文表，如果我没理解错的话，这么做应该也是对的……

并查集没做，只是把原理理解了我就已经很满足了……

任务1
module List = Belt.List

type rec expr =
  | CstI(int)
  | CstB(bool)
  | Var(string)
  | If(expr, expr, expr)
  | Fun(string, expr)
  | App(expr, expr)
  | Add(expr, expr)

type rec typ = TInt | TBool | TVar(string) | TArr(typ, typ)

let rec to_string = (t: typ) =>
  switch t {
  | TInt => "Int"
  | TBool => "Bool"
  | TVar(x) => "@" ++ x
  | TArr(x, y) => "(" ++ to_string(x) ++ "->" ++ to_string(y) ++ ")"
  }

type context = list<(string, typ)>
type constraints = list<(typ, typ)>

let rec cs_to_string = (cs: constraints) =>
  switch cs {
  | list{} => ""
  | list{(a, b), ...rest} =>
    "[" ++ to_string(a) ++ " = " ++ to_string(b) ++ "], " ++ cs_to_string(rest)
  }

let tvar_count = ref(0)
let new_tvar = (): typ => {
  tvar_count.contents = tvar_count.contents + 1
  TVar(Js.Int.toString(tvar_count.contents))
}

// 约束提取
let rec check_expr = (ctx: context, expr: expr): (typ, constraints) => {
  switch expr {
  | CstI(_) => (TInt, list{})
  | CstB(_) => (TBool, list{})
  | Var(x) => (
      switch List.getAssoc(ctx, x, (a, b) => a == b) {
      | Some(xt) => xt
      | _ => assert false // 变量名必须在上下文中存在
      },
      list{},
    )
  | If(e1, e2, e3) => {
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      let (t3, c3) = check_expr(ctx, e3)
      (t2, List.concatMany([c1, c2, c3, list{(t1, TBool), (t2, t3)}]))
    }

  | Fun(x, e) => {
      let tx = new_tvar()
      let (te, c) = check_expr(list{(x, tx), ...ctx}, e)
      (TArr(tx, te), c)
    }

  | App(e1, e2) => {
      let t = new_tvar()
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      (t, List.concatMany([c1, c2, list{(t1, TArr(t2, t))}]))
    }

  | Add(e1, e2) => {
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      (TInt, List.concatMany([c1, c2, list{(t1, t2), (t1, TInt)}]))
    }
  }
}

let rec occurs = (x: string, t: typ): bool => {
  switch t {
  | TInt | TBool => false
  | TVar(y) => x == y
  | TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
  }
}

type subst = list<(string, typ)>

let rec st_to_string = (st: subst) =>
  switch st {
  | list{} => ""
  | list{(a, b), ...rest} => a ++ "= " ++ to_string(b) ++ ", " ++ st_to_string(rest)
  }

let rec rest_subst = (cs: constraints, x: string, xt: typ): constraints => {
  switch cs {
  | list{} => cs
  | list{c, ...rest} =>
    list{
      switch c {
      | (TVar(y), yt) if y == x => (xt, yt)
      | (yt, TVar(y)) if y == x => (xt, yt)
      | _ => c
      },
      ...rest_subst(rest, x, xt),
    }
  }
}

// 约束求解
let solve = (cs: constraints): subst => {
  let rec go = (cs, s): subst => {
    switch cs {
    | list{} => s
    | list{c, ...rest} =>
      switch c {
      | (TInt, TInt) | (TBool, TBool) => go(rest, s)
      | (TArr(t1, t2), TArr(t3, t4)) => go(list{(t1, t3), (t2, t4), ...rest}, s)
      | (TVar(x), t) | (t, TVar(x)) => {
          assert !occurs(x, t) // 禁止递归类型
          go(rest_subst(rest, x, t), list{(x, t), ...s})
        }

      | _ => assert false
      }
    }
  }
  go(cs, list{})
}

let rec subst_resolve = (x: string, s: subst): typ => {
  switch s {
  | list{} => TVar(x)
  | list{(y, yt), ...rest} =>
    if y == x {
      yt
    } else {
      subst_resolve(x, rest)
    }
  }
}

let rec type_subst = (t: typ, s: subst): typ => {
  switch t {
  | TVar(x) => {
      let y = subst_resolve(x, s)
      if y == TVar(x) {
        y
      } else {
        type_subst(y, s) // 递归求解，直到解无可解
      }
    }

  | TArr(t1, t2) => TArr(type_subst(t1, s), type_subst(t2, s))
  | _ => t
  }
}

// 类型推导
let infer = (expr: expr): typ => {
  let (t, cs) = check_expr(list{}, expr)
  let s = solve(cs)
  type_subst(t, s)
}

let test = Fun(
  "f",
  Fun("a", Fun("b", If(Var("a"), Add(App(Var("f"), Var("b")), CstI(1)), App(Var("f"), Var("a"))))),
)

let inferred = infer(test)
Js.log(inferred->to_string)

let omega = Fun("x", App(Var("x"), Var("x")))
let omega_inferred = infer(omega)
Js.log(omega_inferred->to_string)
任务2和3
module List = Belt.List

type rec expr =
  | CstI(int)
  | CstB(bool)
  | Var(string)
  | If(expr, expr, expr)
  | Fun(string, expr)
  | App(expr, expr)
  | Add(expr, expr)
  | Let(string, expr, expr)

type rec typ = TInt | TBool | TArr(typ, typ) | TVar(string) | QVar(string) | IVar(string) // 使用IVar来标记已经实例化的类型变量

let rec to_string = (t: typ) =>
  switch t {
  | TInt => "Int"
  | TBool => "Bool"
  | TArr(x, y) => "(" ++ to_string(x) ++ "->" ++ to_string(y) ++ ")"
  | TVar(x) => "@" ++ x
  | IVar(x) => "#" ++ x
  | QVar(x) => "$" ++ x
  }

type context = list<(string, typ)>
type constraints = list<(typ, typ)>

let rec cs_to_string = (cs: constraints) =>
  switch cs {
  | list{} => ""
  | list{(a, b), ...rest} => to_string(a) ++ " = " ++ to_string(b) ++ ", " ++ cs_to_string(rest)
  }

let var_count = ref(0)
let new_tvar = (): typ => {
  var_count.contents = var_count.contents + 1
  TVar(Js.Int.toString(var_count.contents))
}
let new_ivar = (): typ => {
  var_count.contents = var_count.contents + 1
  IVar(Js.Int.toString(var_count.contents))
}

let inst = (ty: typ): typ => {
  let rec go = (ty: typ, ctx: context): (typ, context) => {
    switch ty {
    | TArr(t1, t2) => {
        let (t1, ctx) = go(t1, ctx)
        let (t2, ctx) = go(t2, ctx)
        (TArr(t1, t2), ctx)
      }

    | QVar(x) =>
      switch List.getAssoc(ctx, x, (a, b) => a == b) {
      | Some(y) => (y, ctx)
      | None => {
          let y = new_ivar()
          (y, list{(x, y), ...ctx})
        }
      }

    | _ => (ty, ctx)
    }
  }
  let (t, _) = go(ty, list{})
  Js.log(ty->to_string)
  Js.log(t->to_string)
  Js.log("---")
  t
}

let rec gen = (ty: typ): typ => {
  switch ty {
  | TArr(t1, t2) => TArr(gen(t1), gen(t2))
  | TVar(x) => QVar(x)
  | _ => ty
  }
}

// 约束提取
let rec check_expr = (ctx: context, expr: expr): (typ, constraints) => {
  switch expr {
  | CstI(_) => (TInt, list{})
  | CstB(_) => (TBool, list{})
  | Var(x) => {
      let ty = switch List.getAssoc(ctx, x, (a, b) => a == b) {
      | Some(xt) => inst(xt)
      | _ => assert false // 变量名必须在上下文中存在
      }
      (ty, list{})
    }

  | If(e1, e2, e3) => {
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      let (t3, c3) = check_expr(ctx, e3)
      (t2, List.concatMany([c1, c2, c3, list{(t1, TBool), (t2, t3)}]))
    }

  | Fun(x, e) => {
      let tx = new_tvar()
      let (te, c) = check_expr(list{(x, tx), ...ctx}, e)
      (TArr(tx, te), c)
    }

  | App(e1, e2) => {
      let t = new_tvar()
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      (t, List.concatMany([c1, c2, list{(t1, TArr(t2, t))}]))
    }

  | Add(e1, e2) => {
      let (t1, c1) = check_expr(ctx, e1)
      let (t2, c2) = check_expr(ctx, e2)
      (TInt, List.concatMany([c1, c2, list{(t1, t2), (t1, TInt)}]))
    }

  | Let(x, e1, e2) => {
      let xt = new_tvar() // 不知道这样处理递归对不对
      let (t1, c1) = check_expr(list{(x, xt), ...ctx}, e1)
      let (t2, c2) = check_expr(list{(x, gen(t1)), ...ctx}, e2)

      (t2, List.concatMany([c1, c2]))
    }
  }
}

let rec occurs = (x: string, t: typ): bool => {
  switch t {
  | TInt | TBool => false
  | TVar(y) | IVar(y) => x == y
  | TArr(t1, t2) => occurs(x, t1) || occurs(x, t2)
  | QVar(_) => assert false
  }
}

type subst = list<(string, typ)>

let rec st_to_string = (st: subst) =>
  switch st {
  | list{} => ""
  | list{(a, b), ...rest} => a ++ "= " ++ to_string(b) ++ ", " ++ st_to_string(rest)
  }

let rec rest_subst = (cs: constraints, x: string, xt: typ): constraints => {
  switch cs {
  | list{} => cs
  | list{c, ...rest} =>
    list{
      switch c {
      | (TVar(y) | IVar(y), yt) if y == x => (xt, yt)
      | (yt, TVar(y) | IVar(y)) if y == x => (xt, yt)
      | _ => c
      },
      ...rest_subst(rest, x, xt),
    }
  }
}

// 约束求解
let solve = (cs: constraints): subst => {
  let rec go = (cs, s): subst => {
    switch cs {
    | list{} => s
    | list{c, ...rest} =>
      switch c {
      | (TInt, TInt) | (TBool, TBool) => go(rest, s)
      | (TArr(t1, t2), TArr(t3, t4)) => go(list{(t1, t3), (t2, t4), ...rest}, s)
      | (TVar(x) | IVar(x), t) | (t, TVar(x) | IVar(x)) => {
          assert !occurs(x, t) // 禁止递归类型
          go(rest_subst(rest, x, t), list{(x, t), ...s})
        }

      | _ => assert false
      }
    }
  }
  go(cs, list{})
}

let rec subst_resolve = (x: string, s: subst): typ => {
  switch s {
  | list{} => TVar(x)
  | list{(y, yt), ...rest} =>
    if y == x {
      yt
    } else {
      subst_resolve(x, rest)
    }
  }
}

let rec type_subst = (t: typ, s: subst): typ => {
  switch t {
  | TVar(x) => {
      let y = subst_resolve(x, s)
      if y == TVar(x) {
        y
      } else {
        type_subst(y, s) // 递归求解，直到解无可解
      }
    }

  | TArr(t1, t2) => TArr(type_subst(t1, s), type_subst(t2, s))
  | _ => t
  }
}

// 类型推导
let infer = (expr: expr): typ => {
  let (t, cs) = check_expr(list{}, expr)
  Js.log(t->to_string)
  Js.log(cs->cs_to_string)
  let s = solve(cs)
  type_subst(t, s)
}

// let test = Let("a", Fun("x", Var("x")), Let("b", Var("a"), App(Var("b"), CstI(10))))

// let test = Let("id", Fun("x", Var("x")), Let("a", App(Var("id"), CstI(42)), Var("a")))

// 递归函数
let test = Let("a", Fun("x", App(Var("a"), Var("x"))), App(Var("a"), CstI(42)))

let inferred = infer(test)
Js.log(inferred->to_string)
...全文
87 回复 打赏 收藏 转发到动态 举报
写回复
用AI写文章
回复
切换为时间正序
请发表友善的回复…
发表回复
三维游戏引擎开发-图形理论基础
通过学习，掌握三维图形学的基本理论，三维数学知识，并根据数理进行实践，纯软件编码方式（不调用OpenGL,DX，或者相关图形库）实现一个简单的三维场景，巩固三维理论，为后续课程打下基础。
[基础软件理论与实践] 第五节作业实现 lxr2010
作业信息 课程信息：https://bbs.csdn.net/topics/608593392 作业内容描述： Complete the type inference ( two substitution functions ) Complete the implementation for let-polymorphism Think about how to handle recursive functions
[基础软件理论与实践] 第二节作业实现 lxr2010
* 课程信息：https://bbs.csdn.net/topics/608593392 * 第二节作业提交帖：https://bbs.csdn.net/topics/ 作业内容描述： 1. 完成Codewars Kata Church Numbers 2. 完成Codewars Kata Church numbers: find the predecessor and subtract
[基础软件理论与实践] 第三节作业实现 lxr2010
* 课程信息：https://bbs.csdn.net/topics/608593392 * 第二节作业提交帖：https://bbs.csdn.net/topics/608988916 1. Complete the de Bruijn index based interpreter in natural semantics 2. Apply the de Bruijn index for extended lambda calculus (+ Let)
[基础软件理论与实践] 第四节作业实现 lxr2010
作业信息 * 课程信息：https://bbs.csdn.net/topics/608593392 * 第四节作业提交帖：https://bbs.csdn.net/topics/609455877 作业内容描述： 1. 完成汇编器(assembler)中的`encode`函数。 2. 使用C/C++/Rust实现支持课程中使用的指令的虚拟机。 3. 完整实现编译器(compiler) 4. 实现一个支持递归函数的解释器(interpreter)
raelidea

230

社区成员

35

社区内容

发帖
与我相关
我的任务
社区描述
日程：https://bbs.csdn.net/topics/608593392 主页：https://bobzhang.github.io/courses/ B站: “张宏波的基础软件课程”
rescript开发语言 个人社区 广东省·深圳市
社区管理员
  • raelidea
  • idea4cccc
  • 幻灰龙
加入社区
  • 近7日
  • 近30日
  • 至今

加载中

查看更多榜单
社区公告
暂无公告

试试用AI创作助手写篇文章吧

+ 用AI写文章