Require Import Lia.
Require Import Bool.
Require Import RelationClasses.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
From PromisingLib Require Import DataStructure.
From PromisingLib Require Import DenseOrder.
Require Import Event.
Require Import Time.
From PromisingLib Require Import Language.

Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.

Set Implicit Arguments.

Inductive tau T (step: forall (e:ThreadEvent.t) (e1 e2:T), Prop) (e1 e2:T): Prop :=
| tau_intro
    e
    (TSTEP: step e e1 e2)
    (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent)
.
#[export]
Hint Constructors tau: core.

Inductive union E T (step: forall (e:E) (e1 e2:T), Prop) (e1 e2:T): Prop :=
| union_intro
    e
    (USTEP: step e e1 e2)
.
#[export]
Hint Constructors union: core.

Lemma tau_mon T (step1 step2: forall (e:ThreadEvent.t) (e1 e2:T), Prop)
      (STEP: step1 <3= step2):
  tau step1 <2= tau step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma union_mon E T (step1 step2: forall (e:E) (e1 e2:T), Prop)
      (STEP: step1 <3= step2):
  union step1 <2= union step2.
Proof.
  i. inv PR. econs; eauto.
Qed.

Lemma tau_union: tau <4= (@union ThreadEvent.t).
Proof.
  ii. inv PR. econs. eauto.
Qed.

Module Thread.
  Section Thread.
    Variable (lang:language).

    Structure t := mk {
      state: (Language.state lang);
      local: Local.t;
      sc: TimeMap.t;
      memory: Memory.t;
    }.

    Inductive promise_step (pf:bool): forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | promise_step_intro
        st lc1 sc1 mem1
        loc from to msg kind
        lc2 mem2
        (LOCAL: Local.promise_step lc1 mem1 loc from to msg lc2 mem2 kind)
        (PF: pf = orb (andb (Memory.op_kind_is_lower_full kind) (Message.is_released_none msg))
                      (Memory.op_kind_is_cancel kind)):
        promise_step pf (ThreadEvent.promise loc from to msg kind) (mk st lc1 sc1 mem1) (mk st lc2 sc1 mem2)
    .

    (* NOTE: Syscalls act like a SC fence. *)
    Inductive program_step (e:ThreadEvent.t): forall (e1 e2:t), Prop :=
    | program_step_intro
        st1 lc1 sc1 mem1
        st2 lc2 sc2 mem2
        (STATE: (Language.step lang) (ThreadEvent.get_program_event e) st1 st2)
        (LOCAL: Local.program_step e lc1 sc1 mem1 lc2 sc2 mem2):
        program_step e (mk st1 lc1 sc1 mem1) (mk st2 lc2 sc2 mem2)
    .
    #[local]
    Hint Constructors program_step: core.

    Inductive step: forall (pf:bool) (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | step_promise
        pf e e1 e2
        (STEP: promise_step pf e e1 e2):
        step pf e e1 e2
    | step_program
        e e1 e2
        (STEP: program_step e e1 e2):
        step true e e1 e2
    .
    #[local]
    Hint Constructors step: core.

    Inductive step_allpf (e:ThreadEvent.t) (e1 e2:t): Prop :=
    | step_nopf_intro
        pf
        (STEP: step pf e e1 e2)
    .
    #[local]
    Hint Constructors step_allpf: core.

    Lemma allpf pf: step pf <3= step_allpf.
    Proof.
      i. econs. eauto.
    Qed.

    Definition pf_tau_step := tau (step true).
    #[local]
    Hint Unfold pf_tau_step: core.

    Definition tau_step := tau step_allpf.
    #[local]
    Hint Unfold tau_step: core.

    Definition all_step := union step_allpf.
    #[local]
    Hint Unfold all_step: core.

    Inductive opt_step: forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | step_none
        e:
        opt_step ThreadEvent.silent e e
    | step_some
        pf e e1 e2
        (STEP: step pf e e1 e2):
        opt_step e e1 e2
    .
    #[local]
    Hint Constructors opt_step: core.

    Inductive opt_promise_step: forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | opt_promise_step_none
        e1:
        opt_promise_step ThreadEvent.silent e1 e1
    | opt_promise_step_some
        pf e e1 e2
        (STEP: Thread.promise_step pf e e1 e2):
        opt_promise_step e e1 e2
    .

    Inductive opt_program_step: forall (e:ThreadEvent.t) (e1 e2:t), Prop :=
    | opt_program_step_none
        e1:
        opt_program_step ThreadEvent.silent e1 e1
    | opt_program_step_some
        e e1 e2
        (STEP: Thread.program_step e e1 e2):
        opt_program_step e e1 e2
    .

    Lemma tau_opt_tau
          e1 e2 e3 e
          (STEPS: rtc Thread.tau_step e1 e2)
          (STEP: Thread.opt_step e e2 e3)
          (EVENT: ThreadEvent.get_machine_event e = MachineEvent.silent):
      rtc Thread.tau_step e1 e3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto.
    Qed.

    Lemma tau_opt_all
          e1 e2 e3 e
          (STEPS: rtc Thread.tau_step e1 e2)
          (STEP: Thread.opt_step e e2 e3):
      rtc Thread.all_step e1 e3.
    Proof.
      induction STEPS.
      - inv STEP; eauto.
      - exploit IHSTEPS; eauto. i.
        econs 2; eauto.
        inv H. inv TSTEP. econs. econs. eauto.
    Qed.

    Definition steps_failure (e1: t): Prop :=
      exists e2 e3,
        <<STEPS: rtc tau_step e1 e2>> /\
        <<FAILURE: step true ThreadEvent.failure e2 e3>>.
    #[local]
    Hint Unfold steps_failure: core.

    (* consistency *)

    Definition consistent (e:t): Prop :=
      forall mem1 sc1
        (CAP: Memory.cap (Local.promises (local e)) (memory e) mem1)
        (SC_MAX: Memory.max_full_timemap mem1 sc1),
        <<FAILURE: steps_failure (mk (state e) (local e) sc1 mem1)>> \/
        exists e2,
          <<STEPS: rtc tau_step (mk (state e) (local e) sc1 mem1) e2>> /\
          <<PROMISES: (Local.promises (local e2)) = Memory.bot>>.

    (* step_future *)

    Lemma promise_step_future
          pf e e1 e2
          (STEP: promise_step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP. ss.
      exploit Local.promise_step_future; eauto. i. des.
      splits; eauto. refl.
    Qed.

    Lemma program_step_future
          e e1 e2
          (STEP: program_step e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP. ss. eapply Local.program_step_future; eauto.
    Qed.

    Lemma step_future
          pf e e1 e2
          (STEP: step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP.
      - eapply promise_step_future; eauto.
      - eapply program_step_future; eauto.
    Qed.

    Lemma opt_step_future
          e e1 e2
          (STEP: opt_step e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      inv STEP.
      - esplits; eauto; refl.
      - eapply step_future; eauto.
    Qed.

    Lemma rtc_all_step_future
          e1 e2
          (STEP: rtc all_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      revert WF1. induction STEP.
      - i. splits; ss; refl.
      - i. inv H. inv USTEP.
        exploit step_future; eauto. i. des.
        exploit IHSTEP; eauto. i. des.
        splits; ss; etrans; eauto.
    Qed.

    Lemma rtc_tau_step_future
          e1 e2
          (STEP: rtc tau_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1)):
      <<WF2: Local.wf (local e2) (memory e2)>> /\
      <<SC2: Memory.closed_timemap (sc e2) (memory e2)>> /\
      <<CLOSED2: Memory.closed (memory e2)>> /\
      <<TVIEW_FUTURE: TView.le (Local.tview (Thread.local e1)) (Local.tview (Thread.local e2))>> /\
      <<SC_FUTURE: TimeMap.le (sc e1) (sc e2)>> /\
      <<MEM_FUTURE: Memory.future (memory e1) (memory e2)>>.
    Proof.
      apply rtc_all_step_future; auto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.

    (* step_inhabited *)

    Lemma promise_step_inhabited
          pf e e1 e2
          (STEP: promise_step pf e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP. ss.
      eapply Local.promise_step_inhabited; eauto.
    Qed.

    Lemma program_step_inhabited
          e e1 e2
          (STEP: program_step e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP. ss.
      eapply Local.program_step_inhabited; eauto.
    Qed.

    Lemma step_inhabited
          pf e e1 e2
          (STEP: step pf e e1 e2)
          (INHABITED1: Memory.inhabited (memory e1)):
      <<INHABITED2: Memory.inhabited (memory e2)>>.
    Proof.
      inv STEP.
      - eapply promise_step_inhabited; eauto.
      - eapply program_step_inhabited; eauto.
    Qed.

    (* step_disjoint *)

    Lemma promise_step_disjoint
          pf e e1 e2 lc
          (STEP: promise_step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      inv STEP.
      exploit Local.promise_step_future; eauto. i. des.
      exploit Local.promise_step_disjoint; eauto.
    Qed.

    Lemma program_step_disjoint
          e e1 e2 lc
          (STEP: program_step e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      inv STEP. ss. eapply Local.program_step_disjoint; eauto.
    Qed.

    Lemma step_disjoint
          pf e e1 e2 lc
          (STEP: step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      inv STEP.
      - eapply promise_step_disjoint; eauto.
      - eapply program_step_disjoint; eauto.
    Qed.

    Lemma opt_step_disjoint
          e e1 e2 lc
          (STEP: opt_step e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      inv STEP.
      - esplits; eauto.
      - eapply step_disjoint; eauto.
    Qed.

    Lemma rtc_all_step_disjoint
          e1 e2 lc
          (STEP: rtc all_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      revert WF1 DISJOINT1 WF. induction STEP; eauto. i.
      inv H. inv USTEP.
      exploit step_future; eauto. i. des.
      exploit step_disjoint; eauto. i. des.
      exploit IHSTEP; eauto.
    Qed.

    Lemma rtc_tau_step_disjoint
          e1 e2 lc
          (STEP: rtc tau_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (DISJOINT1: Local.disjoint (local e1) lc)
          (WF: Local.wf lc (memory e1)):
      <<DISJOINT2: Local.disjoint (local e2) lc>> /\
      <<WF: Local.wf lc (memory e2)>>.
    Proof.
      eapply rtc_all_step_disjoint; cycle 1; eauto.
      eapply rtc_implies; [|eauto].
      apply tau_union.
    Qed.

    (* step_no_reserve_except *)

    Definition no_reserve_except (e: t) :=
      Memory.no_reserve_except (Local.promises (local e)) (memory e).

    Lemma step_no_reserve_except
          pf e e1 e2
          (STEP: step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (NORESERVE1: no_reserve_except e1):
      no_reserve_except e2.
    Proof.
      inv STEP; inv STEP0.
      - eapply Local.promise_step_no_reserve_except; eauto. apply WF1.
      - eapply Local.program_step_no_reserve_except; eauto. apply WF1.
    Qed.

    Lemma rtc_tau_step_no_reserve_except
          e1 e2
          (STEP: rtc tau_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (NORESERVE1: no_reserve_except e1):
      no_reserve_except e2.
    Proof.
      induction STEP; ss; i.
      inv H. inv TSTEP. exploit step_future; eauto. i. des.
      eapply IHSTEP; eauto.
      eapply step_no_reserve_except; eauto.
    Qed.

    Lemma step_bot_no_reserve
          pf e e1 e2
          (STEP: step pf e e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (NORESERVE1: Memory.no_reserve (memory e1))
          (PROMISES2: (Local.promises (local e2)) = Memory.bot):
      Memory.no_reserve (memory e2).
    Proof.
      exploit step_future; eauto. i. des.
      hexploit step_no_reserve_except; eauto; i.
      { eapply Memory.no_reserve_no_reserve_except; eauto. }
      unfold no_reserve_except in *. rewrite PROMISES2 in *.
      eapply Memory.no_reserve_except_bot_no_reserve; eauto.
      apply CLOSED2.
    Qed.

    Lemma rtc_tau_step_bot_no_reserve
          e1 e2
          (STEP: rtc tau_step e1 e2)
          (WF1: Local.wf (local e1) (memory e1))
          (SC1: Memory.closed_timemap (sc e1) (memory e1))
          (CLOSED1: Memory.closed (memory e1))
          (NORESERVE1: Memory.no_reserve (memory e1))
          (PROMISES2: (Local.promises (local e2)) = Memory.bot):
      Memory.no_reserve (memory e2).
    Proof.
      exploit rtc_tau_step_future; eauto. i. des.
      hexploit rtc_tau_step_no_reserve_except; eauto; i.
      { eapply Memory.no_reserve_no_reserve_except; eauto. }
      unfold no_reserve_except in *. rewrite PROMISES2 in *.
      eapply Memory.no_reserve_except_bot_no_reserve; eauto.
      apply CLOSED2.
    Qed.

    Lemma program_step_promises_bot
          e e1 e2
          (STEP: program_step e e1 e2)
          (PROMISES: (Local.promises (local e1)) = Memory.bot):
      (Local.promises (local e2)) = Memory.bot.
    Proof.
      inv STEP. eapply Local.program_step_promises_bot; eauto.
    Qed.

    (* step_prev_None *)

    Lemma step_prev_None
          pf e e1 e2
          (STEP: step pf e e1 e2):
      <<PREV: Memory.prev_None (memory e1) (memory e2)>>.
    Proof.
      inv STEP; inv STEP0; inv LOCAL; ss;
        try by ii; eapply GET_PREV; eauto.
      - eapply Memory.promise_prev_None; eauto.
      - inv LOCAL0. inv WRITE. ss.
        eapply Memory.promise_prev_None; eauto.
      - inv LOCAL1. inv LOCAL2. inv WRITE. ss.
        eapply Memory.promise_prev_None; eauto.
    Qed.

    Lemma opt_step_prev_None
          e e1 e2
          (STEP: opt_step e e1 e2):
      <<PREV: Memory.prev_None (memory e1) (memory e2)>>.
    Proof.
      inv STEP; eauto using step_prev_None.
      ii. eapply GET_PREV; eauto.
    Qed.

    Lemma rtc_tau_step_prev_None
          e1 e2
          (STEPS: rtc tau_step e1 e2):
      <<PREV: Memory.prev_None (memory e1) (memory e2)>>.
    Proof.
      induction STEPS.
      - ii. eapply GET_PREV; eauto.
      - inv H. inv TSTEP.
        inv STEP; inv STEP0; inv LOCAL; ss; ii.
        + exploit Memory.promise_get_from; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
        + inv LOCAL0. inv WRITE.
          exploit Memory.promise_get_from; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
        + inv LOCAL1. inv LOCAL2. inv WRITE. ss.
          exploit Memory.promise_get_from; try exact GET; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
    Qed.

    Lemma rtc_all_step_prev_None
          e1 e2
          (STEPS: rtc all_step e1 e2):
      <<PREV: Memory.prev_None (memory e1) (memory e2)>>.
    Proof.
      induction STEPS.
      - ii. eapply GET_PREV; eauto.
      - inv H. inv USTEP.
        inv STEP; inv STEP0; inv LOCAL; ss; ii.
        + exploit Memory.promise_get_from; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
        + inv LOCAL0. inv WRITE.
          exploit Memory.promise_get_from; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
        + inv LOCAL1. inv LOCAL2. inv WRITE. ss.
          exploit Memory.promise_get_from; try exact GET; eauto. i. des.
          hexploit Memory.promise_prev_None; eauto. i.
          eapply IHSTEPS; eauto.
    Qed.
  End Thread.
End Thread.


Require Import Coq.omega.Omega.
Require Import Coq.Program.Equality.
Require Import Coq.Program.Tactics.
Require Export DeclarationEvaluation.

(******************************************************************************)
(* Weakening lemmas                                                           *)
(******************************************************************************)

Lemma shift_value {t} :
  ∀ {c}, Value t → Value (shiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma tshift_value {t} :
  ∀ {c}, Value t → Value (tshiftTm c t).
Proof.
  induction t; simpl; intros; try contradiction; destruct_conjs; auto.
Qed.

Lemma weaken_value u :
  ∀ {t}, Value t → Value (weakenTm t u).
Proof.
  induction u as [|[]]; simpl; auto using shift_value, tshift_value.
Qed.

(******************************************************************************)
(* Reflexivity, transitivity and narrowing                                    *)
(******************************************************************************)

Lemma sub_refl {Γ T} (wfT: wfTy (domainEnv Γ) T) : Sub Γ T T.
Proof.
  depind wfT; simpl; econstructor; eauto with wf.
Qed.

Lemma narrow_lookup_etvar_ne {Γ T1 T2 Δ} :
  ∀ {X U}, X ≠ (weakenIndexty I0 (domainEnv Δ)) →
    lookup_etvar (appendEnv (etvar Γ T1) Δ) X U →
    lookup_etvar (appendEnv (etvar Γ T2) Δ) X U.
Proof.
  induction Δ; inversion 2; isimpl; try constructor; isimpl; intuition.
  - apply IHΔ; congruence.
Qed.

Definition Trans Q :=
  ∀ Γ S T, Sub Γ S Q → Sub Γ Q T → Sub Γ S T.

Definition Narrow Q :=
  ∀ Γ Δ S T, Sub (appendEnv (etvar Γ Q) Δ) S T →
    ∀ R, Sub Γ R Q → Sub (appendEnv (etvar Γ R) Δ) S T.

Lemma trans_case Q
  (hypT : ∀ R, size_Ty R < size_Ty Q → Trans R)
  (hypN : ∀ R, size_Ty R < size_Ty Q → Narrow R) :
  Trans Q.
Proof with simpl; eauto with infra; try omega.
  intros Γ S T subSQ subQT; revert T subQT.
  induction subSQ; intros; auto.
  - dependent destruction subQT; constructor; auto.
  - eapply SA_Trans_TVar; eauto.
  - dependent destruction subQT; simpl; constructor; eauto with wf...
    + apply (hypT T1)...
    + apply (hypT T2)...
  - dependent destruction subQT; constructor; eauto with wf...
    + apply (hypT T1)...
    + apply (hypT T2)...
      refine (hypN T1 _ G2 empty _ _ subSQ2 _ subQT1)...
  - dependent destruction subQT; constructor; eauto with wf...
    + apply (hypT T1)...
    + apply (hypT T2)...
Qed.

Lemma narrow_case Q (hyp : ∀ (R : Ty), size_Ty R = size_Ty Q → Trans R) :
  Narrow Q.
Proof.
  intros Γ Δ U T subUT; depind subUT; intros R subQ.
  - apply SA_Top; isimpl; auto.
  - apply SA_Refl_TVar; isimpl; auto.
  - pose proof (Sub_wf_1 _ _ _ subQ) as wfQ.
    case (eq_index_dec X (weakenIndexty I0 (domainEnv Δ))); intros; subst.
    + pose proof (lookup_etvar_functional _ lk _ (weaken_lookup_etvar_here Δ wfQ)).
      (* The lookup position X is the one that is being narrowed, so U is in
         fact Q weakened and hence we can use transitivity for U.  U. We can
         derive the goal like this:

                               Γ ⊢ R<:Q
                             ------------- shift_etvar_sub
                             Γ,x<:R ⊢ R<:Q
                            --------------- weaken_sub
         (x<:R) ∈ Γ,x<:R,Δ  Γ,x<:R,Δ ⊢ R<:Q
         ---------------------------------- SA_Trans  -------------- IH
                   Γ,x<:R,Δ ⊢ x<:U                    Γ,x:R,Δ ⊢ U<:T
         ----------------------------------------------------------- hyp U
                                 Γ,x<:R,Δ ⊢ x<:T
      *)
      apply (hyp U); subst; isimpl; auto.
      eapply SA_Trans_TVar; isimpl; eauto using weaken_Sub with wf infra.
    (* Just push the narrowing into the subtyping part. *)
    + eapply SA_Trans_TVar; isimpl; eauto using narrow_lookup_etvar_ne.
  - constructor; auto.
  - constructor; auto; apply (IHsubUT2 (etvar Δ T1) _ Q); auto.
  - constructor; auto.
Qed.

Lemma sub_trans_and_narrow Q : Trans Q ∧ Narrow Q.
Proof.
  induction Q using (sizeind size_Ty); intros; split.
  - apply trans_case; apply H; auto.
  - apply narrow_case; intros R eq.
    apply trans_case; rewrite eq; apply H.
Qed.

Lemma sub_trans {Q Γ S T} : Sub Γ S Q → Sub Γ Q T → Sub Γ S T.
Proof.
  intros; eapply sub_trans_and_narrow; eauto.
Qed.

Lemma sub_narrow {Γ Δ Q R S T} (subQ: Sub Γ R Q) :
  Sub (appendEnv (etvar Γ Q) Δ) S T → Sub (appendEnv (etvar Γ R) Δ) S T.
Proof.
  intros; eapply sub_trans_and_narrow; eauto.
Qed.

Lemma lookup_evar_narrow {Γ Δ Q R} :
  ∀ {x T}, lookup_evar (appendEnv (etvar Γ Q) Δ) x T →
           lookup_evar (appendEnv (etvar Γ R) Δ) x T.
Proof.
  induction Δ; inversion 1; isimpl; constructor; isimpl; eauto with wf.
Qed.

Lemma ptyping_narrow {Γ} Δ {Q R p T pΔ} (subQ: Sub Γ R Q) :
  PTyping (appendEnv (etvar Γ Q) Δ) p T pΔ →
  PTyping (appendEnv (etvar Γ R) Δ) p T pΔ.
Proof.
  intro wt; depind wt; econstructor; isimpl; eauto.
  - specialize (IHwt2 Γ (appendEnv Δ G) Q); isimpl; auto.
Qed.

Lemma typing_narrow {Γ} Δ {Q R t T} (subQ: Sub Γ R Q) :
  Typing (appendEnv (etvar Γ Q) Δ) t T → Typing (appendEnv (etvar Γ R) Δ) t T.
Proof.
  intro wt; depind wt; eauto using Typing, lookup_evar_narrow, sub_narrow.
  - eapply T_Var; eauto using lookup_evar_narrow with infra.
  - eapply T_Abs; isimpl; eauto.
    refine (IHwt Γ (evar Δ T1) _ _ eq_refl); auto.
  - eapply T_Tabs; isimpl; eauto.
    refine (IHwt Γ (etvar _ _) _ _ eq_refl); auto.
  - specialize (IHwt2 Γ (appendEnv Δ G1) Q).
    eapply T_Let; isimpl; eauto using ptyping_narrow.
Qed.

Lemma typing_narrow0 {Γ Q R t T} (subQ: Sub Γ R Q) :
  Typing (etvar Γ Q) t T → Typing (etvar Γ R) t T.
Proof.
  apply (typing_narrow empty subQ).
Qed.

(******************************************************************************)
(* Substitution lemmas                                                        *)
(******************************************************************************)

Instance obligation_Env_var_ty : Obligation_Env_var_ty.
Proof.
  constructor; intros; eapply SA_Trans_TVar; eauto using sub_refl with infra.
Qed.

Instance obligation_Env_reg_Sub : Obligation_Env_reg_Sub.
Proof.
  constructor; intros; simpl; eauto using sub_refl, sub_trans.
Qed.

(******************************************************************************)
(* Progress                                                                   *)
(******************************************************************************)

Lemma can_form_tvar {Γ t X} (v: Value t) (wt: Typing Γ t (tvar X)) : False.
Proof.
  depind wt; auto.
  depind jm17; eauto.
Qed.

Lemma can_form_tarr {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tarr T1 T2)) :
  ∃ T1' t2, t = abs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion jm17; subst; eauto.
    + elimtype False; eauto using can_form_tvar.
Qed.

Lemma can_form_tall {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tall T1 T2)) :
  ∃ T1' t2, t = tabs T1' t2.
Proof.
  depind wt; try contradiction.
  - exists T1, t; reflexivity.
  - inversion jm17; subst; eauto.
    + elimtype False; eauto using can_form_tvar.
Qed.

Lemma can_form_tprod {Γ t T1 T2} (v: Value t) (wt: Typing Γ t (tprod T1 T2)) :
  ∃ t1 t2, t = prod t1 t2 ∧ Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt; try contradiction.
  - exists t1, t2; auto.
  - inversion jm17; subst.
    + elimtype False; eauto using can_form_tvar.
    + destruct (IHwt S1 S2 v eq_refl) as (t1 & t2 & eq & wt1 & wt2).
      exists t1, t2; eauto using T_Sub.
Qed.

Lemma matching_defined {Γ p T1 Δ} (wp: PTyping Γ p T1 Δ) :
  ∀ {t1}, Value t1 → Typing Γ t1 T1 → ∀ t2, ∃ t2', Match p t1 t2 t2'.
Proof.
  induction wp; intros t1 v1 wt1 t2; isimpl.
  - exists (substTm X0 t1 t2).
    refine M_Var.
  - destruct (can_form_tprod v1 wt1) as (t11 & t12 & eq & wt11 & wt12); subst.
    destruct v1 as [v11 v12].
    apply (weaken_Typing G) in wt12.
    assert (val12' : Value (weakenTm t12 (domainEnv G)))
      by (apply weaken_value; auto).
    rewrite <- (domain_PTyping_bindPat _ _ _ _  wp1) in *.
    destruct (IHwp2 (weakenTm t12 (domainEnv G)) val12' wt12 t2) as [t2' m2].
    destruct (IHwp1 _ v11 wt11 t2') as [t2'' m1].
    rewrite (domain_PTyping_bindPat _ _ _ _ wp1) in m2.
    exists t2''.
    exact (M_Prod m2 m1).
Qed.

Lemma progress {t U} (wt: Typing empty t U) :
  Value t ∨ ∃ t', red t t'.
Proof with destruct_conjs; subst; eauto using red.
  depind wt; simpl; auto.
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
    destruct (can_form_tarr v1 wt1)...
  - destruct IHwt as [vt|[t1' r1]]...
    destruct (can_form_tall vt wt)...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct IHwt2 as [v2|[t2' r2]]...
  - destruct IHwt1 as [v1|[t1' r1]]...
    destruct (matching_defined wtp v1 wt1 t2)...
Qed.

(******************************************************************************)
(* Preservation                                                               *)
(******************************************************************************)

Lemma t_abs_inversion {Γ t T0 T1} (wt: Typing Γ (abs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tarr T2 T3) → Sub Γ T2 T1 ∧ Typing (evar Γ T1) t T3.
Proof.
  depind wt.
  - inversion 1; eauto using T_Sub, shift_evar_Sub with shift.
  - eauto using sub_trans.
Qed.

Lemma t_tabs_inversion {Γ t T0 T1} (wt: Typing Γ (tabs T1 t) T0) :
  ∀ {T2 T3}, Sub Γ T0 (tall T2 T3) → Sub Γ T2 T1 ∧ Typing (etvar Γ T2) t T3.
Proof.
  depind wt.
  - inversion 1; subst; split; eauto using T_Sub, typing_narrow0.
  - eauto using sub_trans.
Qed.

Lemma t_prod_inversion {Γ t1 t2 T} (wt: Typing Γ (prod t1 t2) T) :
  ∀ {T1 T2}, Sub Γ T (tprod T1 T2) → Typing Γ t1 T1 ∧ Typing Γ t2 T2.
Proof.
  depind wt.
  - inversion 1; eauto using T_Sub, typing_narrow0.
  - eauto using sub_trans.
Qed.

Lemma local_preservation_lett {p t1 t2 t2'} (m: Match p t1 t2 t2') :
  ∀ {Γ T1 T2 Δ}, PTyping Γ p T1 Δ → Typing Γ t1 T1 →
    Typing (appendEnv Γ Δ) t2 (weakenTy T2 (domainEnv Δ)) →
    Typing Γ t2' T2.
Proof.
  induction m; intros Γ T1 T2 Δ wp wt1 wt2; isimpl.
  - dependent destruction wp; simpl in *.
    eauto using subst_evar_Typing with infra.
  - dependent destruction wp.
    destruct (t_prod_inversion wt1 (sub_refl (Typing_wf_1 _ _ _ wt1))); isimpl.
    eapply IHm2; eauto. eapply IHm1; eauto.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wp1) in *.
    eauto using weaken_Typing.
Qed.

Lemma preservation {Γ t U} (wt: Typing Γ t U) :
  ∀ {t'}, red t t' → Typing Γ t' U.
Proof.
  induction wt; intros t' r; inversion r; subst; eauto using Typing.
  - destruct (t_abs_inversion wt1 (sub_refl (Typing_wf_1 _ _ _ wt1))).
    eauto using subst_evar_Typing, T_Sub with subst typeclass_instances.
  - destruct (t_tabs_inversion wt (sub_refl (Typing_wf_1 _ _ _ wt))).
    eauto using subst_etvar_Typing, T_Sub with infra typeclass_instances.
  - eapply local_preservation_lett; eauto; isimpl.
    rewrite <- (domain_PTyping_bindPat _ _ _ _ wtp) in *; eauto.
Qed.


Inductive CthulhuIC (I C : Type -> Type) (A : Type) : Type :=
| E
| N : A -> C A -> I A -> CthulhuIC I C A.

Arguments E {I C A}.
Arguments N {I C A} _ _ _.

Inductive CthulhuI (C : Type -> Type) (A : Type) : Type :=
| In : CthulhuIC (CthulhuI C) C A -> CthulhuI C A.

Arguments In {C A} _.

CoInductive Cthulhu (A : Type) : Type := MkC
{
  Out : CthulhuI Cthulhu A;
}.

Arguments MkC {A} _.
Arguments Out {A} _.

Fixpoint mapI
  {C : Type -> Type} (map : forall {A B : Type}, (A -> B) -> C A -> C B)
  {A B : Type} (f : A -> B)
  (c : CthulhuI C A) : CthulhuI C B :=
match c with
| In E => In E
| In (N v l r) => In (N (f v) (map f l) (mapI (@map) f r))
end.

Fail
CoFixpoint map {A B : Type} (f : A -> B) (c : Cthulhu A) : Cthulhu B :=
{|
  Out :=
    match Out c with
    | In E => In E
    | In (N v l r) => In (N (f v) (map f l) (mapI (@map) f r))
    end;
|}.

Fail
Definition map {A B : Type} (f : A -> B) (c : Cthulhu A) : Cthulhu B :=
  cofix map (c : Cthulhu A) : Cthulhu B :=
  match Out c with
  | In E => MkC (In E)
  | In (N v l r) => MkC (In
      (fix mapI (ci : CthulhuI Cthulhu A) : CthulhuI Cthulhu B :=
      match ci with
      | In E => In E
      | In (N v l r) => In (N (f v) (map l) (mapI r))
      end) r)
  end.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^511 - 187
Base: 22 + 5/23
***)

Definition curve : CurveParameters :=
  {|
    sz := 23%nat;
    base := 22 + 5/23;
    bitwidth := 32;
    s := 2^511;
    c := [(1, 187)];
    carry_chains := Some [seq 0 (pred 23); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


(** * NEG instruction *)
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype tuple.
Require Import procstate procstatemonad bitsops bitsprops bitsopsprops.
Require Import spec SPred septac spec safe triple basic basicprog spectac.
Require Import instr instrcodec eval monad monadinst reader pointsto cursor.
Require Import Setoid RelationClasses Morphisms.

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

Require Import Relations.
Require Import instrsyntax.

Local Open Scope instr_scope.

Require Import x86.instrrules.core.

(** Special case for negation *)
Lemma NEG_R_rule d (r:DWORDorBYTEReg d) (v:DWORDorBYTE d) :
  let w := negB v in
  |-- basic
    (DWORDorBYTEregIs r v ** OSZCP?) (NEG r)
    (DWORDorBYTEregIs r w ** OSZCP (msb v!=msb w) (msb w) (w == #0) (v != #0) (lsb w)).
Proof. destruct d; do_instrrule_triple. Qed.


(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

(*Require Export SfLib.*)
Require Export Coq.Init.Notations.
Require Export tactics.
Require Export Peano.
Require Export Basics.
Require Export Bool.
Require Export Arith.
Require Export Arith.EqNat.
Require Export Omega.

(* Prop/Type exists depending on the switch universe-type.v/universe-prop.v *)
Notation "{ a , b : T $ P }" :=
  {a : T $ {b : T $ P}}
    (at level 0, a at level 99, b at level 99).
Notation "{ a , b , c : T $ P }" :=
  {a : T $ {b : T $ {c : T $ P}}}
    (at level 0, a at level 99, b at level 99, c at level 99).
Notation "{ a , b , c , d : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ P}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99).
Notation "{ a , b , c , d , e : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ {e : T $ P}}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99, e at level 99).
Notation "{ a , b , c , d , e , f : T $ P }" :=
  {a : T $ {b : T $ {c : T $ {d : T $ {e : T $ {f : T $ P}}}}}}
    (at level 0, a at level 99, b at level 99, c at level 99, d at level 99, e at level 99, f at level 99).

(* Some extra notation from SfLib *)
Notation "[ x , .. , y ]" := (cons x .. (cons y []) ..).

(* Some lemmas from SfLib *)
Theorem beq_nat_sym :
  forall (n m : nat),
    beq_nat n m = beq_nat m n.
Proof.
  induction n; sp.
  unfold beq_nat; destruct m; sp.
  simpl; destruct m; simpl; sp.
Qed.

Definition Deq (T : Type) := forall (x y : T), {x = y} + {x <> y}.

Lemma deq_prod :
  forall (A B : Type), Deq A -> Deq B -> Deq (A * B).
Proof.
  unfold Deq; introv da db; introv; sp.
  generalize (da x0 y0) (db x y); introv ea eb; sp; subst; sp;
  right; intro k; inversion k; sp.
Defined.

Hint Resolve deq_prod : Deq.

Definition assert (b : bool) : Prop := b = true.

Lemma assert_true : assert true.
Proof.
  sp.
Qed.
Hint Immediate assert_true.

Lemma not_assert_false : !(assert false).
Proof.
  unfold assert; sp.
Qed.
Hint Immediate not_assert_false.

Lemma fold_assert :
  forall b,
    (b = true) = assert b.
Proof.
  unfold assert; auto.
Qed.

Lemma assert_orb :
  forall a b,
    assert (a || b) -> assert a + assert b.
Proof.
  destruct a; destruct b; sp.
Qed.

Lemma assert_andb :
  forall a b,
    assert (a && b) <-> assert a /\ assert b.
Proof.
  destruct a; destruct b; sp; split; sp.
Qed.

Lemma assert_of_andb :
  forall a b,
    assert (a && b) <=> assert a # assert b.
Proof.
  destruct a; destruct b; sp; split; sp.
Qed.

Lemma not_assert :
  forall b, b = false <-> ~ assert b.
Proof.
  destruct b; unfold assert; simpl; split; sp.
Qed.

Lemma not_of_assert :
  forall b, b = false <=> ! assert b.
Proof.
  destruct b; unfold assert; simpl; split; sp.
Qed.

Lemma andb_true :
  forall a b,
    a && b = true <-> a = true /\ b = true.
Proof.
  destruct a; destruct b; simpl; sp; split; sp.
Qed.

Lemma andb_eq_true :
  forall a b,
    a && b = true <=> (a = true) # (b = true).
Proof.
  destruct a; destruct b; simpl; sp; split; sp.
Qed.

(* ------ useful stuff ------ *)

Lemma max_prop1 :
  forall a b, a <= max a b.
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto.
  assert (a <= max a b); auto; omega.
Qed.

Lemma max_prop2 :
  forall a b, b <= max a b.
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto; try omega.
  assert (b <= max a b); auto; omega.
Qed.

Lemma max_or :
  forall a b,
    (max a b = a) \/ (max a b = b).
Proof.
  induction a; simpl; sp; try omega.
  destruct b; auto.
  assert (max a b = a \/ max a b = b) by apply IHa; sp.
Qed.

Theorem comp_ind:
  forall P: nat -> Prop,
    (forall n: nat, (forall m: nat, m < n -> P m) -> P n)
    -> forall n:nat, P n.
Proof.
 intros P H n.
 assert (forall n:nat , forall m:nat, m < n -> P m).
 intro n0. induction n0 as [| n']; intros.
 inversion H0.
  apply le_S_n in H0.
  apply le_lt_or_eq in H0.
 sp; subst; sp.
 apply H0 with (n := S n).
  auto.
Qed.

Theorem comp_ind_type :
  forall P: nat -> Type,
    (forall n: nat, (forall m: nat, m < n -> P m) -> P n)
    -> forall n:nat, P n.
Proof.
 intros P H n.
 assert (forall n:nat , forall m:nat, m < n -> P m).
 intro n0. induction n0 as [| n']; intros.
 omega.
 destruct (eq_nat_dec m n'); subst; auto.
 apply IHn'; omega.
 apply H; apply X.
Defined.

(*
Print NTerm_ind.

Print eq_refl.

Require Import Eqdep.

Axiom dec_eq_eq :
  forall (A : Type),
    (forall a b : A, {a = b} + {a <> b})
    -> forall a b : A,
       forall e e' : a = b,
         e = e'. (* Proved in Eqdep_dec. *)

Definition eq_dep_eq_dec'
           (A : Type)
           (dec_eq : forall a b : A, {a = b} + {a <> b})
           (X : A -> Type)
           (a : A)
           (x y : X a)
           (e : eq_dep A X a x a y) : x = y
 := (match e in eq_dep _ _ _ _ a' y' return
          forall e' : a = a',
            (match e' in _ = a' return X a' with
                eq_refl => x
            end) = y'
    with
    | eq_dep_intro =>
      fun e : a = a =>
        match dec_eq_eq A dec_eq a a (eq_refl a) e
              in _ = e
              return match e in _ = a' return X a' with eq_refl => x end = x with
          | eq_refl => eq_refl x
        end
    end) (eq_refl a).
*)

Lemma trivial_if :
  forall T,
  forall b : bool,
  forall t : T,
    (if b then t else t) = t.
Proof.
  intros;  destruct b; auto.
Qed.

Hint Rewrite trivial_if.

Lemma minus0 :
  forall n, n - 0 = n.
Proof.
  destruct n; auto.
Qed.

Lemma pair_inj :
  forall A B,
  forall a c : A,
  forall b d : B,
    (a, b) = (c, d) -> a = c /\ b = d.
Proof.
  sp; inversion H; sp.
Qed.

Lemma S_inj :
  forall a b, S a = S b -> a = b.
Proof.
  auto.
Qed.

Lemma S_le_inj :
  forall a b, S a <= S b -> a <= b.
Proof.
  sp; omega.
Qed.

Lemma S_lt_inj :
  forall a b, S a < S b -> a < b.
Proof.
  sp; omega.
Qed.

Lemma not_or :
  forall a b,
    ~ (a \/ b) -> ~ a /\ ~ b.
Proof.
  sp; apply H; sp.
Qed.

Lemma not_over_or :
  forall a b,
    !(a [+] b) <=> !a # !b.
Proof.
  sp; split; sp.
Qed.

Theorem apply_eq :
  forall {A B} (f: A -> B) {a1 a2:A},
    a1 = a2 -> f a1 = f a2.
Proof. intros. rewrite H. reflexivity.
Qed.

Theorem iff_push_down_forall : forall A (P Q: A-> Prop) ,
  (forall a, P a <=> Q a) -> ((forall a, P a) <=> (forall a, Q a)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Theorem iff_push_down_forallT : forall A (P Q: A-> [univ]) ,
  (forall a, P a <=> Q a) -> ((forall a, P a) <=> (forall a, Q a)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Theorem iff_push_down_impliesT : forall P Q R,
  (R -> (P <=> Q)) -> ((R -> P) <=> (R -> Q)).
Proof. introv Hiff. repeat split; intros; apply Hiff; auto.
Qed.

Lemma sum_assoc :
  forall a b c,
    (a [+] (b [+] c)) <=> ((a [+] b) [+] c).
Proof.
  sp; split; sp.
Qed.

Definition isInl {A B : Type}
    (d : A + B) : bool :=
match d with
| inl _ => true
| inr _ => false
end.

Definition isInr {A B : Type}
    (d : A + B) : bool :=
match d with
| inl _ => false
| inr _ => true
end.

Definition isInlInl {A B C D: Type}
    (d : (A + B) + (C + D)) : bool :=
match d with
| inl (inl _) => true
| _ => false
end.

Definition liftNth {A: Type}
    (f : A-> bool) (l : list A ) (n:nat) : bool :=
match (nth_error l n) with
| Some x => f x
| None => false
end.

Definition liftInl {A B : Type}
    (f : A -> bool) (d : A + B) : bool :=
match d with
| inl a => f a
| inr _ => false
end.

Notation deq_nat := Nat.eq_dec.
Hint Resolve Nat.eq_dec : Deq.

(* ========= DEPENDENT PAIRS ========= *)

Definition eq_existsT (A : Type)
                      (B : A -> Type)
                      (a a' : A)
                      (b : B a)
                      (b' : B a')
                      (ea : a = a')
                      (eb : match ea in _ = a' return B a' with eq_refl => b end = b')
  : existT B a b = existT B a' b'
  := match ea as ea
              in _ = a'
        return forall b' : B a',
                 match ea in _ = a' return B a' with eq_refl => b end = b'
                 -> existT B a b = existT B a' b'
     with
       | eq_refl => fun b' eb => match eb with eq_refl => eq_refl (existT B a b) end
     end b' eb.

Lemma dep_pair_eq :
  forall {T : Type} {a b : T} (eq : a = b) (P : T -> Prop) (pa : P a) (pb : P b),
    @eq_rect T a P pa b eq = pb
    -> exist P a pa = exist P b pb.
Proof.
  intros.
  rewrite <- H.
  rewrite <- eq.
  reflexivity.
Qed.

Ltac apply_tiff_f H1 H2 :=
  let H3 := fresh in (
    (pose proof (fst (H1) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (fst(H1 _ _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Ltac apply_tiff_b H1 H2 :=
  let H3 := fresh in (
    (pose proof (snd (H1) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3) ||
    (pose proof (snd(H1 _ _ _ _ _ _ _) H2) as H3; clear H2; pose proof H3 as H2; clear H3)).

Tactic Notation "apply_tiff"  constr(H1) constr(H2) :=
 (apply_tiff_f H1 H2 || apply_tiff_b H1 H2) .

Tactic Notation "refl" := reflexivity.

Theorem and_tiff_compat_l:
 forall A B C : [univ], (B <=> C) -> (A # B <=> A # C).
Proof.
 introv Hiff. rw Hiff. apply t_iff_refl.
Qed.

Definition transport {T:Type} {a b:T} {P:T -> Type} (eq:a=b) (pa: P a) : (P b):=
@eq_rect T a P pa b eq.

Definition typeCast {A B:Type}  (eq:A=B) (pa: A) : (B):=
@eq_rect Type A (fun X => X) pa B eq.

Definition injective_fun {A B: Type} (f: A->B)  :=
  forall (a1 a2: A), (f a1= f a2) -> a1=a2.

Lemma min_eq : forall n1 n2,
  n1=n2 -> min n1 n2 = n2.
Proof.
  introv H. rewrite  H.
  apply Min.min_idempotent.
Qed.

Lemma negb_eq_true :
  forall b, negb b = true <=> ! (assert b).
Proof.
  intro.
  unfold assert; destruct b; simpl; split; sp.
Qed.

Definition left_identity {S T : Type} (f: S -> T) (g: T-> S): Type :=
 forall s: S , (g (f s)) = s.

Definition bijection  {S T : Type} (f: S -> T) (g: T-> S) : Type
 := prod (left_identity f g)  (left_identity g f).

Definition injection {S T : Type} (f: S -> T) :=
  forall (s1 s2 : S), (f s1 = f s2) -> s1=s2.

Lemma left_id_injection: forall {S T : Type} (f: S -> T) (g: T-> S),
  left_identity f g -> injection f.
Proof.
  introv lid feq.
  apply_eq g feq ffeq.
  rw lid in ffeq.
  rw lid in ffeq.
  trivial.
Qed.

Definition equipollent (A B : Type)
 := {f : A -> B $ { g : B -> A $ bijection f g }}.

(** constructive defn. of surjection -- it gives
    the right inverse for free. classical one may
    be obtained by changing [sig] to [ex] *)
Definition Csurjection {S T : Type} (f: S -> T) :=
  forall (t : T), {s : S $ f s =t}.

Lemma injection_surjection_equipollent
  : forall {S T : Type} (f: S -> T) ,
  injection f
  -> Csurjection f
  -> equipollent S T.
Proof.
Abort.
(**
http://cstheory.stackexchange.com/questions/18962/formalizing-the-theory-of-finite-sets-in-type-theory
*)
Definition Fin (n:nat)
  := {m:nat & if lt_dec m n then unit else void}.

Lemma Fin_eq:
  forall (n: nat) (fa fb : Fin n),
    (projT1 fa) = (projT1 fb)
    -> fa = fb.
Proof.
  introv Heq.
  destruct fa as [a ap].
  destruct fb as [b bp].
  allsimpl.
  subst.
  apply eq_existsT with (ea := eq_refl).
  remember (lt_dec b n); destruct s; destruct ap, bp; auto.
Qed.

Lemma Fin_decidable : forall (n:nat), Deq (Fin n).
Proof.
  unfold Deq.
  intros.
  destruct (Nat.eq_dec (projT1 x) (projT1 y)) as [T|F];[left|right].
  - apply Fin_eq; auto.
  - intro Heq. destruct F. destruct x. destruct y.
    inverts Heq. allsimpl. reflexivity.
Defined.

Hint Resolve Fin_decidable : Deq.

Lemma equipollent_Deq : forall (A B:Type),
    Deq A
    -> equipollent A B
    -> Deq B.
Proof.
  unfold Deq, equipollent, bijection.
  introv Ha Heq. intros. exrepnd.
  pose proof (Ha (g x) (g y)) as Hd.
  dorn Hd; [left| right].
  - apply left_id_injection in Heq1.
    repnud Heq1. auto.
  - introv Heq. apply Hd. f_equal; auto.
Qed.

Hint Resolve equipollent_Deq : Deq.

Lemma bool2_Equi :
  equipollent bool (Fin 2).
Abort.

(** This is a strong constructive version of
    finiteness of a type. It says that
    there should be a bijection between
    some finite initial segment of numbers
    and that type *)
Definition Finite (T : Type) :=
  {n:nat $ equipollent ( Fin n) T}.

Lemma Finite_Deq : forall (A:Type),
    Finite A
    -> Deq A.
Proof.
  introv Hf.
  repnud Hf. exrepnd.
  (* info_eauto with Deq *)
    eapply equipollent_Deq.
    apply Fin_decidable.
    exact Hf0.
Qed.

Hint Resolve Finite_Deq : Deq.

Lemma prod_assoc :
  forall a b c,
    (a # b) # c <=> a # (b # c).
Proof.
  sp; split; sp.
Qed.

Lemma prod_comm :
  forall a b,
    a # b <=> b # a.
Proof.
  sp; split; sp.
Qed.

Lemma or_true_l :
  forall t, True [+] t <=> True.
Proof. sp. Qed.

Lemma or_true_r :
  forall t, t [+] True <=> True.
Proof. sp. Qed.

Lemma or_false_r : forall t, t [+] False <=> t.
Proof. sp; split; sp. Qed.

Lemma or_false_l : forall t, False [+] t <=> t.
Proof. sp; split; sp. Qed.

Lemma and_true_l :
  forall t, True # t <=> t.
Proof. sp; split; sp. Qed.

Lemma not_false_is_true : !False <=> True.
Proof. sp; split; sp. Qed.

Lemma forall_num_lt_d : forall m P,
  (forall n, n < S m -> P n)
  -> P 0 # (forall n, n <  m -> P (S n) ).
Proof.
  introv Hlt.
  dimp (Hlt 0); auto; [omega|].
  dands; auto.
  introv Hgt.
  apply lt_n_S in Hgt.
  eauto.
Qed.
Ltac dforall_lt_hyp name :=
  repeat match goal with
  [ H : forall  n : nat , n< S ?m -> ?C |- _ ] =>
    apply forall_num_lt_d in H;
    let Hyp := fresh name in
    destruct H as [Hyp H]
  | [ H : forall  x : ?T , _ < 0 -> _ |- _ ] => clear H
  end.

Lemma not_over_and :
  forall a b,
    decidable a -> (!(a # b) <=> !a [+] !b).
Proof.
  introv d; split; intro k; tcsp.
  dorn d.
  - right; intro h.
    apply k; sp.
  - left; auto.
Qed.

Lemma decidable_prod : forall
  (P Q: [univ]),
  decidable P
  -> decidable Q
  -> decidable (P * Q).
Proof.
  introv Hpd Hqd.
  unfold decidable;
  destruct Hpd; destruct Hqd;
  try (left; dands; auto; fail);
  (right; introv Hc; repnd; auto).
Defined.

Require Import Coq.Logic.Eqdep_dec.

Lemma UIPReflDeq: forall { A : Type} (deq : Deq A)
  (a: A) (p: a=a), p = eq_refl.
Proof.
  intros.
  remember (@eq_refl A a) as eqr.
  apply UIP_dec.
  auto.
Qed.

Definition DeqP (A : Type):=
forall x0 y0 : A, x0 = y0 \/ x0 <> y0.

Lemma DeqDeqp : forall {A : Type},
  Deq A -> DeqP A.
Proof.
  introv deq.
  intros x y.
  destruct (deq x y);[left|right]; auto.
Qed.

(** copied from Coq.Logic.EqDep_dec.v
    and converted things from Prop to Type
    (and ex to sigT) *)

 Let projT {A : Type} {x: A} (dec: Deq A)
  {P:A -> Type} (exP: sigT P) (def:P x) : P x :=
   match exP with
     | existT _ x' prf =>
       match dec x' x with
         | left eqprf => eq_rect x' P prf x eqprf
         | _ => def
       end
   end.
 Theorem injRightsigT:
   forall  {A : Type} {x: A} (dec: Deq A) (P:A -> Type)  (y y':P x),
     existT P x y = existT P x y' -> y = y'.
 Proof.
   intros.
   cut (projT dec
      (existT _ x y) y = projT dec (existT _ x y') y).
   simpl.
   case (dec x x).
   intro e.
   elim e using K_dec; trivial.

  apply DeqDeqp. trivial.

   intros.
   case n; trivial.

   case H.
   reflexivity.
 Qed.

Ltac EqDecSndEq :=
  let dec:= fresh "dec" in
repeat match goal with
[H : @existT ?A _ _ _ = _ |- _ ] =>
  assert (Deq A) as dec by eauto with Deq;
  apply (injRightsigT dec) in H; clear dec
end.

Lemma DeqTrue:  forall {A} (deq : Deq A) (a : A),
  (deq a a) = (left (@eq_refl A a)).
Proof.
  intros; auto.
  destruct (deq a a) as [HH| HH].
  - f_equal.
    apply UIPReflDeq; auto.
  - destruct HH. auto.
Defined.

Lemma DeqSym:  forall {A} T (deq : Deq A) (a b: A)
  (f : (a=b) -> T) (c:T),
  match deq a b with
  | left p => f p
  | _ => c
  end
  =
  match deq b a with
  | left p => f (eq_sym p)
  | _ => c
  end.
Proof.
  intros.
  destruct (deq a b) as [HH| HH].
  - destruct (deq a b) as [H| H]; subst;sp.
    destruct (deq b b); sp;[].
    pose proof (UIPReflDeq deq _  e) as XX.
    rw XX.
    auto.
  - destruct (deq b a) as [H| H]; subst; sp.
Defined.

Definition constantFn {A B : Type} (f: A-> B): [univ] :=
  forall a1 a2, f a1 = f a2.

Lemma constantMapEq :
  forall {A B : Type} (f: A-> B),
  constantFn f
  -> forall l1 l2,
        length l1 = length l2
        -> map f l1 = map f l2.
Proof.
  introv Hc. repnud Hc.
  induction l1 as [| h1 t1 Hind]; introv Hleq;
  destruct l2; inverts Hleq;[|]; simpl. auto.
  f_equal; auto; congruence.
Defined.

Definition DeqBool : Deq bool := bool_dec.

Hint Resolve  deq_prod DeqBool: Deq.

Definition sigTDeq
 {A : Type} (deq : Deq A)
  (P : A -> Type)
  (deqf : forall (a:A), Deq (P a)) :
  Deq (sigT P).
  introv.
  destruct (deq (projT1 x) (projT1 y)) as [Heq | Hneq];
    [| right].
  - destruct x as [xa xb]. allsimpl.
    revert xb. rewrite Heq.
    intros. allsimpl.
    destruct y as [ya yb].
    allsimpl.
    destruct ((deqf ya) xb yb) as [beq | bneq];[left|right].
    + f_equal; auto.
    + introv Hc. EqDecSndEq.
      apply bneq. exact Hc.
  - introv Heq. apply (f_equal (@projT1 _ _)) in Heq.
    apply Hneq. exact Heq.
Defined.

Definition Deq2Bool {A : Type} (deq : Deq A) (a b : A)
  : bool.
destruct (deq a b);[exact true | exact false].
Defined.

Hint Resolve sigTDeq : Deq.

Lemma and_true_r :
  forall t, t # True <=> t.
Proof. sp; split; sp. Qed.

Lemma true_eq_same : forall T (t : T), t = t <=> True.
Proof. sp; split; sp. Qed.


Set Primitive Projections.
Variant delayF (X : Type) (rec : Type) : Type :=
| NowF (x : X)
| LaterF (d : rec).
CoInductive delay X : Type := go { _observe : delayF X (delay X) }.
Arguments NowF {_ _}.
Arguments LaterF {_ _}.
Arguments _observe {_}.
Arguments go {_}.
Notation Now x := (go (NowF x)).
Notation Later t := (go (LaterF t)).

Definition subst {X Y} (k : X -> delay Y) : delay X -> delay Y :=
  cofix F (c : delay X) : delay Y :=
    match _observe c with
    | NowF x => k x
    | LaterF d => Later (F d)
    end.

Definition bind {X Y} (c : delay X) (k : X -> delay Y) := subst k c.

Definition iter {Acc Res : Type} (body : Acc -> delay (Acc + Res)) : Acc -> delay Res :=
  cofix F acc :=
    bind
      (body acc)
      (fun x =>
         match x with
         | inl acc' => Later (F acc')
         | inr res  => Now res
         end
      ).

Axiom (body : nat -> delay (nat + nat)).
Axiom (k : nat -> delay bool).

Definition observe {X : Type} (d : delay X) : delayF X (delay X) :=
  _observe d.

(* Undesired reduction behavior, the wrapping blocks it *)
Eval cbn in _observe (bind (iter body 0) k).

Eval simpl in _observe (bind (iter body 0) k).


(* Copyright (c) 2014, Robert Dockins *)

Require Import Setoid.
Require Import List.

Require Import basics.
Require Import preord.
Require Import categories.
Require Import sets.
Require Import finsets.
Require Import esets.
Require Import effective.
Require Import directed.
Require Import plotkin.
Require Import joinable.
Require Import approx_rels.
Require Import cpo.
Require Import profinite.

(**  * Discrete unpointed domains

     Every finite type can be turned into a discrete profinite domain.
     These are useful for representing base types.
  *)

Module fintype.
  Record fintype :=
  Fintype
  { carrier :> Type
  ; fintype_list : list carrier
  ; fintype_complete : forall x, In x fintype_list
  ; fintype_dec : forall x y:carrier, {x=y}+{x<>y}
  }.

  Definition eq_mixin (X:fintype) : Eq.mixin_of (carrier X) :=
    Eq.Mixin (carrier X) (@eq _)
    (@Logic.refl_equal _) (@Logic.eq_sym _) (@Logic.eq_trans _).

  Definition preord_mixin (X:fintype) : Preord.mixin_of (carrier X) :=
    Preord.Mixin (carrier X) (@eq _) (@Logic.refl_equal _) (@Logic.eq_trans _).

  Canonical Structure setoid (X:fintype) : Eq.type :=
    Eq.Pack X (eq_mixin X).
  Canonical Structure ord (X:fintype) : preord :=
    Preord.Pack X (preord_mixin X).

  Lemma order_discrete (X:fintype) (x y:X) : x ≤ y -> x = y.
  Proof (fun H => H).

  Lemma strong_eq (X:fintype) (x y:X) : x ≈ y -> x = y.
  Proof (fun H => H).

  Program Definition fintype_effective X : effective_order (ord X) :=
    EffectiveOrder (ord X) (fintype_dec X) (elist (fintype_list X)) _.
  Next Obligation.
    intros. apply elist_elem. exists x. split; auto. apply fintype_complete.
  Qed.

  Program Definition fintype_has_normals hf (X:fintype) :
    has_normals (ord X) (fintype_effective X) hf.
  Proof.
    hnf; intros. exists (fintype_list X). split.
    hnf; intros. exists a; split; auto. apply fintype_complete.
    hnf; simpl; intros. split.
    destruct hf.
    destruct Hinh. exists x.
    exists x. split; auto. apply fintype_complete.
    hnf; auto.
    repeat intro. exists z.
    split; repeat intro.
    apply H in H0. apply finsubset_elem in H0.
    destruct H0; auto.
    intros. hnf in H1, H2. destruct H1.
    hnf. hnf in H3. rewrite H3; auto.
    apply finsubset_elem. intros.
    destruct H0. rewrite H2. auto.
    split; auto.
    exists z; split; auto. apply fintype_complete.
  Qed.

  Definition fintype_plotkin hf (X:fintype) : plotkin_order hf (ord X) :=
    norm_plt (ord X) (fintype_effective X) hf (@fintype_has_normals hf X).
End fintype.

Notation fintype := fintype.fintype.
Notation Fintype := fintype.Fintype.

Canonical Structure fintype.setoid.
Canonical Structure fintype.ord.
Coercion fintype.carrier : fintype >-> Sortclass.

Canonical Structure disc (X:fintype) : PLT :=
    PLT.Ob false (fintype.carrier X)
      (PLT.Class _ _
        (fintype.preord_mixin X)
        (fintype.fintype_effective X)
        (fintype.fintype_plotkin false X)).

Program Definition disc_elem (Y:fintype) (y:Y) : 1 → disc Y :=
  PLT.Hom false (PLT.unit false) (disc Y) (single (tt,y)) _ _.
Next Obligation.
  intros. destruct x'. destruct x.
  apply single_axiom in H1.
  apply single_axiom.
  destruct H1. destruct H1. simpl in *.
  split; split; simpl; auto.
  rewrite H0; auto.
  hnf in H0. subst y'. hnf in H3. hnf. auto.
Qed.
Next Obligation.
  repeat intro. exists y.
  split. repeat intro.
  apply H in H0. apply erel_image_elem in H0.
  apply single_axiom in H0.
  destruct H0 as [[??][??]]; auto.
  apply erel_image_elem.
  apply single_axiom. destruct x. auto.
Qed.

Lemma disc_elem_inj Y : forall y1 y2,
  disc_elem Y y1 ≈ disc_elem Y y2 -> y1 = y2.
Proof.
  intros. destruct H.
  assert ((tt,y1) ∈ PLT.hom_rel (disc_elem Y y2)).
  apply H. apply single_axiom. auto.
  simpl in H1. apply single_axiom in H1.
  destruct H1 as [[??][??]]; auto.
Qed.

Arguments disc_elem [Y] y.

Section disc_cases.
  Variable X:fintype.
  Variables (A B:PLT).
  Variable f : X -> (A → B).

  Program Definition insert_index (x:X) : Preord.hom (A×B) ((A×disc X)×B) :=
    Preord.Hom (A×B) ((A×disc X)×B) (fun ab => ((fst ab, x), snd ab)) _.
  Next Obligation.
    intros x [??] [??] [??]; simpl in *; auto.
    split; simpl; auto. split; auto.
  Qed.

  Fixpoint mk_disc_cases_rel (ls:list X) : eset ((PLT.ord A×disc X)×B)%cat_ob :=
    match ls with
    | nil => ∅
    | x::xs => union2 (image (insert_index x) (PLT.hom_rel (f x)))
                      (mk_disc_cases_rel xs)
    end.

  Lemma mk_disc_cases_elem : forall ls x a b, (In x ls) ->
    ((a,b) ∈ PLT.hom_rel (f x) <-> (a,x,b) ∈ mk_disc_cases_rel ls).
  Proof.
    induction ls; simpl; intros. elim H.
    destruct H. subst a.
    split; intros.
    apply union2_elem. left.
    apply image_axiom1'.
    exists (a0,b); split; auto.
    apply union2_elem in H.
    destruct H. apply image_axiom2 in H.
    destruct H as [[p q] [??]].
    simpl in H0.
    revert H. apply member_eq.
    destruct H0 as [[??][??]]. simpl in *.
    destruct H; destruct H1; simpl in *.
    split; split; auto.
    destruct (In_dec (fintype.fintype_dec X) x ls).
    apply IHls; auto.
    elim n. clear IHls. clear n.
    induction ls; simpl in *.
    apply empty_elem in H. auto.
    apply union2_elem in H. destruct H.
    apply image_axiom2 in H.
    destruct H as [[p q] [??]].
    simpl in H0.
    destruct H0 as [[??][??]]. simpl in *.
    destruct H0. simpl in *. hnf in H4. auto.
    right; auto.
    split; intros.
    apply union2_elem. right. apply IHls; auto.
    apply union2_elem in H0. destruct H0.
    apply image_axiom2 in H0.
    destruct H0 as [[p q] [??]]. simpl in H1.
    destruct H1 as [[??][??]]. simpl in *.
    destruct H1. simpl in *. destruct H3. simpl in *.
    hnf in H5. subst a.
    revert H0. apply member_eq.
    split; split; auto.
    apply IHls; auto.
  Qed.

  Program Definition disc_cases : (A × (disc X))%plt → B :=
    PLT.Hom false (PLT.prod A (disc X)) B
       (mk_disc_cases_rel (fintype.fintype_list X)) _ _.
  Next Obligation.
    generalize (fintype.fintype_list X).
    induction l; simpl; intros.
    apply empty_elem in H1. elim H1.
    apply union2_elem in H1. apply union2_elem.
    destruct H1. left.
    apply image_axiom2 in H1. apply image_axiom1'.
    destruct H1 as [[p q] ?]. destruct H1.
    simpl in H2.
    destruct x; destruct x'. simpl.
    destruct H. simpl in *. hnf in H3. subst c0.
    exists (c1,y'). simpl. split.
    destruct H2 as [[??][??]]. simpl in *.
    destruct H2; destruct H4; simpl in *.
    hnf in H6. subst c2. auto.
    destruct H2 as [[??][??]]. simpl in *.
    destruct H2; destruct H4; simpl in *.
    revert H1. apply PLT.hom_order.
    rewrite H4. auto.
    rewrite H0; auto.
    right. eapply IHl; eauto.
  Qed.
  Next Obligation.
    repeat intro.
    destruct x as [a x].
    destruct (PLT.hom_directed _ _ _ (f x) a M); auto.
    red; simpl; intros. apply H in H0.
    apply erel_image_elem in H0.
    apply erel_image_elem.
    apply (mk_disc_cases_elem (fintype.fintype_list X) x a a0).
    apply fintype.fintype_complete. auto.
    destruct H0.
    apply erel_image_elem in H1.
    exists x0. split; auto.
    apply erel_image_elem.
    apply (mk_disc_cases_elem (fintype.fintype_list X) x a x0).
    apply fintype.fintype_complete. auto.
  Qed.

  Lemma disc_cases_elem x h : disc_cases ∘ 〈 h, disc_elem x 〉 ≈ f x ∘ h.
  Proof.
    split; intros a H. destruct a.
    apply PLT.compose_hom_rel in H.
    apply PLT.compose_hom_rel.
    destruct H as [q [??]].
    destruct q.
    apply (mk_disc_cases_elem (fintype.fintype_list X)) in H0.
    simpl in H.
    rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c1 c2) in H. destruct H.
    exists c1. split; auto.
    simpl in H1.
    apply single_axiom in H1.
    destruct H1 as [[??][??]]. simpl in *.
    hnf in H2. subst c2. auto.
    apply fintype.fintype_complete.
    destruct a.
    apply PLT.compose_hom_rel in H.
    apply PLT.compose_hom_rel.
    destruct H as [q [??]].
    exists (q,x). split.
    apply PLT.pair_hom_rel. split; auto.
    simpl. apply single_axiom.
    destruct c. auto.
    apply (mk_disc_cases_elem (fintype.fintype_list X)).
    apply fintype.fintype_complete.
    auto.
  Qed.

End disc_cases.
Arguments disc_cases [X A B] f.

Program Definition finbool : fintype :=
  Fintype bool (true::false::nil) _ _.
Next Obligation.
  intros. destruct x; simpl; auto.
Qed.
Next Obligation.
  decide equality.
Qed.

Canonical Structure finbool.

Lemma disc_cases_elem'
     : forall (X : fintype) (A B C : PLT)
       (f : X -> A → B) (g: C → 1) (x : X) (h : C → A),
       disc_cases f ∘ PLT.pair h (disc_elem x ∘ g) ≈ f x ∘ h.
Proof.
  split; intros a H. destruct a.
  apply PLT.compose_hom_rel in H.
  apply PLT.compose_hom_rel.
  destruct H as [q [??]].
  destruct q.
  apply (mk_disc_cases_elem X _ _ f (fintype.fintype_list X)) in H0.
  simpl in H.
  rewrite (PLT.pair_hom_rel _ _ _ _ _ _ c c1 c2) in H. destruct H.
  apply PLT.compose_hom_rel in H1.
  simpl in *.
  destruct H1 as [q [??]].
  apply single_axiom in H2.
  exists c1. split; auto.
  destruct H2 as [[??][??]]. simpl in *.
  hnf in H3. subst c2. auto.
  apply fintype.fintype_complete.
  destruct a.
  apply PLT.compose_hom_rel in H.
  apply PLT.compose_hom_rel.
  destruct H as [q [??]].
  exists (q,x). split.
  apply PLT.pair_hom_rel. split; auto.
  apply PLT.compose_hom_rel.
  exists tt.
  split.
  destruct (PLT.hom_directed false _ _ g c nil); auto.
  hnf; auto. hnf; intros. apply nil_elem in H1. elim H1.
  destruct H1. apply erel_image_elem in H2. destruct x0. auto.
  simpl. apply single_axiom. auto.
  apply (mk_disc_cases_elem X _ _ f (fintype.fintype_list X)).
  apply fintype.fintype_complete.
  auto.
Qed.

Lemma disc_cases_univ (X:fintype) (A B:PLT) (f:X -> A → B) q :
  (forall x, f x ≈ q ∘ 〈 id, disc_elem x ∘ PLT.terminate _ _〉) ->
  disc_cases f ≈ q.
Proof.
  intros. split; hnf; simpl; intros.
  destruct a. destruct p.
  apply (mk_disc_cases_elem X _ _ f (fintype.fintype_list X)) in H0.
  destruct (H c1).
  apply H1 in H0.
  apply PLT.compose_hom_rel in H0.
  destruct H0 as [z [??]].
  destruct z.
  apply (PLT.pair_hom_rel false A _ _ id(A) (disc_elem c1 ∘ PLT.terminate _ _))
     in H0.
  destruct H0.
  apply PLT.compose_hom_rel in H4.
  destruct H4 as [?[??]]. destruct x.
  revert H3. apply PLT.hom_order; auto.
  split; simpl.
  simpl in H0. apply ident_elem in H0. auto.
  simpl in H5. apply single_axiom in H5.
  destruct H5 as [[??][??]]; auto.
  apply fintype.fintype_complete.

  destruct a. destruct p.
  apply (mk_disc_cases_elem X _ _ f (fintype.fintype_list X)); auto.
  apply fintype.fintype_complete.
  assert ((c0,c) ∈ PLT.hom_rel (q ∘ 〈id, disc_elem c1 ∘ PLT.terminate false A〉)).
  apply PLT.compose_hom_rel.
  exists (c0,c1).
  split; auto.
  apply PLT.pair_hom_rel.
  split.
  simpl. apply ident_elem; auto.
  apply PLT.compose_hom_rel.
  exists tt. split; auto.
  simpl. apply eprod_elem.
  split. apply eff_complete.
  apply single_axiom; auto.
  simpl. apply single_axiom. auto.
  destruct (H c1).
  apply H3 in H1.
  auto.
Qed.

Lemma disc_cases_commute : forall (X : fintype) (A B C : PLT)
       (f : X -> A → B) (g:C → A) (h:C → disc X),
       disc_cases f ∘ 〈 g, h 〉 ≈ disc_cases (fun x => f x ∘ g) ∘ 〈 id, h 〉.
Proof.
  intros. transitivity (disc_cases f ∘ PLT.pair_map g id ∘ 〈id,h〉).
  unfold PLT.pair_map.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  rewrite <- (cat_assoc PLT). rewrite PLT.pair_commute1.
  rewrite <- (cat_assoc PLT). rewrite PLT.pair_commute2.
  rewrite (cat_ident2 PLT). rewrite (cat_ident1 PLT). auto.
  apply cat_respects; auto.
  symmetry. apply disc_cases_univ.
  intros.
  unfold PLT.pair_map.
  rewrite <- (cat_assoc PLT).
  rewrite (PLT.pair_compose_commute false).
  rewrite <- (cat_assoc PLT). rewrite PLT.pair_commute1.
  rewrite <- (cat_assoc PLT). rewrite PLT.pair_commute2.
  rewrite (cat_ident1 PLT). rewrite (cat_ident2 PLT).
  symmetry.
  apply disc_cases_elem'.
Qed.


Require Export Proofs.GHC.Base.
Require Export Proofs.GHC.List.
Require Export Proofs.GHC.Enum.

Require Export Proofs.Data.Bits.Popcount.
Require Export Proofs.Data.Either.
Require Export Proofs.Data.Foldable.
Require Export Proofs.Data.OldList.
Require Export Proofs.Data.Ord.
Require Export Proofs.Data.Proxy.
Require Export Proofs.Data.Traversable.
Require Export Proofs.Data.Tuple.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations.
From fourcolor Require Import job235to238 job239to253 job254to270.
From fourcolor Require Import job271to278 job279to282.

(******************************************************************************)
(* Reducibility of configurations number 235 to 282, whose indices in         *)
(* the_configs range over segment [234, 282).                                 *)
(******************************************************************************)

Lemma red234to282 : reducible_in_range 234 282 the_configs.
Proof.
CatReducible red234to238 red238to253 red253to270 red270to278 red278to282.
Qed.


Require Import TestSuite.admit.
(* This failed with an anomaly in pre-8.4 because of let-in not
   properly taken into account in the test for unification pattern *)

Inductive foo : forall A, A -> Prop :=
| foo_intro : forall A x, foo A x.
Lemma bar A B f : foo (A -> B) f -> forall x : A, foo B (f x).
Fail induction 1.

(* Whether these examples should succeed with a non-dependent return predicate
   or fail because there is well-typed return predicate dependent in f
   is questionable. As of 25 oct 2011, they succeed *)
refine (fun p => match p with _ => _ end).
Undo.
refine (fun p => match p with foo_intro _ _ => _ end).
admit.
Qed.


(** * Support for rewriting *)

Require Import HahnBase HahnList HahnRelationsBasic HahnEquational HahnFuneq HahnSets.

Set Implicit Arguments.

(** We add some support for rewriting with [inclusion] and [same_relation]
relations. We start with some basic helper lemmas. *)

Section HelperLemmas.

  Variable A : Type.
  Variables r1 r2 r3 r4 r5 r6 r7 r r' : relation A.

  Lemma hahn_subset_exp (s s' : A -> Prop) :
    s ⊆₁ s' -> forall x, s x -> s' x.
  Proof.
    eauto.
  Qed.

  Lemma hahn_inclusion_exp :
    r ⊆ r' -> forall x y, r x y -> r' x y.
  Proof.
    eauto.
  Qed.

  Lemma seq2 (L : r1 ⨾ r2 ≡ r) s :
    r1 ⨾ r2 ⨾ s ≡ r ⨾ s.
  Proof.
    rewrite <- L, seqA; vauto.
  Qed.

  Lemma seq3 (L : r1 ⨾ r2 ⨾ r3 ≡ r) s :
     r1 ⨾ r2 ⨾ r3 ⨾ s ≡ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma seq4 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ≡ r) s :
     r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ s ≡ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma seq5 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ≡ r) s :
     r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ s ≡ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma seq6 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ r6 ≡ r) s :
     r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ r6 ⨾ s ≡ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma sin2 (L : r1 ⨾ r2 ⊆ r) s :
    r1 ⨾ r2 ⨾ s ⊆ r ⨾ s.
  Proof.
    rewrite <- L, seqA; vauto.
  Qed.

  Lemma sin3 (L : r1 ⨾ r2 ⨾ r3 ⊆ r) s :
    r1 ⨾ r2 ⨾ r3 ⨾ s ⊆ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma sin4 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ⊆ r) s :
    r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ s ⊆ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma sin5 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⊆ r) s :
    r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ s ⊆ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

  Lemma sin6 (L : r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ r6 ⊆ r) s :
    r1 ⨾ r2 ⨾ r3 ⨾ r4 ⨾ r5 ⨾ r6 ⨾ s ⊆ r ⨾ s.
  Proof.
    rewrite <- L, !seqA; vauto.
  Qed.

End HelperLemmas.

(** We proceed with a set of rewrite tactics *)

Tactic Notation "hahnf_rewrite" uconstr(EQ) :=
  match goal with
    | |- _ _ _ => eapply hahn_inclusion_exp; [solve[rewrite EQ; apply inclusion_refl2]|]
    | |- _ _ => eapply hahn_subset_exp; [solve[rewrite EQ; apply set_subset_refl2]|]
    | |- _ => rewrite EQ
  end.

Tactic Notation "hahnf_rewrite" "<-" uconstr(EQ) :=
  match goal with
    | |- _ _ _ => eapply hahn_inclusion_exp; [solve[rewrite <- EQ; apply inclusion_refl2]|]
    | |- _ _ => eapply hahn_subset_exp; [solve[rewrite <- EQ; apply set_subset_refl2]|]
    | |- _ => rewrite <- EQ
  end.

Tactic Notation "hahnf_rewrite" uconstr(EQ) "in" hyp(H) :=
  match type of H with
    | _ _ _ => eapply hahn_inclusion_exp in H; [|solve[rewrite EQ; apply inclusion_refl2]]
    | _ _ => eapply hahn_subset_exp in H; [|solve[rewrite EQ; apply set_subset_refl2]]
    | _ => rewrite EQ in H
  end.

Tactic Notation "hahnf_rewrite" "<-" uconstr(EQ) "in" hyp(H) :=
  match type of H with
    | _ _ _ => eapply hahn_inclusion_exp in H; [|solve[rewrite <- EQ; apply inclusion_refl2]]
    | _ _ => eapply hahn_subset_exp in H; [|solve[rewrite <- EQ; apply set_subset_refl2]]
    | _ => rewrite <- EQ in H
  end.

Tactic Notation "hahn_rewrite" uconstr(EQ) :=
  match goal with
    | |- _ _ _ => eapply hahn_inclusion_exp; [solve [rewrite EQ; apply inclusion_refl2]|]
    | |- _ => rewrite EQ
  end.

Tactic Notation "hahn_rewrite" "<-" uconstr(EQ) :=
  match goal with
    | |- _ _ _ => eapply hahn_inclusion_exp; [solve [rewrite <- EQ; apply inclusion_refl2]|]
    | |- _ => rewrite <- EQ
  end.

Tactic Notation "hahn_rewrite" uconstr(EQ) "in" hyp(H) :=
  match type of H with
    | _ _ _ => eapply hahn_inclusion_exp in H; [|solve [rewrite EQ; apply inclusion_refl2]]
    | _ => rewrite EQ in H
  end.

Tactic Notation "hahn_rewrite" "<-" uconstr(EQ) "in" hyp(H) :=
  match type of H with
    | _ _ _ => eapply hahn_inclusion_exp in H; [|solve [rewrite <- EQ; apply inclusion_refl2]]
    | _ => rewrite <- EQ in H
  end.

Tactic Notation "hahn_seq_rewrite" uconstr(x) :=
  first [ hahn_rewrite x
        | hahn_rewrite (seq2 x)
        | hahn_rewrite (fun a => seq2 (x a))
        | hahn_rewrite (fun a b => seq2 (x a b))
        | hahn_rewrite (fun a b c => seq2 (x a b c))
        | hahn_rewrite (fun a b c d => seq2 (x a b c d))
        | hahn_rewrite (fun a b c d e => seq2 (x a b c d e))
        | hahn_rewrite (fun a b c d e f => seq2 (x a b c d e f))
        | hahn_rewrite (seq3 x)
        | hahn_rewrite (fun a => seq3 (x a))
        | hahn_rewrite (fun a b => seq3 (x a b))
        | hahn_rewrite (fun a b c => seq3 (x a b c))
        | hahn_rewrite (fun a b c d => seq3 (x a b c d))
        | hahn_rewrite (fun a b c d e => seq3 (x a b c d e))
        | hahn_rewrite (fun a b c d e f => seq3 (x a b c d e f))
        | hahn_rewrite (seq4 x)
        | hahn_rewrite (fun a => seq4 (x a))
        | hahn_rewrite (fun a b => seq4 (x a b))
        | hahn_rewrite (fun a b c => seq4 (x a b c))
        | hahn_rewrite (fun a b c d => seq4 (x a b c d))
        | hahn_rewrite (fun a b c d e => seq4 (x a b c d e))
        | hahn_rewrite (fun a b c d e f => seq4 (x a b c d e f))
        | hahn_rewrite (seq5 x)
        | hahn_rewrite (fun a => seq5 (x a))
        | hahn_rewrite (fun a b => seq5 (x a b))
        | hahn_rewrite (fun a b c => seq5 (x a b c))
        | hahn_rewrite (fun a b c d => seq5 (x a b c d))
        | hahn_rewrite (fun a b c d e => seq5 (x a b c d e))
        | hahn_rewrite (fun a b c d e f => seq5 (x a b c d e f))
        | hahn_rewrite (seq6 x)
        | hahn_rewrite (fun a => seq6 (x a))
        | hahn_rewrite (fun a b => seq6 (x a b))
        | hahn_rewrite (fun a b c => seq6 (x a b c))
        | hahn_rewrite (fun a b c d => seq6 (x a b c d))
        | hahn_rewrite (fun a b c d e => seq6 (x a b c d e))
        | hahn_rewrite (fun a b c d e f => seq6 (x a b c d e f))
        ].

Tactic Notation "seq_rewrite" uconstr(x) :=
  first [ rewrite x
        | rewrite (seq2 x)
        | rewrite (fun a => seq2 (x a))
        | rewrite (fun a b => seq2 (x a b))
        | rewrite (fun a b c => seq2 (x a b c))
        | rewrite (fun a b c d => seq2 (x a b c d))
        | rewrite (fun a b c d e => seq2 (x a b c d e))
        | rewrite (fun a b c d e f => seq2 (x a b c d e f))
        | rewrite (seq3 x)
        | rewrite (fun a => seq3 (x a))
        | rewrite (fun a b => seq3 (x a b))
        | rewrite (fun a b c => seq3 (x a b c))
        | rewrite (fun a b c d => seq3 (x a b c d))
        | rewrite (fun a b c d e => seq3 (x a b c d e))
        | rewrite (fun a b c d e f => seq3 (x a b c d e f))
        | rewrite (seq4 x)
        | rewrite (fun a => seq4 (x a))
        | rewrite (fun a b => seq4 (x a b))
        | rewrite (fun a b c => seq4 (x a b c))
        | rewrite (fun a b c d => seq4 (x a b c d))
        | rewrite (fun a b c d e => seq4 (x a b c d e))
        | rewrite (fun a b c d e f => seq4 (x a b c d e f))
        | rewrite (seq5 x)
        | rewrite (fun a => seq5 (x a))
        | rewrite (fun a b => seq5 (x a b))
        | rewrite (fun a b c => seq5 (x a b c))
        | rewrite (fun a b c d => seq5 (x a b c d))
        | rewrite (fun a b c d e => seq5 (x a b c d e))
        | rewrite (fun a b c d e f => seq5 (x a b c d e f))
        | rewrite (seq6 x)
        | rewrite (fun a => seq6 (x a))
        | rewrite (fun a b => seq6 (x a b))
        | rewrite (fun a b c => seq6 (x a b c))
        | rewrite (fun a b c d => seq6 (x a b c d))
        | rewrite (fun a b c d e => seq6 (x a b c d e))
        | rewrite (fun a b c d e f => seq6 (x a b c d e f))
        ].

Tactic Notation "hahn_seq_rewrite" "<-" uconstr(x) :=
  first [ hahn_rewrite <- x
        | hahn_rewrite (seq2 (same_relation_sym x))
        | hahn_rewrite (seq2 (same_relation_sym (x _)))
        | hahn_rewrite (seq2 (same_relation_sym (x _ _)))
        | hahn_rewrite (seq2 (same_relation_sym (x _ _ _)))
        | hahn_rewrite (seq2 (same_relation_sym (x _ _ _ _)))
        | hahn_rewrite (seq2 (same_relation_sym (x _ _ _ _ _)))
        | hahn_rewrite (fun a => seq2 (same_relation_sym (x a)))
        | hahn_rewrite (fun a b => seq2 (same_relation_sym (x a b)))
        | hahn_rewrite (fun a b c => seq2 (same_relation_sym (x a b c)))
        | hahn_rewrite (fun a b c d => seq2 (same_relation_sym (x a b c d)))
        | hahn_rewrite (fun a b c d e => seq2 (same_relation_sym (x a b c d e)))
        | hahn_rewrite (fun a b c d e f => seq2 (same_relation_sym (x a b c d e f)))
        | hahn_rewrite (seq3 (same_relation_sym x))
        | hahn_rewrite (fun a => seq3 (same_relation_sym (x a)))
        | hahn_rewrite (fun a b => seq3 (same_relation_sym (x a b)))
        | hahn_rewrite (fun a b c => seq3 (same_relation_sym (x a b c)))
        | hahn_rewrite (fun a b c d => seq3 (same_relation_sym (x a b c d)))
        | hahn_rewrite (fun a b c d e => seq3 (same_relation_sym (x a b c d e)))
        | hahn_rewrite (fun a b c d e f => seq3 (same_relation_sym (x a b c d e f)))
        | hahn_rewrite (seq4 (same_relation_sym x))
        | hahn_rewrite (fun a => seq4 (same_relation_sym (x a)))
        | hahn_rewrite (fun a b => seq4 (same_relation_sym (x a b)))
        | hahn_rewrite (fun a b c => seq4 (same_relation_sym (x a b c)))
        | hahn_rewrite (fun a b c d => seq4 (same_relation_sym (x a b c d)))
        | hahn_rewrite (fun a b c d e => seq4 (same_relation_sym (x a b c d e)))
        | hahn_rewrite (fun a b c d e f => seq4 (same_relation_sym (x a b c d e f)))
        | hahn_rewrite (seq5 (same_relation_sym x))
        | hahn_rewrite (fun a => seq5 (same_relation_sym (x a)))
        | hahn_rewrite (fun a b => seq5 (same_relation_sym (x a b)))
        | hahn_rewrite (fun a b c => seq5 (same_relation_sym (x a b c)))
        | hahn_rewrite (fun a b c d => seq5 (same_relation_sym (x a b c d)))
        | hahn_rewrite (fun a b c d e => seq5 (same_relation_sym (x a b c d e)))
        | hahn_rewrite (fun a b c d e f => seq5 (same_relation_sym (x a b c d e f)))
        | hahn_rewrite (seq6 (same_relation_sym x))
        | hahn_rewrite (fun a => seq6 (same_relation_sym (x a)))
        | hahn_rewrite (fun a b => seq6 (same_relation_sym (x a b)))
        | hahn_rewrite (fun a b c => seq6 (same_relation_sym (x a b c)))
        | hahn_rewrite (fun a b c d => seq6 (same_relation_sym (x a b c d)))
        | hahn_rewrite (fun a b c d e => seq6 (same_relation_sym (x a b c d e)))
        | hahn_rewrite (fun a b c d e f => seq6 (same_relation_sym (x a b c d e f)))
        ].

Tactic Notation "seq_rewrite" "<-" uconstr(x) :=
  first [ rewrite <- x
        | rewrite (seq2 (same_relation_sym x))
        | rewrite (seq2 (same_relation_sym (x _)))
        | rewrite (seq2 (same_relation_sym (x _ _)))
        | rewrite (seq2 (same_relation_sym (x _ _ _)))
        | rewrite (seq2 (same_relation_sym (x _ _ _ _)))
        | rewrite (seq2 (same_relation_sym (x _ _ _ _ _)))
        | rewrite (fun a => seq2 (same_relation_sym (x a)))
        | rewrite (fun a b => seq2 (same_relation_sym (x a b)))
        | rewrite (fun a b c => seq2 (same_relation_sym (x a b c)))
        | rewrite (fun a b c d => seq2 (same_relation_sym (x a b c d)))
        | rewrite (fun a b c d e => seq2 (same_relation_sym (x a b c d e)))
        | rewrite (fun a b c d e f => seq2 (same_relation_sym (x a b c d e f)))
        | rewrite (seq3 (same_relation_sym x))
        | rewrite (fun a => seq3 (same_relation_sym (x a)))
        | rewrite (fun a b => seq3 (same_relation_sym (x a b)))
        | rewrite (fun a b c => seq3 (same_relation_sym (x a b c)))
        | rewrite (fun a b c d => seq3 (same_relation_sym (x a b c d)))
        | rewrite (fun a b c d e => seq3 (same_relation_sym (x a b c d e)))
        | rewrite (fun a b c d e f => seq3 (same_relation_sym (x a b c d e f)))
        | rewrite (seq4 (same_relation_sym x))
        | rewrite (fun a => seq4 (same_relation_sym (x a)))
        | rewrite (fun a b => seq4 (same_relation_sym (x a b)))
        | rewrite (fun a b c => seq4 (same_relation_sym (x a b c)))
        | rewrite (fun a b c d => seq4 (same_relation_sym (x a b c d)))
        | rewrite (fun a b c d e => seq4 (same_relation_sym (x a b c d e)))
        | rewrite (fun a b c d e f => seq4 (same_relation_sym (x a b c d e f)))
        | rewrite (seq5 (same_relation_sym x))
        | rewrite (fun a => seq5 (same_relation_sym (x a)))
        | rewrite (fun a b => seq5 (same_relation_sym (x a b)))
        | rewrite (fun a b c => seq5 (same_relation_sym (x a b c)))
        | rewrite (fun a b c d => seq5 (same_relation_sym (x a b c d)))
        | rewrite (fun a b c d e => seq5 (same_relation_sym (x a b c d e)))
        | rewrite (fun a b c d e f => seq5 (same_relation_sym (x a b c d e f)))
        | rewrite (seq6 (same_relation_sym x))
        | rewrite (fun a => seq6 (same_relation_sym (x a)))
        | rewrite (fun a b => seq6 (same_relation_sym (x a b)))
        | rewrite (fun a b c => seq6 (same_relation_sym (x a b c)))
        | rewrite (fun a b c d => seq6 (same_relation_sym (x a b c d)))
        | rewrite (fun a b c d e => seq6 (same_relation_sym (x a b c d e)))
        | rewrite (fun a b c d e f => seq6 (same_relation_sym (x a b c d e f)))
        ].

Tactic Notation "seq_rewrite" "!" uconstr(x) :=
  seq_rewrite x; repeat seq_rewrite x.

Tactic Notation "seq_rewrite" "?" uconstr(x) :=
  repeat seq_rewrite x.

Tactic Notation "seq_rewrite" "<-" "!" uconstr(x) :=
  seq_rewrite <- x; repeat seq_rewrite <- x.

Tactic Notation "seq_rewrite" "<-" "?" uconstr(x) :=
  repeat seq_rewrite <- x.

Tactic Notation "sin_rewrite" uconstr(x) :=
  first [ rewrite x at 1
        | rewrite (sin2 x) at 1
        | rewrite (fun a => sin2 (x a)) at 1
        | rewrite (fun a b => sin2 (x a b)) at 1
        | rewrite (fun a b c => sin2 (x a b c)) at 1
        | rewrite (fun a b c d => sin2 (x a b c d)) at 1
        | rewrite (fun a b c d e => sin2 (x a b c d e)) at 1
        | rewrite (fun a b c d e f => sin2 (x a b c d e f)) at 1
        | rewrite (sin3 x) at 1
        | rewrite (fun a => sin3 (x a)) at 1
        | rewrite (fun a b => sin3 (x a b)) at 1
        | rewrite (fun a b c => sin3 (x a b c)) at 1
        | rewrite (fun a b c d => sin3 (x a b c d)) at 1
        | rewrite (fun a b c d e => sin3 (x a b c d e)) at 1
        | rewrite (fun a b c d e f => sin3 (x a b c d e f)) at 1
        | rewrite (sin4 x) at 1
        | rewrite (fun a => sin4 (x a)) at 1
        | rewrite (fun a b => sin4 (x a b)) at 1
        | rewrite (fun a b c => sin4 (x a b c)) at 1
        | rewrite (fun a b c d => sin4 (x a b c d)) at 1
        | rewrite (fun a b c d e => sin4 (x a b c d e)) at 1
        | rewrite (fun a b c d e f => sin4 (x a b c d e f)) at 1
        | rewrite (sin5 x) at 1
        | rewrite (fun a => sin5 (x a)) at 1
        | rewrite (fun a b => sin5 (x a b)) at 1
        | rewrite (fun a b c => sin5 (x a b c)) at 1
        | rewrite (fun a b c d => sin5 (x a b c d)) at 1
        | rewrite (fun a b c d e => sin5 (x a b c d e)) at 1
        | rewrite (fun a b c d e f => sin5 (x a b c d e f)) at 1
        | rewrite (sin6 x) at 1
        | rewrite (fun a => sin6 (x a)) at 1
        | rewrite (fun a b => sin6 (x a b)) at 1
        | rewrite (fun a b c => sin6 (x a b c)) at 1
        | rewrite (fun a b c d => sin6 (x a b c d)) at 1
        | rewrite (fun a b c d e => sin6 (x a b c d e)) at 1
        | rewrite (fun a b c d e f => sin6 (x a b c d e f)) at 1
        ].

Tactic Notation "sin_rewrite" "!" uconstr(x) :=
  sin_rewrite x; repeat sin_rewrite x.

Tactic Notation "sin_rewrite" "?" uconstr(x) :=
  repeat sin_rewrite x.

Lemma rewrite_trans A (r: relation A) :
  transitive r -> r ⨾ r ⊆ r.
Proof.
  unfold inclusion, seq; ins; desf; eauto.
Qed.

Lemma rewrite_trans_seq_cr_l A (r: relation A) :
  transitive r -> r^? ⨾ r ⊆ r.
Proof.
  unfold inclusion, seq, clos_refl; ins; desf; eauto.
Qed.

Lemma rewrite_trans_seq_cr_r A (r: relation A) :
  transitive r -> r ⨾ r^? ⊆ r.
Proof.
  unfold inclusion, seq, clos_refl; ins; desf; eauto.
Qed.

Lemma rewrite_trans_seq_cr_cr A (r: relation A) :
  transitive r -> r^? ⨾ r^? ⊆ r^?.
Proof.
  unfold inclusion, seq, clos_refl; ins; desf; eauto.
Qed.

Lemma transitiveI A (r: relation A) :
  inclusion (r ⨾ r) r <-> transitive r.
Proof.
  red; splits; unfold transitive, inclusion, seq; ins; desf; eauto.
Qed.

Ltac simpl_rels :=
  rewrite ?eqv_empty, ?seq_false_l, ?seq_false_r, ?seq_id_l, ?seq_id_r, ?seqA; seq_rewrite ? seq_eqvK.

Ltac rels :=
  repeat first [progress autorewrite with hahn |
                seq_rewrite seq_eqvK |
                seq_rewrite ct_cr | seq_rewrite ct_rt |
                seq_rewrite rt_cr | seq_rewrite rt_ct | seq_rewrite rt_rt |
                seq_rewrite cr_ct | seq_rewrite cr_rt |
                seq_rewrite <- ct_end | seq_rewrite <- ct_begin ];
    try done; eauto 3 with hahn.

Ltac relsf :=
  repeat first [progress autorewrite with hahn |
                seq_rewrite seq_eqvK |
                seq_rewrite ct_cr | seq_rewrite ct_rt |
                seq_rewrite rt_cr | seq_rewrite rt_ct | seq_rewrite rt_rt |
                seq_rewrite cr_ct | seq_rewrite cr_rt |
                match goal with H: transitive _ |- _ =>
                  progress repeat first [rewrite (ct_of_trans H) |
                                rewrite (rt_of_trans H) |
                                sin_rewrite (rewrite_trans H) |
                                sin_rewrite (rewrite_trans_seq_cr_l H) |
                                sin_rewrite (rewrite_trans_seq_cr_r H) |
                                sin_rewrite (rewrite_trans_seq_cr_cr H) ] end |
                progress autorewrite with hahn hahn_full ];
    try done; eauto 3 with hahn.

Global Hint Resolve eq_in_l eq_in_r rt_rt ct_rt rt_ct cr_ct ct_cr cr_rt rt_cr ct_begin ct_end : hahn_full.
Global Hint Resolve inclusion_seq_eqv_r inclusion_seq_eqv_l clos_rt_idempotent inclusion_t_rt : hahn_full.
Global Hint Resolve inclusion_eqv_rel_true inclusion_minus_rel rewrite_trans : hahn_full.

Global Hint Resolve pow_rel_mori : hahn.

(** Helpful tactics for inclusions *)

Ltac apply_unionL_once :=
  first [apply irreflexive_union; split |
         apply inclusion_union_l | apply inclusion_bunion_l; intros |
         apply set_subset_union_l; split | apply set_subset_bunion_l; intros].

Tactic Notation "unionL" := repeat apply_unionL_once.

Tactic Notation "unionR" tactic(dir) :=
  first [apply inclusion_union_r | apply set_subset_union_r]; dir.

Tactic Notation "unionR" tactic(dir) "->" tactic(dir') :=
  unionR dir; unionR dir'.

Tactic Notation "unionR" tactic(dir) "->" tactic(dir') "->" tactic(dir'') :=
  unionR dir; unionR dir'; unionR dir''.

Tactic Notation "unionR" tactic(dir) "->" tactic(dir') "->" tactic(dir'') "->" tactic(dir''') :=
  unionR dir; unionR dir'; unionR dir''; unionR dir'''.

Ltac hahn_rel :=
  rels;
  try match goal with |- (_ ≡ _) => split end;
  unionL; eauto 8 with hahn.

Ltac hahn_frame_r :=
  rewrite <- ?seqA; apply inclusion_seq_mon; [|reflexivity]; rewrite ?seqA.

Ltac hahn_frame_l :=
  rewrite ?seqA; apply inclusion_seq_mon; [reflexivity|].

Ltac hahn_frame :=
  rewrite <- ?seqA;
  repeat (
      match goal with
      | |- inclusion _ (_ ⨾ clos_refl_trans _) => fail 1
      | |- inclusion _ (_ ⨾ clos_trans _) => fail 1
      | |- _ => apply inclusion_seq_mon; [|reflexivity]
      end);
  rewrite ?seqA;
  repeat (
      match goal with
      | |- inclusion _ (clos_refl_trans _ ⨾ _) => fail 1
      | |- inclusion _ (clos_trans _ ⨾ _) => fail 1
      | |- _ => apply inclusion_seq_mon; [reflexivity|]
      end);
  try solve [ apply inclusion_seq_l; try done; auto with hahn
            | apply inclusion_seq_r; try done; auto with hahn].

(** Rewrite with proof search *)

Tactic Notation "arewrite" uconstr(EQ) :=
  let H := fresh in
  first [assert (H: EQ) |
    let typ1 := fresh in let binder1 := fresh in
    evar (typ1 : Type); evar (binder1 : typ1);
    first [assert (H: EQ binder1); subst binder1 typ1 |
      let typ2 := fresh in let binder2 := fresh in
      evar (typ2 : Type); evar (binder2 : typ2);
      assert (H: EQ binder1 binder2); subst binder1 typ1 binder2 typ2]]; cycle 1;
  [ first [seq_rewrite H|sin_rewrite H]; clear H; rewrite ?seqA
  | eauto 4 with hahn hahn_full; try done ]; cycle 1.

Tactic Notation "arewrite" uconstr(EQ) "at" int_or_var(index) :=
  let H := fresh in
  assert (H : EQ); [eauto 4 with hahn hahn_full; try done|
                    rewrite H at index; clear H; rewrite ?seqA].

Tactic Notation "arewrite" uconstr(EQ) "by" tactic(t) :=
  let H := fresh in
    assert (H: EQ) by (by t; eauto with hahn hahn_full);
    first [seq_rewrite H|sin_rewrite H]; clear H; rewrite ?seqA; try done.

Tactic Notation "arewrite" uconstr(EQ) "at" int_or_var(index) "by" tactic(t) :=
  let H := fresh in
    assert (H : EQ) by (by t; eauto with hahn hahn_full);
    rewrite H at index; clear H; rewrite ?seqA; try done.

Tactic Notation "arewrite" "!" uconstr(EQ) :=
  let H := fresh in
  first [assert (H: EQ) |
    let typ1 := fresh in let binder1 := fresh in
    evar (typ1 : Type); evar (binder1 : typ1);
    first [assert (H: EQ binder1); subst binder1 typ1 |
      let typ2 := fresh in let binder2 := fresh in
      evar (typ2 : Type); evar (binder2 : typ2);
      assert (H: EQ binder1 binder2); subst binder1 typ1 binder2 typ2]]; cycle 1;
  [ first [seq_rewrite !H|sin_rewrite !H]; clear H; rewrite ?seqA
  | eauto 4 with hahn hahn_full; try done ]; cycle 1.

Tactic Notation "arewrite_false" constr(exp) :=
  arewrite (exp ≡ fun _ _ => False); [split;[|vauto]|].
Tactic Notation "arewrite_false" "!" constr(exp) :=
  arewrite !(exp ≡ fun _ _ => False); [split;[|vauto]|].
Tactic Notation "arewrite_false" constr(exp) "at" int_or_var(index) :=
  arewrite (exp ≡ fun _ _ => False) at index; [split;[|vauto]|].
Tactic Notation "arewrite_id" constr(exp) :=
  arewrite (exp ⊆ ⦗fun _ => True⦘).
Tactic Notation "arewrite_id" "!" constr(exp) :=
  arewrite !(exp ⊆ ⦗fun _ => True⦘).
Tactic Notation "arewrite_id" constr(exp) "at" int_or_var(index) :=
  arewrite (exp ⊆ ⦗fun _ => True⦘) at index.

(** Unfolding of relational operations **)

Tactic Notation "unfolder_prepare" :=
  rewrite ?seqA;
  repeat hahn_rewrite seq_eqv;
  repeat hahn_seq_rewrite seq_eqv;
  repeat hahn_rewrite seq_eqv_lr;
  repeat hahn_rewrite seq_eqv_r;
  repeat hahn_rewrite seq_eqv_l;
  repeat hahn_rewrite <- id_union.

Tactic Notation "unfolder_prepare"  "in" hyp(H) :=
  rewrite ?seqA in H;
  repeat hahn_rewrite seq_eqv in H;
  repeat hahn_rewrite seq_eqv_lr in H;
  repeat hahn_rewrite seq_eqv_r in H;
  repeat hahn_rewrite seq_eqv_l in H;
  repeat hahn_rewrite <- id_union in H.

Tactic Notation "unfolder" :=
  unfolder_prepare; repeat autounfold with unfolderDb.

Tactic Notation "unfolder" "in" hyp(H) :=
  unfolder_prepare in H; autounfold with unfolderDb in H.

Tactic Notation "unfolder" "in" "*" "|-" :=
  repeat match goal with | [H:_ |- _] => progress unfolder in H
end.

Tactic Notation "unfolder" "in" "*" :=
  unfolder; unfolder in * |-.

(** basic_solver tactic **)
Tactic Notation "basic_solver" int_or_var(index) :=
  by ( rewrite ?rtE; unfolder; splits; ins; desf; eauto index; done).

Tactic Notation "basic_solver" :=
  basic_solver 4.

(** Case analysis *)

Tactic Notation "case_union"  uconstr(x) uconstr(y) :=
  first [rewrite seq_union_l with (r1 := x) (r2 := y)
        |rewrite seq_union_r with (r1 := x) (r2 := y)].

Tactic Notation "case_union_2"  uconstr(x) uconstr(y) :=
  simpl_rels;
  (repeat(
    case_union x y +
    case_union x (y ⨾ _) +
    case_union x (_ ⨾ y) +
    case_union x (_ ⨾ y ⨾ _) +
    case_union x (_ ⨾ _ ⨾ y) +
    case_union x (_ ⨾ _ ⨾ y ⨾ _) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ y) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ y ⨾ _) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ y) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ y ⨾ _) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ y) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ y ⨾ _) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ y) +
    case_union x (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ y ⨾ _) +
    case_union (x ⨾ _) y +
    case_union (_ ⨾ x) y +
    case_union (_ ⨾ x ⨾ _) y +
    case_union (_ ⨾ _ ⨾ x) y +
    case_union (_ ⨾ _ ⨾ x ⨾ _) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ x) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ x ⨾ _) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ x) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ x ⨾ _) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ x) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ x ⨾ _) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ x) y +
    case_union (_ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ _ ⨾ x ⨾ _) y
  ); unionL; [simpl_rels|]).

Tactic Notation "case_union_3" uconstr(x) uconstr(y) uconstr(z) :=
  simpl_rels; case_union_2 _ z; [case_union_2 x y|].

Tactic Notation "case_union_4" uconstr(x) uconstr(y) uconstr(z) uconstr(w) :=
  simpl_rels; case_union_2 _ w; [case_union_3 x y z|].

Tactic Notation "case_union_5" uconstr(x) uconstr(y) uconstr(z) uconstr(w) uconstr(t) :=
  simpl_rels; case_union_2 _ t; [case_union_4 x y z w|].

Tactic Notation "case_refl"  uconstr(x) "at" int(index) :=
  simpl_rels; rewrite crE with (r := x) at index; case_union_2 _ x.

Tactic Notation "case_refl"  uconstr(x) := case_refl x at 1.