-- ===========================================================
--> CafeOBJ codes for lecture 6
-- ===========================================================
--
-- Natural Numbers with the error "errNat"
-- 
-- notice that the module NATerr is different from
-- the module NAT-ERR defined in the file minila/misc.cafe
mod! NATerr {
  pr(NAT)
  [Nat ErrNat < Nat&Err]
  -- For verification
  op errNat : -> ErrNat {constr}
  --
  op _=_ : Nat&Err Nat&Err -> Bool {comm}
  op _+_ : Nat&Err Nat&Err -> Nat&Err {comm}
  op _*_ : Nat&Err Nat&Err -> Nat&Err {comm}
  op sd : Nat&Err Nat&Err -> Nat&Err {comm}
  op _quo_ : Nat Zero -> ErrNat
  op _quo_ : Nat&Err Nat&Err -> Nat&Err
  --
  vars M N : Nat
  var NE : Nat&Err
  -- _=_
  eq (NE = NE) = true .
  eq (N = M) = (N == M) .
  eq (errNat = N) = false .
  -- _+_
  eq NE + errNat = errNat .
  -- _*_
  eq NE * errNat = errNat .
  -- sd
  eq sd(NE,errNat) = errNat .
  -- quo
  eq M quo 0 = errNat .
  eq NE quo errNat = errNat .
  eq errNat quo NE = errNat .
}

--
-- Expressions
--

mod! EXP {
  pr(NATerr)
  [Nat&Err < Exp]
  op _++_ : Exp Exp -> Exp {constr l-assoc prec: 30}
  op _--_ : Exp Exp -> Exp {constr l-assoc prec: 30}
  op _**_ : Exp Exp -> Exp {constr l-assoc prec: 29}
  op _//_ : Exp Exp -> Exp {constr l-assoc prec: 29}
}

open EXP
  red 1 ++ 2 ** 3 .
  red 1 ++ 2 // 0 .
  red 1 ++ 2 // 3 -- 4 ** 5 .
  red 1 ++ errNat ** 3 .
close

--
-- Interpreter
--

mod! INTERPRETER {
  pr(EXP)
  op interpret : Exp -> Nat&Err
  var NE : Nat&Err
  vars E E1 E2 : Exp
  eq interpret(NE) = NE .
  eq interpret(E1 ++ E2) = interpret(E1) + interpret(E2) .
  eq interpret(E1 -- E2) = sd(interpret(E1),interpret(E2)) .
  eq interpret(E1 ** E2) = interpret(E1) * interpret(E2) .
  eq interpret(E1 // E2) = interpret(E1) quo interpret(E2) .
}

open INTERPRETER
  ops e1 e2 e3 e4 : -> Exp .
  eq e1 = 2 ++ 3 ** 4 .
  eq e2 = 0 // 0 .
  eq e3 = 0 // 0 ++ 0 .
  eq e4 = 2 ++ errNat ** 4 .
  red interpret(e1) .
  red interpret(e2) .
  red interpret(e3) .
  red interpret(e4) .
close

--
-- Instructions
--

mod! COMMAND {
  pr(NATerr)
  [Command]
  op push : Nat&Err -> Command {constr}
  op multiply : -> Command {constr}
  op divide : -> Command {constr}
  op add : -> Command {constr}
  op minus : -> Command {constr}
}

mod! LIST (M :: TRIV) {
  [List]
  op nil : -> List {constr}
  op _|_ : Elt.M List -> List {constr}
  op _@_ : List List -> List {assoc}
  var E : Elt.M
  vars L1 L2 : List
  eq nil @ L2 = L2 .
  eq (E | L1) @ L2 = E | (L1 @ L2) .
  eq L1 @ nil = L1 .
}

mod! CLIST {
  pr(LIST(COMMAND{sort Elt -> Command}) * {sort List -> CList})
}

mod! STACK {
  pr(LIST(NATerr{sort Elt -> Nat&Err}) * {sort List -> Stack, op nil -> empstk})
}

--
--  Virtual Machine
--

mod! VM {
  pr(CLIST)
  pr(STACK)
  op vm : CList -> Nat&Err
  op exec : CList Stack -> Nat&Err
  var CL : CList
  var Stk : Stack
  vars NE NE1 NE2 : Nat&Err
  eq vm(CL) = exec(CL,empstk) .
  --
  eq exec(nil,empstk) = errNat .
  eq exec(nil,NE | empstk) = NE .
  eq exec(nil,NE | NE1 | Stk) = errNat .
  --
  eq exec(push(NE) | CL,Stk) = exec(CL,NE | Stk) .
  --
  eq exec(add | CL,empstk) = errNat .
  eq exec(add | CL,NE | empstk) = errNat .
  eq exec(add | CL,NE2 | NE1 | Stk) = exec(CL,NE1 + NE2 | Stk) .
  --
  eq exec(multiply | CL,empstk) = errNat .
  eq exec(multiply | CL,NE | empstk) = errNat .
  eq exec(multiply | CL,NE2 | NE1 | Stk) = exec(CL,NE1 * NE2 | Stk) .
  --
  eq exec(divide | CL,empstk) = errNat .
  eq exec(divide | CL,NE | empstk) = errNat .
  eq exec(divide | CL,NE2 | NE1 | Stk) = exec(CL,NE1 quo NE2 | Stk) .
  --
  eq exec(minus | CL,empstk) = errNat .
  eq exec(minus | CL,NE | empstk) = errNat .
  eq exec(minus | CL,NE2 | NE1 | Stk) = exec(CL,sd(NE1,NE2) | Stk) .
  --
  eq exec(CL,errNat | Stk) = errNat .
  eq exec(CL,NE | errNat | Stk) = errNat .
}

--
-- Compiler
--

mod! COMPILER {
  pr(EXP)
  pr(CLIST)
  op compile : Exp -> CList
  var NE : Nat&Err
  vars E E1 E2 : Exp
  eq compile(NE) = push(NE) | nil .
  eq compile(E1 ++ E2) = compile(E1) @ compile(E2) @ (add | nil) .
  eq compile(E1 -- E2) = compile(E1) @ compile(E2) @ (minus | nil) .
  eq compile(E1 ** E2) = compile(E1) @ compile(E2) @ (multiply | nil) .
  eq compile(E1 // E2) = compile(E1) @ compile(E2) @ (divide | nil) .
}

open COMPILER
  ops e1 e2 e3 e4 : -> Exp .
  eq e1 = 2 ++ 3 ** 4 .
  eq e2 = 0 // 0 .
  eq e3 = 0 // 0 ++ 0 .
  eq e4 = 2 ++ errNat ** 4 .
  red compile(e1) .
  red compile(e2) .
  red compile(e3) .
  red compile(e4) .
close

open VM + COMPILER + INTERPRETER
  ops e1 e2 e3 e4 : -> Exp .
  eq e1 = 2 ++ 3 ** 4 .
  eq e2 = 0 // 0 .
  eq e3 = 0 // 0 ++ 0 .
  eq e4 = 2 ++ errNat ** 4 .
  red vm(compile(e1)) .
  red vm(compile(e2)) .
  red vm(compile(e3)) .
  red vm(compile(e4)) .
  --
  red interpret(e1) .
  red interpret(e2) .
  red interpret(e3) .
  red interpret(e4) .
  --
  red interpret(e1) = vm(compile(e1)) .
  red interpret(e2) = vm(compile(e2)) .
  red interpret(e3) = vm(compile(e3)) .
  red interpret(e4) = vm(compile(e4)) .
close


-- =========================================================
-- Formalization of the Correctness of the compiler
-- =========================================================

mod* COMPILER-THEOREM {
  pr(INTERPRETER)
  pr(VM)
  pr(COMPILER)
-- theorem
  op th1 : Exp -> Bool 
  eq th1(E:Exp) = (interpret(E) = vm(compile(E))) .
}

-- =======================================================
--> Theorem (\forall E:Exp)(interpret(E) = vm(compile(E)))
--   that is th1(E:Exp) 
-- =======================================================
--> Proof. By induction on the strucrure of E.
--> I. Base case
--> 0. m
open COMPILER-THEOREM
  op m : -> Nat&Err .
-- check
  red th1(m) .
close
--> II. Induction case
--> 1. e1 ++ e2
open COMPILER-THEOREM
-- arbitrary values  
  ops e1 e2 : -> Exp .
-- induction hypothesis
  eq interpret(e1) = vm(compile(e1)) .
  eq interpret(e2) = vm(compile(e2)) .
-- check
  red th1(e1 ++ e2) .
--> the above returns:
--> ((exec(compile(e1),empstk) + exec(compile(e2),empstk)) 
-->  = exec((compile(e1) @ (compile(e2) @ (add | nil))),empstk)):Bool
--> this suggest the need to introduce a lemma
close

-- =========================================================
-- module of compiler theorem with lemma
-- =========================================================

mod* COMPILER-THEOREM-with-LEMMA {
  pr(INTERPRETER)
  pr(VM)
  pr(COMPILER)
-- theorem
  op th1 : Exp -> Bool
  eq th1(E:Exp) = (interpret(E) = vm(compile(E))) .
-- lemma
  op lem1 : Exp CList Stack -> Bool
  eq lem1(E:Exp,L:CList,S:Stack) 
     = (exec(compile(E) @ L,S) = exec(L,vm(compile(E)) | S)) .
}

-- ==============================================================
-- Formal Proof (Verification) of the Correctness of the complier
-- assuming the lemma
-- ==============================================================
--
-- =======================================================
--> Theorem (\forall E:Exp)(interpret(E) = vm(compile(E)))
--   that is th1(E:Exp) 
-- =======================================================
--> Proof. By induction on the structure of E.
--> I. Base case
--> 0. m
open COMPILER-THEOREM-with-LEMMA
  op m : -> Nat&Err .
-- check
  red th1(m) .
close
--> II. Induction case
--> 1. e1 ++ e2
open COMPILER-THEOREM-with-LEMMA
-- arbitrary values  
  ops e1 e2 : -> Exp .
-- lemmas
  eq exec(compile(E:Exp) @ L:CList,S:Stack)
     = exec(L,vm(compile(E)) | S) . -- lem1(E,L,S)
-- induction hypothesis
  eq interpret(e1) = vm(compile(e1)) .
  eq interpret(e2) = vm(compile(e2)) .
-- check
  red th1(e1 ++ e2) .
close
--> 2. e1 -- e2
open COMPILER-THEOREM-with-LEMMA
-- arbitrary values  
  ops e1 e2 : -> Exp .
-- lemmas
  eq exec(compile(E:Exp) @ L:CList,S:Stack)
     = exec(L,vm(compile(E)) | S) . -- lem1(E,L,S)
-- induction hypothesis
  eq interpret(e1) = vm(compile(e1)) .
  eq interpret(e2) = vm(compile(e2)) .
-- check
  red th1(e1 -- e2) .
close
--> 3. e1 ** e2
open COMPILER-THEOREM-with-LEMMA
-- arbitrary values  
  ops e1 e2 : -> Exp .
-- lemmas
  eq exec(compile(E:Exp) @ L:CList,S:Stack)
     = exec(L,vm(compile(E)) | S) . -- lem1(E,L,S)
-- induction hypothesis
  eq interpret(e1) = vm(compile(e1)) .
  eq interpret(e2) = vm(compile(e2)) .
-- check
  red th1(e1 ** e2) .
close
--> 4. e1 // e2
open COMPILER-THEOREM-with-LEMMA
-- arbitrary values  
  ops e1 e2 : -> Exp .
-- lemmas
  eq exec(compile(E:Exp) @ L:CList,S:Stack)
     = exec(L,vm(compile(E)) | S) . -- lem1(E,L,S)
-- induction hypothesis
  eq interpret(e1) = vm(compile(e1)) .
  eq interpret(e2) = vm(compile(e2)) .
-- check
  red th1(e1 // e2) .
close
--> QED
--
-- ==========================================================
--> end end end
-- ==========================================================