(* Este archivo contiene todas las definiciones y teoremas necesarios para probar que la insercion de elementos
a un arbol rojinegro, da como resultado un arbol rojinegro *)

(* Archivo traducido de ARNo.hs, se uso hs-to-coq para traducir pero las definiciones no pasaron inmediatamente despuesdes
de hacer la traduccion, varias se tuvieron que mejorar para hacer la demostracion mas sencilla, otras como balance se reescribieron completamente

Se puede decir que la traduccion que dio la herramienta se uso como guia para poder obtener un script que funcionara medianamente bien para lo que se
busca hacer.

Se entiende que esta es una estrucutura un tanto compleja y que la herramienta todavia esta en su infancia y no genere
codigo 100% proof ready *)
Generalizable All Variables.

Require Export Utf8_core.
Require Import Coq.Classes.RelationClasses.
Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Require Import Coq.Program.Equality.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.
Require Import ARNDefiniciones.

(* Converted imports: *)

Require GHC.Base.
Require GHC.Err.
Require GHC.Types.
Import GHC.Base.Notations.

Definition balance {a} `{GHC.Base.Ord a} (rb: Color) (t1: RB a) (k: a) (t2: RB a) :=
 match rb with R => T R t1 k t2
 | _ =>
 match t1 with
 | T R (T R a x b) y c =>
      T R (T B a x b) y (T B c k t2)
 | T R a x (T R b y c) =>
      T R (T B a x b) y (T B c k t2)
 | a => match t2 with
            | T R (T R b y c) z d =>
                T R (T B t1 k b) y (T B c z d)
            | T R b y (T R c z d) =>
                T R (T B t1 k b) y (T B c z d)
            | _ => T B t1 k t2
            end
  end
 end.
(*Se utiliza la definicion de arriba porque facilita la demostracion del teorema final de este archivo.*)
(*(* reorganiza los colores,
si algun subarbol es rojo, hace rojo a la raiz y los subarboles los hace negros
en otro caso lo deja negro
*)
Definition balance {a} : RB a -> a -> RB a -> RB a :=
  fun arg_0__ arg_1__ arg_2__ =>
    match arg_0__, arg_1__, arg_2__ with
    | T R a x b, y, T R c z d => T R (T B a x b) y (T B c z d)
    | T R (T R a x b) y c, z, d => T R (T B a x b) y (T B c z d)
    | T R a x (T R b y c), z, d => T R (T B a x b) y (T B c z d)
    | a, x, T R b y (T R c z d) => T R (T B a x b) y (T B c z d)
    | a, x, T R (T R b y c) z d => T R (T B a x b) y (T B c z d)
    | a, x, b => T B a x b
    end.
     *)
Hint Resolve balance.
(* Esta es la funcion auxiliar de la insercion
 *)
Fixpoint ins {a} `{GHC.Base.Ord a} (x: a) (s: RB a) :=
 match s with
 | E => T R E x E
 | T c a y b => if x GHC.Base.< y : bool then balance c (ins x a) y b
                        else if y GHC.Base.< x : bool then balance c a y (ins x b)
                        else T c a x b
 end.

(* Se opto por la definicion antes escrita por simplicidad al igual que la desmostracion se hacia mas facil.
 *)
(* Fixpoint ins {a} `{GHC.Base.Ord a} (arg_0__: a) (arg_1__: RB a):RB a :=
   match arg_0__, arg_1__ with
           | x, E => T R E x E
           | x, (T B a y b as s) =>
               if x GHC.Base.< y : bool then balance (ins x a) y b else
               if x GHC.Base.> y : bool then balance a y (ins x b) else
               s
           | x, (T R a y b as s) =>
               if x GHC.Base.< y : bool then T R (ins x a) y b else
               if x GHC.Base.> y : bool then T R a y (ins x b) else
               s
           end. *)

Hint Unfold ins.

(* Solo hace negro a la raiz de un arbol rn cualesquiera.
 *)
Definition makeBlack {a} `{GHC.Base.Ord a} (t: RB a) :=
  match t with
  | E => E
  | T _ a x b => T B a x b
  end.
Hint Unfold makeBlack.

(* Funcion que sirve como wrapper para la funcion auxilar ins
 *)
(* cambiar el tipo de regreso a un tipo error/option ------2018*)
(* No se eta usando option porque estorba y se esta simulando la funcion total al agregar el ultimo caso*)
Definition insert{a} `{GHC.Base.Ord a} (x:a) (s: RB a):= makeBlack (ins x s).

Hint Unfold insert.

(* proofs *)

(* definicion inductiva que ayuda a verificar que un arbol es rojinegro al llevar un contador de la altura
negra del arbol
 *)
(* dos nodos sucesivos NO pueden ser rojos *)
Inductive is_redblack {a} `{GHC.Base.Ord a} : RB a -> Color -> nat -> Prop :=
 | IsRB_leaf: forall c, is_redblack E c 0
 | IsRB_r: forall tl x tr n,
          is_redblack tl R n ->
          is_redblack tr R n ->
          is_redblack (T R tl x tr) B n
 | IsRB_b: forall c tl x tr n,
          is_redblack tl B n ->
          is_redblack tr B n ->
          is_redblack (T B tl x tr) c (S n).

Hint Constructors is_redblack.

(* definicion inductiva que sirve como auxiliar al momento de la demostracion, es un poco mas laxa con una invariante
de los arboles rojinegros, ya que permite que la raiz sea roja y que haya dos rojos a lo mas en la raiz del arbol.
 *)
Inductive nearly_redblack {a} `{GHC.Base.Ord a}: RB a -> nat -> Prop :=
| nrRB_r: forall tl k tr n,
         is_redblack tl B n ->
         is_redblack tr B n ->
         nearly_redblack (T R tl k tr) n
| nrRB_b: forall tl k tr n,
         is_redblack tl B n ->
         is_redblack tr B n ->
         nearly_redblack (T B tl k tr) (S n).

(* lema que prueba que un arbol con al menos un elemento no es vacio.
 *)
Lemma T_neq_E {a} `{GHC.Base.Ord a}:
  ∀ (c:Color) (l: RB a) (k: a) (r: RB a), T c l k r ≠ E.
Proof.
intros. intro Hx. inversion Hx.
Qed.

Hint Resolve T_neq_E.

(* Lema que prueba que la insercion en un arbol rojinegro no da como resultado un arbol vacio.
 *)
(* La demostracion es bastante sencilla pero muy repetitiva, consiste en ir destruyendo la estructura hasta caer en los casos bases
de las definiciones antes dadas, de tal manera que se pueda aplicar el lemma T_neq_E, que es a lo que siempre se llega
despues de destruir la insercion.
 *)
Lemma ins_not_E{a} `{GHC.Base.Ord a}: forall (x: a) (s: RB a), ins x s ≠ E.
Proof.
intros.
(* dependent induction s. *)
destruct s.
- simpl.
  apply T_neq_E.
- remember (ins x s1) as a1.
  remember (ins x s2) as a2.
(*   El recordar y sustituir de esta manera es lo que nos hace tener resultados de la forma del lemma T_neq_E.
 *)
  simpl.
  destruct c;case_eq (x GHC.Base.< a0);case_eq (a0 GHC.Base.< x);intros; eauto.
(*   -- rewrite <- Heqa1.
     apply T_neq_E.
  -- rewrite <- Heqa2.
     apply T_neq_E.
  -- apply T_neq_E.
  -- apply T_neq_E.
 *)  -- rewrite <- Heqa1.
     unfold balance.
     destruct a1.
     --- destruct s2; eauto.
     --- apply T_neq_E.
     -- simpl.
       rewrite <- Heqa1.
       apply T_neq_E.
     -- simpl.
       rewrite <- Heqa2.
       apply T_neq_E.
     -- rewrite <- Heqa1.
        simpl.
        destruct a1.
        destruct s2.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        destruct c;destruct s2.
        destruct a1_1.
        destruct a1_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct a1_1.
        destruct a1_2.
        destruct c.
        destruct s2_1; destruct s2_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0;apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c ;apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        destruct a1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct a1_2.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct a1_2.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
        destruct c;destruct s2_2;destruct s2_1.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        --rewrite <- Heqa1.
        simpl.
        destruct a1.
        destruct s2.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        destruct c;destruct s2.
        destruct a1_1.
        destruct a1_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct a1_1.
        destruct a1_2.
        destruct c.
        destruct s2_1; destruct s2_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0;apply T_neq_E.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        destruct c0.
        apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct s2_2.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        destruct c0.
        apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        destruct a1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct a1_2.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct a1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
        destruct c.
        destruct s2_1.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
        -- rewrite <- Heqa2.
        simpl.
        destruct a2.
        destruct s1.
        apply T_neq_E.
        destruct c.
        destruct s1_1.
        destruct s1_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s1_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        apply T_neq_E.
        destruct c;destruct s1.
        destruct a2_1.
        destruct a2_2.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct a2_1.
        destruct a2_2.
        destruct c.
        destruct s1_1; destruct s1_2.
        apply T_neq_E.
        destruct c; apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0;apply T_neq_E.
        apply T_neq_E.
        destruct c.
        destruct s1_1.
        destruct s1_2.
        destruct c0.
        apply T_neq_E.
        apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s1_2.
        destruct c0 ;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        apply T_neq_E.
        destruct c0;apply T_neq_E.
        destruct c.
        destruct s1_1.
        destruct s1_2.
        destruct c0.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s1_2.
        destruct c0.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c0.
        apply T_neq_E.
        destruct a2_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
        destruct c.
        destruct s1_1.
        destruct s1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        destruct c.
        apply T_neq_E.
        destruct s1_2.
        apply T_neq_E.
        destruct c;apply T_neq_E.
        apply T_neq_E.
(* Toda la prueba lleva el mismo patron, probablemente no sea muy complicado automatizar.
 *)
Qed.

Hint Resolve ins_not_E.

(* Este lemma nos dice que si tenemos un arbol _rojo_ (nodo fantasma padre de la raiz) puede ser pintado de negro sin mayor problema
 *)
Lemma is_redblack_toblack {a} `{GHC.Base.Ord a}:
  ∀ (s:RB a) (n: nat), is_redblack s R n → is_redblack s B n.
Proof.
intros.
destruct H1; auto.
(* - constructor.
- constructor;trivial.
- constructor;trivial.
 *)
Qed.

Hint Resolve is_redblack_toblack.

(* Al hacer makeBlack puede que la altura del arbol crezca en uno ya que la raiz puede ser roja(nearly_redblack) y
tiene que ser pintada de negro.
 *)
Lemma makeblack_fiddle {a} `{GHC.Base.Ord a}:
  ∀ (s: RB a)(n : nat), is_redblack s B n →
            ∃ (n:nat), is_redblack (makeBlack s) R n.
Proof.
intros.
dependent induction H1.
(* destruct H1. *)
- exists 0.
  simpl.
  constructor.
- simpl.
  exists (S n).
  constructor; apply is_redblack_toblack;trivial.
- exists (S n).
  constructor;trivial.
Qed.

Hint Resolve makeblack_fiddle.

(* Intento fallido de la prueba de que la insercion es rojinegra, justo como viene en el libro de Appel.
 *)
Lemma ins_is_redblack_2 {a} `{GHC.Base.Ord a}:
  forall (x: a) (s:RB a) (n:nat),
    (is_redblack s B n -> nearly_redblack (ins x s) n) /\
    (is_redblack s R n -> is_redblack (ins x s) B n).
Proof.
induction s; intro n; simpl; split; intros; inversion H1;repeat constructor;auto.
destruct (_GHC.Base.<_ x a0).
destruct (IHs1 n).
destruct (IHs2 n).
unfold balance.
constructor.
eauto.
specialize (H12 H8).
trivial.
auto.
destruct (_GHC.Base.<_ a0 x).
destruct (IHs1 n).
destruct (IHs2 n).
intuition.
apply is_redblack_toblack in H7.
apply is_redblack_toblack in H8.
intuition.
remember (ins x s2) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction.
unfold balance.
constructor;auto.
constructor;auto.
destruct (IHs1 n0).
destruct (IHs2 n0).
intuition.
subst.
destruct (_GHC.Base.<_ x a0).
remember (ins x s1) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction.
unfold balance.
destruct c.
destruct a1_1.
destruct a1_2.
destruct s2.
constructor;auto.
inversion H14;subst.
constructor.

Admitted.

(* Pruba con una modificacion al color, lo cual solo nos deja con dos casos que son complicados de resolver, a diferencia
de la desmostracion pasada.

El estilo de la demostracion es parecida a la de ins_not_E, con la diferencia de que aqui se utiliza induccion sobre el arbol
mas el truco de recordar la operacion ins x a para poder capturar una absudurdo en el cual se pone que T c l a r = E, hay una contradiccion por cada
caso que genera la induccion sobre el arbol.

Dejando ese absurdo de lado el estilo de la demostracion sigue el camino de utilizar las definiciones inductivas para probar quelos arboles
despues de insertar elementos sigan siendo rojinegros.

 *)
Lemma ins_is_redblack_1 {a} `{GHC.Base.Ord a}:
  forall (x: a) (s:RB a) (n:nat),
    (is_redblack s R n -> nearly_redblack (ins x s) n) /\
    (is_redblack s B n -> is_redblack (ins x s) B n).
Proof.
induction s; intro n; simpl; split; intros; inversion H1;repeat constructor;auto.
3: {
subst.
destruct (IHs1 n0).
destruct (IHs2 n0).
destruct (_GHC.Base.<_ x a0).
- unfold balance.
remember (ins x s1) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
destruct c.
destruct a1_1.
destruct a1_2.
destruct s2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
destruct s2_1.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
apply is_redblack_toblack.
trivial.
constructor.
inversion H9.
inversion H13.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
constructor.
inversion H9.
trivial.
inversion H9.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
inversion H10.
inversion H9.
constructor.
inversion H10.
apply is_redblack_toblack.
trivial.
destruct s2_2.
constructor.
apply H3.
trivial.
inversion H9.
constructor.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
apply is_redblack_toblack.
trivial.
inversion H9.
constructor.
inversion H13.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
constructor.
apply H3.
trivial.
trivial.
destruct c.
specialize (H3 H8).
inversion H3.
constructor.
constructor.
apply is_redblack_toblack.
trivial.
inversion H13.
constructor.
inversion H13.
trivial.
destruct s2.
specialize (H3 H8).
constructor.
trivial.
trivial.
destruct c.
destruct s2_1.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
apply is_redblack_toblack.
trivial.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
inversion H10.
inversion H9.
inversion H10.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
apply is_redblack_toblack.
trivial.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
constructor.
apply H3.
trivial.
trivial.
destruct c.
specialize (H3 H8).
inversion H3.
constructor.
inversion H10.
constructor.
apply is_redblack_toblack.
trivial.
trivial.
destruct a1_2.
destruct s2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
destruct s2_1.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
auto.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
inversion H10.
inversion H9.
inversion H10.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
apply is_redblack_toblack.
trivial.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
constructor.
apply H3.
trivial.
trivial.
destruct c.
specialize (H3 H8).
constructor.
constructor.
inversion H3.
auto.
inversion H3.
inversion H13.
inversion H3.
inversion H13.
destruct s2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
destruct s2_1.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
auto.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
inversion H10.
inversion H9.
inversion H10.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
auto.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
constructor.
apply H3.
trivial.
trivial.
destruct s2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
destruct s2_1.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
auto.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
inversion H10.
inversion H9.
inversion H10.
destruct s2_2.
constructor.
apply H3.
trivial.
trivial.
destruct c.
constructor.
constructor.
apply H3.
trivial.
inversion H9.
auto.
inversion H9.
inversion H13.
constructor.
apply H3.
trivial.
trivial.
constructor.
apply H3.
trivial.
trivial.
-specialize (H5 H9).
destruct (_GHC.Base.<_ a0 x).
unfold balance.
remember (ins x s2) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
destruct c.
destruct a1_1.
destruct a1_2.
destruct s1.
constructor.
trivial.
apply H5.
trivial.
destruct c.
destruct s1_1.
destruct s1_2.
constructor.
trivial.
apply H5.
trivial.
destruct c.
constructor.
constructor.
inversion H8.
auto.
inversion H8.
inversion H13.
constructor.
inversion H8.
inversion H13.
apply H5.
trivial.
constructor.
inversion H8.
trivial.
apply H5.
trivial.
destruct c.
constructor.
inversion H8.
inversion H10.
inversion H8.
constructor.
auto.
apply H5.
trivial.
destruct s1_2.
constructor.
inversion H8.
constructor.
trivial.
trivial.
apply H5.
trivial.
destruct c.
constructor.
constructor.
inversion H8.
auto.
inversion H8.
inversion H13.
constructor.
inversion H8.
inversion H13.
apply H5.
trivial.
constructor.
trivial.
apply H5.
trivial.
constructor.
trivial.
apply H5.
trivial.
destruct s1.
destruct c.
constructor.
auto.
inversion H5.
inversion H13.
constructor.
trivial.
trivial.
destruct c0.
destruct s1_1.
destruct s1_2.
destruct c.
constructor.
constructor.
trivial.
inversion H8.
auto.
inversion H5.
inversion H13.
inversion H5.
constructor.
constructor.
trivial.
trivial.
trivial.
destruct c0.
inversion H8.
inversion H13.
destruct c.
inversion H8.
constructor.
constructor.
constructor.
trivial.
trivial.
auto.
inversion H5.
inversion H19.
inversion H8.
constructor.
trivial.
trivial.
destruct c0.
inversion H8.
inversion H5.
constructor.
inversion H10.
constructor.
auto.
constructor;trivial.
inversion H5.
inversion H8.
subst.
destruct s1_2.
destruct c.
constructor.
constructor.
constructor.
trivial.
trivial.
auto.
inversion H13.
constructor.
constructor.
trivial.
trivial.
auto.
destruct c0.
constructor.
constructor.
auto.
inversion H19.
constructor.
inversion H19.
constructor;auto.
destruct c.
constructor.
constructor.
constructor;auto.
auto.
inversion H13.
constructor;auto.
inversion H5.
subst.
destruct c.
constructor;auto.
inversion H13.
constructor;auto.
inversion H5.
subst.
destruct s1.
destruct c.
constructor;auto.
inversion H10.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H13.
constructor;auto.
destruct c0.
destruct s1_1.
destruct s1_2.
destruct c.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
inversion H13.
constructor;auto.
destruct c0.
inversion H8.
inversion H15.
destruct c.
inversion H8.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
inversion H13.
constructor;auto.
destruct c0.
inversion H8.
inversion H11.
destruct s1_2.
destruct c.
inversion H8.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
inversion H8.
inversion H13.
constructor;auto.
destruct c0.
inversion H8.
inversion H15.
destruct c.
inversion H8.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
inversion H8.
inversion H13.
constructor;auto.
destruct c.
inversion H10.
destruct a1_2.
constructor;auto.
destruct c.
inversion H13.
constructor;auto.
destruct s1.
constructor;auto.
destruct c.
destruct s1_1.
destruct s1_2.
constructor;auto.
destruct c.
inversion H8.
inversion H13.
constructor;auto.
destruct c.
inversion H8.
inversion H10.
destruct s1_2.
constructor;auto.
destruct c.
inversion H8.
inversion H13.
constructor;auto.
constructor;auto.
constructor;auto.
}
1:{subst.
destruct (IHs1 n0).
destruct (IHs2 n0).
destruct (_GHC.Base.<_ x a0).
specialize (H3 H8).
unfold balance.
remember (ins x s1) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
inversion H3.
subst.
destruct a1_1.
destruct a1_2.
destruct s2.
constructor;auto.
destruct c.
destruct s2_1.
destruct s2_2.
constructor;auto.
inversion H9.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
inversion H9;subst.
destruct c.
inversion H10.
destruct s2_2.
constructor;auto.
destruct c.
constructor.
constructor;auto.
inversion H15.
constructor;auto.
constructor;auto.
destruct c.
constructor.
inversion H14.
inversion H14.
destruct s2.
constructor;auto.
destruct c.
destruct s2_1.
destruct s2_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H9.
inversion H15.
inversion H9.
constructor;auto.
inversion H9.
subst.
destruct c.
constructor.
inversion H10.
inversion H10.
destruct s2_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
constructor;auto.
destruct c.
constructor;auto.
inversion H13.
destruct a1_2.
destruct s2.
constructor;auto.
destruct c.
destruct s2_1.
destruct s2_2.
constructor;auto.
inversion H9.
subst.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
inversion H9.
subst.
destruct c.
inversion H10.
destruct s2_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
constructor;auto.
destruct c.
inversion H14.
destruct s2.
constructor;auto.
destruct c.
destruct s2_1.
destruct s2_2.
constructor;auto.
inversion H9.
subst.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
inversion H9.
subst.
destruct c.
constructor.
inversion H10.
inversion H10.
destruct s2_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H15.
constructor;auto.
constructor;auto.
subst.
destruct s2.
constructor;auto.
destruct c.
destruct s2_1.
destruct s2_2.
constructor;auto.
inversion H9.
subst.
destruct c.
constructor;auto.
inversion H13.
constructor;auto.
inversion H9;subst.
destruct c.
inversion H10.
destruct s2_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H13.
constructor;auto.
constructor;auto.

-destruct (_GHC.Base.<_ a0 x).
specialize (H5 H9).
unfold balance.
remember (ins x s2) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
inversion H5.
subst.
destruct a1_1.
destruct a1_2.
destruct s1.
constructor;auto.
destruct c.
destruct s1_1.
destruct s1_2.
constructor;auto.
inversion H8.
subst.
destruct c.
inversion H15.
constructor;auto.
inversion H8;subst.
destruct c.
inversion H10.
destruct s1_2.
constructor;auto.
destruct c.
constructor.
constructor;auto.
inversion H15.
inversion H15.
constructor;auto.
constructor;auto.
destruct s1.
destruct c.
inversion H14.
constructor;auto.
destruct c0.
destruct s1_1.
destruct s1_2.
destruct c.
constructor;auto.
inversion H8.
inversion H14.
constructor;auto.
inversion H8.
subst.
destruct c0.
constructor.
inversion H15.
inversion H15.
destruct c.
constructor;auto.
inversion H14.
constructor;auto.
inversion H8.
subst.
destruct c0.
constructor;auto.
inversion H10.
destruct s1_2.
destruct c.
constructor;auto.
inversion H14.
constructor;auto.
destruct c0.
inversion H15.
destruct c.
constructor;auto.
inversion H14.
constructor;auto.
destruct c.
constructor;auto.
inversion H14.
constructor;auto.
destruct s1.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
constructor;auto.
inversion H14.
constructor;auto.
destruct c0.
destruct s1_1.
destruct s1_2.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
inversion H14.
constructor;auto.
inversion H8.
subst.
destruct c0.
inversion H15.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
inversion H14.
constructor;auto.
inversion H8;subst.
destruct c0.
inversion H10.
destruct s1_2.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
inversion H14.
constructor;auto.
destruct c0.
inversion H15.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
inversion H14.
constructor;auto.
destruct c.
inversion H13.
destruct a1_2.
constructor;auto.
destruct c.
inversion H14.
constructor;auto.
subst.
destruct s1.
constructor;auto.
destruct c.
destruct s1_1.
destruct s1_2.
constructor;auto.
inversion H8;subst.
destruct c.
inversion H13.
constructor;auto.
inversion H8;subst.
destruct c.
inversion H10.
destruct s1_2.
constructor;auto.
destruct c.
inversion H13.
constructor;auto.
constructor;auto.
constructor;auto.
}
1:{
destruct (IHs1 n).
destruct (IHs2 n).
destruct (_GHC.Base.<_ x a0).
subst.
specialize (H9 H7).
apply is_redblack_toblack in H7.
specialize (H10 H7).
unfold balance.
constructor;auto.
remember (ins x s1) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
inversion H10;subst.
inversion H9;subst.
intuition.
admit.  (* Caso en que se tiene un arbol rojo y se quiere probar un arbol negro, contrario al lemma make_redblack_toblack.*)
constructor;auto.
destruct (_GHC.Base.<_ a0 x).
unfold balance.
constructor;auto.
remember (ins x s2) as a1.
destruct a1.
symmetry in Heqa1;apply ins_not_E in Heqa1;contradiction. (* Una contradiccion *)
intuition.
apply is_redblack_toblack in H8.
intuition.
inversion H11;subst.
inversion H9;subst.
admit. (* Caso en que se tiene un arbol rojo y se quiere probar un arbol negro, contrario al lemma make_redblack_toblack.*)
constructor;auto.
constructor;auto.
}
Admitted.

(* Teorema principal *)

Lemma insert_is_redblack {a} `{GHC.Base.Ord a}:
  forall (x: a) (s: RB a) (n: nat), is_redblack s R n->
                    exists n', is_redblack (insert x s) R n'.
Proof.
intros.
unfold insert.
apply makeblack_fiddle with n.
apply ins_is_redblack_1.
intuition.
Qed.


Require Export OrderedType SetoidList.
Require Import Morphisms.

Generalizable All Variables.

(** This file defines the interface of typeclass-based
   finite maps. *)

Definition Cmp {elt:Type} (cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true.

(** * [FMaps] : the interface of maps

   We define the class [FMap] of structures that implement finite
   maps. An instance of [FMaps] for an ordered type [key] contains a
   constructor [dict] which for any type [elt] builds the type of maps
   associating [key]s to [elt]s. It also contains all the operations
   that these structuress support : insertion, membership, etc.  The
   specifications of these operations are in a different class (see
   below).

   The operations provided are the same as in the standard [FMaps]
   library, plus two extra operations for more efficient multimaps :
   [insert] and [adjust].

   The last member of the class states that for any ordered type [key] and
   any type [elt], [dict key elt] is itself an ordered type.
   *)
Class FMap `{OrderedType key} := {
  (** the abstract type of maps *)
  dict : forall (elt : Type), Type;

  (** The specification of all map operations is done
     with respect to the sole [MapsTo] predicate. *)
  MapsTo : forall {elt : Type},
    key -> elt -> dict elt -> Prop;

  (** Map operations *)
  empty : forall (elt : Type), dict elt;
  is_empty : forall {elt : Type}, dict elt -> bool;
  mem : forall {elt : Type}, key -> dict elt -> bool;

  add : forall {elt : Type},
    key -> elt -> dict elt -> dict elt;
  find : forall {elt : Type},
    key -> dict elt -> option elt;
  remove : forall {elt : Type},
    key -> dict elt -> dict elt;

  equal : forall {elt : Type},
    (elt -> elt -> bool) -> dict elt -> dict elt -> bool;

  map : forall {elt elt' : Type},
    (elt -> elt') -> dict elt -> dict elt';
  mapi : forall {elt elt' : Type},
    (key -> elt -> elt') -> dict elt -> dict elt';
  map2 : forall {elt elt' elt'' : Type},
    (option elt -> option elt' -> option elt'') ->
    dict elt -> dict elt' ->  dict elt'';
  fold : forall {elt : Type},
    forall {A : Type}, (key -> elt -> A -> A) -> dict elt -> A -> A;

  cardinal : forall {elt : Type}, dict elt -> nat;
  elements : forall {elt : Type},
    dict elt -> list (key*elt);

  (** Extra map update operations using combining functions *)
  insert : forall {elt : Type},
    key -> elt -> (elt -> elt) -> dict elt -> dict elt;
  adjust : forall {elt : Type},
    key -> (elt -> elt) -> dict elt -> dict elt;

  (** Maps are ordered types *)
  FMap_OrderedType :> forall `{OrderedType elt}, OrderedType (dict elt)
}.
Arguments dict key {H FMap}.

(** Map notations (see below) are interpreted in scope [map_scope],
   delimited with key [map]. We bind it to the type [dict]. *)
Delimit Scope map_scope with map.
Bind Scope map_scope with dict.

(** All projections should be made opaque for tactics using [delta]-conversion,
   otherwise the underlying instances may appear during proofs, which then
   causes several problems (notations not being used, unification failures...).
   This doesnt stop computation with [compute] or [vm_compute] though, which is
   exactly what we want.
*)
Global Opaque dict MapsTo empty is_empty mem add find remove
  equal map mapi map2 fold cardinal elements insert adjust (* choose *)
    FMap_OrderedType.

(** There follow definitions of predicates about maps expressable
   in terms of [MapsTo], and which are not provided by the [FMap] class. *)
Definition In  `{FMap key} {elt : Type}
  (k:key)(m: dict key elt) : Prop := exists e:elt, MapsTo k e m.

Definition Empty `{FMap key} {elt : Type} m :=
  forall (a : key)(e:elt) , ~ MapsTo a e m.

Definition eq_key  `{FMap key} {elt} := @KeyOrderedType.eqk _ _ elt.
Definition eq_key_elt `{FMap key} {elt} := @KeyOrderedType.eqke _ _ elt.
Definition lt_key `{FMap key} {elt} :=  @KeyOrderedType.ltk _ _ elt.

Definition Equal `{FMap key} {elt : Type} (m m' : dict key elt) :=
  forall y, find y m = find y m'.
Definition Equiv `{FMap key} {elt : Type} (eq_elt:elt->elt->Prop)
  (m m' : dict key elt)  :=
  (forall k, In k m <-> In k m') /\
  (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
Definition Equivb `{FMap key} {elt : Type}
  (cmp: elt->elt->bool) := Equiv (Cmp cmp).

(** We also define a couple of notations for maps operations.
   New: notations other than 'Map[A,B]' must be explicitly
   imported from MapNotations since they can be incompatible
   with list notations.
   *)
Notation "'Map' '[' A ',' B ']'" :=
  (dict A B)(at level 0, no associativity).

Set Implicit Arguments.
Unset Strict Implicit.

(** * [FMapSpecs] : finite maps' specification

   We provide the specifications of map operations in a separate class
   [FMapSpecs] parameterized by an [FMap] instance. The specifications
   are the same as in the standard [FMaps.FMapInterface.S] module type.
   *)
Class FMapSpecs_MapsTo `(FMap key) := {
  MapsTo_1 : forall elt (m : Map[key,elt]) x y e,
    x === y -> MapsTo x e m -> MapsTo y e m
}.
Class FMapSpecs_mem `(FMap key) := {
  mem_1 : forall elt (m : Map[key,elt]) x,
    In x m -> mem x m = true;
  mem_2 : forall elt (m : Map[key,elt]) x,
    mem x m = true -> In x m
}.
Class FMapSpecs_empty `(FMap key) := {
  empty_1 : forall elt, Empty (empty elt)
}.
Class FMapSpecs_is_empty `(FMap key) := {
  is_empty_1 : forall elt (m : Map[key,elt]),
    Empty m -> is_empty m = true;
  is_empty_2 : forall elt (m : Map[key,elt]),
    is_empty m = true -> Empty m
}.
Class FMapSpecs_add `(FMap key) := {
  add_1 : forall elt (m : Map[key,elt]) x y e,
    x === y -> MapsTo y e (add x e m);
  add_2 : forall elt (m : Map[key,elt]) x y e e',
    x =/= y -> MapsTo y e m -> MapsTo y e (add x e' m);
  add_3 : forall elt (m : Map[key,elt]) x y e e',
    x =/= y -> MapsTo y e (add x e' m) -> MapsTo y e m
}.
Class FMapSpecs_remove `(FMap key) := {
  remove_1 : forall elt (m : Map[key,elt]) x y,
    x === y -> ~ In y (remove x m);
  remove_2 : forall elt (m : Map[key,elt]) x y e,
    x =/= y -> MapsTo y e m -> MapsTo y e (remove x m);
  remove_3 : forall elt (m : Map[key,elt]) x y e,
    MapsTo y e (remove x m) -> MapsTo y e m
}.
Class FMapSpecs_find `(FMap key) := {
  find_1 : forall elt (m : Map[key,elt]) x e,
    MapsTo x e m -> find x m = Some e;
  find_2 : forall elt (m : Map[key,elt]) x e,
    find x m = Some e -> MapsTo x e m
}.
Class FMapSpecs_elements `(FMap key) := {
  elements_1 : forall elt (m : Map[key,elt]) x e,
    MapsTo x e m -> InA eq_key_elt (x,e) (elements m);
  elements_2 : forall elt (m : Map[key,elt]) x e,
    InA eq_key_elt (x,e) (elements m) -> MapsTo x e m;
  elements_3 : forall elt (m : Map[key,elt]),
    sort lt_key (elements m);
  elements_3w : forall elt (m : Map[key,elt]),
    NoDupA eq_key (elements m)
}.
Class FMapSpecs_cardinal `(FMap key) := {
  cardinal_1 : forall elt (m : Map[key,elt]),
    cardinal m = length (elements m)
}.
Class FMapSpecs_fold `(FMap key) := {
  fold_1 : forall elt (m : Map[key,elt])
    (A : Type) (i : A) (f : key -> elt -> A -> A),
    fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i
}.
Class FMapSpecs_equal `(FMap key) := {
  equal_1 : forall elt
    (m m' : Map[key,elt]) (cmp : elt -> elt -> bool),
    Equivb cmp m m' -> equal cmp m m' = true;
  equal_2 : forall elt
    (m m' : Map[key,elt]) (cmp : elt -> elt -> bool),
    equal cmp m m' = true -> Equivb cmp m m'
}.
Class FMapSpecs_map `(FMap key) := {
  map_1 : forall (elt elt':Type)(m: Map[key,elt])
    (x:key)(e:elt)(f:elt->elt'),
    MapsTo x e m -> MapsTo x (f e) (map f m);
  map_2 : forall (elt elt':Type)(m: Map[key,elt])
    (x:key)(f:elt->elt'),
    In x (map f m) -> In x m
}.
Class FMapSpecs_mapi `(FMap key) := {
  mapi_1 : forall (elt elt':Type)(m: Map[key,elt])
    (x:key)(e:elt) (f:key->elt->elt'), MapsTo x e m ->
    exists y, y === x /\ MapsTo x (f y e) (mapi f m);
  mapi_2 : forall (elt elt':Type)(m: Map[key,elt])
    (x:key) (f:key->elt->elt'), In x (mapi f m) -> In x m
}.
Class FMapSpecs_map2 `(FMap key) := {
  map2_1 : forall (elt elt' elt'':Type)(m: Map[key,elt]) m'
    (x:key)(f:option elt->option elt'->option elt''),
    In x m \/ In x m' ->
    find x (map2 f m m') = f (find x m) (find x m');
  map2_2 : forall (elt elt' elt'':Type)(m: Map[key,elt]) m'
    (x:key)(f:option elt->option elt'->option elt''),
    In x (map2 f m m') -> In x m \/ In x m'
}.
Class FMapSpecs_insert `(FMap key) := {
  insert_1 : forall elt (m : Map[key,elt]) x y e d f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (insert x d f m);
  insert_2 : forall elt (m : Map[key,elt]) x y d f,
    x === y -> ~ In y m -> MapsTo y d (insert x d f m);
  insert_3 : forall elt (m : Map[key,elt]) x y e d f,
    x =/= y -> MapsTo y e m -> MapsTo y e (insert x d f m);
  insert_4 : forall elt (m : Map[key,elt]) x y e d f,
    x =/= y -> MapsTo y e (insert x d f m) -> MapsTo y e m
}.
Class FMapSpecs_adjust `(FMap key) := {
  adjust_1 : forall elt (m : Map[key,elt]) x y e f,
    x === y -> MapsTo y e m -> MapsTo y (f e) (adjust x f m);
  adjust_2 : forall elt (m : Map[key,elt]) x y e f,
    x =/= y -> MapsTo y e m -> MapsTo y e (adjust x f m);
  adjust_3 : forall elt (m : Map[key,elt]) x y e f,
    x =/= y -> MapsTo y e (adjust x f m) -> MapsTo y e m
}.

Class FMapSpecs `(F : FMap key) := {
  FFMapSpecs_MapsTo :> FMapSpecs_MapsTo F;
  FFMapSpecs_mem :> FMapSpecs_mem F;
  FFMapSpecs_empty :> FMapSpecs_empty F;
  FFMapSpecs_is_empty :> FMapSpecs_is_empty F;
  FFMapSpecs_add :> FMapSpecs_add F;
  FFMapSpecs_remove :> FMapSpecs_remove F;
  FFMapSpecs_find :> FMapSpecs_find F;
  FFMapSpecs_elements :> FMapSpecs_elements F;
  FFMapSpecs_cardinal :> FMapSpecs_cardinal F;
  FFMapSpecs_fold :> FMapSpecs_fold F;
  FFMapSpecs_equal :> FMapSpecs_equal F;
  FFMapSpecs_map :> FMapSpecs_map F;
  FFMapSpecs_mapi :> FMapSpecs_mapi F;
  FFMapSpecs_map2 :> FMapSpecs_map2 F;
  FFMapSpecs_insert :> FMapSpecs_insert F;
  FFMapSpecs_adjust :> FMapSpecs_adjust F
}.
(* About Build_FMapSpecs. *)
(* About FMapSpecs. *)

(** Extra Ordering : A SpecificOrderedType for maps where the
   equality is the point-wise equality on bindings. Data
   structures who implement this ordered type should provide
   the adequate instance of this class.
   *)
Section Equal.
  Variable container : Type.
  Variable key : Type.
  Variable elt : Type.
  Variable MapsTo : key -> elt -> container -> Prop.
  Definition Equal_kw (s s' : container) : Prop :=
    forall k v, MapsTo k v s <-> MapsTo k v s'.
  Definition Equal_kw_Equivalence : Equivalence Equal_kw.
  Proof. constructor.
    constructor; auto.
    constructor; firstorder.
    constructor; unfold Equal_kw in *.
    rewrite H, H0; auto.
    rewrite H, H0; auto.
  Qed.
End Equal.
Hint Unfold Equal_kw.
Class FMapSpecs_SpecificOrderedType `(F : FMap key) := {
  FMap_SpecificOrderedType :> forall `{OrderedType elt},
    SpecificOrderedType _ (Equal_kw (elt:=elt)
      (fun k v m => exists v', v === v' /\ MapsTo k v' m))
}.

(* Aliases for hints. See SetInterface for the reason why we do that. *)
Definition zMapsTo_1 `{H : @FMapSpecs key Hkey F} :=
  @MapsTo_1 _ _ _ (@FFMapSpecs_MapsTo _ _ _ H).
Definition zmem_2 `{H : @FMapSpecs key Hkey F} :=
  @mem_2 _ _ _ (@FFMapSpecs_mem _ _ _ H).
Definition zis_empty_2 `{H : @FMapSpecs key Hkey F} :=
  @is_empty_2 _ _ _ (@FFMapSpecs_is_empty _ _ _ H).
Definition zmap_2 `{H : @FMapSpecs key Hkey F} :=
  @map_2 _ _ _ (@FFMapSpecs_map _ _ _ H).
Definition zmapi_2 `{H : @FMapSpecs key Hkey F} :=
  @mapi_2 _ _ _ (@FFMapSpecs_mapi _ _ _ H).
Definition zadd_3 `{H : @FMapSpecs key Hkey F} :=
  @add_3 _ _ _ (@FFMapSpecs_add _ _ _ H).
Definition zremove_3 `{H : @FMapSpecs key Hkey F} :=
  @remove_3 _ _ _ (@FFMapSpecs_remove _ _ _ H).
Definition zfind_2  `{H : @FMapSpecs key Hkey F} :=
  @find_2  _ _ _ (@FFMapSpecs_find _ _ _ H).
Definition zinsert_4 `{H : @FMapSpecs key Hkey F} :=
  @insert_4 _ _ _ (@FFMapSpecs_insert _ _ _ H).
Definition zadjust_3 `{H : @FMapSpecs key Hkey F} :=
  @adjust_3 _ _ _ (@FFMapSpecs_adjust _ _ _ H).
Definition zmem_1 `{H : @FMapSpecs key Hkey F} :=
  @mem_1 _ _ _ (@FFMapSpecs_mem _ _ _ H).
Definition zis_empty_1 `{H : @FMapSpecs key Hkey F} :=
  @is_empty_1 _ _ _ (@FFMapSpecs_is_empty _ _ _ H).
Definition zadd_1 `{H : @FMapSpecs key Hkey F} :=
  @add_1 _ _ _ (@FFMapSpecs_add _ _ _ H).
Definition zadd_2 `{H : @FMapSpecs key Hkey F} :=
  @add_2 _ _ _ (@FFMapSpecs_add _ _ _ H).
Definition zremove_1 `{H : @FMapSpecs key Hkey F} :=
  @remove_1 _ _ _ (@FFMapSpecs_remove _ _ _ H).
Definition zremove_2 `{H : @FMapSpecs key Hkey F} :=
  @remove_2 _ _ _ (@FFMapSpecs_remove _ _ _ H).
Definition zfind_1 `{H : @FMapSpecs key Hkey F} :=
  @find_1 _ _ _ (@FFMapSpecs_find _ _ _ H).
Definition zelements_3 `{H : @FMapSpecs key Hkey F} :=
  @elements_3 _ _ _ (@FFMapSpecs_elements _ _ _ H).
Definition zfold_1 `{H : @FMapSpecs key Hkey F} :=
  @fold_1 _ _ _ (@FFMapSpecs_fold _ _ _ H).
Definition zmap_1 `{H : @FMapSpecs key Hkey F} :=
  @map_1 _ _ _ (@FFMapSpecs_map _ _ _ H).
Definition zmapi_1 `{H : @FMapSpecs key Hkey F} :=
  @mapi_1 _ _ _ (@FFMapSpecs_mapi _ _ _ H).
Definition zinsert_1 `{H : @FMapSpecs key Hkey F} :=
  @insert_1 _ _ _ (@FFMapSpecs_insert _ _ _ H).
Definition zinsert_2 `{H : @FMapSpecs key Hkey F} :=
  @insert_2 _ _ _ (@FFMapSpecs_insert _ _ _ H).
Definition zinsert_3 `{H : @FMapSpecs key Hkey F} :=
  @insert_3 _ _ _ (@FFMapSpecs_insert _ _ _ H).
Definition zadjust_1 `{H : @FMapSpecs key Hkey F} :=
  @adjust_1 _ _ _ (@FFMapSpecs_adjust _ _ _ H).
Definition zadjust_2 `{H : @FMapSpecs key Hkey F} :=
  @adjust_2 _ _ _ (@FFMapSpecs_adjust _ _ _ H).

Hint Immediate @zMapsTo_1 @zmem_2 @zis_empty_2
  @zmap_2 @zmapi_2 @zadd_3 @zremove_3 @zfind_2
  @zinsert_4 @zadjust_3
  : map.
Hint Resolve @zmem_1 @zis_empty_1 @zis_empty_2 @zadd_1 @zadd_2 @zremove_1
  @zremove_2 @zfind_1 @zfold_1 @zmap_1 @zmapi_1 @zmapi_2
  @zinsert_1 @zinsert_2 @zinsert_3 @zadjust_1 @zadjust_2
  : map.
Hint Unfold eq_key eq_key_elt lt_key.
(* Typeclasses Opaque dict. *)


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl 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 General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Import Program.
Require Import Coq.Init.Wf.

Require Export substitution.
Require Export computation1.

(** printing #  $\times$ #×# *)
(** printing <=>  $\Leftrightarrow$ #⇔# *)

(** Here, we define the lazy computation system of Nuprl. Since
    it is a deterministic one, we can define it as a (partial)function.
    The computation system of Nuprl is usually specified as a set
    of one step reduction rules. So, our main goal here is to define the
    [compute_step] function. Since a step of computation may result
    in an error, we first lift [NTerm] to add more information
    about the result of one step of computation :

[[

Inductive Comput_Result : Set :=
| csuccess : NTerm -> Comput_Result
| cfailure : String.string-> NTerm -> Comput_Result.

]]

  For a [NonCanonicalOp], we say that some of its arguments are principal.
  Principal arguments are
  subterms that have to be evaluated to a canonical form before checking
  whether the term itself is a redex or not.
  For example, Nuprl's evaluator evaluates the first argument of [NApply]
  until it converges (to a $\lambda$ term).
  The first argument is principal for all [NonCanonicalOp]s.
  For [NCompOp] and [NArithOp], even the second argument is canonical.

    We present the one step computation function in the next page.
    Although it refers to many other definitions, we describe it first so that
    the overall structure of the computation is clear.
    It is defined by pattern matching on the supplied [NTerm].
    If it was a variable, it results in an error.
    If it was an [oterm] with a canonical [Opid], there is nothing more
    to be done. Remember that it is a lazy computation system and a term
    whose outermost [Opid] is canonical is already in normal form.

    If the head [Opid] [ncr] is non-canonical, it does more pattern matching
    to futher expose the structure of its [BTerm]s.
    In particular, the first [BTerm] is principal and
    should have no bound variables and
    its [NTerm] should be an [oterm] (and not a variable).
    If the [Opid] of that [oterm] is canonical, some interesting action can
    be taken. So, there is another (nested) pattern match that invokes
    the appropriate function, depending on the head [Opid] ([ncr]).

    However, if it was non-canonical, the last clause in the top-level
    pattern match gets invoked and it recursively evaluates the first argument
    [arg1nt] and (if the recursive calls succeeds,) repackages
    the result at the same position with the surroundings
    unchanged.

    In the nested pattern match, all but the cases for
    [NCompOp] and [NArithOp] do not need to invoke recursive calls
    of [compute_step]. However, in the cases of [NCompOp] and [NArithOp],
    the first two(instead of one) arguments are principal and need to be
    evaluated first. Hence, the notations [co] and [ca] also take
    [compute_step] as an argument.
    % \pagebreak %

*)

(* begin hide *)

Definition shallow_sub {o} (sub : @Sub o) :=
  forall t, LIn t (range sub) -> size t = 1.

Lemma range_sub_filter_subset {o} :
  forall (sub : @Sub o) l,
    subset (range (sub_filter sub l)) (range sub).
Proof.
  induction sub; introv; simpl; auto.
  destruct a; boolvar; simpl.
  - apply subset_cons1; auto.
  - apply subset_cons2; auto.
Qed.

Lemma simple_size_lsubst_aux {o} :
  forall (t : @NTerm o) sub,
    shallow_sub sub
    -> size (lsubst_aux t sub) = size t.
Proof.
  nterm_ind t as [v|f ind|op bs ind] Case; introv ss; allsimpl; tcsp.

  - Case "vterm".
    remember (sub_find sub v) as sf; symmetry in Heqsf; destruct sf; allsimpl; auto.
    apply sub_find_some in Heqsf.
    apply in_sub_eta in Heqsf; repnd.
    apply ss in Heqsf; auto.

  - Case "oterm".
    f_equal; f_equal; allrw map_map; unfold compose.
    apply eq_maps; introv i; destruct x as [l t]; simpl.
    rw (ind t l); auto.
    intros x j.
    apply (ss x).
    apply range_sub_filter_subset in j; auto.
Qed.

Lemma size_utoken {o} :
  forall a, @size o (mk_utoken a) = 1.
Proof. sp. Qed.

Lemma simple_size_subst_aux {o} :
  forall (t : @NTerm o) v u,
    size u = 1
    -> size (subst_aux t v u) = size t.
Proof.
  introv e.
  unfold subst_aux; apply simple_size_lsubst_aux.
  unfold shallow_sub; simpl; introv k; sp; subst; auto.
Qed.

Lemma simple_size_subst {o} :
  forall (t : @NTerm o) v u,
    size u = 1
    -> size (subst t v u) = size t.
Proof.
  introv e.
  pose proof (unfold_lsubst [(v,u)] t) as h; exrepnd.
  unfold subst; rw h0.
  rw @simple_size_lsubst_aux.
  - apply alpha_eq_preserves_size in h1; auto.
  - unfold shallow_sub; simpl; introv k; sp; subst; auto.
Qed.

Definition size_bs {o} (bs : list (@BTerm o)) :=
  addl (map size_bterm bs).

(* end hide *)

(* We say that the first argument of any non-canonical term
    is a principal argument with respect to computation. It means that
    while evaluating a non-canonical term, its priciple argumens
    must be first evaluated down to a normal form. *)

Definition compute_step_can {o}
           (t : @NTerm o)
           (ncr : NonCanonicalOp)
           (arg1c : CanonicalOp)
           (arg1bts : list BTerm)
           (arg1 : NTerm)
           (btsr : list BTerm)
           (comp : Comput_Result) :=
  match ncr with
    | NApply    => compute_step_apply   arg1c t arg1bts btsr
    | NEApply   => compute_step_eapply btsr t comp arg1 ncr
    | NApseq f  => compute_step_apseq f arg1c t arg1bts btsr
    | NFix      => compute_step_fix     t arg1 btsr
    | NSpread   => compute_step_spread  arg1c t arg1bts btsr
    | NDsup     => compute_step_dsup    arg1c t arg1bts btsr
    | NDecide   => compute_step_decide  arg1c t arg1bts btsr
    | NCbv      => compute_step_cbv     t arg1 btsr
    | NSleep    => compute_step_sleep   arg1c t arg1bts btsr
    | NTUni     => compute_step_tuni    arg1c t arg1bts btsr
    | NMinus    => compute_step_minus   arg1c t arg1bts btsr
    | NFresh    => cfailure "fresh has a bound variable" t
    | NTryCatch      => compute_step_try t arg1 btsr
    | NParallel      => compute_step_parallel arg1c t arg1bts btsr
    | NCompOp    op  => co btsr t arg1bts arg1c op comp arg1 ncr
    | NArithOp   op  => ca btsr t arg1bts arg1c op comp arg1 ncr
    | NCanTest   top => compute_step_can_test top arg1c t arg1bts btsr
  end.

(*
Function compute_step {o}
         (lib : @library o)
         (t : @NTerm o)
         {measure size t} : Comput_Result :=
  match t with
    | vterm v => cfailure compute_step_error_not_closed t
    | oterm (Can _) _ => csuccess t
    | oterm (Mrk _) _ => csuccess t
    | oterm (Exc _) _ => csuccess t
    | oterm (NCan _) [] => cfailure "no args supplied" t
    | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
    | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
      let a := get_fresh_atom lib u in
      compute_step_fresh lib ncan t v vs u bs
                         (@compute_step o lib (subst u v (mk_utoken a)))
                         a
    | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts) :: btsr) =>
      compute_step_can t ncr arg1c arg1bts (oterm (Can arg1c) arg1bts) btsr
                       (match btsr with
                          | bterm _ x :: _ => @compute_step o lib x
                          | _ => cfailure bad_args t
                        end)
    (* assuming qst arg is always principal *)
    (* if the principal argument is an exception, we raise the exception *)
    | oterm (NCan ncr) ((bterm [] (oterm (Exc a) arg1bts))::btsr) =>
      compute_step_catch ncr a t arg1bts btsr
    (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
    | oterm (NCan ncr) ((bterm [] arg1nt)::btsr) =>
      on_success (@compute_step o lib arg1nt) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
    | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
  end.
*)

Definition compute_step_seq_apply {o}
           (t  : @NTerm o)
           (f  : ntseq)
           (bs : list BTerm) :=
  match bs with
    | [bterm [] arg] => csuccess (mk_eapply (mk_ntseq f) arg)
    | _ => cfailure bad_args t
  end.

Definition compute_step_seq_can_test {o}
           (t  : NTerm)
           (bs : list (@BTerm o)) :=
  match bs with
    | [bterm [] _, bterm [] a] => csuccess a
    | _ => cfailure canonical_form_test_not_well_formed t
  end.

Definition compute_step_seq {o}
           (t     : @NTerm o)
           (ncr   : NonCanonicalOp)
           (f     : ntseq)
           (bs    : list (@BTerm o))
           (cstep : Comput_Result) :=
  match ncr with
    | NApply    => compute_step_seq_apply t f bs
    | NEApply   => compute_step_eapply bs t cstep (mk_ntseq f) ncr
    | NApseq _  => cfailure bad_args t
    | NFix      => compute_step_fix t (mk_ntseq f) bs
    | NSpread   => cfailure bad_args t
    | NDsup     => cfailure bad_args t
    | NDecide   => cfailure bad_args t
    | NCbv      => compute_step_cbv t (mk_ntseq f) bs
    | NSleep    => cfailure bad_args t
    | NTUni     => cfailure bad_args t
    | NMinus    => cfailure bad_args t
    | NFresh    => cfailure bad_args t
    | NTryCatch => compute_step_try t (mk_ntseq f) bs
    | NParallel => cfailure bad_args t
    | NCompOp    _ => cfailure bad_args t
    | NArithOp   _ => cfailure bad_args t
    | NCanTest   _ => compute_step_seq_can_test t bs
  end.

(*
(**

  This generates a very complicated term, we'll do that by hand below in
  [compute_step'].

*)
Program Fixpoint compute_step_pf {o}
         (lib : @library o)
         (t : @NTerm o)
         {measure (size t)} : Comput_Result :=
  match t with
    | vterm v => cfailure compute_step_error_not_closed t
    | sterm _ => csuccess t
    | oterm (Can _) _ => csuccess t
    | oterm Exc _ => csuccess t
    | oterm (NCan _) [] => cfailure "no args supplied" t
    | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
    | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
      let a := get_fresh_atom u in
      compute_step_fresh lib ncan t v vs u bs
                         (compute_step_pf lib (subst u v (mk_utoken a)))
                         a
    | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
      compute_step_can t ncr arg1c arg1bts arg1 btsr
                       (match btsr with
                          | bterm _ x :: _ => compute_step_pf lib x
                          | _ => cfailure bad_args t
                        end)
    | oterm (NCan ncr) (bterm [] (sterm f) :: btsr) =>
      compute_step_seq t ncr f btsr
                       (match btsr with
                          | bterm _ x :: _ => compute_step_pf lib x
                          | _ => cfailure bad_args t
                        end)
    (* assuming qst arg is always principal *)
    (* if the principal argument is an exception, we raise the exception *)
    | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
      compute_step_catch ncr t arg1bts btsr
    (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
    | oterm (NCan ncr) ((bterm [] ((oterm _ _) as arg1nt))::btsr) =>
      on_success (compute_step_pf lib arg1nt) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
    | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
  end.

Obligation 1.
{ simpl; rw @simple_size_subst; auto; omega. }
Qed.

Obligation 2.
{ simpl; omega. }
Qed.

Obligation 4.
{ simpl; omega. }
Qed.

Obligation 6.
{ dands; introv; intro k; inversion k. }
Qed.

Obligation 6.
{ dands; introv; intro k; inversion k. }
Qed.

Obligation 7.
{ dands; introv; intro k; inversion k. }
Qed.
*)

(* begin hide *)

(*
Definition compute_step_pf_unfold {o}
         (lib : @library o)
         (t : @NTerm o) : Comput_Result :=
  match t with
    | vterm v => cfailure compute_step_error_not_closed t
    | sterm _ => csuccess t
    | oterm (Can _) _ => csuccess t
    | oterm Exc _ => csuccess t
    | oterm (NCan _) [] => cfailure "no args supplied" t
    | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
    | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
      let a := get_fresh_atom u in
      compute_step_fresh lib ncan t v vs u bs
                         (compute_step_pf lib (subst u v (mk_utoken a)))
                         a
    | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
      compute_step_can t ncr arg1c arg1bts arg1 btsr
                       (match btsr with
                          | bterm _ x :: _ => compute_step_pf lib x
                          | _ => cfailure bad_args t
                        end)
    (* assuming qst arg is always principal *)
    (* if the principal argument is an exception, we raise the exception *)
    | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
      compute_step_catch ncr t arg1bts btsr
    (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
    | oterm (NCan ncr) ((bterm [] arg1nt)::btsr) =>
      on_success (compute_step_pf lib arg1nt) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
    | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
  end.
*)

(*
Lemma compute_step_pf_eq_unfold {o} :
  forall lib (t : @NTerm o),
    compute_step_pf lib t = compute_step_pf_unfold lib t.
Proof.
  destruct t as [v|op bs]; try reflexivity.
  dopid op as [can|ncan|exc|abs] Case; try reflexivity.
  Case "NCan".
  destruct bs; try reflexivity.

  destruct b as [l1 t1].
  destruct l1 as [|v vs].

  - destruct t1 as [v1|op1 bs1]; try reflexivity.

    dopid op1 as [can1|ncan1|exc1|abs1] SCase; try reflexivity.

    + destruct ncan; try reflexivity.

      * destruct bs; try reflexivity.
        simpl; boolvar; try reflexivity.

        { destruct b.
          destruct l; try reflexivity.

          - destruct n as [v2|op2 bs2]; try reflexivity.

            + unfold compute_step_pf.
              unfold compute_step_pf_func.
              unfold Fix_sub.
              simpl.
              boolvar; simpl; tcsp.

            + dopid op2 as [can2|ncan2|exc2|abs2] SSCas2; try reflexivity.

              * unfold compute_step_pf.
                unfold compute_step_pf_func.
                unfold Fix_sub.
                simpl.
                boolvar; tcsp.

              * unfold on_success.
                unfold compute_step_pf at 1.

(*
Check compute_step_func.
Print compute_step_func.
                unfold compute_step_func.
                unfold Fix_sub.
simpl.
rw F_unfold.
t_fold_fix2.
Opaque Fix_F_sub2.
rw fold_fix2.
simpl.

SearchAbout Fix_F_sub.
*)
Abort.
*)

(** Let's now do that by hand using [Fix] *)
Lemma compute_step'_size1 {o} :
  forall ncan v vs (u : @NTerm o) bs a,
    size (subst u v (mk_utoken a)) < size (oterm (NCan ncan) (bterm (v::vs) u :: bs)).
Proof.
  introv.
  rw @simple_size_subst; simpl; try omega.
Qed.

Lemma compute_step'_size2 {o} :
  forall ncr arg1c (arg1bts : list (@BTerm o)) l x bs,
    size x < size (oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts) :: bterm l x :: bs)).
Proof.
  introv; simpl; omega.
Qed.

Lemma compute_step'_size3 {o} :
  forall ncr x (bs : list (@BTerm o)),
    size x < size (oterm (NCan ncr) (bterm [] x :: bs)).
Proof.
  introv; simpl; omega.
Qed.

Lemma compute_step'_size4 {o} :
  forall ncr f l x (bs : list (@BTerm o)),
    size x < size (oterm (NCan ncr) (bterm [] (sterm f) :: bterm l x :: bs)).
Proof.
  introv; simpl; omega.
Qed.

Definition compute_step {o}
           (lib : @library o)
           (t : @NTerm o) : Comput_Result :=
  @Fix NTerm
       (fun a b => lt (size a) (size b))
       (measure_wf lt_wf size)
       (fun _ => Comput_Result)
       (fun t =>
          match t with
            | vterm v => fun _ => cfailure compute_step_error_not_closed t
            | sterm _ => fun _ => csuccess t
            | oterm (Can _) _ => fun _ => csuccess t
            | oterm Exc _ => fun _ => csuccess t
            | oterm (NCan _) [] => fun _ => cfailure "no args supplied" t
            | oterm (NCan nc) (bterm [] (vterm v) :: bs) => fun _ => cfailure compute_step_error_not_closed t
            | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
              fun F =>
                let a := get_fresh_atom u in
                compute_step_fresh
                  lib ncan t v vs u bs
                  (F (subst u v (mk_utoken a))
                     (compute_step'_size1 ncan v vs u bs a))
                  a
            | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
              fun F => compute_step_can t ncr arg1c arg1bts arg1 btsr
                                        ((match btsr with
                                            | bterm l x :: bs => fun F => F x (compute_step'_size2 ncr arg1c arg1bts l x bs)
                                            | _ => fun _ => cfailure bad_args t
                                          end) F)
            | oterm (NCan ncr) (bterm [] (sterm f) :: btsr) =>
              fun F => compute_step_seq t ncr f btsr
                                        ((match btsr with
                                            | bterm l x :: bs => fun F => F x (compute_step'_size4 ncr f l x bs)
                                            | _ => fun _ => cfailure bad_args t
                                          end) F)
            (* assuming qst arg is always principal *)
            (* if the principal argument is an exception, we raise the exception *)
            | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
              fun _ => compute_step_catch ncr t arg1bts btsr
            (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
            | oterm (NCan ncr) ((bterm [] (oterm _ _ as arg1nt))::btsr) =>
              fun F => on_success (F arg1nt (compute_step'_size3 ncr arg1nt btsr)) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
            | oterm (Abs opabs) bs => fun F => compute_step_lib lib opabs bs
          end)
       t.

Definition compute_step_unfold {o}
         (lib : @library o)
         (t : @NTerm o) : Comput_Result :=
  match t with
    | vterm v => cfailure compute_step_error_not_closed t
    | sterm _ => csuccess t
    | oterm (Can _) _ => csuccess t
    | oterm Exc _ => csuccess t
    | oterm (NCan _) [] => cfailure "no args supplied" t
    | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
    | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
      let a := get_fresh_atom u in
      compute_step_fresh lib ncan t v vs u bs
                         (compute_step lib (subst u v (mk_utoken a)))
                         a
    | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
      compute_step_can t ncr arg1c arg1bts arg1 btsr
                       (match btsr with
                          | bterm _ x :: _ => compute_step lib x
                          | _ => cfailure bad_args t
                        end)
    | oterm (NCan ncr) (bterm [] (sterm f) :: btsr) =>
      compute_step_seq t ncr f btsr
                       (match btsr with
                          | bterm _ x :: _ => compute_step lib x
                          | _ => cfailure bad_args t
                        end)
    (* assuming qst arg is always principal *)
    (* if the principal argument is an exception, we raise the exception *)
    | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
      compute_step_catch ncr t arg1bts btsr
    (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
    | oterm (NCan ncr) ((bterm [] arg1nt)::btsr) =>
      on_success (compute_step lib arg1nt) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
    | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
  end.

Lemma compute_step_eq_unfold {o} :
  forall lib (t : @NTerm o),
    compute_step lib t = compute_step_unfold lib t.
Proof.
  destruct t as [v|f|op bs]; simpl; try reflexivity.
  dopid op as [can|ncan|exc|abs] Case; try reflexivity.
  destruct bs as [|b bs]; try reflexivity.
  destruct b as [l t].
  destruct l as [|v vs]; try reflexivity.
  - destruct t as [v1|f1|op1 bs1]; try reflexivity.
    { unfold compute_step at 1.
      destruct bs; try reflexivity;[].
      destruct b.
      destruct ncan; try reflexivity;[].
      destruct l; try reflexivity;[].
      destruct n; try reflexivity;[].
      destruct o0; try reflexivity;[].
      simpl.
      rw Fix_eq; simpl; try reflexivity;[].
      introv F.
      destruct x as [v'|f'|op bs']; auto;[].
      destruct op; auto;[].
      destruct bs'; auto;[].
      destruct b.
      destruct l0.
      - destruct n1; auto.
        + destruct bs'; auto.
          destruct b; auto.
          f_equal; tcsp.
        + destruct o0; try (complete (f_equal; tcsp));[].
          destruct bs'; auto.
          destruct b.
          f_equal; tcsp.
      - f_equal; tcsp.
    }
    dopid op1 as [can1|ncan1|exc1|abs2] SCase; try reflexivity.
    + unfold compute_step at 1.
      destruct bs; try reflexivity.
      destruct b.
      rw Fix_eq; simpl.
      * f_equal.
      * introv F.
        destruct x as [v'|f'|op bs']; auto.
        destruct op; auto.
        destruct bs'; auto.
        destruct b;[].
        destruct l0; auto.
        { destruct n1; auto.
          { destruct bs'; auto.
            destruct b; auto.
            f_equal; tcsp. }
          destruct o0; auto; try (complete (f_equal; tcsp)).
          destruct bs'; auto.
          destruct b; auto.
          apply f_equal; tcsp. }
        { f_equal; tcsp. }
    + unfold compute_step at 1.
      rw Fix_eq; simpl.
      * f_equal.
      * introv F.
        destruct x as [v'|f'|op bs']; auto.
        destruct op; auto.
        destruct bs'; auto.
        destruct b;[].
        destruct l; auto.
        { destruct n0; auto.
          { destruct bs'; auto.
            destruct b.
            f_equal; tcsp. }
          destruct o0; auto; try (complete (f_equal; tcsp)).
          destruct bs'; auto.
          destruct b; auto.
          apply f_equal; tcsp. }
        { f_equal; tcsp. }
  - unfold compute_step at 1.
    rw Fix_eq; simpl.
    + f_equal.
    + introv F.
      destruct x as [v'|f'|op bs']; auto.
      destruct op; auto.
      destruct bs'; auto.
      destruct b;[].
      destruct l; auto.
      { destruct n0; auto.
        { destruct bs'; auto.
          destruct b.
          f_equal; tcsp. }
        destruct o0; auto; try (complete (f_equal; tcsp)).
        destruct bs'; auto.
        destruct b; auto.
        apply f_equal; tcsp. }
      { f_equal; tcsp. }
Qed.

(*
(**

  Let's define this function another way by adding an extra parameter,
  a [nat] that's supposed to be the size of the term

 *)
Fixpoint compute_step'_aux {o}
         (lib : @library o)
         (t : @NTerm o)
         (n : nat) : Comput_Result :=
  match n with
    | 0 => cfailure "" t
    | S n =>
      match t with
        | vterm v => cfailure compute_step_error_not_closed t
        | sterm _ => csuccess t
        | oterm (Can _) _ => csuccess t
        | oterm Exc _ => csuccess t
        | oterm (NCan _) [] => cfailure "no args supplied" t
        | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
        | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
          let a := get_fresh_atom u in
          compute_step_fresh lib ncan t v vs u bs
                             (compute_step'_aux lib (subst u v (mk_utoken a)) (n - size_bs bs))
                             a
        | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
          compute_step_can t ncr arg1c arg1bts arg1 btsr
                           (match btsr with
                              | bterm _ x :: xs => compute_step'_aux lib x (n - (size arg1 + size_bs xs))
                              | _ => cfailure bad_args t
                            end)
        (* assuming qst arg is always principal *)
        (* if the principal argument is an exception, we raise the exception *)
        | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
          compute_step_catch ncr t arg1bts btsr
        (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
        | oterm (NCan ncr) ((bterm [] arg1nt)::btsr) =>
          on_success (compute_step'_aux lib arg1nt (n - size_bs btsr)) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
        | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
      end
  end.

Definition compute_step {o}
         (lib : @library o)
         (t : @NTerm o) : Comput_Result :=
  compute_step_aux lib t (size t).

Definition compute_step_unfold {o}
           (lib : @library o)
           (t : @NTerm o) : Comput_Result :=
  match t with
    | vterm v => cfailure compute_step_error_not_closed t
    | sterm _ => csuccess t
    | oterm (Can _) _ => csuccess t
    | oterm Exc _ => csuccess t
    | oterm (NCan _) [] => cfailure "no args supplied" t
    | oterm (NCan nc) (bterm [] (vterm v) :: bs) => cfailure compute_step_error_not_closed t
    | oterm (NCan ncan) (bterm (v::vs) u :: bs) =>
      let a := get_fresh_atom u in
      compute_step_fresh lib ncan t v vs u bs
                         (compute_step lib (subst u v (mk_utoken a)))
                         a
    | oterm (NCan ncr) (bterm [] (oterm (Can arg1c) arg1bts as arg1) :: btsr) =>
      compute_step_can t ncr arg1c arg1bts arg1 btsr
                       (match btsr with
                          | bterm _ x :: xs => compute_step lib x
                          | _ => cfailure bad_args t
                        end)
    (* assuming qst arg is always principal *)
    (* if the principal argument is an exception, we raise the exception *)
    | oterm (NCan ncr) ((bterm [] (oterm Exc arg1bts))::btsr) =>
      compute_step_catch ncr t arg1bts btsr
    (* if the principal argument is non-canonical or an abstraction then we compute on that term *)
    | oterm (NCan ncr) ((bterm [] arg1nt)::btsr) =>
      on_success (compute_step lib arg1nt) (fun f => oterm (NCan ncr) (bterm [] f :: btsr))
    | oterm (Abs opabs) bs => compute_step_lib lib opabs bs
  end.

Lemma compute_step_eq_unfold {o} :
  forall lib (t : @NTerm o),
    compute_step lib t = compute_step_unfold lib t.
Proof.
  introv.
  destruct t as [v|f|op bs]; try reflexivity.
  destruct op; try reflexivity.
  destruct bs; try reflexivity.
  destruct b.
  destruct l; try reflexivity.
  - destruct n0; try reflexivity.

    { simpl.
      unfold compute_step; simpl.
      fold (size_bs bs).
      assert (match size_bs bs with
                | 0 => S (size_bs bs)
                | S l => size_bs bs - l
              end
              = 1) as e.
      { remember (size_bs bs) as m; clear Heqm.
        destruct m; auto.
        rw <- minus_Sn_m; auto.
        rw minus_diag; auto. }
      rw e; clear e.
      simpl; auto.
    }

    assert (match size_bs bs with
              | 0 => S (addl (map size_bterm l) + size_bs bs)
              | S l0 => addl (map size_bterm l) + size_bs bs - l0
            end
            = S (addl (map size_bterm l))) as e.
    { remember (size_bs bs) as m; clear Heqm.
      destruct m; simpl; try omega. }
    destruct o0; try reflexivity.
    + simpl.
      unfold compute_step; simpl; auto.
      f_equal.
      destruct bs; try reflexivity.
      destruct b; simpl.
      rw plus_permute.
      rw <- NPeano.Nat.add_sub_assoc; auto.
      rw minus_diag.
      rw plus_0_r; auto.
    + simpl.
      unfold compute_step; simpl.
      unfold on_success; simpl.
      allfold (size_bs bs); rw e; simpl; auto.
    + simpl.
      unfold compute_step; simpl.
      allfold (size_bs bs); rw e; simpl; auto.
  - simpl.
    unfold compute_step; simpl.
    allfold (size_bs bs).
    rw <- NPeano.Nat.add_sub_assoc; auto.
    rw minus_diag.
    rw plus_0_r; auto.
    rw @simple_size_subst; simpl; auto.
Qed.
*)

Opaque compute_step.

Tactic Notation "csunf" ident(h) := rewrite @compute_step_eq_unfold in h.
Tactic Notation "csunf" := rewrite @compute_step_eq_unfold.

Lemma compute_step_ncan_ncan {p} :
  forall lib nc nc2 bt2 rest,
    compute_step lib
      (oterm (NCan nc) (bterm [] (oterm (@NCan p nc2) bt2) :: rest))
    = match compute_step lib (oterm (NCan nc2) bt2) with
        | csuccess f => csuccess (oterm (NCan nc) ((bterm [] f) :: rest))
        | cfailure str ts => cfailure str ts
      end.
Proof.
  introv; csunf; simpl; auto.
Qed.

Lemma compute_step_ncan_abs {p} :
  forall lib nc x bt2 rest,
    compute_step lib
      (oterm (NCan nc) (bterm [] (oterm (@Abs p x) bt2) :: rest))
    = match compute_step_lib lib x bt2 with
        | csuccess f => csuccess (oterm (NCan nc) ((bterm [] f) :: rest))
        | cfailure str ts => cfailure str ts
      end.
Proof.
  introv; csunf; simpl; auto.
Qed.

Lemma compute_step_try_ncan {p} :
  forall lib a nc (bts : list (@BTerm p)) v b,
    compute_step lib (mk_try (oterm (NCan nc) bts) a v b)
    = match compute_step lib (oterm (NCan nc) bts) with
        | csuccess f => csuccess (mk_try f a v b)
        | cfailure str ts => cfailure str ts
      end.
Proof.
  introv; csunf; simpl; auto.
Qed.

Lemma compute_step_try_abs {p} :
  forall lib a x (bts : list (@BTerm p)) v b,
    compute_step lib (mk_try (oterm (Abs x) bts) a v b)
    = match compute_step_lib lib x bts with
        | csuccess f => csuccess (mk_try f a v b)
        | cfailure str ts => cfailure str ts
      end.
Proof.
  introv; csunf; simpl; auto.
Qed.

Example comp_test1 {p} :
  forall lib,
    compute_step lib (mk_apply (mk_lam nvarx (vterm nvarx)) (mk_nat 0))
    = csuccess (@mk_nat p 0).
Proof.
  reflexivity.
Qed.

Example comp_test2 {p} :
  forall lib,
    compute_step lib
      (mk_apply
         (mk_apply (mk_lam nvarx (vterm nvarx)) (mk_lam nvarx (vterm nvarx)))
         (mk_nat 0))
    = csuccess (mk_apply (mk_lam nvarx (vterm nvarx)) (@mk_nat p 0)).
Proof.
  reflexivity.
Qed.

(*
Program Fixpoint div2 (n : nat) {measure n} :
  { x : nat | n = 2 * x \/ n = 2 * x + 1 } :=
  match n with
    | S (S p) => S (div2 p)
    | _ => O
   end.
Next Obligation.
  destruct (div2 p (div2_obligation_1 (S (S p)) div2 p eq_refl)).
  repndors; subst; allsimpl; try omega.
Qed.
Next Obligation.
  clear div2.
  induction n; try omega.
  autodimp IHn hyp; tcsp.
  introv k; subst.
  pose proof (H (S p)); sp.
  repndors; subst; tcsp.
  pose proof (H 0); sp.
Qed.

Lemma div2_prop :
  forall n, projT1 (div2 n) <= n.
Proof.
  induction n; simpl; auto.
  destruct n; simpl.
Qed.
*)

Example comp_test_ex_1 {p} :
  forall lib,
    compute_step lib
      (mk_try
         (mk_add (mk_nat 1) (mk_nat 1))
         (mk_token "")
         nvarx
         (mk_var nvarx))
    = csuccess (mk_try
                  (mk_nat 2)
                  (mk_token "")
                  nvarx
                  (@mk_var p nvarx)).
Proof.
  introv; csunf; simpl; auto.
Qed.

Example comp_test_ex3 {p} :
  forall lib,
    compute_step lib
      (mk_try
         (mk_add (mk_nat 1) (mk_exception (mk_token "") mk_zero))
         (mk_token "")
         nvarx
         (mk_var nvarx))
    = csuccess (mk_try
                  (mk_exception (mk_token "")  mk_zero)
                  (mk_token "")
                  nvarx
                  (@mk_var p nvarx)).
Proof.
  introv; csunf; simpl; auto.
Qed.

Definition maybe_compute_step {o} lib (t : @NTerm o) :=
  match compute_step lib t with
    | csuccess x => x
    | cfailure _ _ => t
  end.

Example comp_test_ex4 {p} :
  forall lib,
    on_success
      (compute_step lib
                    (mk_try
                       (mk_exception (mk_token "") mk_zero)
                       (mk_token "")
                       nvarx
                       (mk_var nvarx)))
      (fun x => maybe_compute_step lib x)
    = csuccess (@mk_zero p).
Proof.
  introv; csunf; simpl.
  unfold maybe_compute_step.
  csunf; simpl; unfold co; boolvar; simpl; boolvar; ginv; tcsp.
Qed.

Lemma compute_step_value {p} :
  forall lib t, (@isvalue p t) -> compute_step lib t = csuccess t.
Proof.
  introv h.
  inversion h; subst.
  allapply @iscan_implies; repndors; exrepnd; subst; reflexivity.
Qed.

Lemma compute_step_ovalue {p} :
  forall lib t, @isovalue p t -> compute_step lib t = csuccess t.
Proof.
  introv h.
  inversion h; subst.
  allapply @iscan_implies; repndors; exrepnd; subst; reflexivity.
Qed.

Definition compute_1step {p} lib (t u : @CTerm p) :=
  compute_step lib (get_cterm t) = csuccess (get_cterm u).

(* end hide *)


From fae_gtlc_mu.cast_calculus Require Import lang contexts consistency consistency_lemmas.
From fae_gtlc_mu.backtranslation Require Import cast_help.general_def implication_consistencies.proof expressions.
From fae_gtlc_mu.stlc_mu Require Import lang contexts.
From fae_gtlc_mu.cast_calculus Require Import types.

(* This file naturally extends the backtranslation on expressions to one on contexts *)

(* To contexts of depth 1 *)
Reserved Notation "<{ C }>" (at level 4, C at next level).
Fixpoint backtranslate_ctx_item (C : cast_calculus.contexts.ctx_item) : ctx_item :=
  match C with
  (* uninteresting cases *)
  | cast_calculus.contexts.CTX_Lam => CTX_Lam
  | cast_calculus.contexts.CTX_AppL e2 => CTX_AppL <<<e2>>>
  | cast_calculus.contexts.CTX_AppR e1 => CTX_AppR <<<e1>>>
  | cast_calculus.contexts.CTX_PairL e2 => CTX_PairL <<<e2>>>
  | cast_calculus.contexts.CTX_PairR e1 => CTX_PairR <<<e1>>>
  | cast_calculus.contexts.CTX_Fst => CTX_Fst
  | cast_calculus.contexts.CTX_Snd => CTX_Snd
  | cast_calculus.contexts.CTX_InjL => CTX_InjL
  | cast_calculus.contexts.CTX_InjR => CTX_InjR
  | cast_calculus.contexts.CTX_CaseL e1 e2 => CTX_CaseL <<<e1>>> <<<e2>>>
  | cast_calculus.contexts.CTX_CaseM e0 e2 => CTX_CaseM <<<e0>>> <<<e2>>>
  | cast_calculus.contexts.CTX_CaseR e0 e1 => CTX_CaseR <<<e0>>> <<<e1>>>
  | cast_calculus.contexts.CTX_Fold => CTX_Fold
  | cast_calculus.contexts.CTX_Unfold => CTX_Unfold
  (* interesting case of cast *)
  (* We assume τi and τf to be consistent here (see typing rule for casts). *)
  (* We assume τi and τf are meaningful; i.e. they do not contain open variables. *)
  | CTX_Cast τi τf => match (consistency_open_dec τi τf, decide (Closed τi) , decide (Closed τf)) with
                     | (inleft pC , left pi, left pf) => CTX_AppR (𝓕c (proof.cons_co τi pi τf pf pC) [])
                     (* Here, we need to convert our proof of conventional consistency (pC) into a proof of alternative consistency (proof.cons_co τi pi τf pf pC). *)
                     | _ => CTX_Lam
                     (* Just some random value; we only care about the backtranslation of well-typed contexts. *)
                     end
  end where "<{ C }>" := (backtranslate_ctx_item C).

(* To general contexts *)
Definition backtranslate_ctx (C : cast_calculus.contexts.ctx) : ctx := map backtranslate_ctx_item C.


(** VminusOpSem: Operational Semantics for Vminus *)

Require Import Arith.
Require Import List.
Import ListNotations.
Require Import String.

Require Import Vminus.Classes.
Require Import Vminus.Util.
Require Import Vminus.Env.
Require Import Vminus.Vminus.
Require Import Vminus.CFG.

(* ################################################################# *)
(** * Vminus Operational Semantics *)

(** This file provides both relational and executable definitions of
    the Vminus operational semantics and proves them equivalent.

    We can reason about the semantics of Vminus programs using only
    the relational specification, but if we want to _test_ them or
    extract an interpreter, we need to have the executable version
    too.  Once we have established that the two semantics correspond,
    it is easy to prove that the relational semantics is deterministic
    because it is equivalent to the executable semantics, which is
    given by a function.

    The development is parameterized by a control-flow graph, making
    the operational semantics independent of its representation.

    Later, as a demonstration of using these semantics, we will prove
    the correctness of an Imp to Vminus compiler and some program
    transformations as the Vminus level.
*)

Module Make (Cfg:CFG).
Import Cfg.

Module Opsem.
  (**  ------------------------------------------------------------------------- *)
  (** *** The state of a Vminus program: *)

  (** The local environment is a _partial_ map from [uid]s to
      natural numbers. *)

  Module Locals := Make_Env(Uid).
  Notation loc := (Locals.t (option nat)).
  Notation update := Locals.update.

  (** The Vminus memory is a _total_ map from addresses to
      natural numbers.  (This is a bit artificial, but is a simplification
      that aligns with the variant of Imp we use in this development.)
  *)

  Module Memory := Make_Env(Addr).
  Notation mem := (Memory.t nat).

  (** The state packages together the memory, local environment,
      current program counter.  It also remembers the environment
      in effect at the end of the of the predecessor block, for
      use in phi instructions (see below). *)

  Record state := mkst { st_mem  : mem
                       ; st_pc   : pc
                       ; st_loc  : loc
                       ; st_ppc  : pc     (* predecessor pc *)
                       ; st_ploc : loc    (* predecessor locals *)
                       }.

  (**  ------------------------------------------------------------------------- *)
  (** *** Evaluating values. *)

  (** Simply look up the uid in the local environment. (May fail!) *)

  Definition eval_val (loc:loc) (v:val) : option nat :=
    match v with
      | val_nat n => Some n
      | val_uid i => loc i
    end.

  (**  ------------------------------------------------------------------------- *)
  (** *** Evaluating binary operations. *)

  Definition b2n (b:bool) := if b then 1 else 0.
  Definition n2b (n:nat) := if n then false else true.

  Definition bop_denote (bop:bop) : nat -> nat -> nat :=
    match bop with
      | bop_add => plus
      | bop_sub => minus
      | bop_mul => mult
      | bop_eq => fun n m => b2n (beq_nat n m)
      | bop_le => fun n m => b2n (leb n m)
      | bop_and => fun n m => b2n (n2b n && n2b m)
    end.

  Definition eval_bop (loc:loc) (bop:bop) (v1 v2:val) : option nat :=
    match eval_val loc v1, eval_val loc v2 with
      | Some n1, Some n2 => Some (bop_denote bop n1 n2)
      | _, _ => None
    end.

  (**  ------------------------------------------------------------------------- *)
  (** *** Evaluating phi nodes *)
  (** To evaluate a phi instruction, we need to know from which
      predecessor block control reached this phi node, as well as
      the local environment in effect at the end of that block.

      We look up the value associated with the predecessor label
      in the phi arg list, and interpret it in the predecessor's
      local environment, which are supplied to [eval_phi].
  *)

  Definition eval_phi (ploc:loc) (pl:lbl) (pas:list phiarg)
    : option nat :=
    match assoc Lbl.eq_dec pl pas with
      | Some v => eval_val ploc v
      | None => None
    end.

  (**  ------------------------------------------------------------------------- *)
  (** *** Control transfers *)

  (** Given the current locals and the terminator, determine
      the label of the next block to jump to (if any). *)

  Definition eval_tmn (loc:loc) (t:tmn) : option lbl :=
    match t with
      | tmn_jmp l => Some l
      | tmn_cbr v l1 l2 =>
          match eval_val loc v with
            | Some n => Some (if n then l2 else l1)
            | None => None
          end
      | _ => None
    end.

  (**  ------------------------------------------------------------------------- *)
  (** *** Small-step, relational operational semantics *)

  Inductive step (g:Cfg.t) : state -> state -> Prop :=

  | step_bop : forall mem pc loc bop v1 v2 uid n ppc ploc,
      insn_at_pc g pc (uid, cmd_bop bop v1 v2) ->
      Some n = eval_bop loc bop v1 v2 ->
      step g (mkst mem pc loc ppc ploc)
             (mkst mem (incr_pc pc)
                       (update loc uid (Some n)) ppc ploc)

  (** Evaluate the right-hand side in the predecessor's
     local environment. [lbl_of ppc] is the source block of the
     control-flow edge that we jumped from to reach the current block. *)

  | step_phi : forall mem pc loc pas uid n ppc ploc,
      insn_at_pc g pc (uid, cmd_phi pas) ->
      Some n = eval_phi ploc (lbl_of ppc) pas ->
      step g (mkst mem pc loc ppc ploc)
             (mkst mem (incr_pc pc)
                       (update loc uid (Some n)) ppc ploc)

  (** Find the successor block (if any), update the pc.
      Record the current pc and locals as the "predecessor" state
      for use by any [phi] nodes in the successor block. *)

  | step_tmn : forall mem pc l' loc tmn uid ppc ploc,
      insn_at_pc g pc (uid, cmd_tmn tmn) ->
      Some l' = eval_tmn loc tmn ->
      step g (mkst mem pc loc ppc ploc)
             (mkst mem (block_entry l') loc pc loc)

  (** Loads and stores simply read from/write to the memory component of the state. **)

  | step_load : forall mem pc loc uid addr ppc ploc,
      insn_at_pc g pc (uid, cmd_load addr) ->
      step g (mkst mem pc loc ppc ploc)
             (mkst mem (incr_pc pc)
                       (update loc uid (Some (mem addr))) ppc ploc)

  | step_store : forall mem pc loc uid addr v n ppc ploc,
      insn_at_pc g pc (uid, cmd_store addr v) ->
      Some n = eval_val loc v ->
      step g (mkst mem pc loc ppc ploc)
             (mkst (Memory.update mem addr n)
                   (incr_pc pc) loc ppc ploc).

 (**  ------------------------------------------------------------------------- *)
 (** *** Definition of the initial state. *)

 (** The initial state starts with the program counter at the beginning of the
     entry block in an empty environment.  The "predecessor state" can be
     set arbitrarily -- we will prove that in any well-formed CFG, the
     entry block cannot have any phi nodes. *)

  Definition init_state (g:Cfg.t) (m: mem) : state :=
    (mkst m
          (block_entry (entry_block g))
          (Locals.empty None)
          (block_entry (entry_block g))
          (Locals.empty None)).

  (**  ------------------------------------------------------------------------- *)
  (** * Small-step, executable operational semantics *)

  (** This version of the semantics is just a straight forward interpreter,
      implemented monadically in an error monad to deal with partiality.

      It uses [fetch] where the relational specification uses [insn_at_pc], but
      is otherwise a fairly direct transliteration of the relational version.

      Note: the monad notation and definitions come from [Classes.v], a
      general purpose library that collects together some commonly used
      typeclasses and instances.

      - [mret] is the "return" of a monad
      - the notation  ['x <- e1; e2] is the "bind"
      - [trywith] lifts the [option] monad into the [err] monad
  *)
  (**  ------------------------------------------------------------------------- *)

  Fixpoint eval_step (g : Cfg.t) (s : state) : err state :=
    let 'mkst mem pc loc ppc ploc := s in
    '(uid, insn) <- trywith "no instruction fetched" (Cfg.fetch g pc);
    match insn with
    | cmd_bop bop v1 v2 =>
      'n <- trywith "cannot evalute binop command"  (eval_bop loc bop v1 v2);
      mret (mkst mem (incr_pc pc) (update loc uid (Some n)) ppc ploc)

    | cmd_phi pas =>
      'n <- trywith "cannot evaluate phi" (eval_phi ploc (lbl_of ppc) pas);
      mret (mkst mem (incr_pc pc) (update loc uid (Some n)) ppc ploc)

    | cmd_tmn tmn =>
      'l' <- trywith "cannot evaluate terminator" (eval_tmn loc tmn);
      mret (mkst mem (block_entry l') loc pc loc)

    | cmd_load addr =>
      mret (mkst mem (incr_pc pc) (update loc uid (Some (mem addr))) ppc ploc)

    | cmd_store addr v =>
      'n <- trywith "cannot evaluate address to store to" (eval_val loc v);
        mret (mkst (Memory.update mem addr n) (incr_pc pc) loc ppc ploc)
    end.

  (**  ------------------------------------------------------------------------- *)
  (** *** Helper functions for many-steps of evaluation *)

  Fixpoint eval_until_pc (g : Cfg.t) (s : state)
           (target_pc: pc)
           (fuel : nat): err state :=
    match fuel with
    | 0 => raise "eval out of fuel"
    | S n' =>
      if (eq_dec_pc (st_pc s) target_pc) then mret s
      else
      's' <- (eval_step g s);
      eval_until_pc g s' target_pc n'
    end.

  Definition eval_past_pc (g : Cfg.t) (s : state)
             (target_pc : pc) (fuel : nat) : err state :=
    's' <- eval_until_pc g s target_pc fuel;
    eval_step g s'.

  Definition eval_once_and_until_pc (g : Cfg.t) (s : state)
             (target_pc: pc)
             (fuel: nat) : err state :=
    's' <- eval_step g s;
    eval_until_pc g s' target_pc fuel.

  (**  ------------------------------------------------------------------------- *)
  (** ** Correspondence between relational and executable definitions *)

  (** Given that the relational and executable semantics share most of their "core"
      functionality, it is pretty easy to prove that the two are equivalent.
   *)

  (** This tactic helps drive the evaluator by looking for a hypothesis that is
      "stuck" on a [trywith] because it can't be simplified without further case
      analysis.  The tactic destructs the blocking expression, and is able to
      automatically discharge the goal by applying one of the [step] constructors,
      which is provided as an argument.
  *)

  Ltac eval_step_with_step next_state constructor_rule
       cfg_well_formed fetched :=
    match goal with
    | H: match trywith _ ?X with _ => _ end = inr ?next_state |-
      step ?cfg ?curr_state next_state =>
      destruct X eqn:Heval;
      inversion H;
      eapply constructor_rule;
      try rewrite Cfg.insn_at_pc_fetch;
      try apply fetched;
      try apply cfg_well_formed;
      rewrite Heval;
      reflexivity
    | H : _ = inr next_state |-
      step ?cfg ?curr_state next_state =>
      inversion H;
      eapply constructor_rule;
      try rewrite Cfg.insn_at_pc_fetch;
      try apply fetched;
      try apply cfg_well_formed;
      reflexivity
    end.

  Lemma evaluator_sound: forall g s s',
      Cfg.wf_cfg g -> eval_step g s = inr s' -> step g s s'.
  Proof.
    intros g s s' wf_g; unfold eval_step;
      destruct s as [mem curr_pc curr_loc previous_pc previous_loc];
      destruct (Cfg.fetch g curr_pc) as
          [[uid [bop v1 v2 | pas | term | addr | addr v]] | ] eqn:fetched; simpl;
      intros H;
      [eval_step_with_step s' step_bop wf_g fetched |
       eval_step_with_step s' step_phi wf_g fetched |
       eval_step_with_step s' step_tmn wf_g fetched |
       eval_step_with_step s' step_load wf_g fetched |
       eval_step_with_step s' step_store wf_g fetched | inversion H].
  Qed.

  Lemma evaluator_complete: forall g s s',
      Cfg.wf_cfg g -> step g s s' -> eval_step g s = inr s'.
  Proof.
    intros g s s' wf_g step_rel; unfold eval_step;
      inversion step_rel as
        [mem pc loc bop v1 v2 uid n ppc ploc insn_at_pc_is eval_insn_ok s_eq s'_eq |
         mem pc loc pas uid n ppc ploc insn_at_pc_is eval_insn_ok s_eq s'_eq |
         mem pc label loc term uid ppc ploc insn_at_pc_is eval_insn_ok s_eq s'_eq |
         mem pc loc uid addr ppc ploc insn_at_pc_is eval_insn_ok s'_eq |
         mem pc loc uid addr v n ppc ploc insn_at_pc_is eval_insn_ok s_eq s'_eq];
      simpl;
    rewrite Cfg.insn_at_pc_fetch in insn_at_pc_is; try solve [apply wf_g];
    try rewrite insn_at_pc_is; simpl;
    try rewrite <- eval_insn_ok; try reflexivity.
  Qed.

  Theorem evaluator_correct: forall g s s',
      Cfg.wf_cfg g -> eval_step g s = inr s' <-> step g s s'.
  Proof.
    intros g s s' wf_g; split;
      revert g s s' wf_g.
    apply evaluator_sound.
    apply evaluator_complete.
  Qed.

(** ------------------------------------------------------------------------- *)
(* ################################################################# *)
(** * Determinism of [step] *)

(** A direct consequence of the equivalence between the relational and
    functional specifications is that we can prove that [step] is
    deterministic.

    Note: one can prove that [step] is deterministic _without_ using the
    correspondence with the evaluator, but it requires significantly more work!
    It might be informative to try doing that proof. *)

Lemma step_deterministic : forall g s s1 s2, wf_cfg g ->
  step g s s1 -> step g s s2 -> s1 = s2.
Proof.
  intros g s s1 s2 Hwfcfg Hs1 Hs2.
  rewrite <- evaluator_correct in Hs1; auto.
  rewrite <- evaluator_correct in Hs2; auto.
  rewrite Hs1 in Hs2. inversion Hs2. reflexivity.
Qed.

End Opsem.
End Make.

(**  ------------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Instantiating the operational semantics to ListCFG *)

(** For interesting applications of the operational semantics, such as building
    a compiler or writing program transformations, we need to pick a concrete
    representation of the CFG module.  For this development, we use the
    [ListCFG] definition.
 *)

Require Vminus.ListCFG.
Module Import V := Make ListCFG.ListCFG.

(**  ------------------------------------------------------------------------- *)