(**********************************************************************)
(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                Intensional Lambda Calculus                         *)
(*                                                                    *)
(* is implemented in Coq by adapting the implementation of            *)
(* Lambda Calculus from Project Coq                                   *)
(* 2015                                                               *)
(**********************************************************************)

(**********************************************************************)
(*                           Terms.v                                  *)
(*                                                                    *)
(* adapted from Terms.v for Lambda Calculus                           *)
(*                                                                    *)
(*                          Barry Jay                                 *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith.
Require Import General.
Require Import Test.

(* lambda terms with operators and using de Bruijn's indices *)

Inductive operator :=
| Sop
| Fop
.

Inductive lamSF:  Set :=
  | Ref : nat -> lamSF
  | Op  : operator -> lamSF
  | Abs : lamSF -> lamSF
  | App : lamSF -> lamSF -> lamSF
.

Lemma decidable_term_equality : forall (M N: lamSF), M = N \/ M<> N.
Proof.
induction M; induction N; intros; try (left; congruence); try(right; congruence).
elim(decidable_nats n0 n); auto.
intro; right; intro; congruence.
case o; case o0; split_all; try (left; split_all; fail);  right; split_all.
elim(IHM N); split_all.
left; congruence.
right; congruence.
elim(IHM1 N1); elim(IHM2 N2); auto;
(right; congruence; fail) || left; congruence.
Qed.

(* Lifting *)

Definition relocate (i k n : nat) :=
  match test k i with

      (* k<=i *) | left _ => n+i
   (* k>i  *) | _ => i
  end.

Fixpoint lift_rec (L : lamSF) : nat -> nat -> lamSF :=
  fun k n =>
  match L with
  | Ref i => Ref (relocate i k n)
  | Op o => Op o
  | App M N => App (lift_rec M k n) (lift_rec N k n)
  | Abs M => Abs (lift_rec M (S k) n)
  end.

Definition lift (n : nat) (N : lamSF) := lift_rec N 0 n.

(* Substitution *)

Definition insert_Ref (N : lamSF) (i k : nat) :=
  match compare k i with

   (* k<i *) | inleft (left _) => Ref (pred i)
   (* k=i *) | inleft _ => lift k N
   (* k>i *) | _ => Ref i
  end.

Fixpoint subst_rec (L : lamSF) : lamSF -> nat -> lamSF :=
  fun (N : lamSF) (k : nat) =>
  match L with
  | Ref i => insert_Ref N i k
  | Op o => Op o
  | App M M' => App (subst_rec M N k) (subst_rec M' N k)
  | Abs M => Abs (subst_rec M N (S k))
  end.

Definition subst (N M : lamSF) := subst_rec M N 0.


From Relational Require Import OrderEnrichedCategory.
Set Warnings "-notation-overridden".
From mathcomp Require Import all_ssreflect.
Set Warnings "notation-overridden".

Obligation Tactic := try (Tactics.program_simpl ; fail) ; simpl.

(*
In this file we build products of relative monad morphisms.

First we build products of natural isomorphisms: let F1,G1 : C1 → D1 and Ψ1 a
natural iso between F1 and G1. Similarly let F2,G2 : C2 → D2 and Ψ2 a natural
iso between F2 and G2.
Then we can build F1×F2, G1×G2 : C1×C2→D1×D2 and a natural iso Ψ1×Ψ2 between
the product functors F1×F2 and G1×G2.

Second, two relative monad morphisms θ1 : M1 → W1 and θ2 : M2 → W2 can
be multiplied together to get θ1 × θ2 : M1×M2 → W1×W2 (section Rel_mon_morph_prod).
*)

Section NatIso_prod.
  (*globes*)

  Context {C1 D1 : ord_category} {F1 G1 : ord_functor C1 D1}
          (psi1  : natIso F1 G1).
  Context {C2 D2 : ord_category} {F2 G2 : ord_functor C2 D2}
          (psi2  : natIso F2 G2).

  Local Definition Cprod := prod_cat C1 C2.
  Local Definition Dprod := prod_cat D1 D2.
  Local Definition Fprod := prod_functor F1 F2.
  Local Definition Gprod := prod_functor G1 G2.

  Program Definition prod_natIso : natIso Fprod Gprod := mkNatIso _ _ _ _ _ _ _.
  Next Obligation. (*the map*)
    move=> [A1 A2]. unshelve econstructor. all:simpl.
    apply psi1. apply psi2.
  Defined.
  Next Obligation. (*the inverse map*)
    move=> [A1 A2]. split. all:simpl.
    apply (ni_inv psi1). apply (ni_inv psi2).
  Defined.
  Next Obligation. (*naturality*)
    move=> [A1 A2 [B1 B2]]. all:simpl. move=> [f1 f2]. all:simpl.
    f_equal. eapply (ni_natural _ _ psi1). eapply (ni_natural _ _ psi2).
  Qed.
  Next Obligation. (*proof that it is inverse*)
    move=> [A1 A2]. simpl. f_equal.
    eapply (ni_rightinv _ _ psi1). eapply (ni_rightinv _ _ psi2).
  Qed.
  Next Obligation. (*proof that it is inverse*)
    move=> [A1 A2]. simpl. f_equal.
    eapply (ni_leftinv _ _ psi1). eapply (ni_leftinv _ _ psi2).
  Qed.

End NatIso_prod.

Section Rel_mon_morph_prod.
  (*The first square. it is indexed with _1*)

  Context {I1 CM1 CW1: ord_category}
          {JM1 : ord_functor I1 CM1} {JW1 : ord_functor I1 CW1}
          {JMW1 : ord_functor CM1 CW1}
          {M1 : ord_relativeMonad JM1} {W1 : ord_relativeMonad JW1}
          {cmtSqu1 : natIso JW1 (ord_functor_comp JM1 JMW1)}.
  (*the second square.*)
  Context {I2 CM2 CW2: ord_category}
          {JM2 : ord_functor I2 CM2} {JW2 : ord_functor I2 CW2}
          {JMW2 : ord_functor CM2 CW2}
          {M2 : ord_relativeMonad JM2} {W2 : ord_relativeMonad JW2}
          {cmtSqu2 : natIso JW2 (ord_functor_comp JM2 JMW2)}.

  Local Definition Iprod := prod_cat I1 I2.
  Local Definition CMprod := prod_cat CM1 CM2.
  Local Definition CWprod := prod_cat CW1 CW2.

  Local Definition JMprod := prod_functor JM1 JM2.
  Local Definition JWprod := prod_functor JW1 JW2.
  Local Definition JMWprod := prod_functor JMW1 JMW2.

  Local Definition Mprod := product_rmon M1 M2.
  Local Definition Wprod := product_rmon W1 W2.

  Local Definition cmtSqu_prod := prod_natIso cmtSqu1 cmtSqu2.

  Context (theta1 : relativeMonadMorphism JMW1 cmtSqu1 M1 W1)
          (theta2 : relativeMonadMorphism JMW2 cmtSqu2 M2 W2).

  Local Program Definition cmtSqu
  :natIso (prod_functor JW1 JW2) (ord_functor_comp (prod_functor JM1 JM2) JMWprod)
  := mkNatIso _ _ (prod_natIso cmtSqu1 cmtSqu2) _ _ _ _.
  Next Obligation.
    apply (ni_inv (prod_natIso cmtSqu1 cmtSqu2)).
  Defined.
  Next Obligation.
    eapply (@ni_natural Iprod CWprod JWprod _ (prod_natIso cmtSqu1 cmtSqu2)).
  Qed.
  Next Obligation.
    eapply (@ni_rightinv Iprod CWprod JWprod _ (prod_natIso cmtSqu1 cmtSqu2)).
  Qed.
  Next Obligation.
    eapply (@ni_leftinv Iprod CWprod JWprod _ (prod_natIso cmtSqu1 cmtSqu2)).
  Qed.

  Program Definition prod_relativeMonadMorphism
  : relativeMonadMorphism JMWprod cmtSqu Mprod Wprod :=
    mkRelMonMorph JMWprod cmtSqu Mprod Wprod _ _ _.
  Next Obligation.
    split. apply theta1. apply theta2.
  Defined.
  Next Obligation. (*law 1*)
  move=> [A1 A2]. simpl. f_equal.
  eapply (rmm_law1 _ _ _ _ theta1). eapply (rmm_law1 _ _ _ _ theta2).
  Qed.
  Next Obligation.
  move=> [A1 A2 [B1 B2]]. move=> [f1 f2]. simpl. f_equal.
  eapply (rmm_law2 _ _ _ _ theta1). eapply (rmm_law2 _ _ _ _ theta2).
  Qed.

End Rel_mon_morph_prod.


(** * 6.822 Formal Reasoning About Programs, Spring 2018 - Pset 10 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** * Hoare Logic with Input/Output Traces *)

(* Hoare logic as covered in lecture is only the beginning, so far as
 * programming features that can be supported. In this problem set, we
 * will implement one of variant, a Hoare logic that deals with
 * input/output traces.
 *
 * As we learned in compiler verification, behaviors of a program can be
 * defined as sequences of communications with the outside world. Hoare logic
 * certainly can be used for proving properties about program behaviors.
 * Besides valuation and heap, we will need to keep track of traces of a program
 * to ensure the properties we want, sometimes by proving invariants in the
 * middle of the program.
 *
 * The problem set consists of 4 tasks; basically we ask you to formally prove
 * the correctness of some programs using Hoare logic:
 * 1) To design a big-step operational semantics of the given language.
 * 2) To define a Hoare logic for the language, and to prove the consistency
 *    between the semantics and the logic.
 * 3) To verify three example programs we provide, using Hoare logic.
 * 4) To design your own interesting program and to verify it.
 *)

(** * Language syntax *)

(* There is nothing special with the definitions of [exp] and [bexp]; they are
 * exactly same as we've seen in the lecture.
 *)
Inductive exp :=
| Const (n : nat)
| Var (x : string)
| Read (e1 : exp)
| Plus (e1 e2 : exp)
| Minus (e1 e2 : exp)
| Mult (e1 e2 : exp).

Inductive bexp :=
| Equal (e1 e2 : exp)
| Less (e1 e2 : exp).

(* [heap] and [valuation] are also as usual. *)
Definition heap := fmap nat nat.
Definition valuation := fmap var nat.

(* Besides [heap] and [valuation], we have one more component to verify using
 * Hoare logic, called [io]. We keep track of inputs and outputs of a certain
 * program, regarding them as meaningful communication with the outside world.
 * When a program is executed, it generates [trace], which is a list of [io]s,
 * meaning inputs and outputs that occurred during the execution. Traces are
 * also called behaviors of a program.
 *)
Inductive io := In (v : nat) | Out (v : nat).
Definition trace := list io.

(* We now have two types of assertions: [iassertion] is used only for asserting
 * properties of internal states. [assertion] can be used for asserting
 * properties of [trace]s as well as internal states.
 *)
Definition iassertion := heap -> valuation -> Prop.
Definition assertion := trace -> heap -> valuation -> Prop.

(* [cmd] has more constructors than what we've seen.  The new ones are called
 * [Input] and [Output]. As expected, semantically they generates [io]s,
 * eventually forming a [trace] of a program.
 *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : exp)
| Write (e1 e2 : exp)
| Seq (c1 c2 : cmd)
| If_ (be : bexp) (then_ else_ : cmd)
| While_ (inv : assertion) (be : bexp) (body : cmd)

| Assert (a : iassertion) (* Note that we are using [iassertion], not
                           * [assertion], for [Assert]. While [valuation] and
                           * [heap] are internal states directly manipulated by
                           * a program, [trace] is rather an abstract notion for
                           * defining a behavior of a program.
                           *)

(* The new constructors are below! *)
| Input (x : var) (* [Input] takes an input from the external world and assigns
                   * the value to the local variable [x].
                   *)
| Output (e : exp). (* [Output] prints the value of [e]. *)

(** We here provide fancy notations for our language. *)

Coercion Const : nat >-> exp.
Coercion Var : string >-> exp.
Notation "*[ e ]" := (Read e) : cmd_scope.
Infix "+" := Plus : cmd_scope.
Infix "-" := Minus : cmd_scope.
Infix "*" := Mult : cmd_scope.
Infix "=" := Equal : cmd_scope.
Infix "<" := Less : cmd_scope.
Definition set (dst src : exp) : cmd :=
  match dst with
  | Read dst' => Write dst' src
  | Var dst' => Assign dst' src
  | _ => Assign "Bad LHS" 0
  end.
Infix "<-" := set (no associativity, at level 70) : cmd_scope.
Infix ";;" := Seq (right associativity, at level 75) : cmd_scope.
Notation "'when' b 'then' then_ 'else' else_ 'done'" :=
  (If_ b then_ else_) (at level 75, b at level 0) : cmd_scope.
Notation "{{ I }} 'while' b 'loop' body 'done'" := (While_ I b body) (at level 75) : cmd_scope.
Notation "'assert' {{ I }}" := (Assert I) (at level 75) : cmd_scope.
Notation "x '<--' 'input'" := (Input x) (at level 75) : cmd_scope.
Notation "'output' e" := (Output e) (at level 75) : cmd_scope.
Delimit Scope cmd_scope with cmd.

Infix "+" := plus : reset_scope.
Infix "-" := Init.Nat.sub : reset_scope.
Infix "*" := mult : reset_scope.
Infix "=" := eq : reset_scope.
Infix "<" := lt : reset_scope.
Delimit Scope reset_scope with reset.
Open Scope reset_scope.

(** * Task 1: A big-step operational semantics for commands *)

(* Your first task is to define a big-step operational semantics for commands.
 * While it should be very similar to what we've seen in class, it should
 * also represent something about [io]s (or [trace]). Make sure the semantics
 * captures the effects of [Input]/[Output] on [trace]s. The most
 * recent event should appear at the *front* of the list in the trace.
 *
 * We provide the signature of the big-step semantics below. Replace the
 * [Axiom] below with your own definition of the semantics.
 * The first three arguments are the trace, heap, and valuation before execution,
 * and the final three arguments are the trace, heap, and valuation after execution.
 *)

(** * Define your semantics here! *)

Axiom exec : trace -> heap -> valuation -> cmd ->
             trace -> heap -> valuation -> Prop.

(** * Task 2 : Hoare logic *)

(* We also ask you to define a Hoare logic for our language. The logic should
 * derive triples of the form {{ P }} c {{ Q }}, where "P" and "Q" have type
 * [assertion] and "c" has type [cmd]. It should be also very similar to the
 * Hoare logic we've defined in class.
 *)

(* The logic should be consistent with the semantics you defined, so we
 * also ask you to prove a soundness relation between your Hoare logic and your
 * semantics.  You will need this consistency to prove the correctness of
 * example programs we will provide soon.
 *)

(** Task 2-1: Define your Hoare logic here! *)

Axiom hoare_triple : assertion -> cmd -> assertion -> Prop.

Notation "[[ tr , h , v ]] ~> e" := (fun tr h v => e%reset) (at level 90).
Notation "{{ P }} c {{ Q }}" :=
  (hoare_triple P c%cmd Q) (at level 90, c at next level).

(** Task 2-2: Prove the consistency theorem. *)

Theorem hoare_triple_big_step :
  forall pre c post,
    hoare_triple pre c post ->
    forall tr h v tr' h' v',
      exec tr h v c tr' h' v' ->
      pre tr h v -> post tr' h' v'.
Proof.
Admitted.

(** * Task 3: Verification of some example programs *)

(* Now it's time to verify programs using the Hoare logic you've just defined!
 * We provide three example programs and three corresponding correctness
 * theorems. You are required to prove the theorems stated below using Hoare
 * logic.
 *)

(** Task 3-1: adding two inputs -- prove [add_two_inputs_ok] *)

Example add_two_inputs :=
  ("x" <-- input;;
   "y" <-- input;;
   output ("x" + "y"))%cmd.

Theorem add_two_inputs_ok:
  forall tr h v tr' h' v',
    exec tr h v add_two_inputs tr' h' v' ->
    tr = nil ->
    exists vx vy, tr' = [Out (vx + vy); In vy; In vx].
Proof.
Admitted.

(** Task 3-2: finding the maximum of three numbers -- prove [max3_ok] *)

Example max3 :=
  ("x" <-- input;;
   "y" <-- input;;
   "z" <-- input;;
   when "x" < "y" then
     when "y" < "z" then
       output "z"
     else
       output "y"
     done
   else
     when "x" < "z" then
       output "z"
     else
       output "x"
     done
   done)%cmd.

Inductive max3_spec : trace -> Prop :=
| M3s: forall x y z mx,
    mx >= x ->
    mx >= y ->
    mx >= z ->
    (mx = x \/ mx = y \/ mx = z) ->
    max3_spec [Out mx; In z; In y; In x].

Theorem max3_ok:
  forall tr h v tr' h' v',
    exec tr h v max3 tr' h' v' ->
    tr = nil ->
    max3_spec tr'.
Proof.
Admitted.

(** Task 3-3: Fibonacci sequence -- prove [fibonacci_ok] *)

Inductive fibonacci_spec : trace -> Prop :=
| Fs0: fibonacci_spec nil
| Fs1: fibonacci_spec [Out 1]
| Fs2: fibonacci_spec [Out 1; Out 1]
| Fsn:
    forall x y tr,
      fibonacci_spec (Out y :: Out x :: tr) ->
      fibonacci_spec (Out (x + y) :: Out y :: Out x :: tr).

Example fibonacci (n: nat) :=
  ("cnt" <- 0;;
   "x" <- 0;;
   "y" <- 1;;
   output "y";;
   {{ fun _ _ _ => True }} (* You may change this loop invariant to make your
                            * proof easier! *)
   while "cnt" < n loop
     "tmp" <- "y";;
     "y" <- "x" + "y";;
     "x" <- "tmp";;
     "cnt" <- "cnt" + 1;;
     output "y"
   done)%cmd.

Theorem fibonacci_ok (n: nat):
  forall tr h v tr' h' v',
    exec tr h v (fibonacci n) tr' h' v' ->
    tr = nil ->
    fibonacci_spec tr'.
Proof.
Admitted.

(** * Task 4: Implement your own program to verify. *)

(* The last task is to implement your own program and to verify its correctness
 * using Hoare logic. Note that the three examples we provided above had nothing
 * to do with [heap]s. Design a program that uses the heap in a nontrivial
 * manner and prove its correctness.
 *)

(** Define your own program and prove its correctness here! *)