[基础软件理论与实践] 第五节作业实现 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)
...全文
146 回复 打赏 收藏 转发到动态 举报
写回复
用AI写文章
回复
切换为时间正序
请发表友善的回复…
发表回复
YHG-101型微机化氧量自动分析仪手册.doc
YHG-101型微机化氧量自动分析仪手册doc,YHG-101型微机化氧量自动分析仪手册
国产QFSN-600-2YHG型汽轮发电机漏氢原因分析及处理 (2013年)
氢系统对于发电机的安全运行起到了关键的作用。介绍了庄河发电公司QFSN-600-2YHG型汽轮发电机组,在运行中发现严重漏氢现象,叙述了对氢系统进行全面检查的过程,及漏点的处理工艺和原因分析。实践表明:采用标准的工艺流程对机组漏氢进行检修,可得到满意的效果。
YHG系列水平轴转刷曝气机通过科技成果鉴定 (1995年)
由清华大学环境工程系和北京市市政工程机械公司共同开发研制的ＹＨＰ系列水平轴转刷曝气机，于１９９５年５月１９日通过建设部组织的科技成果鉴定。该产品技术路线正确周密，结构合理，叶片结构有创新，减速装置采用三环减速技术，高效节能，综合技术性能指标达到和超过了国内外同类产品的先进水平，是我国的专利产品，其价格仅为国外同类产品的二分之一。转刷曝气机是一种应用广泛的氧化沟曝气充氧设备。氧化沟作为城市污水?...
易控达 Genius总线隔离中继器.zip
易控达 Genius总线隔离中继器zip,Genius总线隔离中继器，YHG3产品支持3路独立GENIUS电缆数据接口，彼此之间完全电气隔离，任意一路电接口数据输入将输出到另外两路电接口。该产品具有易控达独创的总线故障智能切断功能，当某段总线段出现故障时，系统会将其自动切断，不会影响另外两路总线段。
C++API设计源代码
C++API设计一书的源代码即： This package contains the C++ source code examples from the book "API Design for C++" by Martin Reddy.
raelidea

230

社区成员

35

社区内容

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

加载中

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

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

+ 用AI写文章