Require Import Coq.Strings.String.

From mathcomp Require Import
  ssreflect ssrfun ssrbool ssrnat eqtype choice seq ssrnum ssrint ssralg bigop.

From deriving Require Import deriving.
From extructures Require Import ord fset fmap fperm.

From CoqUtils Require Import nominal.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Section Basic.

Local Open Scope fset_scope.

Definition int_ordMixin :=
  @PcanOrdMixin int _ _ _ pickleK.

Canonical int_ordType :=
  Eval hnf in OrdType int int_ordMixin.
Canonical int_nominalType :=
  Eval hnf in [nominalType for int by //].
Canonical int_trivialNominalType :=
  Eval hnf in [trivialNominalType for int].

Inductive binop : Type :=
| Add | Mul | Sub | Eq | Leq | And | Or.

Definition nat_of_binop b :=
  match b with
  | Add => 0
  | Mul => 1
  | Sub => 2
  | Eq  => 3
  | Leq => 4
  | And => 5
  | Or  => 6
  end.

Definition binop_of_nat n :=
  match n with
  | 0 => Add
  | 1 => Mul
  | 2 => Sub
  | 3 => Eq
  | 4 => Leq
  | 5 => And
  | _ => Or
  end.

Lemma nat_of_binopK : cancel nat_of_binop binop_of_nat.
Proof. by case. Qed.

Definition binop_eqMixin := CanEqMixin nat_of_binopK.
Canonical binop_eqType := Eval hnf in EqType binop binop_eqMixin.
Definition binop_choiceMixin := CanChoiceMixin nat_of_binopK.
Canonical binop_choiceType := Eval hnf in ChoiceType binop binop_choiceMixin.
Definition binop_countMixin := CanCountMixin nat_of_binopK.
Canonical binop_countType := Eval hnf in CountType binop binop_countMixin.
Definition binop_ordMixin := CanOrdMixin nat_of_binopK.
Canonical binop_ordType := Eval hnf in OrdType binop binop_ordMixin.

Inductive expr :=
| Var of string
| Bool of bool
| Num of int
| Binop of binop & expr & expr
| Neg of expr
| ENil
| Offset of expr
| Size of expr
| Cast of expr.

Fixpoint tree_of_expr e :=
  match e with
  | Var x => GenTree.Node 0 [:: GenTree.Leaf (pickle x)]
  | Bool b => GenTree.Node 1 [:: GenTree.Leaf (pickle b)]
  | Num n => GenTree.Node 2 [:: GenTree.Leaf (pickle n)]
  | Binop b e1 e2 => GenTree.Node 3 [:: GenTree.Leaf (pickle b);
                                        tree_of_expr e1; tree_of_expr e2]
  | Neg e => GenTree.Node 4 [:: tree_of_expr e]
  | ENil => GenTree.Node 5 [::]
  | Offset e => GenTree.Node 6 [:: tree_of_expr e]
  | Size e => GenTree.Node 7 [:: tree_of_expr e]
  | Cast e => GenTree.Node 8 [:: tree_of_expr e]
  end.

Fixpoint expr_of_tree t :=
  match t with
  | GenTree.Node 0 [:: GenTree.Leaf x & _] => Var (odflt String.EmptyString (unpickle x))
  | GenTree.Node 1 [:: GenTree.Leaf b & _] => Bool (odflt true (unpickle b))
  | GenTree.Node 2 [:: GenTree.Leaf n & _ ] => Num (odflt (0 : int) (unpickle n))
  | GenTree.Node 3 [:: GenTree.Leaf b, e1, e2 & _ ] =>
    Binop (odflt Add (unpickle b)) (expr_of_tree e1) (expr_of_tree e2)
  | GenTree.Node 4 [:: e & _] => Neg (expr_of_tree e)
  | GenTree.Node 5 _ => ENil
  | GenTree.Node 6 [:: e & _] => Offset (expr_of_tree e)
  | GenTree.Node 7 [:: e & _] => Size (expr_of_tree e)
  | GenTree.Node 8 [:: e & _] => Cast (expr_of_tree e)
  | _ => Var String.EmptyString
  end.

Lemma tree_of_exprK : cancel tree_of_expr expr_of_tree.
Proof.
rewrite /expr_of_tree [@unpickle]lock.
by elim=> /= [x|b|n|b e1 -> e2 ->|e -> | |e ->|e ->|e ->] //;
rewrite -lock pickleK.
Qed.

Definition expr_eqMixin := CanEqMixin tree_of_exprK.
Canonical expr_eqType := Eval hnf in EqType expr expr_eqMixin.
Definition expr_choiceMixin := CanChoiceMixin tree_of_exprK.
Canonical expr_choiceType := Eval hnf in ChoiceType expr expr_choiceMixin.
Definition expr_countMixin := CanCountMixin tree_of_exprK.
Canonical expr_countType := Eval hnf in CountType expr expr_countMixin.
Definition expr_ordMixin := PcanOrdMixin (@pickleK expr_countType).
Canonical expr_ordType := Eval hnf in OrdType expr expr_ordMixin.
Canonical expr_nominalType := Eval hnf in [nominalType for expr by //].
Canonical expr_trivialNominalType := Eval hnf in [trivialNominalType for expr].

Inductive com : Type :=
| Assn of string & expr
| Load of string & expr
| Store of expr & expr
| Alloc of string & expr
| Free of expr
| Skip
| Seq of com & com
| If of expr & com & com
| While of expr & com.

Fixpoint tree_of_com c :=
  match c with
  | Assn x e => GenTree.Node 0 [:: GenTree.Leaf (pickle x); GenTree.Leaf (pickle e)]
  | Load x e => GenTree.Node 1 [:: GenTree.Leaf (pickle x); GenTree.Leaf (pickle e)]
  | Store e1 e2 => GenTree.Node 2 [:: GenTree.Leaf (pickle e1); GenTree.Leaf (pickle e2)]
  | Alloc x e => GenTree.Node 3 [:: GenTree.Leaf (pickle x); GenTree.Leaf (pickle e)]
  | Free e => GenTree.Node 4 [:: GenTree.Leaf (pickle e)]
  | Skip => GenTree.Node 5 [::]
  | Seq c1 c2 => GenTree.Node 6 [:: tree_of_com c1; tree_of_com c2]
  | If e c1 c2 => GenTree.Node 7 [:: GenTree.Leaf (pickle e);
                                     tree_of_com c1;
                                     tree_of_com c2]
  | While e c => GenTree.Node 8 [:: GenTree.Leaf (pickle e); tree_of_com c]
  end.

Fixpoint com_of_tree t :=
  let var x := odflt String.EmptyString (unpickle x) in
  let exp e := odflt (Num 0) (unpickle e) in
  match t with
  | GenTree.Node 0 [:: GenTree.Leaf x; GenTree.Leaf e] => Assn (var x) (exp e)
  | GenTree.Node 1 [:: GenTree.Leaf x; GenTree.Leaf e] => Load (var x) (exp e)
  | GenTree.Node 2 [:: GenTree.Leaf e1; GenTree.Leaf e2] => Store (exp e1) (exp e2)
  | GenTree.Node 3 [:: GenTree.Leaf x; GenTree.Leaf e] => Alloc (var x) (exp e)
  | GenTree.Node 4 [:: GenTree.Leaf e] => Free (exp e)
  | GenTree.Node 5 [::] => Skip
  | GenTree.Node 6 [:: c1; c2] => Seq (com_of_tree c1) (com_of_tree c2)
  | GenTree.Node 7 [:: GenTree.Leaf e; c1; c2] => If (exp e) (com_of_tree c1) (com_of_tree c2)
  | GenTree.Node 8 [:: GenTree.Leaf e; c] => While (exp e) (com_of_tree c)
  | _ => Skip
  end.

Lemma tree_of_comK : cancel tree_of_com com_of_tree.
Proof.
elim=> [x e|x e|e1 e2|x e|e| |c1 IH1 c2 IH2|e c1 IH1 c2 IH2|e c IH] //=;
rewrite ?pickleK ?IH ?IH1 ?IH2 //; f_equal;
by apply: Some_inj; rewrite -[RHS]pickleK.
Qed.

Definition com_eqMixin := CanEqMixin tree_of_comK.
Canonical com_eqType := Eval hnf in EqType com com_eqMixin.
Definition com_choiceMixin := CanChoiceMixin tree_of_comK.
Canonical com_choiceType := Eval hnf in ChoiceType com com_choiceMixin.
Definition com_countMixin := CanCountMixin tree_of_comK.
Canonical com_countType := Eval hnf in CountType com com_countMixin.
Definition com_ordMixin := PcanOrdMixin (@pickleK com_countType).
Canonical com_ordType := Eval hnf in OrdType com com_ordMixin.
Canonical com_nominalType := Eval hnf in [nominalType for com by //].
Canonical com_trivialNominalType := Eval hnf in [trivialNominalType for com].

(** Type of pointers. [name] corresponds to an atom, in the nominal set
    sense. *)
Definition ptr := (name * int)%type.

(* FIXME: If we don't declare these, then many lemmas on partial maps do not
   work when applied to heaps.  The file structured.v contains some examples. *)

Canonical ptr_eqType := Eval hnf in [eqType of ptr].
Canonical ptr_choiceType := Eval hnf in [choiceType of ptr].
Canonical ptr_ordType := Eval hnf in [ordType of ptr].
Canonical ptr_nominalType := Eval hnf in [nominalType of ptr].

(** Pointers values contain an additional immutable size field, initialized at
    allocation time. *)
Inductive value :=
| VBool of bool
| VNum  of int
| VPtr  of ptr & int
| VNil.

Definition sum_of_value v :=
  match v with
  | VBool b => inl b
  | VNum n => inr (inl n)
  | VPtr p sz => inr (inr (inl (p, sz)))
  | VNil => inr (inr (inr tt))
  end.

Definition value_of_sum v :=
  match v with
  | inl b => VBool b
  | inr (inl n) => VNum n
  | inr (inr (inl (p, sz))) => VPtr p sz
  | inr (inr (inr tt)) => VNil
  end.

Lemma sum_of_valueK : cancel sum_of_value value_of_sum.
Proof. by case. Qed.
Lemma value_of_sumK : cancel value_of_sum sum_of_value.
Proof. by do ![case=>//]. Qed.
Definition value_eqMixin := CanEqMixin sum_of_valueK.
Canonical value_eqType := Eval hnf in EqType value value_eqMixin.
Definition value_choiceMixin := CanChoiceMixin sum_of_valueK.
Canonical value_choiceType := Eval hnf in ChoiceType value value_choiceMixin.
Definition value_ordMixin := CanOrdMixin sum_of_valueK.
Canonical value_ordType := Eval hnf in OrdType value value_ordMixin.
Definition value_nominalMixin := BijNominalMixin sum_of_valueK value_of_sumK.
Canonical value_nominalType :=
  Eval hnf in NominalType value value_nominalMixin.

Lemma renamevE pm v :
  rename pm v =
  match v with
  | VBool b => VBool b
  | VNum n => VNum n
  | VPtr p sz => VPtr (rename pm p) sz
  | VNil => VNil
  end.
Proof. by case: v. Qed.

Lemma namesvE v :
  names v =
  match v with
  | VPtr p _ => fset1 p.1
  | _ => fset0
  end.
Proof.
by case: v=> [b|n|[i n] ?|] //=; rewrite -2![RHS]fsetU0.
Qed.

Global Instance VBool_eqvar : {eqvar VBool}.
Proof. by move=> s b _ <-. Qed.

Global Instance VNum_eqvar : {eqvar VNum}.
Proof. by move=> s n _ <-. Qed.

Global Instance VPtr_eqvar : {eqvar VPtr}.
Proof. by move=> s p _ <-; finsupp. Qed.

Global Instance VNil_eqvar : {eqvar VNil}.
Proof. by []. Qed.

Notation locals := {fmap string -> value}.
Notation heap := {fmap ptr -> value}.

Implicit Types (ls : locals) (h : heap) (s : locals * heap).

Definition mkblock (b : name) vs : heap :=
  uncurrym (setm emptym b
                 (mkfmapfp (fun i => if i is Posz n then
                                       Some (nth VNil vs n)
                                     else None)
                           [seq Posz n | n <- iota 0 (size vs)])).

Lemma mkblockE p b vs :
  mkblock b vs p =
  if p.1 == b then
    if p.2 is Posz n then
      if n < size vs then Some (nth VNil vs n)
      else None
    else None
  else None.
Proof.
rewrite /mkblock uncurrymE setmE.
case: ifP=> //= _; rewrite mkfmapfpE.
case: p.2=> [n|n] /=.
  rewrite mem_map; last by move=> ?? [->].
  by rewrite mem_iota /= add0n.
by case: ifP.
Qed.

Global Instance mkblock_eqvar : {eqvar mkblock}.
Proof.
move=> s i _ <- vs _ <-.
eapply getm_nomR => - [i' [n|n]] _ <-; rewrite !mkblockE /=; last by finsupp.
(* FIXME: All this rewriting should not be needed *)
rewrite -[size (rename s vs)]size_eqvar renameT; finsupp.
Qed.

Definition eval_binop b v1 v2 :=
  match b, v1, v2 with
  | Add, VNum n1, VNum n2 => VNum (n1 + n2)
  | Add, VPtr p sz, VNum n
  | Add, VNum n, VPtr p sz => VPtr (p.1, p.2 + n) sz
  | Add, _, _ => VNil
  | Sub, VNum n1, VNum n2 => VNum (n1 - n2)
  | Sub, VPtr p sz, VNum n => VPtr (p.1, p.2 - n) sz
  | Sub, _, _ => VNil
  | Mul, VNum n1, VNum n2 => VNum (n1 * n2)
  | Mul, _, _ => VNil
  | Eq, _, _ => VBool (v1 == v2)
  | Leq, VNum n1, VNum n2 => VBool (n1 <= n2)
  | Leq, _, _ => VNil
  | And, VBool b1, VBool b2 => VBool (b1 && b2)
  | And, _, _ => VNil
  | Or, VBool b1, VBool b2 => VBool (b1 || b2)
  | Or, _, _ => VNil
  end%R.

(** Function [eval_expr] computes the value of an expression [e] given a local
store [ls]. It takes an additional argument [cast] which determines how the cast
operator is interpreted: when [cast = true], cast is just the identity; when
[cast = false], cast converts the block identifier to an integer. *)

Fixpoint eval_expr cast e ls :=
  match e with
  | Var x => odflt VNil (ls x)
  | Bool b => VBool b
  | Num n => VNum n
  | Binop b e1 e2 => eval_binop b (eval_expr cast e1 ls) (eval_expr cast e2 ls)
  | ENil => VNil
  | Neg e =>
    if eval_expr cast e ls is VBool b then VBool (~~ b)
    else VNil
  | Offset e =>
    if eval_expr cast e ls is VPtr p _ then VNum p.2 else VNil
  | Size e =>
    if eval_expr cast e ls is VPtr _ sz then VNum sz else VNil
  | Cast e =>
    let v := eval_expr cast e ls in
    if cast then v
    else if eval_expr cast e ls is VPtr p _ then VNum (val p.1) else VNil
  end.

Section Result.

Variable T : Type.

(** Type of results of computations. [Done x] indicates that a
computation successfully terminated, returning [x] as a
result. [Error] indicates that an error occurred. [NotYet] indicates
that the computation ran for too many steps and couldn't complete. *)

Inductive result :=
| Done of T
| Error
| NotYet.

Definition sum_of_result r :=
  match r with
  | Done x => inl x
  | Error => inr true
  | NotYet => inr false
  end.

Definition result_of_sum r :=
  match r with
  | inl x => Done x
  | inr true => Error
  | inr false => NotYet
  end.

Lemma sum_of_resultK : cancel sum_of_result result_of_sum.
Proof. by case. Qed.
Lemma result_of_sumK : cancel result_of_sum sum_of_result.
Proof. by do ![case=>//]. Qed.

Definition result_of_option r :=
  if r is Some x then Done x else Error.

End Result.

Arguments Error {_}.
Arguments NotYet {_}.

Definition result_eqMixin (T : eqType) :=
  CanEqMixin (@sum_of_resultK T).
Canonical result_eqType (T : eqType) :=
  Eval hnf in EqType (result T) (result_eqMixin T).
Definition result_choiceMixin (T : choiceType) :=
  CanChoiceMixin (@sum_of_resultK T).
Canonical result_choiceType (T : choiceType) :=
  Eval hnf in ChoiceType (result T) (result_choiceMixin T).
Definition result_ordMixin (T : ordType) :=
  CanOrdMixin (@sum_of_resultK T).
Canonical result_ordType (T : ordType) :=
  Eval hnf in OrdType (result T) (result_ordMixin T).
Definition result_nominalMixin (T : nominalType) :=
  BijNominalMixin (@sum_of_resultK T) (@result_of_sumK T).
Canonical result_nominalType (T : nominalType) :=
  Eval hnf in NominalType (result T) (result_nominalMixin T).

Section Nominal.

Variable T : nominalType.

Global Instance Done_eqvar : {eqvar @Done T}.
Proof. by move=> s x _ <-. Qed.

Lemma renameresE pm (r : result T) :
  rename pm r =
  match r with
  | Done x => Done (rename pm x)
  | Error => Error
  | NotYet => NotYet
  end.
Proof. by case: r. Qed.

Lemma namesresE (r : result T) :
  names r = if r is Done x then names x else fset0.
Proof. by case: r. Qed.

End Nominal.

Section Restriction.

Variable T : restrType.

Definition hide_result A (r : result T) :=
  match r with
  | Done x => Done (hide A x)
  | Error => Error
  | NotYet => NotYet
  end.

Lemma hide_result_law : Restriction.law hide_result.
Proof.
rewrite /hide_result; constructor.
- move=> s A _ <- [x| |] _ <- //=; finsupp.
- by move=> A [x| |] //; rewrite hideI.
- by move=> ?? [x| |] //; rewrite hideU.
- by move=> [x| |] //; rewrite hide0.
by move=> ? [x| |] /=; rewrite ?hideP ?fdisjoints0.
Qed.

Definition result_restrMixin := RestrMixin hide_result_law.
Canonical result_restrType := RestrType (result T) result_restrMixin.

End Restriction.

Fixpoint eval_com cast c s k : result (locals * heap) :=
  if k is S k' then
    match c with
    | Assn x e =>
      Done (setm s.1 x (eval_expr cast e s.1), s.2)

    | Load x e =>
      if eval_expr cast e s.1 is VPtr p _ then
        if s.2 p is Some v then Done (setm s.1 x v, s.2)
        else Error
      else Error

    | Store e e' =>
      if eval_expr cast e s.1 is VPtr p _ then
        if updm s.2 p (eval_expr cast e' s.1) is Some h' then Done (s.1, h')
        else Error
      else Error

    | Alloc x e =>
      if eval_expr cast e s.1 is VNum (Posz n) then
        Done (let i := fresh (names s) in
              (setm s.1 x (VPtr (i, 0 : int) n),
               unionm (mkblock i (nseq n (VNum 0))) s.2))
      else Error

    | Free e =>
      if eval_expr cast e s.1 is VPtr p _ then
        if p.2 == 0 then
          if p.1 \in domm ((@currym _ _ _ : heap -> _) s.2) then
            Done (s.1, filterm (fun (p' : ptr) _ => p'.1 != p.1) s.2)
          else Error
        else Error
      else Error

    | Skip => Done s

    | Seq c1 c2 =>
      match eval_com cast c1 s k' with
      | Done s' => eval_com cast c2 s' k'
      | Error => Error
      | NotYet => NotYet
      end

    | If e ct ce =>
      if eval_expr cast e s.1 is VBool b then
        eval_com cast (if b then ct else ce) s k'
      else Error

    | While e c =>
      if eval_expr cast e s.1 is VBool b then
        eval_com cast (if b then Seq c (While e c) else Skip) s k'
      else Error
    end
  else NotYet.

Section Monotonicity.

(** The semantics defined as a function is consistent, in the sense
that increasing the maximum number of steps it can run for can only
cause it to produce a better result. *)

Definition refine_result (T : eqType) (r1 r2 : result T) :=
  (r1 == NotYet) || (r1 == r2).

Lemma eval_com_leq cast s c k k' :
  k <= k' ->
  refine_result (eval_com cast c s k) (eval_com cast c s k').
Proof.
move=> Pk; elim: k' k Pk s c => [|k' IH] [|k] // /IH {IH} IH s.
rewrite /refine_result.
case=> [x e|x e|e e'|x e|e| |c1 c2|e ct ce|e c] /=; try by rewrite eqxx ?orbT.
- case/orP: (IH s c1) => [/eqP -> //|/eqP ->].
  case: (eval_com _ c1 _ _) => [s'| |] //=.
  by eauto.
- by case: eval_expr=> //= b; eauto.
by case: eval_expr=> //= b; eauto.
Qed.

End Monotonicity.

(** Free variables that occur in a command or expression. *)

Fixpoint vars_e e :=
  match e with
  | Var x => fset1 x
  | Bool _ => fset0
  | Num _ => fset0
  | Binop _ e1 e2 => vars_e e1 :|: vars_e e2
  | ENil => fset0
  | Neg e => vars_e e
  | Offset e => vars_e e
  | Size e => vars_e e
  | Cast e => vars_e e
  end.

Fixpoint vars_c c :=
  match c with
  | Assn x e => x |: vars_e e
  | Load x e => x |: vars_e e
  | Store e e' => vars_e e :|: vars_e e'
  | Alloc x e => x |: vars_e e
  | Free e => vars_e e
  | Skip => fset0
  | Seq c1 c2 => vars_c c1 :|: vars_c c2
  | If e ct ce => vars_e e :|: vars_c ct :|: vars_c ce
  | While e c => vars_e e :|: vars_c c
  end.

(** Potentially modified variables in a command. *)

Fixpoint mod_vars_c c :=
  match c with
  | Assn x _   => fset1 x
  | Load x _   => fset1 x
  | Store _ _  => fset0
  | Alloc x _  => fset1 x
  | Free _     => fset0
  | Skip       => fset0
  | Seq c1 c2  => mod_vars_c c1 :|: mod_vars_c c2
  | If _ c1 c2 => mod_vars_c c1 :|: mod_vars_c c2
  | While _ c  => mod_vars_c c
  end.

Lemma mod_vars_cP cast s s' c x k :
  eval_com cast c s k = Done s' ->
  x \notin mod_vars_c c ->
  s'.1 x = s.1 x.
Proof.
elim: k s s' c=> [|k IH] //= [ls h] s'.
case=> [x' e|x' e|e e'|x' e|e| |c1 c2|e c1 c2|e c] /=; rewrite 1?in_fset1.
- by move=> [<-] {s'}; rewrite setmE => /negbTE ->.
- case: eval_expr=> // p sz.
  case: getm=> //= v [<-] {s'}.
  by rewrite setmE => /negbTE ->.
- case: eval_expr=> // p sz.
  by case: updm=> //= h' [<-] {s'} _.
- case: eval_expr=> [| [n|] | |] //= [<-] {s'}.
  by rewrite setmE => /negbTE ->.
- case: eval_expr=> // p sz.
  by case: ifP=> // Hp; case: ifP=> //= Hp' [<-].
- by move=> [<-].
- case e1: eval_com => [s''| |] //= e2.
  rewrite in_fsetU=> /norP [nc1 nc2].
  by rewrite (IH _ _ _ e2) // (IH _ _ _ e1).
- rewrite in_fsetU.
  by case: eval_expr => [[] | | | ] //= he /norP [nc1 nc2];
  rewrite (IH _ _ _ he).
- by case: eval_expr=> [[] | | | ] //= he hx;
  rewrite (IH _ _ _ he) //= fsetUid.
Qed.

Lemma mod_vars_c_subset c : fsubset (mod_vars_c c) (vars_c c).
Proof.
elim: c=> [x e|x e|e e'|x e|e| |c1 IH1 c2 IH2|e c1 IH1 c2 IH2|e c IH] /=;
rewrite ?fsub0set ?fsub1set ?in_fsetU1 ?eqxx //.
- by rewrite fsetUSS.
- by rewrite -fsetUA; apply: fsubsetU; rewrite fsetUSS // orbT.
by rewrite fsubsetU // IH orbT.
Qed.

(** Basic lemmas about the semantics *)

Lemma eval_expr_unionm cast ls1 ls2 e :
  fsubset (vars_e e) (domm ls1) ->
  eval_expr cast e (unionm ls1 ls2) =
  eval_expr cast e ls1.
Proof.
elim: e => [x|b|n|b e1 IH1 e2 IH2|e IH| |e IH|e IH|e IH] //=.
- by rewrite fsub1set unionmE => /dommP [v ->].
- by rewrite fsubUset=> /andP [/IH1 {IH1} -> /IH2 {IH2} ->].
- by case: cast IH=> // IH sub; rewrite IH.
- by case: cast IH=> // IH sub; rewrite IH.
- by case: cast IH=> // IH sub; rewrite IH.
by case: cast IH=> // IH sub; rewrite IH.
Qed.

Lemma eval_binop_names b v1 v2 :
  fsubset (names (eval_binop b v1 v2)) (names (v1, v2)).
Proof.
case: b v1 v2=> [] [b1|n1|p1 sz1|] [b2|n2|p2 sz2|] //=;
  try by rewrite fsub0set.
- by rewrite fsubsetU //= !namesvE fsubsetxx orbT.
- by rewrite fsubsetU //= !namesvE fsubsetxx.
by rewrite fsubsetU //= !namesvE fsubsetxx.
Qed.

Lemma eval_expr_names cast ls e :
  fsubset (names (eval_expr cast e ls)) (names ls).
Proof.
elim: e=> [x|b|n|b e1 IH1 e2 IH2|e IH| |e IH|e IH|e IH] //=;
  try by rewrite fsub0set.
- case get_x: (ls x) => [[b|n|p|]|] //=; try by rewrite fsub0set.
  apply/fsubsetP=> i; rewrite namesvE => /fset1P -> {i}.
  apply/namesmP; eapply PMFreeNamesVal; eauto.
  by rewrite namesvE; apply/namesnP.
- by rewrite (fsubset_trans (eval_binop_names b _ _)) // fsubUset IH1 IH2.
- by case: eval_expr => // *; rewrite fsub0set.
- by case: eval_expr => // *; rewrite fsub0set.
- by case: eval_expr => // *; rewrite fsub0set.
case: cast IH=> //.
by case: (eval_expr _ _ _)=> [b|n|p|]; rewrite fsub0set.
Qed.

Lemma domm_mkblock i vs :
  domm (mkblock i vs) = fset [seq (i, Posz n) | n <- iota 0 (size vs)].
Proof.
apply/eqP; rewrite eqEfsubset; apply/andP; split; apply/fsubsetP => /= - [i' n].
  move=> /dommP [v].
  rewrite mkblockE /= in_fset.
  have [-> {i'}|] //= := altP eqP.
  case: n=> [n|] //=.
  case: ifP=> [n_vs|] //= [e].
  apply/mapP; exists n=> //.
  by rewrite mem_iota.
rewrite in_fset=> /mapP /= [n'].
rewrite mem_iota /= add0n => n_vs [-> ->].
apply/dommP; exists (nth VNil vs n').
by rewrite mkblockE /= eqxx n_vs.
Qed.

Lemma names_domm_mkblock i vs :
  names (domm (mkblock i vs)) = if nilp vs then fset0 else fset1 i.
Proof.
case: ifP=> [/nilP ->|nnil_vs].
  rewrite (_ : mkblock i [::] = emptym) ?domm0 ?namesfs0 //.
  apply/eq_fmap=> p; rewrite mkblockE /= emptymE.
  by case: ifP=> //; case: p.2.
rewrite domm_mkblock names_fset.
apply/eqP; rewrite eqEfsubset; apply/andP; split; apply/fsubsetP=> i'.
  case/namessP=> /= [[i'' n] /mapP [n' ?] [-> ?]].
  by rewrite in_fsetU /= namesT in_fset0 orbF namesnE.
move=> /fset1P ->.
apply/namessP; exists (i, Posz 0).
  apply/mapP; exists 0=> //.
  rewrite mem_iota /= add0n.
  by case: vs nnil_vs.
by rewrite in_fsetU /= namesT in_fset0 orbF namesnE in_fset1 eqxx.
Qed.

Lemma codomm_mkblock i vs : codomm (mkblock i vs) = fset vs.
Proof.
apply/eqP; rewrite eqEfsubset; apply/andP; split; apply/fsubsetP=> v.
  case/codommP=> /= - [i' n].
  rewrite mkblockE /=.
  have [_ {i'}|] //= := altP eqP.
  case: n=> [n|] //=.
  case: ifP=> [n_vs|] //= [<-].
  rewrite in_fset.
  by apply/mem_nth.
rewrite in_fset => v_vs.
apply/codommP.
exists (i, Posz (index v vs)).
by rewrite mkblockE /= eqxx index_mem v_vs nth_index.
Qed.

Lemma names_codomm_mkblock i vs :
  names (codomm (mkblock i vs)) = names vs.
Proof. by rewrite codomm_mkblock names_fset. Qed.

Lemma names_mkblock i vs :
  names (mkblock i vs) = if nilp vs then fset0 else i |: names vs.
Proof.
rewrite namesmE names_domm_mkblock names_codomm_mkblock.
case: vs=> //=.
by rewrite fset0U namessE.
Qed.

Lemma names_mkblock_fsubset i vs :
  fsubset (names (mkblock i vs)) (i |: names vs).
Proof.
by rewrite names_mkblock fun_if if_arg fsub0set fsubsetxx if_same.
Qed.

Lemma fdisjoint_names_domm h1 h2 :
  fdisjoint (names (domm h1)) (names (domm h2)) ->
  fdisjoint (domm h1) (domm h2).
Proof.
move=> /fdisjointP dis; apply/fdisjointP=> p Pp.
have /dis Pi: p.1 \in names (domm h1).
  by apply/namesfsP; exists p=> //=; apply/fsetUP; left; apply/namesnP.
apply: contra Pi=> Pi; apply/namesfsP; exists p=> //.
by apply/fsetUP; left; apply/namesnP.
Qed.

Definition stateu s1 s2 : locals * heap :=
  (unionm s1.1 s2.1, unionm s1.2 s2.2).

Lemma eval_com_vars safe s s' c k :
  fsubset (vars_c c) (domm s.1) ->
  eval_com safe c s k = Done s' ->
  domm s'.1 = domm s.1.
Proof.
elim: k s s' c => [|k IH] /= s s'; first by [].
case=> [x e|x e|e e'|x e|e| |c1 c2|e c1 c2|e c] /=;
rewrite ?fsubU1set ?fsubUset.
- case/andP=> [Px Pe] [<-]; rewrite domm_set /=.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case/andP=> [Px Pe].
  case: eval_expr => // p sz; case: getm=> [v|] //= [<-] {s'}.
  rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split.
    by rewrite fsubU1set Px fsubsetxx.
  by rewrite fsubsetUr.
- case/andP=> Pe Pe'.
  by case: eval_expr => // p sz; rewrite /updm; case: getm=> [v|] //= [<-] {s'}.
- case: eval_expr => [|[n|]| |] // /andP [Px Pe] [<-] /=.
  rewrite domm_set.
  apply/eqP; rewrite eqEfsubset; apply/andP; split; last exact: fsubsetUr.
  by rewrite fsubUset fsubsetxx andbT fsub1set.
- case: eval_expr => // p sz.
  by have [|]:= altP eqP=> // _; case: ifP=> //= in_h1 sub [<-] {s'}.
- by move=> _ [<-] {s'}.
- case/andP=> vars_c1 vars_c2.
  case ev_c1: (eval_com _ _ _) => [s''| |] //= ev_c2.
  move: vars_c2; rewrite -(IH _ _ _ vars_c1 ev_c1) => vars_c2.
  by rewrite -(IH _ _ _ vars_c2 ev_c2).
- case: eval_expr=> // - b.
  by rewrite -andbA => /and3P [_ vars_c1 vars_c2]; case: b; eapply IH; eauto.
case: eval_expr=> // - [] P; apply: IH; try by rewrite fsub0set.
by rewrite /= fsetUC -fsetUA fsetUid fsubUset.
Qed.

End Basic.

Arguments Error {_}.
Arguments NotYet {_}.

Infix "∪" := stateu (at level 40, left associativity) : state_scope.

Instance stateu_eqvar : {eqvar stateu}.
Proof. by rewrite /stateu; finsupp. Qed.


Require Import Hask.Prelude.
Require Import Control.Monad.
Require Import Control.Comonad.

Generalizable All Variables.
Set Primitive Projections.
Set Universe Polymorphism.
Unset Transparent Obligations.

(* A container takes a set of shapes {S] and a family of types {P] indexed by
   {S]. Using these two, we may construct a box for one such shape {x : S]
   along with a function (unnamed, but let's call it {f]) that, given some
   "index" {i : P x], yields the contained element corresponding to {i], of
   type {a].

   For example, the shape of a list of type {list a] may be described by its
   length {n : nat], along with an accessor of type {Fin n -> a]. Thus:

     S = nat
     P = forall n : S, Fin n
     x : S
     f : P x -> a := fun (i : P x) => nth i <some Vector x a>

   The accessor in this case need not be a closure over {Vector x a], but is
   always isomorphic to it.

   The benefit of this abstraction is that any type representable as a
   container must be strictly positive, since its elements are demonstrably
   finite (its use is contingent on the inhabitants of {S] and {P x]). *)

Record Container `(Position : Shape -> Type) (a : Type) := {
    shape  : Shape;
    getter : Position shape -> a
}.

Arguments shape  {Shape Position a} _.
Arguments getter {Shape Position a} _ _.

#[export]
Program Instance Container_Functor {S : Type} (P : S -> Type) :
  Functor (Container P) := {
  fmap := fun X Y f x =>
    {| shape  := shape x
     ; getter := fun i => f (getter x i)
     |}
}.

(* Record FocusedContainer `(Position : Shape -> Type) (a : Type) := { *)
(*   is_container :> Container Position a; *)

(*   refocus : Position (shape is_container) -> FocusedContainer Shape Position a; *)
(*   focus : Position (shape is_container) *)
(* }. *)

(* Arguments focus {Shape Position a} _. *)

(* #[export] *)
(* Program Instance Container_Comonad {S : Type} (P : S -> Type) : *)
(*   Comonad (FocusedContainer P) := { *)
(*   extract   := fun _ x => getter x (focus x); *)
(*   duplicate := fun _ x => *)
(*     {| is_container := *)
(*          {| shape  := shape x *)
(*           ; getter := *)
(*      ; positions :=  *)
(*      ; focus :=  *)
(*      |} *)
(* }. *)

Definition IdentityContainer `(x : a) : Container (const unit) a :=
  {| shape  := tt
   ; getter := const x
   |}.

#[export]
Program Instance IdentityContainer_Applicative :
  Applicative (Container (const unit)) := {
  pure := fun _ => IdentityContainer;
  ap   := fun _ _ f x => IdentityContainer (getter f tt (getter x tt))
}.

#[export]
Program Instance IdentityContainer_Monad :
  Monad (Container (const unit)) := {
  join := fun _ x => getter x tt
}.

Inductive CFree {S : Type} (P : S -> Type) (a : Type) : Type :=
  | CPure : a -> CFree P a
  | CJoin : forall s : S, (P s -> CFree P a) -> CFree P a.

Arguments CPure {S P a} _.
Arguments CJoin {S P a} _ _.

Definition CFree_bind {S : Type} {P : S -> Type} `(k : a -> CFree P b) :
  CFree P a -> CFree P b :=
  fun x0 => let fix go x := match x with
    | CPure a => k a
    | CJoin s g => CJoin s (go \o g)
    end in
  go x0.

#[export]
Program Instance CFree_Functor {S : Type} (P : S -> Type) :
  Functor (CFree P) := {
  fmap := fun _ _ k => CFree_bind (CPure \o k)
}.

#[export]
Program Instance CFree_Applicative {S : Type} (P : S -> Type) :
  Applicative (CFree P) := {
  pure := fun _ => CPure;
  ap   := fun _ _ mf mx => CFree_bind (flip fmap mx) mf
}.

#[export]
Program Instance CFree_Monad {S : Type} (P : S -> Type) : Monad (CFree P) := {
  join := fun _ => CFree_bind id
}.

Fixpoint fold `(r : x -> y) {S : Type} `(c : forall s : S, (P s -> y) -> y)
  (fr : CFree P x) : y :=
  match fr with
    | CPure x   => r x
    | CJoin s k => c s $ fun t => fold r c (k t)
  end.

Fixpoint retract {S : Type} `(fr : CFree P a) :
  (forall s : S, (P s -> a) -> a) -> a :=
  fun c => match fr with
    | CPure x   => x
    | CJoin s k => c s $ fun t => retract (k t) c
  end.

Require Import FunctionalExtensionality.

Module ContainerLaws.

Include MonadLaws.

Section ContainerLaws.

Variable S : Type.
Variable P : S -> Type.

#[export]
Program Instance Container_FunctorLaws : FunctorLaws (Container P).

(*
Ltac reduce_cfree H :=
  try elim=> //= [? ? H];
  congr (CJoin _ _);
  extensionality YY;
  exact: H.

#[export]
Program Instance CFree_FunctorLaws : FunctorLaws (CFree P).
Obligation 1. by reduce_cfree IHx. Qed.
Obligation 2. by reduce_cfree IHx. Qed.

#[export]
Program Instance CFree_ApplicativeLaws : ApplicativeLaws (CFree P).
Obligation 1. by reduce_cfree IHx. Qed.
Obligation 2.
  elim: u => /= [?|? ? IHu].
    elim: v => /= [?|? ? IHv].
      move: w.
      by reduce_cfree IHw.
    by reduce_cfree IHv.
  by reduce_cfree IHu.
Qed.

#[export]
Program Instance CFree_MonadLaws : MonadLaws (CFree P).
Obligation 1. by reduce_cfree IHx. Qed.
Obligation 2. by reduce_cfree IHx. Qed.
Obligation 4. by reduce_cfree IHx. Qed.
*)

End ContainerLaws.

End ContainerLaws.


Require Import Reals Psatz Omega.
Local Open Scope R_scope.
From mathcomp Require Import ssrfun ssreflect eqtype ssrbool seq fintype choice.
From discprob.basic Require Import base sval order monad bigop_ext nify.
From discprob.idxval Require Import pival_dist pival fin_ival fin_ival_dist.
From discprob.prob Require Import finite.
Require Import stdpp.tactics.

From discprob.idxval Require pidist_singleton.

Definition fin_coerce {X} (I: ival X) : ival.ival X.
  unshelve (econstructor).
  - exact (idx I).
  - exact (val I).
  - exact (ind I).
  - exact (val_nonneg I).
Defined.

Definition fin_coerce_ivd {X} (I: ivdist X) : ival_dist.ivdist X.
  unshelve (econstructor).
  - exact (fin_coerce I).
  - abstract (destruct I as [[] ?] => //=;
              apply prob.Series_correct';
              [ rewrite finite.SeriesC_SeriesF SeriesF_big_op; apply val_sum1 |
                eexists; apply SeriesF_is_seriesC]).
Defined.

Lemma ival_idx_coerce {X} (I: ival X): ival.idx (fin_coerce I) = idx I.
Proof.
  destruct I => //=.
Qed.

Lemma fin_coerce_bind {X A} (I: ival X) (f: X → ival A) :
  ival.eq_ival (fin_coerce (x ← I; f x))
               (x ← (fin_coerce I); fin_coerce (f x)).
Proof.
  rewrite /ival.ival_bind //=.
  rewrite /fin_coerce//=. apply ival.eq_ival_quasi_refl.
Qed.

Lemma fin_coerce_plus_unfold {X} (I1 I2: ival X) :
  fin_coerce (iplus I1 I2) =
               (ival.iplus (fin_coerce I1) (fin_coerce I2)).
Proof. rewrite //=. Qed.

Lemma fin_coerce_scale_unfold {X} p (I1: ival X):
  fin_coerce (iscale p I1) = ival.iscale p (fin_coerce I1).
Proof. rewrite /iscale/ival.iscale//=/fin_coerce//=. f_equal.
       apply classical_proof_irrelevance.
Qed.

Lemma fin_coerce_ivdplus_unfold {X} p (I1 I2: ival X) :
  ival.eq_ival (fin_coerce (iplus (iscale p I1) (iscale (1 - p) I2)))
               (ival.iplus (ival.iscale p (fin_coerce I1)) (ival.iscale (1 - p) (fin_coerce I2))).
Proof.
  rewrite /fin_coerce/ival.iplus/ival.iscale//=.
  apply ival.eq_ival_quasi_refl.
Qed.

Definition singleton {X} (I: ivdist X) : pidist X.
Proof.
  unshelve (econstructor).
  { refine {| choices := λ I', (fin_coerce I) = I' |}.
    abstract (eexists; eauto). }
  - abstract (intros I' <-; destruct I as [[] ?] => //=;
              apply prob.Series_correct';
              [ rewrite finite.SeriesC_SeriesF SeriesF_big_op; apply val_sum1 |
                eexists; apply SeriesF_is_seriesC]).
Defined.

Global Instance singleton_proper X : Proper (@eq_ivd X ==> @eq_pidist X) singleton.
Proof.
  intros Is1 Is2 Heq.
  rewrite /eq_pidist/eq_pival; split.
  - intros ? <-.
    exists (fin_coerce Is2). split.
    * rewrite /ival.eq_ival.
      destruct Is1 as [[] ?].
      destruct Is2 as [[] ?] => //=.
    * rewrite //=.
  - intros ? <-.
    exists (fin_coerce Is1).
    destruct Is1 as [[] ?] => //=.
Qed.

Transparent pidist_ret.
Lemma singleton_mret {X} (x: X) : eq_pidist (singleton (mret x)) (mret x).
Proof.
  rewrite //=/singleton/base.mret//=/pidist_ret//=/base.mret//=.
  split.
  - intros I <-. subst.
    eexists; split; last first.
    { eexists. }
    rewrite //=.
    unshelve (eexists); first by eauto.
    unshelve (eexists); first by eauto.
    repeat split => //=.
  - intros I ->. subst.
    eexists; split; last first.
    { eexists. }
    rewrite //=.
    unshelve (eexists); first by eauto.
    unshelve (eexists); first by eauto.
    repeat split => //=.
Qed.

Lemma singleton_bind {X Y} (I: ivdist X) (f: X → ivdist Y) :
  eq_pidist (singleton (mbind f I)) (x ← singleton I; singleton (f x)).
Proof.
  split.
  - intros ? <-; subst.
    edestruct (pival_mbind_in (singleton I) (λ x, singleton (f x))
                              (fin_coerce I)
                              (λ i, fin_coerce (f (ival.ind (fin_coerce I) i))))
      as (Ib&pf&Heq&Hin); eauto.
    * done.
    * intros. done.
  - intros I' Hin.
    apply pival_mbind_in_inv in Hin as (Ix&h&Hhgt0&Hin&Hin'&?).
    eexists; split; last first;
    rewrite /In/singleton//= in Hin. subst.
    etransitivity; first by (symmetry; eauto).

    eapply ival.eq_ival_nondep_option_suffice.
    unshelve (eexists).
    {
      intros (i&ih).
      destruct (Rgt_dec (val I i) 0) as [Hgt|Hngt].
      * assert (h i = fin_coerce (f (ind I i))) as Heq.
        {
          feed pose proof (Hin' i); eauto.
        }
        apply Some.
        exists i.
        rewrite Heq in ih. exact ih.
      * exact None.
    }
    unshelve (eexists).
    {
      intros (i&ifx).
      destruct (Rgt_dec (val I i) 0) as [Hgt|Hngt].
      * assert (h i = fin_coerce (f (ind I i))) as Heq.
        {
          feed pose proof (Hin' i); eauto.
        }
        apply Some.
        exists i. rewrite Heq. exact ifx.
      * exact None.
    }
    repeat split => //=.
    * intros (i&ifx) => //=.
      intros Hgt. destruct Rgt_dec => //=; last first.
      { specialize (val_nonneg (f (ind I i)) ifx). nra. }
      destruct (Hin' i r) => //=.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (ival.val_nonneg (h i) ih). nra. }
      intros Hgt1 => ->.
      f_equal. f_equal.
      destruct (Hin' i _) => //=.
    * intros (i&ifx) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { specialize (val_nonneg (f (ind I i)) ifx). intros. nra. }
      intros Hgt1 => ->.
      f_equal. f_equal.
      destruct (Hin' _ _) => //=.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (ival.val_nonneg (h i) ih). nra. }
      intros Hgt1 ?. rewrite //=.
      destruct (Hin' i Hgt1) => //=.
    * intros (i&ih) => //=.
      intros Hgt. case_eq (Rgt_dec (val I i) 0); last first.
      { intros. specialize (ival.val_nonneg (h i) ih). nra. }
      intros Hgt1 ?. rewrite //=.
      destruct (Hin' i Hgt1) => //=.
Qed.

Lemma singleton_plus {X} p Hpf (I1 I2: ivdist X) :
  eq_pidist (singleton (ivdplus p Hpf I1 I2)) (pidist_plus p Hpf (singleton I1) (singleton I2)).
Proof.
  split.
  - intros ? <-.
    eexists; split.
    { rewrite fin_coerce_ivdplus_unfold. reflexivity. }
    { rewrite //=/pidist_plus//=/pplus_aux/In//=.
      do 2 eexists; split_and!; eauto;
      rewrite /pscale_aux;  try (eexists; split; eauto; done).
    }
  - intros ? (?&?&Hin1&Hin2&->).
    inversion Hin1 as (I1'&Hin1'&Heq1').
    inversion Hin2 as (I2'&Hin2'&Heq2').
    subst. rewrite -Hin1' -Hin2'.

    eexists; split.
    { rewrite -fin_coerce_ivdplus_unfold. reflexivity. }
    split; eauto.
Qed.

Lemma fin_singleton_equiv_singleton {X} (I: ivdist X):
  eq_pidist (singleton I) (pidist_singleton.singleton (fin_coerce_ivd I)).
Proof.
  split.
  - intros I' <-.
    eexists; split.
    * reflexivity.
    * rewrite //=.
  - intros I' <-.
    eexists; split.
    * reflexivity.
    * rewrite //=.
Qed.


Require Import Common ADT.Core ADT.ComputationalADT
        ADTRefinement.Core ADTRefinement.SetoidMorphisms.

(* To derive an ADT interactively from a specification [spec], we can
   build a dependent product [ {adt : _ & refineADT spec adt} ]. The
   derivation flow has the form:

   1. Apply a refinement.
   2. Discharge any side conditions.
   3. Repeat steps 1-2 until adt is completely specialized.

   My (Ben's) current thought is that to make this as pleasant as
   possible, the refinements used in the first step should be
   implemented using tactics which present the user with 'nice' side
   conditions. (In particular, this lets us be careful about not
   having any dangling existential variables at the end of a
   derivation).

   Aside on notation:
   When naming these tactics, I wanted one which
   wasn't already used by a tactic- refine, specialize, and replace
   were taken. The thesaurus suggested 'hone'.  This kind of agrees
   with 'Bedrock' (in as much as a Whetstone is used to sharpen
   knives), so I'm carrying on the naming convention with a
   'Sharpened' notation for the dependent products. *)

Notation Sharpened spec := {adt : _ & refineADT spec adt}.

Notation FullySharpened spec := {adt : _ & prod (refineADT spec adt) (is_computationalADT adt)}.

(* A single refinement step. *)
Definition SharpenStep Sig adt :
  forall adt',
    refineADT (Sig := Sig) adt adt' ->
    Sharpened adt' ->
    Sharpened adt.
Proof.
  intros adt' refineA SpecA';
  eexists (projT1 SpecA').
  (* rewrite refineA. *)
  eapply transitivityT; [ eassumption | ].
  exact (projT2 SpecA').
Defined.

Definition SharpenFully Sig adt :
  forall adt',
    refineADT (Sig := Sig) adt adt' ->
    Sharpened adt' ->
    is_computationalADT adt' ->
    FullySharpened adt.
Proof.
  eauto.
Defined.

(* A tactic for finishing a derivation. Probably needs a better name.*)
Tactic Notation "finish" "sharpening" := eexists; solve [ reflexivity | eapply reflexivityT ].

(* Honing tactic for refining the observer method with the specified index.
     This version of the tactic takes the new implementation as an argument. *)

Tactic Notation "hone'" "method" constr(obsIdx) "using" constr(obsBody) :=
  let A :=
      match goal with
          |- Sharpened ?A => constr:(A) end in
  let ASig := match type of A with
                  ADT ?Sig => Sig
              end in
  let mutIdx_eq' := fresh in
  let Rep' := eval simpl in (Rep A) in
  let ConstructorIndex' := eval simpl in (ConstructorIndex ASig) in
  let MethodIndex' := eval simpl in (MethodIndex ASig) in
  let Methods' := eval simpl in (Methods A) in
    assert (forall idx idx' : MethodIndex', {idx = idx'} + {idx <> idx'})
      as obsIdx_eq' by (decide equality);
    eapply SharpenStep;
    [eapply (@refineADT_Build_ADT_Method
               Rep' _ _ _
               (fun idx : MethodIndex ASig => if (obsIdx_eq' idx ()) then
                             obsBody
                           else
                             Methods' idx))
    | idtac]; cbv beta in *; simpl in *.

(* Honing tactic for refining the constructor method with the specified index.
   This version of the tactic takes the new implementation as an argument. *)
Tactic Notation "hone'" "constructor" constr(mutIdx) "using" constr(mutBody) :=
  let A :=
      match goal with
          |- Sharpened ?A => constr:(A) end in
  let ASig := match type of A with
                  ADT ?Sig => Sig
              end in
  let mutIdx_eq' := fresh in
  let Rep' := eval simpl in (Rep A) in
  let ConstructorIndex' := eval simpl in (ConstructorIndex ASig) in
  let MethodIndex' := eval simpl in (MethodIndex ASig) in
  let Constructors' := eval simpl in (Constructors A) in
    assert (forall idx idx' : ConstructorIndex', {idx = idx'} + {idx <> idx'})
      as mutIdx_eq' by (decide equality);
    eapply SharpenStep;
      [eapply (@refineADT_Build_ADT_Constructors Rep'
                 _
                 _
                 _
                 (fun idx : ConstructorIndex ASig => if (mutIdx_eq' idx mutIdx) then
                               mutBody
                             else
                               Constructors' idx))
      | idtac]; cbv beta in *; simpl in *.


Require Export DEX_typing_rules.
Require Export DEX_BigStepWithTypes.
Import  DEX_BigStep.DEX_BigStep DEX_BigStepWithTypes.DEX_BigStepWithTypes DEX_Dom DEX_Prog.

Section p.
  Variable p : DEX_ExtendedProgram.

Hint Resolve L.join_least L.join_right L.join_left L.leql_trans L.leql_refl : lat.

Lemma join_sym : forall a b, L.join a b = L.join b a. intros. destruct a, b; auto. Qed.

Definition border (b1 b2:FFun.t DEX_Location) : Prop :=
  forall loc n, FFun.lookup b1 n = Some loc -> FFun.lookup b2 n = Some loc.

Lemma border_refl : forall b, border b b.
Proof.
  repeat intro; auto.
Qed.

Lemma border_trans : forall b1 b2 b3, border b1 b2 -> border b2 b3 -> border b1 b3.
Proof.
  unfold border; intros.
  firstorder.
Qed.

Lemma border_extends : forall b loc, border b (FFun.extends b loc).
Proof.
  repeat intro.
  apply FFun.extends_old; auto.
Qed.

Hint Resolve border_refl border_extends.

Lemma well_types_imply_exec_return : forall se region m sgn i s1 rt1 b1 rv2 ,
     DEX_BigStepAnnot.DEX_exec_return p m s1 rv2 ->
     instructionAt m (fst s1) = Some i ->
     DEX_typing_rules.texec p sgn region se (fst s1) i rt1 None ->
     exists b2, exec_return p se m sgn i s1 rt1 b1 rv2 b2 /\ border b1 b2.
Proof.
  intros se region m sgn i s1 rt1 b1 rv2 He.
  inversion_clear He; intros.
  exists b1. split.
  constructor.
  inversion_mine H; simpl in H0; DiscrimateEq; inversion_mine H1.
  constructor; auto.
  constructor 2 with t k_r kv; auto.
  simpl in H11.
  rewrite join_sym in H13; auto.
  auto.
Qed.

Lemma well_types_imply_NormalStep : forall kobs se region m sgn i s1 rt1 b1 s2 rt2,
     DEX_BigStep.DEX_NormalStep p m s1 s2  ->
     instructionAt m (fst s1) = Some i ->
     texec p sgn region se (fst s1) i rt1 (Some rt2) ->
     exists b2, NormalStep kobs p se region m sgn i s1 rt1 b1 s2 rt2 b2
        /\ border b1 b2.
Proof.
  intros kobs se region m sgn i s1 rt1 b1 s2 t2 H.
  inversion_clear H; simpl; intros Hi Ht;
  DiscrimateEq;
  unfold NormalStep;
  inversion_mine Ht;
    try (try (exists b1; split; auto);
    try (econstructor;eauto); try (rewrite join_sym; auto); fail).
  (* Ibinop *)
  exists b1; split; auto.
    assert (forall a b c, L.join (L.join a b) (c) = L.join a (L.join b c)).
      intros; destruct a,b,c; auto.
    rewrite H; econstructor; eauto.
  (* New *)
  exists (newb kobs (se pc) b1 loc). split; auto.
  econstructor; eauto.
  unfold newb. destruct (L.leql_dec (se pc) kobs); auto.
  (* Iput *)
  exists b1; split; auto.
  econstructor; eauto.
  assert (forall a b c, L.join (L.join a b) (c) = L.join a (L.join b c)).
      intros; destruct a,b,c; auto.
  rewrite join_sym; rewrite H.
  assert (L.join (DEX_ft p f) ko = L.join ko (DEX_ft p f)); rewrite join_sym; auto.
  rewrite join_sym.
  rewrite H8; auto.
Qed.

Lemma well_types_imply_exec_intra : forall kobs se region m sgn i s1 rt1 b1 s2 rt2,
     DEX_BigStepAnnot.DEX_exec_intra p m s1 s2  ->
     instructionAt m (fst s1) = Some i ->
     texec p sgn region se (fst s1) i rt1 (Some rt2) ->
     exists b2, exec_intra kobs p se region m sgn i s1 rt1 b1 s2 rt2 b2 /\ border b1 b2.
Proof.
  intros kobs se region m sgn i s1 rt1 b1 s2 rt2 He.
  inversion_clear He; intros.
  elim well_types_imply_NormalStep with (1:=H) (3:=H1) (kobs:=kobs) (b1:=b1); eauto.
  intros b [T1 T2].
  exists b; split; auto.
  constructor; auto.
Qed.

End p.


Require Export Lib.Monads.
Require Import Coq.Strings.String.

Require Import FunctionalExtensionality.
Require Import Common.Either.
Require Import TargetSFI.ExecutionError.

Module StateMonad.
  Section Def.
    Variable st: Type.

    Definition t (res: Type) := st -> (@Either res ExecutionError) * st.

    Definition ret (A:Type) (x:A) : (t A)
      := fun (s:st) => (Right x,s).

    Definition bind A B (s: t A) (f: A -> t B) :=
      fun x => match s x with
            | (Right x',s') => (f x') s'
            | (Left msg err, s') => (Left msg err, s')
            end.

    Definition get : t st :=
      fun s => (Right s, s).

    Definition put (s: st) : t unit :=
      fun _ =>  (Right tt, s).

    Definition modify (f: st -> st) : t unit :=
      fun s => (Right tt, f s).

    Definition lift {A} (x: option A) (msg : string) (err : ExecutionError): t A :=
      fun s => match x with
            | None  => (Left msg err, s)
            | Some v => (Right v, s)
            end.

    Definition fail {A} (msg : string) (err : ExecutionError) : t A :=
      fun s => (Left msg err, s).

    Definition run {A} (s: st) (m: t A) : (@Either A ExecutionError) :=
      match m s with
      | (Left msg err,_) => Left msg err
      | (Right v,s') => Right v
      end.

  End Def.
End StateMonad.

Instance state_monad {st} : Monad (StateMonad.t st) := {
  ret := StateMonad.ret st;
  bind := StateMonad.bind st
}.

Section StateMonadLaws.
  Variable st: Type.

  Lemma state_monad_left_id:
    forall res1 res2 (e: res1) (f: res1 -> StateMonad.t st res2),
      bind (ret e) f = f e.
  Proof.
    auto.
  Qed.

  Lemma state_monad_right_id:
    forall res (m: StateMonad.t st res),
      bind m ret = m.
  Proof.
    intros.
    unfold ret, bind. simpl.
    unfold StateMonad.ret, StateMonad.bind.
    extensionality x.
    destruct (m x); auto.
    destruct e. auto. reflexivity.
  Qed.

  Lemma state_monad_associativity:
    forall res1 res2 res3 (m: StateMonad.t st res1)
      (f: res1 -> StateMonad.t st res2) (g: res2 -> StateMonad.t st res3),
      bind (bind m f) g = bind m (fun x => bind (f x) g).
  Proof.
    intros.
    unfold ret, bind. simpl.
    unfold StateMonad.ret, StateMonad.bind.
    extensionality x.
    destruct m; auto.
    destruct e. destruct (f r s); auto. reflexivity.
  Qed.
End StateMonadLaws.

Instance state_monad_laws {st} : MonadLaws (StateMonad.t st) := {
  m_left_identity := state_monad_left_id st;
  m_right_identity := state_monad_right_id st;
  m_associativity := state_monad_associativity st
}.


Add Rec LoadPath "." as DEP_AI.

Require Import language.
Require Import values.
Require Import List.

Definition atdeps : Set := list (label).
Definition adeps : Set := list (label).

Inductive aval : Set :=
| AV (d:adeps) (v:aval0) : aval
with aval0 : Set :=
| AV_Bottom             : aval0
| AV_Top                : aval0
| AV_Constr0 (n:constr) : aval0
| AV_Constr1 (n:constr) (au:aval) : aval0
| AV_Couple  (au1 au2:aval) : aval0
| AV_Closure (x:identifier) (e:expr) (ac:aenv) : aval0
| AV_Rec_Closure (f x:identifier) (e:expr) (ac:aenv) : aval0
with aenv : Set :=
| AEnv_empty : aenv
| AEnv_cons (x:identifier) (au:aval) (ac':aenv) : aenv.

Inductive atval : Set :=
| ATV (atd:atdeps) (au:aval) : atval
with atenv : Set :=
| ATEnv_empty : atenv
| ATEnv_cons (x:identifier) (atu:atval) (ac':atenv) : atenv.

(* Result of pattern matching *)

Inductive filtered_atval_result : Set :=
| Filtered_atval_result_Match (atc_p:atenv)
| Filtered_atval_result_Match_var
| Filtered_atval_result_Match_unknown (atc_p:atenv)
| Filtered_atval_result_Error.

(* Searching identifier in atenv *)

Inductive ident_in_atenv : Set :=
| Ident_not_in_atenv : ident_in_atenv
| Ident_in_atenv : atval -> ident_in_atenv.

Lemma ident_in_atenv_inv :
 forall i : ident_in_atenv,
 {atu : atval | i = Ident_in_atenv atu} + {i = Ident_not_in_atenv}.
Proof.
  simple induction i.
  right; auto.
  intro atu; left; exists atu; auto.
Qed.

Fixpoint assoc_ident_in_atenv (x:identifier) (atc:atenv) {struct atc} : ident_in_atenv :=
  match atc with
    | ATEnv_empty => Ident_not_in_atenv
    | ATEnv_cons x' atu atc' =>
      if (beq_identifier x x')
      then (Ident_in_atenv atu)
      else (assoc_ident_in_atenv x atc')
  end.

(* Concatenation of dependencies *)

Fixpoint conc_adeps (d d':adeps) :=
  match d with
    | nil => d'
    | cons x tl => cons x (conc_adeps tl d')
  end.

Fixpoint conc_atdeps (td td':atdeps) :=
  match td with
    | nil => td'
    | cons x tl => cons x (conc_atdeps tl td')
  end.

(* Concatenation of environments *)

Fixpoint conc_atenv c c' :=
  match c with
    | ATEnv_empty => c'
    | ATEnv_cons x v c'' => ATEnv_cons x v (conc_atenv c'' c')
  end.

(* conversions between atval and aval *)

Definition aval_to_atval (au:aval) := ATV nil au.

Fixpoint aenv_to_atenv (ac:aenv) :=
  match ac with
    | AEnv_empty => ATEnv_empty
    | AEnv_cons x au ac' => ATEnv_cons x (aval_to_atval au) (aenv_to_atenv ac')
  end.

Definition atval_to_aval (atu:atval) :=
  match atu with
    | ATV atd au => au
  end.

Fixpoint atenv_to_aenv (atc:atenv) :=
  match atc with
    | ATEnv_empty => AEnv_empty
    | ATEnv_cons x atu atc' => AEnv_cons x (atval_to_aval atu) (atenv_to_aenv atc')
  end.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
Require Import Permutation.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq.
Require Import seq_ext.

Declare Scope uniq_scope.

Reserved Notation "'uniq(' a , .. , b ')'" (at level 10,
  no associativity, format "'[v' 'uniq(' a , .. , b ')' ']'").

Section uniq_ext.

Variable A : eqType.

Lemma uniq_NoDup : forall (l : seq A), uniq l -> List.NoDup l.
Proof.
elim => [| hd tl IH /=]; first by constructor.
case/andP; move/negP => H1 H2.
constructor; last by apply IH.
contradict H1.
by apply/inP.
Qed.

Lemma NoDup_uniq : forall (l : seq A), List.NoDup l -> uniq l.
Proof.
elim => // hd tl IH /=; inversion_clear 1; apply/andP; split; last by apply IH.
apply/negP; contradict H0; by apply/inP.
Qed.

Lemma uniq_head (hd : A) tl tl' : ~ List.In hd tl' ->
  (uniq tl -> uniq tl') -> uniq (hd :: tl) -> uniq (hd :: tl').
Proof.
move=> Hhd Htl /=; case/andP=> H1 H2; apply/andP; split; last by auto.
apply/negP; contradict Hhd; by apply/inP.
Qed.

Lemma uniq_head' (hd : A) tl (lst' : seq A) :
  (uniq tl -> uniq lst') -> uniq (hd :: tl) -> uniq lst'.
Proof. move=> Htl /=. case/andP=> H1 H2. by apply Htl. Qed.

Lemma uniq_rotate : forall t (h : A), uniq (h :: t) -> uniq (t ++ h :: nil).
Proof.
elim=> // hd' tl IH hd /=; case/andP; rewrite negb_or; case/andP => H1 H4.
case/andP => H2 H3; apply/andP; split.
- apply/negP; move/inP.
  case/(@List.in_app_or A) => [H | /= H].
  + by move/inP : H2.
  + case : H => // H; by rewrite H eqxx in H1.
- apply IH; by apply/andP.
Qed.

Lemma uniq_rotate' (hd : A) tl (lst' : seq A) :
  (uniq (tl ++ hd :: nil) -> uniq lst') -> uniq (hd :: tl) -> uniq lst'.
Proof. move=> Htl Hlst; apply Htl; by apply uniq_rotate. Qed.

Lemma uniq_head1 (hd : A) tl : uniq (hd :: tl) -> uniq tl.
Proof. move=> /=. by case/andP. Qed.

Lemma list_is_not_set_hd_hd (hd : A) tl : uniq (hd :: hd :: tl) -> False.
Proof. by rewrite /= !inE !eqxx. Qed.

Lemma Permutation_uniq (l1 l2 : seq A) : Permutation l1 l2 -> uniq l1 -> uniq l2.
Proof.
elim => //; clear l1 l2.
- move=> x l l' H IH /=; case/andP; move/negP => H1 H2.
  apply/andP; split; last by apply IH.
  apply/negP.
  contradict H1.
  move/inP : H1 => H1.
  apply/inP.
  apply Permutation_sym in H.
  by eapply Permutation_in; eauto.
- move=> x y l; rewrite [(x :: l)]lock [(y ::l)]lock /= -!lock.
  case/andP; move/negP => H1 H2; rewrite /= in H1 H2.
  apply/andP; split=> [| /=].
  + apply/negP; contradict H1; rewrite /= in H1; case/orP : H1.
    * move/eqP => ->; by rewrite in_cons eqxx.
    * case/andP : H2; move/negP => ? _; tauto.
  + apply/andP; split.
    * move/negP : H1; apply: contra => yl; by rewrite in_cons yl orbC.
    * by case/andP : H2.
- move=> l l' l'' Hll' IH1 Hl'l'' IH2 Hl; by apply IH2, IH1.
Qed.

Lemma uniq_rotate'' : forall hd (tl : A), uniq (hd ++ tl :: nil) -> uniq (tl :: hd).
Proof.
elim => // hd tl IH tl'.
rewrite -cat1s -catA.
apply Permutation_uniq, Permutation_sym.
rewrite -cat1s catA.
by apply permut_rotate.
Qed.

Lemma uniq_cat_inv : forall (l k : seq A), uniq (l ++ k) -> uniq l /\ uniq k.
Proof.
elim=> // h t IH k /=; case/andP; move/negP.
move/negP/inP => H1 H2.
split; last by apply IH in H2; tauto.
apply/andP; split; last by apply IH in H2; tauto.
apply/negP.
move/inP.
contradict H1.
apply List.in_or_app; by auto.
Qed.

Lemma disj_uniq : forall (l k : seq A),
  uniq l -> uniq k -> disj l k -> uniq (l ++ k).
Proof.
elim=> // hd tl IHl k Hhdtl Hk Hinter /=; apply/andP; split; first last.
  apply IHl => //.
  by eapply uniq_head1; eauto.
  by eapply disj_cons_inv; eauto.
rewrite /= in Hhdtl; case/andP : Hhdtl => Hhdtl1 Hhdtl2.
rewrite mem_cat negb_or Hhdtl1 /=.
apply: contra Hhdtl1 => /inP Hhdtl1.
move/(@disj_not_In _ _ hd) : Hinter => /(_ Hhdtl1) /=.
tauto.
Qed.

Lemma uniq_disj : forall (l k : seq A), uniq (l ++ k) -> disj l k.
Proof.
elim=> [| hd tl IH k /= ]; first by move=> k _; apply disj_nil_L.
case/andP. move/negP. move/negP/inP => H1 H2.
apply disj_sym, disj_cons_R.
- exact/disj_sym/IH.
- contradict H1; apply List.in_or_app; by auto.
Qed.

Lemma substitution_uniq : forall n s, size s = n ->
  Permutation s (iota O n) ->
  forall (def : A) l k, size l = n -> size k = n ->
    (forall i, (i < n)%nat -> nth def k i = nth def l (nth 0 s i)) ->
    uniq l -> uniq k.
Proof.
move=> n s Hlens Hperm def l k Hlenl Hlenk H.
apply Permutation_uniq, Permutation_sym.
by eapply substitution_Permutation; eauto.
Qed.

End uniq_ext.

Arguments uniq_rotate'' [A].
Arguments uniq_cat_inv [A].

Notation "'uniq(' a , .. , b ')'" := (uniq (cons a .. (cons b nil) ..)) : uniq_scope.

Ltac remove_useless :=
  match goal with
    | |- is_true (uniq ?l) -> is_true (uniq ?k)=>
      let inj := compute_list_injection l k in
      let perm := eval compute in
          (remove_idx l (fun x => negb (x \in inj(*inb EqNat.beq_nat x inj*))) O) in
      let Htmp := fresh in
      move=> Htmp ;
      move: (uniq_remove_idx Htmp (fun x => negb (x \in inj (*inb EqNat.beq_nat x inj*))) O);
      rewrite [remove_idx _ _ _]/= {Htmp}
  end.

Goal forall {T : eqType} (a b c : T), uniq [:: b; c; a] -> uniq [:: a; b].
move=> T a b c.
remove_useless.
Abort.

Ltac loop n :=
  match n with
    | O => idtac
    | S ?m => (case => //) ; loop m
  end.

Ltac loop' n :=
  match n with
    | O => idtac
    | S ?m => (move/Lt.lt_S_n) ; loop' m
  end.

Ltac uniq_permut default_value :=
  match goal with
    | |- is_true (uniq ?l) -> is_true (uniq ?k)=>
      let bij := compute_list_injection l k in
      let len := eval compute in (size l) in
      let Hn := fresh in
      let Hnot_lt_O := fresh in
        apply substitution_uniq with
          (n:=len) (s:=bij) (def:=default_value);
          [done | apply (@function_permut_Permutation _ Peano_dec.eq_nat_dec len) => // | done | done |
            (
              loop len ; move=> Hn ; loop' len ;
              move: (Lt.lt_n_O Hn) => Hnot_lt_O; move/Hnot_lt_O => //
            )
          ]
  end.

Ltac Uniq_uniq default_value :=
   match goal with
   | H:is_true (uniq ?l1) |- is_true (uniq ?l2) =>
     move: H; remove_useless ; uniq_permut default_value
   end.

(* INPUT: a list
   OUTPUT: returne Some element if this element appears at least twice in the list,
	   None o.w. *)
Ltac look_for_double_in_list lst :=
  match lst with
    | nil => None
    | (?hd :: ?tl) =>
      match In_list hd tl with
        | true => constr:(Some hd)
        | false => look_for_double_in_list tl
      end
  end.

(* INPUT: a context with (uniq lst) and a candidate element
   SIDE-EFFECT: remove all elements except the candidate, eliminate the goal if this is a double *)
Ltac uniq_remove_elements candidate :=
  match goal with
    | H:is_true (uniq (candidate :: candidate :: _)) |- _ =>
      move: {H}(list_is_not_set_hd_hd _ _ _ H) => //
    | H:is_true (uniq (candidate :: ?tl)) |- _ =>
      move: {H}(uniq_rotate _ _ _ H); simpl cat; move=> H ;
        uniq_remove_elements candidate
    | H:is_true (uniq (?hd :: ?tl)) |- _ =>
      move: {H}(uniq_head1 _ _ _ H) => H ;
        uniq_remove_elements candidate
    | _ => fail "no interesting uniq predicate in the context"
  end.

(* INPUT: a context with (uniq lst) and a False goal
   SIDE-EFFECT: eliminate the goal if the list is not a set *)

(*Ltac uniq_false :=
  let candidate :=
    match goal with
      | H:is_true (uniq ?lst) |- False => look_for_double_in_list lst
    end
  in
  match candidate with
    | Some ?candidate' => uniq_remove_elements candidate'
    | _ => fail "no double in the uniq predicate"
  end.*)

(* NB: change 2011/4/04 the code has been changed so that
the tactic tries all the "uniq" hypotheses in the context
in turn; this improvement was necessary to cope with the
situation arising in begcd where there are one context for
seplog vars and one context for regs *)
Ltac uniq_false :=
    match goal with
      | H:is_true (uniq ?lst) |- False =>
        let candidate := look_for_double_in_list lst in

  match candidate with
    | Some ?candidate' => uniq_remove_elements candidate'
    | _ => clear H; uniq_false
(*    | _ => fail "no double in the uniq predicate"*)
  end

      | _ => fail "no double in any uniq predicate"
    end.

Ltac Uniq_not_In_singleton := match goal with
| [ H : is_true (uniq ?lst) |- ~ List.In ?a (?k :: nil) ] =>
  let K := fresh in
    move=> /= [K | // ];
      match k with
        | _ => rewrite <- K in H
      end ;
      uniq_false
end.

Ltac Uniq_not_In :=
  match goal with
    | [ H : is_true (uniq ?lst) |- ~ List.In ?a (?b :: nil) ] =>
      by Uniq_not_In_singleton
    | [ H : is_true (uniq ?lst) |- ~ List.In ?a (?b :: ?k) ] =>
      apply tac_not_In_cons; [by Uniq_not_In_singleton | Uniq_not_In]
    | |- ?X => idtac X
  end.

Ltac Uniq_neq :=
  match goal with
    | [ H : is_true (uniq ?lst) |- ?a <> ?b ] =>
      let K := fresh in
        intro K;
        rewrite <- K in H
        ;
          uniq_false
  end.

Ltac Disj_uniq def :=
  match goal with
  | |- disj (_ :: _) (_ :: _) =>
    Disj_remove_dup ;
    apply uniq_disj; rewrite [cat _ _]/=; by Uniq_uniq def
  end.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B X Y M Aprime Bprime : Universe, ((wd_ X Y /\ (wd_ A M /\ (wd_ Aprime M /\ (wd_ B M /\ (wd_ Bprime M /\ (wd_ B X /\ (wd_ B Y /\ (wd_ A X /\ (wd_ A Y /\ (wd_ A Aprime /\ (wd_ X Aprime /\ (wd_ Y Aprime /\ (wd_ A B /\ (col_ X Y M /\ (col_ B M Bprime /\ (col_ Bprime X Y /\ (col_ M Bprime X /\ col_ M A Aprime))))))))))))))))) -> col_ M Bprime Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export CatSem.CAT.monad_h_morphism_gen.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Section id.

Variable C : Cat.
Variable P : Monad C.

Obligation Tactic := cat.

Program Instance colax_Monad_Hom_id_s : colax_Monad_Hom_struct (P:=P)
  (F0 := Id C)
 (fun c => id _ ).

Definition colax_Monad_Hom_id := Build_colax_Monad_Hom colax_Monad_Hom_id_s.

End id.

Section comp.

Variable C : Cat.
Variable P : Monad C.
Variable D : Cat.
Variable Q : Monad D.
Variable E : Cat.
Variable R : Monad E.

Variable F : Functor C D.
Variable S : colax_Monad_Hom P Q F.
Variable G : Functor D E.
Variable T : colax_Monad_Hom Q R G.

Program Instance colax_Monad_Hom_comp_s : colax_Monad_Hom_struct (P:=P)
  (F0 := G O F)
 (fun c => #G(S c) ;; T (F c)).
Next Obligation.
Proof.
  repeat rewrite <-assoc.
  rewrite <- FComp.
  rewrite <- FComp.
  rewrite assoc.
  rerew (gen_monad_hom_kl (colax_Monad_Hom_struct := T)).
  rewrite <- assoc.
  rewrite <- FComp.
  rerew (gen_monad_hom_kl (colax_Monad_Hom_struct := S)).
  apply hom_refl.
Qed.
Next Obligation.
Proof.
  rewrite <- assoc.
  rewrite <- FComp.
  rewrite (gen_monad_hom_weta (colax_Monad_Hom_struct := S)).
  rewrite (gen_monad_hom_weta (colax_Monad_Hom_struct := T)).
  apply hom_refl.
Qed.

Definition colax_Monad_Hom_comp :=
    Build_colax_Monad_Hom colax_Monad_Hom_comp_s.

End comp.

Section eq.

Variable C : Cat.
Variable P : Monad C.
Variable D : Cat.
Variable Q : Monad D.

Record gen_Monad_Hom_type  := {
 base_f : Functor C D ;
 gen_mon_hom :> colax_Monad_Hom P Q base_f
}.

(*
Section eq_rel.

Variable a b : gen_Monad_Hom_type.

Record eq_gen_Monad_Hom_type : Prop := {
  b_NT : NatIso (base_f a)(base_f b) ;
  b_comm : forall c, b_NT (P c) ;; b c == a c ;; lift (b_NT c)
}.

End eq_rel.

Lemma eq_gen_eq : Equivalence eq_gen_Monad_Hom_type.
Proof.
  constructor.
  unfold Reflexive.
  intros.
  apply (@Build_eq_gen_Monad_Hom_type _ _ (vidNT _ )).
  simpl.
  cat.
  unfold Symmetric.
  intros. destruct H.
  simpl in *.

Definition eq_gen_Monad_Hom_type : relation gen_Monad_Hom_type :=
  fun a b =>
Section eq.

Variable C : Cat.
Variable P : Monad C.
Variable D : Cat.
Variable Q : Monad D.

Lemma gen_Monad_Hom_eq :
    Equivalence (A:=gen_Monad_Hom_type P Q)
    (fun S T => forall c, S c == T c).

Variable F : Functor C D.
Variable F' : Functor C D.

Inductive eq_gen_Monad_Hom

Lemma gen_Monad_Hom_eq :
    Equivalence (A:=gen_Monad_Hom P Q F)
    (fun S T => forall c, S c == T c).
Proof.
  constructor.
  unfold Reflexive.
  cat.
  unfold Symmetric.
  intros.
  rew_all; cat.
  unfold Transitive.
  intros.
  rew_all.
  rew_all.
  cat.
Qed.

Definition gen_Monad_Hom_oid := Build_Setoid gen_Monad_Hom_eq.

End eq.

Program Instance gen_Monad_s : Cat

  rewrite <- assoc.
  cat.

  apply Foid.
  rerew  (FComp G).
  simpl.
  cat.

 (Tau : forall c, F (P c) ---> Q (F c)) := {
  gen_monad_hom_kl : forall c d (f : c ---> P d),
       #F (kleisli f) ;; Tau _  ==
          Tau _ ;; (kleisli (#F f ;; Tau _ )) ;
  gen_monad_hom_weta : forall c : C,
       #F (weta c) ;; Tau _  == weta _
}.

Variable D : Cat.
Variable Q : Monad D.
Variable F : Functor C D

*)

End eq.


Require Import floyd.proofauto.
Require Import aes.aesutils.
Require Import aes.AES256.

Require Import Coqlib.
Require Import msl.Coqlib2.
Require Import floyd.coqlib3.
Require Import Integers.
Require Import List.
Require Import zlist.sublist.
Require Import sha.SHA256.
Require Import sha.general_lemmas.

(* works, but very slow!
Lemma exp_table_correct : forall a : nat, (a < 256)%nat ->
  nth a ff_exp_table Int.zero = exp3 a.
Proof.
  intros.
  do 256 (destruct a as [| a]; [reflexivity | ]).
  omega.
Qed.
*)

Lemma nth_cons_S: forall {T: Type} (n: nat) (h: T) (tl: list T),
  nth (S n) (h :: tl) = nth n tl.
Proof. reflexivity. Qed.

Tactic Notation "int_zero_case_if" constr(v) :=
  let E := fresh in
  destruct (Int.eq_dec v Int.zero) as [E | E];
  [ rewrite E in *; rewrite Int.eq_true in *
  | rewrite (Int.eq_false _  _ E) in *].

(* TODO put this into client_lemmas.v (contains already repable_signed, which is similar but does not
   know all of them *)

(* Equality proofs for all constants from the Compcert Int module: *)
Definition int_wordsize_eq : Int.wordsize = 32%nat := eq_refl.
Definition int_zwordsize_eq : Int.zwordsize = 32 := eq_refl.
Definition int_modulus_eq : Int.modulus = 4294967296 := eq_refl.
Definition int_half_modulus_eq : Int.half_modulus = 2147483648 := eq_refl.
Definition int_max_unsigned_eq : Int.max_unsigned = 4294967295 := eq_refl.
Definition int_max_signed_eq : Int.max_signed = 2147483647 := eq_refl.
Definition int_min_signed_eq : Int.min_signed = -2147483648 := eq_refl.

Ltac my_repable_signed :=
   pose proof int_wordsize_eq;
   pose proof int_zwordsize_eq;
   pose proof int_modulus_eq;
   pose proof int_half_modulus_eq;
   pose proof int_max_unsigned_eq;
   pose proof int_max_signed_eq;
   pose proof int_min_signed_eq;
   unfold repable_signed in *;
   omega.

Lemma xtime_zero: forall (i : int),
  0 <= (Int.unsigned i) < 256 ->
  xtime i = Int.zero -> i = Int.zero.
Proof.
  intros i B H. unfold xtime in H.
  erewrite Int.modu_and in H by reflexivity.
  replace (Int.sub (Int.repr 256) Int.one) with (Int.repr 255) in H by reflexivity.
  int_zero_case_if (Int.and i (Int.repr 128)).
  - apply Int.same_bits_eq. intros j ?. rewrite Int.bits_zero.
    assert (0 <= j <= 6 \/ j = 7 \/ 8 <= j < 32) as C by my_repable_signed.
    destruct C as [C | [C | C]].
    + subst. apply (f_equal (fun x => Int.testbit x (j + 1))) in H.
      rewrite Int.bits_and in H by my_repable_signed.
      assert (Int.testbit (Int.repr 255) (j+1) = true) as E. {
        assert (j = 0 \/ j = 1 \/ j = 2 \/ j = 3 \/ j = 4 \/ j = 5 \/ j = 6) as C1 by omega.
        repeat destruct C1 as [C1 | C1]; subst j; reflexivity.
      }
      rewrite E in H.
      rewrite andb_true_r in H.
      rewrite Int.bits_shl in H by my_repable_signed.
      rewrite Int.unsigned_one in H. replace (j + 1 - 1) with j in H by omega.
      destruct (zlt (j + 1) 1). omega. rewrite H. apply Int.bits_zero.
    + subst. apply (f_equal (fun x => Int.testbit x 7)) in H0.
      rewrite Int.bits_and in H0 by my_repable_signed.
      replace (Int.testbit (Int.repr 128) 7) with true in H0 by reflexivity.
      rewrite andb_true_r in H0. rewrite H0. reflexivity.
    + unfold Int.testbit.
      apply Z.testbit_false. omega.
      rewrite Z.div_small. reflexivity.
      assert (256 <= 2 ^ j). {
        replace 256 with (2 ^ 8) by reflexivity. apply Z.pow_le_mono_r_iff; omega.
      }
      omega.
  - apply (f_equal (fun x => Int.testbit x 0)) in H.
    rewrite Int.bits_xor in H by my_repable_signed.
    replace (Int.testbit (Int.repr 27) 0) with true in H by reflexivity.
    rewrite xorb_true_r in H.
    rewrite Int.bits_zero in H.
    rewrite Int.bits_and in H by my_repable_signed.
    replace (Int.testbit (Int.repr 255) 0) with true in H by reflexivity.
    rewrite andb_true_r in H.
    rewrite Int.bits_shl in H by my_repable_signed.
    destruct (zlt 0 (Int.unsigned Int.one)); discriminate.
Qed.

Lemma fast_times3: forall (i : int),
  0 <= (Int.unsigned i) < 256 ->
  Int.xor i (xtime i) = ff_mult (Int.repr 3) i.
Proof.
  intros. unfold ff_mult. simpl.
  int_zero_case_if i.
  - reflexivity.
  - int_zero_case_if (xtime i).
    + exfalso. apply H0. apply xtime_zero; assumption.
    + unfold ff_checkbit.
      simpl. rewrite Int.xor_zero_l. reflexivity.
Qed.

Lemma ff_exp_step: forall a e,
  0 <= Int.unsigned a < 256 ->
  0 <= e < Int.max_signed ->
  ff_exp a (Int.repr (1 + e)) = ff_mult a (ff_exp a (Int.repr e)).
Proof.
  intros. unfold ff_exp.
  do 2 rewrite (Int.unsigned_repr) by repable_signed.
  rewrite Z2Nat.inj_add by omega.
  replace (Z.to_nat 1 + Z.to_nat e)%nat with (S (Z.to_nat e)) by reflexivity.
  reflexivity.
Qed.

Lemma exp3_step: forall e,
  0 <= e < Int.max_signed ->
  ff_exp (Int.repr 3) (Int.repr (1 + e)) = ff_mult (Int.repr 3) (ff_exp (Int.repr 3) (Int.repr e)).
Proof.
  intros. apply ff_exp_step.
  rewrite (Int.unsigned_repr); repable_signed.
  repable_signed.
Qed.

(* 3^e in GF(2^8) *)
Definition exp3 (e: nat): int := ff_exp (Int.repr 3) (Int.repr (Z.of_nat e)).

Lemma exp3_S: forall n,
  (0 <= n <= 256)%nat -> (* even holds for bigger n, as long as no int overflow *)
  exp3 (S n) = ff_mult (Int.repr 3) (exp3 n).
Proof.
  intros. unfold exp3.
  rewrite <- exp3_step.
  - replace (Z.of_nat (S n)) with (1 + (Z.of_nat n)).
    + reflexivity.
    + replace 1 with (Z.of_nat (S O)) by reflexivity.
      rewrite <- Nat2Z.inj_add. reflexivity.
  - assert (Z.of_nat n <= 256). {
      replace 256 with (Z.of_nat 256) by reflexivity.
      apply Nat2Z.inj_le. omega.
    }
    repable_signed.
Qed.

Lemma exp3_S_slow: forall n,
  (0 <= n <= 256)%nat -> (* even holds for bigger n, as long as no int overflow *)
  exp3 (S n) = ff_mult (Int.repr 3) (exp3 n).
Proof.
  intros. unfold exp3. unfold ff_exp. unfold repeat_op at 1. fold repeat_op.
  rewrite (Int.unsigned_repr).  rewrite (Int.unsigned_repr).
  do 2 rewrite Nat2Z.id. reflexivity. repable_signed.
  assert (Z.of_nat (S n) <= 257). {
    replace 257 with (Z.of_nat 257) by reflexivity.
    apply Nat2Z.inj_le. omega.
  }
  repable_signed.
(* Qed. <-- this takes ages, but why?? *)
Abort.

Lemma ff_exp_range: forall a b,
  0 <= a < 256 ->
  0 <= b < 256 ->
  0 <= Int.unsigned (ff_exp (Int.repr a) (Int.repr b)) < 256.
Proof.
Admitted.

Lemma gen_exp_table_correct : forall n : nat, (n <= 256)%nat ->
  forall i : nat, (i < n)%nat ->
    nth i (gen_exp_table n (exp3 (256-n))) Int.zero = exp3 (256+i-n).
Proof.
  intro n. induction n; intros. omega.
  destruct i as [|j].
  - unfold gen_exp_table. unfold nth. reflexivity.
  - unfold gen_exp_table. fold gen_exp_table. rewrite nth_cons_S.
    rewrite fast_times3.
    + replace (256 + S j - S n)%nat with (256 + j - n)%nat by omega.
      replace (256 - n)%nat with (S (256 - S n)) in IHn by omega.
      rewrite exp3_S in IHn by omega.
      apply IHn; omega.
    + apply ff_exp_range.
      * omega.
      * replace 256 with (Z.of_nat 256) by reflexivity. split.
        { apply Nat2Z.is_nonneg. }
        { apply Nat2Z.inj_lt. omega. }
Qed.

(* slow (minutes)
Lemma exp_table_correct : forall a : nat, (a < 256)%nat ->
  nth a ff_exp_table Int.zero = exp3 a.
Proof.
  specialize (gen_exp_table_correct 256). intros C a H.
  assert (256 <= 256)%nat as L by omega.
  specialize (C L a H).
  replace (256 - 256)%nat with O in C by omega.
  replace (256 + a - 256)%nat with a in C by omega.
  apply C.
Qed.
*)

(* slow (minutes)
Lemma log_table_correct : forall a : nat, (1 < a < 256)%nat ->
  let pow := nth a ff_log_table Int.zero in
  ff_exp (Int.repr 3) pow = Int.repr (Z.of_nat a).
Proof.
  intros.
  destruct a as [| a].
  omega.
  do 255 (destruct a as [| a]; [reflexivity | ]).
  omega.
Qed.
*)

(* unfeasibly slow (150 hours are not enough)
Lemma ff_mult_equiv : forall a b : nat,
  (a < 256)%nat -> (b < 256)%nat ->
  table_ff_mult (Int.repr (Z.of_nat a)) (Int.repr (Z.of_nat b))
  = ff_mult (Int.repr (Z.of_nat a)) (Int.repr (Z.of_nat b)).
Proof.
  intros.
  do 256 (destruct a as [| a]; [do 256 (destruct b as [| b]; [reflexivity | ]); omega | ]).
  omega.
Qed.
*)


Require Import Gappa_tactic.

Lemma truc :
  forall b, (Rabs b <= 1 -> Rabs b <= 2)%R.
Proof.
gappa.
Qed.

Lemma truc' :
  forall b, (Rabs b <= 1 -> Rabs b <= 1)%R.
Proof.
gappa.
Qed.


Module Name.

Require Import Coq.Lists.ListSet.

Inductive Name : Type.

Definition Configuration : Type := set Name.

End Name.


Set Warnings "-notation-overridden".

Require Import LinearScan.Lib.
Require Import LinearScan.Context.
Require Import LinearScan.Interval.
Require Import LinearScan.ScanState.
Require Export LinearScan.Trace.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.
Generalizable All Variables.

Section Morph.

Variable maxReg : nat.          (* max number of registers *)
Definition PhysReg := 'I_maxReg.

Open Scope nat_scope.

(** ** SSMorph *)

(** A [SSMorph] is a relation describe a lawful transition between two
    states.  It is a [PreOrder] relation. *)

Record SSMorph (sd1 sd2 : ScanStateDesc maxReg) : Prop := {
    next_interval_increases : nextInterval sd1 <= nextInterval sd2
}.

Arguments next_interval_increases [sd1 sd2] _.

Global Program Instance SSMorph_PO : PreOrder SSMorph.
Obligation 1. constructor; auto. Qed.
Obligation 2.
  constructor; destruct H; destruct H0.
  - exact: (leq_trans next_interval_increases0).
Qed.

Record SSMorphLen (sd1 sd2 : ScanStateDesc maxReg) : Prop := {
    len_is_SSMorph :> SSMorph sd1 sd2;

    unhandled_nonempty :
      size (unhandled sd1) > 0 -> size (unhandled sd2) > 0
}.

Global Program Instance SSMorphLen_PO : PreOrder SSMorphLen.
Obligation 1.
  unfold Reflexive. intros.
  constructor; auto; constructor; auto.
Qed.
Obligation 2.
  constructor; destruct H; destruct H0.
  transitivity y; assumption. auto.
Qed.

Definition newSSMorphLen (s : ScanStateDesc maxReg) : SSMorphLen s s.
Proof. intros. constructor; auto. constructor; auto. Defined.

Record SSMorphHasLen (sd1 sd2 : ScanStateDesc maxReg) : Prop := {
    haslen_is_SSMorphLen :> SSMorphLen sd1 sd2;

    first_nonempty : size (unhandled sd2) > 0
}.

Definition newSSMorphHasLen (sd : ScanStateDesc maxReg)
  (H : size (unhandled sd) > 0) : SSMorphHasLen sd sd.
Proof. repeat (constructor; auto). Defined.

Record SSInfo P := {
    thisDesc  : ScanStateDesc maxReg;
    thisHolds : P thisDesc;
    thisState : ScanState InUse thisDesc
}.

Arguments thisDesc  {P} _.
Arguments thisHolds {P} _.
Arguments thisState {P} _.

Definition SState (sd : ScanStateDesc maxReg) P Q :=
  Context SSTrace (SSInfo (P sd)) (SSInfo (Q sd)).

Definition error_ {sd P Q a} err : SState sd P Q a := fun _ _ => inl err.

Definition withScanState {a pre} {P Q}
  (f : forall sd : ScanStateDesc maxReg, ScanState InUse sd
         -> SState pre P Q a) : SState pre P Q a :=
  ibind (fun i => f (thisDesc i) (thisState i)) iget.

Arguments withScanState {a pre P Q} f _ _.

Definition withScanStatePO {a pre P} `{PO : PreOrder _ P}
  (f : forall sd : ScanStateDesc maxReg, ScanState InUse sd
         -> SState sd P P a) : SState pre P P a.
Proof.
  intros e i.
  destruct i.
  specialize (f thisDesc0 thisState0).
  assert (SSInfo (P thisDesc0)).
    eapply {| thisDesc  := _
            ; thisHolds := _ |}.
  apply (f e) in X.
  destruct X as [err|p].
    apply (inl err).
  apply inr.
  destruct p.
  split. apply a0.
  destruct s.
  eexists.
  apply (transitivity thisHolds0 thisHolds1).
  assumption.
  Unshelve.
  3:apply thisState0.
  reflexivity.
Defined.

Arguments withScanStatePO {a pre P _} f _ _.

Definition liftLen {pre a} :
  (forall sd : ScanStateDesc maxReg, SState sd SSMorphLen SSMorphLen a)
    -> SState pre SSMorphHasLen SSMorphHasLen a.
Proof.
  move=> f.
  move=> e [sd [morphlen Hempty] st].
  pose ss := {| thisDesc  := sd
              ; thisHolds := newSSMorphLen sd
              ; thisState := st
              |}.
  case: (f sd e ss) => [err|[x [sd' morphlen' st']]].
    exact: inl err.
  apply: inr.
  split; first exact: x.
  apply: {| thisDesc  := sd'
          ; thisHolds := _
          ; thisState := st'
          |}.
  apply: Build_SSMorphHasLen.
    exact: (transitivity morphlen morphlen').
  case: morphlen' => [_ (* _ *) H].
  exact: H.
Defined.

Definition weakenHasLen {pre} : forall sd,
  SSMorphHasLen pre sd -> SSMorph pre sd.
Proof. by move=> ? [[?]]. Defined.

Definition strengthenHasLen {pre} : forall sd,
  SSMorph pre sd -> option (SSMorphHasLen pre sd).
Proof.
  move=> sd H.
  case E: (unhandled sd).
    exact: None.
  apply: Some _.
  constructor.
    constructor. exact.
    rewrite E /=. by [].
  rewrite E /=. by [].
Defined.

Definition moveUnhandledToHandled {pre} : SState pre SSMorphHasLen SSMorph unit.
Proof.
  intros e X.
  destruct X.
  destruct thisDesc0.
  destruct thisHolds0.
  destruct haslen_is_SSMorphLen0.
  destruct len_is_SSMorph0.
  destruct unhandled; first by [].
  destruct p.
  case E: (firstUseReqReg (vnth intervals i).2 == None); last first.
    exact: inl (ECannotSpillIfRegisterRequired i :: e).
  apply inr.
  split. apply tt.
  pose (ScanState_moveUnhandledToHandled thisState0 E).
  eapply {| thisState := s |}.
  Unshelve.
  apply Build_SSMorph; intuition.
Defined.

Definition moveUnhandledToActive {pre} (reg : PhysReg) :
  SState pre SSMorphHasLen SSMorph unit.
Proof.
  intros e X.
  destruct X.
  destruct thisDesc0.
  destruct thisHolds0.
  destruct haslen_is_SSMorphLen0.
  destruct len_is_SSMorph0.
  destruct unhandled; first by [].
  destruct p.
  case H: (reg \notin [seq snd i | i <- active]);
    last exact: inl (ERegisterAlreadyAssigned reg :: e).
  apply inr.
  split. apply tt.
  pose (ScanState_moveUnhandledToActive thisState0 H).
  eapply {| thisState := s |}.
  Unshelve.
  apply Build_SSMorph; intuition.
Defined.

Definition transportUnhandled (sd sd' : ScanStateDesc maxReg)
  (unh : seq (IntervalId sd * nat))
  (Heqe : nextInterval sd' = nextInterval sd) :
  seq (IntervalId sd' * nat).
Proof.
  elim: unh => [|[uid beg] us IHus].
    exact: [::].
  apply: cons.
    split.
      rewrite /IntervalId in uid *.
      by rewrite Heqe.
    exact: beg.
  exact: IHus.
Defined.

Definition moveActiveToHandled
  `(st : ScanState InUse sd) (spilled : bool) `(H: x \in active sd)
  (Hreq : let int := vnth (intervals sd) (fst x) in
          if spilled
          then firstUseReqReg int.2 == None
          else verifyNewHandled sd int.1 (snd x)) :
  { sd' : ScanStateDesc maxReg
  | ScanState InUse sd'
  & SSMorphLen sd sd' /\
    { H : nextInterval sd = nextInterval sd'
    | unhandled sd = transportUnhandled (unhandled sd') H } }.
Proof.
  pose (ScanState_moveActiveToHandled st H Hreq).
  eexists. apply s. simpl.
  split.
    apply Build_SSMorphLen; auto.
    apply Build_SSMorph; auto.
  exists refl_equal.
  elim: (unhandled sd) => //= [[uid beg] us IHus].
  by f_equal.
Defined.

Arguments moveActiveToHandled {sd} st spilled {x} H Hreq.

Definition moveActiveToInactive
  `(st : ScanState InUse sd) `(H: x \in active sd) :
  { sd' : ScanStateDesc maxReg | ScanState InUse sd' & SSMorphLen sd sd' }.
Proof.
  pose (ScanState_moveActiveToInactive st H).
  eexists. apply s.
  apply Build_SSMorphLen; auto.
  apply Build_SSMorph; auto.
Defined.

Definition moveInactiveToActive
  `(st : ScanState InUse sd) `(H : x \in inactive sd)
  (Hreg : snd x \notin [seq snd i | i <- active sd]) :
  { sd' : ScanStateDesc maxReg | ScanState InUse sd' & SSMorphLen sd sd' }.
Proof.
  pose (ScanState_moveInactiveToActive st H Hreg).
  eexists. apply s.
  apply Build_SSMorphLen; auto.
  apply Build_SSMorph; auto.
Defined.

Theorem moveInactiveToActive_spec
  `(st : ScanState InUse sd) `(H : x \in inactive sd)
  (Hreg : snd x \notin [seq snd i | i <- active sd]) :
  let: exist2 sd' st' sslen' := moveInactiveToActive st H Hreg in
  nextInterval sd = nextInterval sd'.
Proof. reflexivity. Qed.

Definition moveInactiveToHandled `(st : ScanState InUse sd)
  (spilled : bool) `(H : x \in inactive sd)
  (Hreq : let int := vnth (intervals sd) (fst x) in
          if spilled
          then firstUseReqReg int.2 == None
          else verifyNewHandled sd int.1 (snd x)) :
  { sd' : ScanStateDesc maxReg
  | ScanState InUse sd'
  & SSMorphLen sd sd' /\
    { H : nextInterval sd = nextInterval sd'
    | unhandled sd = transportUnhandled (unhandled sd') H } }.
Proof.
  pose (ScanState_moveInactiveToHandled st H Hreq).
  eexists. apply s. simpl.
  split.
    apply Build_SSMorphLen; auto.
    apply Build_SSMorph; auto.
  exists refl_equal.
  elim: (unhandled sd) => //= [[uid beg] us IHus].
  by f_equal.
Defined.

Arguments moveInactiveToHandled {sd} st spilled {x} H Hreq.

End Morph.