Project

type ide = string
type exp =
    | Eint of int
    | Ebool of bool
    | Den of ide
    | Sum of exp * exp
    | Diff of exp * exp
    | Prod of exp * exp
    | Eq of exp * exp
    | Minus of exp
    | Iszero of exp
    | Or of exp * exp
    | And of exp * exp
    | Not of exp
    | Ifthenelse of exp * exp * exp
    | Let of ide * exp * exp
    | Fun of ide * exp
    | Apply of exp * exp
    | Letrec of ide * ide * exp * exp
    | Etup of tuple (*Tupla come espressione*)
    | Pipe of tuple (*Concatenazione di funzioni*)
    | ManyTimes of int * exp (*Esecuzione iterata di una funzione*)
and tuple =
    | Nil (*Tupla vuota*)
    | Seq of exp * tuple (*Tupla di espressioni*)
;;

type 't env = (string * 't) list
    exception WrongBindlist
    let emptyenv(x) = [("", x)]
    let rec applyenv(x, y) = match x with
      | [(_, e)] -> e
      | (i1, e1) :: x1 -> if y = i1 then e1
          else applyenv(x1, y)
      | [] -> failwith("wrong env")
    let bind(r, l, e) = (l, e) :: r
    let rec bindlist(r, il, el) = match (il, el) with
      | ([], []) -> r
      | (i::il1, e::el1) -> bindlist(bind(r, i, e), il1, el1)
      | _ -> raise WrongBindlist
;;

type eval=
    | Int of int
    | Bool of bool
    | Unbound
    | RecFunVal of ide * ide * exp * eval env
    | Funval of efun
    | ValTup of etuple
and efun = ide * exp * eval env
and etuple =
    | Nil
    | Seq of eval * etuple
;;

let typecheck(x, y) = match x with
  | "int" ->
      (match y with
        | Int(u) -> true
        | _ -> false)
  | "bool" ->
      (match y with
        |Bool(b) -> true
        |_->false)
  |_->failwith("error");;

  let plus(x, y) = if typecheck("int", x) && typecheck("int", y) then
    (match (x, y) with
      |(Int(u), Int(w)) -> Int(u + w))
  else failwith ("error");;


let diff(x,y)=if typecheck("int",x) && typecheck("int", y) then
    (match (x, y) with
      |(Int(u), Int(w)) -> Int(u - w)
      |_->failwith("error"))
  else failwith ("type error");;


let prod(x,y)=if typecheck("int",x) && typecheck("int", y) then
    (match (x, y) with
      |(Int(u), Int(w)) -> Int(u * w)
      |_->failwith("error"))
  else failwith ("type error");;


let iszero(x)=if typecheck("int",x) then
    (match x with
      |Int(u)->if u=0 then Bool(true) else Bool(false)
      |_->failwith("error"))
  else failwith("type error");;


let equ(x,y)=if typecheck("int",x) && typecheck("int", y) then
    (match (x, y) with
      |(Int(u), Int(w)) -> if u=w then Bool(true) else Bool(false)
      |_->failwith("error"))
  else failwith ("type error");;


let minus(x)=if typecheck("int",x) then
    (match x with
      |Int(u)->Int(-u)
      |_->failwith("error"))
  else failwith("type error");;


let e(x,y)=if typecheck("bool",x) && typecheck("bool", y) then
    (match (x, y) with
      |(Bool(u), Bool(w)) -> Bool(u && w)
      |_->failwith("error"))
  else failwith ("type error");;


let o(x,y)=if typecheck("bool",x) && typecheck("bool", y) then
    (match (x, y) with
      |(Bool(u), Bool(w)) -> Bool(u || w)
      |_->failwith("error"))
  else failwith ("type error");;


let non(x)=if typecheck("bool",x) then
    (match x with
      |Bool(u) -> Bool(not(u))
      |_->failwith("error"))
  else failwith ("type error");;

let rec sem ((ex: exp), (r: eval env)) = match ex with
    | Eint(n) -> Int(n)
    | Ebool(b) -> Bool(b)
    | Den(i) -> applyenv(r, i)
    | Sum(a,b) ->  plus(sem(a, r), sem(b, r))
    | Diff(a,b)  ->  diff(sem(a, r), sem(b, r))
    | Prod(a,b)->prod(sem(a,r), sem(b,r))
    | Iszero(a) -> iszero(sem(a, r))
    | Eq(a,b) -> equ(sem(a, r),sem(b, r))
    | Minus(a) ->  minus(sem(a, r))
    | And(a,b) ->  e(sem(a, r), sem(b, r))
    | Or(a,b) ->  o(sem(a, r), sem(b, r))
    | Not(a) -> non(sem(a, r))
    | Ifthenelse(a,b,c) -> let g = sem(a, r) in
          if typecheck("bool", g) then
            (if g = Bool(true) then sem(b, r) else sem(c, r))
          else failwith ("nonboolean guard")
    | Let(i, e1, e2) -> sem(e2, bind (r, i, sem(e1, r)))
    | Fun(i,a) -> Funval(i,a,r)
    | Letrec(f, i, fBody, letBody) ->
        let benv = bind(r, f, (RecFunVal(f, i, fBody, r)))
        in sem(letBody, benv)
    | Etup(tup) -> (match tup with
        | Seq(ex1, tupla) ->
            let evex1 = sem(ex1, r) in
            let ValTup(etupl) = sem(Etup(tupla), r) in
                ValTup(Seq(evex1, etupl))
        | Nil -> ValTup(Nil))
    | Apply(Den f, arg1) ->
        (let fclosure= sem(Den f, r) in
           match fclosure with
             | Funval(arg, fbody, fDecEnv) ->
                 sem(fbody, bind(fDecEnv, arg, sem(arg1, r)))
             | RecFunVal(f, arg, fbody, fDecEnv) ->
                 let aVal= sem(arg1, r) in
                 let rEnv= bind(fDecEnv, f, fclosure) in
                 let aEnv= bind(rEnv, arg, aVal) in
                   sem(fbody, aEnv)
             | _ -> failwith("non functional value"))
    | Apply(Pipe tup, arg) -> applyPipe tup arg r
    | Apply(_,_) -> failwith("not function")

and applyPipe tup argo r = (match tup with
    | Seq(Den f, tupla) ->
        let appf = Apply(Den f,argo) in
            applyPipe tupla appf r
    | Nil -> sem(argo,r)
    | _ -> failwith("Not a valid Pipe"))
;;