Require Import IOA.
Require Import Automation.
Require Import Misc.
Require Import ListOps.
Require Import Simulation.

Require Import List.
Require Import Peano_dec.
Import ListNotations.

Module Api.

  Inductive Counter_API :=
  | Reset
  | Reset_Done
  | Increment
  | Increment_Done
  | Read_Request
  | Read_Response (value : nat).

End Api.

Module Blocking.

  Import Api.

  Inductive pc := Ready | Resetting | Incrementing | Reading.

  Definition state : Set := pc * nat.

  Definition transition (st : state) (act : EmptySet + Counter_API) (st' : state) : Prop :=
    match act with
    | inr Reset => (fst st = Ready /\ st' = (Resetting, snd st)) \/
                   (fst st <> Ready /\ st' = st)
    | inr Reset_Done => fst st = Resetting /\ st' = (Ready, 0)
    | inr Increment => (fst st = Ready /\ st' = (Incrementing, snd st)) \/
                       (fst st <> Ready /\ st' = st)
    | inr Increment_Done => fst st = Incrementing /\ st' = (Ready, S (snd st))
    | inr Read_Request => (fst st = Ready /\ st' = (Reading, snd st)) \/
                          (fst st <> Ready /\ st' = st)
    | inr (Read_Response n) => st = (Reading, n) /\ st' = (Ready, n)
    | inl f => match f with end
    end.

  Definition init value := value = (Ready, 0).

  Definition Spec : AutomatonDef Counter_API :=
    mkAutomatonDef _ state _ init transition.

  Goal in_traces Spec
       [
         Increment;
           Increment_Done;
           Read_Request;
           Read_Response 1;
           Increment;
           Increment_Done;
           Read_Request;
           Read_Response 2;
           Reset;
           Reset_Done;
           Read_Request;
           Read_Response 0
       ].
  Proof.
    eexists; eexists; split;
      [ cbv; eauto |
        repeat (eapply Step_External; simpl; eauto); econstructor; eauto ].
  Qed.

End Blocking.

Module Sequential.

  Import Api.

  Inductive op := Op_Reset | Op_Increment | Op_Read.

  Definition state := prod (list op) nat.

  Definition transition (st : state) (act : EmptySet + Counter_API) (st' : state) : Prop :=
    match act with
    | inr Reset => st' = (fst st ++ [Op_Reset], snd st)
    | inr Increment => st' = (fst st ++ [Op_Increment], snd st)
    | inr Read_Request => st' = (fst st ++ [Op_Read], snd st)
    | inr Reset_Done => fst st = Op_Reset :: fst st' /\
                        snd st' = 0
    | inr Increment_Done => fst st = Op_Increment :: fst st' /\
                            snd st' = S (snd st)
    | inr (Read_Response n) => fst st = Op_Read :: fst st' /\
                               n = snd st /\
                               snd st' = snd st
    | inl f => match f with end
    end.

  Definition init (st : state) := st = ([], 0).

  Definition Spec : AutomatonDef Counter_API :=
    mkAutomatonDef _ state _ init transition.

  (* overlapping requests -- this trace would not be allowed by the
     blocking spec *)
  Goal in_traces Spec
       [
         Increment; (* input 1 *)
           Read_Request; (* input 2 *)
           Increment_Done; (* output 1 *)
           Increment; (* input 3 *)
           Read_Response 1; (* output 2 *)
           Increment_Done; (* output 3 *)
           Read_Request; (* input 4 *)
           Reset; (* input 5 *)
           Read_Response 2; (* output 4 *)
           Reset_Done; (* output 5 *)
           Read_Request; (* input 6 *)
           Read_Response 0 (* output 6 *)
       ].
  Proof.
    unfold in_traces.
    eexists; exists_lift; [cbv; eauto |].
    eexists.
    repeat (
        estep_ext_break;
        try match goal with
            | [ |- context[ ?x ] ] =>
              is_evar x;
              let T := type of x in
              lazymatch eval simpl in T with
              | state => inst_rec_prod (prod (list op) nat) ltac:(fun x' => unify x x')
              end
            end;
        simpl; intuition; eauto
      ).
  Qed.

End Sequential.

Module MultiClientApi.

  Inductive Counter_API :=
  | Reset (cid : nat)
  | Reset_Done (cid : nat)
  | Increment (cid : nat)
  | Increment_Done (cid : nat)
  | Read_Request (cid : nat)
  | Read_Response (cid : nat) (value : nat).

End MultiClientApi.

Module Linearizable.

  Import MultiClientApi.

  Inductive op := Op_Reset | Op_Increment | Op_Read.
  Inductive resp := Resp_Reset | Resp_Increment | Resp_Read (value : nat).

  (* client id -> pending requests, counter *)
  Record state := mkState {
                      requests : nat -> list op;
                      responses : nat -> list resp;
                      counter : nat
                    }.

  Inductive Internal := Execute.

  Definition transition (st : state) (act : Internal + Counter_API) (st' : state) : Prop :=
    let (req, resp, n) := st in
    match act with
    | inr (Reset cid) => st' = mkState
                                 (fun x => if eq_nat_dec cid x
                                           then req cid ++ [Op_Reset]
                                           else req x)
                                 resp
                                 n
    | inr (Increment cid) => st' = mkState
                                     (fun x => if eq_nat_dec cid x
                                               then req cid ++ [Op_Increment]
                                               else req x)
                                     resp
                                     n
    | inr (Read_Request cid) => st' = mkState
                                        (fun x => if eq_nat_dec cid x
                                                  then req cid ++ [Op_Read]
                                                  else req x)
                                        resp
                                        n
    | inr (Reset_Done cid) => exists tl, resp cid = Resp_Reset :: tl /\
                                         st' = mkState
                                                 req
                                                 (fun x => if eq_nat_dec cid x
                                                           then tl
                                                           else resp x)
                                                 n
    | inr (Increment_Done cid) => exists tl, resp cid = Resp_Increment :: tl /\
                                             st' = mkState
                                                     req
                                                     (fun x => if eq_nat_dec cid x
                                                               then tl
                                                               else resp x)
                                                     n
    | inr (Read_Response cid v) => exists tl, resp cid = (Resp_Read v) :: tl /\
                                              st' = mkState
                                                      req
                                                      (fun x => if eq_nat_dec cid x
                                                                then tl
                                                                else resp x)
                                                      n
    | inl Execute => exists cid op tl, req cid = op :: tl /\
                                       st' = mkState
                                               (fun x => if eq_nat_dec cid x
                                                         then tl
                                                         else req x)
                                               (fun x => if eq_nat_dec cid x then
                                                           resp cid ++ match op with
                                                                       | Op_Reset => [Resp_Reset]
                                                                       | Op_Increment => [Resp_Increment]
                                                                       | Op_Read => [Resp_Read n]
                                                                       end
                                                         else resp x)
                                               match op with
                                               | Op_Increment => n + 1
                                               | _ => n
                                               end
    end.

  Definition init (st : state) :=
    st = mkState (fun _ => nil) (fun _ => nil) 0.

  Definition Spec : AutomatonDef Counter_API :=
    mkAutomatonDef _ state _ init transition.

  Ltac break_state :=
    match goal with
    | [ |- context[ ?x ] ] =>
      is_evar x;
      let T := type of x in
      lazymatch eval simpl in T with
      | state =>
        let x1 := fresh "x" in
        let x2 := fresh "y" in
        let x3 := fresh "z" in
        evar (x1 : nat -> list op);
        evar (x2 : nat -> list resp);
        evar (x3 : nat);
        unify x (mkState x1 x2 x3);
        clear x1 x2 x3
      end
    end.

  Tactic Notation "ext" :=
    estep_ext_break; [solve [break_state; cbv; eauto] |].

  Tactic Notation "int" uconstr(client) :=
    estep_int_break Execute; [
      solve [break_state; simpl; exists client; eexists; eexists; simpl; auto] |].

  Ltac linearization ls :=
    first [
        lazymatch ls with
        | ?h :: ?t => int h; linearization t
        | _ => fail
        end |
        ext; linearization ls |
        solve [eauto]
      ].

  Goal in_traces Spec
       [
         Increment 1;
           Increment 2;
           Increment 3;
           Read_Request 1;
           Read_Request 3;
           Increment_Done 1;
           Increment_Done 2;
           Increment_Done 3;
           Read_Response 1 1; (* even though client 1 reads "1", it's still linearizable *)
           Read_Response 3 3
       ].
  Proof.
    unfold in_traces.
    eexists; exists_lift; [cbv; eauto |].
    eexists.
    linearization [1; 1; 2; 3; 3]. (* another valid linearization would be [1; 1; 3; 2; 3] *)
  Qed.

End Linearizable.


Require Import Arith.
Require Import Omega.
Require Import Coq.Lists.List.
Import ListNotations.

Load lambda.
Load stack.

Module SML.

  Inductive SMCommand : Set :=
  | push (n: nat)
  | del (n: nat)
  | get (n: nat)
  | pack (n: nat)
  | unpack
  | cond_get (n k: nat)
  | call
  | inc
  | dec
  | read
  | out.

  Definition SMProgram := list SMCommand.
  Definition Stack := Stack.Stack.

  Function stack_call (s: Stack) (fn_table: list SMProgram)
           {measure Stack.weight s}: (option Stack) * SMProgram  :=
    match Stack.unpack s with
    | None => (None, [])
    | Some stack =>
      match stack with
      | Stack.snil => (None, [])
      | Stack.stuple t s' => stack_call stack fn_table
      | Stack.snat fid s' =>
        match nth_error fn_table fid with
        | None => (None, [])
        | Some fn => (Some s', fn)
        end
      end
    end.
  Proof.
    intros.
    destruct s; simpl in *; try discriminate.
    assert (Stack.append s1 s2 = Stack.stuple t s') by congruence.
    functional inversion H; subst; simpl in *; try omega.
    clear H teq.
    induction s; simpl in *; try omega.
  Defined.

  Inductive SMState :=
    | running (smp: SMProgram)
          (returns: list SMProgram)
          (fn_table: list SMProgram)
          (stack: Stack)
          (input: list nat)
          (output: list nat)
    | halted (output: list nat)
    | error.

  Definition sm_step (s: SMState): SMState :=
    match s with
    | halted _ | error => s
    | running smp rets fn_table stack input output =>
      match smp with
      | [] =>
        match rets with
        | smp' :: rets' => running smp' rets' fn_table stack input output
        | _ => halted output
        end
      | push n :: smp' =>
        running smp' rets fn_table (Stack.snat n stack) input output
      | del n :: smp' =>
        match Stack.del n stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | get n :: smp' =>
        match Stack.get n stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | pack n :: smp' =>
        match Stack.pack n stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | unpack :: smp' =>
        match Stack.unpack stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | cond_get n k :: smp' =>
        match Stack.cond_get stack n k with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | call :: smp' =>
        match stack_call stack fn_table with
        | (Some stack', smf) =>
          running smf (smp' :: rets) fn_table stack' input output
        | (None, _) => error
        end
      | inc :: smp' =>
        match Stack.inc stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | dec :: smp' =>
        match Stack.dec stack with
        | Some stack' => running smp' rets fn_table stack' input output
        | None => error
        end
      | read :: smp' =>
        match input with
        | [] =>  running smp' rets fn_table (Stack.snat 0 stack) [] output
        | a :: tl => running smp' rets fn_table (Stack.snat a stack) tl output
        end
      | out :: smp' =>
        match Stack.out stack with
        | Some a => running smp' rets fn_table stack input (output ++ [a])
        | None => error
        end
      end
    end.

  Inductive Ctx :=
  | ctx (smp: SMProgram) (fn_table: list SMProgram) (n_args stack_size: nat).

  Definition inc_fid := 1.

  Function lambda_to_sml (l: Lambda.Lambda) (c: Ctx): Ctx :=
    match c with
    | ctx smp fn_table n_args stack_size =>
      match l with
      | Lambda.var n =>
        ctx (smp ++ [get (stack_size - n - 1)]) fn_table n_args (S stack_size)
      | Lambda.lam e =>
        match lambda_to_sml e (ctx [] fn_table (S n_args) (S n_args)) with
        | ctx body fn_table' _ stack_size' =>
          (* remove arguments at end of body, leaving only return val *)
          let body := body ++ (repeat (del 1) (S n_args)) in
          (* retrieve args and create closure *)
          let smp := smp ++ (repeat (get (stack_size - 1)) n_args)
                         ++ [push (List.length fn_table')]
                         ++ [pack (S n_args)] in
          ctx smp (fn_table' ++ [body]) n_args (S stack_size)
        end
      | Lambda.app e1 e2 =>
        match lambda_to_sml e1 (lambda_to_sml e2 c) with
        | ctx smp fn_table' _ stack_size' =>
          ctx (smp ++ [call]) fn_table' n_args (pred stack_size')
        end
      | Lambda.out e =>
        match lambda_to_sml e c with
        | ctx smp fn_table' _ stack_size' =>
          let smp :=
              smp ++ [push 0; push inc_fid; get 2; call; call; out; del 0] in
          ctx smp fn_table' n_args stack_size'
        end
      end
    end.

  (* Compile lambda to SML without the runtime *)
  Definition lambda_to_sml_fns (l: Lambda.Lambda): list SMProgram :=
    match lambda_to_sml l (ctx [] [] 0 0) with
    | ctx _ fn_table _ _ => fn_table
    end.

  Example app_correct: lambda_to_sml_fns
                         (Lambda.lam
                            (Lambda.app
                               (Lambda.app
                                  (Lambda.var 0)
                                  (Lambda.lam (Lambda.var 0)))
                               (Lambda.lam (Lambda.var 0)))) =
                       [[get 1; del 1; del 1];
                          [get 1; del 1; del 1];
                          [get 0; push 0; pack 2; get 1; push 1; pack 2;
                             get 2; call; call; del 1]].
  Proof.
    auto.
  Qed.

  (* Building Library that reads the input *)
  Fixpoint bump_function_ids_by (n : nat) (smp : SMProgram) : SMProgram :=
    match smp with
    | [] => []
    | push m :: smp' => push (m + n) :: (bump_function_ids_by n smp')
    | hd :: smp' => hd :: (bump_function_ids_by n smp')
    end.

  Definition lib_weight (progs: list (list SMProgram)): nat :=
    List.length progs.

  Function make_library (progs: list (list SMProgram))
           {measure lib_weight progs}: list SMProgram :=
    match progs with
    | [] => []
    | table :: tl =>
      table ++ (make_library
                  (map (map (bump_function_ids_by (List.length table))) tl))
    end.
  Proof.
    intros; unfold lib_weight; rewrite map_length; simpl; omega.
  Defined.

  Definition runtime_lib: list SMProgram :=
    let inc_fns := [[inc]] in
    let nil_fns := lambda_to_sml_fns (Lambda.parse_def Lambda.EMPTY) in
    let cons_fns := lambda_to_sml_fns (Lambda.parse_def Lambda.CONS) in
    let zero_fns := lambda_to_sml_fns (Lambda.parse_def Lambda.ZERO) in
    let succ_fns := lambda_to_sml_fns (Lambda.parse_def Lambda.SUCC) in
    let lib := make_library [[[]]; inc_fns; nil_fns] in
    let nil_fid := List.length lib - 1 in
    let lib := make_library [lib; cons_fns] in
    let cons_fid := List.length lib - 1 in
    let lib := make_library [lib; zero_fns] in
    let zero_fid := List.length lib - 1 in
    let lib := make_library [lib; succ_fns] in
    let succ_fid := List.length lib - 1 in
    let church_fns :=
        let start := List.length lib in
        (* ret_zero [n] *)
        [[del 0; push zero_fid];
           (* do_church_work [n] *)
           [dec; push (start + 2); call; push succ_fid; call];
           (* church [n] *)
           [push (start + 0); push (start + 1); get 2; cond_get 2 1;
              del 1; del 1; del 1; call]] in
    let lib := lib ++ church_fns in
    let church_fid := List.length lib - 1 in
    let enc_list_fns :=
        let start := List.length lib in
        (* ret_nil [n] *)
        [[del 0; push nil_fid];
           (* do_list_enc_work [n] *)
           [push (start + 2); call; get 1; del 2; push church_fid; call;
              push cons_fid; call; call];
           (* list_enc [] *)
           [push (start + 0); push (start + 1); read; cond_get 2 1;
              del 2; del 2; call]] in
    lib ++ enc_list_fns.

  Lemma inc_fid_correct: nth_error runtime_lib inc_fid = Some [inc].
  Proof. auto. Qed.

  (* This is the core routine that compiles from lambda calculus and injects
     the input handling code for the SML runtime *)
  Definition sml_of_lambda (l: Lambda.Lambda): (SMProgram * list SMProgram) :=
    let read_list_fid := List.length runtime_lib - 1 in
    match lambda_to_sml l (ctx [push read_list_fid; call] runtime_lib 0 1) with
    | ctx smp fn_table _ _ => (smp ++ [call], fn_table)
    end.

  (* SML Interpreter *)
  Definition exec_init (main: SMProgram) (fn_table: list SMProgram)
             (input: list nat): SMState :=
    running main [] fn_table Stack.snil input [].

  Definition debug_sm (prog: SMProgram * list SMProgram) (input: list nat)
             (fuel: nat): SMState :=
    let (main, fn_table) := prog in
    Utils.run sm_step (exec_init main fn_table input) fuel.

  Definition interpret_sm (prog: SMProgram * list SMProgram) (input: list nat)
             (fuel: nat): option (list nat) :=
    let (main, fn_table) := prog in
    match Utils.run sm_step (exec_init main fn_table input) fuel with
    | halted output => Some output
    | _ => None
    end.

  (* Examples *)
  Example push_simple:
    interpret_sm ([push 3; out], []) [] 20 = Some [3].
  Proof. auto. Qed.

  Example call_simple:
    interpret_sm ([push 0; out; call; push 2; out],
                  [[push 3; out]]) [] 9 = Some [0; 3; 2].
  Proof. auto. Qed.

  Definition parse_lambda_and_compile (lambda_prog : string) :=
    (Lambda.parse_lambda lambda_prog)
      >>= (fun l => Some (sml_of_lambda l)).

  Definition compile_and_interpret (lambda_prog: string) (input: list nat)
             (f: nat): option (list nat) :=
    (parse_lambda_and_compile lambda_prog)
      >>= (fun l => interpret_sm l input f).

  Example run_trans_out_2:
    compile_and_interpret "\_.^(\f.\x.f (f x))" [] 50 = Some [2].
  Proof. auto. Qed.

  Example run_trans_out_f_id_2:
    compile_and_interpret "\_.^((\x.\y.y) (\x.x) (\f.\x.f (f x)))" [] 69 =
    Some [2].
  Proof. auto. Qed.

  Example run_trans_with_input_1:
    compile_and_interpret "\l.^(l (\x.\y.y) (\x.\y.x))" [5] 337 = Some [5].
  Proof. auto. Qed.

  Example run_trans_echo:
    compile_and_interpret Lambda.lambda_echo [1;2;3] 1673 = Some([1;2;3]).
  Proof. auto. Qed.

End SML.


Require Import Coq.Bool.Bool.
Require Import Coq.Lists.List.
Require Import Coq.Structures.Orders.
Require Import Coq.Structures.OrdersEx.
Require Import Coq.FSets.FMapInterface.
Require Import Coq.Program.Program.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.ListUtil.Forall.
Require Import Crypto.Util.ListUtil.SetoidList.
Require Import Crypto.Util.Compose.
Require Import Crypto.Util.Logic.Forall.
Require Import Crypto.Util.Logic.Exists.
Require Import Crypto.Util.Option.
Require Import Crypto.Util.Structures.Equalities.Iso.
Require Import Crypto.Util.Structures.Orders.
Require Import Crypto.Util.Structures.Orders.Iso.
Require Import Crypto.Util.Sorting.Sorted.Proper.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.Tactics.DestructHead.
Require Import Crypto.Util.Tactics.SpecializeAllWays.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SpecializeUnderBindersBy.
Require Import Crypto.Util.Tactics.BreakMatch.
Require Import Crypto.Util.Tactics.SetoidSubst.

Local Set Implicit Arguments.
(* TODO: move to global settings *)
Local Set Keyed Unification.
Local Open Scope lazy_bool_scope.

Create HintDb fmapsect discriminated.

Module WSectSfun (E' : DecidableType) (W' : WSfun E')
       (E : SectDecidableTypeOrig E') <: WSfun E.
  Local Existing Instances E.Proper_to_ E.Proper_of_.

  Local Instance E_eq_equiv : Equivalence E.eq | 10. split; hnf; eauto. Qed.
  Local Instance E'_eq_equiv : Equivalence E'.eq | 10. split; hnf; eauto. Qed.
  Local Instance W'_eq_key_equiv elt : Equivalence (@W'.eq_key elt) | 10. split; cbv; eauto. Qed.
  Local Instance W'_eq_key_elt_equiv elt : Equivalence (@W'.eq_key_elt elt) | 10. split; repeat intros [? ?]; cbv in *; subst; eauto. Qed.

  Definition key := E.t.

  Global Hint Transparent key : core.

  Definition is_proper_key (x : W'.key) : bool
    := if E'.eq_dec x (E.to_ (E.of_ x)) then true else false.
  Definition t elt := { m : W'.t elt | forall x e, W'.MapsTo x e m -> is_proper_key x = true }.

  Local Obligation Tactic := cbv beta; intros.

  Notation mk m' := (exist (fun m : W'.t _ => forall x e, W'.MapsTo x e m -> is_proper_key x = true) m' (fun x e pf => _)).

  Definition lift {A} (f : W'.key -> A) : key -> A
    := fun x => f (E.to_ x).
  Definition liftho {A B} (f : (W'.key -> A) -> B) : (key -> A) -> B
    := fun f' => f (fun x => f' (E.of_ x)).

  Lemma is_proper_key_to k : is_proper_key (E.to_ k) = true.
  Proof.
    cbv [is_proper_key].
    destruct E'.eq_dec; try reflexivity.
    rewrite E.of_to in *.
    exfalso; eauto.
  Qed.
#[global]
  Hint Immediate is_proper_key_to : fmapsect.

  Global Instance Proper_is_proper_key : Proper (E'.eq ==> eq) is_proper_key | 10.
  Proof.
    repeat intro; cbv [is_proper_key].
    do 2 destruct E'.eq_dec; setoid_subst_rel E'.eq; try reflexivity.
    all: exfalso; eauto.
  Qed.

  Local Ltac handle_pf :=
    repeat first [ progress intros
                 | progress cbv beta in *
                 | progress cbv [lift liftho] in *
                 | progress cbn [proj1_sig] in *
                 | exfalso; assumption
                 | progress subst
                 | progress inversion_option
                 | match goal with
                   | [ H : W'.MapsTo _ _ (W'.empty _) |- _ ] => apply W'.empty_1 in H
                   | [ H : W'.MapsTo _ _ (W'.remove _ _) |- _ ] => apply W'.remove_3 in H
                   | [ H : W'.MapsTo ?y ?e (W'.add ?x ?v ?m) |- _ ]
                     => destruct (E'.eq_dec x y);
                        [ let H' := fresh in
                          pose proof (@W'.add_1 _ m x y v ltac:(assumption)) as H';
                          apply W'.find_1 in H;
                          apply W'.find_1 in H';
                          rewrite H in H';
                          clear H
                        | apply W'.add_3 in H; [ | assumption ] ]
                   | [ H : W'.MapsTo _ _ (W'.map ?f _) |- _ ]
                     => let H' := fresh in
                        let H'' := fresh in
                        destruct (@W'.map_2 _ _ _ _ _ (ex_intro _ _ H)) as [? H'];
                        pose proof (@W'.map_1 _ _ _ _ _ f H') as H'';
                        apply W'.find_1 in H;
                        apply W'.find_1 in H'';
                        rewrite H in H'';
                        clear H
                   | [ H : W'.MapsTo _ _ (W'.mapi ?f _) |- _ ]
                     => let H' := fresh in
                        let H'' := fresh in
                        destruct (@W'.mapi_2 _ _ _ _ _ (ex_intro _ _ H)) as [? H'];
                        destruct (@W'.mapi_1 _ _ _ _ _ f H') as [? [? H'']];
                        apply W'.find_1 in H;
                        apply W'.find_1 in H'';
                        rewrite H in H'';
                        clear H
                   end
                 | solve [ eauto with nocore fmapsect ]
                 | progress setoid_subst_rel E'.eq
                 | progress destruct_head' t
                 | match goal with
                   | [ H : W'.MapsTo _ _ (W'.map2 ?f _ _) |- _ ]
                     => let H' := fresh in
                        let H'' := fresh in
                        pose proof (@W'.map2_2 _ _ _ _ _ _ _ (ex_intro _ _ H)) as H';
                        pose proof (@W'.map2_1 _ _ _ _ _ _ f H') as H'';
                        apply W'.find_1 in H;
                        rewrite H in H'';
                        clear H;
                        destruct H' as [[? H']|[? H']];
                        pose proof H' as H;
                        apply W'.find_1 in H;
                        rewrite H in H'';
                        clear H
                   end ].

  Local Obligation Tactic := try abstract handle_pf; handle_pf.

  Program Definition empty elt : t elt := mk (@W'.empty elt).
  Program Definition is_empty : forall elt, t elt -> bool := W'.is_empty.
  Program Definition add elt (k : key) (v : elt) (m : t elt) : t elt
    := mk (lift (@W'.add elt) k v m).
  Program Definition find elt : key -> t elt -> option elt := lift (@W'.find elt).
  Program Definition remove elt (k : key) (m : t elt) : t elt
    := mk (lift (@W'.remove elt) k m).
  Program Definition mem elt : key -> t elt -> bool := lift (@W'.mem elt).
  Program Definition map elt elt' (f : elt -> elt') (m : t elt) : t elt'
    := mk (W'.map f m).
  Program Definition mapi elt elt' (f : key -> elt -> elt') (m : t elt) : t elt'
    := mk (liftho (@W'.mapi elt elt') f m).
  Program Definition map2 elt elt' elt'' (f : option elt -> option elt' -> option elt'') (m : t elt) (m' : t elt') : t elt''
    := mk (W'.map2 f m m').
  Program Definition elements elt (v : t elt) : list (key * elt) := List.map (fun kv => (E.of_ (fst kv), snd kv)) (W'.elements v).
  Program Definition cardinal : forall elt, t elt -> nat := W'.cardinal.
  Program Definition fold elt A : (key -> elt -> A -> A) -> t elt -> A -> A := liftho (@W'.fold elt A).
  Program Definition equal : forall elt, (elt -> elt -> bool) -> t elt -> t elt -> bool := W'.equal.
  Program Definition MapsTo elt : key -> elt -> t elt -> Prop := lift (@W'.MapsTo elt).
  Program Definition In elt : key -> t elt -> Prop := lift (@W'.In elt).
  Definition eq_key elt (p p' : key * elt) : Prop := E.eq (fst p) (fst p'). (* W'.eq_key (E.to_ (fst p), snd p) (E.to_ (fst p'), snd p').*)
  Definition eq_key_elt elt (p p' : key * elt) : Prop := E.eq (fst p) (fst p') /\ snd p = snd p'. (*W'.eq_key_elt (E.to_ (fst p), snd p) (E.to_ (fst p'), snd p').*)

  Local Instance Proper_lift {A R f}
        {f_Proper : Proper (E'.eq ==> R) f}
    : Proper (E.eq ==> R) (@lift A f).
  Proof.
    cbv [lift]; repeat intro; do 2 f_equiv; assumption.
  Qed.

  Local Instance Proper_liftho {A B RA RB f}
        {f_Proper : Proper ((E'.eq ==> RA) ==> RB) f}
    : Proper ((E.eq ==> RA) ==> RB) (@liftho A B f).
  Proof.
    cbv [liftho]; do 3 (repeat intro; f_equiv; try eassumption).
  Qed.

  Local Instance Proper_W'_eq_key_elt_iff elt
    : Proper (eq ==> RelationPairs.RelProd E'.eq eq ==> iff) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_elt_impl elt
    : Proper (eq ==> RelationPairs.RelProd E'.eq eq ==> impl) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_elt_flip_impl elt
    : Proper (eq ==> RelationPairs.RelProd E'.eq eq ==> flip impl) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_elt_iff' elt
    : Proper (@W'.eq_key_elt elt ==> @W'.eq_key_elt elt ==> iff) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_elt_impl' elt
    : Proper (@W'.eq_key_elt elt ==> @W'.eq_key_elt elt ==> impl) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_elt_flip_impl' elt
    : Proper (@W'.eq_key_elt elt ==> @W'.eq_key_elt elt ==> flip impl) (@W'.eq_key_elt elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_iff elt
    : Proper (@W'.eq_key elt ==> @W'.eq_key elt ==> iff) (@W'.eq_key elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_impl elt
    : Proper (@W'.eq_key elt ==> @W'.eq_key elt ==> impl) (@W'.eq_key elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Local Instance Proper_W'_eq_key_flip_impl elt
    : Proper (@W'.eq_key elt ==> @W'.eq_key elt ==> flip impl) (@W'.eq_key elt).
  Proof. cbv; repeat intro; subst; destruct_head'_prod; destruct_head'_and; subst; firstorder (subst; eauto). Qed.

  Lemma eq_to_iff x y : E'.eq (E.to_ x) (E.to_ y) <-> E.eq x y.
  Proof.
    split; intro H; [ | now f_equiv ].
    etransitivity; rewrite <- E.of_to; [ | reflexivity ]; f_equiv; assumption.
  Qed.

  Lemma eq_to_of_impl x y
    : E'.eq (E.to_ x) y -> E.eq x (E.of_ y).
  Proof.
    intro H; (rewrite -> H || rewrite <- H);
      rewrite E.of_to;
      reflexivity.
  Qed.

  Lemma eq_to_of_impl' x y
    : E'.eq y (E.to_ x) -> E.eq (E.of_ y) x.
  Proof. intro; symmetry; apply eq_to_of_impl; symmetry; assumption. Qed.

  Lemma eq_to_of_flip_impl_proper_key x y
        (H' : is_proper_key y = true)
    : E.eq x (E.of_ y) -> E'.eq (E.to_ x) y.
  Proof.
    intro H; (rewrite -> H || rewrite <- H);
      cbv [is_proper_key] in *;
      break_innermost_match_hyps;
      try congruence;
      (idtac + symmetry); assumption.
  Qed.

  Lemma eq_to_of_flip_impl_proper_key' x y
        (H' : is_proper_key y = true)
    : E.eq (E.of_ y) x -> E'.eq y (E.to_ x).
  Proof. intro; symmetry; apply eq_to_of_flip_impl_proper_key; auto; symmetry; assumption. Qed.

  Lemma eq_to_of_iff_proper_key x y
        (H' : is_proper_key y = true)
    : E'.eq (E.to_ x) y <-> E.eq x (E.of_ y).
  Proof.
    split; (apply eq_to_of_impl + apply eq_to_of_flip_impl_proper_key); assumption.
  Qed.

  Lemma eq_to_of_iff_proper_key' x y
        (H' : is_proper_key y = true)
    : E'.eq y (E.to_ x) <-> E.eq (E.of_ y) x.
  Proof.
    split; (apply eq_to_of_impl' + apply eq_to_of_flip_impl_proper_key'); assumption.
  Qed.

  Local Instance W'_Equal_Equivalence elt : Equivalence (@W'.Equal elt) | 10.
  Proof. split; cbv; firstorder eauto using eq_trans. Qed.

  Local Ltac t_Proper_helper :=
    cbv [W'.Equal W'.In Proper respectful option_eq];
    repeat first [ progress intros
                 | progress subst
                 | progress destruct_head'_ex
                 | congruence
                 | reflexivity
                 | eassumption
                 | progress break_innermost_match_hyps
                 | progress break_innermost_match
                 | apply W'.find_2
                 | match goal with
                   | [ H : E'.eq ?x ?y |- _ ]
                     => (idtac + symmetry in H); eapply W'.MapsTo_1 in H; [ | apply W'.find_2; eassumption ]
                   | [ H : _ |- _ ] => apply W'.find_1 in H
                   | [ |- Some _ = None ] => exfalso
                   | [ |- ?x = None ] => destruct x eqn:?
                   | [ |- _ <-> _ ] => split
                   | [ H : W'.find ?k ?m = Some ?v, H' : forall k', W'.find k' ?m = W'.find k' ?m' |- _ ]
                     => unique assert (W'.find k m' = Some v) by now rewrite <- H
                   | [ H : W'.find ?k ?m' = Some ?v, H' : forall k', W'.find k' ?m = W'.find k' ?m' |- _ ]
                     => unique assert (W'.find k m = Some v) by now rewrite <- H
                   end
                 | eexists ].

  Local Instance W'_find_Proper_eq elt : Proper (E'.eq ==> @W'.Equal _ ==> option_eq eq) (@W'.find elt) | 10.
  Proof. t_Proper_helper. Qed.

  Local Instance W'_MapsTo_Proper_eq_iff elt : Proper (E'.eq ==> eq ==> @W'.Equal _ ==> iff) (@W'.MapsTo elt) | 10.
  Proof. t_Proper_helper. Qed.

  Local Instance W'_In_compat elt : Proper (E'.eq ==> @W'.Equal _ ==> iff) (@W'.In elt) | 10.
  Proof. t_Proper_helper. Qed.

  Definition Empty elt (m : t elt) := forall a e, ~ MapsTo a e m.
  Definition Equal elt (m m' : t elt) := forall y, find y m = find y m'.
  Definition Equiv elt (eq_elt:elt->elt->Prop) m m' :=
    (forall k, In k m <-> In k m') /\
      (forall k e e', MapsTo k e m -> MapsTo k e' m' -> eq_elt e e').
  Definition Equivb elt (cmp: elt->elt->bool) := Equiv (Cmp cmp).

  Program Definition Empty_alt : forall elt, t elt -> Prop := W'.Empty.
  Program Definition Equal_alt : forall elt, t elt -> t elt -> Prop := W'.Equal.
  Program Definition Equiv_alt : forall elt, (elt -> elt -> Prop) -> t elt -> t elt -> Prop := W'.Equiv.
  Program Definition Equivb_alt : forall elt, (elt->elt->bool) -> t elt -> t elt -> Prop := W'.Equivb.

  Lemma forall_lift_key_dep {A} f (P : key -> A -> Prop) R
        (f_Proper : Proper (E'.eq ==> R) f)
        (P_Proper : Proper (E.eq ==> R ==> Basics.impl) P)
    : (forall a : key, P a (@lift A f a)) <-> (forall a : W'.key, is_proper_key a = true -> P (E.of_ a) (f a)).
  Proof.
    cbv [lift].
    split; intro H; intro x; [ intro P'; specialize (H (E.of_ x)) | specialize (H (E.to_ x)) ].
    all: cbv [is_proper_key] in *.
    all: break_innermost_match_hyps.
    all: rewrite ?E.of_to in *.
    all: cbv [not] in *.
    all: try discriminate.
    all: specialize_by reflexivity.
    all: trivial.
    all: try now exfalso.
    eapply P_Proper; try eassumption; try reflexivity.
    apply f_Proper.
    (idtac + symmetry); eassumption.
  Qed.

  Lemma forall_lift_key_dep_no_proper {A} f (P : key -> A -> Prop) R
        (f_Proper : Proper (E'.eq ==> R) f)
        (P_Proper : Proper (E.eq ==> R ==> Basics.impl) P)
        (H_side_cond : forall a : W'.key, is_proper_key a = false -> P (E.of_ a) (f a))
    : (forall a : key, P a (@lift A f a)) <-> (forall a : W'.key, P (E.of_ a) (f a)).
  Proof.
    rewrite forall_lift_key_dep by eassumption.
    apply pull_forall_iff; intro a.
    specialize (H_side_cond a).
    destruct (is_proper_key a); intuition.
  Qed.

  Local Ltac t_alt_iff :=
    cbv [In find MapsTo
            Equal_alt Empty_alt Equiv_alt Equivb_alt
            Equal Empty Equiv Equivb];
    let rec get_P lift_f P :=
      lazymatch P with
      | fun a : ?A => ?P
        => let P' := fresh in
           let a' := fresh in
           constr:(fun a' : A
                   => ltac:(let P := constr:(match a' with a => P end) in
                            let res := get_P (lift_f a') P in
                            exact res))
      | _
        => lazymatch (eval pattern lift_f in P) with
           | ?P _ => exact P
           end
      end in
    let rec handle_one_lift LHS :=
      lazymatch LHS with
      | ?G1 /\ ?G2
        => handle_one_lift G1; [ handle_one_lift G2 | .. ]
      | context[lift ?f]
        => lazymatch LHS with
           | (forall a : key, @?P a)
             => let P' := get_P (lift f) P in
                setoid_rewrite (@forall_lift_key_dep_no_proper _ f P')
           | _ => fail 0 "unhandled" LHS (*
|
         | [ |-                (exists a : elt, @?P a) <-> _ ]
           => let P' := get_P (lift f) P in
              setoid_rewrite (@exists_lift_dep _ f P')*)
           end
      | _ => idtac
      end in
    let rec handle_lift _ :=
      let LHS := lazymatch goal with |- ?LHS <-> _ => LHS end in
      lazymatch LHS with
      | context[lift ?f] => handle_one_lift LHS; [ handle_lift () | .. ]
      | _ => idtac
      end in
    handle_lift ();
    try exact _;
    [ try reflexivity; cbv [W'.Equal W'.Empty W'.Equiv W'.Equivb]
    | try solve [ cbv [Proper respectful Basics.impl Basics.flip option_eq];
                  intros; split_iff;
                  destruct_head' t; cbn [proj1_sig] in *;
                  specialize_under_binders_by reflexivity;
                  specialize_all_ways; break_innermost_match_hyps; inversion_option; subst;
                  firstorder eauto; congruence ];
      lazymatch goal with
      | [ |- context[is_proper_key _ = false] ]
        => repeat first [ progress destruct_head' t
                        | progress cbn [proj1_sig] in *
                        | progress specialize_under_binders_by apply W'.find_2
                        | congruence
                        | progress specialize_all_ways_under_binders_by eassumption
                        | progress intros
                        | match goal with
                          | [ |- context[W'.find ?x ?m] ] => destruct (W'.find x m) eqn:?
                          end ]
      | _ => idtac
      end ..
    ].

  Lemma Equal_alt_iff elt (s s' : t elt) : Equal s s' <-> Equal_alt s s'.
  Proof. t_alt_iff. Qed.
  Lemma Empty_alt_iff elt (s : t elt) : Empty s <-> Empty_alt s.
  Proof. t_alt_iff. Qed.
  Lemma Equiv_alt_iff elt eq_elt (s s' : t elt) : Equiv eq_elt s s' <-> Equiv_alt eq_elt s s'.
  Proof. t_alt_iff. Qed.
  Lemma Equivb_alt_iff elt cmp (s s' : t elt) : Equivb cmp s s' <-> Equivb_alt cmp s s'.
  Proof. t_alt_iff. Qed.

  Create HintDb fmapsect_is_proper_key discriminated.
  Create HintDb iso_map_alt discriminated.
  Create HintDb iso_map_alt1 discriminated.
  Create HintDb iso_map_alt2 discriminated.
  Create HintDb iso_map_alt3 discriminated.

  Global
  Hint Unfold
       empty
       is_empty
       mem
       add
       find
       remove
       mem
       map
       mapi
       map2
       elements
       cardinal
       fold
       equal
       MapsTo
       In
       Empty
       Empty_alt
       Equiv_alt
       Equivb_alt
       eq_key
       eq_key_elt
       W'.eq_key
       W'.eq_key_elt
       option_map
       lift
       liftho
    : iso_map_alt.

#[global]
  Hint Rewrite Empty_alt_iff Equal_alt_iff Equiv_alt_iff Equivb_alt_iff
       eq_to_iff
       (*eq_to_of_impl
       eq_to_of_impl'*)
       (*W'.is_empty_spec
       W'.mem_spec
       W'.add_spec
       W'.remove_spec
       W'.singleton_spec
       W'.union_spec
       W'.inter_spec
       W'.diff_spec
       W'.equal_spec
       W'.subset_spec
       W'.fold_spec
       W'.for_all_spec
       W'.exists_spec
       W'.partition_spec1
       W'.partition_spec2
       W'.filter_spec
       W'.cardinal_spec *)
       W'.cardinal_1
       W'.fold_1
       E.of_to
       (*E.to_of*)
       map_length
       fold_left_map
    : iso_map_alt.

  Global Hint Resolve
         W'.MapsTo_1
         W'.mem_1
         W'.empty_1
         W'.is_empty_1
         W'.add_1
         W'.remove_1
         W'.find_1
         W'.elements_1
         W'.equal_1
         W'.map_1
         W'.mapi_1
         W'.map2_1
    : iso_map_alt1.
  Global Hint Resolve
         W'.mem_2
         W'.is_empty_2
         W'.add_2
         W'.remove_2
         W'.find_2
         W'.elements_2
         W'.equal_2
         W'.map_2
         W'.mapi_2
         W'.map2_2
    : iso_map_alt2.
  Global Hint Resolve
         W'.add_3
         W'.remove_3
         W'.elements_3w
    : iso_map_alt3.
  Global Hint Extern 10 => rewrite eq_to_iff in *
             : iso_map_alt1 iso_map_alt2 iso_map_alt3.

  Global Hint Immediate
         eq_to_of_impl
         eq_to_of_impl'
    : iso_map_alt1 iso_map_alt2 iso_map_alt3 core.

  (*Local Hint Resolve
        W'.empty_spec
        W'.elements_spec2w
        W'.choose_spec1
        W'.choose_spec2
    : core.*)

  Local Ltac spec_t_step_quick
    := first [ progress intros
             | progress cbn [fst snd] in *
             | progress subst
             | apply (f_equal2 (@pair _ _))
             | progress repeat autorewrite with iso_map_alt in *
             | progress repeat autounfold with iso_map_alt in *
             | match goal with H : _ |- _ => refine H end
             | reflexivity
             | progress auto
             | exact _
             | progress destruct_head'_and
             | progress destruct_head'_ex
             | progress specialize_under_binders_by eassumption
             | match goal with
               | [ H : _ * _ |- _ ] => let H' := fresh in rename H into H'; destruct H'
               end ].

  Global Hint Extern 100
         => spec_t_step_quick
           : iso_map_alt1 iso_map_alt2 iso_map_alt3.

  Local Ltac spec_t
    := repeat first [ spec_t_step_quick
                    | solve [ eauto with iso_map_alt1 nocore ]
                    | solve [ eauto with iso_map_alt2 nocore ]
                    | solve [ eauto with iso_map_alt3 nocore ] ].

  Local Hint Extern 2 => Proper_compose_hint : typeclass_instances.

#[global]
  Hint Transparent W'.eq_key_elt : fmapsect_is_proper_key.

  Lemma is_proper_key_of_InA_elements elt k v (m : t elt)
        (H : InA (@W'.eq_key_elt _) (k, v) (W'.elements (` m)))
    : is_proper_key k = true.
  Proof.
    destruct m as [m H']; cbn [proj1_sig] in *.
    spec_t.
  Qed.

  Lemma is_proper_key_of_In_elements elt k v (m : t elt)
        (H : List.In (k, v) (W'.elements (` m)))
    : is_proper_key k = true.
  Proof.
    eapply is_proper_key_of_InA_elements.
    rewrite InA_alt.
    eexists (_, _); split; [ | eassumption ]; split; reflexivity.
  Qed.

#[global]
  Hint Resolve
       is_proper_key_of_InA_elements
       is_proper_key_of_In_elements
    : fmapsect_is_proper_key.

#[global]
  Hint Rewrite
       eq_to_of_iff_proper_key
       eq_to_of_iff_proper_key
       using solve [ eauto with nocore fmapsect_is_proper_key ]
    : iso_map_alt.

  Section Spec.

    Variable elt:Type.
    Variable elt' elt'' : Type.
    Variable m m' m'' : t elt.
    Variable x y z : key.
    Variable e e' : elt.

    Lemma MapsTo_1 : E.eq x y -> MapsTo x e m -> MapsTo y e m.
    Proof using Type. clear. spec_t. Qed.
    Lemma mem_1 : In x m -> mem x m = true.
    Proof using Type. clear. spec_t. Qed.
    Lemma mem_2 : mem x m = true -> In x m.
    Proof using Type. clear. spec_t. Qed.
    Lemma empty_1 : Empty (@empty elt).
    Proof using Type. clear. spec_t. Qed.
    Lemma is_empty_1 : Empty m -> is_empty m = true.
    Proof using Type. clear. spec_t. Qed.
    Lemma is_empty_2 : is_empty m = true -> Empty m.
    Proof using Type. clear. spec_t. Qed.
    Lemma add_1 : E.eq x y -> MapsTo y e (add x e m).
    Proof using Type. clear. spec_t. Qed.
    Lemma add_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (add x e' m).
    Proof using Type. clear. spec_t. Qed.
    Lemma add_3 : ~ E.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m.
    Proof using Type. clear. spec_t. Qed.
    Lemma remove_1 : E.eq x y -> ~ In y (remove x m).
    Proof using Type. clear. spec_t. Qed.
    Lemma remove_2 : ~ E.eq x y -> MapsTo y e m -> MapsTo y e (remove x m).
    Proof using Type. clear. spec_t. Qed.
    Lemma remove_3 : MapsTo y e (remove x m) -> MapsTo y e m.
    Proof using Type. clear. spec_t. Qed.
    Lemma find_1 : MapsTo x e m -> find x m = Some e.
    Proof using Type. clear. spec_t. Qed.
    Lemma find_2 : find x m = Some e -> MapsTo x e m.
    Proof using Type. clear. spec_t. Qed.
    Lemma elements_1 :
      MapsTo x e m -> InA (@eq_key_elt _) (x,e) (elements m).
    Proof using Type. clear. spec_t. rewrite InA_map_iff_strict_InA in *; spec_t. Qed.
    Lemma elements_2 :
      InA (@eq_key_elt _) (x,e) (elements m) -> MapsTo x e m.
    Proof using Type. clear. spec_t. rewrite InA_map_iff_strict_InA in *; spec_t. Qed.
    Lemma elements_3w : NoDupA (@eq_key _) (elements m).
    Proof using Type.
      clear.
      pose proof (W'.elements_3w (` m)).
      spec_t.
      apply NoDupA_map_inv with (f:=fun p => (E.to_ (fst p), snd p)) (eqB:=@W'.eq_key _); [ cbv; intros *; break_innermost_match; now spec_t | ].
      rewrite List.map_map.
      setoid_rewrite (_ : eqlistA (@W'.eq_key _) (List.map _ _) _);
        [ instantiate (1:=List.map (fun x => x) _); rewrite List.map_id; eassumption
        | ].
      rewrite eqlistA_altdef, Forall2_map_map_iff, Forall2_Forall, Forall_forall.
      cbv [W'.eq_key Proper]; cbn [fst snd].
      spec_t.
    Qed.
    Lemma cardinal_1 : cardinal m = length (elements m).
    Proof using Type. clear. spec_t. Qed.

    Lemma fold_1 :
      forall (A : Type) (i : A) (f : key -> elt -> A -> A),
        fold f m i = fold_left (fun a p => f (fst p) (snd p) a) (elements m) i.
    Proof using Type. clear. spec_t. Qed.

    Variable cmp : elt -> elt -> bool.

    Lemma equal_1 : Equivb cmp m m' -> equal cmp m m' = true.
    Proof using Type. clear. spec_t. Qed.
    Lemma equal_2 : equal cmp m m' = true -> Equivb cmp m m'.
    Proof using Type. clear. spec_t. Qed.
  End Spec.

  Lemma map_1 : forall (elt elt':Type)(m: t elt)(x:key)(e:elt)(f:elt->elt'),
      MapsTo x e m -> MapsTo x (f e) (map f m).
  Proof. clear. spec_t. Qed.
  Lemma map_2 : forall (elt elt':Type)(m: t elt)(x:key)(f:elt->elt'),
      In x (map f m) -> In x m.
  Proof. clear. spec_t. Qed.
  Lemma mapi_1 (elt elt':Type)(m: t elt)(x:key)(e:elt)
        (f:key->elt->elt')
    : MapsTo x e m ->
      exists y, E.eq y x /\ MapsTo x (f y e) (mapi f m).
  Proof.
    clear.
    pose proof (fun x => @W'.mapi_1 elt elt' (`m) x e (fun x => f (E.of_ x))).
    spec_t.
    eexists.
    split; [ | eassumption ].
    spec_t.
  Qed.
  Lemma mapi_2
    : forall (elt elt':Type)(m: t elt)(x:key)
             (f:key->elt->elt'), In x (mapi f m) -> In x m.
  Proof. clear. spec_t. Qed.
  Lemma map2_1
    : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	     (x:key)(f:option elt->option elt'->option elt''),
      In x m \/ In x m' ->
      find x (map2 f m m') = f (find x m) (find x m').
  Proof. clear. spec_t. Qed.
  Lemma map2_2
    : forall (elt elt' elt'':Type)(m: t elt)(m': t elt')
	     (x:key)(f:option elt->option elt'->option elt''),
      In x (map2 f m m') -> In x m \/ In x m'.
  Proof. clear. spec_t. Qed.
End WSectSfun.

Module WSectS (W' : WS) (E : SectDecidableTypeOrig W'.E) <: WS.
  Module E := E.
  Include WSectSfun W'.E W' E.
End WSectS.

Module SectSfun (E' : OrderedTypeOrig) (W' : Sfun E') (E : SectOrderedTypeOrig E') <: Sfun E.
  Include WSectSfun E' W' E.
  Module E'Compat := E' <+ UpdateEq <+ UpdateStrOrder_Compat.
  Module ECompat := E <+ UpdateEq <+ UpdateStrOrder_Compat.
  Section elt.
    Variable elt:Type.
    Definition lt_key (p p':key*elt) := E.lt (fst p) (fst p').

    Lemma elements_3 m : sort lt_key (elements m).
    Proof using Type.
      pose proof (W'.elements_3 (`m)).
      cbv [elements lt_key W'.lt_key] in *.
      rewrite Sorted_map_iff.
      cbn [fst snd].
      destruct m as [m pf]; cbn [proj1_sig] in *.
      specialize_under_binders_by apply W'.elements_2.
      induction H; constructor; [ | destruct_head' HdRel; constructor ].
      all: repeat first [ progress specialize_all_ways_under_binders_by eapply InA_cons_hd
                        | progress specialize_all_ways_under_binders_by eapply InA_cons_tl ].
      all: specialize_under_binders_by apply conj.
      all: cbn [fst snd] in *.
      all: specialize_under_binders_by reflexivity.
      all: specialize_by_assumption.
      all: eauto.
      all: cbv [is_proper_key] in *; break_innermost_match_hyps; try discriminate.
      destruct_head'_prod; cbn [fst snd] in *.
      clear pf.
      repeat match goal with
             | [ H : Sorted _ _ |- _ ] => clear H
             | [ H : context[InA] |- _ ] => clear H
             | [ H : ?x = ?x |- _ ] => clear H
             end.
      match goal with
      | [ |- E.lt ?x ?y ]
        => destruct (E.compare x y) as [pf'|pf'|pf']; try assumption
      end.
      { rewrite pf' in *.
        setoid_subst_rel E'.eq.
        exfalso; eapply E'.lt_not_eq; (idtac + symmetry); eassumption. }
      { apply E.Proper_to_lt in pf'.
        repeat match goal with
               | [ H : E'.eq ?x (E.to_ (E.of_ ?x)) |- _ ]
                 => rewrite <- H in *
               end.
        exfalso; eapply E'.lt_not_eq; try reflexivity; eapply E'.lt_trans; eassumption. }
    Qed.
  End elt.
End SectSfun.

Module SectS (S' : S) (E' : SectMiniOrderedType S'.E) <: S.
  Module E <: SectOrderedTypeOrig S'.E := E' <+ OT_of_MOT.
  Global Remove Hints E.eq_refl E.eq_sym E.eq_trans : core.
  Include SectSfun S'.E S' E.
End SectS.

(* TODO:
Module SectSord (S' : Sord) (Data' : SectMiniOrderedType S'.Data) (E : SectMiniOrderedType S'.MapS.E) (S'_iso : SectMiniOrderedType S') <: Sord <: SectOrderedType S'.
  Module Data <: SectOrderedType S'.Data := Data' <+ OT_of_MOT.
  Module MapS <: S := SectS S'.MapS E.
  Import MapS.

  Definition t := MapS.t Data.t.

  Definition eq : t -> t -> Prop.
    refine (_ S'.eq).
    compute.
    pose MapS.E.
  Parameter lt : t -> t -> Prop.

  Axiom eq_refl : forall m : t, eq m m.
  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.

  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.

  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.

  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
  (** Total ordering between maps. [Data.compare] is a total ordering
      used to compare data associated with equal keys in the two maps. *)

  Include S.
  Include OT_of_MOT.
End SectSord.
  Definition t := MapS.t Data.t.

  Print SectMiniOrderedType.
  Definition eq : t -> t -> Prop := S'.eq.
  Parameter lt : t -> t -> Prop.

  Axiom eq_refl : forall m : t, eq m m.
  Axiom eq_sym : forall m1 m2 : t, eq m1 m2 -> eq m2 m1.
  Axiom eq_trans : forall m1 m2 m3 : t, eq m1 m2 -> eq m2 m3 -> eq m1 m3.
  Axiom lt_trans : forall m1 m2 m3 : t, lt m1 m2 -> lt m2 m3 -> lt m1 m3.
  Axiom lt_not_eq : forall m1 m2 : t, lt m1 m2 -> ~ eq m1 m2.

  Definition cmp e e' := match Data.compare e e' with EQ _ => true | _ => false end.

  Parameter eq_1 : forall m m', Equivb cmp m m' -> eq m m'.
  Parameter eq_2 : forall m m', eq m m' -> Equivb cmp m m'.

  Parameter compare : forall m1 m2, Compare lt eq m1 m2.
  (** Total ordering between maps. [Data.compare] is a total ordering
      used to compare data associated with equal keys in the two maps. *)

End Sord.

*)


Require Import BinNat.
Require Import Lia.
From Equations Require Import Equations.

(* Needed to use wf recursion on type N *)
Global Instance lt_wf : WellFounded N.lt.
Proof.
intro x.
induction x using N.peano_ind.
+ constructor.
	intros y Hy.
	lia.
+ constructor.
	intros y Hy.
	apply N.lt_succ_r in Hy.
	apply N.le_lteq in Hy.
	destruct Hy.
	- constructor.
		inversion IHx.
		now apply H0.
	- now subst.
Qed.

Require Import FreeSpec.Program.
Require Import FreeSpec.Specification.

Lemma correct_run_program_bind
      {I:         Type -> Type}
      {A B W:     Type}
      (c:         Specification W I)
      (w w':      W)
      (p:         Program I A)
      (f:         A -> Program I B)
      (x:         B)
  : correct_run c w (program_bind p f) x w'
		-> exists y w'', correct_run c w p y w''
			/\ correct_run c w'' (f y) x w'.
Proof.
intros.
revert B f x H.
induction p.
+ exists a.
       exists w.
       constructor.
       - constructor.
       - now cbn in H.
+	admit.
Admitted.


Load test.
Print some.
Let a:=some.
Parameter signed1: object->human->Prop.
Theorem EX:(walk) john-> some man (walk). (**GAUTO  x x x* (here only AUTO is used which takes no arguments, "x x x" are used because GAUTO takes obligatory 3 arguments, they play no role for proofs involving only use of AUTO*)  intro. unfold some. exists john. assumption. Qed.

Theorem EX1: some man (walk) -> (walk) john.
cbv. intro. elim H. intro. intro. replace john with x.
assumption. (**this cannot be proven*)

  Theorem EX2:  all man (walk)->walk john. (**GAUTO x x x*)
    cbv. intro. apply H. Qed.

 Theorem EX3: all man (walk)->walk john->some man (walk). (**GAUTO x x x*)
  cbv. intros.  exists john. assumption. Qed.

 Ltac EXTAC:= cbv; eauto.
 Ltac EXTAC1 x:= cbv; try exists x;EXTAC.

Theorem EX5  :         all man (walk)-> some man (walk).  (** AUTOa John x x (here John is needed to be used with exists*)EXTAC1 john. Qed.

Theorem IRISH: (some irishdelegate)(on_time1 human(finish(the survey)))->(some delegate)(on_time1 human(finish(the survey))). (**AUTOa x x x.*)
cbv. intro. elim H. intro. intro. exists x. auto.
Qed.

Theorem SWE:(a swede)(won3(a nobel_prize))->(a  scandinavian)(won3(a nobel_prize)). (**AUTOa x x x.*)
  cbv. intros. elim H. intros. exists x. assumption. Qed.
Check not1.
Theorem SWE2:not ((a scandinavian)(won2(the nobel_prize)))->not ((a swede)(won2(the  nobel_prize))). (**AUTOa x x x.*)
  cbv. intro. intro. elim H. elim H0. intros. exists x. assumption. Qed.

Theorem SCAN: (no delegate)(on_time1 human(finish(the report)))->not((some scandinaviandelegate)(on_time1 human(finish(the report)))).
(**AUTOa x x x.*)  cbv. intro. intro. elim H0. intro. apply H. Qed.

Theorem IRISH2: (some delegate)(on_time (finish(the survey)))->(some delegate)((finish
                                                                                (the survey))).
  (**AUTOa ADV  x x(ADV  is used so destruct ADV can take effect*) cbv. intro.  destruct ADV in H. elim H. intro. intro. exists x0. apply f0. assumption. Qed.  (** on time delegate finish the survey, the second component of VER delegate  finish the survey is a proof that forall x: delegate, on time delegate finish the survey  x -> finish the survey x *)

Theorem FORT: fortunately (walk john)-> walk john. (**AUTOa ADVS x x (similarly)*)
cbv. destruct ADVS. apply w. Qed.

Parameter in_europe: forall A:CN, (A->Prop)->(A->Prop).
Parameter can: forall A:CN, (A->Prop)->(A->Prop).
Parameter travel: object->Prop.
Parameter freely: forall A:CN, (A->Prop)->(A->Prop).
Parameter within_Europe: forall A:CN, (A->Prop)->(A->Prop).
Let each:= all.
Let person:= human.
Parameter european: CN.
Axiom eu: european->human. Coercion eu: european>->human.
Parameter right_to_live_in_europe:CN.
Check have.
Parameter have1: object->human->Prop.

Axiom ro2: right_to_live_in_europe->object. Coercion ro2: right_to_live_in_europe>->object.

Theorem EUROPEAN: ((each european)(have1
(the right_to_live_in_europe))/\forall x:person, ((have1
(the right_to_live_in_europe)x)->can human(within_Europe human (freely human
(travel)))x))->(each european)(can human(within_Europe human(freely human
                                                                    (travel)))).
(**AUTOa x x x*)   cbv.  intuition.  Qed.

Theorem GENUINE: (a genuine_diamond)(has john)->(a diamond)(has john).
(**AUTOa x x x*)   cbv.   intro. elim H. intros. exists x. assumption. Qed.

Theorem MICKEY: (small animal mickey) ->not( large animal mickey).
  (** The proof here works due to the lexical semantics of Small, defined as both not large and not normalsized *)(**AUTOa x x x.*)  cbv. unfold not. intro. apply H. Qed.

Theorem MICKEY2: (all mouse (small animal)/\ large mouse mickey)->not( large animal mickey). (**AUTOa H1 x H1.*)  cbv. intro. elim H. intro. intro. destruct H0 with mickey. assumption.  Qed.

Set Implicit Arguments.
Parameter Fast : forall A : CN, A -> Prop.
Parameter FASTER_THAN : forall A : CN, {p : A -> A -> Prop & forall h1 h2 h3 : A, (p h1 h2 /\ p h2 h3 -> p h1 h3) /\ (forall h4 h5 : A, p h4 h5 -> Fast  h4 -> Fast  h5)}.
Definition faster_than:= fun A:CN=>projT1 (FASTER_THAN A).
Parameter pc6082 : object.
Parameter itelxz : object.
Variables  o1 o2 o3 : object.
Definition as_fast_as:= fun A:CN=> fun a:A=>fun b:A=> Fast   a ->Fast  b.
Theorem FAST2: faster_than itelxz pc6082  /\ Fast itelxz -> Fast pc6082. cbv. intro. destruct FASTER_THAN in H.   case  a0 with o1 o2 o3. intros. elim H. intros. apply H1 with itelxz. assumption. assumption. Qed. (**This can be semiautomated with the existing tactics:  cbv. intro. destruct FASTER_THAN in H.   case  a0 with o1 o2 o3. AUTOa x x x.*)

Theorem KNOW:know john((won2 (the contract) itel))-> (won2 (the contract) itel) .
(**AUTOa FACTIVE A B(this makes use of all the arguments, given that the first argument is always destructed as A B, we use A and B for the next two arguments of AUTOa*)cbv. destruct FACTIVE. intro. apply p with john. assumption. Qed.

Theorem CONJ:(signed1(the contract)(and3 smith jones anderson)-> (signed1(the contract)smith)).
(**AUTOa AND3 A B.*)   cbv. destruct AND3. intro. apply a0. assumption.

  Theorem CURRENTLY: (has1 (a_factory)itel) t-> currently (((has1 (a_factory)itel)))t.
 (**AUTOa x x x.*)    cbv. intros. destruct H.  AUTO. Qed.


Require Import Events.
Require Import Memory.
Require Import Coqlib.
Require Import Values.
Require Import Integers.
Require Import AST.
Require Import Globalenvs.
Require Import Axioms.

Require Import mem_lemmas. (*needed for definition of mem_forward etc*)

Require Import structured_injections.
Require Import reach.
Require Import Wellfounded.

Definition full_comp (j1 j2: meminj) :=
  forall b0 b1 delta1, j1 b0 = Some (b1, delta1) -> exists b2 delta2, j2 b1 = Some (b2, delta2).

Definition full_ext (mu1 mu2: SM_Injection) :=
  full_comp (extern_of mu1) (extern_of mu2).


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C P T X Y : Universe, ((wd_ P T /\ (wd_ X Y /\ (wd_ P X /\ (wd_ P Y /\ (wd_ B T /\ (wd_ B P /\ (wd_ A B /\ (wd_ X B /\ (wd_ A C /\ (wd_ C B /\ (col_ T P X /\ (col_ P X Y /\ col_ B A X)))))))))))) -> col_ P T Y)).
Proof.
  time tac.
Qed.

End FOFProblem.


(** **********************************************************

Ralph Matthes

August 2022
*)

(** **********************************************************

constructs the final object of the bicategory of (elementarily defined) actegories

in a separate file to reduce dependencies of the base file

 ************************************************************)

Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.categories.StandardCategories.
Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Functors.
Require Import UniMath.CategoryTheory.DisplayedCats.Total.

Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.

Require Import UniMath.Bicategories.Core.Bicat.
Require Import UniMath.Bicategories.Core.Invertible_2cells.
Require Import UniMath.Bicategories.Core.Examples.BicatOfCats.

Require Import UniMath.Bicategories.DisplayedBicats.DispBicat.
Require Import UniMath.Bicategories.Limits.Final.
Require Import UniMath.Bicategories.Limits.Examples.BicatOfCatsLimits.
Require Import UniMath.Bicategories.Limits.Examples.TotalBicategoryLimits.

Require Import UniMath.CategoryTheory.Monoidal.WhiskeredBifunctors.
Require Import UniMath.CategoryTheory.Monoidal.Categories.
Require Import UniMath.CategoryTheory.Monoidal.Functors.

Require Import UniMath.CategoryTheory.Actegories.Actegories.
Require Import UniMath.CategoryTheory.Actegories.MorphismsOfActegories.

Require Import UniMath.Bicategories.MonoidalCategories.BicatOfActegories.

Local Open Scope cat.
Local Open Scope mor_disp_scope.

Import BifunctorNotations.

Section A.

  Context {V : category} (Mon_V : monoidal V).

Definition unit_actegory : actegory Mon_V (pr1 unit_category).
Proof.
  use tpair.
  - use tpair.
    + use make_bifunctor_data.
      * exact (fun _ _ => tt).
      * intros. apply idpath.
      * intros. apply idpath.
    + cbn.
      repeat split; intro x; induction x; apply isapropunit.
  - cbn.
    split.
    + repeat split; intro x; induction x; apply isapropunit.
    + cbn.
      abstract (split; [| split; [| split]];
                [red; split; red; intros; [apply isasetunit | split; apply isasetunit] |
                  red; do 3 (split; [red; intros; apply isasetunit |]); split; apply isasetunit |
                  red; intros; apply isasetunit |
                  red; intros; apply isasetunit]).
Defined.

Definition unit_actegory_disp_bifinal_obj : disp_bifinal_obj_stronger (bidisp_actbicat_disp_bicat Mon_V) (_,,bifinal_cats).
Proof.
  exists unit_actegory.
  use tpair.
  - intros C ActC.
    cbn.
    use tpair.
    + split; red; intros; apply idpath.
    + abstract (repeat split).
  - intros x xx f g ff gg.
    red; cbn; red; cbn.
    red; intros; apply isasetunit.
Defined.

Definition bifinal_actegories : bifinal_obj (actbicat Mon_V).
Proof.
  use total_bicat_final_stronger.
  - exact (actbicat_disp_2cells_isaprop Mon_V).
  - exact (_,,bifinal_cats).
  - exact unit_actegory_disp_bifinal_obj.
Defined.

End A.


From mathcomp Require Import all_ssreflect.

Set Implicit Arguments.
Unset Printing Implicit Defensive.

Require Import ClassicalExtras.
Require Import MyNotation.
Require Import Setoid.
Require Import FunctionalExtensionality.

Require Import Galois.
Require Import LanguageModel.
Require Import TraceModel.
Require Import Properties.
Require Import ChainModel.
Require Import RobustHyperSafetyPreservation.
Require Import RobustSSCHCriterion.

Require Import PropExtensionality.
Definition prop_extensionality := propositional_extensionality.

Section RobustHSafeCriterion.

  Variable Source Target: Language.
  Variable compilation_chain : CompilationChain Source Target.

  Variable T_evs S_evs : Events.
  Variable T_end S_end : Endstates.

  Local Definition trace__S := @trace S_evs S_end.
  Local Definition finpref__S := @finpref S_evs S_end.
  Local Definition trace__T := @trace T_evs T_end.
  Local Definition finpref__T := @finpref T_evs T_end.
  Local Definition prefix__T := @prefix T_evs T_end.

  Local Definition prop__S := prop trace__S.
  Local Definition prop__T := prop trace__T.
  Local Definition hprop__S := hprop trace__S.
  Local Definition hprop__T := hprop trace__T.

  Local Definition HSafety__S := @HSafe S_evs S_end.
  Local Definition HSafety__T := @HSafe T_evs T_end.

  Variable Source_Semantics : Semantics Source trace__S.
  Variable Target_Semantics : Semantics Target trace__T.

  Local Definition sem__S := sem Source_Semantics.
  Local Definition sem__T := sem Target_Semantics.
  Local Definition beh__S := beh Source_Semantics.
  Local Definition beh__T := beh Target_Semantics.
  Local Definition par__S := par Source.
  Local Definition par__T := par Target.
  Local Definition ctx__S := ctx Source.
  Local Definition ctx__T := ctx Target.
  Local Definition rhsat__S := rhsat Source_Semantics.
  Local Definition rhsat__T := rhsat Target_Semantics.

  Local Definition cmp := compile_par Source Target compilation_chain.

  Local Notation "P ↓" := (cmp P) (at level 50).
 (* CA: don't understand why this does not work

   Local Notation " C [ P ] " := (plug _  P C) (at level 50).
  *)
  Local Definition plug__S:= plug Source.
  Local Definition plug__T := plug Target.

  Variable rel : trace__S -> trace__T -> Prop.

  Local Definition adjunction :=  induced_connection rel.

  Local Definition τ' : prop__S -> prop__T := α adjunction.
  Local Definition σ' : prop__T -> prop__S := γ adjunction.

  Local Definition rel_adjunction_law : Adjunction_law τ' σ' := adjunction_law adjunction.

  Local Definition sCl_σRhP := sCl_σRhP compilation_chain
                                        Source_Semantics Target_Semantics
                                        σ'.

  Local Definition hsCl_τRhP := hsCl_τRhP compilation_chain
                                          Source_Semantics Target_Semantics
                                          τ'.

  Definition rel_RHSC :=
    forall P C__T (M : finpref -> Prop), Observations M ->
       M <<< (beh__T (plug__T (P↓) C__T)) ->
       (exists C__S, forall m, M m -> exists t s, prefix__T m t /\
                                    rel s t /\
                                    beh__S (plug__S P C__S) s).

  Lemma conclusion_RSHC (P : par__S) (M : finpref__T -> Prop) (C__S : ctx__S) :
    (forall m, M m -> exists t s, prefix__T m t /\
                          rel s t /\
                          beh__S (plug__S P C__S) s) <->
    M <<< τ' (beh__S (plug__S P C__S)).
  Proof. firstorder. Qed.

  Local Definition rel_RSCHC := @rel_RSCHC Source Target compilation_chain trace__S trace__T
                                           Source_Semantics Target_Semantics rel.

  Lemma rel_RSCHC_rel_RHSC : rel_RSCHC -> rel_RHSC.
  Proof.
    move => H_tilde P Ct M Obs_M H_M.
    destruct (H_tilde P Ct) as [Cs H_Cs].
    exists Cs => m M_m.
    destruct (H_M m M_m) as [t [H_t m_pref_t]].
    destruct (H_Cs t H_t) as [s [rel_s_t H_s]]. now exists t, s.
  Qed.

  Theorem rel_RHSC_sCl_σRHSP :
    rel_RHSC <-> (forall P (H: hprop__T), HSafe H ->  sCl_σRhP P H).
  Proof.
    split.
    - move => H_tilde P H__T H_HSafe.
      setoid_rewrite contra_σRhP. move => [Ct H_tgt].
      destruct (H_HSafe _ H_tgt) as  [M [M_obs [M_leq_beh M_wit]]].
      destruct (H_tilde P Ct M) as [Cs H_conclusion]; auto.
      move/conclusion_RSHC : H_conclusion => H_conclusion.
      exists Cs => Hf. destruct Hf as [bs [H_bs beh_γ_bs]].
      destruct H_bs as [bt [H_bt Heq]]. subst.
      move/rel_adjunction_law : beh_γ_bs => τ_beh_bt.
      apply: (M_wit bt); auto.
      { move => m M_m. destruct (H_conclusion m) as [t [H_t pref_m_t]]; auto.
        exists t. split; auto. }
    - move => Hσ P Ct M M_obs M_leq_beh_tgt.
      have HSafe_H : HSafe (fun b :prop__T => ~ M <<< b).
      { move => b. rewrite -dne => M_b. now exists M. }
      move/contra: (Hσ P (fun b : prop__T => ~ M <<< b) HSafe_H).
      rewrite !neg_rhsat. move => HγP.
      destruct HγP as [Cs H_src]. by exists Ct.
      exists Cs. rewrite conclusion_RSHC.
      apply: NNPP => Hf. apply: H_src.
      exists (σ' (τ' (beh__S (plug__S P Cs)))). split.
      + by exists (τ' (beh__S (plug__S P Cs))).
      +  move/Galois_equiv : rel_adjunction_law.
         move => [mono_gamma [mono_tau [G1 G2]]]. by apply: G1.
  Qed.

   Theorem rel_RHSC_hsCl_τRHSP :
    rel_RHSC <-> (forall P (H: hprop__S), SSC H ->  hsCl_τRhP P H).
   Proof.
     setoid_rewrite <- τRSCHP_σRSCHP.
     exact rel_RHSC_sCl_σRHSP.
     exact rel_adjunction_law.
   Qed.

End RobustHSafeCriterion.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.solinas64_2e224m2e96p1_6limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj17synthconj1 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (plus Zero (plus lv0 lv1)) (plus lv0 lv1)).
Admitted.
QuickChick conj17synthconj1.


(* *********************************************************************)
(*                                                                     *)
(*              The L2C verified compiler                              *)
(*                                                                     *)
(*            L2C Group, Tsinghua University                           *)
(*                                                                     *)
(*  Copyright Tsinghua University.  All rights reserved.  This file is *)
(*  distributed under the terms of the GNU General Public License as   *)
(*  published by the Free Software Foundation, either version 2 of the *)
(*  License, or (at your option) any later version.  This file is also *)
(*  distributed under the terms of the INRIA Non-Commercial License    *)
(*  Agreement.                                                         *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib.
Require Import Integers.
Require Import Floats.
Require Import Cop.
Require Import Ctypes.
Require Import Clop.
Require Import Cltypes.
Require Import Lvalues.
Require Import Ltypes.

(** The following [sem_] functions compute the result of an operator
  application.  The result depends on their run-time values.
  Unlike in C, automatic conversions are not performed. For instance,
  [e1 + e2] is undefined if [e1] is a float and [e2] an integer.
  The Lustre code must explicitly convert [e2] to a float. *)

Inductive binary_operationL : Type :=
  | Oadd : binary_operationL             (* addition (binary [+]) *)
  | Osub : binary_operationL             (* subtraction (binary [-]) *)
  | Omul : binary_operationL             (* multiplication (binary [*]) *)
  | Odivreal : binary_operationL         (* division real ([/]) *)
  | Odivint : binary_operationL          (* division integer ([div]) *)
  | Omod : binary_operationL             (* remainder ([mod]) *)
  | Oand : binary_operationL             (* and ([and]) *)
  | Oor : binary_operationL              (* or ([or]) *)
  | Oxor : binary_operationL             (* xor ([xor]) *)
  | Oeq: binary_operationL               (* comparison ([=]) *)
  | One: binary_operationL               (* comparison ([<>]) *)
  | Olt: binary_operationL               (* comparison ([<]) *)
  | Ogt: binary_operationL               (* comparison ([>]) *)
  | Ole: binary_operationL               (* comparison ([<=]) *)
  | Oge: binary_operationL.              (* comparison ([>=]) *)

Definition of_bool (b: bool): val := if b then Vtrue else Vfalse.

Function bool_val (v: val) (t: type) : option bool :=
  match v, t with
  | Vint n, Tint _ _ => Some (negb (Int.eq n Int.zero))
  | _, _ => None
  end.

Function sem_neg (v: val) (ty: type): option val :=
  match v, ty with
  | Vint n, Tint _ _ => Some (Vint (Int.neg n))
  | Vfloat f, Tfloat F64 => Some (Vfloat (Float.neg f))
  | Vsingle f, Tfloat F32 => Some (Vsingle (Float32.neg f))
  | _, _ => None
  end.

Function sem_notbool (v: val) (ty: type): option val :=
  match v, ty with
  | Vint n, Tint IBool _ => Some (of_bool (Int.eq n Int.zero))
  | _, _ => None
  end.

Function sem_add (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint _ _ => Some (Vint (Int.add n1 n2))
  | Vfloat f1, Vfloat f2, Tfloat F64 => Some (Vfloat (Float.add f1 f2))
  | Vsingle f1, Vsingle f2, Tfloat F32 => Some(Vsingle(Float32.add f1 f2))
  | _, _, _ => None
  end.

Function sem_sub (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1,  Vint n2, Tint _ _ => Some (Vint (Int.sub n1 n2))
  | Vfloat f1, Vfloat f2, Tfloat F64 => Some (Vfloat(Float.sub f1 f2))
  | Vsingle f1, Vsingle f2, Tfloat F32 => Some(Vsingle(Float32.sub f1 f2))
  | _, _, _=> None
  end.

Function sem_mul (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint _ _ => Some (Vint (Int.mul n1 n2))
  | Vfloat f1, Vfloat f2, Tfloat F64 => Some (Vfloat (Float.mul f1 f2))
  | Vsingle f1, Vsingle f2, Tfloat F32 => Some(Vsingle(Float32.mul f1 f2))
  | _, _, _ => None
  end.

Definition div_sign(n1 n2: int)(sz: intsize)(sg: signedness): option val :=
  match sz, sg with
  | I32, Unsigned =>
     if Int.eq n2 Int.zero
     then None else Some(Vint(Int.divu n1 n2))
  | _, _ =>
     if Int.eq n2 Int.zero
     || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
     then None else Some(Vint(Int.divs n1 n2))
  end.

Function sem_div (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint sz sg => div_sign n1 n2 sz sg
  | Vfloat f1, Vfloat f2, Tfloat F64 => Some (Vfloat(Float.div f1 f2))
  | Vsingle f1, Vsingle f2, Tfloat F32 => Some(Vsingle(Float32.div f1 f2))
  | _, _, _ => None
  end.

Definition mod_sign(n1 n2: int)(sz: intsize)(sg: signedness): option val :=
  match sz, sg with
  | I32, Unsigned =>
     if Int.eq n2 Int.zero
     then None else Some(Vint(Int.modu n1 n2))
  | _, _ =>
     if Int.eq n2 Int.zero
     || Int.eq n1 (Int.repr Int.min_signed) && Int.eq n2 Int.mone
     then None else Some(Vint(Int.mods n1 n2))
  end.

Function sem_mod (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint sz sg => mod_sign n1 n2 sz sg
  | _, _, _=> None
  end.

Function sem_and (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint _ _ => Some (Vint (Int.and n1 n2))
  | _, _, _ => None
  end.

Function sem_or (v1 v2: val) (ty: type) : option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint _ _ => Some (Vint (Int.or n1 n2))
  | _, _, _ => None
  end.

Function sem_xor (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint _ _ => Some (Vint (Int.xor n1 n2))
  | _, _, _ => None
  end.

Definition cmp_sign(op: comparison)(n1 n2: int)(sz: intsize)(sg: signedness): bool :=
  match sz, sg with
  | I32, Unsigned => Int.cmpu op n1 n2
  | _, _ => Int.cmp op n1 n2
  end.

Function sem_cmp (op: comparison) (v1 v2: val) (ty: type): option val :=
  match v1, v2, ty with
  | Vint n1, Vint n2, Tint sz sg => Some (of_bool (cmp_sign op n1 n2 sz sg))
  | Vfloat f1, Vfloat f2, Tfloat F64 => Some (of_bool (Float.cmp op f1 f2))
  | Vsingle f1, Vsingle f2, Tfloat F32 => Some(of_bool (Float32.cmp op f1 f2))
  | _, _, _ => None
  end.

Function classify_cast (tfrom tto: type) : classify_cast_cases :=
  match tto, tfrom with
  | Tint IBool _, Tfloat _ => cast_case_default
  | Tint sz2 si2, Tint sz1 si1 => cast_case_i2i sz2 si2
  | Tint sz2 si2, Tfloat F64 => cast_case_f2i sz2 si2
  | Tint sz2 si2, Tfloat F32 => cast_case_s2i sz2 si2
  | Tfloat F64, Tfloat F64 => cast_case_f2f
  | Tfloat F32, Tfloat F32 => cast_case_s2s
  | Tfloat F64, Tfloat F32 => cast_case_s2f
  | Tfloat F32, Tfloat F64 => cast_case_f2s
  | Tfloat F64, Tint sz1 si1 => cast_case_i2f si1
  | Tfloat F32, Tint sz1 si1 => cast_case_i2s si1
  | _, _ => cast_case_default
  end.

Definition sem_cast(v: val)(t1 t2: type): option val :=
  match classify_cast t1 t2 with
  | cast_case_i2i sz2 si2 =>
      match v with
      | Vint i => Some (Vint (cast_int_int sz2 si2 i))
      | _ => None
      end
  | cast_case_f2f =>
      match v with
      | Vfloat f => Some (Vfloat f)
      | _ => None
      end
  | cast_case_s2s =>
      match v with
      | Vsingle f => Some (Vsingle f)
      | _ => None
      end
  | cast_case_s2f =>
      match v with
      | Vsingle f => Some (Vfloat (Float.of_single f))
      | _ => None
      end
  | cast_case_f2s =>
      match v with
      | Vfloat f => Some (Vsingle (Float.to_single f))
      | _ => None
      end
  | cast_case_i2f si1 =>
      match v with
      | Vint i => Some (Vfloat (cast_int_float si1 i))
      | _ => None
      end
  | cast_case_i2s si1 =>
      match v with
      | Vint i => Some (Vsingle (cast_int_single si1 i))
      | _ => None
      end
  | cast_case_f2i sz2 si2 =>
      match v with
      | Vfloat f =>
          match cast_float_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | cast_case_s2i sz2 si2 =>
      match v with
      | Vsingle f =>
          match cast_single_int si2 f with
          | Some i => Some (Vint (cast_int_int sz2 si2 i))
          | None => None
          end
      | _ => None
      end
  | _ => None
  end.

Definition sem_unary_operation (op: unary_operation) (v: val) (ty: type): option val :=
  match op with
  | Onotbool => sem_notbool v ty
  | Oneg => sem_neg v ty
  | Onotint => None
  | Oabsfloat => None
  end.

Inductive classify_binop_case: Type :=
  | binop_case_normal
  | binop_case_divint
  | binop_case_divreal.

Definition classify_binop(ty: type)(op: binary_operationL) :=
  match op with
  | Odivint =>
    match ty with
    | Tint I32 Signed => binop_case_normal
    | _ => binop_case_divint
    end
  | Odivreal =>
    match ty with
    | Tfloat _ => binop_case_normal
    | _ =>  binop_case_divreal
    end
  | _ => binop_case_normal
  end.

Definition sem_div_operation(op: binary_operationL)(v1 v2: val)(t tto: type): option val :=
  match classify_binop t op with
  | binop_case_normal => sem_div v1 v2 t
  | binop_case_divint =>
    match sem_div v1 v2 t with
    | Some v => sem_cast v t tto
    | None => None
    end
  | binop_case_divreal =>
    match (sem_cast v1 t (Tfloat F64)), (sem_cast v2 t (Tfloat F64)) with
    | Some v1', Some v2' => sem_div v1' v2' (Tfloat F64)
    | _, _ => None
    end
  end.

Definition sem_binary_operation (op: binary_operationL) (v1 v2: val)(t tto: type) : option val :=
  match op with
  | Oadd => sem_add v1 v2 t
  | Osub => sem_sub v1 v2 t
  | Omul => sem_mul v1 v2 t
  | Odivint => sem_div_operation Odivint v1 v2 t tto
  | Odivreal => sem_div_operation Odivreal v1 v2 t tto
  | Omod => sem_mod v1 v2 t
  | Oand => sem_and v1 v2 t
  | Oor => sem_or v1 v2 t
  | Oxor => sem_xor v1 v2 t
  | Oeq => sem_cmp Ceq v1 v2 t
  | One => sem_cmp Cne v1 v2 t
  | Olt => sem_cmp Clt v1 v2 t
  | Ogt => sem_cmp Cgt v1 v2 t
  | Ole => sem_cmp Cle v1 v2 t
  | Oge => sem_cmp Cge v1 v2 t
  end.

Fixpoint sem_fold_operation (op: binary_operationL)
    (ty: type) (v: val) (vl: list val): option val :=
  match vl with
  | nil => Some v
  | cons v1 vl1 =>
    match (sem_binary_operation op v v1 ty ty) with
    | Some v2 => sem_fold_operation op ty v2 vl1
    | None => None
    end
  end.

Lemma sem_unary_operation_not_mvl:
  forall op v1 t m,
  sem_unary_operation op v1 t = Some (Vmvl m) -> False.
Proof.
  destruct op; destruct v1; destruct t; intros; inv H.
  destruct i0; inv H1.
  destruct (Int.eq i Int.zero); inv H0.
  destruct f0; congruence.
  destruct f0; congruence.
Qed.

Lemma sem_div_not_mvl:
  forall v1 v2 t m,
  sem_div v1 v2 t = Some (Vmvl m) -> False.
Proof.
  intros. destruct v1,v2,t; inv H.
  destruct i1, s; intros; inv H1;
  destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H0;
  destruct (Int.eq i0 Int.zero); inv H1.
  destruct f1; congruence.
  destruct f1; congruence.
Qed.

Lemma sem_cast_not_mvl:
  forall v1 t ty m,
  sem_cast v1 t ty = Some (Vmvl m) -> False.
Proof.
  unfold sem_cast. intros.
  destruct (classify_cast _ _); try congruence;
  destruct v1; try congruence.
  destruct (cast_float_int _ _); congruence.
  destruct (cast_single_int _ _); congruence.
Qed.

Lemma sem_div_operation_not_mvl:
  forall op v1 v2 t tto m,
  sem_div_operation op v1 v2 t tto = Some (Vmvl m) -> False.
Proof.
  unfold sem_div_operation. intros.
  destruct (classify_binop _ _); try congruence.
  +eapply sem_div_not_mvl; eauto.
  +destruct (sem_div _ _ _); try congruence.
   eapply sem_cast_not_mvl; eauto.
  +destruct (sem_cast v1 _ _); try congruence.
   destruct (sem_cast v2 _ _); try congruence.
   eapply sem_div_not_mvl; eauto.
Qed.

Lemma sem_cmp_not_mvl:
  forall op v1 v2 t m,
  sem_cmp op v1 v2 t = Some (Vmvl m) -> False.
Proof.
  destruct op, v1,v2,t; intros; inv H;
  try (destruct (cmp_sign _ _ _ _ _); inv H1; fail);
  destruct f1; try congruence;
  try destruct (Floats.Float.cmp _ _ _); inv H1;
  destruct (Floats.Float32.cmp _ _ _); inv H0.
Qed.

Lemma sem_binary_operation_not_mvl:
  forall op v1 v2 t tto m,
  sem_binary_operation op v1 v2 t tto = Some (Vmvl m) -> False.
Proof.
  destruct op; simpl; intros;
  try (destruct v1, v2, t; inv H;destruct f1; congruence; fail);
  try (eapply sem_cmp_not_mvl; eauto; fail).
  +eapply sem_div_operation_not_mvl; eauto.
  +eapply sem_div_operation_not_mvl; eauto.
  +destruct v1,v2,t; inv H.
   destruct i1; destruct s; inv H1;
    destruct (Int.eq i0 Int.zero || Int.eq i (Int.repr Int.min_signed) && Int.eq i0 Int.mone); inv H0;
    destruct (Int.eq i0 Int.zero); inv H1.
Qed.

Lemma sem_binary_operation_has_type:
  forall op v1 v2 ty tto v,
  sem_binary_operation op v1 v2 ty tto = Some v ->
  has_type v1 ty.
Proof.
  unfold has_type.
  destruct op, v1, v2, ty; simpl; intros; try inv H; auto;
  unfold sem_div_operation in *; simpl in *;
  try (destruct f1; inv H1; auto; fail);
  try (destruct i0,s; congruence; fail);
  try (destruct i,s; congruence; fail).
Qed.

Lemma sem_fold_operation_has_type:
  forall vl op ty v v1,
  sem_fold_operation op ty v vl = Some v1 ->
  has_type v1 ty ->
  has_type v ty.
Proof.
  destruct vl; simpl; intros.
  inv H. auto.
  destruct (sem_binary_operation _ _ _ _ _) eqn:?; try congruence.
  eapply sem_binary_operation_has_type; eauto.
Qed.

Lemma sem_binary_by_value:
  forall op v1 v2 v t1 t2 tto,
  sem_binary_operation op v1 v2 t1 tto = Some v ->
  has_type v t2 ->
  exists chunk, access_mode t2 = By_value chunk.
Proof.
  intros. destruct v,t2; try tauto; simpl; eauto.
  +destruct i0, s; eauto.
  +destruct f0; eauto.
  +destruct f0; eauto.
  +eapply sem_binary_operation_not_mvl in H; tauto.
  +eapply sem_binary_operation_not_mvl in H; tauto.
Qed.

Lemma sem_fold_operation_by_value:
  forall op v1 v2 v t l,
  sem_fold_operation op t v1 (v2::l)  = Some v ->
  has_type v t ->
  exists chunk, access_mode t = By_value chunk.
Proof.
  intros. inv H.
  destruct (sem_binary_operation _ _ _ _ _) eqn:?; try congruence.
  eapply sem_binary_by_value; eauto.
  eapply sem_fold_operation_has_type; eauto.
Qed.

Lemma sem_unary_by_value:
  forall op v1 v t1 t2,
  sem_unary_operation op v1 t1 = Some v ->
  has_type v t2 ->
  exists chunk, access_mode t2 = By_value chunk.
Proof.
  intros. destruct v,t2; try tauto; simpl; eauto.
  +destruct i0, s; eauto.
  +destruct f0; eauto.
  +destruct f0; eauto.
  +eapply sem_unary_operation_not_mvl in H; tauto.
  +eapply sem_unary_operation_not_mvl in H; tauto.
Qed.

Lemma sem_cast_by_value:
  forall v1 v t1 t2,
  sem_cast v1 t1 t2 = Some v ->
  exists chunk, access_mode t2 = By_value chunk.
Proof.
  unfold sem_cast, classify_cast. intros.
  destruct t1, t2; try congruence;
  try (destruct i; congruence; fail);
  try (destruct i0; congruence; fail);
  try (destruct f; congruence; fail); simpl.
  +destruct i0,s0; eauto.
  +destruct f; eauto.
  +destruct i,s; eauto.
  +destruct f0; eauto.
  +destruct f0; eauto.
Qed.


Require Import List Map Envs AllInRel Exp MoreList.
Require Import IL Annotation.
Require Import Liveness.Liveness RenamedApart.
Require Import ExpVarsBounded SpillSound OneOrEmpty RLiveMin RLiveSound.
Require Import Take TakeSet.
Require Import PartialOrder.

Set Implicit Arguments.

Inductive spill_max_kill (k:nat) :
  (list params)
  -> (list (⦃var⦄ * ⦃var⦄))
  -> (⦃var⦄ * ⦃var⦄)
  -> stmt
  -> ann ⦃var⦄
  -> spilling
  -> Prop :=
  | SpillMKLet
      (ZL : list params)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M Sp L Rlv : ⦃var⦄)
      (x : var)
      (e : exp)
      (s : stmt)
      (sl : spilling)
      (rlv : ann ⦃var⦄)
    : let K := (R \ (Exp.freeVars e ∪ getAnn rlv)) ∪ (R ∩ L) in
      let Kx:= ((R \ K ∪ L) \ getAnn rlv) in
      Sp ⊆ R
      -> L ⊆ Sp ∪ M
      -> spill_max_kill k ZL Λ ({x; (R\K ∪ L) \ Kx}, Sp ∪ M) s rlv sl
      -> Exp.freeVars e ⊆ R\K ∪ L
      -> k > 0
      -> cardinal (R\K ∪ L) <= k
      -> cardinal {x; (R\K ∪ L) \ Kx} <= k
      -> spill_max_kill k ZL Λ (R,M) (stmtLet x e s) (ann1 Rlv rlv) (ann1 (Sp,L,nil) sl)
  | SpillMKReturn
      (ZL : list (params))
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M Sp L Rlv: ⦃var⦄)
      (e : op)
    : let K := (R \ (Ops.freeVars e)) ∪ (R ∩ L) in
      Sp ⊆ R
      -> L ⊆ Sp ∪ M
      -> Ops.freeVars e ⊆ R\K ∪ L
      -> cardinal (R\K ∪ L) <= k
      -> spill_max_kill k ZL Λ (R,M) (stmtReturn e) (ann0 Rlv) (ann0 (Sp,L,nil))
  | SpillMKIf
      (ZL : list (params))
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M Sp L Rlv: ⦃var⦄)
      (e : op)
      (s t : stmt)
      (sl_s sl_t : spilling)
      (rlv1 rlv2 : ann ⦃var⦄)
    : let K := (R \ (Ops.freeVars e ∪ getAnn rlv1 ∪ getAnn rlv2)) ∪ (R ∩ L) in
      Sp ⊆ R
      -> L ⊆ Sp ∪ M
      -> Ops.freeVars e ⊆ R\K ∪ L
      -> cardinal (R\K ∪ L) <= k
      -> spill_max_kill k ZL Λ (R \ K ∪ L, Sp ∪ M) s rlv1 sl_s
      -> spill_max_kill k ZL Λ (R \ K ∪ L, Sp ∪ M) t rlv2 sl_t
      -> spill_max_kill k ZL Λ (R,M) (stmtIf e s t) (ann2 Rlv rlv1 rlv2) (ann2 (Sp,L,nil) sl_s sl_t)
  | SpillMKApp
      (ZL : list params)
      (Λ : list (⦃var⦄ * ⦃var⦄))
      (R M Sp L R_f M_f R' M' Rlv : ⦃var⦄)
      (f : lab)
      (Z : params)
      (Y : args)
    : let K := R \ (R' ∪ (R_f \ of_list Z)) ∪ (R ∩ L) in
      Sp ⊆ R
      -> L ⊆ Sp ∪ M
      -> cardinal (R\K ∪ L) <= k
      -> get ZL (counted f) Z
      -> get Λ (counted f) (R_f,M_f)
      -> R_f \ of_list Z ⊆ R\K ∪ L
      -> M_f \ of_list Z ⊆ Sp ∪ M
      -> list_union (Ops.freeVars ⊝ Y) [=] R' ∪ M'
      -> R' ⊆ R\K ∪ L
      -> M' ⊆ Sp ∪ M
      -> spill_max_kill k ZL Λ (R,M) (stmtApp f Y) (ann0 Rlv) (ann0 (Sp,L, (R', M')::nil))
  | SpillMKFun
      (ZL : list params)
      (Λ rms : list (⦃var⦄ * ⦃var⦄))
      (R M Sp L Rlv : ⦃var⦄)
      (F : list (params * stmt))
      (t : stmt)
      (sl_F : list spilling)
      (sl_t : spilling)
      (rlv_t : ann ⦃var⦄)
      (rlv_F : list (ann ⦃var⦄))
    : let K := (R \ getAnn rlv_t) ∪ (R ∩ L) in
      Sp ⊆ R
      -> L ⊆ Sp ∪ M
      -> cardinal (R\K ∪ L) <= k
      -> length F = length sl_F
      -> length F = length rms
      -> (forall n rm, get rms n rm -> cardinal (fst rm) <= k)
      -> (forall n Zs rm rlv_s sl_s, get rms n rm
                         -> get F n Zs
                         -> get rlv_F n rlv_s
                         -> get sl_F n sl_s
                         -> spill_max_kill k ((fst ⊝ F) ++ ZL)
                                          (rms ++ Λ) rm (snd Zs) rlv_s sl_s
        )
      -> spill_max_kill k ((fst ⊝ F) ++ ZL) (rms ++ Λ) (R\K ∪ L, Sp ∪ M) t rlv_t sl_t
      -> length F = length rlv_F
      -> spill_max_kill k ZL Λ (R,M) (stmtFun F t) (annF Rlv rlv_F rlv_t) (annF (Sp,L,rms) sl_F sl_t).

Lemma Sp_sub_rlv k ZL Λ R M s sl rlv
  : spill_sound k ZL Λ (R,M) s sl
    -> rlive_sound ZL (fst ⊝ Λ) s sl rlv
    -> getSp sl ⊆ getAnn rlv.
Proof.
  intros spillSnd rlive. general induction spillSnd; invc rlive; simpl; eauto.
Qed.

Lemma card_diff (X:Type) `{OrderedType X} (s t : ⦃X⦄)
  : cardinal (s \ t) = cardinal s - cardinal (s ∩ t).
Proof.
  setoid_rewrite <-diff_inter_cardinal with (s':=t) at 2. omega.
Qed.

Lemma card_RKL (X:Type) `{OrderedType X} k (s t u : ⦃X⦄)
  : t ⊆ s
    -> cardinal u <= k
    -> cardinal t = cardinal s + cardinal u - k
    -> cardinal (s \ t ∪ u) <= k.
Proof.
  intros sub ucard card.
  rewrite union_cardinal_inter. rewrite card_diff. rewrite meet_comm, inter_subset_equal; eauto.
  rewrite card. omega.
Qed.

Lemma rkl'_incl_rkl (X:Type) `{OrderedType X} (s s' t t1 t2 u v w : ⦃X⦄) (x : X)
  : let t' := s' \ (t1 ∪ t2) ∪ (s' ∩ v) in
    t1 ⊆ s \ t ∪ v
    -> t2 ⊆ {x; (s \ t ∪ v) \ w}
    -> s' ⊆ u
    -> x ∉ u
    -> s' \ t' ∪ v ⊆ s \ t ∪ v.
Proof.
  intros t' t1_incl t2_incl s'_incl x_nin.
  subst t'.
  cset_tac.
Qed.

Lemma spill_max_kill_spill_sound k ZL Λ R M s sl rlv
  : spill_max_kill k ZL Λ (R,M) s rlv sl
    -> spill_sound k ZL Λ (R,M) s sl.
Proof.
  intros spillSnd. general induction spillSnd; econstructor; eauto.
  intros. inv_get. eapply H6; eauto. apply surjective_pairing.
Qed.

Lemma spill_sound_spill_max_kill k ZL Λ R R' M G s sl rlv ra
  : renamedApart s ra
    -> spill_sound k ZL Λ (R,M) s sl
    -> rlive_min k ZL Λ G s sl rlv
    -> rlive_sound ZL (fst ⊝ Λ) s sl rlv
    -> R' ∪ M ⊆ fst (getAnn ra)
    -> getAnn rlv ⊆ R'
    -> (forall Rf Mf n, get Λ n (Rf,Mf) -> cardinal Rf <= k)
    -> ann_R (fun x (y : ⦃var⦄ * ⦃var⦄) => (list_union (merge ⊝ snd x)) ⊆ fst y) sl ra
    -> spill_max_kill k ZL Λ (R',M) s rlv sl.
Proof.
  intros rena spillSnd rliveMin rlive R_sub rlv_sub' card_Rf annIncl.
  general induction spillSnd; invc rlive; invc rena; invc rliveMin; invc annIncl;
    cbn in rlv_sub'.
  - set (K' := R' \ (Exp.freeVars e ∪ getAnn al) ∪ (R' ∩ L)).
    assert (R' \ K' ∪ L ⊆ R0 \ K ∪ L) as rkl'_in_rkl2.
    {
      eapply rkl'_incl_rkl; eauto.
      - eapply rlive_min_incl_R; eauto. clear; cset_tac.
      - cbn in R_sub. clear - R_sub; cset_tac.
    }
    subst K'.
    econstructor; eauto;
      set (K' := R' \ (Exp.freeVars e ∪ getAnn al) ∪ (R' ∩ L)) in *;
      set (Kx':= (R' \ K' ∪ L) \ getAnn al) in *.
    + rewrite H13. eauto.
    + eapply IHspillSnd; eauto.
      * rewrite H14.
        cbn in R_sub. apply union_incl_split.
        -- apply add_struct_incl. rewrite !minus_incl. rewrite H0, H13, rlv_sub'.
           clear - R_sub. cset_tac.
        -- rewrite H13, rlv_sub', R_sub. cbn. clear; cset_tac.
      * enough (getAnn al \ singleton x ⊆ (R' \ K' ∪ L) \ Kx') as Hypo.
        { rewrite <-Hypo. clear; cset_tac. }
        rewrite <-inter_subset_equal with (s':=getAnn al);[| clear; cset_tac]. rewrite H17.
        subst K'. rewrite <-minus_union, minus_minus.
        setoid_rewrite <-rlv_sub' at 1. apply not_incl_minus; [clear; cset_tac|].
        subst Kx'. clear; cset_tac.
    + subst K'. rewrite <-minus_union.
      rewrite incl_minus_union';[|clear;cset_tac].
      rewrite minus_minus, <-rlv_sub'.
      apply Exp.freeVars_live in H16. clear - H16; cset_tac.
    + rewrite subset_cardinal with (s':=R0 \ K ∪ L); eauto.
    + rewrite subset_cardinal with (s':={x; (R0 \ K ∪ L) \ Kx}); eauto.
      subst Kx'. rewrite minus_minus. apply incl_add_eq; split; [clear;cset_tac|].
      rewrite rkl'_in_rkl2. eapply rlive_min_incl_R in H20.
      * rewrite H20. clear; cset_tac.
      * clear; cset_tac.
      * eauto.
  - econstructor; eauto.
    + rewrite H8; eauto.
    + rewrite <-minus_union.
      rewrite incl_minus_union';[|clear;cset_tac].
      rewrite minus_minus, <-rlv_sub'.
      apply Ops.freeVars_live in H10. clear - H10. cset_tac.
    + rewrite <-minus_union.
      rewrite incl_minus_union';[|clear;cset_tac].
      rewrite minus_minus. rewrite H1. rewrite subset_cardinal with (s':=R0 \ K ∪ L); eauto.
      clear; cset_tac.
  - eapply rlive_min_incl_R with (G:=∅) in spillSnd1 as spillSnd1'; [|clear;cset_tac|eauto].
    eapply rlive_min_incl_R with (G:=∅) in spillSnd2 as spillSnd2'; [|clear;cset_tac|eauto].
    econstructor; eauto.
    + rewrite H12; eauto.
    + rewrite <-minus_union.
      rewrite incl_minus_union';[|clear;cset_tac].
      rewrite minus_minus, <-rlv_sub'.
      apply Ops.freeVars_live in H16. clear - H16; cset_tac.
    + rewrite <-minus_union.
      rewrite incl_minus_union';[|clear;cset_tac].
      rewrite minus_minus. rewrite H1.
      rewrite spillSnd1'. cbn.
      rewrite spillSnd2'. cbn.
      rewrite subset_cardinal with (s':=R0 \ K ∪ L); eauto.
      cbn in R_sub; clear - R_sub H9; cset_tac.
    + eapply IHspillSnd1; eauto.
      * cbn in R_sub.
        rewrite <-minus_union, minus_minus, H6, H17, H18, rlv_sub', H12.
        setoid_rewrite H0 at 4. rewrite H12, rlv_sub'.
        rewrite H13. clear - R_sub. cbn. cset_tac.
      * rewrite <-inter_subset_equal with (s':=getAnn al1); [|clear;cset_tac]. setoid_rewrite H17 at 1.
        rewrite <-minus_union, minus_minus. setoid_rewrite rlv_sub' at 1. clear; cset_tac.
    + eapply IHspillSnd2; eauto.
      * cbn in R_sub.
        rewrite <-minus_union, minus_minus, H6, H17, H18, rlv_sub', H12.
        setoid_rewrite H0 at 4. rewrite H12, rlv_sub'.
        rewrite H19. clear - R_sub. cbn. cset_tac.
      * rewrite <-inter_subset_equal with (s':=getAnn al2); [|clear;cset_tac]. setoid_rewrite H18 at 1.
        rewrite <-minus_union, minus_minus. setoid_rewrite rlv_sub' at 1. clear; cset_tac.
  - inv_get. cbn in *.
    econstructor; eauto;
      set (K':= R'0 \ (R' ∪ (R_f \ of_list Z)) ∪ (R'0 ∩ L)) in *.
    + rewrite H17; eauto.
    + rewrite subset_cardinal; eauto.
      subst K'. rewrite H7. rewrite union_assoc. rewrite H4. clear; cset_tac.
    + subst K'. rewrite <-minus_union, minus_minus.
      rewrite <-inter_subset_equal with (s':=lv ∪ L); eauto.
      setoid_rewrite <-rlv_sub' at 1. clear; cset_tac.
    + subst K'. rewrite <-minus_union, minus_minus.
      rewrite incl_minus_union'; [|clear; cset_tac].
      setoid_rewrite <-inter_subset_equal with (s':=lv ∪ L) at 1; eauto.
      rewrite <-rlv_sub'. clear; cset_tac.
  - econstructor; eauto.
    + rewrite <-rlv_sub'. eauto.
    + rewrite <-minus_union, minus_minus. eapply rlive_min_incl_R in spillSnd; eauto;
                                           [|clear;cset_tac].
      rewrite spillSnd. rewrite subset_cardinal; eauto. clear; cset_tac.
    + intros. inv_get. destruct rm as [R M]. eapply H6; eauto.
      * rewrite List.map_app.
        eapply rlive_sound_monotone; eauto.
        eapply PIR2_app; eauto.
        eapply PIR2_get; intros; inv_get; poLe_set; eauto with len.
      * simpl in *.
        edestruct H11; eauto; dcr.
        rewrite H26. rewrite <- H25.
        eapply incl_union_right.
        eapply incl_list_union; eauto using zip_get.
      * exploit H5; eauto. eapply rlive_min_incl_R in H26; eauto. cbn.
        reflexivity.
      * intros; eauto. decide (n0 >= length rms).
        -- eapply card_Rf; eauto. eapply get_app_right_ge; eauto.
        -- replace Rf with (fst (Rf,Mf)); eauto. eapply H4; eauto.
           eapply get_app_lt_1; swap 1 2. eauto. omega.
    + eapply IHspillSnd; eauto.
      * rewrite List.map_app.
        eapply rlive_sound_monotone; eauto.
        eapply PIR2_app; eauto.
        eapply PIR2_get; intros; inv_get; poLe_set; eauto with len.
      * pe_rewrite. simpl in *.
        assert (Sp ⊆ R'). {
          rewrite H16. rewrite rlv_sub'. reflexivity.
        }
        rewrite H0 at 2. rewrite H7.
        revert R_sub. clear_all.
        intros. cset_tac'.
      * rewrite <-minus_union, minus_minus.
        setoid_rewrite <-rlv_sub' at 1. clear - H22; cset_tac.
      * intros; eauto. decide (n >= length rms).
        -- eapply card_Rf; eauto. eapply get_app_right_ge; eauto.
        -- replace Rf with (fst (Rf,Mf)); eauto. eapply H4; eauto.
           eapply get_app_lt_1; swap 1 2. eauto. omega.
Qed.

Lemma spill_max_kill_monotone ZL Λ Λ' s rlv RM sl k
  : poLe Λ' Λ
    -> spill_max_kill k ZL Λ  RM  s rlv sl
    -> spill_max_kill k ZL Λ' RM  s rlv sl.
Proof.
  intros Λeq spillSnd. general induction spillSnd.
  - econstructor; eauto.
  - econstructor; eauto.
  - econstructor; eauto.
  - eapply PIR2_nth_2 in Λeq as [[R_f' M_f'] [get_blk' blk'_eq]]; eauto.
    cbn in *. clear_trivial_eqs. poLe_set.
    eapply SpillMKApp with (R_f:=R_f') (M_f:=M_f'); eauto.
    + rewrite subset_cardinal; eauto.
      rewrite blk'_eq, H7, H4.
      clear. clearbody K. cset_tac'.
    + revert H4 blk'_eq H7.
      clear. cset_tac.
    + rewrite <- H5.
      revert blk'_eq0. clear. cset_tac.
    + subst K; revert H7. clear. cset_tac.
  - econstructor; eauto.
Qed.

Lemma spill_max_kill_ext' ZL Λ Λ' s rlv RM sl k
  : poEq Λ' Λ
    -> spill_max_kill k ZL Λ  RM  s rlv sl
    -> spill_max_kill k ZL Λ' RM  s rlv sl.
Proof.
  intros; eapply spill_max_kill_monotone; try eassumption.
  eauto.
Qed.


Set Warnings "-extraction-opaque-accessed,-extraction".
Set Warnings "-notation-overridden,-parsing".
Set Implicit Arguments.

From QuickChick Require Import QuickChick.

Import QcDefaultNotation. Open Scope qc_scope.
Import GenLow GenHigh.

Require Import
        Ascii
        List
        ListDec
        String
        Tests.Generators.GenString
        Utils.Functions.ListUtils
        Utils.Functions.StringUtils.

Definition parts_non_empty (s : string) :=
  forallb (@non_empty ascii) (parts (string_to_list s)).

QuickChick (forAll gen_string parts_non_empty).

Definition parts_correct (s : string) :=
  forallb (fun xs => if string_dec (list_to_string (concat xs)) s then true
                  else false)
          (parts (string_to_list s)).

QuickChick (forAll gen_string parts_correct).