From Coq Require Import ssreflect ssrfun ssrbool.
Local Set Warnings "-notation-overridden".
From mathcomp Require Import ssrnat.
From PolyAI Require Export RelationalTransferFunction LSSA Tactic.
From Coq Require Import Lists.List.
From mathcomp.ssreflect Require Import seq.

Require Import Lia.

Local Open Scope string_scope.

Section AbstractInterpreter.

  Ltac simpl_ai :=
    repeat (autorewrite with airw; simpl_map; simplssr).
  Ltac auto_ai := intros ; simpl_ai ; autossr.

  Context {ab: eqType}
          {p: Program}
          {ad: adom (prod_eqType RegisterMap RegisterMap) ab p}
          {adr: adom_relational ad}
          (tf: transfer_function_relational adr p).

  (* Associate for every control location an abstract state *)
  Notation ASValues := (@total_map_d bbid_eqType (@total_map_d nat_eqType ab bot) (_ |-> bot)).
  Notation ASEdges := (@total_map_d bbid_eqType (@total_map_d bbid_eqType ab bot) (_ |-> bot)).
  Notation ASEdgesP := (@partial_map bbid_eqType (@total_map_d bbid_eqType ab bot)).
  Definition AS : Type := ASValues * ASEdges.

  (* Properties we want at the end of our analysis *)
  Definition inst_fixpoint (stateV: ASValues) (bb_id: bbid) (pos: nat) :=
    forall bb, p bb_id = Some bb ->
          forall inst, nth_error bb.1.2 pos = Some inst ->
                  le (transfer_inst inst (stateV bb_id pos)) (stateV bb_id (S pos)).

  Definition term_fixpoint (state: AS) (bb_id: bbid) :=
    forall bb, p bb_id = Some bb ->
          forall abbbid, (abbbid \in (transfer_term bb.2 (state.1 bb_id (length bb.1.2)))) ->
                    le abbbid.1 (state.2 bb_id abbbid.2).

  Definition edge_fixpoint (state: AS) (bb_id: bbid) :=
    forall in_id, le (state.2 in_id bb_id) (state.1 bb_id 0).

  Definition edges_invariant_some (stateE: ASEdges) :=
    forall in_id in_bb, p in_id = Some in_bb ->
      forall out_id, out_id \notin term_successors in_bb.2 ->
                stateE in_id out_id = bot.

  Definition edges_invariant_none (stateE: ASEdges) :=
    forall in_id, p in_id = None ->
             forall out_id, stateE in_id out_id = bot.

  Definition edges_invariant (stateE: ASEdges) :=
    edges_invariant_some stateE /\ edges_invariant_none stateE.

  (*   _           _   _ _     _    *)
  (*  (_)_ __  ___| |_| (_)___| |_  *)
  (*  | | '_ \/ __| __| | / __| __| *)
  (*  | | | | \__ \ |_| | \__ \ |_  *)
  (*  |_|_| |_|___/\__|_|_|___/\__| *)

  (* interpretation of a list of instruction *)
  Fixpoint abstract_interpret_inst_list (l: list Inst) (bb_id: bbid) (pos: nat) (stateV: ASValues) :=
    match l with
    | nil => stateV
    | inst::l' => let new_ab := transfer_inst inst (stateV bb_id pos) in
                let new_state := (bb_id |-> (S pos |-> new_ab; stateV bb_id); stateV) in
                abstract_interpret_inst_list l' bb_id (S pos) new_state
    end.

  Theorem abstract_interpret_inst_list_spec (bb: BasicBlock) (bb_id: bbid):
    Some bb = p bb_id ->
    forall (l: list Inst) pos, (forall n, nth_error l n = nth_error bb.1.2 (n + pos)) ->
      forall stateV, (forall n', n' < pos -> inst_fixpoint stateV bb_id n') ->
        forall n'', inst_fixpoint (abstract_interpret_inst_list l bb_id pos stateV) bb_id n''.
  Proof.
    move => Hbb.
    elim => [ /= pos Hnth stateV Hfixpoint n''| inst l Hind pos Hnth stateV Hfixpoint n'' /=].
    - case_eq (n'' < pos) => [/Hfixpoint // | /negb_true_iff Hge].
      rewrite /inst_fixpoint -Hbb => bb0 [<-] inst.
      move: (Hnth (n'' - pos)). rewrite -leqNgt in Hge. rewrite subnK => [<- | //].
      by case (n'' - pos).
    - apply Hind => [n | n' Hn'ltpos1]. by rewrite addnS; apply (Hnth n.+1).
      case (@idP (n' < pos)) => [Heqn'pos bb0 Hbb0 inst0 Hinst0 | /negP Hn'gepos bb0 Hbb0 inst0 Hinst0].
      + simpl_map. by eapply Hfixpoint; eauto.
      + simpl_map.
        have Heq : (n' = pos) by liassr. subst.
        move: Hbb0 (Hnth 0) => /=.
        rewrite -Hbb => [[->]].
          by rewrite add0n Hinst0 => [[->]].
  Qed.

  Theorem abstract_interpret_inst_list_0_unchanged (l: list Inst) (bb_id bb_id': bbid) (pos: nat) (stateV: ASValues) :
    (abstract_interpret_inst_list l bb_id pos stateV) bb_id' 0 = stateV bb_id' 0.
  Proof.
    elim: l stateV pos => [ // | i l Hind stateV pos]. move: Hind.
    case (bb_id' =P bb_id) => [-> | Hne] ->; by auto_map.
  Qed.

  Theorem abstract_interpret_inst_list_bb_unchanged (l: list Inst) (bb_id: bbid) :
    forall bb_id', bb_id != bb_id' ->
              forall state pos n, (abstract_interpret_inst_list l bb_id pos state) bb_id' n = state bb_id' n.
  Proof.
    move => bb_id' Hbb_ne.
    elim: l => [ // | i l Hind state pos n].
    rewrite Hind. auto_map.
  Qed.

  Hint Rewrite abstract_interpret_inst_list_0_unchanged abstract_interpret_inst_list_bb_unchanged using by first [liassr | autossr ] : airw.

  (*  _                               _             *)
  (* | |_ ___ _ __ _ __ ___   ___  __| | __ _  ___  *)
  (* | __/ _ \ '__| '_ ` _ \ / _ \/ _` |/ _` |/ _ \ *)
  (* | ||  __/ |  | | | | | |  __/ (_| | (_| |  __/ *)
  (*  \__\___|_|  |_| |_| |_|\___|\__,_|\__, |\___| *)
  (*                                    |___/       *)

  (* Interpretation of a terminator *)
  Definition abstract_interpret_term_join_edges (stateE: ASEdges) (bb_id: bbid) (edges: list (ab * bbid)) :=
    fold_right (fun (abid: (ab * bbid)) state =>
                  let (ab, out_id) := abid in (bb_id |-> (out_id |-> join ab (state bb_id out_id); state bb_id); state)
               ) stateE edges.

  Theorem abstract_interpret_term_join_edges_spec (in_id: bbid) (stateE: ASEdges) (edges: list (ab * bbid)):
    forall a out_id, (a, out_id) \in edges ->
                le a (abstract_interpret_term_join_edges stateE in_id edges in_id out_id).
  Proof.
    elim edges => [ // | [a out_id] l Hind a0 out_id0].
    simpl_ai.
    move => /orP[ /eqP [-> ->] | HIn].
    + by auto_map.
    + apply Hind in HIn.
      by case (out_id =P out_id0) => [ -> | /eqP Hne ]; auto_map.
  Qed.

  Hint Resolve abstract_interpret_term_join_edges_spec : core.

  Theorem abstract_interpret_term_join_edges_out_unchanged (in_id out_id: bbid) (stateE: ASEdges) (edges: list (ab * bbid)):
    (forall a , (a, out_id) \notin edges) ->
    forall id, (abstract_interpret_term_join_edges stateE in_id edges id out_id) = stateE id out_id.
  Proof.
    elim edges => [ // | /= [a id] l Hind HnotIn id0].
    move: (HnotIn a).
    rewrite in_cons => /norP [Hne HanotIn].
    have: (is_true (id != out_id)). apply /negP => /eqP Heq. by rewrite Heq eq_refl in Hne.
    move => Hneid.
    by case (in_id =P id0) => [ <- | /eqP Hneid0 ]; simpl_ai; apply Hind => a0; move: (HnotIn a0); autossr.
  Qed.

  Theorem abstract_interpret_term_join_edges_in_unchanged (id in_id: bbid) (stateE: ASEdges) (edges: list (ab * bbid)):
    in_id != id ->
    forall out_id, (abstract_interpret_term_join_edges stateE id edges in_id out_id) = stateE in_id out_id.
  Proof.
    move => Hne out_id.
    elim edges => [ // | [a out_id0] l Hind ].
    auto_ai.
  Qed.

  Hint Rewrite abstract_interpret_term_join_edges_out_unchanged abstract_interpret_term_join_edges_in_unchanged using by first [liassr | autossr ] : airw.

  (*  _                       *)
  (* | |_ ___ _ __ _ __ ___   *)
  (* | __/ _ \ '__| '_ ` _ \  *)
  (* | ||  __/ |  | | | | | | *)
  (*  \__\___|_|  |_| |_| |_| *)

  Definition abstract_interpret_term (bb: BasicBlock) (bb_id: bbid) (state: AS) :=
    let pos := length bb.1.2 in
    let new_edges := transfer_term bb.2 (state.1 bb_id pos) in
    abstract_interpret_term_join_edges state.2 bb_id new_edges.

  Theorem abstract_interpret_term_spec (bb: BasicBlock) (bb_id: bbid) (state: AS):
    p bb_id = Some bb ->
    term_fixpoint (state.1, (abstract_interpret_term bb bb_id state)) bb_id.
  Proof.
    move => Hbb. rewrite /term_fixpoint Hbb => bb0 [<-] [a out_id].
    rewrite /abstract_interpret_term /=.
    by auto.
  Qed.

  Hint Resolve abstract_interpret_term_spec : core.

  Lemma abstract_interpret_term_bb_edge_out_unchanged (bb_id: bbid) (bb: BasicBlock):
    p bb_id = Some bb ->
    forall bb_id', bb_id' \notin (term_successors bb.2) ->
              forall state bb_id'', (abstract_interpret_term bb bb_id state) bb_id'' bb_id' = state.2 bb_id'' bb_id'.
  Proof.
    move => Hbb bb_id' /negP Hbb_not_term state bb_id''.
    rewrite /abstract_interpret_term.
    apply abstract_interpret_term_join_edges_out_unchanged => a.
    apply /negP => Hbb_not_transfer_term.
    apply Hbb_not_term.
    eapply transfer_term_only_successors; eauto.
  Qed.

  Hint Rewrite abstract_interpret_term_bb_edge_out_unchanged using first [ liassr ; autossr ] : airw.

  Fixpoint join_edges_cond_aux (stateE: ASEdges) (seen: seq bbid) (cond: bbid -> bool) (x: bbid) :=
    match stateE with
    | TDDefault => bot
    | TDUpdate stateE' k v =>
      if (k \in seen) && (cond k) then
        join_edges_cond_aux stateE' seen cond x
      else
        join (v x) (join_edges_cond_aux stateE' (k::seen) cond x)
    end.

  Theorem join_edges_cond_aux_spec (stateE: ASEdges) (seen: seq bbid) (cond: bbid -> bool) (x y: bbid):
    cond y ->
    y \notin seen ->
    le (stateE y x) (join_edges_cond_aux stateE seen cond x).
  Proof.
    elim: stateE seen => [ seen Hcond // | stateE' Hind k v seen Hcond Hnotin ].
    case (k =P y) => [ -> | /eqP Hne ]. by auto_map.
    simpl_map.
    case: (k \in seen) => /=.
    - case: (cond k). by autossr.
      eapply AbstractDomain.le_trans; last first.
      + by apply join_sound_r.
      + apply Hind => //.
        by autossr.
    - eapply AbstractDomain.le_trans; last first.
      + by apply join_sound_r.
      + apply Hind; by autossr.
  Qed.

  Definition join_edges_cond (stateE: ASEdges) (cond: bbid -> bool) (bb_id: bbid) :=
    join_edges_cond_aux stateE [::] cond bb_id.

  Theorem join_edges_cond_spec (stateE: ASEdges) (cond: bbid -> bool) (bb_id bb_id': bbid) :
    cond bb_id' ->
    le (stateE bb_id' bb_id) (join_edges_cond stateE cond bb_id).
  Proof.
    move => Hcond.
      by apply join_edges_cond_aux_spec.
  Qed.

  Definition join_edges (stateE: ASEdges) (bb_id: bbid) :=
    join_edges_cond_aux stateE [::] (fun _ => true) bb_id.

  Theorem join_edges_spec (stateE: ASEdges) (bb_id bb_id': bbid) :
    le (stateE bb_id' bb_id) (join_edges stateE bb_id).
  Proof.
      by apply join_edges_cond_aux_spec.
  Qed.

  Hint Resolve join_edges_cond_spec join_edges_spec : core.

  Theorem abstract_interpret_term_edges_invariant_kept (bb_id: bbid) (bb: BasicBlock) (state: AS):
    p bb_id = Some bb ->
    edges_invariant state.2 ->
    edges_invariant (abstract_interpret_term bb bb_id state).
  Proof.
    move => Hbb [Hinvariant_some Hinvariant_none].
    split => [ in_id in_bb Hinbb out_id Hnotinsucc | ].
    - move => /(_ in_id in_bb Hinbb out_id Hnotinsucc) in Hinvariant_some.
      rewrite /abstract_interpret_term.
      case (bb_id =P in_id) => [Heq | Hbb_ne ].
      + rewrite Heq abstract_interpret_term_join_edges_out_unchanged => [ // | a ].
        apply /negP => Hin. move => /negP in Hnotinsucc. apply Hnotinsucc.
        eapply transfer_term_only_successors.
        bigsubst. by eauto.
      + auto_ai.
    - move => in_id Hin_id out_id.
      move => /(_ in_id Hin_id out_id) in Hinvariant_none.
      rewrite /abstract_interpret_term.
      have Hne : (bb_id != in_id). apply /eqP. intro. bigsubst. by rewrite Hbb in Hin_id.
      by simpl_ai.
  Qed.

  Hint Resolve abstract_interpret_term_edges_invariant_kept : core.

  (*  ____            _      ____  _            _     *)
  (* | __ )  __ _ ___(_) ___| __ )| | ___   ___| | __ *)
  (* |  _ \ / _` / __| |/ __|  _ \| |/ _ \ / __| |/ / *)
  (* | |_) | (_| \__ \ | (__| |_) | | (_) | (__|   <  *)
  (* |____/ \__,_|___/_|\___|____/|_|\___/ \___|_|\_\ *)

  (* Interpretation of a basic block *)
  Definition abstract_interpret_bb (bb: BasicBlock) (bb_id: bbid) (state: AS) :=
    let stateV1 := ( bb_id |-> (0 |-> join (state.1 bb_id 0) (join_edges state.2 bb_id); state.1 bb_id) ; state.1) in
    let stateV2 := abstract_interpret_inst_list bb.1.2 bb_id 0 stateV1 in
    let stateE' := abstract_interpret_term bb bb_id (stateV2, state.2) in
    (stateV2, stateE').

  Theorem abstract_interpret_bb_spec_term (bb: BasicBlock) (bb_id: bbid) (state: AS):
    p bb_id = Some bb ->
    term_fixpoint (abstract_interpret_bb bb bb_id state) bb_id.
  Proof.
    move => Hbb.
    rewrite /abstract_interpret_bb.
    set state'Values := (abstract_interpret_inst_list _ _ _ _).
    set state' := (state'Values, state.2).
    have H : state'Values = (state').1. auto.
    rewrite H.
    by apply abstract_interpret_term_spec.
  Qed.

  Theorem abstract_interpret_bb_spec_inst (bb: BasicBlock) (bb_id: bbid) (state: AS):
    p bb_id = Some bb ->
    (forall n, inst_fixpoint (abstract_interpret_bb bb bb_id state).1 bb_id n).
  Proof.
    move => /= Hbb n.
    eapply abstract_interpret_inst_list_spec => [  | n0 | // ].
    - by eauto.
    - by rewrite addn0.
  Qed.

  Theorem abstract_interpret_bb_spec_edge (bb: BasicBlock) (bb_id: bbid) (state: AS):
    Some bb = p bb_id ->
    bb_id \notin (term_successors bb.2) ->
    edge_fixpoint (abstract_interpret_bb bb bb_id state) bb_id.
  Proof.
    move => Hbb Hotin /=.
    rewrite /edge_fixpoint => in_id.
    rewrite abstract_interpret_term_bb_edge_out_unchanged; auto.
    rewrite abstract_interpret_inst_list_0_unchanged.
    by auto_map.
  Qed.

  Hint Resolve abstract_interpret_bb_spec_term abstract_interpret_bb_spec_inst abstract_interpret_bb_spec_edge : core.

  Theorem abstract_interpret_bb_edge_in_unchanged (bb: BasicBlock) (bb_id in_id out_id: bbid) (state: AS):
    Some bb = p bb_id ->
    in_id != bb_id ->
    (abstract_interpret_bb bb bb_id state).2 in_id out_id = state.2 in_id out_id.
  Proof.
    move => Hbb Hbbne /=.
    rewrite /abstract_interpret_term /=.
      by auto_ai.
  Qed.

  Theorem abstract_interpret_bb_value_unchanged (bb: BasicBlock) (bb_id bb_id': bbid) (state: AS):
    Some bb = p bb_id ->
    bb_id != bb_id' ->
    forall pos, (abstract_interpret_bb bb bb_id state).1 bb_id' pos = state.1 bb_id' pos.
  Proof.
    move => Hbb Hbbne pos /=.
      by auto_ai.
  Qed.

  Theorem abstract_interpret_bb_edges_invariant_kept (bb_id: bbid) (bb: BasicBlock) (state: AS):
    p bb_id = Some bb ->
    edges_invariant state.2 ->
    edges_invariant (abstract_interpret_bb bb bb_id state).2.
  Proof.
    by auto_map.
  Qed.

  Hint Rewrite abstract_interpret_bb_edge_in_unchanged abstract_interpret_bb_value_unchanged using first [ liassr ; autossr ] : airw.
  Hint Resolve abstract_interpret_bb_edges_invariant_kept : core.

  (*  _                       *)
  (* | |    ___   ___  _ __   *)
  (* | |   / _ \ / _ \| '_ \  *)
  (* | |__| (_) | (_) | |_) | *)
  (* |_____\___/ \___/| .__/  *)
  (*                  |_|     *)

  Definition set_input_to_identity (state: AS) (entry_id: bbid) :=
    ((entry_id |-> (0 |-> id_relation ; state.1 entry_id); state.1), state.2).

  Program Definition compose_relation_in_program_edges (ps: ProgramStructure) (stateE: ASEdges) (relation: ab) :=
    td_pointwise_un_op_in_seq stateE (fun m => td_pointwise_un_op m (compose_relation relation)) (bbs_in_program ps).

  Theorem compose_relation_in_program_edges_spec (ps: ProgramStructure) (stateE: ASEdges) (relation: ab) (in_id out_id: bbid) :
    compose_relation_in_program_edges ps stateE relation in_id out_id =
    if (in_id \in bbs_in_program ps) then compose_relation relation (stateE in_id out_id) else stateE in_id out_id.
  Proof.
    rewrite td_pointwise_un_op_in_seq_spec.
    case: (in_id \in bbs_in_program ps) => [ /= | // ].
    rewrite /eq_rect. case (compose_relation_in_program_edges_obligation_1 relation).
    by auto_ai.
  Qed.

  Hint Rewrite compose_relation_in_program_edges_spec using first [ liassr ; autossr ] : airw.

  Theorem compose_relation_in_program_edges_edges_invariant_kept (ps: ProgramStructure) (stateE: ASEdges):
    edges_invariant stateE ->
    forall relation, edges_invariant (compose_relation_in_program_edges ps stateE relation).
  Proof.
    move => [Hinvariant_some Hinvariant_none] relation.
    split => [ in_id in_bb Hin_bb out_id Houtnotsucc | in_id Hin_bb out_id].
    - move => /(_ in_id in_bb Hin_bb out_id Houtnotsucc) in Hinvariant_some.
      simpl_ai.
      case: (in_id \in bbs_in_program ps) => //.
        by rewrite Hinvariant_some.
    - move => /(_ in_id Hin_bb out_id) in Hinvariant_none.
      simpl_ai.
      rewrite Hinvariant_none. simpl_ai.
      by case (_ \in _).
  Qed.

  Hint Resolve compose_relation_in_program_edges_edges_invariant_kept : core.

    Program Definition compose_transitive_closure_in_program_edges (ps: ProgramStructure) (stateE: ASEdges) (relation: ab) :=
      td_pointwise_un_op_in_seq stateE (fun m => td_pointwise_un_op m (compose_transitive_closure relation)) (bbs_in_program ps).

    Theorem compose_transitive_closure_in_program_edges_spec (ps: ProgramStructure) (stateE: ASEdges) (relation: ab) (in_id out_id: bbid) :
      compose_transitive_closure_in_program_edges ps stateE relation in_id out_id =
      if (in_id \in bbs_in_program ps) then compose_transitive_closure relation (stateE in_id out_id) else stateE in_id out_id.
    Proof.
      rewrite td_pointwise_un_op_in_seq_spec.
      case: (in_id \in bbs_in_program ps) => [ /= | // ].
      rewrite /eq_rect. case (compose_transitive_closure_in_program_edges_obligation_1 relation).
        by auto_ai.
    Qed.

    Hint Rewrite compose_transitive_closure_in_program_edges_spec using first [ liassr ; autossr ] : airw.

    Theorem compose_transitive_closure_in_program_edges_edges_invariant_kept (ps: ProgramStructure) (stateE: ASEdges):
      edges_invariant stateE ->
      forall relation, edges_invariant (compose_transitive_closure_in_program_edges ps stateE relation).
    Proof.
      move => [Hinvariant_some Hinvariant_none] relation.
      split => [ in_id in_bb Hin_bb out_id Houtnotsucc | in_id Hin_bb out_id].
      - move => /(_ in_id in_bb Hin_bb out_id Houtnotsucc) in Hinvariant_some.
        simpl_ai. case: (in_id \in bbs_in_program ps) => //.
          by rewrite Hinvariant_some.
      - move => /(_ in_id Hin_bb out_id) in Hinvariant_none.
        simpl_ai. rewrite Hinvariant_none. simpl_ai.
          by case_if.
    Qed.

    Hint Resolve compose_transitive_closure_in_program_edges_edges_invariant_kept : core.

    Program Definition compose_transitive_closure_in_program_values (ps: ProgramStructure) (stateV: ASValues) (relation: ab) :=
      td_pointwise_un_op_in_seq stateV (fun m => td_pointwise_un_op m (compose_transitive_closure relation)) (bbs_in_program ps).

  Theorem compose_transitive_closure_in_program_values_spec (ps: ProgramStructure) (stateV: ASValues) (relation: ab) (bb_id: bbid) (pos: nat) :
    compose_transitive_closure_in_program_values ps stateV relation bb_id pos =
    if (bb_id \in bbs_in_program ps) then compose_transitive_closure relation (stateV bb_id pos) else stateV bb_id pos.
  Proof.
    rewrite td_pointwise_un_op_in_seq_spec.
    case: (bb_id \in bbs_in_program ps) => [ | // ].
    rewrite /eq_rect. case (compose_transitive_closure_in_program_values_obligation_1 relation).
    by auto_ai.
  Qed.

  Hint Rewrite compose_transitive_closure_in_program_values_spec : airw.

  Program Definition compose_transitive_closure_in_program (ps: ProgramStructure) (state: AS) (relation: ab) :=
    let stateV := compose_transitive_closure_in_program_values ps state.1 relation in
    let stateE := compose_transitive_closure_in_program_edges ps state.2 relation in
    (stateV, stateE).

  Program Definition compose_relation_in_program_values (ps: ProgramStructure) (stateV: ASValues) (relation: ab) :=
    td_pointwise_un_op_in_seq stateV (fun m => td_pointwise_un_op m (compose_relation relation)) (bbs_in_program ps).

  Theorem compose_relation_in_program_values_spec (ps: ProgramStructure) (stateV: ASValues) (relation: ab) (bb_id: bbid) (pos: nat) :
    compose_relation_in_program_values ps stateV relation bb_id pos =
    if (bb_id \in bbs_in_program ps) then compose_relation relation (stateV bb_id pos) else stateV bb_id pos.
  Proof.
    rewrite td_pointwise_un_op_in_seq_spec.
    case: (bb_id \in bbs_in_program ps) => [ | // ].
    rewrite /eq_rect. case (compose_relation_in_program_values_obligation_1 relation).
    by auto_ai.
  Qed.

  Hint Rewrite compose_relation_in_program_values_spec : airw.

  Definition compose_relation_in_program (ps: ProgramStructure) (state: AS) (relation: ab) :=
    let stateV := compose_relation_in_program_values ps state.1 relation in
    let stateE := compose_relation_in_program_edges ps state.2 relation in
    (stateV, stateE).

  Definition compute_loop_effect_without_transitive (ps: ProgramStructure) (stateE: ASEdges) (header_id: bbid) :=
    join_edges_cond stateE (fun bb_id => bb_id \in (bbs_in_program ps)) header_id.

  (*Definition compute_loop_effect (ps: ProgramStructure) (stateE: ASEdges) (header_id: bbid) :=
    let loop_sym_effect := join_edges_cond stateE (fun bb_id => bb_id \in (bbs_in_program ps)) header_id in
    transitive_closure loop_sym_effect.*)

  Definition compute_loop_enter (ps: ProgramStructure) (stateE: ASEdges) (header_id: bbid) :=
    join_edges_cond stateE (fun bb_id => bb_id \notin (bbs_in_program ps)) header_id.

  (*Definition compute_loop_effect_with_enter (ps: ProgramStructure) (stateE: ASEdges) (header_id: bbid) :=
    let loop_effect := compute_loop_effect ps stateE header_id in
    let entering_loop := join_edges_cond stateE (fun bb_id => bb_id \notin (bbs_in_program ps)) header_id in
    compose_relation entering_loop loop_effect.*)

  (*  ____                                       *)
  (* |  _ \ _ __ ___   __ _ _ __ __ _ _ __ ___   *)
  (* | |_) | '__/ _ \ / _` | '__/ _` | '_ ` _ \  *)
  (* |  __/| | | (_) | (_| | | | (_| | | | | | | *)
  (* |_|   |_|  \___/ \__, |_|  \__,_|_| |_| |_| *)
  (*                  |___/                      *)

  Fixpoint abstract_interpret_program (ps: ProgramStructure) (state: AS) :=
    match ps with
    | BB bb_id =>
      match p bb_id with
      | Some bb => abstract_interpret_bb bb bb_id state
      | None => state
      end
    | DAG ps1 ps2 =>
      abstract_interpret_program ps2 (abstract_interpret_program ps1 state)
    | Loop header_id body =>
      match p header_id with
      | None => state
      | Some header =>
        let state0 := set_input_to_identity state header_id in
        let state1 := abstract_interpret_bb header header_id state0 in
        let state2 := abstract_interpret_program body state1 in
        (*let loop_effect_with_enter := compute_loop_effect_with_enter ps state2.2 header_id in
        compose_relation_in_program ps state2 loop_effect_with_enter*)
        let loop_effect := compute_loop_effect_without_transitive ps state2.2 header_id in
        let loop_enter := compute_loop_enter ps state2.2 header_id in
        let state3 := compose_transitive_closure_in_program ps state2 loop_effect in
        compose_relation_in_program ps state3 loop_enter
      end
    end.

  Theorem abstract_interpret_program_edges_invariant_kept (ps: ProgramStructure) (state: AS):
    structure_sound p ps ->
    edges_invariant state.2 ->
    edges_invariant (abstract_interpret_program ps state).2.
  Proof.
    elim: ps state.
    - move => header body Hind state /= /andP[/andP[_ Hsound] _] Hinvariant /=.
      by case Hheader: (p header); auto_ai.
    - move => ps1 Hind1 ps2 Hind2 state /= /andP[/andP[_ Hsound1] Hsound2].
      by auto.
    - move => state bb_id /= Hsound Hinvariant.
      case_eq (p state) => [ bb Hbb | // ].
      by auto.
  Qed.

  Hint Resolve abstract_interpret_program_edges_invariant_kept : core.

  Theorem abstract_interpret_program_edge_in_unchanged (ps: ProgramStructure) (in_id out_id: bbid) (state: AS):
    structure_sound p ps ->
    in_id \notin (bbs_in_program ps) ->
    (abstract_interpret_program ps state).2 in_id out_id = state.2 in_id out_id.
  Proof.
    elim: ps state.
    - move => header_id body Hind state /= /andP [/andP[_ Hsound] _] Hnotin.
      case Hheader: (p header_id) => [ header_bb | // ].
      simpl_ai.
      rewrite Hind; autossr.
      by rewrite abstract_interpret_bb_edge_in_unchanged; autossr.
    - move => ps1 Hind1 ps2 Hind2 state /= /andP[/andP[_ Hsound1] Hsound2].
      rewrite mem_cat => /norP [Hnotin1 Hnotin2].
        by rewrite Hind2; auto.
    - move => bb_id state /=.
      case Hbb: (p bb_id) => [[[inputs insts] term] | // ] Hnotinterm Hnotin.
      simpl_ai.
      by rewrite abstract_interpret_bb_edge_in_unchanged; auto.
  Qed.

  Hint Rewrite abstract_interpret_program_edge_in_unchanged using by first [liassr | autossr ] : airw.

  Theorem abstract_interpret_program_value_unchanged (ps: ProgramStructure) (in_id: bbid) (state: AS):
    structure_sound p ps ->
    in_id \notin (bbs_in_program ps) ->
    forall pos, (abstract_interpret_program ps state).1 in_id pos = state.1 in_id pos.
  Proof.
    elim: ps state.
    - move => header_id body Hind state /= /andP[/andP[_ Hsound] _] /negb_true_iff Hnotin pos.
      case H: (p header_id) => //=.
      rewrite compose_relation_in_program_values_spec Hnotin /=.
      move: Hnotin. rewrite in_cons eq_sym => /orb_false_iff[Hne Hnotin].
      simpl_ai. rewrite in_cons. rewrite eq_sym in Hne. rewrite Hne Hnotin /=.
      rewrite Hind => //; last by rewrite Hnotin.
      rewrite abstract_interpret_bb_value_unchanged => //; last by rewrite eq_sym Hne.
      rewrite /set_input_to_identity. rewrite td_update_neq => [ // | ].
      by rewrite eq_sym Hne.
    - move => ps1 Hind1 ps2 Hind2 state /= /andP[/andP[_ Hsound1] Hsound2].
      rewrite /= mem_cat => /norP[Hnotin1 Hnotin2] pos.
      rewrite Hind2; auto.
    - move => bb_id state /=. case_eq (p bb_id); auto => bb Hbb _.
      rewrite mem_seq1 => Hne pos.
      by auto_ai.
  Qed.

  Hint Rewrite abstract_interpret_program_value_unchanged using by first [liassr | autossr ] : airw.

  Lemma abstract_interpret_program_term_fixpoint_kept (ps: ProgramStructure):
    structure_sound p ps ->
    forall bb_id, (bb_id \notin (bbs_in_program ps)) ->
             forall state, term_fixpoint state bb_id ->
                      term_fixpoint (abstract_interpret_program ps state) bb_id.
  Proof.
    move => Hsound bb_id Hbbnotin state Hterm bb Hbb [a out_id].
    move: Hterm => /(_ bb Hbb (a, out_id)).
    by simpl_ai.
  Qed.

  Theorem abstract_interpret_program_spec_term (ps: ProgramStructure):
    structure_sound p ps ->
    forall bb_id, (bb_id \in (bbs_in_program ps)) ->
             forall state, term_fixpoint (abstract_interpret_program ps state) bb_id.
  Proof.
    elim: ps.
    - move => header body Hind /= /andP[/andP[/andP[Hheadernotinbody _] Hsoundbody] HheaderSome] bb_id Hin state. move: HheaderSome.
      case Hheader: (p header) => [ bb | //] _ bb0 Hbb0 [x bb_id'] Hin2.
      simpl_ai.
      rewrite compose_relation_in_program_values_spec Hin in Hin2.
      apply transfer_term_compose in Hin2. move: Hin2 => [a'' [Hin2 Hle]] /=.
      rewrite compose_transitive_closure_in_program_values_spec Hin in Hin2.
      apply transfer_term_compose_transitive_closure in Hin2. move: Hin2 => [a''' [Hin2 Hle']] /=.
      eapply AbstractDomain.le_trans. exact Hle. apply compose_relation_le.
      eapply AbstractDomain.le_trans. exact Hle'. apply compose_transitive_closure_le.
      move: Hin. rewrite in_cons => /orP [/eqP Heq | Hin].
      + bigsubst.
        rewrite abstract_interpret_program_edge_in_unchanged; auto.
        rewrite abstract_interpret_program_value_unchanged in Hin2; auto.
        move: (Hbb0) => Htransfer_bb.
        eapply abstract_interpret_bb_spec_term in Htransfer_bb.
        by move => /(_ bb Hbb0 (a''', bb_id') Hin2) /= in Htransfer_bb.
      + set state' := (abstract_interpret_bb _ _ _).
        by move => /(_ Hsoundbody bb_id Hin state' bb0 Hbb0 (a''', bb_id') Hin2) in Hind.
    - move => ps1 Hind1 ps2 Hind2 /= /andP[/andP[/andP[/andP[/allP Hnotsame1 Hnotsame2] HsoundDAG] Hsound1] Hsound2] bb_id.
      rewrite mem_cat => /orP[Hin1 | Hin2] state; [ | auto].
      move => /(_ bb_id Hin1) in Hnotsame1.
      apply abstract_interpret_program_term_fixpoint_kept => //.
      by apply Hind1.
    - move => bb_id /=. case Hbb: (p bb_id) => [bb | //] Hnotinsucc bb_id'.
      rewrite mem_seq1 => /eqP -> state.
      by apply abstract_interpret_bb_spec_term.
  Qed.

  Lemma abstract_interpret_program_inst_fixpoint_kept (ps: ProgramStructure):
    structure_sound p ps ->
    forall bb_id, (bb_id \notin (bbs_in_program ps)) ->
             forall state pos, inst_fixpoint state.1 bb_id pos ->
                          inst_fixpoint (abstract_interpret_program ps state).1 bb_id pos.
  Proof.
    move => Hsound bb_id Hbbnotin state pos Hinstfix bb Hbb inst Hinst.
    simpl_ai.
    by move: Hinstfix => /(_ bb Hbb inst Hinst).
  Qed.

  Theorem abstract_interpret_program_spec_inst (ps: ProgramStructure):
    structure_sound p ps ->
    forall bb_id, (bb_id \in (bbs_in_program ps)) ->
             forall state pos, inst_fixpoint (abstract_interpret_program ps state).1 bb_id pos.
  Proof.
    elim: ps.
    - move => header body Hind /= /andP[/andP[/andP[Hheadernotinbody _] Hsoundbody] HheaderSome] bb_id Hin state pos.
      move: HheaderSome. case Hheader : (p header) => [ bb_header | //] _ bb Hbb inst Hinst.
      simpl_ai.
      eapply AbstractDomain.le_trans. by apply transfer_inst_compose. apply compose_relation_le.
      eapply AbstractDomain.le_trans. by apply transfer_inst_compose_transitive_closure. apply compose_transitive_closure_le.
      move: Hin. rewrite in_cons => /orP [/eqP Heq | Hin].
      + bigsubst.
        rewrite !abstract_interpret_program_value_unchanged; auto.
        eapply abstract_interpret_bb_spec_inst in Hbb.
        by eapply Hbb; eauto.
      + set state' := (abstract_interpret_bb _ _ _).
        by move => /(_ Hsoundbody bb_id Hin state' pos bb Hbb inst Hinst) in Hind.
    - move => ps1 Hind1 ps2 Hind2 /= /andP[/andP[/andP[/andP[/allP Hnotsame1 Hnotsame2] HsoundDAG] Hsound1] Hsound2] bb_id.
      rewrite mem_cat => /orP[Hin1 | Hin2] state pos; [ | auto].
      move => /(_ bb_id Hin1) in Hnotsame1.
      apply abstract_interpret_program_inst_fixpoint_kept => //.
      by apply Hind1.
    - move => bb_id /=. case Hbb: (p bb_id) => [bb | //] Hnotinsucc bb_id0 Hne.
      move: Hne. rewrite mem_seq1 => /eqP -> state pos.
        by apply abstract_interpret_bb_spec_inst.
  Qed.

  Theorem abstract_interpret_program_spec_edge (ps: ProgramStructure):
    structure_sound p ps ->
    forall bb_id, (bb_id \in (bbs_in_program ps)) ->
             forall state, edges_invariant state.2 ->
                      edge_fixpoint (abstract_interpret_program ps state) bb_id.
  Proof.
    elim: ps.
    - move => header body Hind /= /andP[/andP[/andP[Hheadernotinbody Hnaturalloop] Hsoundbody] HheaderSome] bb_id Hin state Hinvariant.
      move: HheaderSome. case Hheader: (p header) => [ bb_header| //] _ in_id /=.
      set state' := (abstract_interpret_program _ _).
      simpl_ai.
      move: Hin. rewrite in_cons => /orP[/eqP Hbb_id | Hbbid_in].
      + subst. case (@idP (in_id \in bbs_in_program (Loop header body))) => [Hin_in | /negP /= Hin_notin]; simplssr.
        * rewrite abstract_interpret_program_value_unchanged => //.
          rewrite abstract_interpret_inst_list_0_unchanged. simpl_map.
          rewrite /compute_loop_effect_without_transitive.
          apply compose_relation_le.
          eapply AbstractDomain.le_trans; last first. apply compose_transitive_closure_le, join_sound_l.
          eapply AbstractDomain.le_trans; last first. apply compose_transitive_closure_id.
          apply compose_transitive_closure_le.
          by auto_ai.
        * rewrite /state' /compute_loop_effect_without_transitive.
          simpl_ai.
          eapply AbstractDomain.le_trans; last first. apply compose_relation_quotient_right, compose_transitive_closure_le, join_sound_l.
          eapply AbstractDomain.le_trans; last first. apply compose_relation_quotient_right, compose_transitive_closure_ge_id.
          eapply AbstractDomain.le_trans; last first. apply compose_relation_id.
          eapply AbstractDomain.le_trans; last first. apply join_edges_cond_spec. rewrite in_cons. apply /norP. split. apply H. exact Hin_notin.
          by auto_ai.
      + case (@idP (in_id \in bbs_in_program (Loop header body))) => [Hin_in | /negP Hin_notin]; simplssr.
        * apply compose_relation_le.
          have Hinvariant2 : (edges_invariant (set_input_to_identity state header).2) by [].
          eapply abstract_interpret_bb_edges_invariant_kept in Hinvariant2; last first. apply Hheader.
          move: (Hind Hsoundbody bb_id Hbbid_in _ Hinvariant2 in_id) => Hgoal.
          by apply compose_transitive_closure_le.
        * have Hinvariant' : (edges_invariant state'.2).
            by apply abstract_interpret_program_edges_invariant_kept, abstract_interpret_bb_edges_invariant_kept => //.
          move => /allP /(_ bb_id Hbbid_in) /allP /(_ in_id) in Hnaturalloop.
          have -> // : (state'.2 in_id bb_id = bot).
          case: Hinvariant' => Hinvariant'_some Hinvariant'_none.
          case Hin_bb: (p in_id) => [[[in_inputs in_insts] in_term] | ]; [ | auto].
          eapply Hinvariant'_some; eauto.
          rewrite program_predecessors_spec Hin_bb in Hnaturalloop.
          apply /negP => Hinterm.
          apply Hnaturalloop in Hinterm.
            by rewrite Hinterm in Hin_notin.
    - move => ps1 Hind1 ps2 Hind2 /= /andP[/andP[/andP[/andP[/allP Hnotsame1 Hnotsame2] /allP HsoundDAG] Hsound1] Hsound2] bb_id.
      rewrite mem_cat => /orP[Hin1 | Hin2] state Hinvariant; last first. apply Hind2 => //. by apply abstract_interpret_program_edges_invariant_kept.
      move => in_id.
      case Hin_id: (p in_id) => [ [[in_inputs in_insts] in_term] | ].
      + simpl_ai.
        move => /(_ Hsound1 bb_id Hin1 state Hinvariant in_id) in Hind1.
        case (@idP (in_id \in bbs_in_program ps2)) => [ Hin2 | /negP Hnotin2 ]; [ | auto_ai ].
        * have Hnotinps2 : (bb_id \notin program_successors p ps2). apply /negP => Hinps2.
            by move => /(_ bb_id Hinps2) in HsoundDAG; rewrite Hin1 in HsoundDAG.
          apply abstract_interpret_program_edges_invariant_kept with (ps := ps1) in Hinvariant => //.
          apply abstract_interpret_program_edges_invariant_kept with (ps := ps2) in Hinvariant => //.
          case Hinvariant => [Hinvariant_some _].
          move => /(_ _ _ Hin_id bb_id) in Hinvariant_some.
          rewrite Hinvariant_some => //.
          apply /negP => Hinterm.
          move => /negP in Hnotinps2. apply Hnotinps2.
          apply program_successors_spec.
          exists in_id. rewrite Hin2. split; auto. by rewrite Hin_id.
      + apply abstract_interpret_program_edges_invariant_kept with (ps := ps1) in Hinvariant => //.
        apply abstract_interpret_program_edges_invariant_kept with (ps := ps2) in Hinvariant => //.
        case Hinvariant => [_ Hinvariant_none].
        move => /(_ _ Hin_id bb_id) in Hinvariant_none.
        by rewrite Hinvariant_none.
    - move => bb_id /= Hsound bb_id0. rewrite mem_seq1 => /eqP -> state.
      move: Hsound. case_eq (p bb_id) => [ [[bb_inputs bb_insts] bb_term] Hbb Hnotin Hinvariant | //].
        by apply abstract_interpret_bb_spec_edge.
  Qed.

  Definition input_state : AS :=
    (("entry" |-> (O |-> id_relation; _ |-> bot); (_ |-> (_ |-> bot))), (_ |-> (_ |-> bot))).

  Theorem abstract_interpret_program_spec (ps: ProgramStructure):
    structure_sound p (DAG (BB "entry") ps) ->
    (forall bb_id bb, p bb_id = Some bb <-> (bb_id \in (bbs_in_program (DAG (BB "entry") ps)))) ->
    forall R R' bb_id pos, reachable_states p R (bb_id, pos, R') ->
                      forall bb, p bb_id = Some bb ->
                      Ensembles.In _ (gamma ((abstract_interpret_program (DAG (BB "entry") ps) input_state).1 bb_id pos)) (R, R').
  Proof.
    move => /= /andP[/andP[/andP[/andP[/andP[Hnotsame1 _] Hnotsame2] HsoundDAG] Hsound1] Hsound2] Hallin R R' bb_id pos Hreachable_states bb Hbb.
    move: Hreachable_states. rewrite /reachable_states.
    move Hs : ("entry", O, R) => s.
    move Hs' : (bb_id, pos, R') => s'.
    set p'hack := (p, 0).
    move Hp : p'hack.1 => p'. rewrite /= in Hp.
    rewrite [in p "entry"]Hp [in multi_step _ _ _]Hp.
    move => Hmulti_step. move: Hs' Hs Hp.
    move: bb_id bb Hbb pos R'.
    elim Hmulti_step => [ p0 s0 bb_id bb Hbb pos R' <- [<- <- <-] <- | ].
    - case_eq (p "entry").
      + move => bb_entry Hbb_entry. rewrite abstract_interpret_program_value_unchanged => //=.
        rewrite abstract_interpret_inst_list_0_unchanged.
        rewrite /join_edges. rewrite /join_edges_cond_aux.
        simpl_map.
        by apply join_sound_l, id_relation_spec.
      + rewrite abstract_interpret_program_value_unchanged => //= _.
        simpl_map. by apply id_relation_spec.
    - move => p0 s0 [[bb_id' pos'] R'] s0'' Hmulti_step' Hind Hstep' bb_id'' bb Hbb pos'' R'' Hs0'' Hs0 Hp0.
      move: Hind. rewrite -Hp0. case_eq (p "entry") => [ bb_entry Hbb_entry | Hentry ].
      + inversion Hstep'.
        * rewrite -Hs0'' in H4. inversion H4. symmetry in Hp0. subst.
          move => /(_ bb_id'' bb Hbb pos' R' (erefl _) (erefl _) (erefl _)) Hind.
          move: (H3) => Hbb''.
          apply Hallin in H3. move: H3. rewrite in_cons => /orP[ /eqP Hentry'' | Hbb''_in ].
          { subst. rewrite abstract_interpret_program_value_unchanged => //.
            have: (inst_fixpoint (abstract_interpret_bb bb_entry "entry" input_state).1 "entry" pos') by apply abstract_interpret_bb_spec_inst.
            move => /(_ _ Hbb'' _ H5). apply.
            eapply transfer_inst_sound. apply H6. rewrite /abstract_interpret_bb in Hind.
              by rewrite abstract_interpret_program_value_unchanged in Hind. }
          { have: (inst_fixpoint (abstract_interpret_program ps (abstract_interpret_bb bb_entry "entry" input_state)).1 bb_id'' pos'). apply abstract_interpret_program_spec_inst => //.
            move => /(_ _ Hbb'' _ H5). apply.
            eapply transfer_inst_sound; eauto. }
        * rewrite -Hs0'' in H4. inversion H4. symmetry in Hp0. subst. move: (H3) => Hbb''.
          move => /(_ bb_id' (params, insts, term) Hbb'' pos' R' (erefl _) (erefl _) (erefl _)) Hind.
          apply Hallin in H3. move: H3. rewrite in_cons => /orP[ /eqP Hentry' | Hbb'_in ].
          { subst. apply Hallin in Hbb. move: Hbb. rewrite in_cons => /orP [/eqP Hentry'' | Hbb''_in].
            { subst. rewrite Hbb'' in Hsound1. inversion H6; subst; try by rewrite /= in Hsound1.
              rewrite /= in Hsound1. rewrite in_cons mem_seq1 eq_refl in Hsound1. move => /norP in Hsound1.
              by move: Hsound1 => [_ Hsound1]. }
            { move: (abstract_interpret_program_spec_edge ps Hsound2 bb_id'' Hbb''_in (abstract_interpret_bb bb_entry "entry" input_state)).
              move: (term_successors_spec _ _ _ _ _ H6) => Hin_term_succ.
              have Hinvariant : (edges_invariant (abstract_interpret_bb bb_entry "entry" input_state).2). by apply abstract_interpret_bb_edges_invariant_kept => //.
              move => /(_ Hinvariant "entry"). apply.
              move: (abstract_interpret_bb_spec_term (params, insts, term) "entry" input_state Hbb'').
              rewrite abstract_interpret_program_edge_in_unchanged => //.
              move: (Hmulti_step') => Hinbounds.
              apply reachable_states_pos in Hinbounds. rewrite /= Hbb'' in Hinbounds.
              apply nth_error_None in H5.
              have Hpos': (Datatypes.length insts = pos') by liassr.
              move => /(_ _ Hbb''). rewrite Hpos'.
              eapply transfer_term_sound in H6; last first. apply Hind.
              move: H6 => [a' [HInTerm HIn]] /(_ (a', bb_id'')).
              rewrite abstract_interpret_program_value_unchanged in HInTerm => //.
              rewrite Hbb_entry in Hbb''. inversion Hbb''. subst.
              move => /(_ HInTerm (R, R'') HIn). auto.
            }
          }
          {
            move: (Hbb) => Hbb_in. apply Hallin in Hbb_in. move: Hbb_in. rewrite in_cons => /orP [/eqP Hbb''' | Hbb''_in].
            {
              subst. apply term_successors_spec in H6. move => /allP /(_ "entry") in HsoundDAG.
              have: ("entry" \in program_successors p ps); last first. move => /HsoundDAG. by rewrite in_cons eq_refl.
              apply program_successors_spec.
              exists bb_id'. split; auto. by rewrite Hbb''.
            }
            {
              move: (abstract_interpret_program_spec_edge ps Hsound2 bb_id'' Hbb''_in (abstract_interpret_bb bb_entry "entry" input_state)).
              move: (term_successors_spec _ _ _ _ _ H6) => Hin_term_succ.
              have Hinvariant : (edges_invariant (abstract_interpret_bb bb_entry "entry" input_state).2). by apply abstract_interpret_bb_edges_invariant_kept.
              move => /(_ Hinvariant bb_id'). apply.
              move: (abstract_interpret_program_spec_term ps Hsound2 bb_id' Hbb'_in (abstract_interpret_bb bb_entry "entry" input_state)).
              move: (Hmulti_step') => Hinbounds.
              apply reachable_states_pos in Hinbounds. rewrite /= Hbb'' in Hinbounds.
              apply nth_error_None in H5.
              have Hpos': (Datatypes.length insts = pos') by liassr.
              move => /(_ _ Hbb''). rewrite Hpos'.
              eapply transfer_term_sound in H6; last first. apply Hind.
              move: H6 => [a' [HInTerm HIn]] /(_ (a', bb_id'')).
              move => /(_ HInTerm (R, R'') HIn). auto.
            }
          }
      + have: ("entry" \in "entry" :: (bbs_in_program ps)) by rewrite in_cons eq_refl.
        move => /Hallin. by rewrite Hentry => /(_ bb).
  Qed.

End AbstractInterpreter.


Require Export DACandMAC.

Section Unlink.

Variable s : SFSstate.

(*********************************************************************)
(*                   Some Useful Synonymous                          *)
(*********************************************************************)

Definition unlink_oSC (o : OBJECT) : set (OBJECT * SecClass) :=
  match fOSC (objectSC s) o with
  | None => objectSC s
  | Some y => set_remove OSCeq_dec (o, y) (objectSC s)
  end.

Definition unlink_acl (o : OBJECT) : set (OBJECT * AccessCtrlListData) :=
  match facl (acl s) o with
  | None => acl s
  | Some y => set_remove ACLeq_dec (o, y) (acl s)
  end.

Let t (o : OBJECT) : SFSstate :=
  mkSFS (groups s) (primaryGrp s) (subjectSC s) (AllGrp s)
    (RootGrp s) (SecAdmGrp s) (unlink_oSC o) (unlink_acl o)
    (secmat s) (unlink_files o) (unlink_directories o).

(*********************************************************************)
(*                           unlink                                  *)
(*********************************************************************)

(*This operation removes a given file form the filesystem.           *)

Inductive unlink (u : SUBJECT) (o : OBJECT) : SFSstate -> Prop :=
    UnlinkOK :
      ObjType o = File ->
      set_In (MyDir (ObjName o)) (domd (directories s)) ->
      match fsecmat (secmat s) (MyDir (fst o)) with
      | None => False
      | Some y => set_In u (ActWriters y)
      end -> ~ set_In o (domsecmat (secmat s)) -> unlink u o (t o).

End Unlink.

Hint Unfold unlink_oSC unlink_acl.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal85.

From lfind Require Import LFind.
Lemma lfind_state  (x:natural) (y:natural) (z:natural):@eq natural (plus (mult x y) (plus y z)) (plus (mult x y) (plus z y)).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal85_theorem0_66_plus_commut/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (x:natural) (y:natural) (z:natural) :=
 let lfind_var := "x:" ++ "(" ++ show x ++ ")"++ "|" ++"y:" ++ "(" ++ show y ++ ")"++ "|" ++"z:" ++ "(" ++ show z ++ ")"
 in let lfind_v := print x lfind_var
 in lfind_state lfind_v  y z.
QuickChick collect_data.
Success.


Require Export LUB_spec_LS.

Module seq_LS.

Module Export UU := lub_spec_LS.

Import LSw.

Section section_sequences.

Variable S : subset.
Variable Hdec :
 forall alpha beta a b:HRw, upper_bound S beta /\ S alpha /\ (beta [>=] b /\ b [>=] a /\ a [>=] alpha) ->
   {s:HRw| S s /\ s [>] a}+{upper_bound S b}.

Variables s0 b0 : HRw.
Variable Hs0 : S s0.
Variable Hb0S : upper_bound S b0. (* a strict upper bound *)

(* implicit assumption : b^0 >w s^0 *)

Definition epsilon (n:A) (H:std (n+1) /\ 0 <=A (n+1)) := (power two_third (n+1) H) [*] (b0 [+] (-w s0)).

Definition fs := fun (alpha beta a b : HRw) (Ha:S a) (Hb : upper_bound S b) (Hab : (b [>=] beta /\ beta [>=] alpha /\ alpha [>=] a)) =>
 (* a actually is sn_1 *)
     match (Hdec a b alpha beta (conj Hb (conj Ha Hab))) with
      | inleft Hs => proj1_sig Hs
      | inright _ => a
      end.

Definition fb := fun (alpha beta a b : HRw) (Ha:S a) (Hb : upper_bound S b)
                     (Hab : (b [>=] beta /\ beta [>=] alpha /\ alpha [>=] a)) (n:A) (H:std (n+1) /\ (0<=A (n+1))) =>
      match (Hdec a b alpha beta (conj Hb (conj Ha Hab))) with
 (* b actually is bn_1 *)
      | inleft Hs => (b [+] proj1_sig Hs) [+] (-w alpha) [+] (epsilon n H)
      | inright _ => beta [+] (epsilon n H)
      end.

Lemma HRw_n : forall (n : A), std n /\ 0 <=A n -> P (n * w).
Proof.
intros n (Hle, Hlim).
unfold P.
exists (n+1).
split.
apply ANS2a.
apply std_lim.
solve[assumption].
apply ANS1.
split.
setoid_replace 0 with (0+0) by ring.
apply le_lt_plus.
solve[assumption].
apply lt_0_1.
rewrite abs_pos_val.
setoid_replace (n * w) with (n * w + 0) by ring.
rewrite mult_distr_l.
apply le_plus.
apply le_refl.
ring_simplify; apply lt_le; apply Aw.
setoid_replace 0 with (n*0) by ring.
apply le_mult.
assumption.
apply lt_le; apply Aw.
Qed.

Definition mk_HRw : forall n:A, std n/\0<=A n -> HRw.
intros n Hn.
exists (n * w).
apply HRw_n; assumption.
Defined.

Lemma mk_HRw_HRw0 : forall H:std 0/\0<=A 0, mk_HRw 0 H [=] [0].
Proof.
intros.
unfold mk_HRw.
simpl.
intros.
rewrite abs_pos_val.
ring_simplify.
apply lt_le; apply Aw.
setoid_replace (0 + -0) with 0 by ring.
apply le_refl.
Qed.

Definition Psb n HlimH0 sn bn :=
S sn /\ upper_bound S bn /\ (bn [+] (-w sn)) [=] ((mk_HRw n HlimH0)[+] [1])[*](power two_third n HlimH0 [*] (b0 [+] (-w s0))).

Lemma lemma0 : forall Hx, Psb 0 Hx s0 b0.
Proof.
intros; unfold Psb.
split.
assumption.
split.
assumption.
rewrite mk_HRw_HRw0.
unfold power; rewrite nat_like_induction_r1.
setoid_replace (([0] [+] [1]) [*] ([1] [*] (b0 [+] (-w s0)))) with (b0 [+] (-w s0)) by ring.
reflexivity.
Qed.

Lemma mk_HRw_step :
  forall (n:A) (H:std n /\ 0 <=A n) (Hx:std (n+1) /\ 0 <=A (n+1)), mk_HRw n H [+] [1] [=] mk_HRw (n+1) Hx.
Proof.
intros.
unfold mk_HRw; simpl; intros.
setoid_replace (n * w + w + - ((n + 1) * w)) with 0 by ring.
rewrite abs_pos_val.
ring_simplify; apply lt_le; apply Aw.
apply le_refl.
Qed.

Lemma lemma_step : forall
(n : A)
(H : std n /\ 0<=A n)
(X : forall Hx : std n /\ 0 <=A n, {sn : HRw & {bn : HRw & Psb n Hx sn bn}})
(Hx : std (n + 1) /\ 0 <=A (n + 1))
(sn_1 : HRw)
(bn_1 : HRw)
(HHsn : S sn_1)
(HHbn : upper_bound S bn_1)
(HHequal : bn_1 [+] (-w sn_1) [=]
          (mk_HRw n H [+] [1]) [*] (power two_third n H [*] (b0 [+] (-w s0))))
(alphan_1 := (two_third [*] sn_1) [+] (one_third [*] bn_1) : HRw)
(betan_1 := (one_third [*] sn_1) [+] (two_third [*] bn_1) : HRw)
(Hyp : bn_1 [>=] betan_1 /\ betan_1 [>=] alphan_1 /\ alphan_1 [>=] sn_1)
(sn := fs alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp : HRw)
(bn := fb alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp n Hx : HRw),
Psb (n + 1) Hx sn bn.
Proof.
intros; unfold sn, bn, fs, fb; simpl.
assert (Heps:(epsilon n Hx) [>] [0]).
unfold epsilon; apply R2_5.
split.
apply power_HRwgt.
apply two_third_prop.
apply HRwgt_HRwplus_inv_r with s0; ring_simplify.
apply Hb0S; apply Hs0.

destruct (Hdec sn_1 bn_1 alphan_1 betan_1 (conj HHbn (conj HHsn Hyp))).
(* case 1 *)
split.
destruct s;simpl; solve[intuition].
split.
unfold upper_bound; intros.
eapply HRwgt_trans with (bn_1 [+]  epsilon n Hx).

repeat rewrite <- HRwplus_assoc.
apply R2_4.
repeat rewrite HRwplus_assoc.
rewrite HRwplus_comm.
setoid_replace bn_1 with ([0][+] bn_1) at 2 by ring.
apply R2_4.
eapply HRwgt_HRwplus_inv_r with (alphan_1).
ring_simplify.
destruct s; simpl; solve[intuition].
apply HRwgt_trans with bn_1.
setoid_replace bn_1 with (bn_1 [+] [0]) at 2 by ring.
rewrite HRwplus_comm.
rewrite (HRwplus_comm bn_1).
apply R2_4.
assumption.
apply HHbn; assumption.
setoid_replace ((((bn_1 [+] proj1_sig s) [+] (-w alphan_1)) [+] epsilon n Hx) [+] (-w proj1_sig s)) with
(((bn_1 [+] (-w alphan_1)) [+] epsilon n Hx)) by ring.
unfold alphan_1, epsilon.
rewrite (two_thirds_one_third bn_1) at 1.
setoid_replace (((two_third [*] bn_1) [+] (one_third [*] bn_1)) [+]
 (-w ((two_third [*] sn_1) [+] (one_third [*] bn_1)))) with (two_third [*] (bn_1 [+] -w sn_1)) by ring.
setoid_rewrite HHequal.
setoid_replace (two_third [*] ((mk_HRw n H [+] [1]) [*] (power two_third n H [*] (b0 [+] (-w s0)))))
with ((mk_HRw n H [+] [1])[*] two_third [*] (power two_third n H [*] (b0 [+] (-w s0)))) by ring.
rewrite HRwmult_assoc.
rewrite (HRwmult_comm two_third).
setoid_replace ((power two_third n H [*] (b0 [+] (-w s0))) [*] two_third)
  with ((power two_third (n+1) Hx) [*] (b0 [+] -w s0))
  by (unfold power; setoid_rewrite nat_like_induction_r2 with (H:=H); simpl; ring).
setoid_replace (power two_third (n + 1) Hx [*] (b0 [+] (-w s0)))
  with ([1] [*] (power two_third (n + 1) Hx [*] (b0 [+] (-w s0)))) at 2 by ring.
rewrite (HRwmult_comm (mk_HRw n H [+] [1])).
rewrite (HRwmult_comm [1]).
rewrite <- HRw_distr.
rewrite (HRwmult_comm _ ((mk_HRw n H [+] [1]) [+] [1])).
rewrite mk_HRw_step with (Hx:=Hx).
reflexivity.

(* case 2 *)
split.
assumption.
split.
unfold upper_bound.
intros.
apply HRwgt_trans with betan_1.
setoid_replace betan_1 with (betan_1 [+] [0]) at 2 by ring.
rewrite (HRwplus_comm betan_1).
rewrite (HRwplus_comm betan_1).
apply R2_4.
apply Heps.
apply u; assumption.
unfold betan_1, alphan_1.
rewrite (two_thirds_one_third sn_1) at 2.
setoid_replace ((((one_third [*] sn_1) [+] (two_third [*] bn_1)) [+] epsilon n Hx) [+]
(-w ((two_third [*] sn_1) [+] (one_third [*] sn_1))))
  with ((two_third [*] (bn_1 [+] -w sn_1)) [+] epsilon n Hx)
  by ring.
rewrite HHequal.
unfold epsilon.
rewrite (HRwmult_comm two_third).
repeat rewrite HRwmult_assoc.
rewrite (HRwmult_comm (b0 [+] -w s0)).
rewrite <- (HRwmult_assoc (power two_third n H)).
setoid_replace (power two_third n H [*] two_third) with (power two_third (n+1) Hx)
  by (unfold power; setoid_rewrite nat_like_induction_r2 with (H:=H); reflexivity).
rewrite mk_HRw_step with (Hx:=Hx).
ring.
Qed.

Lemma mk_Hyp : forall
(sn_1 : HRw)
(bn_1 : HRw)
(HHsn : S sn_1)
(HHbn : upper_bound S bn_1)
(alphan_1 := (two_third [*] sn_1) [+] (one_third [*] bn_1) : HRw)
(betan_1 := (one_third [*] sn_1) [+] (two_third [*] bn_1) : HRw),
 bn_1 [>=] betan_1 /\ betan_1 [>=] alphan_1 /\ alphan_1 [>=] sn_1.
Proof.
intros.
unfold betan_1, alphan_1.
split.
apply HRwgt_HRwge.
rewrite (two_thirds_one_third bn_1) at 1.
rewrite HRwplus_comm.
apply R2_4.
apply HRwgt_HRwplus_inv_r with (one_third [*] (-w sn_1)).
rewrite <- HRw_distr.
setoid_replace  ((one_third [*] sn_1) [+] (one_third [*] (-w sn_1))) with [0] by ring.
apply R2_5.
split.
apply HRwgt_one_third.
apply HRwgt_HRwplus_inv_l with sn_1.
ring_simplify.
apply HHbn; apply HHsn.

split.
apply HRwgt_HRwge; apply step_thirds; apply HHbn; apply HHsn.

rewrite (two_thirds_one_third sn_1) at 2.
rewrite (HRwplus_comm (two_third [*] sn_1)).
rewrite (HRwplus_comm (two_third [*] sn_1)).
apply HRwgt_HRwge.
apply R2_4.
apply HRwgt_HRwplus_inv_r with (one_third [*] (-w sn_1)).
rewrite <- HRw_distr.
setoid_replace  ((one_third [*] sn_1) [+] (one_third [*] (-w sn_1))) with [0] by ring.
apply R2_5.
split.
apply HRwgt_one_third.
apply HRwgt_HRwplus_inv_l with sn_1.
ring_simplify.
apply HHbn; apply HHsn.
Qed.

Definition def_s_b :
    forall k:A, forall Hk:(std k /\ 0 <=A k),
{sn:HRw & {bn:HRw & Psb k Hk sn bn}}.
Proof.
intros k HlimkH0k.
apply (nat_like_induction
 (fun (x:A) => (forall Hx:std x /\ 0<=A x, {sn:HRw & {bn:HRw & Psb x Hx sn bn}}))).
clear HlimkH0k k.
intros.
exists s0.
exists b0.
apply lemma0.
intros n H X Hx.
generalize (X H); intros (sn_1, (bn_1, (HHsn, (HHbn, HHequal)))).
pose (alphan_1:=((two_third [*] sn_1)) [+] (one_third [*] bn_1)).
pose (betan_1:=((one_third [*] sn_1) [+] (two_third [*] bn_1))).
assert (Hyp:bn_1 [>=] betan_1 /\ betan_1 [>=] alphan_1 /\ alphan_1 [>=] sn_1) by (apply mk_Hyp; assumption).
(*
pose (sn:=fs alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp).
pose (bn:=fb alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp n Hx).
*)
exists (fs alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp).
exists (fb alphan_1 betan_1 sn_1 bn_1 HHsn HHbn Hyp n Hx).
(*clear Hs0 Hb0S HlimkH0k k;*) abstract (apply lemma_step with (n:=n) (H:=H); assumption).
apply HlimkH0k.
Defined.

Lemma auxiliary_lemma : forall P, forall x:HRw , forall Hx, projT1 (existT P x Hx) = x.
Proof.
intros; simpl;reflexivity.
Qed.

Lemma s_increases_step :
forall ssA, forall HssA : ssA = (fun k0 Hk0 => proj1_sig (projT1 (def_s_b k0 Hk0))),
forall bbA, forall HbbA : bbA = (fun k0 Hk0 => proj1_sig (projT1 (projT2 (def_s_b k0 Hk0)))),
forall n, forall Hn:std n/\0<=A n,  forall (Hn1:std (n+1)/\0<=A (n+1)), forall m,
   (ssA n Hn m  <= ssA (plusA n a1) Hn1 m)%Z.
Proof.
intros ssA HssA bbA HbbA n Hn.
rewrite HssA.
unfold def_s_b at 2.
intros.
rewrite nat_like_induction_r2 with (H:=Hn).
unfold def_s_b.

pose (NLI:= (nat_like_induction
         (fun x : A => forall Hx : std x /\ 0 <=A x, {sn : HRw & {bn : HRw & Psb x Hx sn bn}})
         (fun Hx : std 0 /\ 0 <=A 0 =>
          existT (fun sn : HRw => {bn : HRw & Psb 0 Hx sn bn}) s0
            (existT (fun bn : HRw => Psb 0 Hx s0 bn) b0 (lemma0 Hx)))
         (fun (n0 : A) (H : std n0 /\ 0 <=A n0)
            (X : forall Hx : std n0 /\ 0 <=A n0, {sn : HRw & {bn : HRw & Psb n0 Hx sn bn}})
            (Hx : std (plusA n0 1) /\ 0 <=A plusA n0 1) =>
          let (sn_1, s) := X H in
          let (bn_1, p) := s in
          match p with
          | conj HHsn (conj HHbn HHequal) =>
              existT (fun sn : HRw => {bn : HRw & Psb (plusA n0 1) Hx sn bn})
                (fs ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                   ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                   (mk_Hyp sn_1 bn_1 HHsn HHbn))
                (existT
                   (fun bn : HRw =>
                    Psb (plusA n0 1) Hx
                      (fs ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                         ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                         (mk_Hyp sn_1 bn_1 HHsn HHbn)) bn)
                   (fb ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                      ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                      (mk_Hyp sn_1 bn_1 HHsn HHbn) n0 Hx)
                   (def_s_b_subproof n0 H X Hx sn_1 bn_1 HHsn HHbn HHequal
                      (mk_Hyp sn_1 bn_1 HHsn HHbn)))
          end) n Hn Hn)).

change (((proj1_sig
   (projT1 NLI)) m <= proj1_sig
   (projT1
      (let (sn_1, s) :=
           NLI in
      let (bn_1, p) := s in
       match p with
       | conj HHsn (conj HHbn HHequal) =>
           existT (fun sn : HRw => {bn : HRw & Psb (plusA n a1) Hn1 sn bn})
             (fs ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                (mk_Hyp sn_1 bn_1 HHsn HHbn))
             (existT
                (fun bn : HRw =>
                 Psb (plusA n a1) Hn1
                   (fs ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                      ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                      (mk_Hyp sn_1 bn_1 HHsn HHbn)) bn)
                (fb ((two_third [*] sn_1) [+] (one_third [*] bn_1))
                   ((one_third [*] sn_1) [+] (two_third [*] bn_1)) sn_1 bn_1 HHsn HHbn
                   (mk_Hyp sn_1 bn_1 HHsn HHbn) n Hn1)
                (def_s_b_subproof n Hn
                   (nat_like_induction
                      (fun x : A =>
                       forall Hx : std x /\ a0 <=A x, {sn : HRw & {bn : HRw & Psb x Hx sn bn}})
                      (fun Hx : std a0 /\ a0 <=A a0 =>
                       existT
                         (fun sn : HRw => {bn : HRw & Psb a0 Hx sn bn}) s0
                         (existT (fun bn : HRw => Psb a0 Hx s0 bn) b0 (lemma0 Hx)))
                      (fun (n0 : A)
                         (H : std n0 /\ a0 <=A n0)
                         (X :
                          forall Hx : std n0 /\ a0 <=A n0,
                          {sn : HRw & {bn : HRw & Psb n0 Hx sn bn}})
                         (Hx : std (plusA n0 a1) /\ a0 <=A plusA n0 a1) =>
                       let (sn_0, s1) := X H in
                       let (bn_0, p0) := s1 in
                       match p0 with
                       | conj HHsn0 (conj HHbn0 HHequal0) =>
                           existT
                           (fun sn : HRw => {bn : HRw & Psb (plusA n0 a1) Hx sn bn})
                           (fs
                           ((two_third [*] sn_0) [+] (one_third [*] bn_0))
                           ((one_third [*] sn_0) [+] (two_third [*] bn_0)) sn_0 bn_0 HHsn0 HHbn0
                           (mk_Hyp sn_0 bn_0 HHsn0 HHbn0))
                           (existT
                           (fun bn : HRw =>
                           Psb
                           (plusA n0 a1) Hx
                           (fs
                           ((two_third [*] sn_0) [+] (one_third [*] bn_0))
                           ((one_third [*] sn_0) [+] (two_third [*] bn_0)) sn_0 bn_0 HHsn0 HHbn0
                           (mk_Hyp sn_0 bn_0 HHsn0 HHbn0)) bn)
                           (fb
                           ((two_third [*] sn_0) [+] (one_third [*] bn_0))
                           ((one_third [*] sn_0) [+] (two_third [*] bn_0)) sn_0 bn_0 HHsn0 HHbn0
                           (mk_Hyp sn_0 bn_0 HHsn0 HHbn0) n0 Hx)
                           (def_s_b_subproof n0 H X Hx sn_0 bn_0 HHsn0 HHbn0 HHequal0
                            (mk_Hyp sn_0 bn_0 HHsn0 HHbn0)))
                       end) n Hn) Hn1 sn_1 bn_1 HHsn HHbn HHequal
                   (mk_Hyp sn_1 bn_1 HHsn HHbn)))
       end)) m)%Z).

destruct NLI.
destruct s.
destruct p as[Hp1 [Hp2 Hp3]].
simpl (projT1 (existT (fun sn : HRw => {bn : HRw & Psb n Hn sn bn}) x (existT (fun bn : HRw => Psb n Hn x bn) x0 (conj Hp1 (conj Hp2 Hp3))))).
rewrite auxiliary_lemma.

unfold fs.
destruct (Hdec x x0 ((two_third [*] x) [+] (one_third [*] x0))
       ((one_third [*] x) [+] (two_third [*] x0))
       (conj Hp2 (conj Hp1 (mk_Hyp x x0 Hp1 Hp2)))).
destruct s as [s Hs].
simpl.
assert (Hsw : (s [>] x)).
assert (t:=two_thirds_one_third x).
setoid_rewrite t.
apply HRwgt_trans with ((two_third [*] x) [+] (one_third [*] x0)).
solve [intuition].
apply HRwgt_HRwplus_l.
apply HRw1_3.
apply Hp2; apply Hp1.
destruct s as [ss Hss].
destruct x as [xx Hxx].
unfold HRwgt in Hsw.
destruct Hsw as [v [Hv1 [Hv2 Hv3]]].
simpl.
assert (xx <=A ss).
apply le_plus_inv with (-xx).
apply le_mult_inv with v.
assumption.
apply le_trans with w.
ring_simplify.
apply lt_le; apply Aw.
assumption.
admit. (** to investigate, strange, is probably related to the construction of s... *)
apply Z.le_refl.
Admitted.

Lemma s_increases :
forall ssA, forall HssA : ssA = (fun k0 Hk0 => proj1_sig (projT1 (def_s_b k0 Hk0))),
forall bbA, forall HbbA : bbA = (fun k0 Hk0 => proj1_sig (projT1 (projT2 (def_s_b k0 Hk0)))),
forall n, forall Hn:std n/\0<=A n, forall p, forall (Hp:std p/\0<=A p), forall m,
  n <=A p -> (ssA n Hn m  <= ssA p Hp m)%Z.
Proof.
intros ssA HssA bbA HbbA n Hn m Hm.
apply (nat_like_induction
  (fun x:A => forall Hx:std x/\ 0<=A x,forall p,
  n <=A x -> (ssA n Hn p <= ssA x Hx p)%Z)).
intros.
assert (n=A 0) by (apply le_id; solve [intuition]).
Admitted. (* ok when shifting from lim to std : to check quickly, still requires dependent rewriting *)

End section_sequences.

End seq_LS.


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 conj21synthconj2 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus (plus (mult lv1 lv0) lv1) lv3)).
Admitted.
QuickChick conj21synthconj2.


(**
Rainbow, a termination proof certification tool

See the COPYRIGHTS and LICENSE files.

- Kim Quyen LY, 2013-04-18

* Matrix interpretation over domain arctic natural numbers

*)

Set Implicit Arguments.

Require Import ATrs ARedPair2 APolyInt_MA2 AMonAlg2 LogicUtil BoolUtil
  AMatrixBasedInt2_ArcticNat VecUtil VecArith2 Matrix2 cpf2color cpf
  OrdSemiRing2 VecOrd cpf_util List AArcticInt2 AArcticBasedInt2
  Equality .

(***********************************************************************)
(** ** Matrix interpretation over domain arctic natural numbers, the main
different with matrix interpretation over natural numbers is that we
want to use the arctic semiring for the underlying algebra operations. *)

Section S.

  Variable arity: symbol -> nat.
  Variable dim : nat.

  Notation Sig := (Sig arity).
  Notation dim_pos := (dim_pos dim).
  Notation mint := (matrixInt_arcnat matrix_arcnat dim).

  (** Cast *)

  Definition matrix_cast_arcnat n m (Heq: n = m)(p: mint n) : mint m.
  rewrite <- Heq; auto.
  Defined.

  (** Default of matrix interpretation over arctic natural numbers. *)

  (* In Arctic natural numbers semi-ring define: A0 = minusInf, A1 = Pos 0,
     for example the (2 x 2) identity matrix is:
     |Pos 0    minusInf|
     |minusInf    Pos 0| *)

  Definition default_matrix_arcnat (n: nat) :=
    mkMatrixInt_arcnat (id_vec_arcnat dim_pos)
    (Vconst (id_matrix_arcnat dim) n).

  (** [fun_of_pairs_matrix_arcnat_list] is a representation for an
     interpretation associating to every function symbol of arity [n],
     an natural matrix with [n] variables. It is represented by a list
     of pairs [(g, mi)], where [g] is a function symbol and [mi] is its
     interpretation. *)

  Section fun_of_pairs_matrix_arcnat_list.

    Variable f : symbol.

    Fixpoint fun_of_matrix_arcnat_list (l : list {g: symbol & mint (arity g)})
      : mint (arity f) :=
      match l with
        | existT g m :: l' =>
          match @eq_symb_dec Sig g f with
            | left h => matrix_cast_arcnat (f_equal arity h) m
            | right _ => fun_of_matrix_arcnat_list l'
          end
        | nil => default_matrix_arcnat (arity f)
      end.

  End fun_of_pairs_matrix_arcnat_list.

  (***********************************************************************)
  (** ** Matrix interpretation in the setting of monotone algebras. *)

  Section MatrixMethodConf_Arcnat.

    Variable l : list {g : symbol & mint (arity g)}.

    Definition trsInt_arcnat (f : Sig) := fun_of_matrix_arcnat_list f l.

    Definition TMatrixInt_arcnat :=
      mkMatrixMethodConf_arcnat Sig trsInt_arcnat.

    Definition MatrixArcnat_MonoAlgType := matAlg_arcnat TMatrixInt_arcnat.

    (** Weak reduction pair for matrix intepretration. *)

    Definition MatrixArcnat_WeakRedPair := bwrp MatrixArcnat_MonoAlgType.

    (** Reduction pair associcated to a monotone algebra. *)

    Definition matrix_arcnat_wrp := mkbWeakRedPair (wf_succ
      MatrixArcnat_WeakRedPair) (sc_succ
      MatrixArcnat_WeakRedPair)(bsucc_sub MatrixArcnat_WeakRedPair)
      (sc_succeq MatrixArcnat_WeakRedPair) (cc_succeq
      MatrixArcnat_WeakRedPair) (ARedPair2.refl_succeq
      MatrixArcnat_WeakRedPair) (ARedPair2.succ_succeq_compat
      MatrixArcnat_WeakRedPair) (bsucceq_sub MatrixArcnat_WeakRedPair)
      (ARedPair2.trans_succ MatrixArcnat_WeakRedPair)
      (ARedPair2.trans_succeq MatrixArcnat_WeakRedPair).

  End MatrixMethodConf_Arcnat.

  (****************************************************************************)
  (** ** Boolean function for matrix interpretation over domain arctic
   natural numbers *)

  Section BoolMint_Arcnat.

    Definition bgt_arc (m n: ArcticDom) :=
      match gt_decr m n with
        | left _ => true (* {m > n} *)
        | right _ => false (* {~ m > n} *)
      end.

    (** Correctness proof of [bgt] in arctic naturals domain. *)

    Lemma bgt_arc_ok : forall m n, bgt_arc m n = true <-> gtr m n.

    Proof.
      intros. unfold bgt_arc.
      case_eq (gt_decr m n); intuition.
    Qed.

    (** Define boolean function of [ge] over domain arctic natural numbers. *)

    Definition bge_arc (m n: ArcticDom) := bgt_arc m n || beq_ArcticDom m n.

    (** Correctness proof of [bge] over domain arctic natural numbers. *)

    Lemma bge_arc_ok : forall m n, bge_arc m n = true <-> ger m n.

    Proof.
      intros n m. intuition. unfold ger.
      unfold bge_arc in H. rewrite orb_eq in H.
      destruct H; try discr.
      apply bgt_arc_ok in H. left. apply H.
      apply beq_ArcticDom_ok in H. right. apply H.
      (* -> *)
      unfold ger in H. destruct H.
      unfold bge_arc. rewrite orb_eq.
      left. rewrite bgt_arc_ok. apply H.
      unfold bge_arc. rewrite orb_eq.
      right. rewrite beq_ArcticDom_ok. apply H.
    Qed.

    (** Define a boolean function of [mat_ge]. *)

    Definition bmat_ge_arcnat (m n : nat) (M N : matrix_arcnat m n) :=
      match mat_ge_dec_arcnat M N with
        | left _ => true  (* M >=m N *)
        | right _ => false (* ~ M >=m N *)
      end.

    (** Correctness prove of [bmat_ge].  *)

    Lemma bmat_ge_arcnat_ok: forall (m n : nat) (M N : matrix_arcnat m n),
                               bmat_ge_arcnat M N = true <-> mat_ge_arcnat M N.

    Proof.
      intros m n M N. unfold bmat_ge_arcnat.
      case_eq (mat_ge_dec_arcnat M N); intuition.
    Qed.

    (** Define boolean function for [mint_ge] over domain arctic natural numbers. *)
    (* Let matrices [M, N \in A^dxd], and vectors [x, y \in A^d].
       If [M >= N and x >= y] then [Mx >= My] *)

    Definition bmint_arc_ge n (l r : mint n) : bool :=
      bVforall2n (bmat_ge_arcnat (n := dim)) (args_arcnat l) (args_arcnat r) &&
      bVforall2n (fun m n => bge_arc m n) (const_arcnat l) (const_arcnat r).

    (** Correctness proof of [bmint_ge] in arctic naturals domain. *)

    Lemma bmint_arc_ge_ok : forall n (l r: mint n),
      bmint_arc_ge l r = true <-> mint_ge_arcnat l r.

    Proof.
      intros n l r. intuition.
      (*[1]. Proving the <- *)
      unfold mint_ge_arcnat. unfold bmint_arc_ge in H.
      rewrite andb_eq in H. destruct H.
      split. rewrite bVforall2n_ok in H. apply H.
      (* Proving boolean function of [bmat_ge_arcnat]. *)
      intros M N. split.
      (* -> *)
      intro H1. rewrite bmat_ge_arcnat_ok in H1. hyp.
      (* <- *)
      intro H1. rewrite bmat_ge_arcnat_ok. hyp.
      (* Proving the second part of && [const_arcnat]. *)
      rewrite bVforall2n_ok in H0. apply H0.
      (* Proving boolean function of [bge_arc]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bge_arc_ok. hyp.
      (* <- *)
      intro H1. rewrite bge_arc_ok. hyp.
      (* [2]. Proving the other ways -> *)
      unfold bmint_arc_ge. rewrite andb_eq. split.
      (* Proving the first part of && [bmat_ge_arcnat]. *)
      rewrite bVforall2n_ok. unfold mint_ge_arcnat in H.
      destruct H. apply H.
      (* Proving the boolean function of [bmat_ge_arcnat]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_ge_arcnat_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_ge_arcnat_ok. hyp.
      (* Proving the second part of && [const_arcnat]. *)
      rewrite bVforall2n_ok. unfold mint_ge_arcnat in H.
      destruct H. apply H0.
      (* Proving the boolean function of [bge_arc]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bge_arc_ok. hyp.
      (* <- *)
      intro H1. rewrite bge_arc_ok. hyp.
    Qed.

    (** Define boolean function of [gtx] over domain arctic natural
       numbers. Arctic addition is not strictly monotone in single
       arguments. It is, however, "haft strict" in the following
       sense: a strict increase in both arguments simultaneously gives
       a strict increase in the result. There is one exception: arctic
       addition is obviously strict if one argument is arctic zero,
       i.e., [-oo]. This is the motivation for introducing the
       following relation [gtx].

       NOTE: arctic addition is strict if one argument is [arctic zero:
       -oo (A0/MinusInf)]; relation [gtx: a >> b <-> (a > b) \/ (a = b =
       -oo]. *)

    Definition bgtx (x y: ArcticDom) : bool :=
      bgt_arc x y || beq_ArcticDom x MinusInf && beq_ArcticDom y MinusInf.

    (* Correctness proof of [bgtx]. *)

    Lemma bgtx_ok : forall x y, bgtx x y = true <-> gtx x y.
    Proof.
      intros x y. split.
      (* -> *)
      intro H. unfold bgtx in H.
      rewrite orb_eq in H. rewrite andb_eq in H.
      destruct H.
      (* Proving the correctness of [bgt]. Left part *)
      rewrite bgt_arc_ok in H. unfold gtx.
      left. hyp.
      (* Right part. *)
      destruct H.
      unfold gtx. right.
      rewrite beq_ArcticDom_ok in H. rewrite beq_ArcticDom_ok in H0. auto.
      (* <- *)
      intro H. unfold gtx in H. destruct H.
      unfold bgtx.
      rewrite orb_eq. rewrite andb_eq. left.
      (* Left part. *)
      rewrite bgt_arc_ok. hyp.
      (* Right part. *)
      unfold eqAr in H. unfold A0r in H. destruct H.
      unfold bgtx. rewrite orb_eq. rewrite andb_eq.
      right. split.
      rewrite beq_ArcticDom_ok. hyp.
      rewrite beq_ArcticDom_ok. hyp.
    Qed.

    (** Define boolean function of [mat_gt]. *)

    Definition bmat_gt_arcnat (M N: matrix_arcnat dim dim) :=
      match mat_gt_dec M N with
          | left _ => true (* M >=m N *)
          | right _ => false (* ~ M >=m N *)
      end.

    (** Correctness proof of [bmat_gt]. *)

    Lemma bmat_gt_arcnat_ok : forall (M N : matrix_arcnat dim dim),
                                bmat_gt_arcnat M N = true <-> mat_gt M N.
    Proof.
      intros M N. unfold bmat_gt_arcnat.
      case_eq (mat_gt_dec M N); intuition.
    Qed.

    (** Define boolean function for [mint_gt] over domain arctic natural numbers. *)
    (* Let matrices [M, N \in A^dxd], and vectors [x, y \in A^d].
       If [M >> N and x >> y] then [Mx >> My] *)

    Definition bmint_arc_gt n (l r : mint n) : bool :=
      bVforall2n bmat_gt_arcnat (args_arcnat l) (args_arcnat r) &&
      bVforall2n (fun m n => bgtx m n) (const_arcnat l) (const_arcnat r).

    (** Correctness proof of [bmint_gt] in arctic naturals domain. *)

    Lemma bmint_arc_gt_ok : forall n (l r : mint n),
      bmint_arc_gt l r = true <-> Vforall2n (mat_gt (dim:=dim))
      (args_arcnat l) (args_arcnat r)
      /\ vec_gt (const_arcnat l) (const_arcnat r).

    Proof.
      intros n l r. intuition.
      (* [1] <- *)
      unfold bmint_arc_gt in H. rewrite andb_eq in H. destruct H.
      rewrite <- bVforall2n_ok. apply H.
      (* Proving boolean function of [bmat_gt]. *)
      intros M N. split.
      (* -> *)
      intro H1. apply bmat_gt_arcnat_ok. hyp.
      (* <- *)
      intro H1. rewrite bmat_gt_arcnat_ok. hyp.
      (* Proving [const_arcnat]. *)
      unfold bmint_arc_gt in H.
      rewrite andb_eq in H. destruct H.
      rewrite bVforall2n_ok in H0. apply H0.
      (* Proving the boolean function of [bgtx]. *)
      intros x y. split.
      (* -> *)
      intro H1. apply bgtx_ok. hyp.
      (* <- *)
      intro H1. rewrite bgtx_ok. hyp.
      (* [2]. -> *)
      unfold bmint_arc_gt. rewrite andb_eq.
      split.
      (* Left part. *)
      rewrite bVforall2n_ok. apply H0.
      (* Proving boolean function of [bmat_gt]. *)
      intros M N. split.
      (* -> *)
      intro H. apply bmat_gt_arcnat_ok. hyp.
      (* <- *)
      intro H. rewrite bmat_gt_arcnat_ok. hyp.
      (* Right part. *)
      rewrite bVforall2n_ok. apply H1.
      (* Proving boolean function of [bgtx]. *)
      intros x y. split.
      (* -> *)
      intro H. unfold bgtx in H. rewrite orb_eq in H. rewrite andb_eq in H.
      destruct H.
      unfold gtx.
      (* Left part. *)
      left. apply bgt_arc_ok. hyp.
      (* Right part. *)
      unfold gtx. right.
      unfold eqAr, A0r.
      destruct H. rewrite beq_ArcticDom_ok in H.
      rewrite beq_ArcticDom_ok in H2. auto.
      (* <- *)
      intro H. rewrite bgtx_ok. hyp.
    Qed.

  End BoolMint_Arcnat.

End S.


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 conj25synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 lv1) lv2)) (plus (mult lv0 (plus (Succ Zero) lv1)) (plus (Succ Zero) lv1))).
Admitted.
QuickChick conj25synthconj4.


From Undecidability Require Import TM.Util.TM_facts TM.Util.Relations.
From Undecidability.L Require Import Util.Subterm Util.L_facts.
From Undecidability.L Require Import LM_heap_def.
From Undecidability.L Require Import FlatPro.SizeAnalysisStep.

Set Default Proof Using "Type".
Require Import FunInd.

Import L_Notations.

Inductive taskOf : L.term -> Pro -> Prop :=
| taskVar x: taskOf (L.var x) (compile (L.var x))
| taskLam s: taskOf (L.lam s) (compile (L.lam s))
| taskL (s t:L.term) P : taskOf s P -> taskOf (s t) (P++compile t++[appT])
| taskR (s t:term) P: taskOf t P -> taskOf (s t) (P++[appT])
| taskAppT (s t:term): taskOf (s t) ([appT]).

Lemma taskOf_refl s : taskOf s (compile s).
Proof. induction s;cbn. 1,3:constructor. now apply taskL. Qed.

Lemma taskOf_notNil s: ~ taskOf s [].
Proof. intros H. remember [] as P eqn:HP. induction H in H,HP|-*;cbn in *. 1,2,5:easy. 1,2:now destruct P. Qed.

Lemma taskOf_jumpTarget s P :
  taskOf s (lamT::P) ->
  exists s' P', (P =compile s' ++ retT ::P') /\ subterm (lam s') s /\ (P'=[] \/ taskOf s P').
Proof.
  intros H. remember (lamT::P) as P0 eqn:HP0. revert P HP0. induction H.
  - easy.
  - cbn. intros ? [= <-]. do 2 eexists. split. reflexivity. split. easy. easy.
  - intros P0 HP. destruct P. now edestruct taskOf_notNil. inv HP.
    edestruct IHtaskOf as (s'&P'&HP&Hs'&H''). reflexivity. subst P.
    do 2 eexists. split. rewrite <- app_assoc;cbn. reflexivity.
    split. now eauto using subterm.
    all:right. destruct H'' as [->|?];cbn. 2:now eauto using taskOf.
    econstructor. apply taskOf_refl.
  - intros P0 HP. destruct P. easy. inv HP.
    edestruct IHtaskOf as (s'&P'&HP&Hs'&H''). reflexivity. subst P.
    do 2 eexists. split. now (rewrite <- app_assoc;cbn).
    split. now eauto using subterm.
    all:right. destruct H'' as [->|?];cbn. 2:now eauto using taskOf. now econstructor.
  - easy.
Qed.

Lemma taskOf_appT s P :
  taskOf s (appT::P) ->
  P = [] \/ taskOf s P.
Proof.
  intros H. remember (appT::P) as P0 eqn:HP0. revert P HP0. induction H.
  - easy.
  - easy.
  - intros P0 HP. destruct P. now edestruct taskOf_notNil. inv HP.
    specialize IHtaskOf with (1:=eq_refl) as [->|];cbn. all:right;eauto using taskOf,taskOf_refl.
  - intros P0 HP. destruct P. inv HP.  easy. inv HP.
    edestruct IHtaskOf as [IH|IH]. reflexivity. subst P.  all:right;eauto using taskOf,taskOf_refl.
  - now left.
Qed.

Lemma taskOf_varT s P n :
  taskOf s (varT n::P) ->
  P = [] \/ taskOf s P.
Proof.
  intros H. remember (varT n::P) as P0 eqn:HP0. revert P HP0. induction H.
  - cbv. intros ? [= ->]. easy.
  - easy.
  - intros P0 HP. destruct P. now edestruct taskOf_notNil. inv HP.
    specialize IHtaskOf with (1:=eq_refl) as [->|];cbn. all:right;eauto using taskOf,taskOf_refl.
  - intros P0 HP. destruct P. inv HP. inv HP.
    edestruct IHtaskOf as [IH|IH]. reflexivity. subst P.  all:right;eauto using taskOf,taskOf_refl.
  - now left.
Qed.

Section Analysis.

  Variable T V : list HClos.
  Variable H: list HEntr.

  Variable i : nat.

  Variable s : L.term.
  Hypothesis R: pow step i (init s) (T,V,H).

  Import Lia.

  Lemma subterm_property :
  (forall g, g el T -> exists s', subterm s' s /\ taskOf s' (snd g))
   /\ (forall g, g el V -> exists s', subterm (lam s') s /\ snd g = compile s')
   /\ (forall g beta, Some (g,beta) el H -> exists s', subterm (lam s') s /\ snd g = compile s').
  Proof using R.
    induction i in T,V,H,R|-*.
    {
      inv R. split. 2:easy.
      intros ? [[= <-]|[]];cbn.
      eauto 10 using Nat.le_0_l, taskOf_refl, (@reflexivity _ subterm _ s).
    }
    - replace (S n) with (n + 1) in R by lia. apply pow_add in R. destruct R as [[[T' V'] H'] [R1 R2]].
      specialize (IHn _ _ _ R1).
      eapply rcomp_1 in R2.
      destruct IHn as (IHT&IHV&IHH).
      inv R2.
      + destruct (IHT (a,lamT::P)) as (s'&Hs'&HP). easy. cbn [fst snd] in *.
        eapply taskOf_jumpTarget in HP as (s''&tmp&->&Hsubterm&HP').
        rewrite jumpTarget_correct in H2. injection H2 as [= <- ->].

        destruct P',HP'. 3:easy. 2:now edestruct taskOf_notNil.
        all:split;[intros g|split;[intros g|intros g beta]].
        all:intros Hg;cbn in Hg;try decompose [or] Hg.
        all:eauto. all:subst;cbn [fst snd] in *.
        2:easy.
        all:eexists. all:split;[|reflexivity].
        { etransitivity. 2:eassumption. eauto using subterm, (@reflexivity _ subterm _ s). }
        { etransitivity. 2:eassumption. eauto using subterm, (@reflexivity _ subterm _ s). }
      + destruct (IHT (a,appT::P)) as (s'&Hsubterm&HP). easy. cbn [fst snd] in *.
        eapply taskOf_appT in HP as HP'.
        injection H2 as [= <- <-].

        all:split;[intros g'|split;[intros g'|intros g' beta]].
        1:destruct P,HP'. 3:easy. 2:now edestruct taskOf_notNil.
        all:intros Hg;cbn in Hg;try decompose [or] Hg.
        {
          edestruct IHV as (?&IHV'). now right;left. destruct IHV' as (?&[= ->]). subst g'.
          do 2 eexists. 2:apply taskOf_refl.
          etransitivity. 2:eassumption. eauto using subterm, (@reflexivity _ subterm _ s).
        }
        all:eauto.
        { subst g'.
          edestruct IHV as (?&IHV'). now right;left. destruct IHV' as (?&[= ->]).
          do 2 eexists. 2:apply taskOf_refl.
          etransitivity. 2:eassumption. eauto using subterm, (@reflexivity _ subterm _ s).
        }
        {subst g'. eauto. }
        eapply in_app_or in Hg as []. eauto. cbn in H.
        destruct H as [[= <- <-]|[]].
        edestruct (IHV g) as (?&?&?). easy.
        edestruct (IHV (b,Q)) as (?&?&?). easy.
        eauto.
      + eapply lookup_el in H2 as (?&Hg).
        destruct (IHH _ _ Hg) as (?&?&?).
        destruct (IHT (a,varT n0::P)) as (s'&Hsubterm&HP). easy. cbn [fst snd] in *.
        eapply taskOf_varT in HP.

        all:split;[intros g'|split;[intros g'|intros g' beta]].
        1:destruct P,HP. 3:easy. 2:now edestruct taskOf_notNil.
        all:intros Hg';cbn in Hg';try decompose [or] Hg'.
        all:eauto.
        { subst g';cbn. easy. }
        { subst g'. easy. }
  Qed.

End Analysis.


Require Import ssreflect ssrfun ssrbool eqtype seq.
Require Import FunctionalExtensionality.
Require Import Coq.Logic.ProofIrrelevance.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(** * Proof of the Yoneda Lemma *)

(** ** Functors *)

Module Functor.

Section RawMixin.

Record mixin_of (F : Type -> Type) := Mixin {
  mx_fmap : forall A B : Type, (A -> B) -> F A -> F B;
  _ : forall (A : Type) (x : F A), mx_fmap (fun a => a) x = x;
  _ : forall (A B C : Type) (f : A -> B) (g : B -> C) (x : F A),
          mx_fmap (g \o f) x = (mx_fmap g \o mx_fmap f) x
}.

End RawMixin.

Section ClassDef.
Local Notation tp := (Type -> Type).

Record class_of F := Class {mixin : mixin_of F}.

Structure type : Type := Pack {sort : tp; _ : class_of sort; _ : tp}.
Local Coercion sort : type >-> Funclass.

Variables (F : tp) (cT : type).
Definition class := let: Pack _ c _ as cT' := cT return class_of cT' in c.
Definition clone c of phant_id class c := @Pack F c F.

(* produce a functor type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of F) :=
  fun m & phant_id m0 m => Pack (@Class F m) F.

Definition fmap := mx_fmap (mixin class).

End ClassDef.

Module Exports.
Coercion sort : type >-> Funclass.
Notation functor := Functor.type.
Notation FunctorMixin := Functor.Mixin.
Notation Functor F m := (@pack F _ m id).

Notation "[ 'functor' 'of' F 'for' cT ]" := (@clone F cT _ id)
  (at level 0, format "[ 'functor'  'of'  F  'for'  cT ]") : form_scope.
Notation "[ 'functor' 'of' F ]" := (@clone F _ _ id)
  (at level 0, format "[ 'functor'  'of'  F ]") : form_scope.

Notation fmap := Functor.fmap.

Arguments Functor.fmap [cT A B] _ _.
Prenex Implicits Functor.fmap.

Section Laws.
Variable F : functor.

Lemma fmap_id (A : Type) (x : F A) : fmap id x = x.
Proof. by case: F x=>S [[]]. Qed.

Lemma fmap_assoc (A B C : Type) (f : A -> B) (g : B -> C) (x : F A) :
  fmap (g \o f) x = (fmap g \o fmap f) x.
Proof. by case: F x=>S [[]]. Qed.

End Laws.

Hint Resolve fmap_id.

End Exports.

End Functor.

Export Functor.Exports.

Section RightFunctor.
Variable A : Type.

Notation tp := (fun R => A -> R).

Program Definition rightFunctorMixin :=
  @Functor.Mixin tp (fun _ _ f g => f \o g) _ _.
Definition rightFunctor : functor :=
  Eval hnf in Functor tp rightFunctorMixin.

Lemma right_fmap (B C : Type) (f : B -> C) (g : rightFunctor B) :
  fmap f g = f \o g.
Proof. by rewrite /rightFunctor /= /rightFunctorMixin /Functor.fmap. Qed.

End RightFunctor.

Notation "A '==>' '?'" := (rightFunctor A)
  (at level 50, format "A  '==>'  '?'") : form_scope.

(** ** Natural Transformations \eta *)

Module Natural.

Section RawMixin.

Variables F G : functor.

Record mixin_of := Mixin {
  mx_eta : forall A : Type, F A -> G A;
  _ : forall (A B : Type) (f : A -> B) (x : F A),
          mx_eta (fmap f x) = fmap f (mx_eta x)
}.

End RawMixin.

Section ClassDef.

Variables F G : functor.

Record class_of F G := Class {mixin : mixin_of F G}.

Structure type : Type := Pack {_ : class_of F G}.

Variable cT : type.
Definition class := let: Pack c as cT' := cT return class_of F G in c.
Definition clone c of phant_id class c := @Pack c.

(* produce a natural type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of F G) :=
  fun m & phant_id m0 m => Pack (@Class F G m).

Definition eta := mx_eta (mixin class).

End ClassDef.

Module Exports.
Coercion eta : type >-> Funclass.
Notation natural := Natural.type.
Notation NaturalMixin := Natural.Mixin.
Notation Natural F G m := (@pack F G _ m id).

Notation "[ 'natural' 'of' F G 'for' cT ]" := (@clone F G cT _ id)
  (at level 0, format "[ 'natural'  'of'  F  G  'for'  cT ]") : form_scope.
Notation "[ 'natural' 'of' F G ]" := (@clone F G _ _ id)
  (at level 0, format "[ 'natural'  'of'  F  G ]") : form_scope.
Notation "F ~~> G" := (natural F G)
  (at level 60, format "F  '~~>'  G") : form_scope.

Notation eta := Natural.eta.

Arguments Natural.eta F G [cT] [A] _.

Section Laws.
Variables F G : functor.
Variable eta : natural F G.

Lemma eta_natural (A B : Type) (f : A -> B) (x : F A) :
  eta B (fmap f x) = fmap f (eta A x).
Proof. by case: eta=> [][][]. Qed.

End Laws.

Section Extensionality.
Variables F G : functor.
Variable eta1 eta2 : natural F G.

Lemma eta_extensionality :
  (forall R g, eta1 R g = eta2 R g) -> eta1 = eta2.
Proof.
move=> H; destruct eta1, eta2.
destruct c, c0; destruct mixin0, mixin1; f_equal; f_equal.
have Heq: mx_eta0 = mx_eta1.
{ extensionality R; extensionality g; by apply: (H R g). }
by subst; f_equal; apply proof_irrelevance.
Qed.

End Extensionality.

Hint Resolve eta_natural.

End Exports.

End Natural.

Export Natural.Exports.

(** ** Isomorphisms *)

Module Iso.

Section RawMixin.

Record mixin_of (T U : Type) := Mixin {
  mx_f : T -> U;
  mx_g : U -> T;
  _ : forall t, (mx_g \o mx_f) t = t;
  _ : forall u, (mx_f \o mx_g) u = u
}.

End RawMixin.

Section ClassDef.

Variables T U : Type.

Record class_of T U := Class {mixin : mixin_of T U}.

Structure type : Type := Pack {_ : class_of T U}.

Variable cT : type.
Definition class := let: Pack c as cT' := cT return class_of T U in c.
Definition clone c of phant_id class c := @Pack c.

(* produce a natural type out of the mixin *)
(* equalize m0 and m by means of a phantom *)
Definition pack (m0 : mixin_of T U) :=
  fun m & phant_id m0 m => Pack (@Class T U m).

Definition iso_f := mx_f (mixin class).
Definition iso_g := mx_g (mixin class).

End ClassDef.

Module Exports.
Notation iso := Iso.type.
Notation IsoMixin := Iso.Mixin.
Notation Iso T U m := (@pack T U _ m id).

Notation "[ 'iso' 'of' T U 'for' cT ]" := (@clone T U cT _ id)
  (at level 0, format "[ 'iso'  'of'  T  U  'for'  cT ]") : form_scope.
Notation "[ 'iso' 'of' T U ]" := (@clone T U _ _ id)
  (at level 0, format "[ 'iso'  'of'  T  U ]") : form_scope.
Notation "T ~= U" := (iso T U)
  (at level 60, format "T  '~='  U") : form_scope.

Notation iso_f := Iso.iso_f.
Notation iso_g := Iso.iso_g.

Arguments Iso.iso_f [T U] cT t.
Arguments Iso.iso_g [T U] cT u.

Section Laws.
Variables T U : Type.
Variable iso : iso T U.

Lemma iso_gf (t : T) : (iso_g iso \o iso_f iso) t = t.
Proof. by case: iso=> [][][]. Qed.

Lemma iso_fg (u : U) : (iso_f iso \o iso_g iso) u = u.
Proof. by case: iso=> [][][]. Qed.

End Laws.

Hint Resolve iso_gf iso_fg.

End Exports.

End Iso.

Export Iso.Exports.

Section Yoneda.
Variable F : functor.

Definition Y (A : Type) := (A ==> ?) ~~> F.

Definition uncheck A (y : Y A) : F A := y A (fun a => a).

Section check.
  Variables (A : Type) (x : F A).

  Definition check_eta (R : Type) (f : (A ==> ?) R) := fmap f x.

  Lemma check_eta_natural (R B : Type) (f : R -> B) (y : (A ==> ?) R) :
    check_eta (fmap f y) = fmap f (check_eta y).
  Proof. by rewrite /check_eta right_fmap fmap_assoc. Qed.

  Definition checkNaturalMixin :=
    @Natural.Mixin _ F check_eta check_eta_natural.
  Definition check : Y A :=
    Eval hnf in Natural (rightFunctor A) F checkNaturalMixin.
End check.

Lemma checkP A R (x : F A) (f : rightFunctor A R) :
  check x _ f = fmap f x.
Proof. by []. Qed.

Lemma uncheck_check A (x : F A) : uncheck (check x) = x.
Proof. by rewrite /uncheck checkP fmap_id. Qed.

Lemma check_uncheck' A (y : Y A) R g : check (uncheck y) R g = y R g.
Proof. by rewrite /uncheck checkP -eta_natural right_fmap. Qed.

Lemma check_uncheck A (y : Y A) : check (uncheck y) = y.
Proof. by apply: eta_extensionality=> R g; apply: check_uncheck'. Qed.

End Yoneda.

Section YonedaIso.
Variable F : functor.

Definition YonedaIsoMixin (A : Type) :=
  @IsoMixin (Y F A) (F A) (@uncheck F A) (@check F A)
            (@check_uncheck F A) (@uncheck_check F A).
Definition YonedaIso (A : Type) := @Iso (Y F A) (F A) (YonedaIsoMixin A).

End YonedaIso.


Coq < Section BasicB.

Coq < Goal B -> B.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  D : Prop
  E : Prop
  F : Prop
  ============================
   B -> B

Unnamed_thm2 < intros.
1 subgoal

  A : Prop
  B : Prop
  C : Prop
  D : Prop
  E : Prop
  F : Prop
  H : B
  ============================
   B

Unnamed_thm2 < exact H.
No more subgoals.

Unnamed_thm2 < Qed.
intros.
exact H.

Unnamed_thm2 is defined


(* -*- company-coq-local-symbols: (("|=" . ?⊨) ("=|" . ?⫤) ("->>" . ?↠) ("=~" . ?≈) ("<|" . ?⟨) ("|>" . ?⟩) ); -*- *)
Set Warnings "-notation-overridden".

Require Import Prelude.Prelude.

Require Import Defs.Env.
Require Import Defs.Freevars.
Require Import Defs.Lc.
Require Import Defs.Set.
Require Import Defs.Substs.

(*** Notation, tactics etc*)
Notation "A |=ty B" := (WfTy  A B) (at level 50)                   : type_scope.

Ltac inv_WfTy_ :=
  (* let H := fresh "H" in *)
  match goal with
    | [ H  : _ |=ty S_Mono (T_Fun _ _) |- _ ] => inverts H
  end.
Ltac inv_WfTy := repeat inv_WfTy_.

(*** Props *)
Theorem WfTy_props : forall (env : Env) (sch : Sch),
    env |=ty sch
  <-> ( free_skvars_Sch sch [<=] Env_skvars env
    /\ free_exvars_Sch sch [<=] Env_exvars env
    /\ lc_Sch sch ).
Proof.
  introv; split.
  - induction 1.
    + simpl. splits; fsetdec.
    + simpl. splits; fsetdec.
    + simpl. splits; fsetdec.
    + simpl. splits. 1,2:fsetdec. rewr*. jauto.
    + simpl. splits.
      * unfold AtomSetImpl.Subset. intros skA NIS.
        fresh_atom' (L \u singleton skA).
        forwards IH: H x. fsetdec. apply proj1 in IH. rewr in IH.
        rewrite <- free_skvars_Sch_open_Sch_wrt_Ty_lower in IH.
        rewrite IH in NIS. fsetdec.
      * fresh_atom. forwards IH: H x. eassumption. apply proj2 in IH. apply proj1 in IH. rewr in IH.
        transitivity (free_exvars_Sch (open_Sch_wrt_Ty Sch5 (T_SkVar_f x))); auto.
      * constructor. intros.
        fresh_atom' (L \u free_skvars_Sch Sch5).
        forwards [SUB__sk [SUB__ex LC]]: H x. fsetdec.
        eapply (subst_skvar_Sch_lc_Sch _ (T_SkVar_f skA) x) in LC. 2:{ auto. }
        rewrite subst_skvar_Sch_open_Sch_wrt_Ty in LC. 2: auto. simpl in LC. if_taut.
        rewrite subst_skvar_Sch_not_in_Sch_idempotent in LC; auto.
  - intros [SUB__sk [SUB__ex LC]]. gen env. LC_ind LC; intros; inv_LC.
    + crush.
    + crush.
    + crush.
    + rewr*. constructor.
      eapply IHLC__ty1. assumption. fsetdec. fsetdec.
      eapply IHLC__ty2. assumption. fsetdec. fsetdec.
   + econstructor. instantiate (1 := {}). intros.
     apply H0.
     * unfold AtomSetImpl.Subset. intros skB IN.
       rewrite free_skvars_Sch_open_Sch_wrt_Ty_upper in IN. indestr; crush.
     * unfold AtomSetImpl.Subset. intros skB IN.
       rewrite free_exvars_Sch_open_Sch_wrt_Ty_upper in IN. indestr; crush.
Qed.

Corollary WfTy_Sch_impls_lc : forall (env : Env) (sch : Sch),
    env |=ty sch
  -> lc_Sch sch.
Proof. apply WfTy_props. Qed.
Corollary WfTy_Ty_impls_lc : forall (env : Env) (ty : Ty),
    env |=ty S_Mono ty
  -> lc_Ty ty.
Proof. introv WFTY. apply WfTy_props in WFTY. rewr*. jauto. Qed.
#[export] Hint Resolve WfTy_Sch_impls_lc WfTy_Ty_impls_lc : core.

Corollary WfTy_impls_free_exvar_sub : forall (env : Env) (sch : Sch),
    env |=ty sch
  -> free_exvars_Sch sch [<=] Env_exvars env.
Proof. apply WfTy_props. Qed.

Corollary WfTy_props_mono : forall (env : Env) (ty : Ty),
    env |=ty (S_Mono ty)
  <-> ( free_skvars_Ty ty [<=] Env_skvars env
    /\ free_exvars_Ty ty [<=] Env_exvars env
    /\ lc_Ty ty ).
Proof. split. introv WFTY. apply WfTy_props in WFTY. crush. intros. apply WfTy_props. crush. Qed.
Corollary WfTy_props_mono1 : forall (env : Env) (ty : Ty),
    env |=ty (S_Mono ty)
  -> ( free_skvars_Ty ty [<=] Env_skvars env
    /\ free_exvars_Ty ty [<=] Env_exvars env
    /\ lc_Ty ty ).
Proof. apply WfTy_props_mono. Qed.
Corollary WfTy_props_mono2 : forall (env : Env) (ty : Ty),
    ( free_skvars_Ty ty [<=] Env_skvars env
    /\ free_exvars_Ty ty [<=] Env_exvars env
    /\ lc_Ty ty )
  -> env |=ty (S_Mono ty).
Proof. apply WfTy_props_mono. Qed.

(*** Rewriting *)
Theorem WfTy_Env_sub : forall (env1 env2 : Env) (sch : Sch),
    env1 |=ty sch
  -> env1 [<=]e env2
  -> env2 |=ty sch.
Proof. intros. rewrite WfTy_props in *. autounfold in *. destr. crush. Qed.
#[export] Hint Resolve WfTy_Env_sub : core.

#[export] Instance WfTy_Env_sub_inst : Proper (Env_sub ==> eq ==> impl) WfTy.
Proof. autounfold. intros. subst. eauto. Qed.

Theorem fv_sch_wfty_subset : forall (sch : Sch) (env : Env),
    env |=ty sch
  -> free_exvars_Sch sch [<=] Env_exvars env.
Proof.
  introv WFTY. induction WFTY; crush. fsetdec.
  fresh_atom.
  forwards: H. eassumption. rewr in H0.
  forwards REWR: free_exvars_Sch_open_Sch_wrt_Ty_lower. erewrite REWR. eassumption.
Qed.

Theorem WfTy_Env_eq : forall (env1 env2 : Env) (sch : Sch),
    env1 |=ty sch
  -> env1 [=]e env2
  -> env2 |=ty sch.
Proof. eauto. Qed.
#[export] Hint Resolve WfTy_Env_eq : core.

#[export] Instance WfTy_Env_eq_inst : Proper (Env_eq ==> eq ==> impl) WfTy.
Proof. autounfold. intros. subst. eauto. Qed.

(*** Inversion *)
Theorem WfTy_fun : forall (env : Env) (ty1 ty2 : Ty),
    env |=ty S_Mono (T_Fun ty1 ty2)
  -> env |=ty S_Mono ty1
  /\ env |=ty S_Mono ty2.
Proof. inversion 1. crush. Qed.
Corollary WfTy_fun1 : forall (env : Env) (ty1 ty2 : Ty),
    env |=ty S_Mono (T_Fun ty1 ty2)
  -> env |=ty S_Mono ty1.
Proof. apply WfTy_fun. Qed.
Corollary WfTy_fun2 : forall (env : Env) (ty1 ty2 : Ty),
    env |=ty S_Mono (T_Fun ty1 ty2)
  -> env |=ty S_Mono ty2.
Proof. apply WfTy_fun. Qed.
#[export] Hint Resolve WfTy_fun1 WfTy_fun2 : core.

(*** Unsorted *)
Theorem WfTy_subst : forall (env2 env1 : Env) (sch : Sch) (ty : Ty) (exA : exvar),
    env1 |=ty sch
  -> Metatheory.remove exA (Env_exvars env1) [<=] Env_exvars env2
  -> Env_skvars env1 [<=] Env_skvars env2
  -> env2 |=ty S_Mono ty
  -> env2 |=ty subst_exvar_Sch ty exA sch.
Proof.
  introv WFTY__sch SUB__ex SUB__sk WFTY__ty.
  apply WfTy_props in WFTY__sch. destruct WFTY__sch as [FVSK__sch [FVEX__sch LC__sch]].
  apply WfTy_props in WFTY__ty.  destruct WFTY__ty  as [FVSK__ty  [FVEX__ty  LC__ty ]].
  apply WfTy_props. splits.
  + rewrite free_skvars_Sch_subst_exvar_Sch_upper.
    rewrite FVSK__sch. rewrite FVSK__ty. fsetdec.
  + rewrite free_exvars_Sch_subst_exvar_Sch_upper.
    rewrite FVEX__sch. rewrite FVEX__ty. fsetdec.
  + auto using lc_Sch_subst_exvar_Sch'.
Qed.


(*
Lemma map_get_get : forall (k:nat) (v:EvidenceC) l',
    map_get ((k,v) :: l') k = Some v.
Proof.
  intros.
  simpl.
  break_match; eauto.
  rewrite PeanoNat.Nat.eqb_refl in Heqb. congruence.
Defined.

Lemma map_get_get_2 : forall (k:nat) (v:EvidenceC) k' v' l',
    k <> k' ->
    map_get ((k',v') :: (k,v) :: l') k = Some v.
Proof.
  intros; simpl.
  break_if;
    dohtac; tauto.
Defined.
*)


From Mtac2 Require Import Base Datatypes List Sorts Specif MTele MFixDef MTeleMatchDef Tactics.
Import Sorts.S.
Import M.notations.
Import ListNotations.

Set Universe Polymorphism.
Unset Universe Minimization ToSet.

(** Given `(A T : Type) (t : T)`, derive
    - `m : MTele`
    - `MTele_Const A m`
    such that
    - `T = MTele_Const A m`
    - `t : MTele_Const A m`
*)

(* FIX: proper error messaging *)
Definition MTele_of (A : Type) : forall T, T -> M (msigT (MTele_Const (s:=Typeₛ) A)) :=
  let matchtele := fun T => mTele (fun _ : T => mBase) in
  let fixtele := mTele (matchtele) in
  mfix'
    (m:=fixtele)
    (fun T (_ : T) => msigT (MTele_Const (s:=Typeₛ) A))
    (
      fun f T =>
        mtmmatch'
          _
          matchtele
          _
          T
          [m:
             (@mtpbase
                _
                (fun T => T -> M (msigT (MTele_Const (s:=Typeₛ) A)))
                A
                (fun t : A => M.ret (mexistT (MTele_Const (s:=Typeₛ) A) mBase t))
                UniCoq
             )
          |  (mtptele (fun (X : Type) => mtptele (fun (F : forall x : X, Type) =>
              @mtpbase
                _
                (fun T => T -> M (msigT (MTele_Const (s:=Typeₛ) A)))
                (forall x : X, F x)
                (fun t : _ =>
                   M.nu (FreshFrom T) mNone (fun x =>
                                   let Fx := reduce (RedOneStep [rl:RedBeta]) (F x) in
                                   let tx := (* rone_step *) (t x) in
                                   '(mexistT _ n T) <- f Fx tx;
                                   n' <- M.abs_fun (P:=fun _ => MTele) x n;
                                   T' <- M.coerce T;
                                   T' <- M.abs_fun (P:=fun x => MTele_Const (s:=Typeₛ) A (n' x)) x T';
                                   M.ret (mexistT (MTele_Const (s:=Typeₛ) A) (mTele n') T')
                                )
                )
                UniCoq
             )))
          ]
    ).

Definition decompose_app {m : MTele} {A : Type} {B : A -> Type} {C : MTele_ConstT A m} {T: Type} (a : A) (t : T)
  :
  M (Unification -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a : A => M (B a)) C) -> M (B a)) :=
  (
    '(mexistT _ m' T') <- MTele_of A T t;
    M.unify m m' UniCoq;;
    M.cumul UniCoq C t;;
    let x := fun u => @M.decompose_app' A B m u a C in
    M.ret x
  ).

Notation "'<[decapp' a 'return' T 'with' b ]>" :=
  (
    ltac:(mrun (decompose_app (B:=T) a b))
  )
  (at level 0, a at next level, b at next level) : M_scope.

Notation "'<[decapp' a 'with' b ]>" :=
  (
    ltac:(mrun (decompose_app (A:=?[A]) (B:=fun _ : ?A => _) a b))
  )
  (at level 0, a at next level, b at next level) : M_scope.

Local Definition mtele_convert' {A : Type} {B : A -> Prop} {G : Type} {mt:MTele} {C : MTele_ConstT A mt} :
  MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a => G -> B a) C)
  -> (G -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ B C)).
induction mt as [|X F IHmt].
- cbn. refine (fun x => x).
- cbn. intros ? ? ?.
  refine (IHmt _ _ _ _); [|auto].
  apply X0.
Defined.

Definition decompose_app_tactic {m : MTele} {A : Type} {B : A -> Type} {C : MTele_ConstT A m} {T: Type} (a : A) (t : T) :
  M (Unification -> MTele_sort (MTele_ConstMap (si:=Typeₛ) Propₛ (fun a : A => gtactic (B a)) C) -> gtactic (B a)) :=
  (
    '(mexistT _ m' T') <- MTele_of A T t;
    M.unify m m' UniCoq;;
    M.cumul UniCoq C t;;
    let x := fun uni f (g : goal gs_open) => @M.decompose_app' A (fun a => mlist (mprod (B a) (goal gs_any))) m uni a C (f g) in
    let y := fun uni f => x uni (mtele_convert' f) in
    M.ret y
  ).

Notation "'<[decapp' a 'return' T 'with' b ]>" :=
  (
      ltac:(mrun (decompose_app_tactic (B:=T) a b))
  )
  (at level 0, a at next level, b at next level) : tactic_scope.

Notation "'<[decapp' a 'with' b ]>" :=
  (
    ltac:(mrun (decompose_app_tactic (A:=?[A]) (B:=fun _ : ?A => _) a b))
  )
  (at level 0, a at next level, b at next level) : tactic_scope.