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

Require Import List Arith Bool Lia Eqdep_dec.

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

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

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

Set Implicit Arguments.

(* * Decidability of FSAT for monadic signatures *)

Local Notation ø := vec_nil.

Section Σ1_model.

  Variable (V : Type) (n : nat) (HV : V -> False).

  Definition ΣP1 : fo_signature.
  Proof using V n.
    exists V (pos n); intros _.
    + exact 1.
    + exact 1.
  Defined.

  Variable (X : Type) (M : fo_model ΣP1 X) (HX : finite_t X) (Mdec : fo_model_dec M).

  (* We simulate X with a model over bool^n -> bool *)

  Let f p (x : X) := if Mdec (r := p) (x##ø) then true else false.

  Let Q (v : vec bool n) := exists x, forall p, f p x = vec_pos v p.

  Let Q_dec v : { Q v } + { ~ Q v }.
  Proof.
    unfold Q.
    apply (fol_quant_sem_dec fol_ex); auto; intros x.
    apply (fol_quant_sem_dec fol_fa); auto.
    + apply finite_t_pos.
    + intro; apply bool_dec.
  Qed.

  Let K v := if Q_dec v then true else false.

  Let HK v : K v = true <-> Q v.
  Proof.
    unfold K.
    destruct (Q_dec v); split; try tauto; discriminate.
  Qed.

  Let Kf x : K (vec_set_pos (fun p => f p x)) = true.
  Proof.
    apply HK; exists x; intros; rew vec.
  Qed.

  Let M' : fo_model ΣP1 (sig (fun v => K v = true)).
  Proof.
    split.
    + intros s; destruct (HV s).
    + simpl; intros p v.
      exact (vec_pos (proj1_sig (vec_head v)) p = true).
  Defined.

  Let R : @fo_simulation ΣP1 nil (pos_list n) _ M _ M'.
  Proof.
    exists (fun x v => forall p, f p x = vec_pos (proj1_sig v) p).
    + intros s; destruct (HV s).
    + intros p; simpl; intros v w _ H.
      generalize (H pos0); simpl; clear H.
      vec split v with x; vec nil v; clear v.
      vec split w with y; vec nil w; clear w.
      destruct y as [ v Hv ]; simpl; intros Hx.
      generalize (Hx p); unfold f; clear Hx.
      destruct (Mdec (x##ø)); split; try easy.
      intros E; rewrite E in *; discriminate.
    + intros x.
      exists (exist _ (vec_set_pos (fun p => f p x)) (Kf x)); intros p; simpl; rew vec.
    + intros (v & Hv).
      unfold K in Hv; simpl; auto.
      destruct (Q_dec v); auto; discriminate.
  Defined.

  Variable rho : nat -> X.

  Let psi n : sig (fun v => K v = true) := exist _ _ (Kf (rho n)).

  Let equiv (A : fol_form ΣP1) : fol_sem M rho A <-> fol_sem M' psi A.
  Proof.
    apply fo_model_simulation with (R := R).
    + intros s; destruct (HV s).
    + intros p _; apply pos_list_prop.
    + intros i _ p; unfold psi, R; simpl; rew vec.
  Qed.

  Variable (A : fol_form ΣP1) (HA : fol_sem M rho A).

  Local Theorem bounded_model : exists (Q : vec bool n -> bool)
                                 (M' : fo_model ΣP1 (sig (fun v => Q v = true)))
                                 (_ : fo_model_dec M') psi,
                                 fol_sem M' psi A.
  Proof using Mdec HX HA HV.
    exists K, M'.
    exists.
    { unfold M'; intros p v; simpl; apply bool_dec. }
    exists psi; apply equiv, HA.
  Qed.

End Σ1_model.

(* A monadic FO formula which has a model also has
    a model over base type X which is a decidable subtype of bool^n
    where n bound the number of unary predicates *)

Theorem Monadic_model_bounded n V (A : fol_form (ΣP1 V n)) :
           (V -> False)
        -> fo_form_fin_dec_SAT A
        -> exists (b : vec bool n -> bool),
                  fo_form_fin_dec_SAT_in A (sig (fun v => b v = true)).
Proof.
  intros HV (X & M & H1 & H2 & phi & H3).
  destruct bounded_model with (1 := HV) (4 := H3)
    as (Q & M' & G2 & psi & G3); auto.
  exists Q, M'.
  exists.
  { apply finite_t_sig_bool, finite_t_vec, finite_t_bool. }
  exists G2, psi; auto.
Qed.

(* Monadic FO logic with n unary rels and no function symbols
    has a decidable FSAT *)

Theorem FSAT_ΣP1_dec n V (A : fol_form (ΣP1 V n)) : (V -> False) -> decidable (fo_form_fin_dec_SAT A).
Proof.
  intros HV.
  assert (H : decidable (exists P : vec bool n -> bool, fo_form_fin_dec_SAT_in A (sig (fun v => P v = true)))).
  { apply ex_fun_bool_decidable.
    + apply finite_t_vec, finite_t_bool.
    + intros v w; apply vec_eq_dec, bool_dec.
    + intros P Q H; apply FSAT_in_ext; intro; rewrite H; tauto.
    + intro; apply FSAT_in_dec; simpl.
      * intros s; destruct (HV s).
      * red; apply pos_eq_dec.
      * apply finite_t_sig_bool, finite_t_vec, finite_t_bool.
      * intros (x & Hx) (y & Hy).
        destruct (vec_eq_dec bool_dec x y) as [ H | H ].
        - subst; left; f_equal; apply eq_bool_pirr.
        - right; contradict H; inversion H; auto. }
  destruct H as [ H | H ].
  + left.
    destruct H as (P & HP).
    exists { v | P v = true }; auto.
  + right; intros (X & HX).
    apply H, Monadic_model_bounded; auto; exists X; auto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
Unset Printing Notations.
Set Printing Implicit.
Require Import Arith.
From QuickChick Require Import QuickChick.
Inductive natural : Type := Succ : natural -> natural |  Zero : natural.
Derive Show for natural. Derive Arbitrary for natural.  Instance Dec_Eq_natural : Dec_Eq natural. Proof. dec_eq. Qed.
Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint eqb (n m: natural) : bool :=
  match n, m with
    | Zero, Zero => true
    | Zero, Succ _ => false
    | Succ _, Zero => false
    | Succ n', Succ m' => eqb n' m'
  end.

  Fixpoint mem  (mem_arg1 : lst) (mem_arg0 : natural)
  := match mem_arg0, mem_arg1 with
    | x, Nil => false
    | x, Cons y z => orb (eqb x y) (mem z x)
    end.

Fixpoint append (append_arg0 : lst) (append_arg1 : lst) : lst
           := match append_arg0, append_arg1 with
              | Nil, x => x
              | Cons x y, z => Cons x (append y z)
              end.

              Definition lst_mem (lst_mem_arg0 : natural) (lst_mem_arg1 : lst) : bool
              := match lst_mem_arg0, lst_mem_arg1 with
                 | n, x => mem x n
                 end.

   Fixpoint lst_subset (lst_subset_arg0 : lst) (lst_subset_arg1 : lst) : bool
              := match lst_subset_arg0, lst_subset_arg1 with
                 | Nil, x => true
                 | Cons n x, y => andb (lst_subset x y) (lst_mem n y )
                 end.

   Definition lst_eq (lst_eq_arg0 : lst) (lst_eq_arg1 : lst) : bool
              := match lst_eq_arg0, lst_eq_arg1 with
                 | x, y => andb (lst_subset x y) (lst_subset y x)
                 end.

Fixpoint lst_intersection (lst_intersection_arg0 : lst) (lst_intersection_arg1 : lst) : lst
           := match lst_intersection_arg0, lst_intersection_arg1 with
              | Nil, x => Nil
              | Cons n x, y => if lst_mem n y then Cons n (lst_intersection x y) else lst_intersection x y
              end.

Lemma Nat_beq_refl : forall (n : natural), eqb n n = true.
Proof.
  intros.
  induction n.
  - auto.
  - reflexivity.

Qed.

Lemma append_single : forall (x : lst) (n : natural), Cons n x = append (Cons n Nil) x.
Proof.
  reflexivity.
Qed.

Lemma mem_append : forall (n : natural) (x y : lst), lst_mem n x = true -> lst_mem n (append y x) = true.
Proof.
  intros.
  induction y.
  - simpl. rewrite IHy. apply Bool.orb_true_r.
  - simpl. assumption.

Qed.

Lemma subset_append_general : forall (x y z : lst), lst_subset x y = true -> lst_subset x (append z y) = true.
Proof.
  intros.
  induction x.
  - simpl. simpl in H. apply Bool.andb_true_iff in H. destruct H. apply IHx in H. apply Bool.andb_true_iff. split.
    + assumption.
    +
    rewrite mem_append. split.
      * assumption.
- reflexivity.
Qed.

Theorem theorem0 : forall (x : lst) (y : lst), lst_subset x y = true -> lst_eq (lst_intersection x y) x = true.
Proof.
  intros.
  induction x.
  - simpl. simpl in H. apply Bool.andb_true_iff in H. destruct H. rewrite H0. apply IHx in H. unfold lst_eq in H.
  apply Bool.andb_true_iff in H. destruct H. unfold lst_eq. apply Bool.andb_true_iff. split.
    + simpl. apply Bool.andb_true_iff. split.
      *
      rewrite append_single. apply subset_append_general. assumption.
      *
      rewrite Nat_beq_refl. reflexivity.
    + simpl. apply Bool.andb_true_iff. split.
      *
      rewrite append_single. apply subset_append_general. assumption.
      *
      lfind. Admitted.


Require Import ZArith.
Require Import hddivsteps590.
Require Import hddivsteps_def.
Require Import hddivsteps_theory.

Theorem hddivsteps590_gcd : forall f g,
  Z.Odd f ->
  (f <= 0x101c840faed222b9ef3bfe933011b277f84ee3d3f6dc8b496d8cd75b8315afec2)%Z ->
  (0 <= g <= f)%Z ->
  Znumtheory.Zis_gcd f g
    (hddivsteps.f (N.iter 590 hddivsteps.step (hddivsteps.init f g))).
Proof.
intros f g Hf HM Hg.
eapply processDivstep_gcd; try assumption; try apply HM.
apply example590.
Qed.

Check hddivsteps590_gcd.
Print Assumptions hddivsteps590_gcd.

Theorem hddivsteps590_inverse : forall f g,
  Z.Odd f ->
  (f <= 0x101c840faed222b9ef3bfe933011b277f84ee3d3f6dc8b496d8cd75b8315afec2)%Z ->
  (0 <= g <= f)%Z ->
  Znumtheory.rel_prime f g ->
  let st := N.iter 590 hddivsteps.step (hddivsteps.init f g) in
  Z.abs (hddivsteps.f st) = 1%Z /\
   eqm f ((hddivsteps.d st * hddivsteps.f st) * g) 1.
Proof.
intros f g Hf HM Hg Hprime.
eapply processDivstep_inverse; try assumption; try apply HM.
apply example590.
Qed.

Check hddivsteps590_inverse.
Print Assumptions hddivsteps590_inverse.

Theorem hddivsteps590_prime_inverse : forall f g,
  Z.Odd f ->
  Znumtheory.prime f ->
  (g < f <= 0x101c840faed222b9ef3bfe933011b277f84ee3d3f6dc8b496d8cd75b8315afec2)%Z ->
  let st := N.iter 590 hddivsteps.step (hddivsteps.init f g) in
  (g = 0 -> hddivsteps.d st = 0)%Z /\
  (0 < g -> Z.abs (hddivsteps.f st) = 1 /\
            eqm f ((hddivsteps.d st * hddivsteps.f st) * g) 1)%Z.
Proof.
intros f g Hf Hprime HM Hg.
eapply processDivstep_prime_inverse; try assumption; try apply HM.
apply example590.
Qed.

Check hddivsteps590_prime_inverse.
Print Assumptions hddivsteps590_prime_inverse.


(**************************************************************************
* TLC: A library for Coq                                                  *
* Sum of Data Structures                                                  *
**************************************************************************)

Set Implicit Arguments.
Require Import LibTactics LibLogic LibBool.
Generalizable Variables A B.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Sum type *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Definition *)

(** From the Prelude:

    Inductive sum A B : Type :=
      | inl : A -> sum A B
      | inr : B -> sum A B.

    Hint Constructors sum : core.
    Notation "x + y" := (sum x y) : type_scope.

  Remark: ideally, constructors would be renamed to [sum_l] and [sum_r];
  to follow conventions.

*)

Arguments inl {A} {B}.
Arguments inr {A} {B}.

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Inhabited *)

Instance sum_inhab_l : forall `{Inhab A} B, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inl arbitrary)). Qed.

Instance sum_inhab_r : forall `{Inhab B} A, Inhab (A + B).
Proof using. intros. apply (Inhab_of_val (inr arbitrary)). Qed.

Definition Inhab_sum : forall `{Inhab A, Inhab B}, Inhab (A + B).
Proof using. typeclass. Qed.

(* ********************************************************************** *)
(* ################################################################# *)
(** * Operations *)

(* ---------------------------------------------------------------------- *)
(* ================================================================= *)
(** ** Testing the branch of the sum *)

Definition is_inl (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => true
  | inr _ => false
  end.

Definition is_inr (A B : Type) (x : A + B) : bool :=
  match x with
  | inl _ => false
  | inr _ => true
  end.

Section IsIn.
Variables (A B : Type).
Implicit Type x : A + B.

Lemma is_inl_neg_is_inr : forall x,
  is_inl x = ! (is_inr x).
Proof using. intros x. destruct~ x. Qed.

Lemma is_inr_neg_is_inl : forall x,
  is_inr x = ! (is_inl x).
Proof using. intros x. destruct~ x. Qed.

End IsIn.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Stripping of the branch tag *)

Section Get.
Context `{IA1:Inhab A1} `{IA2:Inhab A2}.
Implicit Types x : A1+A2.

Definition get21 x :=
  match x with
  | inl x1 => x1
  | inr x2 => arbitrary
  end.

Definition get22 x :=
  match x with
  | inl x1 => arbitrary
  | inr x2 => x2
  end.

End Get.

(*-----------------------------------------------------*)
(* ================================================================= *)
(** ** Lifting functions over sum types *)

Section Fget.
Context {A1:Type} {A2:Type} `{IB1:Inhab B1} `{IB2:Inhab B2}.
Implicit Types f : A1+A2->B1+B2.

Definition fun_get21 f :=
  fun x => get21 (f (inl x)).
Definition fun_get22 f :=
  fun x => get22 (f (inr x)).

End Fget.


Set Warnings "-notation-overridden,-parsing".
From LF Require Export Lists.

Module ListWorkbench.
Inductive list(T:Type):Type :=
| nil
| cons (e:T) (l:list T)
.

Inductive boollist:Type :=
| boolnil
| boolcons (e:bool) (l:boollist)
.

Check boolnil.
Check boolcons.
Check list.
Check nil.
Check nil nat.
Check cons.
Check cons nat.
Check cons nat 2 (nil nat).
Check cons nat 2 (cons nat 1 (nil nat)).
Definition nat_nil := nil nat.
Definition nat_cons := cons nat.
Check nat_cons 2 (nat_cons 1 (nat_nil)).

Fixpoint repeat(T:Type) (x:T) (count:nat): list T :=
  match count with
  | 0 => nil T
  | S n' => cons T x (repeat T x n')
  end.

Compute repeat nat 12 3.

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity. Qed.

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity. Qed.

Arguments nil {T}.
Arguments cons {T} _ _.
Arguments repeat {T} _ _.

Compute repeat true 3.

Fixpoint repeat'{T:Type} (x:T) (count:nat): list T :=
  match count with
  | 0 => nil
  | S n' => cons x (repeat x n')
  end.

Compute repeat' true 3.

Check @nil.
Check nil.
Definition mytest(l:list nat):list nat := @nil nat.

Arguments list {T}.
Definition mytest'(l:@list nat):@list nat := @nil nat.

End ListWorkbench.


Require Export D.

Definition bassn b : Assertion :=
  fun st => (beval st b = true).

Definition reduce_to_zero' : com :=
  WHILE BNot (BEq (AId X) (ANum 0)) DO
    X ::= AMinus (AId X) (ANum 1)
  END.

Lemma not_true_iff_flase : forall b,
  negb b = false -> b = true.
Proof. intros. destruct b. reflexivity.  inversion H. Qed.

Theorem reduce_to_zero_correct' :
  {{fun st => True}}
  reduce_to_zero'
  {{fun st => st X = 0}}.
Proof.
  unfold reduce_to_zero'.
  (* First we need to transform the postcondition so
     that hoare_while will apply. *)
  eapply hoare_consequence_post.
  apply hoare_while.
  Case "Loop body preserves invariant".
    (* Need to massage precondition before hoare_asgn applies *)
    eapply hoare_consequence_pre. apply hoare_asgn.
    (* Proving trivial implication (2) ->> (3) *)
    intros st [HT Hbp]. unfold assn_sub. apply I.
  Case "Invariant and negated guard imply postcondition".
    intros st [Inv GuardFalse].
    unfold bassn in GuardFalse. simpl in GuardFalse.
    (* SearchAbout helps to find the right lemmas *)
    SearchAbout [not true].
(*    rewrite not_true_iff_false in GuardFalse.*)
    SearchAbout [negb false].
    rewrite negb_false_iff in GuardFalse.
    SearchAbout [beq_nat true].
    apply beq_nat_true in GuardFalse.
    apply GuardFalse. Qed.

(*
  unfold hoare_triple. intros.
  unfold reduce_to_zero' in H.  inversion H; subst.
  Case "While Loop".
    inversion H5. destruct (beq_nat (st' X) 0) eqn:Heq.
    apply beq_nat_eq. symmetry. assumption.
    inversion H2.
  Case "While End".
    inversion H3. destruct (beq_nat (st X) 0) eqn:Heq.
    inversion H2.  *)

Lemma le_sum : forall n m, n <= m -> S n <= S m.
  Proof. intros. omega. Qed.

Example while_example :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof. intros.
  eapply hoare_consequence_post. apply hoare_while.
  Case "True".
  unfold hoare_triple. intros.
  destruct H0. inversion H; subst.
  simpl. unfold update. rewrite eq_id. replace (st X + 1) with (S (st X)). apply le_sum. inversion H1. apply ble_nat_true. assumption. omega.
 Case "False".
  unfold hoare_triple.  unfold assert_implies. intros.
  destruct H. inversion H. reflexivity.
  inversion H0. apply ble_nat_false in H4. apply H4 in H2. inversion H2. Qed.

Lemma hoare_while : forall P b c,
{{fun st => P st /\ bassn b st }} c {{P}} ->
{{P}} WHILE b DO c END {{fun st => P st /\ ~ (bassn b st)}}.
Proof.
  unfold hoare_triple.
  intros P b c Hhoare st st' He HP.
  (* Like we've seen before, we need to reason by induction
     on He, because, in the "keep looping" case, its hypotheses
     talk about the whole loop instead of just c. *)
  remember (WHILE b DO c END) as wcom eqn:Heqwcom.
  ceval_cases (induction He) Case;
    (* While 이외의 command는 inversion으로 없어짐 *)
    try (inversion Heqwcom); subst; clear Heqwcom.
  Case "E_WhileEnd".
    split; try assumption. unfold not, bassn. rewrite H. intros Hcontra. inversion Hcontra.
  Case "E_WhileLoop".
  apply IHHe2. reflexivity.
  eapply Hhoare. apply He1. split; assumption. Qed.

(* command에 induction inversion 차이 *)
Lemma hoar : forall b' c c' st st', WHILE b' DO c' END = c -> c / st||st'-> True.
Proof. intros. induction H0; subst; inversion H; subst.
  (* E_WhilEnd *) reflexivity.
  (* E_WhileLoop *) reflexivity.
Qed.

Example while_example2 :
    {{fun st => st X <= 3}}
  WHILE (BLe (AId X) (ANum 2))
  DO X ::= APlus (AId X) (ANum 1) END
    {{fun st => st X = 3}}.
Proof.
  eapply hoare_consequence_post.
  Case "{{P}} c {{Q'}}".
    apply hoare_while.
    unfold hoare_triple; intros.
    destruct H0. inversion H1. apply ble_nat_true in H3. inversion H; subst. unfold update. rewrite eq_id. simpl. replace (st X + 1) with (S (st X)). apply le_sum. assumption. omega.
  Case "Q' ->> Q".
    unfold hoare_triple, assert_implies. intros.
    destruct H. inversion H. reflexivity.
    unfold not, bassn in H0. simpl in H0.
    destruct (ble_nat (st X) 2) eqn:Hb. contradiction H0. reflexivity.
    apply ble_nat_false in Hb. apply Hb in H2. inversion H2.
Qed.

Theorem always_loop_hoare : forall P Q,
  {{P}} WHILE BTrue DO SKIP END {{Q}}.
Proof.
  intros. eapply hoare_consequence_post. apply hoare_while.
  unfold bassn, hoare_triple. intros. inversion H; subst. apply H0.
  unfold bassn, hoare_triple, assert_implies. intros. destruct H.
  simpl in H0. contradiction H0. reflexivity. Qed.

Theorem reduce_to_zero_correct'_one_more :
  {{fun st => True}}
  reduce_to_zero'
  {{fun st => st X = 0}}.
Proof.
  unfold reduce_to_zero'.
  eapply hoare_consequence_post.
  Case "{{P}} c {{Q'}}".
    apply hoare_while. (* Q' = P/\~b 이 되고, P/\b c P 임을 보이자 *)
    unfold bassn, hoare_triple. intros. reflexivity.
  Case "Q' ->> Q".
   (* P/\~b ->> Q 임을 보이면 된다. *)
    unfold hoare_triple, bassn, assert_implies. intros.
    destruct H. simpl in H0. apply eq_true_negb_classical in H0.
    symmetry in H0. apply beq_nat_eq in H0. assumption.
Qed.


(*
TPPmark 2016

Written by Sosuke Moriguchi, Kwansei Gakuin University
*)

Require Import List.
Import ListNotations.
Require Import Omega.

(* From depndent type spec *)
Module Dependent.

(* 依存型の取り方は、listの長さから自然数を制限するか、自然数からlistの長さを制限するか、の二つがある。どちらでも、destructで展開するとほぼ同じになる。 *)

(* 今回はlistを先に取り、自然数に制約を与える *)

Section nth.

Context {A : Type}.

Definition nth_d : forall l : list A, {n : nat | n < length l} -> A.
(* 再帰は非依存型で行う *)
fix 1.
intro l; destruct l as [| a l']; simpl; intro x; destruct x as [x H].
 elimtype False; omega.
 destruct x.
  exact a.
  apply nth_d with l'.
   econstructor.
    apply lt_S_n in H.
     exact H.
Defined.

Lemma nth_d_eq : forall (l : list A) (x x' : {n : nat | n < length l}),
 proj1_sig x = proj1_sig x' -> nth_d l x = nth_d l x'.
induction l; intros x x' He; destruct x as [x H]; destruct x' as [x' H'].
 simpl in H; omega.
 simpl in *; subst.
  destruct x'.
   now auto.
   apply IHl; simpl; now auto.
Qed.

End nth.

Extraction nth_d.

Section replace.

Context {A : Type}.

(* 返し値に条件を書くと長くなるため、またそれを慌てて作る理由もないため一度普通の関数として作る。条件を示せば最後に合成するのは簡単。 *)
Definition replace_d : forall (l : list A), A -> {n : nat | n < length l} -> list A.
fix 1.
intros l a; destruct l as [| a' l']; simpl; intro x; destruct x as [x H].
 elimtype False; omega.
 destruct x.
  exact (a :: l').
  refine (cons a' _).
   apply replace_d with l'.
    exact a.
    econstructor.
     apply lt_S_n in H.
      exact H.
Defined.

Lemma replace_d_length_eq :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}),
  length l = length (replace_d l a x).
induction l as [| a' l' IHl]; intros a x; destruct x as [x H].
 simpl in H; omega.
 destruct x.
  simpl; now auto.
  simpl.
   f_equal; now auto.
Qed.

Lemma replace_d_nth :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}) (x' : {n : nat | n < length (replace_d l a x)}),
  proj1_sig x = proj1_sig x' -> nth_d (replace_d l a x) x' = a.
induction l as [| a' l' IHl]; intros a x x' He; destruct x as [x H]; destruct x' as [x' H']; simpl in He.
 simpl in H; omega.
 destruct x.
  subst; simpl; now auto.
  destruct x'.
   now inversion He.
   inversion He; subst.
    simpl.
     simpl in H; simpl in H'.
      apply IHl.
       simpl; now auto.
Qed.

Definition replace_d_nat_translate :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}),
  {m : nat | m < length l} -> {m : nat | m < length (replace_d l a x)}.
intros l a x x'; destruct x as [x H]; destruct x' as [x' H'].
 rewrite (replace_d_length_eq l a (exist _ x H)) in H'.
  econstructor.
   exact H'.
Defined.

Lemma replace_d_nat_translate_proj_eq :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}) (x' : {m : nat | m < length l}),
   proj1_sig x' = proj1_sig (replace_d_nat_translate l a x x').
unfold replace_d_nat_translate; intros l a x x'; destruct x; destruct x'; simpl; now auto.
Qed.

Lemma replace_d_nth_exists :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}),
  exists x' : {n : nat | n < length (replace_d l a x)}, proj1_sig x = proj1_sig x' /\ nth_d (replace_d l a x) x' = a.
intros l a x.
 exists (replace_d_nat_translate l a x x); split.
  now apply replace_d_nat_translate_proj_eq.
  apply replace_d_nth.
   now apply replace_d_nat_translate_proj_eq.
Qed.

Lemma replace_d_nth_not :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}) (x' : {n : nat | n < length l}) (x'' : {n : nat | n < length (replace_d l a x)}),
  proj1_sig x <> proj1_sig x' ->
   proj1_sig x' = proj1_sig x'' -> nth_d l x' = nth_d (replace_d l a x) x''.
induction l as [| a' l' IHl]; intros a x x' x'' Hne He; destruct x as [x H]; destruct x' as [x' H']; destruct x'' as [x'' H'']; simpl in He, Hne.
 simpl in H; omega.
 subst; destruct x.
  destruct x''.
   elim Hne; now auto.
   simpl.
    apply nth_d_eq; simpl; now auto.
  destruct x''.
   simpl; now auto.
   simpl.
    eapply IHl.
     simpl; intro.
      apply Hne; subst; now auto.
     simpl; now auto.
Qed.

Lemma replace_d_nth_not_exists :
 forall (l : list A) (a : A) (x : {n : nat | n < length l}) (x' : {n : nat | n < length l}),
  proj1_sig x <> proj1_sig x' ->
   exists x'' : {n : nat | n < length (replace_d l a x)}, proj1_sig x' = proj1_sig x'' /\ nth_d l x' = nth_d (replace_d l a x) x''.
intros l a x x' Hne.
 exists (replace_d_nat_translate l a x x').
  split.
   now apply replace_d_nat_translate_proj_eq.
   apply replace_d_nth_not.
    now auto.
    now apply replace_d_nat_translate_proj_eq.
Qed.

(* 結果の合成 *)
Definition replace_d' (l : list A) (a : A) (x : {n : nat | n < length l})
 : {l' : list A |
     length l = length l'
     /\ forall (x' : {n : nat | n < length l}) (x'' : {n : nat | n < length l'}),
         proj1_sig x' = proj1_sig x''
         -> (proj1_sig x = proj1_sig x' -> nth_d l' x'' = a)
            /\ (proj1_sig x <> proj1_sig x' -> nth_d l x' = nth_d l' x'')}.
refine (existT _ (replace_d l a x) _).
 split.
  apply replace_d_length_eq.
  intros x' x'' He; split; intro Hp.
   apply replace_d_nth.
    rewrite Hp; now auto.
   apply replace_d_nth_not; now auto.
Defined.

End replace.

Extraction replace_d.
Extraction replace_d_nat_translate.
Recursive Extraction replace_d'. (* インライン展開とパターンマッチ展開するとreplace_dを呼ぶだけになる。 *)

Section remove.

Context {A : Type}.

Definition remove_d : forall (l : list A), {n : nat | n < length l} -> list A.
fix 1.
intro l; destruct l as [| a' l']; simpl; intro x; destruct x as [x H].
 elimtype False; omega.
 destruct x.
  exact l'.
  refine (cons a' _).
   apply remove_d with l'.
    econstructor.
     apply lt_S_n in H.
      exact H.
Defined.

Lemma remove_d_length_S_eq :
 forall (l : list A) (x : {n : nat | n < length l}),
  length l = S (length (remove_d l x)).
induction l as [| a' l' IHl]; intro x; destruct x as [x H].
 simpl in H; omega.
 destruct x.
  simpl; now auto.
  simpl.
   f_equal; now auto.
Qed.

Lemma remove_d_nth_lt :
 forall (l : list A) (x x' : {n : nat | n < length l}) (x'' : {n : nat | n < length (remove_d l x)}),
  proj1_sig x > proj1_sig x'' -> proj1_sig x' = proj1_sig x'' -> nth_d l x' = nth_d (remove_d l x) x''.
induction l as [| a' l' IHl]; intros x x' x'' Hgt He; destruct x as [x H]; destruct x' as [x' H']; destruct x'' as [x'' H'']; simpl in He; subst.
 simpl in H; omega.
 destruct x.
  simpl in Hgt; omega.
  destruct x''.
   simpl; now auto.
   simpl in *.
    apply IHl.
     simpl; apply gt_S_n; now auto.
     simpl; now auto.
Qed.

(* translateやexistsは示せない（長さ1のリストから要素を削除すると、n < 0となるnがないため）。細かな情報を付けてもいいが、それ自体はあまりいらないので放置。 *)
(* 問題はgeの場合でltだけなら示せるが *)
(*
Definition remove_d_nat_translate (l : list A) (x x' : {n : nat | n < length l}) : {n : nat | n < length (remove_d l x)}.
destruct x as [x H]; destruct x' as [x' H']; destruct le_gt_dec with x x'.
*)

Lemma remove_d_nth_ge :
 forall (l : list A) (x : {n : nat | n < length l}) (x' : {n : nat | n < length l}) (x'' : {n : nat | n < length (remove_d l x)}),
  proj1_sig x <= proj1_sig x'' ->
   proj1_sig x' = S (proj1_sig x'') -> nth_d l x' = nth_d (remove_d l x) x''.
induction l as [| a' l' IHl]; intros x x' x'' Hle He; destruct x as [x H]; destruct x' as [x' H']; destruct x'' as [x'' H'']; simpl in He; subst.
 simpl in H; omega.
 destruct x.
  destruct x''; simpl; apply nth_d_eq; simpl; now auto.
  destruct x''; simpl; simpl in Hle.
   omega.
   apply IHl; simpl.
    apply le_S_n; now auto.
    now auto.
Qed.

Definition remove_d' (l : list A) (x : {n : nat | n < length l})
 : {l' : list A |
     length l = S (length l')
     /\ forall (x' : {n : nat | n < length l}) (x'' : {n : nat | n < length l'}),
         (proj1_sig x > proj1_sig x'' -> proj1_sig x' = proj1_sig x'' -> nth_d l x' = nth_d l' x'')
         /\ (proj1_sig x <= proj1_sig x'' -> proj1_sig x' = S (proj1_sig x'') -> nth_d l x' = nth_d l' x'')}.
refine (existT _ (remove_d l x) _).
 split.
  apply remove_d_length_S_eq.
  intros x' x''; split; intros Hc He.
   apply remove_d_nth_lt; now auto.
   apply remove_d_nth_ge; now auto.
Defined.

End remove.

Extraction remove_d.
Recursive Extraction remove_d'.

Section dep.

Context {A : Type}.

Definition remove_lst (lst : list (list A)) (i : {n : nat | n < length lst}) (j : {n : nat | n < length (nth_d lst i)}) : list (list A) :=
 replace_d lst (remove_d (nth_d lst i) j) i.

Theorem remove_lst_i :
 forall (lst : list (list A)) (i : {n : nat | n < length lst}) (j : {n : nat | n < length (nth_d lst i)}),
  exists i' : {n : nat | n < length (remove_lst lst i j)}, proj1_sig i = proj1_sig i' /\ length (nth_d lst i) = S (length (nth_d (remove_lst lst i j) i')).
unfold remove_lst.
 intros lst i j.
  exists (replace_d_nat_translate lst (remove_d (nth_d lst i) j) i i).
   split.
    now apply replace_d_nat_translate_proj_eq.
    rewrite replace_d_nth.
     now apply remove_d_length_S_eq.
     now apply replace_d_nat_translate_proj_eq.
Qed.

Theorem remove_lst_i' :
 forall (lst : list (list A)) (i : {n : nat | n < length lst}) (j : {n : nat | n < length (nth_d lst i)}) (i' : {n : nat | n < length lst}),
  proj1_sig i <> proj1_sig i'
  -> exists i'' : {n : nat | n < length (remove_lst lst i j)}, proj1_sig i' = proj1_sig i'' /\ nth_d lst i' = nth_d (remove_lst lst i j) i''.
unfold remove_lst.
 intros lst i j i' Hne.
  exists (replace_d_nat_translate lst (remove_d (nth_d lst i) j) i i').
   split.
    now apply replace_d_nat_translate_proj_eq.
    apply replace_d_nth_not.
     now auto.
     now apply replace_d_nat_translate_proj_eq.
Qed.

Definition remove_lst' (lst : list (list A)) (i : {n : nat | n < length lst}) (j : {n : nat | n < length (nth_d lst i)})
 : {lst' : list (list A) |
     (exists i' : {n : nat | n < length lst'},
       proj1_sig i = proj1_sig i' /\ length (nth_d lst i) = S (length (nth_d lst' i')))
     /\ forall i' : {n : nat | n < length lst},
         proj1_sig i <> proj1_sig i' ->
          exists i'' : {n : nat | n < length lst'},
           proj1_sig i' = proj1_sig i'' /\ nth_d lst i' = nth_d lst' i''}.
refine (existT _ (remove_lst lst i j) _).
 split.
  now apply remove_lst_i.
  now apply remove_lst_i'.
Defined.

Definition remove_lst'' (lst : list (list A)) (i : {n : nat | n < length lst}) (j : {n : nat | n < length (nth_d lst i)})
 : {lst' : list (list A) |
     (exists i' : {n : nat | n < length lst'},
       proj1_sig i = proj1_sig i'
       /\ forall (j' : {n : nat | n < length (nth_d lst i)}) (j'' : {n : nat | n < length (nth_d lst' i')}),
           (proj1_sig j > proj1_sig j'' -> proj1_sig j' = proj1_sig j'' -> nth_d (nth_d lst i) j' = nth_d (nth_d lst' i') j'')
           /\ (proj1_sig j <= proj1_sig j'' -> proj1_sig j' = S (proj1_sig j'') -> nth_d (nth_d lst i) j' = nth_d (nth_d lst' i') j''))
     /\ forall i' : {n : nat | n < length lst},
         proj1_sig i <> proj1_sig i' ->
          exists i'' : {n : nat | n < length lst'},
           proj1_sig i' = proj1_sig i'' /\ nth_d lst i' = nth_d lst' i''}.
refine (existT _ (remove_lst lst i j) _).
 unfold remove_lst; split.
  exists (replace_d_nat_translate lst (remove_d (nth_d lst i) j) i i).
   split.
    now apply replace_d_nat_translate_proj_eq.
    rewrite (replace_d_nth lst (remove_d (nth_d lst i) j) i (replace_d_nat_translate lst (remove_d (nth_d lst i) j) i i)).
     intros j' j''.
      split; intros Hcmp He.
       apply remove_d_nth_lt; now auto.
       apply remove_d_nth_ge; now auto.
     now apply replace_d_nat_translate_proj_eq.
  now apply remove_lst_i'.
Defined.

End dep.

Recursive Extraction remove_lst.
Extraction remove_lst'.
Extraction remove_lst''.

End Dependent.

(* From logic spec *)
Module Predicate.

Section nth.

Context {A : Type}.

Inductive Nth : list A -> nat -> A -> Prop :=
| Nth_O : forall l a, Nth (a :: l) 0 a
| Nth_S : forall l n a a', Nth l n a -> Nth (a' :: l) (S n) a.

Lemma Nth_length_n :
 forall (l : list A) (n : nat) (a : A),
  Nth l n a -> n < length l.
intros; induction H; simpl; omega.
Qed.

Lemma Nth_n_exists :
 forall (l : list A) (n : nat),
  n < length l -> exists a : A, Nth l n a.
intros l n; revert l; induction n; intros.
 destruct l.
  simpl in H; omega.
  exists a; now constructor.
 destruct l.
  simpl in H; omega.
  simpl in H; apply lt_S_n in H; apply IHn in H.
   destruct H as [a' H]; exists a'; constructor; now auto.
Qed.

Lemma Nth_unique :
 forall (l : list A) (n : nat) (a1 a2 : A),
  Nth l n a1 -> Nth l n a2 -> a1 = a2.
intros l n; revert l; induction n; intros.
 inversion H; subst; inversion H0; subst; now auto.
 inversion H; subst; inversion H0; subst.
  now eauto.
Qed.

End nth.

Section replace.

Context {A : Type}.

Variable a : A.

Inductive Replace : list A -> nat -> list A -> Prop :=
| Replace_O : forall l a', Replace (a' :: l) O (a :: l)
| Replace_S : forall l n a' l', Replace l n l' -> Replace (a' :: l) (S n) (a' :: l').

Lemma Replace_length_eq :
 forall (l : list A) (n : nat) (l' : list A),
  Replace l n l' -> length l = length l'.
intros.
induction H; simpl; now auto.
Qed.

Lemma Replace_length_n :
 forall (l : list A) (n : nat) (l' : list A),
  Replace l n l' -> n < length l.
intros l n; revert l; induction n; intros.
 inversion H; subst.
  simpl; omega.
 inversion H; subst.
  apply IHn in H2.
   simpl; omega.
Qed.

Lemma Replace_n_exists :
 forall (l : list A) (n : nat),
  n < length l -> exists l' : list A, Replace l n l'.
intros l n; revert l; induction n; intros.
 destruct l; simpl in H.
  omega.
  exists (a :: l); now constructor.
 destruct l; simpl in H.
  omega.
  apply lt_S_n in H.
   apply IHn in H.
    destruct H as [l' H].
     exists (a0 :: l'); constructor; now auto.
Qed.

Lemma Replace_unique :
 forall (l : list A) (n : nat) (l1 l2 : list A),
  Replace l n l1 -> Replace l n l2 -> l1 = l2.
intros l n; revert l; induction n; intros.
 inversion H; subst; inversion H0; subst; now auto.
 inversion H; subst; inversion H0; subst.
  f_equal; now eauto.
Qed.

Lemma Replace_mth :
 forall (l : list A) (n : nat) (l' : list A) (m : nat) (a1 a2 : A),
  Replace l n l' -> n <> m -> Nth l m a1 -> Nth l' m a2 -> a1 = a2.
intros l n l' m a1 a2 H; revert m; induction H; intros.
 inversion H0; subst.
  elim H; now auto.
  inversion H1; subst.
   apply Nth_unique with l n; now auto.
 inversion H1; subst.
  inversion H2; subst; now auto.
  inversion H2; subst; now eauto.
Qed.

Lemma Replace_nth :
 forall (l : list A) (n : nat) (l' : list A),
  Replace l n l' -> Nth l' n a.
intros; induction H; simpl.
 now constructor.
 constructor; now auto.
Qed.

End replace.

Section remove.

Context {A : Type}.

Inductive Remove : list A -> nat -> list A -> Prop :=
| Remove_O : forall l a, Remove (a :: l) O l
| Remove_S : forall l n a l', Remove l n l' -> Remove (a :: l) (S n) (a :: l').

Lemma Remove_length_S :
 forall (l : list A) (n : nat) (l' : list A),
  Remove l n l' -> length l = S (length l').
intros; induction H; simpl; now auto.
Qed.

Lemma Remove_length_n :
 forall (l : list A) (n : nat) (l' : list A),
  Remove l n l' -> n < length l.
intros l n; revert l; induction n; intros.
 inversion H; subst.
  simpl; omega.
 inversion H; subst.
  apply IHn in H2.
   simpl; omega.
Qed.

Lemma Remove_n_exists :
 forall (l : list A) (n : nat),
  n < length l -> exists l' : list A, Remove l n l'.
intros l n; revert l; induction n; intros.
 destruct l; simpl in H.
  omega.
  exists l; now constructor.
 destruct l; simpl in H.
  omega.
  apply lt_S_n in H.
   apply IHn in H.
    destruct H as [l' H].
     exists (a :: l'); constructor; now auto.
Qed.

Lemma Remove_unique :
 forall (l : list A) (n : nat) (l1 l2 : list A),
  Remove l n l1 -> Remove l n l2 -> l1 = l2.
intros l n; revert l; induction n; intros.
 inversion H; subst; inversion H0; subst; now auto.
 inversion H; subst; inversion H0; subst.
  f_equal; now eauto.
Qed.

Lemma Remove_mth_ge :
 forall (l : list A) (n : nat) (l' : list A) (m : nat) (a1 a2 : A),
  Remove l n l' -> n <= m -> Nth l (S m) a1 -> Nth l' m a2 -> a1 = a2.
intros l n l' m a1 a2 H; revert m; induction H; intros.
 inversion H0; subst.
  eapply Nth_unique; now eauto.
 inversion H2; subst.
  omega.
  inversion H1; subst.
   inversion H2; subst.
    apply le_S_n in H0.
     now eauto.
Qed.

Lemma Remove_mth_lt :
 forall (l : list A) (n : nat) (l' : list A) (m : nat) (a1 a2 : A),
  Remove l n l' -> m < n -> Nth l m a1 -> Nth l' m a2 -> a1 = a2.
intros l n l' m a1 a2 H; revert m; induction H; intros.
 omega.
 destruct m.
  inversion H1; subst; inversion H2; subst; now auto.
  inversion H1; subst; inversion H2; subst.
   apply lt_S_n in H0; now eauto.
Qed.

End remove.

Section pred.

Context {A : Type}.

Definition Remove_i_j (lst : list (list A)) (i j : nat) (lst' : list (list A)) : Prop :=
 exists l l' : list A, Nth lst i l /\ Remove l j l' /\ Replace l' lst i lst'.

(* Uniqueness *)
Theorem Remove_i_j_unique :
 forall (lst : list (list A)) (i j : nat) (lst1 lst2 : list (list A)),
  Remove_i_j lst i j lst1 -> Remove_i_j lst i j lst2 -> lst1 = lst2.
unfold Remove_i_j; intros.
 destruct H as [l1 [l1' [H11 [H12 H13]]]].
  destruct H0 as [l2 [l2' [H21 [H22 H23]]]].
   assert (l1 = l2).
    eapply Nth_unique; now eauto.
   subst.
   assert (l1' = l2').
    eapply Remove_unique; now eauto.
   subst.
   eapply Replace_unique; now eauto.
Qed.

(* Length specificatoin 1 *)
Theorem Remove_i_j_length_i :
 forall (lst : list (list A)) (i j : nat) (lst' : list (list A)),
  Remove_i_j lst i j lst' -> exists l l' : list A, Nth lst i l /\ Nth lst' i l' /\ length l = S (length l').
unfold Remove_i_j; intros.
 destruct H as [l [l' [H1 [H2 H3]]]].
  exists l, l'; intuition.
   apply Replace_nth with lst; now auto.
   apply Remove_length_S with j; now auto.
Qed.

(* Length specificatoin 2' *)
Theorem Remove_i_j_eq_k :
 forall (lst : list (list A)) (i j : nat) (lst' : list (list A)) (k : nat),
  Remove_i_j lst i j lst' -> i <> k -> k < length lst -> exists l : list A, Nth lst k l /\ Nth lst' k l.
unfold Remove_i_j; intros.
 destruct H as [l [l' [H2 [H3 H4]]]].
  destruct (Nth_n_exists lst k H1) as [l1 H5].
   exists l1; split.
    now auto.
    destruct (Nth_n_exists lst' k).
     erewrite <- Replace_length_eq; now eauto.
     erewrite Replace_mth; now eauto.
Qed.

(* Length specificatoin 2 *)
Corollary Remove_i_j_length_k :
 forall (lst : list (list A)) (i j : nat) (lst' : list (list A)) (k : nat),
  Remove_i_j lst i j lst' -> i <> k -> k < length lst -> exists l l' : list A, Nth lst k l /\ Nth lst' k l' /\ length l = length l'.
intros.
 destruct (Remove_i_j_eq_k _ _ _ _ _ H H0 H1) as [l [Hx Hy]].
  exists l, l; now auto.
Qed.

End pred.

End Predicate.


(** * Lists *)

(**

This file contains a formalization of lists define as iterated products ([list]).

Written by: Anders Mörtberg, 2016 (inspired by a remark of Vladimir Voevodsky), Floris van Doorn, december 2017

*)

Require Import UniMath.MoreFoundations.Tactics.
Require Import UniMath.Combinatorics.StandardFiniteSets.
Require Import UniMath.Combinatorics.Vectors.

(** * Lists over an arbitrary type *)
Section lists.

Context {A : UU}.

(** The type of lists *)
Definition list : UU := ∑ n, vec A n.

(** The empty list *)
Definition nil : list := (0,, vnil).

(** List cons *)
Definition cons (x : A) (xs : list) : list :=
  (S (pr1 xs),, vcons x (pr2 xs)).

Local Notation "[]" := nil (at level 0, format "[]").
Local Infix "::" := cons.

Lemma list_ind : ∏ (P : list -> UU),
     P nil
  -> (∏ (x : A) (xs : list), P xs -> P (x :: xs))
  -> ∏ xs, P xs.
Proof.
intros P Hnil Hcons xs.
induction xs as [n xs].
induction n as [|n IHn].
- induction xs.
  apply Hnil.
- simpl in xs.
  induction xs as [x xs].
  apply (Hcons x (n,,xs) (IHn xs)).
Defined.

Lemma list_ind_compute_2
      (P : list -> UU)
      (p0 : P nil)
      (ind : ∏ (x : A) (xs : list), P xs -> P (x :: xs))
      (x : A) (xs : list)
      (f := list_ind P p0 ind) :
  f (x::xs) = ind x xs (f xs).
Proof.
  apply idpath.
Defined.

Definition foldr {B : UU} (f : A -> B -> B) (b : B) : list -> B :=
  list_ind (λ _, B) b (λ a _ b', f a b').

Definition length : list -> nat := pr1.

(** Variation of foldr that returns a for the empty list and folds the
    rest with the first element as new default value *)
Definition foldr1 (f : A -> A -> A) (a : A) : list → A.
Proof.
  apply list_ind.
  - exact a.
  - intros a' l fl. revert l. apply list_ind.
    + exact a'.
    + intros _ _ _. exact (f a' fl).
Defined.

(** Variation of foldr1 with embedded mapping, see below for [foldr1_foldr1_map] *)
Definition foldr1_map {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) : list → B.
Proof.
  apply list_ind.
  - exact b.
  - intros a' l fl. revert l. apply list_ind.
    + exact (h a').
    + intros _ _ _. exact (f (h a') fl).
Defined.

(** The n-th element of a list *)

Definition nth x : stn(length x) -> A := el (pr2 x).

Definition functionToList' n : (stn n -> A) -> vec A n.
Proof.
  intros f.
  induction n as [|n I].
  - exact tt.
  - exists (f (●0))%stn.
    exact (I(f ∘ dni (●0)))%stn.
Defined.

Definition functionToList n : (stn n -> A) -> list.
Proof.
  intros f.
  exact (n ,, make_vec f).
Defined.

Section Test.

  Local Open Scope stn.

  Context {a b c d:A}.
  Let x := a::b::c::d::[].
  Goal nth x (●0) = a. apply idpath. Qed.
  Goal nth x (●1) = b. apply idpath. Qed.
  Goal nth x (●2) = c. apply idpath. Qed.
  Goal nth x (●3) = d. apply idpath. Qed.

  Goal functionToList _ (nth x) = x. apply idpath. Qed.

End Test.

End lists.

(** Make the type not implicit for list *)
Arguments list : clear implicits.

Section more_lists.

Definition map {A B : UU} (f : A -> B) : list A -> list B :=
  foldr (λ a l, cons (f a) l) nil.

Lemma mapStep {A B : UU} (f : A -> B) (a:A) (x:list A) : map f (cons a x) = cons (f a) (map f x).
Proof.
  apply idpath.
Defined.

(** Various unfolding lemmas *)
Lemma foldr_nil {A B : UU} (f : A -> B -> B) (b : B) : foldr f b nil = b.
Proof.
  apply idpath.
Qed.

Lemma foldr_cons {A B : UU} (f : A -> B -> B) (b : B) (x : A) (xs : list A) :
  foldr f b (cons x xs) = f x (foldr f b xs).
Proof.
  apply idpath.
Qed.

Lemma map_nil {A B : UU} (f : A -> B) : map f nil = nil.
Proof.
  apply idpath.
Qed.

Lemma map_cons {A B : UU} (f : A -> B) (x : A) (xs : list A) :
  map f (cons x xs) = cons (f x) (map f xs).
Proof.
  apply idpath.
Qed.

Lemma map_compose {A B C : UU} (f : A → B) (g : B → C) (xs : list A) :
  map (g ∘ f) xs = map g (map f xs).
Proof.
  revert xs. apply list_ind.
  - apply idpath.
  - intros x xs IH. now rewrite !map_cons, IH.
Defined.

Lemma map_idfun {A : UU} (xs : list A) :
  map (idfun A) xs = xs.
Proof.
  revert xs. apply list_ind.
  - apply idpath.
  - intros x xs IH. now rewrite !map_cons, IH.
Defined.

Lemma map_homot {A B : UU} {f g : A → B} (h : f ~ g) (xs : list A) :
  map f xs = map g xs.
Proof.
  revert xs. apply list_ind.
  - apply idpath.
  - intros x xs IH. now rewrite !map_cons, h, IH.
Defined.

Lemma foldr1_nil {A: UU} (f : A -> A -> A) (a : A) : foldr1 f a nil = a.
Proof.
  apply idpath.
Qed.

Lemma foldr1_cons_nil {A : UU} (f : A -> A -> A) (a : A) (x : A) :
  foldr1 f a (cons x nil) = x.
Proof.
apply idpath.
Qed.

Lemma foldr1_cons {A : UU} (f : A -> A -> A) (a : A) (x y : A) (xs : list A) :
  foldr1 f a (cons x (cons y xs)) = f x (foldr1 f a (cons y xs)).
Proof.
apply idpath.
Qed.

Lemma foldr1_map_nil {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B) :
  foldr1_map f b h nil = b.
Proof.
  apply idpath.
Qed.

Lemma foldr1_map_cons_nil {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B)
  (x : A) : foldr1_map f b h (cons x nil) = h x.
Proof.
  apply idpath.
Qed.

Lemma foldr1_map_cons {A : UU} {B : UU} (f : B -> B -> B) (b : B) (h : A -> B)
  (x y : A) (xs : list A) :
  foldr1_map f b h (cons x (cons y xs)) = f (h x) (foldr1_map f b h (cons y xs)).
Proof.
  apply idpath.
Qed.

Lemma foldr1_foldr1_map {A B : UU} (f : B -> B -> B) (b : B) (h : A -> B) (xs : list A) :
  foldr1_map f b h xs = foldr1 f b (map h xs).
Proof.
  revert xs.
  induction xs as [[|n] xs].
  - induction xs.
    apply idpath.
  - induction n as [|n IH].
    + induction xs as [m []].
      apply idpath.
    + induction xs as [m [k xs]].
      assert (IHinst := IH (k,,xs)).
      change (S (S n),, m,, k,, xs) with (cons m (cons k (n,,xs))).
      do 2 rewrite map_cons.
      rewrite foldr1_cons.
      change (S n,, k,, xs) with (cons k (n,,xs)) in IHinst.
      rewrite map_cons in IHinst.
      rewrite <- IHinst.
      apply foldr1_map_cons. (* this steps could be done by cbn and reflexivity *)
Qed.

End more_lists.

Local Notation "[]" := nil (at level 0, format "[]").
Local Infix "::" := cons.

(** concatenate two lists  *)

Definition concatenate {X} : list X -> list X -> list X
  := λ r s, foldr cons s r.

Local Infix "++" := concatenate.

Lemma concatenateStep {X} (x:X) (r s:list X) :
  (x::r) ++ s = x :: (r ++ s).
Proof.
  apply idpath.
Defined.

Lemma nil_concatenate {X} (r : list X) : nil ++ r = r.
Proof. apply idpath. Defined.

Lemma concatenate_nil {X} (r : list X) : r ++ nil = r.
Proof. revert r. apply list_ind. apply idpath. intros x xs p. exact (maponpaths (cons x) p). Defined.

Lemma assoc_concatenate {X} (r s t : list X) : (r ++ s) ++ t = r ++ (s ++ t).
Proof.
  revert r. apply list_ind.
  - apply idpath.
  - intros x xs p. now rewrite !concatenateStep, p.
Defined.

Lemma map_concatenate {X Y} (f : X → Y) (r s : list X) : map f (r ++ s) = map f r ++ map f s.
Proof.
  revert r. apply list_ind.
  - apply idpath.
  - intros x xs p. now rewrite mapStep, !concatenateStep, mapStep, p.
Defined.

Lemma foldr_concatenate {X Y : UU} (f : X → Y) (l : list X) :
  foldr concatenate [] (map (λ x, f x::[]) l) = map f l.
Proof.
  revert l. apply list_ind.
  - apply idpath.
  - intros x l IH. now rewrite !map_cons, foldr_cons, IH.
Defined.

Lemma foldr1_concatenate {X Y : UU} (f : X → Y) (l : list X) :
  map f l = foldr1 concatenate [] (map (λ x, f x::[]) l).
Proof.
  revert l. apply list_ind.
  - apply idpath.
  - intros x. refine (list_ind _ _ _).
    + intro. apply idpath.
    + intros x' l _ IH. exact (maponpaths (cons (f x)) IH).
Defined.

(** Append a single element to a list *)

Definition append {X} (x : X) (l : list X) : list X :=
  l ++ x::[].

Lemma appendStep {X} (x y : X) (l : list X) : append x (y::l) = y::append x l.
  Proof. apply idpath. Defined.

Lemma append_concatenate {X} (x : X) (l s : list X) : append x (l ++ s) = l ++ append x s.
  Proof. apply assoc_concatenate. Defined.

Lemma map_append {X Y} (f : X → Y) (x : X) (r : list X) : map f (append x r) = append (f x) (map f r).
  Proof. exact (map_concatenate _ _ _). Defined.

(** Reverse a list *)

Definition reverse {X} : list X → list X :=
  foldr append [].

Lemma reverse_nil (X : Type) : reverse (@nil X) = [].
Proof. apply idpath. Defined.

Lemma reverseStep {X} (x : X) (r : list X) : reverse (x::r) = append x (reverse r).
Proof. apply idpath. Defined.

Lemma map_reverse {X Y} (f : X → Y) (r : list X) : map f (reverse r) = reverse (map f r).
Proof.
  revert r. apply list_ind.
  - apply idpath.
  - intros x xs p. now rewrite mapStep, !reverseStep, map_append, p.
Defined.

Lemma reverse_concatenate {X} (l s : list X) : reverse (l ++ s) = reverse s ++ reverse l.
Proof.
  revert l. apply list_ind.
  - symmetry. apply concatenate_nil.
  - intros x xs p. now rewrite concatenateStep, !reverseStep, p, append_concatenate.
Defined.

Lemma reverse_append {X} (x : X) (l : list X) : reverse (append x l) = x :: reverse l.
Proof. unfold append. now rewrite reverse_concatenate, reverseStep, reverse_nil. Defined.

Lemma reverse_reverse {X} (r : list X) : reverse (reverse r) = r.
Proof.
  revert r. apply list_ind.
  - apply idpath.
  - intros x xs p. now rewrite !reverseStep, reverse_append, p.
Defined.

(** flatten lists of lists  *)

Definition flatten {X} : list (list X) → list X.
Proof.
  apply list_ind.
  + exact [].
  + intros s _ f. exact (concatenate s f).
Defined.

Lemma flattenStep {X} (x:list X) (m : list(list X)) : flatten (x::m) = concatenate x (flatten m).
Proof.
  unfold flatten.
  rewrite list_ind_compute_2.
  apply idpath.
Defined.

Lemma isofhlevellist (n : nat) {X : UU} (is1 : isofhlevel (S (S n)) X) : isofhlevel (S (S n)) (list X).
Proof.
  use isofhleveltotal2.
  - intros m k. apply isofhlevelsnprop, isasetnat.
  - intro m. apply isofhlevelvec, is1.
Defined.


Require Import Bool.
Require Import List.
Require Import Nat.
Require Import Arith.

Import ListNotations.

(* Project modules *)
Require Import ListUtils.

Definition dup {T: Type} (n : nat) (ws : list T) : option (list T) :=
   match List.nth_error ws n with
     | Some v => Some (v::ws)
     | None => None
   end.

Definition apply_1 {T} (f: T -> T) xs :=
  match xs with
    | a::xs => Some (f a::xs)
    | nil => None
  end.

Definition apply_2 {T} (f: T -> T -> T) xs :=
  match xs with
    | a::b::xs => Some (f a b::xs)
    | _ => None
  end.

Definition apply_3 {T} (f: T -> T -> T -> T) xs :=
  match xs with
    | a::b::c::xs => Some (f a b c::xs)
    | _ => None
  end.

Section SWAP.

Definition swap {T : Type} (n : nat) (ws : list T) : option (list T) :=
   match skipn (1+n) ws, firstn (1+n) ws with
     | w1 :: l1, w0 :: l0 => Some ((w1 :: l0) ++ w0 :: l1)
     | _, _ => None
   end.

Variable (T : Type).

Lemma swap_same_length : forall (w0 w1 : T) (l0 l1 : list T),
  length ((w0 :: l0) ++ w1 :: l1) = length ((w1 :: l0) ++ w0 :: l1).
Proof.
  intros.
  rewrite -> app_length.
  rewrite -> app_length.
  reflexivity.
Qed.

Lemma swap_eq : forall (n : nat) (ws ws' : list T),
  swap n ws = Some ws' ->
  length ws = length ws'.
Proof.
  intros n ws ws'.
  intros.
  unfold swap in H.
  destruct (skipn (1+n) ws) eqn:S. discriminate H.
  destruct (firstn (1+n) ws) eqn:F. discriminate H.
  rewrite <- (firstn_skipn (1+n) ws).
  inversion H.
  rewrite -> F, S.
  rewrite -> app_comm_cons.
  apply swap_same_length.
Qed.

Lemma swap_long : forall (n : nat) (ws ws' : list T),
  swap n ws = Some ws' ->
  (1+n) < length ws.
Proof.
  intros. simpl.
  unfold swap in H.
  destruct (skipn (1 + n) ws) eqn:Q. inversion H.
  destruct (firstn (1 + n) ws). inversion H.
  apply skipn_head_lt in Q.
  assumption.
Qed.

Lemma swap_skipn_length : forall (w0 w1 : T) (l0 l1 : list T),
  swap (length l0) ((w0 :: l0) ++ w1 :: l1) = Some ((w1 :: l0) ++ w0 :: l1).
Proof.
  intros.
  unfold swap.
  assert (1 + length l0 = length (w0::l0)) by reflexivity.
  rewrite -> H.
  rewrite -> firstn_app, firstn_all, minus_diag.
  rewrite -> skipn_app, app_nil_r.
  reflexivity.
Qed.

Lemma swap_correct : forall (n : nat) (ws ws' : list T),
  swap n ws = Some ws'
  -> exists w0 w1 l0 l1, ws = (w0::l0) ++ (w1::l1) /\ ws' = (w1::l0) ++ (w0::l1).
Proof.
  intros. unfold swap in H.
  assert ( firstn (1 + n) ws ++ skipn (1 + n) ws = ws) by apply firstn_skipn.
  destruct ws eqn:Q. inversion H.
  simpl in *.
  destruct (skipn n l).
  - inversion H.
  - inversion H0.
    exists t, t0, (firstn n l), (skipn (1+n) l).
    assert (FS: firstn n l ++ skipn n l = l) by apply firstn_skipn.
    split; [idtac | inversion H];
      do 3 f_equal;
      rewrite <- FS in H2 at 2;
      apply app_inv_head, skipn_succ in H2;
      assumption.
Qed.

End SWAP.

Lemma swap_alpha_2n_delta_2n : forall {T : Type} (n : nat) (ws ws' : list T),
  swap n ws = Some ws'
  -> skipn (2 + n) ws = skipn (2 + n) ws'.
Proof.
  intros.
  unfold swap in H.
  assert (FS: firstn (1+n) ws ++ skipn (1+n) ws = ws) by apply firstn_skipn.
  destruct (skipn (1 + n) ws) eqn:SKIP. inversion H.
  destruct (firstn (1 + n) ws). inversion H.

  rewrite -> app_app in H.
  inversion H.
  subst ws' ws.
  rewrite -> app_app.
  rewrite -> app_comm_cons at 1.
  rewrite <- app_comm_cons at 1.

  Ltac skip x fstn SKIP := replace (2 + x) with (length fstn) at 1 by (
    apply skipn_head_all in SKIP;
    rewrite -> app_comm_cons, app_length, plus_comm;
    inversion SKIP;
    reflexivity
  ).
  skip n (t0 :: l0 ++ [t]) SKIP. rewrite -> skipn_short.
  skip n (t :: l0 ++ [t0]) SKIP. rewrite -> skipn_short.
  reflexivity.
Qed.


(* natree Library *)
(* v0   Olivier Laurent *)

(** * [nat]-labelled binary trees and embedding into nat *)

Require Import Lt Plus Mult Even Div2 Wf_nat.
Require Import NPeano.
Require Import Psatz.

Require Import Injective.
Require Import Surjective.

(* begin hide *)
Lemma pow_inc : forall n m m', 1 < n -> m < m' -> pow n m < pow n m'.
Proof.
intros n m m' Hn Hlt.
induction Hlt.
- simpl.
  destruct n ; try (now inversion Hn).
  destruct n ; try (now inversion Hn).
  simpl.
  rewrite <- (plus_0_r (S (S n) ^ m)).
  rewrite <- plus_assoc.
  apply plus_lt_compat_l.
  simpl.
  induction m ; simpl ; lia.
- simpl.
  etransitivity ; [ apply IHHlt | ].
  clear - Hn.
  induction m0 ; simpl ; try lia.
  apply mult_lt_compat_l ; lia.
Qed.
(* end hide *)

(** * Coding of pairs of [nat] *)

(** Simple coding **)
Definition cpair n m := 2 ^ n * (2 * m + 1).

Lemma cpair_not_0 : forall n m, cpair n m <> 0.
Proof.
induction n ; unfold cpair ; simpl ; intros m H.
- destruct m ; inversion H.
- specialize IHn with m.
  unfold cpair in IHn.
  lia.
Qed.

Lemma cpair_inc_l : forall n n' m, n < n' -> cpair n m < cpair n' m.
Proof.
intros n n' m Hlt.
unfold cpair.
apply mult_lt_compat_r ; try lia.
apply (pow_inc 2) ; [ lia | assumption ].
Qed.

Lemma cpair_inc_r : forall n m m', m < m' -> cpair n m < cpair n m'.
Proof.
intros n m m' Hlt.
unfold cpair.
apply mult_lt_compat_l ; try lia.
clear ; induction n ; simpl ; lia.
Qed.

Lemma cpair_lt_l : forall n m, n < cpair n m.
Proof.
intros n m.
unfold cpair.
induction n ; simpl ; lia.
Qed.

Lemma cpair_lt_r : forall n m, m < cpair n m.
Proof.
intros n m.
unfold cpair.
induction n ; simpl ; lia.
Qed.

Lemma cpair_inj : injective2 cpair.
Proof.
intros n.
induction n ; intros m n' m' Hc ; unfold cpair in Hc ; simpl in Hc.
- assert (0 = n') by (destruct n' ; simpl in Hc ; lia) ; subst.
  simpl in Hc ; split ; lia.
- destruct n' ; simpl in Hc.
  + exfalso ; lia.
  + assert (n = n' /\ m = m') as [Hn Hm] by (apply IHn ; unfold cpair ; lia).
    split ; [ f_equal | ] ; assumption.
Qed.

Lemma cpair_surj : forall k , 0 < k -> exists n m, k = cpair n m.
Proof.
induction k using (well_founded_induction lt_wf).
intros Hpos.
destruct (even_or_odd k) as [ He | Ho ].
- assert (0 < div2 k) as Hpos2.
  {
    destruct k.
    - inversion Hpos.
    - apply even_div2 in He.
      rewrite He.
      apply lt_0_Sn.
  }
  destruct (H (div2 k) (lt_div2 _ Hpos) Hpos2) as (n & m & Heq).
  exists (S n) ; exists m.
  unfold cpair in Heq ; simpl.
  unfold cpair ; simpl.
  apply even_double in He.
  rewrite He ; unfold double.
  lia.
- apply odd_S2n in Ho.
  destruct Ho as [p Hp] ; subst.
  exists 0 ; exists p.
  unfold double ; unfold cpair ; simpl ; lia.
Qed.

(** Refined surjective coding **)
Definition pcpair n m := pred (cpair n m).

Lemma pcpair_inc_l : forall n n' m, n < n' -> pcpair n m < pcpair n' m.
Proof.
intros n n' m Hlt.
unfold pcpair.
case_eq (cpair n m).
- intros Heq.
  apply cpair_not_0 in Heq.
  inversion Heq.
- intros n0 Heq.
  simpl.
  case_eq (cpair n' m).
  + intros Heq'.
    apply cpair_not_0 in Heq'.
    inversion Heq'.
  + intros m0 Heq'.
    simpl.
    apply (cpair_inc_l _ _ m) in Hlt.
    rewrite Heq in Hlt.
    rewrite Heq' in Hlt.
    lia.
Qed.

Lemma pcpair_inc_r : forall n m m', m < m' -> pcpair n m < pcpair n m'.
Proof.
intros n m m' Hlt.
unfold pcpair.
case_eq (cpair n m).
- intros Heq.
  apply cpair_not_0 in Heq.
  inversion Heq.
- intros n0 Heq.
  simpl.
  case_eq (cpair n m').
  + intros Heq'.
    apply cpair_not_0 in Heq'.
    inversion Heq'.
  + intros m0 Heq'.
    simpl.
    apply (cpair_inc_r n) in Hlt.
    rewrite Heq in Hlt.
    rewrite Heq' in Hlt.
    lia.
Qed.

Lemma pcpair_le_l : forall n m, n <= pcpair n m.
Proof.
intros n m.
unfold pcpair ; unfold cpair.
assert (n <= pred (2 ^ n)) as Hp.
{
  induction n ; simpl.
  - reflexivity.
  - apply (plus_le_compat_l _ _ 1) in IHn.
    etransitivity ; [ apply IHn | ].
    assert (forall n, 0 < 2 ^ n) as Hpos
      by (clear ; intros n ; induction n ; simpl ; lia).
    specialize Hpos with n.
    lia.
}
etransitivity ; [ apply Hp | ].
clear Hp.
induction m ; simpl ; try lia.
Qed.

Lemma pcpair_le_r : forall n m, m <= pcpair n m.
Proof.
intros n m.
unfold pcpair ; unfold cpair.
induction n ; simpl ; try lia.
Qed.

Lemma pcpair_inj : injective2 pcpair.
Proof.
intros n m n' m' Heq.
apply cpair_inj.
unfold pcpair in Heq.
case_eq (cpair n m).
- intros Hc ; exfalso ; apply cpair_not_0 in Hc ; assumption.
- intros n0 Hc.
  case_eq (cpair n' m').
  + intros Hc' ; exfalso ; apply cpair_not_0 in Hc' ; assumption.
  + intros n1 Hc'.
    rewrite Hc in Heq.
    rewrite Hc' in Heq.
    rewrite <- 2 pred_Sn in Heq.
    subst ; reflexivity.
Qed.

Lemma pcpair_surj : surjective2 pcpair.
Proof.
intros k.
destruct (cpair_surj (S k) (lt_0_Sn _)) as (n & m & Heq).
exists n ; exists m ; unfold pcpair ; rewrite <- Heq.
apply pred_Sn.
Qed.

(** * Coding of [nat]-labelled binary trees *)

Inductive nattree : Set :=
| Lnt : nattree
| Bnt : nat -> nattree -> nattree -> nattree
.

Fixpoint nattree2nat t :=
match t with
| Lnt => 0
| Bnt k t1 t2 => cpair k (pcpair (nattree2nat t1) (nattree2nat t2))
end.

Lemma nattree2nat_inj : injective nattree2nat.
Proof.
intros t1.
induction t1 ; intros t2 Heq ; destruct t2 ; simpl in Heq.
- reflexivity.
- exfalso.
  symmetry in Heq.
  apply cpair_not_0 in Heq.
  assumption.
- exfalso.
  apply cpair_not_0 in Heq.
  assumption.
- apply cpair_inj in Heq.
  destruct Heq as [Heq1 Heq].
  apply pcpair_inj in Heq.
  destruct Heq as [Heq2 Heq3].
  apply IHt1_1 in Heq2.
  apply IHt1_2 in Heq3.
  f_equal ; assumption.
Qed.

Lemma nattree2nat_surj : surjective nattree2nat.
Proof.
intros y.
induction y using (well_founded_induction lt_wf).
destruct y.
- exists Lnt ; reflexivity.
- destruct (cpair_surj _ (lt_O_Sn y)) as (n & m & Heq).
  destruct (pcpair_surj m) as (n' & m' & Heq').
  assert (m < S y) as Hm by (rewrite Heq ; apply cpair_lt_r).
  assert (n' <= pcpair n' m') as Hl by apply pcpair_le_l.
  assert (n' < S y) as Hn' by lia.
  assert (m' <= pcpair n' m') as Hr by apply pcpair_le_r.
  assert (m' < S y) as Hm' by lia.
  apply H in Hn'.
  apply H in Hm'.
  destruct Hn' as [t1 H1].
  destruct Hm' as [t2 H2] ; subst.
  exists (Bnt n t1 t2).
  assumption.
Qed.


(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*             Sets of variables indexed by natural numbers                 *)
(*                     representing their order                             *)
(*                                                                          *)
(*                                                                          *)
(*                                                                          *)
(****************************************************************************)
(*                                  Vars.v                                  *)
(****************************************************************************)

Require Import Peano_dec.
Require Import Compare_dec.
Require Import Compare.
Require Import Le.
Require Import Gt.
Require Import Prelude1.
Require Import CanonBDDs.canonicite.Finite_sets.

Section Intervals.

Variable n : nat.

Inductive Var (n : nat) : Set :=
    Var_intro : forall k : nat, k > 0 -> k <= n -> Var n.

Definition Order (xi : Var n) : nat :=
  match xi return nat with
  | Var_intro i pi qi => i
  end.

Lemma Ordering_surj :
 forall k : nat, k > 0 -> k <= n -> exists x : Var n, k = Order x.
Proof.
intros k H1 H2.
exists (Var_intro n k H1 H2); auto with arith.
Qed.
Hint Resolve Ordering_surj.

Definition eq_Var (xi xj : Var n) := Order xi = Order xj.
Definition le_Var (xi xj : Var n) := Order xi <= Order xj.
Definition gt_Var (xi xj : Var n) := Order xi > Order xj.

Lemma same_order_eq_Var :
 forall (k : nat) (xi xj : Var n),
 Order xi = k -> Order xj = k -> eq_Var xi xj.
Proof.
intros k xi xj Ind_xi Ind_xj.
unfold eq_Var in |- *.
replace (Order xi) with k.
replace (Order xj) with k.
trivial with arith.
Qed.

Lemma eq_Var_same_order :
 forall xi xj : Var n, eq_Var xi xj -> Order xi = Order xj.
Proof.
unfold eq_Var in |- *; auto with arith.
Qed.
Hint Resolve eq_Var_same_order.

Lemma eq_Var_refl : forall x : Var n, eq_Var x x.
Proof.
simple induction x.
unfold eq_Var in |- *; auto with arith.
Qed.
Hint Resolve eq_Var_refl.

Lemma eq_Var_sym : forall x1 x2 : Var n, eq_Var x1 x2 -> eq_Var x2 x1.
Proof.
intros x1 x2 eq_x1_x2.
apply same_order_eq_Var with (k := Order x2); auto with arith.
Qed.
Hint Immediate eq_Var_sym: bdd.

Lemma eq_Var_trans :
 forall x1 x2 x3 : Var n, eq_Var x1 x2 -> eq_Var x2 x3 -> eq_Var x1 x3.
Proof.
intros x1 x2 x3 eq_12 eq_13.
cut (Order x1 = Order x2); auto with arith.
cut (Order x2 = Order x3); auto with arith.
intros H23 H12.
apply same_order_eq_Var with (k := Order x2); auto with arith.
Qed.

Lemma eq_Var_dec : forall xi xj : Var n, {eq_Var xi xj} + {~ eq_Var xi xj}.
Proof.
unfold eq_Var in |- *.
intros xi xj.
apply eq_nat_dec.
Qed.
Hint Resolve eq_Var_dec.

Lemma le_or_gt_Var : forall xi xj : Var n, le_Var xi xj \/ gt_Var xi xj.
Proof.
intros xi xj.
elim (le_gt_dec (Order xi) (Order xj)); intro.
left.
unfold le_Var in |- *; trivial with arith.
right.
unfold gt_Var in |- *; trivial with arith.
Qed.

Lemma Order_le_n : forall x : Var n, Order x <= n.
Proof.
simple induction x; simpl in |- *; auto with arith.
Qed.
Hint Resolve Order_le_n.

Lemma Order_gt_O : forall x : Var n, Order x > 0.
Proof.
simple induction x; simpl in |- *; auto with arith.
Qed.
Hint Resolve Order_gt_O.

Lemma Order_S : forall x : Var n, exists m : nat, Order x = S m.
Proof.
intros.
generalize (Order_gt_O x).
elim (Order x).
intro; absurd (0 > 0); auto with arith.
intros p H1 H2; exists p; trivial with arith.
Qed.

Lemma le_Var_total_order : total_order (Var n) le_Var eq_Var.
Proof.
unfold total_order in |- *.
split.
(*  (order (Var n) le_Var eq_Var) *)
unfold order in |- *.
split; try split.
    (* (reflexivity (Var n) le_Var) *)
unfold reflexivity, le_Var in |- *; auto with arith.
    (* (anti_symetry (Var n) le_Var eq_Var) *)
unfold anti_symetry, le_Var, eq_Var in |- *; auto with arith.
    (* (transitivity (Var n) le_Var) *)
unfold transitivity, le_Var in |- *.
intros xi xj xk xi_le_xj xj_le_xk.
apply le_trans with (m := Order xj); auto with arith.
(*  (totality (Var n) le_Var)     *)
unfold totality, le_Var in |- *; auto with arith.
Qed.
Hint Resolve le_Var_total_order.

(*-----------------       Sets of indexed variables      ------------------*)

Definition Varset (n : nat) := set (Var n).

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

Axiom
  Proof_irrelevance :
    forall (x : Var n) (P : Varset n),
    P x -> forall a : Var n, eq_Var x a -> P a.

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

Definition Var_le (k : nat) (x : Var n) : Prop := Order x <= k.

Lemma Var_k_finite : forall k : nat, k <= n -> finite (Var n) (Var_le k).
Proof.
simple induction k.
(* k = O *)
intro H_triv.
apply (extensionality (Var n) (empty (Var n)) (Var_le 0)); auto with arith.
apply Def_set_eq; unfold incl, empty, Var_le, In in |- *; try contradiction.
intros x H_abs.
absurd (Order x <= 0); auto with arith.
(* k -> (S k) *)
clear k.
intros k Hk Sk_le_n.
elimtype (exists x : Var n, S k = Order x); auto with arith.
intros x Order_x.
apply (extensionality (Var n) (add (Var n) (Var_le k) x) (Var_le (S k))).
  (* (set_eq (Var n) (add (Var n) (Var_le k) x) (Var_le (S k))) *)
apply Def_set_eq; unfold incl, empty, Var_le, add, In in |- *.
intro xi.
simple induction 1; auto with arith.
simple induction 1; elim Order_x; auto with arith.
intros xi Oxi_le_Sk.
elim (le_nSm_le_nm_or_eq k (Order xi)); auto with arith.
intro Order_xi.
right.
pattern xi in |- *.
apply Proof_irrelevance with (x := x); auto with arith.
apply same_order_eq_Var with (k := S k); trivial with arith.
symmetry  in |- *; trivial with arith.
  (* (finite (Var n) (add (Var n) (Var_le k) x)) *)
apply finite_add; auto with arith.
unfold In, Var_le in |- *.
elim Order_x; auto with arith.
Qed.

Lemma Var_n_finite : finite (Var n) (all_ (Var n)).
Proof.
apply (extensionality (Var n) (Var_le n) (all_ (Var n))).
apply Def_set_eq; unfold incl, Var_le, all_, In in |- *; auto with arith.
apply Var_k_finite; auto with arith.
Qed.

End Intervals.

Hint Resolve Ordering_surj eq_Var_same_order eq_Var_refl eq_Var_dec
  Order_le_n Order_gt_O le_Var_total_order Var_n_finite.

Hint Immediate eq_Var_sym: bdd.


Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.

intros [] [].
+ reflexivity.
+ intros N. rewrite <- N. reflexivity.
+ reflexivity.
+ intros N. rewrite <- N. reflexivity.
Qed.


Require Import Arith List String.
Require Import CertiCoq.Benchmarks.lib.vs.
Require Import CertiCoq.Benchmarks.lib.Binom.
Require Import CertiCoq.Benchmarks.lib.Color.
Require Import CertiCoq.Benchmarks.lib.sha256.

From CertiCoq.Plugin Require Import CertiCoq.

Open Scope string.

Import ListNotations.
Import VeriStar.

(* The same benchmarks as CertiCoq benchmarks, but slightly modified
   to suspend computations with unit so we can run multiple times *)

(* Demo 1 *)

Definition demo1  (_ : unit) := List.app (List.repeat true 500) (List.repeat false 300).

(* Demo 2 *)

Fixpoint repeat2 {A : Type} (x y : A) (n : nat) :=
  match n with
  | 0 => []
  | S n => x :: y :: repeat2 x y n
  end.

Definition demo2 (_ : unit) := List.map negb (repeat2 true false 100).

(* List sum *)

Definition list_sum  (_ : unit) := List.fold_left plus (List.repeat 1 100) 0.

(* Veristar *)
Definition vs_easy (_ : unit) :=
  (fix loop (n : nat) (res : veristar_result) :=
     match n with
     | 0 =>
       match res with
       | Valid => true
       | _ => false
       end
     | S n =>
       let res := check_entailment example_ent in
       loop n res
     end) 100  Valid.

Definition vs_hard (_ : unit) :=
  match vs.main_h with
  | Valid => true
  | _ => false
  end.

(* Binom *)

Definition binom (_ : unit) := Binom.main.

(* Color *)
Definition color (_ : unit) := Color.main.

(* Sha *)

(* From the Coq website *)
Definition test := "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an environment for semi-interactive development of machine-checked proofs. Typical applications include the certification of properties of programming languages (e.g. the CompCert compiler certification project, the Verified Software Toolchain for verification of C programs, or the Iris framework for concurrent separation logic), the formalization of mathematics (e.g. the full formalization of the Feit-Thompson theorem, or homotopy type theory), and teaching.".

Definition sha (_ : unit) := sha256.SHA_256 (sha256.str_to_bytes test).

Definition sha_fast (_ : unit) := sha256.SHA_256' (sha256.str_to_bytes test).

Extraction "demo1" demo1.
Extraction "demo2" demo2.
Extraction "demo2" demo2.
Extraction "list_sum" list_sum.
(* Modified by hand *)
(* Extraction "vs_easy_aut" vs_easy. *)
(* Modified by hand *)
(* Extraction "vs_hard_aut" vs_hard. *)
(* Definition binom (_ : unit) := Binom.main. *)
(* Extraction "binom" binom. *)
(* Does not typecheck *)
Extraction "color" color.
Extraction "sha" sha.
Extraction "sha_fast" sha_fast.


(**
In this exercise we use the spin-lock from the previous exercise to implement
the running example during the lecture of the tutorial: proving that when two
threads increase a reference that's initially zero by two, the result is four.
*)
From iris.algebra Require Import auth frac_auth.
From iris.base_logic.lib Require Import invariants.
From iris.heap_lang Require Import lib.par proofmode notation.
From tutorial Require Import ex_03_spinlock.

Print heap_lang.
Eval simpl in (@language.prim_step heap_lang).

Ltac wp_exec := repeat (wp_pure _ || wp_load || wp_store).

(** The program as a heap-lang expression. We use the heap-lang [par] module for
parallel composition. *)
Definition parallel_add : expr :=
  let: "r" := ref #0 in
  let: "l" := newlock #() in
  (
    (acquire "l";; "r" <- !"r" + #2;; release "l")
  |||
    (acquire "l";; "r" <- !"r" + #2;; release "l")
  );;
  acquire "l";;
  !"r".

(** 1st proof : we only prove that the return value is even.
No ghost state is involved in this proof. *)
Section proof1.
  Context `{!heapG Σ, !spawnG Σ}.

  Definition parallel_add_inv_1 (r : loc) : iProp Σ :=
    (∃ n : Z, r ↦ #n ∗ ⌜ Zeven n ⌝)%I.

  (** *Exercise*: finish the missing cases of this proof. *)
  Lemma parallel_add_spec_1 :
    {{{ True }}} parallel_add {{{ n, RET #n; ⌜Zeven n⌝ }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add. wp_alloc r as "Hr". wp_let.
    wp_apply (newlock_spec (parallel_add_inv_1 r) with "[Hr]").
    { (* exercise *)
      unfold parallel_add_inv_1. iExists _. iFrame.
    }
    iIntros (l) "#Hl". wp_let.
    (* Q: How does the concept of "logically atomic" (in iris 1.0) appear? *)
    (* Iris 3.0
Notice, however, that the base logic does not have a notion of “threads” or “programs”,
but only of
separation
. Ultimately, the logic does not care about “who” owns the resources
under consideration; it is only concerned with reasoning about consequences of ownership
and how it can be merged and split disjointly.
     *)
    About wp_par.
    Goal
∀ (Σ : gFunctors) (heapG0 : heapG Σ), spawnG Σ
                                      → ∀ (Ψ1 Ψ2 : val → iProp Σ) (e1 e2 : expr) (Φ : val → iProp Σ),
                                      WP e1 {{ v, Ψ1 v }}
                                      -∗ WP e2 {{ v, Ψ2 v }}
                                         -∗ (∀ v1 v2 : val, Ψ1 v1 ∗ Ψ2 v2 -∗ ▷ Φ (v1, v2)%V)
                                            -∗ WP e1 ||| e2 {{ v, Φ v }}.
Proof.
  intros.
  iIntros.
Abort.
    wp_apply (par_spec (λ _, True%I) (λ _, True%I)).
    (* wp_apply (wp_par (λ _, True%I) (λ _, True%I)). *)
    - wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n) "[Hr %]".
      wp_seq. wp_load. wp_op. wp_store.
      wp_apply (release_spec with "[Hr $Hl]"); [|done].
      iExists _. iFrame "Hr". iPureIntro. by apply Zeven_plus_Zeven.
    - (* exercise *)
      wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n) "[Hr %]".
      Local Opaque release.
      wp_exec.
      Local Transparent release.
      wp_apply (release_spec); eauto. Undo 1. (* we lost "Hr" *)
      iApply (release_spec with "[Hr]").
      + iSplit; eauto.
        unfold parallel_add_inv_1. iExists _. iSplit; eauto.
        iPureIntro. apply Zeven_plus_Zeven; auto. econstructor.
      + eauto.
    - (* exercise *)
      iIntros.
      iNext.
      wp_seq.
      wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n) "[Hr %]".
      wp_exec. iApply "Post". eauto.
  Qed.

End proof1.

(** 2nd proof : we prove that the program returns 4 exactly.
We need a piece of ghost state: integer ghost variables.

Whereas we previously abstracted over an arbitrary "ghost state" [Σ] in the
proofs, we now need to make sure that we can use integer ghost variables. For
this, we add the type class constraint:

  inG Σ (authR (optionUR (exclR ZC)))

*)

Section proof2.
  Context `{!heapG Σ, !spawnG Σ, !inG Σ (authR (optionUR (exclR ZC)))}.

  Definition parallel_add_inv_2 (r : loc) (γ1 γ2 : gname) : iProp Σ :=
    (∃ n1 n2 : Z, r ↦ #(n1 + n2)
            ∗ own γ1 (● (Excl' n1)) ∗ own γ2 (● (Excl' n2)))%I.

  (** Some helping lemmas for ghost state that we need in the proof. In actual
  proofs we tend to inline simple lemmas like these, but they are here to
  make things easier to understand. *)
  Lemma ghost_var_alloc n :
    (|==> ∃ γ, own γ (● (Excl' n)) ∗ own γ (◯ (Excl' n)))%I.
  Proof.
    iMod (own_alloc (● (Excl' n) ⋅ ◯ (Excl' n))) as (γ) "[??]"; by eauto with iFrame.
  Qed.

  Lemma ghost_var_agree γ n m :
    own γ (● (Excl' n)) -∗ own γ (◯ (Excl' m)) -∗ ⌜ n = m ⌝.
  Proof.
    iIntros "Hγ● Hγ◯".
    by iDestruct (own_valid_2 with "Hγ● Hγ◯")
      as %[<-%Excl_included%leibniz_equiv _]%auth_valid_discrete_2.
  Qed.

  Lemma ghost_var_update γ n' n m :
    own γ (● (Excl' n)) -∗ own γ (◯ (Excl' m)) ==∗
      own γ (● (Excl' n')) ∗ own γ (◯ (Excl' n')).
  Proof.
    iIntros "Hγ● Hγ◯".
    iMod (own_update_2 _ _ _ (● Excl' n' ⋅ ◯ Excl' n') with "Hγ● Hγ◯") as "[$$]".
    { by apply auth_update, option_local_update, exclusive_local_update. }
    done.
  Qed.

  (** *Exercise*: finish the missing cases of the proof. *)
  Lemma parallel_add_spec_2 :
    {{{ True }}} parallel_add {{{ RET #4; True }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add. wp_alloc r as "Hr". wp_let.
    iMod (ghost_var_alloc 0) as (γ1) "[Hγ1● Hγ1◯]".
    iMod (ghost_var_alloc 0) as (γ2) "[Hγ2● Hγ2◯]".
    wp_apply (newlock_spec (parallel_add_inv_2 r γ1 γ2) with "[Hr Hγ1● Hγ2●]").
    { (* exercise *)
      unfold parallel_add_inv_2.
      iExists _, _.
      iFrame.
    }
    iIntros (l) "#Hl". wp_let.
    (**********************************************)
    (* ownership of ghost resources are splitted! *)
    (**********************************************)
    wp_apply (par_spec (λ _, own γ1 (◯ Excl' 2)) (λ _, own γ2 (◯ Excl' 2))
                with "[Hγ1◯] [Hγ2◯]").
    (* wp_apply (wp_par (λ _, own γ1 (◯ Excl' 2)) (λ _, own γ2 (◯ Excl' 2)) *)
    (*             with "[Hγ1◯] [Hγ2◯]"). *)
    - wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n1 n2) "(Hr & Hγ1● & Hγ2●)".
      wp_seq. wp_load. wp_op. wp_store.
      iDestruct (ghost_var_agree with "Hγ1● Hγ1◯") as %->.
      iMod (ghost_var_update γ1 2 with "Hγ1● Hγ1◯") as "[Hγ1● Hγ1◯]".
      wp_apply (release_spec with "[- $Hl Hγ1◯]"); [|by auto].
      iExists _, _. iFrame "Hγ1● Hγ2●". rewrite (_ : 2 + n2 = 0 + n2 + 2); [done|ring].
    - (* exercise *)
      wp_apply (acquire_spec); eauto.
      iDestruct 1 as (n1 n2) "(Hr & Hγ1● & Hγ2●)".
      wp_seq. wp_load. wp_op. wp_store.
      iDestruct (ghost_var_agree with "Hγ2● Hγ2◯") as %->.
      iMod (ghost_var_update γ2 2 with "Hγ2● Hγ2◯") as "[Hγ2● Hγ2◯]".
      wp_apply (release_spec with "[Hr Hγ1● Hγ2●]"); cycle 1.
      {
        Fail iMod (ghost_var_update γ2 2 with "Hγ1● Hγ1◯") as "[Hγ1● Hγ1◯]". (* ?????????? *)
        eauto.
      }
      iSplit; eauto.
      unfold parallel_add_inv_2.
      iExists _, _. iFrame.
      replace (n1 + 2) with (n1 + 0 + 2); eauto.
      omega.
    - (* exercise *)
      iIntros (v1 v2) "OWN".
    (***********************************************************************)
    (* splitted ghost variables are updated in each side, and merged here! *)
    (***********************************************************************)
      iNext.
      wp_seq.
      wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n1 n2) "(Hr & Hγ1● & Hγ2●)".
      iDestruct "OWN" as "[Hγ1◯ Hγ2◯]".
      iDestruct (ghost_var_agree with "Hγ1● Hγ1◯") as %->.
      iDestruct (ghost_var_agree with "Hγ2● Hγ2◯") as %->.
      wp_exec.
      change (2 + 2) with 4.
      iApply "Post".
      eauto.
  Qed.

  Lemma parallel_add_spec_2_weird :
    {{{ True }}} parallel_add {{{ RET #4; True }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add. wp_alloc r as "Hr". wp_let.
    iMod (ghost_var_alloc 0) as (γ1) "[Hγ1● Hγ1◯]".
    iMod (ghost_var_alloc 0) as (γ2) "[Hγ2● Hγ2◯]".
    wp_apply (newlock_spec (parallel_add_inv_2 r γ1 γ2) with "[Hr Hγ1● Hγ2●]").
    { (* exercise *)
      unfold parallel_add_inv_2.
      iExists _, _.
      iFrame.
    }
    iIntros (l) "#Hl". wp_let.
    wp_apply (par_spec (λ _, own γ1 (◯ Excl' 777)) (λ _, own γ2 (◯ Excl' 777))
                with "[Hγ1◯] [Hγ2◯]").
    (* wp_apply (wp_par (λ _, own γ1 (◯ Excl' 777)) (λ _, own γ2 (◯ Excl' 777)) *)
    (*             with "[Hγ1◯] [Hγ2◯]"). *)
    - wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n1 n2) "(Hr & Hγ1● & Hγ2●)".
      wp_seq. wp_load. wp_op. wp_store.
      iDestruct (ghost_var_agree with "Hγ1● Hγ1◯") as %->.
      iMod (ghost_var_update γ1 777 with "Hγ1● Hγ1◯") as "[Hγ1● Hγ1◯]".
      wp_apply (release_spec with "[- $Hl Hγ1◯]"); [|by auto].
      iExists _, _. iFrame "Hγ1● Hγ2●".
  Abort.

End proof2.

(** 3rd proof : we prove that the program returns 4 exactly, but using a
fractional authoritative ghost state.  We need another piece of ghost state. *)
Section proof3.
  Context `{!heapG Σ, !spawnG Σ, !inG Σ (frac_authR natR)}.

  Definition parallel_add_inv_3 (r : loc) (γ : gname) : iProp Σ :=
    (∃ n : nat, r ↦ #n ∗ own γ (●! n))%I.
  (* Definition parallel_add_inv_2 (r : loc) (γ1 γ2 : gname) : iProp Σ := *)
  (*   (∃ n1 n2 : Z, r ↦ #(n1 + n2) *)
  (*           ∗ own γ1 (● (Excl' n1)) ∗ own γ2 (● (Excl' n2)))%I. *)

  (** *Exercise*: finish the missing cases of the proof. *)
  Lemma parallel_add_spec_3 :
    {{{ True }}} parallel_add {{{ RET #4; True }}}.
  Proof.
    iIntros (Φ) "_ Post".
    unfold parallel_add. wp_alloc r as "Hr". wp_let.
    iMod (own_alloc (●! 0%nat ⋅ ◯! 0%nat)) as (γ) "[Hγ● [Hγ1◯ Hγ2◯]]"; [done|].
    wp_apply (newlock_spec (parallel_add_inv_3 r γ) with "[Hr Hγ●]").
    { (* exercise *)
      unfold parallel_add_inv_3.
      iExists _. iFrame.
    }
    iIntros (l) "#Hl". wp_let.
    wp_apply (par_spec (λ _, own γ (◯!{1/2} 2%nat)) (λ _, own γ (◯!{1/2} 2%nat))
                with "[Hγ1◯] [Hγ2◯]").
    (* wp_apply (wp_par (λ _, own γ (◯!{1/2} 2%nat)) (λ _, own γ (◯!{1/2} 2%nat)) *)
    (*             with "[Hγ1◯] [Hγ2◯]"). *)
    - wp_apply (acquire_spec with "Hl"). iDestruct 1 as (n) "[Hr Hγ●]".
      wp_seq. wp_load. wp_op. wp_store.
      iMod (own_update_2 _ _ _ (●! (n+2) ⋅ ◯!{1/2}2)%nat with "Hγ● Hγ1◯") as "[Hγ● Hγ1◯]".
      { rewrite (comm plus).
        by apply frac_auth_update, (op_local_update_discrete n 0 2)%nat. }
      wp_apply (release_spec with "[$Hl Hr Hγ●]"); [|by auto].
      iExists _. iFrame. by rewrite Nat2Z.inj_add.
    - (* exercise *)
      wp_apply (acquire_spec); eauto.
      iDestruct 1 as (n) "[LOC OWN]".
      wp_seq. wp_load. wp_op. wp_store.
      iMod (own_update_2 _ _ _ (●! (n+2) ⋅ ◯!{1/2}2)%nat with "OWN Hγ2◯") as "[OWN Hγ2◯]".
      { rewrite (comm plus).
        by apply frac_auth_update, (op_local_update_discrete n 0 2)%nat. }
      (* iDestruct (ghost_var_agree with "Hγ2● Hγ2◯") as %->. *)
      (* iMod (ghost_var_update γ2 2 with "Hγ2● Hγ2◯") as "[Hγ2● Hγ2◯]". *)
      wp_apply (release_spec with "[LOC OWN]"); cycle 1.
      {
        iIntros.
        Print frac_auth.
        Print lib.own.
        eauto.
      }
      iSplit; eauto.
      unfold parallel_add_inv_3.
      iExists _. iFrame.
      rewrite Nat2Z.inj_add. auto.
    - (* exercise *)
      iIntros (v1 v2) "[A B]".
      iNext.
      wp_seq.
      wp_apply (acquire_spec); eauto.
      iDestruct 1 as (n) "[LOC OWN]".
      wp_exec.

      iCombine "A B" as "OWN0".
      iDestruct (own_valid_2 with "OWN OWN0") as %->%frac_auth_agreeL.
      by iApply "Post".
  Qed.

End proof3.


Require Import Axiom_Extensionality.
Require Import nat.
Require Import bool.
Require Import option.
Require Import reflection.

Require Import setoid.

Inductive Key : Type := key : nat -> Key.

Definition beq_Key (k1 k2:Key) : bool :=
    match k1, k2 with
    | key n1, key n2    => eqb n1 n2
    end.

Lemma beq_Key_refl : forall (k:Key), beq_Key k k = true.
Proof. intros [n]. apply eqb_refl. Qed.

Lemma beq_Key_true_iff : forall (k1 k2:Key),
    beq_Key k1 k2 = true <-> k1 = k2.
Proof.
    intros [n1] [n2]. split.
    - simpl. intros H. rewrite <- eqb_semantics in H. rewrite H. reflexivity.
    - intros H. inversion H. apply eqb_refl.
Qed.

Lemma beq_Key_false_iff : forall (k1 k2:Key),
    beq_Key k1 k2 = false <-> k1 <> k2.
Proof.
    intros [n1] [n2]. split.
    - simpl. intros H. rewrite eqb_false_iff in H.
        intros H'. inversion H' as [H0]. apply H. exact H0.
    - simpl. intros H. apply eqb_false_iff. intros H'. apply H.
        rewrite H'. reflexivity.
Qed.

Definition TotalMap (a:Type) : Type := Key -> a.

Definition t_empty (a:Type) (v:a) : TotalMap a := fun _ => v.

Arguments t_empty {a} _ _.

Definition t_update (a:Type) (m:TotalMap a) (k:Key) (v:a) :=
    fun k' => if beq_Key k k' then v else m k'.

Arguments t_update {a} _ _ _ _.

Lemma t_update_eq : forall (a:Type) (m:TotalMap a) (k:Key) (v:a),
    (t_update m k v) k = v.
Proof.
    intros a m k v. unfold t_update. rewrite beq_Key_refl. reflexivity.
Qed.

Lemma t_update_neq : forall (a:Type) (m:TotalMap a) (k1 k2:Key) (v:a),
    k1 <> k2 -> t_update m k1 v k2 = m k2.
Proof.
    intros a m k1 k2 v H. unfold t_update.
    assert (beq_Key k1 k2 = false) as H'. { apply beq_Key_false_iff. exact H. }
    rewrite H'. reflexivity.
Qed.

Lemma t_update_irrel : forall (a:Type) (m:TotalMap a) (k1 k2:Key),
    t_update m k1 (m k2) k2 = m k2.
Proof.
    intros a m k1 k2. destruct (beq_Key k1 k2) eqn:E.
    - rewrite beq_Key_true_iff in E. rewrite E. apply t_update_eq.
    - rewrite beq_Key_false_iff in E. apply t_update_neq. assumption.
Qed.

Lemma t_update_shadow : forall (a:Type) (m:TotalMap a) (k:Key) (v1 v2:a),
    t_update (t_update m k v1) k v2 = t_update m k v2.
Proof.
    intros a m k v1 v2. apply extensionality. intros k'.
    destruct (beq_Key k k') eqn:H.
    - rewrite beq_Key_true_iff in H.
        rewrite H, t_update_eq, t_update_eq. reflexivity.
    - rewrite beq_Key_false_iff in H.
        rewrite t_update_neq, t_update_neq, t_update_neq.
        + reflexivity.
        + exact H.
        + exact H.
        + exact H.
Qed.

Lemma beq_KeyP : forall (x y:Key), reflect (x = y) (beq_Key x y).
Proof.
    intros x y. apply iff_reflect. symmetry. exact (beq_Key_true_iff x y).
Qed.

Lemma t_update_same : forall (a:Type) (m:TotalMap a) (k:Key),
    t_update m k (m k) = m.
Proof.
    intros a m k. apply extensionality. intros k'. destruct (beq_KeyP k k').
    - rewrite H. rewrite t_update_eq. reflexivity.
    - rewrite t_update_neq.
        + reflexivity.
        + exact H.
Qed.

Lemma t_update_permute : forall (a:Type) (m:TotalMap a) (k1 k2:Key) (v1 v2:a),
    k1 <> k2 ->
    t_update (t_update m k2 v2) k1 v1 =
    t_update (t_update m k1 v1) k2 v2.
Proof.
    intros a m k1 k2 v1 v2 H. apply extensionality. intros k.
    destruct (beq_KeyP k1 k) as [H1|H1], (beq_KeyP k2 k) as [H2|H2].
    - exfalso. apply H. rewrite H1, H2. reflexivity.
    - rewrite H1, t_update_eq. rewrite t_update_neq, t_update_eq.
        + reflexivity.
        + exact H2.
    - rewrite H2, t_update_eq. rewrite t_update_neq, t_update_eq.
        + reflexivity.
        + exact H1.
    - rewrite t_update_neq, t_update_neq, t_update_neq, t_update_neq.
        + reflexivity.
        + exact H1.
        + exact H2.
        + exact H2.
        + exact H1.
Qed.

Definition PartialMap (a:Type) : Type := TotalMap (option a).

Definition empty (a:Type) : PartialMap a := t_empty None.

Arguments empty {a} _.

Definition update (a:Type) (m:PartialMap a) (k:Key) (v:a) := t_update m k (Some v).

Arguments update {a} _ _ _ _.

Lemma update_eq : forall (a:Type) (m:PartialMap a) (k:Key) (v:a),
    (update m k v) k = Some v.
Proof. intros a m k v. unfold update. apply t_update_eq. Qed.

Lemma update_neq : forall (a:Type) (m:PartialMap a) (k k':Key) (v:a),
    k <> k' -> (update m k v) k' = m k'.
Proof. intros a m k k' v H. unfold update. apply t_update_neq. exact H. Qed.

Lemma update_shadow : forall (a:Type) (m:PartialMap a) (k:Key) (v1 v2:a),
    update (update m k v1) k v2 = update m k v2.
Proof. intros a m k v1 v2. unfold update. apply t_update_shadow. Qed.

Lemma update_same : forall (a:Type) (m:PartialMap a) (k:Key) (v:a),
    m k = Some v -> update m k v = m.
Proof. intros a m k v H. unfold update. rewrite <- H. apply t_update_same. Qed.

Lemma update_permute : forall (a:Type) (m:PartialMap a) (k1 k2:Key) (v1 v2:a),
    k1 <> k2 ->
    update (update m k2 v2) k1 v1 =
    update (update m k1 v1) k2 v2.
Proof.
    intros a m k1 k2 v1 v2 H. unfold update. apply t_update_permute. exact H.
Qed.


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Main.
Require Import Functor.Functor Functor.Functor_Ops.
Require Import NatTrans.Main.

(** Local notations for readability *)
Local Notation NID := NatTrans_id (only parsing).

Local Hint Extern 1 => progress (repeat (apply NatTrans_eq_simplify; FunExt); cbn in *).

(** for a functor p : C -> C' and a category D, the left functor extender is a functor that maps (as an object) functor F : C' -> D to F ∘ p : C -> D.  *)
Section Left_Functor_Extender.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

    Program Definition Left_Functor_Extender :
      ((Func_Cat C' D) –≻ (Func_Cat C D))%functor :=
      {|
        FO := fun F => (F ∘ p)%functor;
        FA := fun F F' N => (N ∘_h (NID p))%nattrans
      |}.

End Left_Functor_Extender.

(** for a functor p : C -> C' and a category D, the left functor extender is a functor that maps (as an object) functor F : D -> C to p ∘ F : D -> C'.  *)
Section Right_Functor_Extender.
  Context {C C' : Category} (p : (C –≻ C')%functor) (D : Category).

    Program Definition Right_Functor_Extender :
      ((Func_Cat D C) –≻ (Func_Cat D C'))%functor :=
      {|
        FO := fun F => (p ∘ F)%functor;
        FA := fun F F' N => ((NID p) ∘_h N)%nattrans
      |}.

End Right_Functor_Extender.

(** if two functors are naturally isomorphic then so are left exending with them. *)
Section Left_Functor_Extender_Iso.
  Context {C C' : Category} {p p' : (C –≻ C')%functor } (N : (p ≃ p')%natiso) (D : Category).

  Local Hint Extern 1 => (rewrite Trans_com); trivial; fail.
  Local Hint Extern 1 => rewrite <- F_compose.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj C |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u w) (left_inverse N))
  end.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj C |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u w) (right_inverse N))
  end.

  Program Definition Left_Functor_Extender_Iso :
    ((Left_Functor_Extender p D) ≃ (Left_Functor_Extender p' D))%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              fun e =>
                ((NatTrans_id_Iso e) ∘_h N)%natiso
          |};
        inverse_morphism :=
          {|
            Trans :=
              fun e =>
                ((NatTrans_id_Iso e) ∘_h (N⁻¹))%natiso
          |}
      |}
  .

End Left_Functor_Extender_Iso.

(** if two functors are naturally isomorphic then so are right exending with them. *)
Section Right_Functor_Extender_Iso.
  Context {C C' : Category} {p p' : (C –≻ C')%functor} (N : (p ≃ p')%natiso) (D : Category).

  Local Hint Extern 1 => (rewrite Trans_com); trivial; fail.
  Local Hint Extern 1 => rewrite <- F_compose.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj D, F : (D –≻ C)%functor |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u (F _o w)%object) (left_inverse N))
    end.
  Local Hint Extern 1 =>
  match goal with
    [w : @Obj D, F : (D –≻ C)%functor |- _] =>
    cbn_rewrite (f_equal (fun u => Trans u (F _o w)%object) (right_inverse N))
    end.

  Program Definition Right_Functor_Extender_Iso :
    ((Right_Functor_Extender p D) ≃ (Right_Functor_Extender p' D))%natiso
    :=
      {|
        iso_morphism :=
          {|
            Trans :=
              fun e =>
                (N ∘_h (NatTrans_id_Iso e))%natiso
          |};
        inverse_morphism :=
          {|
            Trans :=
              fun e =>
                ((N⁻¹) ∘_h (NatTrans_id_Iso e))%natiso
          |}
      |}
  .

End Right_Functor_Extender_Iso.

Section Right_Left_Functor_Extension_Iso.
  Context {B C D E : Category} (F : (B –≻ C)%functor) (G : (D –≻ E)%functor).

  (** It doesn't matter if we first extend from left or right. The resulting functors are isomorphic. *)
  Program Definition Right_Left_Functor_Extension_Iso :
    ((((Right_Functor_Extender G B) ∘ (Left_Functor_Extender F D))%functor)
       ≃ ((Left_Functor_Extender F E) ∘ (Right_Functor_Extender G C))%functor)%natiso :=
    {|
      iso_morphism := {|Trans := fun h => NatTrans_Functor_assoc_sym F h G |};
      inverse_morphism := {|Trans := fun h => NatTrans_Functor_assoc F h G |}
    |}.

End Right_Left_Functor_Extension_Iso.


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

(** This module defines type constructors for types in [Type]
    ([Datatypes.v] and [Logic.v] defined them for types in [Set]) *)

Set Implicit Arguments.

Require Import Datatypes.
Require Export Logic.

(** Negation of a type in [Type] *)

Definition notT (A:Type) := A -> False.

(** Properties of [identity] *)

Section identity_is_a_congruence.

 Variables A B : Type.
 Variable f : A -> B.

 Variables x y z : A.

 Lemma identity_sym : identity x y -> identity y x.
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma identity_trans : identity x y -> identity y z -> identity x z.
 Proof.
  destruct 2; trivial.
 Defined.

 Lemma identity_congr : identity x y -> identity (f x) (f y).
 Proof.
  destruct 1; trivial.
 Defined.

 Lemma not_identity_sym : notT (identity x y) -> notT (identity y x).
 Proof.
  red; intros H H'; apply H; destruct H'; trivial.
 Qed.

End identity_is_a_congruence.

Definition identity_ind_r :
  forall (A:Type) (a:A) (P:A -> Prop), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rec_r :
  forall (A:Type) (a:A) (P:A -> Set), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Definition identity_rect_r :
  forall (A:Type) (a:A) (P:A -> Type), P a -> forall y:A, identity y a -> P y.
 intros A x P H y H0; case identity_sym with (1 := H0); trivial.
Defined.

Hint Immediate identity_sym not_identity_sym: core.

Notation refl_id := identity_refl (only parsing).
Notation sym_id := identity_sym (only parsing).
Notation trans_id := identity_trans (only parsing).
Notation sym_not_id := not_identity_sym (only parsing).