(* This program 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 program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(**
   list.
   Polymorphic lists with some operations.

   @author Olga Caprotti and Martijn Oostdijk
   @version $Revision$
*)

Require Import Arith.
Require Import ZArith.
Require Import EqNat.

Require Import dec.
Require Import natZ.

(** * Polymorphic lists *)

Inductive list (A : Set) : Set :=
  | Nil : list A
  | Cons : A -> list A -> list A.

(** Length of a list *)

Fixpoint length (A : Set) (l : list A) {struct l} : nat :=
  match l with
  | Nil => 0
  | Cons a r => S (length A r)
  end.

Lemma length_0 : forall (A : Set) (l : list A), length A l = 0 -> l = Nil A.
Proof.
   intros A l. case l.
   reflexivity.
   simpl in |- *. intros. discriminate H.
Qed.

Lemma length_S :
 forall (A : Set) (l : list A) (n : nat),
 length A l = S n ->
 exists h : A, (exists t : list A, l = Cons A h t /\ length A t = n).
Proof.
   intros A l. case l.
   simpl in |- *. intros. discriminate H.
   simpl in |- *. intros h0 t0 n H. injection H. intro.
   split with h0. split with t0. split.
   reflexivity. assumption.
Qed.

(** Map a function over a list *)

Fixpoint map (A B : Set) (f : A -> B) (l : list A) {struct l} :
 list B :=
  match l with
  | Nil => Nil B
  | Cons a r => Cons B (f a) (map A B f r)
  end.

Notation Map := (map _ _) (only parsing).

Lemma map_length :
 forall (A B : Set) (f : A -> B) (l : list A),
 length A l = length B (map A B f l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   simpl in |- *. intros. rewrite H. reflexivity.
Qed.

(** Checks that all members of a list are P *)

Fixpoint alllist (A : Set) (P : A -> Prop) (qlist : list A) {struct qlist} :
 Prop :=
  match qlist with
  | Nil => True
  | Cons m l => P m /\ alllist A P l
  end.

Lemma alllist_dec :
 forall (A : Set) (P : A -> Prop) (l : list A),
 (forall x : A, P x \/ ~ P x) -> alllist A P l \/ ~ alllist A P l.
Proof.
   simple induction l.
   simpl in |- *. left. trivial.
   intros h t IH H. simpl in |- *.
   elim IH. elim (H h).
   left. split. assumption. assumption.
   right. intro. apply H0. elim H2. intros. assumption.
   right. intro. apply H0. elim H1. intros. assumption.
   assumption.
Qed.

(** Checks that some member of a list is P *)

Fixpoint exlist (A : Set) (P : A -> Prop) (qlist : list A) {struct qlist} :
 Prop :=
  match qlist with
  | Nil => False
  | Cons m l => P m \/ exlist A P l
  end.

Lemma exlist_dec :
 forall (A : Set) (P : A -> Prop) (l : list A),
 (forall x : A, P x \/ ~ P x) -> exlist A P l \/ ~ exlist A P l.
Proof.
   simple induction l.
   simpl in |- *. right. intro. assumption.
   intros h t IH H. simpl in |- *.
   elim (H h).
   left. left. assumption.
   elim IH.
   left. right. assumption.
   right. intro. elim H2.
   assumption. assumption.
   assumption.
Qed.

(** Membership *)

Definition inlist (A : Set) (a : A) := exlist A (fun b : A => a = b).

Lemma inlist_head_eq :
 forall (A : Set) (x y : A) (l : list A), x = y -> inlist A x (Cons A y l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *.
   left. assumption.
Qed.

Lemma inlist_head_neq :
 forall (A : Set) (x y : A) (l : list A),
 x <> y -> (inlist A x (Cons A y l) <-> inlist A x l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *.
   split.
   intros. elim H0. intro. elim H. assumption.
   intros. assumption.
   intros. right. assumption.
Qed.

Lemma inlist_tail :
 forall (A : Set) (x y : A) (l : list A),
 inlist A x l -> inlist A x (Cons A y l).
Proof.
   intros. unfold inlist in |- *. simpl in |- *. right. assumption.
Qed.

Lemma inlist_dec :
 forall (A : Set) (x : A) (l : list A),
 (forall a b : A, a = b \/ a <> b) -> inlist A x l \/ ~ inlist A x l.
Proof.
   intros. unfold inlist in |- *.
   apply exlist_dec. exact (H x).
Qed.

(** alllist and exlist behave nicely *)

Theorem alllist_ok :
 forall (A : Set) (P : A -> Prop) (qlist : list A),
 alllist A P qlist <-> (forall q : A, inlist A q qlist -> P q).
Proof.
   split.

   (* -> *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H0.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H. intros. elim H2.
   intro. rewrite H3. assumption.
   intro. apply IH. assumption. assumption.

   (* <- *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. trivial.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. split.
   apply H. left. reflexivity.
   apply IH. intros. apply H. right. assumption.
Qed.

Theorem exlist_ok :
 forall (A : Set) (P : A -> Prop) (qlist : list A),
 exlist A P qlist <-> (exists q : A, inlist A q qlist /\ P q).
Proof.
   split.

   (* -> *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H.
   intro. split with q. split. left. reflexivity. assumption.
   intro. elim IH. intros q1 Hq1. elim Hq1. intros. split with q1.
   split. right. assumption. assumption. assumption.

   (* <- *)
   elim qlist.
   unfold inlist in |- *. simpl in |- *. intros. elim H. intros. elim H0. intros. elim H1.
   unfold inlist in |- *. simpl in |- *. intros q l IH H. elim H.
   intros q1 Hq1. elim Hq1. intros. elim H0.
   intro. left. rewrite <- H2. assumption.
   intro. right. apply IH. split with q1. split. assumption. assumption.
Qed.

(** * Lists of natural numbers. *)

Definition natlist := list nat.

(** Multiply all elements of a natlist *)

Fixpoint product (qlist : natlist) : nat :=
  match qlist with
  | Nil => 1
  | Cons m l => m * product l
  end.

(** Drop the first occurance of q from qlist *)

Fixpoint drop (q : nat) (qlist : natlist) {struct qlist} : natlist :=
  match qlist with
  | Nil => Nil nat
  | Cons q' l => if beq_nat q q' then l else Cons nat q' (drop q l)
  end.

(** Multiply all elements of qlist, except for (first occurance of) q *)

Definition multDrop (q : nat) (l : natlist) := product (drop q l).

Lemma multdrop_cons_eq :
 forall (q : nat) (l : natlist), multDrop q (Cons nat q l) = product l.
Proof.
   unfold multDrop in |- *. simpl in |- *. intros. elim (beq_nat_eq q q). intros.
   rewrite H. reflexivity. reflexivity.
Qed.

Lemma multdrop_cons_neq :
 forall (p q : nat) (l : natlist),
 p <> q -> multDrop p (Cons nat q l) = q * multDrop p l.
Proof.
   unfold multDrop in |- *. simpl in |- *. intros. elim (beq_nat_neq p q). intros.
   rewrite H0. simpl in |- *. reflexivity. assumption.
Qed.

Lemma multdrop_mult :
 forall (qlist : natlist) (q : nat),
 inlist nat q qlist -> q * multDrop q qlist = product qlist.
Proof.
   simple induction qlist.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros q1 l IH. intros. elim (eqdec q q1).

   (* case q=q1 *)
   intro. rewrite H0. rewrite multdrop_cons_eq. reflexivity.

   (* case ~q=q1 *)
   intro. rewrite multdrop_cons_neq.
   rewrite <- (IH q). rewrite mult_assoc.
   rewrite (mult_comm q q1). rewrite mult_assoc. reflexivity.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intro. assumption.
   assumption.
Qed.

(** * Lists of integers. *)

Definition Zlist := list Z.

(** allPos checks whether all members of a Zlist are non-negative. *)

Definition allPos : Zlist -> Prop := alllist Z (fun x : Z => (x >= 0)%Z).

(** Multiply all elements of a Zlist *)

Fixpoint zproduct (l : Zlist) : Z :=
  match l with
  | Nil => 1%Z
  | Cons x t => (x * zproduct t)%Z
  end.

Lemma productzproduct :
 forall l : natlist, Z_of_nat (product l) = zproduct (map nat Z Z_of_nat l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   simpl in |- *. rewrite <- IH.
   rewrite Znat.inj_mult.
   reflexivity.
Qed.

Lemma zproductproduct :
 forall l : Zlist, Z.abs_nat (zproduct l) = product (map Z nat Z.abs_nat l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   simpl in |- *. rewrite abs_mult.
   rewrite IH. reflexivity.
Qed.

(** Drop an element from a Zlist *)

Fixpoint zdrop (x : Z) (l : Zlist) {struct l} : Zlist :=
  match l with
  | Nil => Nil Z
  | Cons h t => if Zeq_bool x h then t else Cons Z h (zdrop x t)
  end.

Lemma zdrop_head_eq :
 forall (x y : Z) (l : Zlist), x = y -> zdrop x (Cons Z y l) = l.
Proof.
   simpl in |- *. intros. elim (zeq_bool_eq x y). intros.
   rewrite H0. reflexivity. assumption.
Qed.

Lemma zdrop_head_neq :
 forall (x y : Z) (l : Zlist),
 x <> y -> zdrop x (Cons Z y l) = Cons Z y (zdrop x l).
Proof.
   simpl in |- *. intros. elim (zeq_bool_neq x y). intros.
   rewrite H0. reflexivity. assumption.
Qed.

Lemma zdrop_length :
 forall (x : Z) (l : Zlist),
 inlist Z x l -> S (length Z (zdrop x l)) = length Z l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intros. elim H.
   intros h t IH. intros. elim (zeqdec x h).

   (* case x=h *)
   intro. simpl in |- *. elim (zeq_bool_eq x h).
   intros. rewrite H1. reflexivity. assumption.

   (* case x<>h *)
   intro. simpl in |- *. elim (zeq_bool_neq x h).
   intros. rewrite H1. simpl in |- *. rewrite IH. reflexivity.
   elim H. intros. elim H0. assumption. intros. assumption. assumption.
Qed.

Lemma zdrop_neq_inlist :
 forall (x y : Z) (l : Zlist),
 x <> y -> inlist Z x l -> inlist Z x (zdrop y l).
Proof.
   simple induction l.
   intros. elim H0.
   intros h t IH.
   intros. elim (zeqdec x h).
   intro. rewrite zdrop_head_neq.
   apply inlist_head_eq. assumption.
   rewrite <- H1. intro. apply H. symmetry  in |- *. assumption.
   intro. elim (zeqdec y h).
   intro. rewrite zdrop_head_eq.
   elim (inlist_head_neq Z x h t).
   intros. apply H3. assumption.
   assumption. assumption.
   intro. rewrite zdrop_head_neq.
   elim (inlist_head_neq Z x h (zdrop y t)). intros.
   apply H4. apply IH. assumption.
   elim (inlist_head_neq Z x h t). intros.
   apply H5. assumption.
   assumption. assumption. assumption.
Qed.

Lemma zdrop_inlist_weak :
 forall (x y : Z) (l : Zlist), inlist Z x (zdrop y l) -> inlist Z x l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intro. assumption.
   intros h t IH. intros.
   elim (zeqdec x h).
   intro. rewrite H0. unfold inlist in |- *. simpl in |- *. left. reflexivity.
   intro. elim (zeqdec y h).
   intro. rewrite H1 in H. rewrite zdrop_head_eq in H.
   apply inlist_tail. assumption. reflexivity.
   intro. rewrite zdrop_head_neq in H.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intros. apply inlist_tail. apply IH. assumption.
   assumption.
Qed.

Lemma zdrop_swap :
 forall (x y : Z) (l : Zlist), zdrop x (zdrop y l) = zdrop y (zdrop x l).
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   intros h t IH.
   elim (zeqdec x h). elim (zeqdec y h).

   (* y=h, x=h *)
   intros. rewrite H. rewrite H0. reflexivity.

   (* y<>h, x=h *)
   intros.
   rewrite (zdrop_head_eq x h t).
   rewrite (zdrop_head_neq y h t).
   rewrite zdrop_head_eq. reflexivity.
   assumption. assumption. assumption.

   elim (zeqdec y h).

   (* y=h, x<>h *)
   intros.
   rewrite (zdrop_head_eq y h).
   rewrite (zdrop_head_neq x h).
   rewrite zdrop_head_eq. reflexivity.
   assumption. assumption. assumption.

   (* y<>h, x<>h *)
   intros.
   rewrite (zdrop_head_neq y h).
   rewrite (zdrop_head_neq x h).
   rewrite (zdrop_head_neq x h).
   rewrite (zdrop_head_neq y h).
   rewrite IH. reflexivity.
   assumption. assumption.
   assumption. assumption.
Qed.

Lemma zdrop_inlist_swap :
 forall (x y : Z) (l : Zlist),
 inlist Z y l -> inlist Z x (zdrop y l) -> inlist Z y (zdrop x l).
Proof.
   simple induction l.
   simpl in |- *. intro H. elim H.
   intros h t IH.
   elim (zeqdec x h). elim (zeqdec y h).

   (* y=h,x=h *)
   intros Hyh Hxh. rewrite Hyh. rewrite Hxh.
   intros. assumption.

   (* y<>h,x=h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_neq y).
   rewrite (zdrop_head_eq x).
   intros. elim (inlist_head_neq Z y h t).
   intros. apply H1. assumption.
   assumption. assumption. assumption.

   elim (zeqdec y h).

   (* y=h,x<>h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_eq y).
   rewrite (zdrop_head_neq x).
   intros. apply inlist_head_eq. assumption.
   assumption. assumption.

   (* y<>h, x<>h *)
   intros Hyh Hxh.
   rewrite (zdrop_head_neq y).
   rewrite (zdrop_head_neq x).
   intros. elim (inlist_head_neq Z y h (zdrop x t)).
   intros. apply H2. apply IH.
   elim (inlist_head_neq Z y h t). intros.
   apply H3. assumption. assumption.
   elim (inlist_head_neq Z x h (zdrop y t)). intros.
   apply H3. assumption.
   assumption. assumption. assumption. assumption.
Qed.

Lemma zdrop_product :
 forall (x : Z) (l : Zlist),
 inlist Z x l -> (x * zproduct (zdrop x l))%Z = zproduct l.
Proof.
   simple induction l.
   simpl in |- *. intro. elim H.
   intros h t IH. elim (zeqdec x h).
   intros. rewrite zdrop_head_eq.
   rewrite H. reflexivity. assumption.
   intros. rewrite zdrop_head_neq.
   simpl in |- *. rewrite Zmult_assoc.
   rewrite Zmult_comm with x h.
   rewrite Zmult_assoc_reverse.
   rewrite IH. reflexivity.
   elim inlist_head_neq with Z x h t. intros.
   apply H1. assumption.
   assumption. assumption.
Qed.

(** Multiply all elements except first occurance of x *)

Definition zmultDrop (x : Z) (l : Zlist) := zproduct (zdrop x l).

Lemma zmultdrop_cons_eq :
 forall (q : Z) (l : Zlist), zmultDrop q (Cons Z q l) = zproduct l.
Proof.
   unfold zmultDrop in |- *. simpl in |- *. intros. elim (zeq_bool_eq q q). intros.
   rewrite H. reflexivity. reflexivity.
Qed.

Lemma zmultdrop_cons_neq :
 forall (p q : Z) (l : Zlist),
 p <> q -> zmultDrop p (Cons Z q l) = (q * zmultDrop p l)%Z.
Proof.
   unfold zmultDrop in |- *. simpl in |- *. intros. elim (zeq_bool_neq p q). intros.
   rewrite H0. simpl in |- *. reflexivity. assumption.
Qed.

Lemma zmultdrop_mult :
 forall (qlist : Zlist) (q : Z),
 inlist Z q qlist -> (q * zmultDrop q qlist)%Z = zproduct qlist.
Proof.
   simple induction qlist.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros q1 l IH. intros. elim (zeqdec q q1).

   (* case q=q1 *)
   intro. rewrite H0. rewrite zmultdrop_cons_eq. reflexivity.

   (* case ~q=q1 *)
   intro. rewrite zmultdrop_cons_neq.
   rewrite <- (IH q). rewrite Zmult_assoc.
   rewrite (Zmult_comm q q1). rewrite Zmult_assoc. reflexivity.
   unfold inlist in H. simpl in H. elim H.
   intro. elim H0. assumption.
   intro. assumption.
   assumption.
Qed.

Lemma multdropzmultdrop :
 forall (q : nat) (qlist : natlist),
 Z_of_nat (multDrop q qlist) =
 zmultDrop (Z_of_nat q) (map nat Z Z_of_nat qlist).
Proof.
   simple induction qlist.
   simpl in |- *. reflexivity.
   intros h t.
   elim (eqdec q h).

   (* q=h *)
   intro H. rewrite H. simpl in |- *.
   rewrite multdrop_cons_eq.
   rewrite zmultdrop_cons_eq.
   rewrite productzproduct.
   intro IH. reflexivity.

   (* ~q=h *)
   intro H. simpl in |- *.
   rewrite multdrop_cons_neq.
   rewrite zmultdrop_cons_neq.
   intro IH. rewrite <- IH.
   rewrite Znat.inj_mult. reflexivity.
   intro. apply H.
   rewrite <- (abs_inj q). rewrite <- (abs_inj h).
   rewrite H0. reflexivity.
   assumption.
Qed.

(** Multiply all elements in list with a *)

Definition mapmult (a : Z) (l : Zlist) := map Z Z (fun x : Z => (a * x)%Z) l.

Lemma mapmult_image :
 forall (a : Z) (l : Zlist) (x : Z),
 inlist Z x l -> inlist Z (a * x)%Z (mapmult a l).
Proof.
   unfold mapmult in |- *. unfold inlist in |- *. simple induction l.
   simpl in |- *. intros. assumption.
   simpl in |- *. intros h t IH. intros. elim H.
   left. rewrite H0. reflexivity.
   right. apply IH. assumption.
Qed.

Lemma mapmult_orig :
 forall (a : Z) (l : Zlist) (y : Z),
 inlist Z y (mapmult a l) -> exists x : Z, inlist Z x l /\ y = (a * x)%Z.
Proof.
   unfold mapmult in |- *. unfold inlist in |- *. simple induction l.
   simpl in |- *. intros. elim H.
   simpl in |- *. intros h t IH. intros.
   elim H.
   intro. split with h. split. left. reflexivity. assumption.
   intro. elim (IH y). intros. elim H1. intros.
   split with x. split. right.
   assumption. assumption. assumption.
Qed.

(** Lift inject_nat and absolu to natlist and Zlist. *)

Lemma abs_inj_list :
 forall l : natlist, map _ _ Z.abs_nat (map _ _ Z_of_nat l) = l.
Proof.
   simple induction l.
   simpl in |- *. reflexivity.
   simpl in |- *. intros h t IH.
   rewrite abs_inj. rewrite IH. reflexivity.
Qed.

Lemma inj_abs_pos_list :
 forall l : Zlist, allPos l -> map _ _ Z_of_nat (map _ _ Z.abs_nat l) = l.
Proof.
   simple induction l.
   simpl in |- *. intros. reflexivity.
   simpl in |- *. intros h t IH H. elim H. intros.
   rewrite inj_abs_pos. rewrite IH. reflexivity.
   assumption. assumption.
Qed.

Lemma inlist_inj_abs_pos_list :
 forall (q : nat) (l : Zlist),
 allPos l -> inlist nat q (map Z nat Z.abs_nat l) -> inlist Z (Z_of_nat q) l.
Proof.
   simple induction l.
   unfold inlist in |- *. simpl in |- *. intros. assumption.
   unfold inlist in |- *. unfold allPos in |- *. simpl in |- *.
   intros h t IH Hp H. elim Hp. elim H.
   left. rewrite H0. rewrite inj_abs_pos. reflexivity.
   intros. assumption.
   right. apply IH. assumption. assumption.
Qed.


Require Import TestSuite.admit.
Section group_morphism.

(* An example with default canonical structures *)

Variable A B : Type.
Variable plusA : A -> A -> A.
Variable plusB : B -> B -> B.
Variable zeroA : A.
Variable zeroB : B.
Variable eqA : A -> A -> Prop.
Variable eqB : B -> B -> Prop.
Variable phi : A -> B.

Record img := {
  ia : A;
  ib :> B;
  prf : phi ia = ib
}.

Parameter eq_img : forall (i1:img) (i2:img),
  eqB (ib i1) (ib i2) -> eqA (ia i1) (ia i2).

Lemma phi_img (a:A) : img.
  exists  a (phi a).
  refine ( refl_equal _).
Defined.
Canonical Structure phi_img.

Lemma zero_img : img.
  exists zeroA zeroB.
  admit.
Defined.
Canonical Structure zero_img.

Lemma plus_img : img -> img -> img.
intros i1 i2.
exists (plusA (ia i1) (ia i2)) (plusB (ib i1) (ib i2)).
admit.
Defined.
Canonical Structure plus_img.

(* Print Canonical Projections. *)

Goal forall a1 a2, eqA (plusA a1 zeroA) a2.
  intros a1 a2.
  refine  (eq_img _ _  _).
change (eqB (plusB (phi a1) zeroB) (phi a2)).
Admitted.

Variable foo : A -> Type.

Definition local0 := fun (a1 : A) (a2 : A) (a3 : A) =>
                       (eq_refl : plusA a1 (plusA zeroA a2) = ia _).
Definition local1 :=
  fun (a1 : A) (a2 : A) (f : A -> A) =>
    (eq_refl : plusA a1 (plusA zeroA (f a2)) = ia _).

Definition local2 :=
  fun (a1 : A) (f : A -> A) =>
    (eq_refl : (f a1) = ia _).

Goal forall a1 a2, eqA (plusA a1 zeroA) a2.
  intros a1 a2.
  refine  (eq_img _ _  _).
change (eqB (plusB (phi a1) zeroB) (phi a2)).
Admitted.

End group_morphism.

Open Scope type_scope.

Section type_reification.

Inductive term :Type :=
   Fun : term -> term -> term
 | Prod : term -> term -> term
 | Bool : term
 | SET :term
 | PROP :term
 | TYPE :term
 | Var : Type -> term.

Fixpoint interp (t:term) :=
  match t with
    Bool => bool
  | SET => Set
  | PROP => Prop
  | TYPE => Type
  | Fun a b => interp a -> interp b
  | Prod a b => interp a * interp b
  | Var x => x
end.

Record interp_pair :Type :=
  { repr:>term;
    abs:>Type;
    link: abs = interp repr }.

Lemma prod_interp :forall (a b:interp_pair),a * b = interp (Prod a b) .
Proof.
intros a b.
change (a * b = interp a * interp b).
rewrite (link a), (link b); reflexivity.
Qed.

Lemma fun_interp :forall (a b:interp_pair), (a -> b) = interp (Fun a b).
Proof.
intros a b.
change ((a -> b) = (interp a -> interp b)).
rewrite (link a), (link b); reflexivity.
Qed.

Canonical Structure ProdCan (a b:interp_pair) :=
  Build_interp_pair (Prod a b) (a * b) (prod_interp a b).

Canonical Structure FunCan (a b:interp_pair) :=
  Build_interp_pair (Fun a b) (a -> b) (fun_interp a b).

Canonical Structure BoolCan :=
  Build_interp_pair Bool bool (refl_equal _).

Canonical Structure VarCan (x:Type) :=
  Build_interp_pair (Var x) x (refl_equal _).

Canonical Structure SetCan :=
  Build_interp_pair SET Set (refl_equal _).

Canonical Structure PropCan :=
  Build_interp_pair PROP Prop (refl_equal _).

Canonical Structure TypeCan :=
  Build_interp_pair TYPE Type (refl_equal _).

(* Print Canonical Projections. *)

Variable A:Type.

Variable Inhabited: term -> Prop.

Variable Inhabited_correct: forall p, Inhabited (repr p)  -> abs p.

Lemma L : Prop * A -> bool * (Type -> Set) .
refine (Inhabited_correct _ _).
change (Inhabited (Fun (Prod PROP (Var A)) (Prod Bool (Fun TYPE SET)))).
Admitted.

Check L : abs _ .

End type_reification.


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

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj29synthconj4 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (Succ (plus (mult lv0 (plus Zero lv1)) (plus lv1 lv0))) (plus (mult lv1 lv2) lv2)).
Admitted.
QuickChick conj29synthconj4.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal33.

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

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Open Scope string_scope.

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


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

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

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

Theorem pipo_6 : (forall A B C D O M1 : Universe, ((wd_ A B /\ (wd_ A C /\ (wd_ B C /\ (wd_ O M1 /\ (wd_ O A /\ (wd_ O C /\ (wd_ O D /\ (wd_ O B /\ (wd_ M1 A /\ (wd_ M1 B /\ (col_ A B C /\ (col_ O A C /\ col_ M1 A B)))))))))))) -> col_ A O B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import
        FJ.Base
        FJ.Syntax
        FJ.Semantics.AuxiliarDefinitions
        FJ.Typing
        FJ.Tactics
        FJ.Typechecker.ExpTypechecker.

Definition MethodOkDec : forall (n : nat) CT C (M : Method), {{ M | MethodOk CT C M}}.
  refine (fun n CT C M =>
            match MapsToDec C CT with
            | !! => ??
            | [|| CD ||] =>
                match ExpHasTypeDec n CT (mkGamma ((mkFormalArg this C) :: (margs M)))
                                    (mbody M) with
                | ?? => ??
                | Found _ D _ =>
                  match valid_overrideDec CT n (mname M) (cextends CD)
                                          (mkMethodType (map ftype (margs M)) (mtype M)) with
                  | No => ??
                  | Yes =>
                    match BoundedSubtypeDec CT n D (mtype M) with
                    | Yes => Found _ M _
                    | No  => ??
                    end
                  end
              end
            end) ; simpl in * ; try map_solver ; eauto.
  eapply T_Method ;eauto.
  eapply BoundedSubtypeSound ; eauto.
Defined.


Require Import Framework File FileDiskNoninterference FileDiskRefinement.
Require Import FunctionalExtensionality Lia.

Lemma lt_le_lt:
      forall n m p q,
      n + m < q -> p <= m -> n + p < q.
Proof.  lia. Qed.

Lemma nth_error_None_r :
forall T (l: list T) n,
n >= length l ->
nth_error l n = None.
Proof.
  apply nth_error_None.
Qed.

Lemma used_blocks_are_allocated:
forall s2 off inum fm,
refines s2 fm ->
inum < Inode.InodeAllocatorParams.num_of_blocks ->
off < length (Inode.block_numbers
(Inode.decode_inode
    (fst (snd (snd s2))
      (Inode.InodeAllocatorParams.bitmap_addr + S inum)))) ->
test_bit inum
(value_to_bits
  (fst (snd (snd s2)) Inode.InodeAllocatorParams.bitmap_addr)) = true ->
test_bit (nth off (Inode.block_numbers (Inode.decode_inode
            (fst (snd (snd s2)) (Inode.InodeAllocatorParams.bitmap_addr + S inum)))) 0)
  (value_to_bits (fst (snd (snd s2)) DiskAllocatorParams.bitmap_addr)) = true.
Proof.
  unfold refines, files_rep,
  files_inner_rep; intros.
  cleanup; repeat cleanup_pairs.
  destruct_fresh (x inum).
  {
    eapply_fresh FileInnerSpecs.inode_exists_then_file_exists in D; eauto.
    cleanup.

    unfold file_rep in *; cleanup.

      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H8.
      cleanup; split_ors; cleanup; try congruence.
      (* rewrite H4, H11 in D; simpl in *; try congruence. *)

      unfold Inode.inode_map_valid, Inode.inode_valid in *; cleanup.
      unfold file_map_rep, file_rep in *; cleanup.
      eapply_fresh H12 in D; eauto; cleanup.

      unfold DiskAllocator.block_allocator_rep in *.
      edestruct H7; eauto.
      rewrite H4, H11 in D; simpl in *; try congruence.
      cleanup.

      destruct_fresh (nth_error (Inode.block_numbers (Inode.decode_inode (seln x4 inum value0))) off).
      edestruct H16 in D; eauto; cleanup.
      eapply nth_error_nth with (d:= 0) in D; rewrite <- D in *.

      eapply DiskAllocator.valid_bits_extract with (n:= (nth off
      (Inode.block_numbers
         (Inode.decode_inode (seln x4 inum value0)))
      0)) in H19.
      cleanup; split_ors; cleanup; try congruence.

      eapply Forall_forall in H18.
      2: eapply nth_In; eauto.
      instantiate (1:= 0) in H18.
      pose proof DiskAllocatorParams.num_of_blocks_in_bounds.
      eapply PeanoNat.Nat.lt_le_trans; eauto.

      rewrite H20.
      unfold DiskAllocatorParams.num_of_blocks; eauto.
      rewrite H20; eauto.

      apply nth_error_None in D; lia.
      lia.

      rewrite H9; eauto.
  }
  {
    unfold file_rep in *; cleanup.
      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H7.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H3, H10 in D; simpl in *; congruence.

      all: try rewrite value_to_bits_length;
      unfold Inode.InodeAllocatorParams.num_of_blocks in *;
      pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.
  }
Qed.

Lemma data_block_inbounds:
forall inum off s2 fm,
refines s2 fm ->
inum < Inode.InodeAllocatorParams.num_of_blocks ->
off < length (Inode.block_numbers
(Inode.decode_inode
    (fst (snd (snd s2))
      (Inode.InodeAllocatorParams.bitmap_addr + S inum)))) ->
test_bit inum
(value_to_bits
  (fst (snd (snd s2)) Inode.InodeAllocatorParams.bitmap_addr)) = true ->
DiskAllocatorParams.bitmap_addr +
S
(nth off
(Inode.block_numbers
(Inode.decode_inode
  (fst (snd (snd (fst s2, snd s2)))
    (Inode.InodeAllocatorParams.bitmap_addr + S inum)))) 0) <
FSParameters.data_length.
Proof.
  unfold refines, files_rep,
  files_inner_rep; intros.
  cleanup; repeat cleanup_pairs.
  destruct_fresh (x inum).
  {
    eapply_fresh FileInnerSpecs.inode_exists_then_file_exists in D; eauto.
    cleanup.

    unfold file_rep in *; cleanup.

      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H8.
      cleanup; split_ors; cleanup; try congruence.

      unfold Inode.inode_map_valid, Inode.inode_valid in *; cleanup.
      eapply_fresh H7 in D; eauto.
      cleanup.
      unfold file_map_rep, file_rep in *; cleanup.
      eapply_fresh H14 in D; eauto; cleanup.

      unfold DiskAllocator.block_allocator_rep in *.
      rewrite H4, H11 in D; simpl in *; cleanup.

      destruct_fresh (nth_error (Inode.block_numbers (Inode.decode_inode (seln x4 inum value0))) off).
      eapply_fresh H18 in D; cleanup.
      eapply nth_error_nth with (d:= 0) in D; rewrite <- D in *.

      eapply DiskAllocator.valid_bits_extract with (n:= (nth off
      (Inode.block_numbers
         (Inode.decode_inode (seln x4 inum value0)))
      0)) in H19.
      cleanup; split_ors; cleanup; try congruence.
      pose proof DiskAllocatorParams.blocks_fit_in_disk.
      unfold DiskAllocatorParams.bitmap_addr, DiskAllocatorParams.num_of_blocks in *.

      eapply Forall_forall in H13.
      2: eapply nth_In; eauto.
      instantiate (1:= 0) in H13.
      apply PeanoNat.Nat.le_succ_l in H13.
      eapply lt_le_lt; eauto.

      rewrite H20.
      eapply Forall_forall in H13.
      2: eapply nth_In; eauto.
      instantiate (1:= 0) in H13.
      pose proof DiskAllocatorParams.num_of_blocks_in_bounds.
      eapply PeanoNat.Nat.lt_le_trans; eauto.

      rewrite H20; eauto.

      apply nth_error_None in D; lia.
      lia.

      rewrite H9; eauto.
  }
  {
    unfold file_rep in *; cleanup.
    unfold Inode.inode_rep,
    Inode.inode_map_rep,
    Inode.InodeAllocator.block_allocator_rep in *.
    cleanup.

    eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H7.
    cleanup; split_ors; cleanup; try congruence.
    rewrite H3, H10 in D; simpl in *; congruence.

    all: try rewrite value_to_bits_length;
    unfold Inode.InodeAllocatorParams.num_of_blocks in *;
    pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.
  }
Qed.

Hint Resolve data_block_inbounds: core.

Lemma data_block_inbounds_2:
forall inum off s fm im dm inode,
Inode.inode_rep im s ->
File.DiskAllocator.block_allocator_rep dm s ->
File.file_map_rep fm im dm ->
im inum = Some inode ->
off < length (Inode.block_numbers inode) ->
File.DiskAllocatorParams.bitmap_addr +
S (seln (Inode.block_numbers inode) off 0) <
FSParameters.data_length.
Proof.
  intros.
  cleanup; repeat cleanup_pairs.
    eapply_fresh FileInnerSpecs.inode_exists_then_file_exists in H2; eauto.
    cleanup.

      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H7.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H5, H10 in H2; simpl in *; congruence.

      unfold Inode.inode_map_valid, Inode.inode_valid in *; cleanup.
      eapply_fresh H6 in H2; eauto.
      cleanup.
      unfold File.file_map_rep, File.file_rep in *; cleanup.
      eapply_fresh H14 in H2; eauto; cleanup.

      unfold File.DiskAllocator.block_allocator_rep in *.
      rewrite H5, H10 in H2; simpl in *; cleanup.

      destruct_fresh (nth_error (Inode.block_numbers (Inode.decode_inode (seln x2 inum value0))) off).
      eapply_fresh H18 in D; cleanup.
      eapply nth_error_nth with (d:= 0) in D; rewrite <- D in *.

      eapply File.DiskAllocator.valid_bits_extract with (n:= (nth off
      (Inode.block_numbers
         (Inode.decode_inode (seln x2 inum value0)))
      0)) in H19.
      cleanup; split_ors; cleanup; try congruence.
      pose proof File.DiskAllocatorParams.blocks_fit_in_disk.
      unfold File.DiskAllocatorParams.bitmap_addr, File.DiskAllocatorParams.num_of_blocks in *.

      eapply Forall_forall in H13.
      2: eapply nth_In; eauto.
      instantiate (1:= 0) in H13.
      apply PeanoNat.Nat.le_succ_l in H13.
      eapply lt_le_lt; eauto.
      rewrite nth_seln_eq; eauto.

      rewrite H20.
      eapply Forall_forall in H13.
      2: eapply nth_In; eauto.
      instantiate (1:= 0) in H13.
      pose proof File.DiskAllocatorParams.num_of_blocks_in_bounds.
      eapply PeanoNat.Nat.lt_le_trans; eauto.

      rewrite H20; eauto.

      apply nth_error_None in D; lia.
      destruct (Compare_dec.lt_dec inum (length x2)); eauto.
      edestruct (H9 inum); try lia.
      rewrite H5, H in H2; simpl in *; try congruence; try lia.
      rewrite H8; eauto.
Qed.

Set Nested Proofs Allowed.
Lemma used_blocks_are_allocated_2:
forall s off inum im inode dm fm,
Inode.inode_rep im s ->
File.DiskAllocator.block_allocator_rep
     dm s ->
     File.file_map_rep fm im dm ->
im inum = Some inode ->
off < length (Inode.block_numbers inode) ->
test_bit (seln (Inode.block_numbers inode) off 0)
  (value_to_bits
    (s File.DiskAllocatorParams.bitmap_addr)) = true.
Proof.
intros.
eapply_fresh FileInnerSpecs.inode_exists_then_file_exists in H2; eauto.
cleanup.
unfold Inode.inode_rep, Inode.inode_map_rep,
Inode.inode_map_valid,
Inode.inode_valid,
Inode.InodeAllocator.block_allocator_rep in *; cleanup.
match goal with
     | [H: ?x1 ?inum = Some _,
        H1: forall _ _,
        ?x1 _ = Some _ -> _ /\ _|- _] =>
        eapply_fresh H1 in H; eauto; cleanup
end.

match goal with
| [H: Forall _ (Inode.block_numbers _)|- _] =>
  eapply_fresh Forall_forall in H; [| eapply in_seln; eauto]
end;
unfold File.DiskAllocatorParams.num_of_blocks; intuition eauto.
destruct (Compare_dec.lt_dec inum Inode.InodeAllocatorParams.num_of_blocks).
{
  match goal with
| [H: Inode.InodeAllocator.valid_bits
_ _ (value_to_bits
   (?s1
      Inode.InodeAllocatorParams.bitmap_addr))
?s1 |- _] =>
eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H; eauto
end.
all: try solve [pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds;
try rewrite value_to_bits_length;
unfold Inode.InodeAllocatorParams.num_of_blocks in *; try lia].
cleanup; split_ors; cleanup; try congruence.
- rewrite H5, H13 in H2; simpl in *; congruence.
- unfold File.file_map_rep, File.file_rep in *; cleanup.
eapply_fresh a0 in H2; eauto; cleanup.

unfold File.DiskAllocator.block_allocator_rep in *.
cleanup.
rewrite H5, H13 in H2; simpl in *; cleanup.

destruct_fresh (nth_error (Inode.block_numbers (Inode.decode_inode (seln x2 inum value0))) off).
eapply_fresh H15 in D; cleanup.
eapply nth_error_nth with (d:= 0) in D; rewrite <- D in *.

eapply File.DiskAllocator.valid_bits_extract with (n:= (nth off
(Inode.block_numbers
   (Inode.decode_inode (seln x2 inum value0)))
0)) in v.
cleanup; split_ors; cleanup; try congruence.
erewrite nth_seln_eq; eauto.

rewrite e1.
rewrite <- nth_seln_eq.
unfold File.DiskAllocatorParams.num_of_blocks in *;
pose proof File.DiskAllocatorParams.num_of_blocks_in_bounds.
eapply PeanoNat.Nat.lt_le_trans; eauto.

rewrite e1; eauto.

apply nth_error_None in D; lia.
}
{
  unfold Inode.inode_rep, Inode.inode_map_rep,
    Inode.inode_map_valid,
    Inode.inode_valid,
    Inode.InodeAllocator.block_allocator_rep in *; cleanup.
    edestruct (H10 inum); try lia.
    rewrite H5, H12 in *;
    simpl in *; try lia; try congruence.
}
Qed.

Lemma inode_allocations_are_same:
forall im1 im2 s1 s2 inum,
Inode.inode_rep im1 s2 ->
Inode.inode_rep im2 s1 ->
addrs_match_exactly im1 im2 ->
inum < Inode.InodeAllocatorParams.num_of_blocks ->
test_bit inum
(value_to_bits
  (s1 Inode.InodeAllocatorParams.bitmap_addr)) =
test_bit inum
  (value_to_bits (s2 Inode.InodeAllocatorParams.bitmap_addr)).
Proof.
  unfold refines, files_rep,
  files_inner_rep, same_for_user_except; intros.
  cleanup; repeat cleanup_pairs.
  destruct_fresh (im1 inum).
  {
      destruct_fresh (im2 inum).
      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.
      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H10.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H8, H10 in D; simpl in *; congruence.
      rewrite nth_seln_eq in H.
      repeat erewrite nth_error_nth'.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H5.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H3, H14 in D0; simpl in *; congruence.
      all: try rewrite value_to_bits_length;
      unfold Inode.InodeAllocatorParams.num_of_blocks in *;
      pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.

      unfold file_map_rep in *; cleanup.
      edestruct H1; exfalso.
      apply H4; eauto; congruence.
    }
  {
    destruct_fresh (im2 inum).
    {
      unfold file_map_rep in *; cleanup.
      edestruct H1; exfalso.
      apply H4; eauto; congruence.
    }
    {
      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.
      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H10.
      cleanup; split_ors; cleanup; try congruence.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H5.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H3, H14 in D0; simpl in *; congruence.
      all: try rewrite value_to_bits_length;
      unfold Inode.InodeAllocatorParams.num_of_blocks in *;
      pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.
      rewrite H8, H10 in D; simpl in *; congruence.
    }
  }
Qed.

Lemma inode_allocations_are_same_2:
forall u im1 im2 fm1 fm2 bm1 bm2 s1 s2 inum ex,
Inode.inode_rep im1 s1 ->
Inode.inode_rep im2 s2 ->
file_map_rep fm1 im1 bm1 ->
file_map_rep fm2 im2 bm2 ->
same_for_user_except u ex fm1 fm2 ->
inum < Inode.InodeAllocatorParams.num_of_blocks ->
test_bit inum
(value_to_bits
  (s1 Inode.InodeAllocatorParams.bitmap_addr))
= test_bit inum
  (value_to_bits (s2 Inode.InodeAllocatorParams.bitmap_addr)).
Proof.
  unfold refines, files_rep,
  files_inner_rep, same_for_user_except; intros.
  cleanup; repeat cleanup_pairs.
  destruct_fresh (im1 inum).
  {
    eapply_fresh FileInnerSpecs.inode_exists_then_file_exists in D; eauto.
    cleanup.
    destruct_fresh (fm1 inum).
    {
      destruct_fresh (im2 inum).
      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.
      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H15.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H13, H7 in D; simpl in *; congruence.
      rewrite nth_seln_eq in H.
      repeat erewrite nth_error_nth'.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H10.
      cleanup; split_ors; cleanup; try congruence.
      rewrite H8, H18 in D1; simpl in *; congruence.

      all: try rewrite value_to_bits_length;
      unfold Inode.InodeAllocatorParams.num_of_blocks in *;
      pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.

      unfold file_map_rep in *; cleanup.
      edestruct H3; edestruct H2; exfalso.
      apply H14; eauto.
      eapply H7; eauto; congruence.
    }
    {
      cleanup.
    }
  }
  {
    eapply_fresh FileInnerSpecs.inode_missing_then_file_missing in D; eauto.
    cleanup.
    destruct_fresh (fm1 inum).
    {
      congruence.
    }
    destruct_fresh (im2 inum).
    {
      unfold file_map_rep in *; cleanup.
      edestruct H2; edestruct H3; exfalso.
      eapply H14; eauto.
      eapply H12; eauto.
      congruence.
    }
    {
      unfold Inode.inode_rep,
      Inode.inode_map_rep,
      Inode.InodeAllocator.block_allocator_rep in *.
      cleanup.
      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H14.
      cleanup; split_ors; cleanup; try congruence.

      eapply Inode.InodeAllocator.valid_bits_extract with (n:= inum) in H9.
      cleanup; split_ors; cleanup; try congruence.

      rewrite H7, H18 in D1; simpl in *; congruence.
      all: try rewrite value_to_bits_length;
      unfold Inode.InodeAllocatorParams.num_of_blocks in *;
      pose proof Inode.InodeAllocatorParams.num_of_blocks_in_bounds; try lia.
      rewrite H12, H14 in D; simpl in *; congruence.
    }
  }
Qed.

Lemma get_all_file_sizes_up_to_related_equal:
forall n fm1 fm2 ex u,
same_for_user_except u ex fm1 fm2 ->
get_all_file_sizes_up_to fm1 n = get_all_file_sizes_up_to fm2 n.
Proof.
  unfold same_for_user_except;
  induction n; simpl; intros;
  cleanup; eauto.
  {
    erewrite IHn; eauto.
    destruct_fresh (fm1 n);
    destruct_fresh (fm2 n); eauto.
    {
      eapply H1 in D; eauto; cleanup; eauto.
    }
    {
      edestruct H; exfalso; intuition.
      eapply H2; eauto; congruence.
    }
    {
      edestruct H; exfalso; intuition.
      eapply H3; eauto; congruence.
    }
  }
Qed.

Fixpoint count_trues_up_to n bm :=
match n with
| 0 => 0
| S x =>
  if test_bit x bm then
    S (count_trues_up_to x bm)
  else
  count_trues_up_to x bm
end.

Lemma count_trues_up_to_length :
forall n bm,
count_trues_up_to n bm <= n.
Proof.
  induction n; simpl in *; intros;
  cleanup; try lia.
  specialize (IHn bm).
  destruct (test_bit n bm); simpl; try lia.
Qed.

Lemma count_trues_up_to_length_upper_bound :
forall n bm,
count_trues_up_to n bm <= bitmap_size.
Proof.
  induction n; simpl in *; intros;
  cleanup; try lia.
  specialize (IHn bm).
  destruct_fresh (test_bit n bm); simpl; try lia.
  assert (n < bitmap_size). {
    destruct (Compare_dec.lt_dec n bitmap_size); eauto.
      pose proof test_bit_oob as Hp.
      rewrite Hp in D; try congruence; lia.
  }
  pose proof (count_trues_up_to_length n bm).
  lia.
Qed.

Lemma count_trues_up_to_all :
forall n bm,
count_trues_up_to n bm = n ->
(forall i, i < n -> test_bit i bm = true).
Proof.
  induction n; intros;
  cleanup; try lia; eauto.

  simpl in *.
  destruct (PeanoNat.Nat.eq_dec i n); subst.
  destruct (test_bit n bm); eauto.
  pose proof (count_trues_up_to_length n bm).
  lia.
  apply IHn; eauto.
  destruct (test_bit n bm); eauto.
  pose proof (count_trues_up_to_length n bm).
  lia.
  lia.
Qed.

Lemma get_first_zero_index_count_trues:
forall n bm,
get_first_zero_index bm < n <->
count_trues_up_to n bm < n.
Proof.
  induction n; simpl in *; intros;
  cleanup; try lia.
  destruct_fresh (test_bit n bm); simpl; try lia.
  edestruct (get_first_zero_index_correct bm).
  {
    intuition try lia.
    inversion H1; subst.
    {
      rewrite H in D; try congruence.
      assert (get_first_zero_index bm < bitmap_size). {
        destruct (Compare_dec.lt_dec (get_first_zero_index bm) bitmap_size); eauto.
        pose proof test_bit_oob as Hp.
        rewrite Hp in D; try congruence; lia.
      }
      lia.
    }
    {
      assert(get_first_zero_index bm < n) by lia.
      edestruct IHn; try lia.
      apply H4 in H2; lia.
    }
    {
      assert(count_trues_up_to n bm < n) by lia.
      edestruct IHn; try lia.
      apply H4 in H2; lia.
    }
  }
  {
    {
      intuition try lia.
      inversion H; subst.
      {
        pose proof (count_trues_up_to_length (get_first_zero_index bm) bm).
        lia.
      }
      {
        edestruct (IHn bm); lia.
      }
      {
        edestruct (get_first_zero_index_correct bm).
        destruct (Compare_dec.lt_dec (get_first_zero_index bm) (S n)); eauto.
        rewrite H1 in D; try congruence; lia.
      }
    }
  }
Qed.
(*
Lemma count_trues_lt_exists_empty:
forall bl,
count_trues bl < length bl ->
exists i, i < length bl /\ seln bl i false = false.
Proof.
  induction bl; simpl in *; intros;
  cleanup; try lia.
  edestruct IHbl; try lia.
  cleanup.
  exists (S x); simpl; eauto.
  split; eauto; try lia.
  exists 0; simpl; split; eauto.
  lia.
Qed.

  Lemma count_trues_upd_true:
  forall l a,
  seln l a false = false ->
  a < length l ->
  count_trues (updn l a true) = S (count_trues l).
  Proof.
    induction l; simpl; intros; try lia.
    destruct a0; simpl in *; subst; eauto.
    destruct a; eauto;
    erewrite IHl; eauto; lia.
  Qed.

  Lemma count_trues_upd_false:
  forall l a,
  seln l a false = true ->
  a < length l ->
  S (count_trues (updn l a false)) = count_trues l.
  Proof.
    induction l; simpl; intros; try lia.
    destruct a0; simpl in *; subst; eauto.
    destruct a; eauto;
    erewrite IHl; eauto; lia.
  Qed.

  Lemma count_trues_upd_list_true:
  forall l_a l,
  (forall a, In a l_a -> seln l a false = false) ->
  Forall (fun a => a < length l) l_a ->
  NoDup l_a ->
  count_trues (repeated_apply (fun l a => updn l a true) l l_a) = length l_a + count_trues l.
  Proof.
    induction l_a; simpl; intros; try lia.
    inversion H0; clear H0; subst.
    inversion H1; clear H1; subst.
    erewrite count_trues_upd_true.
    rewrite IHl_a; eauto.
    erewrite seln_repeated_apply_updn; eauto.
    rewrite repeated_apply_length; intros; eauto.
    apply updn_length.
  Qed.

  Lemma count_trues_upd_list_false:
  forall l_a l,
  (forall a, In a l_a -> seln l a false = true) ->
  Forall (fun a => a < length l) l_a ->
  NoDup l_a ->
  length l_a + count_trues (repeated_apply (fun l a => updn l a false) l l_a)
  = count_trues l.
  Proof.
    induction l_a; simpl; intros; try lia.
    inversion H0; clear H0; subst.
    inversion H1; clear H1; subst.
    rewrite <- PeanoNat.Nat.add_succ_r.
    erewrite count_trues_upd_false.
    rewrite IHl_a; eauto.
    erewrite seln_repeated_apply_updn; eauto.
    rewrite repeated_apply_length; intros; eauto.
    apply updn_length.
  Qed.

  Lemma firstn_repeated_apply_comm:
  forall T l_a n (b: T) l,
  firstn n (repeated_apply (fun l a => updn l a b) l l_a) =
  repeated_apply (fun l a => updn l a b) (firstn n l) l_a.
  Proof.
    induction l_a; simpl; eauto.
    intros.
    rewrite updn_firstn_comm; eauto.
    rewrite IHl_a; eauto.
  Qed.
*)
Set Nested Proofs Allowed.
Lemma count_trues_up_to_count_somes_up_to_eq:
forall n bm s,
DiskAllocator.block_allocator_rep bm s ->
count_trues_up_to n (value_to_bits (s DiskAllocatorParams.bitmap_addr)) =
count_somes_up_to n bm.
Proof.
  induction n; simpl; intros; eauto.
  erewrite IHn; eauto.
  unfold DiskAllocator.block_allocator_rep in *; logic_clean.
  destruct (Compare_dec.lt_dec n DiskAllocatorParams.num_of_blocks).
  eapply DiskAllocator.valid_bits_extract in H0; eauto.
  all: try solve [setoid_rewrite H1; eauto; lia].
  cleanup.
  split_ors; cleanup; eauto.
  edestruct (H2 n); try lia.
  cleanup; eauto.
Qed.

(*
Lemma count_trues_ge_all_some:
forall l bm s,
DiskAllocator.block_allocator_rep bm s ->
Forall (fun a => bm a <> None) l ->
NoDup l ->
count_trues_up_to (s DiskAllocatorParams.bitmap_addr) >= length l.
Proof.
  induction l; simpl; intros.
  lia.
  inversion H0; inversion H1;
  clear H0 H1; cleanup.  eapply_fresh DiskAllocator.block_allocator_rep_delete with (a:= a) in H.
  assert (A: Forall (fun ax : addr => (Mem.delete bm a) ax <> None) l). {
    eapply Forall_forall; intros.
    destruct (PeanoNat.Nat.eq_dec a x); subst.
    tauto.
    rewrite delete_ne; eauto.
    eapply Forall_forall in H5; eauto.
  }
  specialize (IHl _ _ Hx A H9).
  clear Hx.
  unfold DiskAllocator.block_allocator_rep in *; cleanup.
  eapply DiskAllocator.valid_bits_extract with (n:= a) in H0; eauto.
  cleanup; split_ors; cleanup; try congruence.

  replace (firstn DiskAllocatorParams.num_of_blocks
  (value_to_bits (s DiskAllocatorParams.bitmap_addr))) with
  (updn (firstn DiskAllocatorParams.num_of_blocks
  (value_to_bits
     (upd s DiskAllocatorParams.bitmap_addr
        (bits_to_value
           (updn (value_to_bits (s DiskAllocatorParams.bitmap_addr))
              a false)) DiskAllocatorParams.bitmap_addr))) a true).

  erewrite count_trues_upd_true.
  lia.
  rewrite seln_firstn.
  rewrite upd_eq.
  rewrite bits_to_value_to_bits_exact.
  rewrite seln_updn_eq; eauto.
  rewrite value_to_bits_length.
  pose proof DiskAllocatorParams.num_of_blocks_in_bounds.
  destruct (Compare_dec.lt_dec a DiskAllocatorParams.num_of_blocks).
  unfold DiskAllocatorParams.num_of_blocks in *; lia.
  rewrite H2 in H3; try congruence; lia.
  rewrite updn_length, value_to_bits_length; eauto.
  eauto.
  destruct (Compare_dec.lt_dec a DiskAllocatorParams.num_of_blocks).
  unfold DiskAllocatorParams.num_of_blocks in *; lia.
  rewrite H2 in H3; try congruence; lia.
  pose proof DiskAllocatorParams.num_of_blocks_in_bounds.
  rewrite firstn_length_l.
  destruct (Compare_dec.lt_dec a DiskAllocatorParams.num_of_blocks).
  unfold DiskAllocatorParams.num_of_blocks in *; lia.
  rewrite H2 in H3; try congruence; lia.
  rewrite value_to_bits_length; unfold DiskAllocatorParams.num_of_blocks; eauto.
  destruct (Compare_dec.lt_dec a DiskAllocatorParams.num_of_blocks);
  [|rewrite H2 in H3; try congruence; lia].
  rewrite <- updn_firstn_comm.
  rewrite upd_eq.
  rewrite bits_to_value_to_bits_exact.

  rewrite updn_twice.
  erewrite seln_eq_updn_eq; eauto.
  rewrite updn_length, value_to_bits_length; eauto.
  eauto.
  destruct (Compare_dec.lt_dec a DiskAllocatorParams.num_of_blocks).
  unfold DiskAllocatorParams.num_of_blocks in *; lia.
  rewrite H2 in H4; try congruence; lia.
  pose proof DiskAllocatorParams.num_of_blocks_in_bounds.
  rewrite value_to_bits_length;
  rewrite H1; unfold DiskAllocatorParams.num_of_blocks; eauto.
Qed.
*)

Lemma file_map_rep_delete_file:
      forall fm im bm s f i inum,
      file_map_rep fm im bm ->
      Inode.inode_rep im s ->
      DiskAllocator.block_allocator_rep bm s ->
      fm inum = Some f ->
      im inum = Some i ->
      let bm' := (repeated_apply (Mem.delete (AEQ:=addr_dec)) bm (Inode.block_numbers i)) in
      let s' := (upd (upd s DiskAllocatorParams.bitmap_addr
                     (bits_to_value
                        (repeated_apply (fun l a => unset_bit a l)
                                        (value_to_bits (s DiskAllocatorParams.bitmap_addr)) (Inode.block_numbers i)))) Inode.InodeAllocatorParams.bitmap_addr
                (bits_to_value
                        (unset_bit inum (value_to_bits (s Inode.InodeAllocatorParams.bitmap_addr)))))  in

 file_map_rep (Mem.delete fm inum) (Mem.delete im inum) bm' /\
 Inode.inode_rep (Mem.delete im inum) s' /\
 DiskAllocator.block_allocator_rep bm' s'.
    Proof.
      unfold file_map_rep, file_rep,
    Inode.inode_rep, Inode.inode_map_rep,
    Inode.inode_map_valid, Inode.inode_valid in *;
      intros; cleanup.
      eapply_fresh H7 in H2; eauto; cleanup.
      eapply_fresh H5 in H3; cleanup.
      split.
      2: split.
      {(** file_map_rep **)
       intuition.
        {
            unfold addrs_match_exactly in *; intros.
            destruct (addr_dec inum a); subst.
            repeat rewrite Mem.delete_eq; eauto.
            split; intros; congruence.
            repeat rewrite Mem.delete_ne; eauto.
          }
          {
            destruct (addr_dec inum inum0); subst;
            [rewrite Mem.delete_eq in H14;
             rewrite Mem.delete_eq in H15; eauto |
             rewrite Mem.delete_ne in H14;
             rewrite Mem.delete_ne in H15; eauto];
            try congruence.
            eapply_fresh H7 in H14; eauto.
            unfold file_rep in *; cleanup; eauto.
          }
          {
            destruct (addr_dec inum inum0); subst;
            [rewrite Mem.delete_eq in H14;
             rewrite Mem.delete_eq in H15; eauto |
             rewrite Mem.delete_ne in H14;
             rewrite Mem.delete_ne in H15; eauto];
            try congruence.
            eapply_fresh H7 in H14; eauto.
            unfold file_rep in *; cleanup; eauto.
          }
          {
            destruct (addr_dec inum inum0); subst;
            [rewrite Mem.delete_eq in H14;
             rewrite Mem.delete_eq in H15; eauto |
             rewrite Mem.delete_ne in H14;
             rewrite Mem.delete_ne in H15; eauto];
            try congruence.
            {
              eapply_fresh H6 in H14; eauto.
              eapply_fresh H7 in H14; eauto.
              cleanup.
              eapply_fresh H19 in H16; eauto;
              cleanup.
              eexists; intuition eauto.
              eapply nth_error_In in H16.
              eapply not_In_NoDup_app in H16; eauto.
              rewrite repeated_apply_delete_not_in; eauto.
            }
          }
          {
            rewrite count_somes_up_to_some_repeated_delete; eauto.
            erewrite get_all_file_sizes_up_to_delete; eauto.
            unfold Inode.InodeAllocator.block_allocator_rep in *.
            cleanup.
            destruct (Compare_dec.lt_dec inum Inode.InodeAllocatorParams.num_of_blocks); eauto.
            edestruct (H16 inum).
            lia.

            rewrite H4, H0 in H3; simpl in *; congruence.
            eapply Forall_forall; intros.
            eapply_fresh in_seln_exists in H14; cleanup.
            edestruct H11.
            eapply nth_error_nth'; eauto.
            rewrite <- nth_seln_eq in H17; cleanup.
            rewrite H16 in H18; eexists; eauto.
          }
        }
      {(** inode_rep **)
        eexists; intuition eauto.
        rewrite upd_comm.
        eapply Inode.InodeAllocator.block_allocator_rep_upd_noop; eauto.
        eapply Inode.InodeAllocator.block_allocator_rep_delete; eauto.
        unfold DiskAllocatorParams.bitmap_addr,
        Inode.InodeAllocatorParams.bitmap_addr.
        pose proof FSParameters.inodes_before_data; lia.
        destruct (addr_dec inum i0); subst.
        repeat rewrite Mem.delete_eq; simpl; eauto.
        repeat rewrite Mem.delete_ne; simpl; eauto.

        destruct (addr_dec inum i0); subst.
        rewrite Mem.delete_eq in H14; simpl; congruence.
        rewrite Mem.delete_ne in H14; simpl; eauto.
        eapply H5 in H14; cleanup; eauto.

        destruct (addr_dec inum i0); subst.
        rewrite Mem.delete_eq in H14; simpl; congruence.
        rewrite Mem.delete_ne in H14; simpl; eauto.
        eapply H5 in H14; cleanup; eauto.

        destruct (addr_dec inum i0); subst.
        rewrite Mem.delete_eq in H15; simpl; congruence.
        rewrite Mem.delete_ne in H15; simpl; eauto.
        destruct (addr_dec inum j); subst.
        rewrite Mem.delete_eq in H16; simpl; congruence.
        rewrite Mem.delete_ne in H16; simpl; eauto.
      }
      {
       eapply DiskAllocator.block_allocator_rep_upd_noop; eauto.
       eapply DiskAllocator.block_allocator_rep_delete_list; eauto.
        unfold DiskAllocatorParams.bitmap_addr,
        Inode.InodeAllocatorParams.bitmap_addr.
        pose proof FSParameters.inodes_before_data; lia.
      }
      Unshelve.
      eauto.
Qed.

Lemma get_all_file_sizes_up_to_delete_oob:
forall n a fm,
a >= n ->
get_all_file_sizes_up_to (Mem.delete fm a) n =
get_all_file_sizes_up_to fm n.
Proof.
  induction n; simpl; intros; eauto;
  rewrite delete_ne; eauto.
  rewrite IHn; lia.
  lia.
Qed.

Lemma free_block_exists:
forall fm1 fm2 s1 s2 u' ex,
same_for_user_except u' ex fm1 fm2 ->
files_inner_rep fm1 s1 ->
files_inner_rep fm2 s2 ->
get_first_zero_index (value_to_bits (s1 DiskAllocatorParams.bitmap_addr)) < DiskAllocatorParams.num_of_blocks ->
get_first_zero_index (value_to_bits (s2 DiskAllocatorParams.bitmap_addr)) < DiskAllocatorParams.num_of_blocks.
Proof.
unfold files_inner_rep; intros; cleanup.
eapply get_first_zero_index_count_trues.
eapply get_first_zero_index_count_trues in H2.
erewrite count_trues_up_to_count_somes_up_to_eq; eauto.
erewrite count_trues_up_to_count_somes_up_to_eq in H2; only 2: eauto.
unfold file_map_rep in *; cleanup.
erewrite get_all_file_sizes_up_to_related_equal in H2; eauto.
Qed.

Lemma free_block_exists_iff:
forall fm1 fm2 s1 s2 u' ex,
same_for_user_except u' ex fm1 fm2 ->
files_inner_rep fm1 s1 ->
files_inner_rep fm2 s2 ->
get_first_zero_index (value_to_bits (s1 DiskAllocatorParams.bitmap_addr)) < DiskAllocatorParams.num_of_blocks <->
get_first_zero_index (value_to_bits (s2 DiskAllocatorParams.bitmap_addr)) <
  DiskAllocatorParams.num_of_blocks.
Proof.
  intros; split.
  eapply free_block_exists; eauto.
  eapply free_block_exists.
  apply same_for_user_except_symmetry; eauto.
  all: eauto.
Qed.

Lemma test_bit_same_count_trues_up_to_eq:
forall n bm1 bm2,
(forall i, i < n -> test_bit i bm1 = test_bit i bm2) ->
count_trues_up_to n bm1 = count_trues_up_to n bm2.
Proof.
  induction n; simpl; intros; eauto.
  erewrite H, IHn; simpl; eauto.
Qed.

Lemma addrs_match_exactly_sym:
  forall A AEQ V1 V2 (m1: @mem A AEQ V1) (m2: @mem A AEQ V2),
  addrs_match_exactly m1 m2 ->
  addrs_match_exactly m2 m1.
Proof.
  unfold addrs_match_exactly; intros; cleanup.
  specialize (H a).
  intuition eauto; try congruence.
Qed.

Lemma addrs_match_exactly_trans:
  forall A AEQ V1 V2 V3 (m1: @mem A AEQ V1) (m2: @mem A AEQ V2)
  (m3: @mem A AEQ V3),
  addrs_match_exactly m1 m2 ->
  addrs_match_exactly m2 m3 ->
  addrs_match_exactly m1 m3.
Proof.
  unfold addrs_match_exactly; intros; cleanup.
  specialize (H a).
  specialize (H0 a).
  intuition eauto; try congruence.
Qed.

Lemma addrs_match_exactly_missing_1:
  forall A AEQ V1 V2 (fm: @mem A AEQ V1) (im: @mem A AEQ V2) inum,
  addrs_match_exactly fm im ->
  im inum = None ->
  fm inum = None.
Proof.
  intros; cleanup.
  destruct_fresh (fm inum); eauto.
  edestruct H; exfalso.
  apply H1; eauto; congruence.
Qed.

Lemma addrs_match_exactly_exists_1:
  forall A AEQ V1 V2 (fm: @mem A AEQ V1) (im: @mem A AEQ V2) inum inode,
  addrs_match_exactly fm im ->
  im inum = Some inode ->
  exists f, fm inum = Some f.
Proof.
  intros; cleanup.
  destruct_fresh (fm inum); eauto.
  edestruct H; exfalso.
  apply H2; eauto; congruence.
Qed.

Lemma free_block_exists_inode:
forall fm1 fm2 s1 s2 u' ex,
same_for_user_except u' ex fm1 fm2 ->
files_inner_rep fm1 s1 ->
files_inner_rep fm2 s2 ->
get_first_zero_index
(value_to_bits
        (s1 Inode.InodeAllocatorParams.bitmap_addr)) <
        Inode.InodeAllocatorParams.num_of_blocks ->
(get_first_zero_index
(value_to_bits
            (s2 Inode.InodeAllocatorParams.bitmap_addr))) <
            Inode.InodeAllocatorParams.num_of_blocks.
Proof.
  intros.
  eapply get_first_zero_index_count_trues.
  eapply get_first_zero_index_count_trues in H2.
  erewrite test_bit_same_count_trues_up_to_eq in H2; eauto.
  intros.
  unfold same_for_user_except, files_inner_rep, file_map_rep  in *; cleanup.
  eapply inode_allocations_are_same; eauto.

  eapply addrs_match_exactly_trans; eauto.
  eapply addrs_match_exactly_trans; eauto.
  eapply addrs_match_exactly_sym; eauto.
  eapply addrs_match_exactly_sym; eauto.
Qed.

Lemma free_block_exists_iff_inode:
forall fm1 fm2 s1 s2 u' ex,
same_for_user_except u' ex fm1 fm2 ->
files_inner_rep fm1 s1 ->
files_inner_rep fm2 s2 ->
get_first_zero_index
  (value_to_bits
        (s1 Inode.InodeAllocatorParams.bitmap_addr)) <
        Inode.InodeAllocatorParams.num_of_blocks <->
(get_first_zero_index
      (value_to_bits
            (s2 Inode.InodeAllocatorParams.bitmap_addr))) <
            Inode.InodeAllocatorParams.num_of_blocks.
Proof.
  intros; split.
  eapply free_block_exists_inode; eauto.
  eapply free_block_exists_inode.
  apply same_for_user_except_symmetry; eauto.
  all: eauto.
Qed.


(** Coq coding by choukh, Sep 2021 **)

Require Import ZFC.LargeOrdinals.SidedTetration.
Export OrdinalClass 𝐎𝐍Separation VeblenFixedPoint.

Local Hint Resolve enum_operative ordAdd_ran ordMul_ran ordExp_ran : core.

(* 加法不动点 *)
Section OrdAddFixedPoint.
Variable ξ : set.
Variable ξ_is_ord : ξ ⋵ 𝐎𝐍.
Local Hint Resolve ξ_is_ord : core.

Definition σ₀ := sup {ξ ⋅ n | n ∊ ω}.

Remark σ₀_normal_form : σ₀ = ξ ⋅ ω.
Proof. symmetry. apply ordMul_limit; nauto. Qed.

Lemma σ₀_is_ord : σ₀ ⋵ 𝐎𝐍.
Proof. rewrite σ₀_normal_form; auto. Qed.
Local Hint Resolve σ₀_is_ord : core.

Lemma σ₀_is_limord : σ₀ ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with nauto.
  rewrite σ₀_normal_form.
  destruct (classic (ξ = 0)).
  - subst. rewrite ordMul_0_l... apply empty_is_limord.
  - apply ordMul_is_limord_r...
Qed.
Local Hint Resolve σ₀_is_limord : core.

Lemma σ₀_has_mul_n : ξ ≠ 0 → ∀n ∈ ω, ξ ⋅ n ∈ σ₀.
Proof with nauto.
  intros Hξ0 n Hn. apply (FUnionI _ _ n⁺)...
  apply ω_inductive... apply ordMul_normal...
Qed.

Lemma σ₀_has_those_of_mul_n : ξ ≠ 0 → ∀n ∈ ω, ∀α ∈ ξ ⋅ n, α ∈ σ₀.
Proof with eauto.
  intros Hξ0 n Hn α Hα. eapply ord_trans...
  apply σ₀_has_mul_n...
Qed.
Local Notation σ₀I := σ₀_has_those_of_mul_n.

Lemma σ₀_has_only_those_of_mul_n : ∀α ∈ σ₀, ∃n ∈ ω, α ∈ ξ ⋅ n.
Proof. intros α Hα. apply FUnionE in Hα; auto. Qed.
Local Notation σ₀E := σ₀_has_only_those_of_mul_n.

Fact σ₀_iff_of_mul_n : ξ ≠ 0 → ∀α ⋵ 𝐎𝐍, α ∈ σ₀ ↔ ∃n ∈ ω, α ∈ ξ ⋅ n.
Proof. split. apply σ₀E. intros [n [Hn Hα]]. apply (σ₀I H n); auto. Qed.

Lemma σ₀_neq_0 : ξ ≠ 0 → σ₀ ≠ 0.
Proof.
  intros Hξ0 H. rewrite σ₀_normal_form in H.
  apply ordMul_eq_0 in H as []; nauto.
Qed.
Local Hint Resolve σ₀_neq_0 : core.

Lemma σ₀_closed_under_add : ξ ≠ 0 → ∀α ∈ σ₀, ξ + α ∈ σ₀.
Proof with neauto.
  intros Hξ0 α Hα.
  assert (Hoα: α ⋵ 𝐎𝐍). apply (ord_is_ords σ₀)...
  apply σ₀E in Hα as [n [Hn Hα]].
  apply (σ₀I Hξ0 n⁺). apply ω_inductive...
  eapply ord_trans_lt_le. auto.
  apply ordAdd_preserve_lt; revgoals...
  rewrite ordMul_suc... right. apply ordAdd_arbitrary_assoc...
Qed.

Definition σ := FixedPoint (OrdAdd ξ).
Definition σ_number := fixed_point (OrdAdd ξ).

Lemma σ₀_is_σ_number : σ₀ ⋵ σ_number.
Proof with neauto.
  split...
  destruct (classic (ξ = 0)) as [|H0]. rewrite H, ordAdd_0_l...
  ext.
  - rewrite ordAdd_limit in H...
    apply FUnionE in H as [α [Hα Hx]]. eapply ord_trans...
    apply σ₀_closed_under_add...
  - rewrite ordAdd_limit... eapply FUnionI...
    apply σ₀E in H as [n [Hn Hx]].
    eapply ordAdd_enlarge_l_strictly...
Qed.

Lemma σ_number_has_mul_n : ξ ≠ 0 → ∀n ∈ ω, ∀σ ⋵ σ_number, ξ ⋅ n ∈ σ.
Proof with neauto.
  intros Hξ0 n Hn. ω_induction n; intros σ [Hσ Heq].
  - rewrite ordMul_0_r, <- Heq...
    apply ord_neq_0_gt_0...
    intros H. apply ordAdd_eq_0 in H as []...
  - rewrite ordMul_suc, <- Heq, <- ordAdd_arbitrary_assoc...
    apply ordAdd_preserve_lt... apply IH. split...
Qed.

Lemma σ₀_is_the_least_σ_number : ∀α ⋵ σ_number, σ₀ ⋸ α.
Proof with eauto.
  intros σ [Hσ Heq]. apply ord_le_iff_sub...
  intros x Hx. apply σ₀E in Hx as [n [Hn Hx]].
  destruct (classic (ξ = 0)).
  - subst. rewrite ordMul_0_l in Hx... exfalso0.
  - eapply ord_trans... apply σ_number_has_mul_n... split...
Qed.

Lemma σ_number_sub_𝐎𝐍 : σ_number ⫃ 𝐎𝐍.
Proof. intros α []; auto. Qed.
Local Hint Resolve σ_number_sub_𝐎𝐍 : core.

Lemma σ_number_unbounded : unbounded σ_number.
Proof. apply fixed_point_class_unbounded, ordAdd_normal; nauto. Qed.
Local Hint Resolve σ_number_unbounded : core.

Lemma σ_spec : ∀α ⋵ 𝐎𝐍, ∀β ⋵ σ_number, β ∉ {σ x | x ∊ α} → σ α ⋸ β.
Proof. intros α Hα β Hβ. apply enum_spec; auto. Qed.

Lemma σ_is_σ_number : σ :ᶜ 𝐎𝐍 ⇒ σ_number.
Proof. apply enum_into_class; auto. Qed.
Local Hint Resolve σ_is_σ_number : core.

Lemma σ_operative : σ :ᶜ 𝐎𝐍 ⇒ 𝐎𝐍.
Proof. intros. apply enum_operative; auto. Qed.
Local Hint Resolve σ_operative : core.

Theorem σ_0 : σ 0 = σ₀.
Proof with auto.
  ord_ext...
  - apply σ_spec... apply σ₀_is_σ_number.
    intros H. apply ReplAx in H as [x [Hx _]]. exfalso0.
  - apply σ₀_is_the_least_σ_number...
Qed.

Theorem σ_monotone : monotone σ.
Proof. apply enum_monotone; auto. Qed.

Theorem σ_injective : class_injective σ 𝐎𝐍.
Proof. apply enum_injective; auto. Qed.

Theorem σ_surjective : class_surjective σ 𝐎𝐍 σ_number.
Proof. apply enum_surjective; auto. Qed.

Theorem σ_iff_σ_number :
  ∀ ξ, ξ ⋵ σ_number ↔ ∃ α, α ⋵ 𝐎𝐍 ∧ σ α = ξ.
Proof. apply enum_iff_class; auto. Qed.

Theorem σ_normal : normal σ.
Proof. apply fixedPoint_normal, ordAdd_normal; nauto. Qed.

Theorem σ_limit : continuous σ.
Proof. apply σ_normal. Qed.

Theorem σ_closed : closed σ_number.
Proof with auto.
  eapply normal_operation_range_closed...
  apply enum_onto_class... apply σ_normal.
Qed.

Lemma sigma : ∀α ⋵ 𝐎𝐍, ξ + σ α = σ α.
Proof. apply fixedPoint, ordAdd_normal; nauto. Qed.

Theorem σ_suc : ∀α ⋵ 𝐎𝐍, σ α⁺ = (σ α)⁺.
Proof with neauto.
  intros α Hα. ord_ext...
  - apply σ_spec...
    + split... rewrite <- ordAdd_1_r, <- ordAdd_assoc, sigma...
    + intros H. apply ReplAx in H as [x [Hx H]].
      assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords α⁺)...
      apply ord_le_iff_lt_suc in Hx as []...
      * apply σ_normal in H0... rewrite H in H0.
        apply ord_le_iff_not_gt in H0...
      * subst. apply (ord_irrefl (σ α))... rewrite H at 2...
  - apply ord_le_iff_sub... intros x Hx.
    assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords (σ α)⁺)...
    apply ord_le_iff_lt_suc in Hx as []...
    + eapply ord_trans... apply σ_normal...
    + subst. apply σ_normal...
Qed.

Theorem σ_normal_form : ∀α ⋵ 𝐎𝐍, σ α = ξ ⋅ ω + α.
Proof with eauto.
  ord_induction. intros α Hα IH.
  ord_destruct α.
  - subst. rewrite σ_0, σ₀_normal_form, ordAdd_0_r...
  - destruct Hsuc as [β [Hβ H]]. subst.
    rewrite σ_suc, ordAdd_suc... f_equal...
  - rewrite σ_limit, ordAdd_limit... ext.
    + apply FUnionE in H as [β [Hβ H]].
      eapply FUnionI... rewrite <- IH...
    + apply FUnionE in H as [β [Hβ H]].
      eapply FUnionI... rewrite IH...
Qed.

(* σ数同时也是满足β < σ₀的所有β-加的不动点 *)
Theorem σ_for_all_smaller_add : ξ ≠ 0 → ∀α ⋵ 𝐎𝐍, ∀β ∈ σ 0, β + σ α = σ α.
Proof with neauto.
  intros Hξ α Hα β Hβ.
  assert (Hoβ: β ⋵ 𝐎𝐍). apply (ord_is_ords (σ 0))...
  rewrite σ_0 in Hβ. apply FUnionE in Hβ as [n [Hn Hβ]].
  rewrite σ_normal_form... ord_ext...
  - eapply ord_trans_le. auto.
    apply ordAdd_preserve_le_l; revgoals. left... 1-3: auto.
    rewrite <- ordAdd_assoc, <- ordMul_distr...
    rewrite (ordAdd_n_absorption ω)...
  - apply ordAdd_enlarge_l...
Qed.

End OrdAddFixedPoint.

(* 乘法不动点 *)
Section OrdMulFixedPoint.
Variable ξ : set.
Variable ξ_is_ord : ξ ⋵ 𝐎𝐍.
Variable ξ_neq_0 : ξ ≠ 0.
Local Hint Resolve ξ_is_ord : core.
Local Hint Resolve ξ_neq_0 : core.

Definition μ₀ := 0.
Definition μ₁ := sup {ξ ^ n | n ∊ ω}.

Remark μ₁_normal_form : μ₁ = ξ ^ ω.
Proof. symmetry. apply ordExp_limit; nauto. Qed.

Lemma μ₁_is_ord : μ₁ ⋵ 𝐎𝐍.
Proof. rewrite μ₁_normal_form; auto. Qed.
Local Hint Resolve μ₁_is_ord : core.

Lemma μ₁_is_limord : ξ ≠ 1 → μ₁ ⋵ 𝐎𝐍ˡⁱᵐ.
Proof with nauto.
  intros Hξ1. rewrite μ₁_normal_form.
  apply ordExp_is_limord_r...
Qed.
Local Hint Resolve μ₁_is_limord : core.

Lemma μ₁_has_exp_n : ξ ≠ 1 → ∀n ∈ ω, ξ ^ n ∈ μ₁.
Proof with nauto.
  intros Hξ1 n Hn. apply (FUnionI _ _ n⁺)...
  apply ω_inductive... apply ordExp_normal...
Qed.

Lemma μ₁_has_those_of_exp_n : ξ ≠ 1 → ∀n ∈ ω, ∀α ∈ ξ ^ n, α ∈ μ₁.
Proof with eauto.
  intros Hξ1 n Hn α Hα. eapply ord_trans...
  apply μ₁_has_exp_n...
Qed.
Local Notation μ₁I := μ₁_has_those_of_exp_n.

Lemma μ₁_has_only_those_of_exp_n : ∀α ∈ μ₁, ∃n ∈ ω, α ∈ ξ ^ n.
Proof. intros α Hα. apply FUnionE in Hα; auto. Qed.
Local Notation μ₁E := μ₁_has_only_those_of_exp_n.

Fact μ₁_iff_of_exp_n : ξ ≠ 1 → ∀α ⋵ 𝐎𝐍, α ∈ μ₁ ↔ ∃n ∈ ω, α ∈ ξ ^ n.
Proof. split. apply μ₁E. intros [n [Hn Hα]]. apply (μ₁I H n); auto. Qed.

Lemma μ₁_neq_0 : μ₁ ≠ 0.
Proof.
  intros H. rewrite μ₁_normal_form in H.
  apply ordExp_eq_0 in H; nauto.
Qed.
Local Hint Resolve μ₁_neq_0 : core.

Lemma μ₁_closed_under_mul : ξ ≠ 1 → ∀α ∈ μ₁, ξ ⋅ α ∈ μ₁.
Proof with neauto.
  intros Hξ1 α Hα.
  assert (Hoα: α ⋵ 𝐎𝐍). apply (ord_is_ords μ₁)...
  apply μ₁E in Hα as [n [Hn Hα]].
  apply (μ₁I Hξ1 n⁺). apply ω_inductive...
  eapply ord_trans_lt_le. auto.
  apply ordMul_preserve_lt; revgoals...
  rewrite ordExp_suc... right. apply ordMul_arbitrary_assoc...
Qed.

Definition μ := FixedPoint (OrdMul ξ).
Definition μ_number := fixed_point (OrdMul ξ).

Lemma μ₁_is_μ_number : μ₁ ⋵ μ_number.
Proof with neauto.
  split...
  destruct (classic (ξ = 1)) as [|H1]. rewrite H, ordMul_1_l...
  ext.
  - rewrite ordMul_limit in H...
    apply FUnionE in H as [α [Hα Hx]]. eapply ord_trans...
    apply μ₁_closed_under_mul...
  - destruct (classic (x = 0)).
    + subst. apply ord_neq_0_gt_0...
      intros H0. apply ordMul_eq_0 in H0 as []...
    + rewrite ordMul_limit... eapply FUnionI...
      apply μ₁E in H as [n [Hn Hx]].
      eapply ordMul_enlarge_l_strictly...
Qed.

Lemma μ_number_has_exp_n : ξ ≠ 1 →
  ∀n ∈ ω, ∀μ ⋵ μ_number, μ ≠ μ₀ → ξ ^ n ∈ μ.
Proof with neauto.
  intros Hξ1 n Hn. ω_induction n; intros μ [Hμ Heq] Hμ0.
  - rewrite ordExp_0_r, <- Heq...
    apply ord_neq_0_1_gt_1...
    + intros H. apply ordMul_eq_0 in H as []...
    + intros H1. assert (Hμ1: μ = 1). congruence.
      rewrite Hμ1 in Heq. rewrite ordMul_1_r in Heq...
  - rewrite ordExp_suc, <- Heq, <- ordMul_arbitrary_assoc...
    apply ordMul_preserve_lt... apply IH... split...
Qed.

Lemma μ₁_is_the_least_nonzero_μ_number : ∀α ⋵ μ_number, α ≠ μ₀ → μ₁ ⋸ α.
Proof with eauto.
  intros μ [Hμ Heq] Hμ0. apply ord_le_iff_sub...
  intros x Hx. apply μ₁E in Hx as [n [Hn Hx]].
  destruct (classic (ξ = 1)).
  - subst. rewrite ordExp_1_l in Hx...
    rewrite one in Hx. apply SingE in Hx. subst...
  - eapply ord_trans... apply μ_number_has_exp_n... split...
Qed.

Lemma μ_number_sub_𝐎𝐍 : μ_number ⫃ 𝐎𝐍.
Proof. intros α []; auto. Qed.
Local Hint Resolve μ_number_sub_𝐎𝐍 : core.

Lemma μ_number_unbounded : unbounded μ_number.
Proof. apply fixed_point_class_unbounded, ordMul_normal; nauto. Qed.
Local Hint Resolve μ_number_unbounded : core.

Lemma μ_spec : ∀α ⋵ 𝐎𝐍, ∀β ⋵ μ_number, β ∉ {μ x | x ∊ α} → μ α ⋸ β.
Proof. intros α Hα β Hβ. apply enum_spec; auto. Qed.

Lemma μ_is_μ_number : μ :ᶜ 𝐎𝐍 ⇒ μ_number.
Proof. apply enum_into_class; auto. Qed.
Local Hint Resolve μ_is_μ_number : core.

Lemma μ_operative : μ :ᶜ 𝐎𝐍 ⇒ 𝐎𝐍.
Proof. intros. apply enum_operative; auto. Qed.
Local Hint Resolve μ_operative : core.

Theorem μ_0 : μ 0 = μ₀.
Proof with auto.
  ord_ext...
  apply μ_spec... split... rewrite ordMul_0_r...
  intros H. apply ReplAx in H as [x [Hx _]]. exfalso0.
Qed.

Theorem μ_injective : class_injective μ 𝐎𝐍.
Proof. apply enum_injective; auto. Qed.

Theorem μ_1 : μ 1 = μ₁.
Proof with nauto.
  ord_ext...
  - apply μ_spec... apply μ₁_is_μ_number.
    intros H. apply ReplAx in H as [x [Hx H]].
    rewrite one in Hx. apply SingE in Hx. subst.
    rewrite <- zero, μ_0 in H...
  - apply μ₁_is_the_least_nonzero_μ_number...
    intros H. rewrite <- μ_0 in H.
    apply μ_injective in H...
Qed.

Theorem μ_monotone : monotone μ.
Proof. apply enum_monotone; auto. Qed.

Theorem μ_surjective : class_surjective μ 𝐎𝐍 μ_number.
Proof. apply enum_surjective; auto. Qed.

Theorem μ_iff_μ_number :
  ∀ ξ, ξ ⋵ μ_number ↔ ∃ α, α ⋵ 𝐎𝐍 ∧ μ α = ξ.
Proof. apply enum_iff_class; auto. Qed.

Theorem μ_normal : normal μ.
Proof. apply fixedPoint_normal, ordMul_normal; nauto. Qed.

Theorem μ_limit : continuous μ.
Proof. apply μ_normal. Qed.

Theorem μ_closed : closed μ_number.
Proof with auto.
  eapply normal_operation_range_closed...
  apply enum_onto_class... apply μ_normal.
Qed.

Lemma mu : ∀α ⋵ 𝐎𝐍, ξ ⋅ μ α = μ α.
Proof. apply fixedPoint, ordMul_normal; nauto. Qed.

Lemma μ_is_limord : ξ ≠ 1 → μ :ᶜ 𝐎𝐍 ⇒ 𝐎𝐍ˡⁱᵐ.
Proof with neauto.
  intros Hξ1 α Hα. apply fixed_point_is_limord...
  apply ordMul_normal... intros β Hβ Heq.
  replace (FixedPoint (OrdMul ξ)) with μ in Heq...
  pose proof (mu β⁺ (ord_suc_is_ord β Hβ)).
  rewrite Heq, ordMul_suc, mu, <- ordAdd_1_r in H...
  apply ordAdd_cancel in H...
Qed.
Local Hint Resolve μ_is_limord : core.

Lemma μ_neq_0 : ∀α ⋵ 𝐎𝐍, α ≠ 0 → μ α ≠ 0 .
Proof with nauto.
  intros α Hα Hα0. apply EmptyNI.
  destruct (classic (α = 1)).
  - subst. rewrite μ_1. exists 0.
    apply (FUnionI _ _ 0)... rewrite ordExp_0_r...
  - exists (μ 1). apply μ_normal...
Qed.
Local Hint Resolve μ_neq_0 : core.

Lemma mu_add : ξ ≠ 1 → ∀α ⋵ 𝐎𝐍, α ≠ 0 → ξ + μ α = μ α.
Proof with nauto.
  intros Hξ1 α Hα Hα0. rewrite <- mu...
  rewrite <- (ordMul_1_r ξ) at 1...
  rewrite <- ordMul_distr... f_equal.
  apply ordAdd_1_absorption... apply limord_ge_ω...
Qed.

Theorem μ_suc_trivial : ξ = 1 → ∀α ⋵ 𝐎𝐍, μ α⁺ = (μ α)⁺.
Proof with neauto.
  intros Hξ1 α Hα. ord_ext...
  - apply μ_spec...
    + split... rewrite Hξ1, ordMul_1_l...
    + intros H. apply ReplAx in H as [x [Hx H]].
      assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords α⁺)...
      apply ord_le_iff_lt_suc in Hx as []...
      * apply μ_normal in H0... rewrite H in H0.
        apply ord_le_iff_not_gt in H0...
      * subst. apply (ord_irrefl (μ α))... rewrite H at 2...
  - apply ord_le_iff_sub... intros x Hx.
    assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords (μ α)⁺)...
    apply ord_le_iff_lt_suc in Hx as []...
    + eapply ord_trans... apply μ_normal...
    + subst. apply μ_normal...
Qed.

Theorem μ_suc : ξ ≠ 1 → ∀α ⋵ 𝐎𝐍, α ≠ 0 → μ α⁺ = μ α + μ 1.
Proof with neauto.
  intros Hξ1 α Hα Hα0.
  ord_ext...
  - apply μ_spec...
    + split... rewrite ordMul_distr, mu, mu...
    + intros H. apply ReplAx in H as [x [Hx H]].
      assert (Hox: x ⋵ 𝐎𝐍). apply (ord_is_ords α⁺)...
      apply ord_le_iff_lt_suc in Hx as []...
      * apply μ_normal in H0... rewrite H in H0.
        apply ord_le_iff_not_gt in H0...
        left. apply ordAdd_enlarge_r...
      * subst. apply (ord_irrefl (μ α))... rewrite H at 2...
        apply ordAdd_enlarge_r...
  - apply ord_le_iff_sub... intros x Hx.
    rewrite ordAdd_limit, μ_1 in Hx...
    apply FUnionE in Hx as [β [Hβ Hx]].
    apply FUnionE in Hβ as [n [Hn Hβ]].
    eapply ord_trans... eapply ord_trans. auto.
    apply ordAdd_preserve_lt; revgoals...
    eapply (ord_is_ords (ξ ^ n))... clear Hβ Hx x.
    ω_induction n.
    + rewrite ordExp_0_r, ordAdd_1_r...
      apply sucord_in_limord... apply μ_normal...
    + rewrite ordExp_suc, <- mu, <- (mu α⁺)...
      rewrite <- ordMul_arbitrary_assoc, <- ordMul_distr...
      apply ordMul_preserve_lt...
Qed.

Theorem μ_normal_form_trivial : ξ = 1 → ∀α ⋵ 𝐎𝐍, μ α = α.
Proof with eauto.
  intros Hξ1. ord_induction. intros α Hα IH.
  ord_destruct α.
  - subst. rewrite μ_0...
  - destruct Hsuc as [β [Hβ H]]. subst.
    rewrite μ_suc_trivial... f_equal...
  - rewrite μ_limit... ext.
    + apply FUnionE in H as [β [Hβ H]].
      eapply ord_trans... rewrite IH...
    + eapply FUnionI. apply sucord_in_limord...
      rewrite IH... apply sucord_in_limord...
Qed.

Theorem μ_normal_form : ξ ≠ 1 → ∀α ⋵ 𝐎𝐍, α ≠ 0 → μ α = ξ ^ ω ⋅ α.
Proof with eauto.
  intros Hξ1. ord_induction. intros α Hα IH Hα0.
  ord_destruct α.
  - subst. rewrite μ_0, ordMul_0_r...
  - destruct Hsuc as [β [Hβ H]]. subst.
    destruct (classic (β = 0)).
    + subst. replace 0⁺ with (Embed 1)...
      rewrite μ_1, ordMul_1_r, μ₁_normal_form...
    + rewrite μ_suc, ordMul_suc, μ_1, μ₁_normal_form, IH...
  - rewrite μ_limit, ordMul_limit... ext.
    + apply FUnionE in H as [β [Hβ H]].
      destruct (classic (β = 0)).
      * subst. rewrite μ_0 in H. exfalso0.
      * eapply FUnionI... rewrite <- IH...
    + apply FUnionE in H as [β [Hβ H]].
      destruct (classic (β = 0)).
      * subst. rewrite ordMul_0_r in H... exfalso0.
      * eapply FUnionI... rewrite IH...
Qed.

(* μ数同时也是满足0 < β < μ₁的所有β-乘的不动点 *)
Theorem μ_for_all_smaller_mul : ξ ≠ 1 → ∀α ⋵ 𝐎𝐍, ∀β ∈ μ 1, β ≠ 0 → β ⋅ μ α = μ α.
Proof with neauto.
  intros Hξ α Hα β Hβ Hβ0.
  assert (Hoβ: β ⋵ 𝐎𝐍). apply (ord_is_ords (μ 1))...
  rewrite μ_1 in Hβ. apply FUnionE in Hβ as [n [Hn Hβ]].
  destruct (classic (α = 0)). subst. rewrite μ_0, ordMul_0_r...
  rewrite μ_normal_form... ord_ext...
  - eapply ord_trans_le. auto.
    apply ordMul_preserve_le_l; revgoals. left... 1-3: auto.
    rewrite <- ordMul_assoc, ordExp_add...
    rewrite (ordAdd_n_absorption ω)...
  - apply ordMul_enlarge_l... apply ord_suc_correct...
Qed.

End OrdMulFixedPoint.


Require Import Coq.Lists.List.
Require Import Io.All.
Require Import Io.System.All.
Require Import ListString.All.

Import ListNotations.
Import C.Notations.
Require Import String.

Fixpoint dec (n : nat) (line : LString.t) : LString.t :=
  match (n, LString.to_string line) with
    | (O, str)    => LString.s str
    | (S n', str) =>
      dec n' (LString.s ((fix dec' line :=
                             match line with
                               | String " " s              => String " " (dec' s)
                               | String "#" (String "#" s) => String "#" s
                               | s                         => s
                             end) str))
  end.

Fixpoint inc (n:nat) (line : LString.t) : LString.t :=
  match (n, LString.to_string line) with
    | (O, str)    => LString.s str
    | (S n', str) =>
      inc n' (LString.s ((fix inc' st :=
                            match st with
                              | String " " s => String " " (inc' s)
                              | String "#" s => String "#" (String "#" s)
                              | s            => s
                            end) str))
  end.

Import Ascii.
Definition new_line : Ascii.ascii := "010".

Definition map_line f (code : LString.t) : LString.t :=
  (LString.join (LString.s (String new_line ""))) (map f (LString.split code new_line)).

Definition is_minus (num : LString.t) : bool :=
  match LString.to_string num with
    | String "-" _ => true
    | _            => false
  end.

Definition lstr2nat (num : LString.t) : option nat :=
  let abs_num := match LString.to_string num with
                  | String "-" n => LString.s n
                  | n            => LString.s n
                end in
  match (LString.to_N 10 abs_num) with
    | Some n => Some (BinNat.N.to_nat n)
    | None   => None
  end.

Definition shift (argv : list LString.t) : C.t System.effect unit :=
  match argv with
  | [_; num; file_name] =>
    let! content := System.read_file file_name in
    match content with
    | None         => System.log (LString.s "Cannot read the file.")
    | Some content =>
      let shifter := if is_minus num then dec else inc in
      match lstr2nat num with
        | Some n => System.log (map_line (shifter n) content)
        | None   => System.log (LString.s "Wrong number spec.")
      end
    end
  | _                   => System.log (LString.s "Exact 2 parameters expected.")
  end.

(* Definition foo (arg : ascii) (s:string) : bool := *)
(*   match s with *)
(*     | String arg  _ => true *)
(*     | String c s => false *)
(*     | _   => false *)
(*   end. *)
(* Compute foo "b" "a b". *)

Fixpoint replace (str : string) : string :=
  match str with
    | String "-" s => String " " (replace s)
    | String c   s => String c   (replace s)
    | EmptyString  => EmptyString
  end.

Definition drop_dir (path : string) : string :=
  (fix drop path file :=  match path with
                           | String "/" s => drop s s
                           | String c   s => drop s file
                           | EmptyString  => file
                         end) path path.

Fixpoint combi (argv : list LString.t) : C.t System.effect unit :=
  match argv with
    | cons _ file_names =>
      (fix combi' file_names' :=
         match file_names' with
           | nil             => ret tt
           | cons name names =>
             let! content := System.read_file name in
             let! _ := match content with
                        | None         =>
                          System.log (LString.s "Cannot read the file.")
                        | Some content =>
                          let name' := drop_dir (replace (LString.to_string name)) in
                          let title := substring 0 ((length name')-3) name' in
                          let! _ := System.log (LString.s "# " ++ LString.s title) in
                          System.log (map_line (inc 1) content)
                      end in
             combi' names
         end) file_names
    | _                  => System.log (LString.s "Only 1 parameter expected.")
  end.

Definition main := Extraction.launch combi.
Extraction "./extraction/main" main.


(* Type constructors are split into several groups depending on how
   many arguments need to be applied for the overall type to be
   well formed. We keep primitive types like Read, Write and Ref fully
   applied to make the mechanisation easier. In the full language the
   ability to partially apply these could be recovered using
   type synonyms. *)
Require Export Iron.SystemF2Closure.Kind.

(********************************************************************)
(* Type Constructors. *)
Inductive tycon0 : Type :=
  | TyConFun    : tycon0
  | TyConUnit   : tycon0
  | TyConBool   : tycon0
  | TyConNat    : tycon0.
Hint Constructors tycon0.

Fixpoint kindOfTyCon0 (tc : tycon0) :=
  match tc with
  | TyConFun      => KFun KData (KFun KData KData)
  | TyConUnit     => KData
  | TyConBool     => KData
  | TyConNat      => KData
  end.

Fixpoint tycon0_beq tc1 tc2 :=
  match tc1, tc2 with
  | TyConFun,       TyConFun    => true
  | TyConUnit,      TyConUnit   => true
  | TyConBool,      TyConBool   => true
  | TyConNat,       TyConNat    => true
  | _,              _           => false
  end.

(********************************************************************)
(* Type constructors with at least one applied argument. *)
Inductive tycon1 : Type :=
  | TyConRead   : tycon1
  | TyConWrite  : tycon1
  | TyConAlloc  : tycon1
  | TyConUse    : tycon1.

Fixpoint kindOfTyCon1 (tc : tycon1) :=
  match tc with
  | TyConRead     => KFun KRegion KEffect
  | TyConWrite    => KFun KRegion KEffect
  | TyConAlloc    => KFun KRegion KEffect
  | TyConUse      => KFun KRegion KClosure
  end.

Fixpoint tycon1_beq tc1 tc2 :=
  match tc1, tc2 with
  | TyConRead,   TyConRead   => true
  | TyConWrite,  TyConWrite  => true
  | TyConAlloc,  TyConAlloc  => true
  | TyConUse,    TyConUse    => true
  | _,           _           => false
  end.

Definition isEffectTyCon (tc : tycon1) : bool :=
  match tc with
  | TyConRead              => true
  | TyConWrite             => true
  | TyConAlloc             => true
  | TyConUse               => true
  end.

(********************************************************************)
(* Type constructors with at least two applied arguments. *)
Inductive tycon2 : Type :=
  | TyConRef    : tycon2.
Hint Constructors tycon2.

Fixpoint kindOfTyCon2 (tc : tycon2) :=
  match tc with
  | TyConRef      => KFun KRegion (KFun KData KData)
  end.

Fixpoint tycon2_beq tc1 tc2 :=
  match tc1, tc2 with
  | TyConRef,       TyConRef       => true
  end.

(********************************************************************)
(* Type constructors with at least three applied arguments. *)
Inductive tycon3 : Type :=
  | TyConComp    : tycon3.
Hint Constructors tycon3.

Fixpoint kindOfTyCon3 (tc : tycon3) :=
  match tc with
  | TyConComp    => KFun KData (KFun KEffect (KFun KClosure KData))
  end.

Fixpoint tycon3_beq tc1 tc2 :=
  match tc1, tc2 with
  | TyConComp,      TyConComp     => true
  end.