(************************************************************************)
(* Copyright (c) 2021, Gergei Bana and Qianli Zhang                     *)
(*                                                                      *)
(* This work is licensed under the MIT license. The license is          *)
(* described in the file "LICENSE" available at the root of the source  *)
(* or at https://opensource.org/licenses/MIT                            *)
(************************************************************************)

Require Import Core.
Require Import Pair.

(*  *)

Definition Blindness_prop (z : list ppt) (m0 m1 t n0 n1 : ppt) (t0 t1 : list ppt -> ppt)
           (blind brand acc ub: list ppt -> ppt ) (bot : ppt) : Prop :=
  Fresh n0 (m0 :: m1 :: t :: z) -> FreshTermc n0 t0 -> FreshTermc n0 t1 ->
  Fresh n1 (m0 :: m1 :: t :: z) -> FreshTermc n1 t0 -> FreshTermc n1 t1 ->
  let bn0 := brand [n0] in
  let bn1 := brand [n1] in
  let ti0 := t0 [blind [m0; t; bn0]; blind [m1; t; bn1]] in
  let ti1 := t1 [blind [m1; t; bn0]; blind [m0; t; bn1]] in
  z ++ [blind [m0; t; bn0]; blind [m1; t; bn1]; If acc [m0; t; bn0; ti0] & acc [m1; t; bn1; ti0]
                                                        Then ＜ ub [m0; t; bn0; ti0], ub [m1; t; bn1; ti0] ＞ Else ( ＜ bot, bot ＞)]
  ~
  z ++ [blind [m1; t; bn0]; blind [m0; t; bn1]; If acc [m1; t; bn0; ti1] & acc [m0; t; bn1; ti1]
                                                        Then ＜ ub [m0; t; bn1; ti1], ub [m1; t; bn0; ti1] ＞ Else (＜ bot, bot ＞)].

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

Inductive UbNUDContextTerm (bn: ppt) (blind brand: list ppt -> ppt) : ppt -> Prop :=
| UbNUDAttContListTerm :
  forall (tl : list ppt) (f : list ppt -> ppt),
    ContextTerm Adversarial List f ->
    UbNUDContext bn blind brand tl ->
    UbNUDContextTerm bn blind brand (f tl)
| UbNUDBlindSign :
  forall (t1 t: ppt) ,
    FreshTerm bn t1 ->
    FreshTerm bn t ->
    UbNUDContextTerm bn blind brand (blind [t1; t; (brand [bn])])
with UbNUDContext (bn : ppt) (blind brand: list ppt -> ppt): list ppt -> Prop :=
| UbNUDFresh :
  forall tl ,
    Fresh bn tl ->
    UbNUDContext bn blind brand tl
| UbNUDContextConc :
  forall (u : ppt) (ul2 : list ppt),
    UbNUDContextTerm bn blind brand u ->
    UbNUDContext bn blind brand ul2 ->
    UbNUDContext bn blind brand (u :: ul2).

(*  *)

Proposition UbNUDFreshTerm : forall t bn blind brand,
    FreshTerm bn t -> UbNUDContextTerm bn blind brand t.
Proof.
  intros.
  apply (frConc bn t []) in H.
  apply (UbNUDFresh bn blind brand [t]) in H.
  apply (UbNUDAttContListTerm bn blind brand [t] (fun lx => Nth 0 lx)) in H.
  unfold Nth in H; simpl in H.
  auto.
  ProveContext.
  ProveFresh.
Qed.

(* original constructive rule *)

Proposition UbNUDContextApp : forall bn, forall ul1 ul2 : list ppt, forall blind brand,
     UbNUDContext bn blind brand ul1 -> UbNUDContext bn blind brand ul2 -> UbNUDContext bn blind brand (ul1 ++ ul2).
Proof.
  intros.
  induction ul1.
  - simpl. auto.
  - inversion H.
    + inversion H1.
      apply (UbNUDFresh bn blind brand) in H7.
      apply (UbNUDFreshTerm a bn blind brand) in H6.
      apply IHul1 in H7.
      simpl. apply UbNUDContextConc; auto.
    + apply IHul1 in H4.
      simpl. apply UbNUDContextConc; auto.
Qed.

(*  *)
Definition UbNotUndefined_prop (t1 t n0 t2 : ppt)
           (blind brand acc ub: list ppt -> ppt ) (bot : ppt) : Prop :=
  let bn0 := brand [n0] in
  Fresh n0 [t; t1] ->
  UbNUDContextTerm n0 blind brand t2 ->
  ((acc [t1; t; bn0; t2]) & (ub [t1; t; bn0; t2] ≟ bot)) = FAlse.


Require Import Fiat.Parsers.Reflective.Syntax.
Require Import Fiat.Parsers.Reflective.Semantics.
Require Import Fiat.Common.List.Operations.
Set Implicit Arguments.

Local Open Scope list_scope.

Module opt.
  Definition map {A B} := Eval cbv [List.map] in @List.map A B.
  Definition fold_left {A B} := Eval cbv [List.fold_left] in @List.fold_left A B.
  Definition nth' {A} := Eval cbv [nth'] in @List.nth' A.

  Definition interp_RLiteralTerm {T} (t : RLiteralTerm T) : interp_TypeCode T
    := Eval cbv [interp_RLiteralTerm] in
        match t with
        | RLC t'
          => interp_RLiteralTerm (RLC t')
        | RLNC t'
          => match t' in (RLiteralNonConstructor T') return interp_TypeCode T' with
             | Rnth' _ => nth'
             | Rmap _ _ => @map _ _
             | Rfold_left _ _ => @fold_left _ _
             | t'' => interp_RLiteralTerm (RLNC t'')
             end
        end.

  Definition interp_Term {T} (t : Term interp_TypeCode T) : interp_TypeCode T
    := interp_Term_gen (@interp_RLiteralTerm) t.
End opt.


Require Import Arith.
Require Import List.
Require Import String.
Require Import Ascii.
Require Import PipeGraph.Debug.
Require Import PipeGraph.Util.
Require Import PipeGraph.StringUtil.
Require Import PipeGraph.Instruction.
Require Import PipeGraph.Graph.
Require Import PipeGraph.FOLPredicate.
Require Import PipeGraph.GraphvizCompressed.

Open Scope string_scope.

Import ListNotations.

Inductive ISAPattern : Set :=
| Rel : ISAEdge -> ISAPattern
| Chain : ISAPattern -> ISAPattern -> ISAPattern
| Union : ISAPattern -> ISAPattern -> ISAPattern
| Intersection : ISAPattern -> ISAPattern -> ISAPattern (* currently unsupported *)
| TranClos : ISAPattern -> ISAPattern
| ReflClos : ISAPattern -> ISAPattern
| ReflTranClos : ISAPattern -> ISAPattern.

(* Restrict ourselves to irr(x) and irr(tranclosure(x)) i.e. acyclic for now. *)
Inductive ISAAxiom : Set :=
| Irr : ISAPattern -> ISAAxiom.

Definition Acyclic
  (a : ISAPattern)
  : ISAAxiom :=
  Irr (TranClos a).

Definition beq_isa_edge
  (a b : ISAEdge)
  : bool :=
  match (a, b) with
  | (EdgePO, EdgePO)
  | (EdgeCO, EdgeCO)
  | (EdgeRF, EdgeRF)
  | (EdgeFR, EdgeFR)
  | (EdgeRFE, EdgeRFE)
  | (EdgeFRE, EdgeFRE)
  | (EdgePO_loc, EdgePO_loc)
  | (EdgePO_plus, EdgePO_plus)
  | (EdgePO_loc_plus, EdgePO_loc_plus)
  | (EdgeFence, EdgeFence)
  | (EdgeToFence, EdgeToFence)
  | (EdgeFromFence, EdgeFromFence)
  | (EdgeFence_plus, EdgeFence_plus)
  | (EdgeFencePO_plus, EdgeFencePO_plus)
  | (EdgePOFence_plus, EdgePOFence_plus)
  | (EdgePPO, EdgePPO)
  | (EdgePPO_plus, EdgePPO_plus)
  | (EdgePPOFence_plus, EdgePPOFence_plus)
  | (EdgeFencePPO_plus, EdgeFencePPO_plus) =>
      true
  | _ => false
  end.

Definition PrintISAEdge
  (a : ISAEdge)
  : string :=
  match a with
  | EdgePO => "po"
  | EdgeCO => "co"
  | EdgeRF => "rf"
  | EdgeFR => "fr"
  | EdgeRFE => "rfe"
  | EdgeFRE => "fre"
  | EdgePO_loc => "po_loc"
  | EdgePO_plus => "po+"
  | EdgePO_loc_plus => "po_loc+"
  | EdgeFence => "fence"
  | EdgeToFence => "to_fence"
  | EdgeFromFence => "from_fence"
  | EdgeFence_plus => "fence+"
  | EdgeFencePO_plus => "fence_po+"
  | EdgePOFence_plus => "po_fence+"
  | EdgePPO => "ppo"
  | EdgePPO_plus => "ppo+"
  | EdgePPOFence_plus => "ppo_fence+"
  | EdgeFencePPO_plus => "fence_ppo+"
  end.

(* What is the ISA edge in uspec land? *)
Definition GetISAEdgeString
  (a : ISAEdge)
  : string :=
  match a with
  | EdgePO => "po"
  | EdgeCO => "co"
  | EdgeRF => "rf"
  | EdgeFR => "fr"
  | EdgeRFE => "rfe"
  | EdgeFRE => "fre"
  | EdgePO_loc => "po_loc"
  | EdgePO_plus => "po_plus"
  | EdgePO_loc_plus => "po_loc_plus"
  | EdgeFence => "fence"
  | EdgeToFence => "to_fence"
  | EdgeFromFence => "from_fence"
  | EdgeFence_plus => "fence_plus"
  | EdgeFencePO_plus => "fence_po_plus"
  | EdgePOFence_plus => "po_fence_plus"
  | EdgePPO => "ppo"
  | EdgePPO_plus => "ppo_plus"
  | EdgePPOFence_plus => "PPOFence_plus"
  | EdgeFencePPO_plus => "FencePPO_plus"
  end.

Fixpoint ContainsEmptyChoice
  (l : list ((list ISAEdge) * option ISAPattern))
  : bool :=
  match l with
  | [] => false
  | h::t => match h with
            | ([], None) => true
            | _ => ContainsEmptyChoice t
            end
  end.

Definition IncludeEmptyChoice
  (l : list (list ISAEdge * option ISAPattern))
  : list (list ISAEdge * option ISAPattern) :=
  if ContainsEmptyChoice l then l else (([], None)::l).

(* ([], None) represents an empty choice. *)
(* Note: I'm assuming that (x?)+ will always be provided to me as x*. *)
Fixpoint GetInitialEdge
  (truncate : bool)
  (n : nat)
  (pat : ISAPattern)
  : list ((list ISAEdge) * option ISAPattern) :=
  let addChainHalfInitial (n'' : nat) (half : ISAPattern) (left : list ISAEdge * option ISAPattern)
    : list (list ISAEdge * option ISAPattern) :=
    match left with
    | ([], None) =>
        (* An empty choice. We need to replace it with GetInitialEdge (half). *)
        GetInitialEdge truncate n'' half
    | (a, None) => [(a, Some half)]
    | (a, Some left') => [(a, Some (Chain left' half))]
    end
  in
  match n with
  | S n' =>
    match pat with
    | Rel edge => [([edge], None)]
    | Chain x y => let a := GetInitialEdge truncate n' x in
                   let b := Map (addChainHalfInitial n' y) a in
                   fold_left app_rev b []
    | Union x y => app_tail (GetInitialEdge truncate n' x) (GetInitialEdge truncate n' y)
    | Intersection x y => Warning [] ["Intersection currently unsupported!"]
    | TranClos x => let a := GetInitialEdge truncate n' x in
                    let b :=
                      if truncate then
                        [a]
                      else
                        Map (addChainHalfInitial n' (ReflTranClos x)) a
                    in
                    fold_left app_rev b []
    | ReflClos x => IncludeEmptyChoice (GetInitialEdge truncate n' x)
    (* Either we provide x's choices with nothing after them except the rest of x,
       or x's choices with another (ReflTranClos x) after whatever's left of x,
       or nothing at all (the reflexive closure kicking in). *)
    | ReflTranClos x => let a := GetInitialEdge truncate n' x in
                        let b :=
                          if truncate then
                            []
                          else
                            Map (addChainHalfInitial n' (ReflTranClos x)) a
                        in
                        let c := fold_left app_rev b [] in
                        IncludeEmptyChoice (app_tail c a)
    end
  | O => Warning [] ["Recursed too deep in GetInitialEdge!"]
  end.

Fixpoint GetFinalEdge
  (n : nat)
  (pat : ISAPattern)
  : list ((list ISAEdge) * option ISAPattern) :=
  let addChainHalfFinal (n'' : nat) (half : ISAPattern) (left : list ISAEdge * option ISAPattern)
    : list (list ISAEdge * option ISAPattern) :=
    match left with
    | ([], None) =>
        (* An empty choice. We need to replace it with GetFinalEdge(half). *)
        GetFinalEdge n'' half
    | (a, None) => [(a, Some half)]
    | (a, Some left') => [(a, Some (Chain half left'))]
    end
  in
  match n with
  | S n' =>
    match pat with
    | Rel edge => [([edge], None)]
    | Chain x y => let a := GetFinalEdge n' y in
                   let b := Map (addChainHalfFinal n' x) a in
                   fold_left app_rev b []
    | Union x y => app_tail (GetFinalEdge n' x) (GetFinalEdge n' y)
    | Intersection x y => Warning [] ["Intersection currently unsupported!"]
    | TranClos x => let a := GetFinalEdge n' x in
                    let b := Map (addChainHalfFinal n' (ReflTranClos x)) a in
                    fold_left app_rev b []
    | ReflClos x => IncludeEmptyChoice (GetFinalEdge n' x)
    (* Either we provide x's choices with nothing before them except the rest of x,
       or x's choices with another (ReflTranClos x) before whatever's left of x,
       or nothing at all (the reflexive closure kicking in). *)
    | ReflTranClos x => let a := GetFinalEdge n' x in
                        let b := Map (addChainHalfFinal n' (ReflTranClos x)) a in
                        let c := fold_left app_rev b [] in
                        IncludeEmptyChoice (app_tail c a)
    end
  | O => Warning [] ["Recursed too deep in GetFinalEdge!"]
  end.

Fixpoint beq_pattern
  (a b : ISAPattern)
  : bool :=
  match (a, b) with
  | (Rel x, Rel x') => beq_isa_edge x x'
  | (Chain x y, Chain x' y')
  | (Union x y, Union x' y')
  | (Intersection x y, Intersection x' y') =>
      andb (beq_pattern x x') (beq_pattern y y')
  | (TranClos x, TranClos x')
  | (ReflClos x, ReflClos x')
  | (ReflTranClos x, ReflTranClos x') =>
      beq_pattern x x'
  | _ => false
  end.

Definition GetISAEdges
  (tups : list (list ISAEdge * option ISAPattern))
  : list (list ISAEdge) :=
  let f x :=
    match x with
    | (y, z) => y
    end
  in
  Map f tups.

Definition GetISAChains
  (tups : list (list ISAEdge * option ISAPattern))
  : list ISAPattern :=
  let f x :=
    match x with
    | (y, z) => z
    end
  in
  let g x y :=
    match y with
    | None => x
    | Some y' => (y'::x)
    end
  in
  let chains := Map f tups in
  fold_left g chains [].

Definition FilterDups
  (l : list ISAPattern)
  : list ISAPattern :=
  let f x y :=
    if find (beq_pattern y) x then x else (y::x)
  in
  fold_left f l [].

Fixpoint GetAllSubchains
  (n : nat)
  (ret : list ISAPattern)
  (pat : ISAPattern)
  : list ISAPattern :=
  let h x y :=
    if find (beq_pattern y) x then false else true
  in
  match n with
  | S n' =>
      (* Add the current chain. *)
      let ret := (pat::ret) in
      (* Find all subchains that you can get by hacking one chunk off the end of the chain. *)
      let subchains := FilterDups (GetISAChains (GetFinalEdge 100 pat)) in
      (* Filter them so we're left with just new subchains. *)
      let subchains := filter (h ret) subchains in
      (* Fold over all the new subchains. *)
      fold_left (GetAllSubchains n') subchains ret
  | O => Warning [] ["Recursed too deep in GetAllSubchains!"]
  end.

Definition GetAllTranChains
  (pat : ISAPattern)
  : list ISAPattern :=
  (* Rip off the last step of the pattern in all possible ways. *)
  GetISAChains (GetFinalEdge 100 pat).

Definition FoldISAChains
  (pat pat' : list ISAPattern)
  : list ISAPattern :=
  let h x y :=
    if find (beq_pattern y) x then false else true
  in
  app_tail pat (filter (h pat) pat').

Fixpoint CanBeNull
  (pat : ISAPattern)
  : bool :=
  match pat with
  | Rel edge => false
  | Chain x y =>
      andb (CanBeNull x) (CanBeNull y)
  | Union x y => orb (CanBeNull x) (CanBeNull y)
  | Intersection x y => Warning false ["Intersection currently unsupported!"]
  | TranClos x => false
  | ReflClos x => true
  | ReflTranClos x => true
  end.

Fixpoint GetSingleEdgeChoices
  (pat : ISAPattern)
  : list (list ISAEdge) :=
  match pat with
  | Rel edge => [[edge]]
  | Chain x y =>
      let result := [] in
      let result :=
        if CanBeNull x then
          app_tail result (GetSingleEdgeChoices y)
        else
          result
      in
      let result :=
        if CanBeNull y then
          app_tail result (GetSingleEdgeChoices x)
        else
          result
      in
      result
  | Union x y => app_tail (GetSingleEdgeChoices x) (GetSingleEdgeChoices y)
  | Intersection x y => Warning [] ["Intersection currently unsupported!"]
  | TranClos x
  | ReflClos x
  | ReflTranClos x => GetSingleEdgeChoices x
  end.

Fixpoint PrintISAPattern
  (pat : ISAPattern)
  : list string :=
  match pat with
  | Rel edge => [PrintISAEdge edge]
  | Chain x y => app_tail (PrintISAPattern x) (" ; "::(PrintISAPattern y))
  | Union x y => app_tail (PrintISAPattern x) (" U "::(PrintISAPattern y))
  | Intersection x y => Warning (app_tail (PrintISAPattern x) (" /\ "::(PrintISAPattern y))) ["Intersection currently unsupported!"]
  | TranClos x => app_tail ("( "::(PrintISAPattern x)) [" )+ "]
  | ReflClos x => app_tail ("( "::(PrintISAPattern x)) [" )? "]
  | ReflTranClos x => app_tail ("( "::(PrintISAPattern x)) [" )* "]
  end.

Definition PrintISAPatterns
  (pats : list ISAPattern)
  : list string :=
  let f x y := app_tail x (newline::"//"::y) in
  let strs := Map PrintISAPattern pats in
  fold_left f strs [].


From Hammer Require Import Hammer.

Require Import Equalities Bool SetoidList RelationPairs.

Set Implicit Arguments.

Module KeyDecidableType(D:DecidableType).

Local Open Scope signature_scope.
Local Notation key := D.t.

Definition eqk {elt} : relation (key*elt) := D.eq @@1.
Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq.

Hint Unfold eqk eqke.

Instance eqk_equiv {elt} : Equivalence (@eqk elt) := _.

Instance eqke_equiv {elt} : Equivalence (@eqke elt) := _.

Instance eqke_eqk {elt} : subrelation (@eqke elt) (@eqk elt).
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqke_eqk".   firstorder. Qed.

Lemma eqke_def {elt} k k' (e e':elt) :
eqke (k,e) (k',e') = (D.eq k k' /\ e = e').
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqke_def".   reflexivity. Defined.

Lemma eqke_def' {elt} (p q:key*elt) :
eqke p q = (D.eq (fst p) (fst q) /\ snd p = snd q).
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqke_def'".   reflexivity. Defined.

Lemma eqke_1 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> D.eq k k'.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqke_1".   now destruct 1. Qed.

Lemma eqke_2 {elt} k k' (e e':elt) : eqke (k,e) (k',e') -> e=e'.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqke_2".   now destruct 1. Qed.

Lemma eqk_def {elt} k k' (e e':elt) : eqk (k,e) (k',e') = D.eq k k'.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqk_def".   reflexivity. Defined.

Lemma eqk_def' {elt} (p q:key*elt) : eqk p q = D.eq (fst p) (fst q).
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqk_def'".   reflexivity. Qed.

Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.eqk_1".   trivial. Qed.

Hint Resolve eqke_1 eqke_2 eqk_1.

Lemma InA_eqke_eqk {elt} p (m:list (key*elt)) :
InA eqke p m -> InA eqk p m.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.InA_eqke_eqk".
induction 1; firstorder.
Qed.
Hint Resolve InA_eqke_eqk.

Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) :
InA eqk p m -> exists q, eqk p q /\ InA eqke q m.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.InA_eqk_eqke".
induction 1; firstorder.
Qed.

Lemma InA_eqk {elt} p q (m:list (key*elt)) :
eqk p q -> InA eqk p m -> InA eqk q m.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.InA_eqk".
now intros <-.
Qed.

Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e).
Definition In {elt} k m := exists e:elt, MapsTo k e m.

Hint Unfold MapsTo In.

Lemma In_alt {elt} k (l:list (key*elt)) :
In k l <-> exists e, InA eqk (k,e) l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_alt".
unfold In, MapsTo.
split; intros (e,H).
- exists e; auto.
- apply InA_eqk_eqke in H. destruct H as ((k',e'),(E,H)).
compute in E. exists e'. now rewrite E.
Qed.

Lemma In_alt' {elt} (l:list (key*elt)) k e :
In k l <-> InA eqk (k,e) l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_alt'".
rewrite In_alt. firstorder. eapply InA_eqk; eauto. now compute.
Qed.

Lemma In_alt2 {elt} k (l:list (key*elt)) :
In k l <-> Exists (fun p => D.eq k (fst p)) l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_alt2".
unfold In, MapsTo.
setoid_rewrite Exists_exists; setoid_rewrite InA_alt.
firstorder.
exists (snd x), x; auto.
Qed.

Lemma In_nil {elt} k : In k (@nil (key*elt)) <-> False.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_nil".
rewrite In_alt2; apply Exists_nil.
Qed.

Lemma In_cons {elt} k p (l:list (key*elt)) :
In k (p::l) <-> D.eq k (fst p) \/ In k l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_cons".
rewrite !In_alt2, Exists_cons; intuition.
Qed.

Instance MapsTo_compat {elt} :
Proper (D.eq==>Logic.eq==>equivlistA eqke==>iff) (@MapsTo elt).
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.MapsTo_compat".
intros x x' Hx e e' He l l' Hl. unfold MapsTo.
rewrite Hx, He, Hl; intuition.
Qed.

Instance In_compat {elt} : Proper (D.eq==>equivlistA eqk==>iff) (@In elt).
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_compat".
intros x x' Hx l l' Hl. rewrite !In_alt.
setoid_rewrite Hl. setoid_rewrite Hx. intuition.
Qed.

Lemma MapsTo_eq {elt} (l:list (key*elt)) x y e :
D.eq x y -> MapsTo x e l -> MapsTo y e l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.MapsTo_eq".   now intros <-. Qed.

Lemma In_eq {elt} (l:list (key*elt)) x y :
D.eq x y -> In x l -> In y l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_eq".   now intros <-. Qed.

Lemma In_inv {elt} k k' e (l:list (key*elt)) :
In k ((k',e) :: l) -> D.eq k k' \/ In k l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_inv".
intros (e',H). red in H. rewrite InA_cons, eqke_def in H.
intuition. right. now exists e'.
Qed.

Lemma In_inv_2 {elt} k k' e e' (l:list (key*elt)) :
InA eqk (k, e) ((k', e') :: l) -> ~ D.eq k k' -> InA eqk (k, e) l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_inv_2".
rewrite InA_cons, eqk_def. intuition.
Qed.

Lemma In_inv_3 {elt} x x' (l:list (key*elt)) :
InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.KeyDecidableType.In_inv_3".
rewrite InA_cons. destruct 1 as [H|H]; trivial. destruct 1.
eauto with *.
Qed.

Hint Extern 2 (eqke ?a ?b) => split.
Hint Resolve InA_eqke_eqk.
Hint Resolve In_inv_2 In_inv_3.

End KeyDecidableType.

Module PairDecidableType(D1 D2:DecidableType) <: DecidableType.

Definition t := (D1.t * D2.t)%type.

Definition eq := (D1.eq * D2.eq)%signature.

Instance eq_equiv : Equivalence eq := _.

Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.PairDecidableType.eq_dec".
intros (x1,x2) (y1,y2); unfold eq; simpl.
destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
compute; intuition.
Defined.

End PairDecidableType.

Module PairUsualDecidableType(D1 D2:UsualDecidableType) <: UsualDecidableType.
Definition t := (D1.t * D2.t)%type.
Definition eq := @eq t.
Instance eq_equiv : Equivalence eq := _.
Definition eq_dec : forall x y, { eq x y }+{ ~eq x y }.
Proof. hammer_hook "EqualitiesFacts" "EqualitiesFacts.PairUsualDecidableType.eq_dec".
intros (x1,x2) (y1,y2);
destruct (D1.eq_dec x1 y1); destruct (D2.eq_dec x2 y2);
unfold eq, D1.eq, D2.eq in *; simpl;
(left; f_equal; auto; fail) ||
(right; intros [=]; auto).
Defined.

End PairUsualDecidableType.


(* Copyright (c) 2012-2015, Robbert Krebbers. *)
(* This file is distributed under the terms of the BSD license. *)
(** This files implements an efficient implementation of finite maps whose keys
range over Coq's data type of strings [string]. The implementation uses radix-2
search trees (uncompressed Patricia trees) as implemented in the file [pmap]
and guarantees logarithmic-time operations. *)
From prelude Require Export fin_maps pretty.
From prelude Require Import gmap.

Notation stringmap := (gmap string).
Notation stringset := (gset string).

(** * Generating fresh strings *)
Local Open Scope N_scope.
Let R {A} (s : string) (m : stringmap A) (n1 n2 : N) :=
  n2 < n1 ∧ is_Some (m !! (s +:+ pretty (n1 - 1))).
Lemma fresh_string_step {A} s (m : stringmap A) n x :
  m !! (s +:+ pretty n) = Some x → R s m (1 + n) n.
Proof. split; [lia|]. replace (1 + n - 1) with n by lia; eauto. Qed.
Lemma fresh_string_R_wf {A} s (m : stringmap A) : wf (R s m).
Proof.
  induction (map_wf m) as [m _ IH]. intros n1; constructor; intros n2 [Hn Hs].
  specialize (IH _ (delete_subset m (s +:+ pretty (n2 - 1)) Hs) n2).
  cut (n2 - 1 < n2); [|lia]. clear n1 Hn Hs; revert IH; generalize (n2 - 1).
  intros n1. induction 1 as [n2 _ IH]; constructor; intros n3 [??].
  apply IH; [|lia]; split; [lia|].
  by rewrite lookup_delete_ne by (intros ?; simplify_eq/=; lia).
Qed.
Definition fresh_string_go {A} (s : string) (m : stringmap A) (n : N)
    (go : ∀ n', R s m n' n → string) : string :=
  let s' := s +:+ pretty n in
  match Some_dec (m !! s') with
  | inleft (_↾Hs') => go (1 + n)%N (fresh_string_step s m n _ Hs')
  | inright _ => s'
  end.
Definition fresh_string {A} (s : string) (m : stringmap A) : string :=
  match m !! s with
  | None => s
  | Some _ =>
     Fix_F _ (fresh_string_go s m) (wf_guard 32 (fresh_string_R_wf s m) 0)
  end.
Lemma fresh_string_fresh {A} (m : stringmap A) s : m !! fresh_string s m = None.
Proof.
  unfold fresh_string. destruct (m !! s) as [a|] eqn:Hs; [clear a Hs|done].
  generalize 0 (wf_guard 32 (fresh_string_R_wf s m) 0); revert m.
  fix 3; intros m n [?]; simpl; unfold fresh_string_go at 1; simpl.
  destruct (Some_dec (m !! _)) as [[??]|?]; auto.
Qed.
Definition fresh_string_of_set (s : string) (X : stringset) : string :=
  fresh_string s (mapset.mapset_car X).
Lemma fresh_string_of_set_fresh (X : stringset) s : fresh_string_of_set s X ∉ X.
Proof. apply eq_None_ne_Some, fresh_string_fresh. Qed.

Fixpoint fresh_strings_of_set
    (s : string) (n : nat) (X : stringset) : list string :=
  match n with
  | 0 => []
  | S n =>
     let x := fresh_string_of_set s X in
     x :: fresh_strings_of_set s n ({[ x ]} ∪ X)
  end%nat.


Require Import Metalib.Metatheory.
Require Import FcEtt.ett_ott.
Require Import FcEtt.ett_inf.

Set Bullet Behavior "Strict Subproofs".
Set Implicit Arguments.

(*

This module proves the following results:

     Lemma AnnSig_an_toplevel: AnnSig an_toplevel.
     Lemma Sig_toplevel: Sig toplevel.

It *should* be the only place in the development that
unfolds the definition of an_toplevel. That way, if we change the
definition of the signature in ett.ott, we only need to change this file.

In this case, it uses the fact that an_toplevel (defined in ett.ott)
contains the following definitions:

Definition Fix : atom.
  pick fresh F.
  exact F.
Qed.

Definition FixDef : tm :=
  (a_Abs Irrel a_Star
         (a_Abs Rel (a_Pi Rel (a_Var_b 0) (a_Var_b 1))
                (a_App (a_Var_b 0) Rel
                       (a_App (a_App (a_Fam Fix) Irrel (a_Var_b 1)) Rel (a_Var_b 0))))).

Definition FixTy : tm :=
  a_Pi Irrel a_Star
       (a_Pi Rel (a_Pi Rel (a_Var_b 0) (a_Var_b 1))
             (a_Var_b 1)).
 *)

Lemma AxFix : binds Fix (Ax FixDef FixTy) an_toplevel.
  unfold an_toplevel.
  eauto.
Qed.

Ltac an_use_binder f x :=
  pick fresh x and apply f; eauto;
  unfold open_tm_wrt_tm; simpl; simpl_env; eauto;
  match goal with
    [ |- AnnTyping ?ctx ?a ?A ] =>
    assert (AnnCtx ctx); [econstructor; eauto|idtac]
  end.

Lemma An_App_intro :
  forall (G : context) (b : tm) (rho : relflag) (a B A C : tm),
       AnnTyping G b (a_Pi rho A B) -> (open_tm_wrt_tm B a) = C ->
       AnnTyping G a A -> AnnTyping G (a_App b rho a) C.
Proof.
  intros. subst. eapply An_App; eauto.
Qed.

Lemma FixTy_Star :
  AnnTyping nil FixTy a_Star.
Proof.
  an_use_binder An_Pi X.
  an_use_binder An_Pi Z.
  an_use_binder An_Pi W.
  eauto.
  eauto.
  an_use_binder An_Pi W.
  eauto.
Qed.

Lemma FixDef_FixTy :
  AnnTyping nil FixDef FixTy.
Proof.
  an_use_binder An_Abs X.
  an_use_binder An_Abs x.
  { an_use_binder An_Pi Z. eauto. }
  { an_use_binder An_Pi Z. eauto. }
  { eapply An_App_intro; eauto.
    { eapply An_App_intro; simpl; eauto.
      { eapply An_App_intro; simpl; eauto.
        econstructor; eauto.
        eapply AxFix.
        an_use_binder An_Pi Z.
        an_use_binder An_Pi W; eauto.
        an_use_binder An_Pi M; eauto.
        an_use_binder An_Pi N; eauto.
        unfold open_tm_wrt_tm. simpl. eauto. }
      unfold open_tm_wrt_tm. simpl. eauto.
    }
  }
Qed.

Lemma AnnSig_an_toplevel: AnnSig an_toplevel.
Proof.
  unfold an_toplevel.
  econstructor; eauto.
(*  eapply AxFix. *)
  eapply FixTy_Star. eauto.
  eapply FixDef_FixTy.
Qed.

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

Ltac use_binder f x :=
  pick fresh x and apply f;
  unfold open_tm_wrt_tm; simpl; simpl_env; eauto;
  match goal with
    [ |- Typing ?ctx ?a ?A ] =>
    assert (Ctx ctx); [econstructor; eauto|idtac]
  end.

Lemma E_App_intro :
  forall (G : context) (b : tm) (a B A C : tm),
       Typing G b (a_Pi Rel A B) -> (open_tm_wrt_tm B a) = C ->
       Typing G a A -> Typing G (a_App b Rel a) C.
Proof.
  intros. subst.  eapply E_App; eauto.
Qed.

Lemma E_IApp_intro :
  forall (G : context) (b : tm) (a B A C : tm),
       Typing G b (a_Pi Irrel A B) -> (open_tm_wrt_tm B a) = C ->
       Typing G a A -> Typing G (a_App b Irrel a_Bullet) C.
Proof.
  intros. subst.  eapply E_IApp; eauto.
Qed.

Lemma FixTy_erase :
  Typing nil (erase_tm FixTy) a_Star.
Proof.
  use_binder E_Pi X.
  use_binder E_Pi Z.
  use_binder E_Pi W.
  eauto.
  eauto.
  use_binder E_Pi W.
  eauto.
Qed.

Lemma FixDef_FixTy_erase :
  Typing nil (erase_tm FixDef) (erase_tm FixTy).
Proof.
  pose (H := AxFix). clearbody H.
  unfold FixDef,FixTy; simpl.
  use_binder E_Abs X.
  use_binder E_Abs x.
  { use_binder E_Pi Z. eauto. }
  { eapply E_App_intro; eauto.
    { eapply E_App_intro; simpl; eauto.
      { eapply E_IApp_intro with (a := (a_Var_f X)); simpl; eauto.

        pose (K := @E_Fam _ Fix  (erase_tm FixTy) (erase_tm FixDef) H1).
        unfold toplevel, erase_sig in K.
        apply binds_map with (f:=erase_csort) in H.
        apply K in H.
        clear K.
        simpl in H.
        apply H.

        { simpl.
        use_binder E_Pi Z; eauto.
        use_binder E_Pi W; eauto.
        use_binder E_Pi M; eauto.
        use_binder E_Pi N; eauto. }

        { unfold open_tm_wrt_tm. simpl. eauto. }
      }
      unfold open_tm_wrt_tm. simpl. eauto.
    }
  }
  use_binder E_Pi Z; eauto.
Qed.

Lemma Sig_toplevel: Sig toplevel.
Proof.
  unfold toplevel, erase_sig.
  unfold an_toplevel.
  econstructor; eauto.
(*  unfold toplevel, erase_sig.
  pose (K := AxFix).
  eapply binds_map with (f:= erase_csort) in K.
  apply K. *)
  eapply FixTy_erase.
  eapply FixDef_FixTy_erase.
Qed.


From mathcomp.ssreflect Require Import all_ssreflect seq.
From mathcomp Require Import finmap.

From Paco Require Import paco paco2.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Require Import MPST.Common.

CoInductive rg_ty :=
| rg_end
| rg_msg (FROM TO : role)
         (CONT : lbl -> option (mty * rg_ty)).

Unset Elimination Schemes.
Inductive ig_ty :=
| ig_end (CONT : rg_ty)
| ig_msg (ST : option lbl)
         (FROM TO : role)
         (CONT : lbl -> option (mty * ig_ty)).
Set Elimination Schemes.

Definition P_option A (P : A -> Type) (C : option A) : Type :=
  match C with
  | Some X => P X
  | None => True
  end.

Definition P_prod A B (P : B -> Type) (C : A * B) : Type :=
  match C with
  | (X, Y)=> P Y
  end.

Lemma ig_ty_ind'
      (P : ig_ty -> Prop)
      (P_end : forall CONT, P (ig_end CONT))
      (P_msg : (forall ST FROM TO CONT,
                   (forall L, P_option (P_prod P) (CONT L)) ->
                   P (ig_msg ST FROM TO CONT)))
  : forall G, P G.
Proof.
  fix Ih 1; case.
  - by apply: P_end.
  - move=> ST F T C; apply: P_msg => L.
    case: (C L)=>[[Ty G]|].
    + by rewrite /P_option/P_prod; apply/Ih.
    + by rewrite /P_option.
Qed.

Lemma ig_ty_ind
      (P : ig_ty -> Prop)
      (P_end : forall CONT, P (ig_end CONT))
      (P_msg : (forall ST FROM TO CONT,
                   (forall L Ty G, CONT L = Some (Ty, G) -> P G) ->
                   P (ig_msg ST FROM TO CONT)))
  : forall G, P G.
Proof.
  elim/ig_ty_ind'=>// ST FROM TO CONT Ih.
  apply/P_msg => L Ty G; move: (Ih L); case: (CONT L) =>[[Ty' G']|]//=.
  by move=> P_G' [_ <-].
Qed.

Lemma ig_ty_rect'
      (P : ig_ty -> Type)
      (P_end : forall CONT, P (ig_end CONT))
      (P_msg : (forall ST FROM TO CONT,
                   (forall L, P_option (P_prod P) (CONT L)) ->
                   P (ig_msg ST FROM TO CONT)))
  : forall G, P G.
Proof.
  fix Ih 1; case.
  - by apply: P_end.
  - move=> ST F T C; apply: P_msg => L.
    case: (C L)=>[[Ty G]|].
    + by rewrite /P_option/P_prod; apply/Ih.
    + by rewrite /P_option.
Qed.

Lemma ig_ty_rect
      (P : ig_ty -> Type)
      (P_end : forall CONT, P (ig_end CONT))
      (P_msg : (forall ST FROM TO CONT,
                   (forall L Ty G, CONT L = Some (Ty, G) -> P G) ->
                   P (ig_msg ST FROM TO CONT)))
  : forall G, P G.
Proof.
  elim/ig_ty_rect'=>// ST FROM TO CONT Ih.
  apply/P_msg => L Ty G; move: (Ih L); case: (CONT L) =>[[Ty' G']|]//=.
  by move=> P_G' [_ <-].
Qed.

Inductive part_of: role -> rg_ty -> Prop :=
  | pof_from F T C: part_of F (rg_msg F T C)
  | pof_to F T C: part_of T (rg_msg F T C)
  | pof_cont p F T C L G Ty: C L = Some (Ty, G)
    -> part_of p G -> part_of p (rg_msg F T C).

Inductive part_of_all: role -> rg_ty -> Prop :=
  | pall_from F T C: part_of_all F (rg_msg F T C)
  | pall_to F T C: part_of_all T (rg_msg F T C)
  | pall_cont p F T C :
      P_all (part_of_all p) C -> part_of_all p (rg_msg F T C).

(* Needed to build the next global type in a step  *)
Inductive part_of_allT: role -> rg_ty -> Type :=
  | pallT_from F T C: part_of_allT F (rg_msg F T C)
  | pallT_to F T C: part_of_allT T (rg_msg F T C)
  | pallT_cont p F T C :
      (forall l Ty G, C l = Some (Ty, G) -> part_of_allT p G) ->
      part_of_allT p (rg_msg F T C).

Inductive iPart_of: role -> ig_ty -> Prop :=
  | ipof_end p cG: part_of p cG -> iPart_of p (ig_end cG)
  | ipof_from F T C: iPart_of F (ig_msg None F T C)
  | ipof_to o F T C: iPart_of T (ig_msg o F T C)
  | ipof_cont p o F T C L G Ty: C L = Some (Ty, G)
    -> iPart_of p G -> iPart_of p (ig_msg o F T C).

Lemma rgend_part p G : part_of_all p G -> G = rg_end -> False.
Proof. by move=>[]. Qed.

Lemma pall_inv F T C G p :
  part_of_all p G -> G = rg_msg F T C -> F <> p -> T <> p ->
  (forall l Ty G, C l = Some (Ty, G) -> part_of_all p G).
Proof.
    by move=>[ F' T' C' [->]//
             | F' T' C' [_ ->]//
             |{}p F' T' C' ALL [_ _ <-] _ _ l Ty {}G /ALL
             ].
Defined.

Fixpoint find_partsc p G (H : part_of_all p G) {struct H}
  : part_of_allT p G
  :=
  match G as G0 return G = G0 -> part_of_allT p G0 with
  | rg_msg F T C => fun EQ =>
                      match @eqP _ F p with
                      | ReflectT pF => match EQ, pF with
                                       | erefl, erefl => pallT_from F T C
                                       end
                      | ReflectF pF =>
                        match @eqP _ T p with
                        | ReflectT pT => match EQ, pT with
                                         | erefl, erefl => pallT_to F T C
                                         end
                        | ReflectF pT =>
                          pallT_cont F T
                                     (fun l Ty G Cl =>
                                        find_partsc (pall_inv H EQ pF pT Cl))
                        end
                      end
  | rg_end => fun E => match rgend_part H E with end
  end erefl.

Definition rg_unr (G : rg_ty) : ig_ty :=
  match G with
  | rg_msg F T C
      => ig_msg None F T
                (fun lbl =>
                  match C lbl with
                  | None => None
                  | Some (t, G) => Some (t, ig_end G)
                  end)
  | rg_end => ig_end rg_end
  end.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(** * DecimalFacts : some facts about Decimal numbers *)

Require Import Decimal.

Lemma uint_dec (d d' : uint) : { d = d' } + { d <> d' }.
Proof.
 decide equality.
Defined.

Lemma rev_revapp d d' :
 rev (revapp d d') = revapp d' d.
Proof.
 revert d'. induction d; simpl; intros; now rewrite ?IHd.
Qed.

Lemma rev_rev d : rev (rev d) = d.
Proof.
 apply rev_revapp.
Qed.

(** Normalization on little-endian numbers *)

Fixpoint nztail d :=
 match d with
 | Nil => Nil
 | D0 d => match nztail d with Nil => Nil | d' => D0 d' end
 | D1 d => D1 (nztail d)
 | D2 d => D2 (nztail d)
 | D3 d => D3 (nztail d)
 | D4 d => D4 (nztail d)
 | D5 d => D5 (nztail d)
 | D6 d => D6 (nztail d)
 | D7 d => D7 (nztail d)
 | D8 d => D8 (nztail d)
 | D9 d => D9 (nztail d)
 end.

Definition lnorm d :=
 match nztail d with
 | Nil => zero
 | d => d
 end.

Lemma nzhead_revapp_0 d d' : nztail d = Nil ->
 nzhead (revapp d d') = nzhead d'.
Proof.
 revert d'. induction d; intros d' [=]; simpl; trivial.
 destruct (nztail d); now rewrite IHd.
Qed.

Lemma nzhead_revapp d d' : nztail d <> Nil ->
 nzhead (revapp d d') = revapp (nztail d) d'.
Proof.
 revert d'.
 induction d; intros d' H; simpl in *;
 try destruct (nztail d) eqn:E;
  (now rewrite ?nzhead_revapp_0) || (now rewrite IHd).
Qed.

Lemma nzhead_rev d : nztail d <> Nil ->
 nzhead (rev d) = rev (nztail d).
Proof.
 apply nzhead_revapp.
Qed.

Lemma rev_nztail_rev d :
  rev (nztail (rev d)) = nzhead d.
Proof.
 destruct (uint_dec (nztail (rev d)) Nil) as [H|H].
 - rewrite H. unfold rev; simpl.
   rewrite <- (rev_rev d). symmetry.
   now apply nzhead_revapp_0.
 - now rewrite <- nzhead_rev, rev_rev.
Qed.

Lemma revapp_nil_inv d d' : revapp d d' = Nil -> d = Nil /\ d' = Nil.
Proof.
 revert d'.
 induction d; simpl; intros d' H; auto; now apply IHd in H.
Qed.

Lemma rev_nil_inv d : rev d = Nil -> d = Nil.
Proof.
 apply revapp_nil_inv.
Qed.

Lemma rev_lnorm_rev d :
  rev (lnorm (rev d)) = unorm d.
Proof.
 unfold unorm, lnorm.
 rewrite <- rev_nztail_rev.
 destruct nztail; simpl; trivial;
  destruct rev eqn:E; trivial; now apply rev_nil_inv in E.
Qed.

Lemma nzhead_nonzero d d' : nzhead d <> D0 d'.
Proof.
 induction d; easy.
Qed.

Lemma unorm_0 d : unorm d = zero <-> nzhead d = Nil.
Proof.
 unfold unorm. split.
 - generalize (nzhead_nonzero d).
   destruct nzhead; intros H [=]; trivial. now destruct (H u).
 - now intros ->.
Qed.

Lemma unorm_nonnil d : unorm d <> Nil.
Proof.
 unfold unorm. now destruct nzhead.
Qed.

Lemma nzhead_invol d : nzhead (nzhead d) = nzhead d.
Proof.
 now induction d.
Qed.

Lemma unorm_invol d : unorm (unorm d) = unorm d.
Proof.
 unfold unorm.
 destruct (nzhead d) eqn:E; trivial.
 destruct (nzhead_nonzero _ _ E).
Qed.

Lemma norm_invol d : norm (norm d) = norm d.
Proof.
 unfold norm.
 destruct d.
 - f_equal. apply unorm_invol.
 - destruct (nzhead d) eqn:E; auto.
   destruct (nzhead_nonzero _ _ E).
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.

Require Import Nat Arith.

Inductive lst : Type :=
  | Nil : lst
  | Cons : nat -> lst -> lst.

  Fixpoint append (l1 : lst) (l2 : lst) : lst :=
   match l1 with
   | Nil => l2
   | Cons x y => Cons x (append y l2)
   end.

 Fixpoint rev (l : lst) : lst :=
   match l with
   | Nil => Nil
   | Cons x y => append (rev y) (Cons x Nil)
   end.

Theorem append_assoc : forall x y z : lst, append (append x y) z = append x (append y z).
Proof.
  intros.
  induction x.
  - reflexivity.
  - simpl. rewrite IHx. reflexivity.
Qed.

Theorem rev_append_cons_aux : forall (l1 l2 : lst) (x : nat), rev (append (rev l1) (Cons x l2)) = append (rev l2) (Cons x l1).
Proof.
  intro.
  induction l1.
  - reflexivity.
  - intros. simpl. rewrite append_assoc. simpl. rewrite IHl1. simpl.
    lfind. Admitted.


(*
 * Copyright (c) 2023 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
From stdpp Require Import base.

From elpi Require Import elpi.
From elpi.apps Require Import derive.

From bedrock.prelude.elpi Require Export basis.
Elpi Accumulate derive Db bedrock.basis.db.

Elpi Db derive.stdpp.inhabited.db lp:{{
  pred inhabited o:gref, o:gref.
  pred inhabited-done o:gref.
  :name "inhabited-done.typeclass"
  inhabited-done GR :-
    typeclass "derive.stdpp.inhabited.db"
      (before "inhabited-done.typeclass") (inhabited-done GR) {{ @Inhabited lp:{{global GR}} }} Bo_.
}}.
Elpi Accumulate derive Db derive.stdpp.inhabited.db.
Elpi Typecheck derive.

(***************************************************
 Inhabited
 ***************************************************)
Elpi Accumulate derive lp:{{
  namespace derive.inhabited {
    pred main i:gref, i:string, o:list prop.
    main TyGR Prefix Clauses :- std.do! [
      remove-final-underscore Prefix Prefix',
      InstanceName is Prefix' ^ "_inhabited",
      TyInhabited = {{ Inhabited lp:{{global TyGR}} }},
      std.assert-ok! (coq.elaborate-skeleton TyInhabited _ ETyInhabited) "[derive.inh.main] [TyInhabited]",
      std.assert-ok! (coq.typecheck {{ lp:BoInhabited : lp:ETyInhabited }} _) "typechecking the [Inhabited t] instance failed",
      coq.ltac.collect-goals BoInhabited [SealedGoal] [],
      coq.ltac.open (coq.ltac.call "solve_inhabited" []) SealedGoal [],
      @using! "Type" => coq.env.add-const InstanceName BoInhabited ETyInhabited @opaque! C,
      @global! => coq.TC.declare-instance (const C) 0,
      Clauses = [inhabited-done TyGR, inhabited TyGR (const C)],
      std.forall Clauses (x\
        coq.elpi.accumulate _ "derive.stdpp.inhabited.db" (clause _ _ x)
      ),
    ].
    main _ _ _ :- usage.

    pred usage.
    usage :- coq.error
"Usage: #[only(inhabited)] derive T
where T is an inductive or a definition that unfolds to an inductive.

Example #1:
 Variant T := A | B | C.
 #[only(inhabited)] derive T

Example #2:
  #[only(inhabited)] derive
  Variant T := A | B | C.

Example #3:
  Variant _T := A | B | C.
  Definition T := _T.
  #[only(inhabited)] derive T.".

  }

  derivation
    (indt T) Prefix
    (derive "inhabited"
       (derive.inhabited.main (indt T) Prefix)
       (inhabited-done (indt T))
    ).
}}.
Elpi Typecheck derive.


Require Import List.
Require Import Memory.
Require Import Reifiable.

Set Implicit Arguments.
Import ListNotations.

Module BinOp.
End BinOp.

Module Source.
  Inductive t (T : forall A, Reifiable.t A -> Type) : forall A, Reifiable.t A -> Type :=
  | imm A (RA : Reifiable.t A) (v : A) : t T RA
  | var A (RA : Reifiable.t A) (x : T A RA) : t T RA
  | def A B (RA : Reifiable.t A) (RB : Reifiable.t B) (e1 : t T RA) (e2 : T A RA -> t T RB) : t T RB
  | convert A B (RA : Reifiable.t A) (RB : Reifiable.t B) (e : t T RA)
    : (forall v, Reifiable.invariant RA v -> Reifiable.invariant RB v) ->
      t T RB.
(*  | binop (op : BinOp.t) (x : Operand.t T) (y : Operand.t T) (s_next : T -> t T)
  | jcc (c : Operand.t T) (s_true : t T) (s_false : t T) (s_next : T -> t T)
  | iter (x : Operand.t T) (s_c : T -> t T) (s_f : T -> t T) (s_next : T -> t T).*)
End Source.


From isla Require Import opsem.

Definition a68 : isla_trace :=
  Smt (DeclareConst 0%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "PC" [] (RegVal_Base (Val_Symbolic 0%Z)) Mk_annot :t:
  Smt (DefineConst 1%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 0%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DeclareConst 13%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "x8" [] (RegVal_Base (Val_Symbolic 13%Z)) Mk_annot :t:
  Smt (DefineConst 14%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 13%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  WriteReg "x9" [] (RegVal_Base (Val_Symbolic 14%Z)) Mk_annot :t:
  WriteReg "PC" [] (RegVal_Base (Val_Symbolic 1%Z)) Mk_annot :t:
  tnil
.


Require        Coq.FSets.FMapWeakList.
Require Import Coq.FSets.FMapFacts.
Require        Coq.Structures.Equalities.

Require Import SPAM.SeparationLogic.Syntax.

Module DecidableLvar.
Import Coq.Structures.Equalities.
Include (UsualDecidableTypeBoth with Definition t := Syntax.lvar).
End DecidableLvar.

Module DecidablePvar.
Import Coq.Structures.Equalities.
Include (UsualDecidableTypeBoth with Definition t := Syntax.pvar).
End DecidablePvar.

Module DecidableConcrete.
Import Coq.Structures.Equalities.
Include (UsualDecidableTypeBoth with Definition t := Syntax.concrete).
End DecidableConcrete.

Module LogicalMap := FMapWeakList.Make DecidableLvar.

Definition logicalEnv : Type := LogicalMap.t concrete.

Module ProgramMap := FMapWeakList.Make DecidablePvar.
Module ProgramMapF := WFacts ProgramMap.
Module ProgramMapP := WProperties ProgramMap.

Definition variableStore : Type := ProgramMap.t concrete.

Module HeapMap := FMapWeakList.Make DecidableConcrete.
Module HeapMapF := WFacts HeapMap.
Module HeapMapP := WProperties HeapMap.

Definition heap : Type := HeapMap.t concrete.

Inductive InterpsTo (e : logicalEnv) (s : variableStore) :  basevalue -> concrete -> Prop :=
  | iConcrete (c : concrete)
  : InterpsTo e s (vlit c) c
  | iProgram (p : pvar) (c : concrete)
  : ProgramMap.MapsTo p c s
    -> InterpsTo e s (vpvar p) c
  | iLogical (l : lvar) (c : concrete)
  : LogicalMap.MapsTo l c e
    -> InterpsTo e s (vlvar l) c.

Notation "[[ v ]]_{ e , s } = c" := (Arithmetic.interpret (eval:=InterpsTo e s) v c) (at level 70).

Definition InterpsList (e : logicalEnv) (s : variableStore) : list (value_ * concrete) -> Prop
  := Forall (fun '(v, c) => [[ v ]]_{ e, s } = c).

Definition addConsecutive (c : concrete) (vals : list concrete) (h : heap)
  := fold_left (fun h' '(idx, v) => HeapMap.add (c + idx) v h') (combine (List.seq 0 (length vals)) vals) h.

Fixpoint Satisfies (e : logicalEnv) (s : variableStore) (h : heap) (A : sassert) : Prop :=
  match A with
  | empty => HeapMap.Empty h
  | singleton x y =>
      exists (c c' : concrete),
        [[ x ]]_{e,s} = c
        /\ [[ y ]]_{e,s} = c'
        /\ h = HeapMap.add c c' (HeapMap.empty concrete)
  | top => True
  | x s= y =>
      forall (c c' : concrete),
        [[ x ]]_{e,s} = c
        /\ [[ y ]]_{e,s} = c'
        -> c = c'
  | A s/\ B => Satisfies e s h A /\ Satisfies e s h B
  | A s\/ B => Satisfies e s h A \/ Satisfies e s h B
  | s~ A => ~ Satisfies e s h A
  | A s-> B => Satisfies e s h A -> Satisfies e s h B
  | A s* B =>
      exists (h' h'' : heap),
        HeapMapP.Partition h h' h''
        /\ Satisfies e s h' A
        /\ Satisfies e s h'' B
  | A s-* B =>
      forall (h' : heap),
        HeapMapP.Disjoint h h'
          -> Satisfies e s h A
          -> Satisfies e s (HeapMapP.update h h') B
  | sforall x, A =>
      forall (c : concrete),
        Satisfies (LogicalMap.add x c e) s h A
  | sexists x, A =>
      exists (c : concrete),
        Satisfies (LogicalMap.add x c e) s h A
  end.

Notation "env |= A" := (let '(e, s, h) := env in Satisfies e s h A) (at level 99).

Definition Tautology (A : sassert) : Prop
  := forall e s h, (e, s, h) |= A.

Notation "_|= A" := (Tautology A) (at level 99).

Example top_taut : _|= top.
Proof.
  unfold Tautology.
  intros e s h.
  unfold Satisfies.
  easy.
  Qed.

Definition Empty (A : sassert) : Prop
  := forall e s h, (e, s, h) |= A -> HeapMap.Empty h.

Example empty_Empty : Empty empty.
Proof.
  unfold Empty.
  intros e s h.
  unfold Satisfies.
  easy.
  Qed.

Theorem equiv_definition_of_Empty (A : sassert)
  : Empty A <-> _|= A s-> empty.
Proof.
  split.
  { intros empty_A.
    unfold Tautology.
    intros e s h.
    simpl.
    apply empty_A.
  }
  { intros A_impl_empty.
    unfold Empty.
    unfold Tautology in A_impl_empty.
    simpl in A_impl_empty.
    apply A_impl_empty.
  }
  Qed.

Theorem empty_duplicable (A : sassert)
  : Empty A -> forall e s h, forall (B : sassert),
        (e, s, h) |= B s* A -> (e, s, h) |= B s* A s* A.
Proof.
  intros empty_A e s h B sat_B_sand_A.
  simpl.
  exists h.
  exists (HeapMap.empty concrete).
  split.
  { unfold HeapMapP.Partition.
    split.
    { admit. (* h is disjoint from the empty map *)
    }
    { intros k c.
      admit. (* no key appears in the empty map *)
    }
  }
  { split.
    { simpl in sat_B_sand_A.
      assumption.
    }
    { simpl in sat_B_sand_A.
      destruct sat_B_sand_A as [ h' [ h'' [ _ [ _ sat_A ] ] ] ].
      apply empty_A in sat_A as empty_h''.
      assert (forall h, HeapMap.Empty h -> h = HeapMap.empty concrete) as empty_impl_eq.
      { admit. (* The above *) }
      apply empty_impl_eq in empty_h''.
      rewrite <- empty_h''.
      exact sat_A.
    }
  }
  Admitted.


From isla Require Import opsem.

Definition a40 : isla_trace :=
  Smt (DeclareConst 55%Z (Ty_BitVec 64%N)) Mk_annot :t:
  ReadReg "R0" [] (RegVal_Base (Val_Symbolic 55%Z)) Mk_annot :t:
  Smt (DefineConst 57%Z (Manyop (Bvmanyarith Bvand) [Unop (Extract 31%N 0%N) (Val (Val_Symbolic 55%Z) Mk_annot) Mk_annot; Val (Val_Bits (BV 32%N 0x1%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 59%Z (Manyop (Bvmanyarith Bvor) [Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot; Unop (Extract 0%N 0%N) (Binop ((Bvarith Bvlshr)) (Val (Val_Symbolic 57%Z) Mk_annot) (Val (Val_Bits (BV 32%N 0x1f%Z)) Mk_annot) Mk_annot) Mk_annot] Mk_annot)) Mk_annot :t:
  Smt (DefineConst 60%Z (Binop (Eq) (Val (Val_Symbolic 57%Z) Mk_annot) (Val (Val_Bits (BV 32%N 0x0%Z)) Mk_annot) Mk_annot)) Mk_annot :t:
  tcases [
    Smt (Assert (Val (Val_Symbolic 60%Z) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 62%Z (Manyop Concat [Manyop Concat [Val (Val_Symbolic 59%Z) Mk_annot; Val (Val_Bits (BV 1%N 0x1%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 2%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
    Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
    Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
    Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
    Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
    ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
    Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
    tnil;
    Smt (Assert (Unop (Not) (Val (Val_Symbolic 60%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    Smt (DefineConst 62%Z (Manyop Concat [Manyop Concat [Val (Val_Symbolic 59%Z) Mk_annot; Val (Val_Bits (BV 1%N 0x0%Z)) Mk_annot] Mk_annot; Val (Val_Bits (BV 2%N 0x0%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    Smt (DefineConst 63%Z (Unop (Extract 3%N 3%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "N"] (RegVal_Struct [("N", RegVal_Base (Val_Symbolic 63%Z))]) Mk_annot :t:
    Smt (DefineConst 64%Z (Unop (Extract 2%N 2%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "Z"] (RegVal_Struct [("Z", RegVal_Base (Val_Symbolic 64%Z))]) Mk_annot :t:
    Smt (DefineConst 65%Z (Unop (Extract 1%N 1%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "C"] (RegVal_Struct [("C", RegVal_Base (Val_Symbolic 65%Z))]) Mk_annot :t:
    Smt (DefineConst 66%Z (Unop (Extract 0%N 0%N) (Val (Val_Symbolic 62%Z) Mk_annot) Mk_annot)) Mk_annot :t:
    WriteReg "PSTATE" [Field "V"] (RegVal_Struct [("V", RegVal_Base (Val_Symbolic 66%Z))]) Mk_annot :t:
    Smt (DeclareConst 67%Z (Ty_BitVec 64%N)) Mk_annot :t:
    ReadReg "_PC" [] (RegVal_Base (Val_Symbolic 67%Z)) Mk_annot :t:
    Smt (DefineConst 68%Z (Manyop (Bvmanyarith Bvadd) [Val (Val_Symbolic 67%Z) Mk_annot; Val (Val_Bits (BV 64%N 0x4%Z)) Mk_annot] Mk_annot)) Mk_annot :t:
    WriteReg "_PC" [] (RegVal_Base (Val_Symbolic 68%Z)) Mk_annot :t:
    tnil
  ]
.


(*===========================================================================
    State of the registers
  ===========================================================================*)
Require Import Ssreflect.ssreflect Ssreflect.ssrfun Ssreflect.ssrbool Ssreflect.eqtype Ssreflect.seq Ssreflect.fintype Ssreflect.finfun .
Require Import x86proved.x86.reg x86proved.bitsrep x86proved.update.
Local Open Scope update_scope.

(* State of the registers, including IP and flags *)
(* Lookup is just function application *)
(*=RegState *)
Definition RegState := AnyReg -> DWORD.
(*=End *)

(* Avoid == to permit extraction *)
Instance RegStateUpdateOps : UpdateOps RegState AnyReg DWORD :=
  fun rs r v => fun r' => if r == r' then v else rs r'.

Lemma setThenGetDistinct r1 v r2 (rs: RegState) :
  ~~ (r1 == r2) -> (rs !r1:=v) r2 = rs r2.
Proof. move => neq. rewrite /update /RegStateUpdateOps. by rewrite (negbTE neq). Qed.

Lemma setThenGetSame r v rs : (rs !r:=v) r = v.
Proof. rewrite /update /RegStateUpdateOps.
by rewrite (introT (eqP) (refl_equal _)).
Qed.

Require Import Coq.Logic.FunctionalExtensionality.

Instance RegStateUpdate : Update RegState AnyReg DWORD.
apply Build_Update.
(* Same register *)
move => rs r v w. rewrite /update /RegStateUpdateOps.
apply functional_extensionality => r'. by case: (r == r').
(* Different register *)
move => rs r1 r2 v1 v2 neq. rewrite /update /RegStateUpdateOps.
apply functional_extensionality => r.
case E1: (r2 == r).
case E2: (r1 == r). rewrite (elimT (eqP) E1) in neq.
rewrite (elimT (eqP) E2) in neq. done. done.
done.
Qed.

Definition initialReg : RegState := fun _ => #0.

Require Import Coq.Strings.String.
Definition regStateToString (rs:RegState) :=
  (" EIP=" ++ toHex (rs EIP) ++
   " ESP=" ++ toHex (rs ESP) ++
   " EBP=" ++ toHex (rs EBP) ++
   " EAX=" ++ toHex (rs EAX) ++
   " EBX=" ++ toHex (rs EBX) ++
   " ECX=" ++ toHex (rs ECX) ++
   " EDX=" ++ toHex (rs EDX) ++
   " ESI=" ++ toHex (rs ESI) ++
   " EDI=" ++ toHex (rs EDI) ++
   " EBP=" ++ toHex (rs EBP)
   )%string.