Add LoadPath "../../ml_proof".

Require Import ZArith.
Require Import List.
Require Import FMapPositive.

Require Import generic.

Require Import domains.
Require Import model.
Import ImpLang.Base.
Import ImpLang.BaseM.

Notation "'□' '+' e" := (Fplusl e) (at level 50) : k_scope.
Notation "e '+' '□'" := (Fplusr e) (at level 50) : k_scope.
Notation "'□' '/' e" := (Fdivl e) (at level 40): k_scope.
Notation "e '/' '□'" := (Fdivr e) (at level 40): k_scope.
Notation "'□' '<=' e" := (Flel e) (at level 70): k_scope.
Notation "i '<=' '□'" := (Fler i) (at level 70): k_scope.
Notation "'□' '&&' e" := (Fandl e) (at level 40): k_scope.
Notation "v ':=□'" := (Fassign v) (at level 30): k_scope.
Notation "'if□then' s1 'else' s2" := (Fif s1 s2) (at level 20): k_scope.

Delimit Scope k_scope with K.
Open Scope k_scope.

Coercion KExp : Exp >-> kitem.
Coercion KBExp : BExp >-> kitem.
Coercion KStmt : Stmt >-> kitem.
Coercion KFreezer : freezer >-> kitem.

Set Implicit Arguments.

Generalizable Variables rest env x y i j r e b s.

Inductive kstep : kcfg -> kcfg -> Prop :=
  (* evaluation rules *)
  | k_lookup : `(kstep (KCfg (kra (EVar x) rest) env)
                       (KCfg (kra (ECon (lookup env x)) rest) env))
  | k_assign : `(kstep (KCfg (kra (SAssign x (ECon i)) rest) env)
                       (KCfg (kra Skip rest) (update env x i)))
  | k_plus : `(kstep (KCfg (kra (EPlus (ECon i) (ECon j)) rest) env)
                     (KCfg (kra (ECon (Zplus i j)) rest) env))
  | k_div : `(Zneq_bool 0%Z j = true ->
              kstep (KCfg (kra (EDiv (ECon i) (ECon j)) rest) env)
                    (KCfg (kra (ECon (Zdiv i j)) rest) env))
  | k_le : `(kstep (KCfg (kra (BLe (ECon i) (ECon j)) rest) env)
                   (KCfg (kra (BCon (Zle_bool i j)) rest) env))
  | k_and_t : `(kstep (KCfg (kra (BAnd (BCon true) b) rest) env)
                      (KCfg (kra b rest) env))
  | k_and_f : `(kstep (KCfg (kra (BAnd (BCon false) b) rest) env)
                      (KCfg (kra (BCon false) rest) env))
  | k_skip: `(kstep (KCfg (kra Skip rest) env)
                    (KCfg rest env))
  | k_if_t : `(kstep (KCfg (kra (SIf (BCon true) s1 s2) rest) env)
                     (KCfg (kra s1 rest) env))
  | k_if_f : `(kstep (KCfg (kra (SIf (BCon false) s1 s2) rest) env)
                     (KCfg (kra s2 rest) env))
  | k_while : `(kstep (KCfg (kra (SWhile b s) rest) env)
                      (KCfg (kra (SIf b (Seq s (SWhile b s)) Skip) rest) env))
  (* heating and cooling *)
  (* plus *)
  | k_heat_plus_l : `(isEVal e = false ->
                kstep (KCfg (kra (EPlus e e2) rest) env)
                      (KCfg (kra e (kra (□ + e2) rest)) env))
  | k_heat_plus_r : `(isEVal e2 = false ->
                kstep (KCfg (kra (EPlus e e2) rest) env)
                      (KCfg (kra e2 (kra (e + □) rest)) env))
  | k_cool_plus_l : `(kstep (KCfg (kra (ECon i) (kra (□ + e) rest)) env)
                            (KCfg (kra (EPlus (ECon i) e) rest) env))
  | k_cool_plus_r : `(kstep (KCfg (kra (ECon i) (kra (e + □) rest)) env)
                            (KCfg (kra (EPlus e (ECon i)) rest) env))
  (* div *)
  | k_heat_div_l : `(isEVal e = false ->
                kstep (KCfg (kra (EDiv e e2) rest) env)
                      (KCfg (kra e (kra (□ / e2) rest)) env))
  | k_heat_div_r : `(isEVal e2 = false ->
                kstep (KCfg (kra (EDiv e e2) rest) env)
                      (KCfg (kra e2 (kra (e / □) rest)) env))
  | k_cool_div_l : `(kstep (KCfg (kra (ECon i) (kra (□ / e) rest)) env)
                           (KCfg (kra (EDiv (ECon i) e) rest) env))
  | k_cool_div_r : `(kstep (KCfg (kra (ECon i) (kra (e / □) rest)) env)
                           (KCfg (kra (EDiv e (ECon i)) rest) env))
  (* le is seqstrict *)
  | k_heat_le_l : `(isEVal e = false ->
                kstep (KCfg (kra (BLe e e2) rest) env)
                      (KCfg (kra e (kra (□ <= e2) rest)) env))
  | k_heat_le_r : `(isEVal e2 = false ->
                kstep (KCfg (kra (BLe (ECon i) e2) rest) env)
                      (KCfg (kra e2 (kra (i <= □) rest)) env))
  | k_cool_le_l : `(kstep (KCfg (kra (ECon i) (kra (□ <= e) rest)) env)
                            (KCfg (kra (BLe (ECon i) e) rest) env))
  | k_cool_le_r : `(kstep (KCfg (kra (ECon j) (kra (i <= □) rest)) env)
                            (KCfg (kra (BLe (ECon i) (ECon j)) rest) env))
  (* and only left-strict *)
  | k_heat_and : `(isBool b1 = false ->
                 kstep (KCfg (kra (BAnd b1 b2) rest) env)
                       (KCfg (kra b1 (kra (□ && b2) rest)) env))
  | k_cool_and : `(kstep (KCfg (kra (BCon b) (kra (□ && b2) rest)) env)
                         (KCfg (kra (BAnd (BCon b) b2) rest) env))
  (* assign *)
  | k_heat_assign : `(isEVal e = false ->
                  kstep (KCfg (kra (SAssign x e) rest) env)
                        (KCfg (kra e (kra (x :=□) rest)) env))
  | k_cool_assign : `(kstep (KCfg (kra (ECon i) (kra (x :=□) rest)) env)
                            (KCfg (kra (SAssign x (ECon i)) rest) env))

  (* if *)
  | k_heat_if : `(isBool b = false ->
               kstep (KCfg (kra (SIf b s1 s2) rest) env)
                     (KCfg (kra b (kra (if□then s1 else s2) rest)) env))
  | k_cool_if : `(
               kstep (KCfg (kra (BCon b) (kra (if□then s1 else s2) rest)) env)
                     (KCfg (kra (SIf (BCon b) s1 s2) rest) env))
  (* seq *)
  | k_heat_seq : `(kstep (KCfg (kra (Seq s1 s2) rest) env)
                         (KCfg (kra s1 (kra s2 rest)) env))
  .

Inductive steps : kcfg -> kcfg -> Prop :=
  | done : forall c, steps c c
  | more : forall c1 c2 c3, kstep c1 c2 -> steps c2 c3 -> steps c1 c3
  .

Lemma eval_happy :
  steps (KCfg (kra (SAssign (var 1) (EPlus (EVar (var 1)) (EVar (var 2)))) nil)
            (update (update (PositiveMap.empty _) (var 1) 12%Z) (var 2) 13%Z))
        (KCfg nil (update (update (PositiveMap.empty _) (var 1) 25%Z) (var 2) 13%Z)).

Proof.
repeat (eapply more;[solve[auto using kstep]|cbv]).
apply done.
Qed.

Lemma loop_test:
  steps (KCfg (kra (SWhile (BLe (ECon 0) (EVar (var 1)))
    (SAssign (var 1) (EPlus (EVar (var 1)) (ECon (-1)%Z))))
  nil) (update (PositiveMap.empty _) (var 1) 25%Z))
  (KCfg nil (update (PositiveMap.empty _) (var 1) (-1)%Z)).
Proof.
repeat (eapply more;[solve[auto using kstep]|cbv]).
apply done.
Qed.

Import TermAbbrevs.
Notation "'□' '+' e" := (Fplusl e) (at level 50) : kt_scope.
Notation "e '+' '□'" := (Fplusr e) (at level 50) : kt_scope.
Notation "'□' '/' e" := (Fdivl e) (at level 40): kt_scope.
Notation "e '/' '□'" := (Fdivr e) (at level 40): kt_scope.
Notation "'□' '<=' e" := (Flel e) (at level 70): kt_scope.
Notation "i '<=' '□'" := (Fler i) (at level 70): kt_scope.
Notation "'□' '&&' e" := (Fandl e) (at level 40): kt_scope.
Notation "v ':=□'" := (Fassign v) (at level 30): kt_scope.
Notation "'if□then' s1 'else' s2" := (Fif s1 s2) (at level 20): kt_scope.

Delimit Scope kt_scope with KT.
Open Scope kt_scope.

(*
Local Open Scope positive_scope.
Definition restv := 1.
Definition envv := 2.
Definition xv := 3.
Definition yv := 4.
Definition bv := 5.
Definition rv := 6.
Definition iv := 7.
Definition jv := 8.
Definition sv := 9.
Definition s1v := 10.
Definition s2v := 11.
Definition env'v := 12.
Definition ev := 13.
Definition e2v := 14.
Definition b1v := 15.
Definition b2v := 16.

Definition rest := TMVar restv.
Definition env := TMVar envv.
Definition x := TMVar xv.
Definition y := TMVar yv.
Definition b := TMVar bv.
Definition r := TMVar rv.
Definition i := TMVar iv.
Definition j := TMVar jv.
Definition s := TMVar sv.
Definition s1 := TMVar s1v.
Definition s2 := TMVar s2v.
Definition env' := TMVar env'v.
Definition e := TMVar ev.
Definition e2 := TMVar e2v.
Definition b1 := TMVar b1v.
Definition b2 := TMVar b2v.

(* With unsorted terms, kitem injections can't be
   coercions. Maybe labels should be refined
   to make kra do the injection itself?
   would require partial operations in the labels *)

Definition rules : list (T * T * option T) :=
  (* lookup *)
  (KCfg (kra (KExp (EVar x)) rest) env,
   KCfg (kra (KExp (ECon (Lookup env x))) rest) env,
   None) ::
  (* assign *)
  (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env,
   KCfg (kra (KStmt Skip) rest) (Update env x i),
   None) ::
  (* plus *)
  (KCfg (kra (KExp (EPlus (ECon i) (ECon j))) rest) env,
   KCfg (kra (KExp (ECon (PlusZ i j))) rest) env,
   None) ::
  (* div *)
  (KCfg (kra (KExp (EDiv (ECon i) (ECon j))) rest) env,
   KCfg (kra (KExp (ECon (DivZ i j))) rest) env,
   Some (Nez j)) ::
  (* le *)
  (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env,
   KCfg (kra (KBExp (BCon (Zleb i j))) rest) env,
   None) ::
  (* and true *)
  (KCfg (kra (KBExp (BAnd (BCon (Bool true)) b)) rest) env,
   KCfg (kra (KBExp b) rest) env,
   None) ::
  (* and false *)
  (KCfg (kra (KBExp (BAnd (BCon (Bool false)) b)) rest) env,
   KCfg (kra (KBExp (BCon (Bool false))) rest) env,
   None) ::
  (* skip *)
  (KCfg (kra (KStmt Skip) rest) env,
   KCfg rest env,
   None) ::
  (* if true *)
  (KCfg (kra (KStmt (SIf (BCon (Bool true)) s1 s2)) rest) env,
   KCfg (kra (KStmt s1) rest) env,
   None) ::
  (* if false *)
  (KCfg (kra (KStmt (SIf (BCon (Bool false)) s1 s2)) rest) env,
   KCfg (kra (KStmt s2) rest) env,
   None) ::
  (KCfg (kra (KStmt (SWhile b s)) rest) env,
   KCfg (kra (KStmt (SIf b (Seq s (SWhile b s)) Skip)) rest) env,
   None) ::
  (* heating and cooling *)
  (* plus *)
  (KCfg (kra (KExp (EPlus e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ + e2)) rest)) env,
   Some (negb (isVal e))) ::
  (KCfg (kra (KExp (EPlus e e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (e + □)) rest)) env,
   Some (negb (isVal e2))) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ + e)) rest)) env,
   KCfg (kra (KExp (EPlus (ECon i) e)) rest) env,
   None) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e + □)) rest)) env,
   KCfg (kra (KExp (EPlus e (ECon i))) rest) env,
   None) ::
  (* div *)
  (KCfg (kra (KExp (EDiv e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ / e2)) rest)) env,
   Some (negb (isVal e))) ::
  (KCfg (kra (KExp (EDiv e e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (e / □)) rest)) env,
   Some (negb (isVal e2))) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ / e)) rest)) env,
   KCfg (kra (KExp (EDiv (ECon i) e)) rest) env,
   None) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e / □)) rest)) env,
   KCfg (kra (KExp (EDiv e (ECon i))) rest) env,
   None) ::
  (* le is seqstrict *)
  (KCfg (kra (KBExp (BLe e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ <= e2)) rest)) env,
   Some (negb (isVal e))) ::
  (KCfg (kra (KBExp (BLe (ECon i) e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (i <= □)) rest)) env,
   Some (negb (isVal e2))) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ <= e)) rest)) env,
   KCfg (kra (KBExp (BLe (ECon i) e)) rest) env,
   None) ::
  (KCfg (kra (KExp (ECon j)) (kra (KFreezer (i <= □)) rest)) env,
   KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env,
   None) ::
  (* and only left-strict *)
  (KCfg (kra (KBExp (BAnd b1 b2)) rest) env,
   KCfg (kra (KBExp b1) (kra (KFreezer (□ && b2)) rest)) env,
   Some (negb (isBool b1))) ::
  (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (□ && b2)) rest)) env,
   KCfg (kra (KBExp (BAnd (BCon b) b2)) rest) env,
   None) ::
  (* assign *)
  (KCfg (kra (KStmt (SAssign x e)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (x :=□)) rest)) env,
   Some (negb (isVal e))) ::
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (x :=□)) rest)) env,
   KCfg (kra (KStmt (SAssign x (ECon i))) rest) env,
   None) ::
  (* if *)
  (KCfg (kra (KStmt (SIf b s1 s2)) rest) env,
   KCfg (kra (KBExp b) (kra (KFreezer (if□then s1 else s2)) rest)) env,
   Some (negb (isBool b))) ::
  (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (if□then s1 else s2)) rest)) env,
   KCfg (kra (KStmt (SIf (BCon b) s1 s2)) rest) env,
   None) ::
  (* seq *)
  (KCfg (kra (KStmt (Seq s1 s2)) rest) env,
   KCfg (kra (KStmt s1) (kra (KStmt s2) rest)) env,
   None) ::
  nil.

Inductive Irules : (T * T * option T) -> Prop :=
  (* lookup *)
  | i_lookup : Irules
  (KCfg (kra (KExp (EVar x)) rest) env,
   KCfg (kra (KExp (ECon (Lookup env x))) rest) env,
   None)
  (* assign *)
  | i_assign : Irules
  (KCfg (kra (KStmt (SAssign x (ECon i))) rest) env,
   KCfg (kra (KStmt Skip) rest) (Update env x i),
   None)
  (* plus *)
  | i_plus : Irules
  (KCfg (kra (KExp (EPlus (ECon i) (ECon j))) rest) env,
   KCfg (kra (KExp (ECon (PlusZ i j))) rest) env,
   None)
  (* div *)
  | i_div : Irules
  (KCfg (kra (KExp (EDiv (ECon i) (ECon j))) rest) env,
   KCfg (kra (KExp (ECon (DivZ i j))) rest) env,
   Some (Nez j))
  (* le *)
  | i_le : Irules
  (KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env,
   KCfg (kra (KBExp (BCon (Zleb i j))) rest) env,
   None)
  (* and true *)
  | i_and_t : Irules
  (KCfg (kra (KBExp (BAnd (BCon (Bool true)) b)) rest) env,
   KCfg (kra (KBExp b) rest) env,
   None)
  | i_and_f : Irules
  (* and false *)
  (KCfg (kra (KBExp (BAnd (BCon (Bool false)) b)) rest) env,
   KCfg (kra (KBExp (BCon (Bool false))) rest) env,
   None)
  | i_skip : Irules
  (* skip *)
  (KCfg (kra (KStmt Skip) rest) env,
   KCfg rest env,
   None)
  (* if true *)
  | i_if_t : Irules
  (KCfg (kra (KStmt (SIf (BCon (Bool true)) s1 s2)) rest) env,
   KCfg (kra (KStmt s1) rest) env,
   None)
  (* if false *)
  | i_if_f : Irules
  (KCfg (kra (KStmt (SIf (BCon (Bool false)) s1 s2)) rest) env,
   KCfg (kra (KStmt s2) rest) env,
   None)
  | i_while : Irules
  (KCfg (kra (KStmt (SWhile b s)) rest) env,
   KCfg (kra (KStmt (SIf b (Seq s (SWhile b s)) Skip)) rest) env,
   None)
  (* heating and cooling *)
  (* plus *)
  | i_heat_plus_l : Irules
  (KCfg (kra (KExp (EPlus e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ + e2)) rest)) env,
   Some (negb (isVal e)))
  | i_heat_plus_r : Irules
  (KCfg (kra (KExp (EPlus e e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (e + □)) rest)) env,
   Some (negb (isVal e2)))
  | i_cool_plus_l : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ + e)) rest)) env,
   KCfg (kra (KExp (EPlus (ECon i) e)) rest) env,
   None)
  | i_cool_plus_r : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e + □)) rest)) env,
   KCfg (kra (KExp (EPlus e (ECon i))) rest) env,
   None)
  (* div *)
  | i_heat_div_l : Irules
  (KCfg (kra (KExp (EDiv e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ / e2)) rest)) env,
   Some (negb (isVal e)))
  | i_heat_div_r : Irules
  (KCfg (kra (KExp (EDiv e e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (e / □)) rest)) env,
   Some (negb (isVal e2)))
  | i_cool_div_l : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ / e)) rest)) env,
   KCfg (kra (KExp (EDiv (ECon i) e)) rest) env,
   None)
  | i_cool_div_r : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (e / □)) rest)) env,
   KCfg (kra (KExp (EDiv e (ECon i))) rest) env,
   None)
  (* le is seqstrict *)
  | i_heat_le_l : Irules
  (KCfg (kra (KBExp (BLe e e2)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (□ <= e2)) rest)) env,
   Some (negb (isVal e)))
  | i_heat_le_r : Irules
  (KCfg (kra (KBExp (BLe (ECon i) e2)) rest) env,
   KCfg (kra (KExp e2) (kra (KFreezer (i <= □)) rest)) env,
   Some (negb (isVal e2)))
  | i_cool_le_l : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (□ <= e)) rest)) env,
   KCfg (kra (KBExp (BLe (ECon i) e)) rest) env,
   None)
  | i_cool_le_r : Irules
  (KCfg (kra (KExp (ECon j)) (kra (KFreezer (i <= □)) rest)) env,
   KCfg (kra (KBExp (BLe (ECon i) (ECon j))) rest) env,
   None)
  (* and only left-strict *)
  | i_heat_and : Irules
  (KCfg (kra (KBExp (BAnd b1 b2)) rest) env,
   KCfg (kra (KBExp b1) (kra (KFreezer (□ && b2)) rest)) env,
   Some (negb (isBool b1)))
  | i_cool_and : Irules
  (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (□ && b2)) rest)) env,
   KCfg (kra (KBExp (BAnd (BCon b) b2)) rest) env,
   None)
  (* assign *)
  | i_heat_assign : Irules
  (KCfg (kra (KStmt (SAssign x e)) rest) env,
   KCfg (kra (KExp e) (kra (KFreezer (x :=□)) rest)) env,
   Some (negb (isVal e)))
  | i_cool_assign : Irules
  (KCfg (kra (KExp (ECon i)) (kra (KFreezer (x :=□)) rest)) env,
   KCfg (kra (KStmt (SAssign x (ECon i))) rest) env,
   None)
  (* if *)
  | i_heat_if : Irules
  (KCfg (kra (KStmt (SIf b s1 s2)) rest) env,
   KCfg (kra (KBExp b) (kra (KFreezer (if□then s1 else s2)) rest)) env,
   Some (negb (isBool b)))
  | i_cool_if : Irules
  (KCfg (kra (KBExp (BCon b)) (kra (KFreezer (if□then s1 else s2)) rest)) env,
   KCfg (kra (KStmt (SIf (BCon b) s1 s2)) rest) env,
   None)
  (* seq *)
  | i_heat_seq : Irules
  (KCfg (kra (KStmt (Seq s1 s2)) rest) env,
   KCfg (kra (KStmt s1) (kra (KStmt s2) rest)) env,
   None).

Lemma Irules_rules : forall r, Irules r <-> In r rules.
Proof.
split.
destruct 1;repeat ((left;reflexivity)||right).

intro H.
repeat (destruct H as [<-|];[constructor|]).
destruct H.
Qed.

Require Import matchinglreduction.

Module Import ImpReduction := MatchLReduction ImpLang.
Import BaseF.

Definition rule_to_Rule : (T * T * option T) -> Rule := fun r =>
  match r with
    | (before, after, cond) =>
      match cond with
        | Some t =>
          (And (Pattern before)
            (Equals t (Bool true)),
            Pattern after)
        | None =>
          (Pattern before,
            Pattern after)
      end
  end.

(* equivalent to ts (map rule_to_Rule rules),
   but with the In hoisted *)
Import BaseS.

Definition rules_step gamma gamma' :=
  exists r : (T * T * option T),
    Irules r /\
    exists rho : Valuation,
      match r with
        | (first, second, cond) =>
          Some gamma = value rho first /\
          Some gamma' = value rho second /\
          match cond with
            | Some c => Some (existT _ sBool true) = value rho c
            | None => True
          end
      end.

Lemma step_to_rule : forall c1 c2, kstep c1 c2 ->
  rules_step (existT _ skcfg c1) (existT _ skcfg c2).
Ltac pattern_rule :=
match goal with
  [ H : kstep ?lhs ?rhs |- _] =>
  term_quote lhs ltac:(fun lhst =>
  term_quote rhs ltac:(fun rhst =>
    eexists (lhst,rhst,_)))
end.
Ltac find_rule :=
  split;[constructor|].

Ltac find_env :=
  unfold x, e, e2, i, j, b, b1, b2, s, s1, s2, rest, env;
    match goal with
      [|- exists _ : _,
        Some (existT _ _ ?val) = value _ ?pat /\ _ /\ _] =>
      align_rule val pat (PositiveMap.empty M)
      ltac:(fun env' => exists env')
    end.
Ltac finish := intuition;
 (unfold value; simpl;
  unfold lapply;simpl;
  apply f_equal;apply f_equal;
    match goal with
      [H : _ = _ |- _] => rewrite H; reflexivity
    end).

unfold rules_step.
destruct 1 as [] _eqn: Heq; clear Heq;
 pattern_rule; find_rule; find_env; solve[finish].
Qed.

Opaque PositiveMap.find.

Definition Mstep (gamma gamma' : sigT sort_sem) :=
  match gamma, gamma' with
    | existT skcfg c1, existT skcfg c2 => kstep c1 c2
    | _, _ => False
  end.

Lemma some_inj (A : Set) (x y : A) :
  Some x = Some y -> x = y.
Proof.
  injection 1; trivial.
Qed.
Lemma M_inj (s : Sort) (x y : sort_sem s) :
  existT _ s x = existT _ s y -> x = y.
Proof.
  apply Eqdep_dec.inj_pair2_eq_dec; exact sort_dec.
Qed.

Lemma rule_to_step : forall gamma gamma',
  rules_step gamma gamma' -> Mstep gamma gamma'.
Ltac prog x := destruct x; try discriminate;[idtac].
Ltac pvar v venv := let m := fresh "m" in
  destruct (PositiveMap.find v venv) as [m|];[destruct m as [[]]|];try discriminate;[idtac].
Ltac reduce_hyp H :=
  unfold lapply in H; simpl in H; apply some_inj in H.
Ltac give_rule con :=
  (repeat match goal with [ H : @eq (option (sigT ImpLabels.sort_sem)) _ _ |- _] => reduce_hyp H;try apply M_inj in H end);
    subst; apply con; assumption.
Ltac give_rule':=
  (repeat match goal with [ H : @eq (option (sigT ImpLabels.sort_sem)) _ _ |- _] => reduce_hyp H;try apply M_inj in H end);
    subst; unfold Mstep;
  match goal with
    [ H : true = Datatypes.negb _ |- _] =>
    pose (Bool.negb_sym _ _ H)
    |   _ => idtac
  end;solve[auto using kstep].

unfold rules_step, value.
intros. destruct H as [r [InR H]].
destruct InR; destruct H as [env0 [Hbefore [Hafter Hcond]]];
    simpl in Hbefore, Hafter, Hcond;
try (
repeat match goal with
 [H : context E [PositiveMap.find ?v ?e] |- _] =>
   pvar v e
  end; give_rule').
Qed.

Theorem rule_adequate : forall gamma gamma',
  Mstep gamma gamma' <-> rules_step gamma gamma'.
Proof.
split.

unfold Mstep; intro H.
destruct gamma as [[]]; try (exfalso; assumption).
destruct gamma' as [[]]; try (exfalso; assumption).
apply step_to_rule; assumption.

apply rule_to_step.
Qed.

Import TermAbbrevs.

 *)


Require Import rt.util.all.
Require Import rt.model.time rt.model.arrival.basic.task rt.model.arrival.basic.job.
Require Import rt.model.schedule.global.schedulability.
Require Import rt.model.schedule.global.basic.schedule.
Require rt.model.schedule.uni.schedule rt.model.schedule.uni.schedulability.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Partitioned.

  Module uni := rt.model.schedule.uni.schedule.UniprocessorSchedule.
  Module uni_sched := rt.model.schedule.uni.schedulability.Schedulability.
  Import SporadicTaskset Schedule Schedulability.
  Export Time.

  Section PartitionedDefs.

    Context {Task: eqType}.
    Context {Job: eqType}.
    Variable job_task: Job -> Task.

    (* Consider any job arrival sequence. *)
    Variable arr_seq: arrival_sequence Job.

    (* Given any multiprocessor schedule of these jobs, ... *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* ... we define a notion of "partitioned scheduling" (= no migrations) on
      a per-job, per-task, and finally whole-schedule level. *)

    Section NoJobMigration.

      (* A job is "partitioned" iff it never migrates, i.e., it
       * executes on the same processor whenever it is scheduled. *)

      (* So any job j... *)
      Variable j: Job.

      (* ... never migrates iff the following holds: ... *)
      Definition never_migrates :=
        (* ...for any point in time t... *)
        forall t,
          (* ...and any processor cpu... *)
        forall cpu,
          (* ... if job j is scheduled at time t on processor cpu... *)
          scheduled_on sched j cpu t ->
          (* ...then at any other time... *)
          forall t',
            (* ...if the same job is scheduled, it must be scheduled on
             * the same processor. *)
            forall cpu',
              scheduled_on sched j cpu' t' -> cpu' = cpu.

      (* Furthermore, we say that the job is assigned to processor assigned_cpu
       * if it executes only on that processor. *)
      Variable assigned_cpu : processor num_cpus.
      Definition job_local_to_processor :=
        forall t, forall cpu,
          scheduled_on sched j cpu t -> cpu = assigned_cpu.

    End NoJobMigration.

    (* Having defined a notiont of 'partitioned' for individual jobs, let us
     * now turn to tasks. *)

    Section NoTaskMigration.

      (* Given any task tsk in ts, ... *)
      Variable tsk: Task.

      (* ...we say that tsk is assigned to processor assigned_cpu ... *)
      Variable assigned_cpu : processor num_cpus.

      (* ...iff every job of tsk executes exclusively on assigned_cpu. *)
      Definition task_local_to_processor :=
        forall j,
          job_task j = tsk ->
          job_local_to_processor j assigned_cpu.

    End NoTaskMigration.

    (* Finally, a schedule is fully partitioned iff every task is assigned
       to some processor. *)
    Section PartitionedSchedule.

      (* Consider a task set ts to be scheduled. *)
      Variable ts: list Task.

      (* Given an assignment from every task in ts to a processor, ...*)
      Variable assigned_cpu: Task -> processor num_cpus.

      (* ...we say that a schedule is partitioned iff every task is local
         to the corresponding processor. *)
      Definition partitioned_schedule :=
        forall tsk,
          tsk \in ts ->
          task_local_to_processor tsk (assigned_cpu tsk).

    End PartitionedSchedule.

  End PartitionedDefs.

  Section SimpleProperties.

    Context {Job: eqType}.

    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    Section NoJobMigrationLemmas.

      Variable j: Job.

      Lemma local_jobs_dont_migrate:
        forall cpu,
          job_local_to_processor sched j cpu -> never_migrates sched j.
      Proof.
        rewrite /job_local_to_processor /never_migrates
             =>  cpu H_is_local t cpu' H_sched_at_t t' cpu'' H_sched_at_t'.
        apply H_is_local in H_sched_at_t.
        apply H_is_local in H_sched_at_t'.
        by rewrite H_sched_at_t H_sched_at_t'.
      Qed.

    End NoJobMigrationLemmas.

  End SimpleProperties.

End Partitioned.


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

(*  Pierre Casteran
    LaBRI, Université Bordeaux 1, and Inria Futurs (Logical)
*)
Require Import Arith.
Require Import Omega. (* ( :-) *)
Require Import Compare_dec.
Require Import Relations.
Require Import Wellfounded.
Require Import Max.

Require Import Tools.
Require Import More_nat.
Require Import AccP.
Require Import Gamma0_prelude.
Set Implicit Arguments.

Section on_length.

 Open Scope nat_scope.

(* length of ordinal terms *)
(* from Schütte, Proof theory, used in proofs of transitivity
   and total ordering *)

Fixpoint nbterms (t:T2) : nat :=
  match t with zero => 0
             | cons a b n v => (S n) + nbterms v
  end.

(* is the multiplication by 2 useful ? *)

Fixpoint length (t:T2) : nat :=
  match t  with zero => 0
             | cons a b n v =>
                 nbterms (cons a b n v) +
                  2 * (max (length a) (max (length b) (length_aux v)))
  end
with length_aux (t:T2) : nat :=
 match t with zero => 0
            | cons a b n v =>
               max (length a) (max (length b) (length_aux v))
 end.

Lemma length_a : forall a b n v, length a <
                                 length (cons a b n v).
Proof.
 simpl.
 intros; apply le_lt_n_Sm.
 match goal with
     [ |- ?a <= ?b + ?c + ?d] => rewrite (plus_comm (b + c) d) end.
 apply le_plus_trans.
 apply le_plus_trans.
 apply le_max_l.
Qed.

Lemma length_b : forall a b n v, length b <
                                 length (cons a b n v).
Proof.
 simpl.
 intros; apply le_lt_n_Sm.
 match goal with
  [ |- ?a <= ?b + ?c + ?d] => rewrite (plus_comm (b + c) d) end.
 apply le_plus_trans.
 apply le_plus_trans.
 eapply le_trans.
 2:eapply le_max_r.
 apply le_max_l.
Qed.

Lemma length_c : forall a b n v, length v <
                                    length (cons a b n v).
Proof.
 simpl.
 intros; apply le_lt_n_Sm.
 case v.
 simpl.
 auto with arith.
 intros.
 simpl (length (cons t t0 n0 t1)).
 simpl (nbterms (cons t t0 n0 t1)).
 match goal with
  [ |- ?a <= ?b + ?c + ?d] => rewrite <- (plus_assoc b c d) end.
 simpl (length_aux (cons t t0 n0 t1)).
 match goal with [ |- ?a <= ?b + ?c ] => assert (a <= c) end.
 pattern (max (length t) (max (length t0) (length_aux t1))).
 generalize (max (length t) (max (length t0) (length_aux t1))).
 intro n1.
 simpl.
 apply le_n_S.
 apply plus_le_compat_l.
 repeat rewrite plus_0_r.
 apply plus_le_compat;
 apply le_trans with (max (length b) n1);
 apply le_max_r.
 omega.
Qed.

Lemma length_n : forall a b r n p, n < p ->
                        length (cons a b n r) <
                        length (cons a b p r).
Proof.
 induction 1.
 simpl.
 auto with arith.
 simpl;auto with arith.
Qed.

Lemma length_psi : forall a b n c,
                      length [a, b] <= length (cons a b n c).
Proof.
 simpl.
 intros; apply le_lt_n_Sm.
 match goal with
    [ |- ?a <= ?b + ?c + ?d] => rewrite (plus_comm (b + c) d) end.
 apply le_plus_trans.
 replace (max (length b) 0) with (length b).
 repeat  rewrite plus_0_r.
 apply plus_le_compat;
 apply max_le_regL;
 apply le_max_l.
 rewrite max_l;auto with arith.
Qed.

Lemma length_ab : forall a b, length a + length b <= length (cons a b 0 zero).
Proof.
 simpl.
 intros.
 repeat rewrite (max_l (length b) 0);auto with arith.
 case (le_lt_dec (length a) (length b)).
 intro;repeat rewrite max_r;auto.
 omega.
 intro;repeat rewrite max_l;auto.
 omega.
 auto with arith.
Qed.

Lemma length_abnc : forall a b n c,
   length a + length b <= length (cons a b n c).
Proof.
 intros.
 eapply Le.le_trans.
 eapply length_ab.
 apply length_psi.
Qed.

End on_length.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import List Arith.

From Undecidability.Synthetic
  Require Import Definitions
                 ReducibilityFacts
                 InformativeDefinitions
                 InformativeReducibilityFacts.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils decidable discernable
                 fol_ops fo_sig fo_terms fo_logic
                 fo_sat fo_sat_dec

                 red_utils

                 Sig_Sig_fin
                 Sig_rem_props
                 Sig_rem_constants
                 Sig0
                 Sig1
                 Sig1_1
                 Sig_discernable.

Set Implicit Arguments.
Unset Strict Implicit.

Local Infix "≢" := discernable (at level 70, no associativity).

(* * Collection of high-level synthetic decidability results *)

Section Sig_MONADIC_Sig_11.

  Variable (Σ : fo_signature)
           (HΣ1 : forall s, ar_syms Σ s <= 1)
           (HΣ2 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_FSAT_11 : FSAT Σ ⪯ᵢ FSAT (Σ11 (syms Σ) (rels Σ)).
  Proof using HΣ2 HΣ1.
    apply ireduces_transitive with (Q := FSAT (Σno_props Σ)).
    + exists (Σrem_props HΣ2 0); intros A.
      apply exists_equiv; intro; apply Σrem_props_correct.
    + assert (forall s, ar_syms (Σno_props Σ) s <= 1) as H1.
      { simpl; auto. }
      exists (Σrem_constants H1 0); intros A.
      apply exists_equiv; intro; apply Σrem_constants_correct.
  Qed.

End Sig_MONADIC_Sig_11.

Section Sig_MONADIC_PROP.

  (* FSAT Σ(X,Y) and FSAT Σ(ø,Y) are inter-reducible
     is the arities on rels/Y are all 0, ie Propositional case

     Σ0 maps Σ into a signature with no function symbols and
     the same relation symbols, all of arity 0
   *)

  Variable (Σ : fo_signature)
           (HΣ : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_FSAT_x0 : FSAT Σ ⪯ᵢ FSAT (Σ0 Σ).
  Proof using HΣ. exists (@Σ_Σ0 Σ); exact (Σ_Σ0_correct HΣ). Qed.

  Theorem FSAT_x0_FSAT_PROP : FSAT (Σ0 Σ) ⪯ᵢ FSAT Σ.
  Proof using HΣ. exists (Σ0_Σ HΣ); exact (Σ0_Σ_correct HΣ). Qed.

End Sig_MONADIC_PROP.

(* Check FSAT_FULL_MONADIC_FSAT_11.
Print Assumptions FSAT_FULL_MONADIC_FSAT_11. *)

Section FSAT_MONADIC_DEC.

  (* No variables and uniform arity of 1 is decidable
      Signature must be discrete  *)

  Variable (F P : Type)
           (H1 : F -> False)
           (H2 : discrete P)
           (A : fol_form (Σ11 F P)).

  Theorem FSAT_MONADIC_DEC : decidable (FSAT _ A).
  Proof using H2 H1.
    destruct Sig_discrete_to_pos with (A := A)
      as (n & m & i & j & B & HB).
    + simpl; intros s; destruct (H1 s).
    + apply H2.
    + assert (n = 0) as ->.
      { destruct n; auto.
        destruct (H1 (i pos0)). }
      simpl in *.
      destruct FSAT_ΣP1_dec with (V := pos 0) (A := B)
        as [ H | H ].
      * intros p; invert pos p.
      * left; apply HB; auto.
      * right; rewrite HB; auto.
  Qed.

End FSAT_MONADIC_DEC.

Section FSAT_MONADIC_11_FSAT_MONADIC_1.

  Variable (n : nat) (Y : Type) (HY : finite_t Y).

  Theorem FSAT_MONADIC_11_FSAT_MONADIC_1 :
            FSAT (Σ11 (pos n) Y) ⪯ᵢ FSAT (Σ11 Empty_set (list (pos n)*Y + Y)).
  Proof using HY.
    apply ireduces_dependent, Σ11_Σ1_reduction; auto.
  Qed.

End FSAT_MONADIC_11_FSAT_MONADIC_1.

Section FSAT_Σ11_DEC.

  Variable (n : nat)
           (P : Type)
           (HP1 : finite_t P)
           (HP2 : discrete P)
           (A : fol_form (Σ11 (pos n) P)).

  Theorem FSAT_Σ11_DEC : decidable (FSAT _ A).
  Proof using HP2 HP1.
    destruct FSAT_MONADIC_11_FSAT_MONADIC_1 with (n := n) (1 := HP1)
      as (f & Hf).
    specialize (Hf A).
    destruct FSAT_MONADIC_DEC with (A := f A) as [ H | H ]; simpl; auto; try easy.
    + left; revert H; apply Hf.
    + right; contradict H; revert H; apply Hf.
  Qed.

End FSAT_Σ11_DEC.

Section FSAT_FULL_Σ11_DEC.

  Variable (F P : Type) (HF : discrete F) (HP : discrete P)
           (A : fol_form (Σ11 F P)).

  Hint Resolve finite_t_pos : core.

  Theorem FSAT_FULL_Σ11_DEC : decidable (FSAT _ A).
  Proof using HP HF.
    destruct Sig_discrete_to_pos with (A := A)
      as (n & m & i & j & B & HB); auto.
    destruct FSAT_Σ11_DEC with (A := B) as [ H | H ]; auto.
    + left; apply HB; auto.
    + right; contradict H; apply HB; auto.
  Qed.

End FSAT_FULL_Σ11_DEC.

Section FSAT_FULL_MONADIC_DEC.

  (* We can be (a bit) more general here, see discernable.v
     However, decidable discernability is required
     for showing FSAT is decidable *)

  Variable (Σ : fo_signature)
           (H1 : discrete (syms Σ))
           (H2 : discrete (rels Σ))
           (H3 : forall s, ar_syms Σ s <= 1)
           (H4 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_DEC A : decidable (FSAT Σ A).
  Proof using H4 H3 H2 H1.
    destruct FSAT_FULL_MONADIC_FSAT_11 with Σ as (f & Hf); auto.
    destruct FSAT_FULL_Σ11_DEC with (A := f A) as [ H | H ]; auto.
    + left; apply Hf, H.
    + right; contradict H; apply Hf, H.
  Qed.

  (* The case where ar_rels Σ r = 0 for any r also gives
     decidability regardless of syms arities because formulas
     contain no terms *)

End FSAT_FULL_MONADIC_DEC.

(* Check FSAT_FULL_MONADIC_DEC.
Print Assumptions FSAT_FULL_MONADIC_DEC. *)

Section FSAT_PROP_ONLY_DEC.

  Variable (Σ : fo_signature)
           (H1 : discrete (rels Σ))
           (H2 : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_ONLY_DEC A : decidable (FSAT Σ A).
  Proof using H2 H1.
    destruct (FSAT_PROP_FSAT_x0 H2) as (f & Hf).
    destruct FSAT_FULL_MONADIC_DEC with (A := f A)
      as [ H | H ]; auto.
    + intros [].
    + left; revert H; apply Hf; auto.
    + right; contradict H; revert H; apply Hf; auto.
  Qed.

End FSAT_PROP_ONLY_DEC.

(* Check FSAT_PROP_ONLY_DEC.
Print Assumptions FSAT_PROP_ONLY_DEC. *)

Theorem FULL_MONADIC (Σ : fo_signature) :
          { _ : discrete (syms Σ) &
          { _ : discrete (rels Σ)
              | (forall s, ar_syms Σ s <= 1)
             /\ (forall r, ar_rels Σ r <= 1) } }
        + { _ : discrete (rels Σ)
              | forall r, ar_rels Σ r = 0 }
       -> forall A, decidable (FSAT Σ A).
Proof.
  intros [ (H1 & H2 & H3 & H4) | (H1 & H2) ].
  + apply FSAT_FULL_MONADIC_DEC; auto.
  + apply FSAT_PROP_ONLY_DEC; auto.
Qed.

Theorem Σ11_discernable_dec_FSAT X Y :
          (forall u v : X, decidable (u ≢ v))
       -> (forall u v : Y, decidable (u ≢ v))
       -> forall A, decidable (FSAT (Σ11 X Y) A).
Proof.
  intros H0 H1 A.
  destruct (Sig_discernable_dec_to_discrete H0 H1 A)
    as (DX & DY & ? & ? & ? & ? & B & HB); auto.
  destruct FSAT_FULL_MONADIC_DEC with (A := B); simpl; auto.
  + left; tauto.
  + right; tauto.
Qed.

Section FSAT_FULL_MONADIC_discernable.

  Variable (Σ : fo_signature)
           (H1 : forall u v : syms Σ, decidable (u ≢ v))
           (H2 : forall u v : rels Σ, decidable (u ≢ v))
           (H3 : forall s, ar_syms Σ s <= 1)
           (H4 : forall r, ar_rels Σ r <= 1).

  Theorem FSAT_FULL_MONADIC_discernable A : decidable (FSAT Σ A).
  Proof using H4 H3 H2 H1.
    destruct (FSAT_FULL_MONADIC_FSAT_11 H3 H4) as (f & Hf).
    destruct (Σ11_discernable_dec_FSAT H1 H2 (f A)) as [ H | H ].
    + left; apply Hf; auto.
    + right; contradict H; apply Hf; auto.
  Qed.

End FSAT_FULL_MONADIC_discernable.

Section FSAT_PROP_ONLY_discernable.

  Variable (Σ : fo_signature)
           (H1 : forall u v : rels Σ, decidable (u ≢ v))
           (H2 : forall r, ar_rels Σ r = 0).

  Theorem FSAT_PROP_ONLY_discernable A : decidable (FSAT Σ A).
  Proof using H2 H1.
    destruct (FSAT_PROP_FSAT_x0 H2) as (f & Hf).
    destruct FSAT_FULL_MONADIC_discernable with (A := f A)
      as [ H | H ]; auto.
    + intros [].
    + left; revert H; apply Hf; auto.
    + right; contradict H; revert H; apply Hf; auto.
  Qed.

End FSAT_PROP_ONLY_discernable.

Theorem FULL_MONADIC_discernable (Σ : fo_signature) :
          { _ : forall u v : syms Σ, decidable (u ≢ v) &
          { _ : forall u v : rels Σ, decidable (u ≢ v)
              | (forall s, ar_syms Σ s <= 1)
             /\ (forall r, ar_rels Σ r <= 1) } }
        + { _ : forall u v : rels Σ, decidable (u ≢ v)
              | forall r, ar_rels Σ r = 0 }
       -> forall A, decidable (FSAT Σ A).
Proof.
  intros [ (H1 & H2 & H3 & H4) | (H1 & H2) ].
  + apply FSAT_FULL_MONADIC_discernable; auto.
  + apply FSAT_PROP_ONLY_discernable; auto.
Qed.

(* For a monadic signature Σ (arity 0 or 1) with at least one unary relation,

   FSAT is decidable iff both syms and rels have decidable discernability
*)

Theorem FULL_MONADIC_discernable_dec_FSAT_dec_equiv Σ r :
            ar_rels Σ r = 1
         -> (forall s, ar_syms Σ s <= 1)
         -> (forall r, ar_rels Σ r <= 1)
         -> ( (forall u v : syms Σ, decidable (u ≢ v))
            * (forall u v : rels Σ, decidable (u ≢ v)) )
          ≋ forall A, decidable (FSAT Σ A).
Proof.
  intros Hr H1 H2.
  split.
  + intros (? & ?); apply FSAT_FULL_MONADIC_discernable; auto.
  + intros H3; split.
    * apply FSAT_dec_implies_discernable_syms_dec with r; auto.
    * apply FSAT_dec_implies_discernable_rels_dec; auto.
Qed.

(* For a signature with only constant relations (arity 0),
   FSAT is decidable iff relations have decidable discernability *)

Theorem MONADIC_PROP_discernable_dec_FSAT_dec_equiv (Σ : fo_signature) :
            (forall r, @ar_rels Σ r = 0)
        ->  (forall u v : rels Σ, decidable (u ≢ v))
          ≋  forall A, decidable (FSAT Σ A).
Proof.
  intros H; split.
  + intros; apply FULL_MONADIC_discernable; eauto.
  + intros H1.
    assert (forall A, decidable (FSAT (Σ0 Σ) A)) as H2.
    { revert H1; apply ireduction_decidable, FSAT_x0_FSAT_PROP; auto. }
    exact (FSAT_dec_implies_discernable_rels_dec H2).
Qed.


(*|
==========================================
Transition relations over concurrent trees
==========================================

Trees represent the dynamics of non-deterministic procesess.
In order to capture their behavioral equivalence, we follow the
process-algebra tradition and define bisimulation atop of labelled
transition systems.

A node is said to be _observable_ if it is a visible event, a return
node, or an internal br tagged as visible.
The first transition relation we introduce is [trans]: a tree can
finitely descend through unobservable brs until it reaches an
observable node. At this point, it steps following the simple rules:
- [Ret v] steps to a silently blocked state by emitting a value
label of [v]
- [Vis e k] can step to any [k x] by emitting an event label tagged
with both [e] and [x]
- [BrS k] can step to any [k x] by emitting a tau label

This transition system will define a notion of strong bisimulation
in the process algebra tradition.
It also leads to a weak bisimulation by defining [wtrans] as a
sequence of tau steps, and allowing a challenge to be answered by
[wtrans . trans . wtrans].
Once [trans] is defined over our structure, we can reuse the constructions
used by Pous in [Coinduction All the Way Up] to build these weak relations
-- with the exception that we need to work in Kleene Algebras w.r.t. to model
closed under [equ] rather than [eq].

.. coq:: none
|*)

From Coq Require Import Fin.

From Coinduction Require Import
     coinduction rel tactics.

From ITree Require Import
     Core.Subevent
     Indexed.Sum.

From CTree Require Import
     CTree Eq.Shallow Eq.Equ.

From RelationAlgebra Require Import
     monoid
     kat
     kat_tac
     prop
     rel
     srel
     comparisons
     rewriting
     normalisation.

Import CTree.
Import CTreeNotations.
Import EquNotations.
Open Scope ctree.

Set Implicit Arguments.
Set Primitive Projections.

#[local] Tactic Notation "step" := __step_equ.
#[local] Tactic Notation "step" "in" ident(H) := __step_in_equ H.

(*|
.. coq::
|*)

Section Trans.

  Context {E B : Type -> Type} {R : Type}.
  Context {HasStuck: B0 -< B}.

  Notation S' := (ctree' E B R).
  Notation S  := (ctree  E B R).

  Definition SS : EqType :=
    {| type_of := S ; Eq := equ eq |}.

  (*|
The domain of labels of the LTS.
Note that it could be typed more strongly: [val] labels can only
be of type [R]. However typing it statically makes lemmas about
[bind] particularly awkward to state, so this seems to be the
least annoying solution.
|*)
  Variant label : Type :=
    | tau
    | obs {X : Type} (e : E X) (v : X)
    | val {X : Type} (v : X).

  Variant is_val : label -> Prop :=
    | Is_val : forall X (x : X), is_val (val x).

  Lemma is_val_tau : ~ is_val tau.
  Proof.
    intro H. inversion H.
  Qed.

  Lemma is_val_obs {X} (e : E X) x : ~ is_val (obs e x).
  Proof.
    intro H. inversion H.
  Qed.

  (*|
The transition relation over [ctree]s.
It can either:
- recursively crawl through invisible [br] node;
- stop at a successor of a visible [br] node, labelling the transition [tau];
- stop at a successor of a [Vis] node, labelling the transition by the event and branch taken;
- stop at a sink (implemented as a [br] node with no successor) by stepping from a [ret v]
node, labelling the transition by the returned value.
|*)
  Inductive trans_ : label -> hrel S' S' :=

  | Stepbr {X} (c : B X) x k l t :
    trans_ l (observe (k x)) t ->
    trans_ l (BrF false c k) t

  | Steptau {X} (c : B X) x k t :
    k x ≅ t ->
    trans_ tau (BrSF c k) (observe t)

  | Stepobs {X} (e : E X) k x t :
    k x ≅ t ->
    trans_ (obs e x) (VisF e k) (observe t)

  | Stepval r k :
    trans_ (val r) (RetF r) (brDF branch0 k).
  Hint Constructors trans_ : core.

  Definition transR l : hrel S S :=
    fun u v => trans_ l (observe u) (observe v).

  Ltac FtoObs :=
    match goal with
      |- trans_ _ _ ?t =>
        change t with (observe {| _observe := t |})
    end.

  #[local] Instance trans_equ_aux1 l t :
    Proper (going (equ eq) ==> flip impl) (trans_ l t).
  Proof.
    intros u u' equ; intros TR.
    inv equ; rename H into equ.
    step in equ.
    revert u equ.
    dependent induction TR; intros; subst; eauto.
    + inv equ.
      * rewrite H2; eauto.
      * FtoObs.
	apply (Steptau c x).
	rewrite H.
	rewrite (ctree_eta t), <- H2.
	step; constructor; intros; symmetry; auto.
      * FtoObs.
	apply (Steptau c x).
	rewrite H.
	rewrite (ctree_eta t), <- H2.
	step; constructor; intros; symmetry; auto.
    + FtoObs.
      econstructor.
      rewrite H; symmetry; step; auto.
    + inv equ. dependent destruction H3. econstructor.
  Qed.

  #[local] Instance trans_equ_aux2 l :
    Proper (going (equ eq) ==> going (equ eq) ==> impl) (trans_ l).
  Proof.
    intros t t' eqt u u' equ TR.
    rewrite <- equ; clear u' equ.
    inv eqt; rename H into eqt.
    revert t' eqt.
    dependent induction TR; intros; auto.
    + step in eqt; dependent induction eqt.
      apply (Stepbr c x).
      apply IHTR.
      rewrite REL; reflexivity.
    + step in eqt; dependent induction eqt.
      econstructor.
      rewrite <- REL; eauto.
    + step in eqt; dependent induction eqt.
      econstructor.
      rewrite <- REL; eauto.
    + step in eqt; dependent induction eqt.
      econstructor.
  Qed.

  #[global] Instance trans_equ_ l :
    Proper (going (equ eq) ==> going (equ eq) ==> iff) (trans_ l).
  Proof.
    intros ? ? eqt ? ? equ; split; intros TR.
    - eapply trans_equ_aux2; eauto.
    - symmetry in equ; symmetry in eqt; eapply trans_equ_aux2; eauto.
  Qed.

  (*|
[equ] is congruent for [trans], we can hence build a [srel] and build our
relations in this model to still exploit the automation from the [RelationAlgebra]
library.
|*)
  #[global] Instance trans_equ l :
    Proper (equ eq ==> equ eq ==> iff) (transR l).
  Proof.
    intros ? ? eqt ? ? equ; unfold transR.
    rewrite eqt, equ; reflexivity.
  Qed.

  Definition trans l : srel SS SS := {| hrel_of := transR l : hrel SS SS |}.

  Lemma trans__trans : forall l t u,
      trans_ l (observe t) (observe u) = trans l t u.
  Proof.
    reflexivity.
  Qed.

  Lemma transR_trans : forall l (t t' : S),
      transR l t t' = trans l t t'.
  Proof.
    reflexivity.
  Qed.

  (*|
Extension of [trans] with its reflexive closure, labelled by [tau].
|*)
  Definition etrans (l : label) : srel SS SS :=
    match l with
    | tau => (cup (trans l) 1)
    | _ => trans l
    end.

  (*|
The transition for the weak bisimulation: a sequence of
internal steps, a labelled step, and a new sequence of internal ones
|*)
  Definition wtrans l : srel SS SS :=
    (trans tau)^* ⋅ etrans l ⋅ (trans tau)^*.

  Definition pwtrans l : srel SS SS :=
    (trans tau)^* ⋅ trans l ⋅ (trans tau)^*.

  Definition tautrans : srel SS SS :=
    (trans tau)^+.

  (*|
----------------------------------------------
Elementary theory for the transition relations
----------------------------------------------

Inclusion relation between the three relations:
[trans l ≤ etrans l ≤ wtrans l]

[etrans] is reflexive, and hence so is [wtrans]
[etrans tau p p]

[wtrans] can be built by consing or snocing [trans tau]
[trans tau p p' -> wtrans l p' p'' -> wtrans l p p'']
[wtrans l p p' -> trans tau p' p'' -> wtrans l p p'']

Introduction rules for [trans]
[trans (val v)   (ret v)       stuck]
[trans (obs e v) (Vis e k)     (k v)]
[trans tau       (BrS n k) (k x)]
[trans tau       (Step t) t]
[trans l (k x) u -> trans l (BrI n k) u]
[trans l t u     -> trans l (Guard t) u]

Elimination rules for [trans]
[trans l (Ret x)       u -> l = val x /\ t ≅ stuck]
[trans l (Vis e k)     u -> exists v, l = obs e v /\ t ≅ k v]
[trans l (BrS n k) u -> exists x, t' ≅ k x /\ l = tau]
[trans l (Step t)      u -> t ≅ u /\ l = tau]
[trans l (BrI n k) u -> exists x, trans l (k x) u]
[trans l (Guard t)      u -> trans l t u]

|*)
  Lemma trans_etrans l: trans l ≦ etrans l.
  Proof.
    unfold etrans; case l; ka.
  Qed.
  Lemma etrans_wtrans l: etrans l ≦ wtrans l.
  Proof.
    unfold wtrans; ka.
  Qed.
  Lemma trans_wtrans l: trans l ≦ wtrans l.
  Proof. rewrite trans_etrans. apply etrans_wtrans. Qed.
  Lemma tautrans_wtrans : tautrans ≦ wtrans tau.
  Proof.
    unfold tautrans, wtrans, etrans; ka.
  Qed.
  Lemma pwtrans_wtrans l : pwtrans l ≦ wtrans l.
  Proof.
    unfold pwtrans, wtrans, etrans; case l; ka.
  Qed.

  Lemma trans_etrans_ l: forall p p', trans l p p' -> etrans l p p'.
  Proof. apply trans_etrans. Qed.
  Lemma trans_wtrans_ l: forall p p', trans l p p' -> wtrans l p p'.
  Proof. apply trans_wtrans. Qed.
  Lemma etrans_wtrans_ l: forall p p', etrans l p p' -> wtrans l p p'.
  Proof. apply etrans_wtrans. Qed.
  Lemma tautrans_wtrans_ : forall p p', tautrans p p' -> wtrans tau p p'.
  Proof. apply tautrans_wtrans. Qed.
  Lemma pwtrans_wtrans_ l : forall p p', pwtrans l p p' -> wtrans l p p'.
  Proof. apply pwtrans_wtrans. Qed.

  Lemma enil p: etrans tau p p.
  Proof. cbn. now right. Qed.
  Lemma wnil p: wtrans tau p p.
  Proof. apply etrans_wtrans, enil. Qed.

  Lemma wcons l: forall p p' p'', trans tau p p' -> wtrans l p' p'' -> wtrans l p p''.
  Proof.
    assert ((trans tau: srel SS SS) ⋅ wtrans l ≦ wtrans l) as H
        by (unfold wtrans; ka).
    intros. apply H. eexists; eassumption.
  Qed.
  Lemma wsnoc l: forall p p' p'', wtrans l p p' -> trans tau p' p'' -> wtrans l p p''.
  Proof.
    assert (wtrans l ⋅ trans tau ≦ wtrans l) as H
        by (unfold wtrans; ka).
    intros. apply H. eexists; eassumption.
  Qed.

  Lemma wconss l: forall p p' p'', wtrans tau p p' -> wtrans l p' p'' -> wtrans l p p''.
  Proof.
    assert (wtrans tau ⋅ wtrans l ≦ wtrans l) as H by (unfold wtrans, etrans; ka).
    intros. apply H. eexists; eassumption.
  Qed.
  Lemma wsnocs l: forall p p' p'', wtrans l p p' -> wtrans tau p' p'' -> wtrans l p p''.
  Proof.
    assert (wtrans l ⋅ wtrans tau ≦ wtrans l) as H by (unfold wtrans, etrans; ka).
    intros. apply H. eexists; eassumption.
  Qed.

  Lemma wtrans_tau: wtrans tau ≡ (trans tau)^*.
  Proof.
    unfold wtrans, etrans. ka.
  Qed.

  Lemma pwtrans_tau: pwtrans tau ≡ (trans tau)^+.
  Proof.
    unfold pwtrans, etrans. ka.
  Qed.

  #[global] Instance PreOrder_wtrans_tau: PreOrder (wtrans tau).
  Proof.
    split.
    intro. apply wtrans_tau.
    now (apply (str_refl (trans tau)); cbn).
    intros ?????. apply wtrans_tau. apply (str_trans (trans tau)).
    eexists; apply wtrans_tau; eassumption.
  Qed.

End Trans.

Class Respects_val {E F} (L : rel (@label E) (@label F)) :=
  { respects_val:
    forall l l',
      L l l' ->
      is_val l <-> is_val l' }.

Class Respects_tau {E F} (L : rel (@label E) (@label F)) :=
  { respects_tau: forall l l',
      L l l' ->
      l = tau <-> l' = tau }.

Definition eq_obs {E} (L : relation (@label E)) : Prop :=
  forall X X' e e' (x : X) (x' : X'),
    L (obs e x) (obs e' x') ->
    obs e x = obs e' x'.

#[global] Instance Respects_val_eq A: @Respects_val A A eq.
split; intros; subst; reflexivity.
Defined.

#[global] Instance Respects_tau_eq A: @Respects_tau A A eq.
split; intros; subst; reflexivity.
Defined.

(*|
Backward reasoning for [trans]
------------------------------
Note: we need to be a bit careful to define these proof rules
explicitly over [ctree]s and not [rel_of SS] as gets coerced
in the section above so that [eauto with trans] works smoothly.
|*)
Section backward.

  Context {E B : Type -> Type} {X : Type}.
  Context `{B0 -< B}.
  Context `{B1 -< B}.

  (*|
Structural rules
|*)

  Lemma trans_ret : forall (x : X),
      trans (E := E) (B := B) (val x) (Ret x) stuckD.
  Proof.
    intros; constructor.
  Qed.

  Lemma trans_vis : forall {Y} (e : E Y) x (k : Y -> ctree E B X),
      trans (obs e x) (Vis e k) (k x).
  Proof.
    intros; constructor; auto.
  Qed.

  Lemma trans_brD : forall {Y} l (t t' : ctree E B X) (c : B Y) k x,
      trans l t t' ->
      k x ≅ t ->
      trans l (BrD c k) t'.
  Proof.
    intros * TR Eq.
    apply Stepbr with x.
    rewrite Eq; auto.
  Qed.

  Lemma trans_brS : forall {Y} (c : B Y) (k : _ -> ctree E B X) x,
      trans tau (BrS c k) (k x).
  Proof.
    intros.
    apply Steptau with x; reflexivity.
  Qed.

  (*|
Ad-hoc rules for pre-defined finite branching
|*)

  Variable (l : @label E) (t t' u u' v v' w w' : ctree E B X).

  Lemma trans_step :
    trans tau (Step t) t.
  Proof.
    intros; apply (@trans_brS unit _ (fun _ => t) tt).
  Qed.

  Lemma trans_guard :
    trans l t t' ->
    trans l (Guard t) t'.
  Proof.
    intros * TR; eapply trans_brD; eauto; exact F1.
  Qed.

End backward.

Section BackwardBounded.

  Context {E B : Type -> Type} {X : Type}.
  Context `{B0 -< B}.
  Context `{B2 -< B}.
  Context `{B3 -< B}.
  Context `{B4 -< B}.
  Variable (l : @label E) (t t' u u' v v' w w' : ctree E B X).

  Lemma trans_brS21 :
    trans tau (brS2 t u) t.
  Proof.
    intros.
    unfold brS2.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k true)
    end.
  Qed.

  Lemma trans_brS22 :
    trans tau (brS2 t u) u.
  Proof.
    intros.
    unfold brS2.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k false)
    end.
  Qed.

  Lemma trans_brD21 :
    trans l t t' ->
    trans l (brD2 t u) t'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := true); eauto.
  Qed.

  Lemma trans_brD22 :
    trans l u u' ->
    trans l (brD2 t u) u'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := false); eauto.
  Qed.

  Lemma trans_brS31 :
    trans tau (brS3 t u v) t.
  Proof.
    intros.
    unfold brS3.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t31)
    end.
  Qed.

  Lemma trans_brS32 :
    trans tau (brS3 t u v) u.
  Proof.
    intros.
    unfold brS3.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t32)
    end.
  Qed.

  Lemma trans_brS33 :
    trans tau (brS3 t u v) v.
  Proof.
    intros.
    unfold brS3.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t33)
    end.
  Qed.

  Lemma trans_brD31 :
    trans l t t' ->
    trans l (brD3 t u v) t'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t31); eauto.
  Qed.

  Lemma trans_brD32 :
    trans l u u' ->
    trans l (brD3 t u v) u'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t32); eauto.
  Qed.

  Lemma trans_brD33 :
    trans l v v' ->
    trans l (brD3 t u v) v'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t33); eauto.
  Qed.

  Lemma trans_brS41 :
    trans tau (brS4 t u v w) t.
  Proof.
    intros.
    unfold brS4.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t41)
    end.
  Qed.

  Lemma trans_brS42 :
    trans tau (brS4 t u v w) u.
  Proof.
    intros.
    unfold brS4.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t42)
    end.
  Qed.

  Lemma trans_brS43 :
    trans tau (brS4 t u v w) v.
  Proof.
    intros.
    unfold brS4.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t43)
    end.
  Qed.

  Lemma trans_brS44 :
    trans tau (brS4 t u v w) w.
  Proof.
    intros.
    unfold brS4.
    match goal with
      |- _ (trans tau) (BrS _ ?k) ?t => exact (trans_brS _ k t44)
    end.
  Qed.

  Lemma trans_brD41 :
    trans l t t' ->
    trans l (brD4 t u v w) t'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t41); eauto.
  Qed.

  Lemma trans_brD42 :
    trans l u u' ->
    trans l (brD4 t u v w) u'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t42); eauto.
  Qed.

  Lemma trans_brD43 :
    trans l v v' ->
    trans l (brD4 t u v w) v'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t43); eauto.
  Qed.

  Lemma trans_brD44 :
    trans l w w' ->
    trans l (brD4 t u v w) w'.
  Proof.
    intros * TR.
    eapply trans_brD with (x := t44); eauto.
  Qed.

End BackwardBounded.

(*|
Forward reasoning for [trans]
------------------------------
|*)

Section forward.

  Context {E B : Type -> Type} `{HasStuck : B0 -< B} {X : Type}.

  (*|
Inverting equalities between labels
|*)

  Lemma val_eq_invT : forall X Y x y, @val E X x = @val E Y y -> X = Y.
    clear B HasStuck. intros * EQ.
    now dependent induction EQ.
  Qed.

  Lemma val_eq_inv : forall X x y, @val E X x = val y -> x = y.
    clear B HasStuck. intros * EQ.
    now dependent induction EQ.
  Qed.

  Lemma obs_eq_invT : forall X Y e1 e2 v1 v2, @obs E X e1 v1 = @obs E Y e2 v2 -> X = Y.
    clear B HasStuck. intros * EQ.
    now dependent induction EQ.
  Qed.

  Lemma obs_eq_inv : forall X e1 e2 v1 v2, @obs E X e1 v1 = @obs E X e2 v2 -> e1 = e2 /\ v1 = v2.
    clear B HasStuck. intros * EQ.
    now dependent induction EQ.
  Qed.

  (*|
Structural rules
|*)

  Lemma trans_ret_inv : forall x l (t : ctree E B X),
      trans l (Ret x) t ->
      t ≅ stuckD /\ l = val x.
  Proof.
    intros * TR; inv TR; intuition.
    rewrite ctree_eta, <- H2; auto.
    step; constructor; intros abs; inv abs.
  Qed.

  Lemma trans_vis_inv : forall {Y} (e : E Y) k l (u : ctree E B X),
      trans l (Vis e k) u ->
      exists x, u ≅ k x /\ l = obs e x.
  Proof.
    intros * TR.
    inv TR.
    dependent induction H3; eexists; split; eauto.
    rewrite ctree_eta, <- H4, <- ctree_eta; symmetry; auto.
  Qed.

  Lemma trans_brD_inv : forall {Y} l (c : B Y) k (u : ctree E B X),
      trans l (BrD c k) u ->
      exists n, trans l (k n) u.
  Proof.
    intros * TR.
    cbn in *.
    unfold transR in *.
    cbn in TR |- *.
    match goal with
    | h: trans_ _ ?x ?y |- _ =>
        remember x as ox; remember y as oy
    end.
    revert c k u Heqox Heqoy.
    induction TR; intros; inv Heqox; eauto.
  Qed.

  (*|
Ad-hoc rules for pre-defined finite branching
|*)

  Variable (l : @label E) (t t' u v w : ctree E B X).
  Context `{B1 -< B} `{B2 -< B} `{B3 -< B} `{B4 -< B}.

  Lemma trans_guard_inv :
    trans l (Guard t) t' ->
    trans l t t'.
  Proof.
    intros * TR; apply trans_brD_inv in TR as [_ TR]; auto.
  Qed.

  Lemma trans_brD2_inv :
    trans l (brD2 t u) t' ->
    (trans l t t' \/ trans l u t').
  Proof.
    intros * TR; apply trans_brD_inv in TR as [[] TR]; auto.
  Qed.

  Lemma trans_brD3_inv :
    trans l (brD3 t u v) t' ->
    (trans l t t' \/ trans l u t' \/ trans l v t').
  Proof.
    intros * TR; apply trans_brD_inv in TR as [n TR].
    destruct n; auto.
  Qed.

  Lemma trans_brD4_inv :
    trans l (brD4 t u v w) t' ->
    (trans l t t' \/ trans l u t' \/ trans l v t' \/ trans l w t').
  Proof.
    intros * TR; apply trans_brD_inv in TR as [n TR].
    destruct n; auto.
  Qed.

  Lemma trans_brS_inv : forall {X} (c : B X) k,
      trans l (BrS c k) t' ->
      exists x, t' ≅ k x /\ l = tau.
  Proof.
    intros * TR.
    cbn in *; red in TR; cbn in TR.
    dependent induction TR.
    eexists; split; auto.
    rewrite H3, ctree_eta, (ctree_eta t0), x; reflexivity.
  Qed.

  Lemma trans_step_inv :
    trans l (Step t) t' ->
    t' ≅ t /\ l = tau.
  Proof.
    intros * TR; apply trans_brS_inv in TR as (_ & ? & ?); auto.
  Qed.

  Lemma trans_brS2_inv :
    trans l (brS2 t u) t' ->
    (l = tau /\ (t' ≅ t \/ t' ≅ u)).
  Proof.
    intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto.
    destruct x; auto.
  Qed.

  Lemma trans_brS3_inv :
    trans l (brS3 t u v) t' ->
    (l = tau /\ (t' ≅ t \/ t' ≅ u \/ t' ≅ v)).
  Proof.
    intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto.
    destruct x; auto.
  Qed.

  Lemma trans_brS4_inv :
    trans l (brS4 t u v w) t' ->
    (l = tau /\ (t' ≅ t \/ t' ≅ u \/ t' ≅ v \/ t' ≅ w)).
  Proof.
    intros * TR; apply trans_brS_inv in TR as (? & TR & ->); split; auto.
    destruct x; auto.
  Qed.

  (*|
Inversion rules for [trans] based on the value of the label
-----------------------------------------------------------
In general, these would require to introduce the relation that
only steps through the non-observable internal br.
I'll skip them for now and introduce them if they turn out to be
useful.
|*)

  Lemma trans__val_inv {Y} :
    forall (T U : ctree' E B X) (x : Y),
      trans_ (val x) T U ->
      go U ≅ stuckD.
  Proof.
    intros * TR.
    remember (val x) as ox.
    rewrite ctree_eta; induction TR; intros; auto; try now inv Heqox.
    step; econstructor; intros abs; inv abs.
  Qed.

  Lemma trans_val_inv {Y} :
    forall (t u : ctree E B X) (x : Y),
      trans (val x) t u ->
      u ≅ stuckD.
  Proof.
    intros * TR. cbn in TR. red in TR.
    apply trans__val_inv in TR. rewrite ctree_eta. apply TR.
  Qed.

  Lemma wtrans_val_inv : forall (x : X),
      wtrans (val x) u stuckD ->
      exists t, wtrans tau u t /\ trans (val x) t stuckD.
  Proof.
    intros * TR.
    destruct TR as [t2 [t1 step1 step2] step3].
    exists t1; split.
    apply wtrans_tau; auto.
    erewrite <- trans_val_inv; eauto.
  Qed.

End forward.

(*|
[etrans] theory
---------------
|*)

Lemma etrans_case {E B X} `{B0 -< B} : forall l (t u : ctree E B X),
    etrans l t u ->
    (trans l t u \/ (l = tau /\ t ≅ u)).
Proof.
  intros [] * TR; cbn in *; intuition.
Qed.

Lemma etrans_ret_inv {E B X} `{HasStuck : B0 -< B} : forall x l (t : ctree E B X),
    etrans l (Ret x) t ->
    (l = tau /\ t ≅ Ret x) \/ (l = val x /\ t ≅ stuckD).
Proof.
  intros ? [] ? step; cbn in step.
  - intuition; try (eapply trans_ret in step; now apply step).
    inv H.
  - eapply trans_ret_inv in step; intuition.
  - eapply trans_ret_inv in step; intuition.
Qed.

(*|
Stuck processes
---------------
A process is said to be stuck if it cannot step. The [stuck] process used
to reduce pure computations is of course stuck, but so is [spinI], while [spinV]
is not.
|*)

Section stuck.

  Context {E B : Type -> Type} {X : Type} {HasStuck: B0 -< B}.
  Variable (l : @label E) (t u : ctree E B X).

  Definition is_stuck : ctree E B X -> Prop :=
    fun t => forall l u, ~ (trans l t u).

  #[global] Instance is_stuck_equ : Proper (equ eq ==> iff) is_stuck.
  Proof.
    intros ? ? EQ; split; intros ST; red; intros * ABS.
    rewrite <- EQ in ABS; eapply ST; eauto.
    rewrite EQ in ABS; eapply ST; eauto.
  Qed.

  Lemma etrans_is_stuck_inv (v v' : ctree E B X) :
    is_stuck v ->
    etrans l v v' ->
    (l = tau /\ v ≅ v').
  Proof.
    intros * ST TR.
    edestruct @etrans_case; eauto.
    apply ST in H; tauto.
  Qed.

  Lemma transs_is_stuck_inv (v v' : ctree E B X) :
    is_stuck v ->
    (trans tau)^* v v' ->
    v ≅ v'.
  Proof.
    intros * ST TR.
    destruct TR as [[] TR]; intuition.
    destruct TR.
    apply ST in H; tauto.
  Qed.

  Lemma wtrans_is_stuck_inv :
    is_stuck t ->
    wtrans l t u ->
    (l = tau /\ t ≅ u).
  Proof.
    intros * ST TR.
    destruct TR as [? [? ?] ?].
    apply transs_is_stuck_inv in H; auto.
    rewrite H in ST; apply etrans_is_stuck_inv in H0 as [-> ?]; auto.
    rewrite H0 in ST; apply transs_is_stuck_inv in H1; auto.
    intuition.
    rewrite H, H0; auto.
  Qed.

  Lemma Br0_is_stuck b (c : B void) (k : void -> _) :
    is_stuck (Br b c k).
  Proof.
    red. intros. intro. inv H; destruct x.
  Qed.

  Lemma Br_fin0_is_stuck b (c : B (fin 0)) (k : fin 0 -> _) :
    is_stuck (Br b c k).
  Proof.
    red. intros. intro. inv H; now apply case0.
  Qed.

  Lemma stuckD_is_stuck :
    is_stuck stuckD.
  Proof.
    apply Br0_is_stuck.
  Qed.

  Lemma stuckS_is_stuck :
    is_stuck stuckS.
  Proof.
    apply Br0_is_stuck.
  Qed.

  Lemma spinD_gen_is_stuck {Y} (x : B Y) :
    is_stuck (spinD_gen x).
  Proof.
    red; intros * abs.
    remember (spinD_gen x) as v.
    assert (EQ: v ≅ spinD_gen x) by (subst; reflexivity); clear Heqv; revert EQ; rewrite ctree_eta.
    induction abs; auto; try now (rewrite ctree_eta; intros abs; step in abs; inv abs).
    intros EQ; apply IHabs.
    rewrite <- ctree_eta.
    rewrite ctree_eta in EQ.
    step in EQ; cbn in *.
    dependent induction EQ; auto.
  Qed.

  Lemma spinD_is_stuck `{B1 -< B}:
    is_stuck spinD.
  Proof.
    red; intros * abs.
    remember spinD as v.
    assert (EQ: v ≅ spinD) by (subst; reflexivity); clear Heqv; revert EQ; rewrite ctree_eta.
    induction abs; auto; try now (rewrite unfold_spinD; intros abs; step in abs; inv abs).
    intros EQ; apply IHabs.
    rewrite <- ctree_eta.
    rewrite unfold_spinD in EQ.
    step in EQ.
    dependent induction EQ; auto.
  Qed.

  Lemma spinS_is_not_stuck `{B1 -< B} :
    ~ (is_stuck spinS).
  Proof.
    red; intros * abs.
    apply (abs tau spinS).
    rewrite ctree_eta at 1; cbn.
    constructor; [exact tt | reflexivity].
  Qed.

End stuck.

(*|
wtrans theory
---------------
|*)

Section wtrans.

  Context {E B : Type -> Type} {X : Type} `{HasStuck : B0 -< B}.

  Lemma wtrans_step `{B1 -< B} : forall l (t t' : ctree E B X),
      wtrans l t t' ->
      wtrans l (Step t) t'.
  Proof.
    intros * TR.
    eapply wcons; eauto.
    apply trans_step.
  Qed.

  Lemma trans_tau_str_ret_inv : forall x (t : ctree E B X),
      (trans tau)^* (Ret x) t ->
      t ≅ Ret x.
  Proof.
    intros * [[|] step].
    - cbn in *; symmetry; eauto.
    - destruct step.
      apply trans_ret_inv in H; intuition congruence.
  Qed.

  Lemma wtrans_ret_inv : forall x l (t : ctree E B X),
      wtrans l (Ret x) t ->
      (l = tau /\ t ≅ Ret x) \/ (l = val x /\ t ≅ stuckD).
  Proof.
    intros * step.
    destruct step as [? [? step1 step2] step3].
    apply trans_tau_str_ret_inv in step1.
    rewrite step1 in step2; clear step1.
    apply etrans_ret_inv in step2 as [[-> EQ] |[-> EQ]].
    rewrite EQ in step3; apply trans_tau_str_ret_inv in step3; auto.
    rewrite EQ in step3.
    apply transs_is_stuck_inv in step3; [| apply stuckD_is_stuck].
    intuition.
  Qed.

  Lemma wtrans_val_inv' : forall (x : X) (t v : ctree E B X),
      wtrans (val x) t v ->
      exists u, wtrans tau t u /\ trans (val x) u v /\ v ≅ stuckD.
  Proof.
    intros * TR.
    destruct TR as [t2 [t1 step1 step2] step3].
    pose proof trans_val_inv step2 as EQ.
    rewrite EQ in step3, step2.
    apply transs_is_stuck_inv in step3; auto using stuckD_is_stuck.
    exists t1; repeat split.
    apply wtrans_tau, step1.
    rewrite <- step3; auto.
    symmetry; auto.
  Qed.

End wtrans.

(*|
Forward and backward rules for [trans] w.r.t. [bind]
----------------------------------------------------
trans l (t >>= k) u -> (trans l t t' /\ u ≅ t' >>= k) \/ (trans (ret x) t stuck /\ trans l (k x) u)
l <> val x -> trans l t u -> trans l (t >>= k) (u >>= k)
trans (val x) t stuck -> trans l (k x) u -> trans l (bind t k) u.
|*)
Lemma trans_bind_inv_aux {E B X Y} `{HasStuck : B0 -< B} l T U :
  trans_ l T U ->
  forall (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y),
    go T ≅ t >>= k ->
    go U ≅ u ->
    (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/
      (exists (x : X), trans (val x) t stuckD /\ trans l (k x) u).
Proof.
  intros TR; induction TR; intros.
  - rewrite unfold_bind in H; setoid_rewrite (ctree_eta t0).
    desobs t0.
    + right.
      exists r; split.
      constructor.
      rewrite <- H.
      apply (Stepbr _ x); auto.
      rewrite <- H0; auto.
    + step in H; inv H.
    + step in H; dependent induction H.
      specialize (IHTR (k1 x) k0 u).
      destruct IHTR as [(? & ? & ? & ?) | (? & ? & ?)]; auto.
      rewrite <- ctree_eta, REL; reflexivity.
      left; split; eauto.
      exists x0; split; auto.
      apply (Stepbr _ x); auto.
      right.
      exists x0; split; auto.
      apply (Stepbr _ x); auto.
  - rewrite unfold_bind in H0; setoid_rewrite (ctree_eta t0).
    desobs t0.
    + right.
      exists r; split.
      constructor.
      rewrite <- H0.
      apply (Steptau _ x); auto.
      rewrite H, <- H1, ctree_eta; auto.
    + step in H0; inv H0.
    + step in H0; dependent induction H0.
      left; split; [intros abs; inv abs |].
      exists (k1 x); split.
      econstructor; reflexivity.
      rewrite <- H1, <- ctree_eta, <- H.
      apply REL.
  - rewrite unfold_bind in H0; setoid_rewrite (ctree_eta t0).
    desobs t0.
    + right.
      exists r; split.
      constructor.
      rewrite <- H0.
      constructor.
      rewrite H, <- H1, ctree_eta; auto.
    + step in H0; dependent induction H0.
      left; split; [intros abs; inv abs |].
      exists (k1 x); split.
      econstructor; reflexivity.
      rewrite <- H1, <- ctree_eta, <- H.
      apply REL.
    + step in H0; inv H0.
  - rewrite unfold_bind in H; setoid_rewrite (ctree_eta t).
    desobs t.
    + right.
      exists r0; split.
      constructor.
      rewrite <- H, <- H0.
      constructor.
    + step in H; inv H.
    + step in H; inv H.
Qed.

Lemma trans_bind_inv {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l :
  trans l (t >>= k) u ->
  (~ (is_val l) /\ exists t', trans l t t' /\ u ≅ t' >>= k) \/
    (exists (x : X), trans (val x) t stuckD /\ trans l (k x) u).
Proof.
  intros TR.
  eapply trans_bind_inv_aux.
  apply TR.
  rewrite <- ctree_eta; reflexivity.
  rewrite <- ctree_eta; reflexivity.
Qed.

Lemma trans_bind_inv_l {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l :
  trans l (t >>= k) u ->
  exists l' t', trans l' t t'.
Proof.
  intros TR.
  apply trans_bind_inv in TR.
  destruct TR as [(? & ? & ? & ?) | (? & ? & ?)]; eauto.
Qed.

Lemma trans_bind_l {E B X Y} `{HasStuck : B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l :
  ~ (@is_val E l) ->
  trans l t u ->
  trans l (t >>= k) (u >>= k).
Proof.
  cbn; unfold transR; intros NOV TR.
  dependent induction TR; cbn in *.
  - rewrite unfold_bind, <- x.
    cbn.
    econstructor.
    now apply IHTR.
  - rewrite unfold_bind.
    rewrite <- x1; cbn.
    econstructor.
    rewrite H.
    rewrite (ctree_eta t0),x,<- ctree_eta.
    reflexivity.
  - rewrite unfold_bind.
    rewrite <- x1; cbn.
    econstructor.
    rewrite H.
    rewrite (ctree_eta t0),x,<- ctree_eta.
    reflexivity.
  - exfalso; eapply NOV; constructor.
Qed.

Lemma trans_bind_r {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l :
  trans (val x) t stuckD ->
  trans l (k x) u ->
  trans l (t >>= k) u.
Proof.
  cbn; unfold transR; intros TR1.
  genobs t ot.
  remember (observe stuckD) as oc.
  remember (val x) as v.
  revert t x Heqot Heqoc Heqv.
  induction TR1; intros; try (inv Heqv; fail).
  - rewrite (ctree_eta t0), <- Heqot; cbn; econstructor.
    eapply IHTR1; eauto.
  - dependent induction Heqv.
    rewrite (ctree_eta t), <- Heqot, unfold_bind; cbn; auto.
Qed.

Lemma is_stuck_bind : forall {E B X Y} `{B0 -< B}
                        (t : ctree E B X) (k : X -> ctree E B Y),
    is_stuck t -> is_stuck (bind t k).
Proof.
  repeat intro.
  apply trans_bind_inv in H1 as [].
  - destruct H1 as (? & ? & ? & ?).
    now apply H0 in H2.
  - destruct H1 as (? & ? & ?).
    now apply H0 in H1.
Qed.

(*|
Forward and backward rules for [wtrans] w.r.t. [bind]
-----------------------------------------------------
|*)

Lemma etrans_bind_inv {E B X Y} `{HasStuck : B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l :
  etrans l (t >>= k) u ->
  (~ (is_val l) /\ exists t', etrans l t t' /\ u ≅ t' >>= k) \/
    (exists (x : X), trans (val x) t stuckD /\ etrans l (k x) u).
Proof.
  intros TR.
  apply @etrans_case in TR as [ | (-> & ?)].
  - apply trans_bind_inv in H as [[? (? & ? & ?)]|( ? & ? & ?)]; eauto.
    left; split; eauto.
    eexists; split; eauto; apply trans_etrans; auto.
    right; eexists; split; eauto; apply trans_etrans; auto.
  - left; split.
    intros abs; inv abs.
    exists t; split; auto using enil; symmetry; auto.
Qed.

Lemma transs_bind_inv {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) :
  (trans tau)^* (t >>= k) u ->
  (exists t', (trans tau)^* t t' /\ u ≅ t' >>= k) \/
    (exists (x : X), wtrans (val x) t stuckD /\ (trans tau)^* (k x) u).
Proof.
  intros [n TR].
  revert t k u TR.
  induction n as [| n IH]; intros; subst.
  - cbn in TR.
    left; exists t; split.
    exists 0%nat; reflexivity.
    symmetry; auto.
  - destruct TR as [t1 TR1 TR2].
    apply trans_bind_inv in TR1 as [(_ & t2 & TR1 & EQ) | (x & TR1 & TR1')].
    + rewrite EQ in TR2; clear t1 EQ.
      apply IH in TR2 as [(t3 & TR2 & EQ')| (x & TR2 & TR3)].
      * left; eexists; split; eauto.
        apply wtrans_tau; eapply wcons; eauto.
        apply wtrans_tau; auto.
      * right; exists x; split; eauto.
        eapply wcons; eauto.
    + right.
      exists x; split.
      apply trans_wtrans; auto.
      exists (S n), t1; auto.
Qed.

(*|
Things are a bit ugly with [wtrans], we end up with three cases:
- the reduction entirely takes place in the prefix
- the computation spills over the continuation, with the label taking place
in the continuation
- the computation splills over the continuation, with the label taking place
in the prefix. This is a bit more annoying to express: we cannot necessarily
[wtrans l] all the way to a [Ret] as the end of the computation might contain
just before the [Ret] some invisible br nodes. We therefore have to introduce
the last visible state reached by [wtrans] and add a [trans (val _)] afterward.
|*)
Lemma wtrans_bind_inv {E B X Y} `{HasStuck : B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) l :
  wtrans l (t >>= k) u ->
  (~ (is_val l) /\ exists t', wtrans l t t' /\ u ≅ t' >>= k) \/
    (exists (x : X), wtrans (val x) t stuckD /\ wtrans l (k x) u) \/
    (exists (x : X) s, wtrans l t s /\ trans (val x) s stuckD /\ wtrans tau (k x) u).
Proof.
  intros TR.
  destruct TR as [t2 [t1 step1 step2] step3].
  apply transs_bind_inv in step1 as [(u1 & TR1 & EQ1)| (x & TR1 & TR1')].
  - rewrite EQ1 in step2; clear t1 EQ1.
    apply etrans_bind_inv in step2 as [(H & u2 & TR2 & EQ2)| (x & TR2 & TR2')].
    + rewrite EQ2 in step3; clear t2 EQ2.
      apply transs_bind_inv in step3 as [(u3 & TR3 & EQ3)| (x & TR3 & TR3')].
      * left; split; auto.
        eexists; split; eauto.
        exists u2; auto; exists u1; auto.
      * right; right.
        apply wtrans_val_inv in TR3 as (u3 & TR2' & TR2'').
        exists x, u3.
        split; [|split]; auto.
        2:apply wtrans_tau; auto.
        exists u2; [exists u1; assumption | ].
        apply wtrans_tau; apply wtrans_tau in TR1.
        eapply wconss; eauto.
    + right; left.
      exists x; split.
      eexists; [eexists |]; eauto; apply wtrans_tau, wnil.
      eexists; [eexists |]; eauto; apply wtrans_tau, wnil.
  - right; left.
    exists x; split; eauto.
    eexists; [eexists |]; eauto.
Qed.

Lemma etrans_bind_l {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l :
  ~ is_val l ->
  etrans l t u ->
  etrans l (t >>= k) (u >>= k).
Proof.
  destruct l; cbn; try apply trans_bind_l; auto.
  intros NOV [|].
  left; apply trans_bind_l; auto.
  right; rewrite H0; auto.
Qed.

Lemma transs_bind_l {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) :
  (trans tau)^* t u ->
  (trans tau)^* (t >>= k) (u >>= k).
Proof.
  intros [n TR].
  revert t u TR.
  induction n as [| n IH].
  - cbn; intros; exists 0%nat; cbn; rewrite TR; reflexivity.
  - intros t u [v TR1 TR2].
    apply IH in TR2.
    eapply wtrans_tau, wcons.
    apply trans_bind_l; eauto; intros abs; inv abs.
    apply wtrans_tau; eauto.
Qed.

Lemma wtrans_bind_l {E B X Y} `{B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B X) l :
  ~ (@is_val E l) ->
  wtrans l t u ->
  wtrans l (t >>= k) (u >>= k).
Proof.
  intros NOV [t2 [t1 TR1 TR2] TR3].
  eexists; [eexists |].
  apply transs_bind_l; eauto.
  apply etrans_bind_l; eauto.
  apply transs_bind_l; eauto.
Qed.

Lemma wtrans_case {E B X} `{HasStuck : B0 -< B} (t u : ctree E B X) l:
  wtrans l t u ->
  t ≅ u \/ (exists v, trans l t v /\ wtrans tau v u) \/ (exists v, trans tau t v /\ wtrans l v u).
Proof.
  intros [t2 [t1 [n TR1] TR2] TR3].
  destruct n as [| n].
  - apply wtrans_tau in TR3.
    cbn in TR1; rewrite <- TR1 in TR2.
    destruct l; eauto.
    destruct TR2; eauto.
    cbn in H; rewrite <- H in TR3.
    apply wtrans_tau in TR3.
    destruct TR3 as [[| n] ?]; eauto.
    destruct H0 as [? ? ?]; right; left; eexists; split; eauto.
    apply wtrans_tau; exists n; auto.
  - destruct TR1 as [? ? ?].
    right; right.
    eexists; split; eauto.
    exists t2; [exists t1|]; eauto.
    exists n; eauto.
Qed.

Lemma wtrans_case' {E B X} `{HasStuck : B0 -< B} (t u : ctree E B X) l:
  wtrans l t u ->
  match l with
  | tau => (t ≅ u \/ exists v, trans tau t v /\ wtrans tau v u)
  | _   => (exists v, trans l t v /\ wtrans tau v u) \/
            (exists v, trans tau t v /\ wtrans l v u)
  end.
Proof.
  intros [t2 [t1 [n TR1] TR2] TR3].
  destruct n as [| n].
  - apply wtrans_tau in TR3.
    cbn in TR1; rewrite <- TR1 in TR2.
    destruct l; eauto.
    destruct TR2; eauto.
    cbn in H; rewrite <- H in TR3.
    apply wtrans_tau in TR3.
    destruct TR3 as [[| n] ?]; eauto.
    destruct H0 as [? ? ?]; right; eexists; split; eauto.
    apply wtrans_tau; exists n; auto.
  - destruct TR1 as [? ? ?].
    destruct l; right.
    all:eexists; split; eauto.
    all:exists t2; [exists t1|]; eauto.
          all:exists n; eauto.
Qed.

Lemma wtrans_stuckD_inv {E B R} `{HasStuck : B0 -< B} :
  forall (t : ctree E B R) l,
    wtrans l stuckD t ->
    match l with | tau => t ≅ stuckD | _ => False end.
Proof.
  intros * TR.
  apply wtrans_case' in TR.
  destruct l; break; cbn in *.
  symmetry; auto.
  all: exfalso; eapply stuckD_is_stuck; now apply H.
Qed.

Lemma pwtrans_case {E B X} `{B0 -< B} (t u : ctree E B X) l:
  pwtrans l t u ->
  (exists v, trans l t v /\ wtrans tau v u) \/ (exists v, trans tau t v /\ wtrans l v u).
Proof.
  intros [t2 [t1 [n TR1] TR2] TR3].
  destruct n as [| n].
  - apply wtrans_tau in TR3.
    cbn in TR1; rewrite <- TR1 in TR2. eauto.
  - destruct TR1 as [? ? ?].
    right.
    eexists; split; eauto.
    exists t2; [exists t1|]; eauto.
    exists n; eauto.
    apply trans_etrans; auto.
Qed.

(*|
It's a bit annoying that we need two cases in this lemma, but if
[t = Guard (Ret x)] and [u = k x], we can process the [Guard] node
by taking the [Ret] in the prefix, but we cannot process it to
reach [u] in the bound computation.
|*)
Lemma wtrans_bind_r {E B X Y} `{HasStuck : B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l :
  wtrans (val x) t stuckD ->
  wtrans l (k x) u ->
  (u ≅ k x \/ wtrans l (t >>= k) u).
Proof.
  intros TR1 TR2.
  apply wtrans_val_inv in TR1 as (t' & TR1 & TR1').
  eapply wtrans_bind_l in TR1; [| intros abs; inv abs].
  apply wtrans_case in TR2 as [? | [|]].
  - left; symmetry; assumption.
  - right;eapply wconss; [apply TR1 | clear t TR1].
    destruct H as (? & ? & ?).
    eapply trans_bind_r in TR1'; eauto.
    eapply wsnocs; eauto.
    apply trans_wtrans; auto.
  - right;eapply wconss; [apply TR1 | clear t TR1].
    destruct H as (? & ? & ?).
    eapply trans_bind_r in TR1'; eauto.
    eapply wconss; [|eauto].
    apply trans_wtrans; auto.
Qed.

Lemma wtrans_bind_r' {E B X Y} `{HasStuck : B0 -< B} (t : ctree E B X) (k : X -> ctree E B Y) (u : ctree E B Y) x l :
  wtrans (val x) t stuckD ->
  pwtrans l (k x) u ->
  (wtrans l (t >>= k) u).
Proof.
  intros TR1 TR2.
  apply wtrans_val_inv in TR1 as (t' & TR1 & TR1').
  eapply wtrans_bind_l in TR1; [| intros abs; inv abs].
  apply pwtrans_case in TR2 as [? | ].
  - eapply wconss; [apply TR1 | clear t TR1].
    destruct H as (? & ? & ?).
    eapply trans_bind_r in TR1'; eauto.
    eapply wsnocs; eauto.
    apply trans_wtrans; auto.
  - eapply wconss; [apply TR1 | clear t TR1].
    destruct H as (? & ? & ?).
    eapply trans_bind_r in TR1'; eauto.
    eapply wconss; [|eauto].
    apply trans_wtrans; auto.
Qed.

Lemma trans_val_invT {E B R R'} `{B0 -< B}:
  forall (t u : ctree E B R) (v : R'),
    trans (val v) t u ->
    R = R'.
Proof.
  intros * TR.
  remember (val v) as ov.
  induction TR; intros; auto; try now inv Heqov.
Qed.

Lemma wtrans_bind_lr {E B X Y} `{B0 -< B} (t u : ctree E B X) (k : X -> ctree E B Y) (v : ctree E B Y) x l :
  pwtrans l t u ->
  wtrans (val x) u stuckD ->
  pwtrans tau (k x) v ->
  (wtrans l (t >>= k) v).
Proof.
  intros [t2 [t1 TR1 TR1'] TR1''] TR2 TR3.
  exists (x <- t2;; k x).
  - assert (~ is_val l).
    {
      destruct l; try now intros abs; inv abs.
      exfalso.
      pose proof (trans_val_invT TR1'); subst.
      apply trans_val_inv in TR1'.
      rewrite TR1' in TR1''.
      apply transs_is_stuck_inv in TR1''; [| apply stuckD_is_stuck].
      rewrite <- TR1'' in TR2.
      apply wtrans_is_stuck_inv in TR2; [| apply stuckD_is_stuck].
      destruct TR2 as [abs _]; inv abs.
    }
    eexists.
    2:apply trans_etrans, trans_bind_l; eauto.
    apply wtrans_tau; eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_tau; auto].
  - apply wtrans_tau.
    eapply wconss.
    eapply wtrans_bind_l; [intros abs; inv abs| apply wtrans_tau; eauto].
    eapply wtrans_bind_r'; eauto.
Qed.

Lemma trans_trigger : forall {E B X Y} `{B0 -< B} (e : E X) x (k : X -> ctree E B Y),
    trans (obs e x) (trigger e >>= k) (k x).
Proof.
  intros.
  unfold CTree.trigger.
  rewrite unfold_bind; cbn.
  setoid_rewrite bind_ret_l.
  constructor; auto.
Qed.

Lemma trans_trigger' : forall {E B X Y} `{B0 -< B} (e : E X) x (t : ctree E B Y),
    trans (obs e x) (trigger e;; t) t.
Proof.
  intros.
  unfold CTree.trigger.
  rewrite unfold_bind; cbn.
  setoid_rewrite bind_ret_l.
  constructor; auto.
Qed.

Lemma trans_trigger_inv : forall {E B X Y} `{HasStuck : B0 -< B} (e : E X) (k : X -> ctree E B Y) l u,
    trans l (trigger e >>= k) u ->
    exists x, u ≅ k x /\ l = obs e x.
Proof.
  intros * TR.
  unfold trigger in TR.
  apply trans_bind_inv in TR.
  destruct TR as [(? & ? & TR & ?) |(? & TR & ?)].
  - apply trans_vis_inv in TR.
    destruct TR as (? & ? & ->); eexists; split; eauto.
    rewrite H0, H1, bind_ret_l; reflexivity.
  - apply trans_vis_inv in TR.
    destruct TR as (? & ? & abs); inv abs.
Qed.

(*|
[wf_val] states that a [label] is well-formed:
if it is a [val] it should be of the right type.
|*)
Definition wf_val {E} X l := forall Y (v : Y), l = @val E Y v -> X = Y.

Lemma wf_val_val {E} X (v : X) : wf_val X (@val E X v).
Proof.
  red. intros. apply val_eq_invT in H. assumption.
Qed.

Lemma wf_val_nonval {E} X (l : @label E) : ~is_val l -> wf_val X l.
Proof.
  red. intros. subst. exfalso. apply H. constructor.
Qed.

Lemma wf_val_trans {E B X} `{B0 -< B} (l : @label E) (t t' : ctree E B X) :
  trans l t t' -> wf_val X l.
Proof.
  red. intros. subst.
  now apply trans_val_invT in H0.
Qed.

(*| If the LTS has events of type [L +' R] then
  it is possible to step it as either an [L] LTS
  or [R] LTS ignoring the other.
 |*)
Section Coproduct.
  Arguments label: clear implicits.
  Context {L R C: Type -> Type} {X: Type} {HasStuck: B0 -< C}.
  Notation S := (ctree (L +' R) C X).
  Notation S' := (ctree' (L +' R) C X).
  Notation SP := (SS -> label (L +' R) -> Prop).

  (* Skip an [R] event *)
  Inductive srtrans_: rel S' S' :=
  | IgnoreR {X} (e : R X) k x t :
    srtrans_ (observe (k x)) t ->
    srtrans_ (VisF (inr1 e) k) t.

  (* Skip an [L] event *)
  Inductive sltrans_: rel S' S' :=
  | IgnoreL {X} (e : L X) k x t :
    sltrans_ (observe (k x)) t ->
    sltrans_ (VisF (inl1 e) k) t.

  Hint Constructors srtrans_ sltrans_: core.

  (* Make those relations that respect equality [srel] *)
  Program Definition srtrans : srel SS SS :=
    {| hrel_of := (fun (u v: SS) => srtrans_ (observe u) (observe v)) |}.
  Next Obligation. split; induction 1; auto. Defined.

  Program Definition sltrans : srel SS SS :=
    {| hrel_of := (fun (u v: SS) => sltrans_ (observe u) (observe v)) |}.
  Next Obligation. split; induction 1; auto. Defined.

  (*| Obs transition on the left, ignores right transitions and [tau] |*)
  Definition ltrans {X}(l: L X)(x: X): srel SS SS :=
    (trans tau ⊔ srtrans)^* ⋅ trans (obs (inl1 l) x) ⋅ (trans tau ⊔ srtrans)^*.

  (*| Obs transition on the right, ignores left transitions and [tau] |*)
  Definition rtrans {X}(r: R X)(x: X): srel SS SS :=
    (trans tau ⊔ sltrans)^* ⋅ trans (obs (inr1 r) x) ⋅ (trans tau ⊔ sltrans)^*.

End Coproduct.

(*|
[inv_trans] is an helper tactic to automatically
invert hypotheses involving [trans].
|*)

#[local] Notation trans' l t u := (hrel_of (trans l) t u).

Ltac inv_trans_one :=
  match goal with

  (* Ret *)
  | h : trans' _ (Ret ?x) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_ret_inv in h as [?EQ EQl];
      match type of EQl with
      | val _   = val _ => apply val_eq_inv in EQl; try (inversion EQl; fail)
      | tau     = val _ => now inv EQl
      | obs _ _ = val _ => now inv EQl
      | _ => idtac
      end

  (* Vis *)
  | h : trans' _ (Vis ?e ?k) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_vis_inv in h as (?x & ?EQ & EQl);
      match type of EQl with
      | @obs _ ?X _ _ = obs _ _ =>
          let EQt := fresh "EQt" in
          let EQe := fresh "EQe" in
          let EQv := fresh "EQv" in
          apply obs_eq_invT in EQl as EQt;
          subst_hyp_in EQt h;
          apply obs_eq_inv in EQl as [EQe EQv];
          try (inversion EQv; inversion EQe; fail)
      | val _   = obs _ _ => now inv EQl
      | tau     = obs _ _ => now inv EQl
      | _ => idtac
      end

  (* Step *)
  | h : trans' _ (Step _) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_step_inv in h as (?EQ & EQl);
      match type of EQl with
      | tau     = tau => clear EQl
      | val _   = tau => now inv EQl
      | obs _ _ = tau => now inv EQl
      | _ => idtac
      end

  (* BrS *)
  | h : trans' _ (BrS ?n ?k) _ |- _ =>
      let x := fresh "x" in
      let EQl := fresh "EQl" in
      apply trans_brS_inv in h as (x & ?EQ & EQl);
      match type of EQl with
      | tau     = tau => clear EQl
      | val _   = tau => now inv EQl
      | obs _ _ = tau => now inv EQl
      | _ => idtac
      end

  (* brS2 *)
  | h : trans' _ (brS2 _ _) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_brS2_inv in h as (EQl & [?EQ | ?EQ]);
      match type of EQl with
      | tau     = tau => clear EQl
      | val _   = tau => now inv EQl
      | obs _ _ = tau => now inv EQl
      | _ => idtac
      end

  (* brS3 *)
  | h : trans' _ (brS3 _ _ _) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_brS3_inv in h as (EQl & [?EQ | [?EQ | ?EQ]]);
      match type of EQl with
      | tau     = tau => clear EQl
      | val _   = tau => now inv EQl
      | obs _ _ = tau => now inv EQl
      | _ => idtac
      end

  (* brS4 *)
  | h : trans' _ (brS4 _ _ _ _) _ |- _ =>
      let EQl := fresh "EQl" in
      apply trans_brS4_inv in h as (EQl & [?EQ | [?EQ | [?EQ | ?EQ]]]);
      match type of EQl with
      | tau     = tau => clear EQl
      | val _   = tau => now inv EQl
      | obs _ _ = tau => now inv EQl
      | _ => idtac
      end

  (* Guard *)
  | h : trans' _ (Guard _) _ |- _ =>
      apply trans_guard_inv in h

  (* BrD *)
  | h : trans' _ (BrD ?n ?k) _ |- _ =>
      let x := fresh "x" in
      apply trans_brD_inv in h as (x & ?TR)

  (* brD2 *)
  | h : trans' _ (brD2 _ _) _ |- _ =>
      apply trans_brD2_inv in h as [?TR | ?TR]

  (* brD3 *)
  | h : trans' _ (brD3 _ _ _) _ |- _ =>
      apply trans_brD3_inv in h as [?TR | [?TR | ?TR]]

  (* brD4 *)
  | h : trans' _ (brD4 _ _ _ _) _ |- _ =>
      apply trans_brD4_inv in h as [?TR | [?TR | [?TR | ?TR]]]

  (* stuckD *)
  | h : trans' _ stuckD _ |- _ =>
      exfalso; eapply stuckD_is_stuck; now apply h
  (* stuckS *)
  | h : trans' _ stuckS _ |- _ =>
      exfalso; eapply stuckS_is_stuck; now apply h

  (* trigger *)
  | h : trans' _ (CTree.bind (CTree.trigger ?e) ?t) _ |- _ =>
      apply trans_trigger_inv in h as (?x & ?EQ & ?EQl)

  end; try subs
.

Ltac inv_trans := repeat inv_trans_one.

Create HintDb trans.
#[global] Hint Resolve
 trans_ret trans_vis trans_brS trans_brD
 trans_guard
 trans_brD21 trans_brD22
 trans_brD31 trans_brD32 trans_brD33
 trans_brD41 trans_brD42 trans_brD43 trans_brD44
 trans_step
 trans_brS21 trans_brS22
 trans_brS31 trans_brS32 trans_brS33
 trans_brS41 trans_brS42 trans_brS43 trans_brS44
 trans_trigger trans_bind_l trans_bind_r
  : trans.

#[global] Hint Constructors is_val : trans.
#[global] Hint Resolve
  is_val_tau is_val_obs
  wf_val_val wf_val_nonval wf_val_trans : trans.

Ltac etrans := eauto with trans.


Section Minimal_propositional_logic.

Variables P Q R T : Prop.

Section example_of_assumption.
  Hypothesis H : P -> Q -> R.

  Lemma L1 : P -> Q -> R.
  Proof.
    assumption.
  Qed.

End example_of_assumption.

Theorem delta : (P -> P -> Q) -> P -> Q.
Proof (fun (H : P -> P -> Q) (p : P) => (H p) p).

Theorem apply_example : (Q -> R -> T) -> (P -> Q) -> P -> R -> T.
Proof.
  intros H H0 p.
  apply H.
  exact (H0 p).
Qed.

Theorem imp_dist : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros H H' p.
  apply H.
  - assumption.
  - apply H'. assumption.
Qed.

(* Exercise 3.2, p58, and Exercise 3.3, p65 *)

Lemma id_P : P -> P.
Proof.
  intro. assumption.
Qed.

Lemma id_P' : P -> P.
Proof.
  intro; assumption.
Qed.

Lemma id_PP : (P -> P) -> (P -> P).
Proof.
  intro. assumption.
Qed.

Lemma id_PP' : (P -> P) -> (P -> P).
Proof.
  intro; assumption.
Qed.

Lemma imp_trans : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros H H' p.
  apply H'. apply H. assumption.
Qed.

Lemma imp_trans' : (P -> Q) -> (Q -> R) -> P -> R.
Proof.
  intros H H' p; apply H'; apply H; assumption.
Qed.

Lemma imp_perm : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros H q p.
  apply H.
  - assumption.
  - assumption.
Qed.

Lemma imp_perm' : (P -> Q -> R) -> (Q -> P -> R).
Proof.
  intros H q p; apply H; assumption.
Qed.

Lemma ignore_Q : (P -> R) -> P -> Q -> R.
Proof.
  intros H p _.
  apply H. assumption.
Qed.

Lemma ignore_Q' : (P -> R) -> P -> Q -> R.
Proof.
  intros H p _; apply H; assumption.
Qed.

Lemma delta_imp : (P -> P -> Q) -> P -> Q.
Proof.
  intros H p.
  apply H.
  - assumption.
  - assumption.
Qed.

Lemma delta_imp' : (P -> P -> Q) -> P -> Q.
Proof.
  intros H p; apply H; assumption.
Qed.

Lemma delta_impR : (P -> Q) -> (P -> P -> Q).
Proof.
  intros H p _.
  apply H. assumption.
Qed.

Lemma delta_impR' : (P -> Q) -> (P -> P -> Q).
Proof.
  intros H p _; apply H; assumption.
Qed.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros H H' H'' p.
  apply H''.
  - apply H. assumption.
  - apply H'. assumption.
Qed.

Lemma diamond' : (P -> Q) -> (P -> R) -> (Q -> R -> T) -> P -> T.
Proof.
  intros H H' H'' p; apply H''; [apply H | apply H']; assumption.
Qed.

Lemma weak_peirce : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros H. apply H.
  intros H'. apply H'.
  intro p.
  apply H.
  intros _. assumption.
Qed.

Lemma weak_peirce' : ((((P -> Q) -> P) -> P) -> Q) -> Q.
Proof.
  intros H; apply H; intros H'; apply H';
  intro p; apply H; intros _; assumption.
Qed.

(* End of Exercise 3.2 and Exercise 3.3 *)

Definition f : (nat -> bool) -> (nat -> bool) -> nat -> bool.
  intros f1 f2.
  assumption.
Defined.

Print f.

Eval compute in (f (fun n => true) (fun n => false) 45).

Opaque f.

Eval compute in (f (fun n => true) (fun n => false) 45).

Section proof_of_triple_impl.
  (*  (((P -> Q) -> Q) -> Q) -> P -> Q *)
  Hypothesis H : ((P -> Q) -> Q) -> Q.
  Hypothesis p : P.

  Lemma Rem : (P -> Q) -> Q.
  Proof (fun H0 : P -> Q => H0 p).

  Theorem triple_impl : Q.
  Proof (H Rem).

End proof_of_triple_impl.

Print triple_impl.

Print Rem.

Theorem then_example : P -> Q -> (P -> Q -> R) -> R.
Proof.
  intros p q H.
  apply H; assumption.
Qed.

Theorem triple_impl_one_shot : (((P -> Q) -> Q) -> Q) -> P -> Q.
Proof.
  intros H p; apply H; intro H0; apply H0; assumption.
Qed.

Theorem compose_example : (P -> Q -> R) -> (P -> Q) -> (P -> R).
Proof.
  intros H H' p.
  apply H; [assumption | apply H'; assumption].
Qed.

Theorem orelse_example :
  (P -> Q) -> R -> ((P -> Q) -> R -> (T -> Q) -> T) -> T.
Proof.
  intros H r H0.
  apply H0; (assumption || intro H1).
Abort.

Lemma L3 : (P -> Q) -> (P -> R) -> (P -> Q -> R -> T) -> P -> T.
Proof.
  intros H H0 H1 p.
  apply H1; [idtac | apply H | apply H0]; assumption.
Qed.

Theorem then_fail_example : (P -> Q) -> (P -> Q).
Proof.
  intros X; apply X; fail.
Qed.

Theorem then_fail_example2 : ((P -> P) -> (Q -> Q) -> R) -> R.
Proof.
  (* intro X; apply X; fail. -- Error: Tactic failure *)
Abort.

Theorem try_example : (P -> Q -> R -> T) -> (P -> Q) -> (P -> R -> T).
Proof.
  intros H H' p r.
  apply H; try assumption.
  apply H'; assumption.
Qed.

Section section_for_cut_example.
  Hypotheses (H : P -> Q)
             (H0 : Q -> R)
             (H1 : (P -> R) -> T -> Q)
             (H2 : (P -> R) -> T).

Theorem cut_example : Q.
Proof.
  cut (P -> R).
  intro H3.
  apply H1;  [assumption | apply H2; assumption].
  intro; apply H0; apply H; assumption.
Qed.

Print cut_example.

(* Exercise 3.5 *)
Theorem cut_example' : Q.
Proof.
  apply H1.
  - intro p; apply H0; apply H; assumption.
  - apply H2; intro p; apply H0; apply H; assumption.
Qed.

Print cut_example'.

End section_for_cut_example.

(* Auto tactic *)

Theorem triple_impl2 : (((P -> Q) -> Q) -> Q) -> P -> Q.
Proof.
  auto.
Qed.

Print triple_impl2.

End Minimal_propositional_logic.

Print imp_dist.

Print triple_impl.

Section using_imp_dist.

Variables (P1 P2 P3 : Prop).
Check (imp_dist P1 P2 P3).

Check (imp_dist (P1 -> P2) (P2 -> P3) (P3 -> P1)).

End using_imp_dist.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Class SepconSemantics
      (L: Language)
      {sepconL: SepconLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_sepcon: forall x y, Same_set _ (Kdenotation M (x * y)) (WeakSemantics.sepcon (Kdenotation M x) (Kdenotation M y)).

Class WandSemantics
      (L: Language)
      {wandL: WandLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_wand: forall x y, Same_set _ (Kdenotation M (x -* y)) (StrongSemantics.wand (Kdenotation M x) (Kdenotation M y)).

Class EmpSemantics
      (L: Language)
      {empL: EmpLanguage L}
      (MD: Model)
      {kMD: KripkeModel MD}
      (M: Kmodel)
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      (SM: Semantics L MD): Type :=
  denote_emp: Same_set _ (Kdenotation M emp) StrongSemantics.emp.

Lemma sat_sepcon
      {L: Language}
      {sepconL: SepconLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {usepconSM: SepconSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x * y <->
    exists m1 m2, join m1 m2 m /\
                  KRIPKE: M , m1 |= x /\
                  KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_sepcon x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_wand
      {L: Language}
      {wandL: WandLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {uwandSM: WandSemantics L MD M SM}:
  forall m x y,
    KRIPKE: M , m |= x -* y <->
    forall m0 m1 m2, m <= m0 ->
                     join m0 m1 m2 ->
                     KRIPKE: M , m1 |= x ->
                     KRIPKE: M, m2 |= y.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct (denote_wand x y).
  split; [apply H | apply H0].
Qed.

Lemma sat_emp
      {L: Language}
      {empL: EmpLanguage L}
      {MD: Model}
      {kMD: KripkeModel MD}
      {M: Kmodel}
      {R: Relation (Kworlds M)}
      {J: Join (Kworlds M)}
      {SM: Semantics L MD}
      {uempSM: EmpSemantics L MD M SM}:
  forall (m: Kworlds M), KRIPKE: M, m |= emp <-> increasing' m.
Proof.
  intros; simpl.
  unfold satisfies.
  destruct denote_emp.
  split; [apply H | apply H0].
Qed.


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery32_2e389m21_13limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition add :
  { add : feBW_small -> feBW_small -> feBW_small
  | forall a b, phiM_small (add a b) = F.add (phiM_small a) (phiM_small b) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_add ().
  Show Ltac Profile.
Time Defined.

Print Assumptions add.


Require Import VerifiedNatIntf.
Require Import CanonicalArrImpl CommutingArrayIntf.

Set Implicit Arguments.

(* An implementation of CommutingArrayInterface using the definitions in
 * CanonicalArrayImpl. Of course, all of the commutativity properties hold
 * trivially. *)
Module CommutingCanonicalArrayImpl (N : VerifiedNatInterface)
    : CommutingArrayInterface N.
  Module Canon := CanonicalArrayImpl N.
  Definition M := Canon.M.
  Definition make := Canon.make.
  Definition len := Canon.len.
  Definition get := Canon.get.
  Definition set := Canon.set.
  Definition concat := Canon.concat.

  Definition convert A (m:M A) := m.

  Lemma make_commutes : forall (A : Type) n (x : A),
      convert (make n x) = Canon.make n x.
    auto.
  Defined.

  Lemma len_commutes : forall (A : Type) (l : M A),
      len l =  Canon.len (convert l).
    auto.
  Defined.

  Lemma get_commutes : forall A (l : M A) index,
      get l index = Canon.get (convert l) index.
    auto.
  Defined.

  Lemma set_commutes : forall A (l : M A) index x,
      convert (set l index x) = Canon.set (convert l) index x.
    auto.
  Defined.

  Lemma concat_commutes : forall A (l : M A) (l' : M A),
      convert (concat l l') = Canon.concat (convert l) (convert l').
    auto.
  Defined.
End CommutingCanonicalArrayImpl.