(** * Contraction

    可縮性に関する定理や定義。 *)

Require Import Basis .
Require Import Path .
Require Import Homotopy .

(** 戦術を使う。 *)
Declare ML Module "ltac_plugin" .
Set Default Proof Mode "Classic" .

(** 記法を使う。 *)
Import Basis.Notation .
Import Basis.Notation.Path .

(** [center] と [x : A] の間に道がある。 *)
Definition center_path
  {A : Type} (cA : contr A) (x : A) : center cA = x .
Proof.
 exact (dsnd cA x) .
Defined.

(** [A] が [contr] であれば [x y : A] の間に道がある。 *)
Definition path_contr
  {A : Type} (cA : contr A) (x y : A) : x = y .
Proof.
 refine (coninv (y := center cA) _ _) .
 -
  exact (center_path cA x) .
 -
  exact (center_path cA y) .
Defined.

(** [A] が [IC : contr A] であれば、その二点の間の道 [p : paths x y] は
    [path_contr IC x y] からの道を持つ。 *)
Definition K_path_contr
  {A : Type} (cA : contr A) {x y : A} (p : x = y)
  : path_contr cA x y = p .
Proof.
 revert y p .
 refine (@paths_elim A x ?[ex_P] _) .
 exact (coninv_pp (center_path cA x)) .
Defined.

(** [A] が [contr] であれば [p q : paths x y] の間に道がある。 *)
Definition path_path_contr
  {A : Type} (cA : contr A) {x y : A} (p q : x = y) : p = q .
Proof.
 refine (coninv (y := path_contr cA x y) _ _) .
 -
  exact (K_path_contr cA p) .
 -
  exact (K_path_contr cA q) .
Defined.

(** [A] が [contr] であれば、その二点の間の [paths] も [contr] である。 *)
Definition contr_paths_contr
  {A : Type} (cA : contr A) (x y : A) : contr (x = y) .
Proof.
 refine (dpair (path_contr cA x y) _) .
 exact (K_path_contr cA) .
Defined.

(** [x] を始点とする道の集まり。 *)
Definition based_paths {X : Type} (x : X) : Type := sigma y, x = y .

(** [p : based_paths x] は [dpair x idpath] からの道を持つ。 *)
Definition path_based_paths
  {X : Type} {x : X} (p : based_paths x)
  : dpair x 1 = p .
Proof.
 refine (dsum_elim _ p) .
 refine (@paths_elim X x _ _) .
 exact 1 .
Defined.

(** [based_paths] は [contr] である。 *)
Definition contr_based_paths
  {X : Type} (x : X) : contr (based_paths x) .
Proof.
 refine (dpair (dpair x 1) _) .
 exact path_based_paths .
Defined.

(** [based_paths] の除去子。 *)
Definition based_paths_elim
  {A : Type} (a : A) (P : based_paths a -> Type)
  (c : forall a' p, P (dpair a' p))
  (x : based_paths a) : P x .
Proof.
 revert x .
 refine (dsum_elim _) .
 exact c .
Defined.

(** [paths_elim] を [based_paths] を使って書き直したもの。 *)
Definition paths_elim_by_based_paths
  {A : Type} (a : A) (P : based_paths a -> Type)
  (c : P (dpair a 1))
  (x : based_paths a) : P x .
Proof.
 revert x .
 refine (dsum_elim _) .
 refine (@paths_elim A a _ _) .
 exact c .
Defined.

(** 定義域 (domain) が [contr] である関数は、
    命題的定値 (propositionally constant) である。 *)
Definition contr_dom_constant
  {A B : Type} (cA : contr A) (f : A -> B) {x y : A}
  : f x = f y .
Proof.
 refine (ap f _) .
 exact (path_contr cA x y) .
Defined.

(** [X] が [contr] で [r : Y -> X] が引き込み (retraction) であれば、
    [Y] もまた [contr] である。

    [s : Y -> X] は [Y -> unit] と同じように [const] によって自明に
    与えられることに注意せよ。 *)
Definition contr_retract
  {X Y} (cX : contr X) (r : X -> Y) (s : Y -> X)
  (retr : forall x, r (s x) = x) : contr Y .
Proof.
 refine (dpair (r (center cX)) _) .
 refine (fun y => _) .
 refine (concat (y := r (s y)) _ _).
 -
  exact (contr_dom_constant cX r) .
 -
  exact (retr y) .
Defined.

(** 参考文献:

    * https://github.com/HoTT/HoTT/blob/1940297dd121d54d033274d84c5d023fdc56bfb4/theories/Basics/Contractible.v

    *)


(** **** SNU 4190.310, 2016 Spring *)

(** Assignment 07 *)
(** Due: 2016/05/01 23:59 *)

(* Important:
   - You are NOT allowed to use the [admit] tactic.

   - Just leave [exact GIVEUP] for those problems that you fail to prove.

   - You are ALLOWED to use any tactics including.

     [tauto], [intuition], [firstorder], [omega].
*)

Definition GIVEUP {T: Type} : T.  Admitted.

Require Export SfLib.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Fixpoint aeval (a : aexp) : nat :=
  match a with
  | ANum n => n
  | APlus a1 a2 => (aeval a1) + (aeval a2)
  | AMinus a1 a2  => (aeval a1) - (aeval a2)
  | AMult a1 a2 => (aeval a1) * (aeval a2)
  end.

Fixpoint beval (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval a1) (aeval a2)
  | BLe a1 a2   => ble_nat (aeval a1) (aeval a2)
  | BNot b1     => negb (beval b1)
  | BAnd b1 b2  => andb (beval b1) (beval b2)
  end.

Fixpoint optimize_0plus (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus (ANum 0) e2 =>
      optimize_0plus e2
  | APlus e1 e2 =>
      APlus (optimize_0plus e1) (optimize_0plus e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus e1) (optimize_0plus e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus e1) (optimize_0plus e2)
  end.

Reserved Notation "e '||' n" (at level 50, left associativity).

Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
      (ANum n) || n
  | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 || n1) -> (e2 || n2) -> (APlus e1 e2) || (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 || n1) -> (e2 || n2) -> (AMinus e1 e2) || (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp) (n1 n2 : nat),
      (e1 || n1) -> (e2 || n2) -> (AMult e1 e2) || (n1 * n2)

  where "e '||' n" := (aevalR e n) : type_scope.

Tactic Notation "aevalR_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_ANum" | Case_aux c "E_APlus"
  | Case_aux c "E_AMinus" | Case_aux c "E_AMult" ].

Theorem aeval_iff_aevalR : forall a n,
  (a || n) <-> aeval a = n.
Proof.
  (* WORKED IN CLASS *)
  split.
  Case "->".
    intros H; induction H; subst; reflexivity.
  Case "<-".
    generalize dependent n.
    induction a; simpl; intros; subst; constructor;
       try apply IHa1; try apply IHa2; reflexivity.
Qed.

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

Fixpoint optimize_1mult (a:aexp) : aexp :=
  match a with
  | ANum n =>
      ANum n
  | APlus e1 e2 =>
      APlus (optimize_1mult e1) (optimize_1mult e2)
  | AMinus e1 e2 =>
      AMinus (optimize_1mult e1) (optimize_1mult e2)
  | AMult (ANum 1) e2 =>
      optimize_1mult e2
  | AMult e1 (ANum 1) =>
      optimize_1mult e1
  | AMult e1 e2 =>
      AMult (optimize_1mult e1) (optimize_1mult e2)
  end.


(* Exercise 5 *)

Require Import BenB.

Variables A B C D : Prop.

Theorem exercise_005 : (A /\ B) -> (A \/ B).
Proof.
imp_i Sigma.
dis_i1.
con_e1 B.
hyp Sigma.
Qed.


(*
  Context (obj : Type).
  Context (C : obj -> obj -> Type).
  Context (compose : forall (X Y Z : obj), C X Y -> C Y Z -> C X Z).
*)
From ITree Require Import
     ITree
     ITreeFacts
     Basics.Monad.

Class category :=
  {
  obj : Type;
  C : obj -> obj -> Type;
  compose : forall {X Y Z : obj}, C X Y -> C Y Z -> C X Z;
  id : forall {X : obj}, C X X;
  arrow_eq : forall {X Y : obj}, C X Y -> C X Y -> Prop;
  l_id : forall (X Y : obj) (f : C X Y), arrow_eq f (compose id f);
  r_id : forall (X Y : obj) (f : C X Y), arrow_eq f (compose f id);
  assoc : forall (W X Y Z : obj) (f : C W X) (g : C X Y) (h : C Y Z),
      arrow_eq (compose f (compose g h) ) (compose (compose f g) h)
  }.

  Notation "f ∘ g" := (compose f g) (at level 50).

Section RelativeMonad.
  Context (C1 C2 : category).
  Context (T J : @obj C1 -> @obj C2).
  Context (Meq : forall (X: @obj C2) (Y : @obj C1), C X (T Y) -> C X (T Y) -> Prop ).
  Notation "f ~ g" := (Meq _ _ f g) (at level 60).

  Class RelMonad :=
    {
    rret : forall {X : obj}, C (J X) (T X);
    rbind : forall {X Y : obj}, C (J X) (T Y) -> C (T X) (T Y);
    rbind_ret : forall (X : obj), rbind (@rret X) ~ id;
    rret_bind : forall (X Y : obj) (f : C (J X) (T Y) ), rret ∘ (rbind f) ~ f;
    rbind_bind : forall (X Y Z : obj) (f : C (J X) (T Y)) (g : C (J Y) (T Z)),
        (rbind f) ∘ (rbind g) ~ rbind (f ∘ (rbind g));
    }.

End RelativeMonad.

Section TypeCat.
  Program Instance TypeCat : category :=
    {|
    obj := Type;
    C := fun A B => A -> B;
    compose := fun _ _ _ f g x => g (f x);
    id := fun _ x => x;
    arrow_eq := fun _ _ f g => forall x, f x = g x
    |}.

End TypeCat.

Section MonadRelMonad.
  Context (M : Type -> Type).
  Context (EqM : Eq1 M).
  Context (MonadM : Monad M).
  Context (MonadLawsM : MonadLawsE M).

  Program Instance RMM : RelMonad TypeCat TypeCat M (fun x => x) (fun _ _ f g => forall x, EqM _ (f x) (g x))
    :=
    {|
    rret := fun _ x => ret x;
    rbind := fun _ _ k m => bind m k;
    |}.
  Next Obligation .
    cbv. destruct MonadM. destruct MonadLawsM. unfold eq1 in *. auto.
  Qed.
  Next Obligation.
    cbv. destruct MonadLawsM. destruct MonadM. unfold eq1 in *. auto.
  Qed.
  Next Obligation.
    cbv. destruct MonadLawsM. destruct MonadM. unfold eq1 in *. auto.
  Qed.

End MonadRelMonad.

Section VectorRelMonad.


Require Export SfLib.

Module Sat.

Inductive boolean : Type :=
  | btrue : boolean
  | bfalse : boolean
  .

Tactic Notation "boolean_cases" tactic(first) ident(c) :=
  first; [ Case_aux c "btrue" | Case_aux c "bfalse" ].

Inductive formula : Type :=
  | fval : boolean -> formula
  | fvar : id -> formula
  | fite : formula -> formula -> formula -> formula
  .

Tactic Notation "formula_cases" tactic(first) ident(c) :=
  first; [ Case_aux c "fval" | Case_aux c "fvar" | Case_aux c "fite" ].

Notation ftrue := (fval btrue).
Notation ffalse := (fval bfalse).

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

Definition model : Type := (id -> boolean).

Fixpoint evaluate (f : formula) (m : model) : boolean :=
  match f with
  | fval b => b
  | fvar x => m x
  | fite p a b => match evaluate p m with
                  | btrue => evaluate a m
                  | bfalse => evaluate b m
                  end
  end.

Definition satisfies (f : formula) (m : model) : Prop :=
  evaluate f m = btrue
  .

Definition satisfiable (f : formula) : Prop :=
  exists (m : model), satisfies f m
  .

Definition unsatisfiable (f : formula) : Prop := not (satisfiable f)
  .

Inductive appears_free_in : id -> formula -> Prop :=
  | afi_var : forall x, appears_free_in x (fvar x)
  | afi_ite1 : forall x t1 t2 t3,
      appears_free_in x t1 -> appears_free_in x (fite t1 t2 t3)
  | afi_ite2 : forall x t1 t2 t3,
      appears_free_in x t2 -> appears_free_in x (fite t1 t2 t3)
  | afi_ite3 : forall x t1 t2 t3,
      appears_free_in x t3 -> appears_free_in x (fite t1 t2 t3)
  .

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_ite1" | Case_aux c "afi_ite2" | Case_aux c "afi_ite3"
  ].

Hint Constructors appears_free_in.

(* return the number of the largest id that occurs in the given formula *)
Fixpoint max_id (f : formula) : nat :=
  match f with
  | fval b => 0
  | fvar x => match x with
                | Id n => n
              end
  | fite p a b => max (max_id p) (max (max_id a) (max_id b))
  end.

Definition fresh_id (f1 : formula) (f2 : formula) : id :=
   Id (S (max (max_id f1) (max_id f2))).

End Sat.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.

(* Why3 comment *)
(* infix_ls is replaced with (x < x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma infix_lseq_def : forall (x:Z) (y:Z), (x <= y)%Z <-> ((x < y)%Z \/
  (x = y)).
exact Zle_lt_or_eq_iff.
Qed.

(* Why3 comment *)
(* infix_pl is replaced with (x + x1)%Z by the coq driver *)

(* Why3 comment *)
(* prefix_mn is replaced with (-x)%Z by the coq driver *)

(* Why3 comment *)
(* infix_as is replaced with (x * x1)%Z by the coq driver *)

(* Why3 goal *)
Lemma Assoc : forall (x:Z) (y:Z) (z:Z),
  (((x + y)%Z + z)%Z = (x + (y + z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zplus_assoc.
Qed.

(* Why3 goal *)
Lemma Unit_def_l : forall (x:Z), ((0%Z + x)%Z = x).
Proof.
exact Zplus_0_l.
Qed.

(* Why3 goal *)
Lemma Unit_def_r : forall (x:Z), ((x + 0%Z)%Z = x).
Proof.
exact Zplus_0_r.
Qed.

(* Why3 goal *)
Lemma Inv_def_l : forall (x:Z), (((-x)%Z + x)%Z = 0%Z).
Proof.
exact Zplus_opp_l.
Qed.

(* Why3 goal *)
Lemma Inv_def_r : forall (x:Z), ((x + (-x)%Z)%Z = 0%Z).
Proof.
exact Zplus_opp_r.
Qed.

(* Why3 goal *)
Lemma Comm : forall (x:Z) (y:Z), ((x + y)%Z = (y + x)%Z).
Proof.
exact Zplus_comm.
Qed.

(* Why3 goal *)
Lemma Assoc1 : forall (x:Z) (y:Z) (z:Z),
  (((x * y)%Z * z)%Z = (x * (y * z)%Z)%Z).
Proof.
intros x y z.
apply sym_eq.
apply Zmult_assoc.
Qed.

(* Why3 goal *)
Lemma Mul_distr_l : forall (x:Z) (y:Z) (z:Z),
  ((x * (y + z)%Z)%Z = ((x * y)%Z + (x * z)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_r.
Qed.

(* Why3 goal *)
Lemma Mul_distr_r : forall (x:Z) (y:Z) (z:Z),
  (((y + z)%Z * x)%Z = ((y * x)%Z + (z * x)%Z)%Z).
Proof.
intros x y z.
apply Zmult_plus_distr_l.
Qed.

(* Why3 goal *)
Lemma infix_mn_def : forall (x:Z) (y:Z), ((x - y)%Z = (x + (-y)%Z)%Z).
reflexivity.
Qed.

(* Why3 goal *)
Lemma Comm1 : forall (x:Z) (y:Z), ((x * y)%Z = (y * x)%Z).
Proof.
exact Zmult_comm.
Qed.

(* Why3 goal *)
Lemma Unitary : forall (x:Z), ((1%Z * x)%Z = x).
Proof.
exact Zmult_1_l.
Qed.

(* Why3 goal *)
Lemma NonTrivialRing : ~ (0%Z = 1%Z).
Proof.
discriminate.
Qed.

(* Why3 goal *)
Lemma Refl : forall (x:Z), (x <= x)%Z.
Proof.
intros x.
apply Zle_refl.
Qed.

(* Why3 goal *)
Lemma Trans : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z -> ((y <= z)%Z ->
  (x <= z)%Z).
Proof.
exact Zle_trans.
Qed.

(* Why3 goal *)
Lemma Antisymm : forall (x:Z) (y:Z), (x <= y)%Z -> ((y <= x)%Z -> (x = y)).
Proof.
exact Zle_antisym.
Qed.

(* Why3 goal *)
Lemma Total : forall (x:Z) (y:Z), (x <= y)%Z \/ (y <= x)%Z.
Proof.
intros x y.
destruct (Zle_or_lt x y) as [H|H].
left.
assumption.
right.
now apply Zlt_le_weak.
Qed.

(* Why3 goal *)
Lemma ZeroLessOne : (0%Z <= 1%Z)%Z.
Proof.
apply Zle_lt_or_eq_iff.
now left.
Qed.

(* Why3 goal *)
Lemma CompatOrderAdd : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z ->
  ((x + z)%Z <= (y + z)%Z)%Z.
Proof.
exact Zplus_le_compat_r.
Qed.

(* Why3 goal *)
Lemma CompatOrderMult : forall (x:Z) (y:Z) (z:Z), (x <= y)%Z ->
  ((0%Z <= z)%Z -> ((x * z)%Z <= (y * z)%Z)%Z).
Proof.
exact Zmult_le_compat_r.
Qed.


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

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 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.

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

Theorem append_nil: forall (l: lst), append l Nil = l.
Proof.
   induction l.
   { simpl. f_equal. assumption. }
   { simpl. reflexivity. }
Qed.

Theorem append_assoc:
   forall (l1 l2 l3: lst), append l1 (append l2 l3) = append (append l1 l2) l3.
Proof.
   induction l1; induction l2; induction l3; try (simpl; reflexivity).
   { simpl. rewrite <- IHl1. f_equal. }
   { simpl. lfind.  reflexivity.  }
Admitted.

Theorem append_rev_cons:
   forall (l1 l2: lst) (x: natural),
   rev (append l1 (Cons x l2)) = append (rev l2) (Cons x (rev l1)).
Proof.
   induction l1; induction l2; try (simpl; reflexivity).
   { intro. simpl. rewrite IHl1. simpl. rewrite <- append_assoc.
   f_equal. }
   { intro. simpl. rewrite IHl1. simpl. reflexivity. }
Qed.

Theorem rev_append: forall (l1 l2: lst), rev (append l1 l2) = append (rev l2) (rev l1).
Proof.
   induction l1.
   { induction l2.
   { simpl. rewrite append_rev_cons.
      rewrite <- 2 append_assoc.
      f_equal. }
   { simpl. rewrite append_nil. reflexivity. }
   }
   { intro. simpl. rewrite append_nil. reflexivity. }
Qed.

Theorem rev_involutive : forall (x : lst), eq (rev (rev x)) x.
Proof.
   induction x.
   { simpl. rewrite rev_append. simpl. f_equal.
   assumption. }
   { simpl. reflexivity. }
Qed.

Theorem theorem0 : forall (x : lst), eq (rev (append (rev x) Nil)) x.
Proof.
   intro.
   rewrite append_nil.
   apply rev_involutive.
Qed.


Coq < Section Simplification.

Coq < Variables P Q : Prop.
P is assumed
Q is assumed

Coq < Goal (P /\ Q) -> P.
1 subgoal

  P : Prop
  Q : Prop
  ============================
   P /\ Q -> P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : P /\ Q
  ============================
   P

Unnamed_thm < elim H.
1 subgoal

  P : Prop
  Q : Prop
  H : P /\ Q
  ============================
   P -> Q -> P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : P /\ Q
  H0 : P
  ============================
   Q -> P

Unnamed_thm < intro.
1 subgoal

  P : Prop
  Q : Prop
  H : P /\ Q
  H0 : P
  H1 : Q
  ============================
   P

Unnamed_thm < exact H0.
Proof completed.

Unnamed_thm < Qed.
intro.
elim H.
intro.
intro.
exact H0.

Unnamed_thm is defined


Load "Dep/Array".

Fixpoint complete_leaf_tree A r d :=
  match d with
  | 0 => A
  | S d' => array (complete_leaf_tree A r d') r
  end.

Section Example.

Compute complete_leaf_tree nat 2 3.

Check Array [|Array [|Array [|0; 1|]; Array [|2; 3|]|]; Array [|Array [|4; 5|]; Array [|6; 7|]|]|] :
  complete_leaf_tree nat 2 3.

End Example.

Fixpoint complete_leaf_tree_to_list {A r d} (clt : complete_leaf_tree A r d) :=
  match d with
  | 0 => fun (clt : complete_leaf_tree A r 0) =>
    [clt : A]
  | S d' => fun (clt : complete_leaf_tree A r (S d')) =>
    List.flat_map complete_leaf_tree_to_list (array_to_list clt)
  end clt.

Theorem complete_leaf_tree_to_list_length :
  forall {A r d} (clt : complete_leaf_tree A r d),
  length (complete_leaf_tree_to_list clt) = Nat.pow r d.
Proof.
  intros ? ? ?. induction d; intros clt.
  - auto.
  - simpl. rewrite flat_map_length_constant_length_for_type with (k := Nat.pow r d).
    + rewrite array_to_list_length. auto.
    + auto.
Qed.

Inductive digital_list {A r} : nat -> Type :=
  | DigitalListNil : digital_list 0
  | DigitalListCons :
      forall {d} k,
      k < r ->
      array (complete_leaf_tree A r d) k ->
      digital_list d ->
      digital_list (S d).

Arguments digital_list : clear implicits.

Inductive concrete_digital_list {A r} :=
  | ConcreteDigitalList : forall d, digital_list A r d -> concrete_digital_list.

Arguments concrete_digital_list : clear implicits.

Fixpoint digital_list_to_list {A r d} (dl : digital_list A r d) :=
  match dl with
  | DigitalListNil => []
  | DigitalListCons k _ a dl' =>
    List.flat_map complete_leaf_tree_to_list (array_to_list a) ++ digital_list_to_list dl'
  end.

Definition concrete_digital_list_to_list {A r} (cdl : concrete_digital_list A r) :=
  let '(ConcreteDigitalList _ dl) := cdl in digital_list_to_list dl.

Section Example.

Compute array (complete_leaf_tree nat 2 3) 2.

Check
  DigitalListCons _ (le_n _)
  (Array [|Array [|Array [|Array [|0; 1|]; Array [|2; 3|]|]; Array [|Array [|4; 5|]; Array [|6; 7|]|]|]|] :
    array (complete_leaf_tree _ _ 3) _)
  (
    DigitalListCons _ (le_S _ _ (le_n _))
    (Array [||])
    (
      DigitalListCons _ (le_n _)
      (Array [| Array [|8; 9|]|] : array (complete_leaf_tree _ _ 1) _)
      (
        DigitalListCons _ (le_S _ _ (le_n _))
        (Array [||])
        DigitalListNil
      )
    )
  ).

End Example.

Fixpoint digital_list_length {A r d} (dl : digital_list A r d) :=
  match dl with
  | DigitalListNil => 0
  | DigitalListCons k _ _ dl' => (Nat.pow r (pred d)) * k + digital_list_length dl'
  end.

Definition concrete_digital_list_length {A r} (cdl : concrete_digital_list A r) :=
  let '(ConcreteDigitalList _ dl) := cdl in digital_list_length dl.

Theorem digital_list_length_correct :
  forall {A r d} (dl : digital_list A r d),
  digital_list_length dl = length (digital_list_to_list dl).
Proof.
  intros ? ? ? ?. induction dl.
  - auto.
  - simpl. rewrite IHdl; clear IHdl. rewrite List.app_length. apply PeanoNat.Nat.add_cancel_r.
    clear - a. destruct a as [sl]. unfold array_to_list. induction sl.
    + auto.
    + rewrite <- mult_n_Sm. rewrite IHsl; clear IHsl. simpl. rewrite List.app_length.
      rewrite complete_leaf_tree_to_list_length. lia.
Qed.

Theorem concrete_digital_list_length_correct :
  forall {A r} (cdl : concrete_digital_list A r),
  concrete_digital_list_length cdl = length (concrete_digital_list_to_list cdl).
Proof.
  intros ? ? ?. destruct cdl as (d & dl). apply digital_list_length_correct.
Qed.

Theorem digital_list_length_upper_bound :
  forall {A r d} (dl : digital_list A r d),
  digital_list_length dl < Nat.pow r d.
Proof.
  intros ? ? ? ?. induction dl.
  - auto.
  - simpl. nia.
Qed.

Fixpoint complete_leaf_tree_nth {A r d} (isl : sized_list nat d) (clt : complete_leaf_tree A r d) : option A :=
  match d with
  | 0 => fun (isl : sized_list nat 0) (clt : complete_leaf_tree A r 0) =>
    Some (clt : A)
  | S d' => fun (isl : sized_list nat (S d')) (clt : complete_leaf_tree A r (S d')) =>
    match isl with
    | @SizedListCons _ d'0 i isl'0 => fun (Heqd : S d'0 = S d') =>
      let isl' := rew (eq_add_S _ _ Heqd) in isl'0 in
      option_flat_map (complete_leaf_tree_nth isl') (array_nth i clt)
    end eq_refl
  end isl clt.

Section Example.

Compute
  complete_leaf_tree_nth
    [|1; 1; 0|]
    (Array [|Array [|Array [|0; 1|]; Array [|2; 3|]|]; Array [|Array [|4; 5|]; Array [|6; 7|]|]|]).

End Example.

Theorem complete_leaf_tree_nth_correct :
  forall {A r d} (isl : sized_list nat d) (clt : complete_leaf_tree A r d),
  sized_list_forall (fun i => i < r) isl ->
  complete_leaf_tree_nth isl clt =
    List.nth_error (complete_leaf_tree_to_list clt) (indexes_sized_list_to_index r isl).
Proof.
  intros ? ? ?. induction d; intros ? ? ?.
  - remember 0. destruct isl.
    + auto.
    + discriminate.
  - remember (S d) as d0. destruct isl.
    + discriminate.
    + injection Heqd0 as ->. destruct H as (? & ?). simpl.
      rewrite PeanoNat.Nat.mul_comm. rewrite flat_map_list_nth_error_constant_length_for_type.
      * rewrite array_nth_correct. apply option_flat_map_ext. intros clt'. apply IHd. auto.
      * apply complete_leaf_tree_to_list_length.
      * apply indexes_sized_list_to_index_upper_bound. auto.
Qed.

Fixpoint complete_leaf_tree_update {A r d} (isl : sized_list nat d)
  (x : A) (clt : complete_leaf_tree A r d) : option (complete_leaf_tree A r d) :=
  match d with
  | 0 => fun (isl : sized_list nat 0) (clt : complete_leaf_tree A r 0) =>
    Some (x : complete_leaf_tree A r 0)
  | S d' => fun (isl : sized_list nat (S d')) (clt : complete_leaf_tree A r (S d')) =>
    match isl with
    | @SizedListCons _ d'0 i isl'0 => fun (Heqd : S d'0 = S d') =>
      let isl' := rew (eq_add_S _ _ Heqd) in isl'0 in
      option_flat_map
        (fun clt' => array_update i clt' clt)
        (option_flat_map (complete_leaf_tree_update isl' x) (array_nth i clt))
    end eq_refl : option (complete_leaf_tree A r (S d'))
  end isl clt.

Theorem complete_leaf_tree_update_correct :
  forall {A r d} x (isl : sized_list nat d) (clt : complete_leaf_tree A r d),
  sized_list_forall (fun i => i < r) isl ->
  option_map complete_leaf_tree_to_list (complete_leaf_tree_update isl x clt) =
    list_update (indexes_sized_list_to_index r isl) x (complete_leaf_tree_to_list clt).
Proof.
  intros ? ? ? ?. induction d; intros ? ? ?.
  - simpl. remember (indexes_sized_list_to_index r (d := 0) isl) as i. destruct i.
    + auto.
    + exfalso. remember 0. destruct isl; discriminate.
  - remember (S d) as d0. destruct isl.
    + discriminate.
    + rename n0 into i. injection Heqd0 as ->. destruct H as (? & ?). simpl. fold complete_leaf_tree.
      rewrite PeanoNat.Nat.mul_comm. rewrite flat_map_list_update_constant_length_for_type.
      * rewrite array_nth_correct. remember (List.nth_error (array_to_list clt) i) as o0.
        fold complete_leaf_tree in o0. setoid_rewrite <- Heqo0. destruct o0 as [clt0 | ]; auto.
        simpl. rewrite <- IHd; auto; clear IHd. remember (complete_leaf_tree_update isl x clt0) as o1.
        destruct o1; auto. simpl.
        replace (
          fun clt0 =>
            @List.flat_map (complete_leaf_tree A r d) A (@complete_leaf_tree_to_list A r d)
              (@array_to_list (complete_leaf_tree A r d) r clt0)
        ) with (
          Basics.compose
          (@List.flat_map (complete_leaf_tree A r d) A (@complete_leaf_tree_to_list A r d))
          (fun clt0 => @array_to_list (complete_leaf_tree A r d) r clt0)
        ) by auto.
        rewrite <- option_map_option_map. rewrite array_update_correct.
        rewrite (option_map_ext _ _ _ (List.flat_map_concat_map _)).
        replace (
          fun (l : list (complete_leaf_tree A r d)) => List.concat (List.map complete_leaf_tree_to_list l)
        ) with (
          Basics.compose
          (@List.concat _)
          (List.map (@complete_leaf_tree_to_list A r d))
        ) by auto.
        rewrite <- option_map_option_map. f_equal.
        symmetry. apply list_update_list_map.
      * apply complete_leaf_tree_to_list_length.
      * apply indexes_sized_list_to_index_upper_bound. auto.
Qed.

Fixpoint complete_leaf_tree_pop {A r d} (clt : complete_leaf_tree A r d) : option (digital_list A r d * A) :=
  match d with
  | 0 => fun (Heqd : d = 0) (clt : complete_leaf_tree A r 0) =>
    Some (DigitalListNil, clt : A)
  | S d' => fun (Heqd : d = S d') =>
    match r with
    | 0 => fun _ _ => None
    | S r' => fun (Heqn : r = S r') (clt : complete_leaf_tree A (S r') (S d')) =>
      let (sl0, x) := array_pop clt in
      option_map
        (fun '(dl', y) => (DigitalListCons r' (le_n _) sl0 dl', y))
        (complete_leaf_tree_pop x)
    end eq_refl
  end eq_refl clt.

Theorem complete_leaf_tree_pop_correct :
  forall {A r d} (clt : complete_leaf_tree A r d),
  r > 1 ->
  option_map
    (fun '(dl, x) => digital_list_to_list dl ++ [x])
    (complete_leaf_tree_pop clt) = Some (complete_leaf_tree_to_list clt).
Proof.
  intros ? ? ? ? ?. induction d.
  - auto.
  - simpl. destruct r; try lia. remember (array_pop clt) as a0_clt0. fold complete_leaf_tree in a0_clt0.
    destruct a0_clt0 as (a0, clt0). rewrite option_map_option_map. unfold Basics.compose.
    specialize (IHd clt0). remember (complete_leaf_tree_pop clt0) as o0.
    destruct o0  as [(dl0, x) | ]; try discriminate. simpl. f_equal. simpl in IHd. injection IHd as ?.
    rewrite <- List.app_assoc. rewrite H0. specialize (array_pop_correct clt) as ?. rewrite <- Heqa0_clt0 in H1.
    rewrite <- H1. rewrite List.flat_map_app. simpl. rewrite List.app_nil_r. auto.
Qed.

Definition digital_list_empty {A r} : digital_list A r 0 := DigitalListNil.

Definition concrete_digital_list_empty {A r} : concrete_digital_list A r :=
  ConcreteDigitalList 0 digital_list_empty.

Theorem digital_list_empty_correct :
  forall {A r},
  digital_list_to_list (digital_list_empty : digital_list A r 0) = [].
Proof.
  auto.
Qed.

Theorem concrete_digital_list_empty_correct :
  forall {A r},
  concrete_digital_list_to_list (concrete_digital_list_empty : concrete_digital_list A r) = [].
Proof.
  auto.
Qed.

Fixpoint digital_list_nth_inner {A r d} (isl : sized_list nat d) (dl : digital_list A r d)
  {struct dl} : option A :=
  match dl with
  | DigitalListNil => fun (isl : sized_list nat 0) =>
    None
  | @DigitalListCons _ _ d' k _ a dl' => fun (isl : sized_list nat (S d')) =>
    match isl with
    | @SizedListCons _ d'0 i isl'0 => fun (Heqd : S d'0 = S d') =>
      let isl' := rew (eq_add_S _ _ Heqd) in isl'0 in
      if Nat.eqb i k
      then digital_list_nth_inner isl' dl'
      else option_flat_map (complete_leaf_tree_nth isl') (array_nth i a)
    end eq_refl
  end isl.

Definition digital_list_nth {A r d} i (dl : digital_list A r d) : option A :=
  if Nat.ltb i (digital_list_length dl)
  then digital_list_nth_inner (indexes_sized_list_of_index r i) dl
  else None.

Definition concrete_digital_list_nth {A r} i (cdl : concrete_digital_list A r) : option A :=
  let '(ConcreteDigitalList _ dl) := cdl in digital_list_nth i dl.

Theorem digital_list_nth_inner_correct :
  forall {A r d} (isl : sized_list nat d) (dl : digital_list A r d),
  sized_list_forall (fun i => i < r) isl ->
  indexes_sized_list_to_index r isl < digital_list_length dl ->
  digital_list_nth_inner isl dl =
    List.nth_error (digital_list_to_list dl) (indexes_sized_list_to_index r isl).
Proof.
  intros ? ? ? ? ? ? ?. induction dl.
  - simpl. symmetry. apply list_nth_error_nil.
  - simpl. dependent destruction isl. rename n0 into i.
    unrew. destruct H as (? & ?). simpl in H0.
    assert (length (List.flat_map complete_leaf_tree_to_list (array_to_list a)) = Nat.pow r d * k). {
      rewrite (flat_map_length_constant_length_for_type _ _ (Nat.pow r d)).
      - rewrite array_to_list_length. lia.
      - apply complete_leaf_tree_to_list_length.
    }
    destruct (PeanoNat.Nat.eqb_spec i k).
    + subst i. rewrite IHdl; auto; try nia; clear IHdl. simpl. rewrite List.nth_error_app2.
      * f_equal. rewrite H2. lia.
      * rewrite H2. lia.
    + clear IHdl. simpl. rewrite List.nth_error_app1.
      * rewrite PeanoNat.Nat.mul_comm. rewrite flat_map_list_nth_error_constant_length_for_type.
        -- rewrite <- array_nth_correct. apply option_flat_map_ext. intros clt.
           apply complete_leaf_tree_nth_correct. auto.
        -- apply complete_leaf_tree_to_list_length.
        -- apply indexes_sized_list_to_index_upper_bound. auto.
      * specialize (indexes_sized_list_to_index_upper_bound isl H1) as ?.
        specialize (digital_list_length_upper_bound dl) as ?.
        rewrite H2. nia.
Qed.

Theorem digital_list_nth_correct :
  forall {A r d} i (dl : digital_list A r d),
  r > 1 ->
  digital_list_nth i dl = List.nth_error (digital_list_to_list dl) i.
Proof.
  intros ? ? ? ? ? ?. unfold digital_list_nth.
  destruct (PeanoNat.Nat.ltb_spec0 i (digital_list_length dl)).
  - assert (indexes_sized_list_to_index r (d := d) (indexes_sized_list_of_index r i) = i). {
      apply indexes_sized_list_to_of_correct.
      - auto.
      - apply (PeanoNat.Nat.le_trans _ _ _ l). apply PeanoNat.Nat.lt_le_incl.
        apply digital_list_length_upper_bound.
    }
    rewrite digital_list_nth_inner_correct.
    + rewrite H0. auto.
    + apply indexes_sized_list_of_index_upper_bound. auto.
    + rewrite H0. auto.
  - rewrite digital_list_length_correct in n. symmetry. apply List.nth_error_None. lia.
Qed.

Theorem concrete_digital_list_nth_correct :
  forall {A r} i (cdl : concrete_digital_list A r),
  r > 1 ->
  concrete_digital_list_nth i cdl = List.nth_error (concrete_digital_list_to_list cdl) i.
Proof.
  intros ? ? ? ? ?. destruct cdl as (d & dl). apply digital_list_nth_correct. auto.
Qed.

Section Example.

Compute
  let cdl :=
    ConcreteDigitalList
    _
    (
      DigitalListCons _ (le_n _)
      (Array [|Array [|Array [|Array [|0; 1|]; Array [|2; 3|]|]; Array [|Array [|4; 5|]; Array [|6; 7|]|]|]|] :
        array (complete_leaf_tree _ _ 3) _)
      (
        DigitalListCons _ (le_S _ _ (le_n _))
        (Array [||])
        (
          DigitalListCons _ (le_n _)
          (Array [| Array [|8; 9|]|] : array (complete_leaf_tree _ _ 1) _)
          (
            DigitalListCons _ (le_S _ _ (le_n _))
            (Array [||])
            DigitalListNil
          )
        )
      )
    ) in
  let f :=
    fix f i :=
      match i with
      | 0 => []
      | S i' => f i' ++ [concrete_digital_list_nth i' cdl]
      end in
  (
    concrete_digital_list_to_list cdl,
    f (concrete_digital_list_length cdl),
    concrete_digital_list_nth 100 cdl
  ).

End Example.

Fixpoint digital_list_update_inner {A r d} (isl : sized_list nat d) (x : A) (dl : digital_list A r d)
  {struct dl} : option (digital_list A r d) :=
  match dl with
  | DigitalListNil => fun (isl : sized_list nat 0) =>
    None
  | @DigitalListCons _ _ d' k Hlt a dl' => fun (isl : sized_list nat (S d')) =>
    match isl with
    | @SizedListCons _ d'0 i isl'0 => fun (Heqd : S d'0 = S d') =>
      let isl' := rew (eq_add_S _ _ Heqd) in isl'0 in
      if Nat.eqb i k
      then
        option_map
          (DigitalListCons k Hlt a)
          (digital_list_update_inner isl' x dl')
      else
        option_map
          (fun a0 => DigitalListCons k Hlt a0 dl')
          (
            option_flat_map
              (fun clt' => array_update i clt' a)
              (option_flat_map (complete_leaf_tree_update isl' x) (array_nth i a))
          )
    end eq_refl : option (digital_list A r (S d'))
  end isl.

Definition digital_list_update {A r d} i x (dl : digital_list A r d) : option (digital_list A r d) :=
  if Nat.ltb i (digital_list_length dl)
  then digital_list_update_inner (indexes_sized_list_of_index r i) x dl
  else None.

Definition concrete_digital_list_update {A r} i x (cdl : concrete_digital_list A r) :
  option (concrete_digital_list A r) :=
  let '(ConcreteDigitalList _ dl) := cdl in
    option_map (ConcreteDigitalList _) (digital_list_update i x dl).

Theorem digital_list_update_inner_correct :
  forall {A r d} (isl : sized_list nat d) x (dl : digital_list A r d),
  sized_list_forall (fun i => i < r) isl ->
  indexes_sized_list_to_index r isl < digital_list_length dl ->
  option_map digital_list_to_list (digital_list_update_inner isl x dl) =
    list_update (indexes_sized_list_to_index r isl) x (digital_list_to_list dl).
Proof.
  intros ? ? ? ? ? ? ? ?. induction dl.
  - simpl. symmetry. apply list_update_nil.
  - simpl. dependent destruction isl. rename n0 into i.
    unrew. destruct H as (? & ?). simpl in H0.
    assert (length (List.flat_map complete_leaf_tree_to_list (array_to_list a)) = Nat.pow r d * k). {
      rewrite (flat_map_length_constant_length_for_type _ _ (Nat.pow r d)).
      - rewrite array_to_list_length. lia.
      - apply complete_leaf_tree_to_list_length.
    }
    destruct (PeanoNat.Nat.eqb_spec i k).
    + subst i. simpl. rewrite list_update_app_2.
      * rewrite H2.
        replace (Nat.pow r d * k + indexes_sized_list_to_index r isl - Nat.pow r d * k)
          with (indexes_sized_list_to_index r isl) by lia.
        rewrite <- IHdl; auto; try nia; clear IHdl.
        remember (digital_list_update_inner isl x dl) as o0. destruct o0; auto.
      * rewrite H2. lia.
    + clear IHdl. simpl. rewrite list_update_app_1.
      * rewrite PeanoNat.Nat.mul_comm. rewrite flat_map_list_update_constant_length_for_type.
        -- rewrite <- array_nth_correct. remember (array_nth i a) as o0. destruct o0; auto. simpl.
           rewrite option_map_option_map. unfold Basics.compose. simpl.
           replace (
             fun (a0 : array (complete_leaf_tree A r d) k) =>
               List.flat_map complete_leaf_tree_to_list (array_to_list a0) ++ digital_list_to_list dl
           ) with (
             Basics.compose
             (fun l0 => l0 ++ digital_list_to_list dl)
             (
               Basics.compose
               (List.flat_map complete_leaf_tree_to_list)
               (@array_to_list (complete_leaf_tree A r d) k)
             )
           ) by auto.
           rewrite <- option_map_option_map. f_equal.
           rewrite <- option_map_option_map. rewrite option_map_option_flat_map.
           rewrite (option_flat_map_ext _ _ _ (fun _ => array_update_correct _ _ _)).
           rewrite ? option_map_option_flat_map. rewrite <- complete_leaf_tree_update_correct.
           rewrite option_map_flat_option_map. unfold Basics.compose.
           apply option_flat_map_ext. intros clt0. rewrite list_update_list_map.
           ++ remember (list_update i clt0 (array_to_list a)) as o1. destruct o1; auto. simpl.
              f_equal. apply List.flat_map_concat_map.
           ++ auto.
        -- apply complete_leaf_tree_to_list_length.
        -- apply indexes_sized_list_to_index_upper_bound. auto.
      * specialize (indexes_sized_list_to_index_upper_bound isl H1) as ?.
        specialize (digital_list_length_upper_bound dl) as ?.
        rewrite H2. nia.
Qed.

Theorem digital_list_update_correct :
  forall {A r d} i x (dl : digital_list A r d),
  r > 1 ->
  option_map digital_list_to_list (digital_list_update i x dl) = list_update i x (digital_list_to_list dl).
Proof.
  intros ? ? ? ? ? ? ?. unfold digital_list_update.
  destruct (PeanoNat.Nat.ltb_spec0 i (digital_list_length dl)).
  - assert (indexes_sized_list_to_index r (d := d) (indexes_sized_list_of_index r i) = i). {
      apply indexes_sized_list_to_of_correct.
      - auto.
      - apply (PeanoNat.Nat.le_trans _ _ _ l). apply PeanoNat.Nat.lt_le_incl.
        apply digital_list_length_upper_bound.
    }
    rewrite digital_list_update_inner_correct.
    + rewrite H0. auto.
    + apply indexes_sized_list_of_index_upper_bound. auto.
    + rewrite H0. auto.
  - rewrite digital_list_length_correct in n. symmetry. apply list_update_None. lia.
Qed.

Theorem concrete_digital_list_update_correct :
  forall {A r} i x (cdl : concrete_digital_list A r),
  r > 1 ->
  option_map concrete_digital_list_to_list (concrete_digital_list_update i x cdl) =
    list_update i x (concrete_digital_list_to_list cdl).
Proof.
  intros ? ? ? ? ? ?. destruct cdl as (d & dl). unfold concrete_digital_list_to_list. simpl.
  rewrite option_map_option_map. apply digital_list_update_correct. auto.
Qed.

Fixpoint digital_list_push {A r d} (x : A) (dl : digital_list A r d) :
  option (complete_leaf_tree A r d) * (digital_list A r d) :=
  match dl with
  | DigitalListNil => fun _ =>
    (Some (x : complete_leaf_tree A r 0), DigitalListNil)
  | @DigitalListCons _ _ d' k Hlt a dl' => fun (Heqd : d = S d') =>
    match digital_list_push x dl' with
    | (None, dl'0) => (None, @DigitalListCons _ _ d' k Hlt a dl'0)
    | (Some clt0, dl'0) =>
      match Compare_dec.le_lt_eq_dec (S k) r Hlt with
      | left Hlt0 => (None, @DigitalListCons _ _ d' (S k) Hlt0 (array_push clt0 a) dl'0)
      | right Heq =>
        match Compare_dec.zerop r with
        | left _ => (None, @DigitalListCons _ _ d' k Hlt a dl'0)
        | right Hlt0 => (Some (rew Heq in (array_push clt0 a)), @DigitalListCons _ _ d' 0 Hlt0 array_empty dl'0)
        end
      end
    end
  end eq_refl.

Definition concrete_digital_list_push {A r} (x : A) (cdl : concrete_digital_list A r) :
  concrete_digital_list A r :=
  let '(ConcreteDigitalList d dl) := cdl in
    match digital_list_push x dl with
    | (None, dl0) => ConcreteDigitalList d dl0
    | (Some clt0, dl0) =>
      match Compare_dec.lt_dec 1 r with
      | left Hlt => ConcreteDigitalList (S d) (@DigitalListCons _ _ d 1 Hlt (array_single clt0) dl0)
      | right _ => ConcreteDigitalList d dl
      end
    end.

Theorem digital_list_push_correct :
  forall {A r d} x (dl : digital_list A r d),
  r > 1 ->
  (let (clt0_o, dl0) := digital_list_push x dl in
    match clt0_o with
    | None => []
    | Some clt0 => complete_leaf_tree_to_list clt0
    end ++ digital_list_to_list dl0) = digital_list_to_list dl ++ [x].
Proof.
  intros ? ? ? ? ? ?. induction dl.
  - auto.
  - simpl. fold complete_leaf_tree.
    remember (digital_list_push x dl) as clt0_o_dl0. destruct clt0_o_dl0 as (clt0_o, dl0).
    destruct clt0_o as [clt0 | ].
    + destruct (Compare_dec.le_lt_eq_dec (S k) r l).
      * simpl. rewrite <- List.app_assoc. rewrite <- IHdl.
        rewrite array_push_correct. rewrite List.flat_map_app. simpl.
        do 2 rewrite <- List.app_assoc. auto.
      * destruct (Compare_dec.zerop r); try lia. simpl. rewrite <- List.app_assoc. rewrite <- IHdl.
        unrew. rewrite array_push_correct. rewrite List.flat_map_app. simpl.
        do 2 rewrite <- List.app_assoc. auto.
    + simpl. simpl in IHdl. rewrite IHdl. apply List.app_assoc.
Qed.

Theorem concrete_digital_list_push_correct :
  forall {A r} x (cdl : concrete_digital_list A r),
  r > 1 ->
  concrete_digital_list_to_list (concrete_digital_list_push x cdl) =
    concrete_digital_list_to_list cdl ++ [x].
Proof.
  intros ? ? ? ? ?. destruct cdl as (d & dl). unfold concrete_digital_list_to_list. simpl.
  rewrite <- digital_list_push_correct; auto.
  remember (digital_list_push x dl) as clt0_o_dl0. destruct clt0_o_dl0 as (clt0_o, dl0).
  destruct clt0_o as [clt0 | ].
  - destruct (Compare_dec.lt_dec 1 r); try lia. simpl. rewrite <- List.app_assoc. auto.
  - auto.
Qed.

Fixpoint digital_list_pop {A r d} (dl : digital_list A r d) : option (digital_list A r d * A) :=
  match dl with
  | DigitalListNil => None
  | @DigitalListCons _ _ d' k Hlt a dl' =>
    match digital_list_pop dl' with
    | None =>
      match k with
      | 0 => fun _ _ =>
        None
      | S k' => fun (a : array (complete_leaf_tree A r d') (S k')) (Hlt : S k' < r) =>
        let (a0, blt) := array_pop a in
        option_map
          (fun '(dl'0, x) => (@DigitalListCons _ _ d' k' (PeanoNat.Nat.lt_succ_l _ _ Hlt) a0 dl'0, x))
          (complete_leaf_tree_pop blt)
      end a Hlt
    | Some (dl'0, x) => Some (@DigitalListCons _ _ d' k Hlt a dl'0, x)
    end
  end.

Definition concrete_digital_list_pop {A r} (cdl : concrete_digital_list A r) :
  option (concrete_digital_list A r * A) :=
  let '(ConcreteDigitalList d dl) := cdl in
    option_map
      (fun '(dl0, x) => (ConcreteDigitalList d dl0, x))
      (digital_list_pop dl).

Lemma digital_list_pop_None :
  forall {A r d} (dl : digital_list A r d),
  r > 1 ->
  digital_list_pop dl = None ->
  digital_list_to_list dl = [].
Proof.
  intros ? ? ? ? ? ?. induction dl.
  - auto.
  - simpl. simpl in H0. remember (digital_list_pop dl) as o0. destruct o0 as [(dl'0, x) | ].
    + discriminate.
    + destruct k.
      * remember 0. destruct a as [sl]. destruct sl; try discriminate. rewrite IHdl; auto.
      * remember (array_pop a) as a0_clt0. destruct a0_clt0 as (a0, clt0).
        specialize (complete_leaf_tree_pop_correct clt0 H) as ?.
        remember (complete_leaf_tree_pop clt0) as o1. destruct o1; discriminate.
Qed.

Theorem digital_list_pop_correct :
  forall {A r d} (dl : digital_list A r d),
  r > 1 ->
  option_map
    (fun '(dl0, x) => (digital_list_to_list dl0, x))
    (digital_list_pop dl) = list_pop (digital_list_to_list dl).
Proof.
  intros ? ? ? ? ?. induction dl.
  - auto.
  - simpl. remember (digital_list_pop dl) as o0. destruct o0 as [(dl'0, x) | ].
    + simpl. simpl in IHdl. symmetry in IHdl. eapply list_pop_app_Some in IHdl. rewrite IHdl. auto.
    + destruct k.
      * simpl. remember 0. destruct a as [sl]. destruct sl; try discriminate. auto.
      * remember (array_pop a) as a0_clt0. destruct a0_clt0 as (a0, clt0).
        rewrite option_map_option_map. unfold Basics.compose.
        specialize (complete_leaf_tree_pop_correct clt0 H) as ?.
        remember (complete_leaf_tree_pop clt0) as o1. destruct o1 as [(dl0, x) | ]; try discriminate.
        simpl. simpl in H0. injection H0 as ?.
        specialize (array_pop_correct a) as ?. rewrite <- Heqa0_clt0 in H1.
        rewrite <- H1. rewrite List.flat_map_app. simpl. rewrite List.app_nil_r. rewrite <- List.app_assoc.
        rewrite <- H0. rewrite <- List.app_assoc. simpl.
        symmetry in Heqo0. apply digital_list_pop_None in Heqo0; auto. rewrite Heqo0.
        symmetry. apply list_pop_cons. apply List.app_assoc.
Qed.

Theorem concrete_digital_list_pop_correct :
  forall {A r} (cdl : concrete_digital_list A r),
  r > 1 ->
  option_map
    (fun '(cdl0, x) => (concrete_digital_list_to_list cdl0, x))
    (concrete_digital_list_pop cdl) = list_pop (concrete_digital_list_to_list cdl).
Proof.
  intros ? ? ? ?. destruct cdl as (d & dl). unfold concrete_digital_list_to_list. simpl.
  rewrite option_map_option_map. unfold Basics.compose. rewrite <- digital_list_pop_correct; auto.
  apply option_map_ext. intros (dl0, x). auto.
Qed.

Section Example.

About concrete_digital_list_to_list.

About concrete_digital_list_empty.
Check @concrete_digital_list_empty_correct.

About concrete_digital_list_length.
Check @concrete_digital_list_length_correct.

About concrete_digital_list_nth.
Check @concrete_digital_list_nth_correct.

About concrete_digital_list_update.
Check @concrete_digital_list_update_correct.

About concrete_digital_list_push.
Check @concrete_digital_list_push_correct.

About concrete_digital_list_pop.
Check @concrete_digital_list_pop_correct.

End Example.


Require Import Coq.omega.Omega.
Require Import Bedrock.Examples.AutoSep.

Set Implicit Arguments.

Definition copyS : spec := SPEC("dst", "src", "sz") reserving 3
  Al src, Al dst,
  PRE[V] array src (V "src") * array dst (V "dst")
    * [| V "sz" = length src |] * [| V "sz" = length dst |]
  POST[_] array src (V "src") * array src (V "dst").

Definition agreeUpTo (a b : list W) (i : nat) :=
  exists c, length c = i
    /\ exists a', a = c ++ a'
    /\ exists b', b = c ++ b'.

Definition array := bmodule "array" {{
  bfunction "copy"("dst", "src", "sz", "i", "to", "from") [copyS]
    "i" <- 0;;

    [Al src, Al dst,
      PRE[V] array src (V "src") * array dst (V "dst")
        * [| V "sz" = length src |] * [| V "sz" = length dst |]
        * [| agreeUpTo dst src (wordToNat (V "i")) |]
      POST[_] array src (V "src") * array src (V "dst")]
    While ("i" < "sz") {
      "to" <- 4 * "i";;
      "to" <- "dst" + "to";;

      "from" <- 4 * "i";;
      "from" <- "src" + "from";;

      "from" <-* "from";;
      "to" *<- "from";;

      "i" <- "i" + 1
    };;

    Return 0
  end
}}.

Lemma agreeUpTo_0 : forall a b, agreeUpTo a b 0.
  unfold agreeUpTo; exists nil; simpl; eauto.
Qed.

Local Hint Resolve agreeUpTo_0.

Lemma agreeUpTo_S : forall a b n, agreeUpTo a b (wordToNat n)
  -> n < natToW (length a)
  -> n < natToW (length b)
  -> goodSize (length a)
  -> agreeUpTo (Array.upd a n (Array.sel b n)) b (wordToNat (n ^+ $1)).
  unfold agreeUpTo; intros;
    repeat match goal with
             | [ H : Logic.ex _ |- _ ] => destruct H; intuition; subst
           end; autorewrite with Arr in *.

  exists (x ++ Array.sel (x ++ x1) n :: nil).

  autorewrite with Arr; simpl.
  rewrite H3; intuition eauto.

  destruct x1; simpl in *.
  rewrite H3 in H1.
  unfold natToW in H1; autorewrite with Arr in H1; generalize H1; clear; intros; nomega.

  destruct x0; simpl in *.
  rewrite H3 in H0.
  unfold natToW in H0; autorewrite with Arr in H0; generalize H0; clear; intros; nomega.

  exists x0; autorewrite with Arr; intuition.
  exists x1; autorewrite with Arr; intuition.
Qed.

Local Hint Resolve agreeUpTo_S.

Lemma agreeUpTo_done : forall a b n,
  agreeUpTo a b n
  -> (length a <= n)%nat
  -> (length b <= n)%nat
  -> a = b.
  unfold agreeUpTo; firstorder; subst.
  rewrite app_length in *.
  assert (length x0 = 0) by omega.
  destruct x0; simpl in *; try omega.
  destruct x1; simpl in *; try omega.
  auto.
Qed.

Local Hint Extern 1 (_ < _) => congruence.

Theorem arrayOk : moduleOk array.
  vcgen; abstract (sep_auto;
    match goal with
      | [ |- himp _ (Array.array ?A _) (Array.array ?B _) ] =>
        replace B with A by (eapply agreeUpTo_done; eauto 10); reflexivity
      | _ => eauto 10
    end).
Qed.


Require Export GeoCoq.Elements.OriginalProofs.proposition_10.
Require Export GeoCoq.Elements.OriginalProofs.lemma_ABCequalsCBA.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equalanglestransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_09 :
   forall A B C,
   nCol B A C ->
   exists X, CongA B A X X A C /\ InAngle B A C X.
Proof.
intros.
assert (~ eq A B).
 {
 intro.
 assert (eq B A) by (conclude lemma_equalitysymmetric).
 assert (Col B A C) by (conclude_def Col ).
 contradict.
 }
assert (~ eq A C).
 {
 intro.
 assert (Col B A C) by (conclude_def Col ).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists E, (Out A C E /\ Cong A E A B)) by (conclude lemma_layoff);destruct Tf as [E];spliter.
assert (~ eq B E).
 {
 intro.
 assert (Col A B E) by (conclude_def Col ).
 assert (Col A C E) by (conclude lemma_rayimpliescollinear).
 assert (Col E A B) by (forward_using lemma_collinearorder).
 assert (Col E A C) by (forward_using lemma_collinearorder).
 assert (neq A E) by (conclude lemma_raystrict).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B C) by (conclude lemma_collinear4).
 assert (Col B A C) by (forward_using lemma_collinearorder).
 contradict.
 }
let Tf:=fresh in
assert (Tf:exists F, (BetS B F E /\ Cong F B F E)) by (conclude proposition_10);destruct Tf as [F];spliter.
assert (eq B B) by (conclude cn_equalityreflexive).
assert (eq F F) by (conclude cn_equalityreflexive).
assert (Cong A F A F) by (conclude cn_congruencereflexive).
assert (Cong A B A E) by (conclude lemma_congruencesymmetric).
assert (Cong E F B F) by (forward_using lemma_doublereverse).
assert (Cong B F E F) by (conclude lemma_congruencesymmetric).
assert (~ Col B A F).
 {
 intro.
 assert (Col B F E) by (conclude_def Col ).
 assert (Col F B E) by (forward_using lemma_collinearorder).
 assert (Col F B A) by (forward_using lemma_collinearorder).
 assert (neq B F) by (forward_using lemma_betweennotequal).
 assert (neq F B) by (conclude lemma_inequalitysymmetric).
 assert (Col B E A) by (conclude lemma_collinear4).
 assert (Col A C E) by (conclude lemma_rayimpliescollinear).
 assert (Col E A B) by (forward_using lemma_collinearorder).
 assert (Col E A C) by (forward_using lemma_collinearorder).
 assert (neq A E) by (conclude lemma_raystrict).
 assert (neq E A) by (conclude lemma_inequalitysymmetric).
 assert (Col A B C) by (conclude lemma_collinear4).
 assert (Col B A C) by (forward_using lemma_collinearorder).
 contradict.
 }
assert (Out A B B) by (conclude lemma_ray4).
assert (~ eq A F).
 {
 intro.
 assert (Col B A F) by (conclude_def Col ).
 contradict.
 }
assert (Out A F F) by (conclude lemma_ray4).
assert (CongA B A F C A F) by (conclude_def CongA ).
assert (CongA C A F B A F) by (conclude lemma_equalanglessymmetric).
assert (nCol C A F) by (conclude_def CongA ).
assert (CongA C A F F A C) by (conclude lemma_ABCequalsCBA).
assert (CongA B A F F A C) by (conclude lemma_equalanglestransitive).
assert (InAngle B A C F) by (conclude_def InAngle ).
close.
Qed.

End Euclid.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq choice div.
Require Import fintype bigops finset prime groups ssralg.

(***********************************************************************)
(*  Definition of the additive group and ring Zp, represented as 'I_p  *)
(***********************************************************************)
(* Definitions:                                                        *)
(* From fintype.v:                                                     *)
(*   'I_p == the subtype of integers less than p, taken here as the    *)
(*           type of integers mod p.                                   *)
(* This file:                                                          *)
(*   inZp p_gt0 == the natural projection from nat into the integers   *)
(*                 mod p (represented as 'I_p), when p_gt0 is a proof  *)
(*                 that p > 0.                                         *)
(* the operations:                                                     *)
(*   Zp0 == neutral element for addition                               *)
(*   Zp1 == neutral element for multiplication                         *)
(*   Zp_opp == inverse function for addition                           *)
(*   Zp_add == addition                                                *)
(*   Zp_mul == multiplication                                          *)
(*   Zp_inv == inverse function for multiplication                     *)
(*  Zp_finGroupType pp == the canonical finGroupType on 'I_pp, when pp *)
(*                        is a pos_nat.                                *)
(*  Zp_ring lt1p == the (commutative, unitary) ring structure on 'I_p, *)
(*                  given lt1p : 1 < p                                 *)
(*  Fp_field pr_p == the field structure on 'I_p, given pr_p : prime p *)
(*     Zp p    == the set (and additive group) of all integers mod p.  *)
(*  Zp_unit p  == the subtype of all units in the ring 'I_p            *)
(*  Zp_units p == the set (and multiplicative group) of all 'I_p units *)
(* operations in Zp_units:                                             *)
(* Zp_unit_one == the neutral element for multiplication in Zp_unit    *)
(* Zp_unit_inv u == the inverse function for multiplication in Zp_unit *)
(* Zp_unit_mul u v == multiplication in Zp_unit                        *)
(* We show that Zp and Zp_units are abelian, and compute their orders. *)
(***********************************************************************)

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

Section ZpDef.

(***********************************************************************)
(*                                                                     *)
(*  Mod p arithmetic on the finite set {0, 1, 2, ..., p - 1}           *)
(*                                                                     *)
(***********************************************************************)

Variable p : nat.
Hypothesis p_gt0 : 0 < p.

Definition Zp : {set 'I_p} := setT.

Implicit Types x y z : 'I_p.

(* Standard injection; val (inZp i) = i %% p *)
Definition inZp i := Ordinal (ltn_pmod i p_gt0).
Lemma modZp : forall x, x %% p = x.
Proof. by move=> x; rewrite modn_small ?ltn_ord. Qed.
Lemma valZpK : forall x, inZp x = x.
Proof. by move=> x; apply: val_inj; rewrite /= modZp. Qed.

(* Operations *)
Definition Zp0 := Ordinal p_gt0.
Definition Zp1 := inZp 1.
Definition Zp_opp x := inZp (p - x).
Definition Zp_add x y := inZp (x + y).
Definition Zp_mul x y := inZp (x * y).
Definition Zp_inv x := if coprime p x then inZp (egcdn x p).1 else x.

(* Units subtype *)

Inductive Zp_unit : predArgType := ZpUnit x of coprime p x.

Implicit Types u v : Zp_unit.

Coercion Zp_unit_val u := let: ZpUnit x _ := u in x.

Canonical Structure Zp_unit_subType :=
  Eval hnf in [subType for Zp_unit_val by Zp_unit_rect].
Definition Zp_unit_eqMixin := Eval hnf in [eqMixin of Zp_unit by <:].
Canonical Structure Zp_unit_eqType := Eval hnf in EqType Zp_unit_eqMixin.
Definition Zp_unit_choiceMixin := [choiceMixin of Zp_unit by <:].
Canonical Structure Zp_unit_choiceType :=
  Eval hnf in ChoiceType Zp_unit_choiceMixin.
Definition Zp_unit_countMixin := [countMixin of Zp_unit by <:].
Canonical Structure Zp_unit_countType :=
  Eval hnf in CountType Zp_unit_countMixin.
Canonical Structure Zp_unit_subCountType :=
  Eval hnf in [subCountType of Zp_unit].
Definition Zp_unit_finMixin := [finMixin of Zp_unit by <:].
Canonical Structure Zp_unit_finType := Eval hnf in FinType Zp_unit_finMixin.
Canonical Structure Zp_unit_subFinType := Eval hnf in [subFinType of Zp_unit].

Definition Zp_units : {set Zp_unit} := setT.

(* Additive group structure. *)

Lemma Zp_add0z : left_id Zp0 Zp_add.
Proof. exact: valZpK. Qed.

Lemma Zp_addNz : left_inverse Zp0 Zp_opp Zp_add.
Proof.
by move=> x; apply: val_inj; rewrite /= modn_addml subnK ?modnn // ltnW.
Qed.

Lemma Zp_addA : associative Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modn_addml modn_addmr addnA.
Qed.

Lemma Zp_addC : commutative Zp_add.
Proof. by move=> x y; apply: val_inj; rewrite /= addnC. Qed.

Definition Zp_groupMixin := FinGroup.Mixin Zp_addA Zp_add0z Zp_addNz.

Definition Zp_zmodMixin := ZmodMixin Zp_addA Zp_addC Zp_add0z Zp_addNz.

(* Ring operations *)

Lemma Zp_mul1z : left_id Zp1 Zp_mul.
Proof. by move=> x; apply: val_inj; rewrite /= modn_mulml mul1n modZp. Qed.

Lemma Zp_mulC : commutative Zp_mul.
Proof. by move=> x y; apply: val_inj; rewrite /= mulnC. Qed.

Lemma Zp_mulz1 : right_id Zp1 Zp_mul.
Proof. by move=> x; rewrite Zp_mulC Zp_mul1z. Qed.

Lemma Zp_mulA : associative Zp_mul.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modn_mulml modn_mulmr mulnA.
Qed.

Lemma Zp_mul_addr : right_distributive Zp_mul Zp_add.
Proof.
by move=> x y z; apply: val_inj; rewrite /= modn_mulmr modn_add2m muln_addr.
Qed.

Lemma Zp_mul_addl : left_distributive Zp_mul Zp_add.
Proof. by move=> x y z; rewrite -!(Zp_mulC z) Zp_mul_addr. Qed.

Lemma Zp_mulVz : forall x, coprime p x -> Zp_mul (Zp_inv x) x = Zp1.
Proof.
move=> x co_p_x; apply: val_inj; rewrite /Zp_inv co_p_x /= modn_mulml.
by rewrite -(chinese_modl co_p_x 1 0) /chinese addn0 mul1n mulnC.
Qed.

Lemma Zp_mulzV : forall x, coprime p x -> Zp_mul x (Zp_inv x) = Zp1.
Proof. by move=> x Ux; rewrite /= Zp_mulC Zp_mulVz. Qed.

Lemma Zp_intro_unit : forall x y, Zp_mul y x = Zp1 -> coprime p x.
Proof.
move=> x y [yx1]; have:= coprimen1 p.
by rewrite -coprime_modr -yx1 coprime_modr coprime_mulr; case/andP.
Qed.

Lemma Zp_inv_out : forall x, ~~ coprime p x -> Zp_inv x = x.
Proof. by rewrite /Zp_inv => x; move/negPf->. Qed.

Lemma Zp_mulrn : forall x n,
  ((x : ZmodType Zp_zmodMixin) *+ n)%R = inZp (x * n).
Proof.
move=> x n; apply: val_inj => /=.
elim: n => [|n IHn]; first by rewrite muln0 modn_small.
by rewrite !GRing.mulrS /= IHn modn_addmr mulnS.
Qed.

(* Multiplicative (unit) group. *)

Lemma Zp_unit_one_proof : coprime p Zp1.
Proof. by rewrite coprime_modr coprimen1. Qed.

Lemma Zp_unit_mul_proof : forall u v, coprime p (Zp_mul u v).
Proof. by move=> u v; rewrite coprime_modr coprime_mulr (valP u) (valP v). Qed.

Lemma Zp_unit_inv_proof : forall u, coprime p (Zp_inv u).
Proof.
move=> u; have:= Zp_unit_one_proof; rewrite -(Zp_mulVz (valP u)).
by rewrite coprime_modr coprime_mulr; case/andP.
Qed.

Definition Zp_unit_one := ZpUnit Zp_unit_one_proof.

Definition Zp_unit_inv u := ZpUnit (Zp_unit_inv_proof u).

Definition Zp_unit_mul u v := ZpUnit (Zp_unit_mul_proof u v).

Lemma Zp_unit_mul1g : left_id Zp_unit_one Zp_unit_mul.
Proof. move=> u; apply: val_inj; exact: Zp_mul1z. Qed.

Lemma Zp_unit_mulVg : left_inverse Zp_unit_one Zp_unit_inv Zp_unit_mul.
Proof. move=> u; apply: val_inj; exact: Zp_mulVz (valP u). Qed.

Lemma Zp_unit_mulA : associative Zp_unit_mul.
Proof. move=> u v w; apply: val_inj; exact: Zp_mulA. Qed.

Lemma Zp_unit_mulC : commutative Zp_unit_mul.
Proof. move=> u v; apply: val_inj; exact: Zp_mulC. Qed.

Definition Zp_unit_groupMixin :=
  FinGroup.Mixin Zp_unit_mulA Zp_unit_mul1g Zp_unit_mulVg.

Definition Zp_unit_zmodMixin :=
  ZmodMixin Zp_unit_mulA Zp_unit_mulC Zp_unit_mul1g Zp_unit_mulVg.

(* Group orders *)

Lemma card_Zp : #|Zp| = p.
Proof. by rewrite cardsT card_ord. Qed.

Lemma card_Zp_units : #|Zp_units| = phi p.
Proof. by rewrite cardsT card_sub phi_count_coprime big_mkord -sum1_card. Qed.

End ZpDef.

Section ZpGroup.

(* Canonical group structures for Zp and Zp_units; we use pos_nat to carry *)
(* the p > 0 assumption, which works fine for group element orders, but    *)
(* doesn't extend very well to the ring and field cases, where one needs   *)
(* stronger constraints (resp., p > 1, prime p) which don't have canonical *)
(* proofs. "Type" classes would work better here.                          *)

Import GroupScope.

Variable p : pos_nat.

Canonical Structure Zp_baseFinGroupType :=
  Eval hnf in BaseFinGroupType (Zp_groupMixin (valP p)).
Canonical Structure Zp_finGroupType := FinGroupType (Zp_addNz (valP p)).
Canonical Structure Zp_zmodType :=
  Eval hnf in ZmodType (Zp_zmodMixin (valP p)).
Canonical Structure Zp_group := Eval hnf in [group of Zp p].

Canonical Structure Zp_unit_baseFinGroupType :=
  Eval hnf in BaseFinGroupType (Zp_unit_groupMixin (valP p)).
Canonical Structure Zp_unit_finGroupType :=
  FinGroupType (Zp_unit_mulVg (valP p)).
Canonical Structure Zp_unit_zmodType :=
  Eval hnf in ZmodType (Zp_unit_zmodMixin (valP p)).
Canonical Structure Zp_units_group := Eval hnf in [group of Zp_units p].

Implicit Type x : 'I_p.

Definition Zp_gen := Zp1 (valP p).

Lemma Zp_mulgC : @commutative 'I_p mulg.
Proof. exact: Zp_addC. Qed.

Lemma Zp_abelian : abelian (Zp p).
Proof. apply/centsP=> x _ y _; exact: Zp_mulgC. Qed.

Lemma Zp_expgn : forall x n, x ^+ n = inZp (valP p) (x * n).
Proof. exact: Zp_mulrn. Qed.

Lemma Zp_gen_expgz : forall x, Zp_gen ^+ x = x.
Proof. move=> x; rewrite Zp_expgn; exact: Zp_mul1z. Qed.

Lemma Zp_cycle : setT = <[Zp_gen]>.
Proof.
by apply/setP=> x; rewrite -[x]Zp_gen_expgz inE groupX ?mem_gen ?set11.
Qed.

Lemma Zp_unit_mulgC : @commutative (Zp_unit p) mulg.
Proof. exact: Zp_unit_mulC. Qed.

Lemma Zp_units_abelian : abelian (Zp_units p).
Proof. apply/centsP=> x _ y _; exact: Zp_unit_mulgC. Qed.

Lemma Zp_units_expgn : forall (u : Zp_unit p) n,
  u ^+ n = inZp (valP p) (u ^ n) :> 'I_p.
Proof.
move=> u n; apply: val_inj => /=; elim: n => [|n IHn] //.
by rewrite expgS /= IHn expnS modn_mulmr.
Qed.

End ZpGroup.

Implicit Arguments Zp_gen [p].

Section ZpRing.

Open Scope ring_scope.

Variable p : nat.
Hypothesis lt1p : 1 < p.
Let lt0p := ltnW lt1p.

Lemma Zp_nontriv : Zp1 lt0p != Zp0 lt0p.
Proof. by rewrite /eq_op /= modn_small. Qed.

Definition Zp_ringMixin :=
  @ComRingMixin (ZmodType (Zp_zmodMixin lt0p)) _ _
           (Zp_mulA _) (Zp_mulC _) (Zp_mul1z _) (Zp_mul_addl _) Zp_nontriv.

Definition Zp_comRingMixin :
   @commutative (RingType Zp_ringMixin) *%R := Zp_mulC _.

Definition Zp_unitMixin :=
  @ComUnitRingMixin (ComRingType Zp_comRingMixin) (fun i => coprime p i)
   (Zp_inv lt0p) (Zp_mulVz _) (@Zp_intro_unit _ _) (Zp_inv_out _).

Definition Zp_ring := ComUnitRingType Zp_unitMixin.

Lemma Zp_nat : forall n, n%:R = inZp lt0p n :> Zp_ring.
Proof.
by move=> n; apply: val_inj; rewrite [n%:R]Zp_mulrn /= modn_mulml mul1n.
Qed.

End ZpRing.

Lemma ord1 : forall i : 'I_1, i = 0%R.
Proof. case=> [[]] // ?; exact/eqP. Qed.

Lemma lshift_ord1 : forall n (i : 'I_1), lshift n i = 0%R :> 'I_n.+1.
Proof. by move=> n i; apply/eqP; rewrite [i]ord1. Qed.

(* Field structure for primes. *)

Section PrimeField.

Open Scope ring_scope.

Variable p : nat.
Hypothesis pr_p : prime p.
Let lt1p := prime_gt1 pr_p.

Let Fp_ring := ComUnitRingType (Zp_unitMixin lt1p).

Lemma Fp_fieldMixin : GRing.Field.mixin_of Fp_ring.
Proof.
by move=> x nzx; rewrite /GRing.unit /= prime_coprime // gtnNdvd ?lt0n.
Qed.

Definition Fp_idomainMixin := FieldIdomainMixin Fp_fieldMixin.

Definition Fp_field := @FieldType (IdomainType Fp_idomainMixin) Fp_fieldMixin.

End PrimeField.


(*
(C) Copyright 2010, COQTAIL team

Project Info: http://sourceforge.net/projects/coqtail/

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

This library 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 Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301,
USA.
*)

Require Import Type_class_definition.
Require Import Type_class_instance.
Require Import Coq.Relations.Relation_Definitions.
Require Import Lia.
Require Import Arith.
Require Import Nbinomial.
Require Import Setoid.

Definition iter_l (A : Type) (op : operation A) (neutral : A) (x : A) :=
fix s n := match n with
  | O => neutral
  | S n' => op x (s n')
end.

Definition iter_r (A : Type) (op : operation A) (neutral : A) (x : A) :=
fix s n := match n with
  | O => neutral
  | S n' => op (s n') x
end.

Definition iter1 (A : Type) (op : operation A) (f : nat -> A) :=
fix s n := match n with
  | O => f O
  | S n' => op (f n) (s n')
end.

Section Commutative_Ring.
  Variable X : Type.
  Variable eqr : relation X.
  Variable add mul : operation X.
  Variable zero one : X.
  Variable CR : Ring_Commutative X eqr add mul zero one.

  Definition CRpow : X -> nat -> X := iter_r X mul one.
  Definition CRsum : (nat -> X) -> nat -> X  := iter1 X add.
  Definition CRnatmul : nat -> X -> X := fun n x => iter_l X add zero x n.

  Notation " a ^^ b " := (CRpow a b) (at level 30, right associativity).
  Notation " a * b " := (mul a b).
  Notation " a == b " := (eqr a b) (at level 90, no associativity).
  Notation " a + b " := (add a b).
  Notation " a ** b " := (CRnatmul a b) (at level 60).

  Definition newton_sum n a b : X :=
    CRsum (fun k => (Nbinomial n k) ** (a ^^ k) * (b ^^ (n - k))) n.

  Definition opp : X -> X.
  Proof.
    intros x.
    destruct (group_reverse x) as [y ?].
    exact y.
  Defined.

  Definition sub : X -> X -> X := fun a b => add a (opp b).

  Add Setoid X eqr monoid_setoid as setoid_X.

  Add Morphism add with signature eqr ==> eqr ==> eqr as add_wd.
  intros.
  transitivity (x + y0).
   apply monoid_eq_compat_l; assumption.
   apply monoid_eq_compat_r; assumption.
  Qed.

  Add Morphism mul with signature eqr ==> eqr ==> eqr as mul_wd.
  intros.
  transitivity (x * y0).
   apply monoid_eq_compat_l; assumption.
   apply monoid_eq_compat_r; assumption.
  Qed.

  Add Morphism opp with signature eqr ==> eqr as opp_wd.
  Proof.
  intros.
  unfold opp.
  destruct (group_reverse x) as [x' ?].
  destruct (group_reverse y) as [y' ?].
  transitivity (zero + y'); [ | apply monoid_iden_l].
  transitivity (x' + x + y'); [ | apply monoid_eq_compat_r; rewrite op_comm; assumption].
  transitivity (x' + y + y'); [ | apply monoid_eq_compat_r; apply monoid_eq_compat_l; symmetry; assumption].
  transitivity (zero + x').
   symmetry; apply monoid_iden_l.
   transitivity (x' + x + x').
    apply monoid_eq_compat_r; symmetry; transitivity (x + x'); auto; apply op_comm.
    transitivity (x' + (y + y')).
     transitivity (x' + (x + x')).
      symmetry; apply op_assoc.
      apply monoid_eq_compat_l; transitivity zero; auto with relations.
     apply op_assoc.
  Qed.

  Lemma Xring : @ring_theory X zero one add mul sub opp eqr.
  Proof.
    split; intros.
     apply monoid_iden_l.
     apply op_comm.
     apply op_assoc.
     apply monoid_iden_l.
     apply op_comm.
     apply op_assoc.
     apply ring_distributive_l.
     reflexivity.

     unfold opp.
     destruct (group_reverse x) as [y ?].
     assumption.
  Qed.

  Add Ring X : Xring.

  Lemma CRsum_simpl f n : CRsum f (S n) = f (S n) + CRsum f n.
  Proof.
  reflexivity.
  Qed.

  Lemma CRsum_simpl_r f n : CRsum f (S n) == CRsum f n + f (S n).
  Proof.
  intros; simpl; ring.
  Qed.

  Lemma CRsum_reindex : forall n f, f O + CRsum (fun k => f (S k)) n == CRsum f (S n).
  Proof.
  intros n f.
  induction n.
   simpl; ring.

   do 2 rewrite CRsum_simpl.
   rewrite <- IHn.
   ring.
  Qed.

  Lemma CRsum_eq_compat_weak : forall a b n, (forall n, a n == b n) -> CRsum a n == CRsum b n.
  Proof.
  intros a b n H.
  induction n.
   simpl; apply H.

   simpl.
   rewrite IHn.
   rewrite H.
   reflexivity.
  Qed.

  Lemma CRsum_eq_compat : forall a b n, (forall i, i <= n -> a i == b i) -> CRsum a n == CRsum b n.
  Proof.
  intros a b n H.
  induction n.
   simpl; apply H.
   constructor.

   simpl.
   rewrite IHn.
    rewrite H.
     reflexivity.
     constructor.
    intros; apply H; auto.
  Qed.

  Lemma CRsum_add_compat : forall a b n, CRsum (fun i => a i + b i) n == CRsum a n + CRsum b n.
  Proof.
  intros a b n.
  induction n.
   simpl; reflexivity.

   simpl.
   rewrite IHn.
   ring.
  Qed.

  Lemma CRsum_scal_compat : forall x f n, x * CRsum f n == CRsum (fun n => x * f n) n.
  Proof.
  intros a b n.
  induction n.
   simpl; reflexivity.

   simpl.
   ring_simplify.
   rewrite IHn.
   reflexivity.
  Qed.

  Lemma CRpow_simpl : forall a n, a ^^ (S n) = a ^^ n * a.
  Proof.
  reflexivity.
  Qed.

  Lemma CRadd_eq_compat : forall a b c d, a == c -> b == d -> a + b == c + d.
  Proof.
  intros ? ? ? ? H H'.
  rewrite H; rewrite H'.
  ring.
  Qed.

  Lemma CRmul_scal_compat : forall a b n, n ** a * b == a * (n ** b).
  Proof.
  intros a b n.
  induction n.
   simpl; ring.

   simpl.
   rewrite IHn.
   ring.
  Qed.

  Lemma CRscal_eq_compat : forall a b n, a == b -> n ** a == n ** b.
  Proof.
  intros a b n H.
  induction n.
   simpl; ring.

   simpl.
   rewrite IHn.
   rewrite H.
   ring.
  Qed.

  Lemma CRscal_mult_scal_one : forall a n, (n ** one) * a == n ** a.
  Proof.
  intros a n.
  induction n.
   simpl; ring.

   simpl.
   rewrite <- IHn.
   ring.
  Qed.

  Lemma CRscal_add_eq_compat : forall a b n, (n ** a) + (n ** b) == n ** (a + b).
  Proof.
  intros a b n.
  induction n.
   simpl; ring.

   simpl.
   rewrite <- IHn.
   ring.
  Qed.

  Lemma CRadd_scal_eq_compat : forall a n p, (n ** a) + (p ** a) == (n + p) ** a.
  Proof.
  intros a n p.
  induction n.
   simpl; ring.

   simpl.
   rewrite <- IHn.
   ring.
  Qed.

  Theorem Newton : forall n a b, (a + b) ^^ n == newton_sum n a b.
  Proof.
  intros n a b.
  induction n; [compute; ring | ].
  destruct n; [compute; ring | ].

  unfold newton_sum.
  rewrite CRsum_simpl.
  rewrite <- CRsum_reindex.

  rewrite <- (CRsum_eq_compat (fun k =>
    (Nbinomial (S n)    k  ** a ^^ S k * b ^^ (S (S n) - S k)) +
    (Nbinomial (S n) (S k) ** a ^^ S k * b ^^ (S (S n) - S k)))).
   rewrite CRsum_add_compat.
   rewrite CRpow_simpl.
   rewrite IHn.
   rewrite ring_distributive_r.
   unfold newton_sum.
   do 2 (rewrite (op_comm (O:=mul)); rewrite CRsum_scal_compat).
   assert (AP:forall a b c d e f, a == e + c -> b == d + f -> a + b == c + (d + (e + f)))
     by (intros ? ? ? ? ? ? Hi Hj; rewrite Hi; rewrite Hj; ring);
     apply AP; clear AP.
    rewrite CRsum_simpl_r.
    repeat rewrite Nbinomial_diag.
    repeat rewrite minus_diag.
    apply CRadd_eq_compat.
     apply CRsum_eq_compat_weak.
     intro.
     rewrite <- CRmul_scal_compat.
     apply CRscal_eq_compat.
     rewrite CRpow_simpl.
     simpl; ring.

     simpl; ring.

    rewrite <- CRsum_reindex.
    apply CRadd_eq_compat.
     simpl; repeat rewrite binomial_zero; ring.
     apply CRsum_eq_compat; intros j Hj.
     rewrite <- minus_Sn_m with (S n) _; [|lia].
     simpl.
     rewrite <- CRmul_scal_compat.
     apply CRscal_eq_compat.
     ring.

   intros j Hj.
   rewrite <- CRscal_mult_scal_one.
   rewrite <- (CRscal_mult_scal_one _ (Nbinomial (S n) (S j))).
   rewrite <- ring_distributive_l.
   rewrite CRadd_scal_eq_compat.
   rewrite Nbinomial_pascal; [ | lia].
   rewrite CRscal_mult_scal_one.
   reflexivity.
  Qed.

End Commutative_Ring.


Require Import datatypes.
Require Import bigstep.

(****************** One-step Reduction **************)

Inductive s1: Spec -> Tape -> State -> Tape -> State -> Prop :=

(* RIGHT move *)

 | s1R: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, R)) ->
        (s1 T (pair l r) p
              (pair (Cons (hd r) l) (tl r)) q)

(* LEFT move *)

 | s1L: forall T:Spec, forall p q:State,
        forall l r:HTape,
        (tr T p (read (pair l r))) = (Some (q, L)) ->
        (s1 T (pair l r) p
              (pair (tl l) (Cons (hd l) r)) q)

(* WRITE move *)

 | s1W: forall T:Spec, forall p q:State,
        forall l r:HTape, forall a:Sym,
        (tr T p (read (pair l r))) = (Some (q, (W a))) ->
        (s1 T (pair l r) p
              (pair l (Cons a (tl r))) q).

(****************** Finite Reduction *********************)

Inductive sf: Spec -> Tape -> State -> Tape -> State -> Prop :=

(* HALT move *)

   sf0: forall T:Spec, forall q:State, forall t:Tape,
        (sf T t q t q)

(* inductive moves *)

 | sfI: forall T:Spec, forall p q i:State, forall s t u:Tape,
        (s1 T s p u i) -> (sf T u i t q) ->
        (sf T s p t q).

(****************** Infinite Reduction *********************)

CoInductive si: Spec -> Tape -> State -> Prop :=

(* coinductive moves *)

 | siC: forall T:Spec, forall p q:State, forall s t:Tape,
        (s1 T s p t q) -> (si T t q) ->
        (si T s p).


Require Import FunctionalExtensionality.
Require Import ProofIrrelevance.

Definition ex1 {A : Type} (P : A -> Prop) : Type :=
  { x : A | P x /\ forall y : A, P y -> x = y }.

(** Abstract categories **)

Section AbstractCategory.

  Structure CategoryDefinition : Type := mkCategoryDefinition {
    ob   : Type ;
    hom  : ob -> ob -> Type ;
    id   : forall X: ob, hom X X ;
    comp : forall (X Y Z: ob) (f: hom Y Z) (g: hom X Y), hom X Z
  }.

  Definition comp_id (def : CategoryDefinition) : Prop :=
    forall (X Y: ob def) (f: hom def X Y),
     comp def X X Y f (id def X) = f.

  Definition id_comp (def : CategoryDefinition) : Prop :=
    forall (X Y: ob def) (f: hom def X Y),
     comp def X Y Y (id def Y) f = f.

  Definition comp_assoc (def : CategoryDefinition) : Prop :=
    forall (W X Y Z : ob def)
           (f : hom def Y Z)
           (g : hom def X Y)
           (h : hom def W X),
             comp def W Y Z f (comp def W X Y g h)
           = comp def W X Z (comp def X Y Z f g) h.

  Structure Category : Type := mkCategory {
    def        : CategoryDefinition ;
    Comp_id    : comp_id def ;
    Id_comp    : id_comp def ;
    Comp_assoc : comp_assoc def
  }.

End AbstractCategory.

Notation "f ** g"  := (comp (def _) _ _ _ f g) (at level 25).
Notation "X ~~> Y" := (hom (def _) X Y) (at level 35).

Section AbstractCategoryDefs.

  Variable c : Category.

  Definition Ob   := ob (def c).
  Definition Hom  := hom (def c).
  Definition Id   := id (def c).
  Definition Comp := comp (def c).

  Definition initial_object (I : Ob) :=
    forall X: Ob,
      ex1 (fun f: I ~~> X, True).

  Definition terminal_object (T : Ob) :=
    forall X: Ob,
      ex1 (fun f: X ~~> T, True).

  Definition product (A B AxB : Ob)
                     (pi1 : AxB ~~> A)
                     (pi2 : AxB ~~> B) :=
    forall (X: Ob) (f1 : X ~~> A) (f2 : X ~~> B),
      ex1 (fun phi : X ~~> AxB,
              pi1 ** phi = f1 /\
              pi2 ** phi = f2
      ).

  Definition coproduct (A B AuB : Ob)
                       (in1 : A ~~> AuB)
                       (in2 : B ~~> AuB) :=
      forall (X : Ob) (g1 : A ~~> X) (g2 : B ~~> X),
      ex1 (fun phi : AuB ~~> X,
              phi ** in1 = g1 /\
              phi ** in2 = g2
      ).

  Definition equalizer (A B : Ob) (f g : A ~~> B)
                       (E : Ob) (ea : E ~~> A)
                       (ea_equalize: f ** ea = g ** ea)
                       :=
      forall (X : Ob) (xa : X ~~> A) (xa_equalize : f ** xa = g ** xa),
        ex1 (fun phi : X ~~> E, ea ** phi = xa).

  Definition pullback (A B C : Ob) (f : A ~~> C) (g : B ~~> C)
                      (P : Ob) (pa : P ~~> A) (pb : P ~~> B)
                      (p_commute : f ** pa = g ** pb) :=
      forall (X : Ob) (xa : X ~~> A) (xb : X ~~> B)
             (x_commute : f ** xa = g ** xb),
        ex1 (fun phi : X ~~> P, pa ** phi = xa /\ pb ** phi = xb).

End AbstractCategoryDefs.


From Coq Require Import Arith micromega.Lia.
From BY Require Import Hierarchy.Definitions Monoid Hierarchy.List.

Section BigOp.

  (* Local Open Scope mag_scope. *)
  Local Open Scope mon_scope.

  Context
    {A : Type}
    `{Setoid A}
    (op : A -> A -> A)
    `{!Proper ((≡) ==> (≡) ==> (≡)) op}
    (id : A)
    `{Assoc A (≡) op}
    `{LeftId A (≡) id op}
    `{RightId A (≡) id op}.

  (* Local Instance : Op1 A := op. *)
  (* Local Instance : Id1 A := id. *)
  (* Local Instance : Monoid A. split; exact _. Qed. *)

  Local Infix "∘" := op.
  Local Notation "'ε'" := id.
  Local Notation "(∘)" := op (only parsing).

  (* Local Instance : Magma A. sub_class_tac. Qed. *)
  (* Local Instance : SemiGroup A. sub_class_tac. Qed. *)

  (* Instance quot_mon (rel : relation A) `{!MagmaCongruence rel} `{subrelation A (≡) rel} : @Monoid _ rel _ _. *)
  (* repeat split; try apply _; *)
  (* cbv; intros; apply is_subrelation; (apply assoc; exact _) || (apply right_id; exact _) || (apply left_id; exact _). Qed. *)

  Global Instance fold_left_proper : Proper ((≡) ==> (≡) ==> (≡)) (fold_left (∘)).
  Proof.
    do 3 red. induction x; intros.
    - inversion H4.
      subst. assumption.
    - inversion H4; subst.
      simpl. apply IHx.
      assumption.
      rewrite H5, H8.
      reflexivity.
  Qed.

  Lemma fold_left_assoc (a b : A) ls :
    a ∘ (fold_left (∘) ls b) ≡ fold_left (∘) ls (a ∘ b).
  Proof.
    revert b; induction ls; intros b; simpl.
    - reflexivity.
    - rewrite IHls.
      rewrite (assoc (∘)).
      reflexivity.
  Qed.

  Context
    (f : nat -> A).

  Definition big_op_list (l : list nat) f := fold_left (∘) (map f l) ε.
  Definition big_op f n m := big_op_list (seq n (m - n)) f.
  Definition big_op_rev f n m := big_op_list (rev (seq n (m - n))) f.

  Hint Unfold big_op big_op_rev big_op_list : bigop.

  Lemma big_op_S_r n m (nltm : n <= m) :
    big_op f n (S m) = big_op f n m ∘ f m.
  Proof. unfold big_op, big_op_list.
         rewrite Nat.sub_succ_l, seq_snoc, map_app, fold_left_app, <- le_plus_minus; auto. Qed.

  Lemma big_op_S_l n m (nltm : n <= m) :
    big_op f n (S m) ≡ f n ∘ big_op f (S n) (S m).
  Proof. unfold big_op, big_op_list.
         rewrite Nat.sub_succ_l, fold_left_assoc. auto.
         simpl. rewrite (right_id ε (∘)), (left_id ε (∘)).
         auto. assumption. Qed.

  Lemma big_op_rev_S_r n m (nltm : n <= m) :
    big_op_rev f n (S m) = big_op_rev f (S n) (S m) ∘ f n.
  Proof. unfold big_op_rev, big_op_list.
         rewrite Nat.sub_succ_l by auto; simpl; rewrite map_app, fold_left_app. reflexivity. Qed.

  Lemma big_op_rev_S_l n m (nltm : n <= m) :
    big_op_rev f n (S m) ≡ f m ∘ big_op_rev f n m.
  Proof. unfold big_op_rev, big_op_list.
         rewrite Nat.sub_succ_l, seq_snoc, rev_app_distr, fold_left_assoc, <- le_plus_minus, (right_id ε (∘)) by auto; simpl;
           rewrite (left_id ε (∘)); auto. Qed.

  Lemma big_op_rev_nil n m (mltn : m <= n) :
    big_op_rev f n m = ε.
  Proof. unfold big_op_rev; replace (m - n) with 0 by lia; reflexivity. Qed.

  Lemma big_op_nil n m (mltn : m <= n) :
    big_op f n m = ε.
  Proof. unfold big_op; replace (m - n) with 0 by lia; reflexivity. Qed.

  Lemma big_op_split n m k (nmk : n <= m <= k) :
    (big_op f n m) ∘ (big_op f m k) ≡ big_op f n k.
  Proof.
    revert nmk; revert n m. induction k; intros.
    - assert (n = 0); assert (m = 0); subst; try lia. rewrite big_op_nil, (left_id ε (∘)). reflexivity. lia.
    - destruct (Nat.eq_dec m (S k)).
      + subst. rewrite (big_op_nil (S k)), (right_id ε (∘)). reflexivity. lia.
      + rewrite big_op_S_r, (assoc (∘)), IHk, <- big_op_S_r by lia. reflexivity. Qed.

  Lemma big_op_rev_split n m k (nmk : n <= m <= k) :
    (big_op_rev f m k) ∘ (big_op_rev f n m) ≡ big_op_rev f n k.
  Proof.
    revert nmk; revert n m. induction k; intros.
    - assert (n = 0); assert (m = 0); try lia; subst. rewrite big_op_rev_nil, (left_id ε (∘)). reflexivity. lia.
    - destruct (Nat.eq_dec m (S k)).
      + subst. rewrite (big_op_rev_nil (S k)), (left_id ε (∘)). reflexivity. lia.
      + rewrite big_op_rev_S_l, <- (assoc (∘)), IHk, <- big_op_rev_S_l by lia. reflexivity. Qed.

  Lemma big_op_shift g n m k :
    (forall i, f i ≡ g (i + k)) ->
    big_op f n m ≡ big_op g (n + k) (m + k).
  Proof.
    intros. unfold big_op, big_op_list. f_equiv.
    replace (m + k - (n + k)) with (m - n) by lia.
    apply map_seq_ext_equiv; intros. rewrite H4.
    replace (i + (n + k - n)) with (i + k) by lia.
    reflexivity. lia. Qed.

  Lemma big_op_rev_shift g n m k :
    (forall i, f i = g (i + k)) ->
    big_op_rev f n m ≡ big_op_rev g (n + k) (m + k).
  Proof.
    intros. unfold big_op_rev, big_op_list. f_equiv.
    rewrite !map_rev. replace (m + k - (n + k)) with (m - n) by lia.

    f_equiv. apply map_seq_ext_equiv. intros.
    rewrite H4.
    replace (i + (n + k - n)) with (i + k) by lia.
    reflexivity. lia.
  Qed.

End BigOp.

Notation big_sum := (big_op op1 0)%RI.
Notation big_mul := (big_op op2 1)%RI.
Notation big_sum_rev := (big_op_rev op1 0)%RI.
Notation big_mul_rev := (big_op_rev op2 1)%RI.


From mathcomp Require Import ssreflect.

Require Import collect_operator.
Require Import direct_product.
Require Import mapping.

(* 配置集合, MappingSpace *)
Inductive MappingSpace {U:Type} (X Y:Collection U) : Collection (TypeOfDirectProduct U) :=
  definition_of_mapping_space: forall (F:TypeOfDirectProduct U),
    (exists f:U->U, MappingFunction f X Y /\ F = GraphOfFunction f X Y) -> F ∈ MappingSpace X Y.

Section MappingSpace.

  Variable U:Type.

  Theorem element_of_mapping_space_is_function:
    forall (X Y: Collection U) (F:TypeOfDirectProduct U),
      F ∈ MappingSpace X Y -> exists f:U->U,MappingFunction f X Y /\ F = GraphOfFunction f X Y.
  Proof.
    move => X Y F HFM.
    inversion HFM.
    apply H.
  Qed.

  Theorem powerset_of_product_included_mapping_space:
    forall (X Y: Collection U), MappingSpace X Y ⊂ 𝔓(X × Y).
  Proof.
    move => X Y F H.
    split => f H'.
    inversion H.
    inversion H0 as [f' [Hf HF]].
    rewrite HF in H'.
    inversion H'.
    inversion H2 as [x [y [Heq [Hyf'x HXY]]]].
    rewrite -Heq in HXY.
    assumption.
  Qed.

  Theorem element_of_mapping_space_to_graph:
    forall (A B:Collection U) (G:TypeOfDirectProduct U),
      G ∈ MappingSpace A B -> ConditionOfGraphOfMapping G A B.
  Proof.
    move => A B G H.
    inversion H.
    inversion H0 as [g].
    inversion H2.
    split.
    apply (direct_product_included_graph_of_function U g A B G).
    trivial.
    move => a HaA.
    exists (g a).
    split.
    rewrite H4.
    split.
    exists a.
    exists (g a).
    split;[reflexivity|split;[reflexivity|]].
    have L1: exists b:U, b = g a /\ b ∈ B.
    apply H3.
    trivial.
    inversion L1 as [b [Hbga HbB]].
    rewrite -Hbga.
    apply in_and_to_ordered_pair_in_direct_product.
    split;trivial.
    move => b' HG'.
    rewrite H4 in HG'.
    inversion HG'.
    inversion H5 as [a0 [b0 [Heq [Hb'ga Hab'AB]]]].
    apply ordered_pair_to_and in Heq.
    inversion Heq as [Heql Heqr].
    rewrite Heqr Heql.
    apply sym_eq.
    assumption.
  Qed.

End MappingSpace.


(** This file generates unsatisfiable formulas for problems
   in the fragment SAT + EUF or SAT + EUF + ZArith. *)

(** We define families of boolean variables indexed by an integer. *)
Inductive x : nat -> Prop :=
| mk_x : forall i, x i.
Inductive y : nat -> Prop :=
| mk_y : forall i, y i.
Inductive z : nat -> Prop  :=
| mk_z : forall i, z i.

(** [diamond_equations acc n] appends to the formula [acc] all the
   disjunctions [(x i = y i /\ y i = x (S i)) \/
   ((x i = z i) /\ (z i = x (S i))] for [i] ranging [0] to [pred n].
   It corresponds to "diamond" equalities on the chains [x], [y] and [z]:
        y0       y1
      /   \    /    \
   x 0 ----> x 1 -----> .................. ----> x n
      \    /   \    /
        z0       z1
   such that each diamond constraint ensures that [x i = x (S i)] by
   transitivity whether at the top or the bottom of the diamond.
*)
Fixpoint diamond_equations (acc : Prop) (n : nat) : Prop :=
  match n with
    | O => acc
    | S m =>
      let eq1 := x m = y m /\ y m = x n in
      let eq2 := x m = z m /\ z m = x n in
        diamond_equations ((eq1 \/ eq2) -> acc) m
  end.

(** [diamond n] returns the implication [diamond_equations n -> x 0 = x n].
   It is a valid formula with [1 + 4 * n] equations between [1 + 3 * n]
   variables. *)
Definition diamond (n : nat) : Prop :=
  diamond_equations (x 0 = x n) n.

(** We now implement a variation of [diamond] where one layer of a
   function symbol [f] is added to the [x_i] at every step. Whereas
   [diamond n] is valid in SAT + equivalence, this one requires congruence.

   [fdiamond_equations f acc n] appends to the formula [acc] all the
   disjunctions [x i = y i /\ y i = f (x (S i)) \/
   ((x i = z i) /\ (z i = f (x (S i)))] for [i] ranging [0] to [pred n].
   It corresponds to "diamond" equalities on the chains [x], [y] and [z]:
        y0       y1
      /   \    /    \
   x 0 ---> f(x 1)-----> .................. ----> f^n(x n)
      \    /   \    /
        z0       z1
   such that each diamond constraint ensures that [x i = f(x (S i))]
   by transitivity whether at the top or the bottom of the diamond.
   NB : it is actually going in reverse order with respect to the above schema
   but you get the idea.
*)
Fixpoint fdiamond_equations (f : Prop -> Prop) (acc : Prop) (n : nat) : Prop :=
  match n with
    | O => acc
    | S m =>
      let eq1 := x m = y m /\ y m = f (x n) in
      let eq2 := x m = z m /\ z m = f (x n) in
        fdiamond_equations f ((eq1 \/ eq2) -> acc) m
  end.

(** [fdiamond n] returns the implication
   [fdiamond_equations f n -> x 0 = f^n (x n)].
   It is a valid formula with [1 + 4 * n] equations between [1 + 3 * n]
   variables. *)
Fixpoint power (f : Prop -> Prop) n x :=
  match n with 0 => x | S m => power f m (f x) end.
Definition fdiamond (f : Prop -> Prop) (n : nat) : Prop :=
  fdiamond_equations f (x 0 = power f n (x n)) n.

(** We define families of integer variables indexed by an integer. *)
Require Import ZArith.
Parameter zx : nat -> Z.
Parameter zy : nat -> Z.
Parameter zz : nat -> Z.

(** [diamond_Zequations acc n] appends to the formula [acc] all the
   disjunctions [(x i = y i /\ y i = 1 + x (S i)) \/
   ((x i = z i) /\ (z i = 1 + x (S i))] for [i] ranging [0] to [pred n].
   It corresponds to "diamond" equalities on the chains [x], [y] and [z]:
        y0       y1
      /   \    /    \
   x 0 ----> x 1 -----> .................. ----> x n
      \    /   \    /
        z0       z1
   such that each diamond constraint ensures that [x i = 1 + x (S i)] by
   transitivity whether at the top or the bottom of the diamond.
*)
Fixpoint diamond_Zequations (acc : Prop) (n : nat) : Prop :=
  match n with
    | O => acc
    | S m =>
      let eq1 := zx m = zy m /\ zy m = (1 + zx n)%Z in
      let eq2 := zx m = zz m /\ zz m = (1 + zx n)%Z in
        diamond_Zequations ((eq1 \/ eq2) -> acc) m
  end.

(** [Zdiamond n] returns the implication
   [diamond_Zequations n -> zx 0 - n = zx n].
   It is a valid formula with [1 + 4 * n] equations between [1 + 3 * n]
   variables. *)
Definition Zdiamond (n : nat) : Prop :=
  diamond_Zequations (zx 0 - (Z_of_nat n) = zx n)%Z n.

(** Another goal which only contains arithmetic, no real congruence,
   and basically no propositional value. It is a sequence of arithmetic
   equalities which simulate the definition of a Fibonacci number.
   *)
Fixpoint fibo_defs (res : Prop) (n : nat)  : Prop :=
  match n with
    | 0 => zx 0 = 1%Z -> res
    | S m =>
      match m with
        | 0 => zx 1 = zx 0 -> fibo_defs res m
        | S p => zx (S (S p)) = Zplus (zx (S p)) (zx p) -> fibo_defs res m
      end
  end.
Fixpoint fibo (n : nat) (z : Z) : Z :=
  match n with
    | 0 => 1%Z
    | S m =>
      match m with
        | 0 => 1%Z
        | S p => Zplus (fibo p (z-2)) (fibo m (z-1))
      end
  end.
Definition fibo_arith (n : nat) :=
  fibo_defs (zx n = fibo n (Z_of_nat n)) n.