Require Import List.
Import ListNotations.
Require Import Logic.FunctionalExtensionality.

Module ProgramAlgebra.

(* PRIMARY *)
(** it's unnecessary to give the exact definition *)
Class UserParams : Type := {
  Var : Set;
  GLOBVARS : list Var;
  eqb: Var -> Var -> bool;
}.
Section Assign.
Context {UserVar : UserParams}.
Definition Exp := (list Var) -> (list Var).

Record Assign := makeAssign {
  ids : (list Var);
  values : Exp;
}.
Definition refl : Exp := (fun x => x).

Definition empty_assn : Assign :=
  makeAssign GLOBVARS refl.
End Assign.

(** Boolexp is the type of boolean condition *)

Section Bool.
  Context {UserVar : UserParams}.
  Definition Boolexp : Type := (list Var) -> bool.
  Definition true_stat : Boolexp := (fun x => true).
  Definition false_stat : Boolexp := (fun x => false).
End Bool.

(* FINITE ALGEBRA *)
Section ualg.
  Context {UserVar : UserParams}.
  Variable syn : Type.
  Inductive Alg : Type :=
  | Chaos : Alg
  | Assn : Assign -> Alg
  | Cond : Alg -> Boolexp -> Alg -> Alg
  | Seq : Alg -> Alg -> Alg
  | Choice : Alg -> Alg -> Alg
  | Recur : (syn -> Alg) -> Alg.
End ualg.

Section Fact.
Context {UserVar : UserParams}.

Definition Ualg := forall syn, Alg syn.

(** Notation of Alg *)
Notation "var :== exp" := (makeAssign var exp)(at level 51).

Notation "@{ e }" := (fun x => Assn x e)(at level 10).

Notation "_|_" := (fun x => Chaos x)(at level 10).

Definition empty_program : Ualg := @{ empty_assn }.

Fixpoint Choice_of_Alg_List {syn} (l : list (Alg syn))  : Alg syn :=
  match l with
  | [] => (empty_program syn)
  | x :: xs => (Choice syn x (Choice_of_Alg_List xs))
  end.

Notation "|-| l" := (Choice_of_Alg_List l)(at level 20).

(* LAW *)
(** Law A.1 *)
(** Law A.1.1 *)
Axiom Chaos_zero_Choice_l : forall syn (p : Alg syn), (Choice syn (_|_ syn) p) = _|_ syn.
Axiom Chaos_zero_Seq_l : forall syn (p : Alg syn), (Seq syn (_|_ syn) p) = _|_ syn.
Axiom Chaos_zero_Seq_r : forall syn (p : Alg syn), (Seq syn p (_|_ syn)) = _|_ syn.

(** Law A.1.2 *)
Axiom Choice_comm : forall x (p q : Alg x), (Choice x p q) = (Choice x q p).
Theorem Chaos_zero_Choice_r : forall syn (p : Alg syn), (Choice syn p (_|_ syn)) = _|_ syn.
Proof. intros. simpl. rewrite Choice_comm. apply Chaos_zero_Choice_l. Qed.
Axiom Choice_assoc : forall syn (p q r : Alg syn), (Choice syn (Choice syn p q) r) = (Choice syn p (Choice syn q r)).
Axiom Choice_id : forall syn (p : Alg syn), (Choice syn p p) = p.
Axiom Choice_zero_l : forall syn (p : Alg syn),
  Choice syn (empty_program syn) p = p.
Theorem Choice_zero_r : forall syn (p : Alg syn),
  Choice syn p (empty_program syn) = p.
Proof. intros. simpl. rewrite Choice_comm. apply Choice_zero_l. Qed.

(** Law A.1.3 *)
Axiom Cond_rev : forall x (p q : Alg x) (b : Boolexp),
  (Cond x p  b q)  = (Cond x q (fun g => negb (b g)) p).

(** Law A.1.4 *)
Axiom Seq_assoc : forall syn (p q r : Alg syn),
  (Seq syn (Seq syn p q) r) = (Seq syn p (Seq syn q r)).

(** Law A.2 *)
(** Law A.2.1 *)
Fixpoint lookup_help (a: Var) (vs rs: (list Var)) : Var :=
  match vs, rs with
  | _, [] => a
  | [], _ => a
  | v::vl, r::rl => if (eqb a v) then r else lookup_help a vl rl
  end.
Fixpoint extends_mapping_help (us rs k : (list Var)) : (list Var) :=
  match k with
  | [] => []
  | v::vl => lookup_help v us rs :: extends_mapping_help us rs vl
  end.
Definition extends_mapping (us : (list Var)) (m : (list Var) -> (list Var)) :=
 fun k => (extends_mapping_help us (m us) k).
Definition extends_assign (v : Assign) :=
   makeAssign
     GLOBVARS
     (extends_mapping v.(ids) v.(values)).
Axiom Assign_extends : forall (v : Assign),
 v = extends_assign v.

(** Law A.2.2 *)
Axiom Assign_compose : forall syn (v : (list Var)) (g h : Exp),
  Seq syn (@{v :== g} syn) (@{v :== h} syn) = (@{v :== (fun x => h (g x))} syn).

(** Law A.2.3 *)
Definition exp_Cond (g h : Exp) b : Exp :=
 fun x =>
   match (b x) with
   | true => g x
   | false => h x
   end.

Axiom Assign_Cond : forall syn (v : (list Var)) (g h : Exp) (b : Boolexp) ,
  Cond syn (@{v :== g} syn) b (@{v :== h} syn) = (@{ v :== exp_Cond g h b } syn).

(** Law A.2.4 *)
Axiom Assign_to_NF : forall (v : (list Var)) (e : Exp) b syn,
  b GLOBVARS = false ->
  @{v :== e} syn = (Cond syn (_|_ syn) b (|-| [@{extends_assign (v :== e)} syn])).

(** Law A.2.5 *)
Axiom Chaos_to_NF : forall syn b p, b GLOBVARS = true -> (_|_) syn = (Cond syn (_|_ syn) b (|-| p)).

(** TH1 *)

Definition Total_Assign (a : Assign) := a.(ids) = GLOBVARS.
Theorem Assign_is_Total : forall a : Assign, exists b : Assign, a=b /\ Total_Assign b.
Proof.
  intros. exists (extends_assign a). split.
  - apply Assign_extends.
  - unfold Total_Assign. unfold extends_assign. auto.
Qed.

Theorem Assign_elim_Seq : forall syn (a b: Assign),
     exists (c: Assign), Seq syn (@{a} syn) (@{b} syn) = (@{c} syn) /\ Total_Assign c.
Proof. intros. rewrite (Assign_extends a). rewrite (Assign_extends b).
    unfold extends_assign. rewrite Assign_compose. eexists;split;eauto.
    unfold Total_Assign. auto. Qed.

Theorem Assign_elim_Cond : forall syn (a b: Assign) (d : Boolexp),
     exists (c: Assign), Cond syn (@{a} syn) d (@{b} syn) = (@{c} syn) /\ Total_Assign c.
Proof. intros. rewrite (Assign_extends a). rewrite (Assign_extends b).
    unfold extends_assign. rewrite Assign_Cond. eexists;split;eauto.
    unfold Total_Assign. auto.  Qed.

(** Law A.3 *)
Definition CH {syn} (p : list (Alg syn)): Prop :=
  forall (x : Alg syn), In x p -> exists y, x = (@{y} syn) /\ Total_Assign y.

(** Law A.3.1 *)
Axiom Choice_distr : forall syn (a b : list (Alg syn)),
  CH a -> CH b -> (Choice syn (|-| a) (|-| b)) = (|-| (a ++ b)).

(** Law A.3.2 *)
Axiom Cond_over_Choice : forall syn (a b : list (Alg syn)) (bexp : Boolexp),
  CH a -> CH b ->
  Cond syn (|-| a) bexp (|-| b) = |-| (map (fun g => Cond syn (fst g) bexp (snd g)) (list_prod a b)).

(** Law A.3.3 *)
Axiom Seq_over_Choice : forall syn (a b : list (Alg syn)),
  CH a -> CH b ->
  Seq syn (|-| a) (|-| b) = |-| (map (fun g => Seq syn (fst g) (snd g)) (list_prod a b)).

(** Law A.3.4 *)
Axiom Choice_to_NF : forall syn (a : list (Alg syn)) b,
  CH a -> b GLOBVARS = false ->
  (|-| a) = Cond syn (_|_ syn) b (|-| a).

(** TH2 *)
Lemma CH_hd :forall syn (l: list (Alg syn)) (a : Alg syn),
  CH (a :: l) -> exists y, a = (@{y} syn) /\ Total_Assign y.
Proof. intros. unfold CH in *. assert (In a (a::l)) by (apply in_eq;auto).
  apply H in H0. auto. Qed.
Lemma CH_cons : forall syn (l: list (Alg syn)) (a : Alg syn),
  CH (a :: l) -> CH l.
Proof. intros. unfold CH in *. intros. apply (in_cons a) in H0 as H1.
  apply H in H1. auto. Qed.

Lemma Choice_list_cons : forall syn (l: list (Alg syn)) (a: Alg syn),
  (|-| (a :: l)) = (Choice syn a (|-| l)).
Proof. intros. unfold Choice_of_Alg_List. auto. Qed.

Lemma Choice_list_eq_app : forall syn (l1 l2 l3 : list (Alg syn)),
  (|-| l1) = (|-| l2) -> (|-| (l3 ++ l1)) = (|-| (l3 ++ l2)).
Proof. intros. induction l3;auto. repeat rewrite <- app_comm_cons.
  repeat rewrite Choice_list_cons. rewrite IHl3. auto. Qed.

Lemma CH_app_rev : forall syn (l1 l2 : list (Alg syn)),
  CH l1 -> CH l2 -> CH (l1 ++ l2).
Proof. intros. unfold CH in *. intros. apply in_app_or in H1. destruct H1.
  - apply H in H1. auto.
  - apply H0 in H1. auto.
Qed.

Lemma CH_elim_Cond : forall syn (p q c : list (Alg syn)) (b : Boolexp),
  CH p -> CH q -> exists c, (Cond syn (|-| p) b (|-| q)) = (|-| c) /\ CH c.
Proof. intros. rewrite Cond_over_Choice;auto. induction p;simpl. induction q;simpl.
  - exists [];auto.
  - apply CH_cons in H0 as H1. apply IHq in H1. auto.
  - apply CH_cons in H as H1. apply IHp in H1. rewrite map_app.
    destruct H1. remember (map (fun y => (a, y)) q).
    remember (map (fun g => Cond syn (fst g) b (snd g)) l). exists (l0 ++ x).
    destruct H1. split.
    + rewrite Heql0. apply Choice_list_eq_app. auto.
    + apply CH_app_rev;auto. apply CH_hd in H as H3. rewrite Heql0. rewrite Heql.
      unfold CH in *. intros. apply in_map_iff in H4. repeat destruct H4.
      destruct H3. apply in_map_iff in H5. destruct H5. destruct H4.
      rewrite <- H4. simpl. apply H0 in H5. destruct H5. destruct H5.
      rewrite H5. destruct H3. rewrite H3. apply Assign_elim_Cond.
Qed.

Lemma CH_elim_Seq : forall syn (p q c : list (Alg syn)),
  CH p -> CH q -> exists c, (Seq syn (|-| p) (|-| q)) = (|-| c) /\ CH c.
Proof. intros. rewrite Seq_over_Choice;auto. induction p;simpl. induction q;simpl.
  - exists [];auto.
  - apply CH_cons in H0 as H1. apply IHq in H1. auto.
  - apply CH_cons in H as H1. apply IHp in H1. rewrite map_app.
    destruct H1. remember (map (fun y => (a, y)) q).
    remember (map (fun g => Seq syn (fst g) (snd g)) l). exists (l0 ++ x).
    destruct H1. split.
    + rewrite Heql0. apply Choice_list_eq_app. auto.
    + apply CH_app_rev;auto. apply CH_hd in H as H3. rewrite Heql0. rewrite Heql.
      unfold CH in *. intros. apply in_map_iff in H4. repeat destruct H4.
      destruct H3. apply in_map_iff in H5. destruct H5. destruct H4.
      rewrite <- H4. simpl. apply H0 in H5. destruct H5. destruct H5.
      rewrite H5. destruct H3. rewrite H3. apply Assign_elim_Seq.
Qed.

Lemma CH_elim_Choice : forall syn (p q c : list (Alg syn)),
  CH p -> CH q -> exists c, (Choice syn (|-| p) (|-| q)) = (|-| c) /\ CH c.
Proof. intros. rewrite Choice_distr;eauto. exists (p ++ q). split;auto.
  apply CH_app_rev;auto. Qed.

(** Law A.4 *)
(** Law A.4.1 *)
Axiom NF_over_Choice : forall syn (a b : list (Alg syn)) (c d : Boolexp),
  CH a -> CH b ->
  (Choice syn (Cond syn (_|_ syn) c (|-| a)) (Cond syn (_|_ syn) d (|-| b))) =
  (Cond syn (_|_ syn) (fun g => orb (c g) (d g)) (Choice syn (|-|a) (|-| b))).

(** Law A.4.2 *)
Axiom NF_over_Cond : forall syn (a b : list (Alg syn)) (c d e : Boolexp),
  CH a -> CH b ->
  (Cond syn (Cond syn (_|_ syn) c (|-|a)) d (Cond syn (_|_ syn) e (|-| b))) =
  (Cond syn (_|_ syn) (fun g => if (d g) then (c g) else (e g)) (Cond syn (|-|a) d (|-| b))).

(** Law A.4.3-A.4.4 *)
Definition Assign_over_Boolexp (b : Boolexp) syn (a : Alg syn):=
  match a with
  | Assn _ x => b ((extends_mapping x.(ids) x.(values)) GLOBVARS)
  | _ => false
  end.
Definition CH_over_Boolexp {syn} (a : list (Alg syn)) (b : Boolexp) :=
  fold_left orb (map (Assign_over_Boolexp b syn) a) true.

(** Law A.4.5 *)
Axiom NF_over_Seq : forall syn (a b : list (Alg syn)) (c d : Boolexp),
  CH a -> CH b ->
  (Seq syn (Cond syn (_|_ syn) c (|-| a)) (Cond syn (_|_ syn) d (|-| b))) =
  (Cond syn (_|_ syn) (fun g => orb (c g) (CH_over_Boolexp a d)) (Seq syn (|-| a) (|-| b))).

(** TH.3 *)
Definition FNF {syn} (P : Alg syn ): Prop :=
  exists bexp Q, P = Cond syn (_|_ syn) bexp Q /\ exists R, Q = (|-| R) /\ CH R.

Lemma FNF_elim_Cond : forall syn (P Q : Alg syn) (b : Boolexp),
  FNF P -> FNF Q -> FNF (Cond syn P b Q).
Proof.
  intros. unfold FNF in H. destruct H. destruct H. destruct H.
  destruct H1. destruct H1.
  unfold FNF in H0. destruct H0. destruct H0. destruct H0.
  destruct H3. destruct H3.
  rewrite H. rewrite H0. rewrite H1. rewrite H3.
  rewrite NF_over_Cond;auto. unfold FNF.
  eexists. eexists. split;eauto.
  apply CH_elim_Cond;auto.
Qed.

Lemma FNF_elim_Choice : forall syn (P Q : Alg syn),
  FNF P -> FNF Q -> FNF (Choice syn P Q).
Proof.
  intros. unfold FNF in H. destruct H. destruct H. destruct H.
  destruct H1. destruct H1.
  unfold FNF in H0. destruct H0. destruct H0. destruct H0.
  destruct H3. destruct H3.
  rewrite H. rewrite H0. rewrite H1. rewrite H3.
  rewrite NF_over_Choice;auto. unfold FNF.
  eexists. eexists. split;eauto.
  apply CH_elim_Choice;auto.
Qed.

Lemma FNF_elim_Seq : forall syn (P Q : Alg syn),
  FNF P -> FNF Q -> FNF (Seq syn P Q).
Proof.
  intros. unfold FNF in H. destruct H. destruct H. destruct H.
  destruct H1. destruct H1.
  unfold FNF in H0. destruct H0. destruct H0. destruct H0.
  destruct H3. destruct H3.
  rewrite H. rewrite H0. rewrite H1. rewrite H3.
  rewrite NF_over_Seq;auto. unfold FNF.
  eexists. eexists. split;eauto.
  apply CH_elim_Seq;auto.
Qed.

(** Law A.5-A.7 *)
Definition clos (c : Type) := (c -> Alg c).
Inductive Closure :=
  | iter : forall c, clos c -> Closure.

Hypothesis lub : Closure -> Ualg.

Definition eqEval (x y : Assign) :=
  forall a, In a (x.(values) x.(ids)) -> In a (y.(values) y.(ids)).

Definition eqAssn {syn syn1} (x : Alg syn) (y : Alg syn1) :=
  match x with
  | Assn _ e =>
    match y with
    | Assn _ f => eqEval (extends_assign e) (extends_assign f)
    | _ => False
    end
  | _ => False
  end.

Definition RefineCH {syn syn1} (A : list (Alg syn))
 (B : list (Alg syn1)) :=
 forall x,
  In x B -> exists y, In y A /\ eqAssn x y.

Definition Refine {syn syn1} (P : Alg syn)
 (Q : Alg syn1) :=
  exists bexp cexp S T U V,
   (P = Cond syn (_|_ syn) bexp S
    /\ S = (|-| U) /\ CH U)
  /\ (Q = Cond syn1 (_|_ syn1) cexp T
    /\ T = (|-| V) /\ CH V)
  /\ ((cexp GLOBVARS = false /\ (RefineCH U V))
    \/ (bexp GLOBVARS = true)).

Fixpoint EqAlg {syn syn1} (x : Alg syn) (y : Alg syn1) :=
  match x, y with
  | Assn _ e, Assn _ f => eqEval (extends_assign e) (extends_assign f)
  | Chaos _, Chaos _ => True
  | Cond _ P bexp Q, Cond _ R cexp T => bexp GLOBVARS = cexp GLOBVARS /\ EqAlg P R /\ EqAlg Q T
  | Seq _ P Q, Seq _ R T => EqAlg P R /\ EqAlg Q T
  | Choice _ P Q, Choice _ R T => EqAlg P R /\ EqAlg Q T
  | _, _ => False
  end.

Definition RecurFix {syn} (f : clos (Alg syn)) (x : Alg syn) :=
  exists y, y = (f x) /\ EqAlg x y.

Axiom fix_is_lub : forall s (f : clos (Alg s)) (x : Alg s),
 RecurFix f x -> (f x) = lub (iter (Alg s) f) (Alg s).

Definition FNF_pres {syn : Type} (f : clos (Alg syn)) :=
  forall x, FNF x -> FNF (f x).

Axiom Recur_clos : forall (syn : Type) (F : clos (Alg syn)),
  Recur (Alg syn) F = lub (iter (Alg syn) F) (Alg syn).

Axiom Recur_over_Recur : forall (syn : Type) (f g : clos (Alg syn)) x,
   f x = lub (iter (Alg syn) g) (Alg syn) ->
   exists c, FNF_pres c /\
   lub (iter (Alg syn) f) (Alg syn) = lub (iter (Alg syn) c) (Alg syn).

Axiom Recur_over_Choice : forall (syn : Type) (f : clos (Alg syn)) (p : Alg (Alg syn)),
  FNF_pres f -> FNF p ->
  (Choice (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) p =
  lub (iter (Alg syn) (fun g => (Choice (Alg syn) (f g) p))) (Alg syn)).

Axiom Recur_over_Cond : forall (syn : Type) (f : clos (Alg syn)) (p : Alg (Alg syn)) (b : Boolexp),
  FNF_pres f -> FNF p ->
  (Cond (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) b p =
  lub (iter (Alg syn) (fun g => (Cond (Alg syn) (f g) b p))) (Alg syn)).

Axiom Recur_over_Seq_l : forall (syn : Type) (f : clos (Alg syn)) (p : Alg (Alg syn)),
  FNF_pres f -> FNF p ->
  (Seq (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) p =
  lub (iter (Alg syn) (fun g => (Seq (Alg syn) (f g) p))) (Alg syn)).

Axiom Recur_over_Seq_r : forall (syn : Type) (f : clos (Alg syn)) (p : Alg (Alg syn)),
  FNF_pres f -> FNF p ->
  (Seq (Alg syn) p (lub (iter (Alg syn) f) (Alg syn)) =
  lub (iter (Alg syn) (fun g => (Seq (Alg syn) p (f g)))) (Alg syn)).

Axiom Recur_over_Rec_Choice : forall (syn : Type) (f g : clos (Alg syn)),
  FNF_pres f -> FNF_pres g ->
  Choice (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) (lub (iter (Alg syn) g) (Alg syn)) =
  lub (iter (Alg syn) (fun k => (Choice (Alg syn) (f k) (g k)))) (Alg syn).

Axiom Recur_over_Rec_Cond : forall (syn : Type) (f g : clos (Alg syn)) (b : Boolexp),
  FNF_pres f -> FNF_pres g ->
  Cond (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) b (lub (iter (Alg syn) g) (Alg syn)) =
  lub (iter (Alg syn) (fun k => (Cond (Alg syn) (f k) b (g k)))) (Alg syn).

Axiom Recur_over_Rec_Seq : forall (syn : Type) (f g : clos (Alg syn)),
  FNF_pres f -> FNF_pres g ->
  Seq (Alg syn) (lub (iter (Alg syn) f) (Alg syn)) (lub (iter (Alg syn) g) (Alg syn)) =
  lub (iter (Alg syn) (fun k => (Seq (Alg syn) (f k) (g k)))) (Alg syn).

Definition IFNF {syn} (p : Alg (Alg syn)) :=
  exists x, p = lub (iter (Alg syn) x) (Alg syn) /\ FNF_pres x.

Lemma IFNF_elim_Choice_FNF_l :
  forall x (a b : Alg (Alg x)), IFNF a -> FNF b ->
  IFNF (Choice (Alg x) a b).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. apply Recur_over_Choice;auto.
  unfold FNF_pres. intros. apply FNF_elim_Choice;auto. Qed.

Lemma IFNF_elim_Choice_FNF_r :
  forall x (a b : Alg (Alg x)), IFNF a -> FNF b ->
  IFNF (Choice (Alg x) b a).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. rewrite Choice_comm. apply (Recur_over_Choice x);auto.
  unfold FNF_pres. intros. apply FNF_elim_Choice;auto. Qed.

Lemma IFNF_elim_Cond_FNF_l :
  forall x (a b : Alg (Alg x)) c, IFNF a -> FNF b ->
  IFNF (Cond (Alg x) a c b).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. apply Recur_over_Cond;auto.
  unfold FNF_pres. intros. apply FNF_elim_Cond;auto. Qed.

Lemma IFNF_elim_Cond_FNF_r :
  forall x (a b : Alg (Alg x)) c, IFNF a -> FNF b ->
  IFNF (Cond (Alg x) b c a).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. rewrite Cond_rev. apply Recur_over_Cond;auto.
  unfold FNF_pres. intros. apply FNF_elim_Cond;auto. Qed.

Lemma IFNF_elim_Seq_FNF_l :
  forall x (a b : Alg (Alg x)), IFNF a -> FNF b ->
  IFNF (Seq (Alg x) a b).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. apply Recur_over_Seq_l;auto.
  unfold FNF_pres. intros. apply FNF_elim_Seq;auto. Qed.

Lemma IFNF_elim_Seq_FNF_r :
  forall x (a b : Alg (Alg x)), IFNF a -> FNF b ->
  IFNF (Seq (Alg x) b a).
Proof. intros. unfold IFNF in *. destruct H. destruct H. eexists.
  split. rewrite H. apply Recur_over_Seq_r;auto.
  unfold FNF_pres. intros. apply FNF_elim_Seq;auto. Qed.

Theorem Alg_is_FNF_or_IFNF : forall (a : Ualg) x, FNF (a (Alg x)) \/ IFNF (a (Alg x)).
Proof.
  intros. induction (a (Alg x)).
  - left. rewrite (Chaos_to_NF (Alg x) true_stat [@{empty_assn} (Alg x)]);auto.
    unfold FNF. eexists. eexists. split;eauto. eexists. split;auto.
    unfold empty_program. unfold CH. intros.
    unfold In in H. destruct H;try contradiction. rewrite <- H.
    eexists. split;auto. unfold empty_assn. unfold Total_Assign. auto.
  - left. destruct a0. rewrite (Assign_to_NF _ _ false_stat (Alg x));auto. unfold FNF.
    eexists. eexists. split;eauto.
    eexists. split;auto. unfold CH. intros. unfold In in H.
    destruct H;try contradiction. rewrite <- H. eexists. split;auto.
    unfold Total_Assign. unfold extends_assign. auto.
  - destruct IHa0_1;destruct IHa0_2.
    + left. apply FNF_elim_Cond;auto.
    + right. apply IFNF_elim_Cond_FNF_r;auto.
    + right. apply IFNF_elim_Cond_FNF_l;auto.
    + right. unfold IFNF in *. destruct H. destruct H. destruct H0.
      destruct H0. rewrite H. rewrite H0. eexists. split.
      apply Recur_over_Rec_Cond;auto. unfold FNF_pres.
      intros. apply FNF_elim_Cond;auto.
  - destruct IHa0_1;destruct IHa0_2.
    + left. apply FNF_elim_Seq;auto.
    + right. apply IFNF_elim_Seq_FNF_r;auto.
    + right. apply IFNF_elim_Seq_FNF_l;auto.
    + right. unfold IFNF in *. destruct H. destruct H. destruct H0.
      destruct H0. rewrite H. rewrite H0. eexists. split.
      apply Recur_over_Rec_Seq;auto. unfold FNF_pres.
      intros. apply FNF_elim_Seq;auto.
  - destruct IHa0_1;destruct IHa0_2.
    + left. apply FNF_elim_Choice;auto.
    + right. apply IFNF_elim_Choice_FNF_r;auto.
    + right. apply IFNF_elim_Choice_FNF_l;auto.
    + right. unfold IFNF in *. destruct H. destruct H. destruct H0.
      destruct H0. rewrite H. rewrite H0. eexists. split.
      apply Recur_over_Rec_Choice;auto. unfold FNF_pres.
      intros. apply FNF_elim_Choice;auto.
  - right. unfold IFNF. exists a0. split. apply Recur_clos.
    unfold FNF_pres. intros. remember (H x0). clear Heqo.
    destruct o;auto. unfold IFNF in H1. do 2 destruct H1.
    remember (Recur_over_Recur x a0 x1 x0). clear Heqe.
    apply e in H1 as H3. do 2 (destruct H3). unfold FNF_pres in H3.
    apply H3 in H0. do 2 rewrite <- Recur_clos in H4.
    inversion H4. auto.
Qed.

Axiom Ualg_to_Alg : forall syn (x : Alg syn), exists t: Ualg, t syn = x.

End Fact.
End ProgramAlgebra.


Require Export basic_facts_plane.
Require Export forth.

(** First, we derive some lemmas needed to show duality. **)

Module Type Decidability.

Parameter Line : Set.
Parameter Point : Set.
Parameter Incid : Point -> Line -> Prop.

Axiom eq_line_dec : forall d1 d2 : Line, {d1 = d2}+{d1 <> d2}.
Axiom eq_point_dec : forall A B: Point, {A = B}+{A <> B}.
(* should be moved somewhere else *)
Axiom outsider : forall l1 l2: Line, { P:Point | ~Incid P l1/\~Incid P l2}.

End Decidability.

Module decidability (M:ProjectivePlane) : Decidability
with Definition Line:=M.Line
with Definition Point:= M.Point
with Definition Incid := M.Incid.

Definition Line:=M.Line.
Definition Point:= M.Point.
Definition Incid := M.Incid.

Module Export ProjectivePlane' := forth.forth M.
Module Export uniq := uniqueness_axioms M.

(* Decidability of point equality / line equality *)

Lemma eq_point_dec_sublemma :
  forall A B : Point, forall d : Line, ~Incid A d -> ~Incid B d -> {A = B}+{A <> B}.
generalize a3_1 a3_2.
intros Ha31' Ha32'.
intros A B d HAd HBd.
elim (Ha31' d).
intros M HM.
elim HM; clear HM; intros N HN.
elim HN; clear HN; intros P HMNP.
elim (a1_exist A M).
intros l1 Hl1.
elim (a1_exist A N).
intros l2 Hl2.
assert (l1 <> l2).
intros Hl1l2.
subst l1.
elim Hl2; intros Hl2a Hl2b.
elim Hl1; intros Hl1a Hl1b.
assert (N <> M).
unfold dist3 in HMNP; intuition.
elim HMNP; clear HMNP; intros Hdist3 HMNP.
elim HMNP; clear HMNP; intros HM HNP.
elim HNP; clear HNP; intros HN HP.
generalize (a1_unique N M l2 d H Hl2b Hl1b HN HM).
intros Hl2d.
subst l2.
tauto.
elim (incid_dec B l1).
intros HBl1.
elim (incid_dec B l2).
intros HBl2.
left.
eapply a2_unique.
apply H.
tauto.
tauto.
assumption.
intuition.
intros HBl2.
right.
assert (B<>A) ; [idtac | intuition].
eapply incidABl.
split.
apply HBl2.
tauto.
intros HBl1.
right.
assert (B<>A); [idtac | intuition].
eapply incidABl.
split.
apply HBl1.
tauto.
Qed.

Lemma eq_point_dec : forall A B: Point, {A = B}+{A <> B}.
generalize a3_1 a3_2.
intros Ha31' Ha32'.
elim Ha32'; intros delta_0 Hdelta.
elim Hdelta; clear Hdelta; intros delta_1 Hdelta.
intros A B.
elim (incid_dec A delta_0).
intros HAd.
elim (incid_dec B delta_0).
intros HBd.
elim (incid_dec A delta_1).

(* cas1 *)
intros HAd1.
elim (incid_dec B delta_1).
intros HBd1.
left.
eapply a2_unique;eauto.

intros HBd1.
right.
assert (B<>A).
eapply (incidABl B A);eauto.
intuition.

intros HAd1.
elim (incid_dec B delta_1).
intros HBd1.
right.
eapply incidABl.
split.
apply HAd1.
apply HBd1.
(* cas 2 *)
intros HBd1.
eapply eq_point_dec_sublemma; eauto.

intros HBd.
right.
assert (B<>A).
apply (incidABl B A delta_0).
split.
assumption.
assumption.
intuition.

intros HAd.
elim (incid_dec B delta_0).
intros HBd.
right.
eapply incidABl with (l:=delta_0).
split.
assumption.
assumption.
(* cas 2 *)
intros HBd.
eapply eq_point_dec_sublemma; eauto.
Qed.

Ltac Apply_unicity := match goal with
H1: ?A <> ?B, H2: ?Incid ?A ?l, H3: ?Incid ?B ?l, H4 : ?Incid ?A ?m, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: l=m); try apply (a1_unique A B l m H1 H2 H3 H4 H5);subst l
| H1: ?l <> ?m, H2: ?Incid ?A ?l, H3: ?Incid ?A ?m, H4 : ?Incid ?B ?l, H5: ?Incid ?B ?m |- _ =>
let id:= fresh in assert (id: A=B); try apply (a2_unique l m A B H1 H2 H3 H4 H5);subst A
end.

Ltac Collapse := repeat (Apply_unicity; CleanDuplicatedHyps).

Lemma eq_line_dec :
  forall d1 d2 : Line, {d1 = d2}+{d1 <> d2}.
Proof.
generalize a3_1 a3_2.
intros Hsa31' Hsa32'.
intros l1 l2.
elim (Hsa31' l1).
intros M HM; elim HM; clear HM; intros N HN; elim HN; clear HN; intros P HMNP.
elim (incid_dec M l2).
intros HMl2; elim (incid_dec N l2).
intros HNl2.
left.
unfold dist3 in *;decompose [and] HMNP;Collapse.

intros HNl2.
right.
apply incidAl1l2 with (A:=N).
intuition.
right.
apply incidAl1l2 with (A:=M); intuition.
Qed.

Lemma first_point : forall l:Line, {V:Point| Incid V l}.
Proof.
intros l.
elim (a3_1 l).
intros P HP.
elim HP; intros B HB ; elim HB; intros.
exists P; intuition.
Qed.

(*** essai de preuve de décidabilité de l'incidence à partir de celles de l'égalité
pour les points et aussi pour les droites *)

Lemma incid_dec2 : forall A:Point, forall l:Line, {Incid A l}+{~Incid A l}.
Proof.
intros A l.
elim (first_point l).
intros M HM.
elim (eq_point_dec A M).
intros; subst; left; auto.
intros HAM.
elim (a1_exist A M).
intros lAM (HA,HM').
elim (eq_line_dec lAM l).
intros; subst; left; auto.
intros;right; unfold not; intro H.
generalize (a1_unique A M lAM l HAM HA HM' H HM).
intros; subst; intuition.
Qed.

Lemma second_line : forall l1 : Line, {l2:Line | l1<>l2}.
intros l1.
elim a3_2.
intros d1 Hd1.
elim Hd1; clear Hd1; intros d2 Hd1d2.
elim (eq_line_dec l1 d1).
intros Hl1d1; subst l1.
exists d2.
assumption.
intros Hl1d1.
exists d1.
assumption.
Qed.

Lemma second_point : forall A:Point, forall l:Line, Incid A l -> {B : Point | (B<>A)/\(Incid B l)}.
intros A l HAl.
elim (a3_1 l).
intros P1 H.
elim H; intros P2 H'.
elim H'; intros P3 H''.
elim (eq_point_dec A P1).
intros HAP1.
subst A.
exists P2.
unfold dist3 in *; intuition.
intros Hnew.
exists P1.
intuition.
Qed.

Lemma third_point : forall A B:Point, forall l:Line, A<>B/\Incid A l/\Incid B l ->
{C:Point | dist3 A B C/\Incid C l}.
intros A B l HABl.
elim (a3_1 l).
intros P1 H.
elim H; intros P2 H'.
elim H'; intros P3 H''.
elim (eq_point_dec A P1).
intros HAP1.
subst A.
elim (eq_point_dec B P2).
intros HBP2.
subst B.
exists P3.
unfold dist3 in *; intuition.
intros HBP2.
exists P2.
unfold dist3 in *; intuition.
intros HAP1.
elim (eq_point_dec B P1).
intros HBP1.
subst B.
elim (eq_point_dec A P2).
exists P3.
subst A.
unfold dist3 in *; intuition.
intros HAP2.
exists P2.
unfold dist3 in *; intuition.
intros HBP1.
exists P1.
unfold dist3 in *;intuition.
Qed.

Lemma outsider : forall l1 l2: Line, { P:Point | ~Incid P l1/\~Incid P l2}.
intros l1 l2.
elim (eq_line_dec l1 l2).
intros Hl1l2; subst l1.
elim (second_line l2).
intros d Hl2d.
elim (a3_1 d).
intros P HP.
elim (incid_dec P l2).
intros HPl2.
elim (incid_dec P d).
intros HPd.
elim (second_point P d HPd).
intros Q (HQP,HQd).
exists Q.
assert (~Incid Q l2).
intros HQl2.
apply HQP.
eapply (a2_unique l2 d Q P Hl2d); assumption.
tauto.
intros HPd.
elim (a2_exist l2 d); intros C (HCl2,HCd).
elim (second_point C d HCd).
intros Q (HQC,HQd).
exists Q.
assert (~Incid Q l2).
intros HQl2.
apply HQC.
apply (a2_unique l2 d Q C); assumption.
tauto.
intros HPl2; exists P; tauto.

intros Hl1l2.
elim (a2_exist l1 l2).
intros C (HCl1,HCl2).
elim (second_point C l1 HCl1).
intros P1 (HP1C,HP1l1).
elim (second_point C l2 HCl2).
intros P2 (HP2C,HP2l2).
elim (a1_exist P1 P2).
intros d (HP1d,HP2d).
elim (eq_point_dec P1 P2).

intros HP1P2.
subst P1.
assert (P2=C).
eapply (a2_unique l1 l2 P2 C); assumption.
assert (Hf:False) by (apply (HP2C H)).
elim Hf.
intros HP1P2.
elim (third_point P1 P2 d (conj HP1P2 (conj HP1d HP2d))).
intros newP (Hdist3,HnewPd).
exists newP.
split.
intros HnewPl1.
assert (H:(newP<>P1)) by (unfold dist3 in *; intuition).
apply H.
assert (d<>l1).
intros Hdl1.
subst l1.
apply HP2C.
eapply (a2_unique d l2 P2 C); assumption.
eapply (a2_unique d l1 newP P1); assumption.
intros HnewPl2.
assert (H:(newP<>P2)) by (unfold dist3 in *; intuition).
apply H.
assert (d<>l2).
intros Hdl2.
subst l2.
apply HP1C.
eapply (a2_unique l1 d P1 C) ; assumption.
eapply (a2_unique d l2 newP P2); try assumption.
Qed.

End decidability.


Require Import String.
Require Import Ascii.
Require Import Bool.
Require Import Arith.
Require Import Omega.
Require Import Program.Tactics.

(*
 * I should polish this up and get merged upstream.
 * coq's string library is a disgrace.
 *)

Section MissingListBits.

   (* XXX why isn't this in the library? or is it and I can't find it? *)
   Function take {T} (n: nat) (xs: list T) :=
      match n, xs with
      | S n, (x :: more)%list => (x :: take n more)%list
      | _, _ => nil
      end.

   Lemma take_length:
      forall T (xs : list T) n,
      List.length (take n xs) <= List.length xs.
   Proof.
      intros. revert n.
      induction xs; intros.
      - destruct n; rewrite take_equation; auto.
      - destruct n; rewrite take_equation; simpl; try omega.
        apply le_n_S. apply IHxs.
   Qed.

   Lemma take_length_strict:
      forall T (xs : list T) n,
      n <= List.length xs -> List.length (take n xs) = n.
   Proof.
      intros. revert H. revert n.
      induction xs; intros.
      - simpl in H. assert (n = 0) by omega. subst. simpl. reflexivity.
      - destruct n; rewrite take_equation; simpl in *; try apply eq_S; try apply IHxs; omega.
   Qed.

   Lemma take_correctness:
      forall T n (xs : list T) k x,
         k < n -> List.nth k (take n xs) x = List.nth k xs x.
   Proof.
      intros T n xs. revert n.
      induction xs; intros;
         rewrite take_equation;
         destruct n; destruct k;
         simpl; try discriminate;
         try apply IHxs; try omega;
         auto.
   Qed.

   Lemma take_correctness_2:
      forall T n (xs : list T) k x,
         k >= n -> List.nth k (take n xs) x = x.
   Proof.
      intros T n xs. revert n.
      induction xs; intros;
         rewrite take_equation;
         destruct n; destruct k;
         simpl; try apply IHxs; try omega; auto.
   Qed.

   (* and I'd expect to find this too... *)
   Function natlist_sum (ns : list nat): nat :=
      match ns with
      | nil => 0
      | (n :: more)%list => n + (natlist_sum more)
      end.

   Lemma natlist_sum_ge:
      forall n ns,
      List.In n ns -> natlist_sum ns >= n.
   Proof.
      intros.
      revert H. revert n.
      induction ns; intros.
      - unfold List.In in H. contradiction.
      - rewrite natlist_sum_equation.
        apply List.in_inv in H.
        destruct H; subst; try apply IHns in H; try omega.
   Qed.

   (* not sure what else to prove about natlist_sum *)

End MissingListBits.

Section CharacterFacts.
   (*
    * These bits are from pset3regex
    *)

  (* `ascii_eq` is an executable equality test for characters. *)
  Definition ascii_eq (a b:ascii) : bool :=
    match (a, b) with
    | (Ascii a1 a2 a3 a4 a5 a6 a7 a8,
       Ascii b1 b2 b3 b4 b5 b6 b7 b8) =>
      eqb a1 b1 && eqb a2 b2 && eqb a3 b3 && eqb a4 b4 &&
          eqb a5 b5 && eqb a6 b6 && eqb a7 b7 && eqb a8 b8
    end.

  Lemma ascii_eq_refl (a:ascii):
    ascii_eq a a = true.
  Proof.
    destruct a; unfold ascii_eq; repeat rewrite eqb_reflx; simpl; auto.
  Qed.

  (* `ascii_eq` is equivalent to character equality. *)
  Lemma ascii_eq_iff a b:
    ascii_eq a b = true <-> a = b.
  Proof.
    split; intros.
    - unfold ascii_eq in H; destruct a; destruct b;
        repeat rewrite andb_true_iff in *; destruct_pairs;
          rewrite eqb_true_iff in *; congruence.
    - rewrite H; apply ascii_eq_refl.
  Qed.

  (*
   * These bits are mine
   *)

  (* we also need inequality *)
  Lemma ascii_neq_iff a b:
    ascii_eq a b = false <-> a <> b.
  Proof.
    split; intros.
    - unfold ascii_eq in H; destruct a; destruct b;
        repeat rewrite andb_false_iff in *.
        repeat rewrite eqb_false_iff in *.
        injection.
        (* destruct pairs doesn't work... *)
        repeat (destruct H; auto).
    - unfold ascii_eq; destruct a; destruct b.
      unfold eqb.
      (* there must be a better way to do this... *)
      destruct b; destruct b0; auto; destruct b1; destruct b8; auto; simpl;
      destruct b2; destruct b9; auto; destruct b3; destruct b10; auto; simpl;
      destruct b4; destruct b11; auto; destruct b5; destruct b12; auto; simpl;
      destruct b6; destruct b13; auto; destruct b7; destruct b14; auto; simpl;
      contradiction.
  Qed.

End CharacterFacts.

Section StringFacts.

  (*
   * These bits are from pset3regex
   *)

  Lemma append_nil_l s:
    ("" ++ s)%string = s.
  Proof.
    simpl; auto.
  Qed.

  Lemma append_nil_r s:
    (s ++ "")%string = s.
  Proof.
    induction s; simpl; try rewrite IHs; auto.
  Qed.

  Lemma append_assoc s1 s2 s3:
    (s1 ++ s2 ++ s3)%string = ((s1 ++ s2) ++ s3)%string.
  Proof.
    induction s1; simpl; try rewrite IHs1; auto.
  Qed.

  Lemma append_comm_cons a s1 s2:
    (String a s1 ++ s2)%string = String a (s1 ++ s2)%string.
  Proof.
    induction s1; simpl; auto.
  Qed.

  Definition strlen := String.length.

  Lemma append_strlen_l s1 s2:
    strlen s1 <= strlen (s1 ++ s2).
  Proof.
    induction s1; simpl; try rewrite IHs1; omega.
  Qed.

  Lemma append_strlen_r s1 s2:
    strlen s1 <= strlen (s1 ++ s2).
  Proof.
    induction s1; simpl; try rewrite IHs1; omega.
  Qed.

  (*
   * These bits are mine.
   *)
  Lemma length_zero_empty:
     forall s,
     strlen s = 0 -> s = EmptyString.
  Proof.
     intros.
     induction s.
     - auto.
     - simpl in H. discriminate.
  Qed.

  Lemma length_cons:
     forall c s,
     strlen (String c s) = S (strlen s).
  Proof.
     intros; simpl; auto.
  Qed.

  Lemma length_append:
     forall s1 s2,
     String.length (s1 ++ s2)%string = String.length s1 + String.length s2.
  Proof.
     intros.
     induction s1.
     - simpl; auto.
     - rewrite append_comm_cons.
       repeat rewrite length_cons.
       rewrite plus_Sn_m.
       apply eq_S.
       auto.
  Qed.

  Lemma cons_substring:
     forall n c s,
     String.substring 0 (S n) (String c s) = String c (String.substring 0 n s).
  Proof.
     intros.
     simpl.
     auto.
  Qed.

  Lemma cons_eq_cons:
     forall c s1 s2,
        String c s1 = String c s2 <-> s1 = s2.
  Proof.
     intros.
     split.
     - congruence.
     - intro. rewrite H. auto.
  Qed.

  Lemma cons_neq_cons:
     forall c s1 s2,
        String c s1 <> String c s2 <-> s1 <> s2.
  Proof.
     split; intros; congruence.
  Qed.

  (* XXX this needs a better name *)
  Lemma cons_neq_cons_2:
     forall c1 c2 s,
        String c1 s <> String c2 s <-> c1 <> c2.
  Proof.
     split; intros; congruence.
  Qed.

  (* XXX this too *)
  Lemma cons_neq_cons_3:
     forall c1 c2 s1 s2,
        String c1 s1 <> String c2 s2 <-> c1 <> c2 \/ s1 <> s2.
  Proof.
     split; intros.
     - destruct (ascii_dec c1 c2); subst.
       * rewrite cons_neq_cons in H. auto.
       * auto.
     - destruct H; congruence.
  Qed.

  Lemma cons_not_itself:
     forall c s,
        String c s = s -> False.
  Proof.
     intros.
     induction s; try discriminate.
     inversion H; subst.
     auto.
  Qed.

  Lemma cons_is_prepend:
     forall c s,
        String c s = ((String c EmptyString) ++ s)%string.
  Proof.
     intros.
     induction s; simpl; auto.
  Qed.

  Lemma append_eq_append:
     forall s1 s2 s3,
        (s1 ++ s3)%string = (s2 ++ s3)%string -> s1 = s2.
  Proof.
  (* There must be a less messy way to do this. *)
  intros.
  revert H. revert s1 s2.
  induction s3; intros.
  - repeat rewrite append_nil_r in H. auto.
  - rewrite cons_is_prepend in H.
    repeat rewrite append_assoc in H.
    apply IHs3 with
       (s1 := (s1 ++ String a "")%string) (s2 := (s2 ++ String a "")%string) in H.
    revert H; revert s2; induction s1; intros.
    * destruct s2; auto.
      simpl in H.
      destruct (ascii_dec a a0); subst.
      + assert (EmptyString = (s2 ++ String a0 EmptyString)%string) by congruence.
        destruct s2.
        -- rewrite append_nil_l in H0. discriminate.
        -- simpl in H0. discriminate.
      + congruence.
    * destruct s2; simpl in H.
      + destruct (ascii_dec a a0); subst.
        -- assert ((s1 ++ String a0 EmptyString)%string = EmptyString) by congruence.
           destruct s1.
           ** rewrite append_nil_l in H0. discriminate.
           ** simpl in H0. discriminate.
        -- congruence.
      + destruct (ascii_dec a0 a1); subst.
        -- assert ((s1 ++ String a "")%string = (s2 ++ String a "")%string) by congruence.
           apply IHs1 in H0.
           rewrite H0; auto.
        -- congruence.
  Qed.

  Lemma prepend_eq_prepend:
     forall s1 s2 s3,
        (s1 ++ s2)%string = (s1 ++ s3)%string -> s2 = s3.
  Proof.
     intros.
     induction s1.
     - repeat rewrite append_nil_l in H; auto.
     - simpl in H.
       apply cons_eq_cons in H.
       auto.
  Qed.

  Lemma null_substring:
     forall s,
     String.substring 0 0 s = EmptyString.
  Proof.
     intros.
     (* just compute doesn't work *)
     induction s; compute; auto.
  Qed.

  Lemma entire_substring:
     forall s,
     String.substring 0 (String.length s) s = s.
  Proof.
     intros.
     remember (String.length s) as n.
     revert Heqn. revert n.
     induction s; intros.
     - simpl in Heqn.
       rewrite Heqn.
       compute.
       auto.
     - assert (exists m, n = S m) as M by
         (induction n; [simpl in Heqn; omega | exists n; auto]).
       destruct M as [m M].
       rewrite M.
       rewrite cons_substring.
       rewrite cons_eq_cons.
       apply IHs.
       simpl in Heqn.
       omega.
  Qed.

  Lemma substring_cons_head:
     forall c s n,
     String.substring 0 (S n) (String c s) = String c (String.substring 0 n s).
  Proof.
     intros; simpl; auto.
  Qed.

  Lemma substring_cons_tail:
     forall c s m n,
     String.substring (S m) n (String c s) = String.substring m n s.
  Proof.
     intros; simpl; auto.
  Qed.

  (* substring of s1 ++ s2 that falls entirely within s1 *)
  Lemma substring_append_first:
     forall s1 s2 m n,
     m + n <= String.length s1 ->
     String.substring m n (s1 ++ s2)%string = String.substring m n s1.
  Proof.
     intro. (* s1 only *)
     induction s1; intros.
     - simpl in H.
       assert (m = 0) by omega.
       assert (n = 0) by omega.
       subst.
       simpl.
       rewrite null_substring.
       auto.
     - destruct (Nat.eq_dec m 0).
       * subst.
         rewrite Nat.add_0_l in H.
         destruct (Nat.eq_dec n 0).
         + subst. repeat rewrite null_substring. auto.
         + assert (exists k, n = S k) as kEq by
              (exists (Nat.pred n); rewrite Nat.succ_pred; auto).
           destruct kEq as [k kEq].
           rewrite kEq.
           rewrite append_comm_cons.
           repeat rewrite substring_cons_head.
           rewrite cons_eq_cons.
           apply IHs1.
           simpl in H.
           omega.
       * assert (exists k, m = S k) as kEq by
           (exists (Nat.pred m); rewrite Nat.succ_pred; auto).
           destruct kEq as [k kEq].
           rewrite kEq.
           rewrite append_comm_cons.
           repeat rewrite substring_cons_tail.
           apply IHs1.
           simpl in H.
           omega.
  Qed.

  (* substring of s1 ++ s2 that includes parts of both s1 and s2 *)
  Lemma substring_append_both:
     forall s1 s2 m n,
     m <= String.length s1 -> m + n >= String.length s1 ->
     String.substring m n (s1 ++ s2)%string =
        (String.substring m (String.length s1 - m) s1 ++
         String.substring 0 ((m + n) - String.length s1) s2)%string.
  Proof.
     intro; (* s1 only *)
     induction s1; intros.
     - simpl in H. assert (m = 0) by omega; subst. simpl.
       rewrite Nat.sub_0_r. auto.
     - rewrite length_cons.
       destruct m; simpl in H; simpl in H0.
       *
         assert (exists k, n = S k) as kEq by
            (exists (Nat.pred n); rewrite Nat.succ_pred; omega).
         destruct kEq as [k kEq].
         rewrite kEq.
         specialize IHs1 with (s2 := s2) (m := 0) (n := k).
         rewrite Nat.sub_0_r in *.
         rewrite Nat.add_0_l in *.
         rewrite append_comm_cons.
         repeat rewrite substring_cons_head.
         rewrite append_comm_cons.
         rewrite cons_eq_cons.
         rewrite Nat.sub_succ.
         apply IHs1; omega.
       * rewrite plus_Sn_m.
         repeat rewrite Nat.sub_succ.
         apply IHs1; omega.
  Qed.

  (* substring of s1 ++ s2 that falls entirely within s2 *)
  Lemma substring_append_second:
     forall s1 s2 m n,
     m >= String.length s1 ->
     String.substring m n (s1 ++ s2)%string = String.substring (m - String.length s1) n s2.
  Proof.
     intro. (* s1 only *)
     induction s1; intros.
     - simpl. rewrite Nat.sub_0_r. auto.
     - rewrite append_comm_cons.
       simpl in H.
       assert (exists k, m = S k) as kEq by
          (exists (Nat.pred m); rewrite Nat.succ_pred; omega).
       destruct kEq as [k kEq].
       rewrite kEq.
       simpl.
       apply IHs1.
       omega.
  Qed.

  (* General statement of substring_append. *)
  Lemma substring_append:
     forall s1 s2 m n,
     exists m1 n1 m2 n2,
     String.substring m n (s1 ++ s2)%string =
        (String.substring m1 n1 s1 ++ String.substring m2 n2 s2)%string.
  Proof.
     intros.
     destruct (le_gt_dec m (String.length s1)).
     1: destruct (le_gt_dec (m + n) (String.length s1)).
     - (* substring_append_first *)
       exists m; exists n.
       exists 0; exists 0.
       rewrite null_substring.
       rewrite append_nil_r.
       apply substring_append_first.
       auto.
     - (* substring_append_both *)
       exists m; exists (String.length s1 - m).
       exists 0; exists ((m + n) - String.length s1).
       apply substring_append_both; omega.
     - (* substring_append_second *)
       exists 0; exists 0.
       exists (m - String.length s1); exists n.
       rewrite null_substring.
       rewrite append_nil_l.
       apply substring_append_second.
       omega.
  Qed.

  (* Specialization of substring_append_first for m = 0 *)
  Lemma substring_append_head_shorter:
     forall s1 s2 n,
     n <= String.length s1 ->
     String.substring 0 n (s1 ++ s2)%string = String.substring 0 n s1.
  Proof.
     intros.
     apply substring_append_first.
     omega.
  Qed.

  (* Specialization of substring_append_both for m = 0 *)
  Lemma substring_append_head_longer:
     forall s1 s2 n,
     n >= String.length s1 ->
     String.substring 0 n (s1 ++ s2)%string =
        (s1 ++ String.substring 0 (n - String.length s1) s2)%string.
  Proof.
     intros.
     assert (String.substring 0 n (s1 ++ s2)%string =
             (String.substring 0 (String.length s1 - 0) s1 ++
              String.substring 0 ((0 + n) - String.length s1) s2)%string) by
        (rewrite substring_append_both; try omega; auto).
     rewrite H0.
     rewrite Nat.sub_0_r.
     rewrite entire_substring.
     simpl.
     reflexivity.
  Qed.

  (* Specialization of substring_append_both for n = strlen s - m *)
  Lemma substring_append_tail_longer:
     forall s1 s2 m,
     m <= String.length s1 ->
     String.substring m (String.length (s1 ++ s2)%string - m) (s1 ++ s2)%string =
        (String.substring m (String.length s1 - m) s1 ++ s2)%string.
  Proof.
     intros.

     assert (m <= String.length (s1 ++ s2)%string) by
        (rewrite length_append; omega).
     assert (String.length (s1 ++ s2)%string >= String.length s1) by
        (rewrite length_append; omega).

     assert(String.substring m (String.length (s1 ++ s2)%string - m) (s1 ++ s2)%string =
            (String.substring m (String.length s1 - m) s1 ++
             String.substring 0 ((m + (String.length (s1 ++ s2)%string - m)) -
                                  String.length s1) s2)%string) by
        (rewrite substring_append_both; try omega; try rewrite <- le_plus_minus; auto).
     rewrite H2.

     rewrite <- le_plus_minus; auto.
     rewrite length_append.
     rewrite minus_plus.
     rewrite entire_substring.
     reflexivity.
  Qed.

  (* Specialization of substring_append_second for n = strlen s - m *)
  Lemma substring_append_tail_shorter:
     forall s1 s2 m,
     m >= String.length s1 ->
     String.substring m (String.length (s1 ++ s2)%string - m) (s1 ++ s2)%string =
        String.substring (m - String.length s1) (String.length s2 - (m - String.length s1)) s2.
  Proof.
     intros.
     rewrite substring_append_second; auto.
     rewrite length_append.
     (* ! *)
     assert (forall a b c, b >= c -> a - (b - c) = c + a - b) as Ha by (intros; omega).
     rewrite Ha; auto.
  Qed.

  Lemma split_once:
     forall s n,
     n <= String.length s ->
     ((String.substring 0 n s) ++ (String.substring n (String.length s - n) s))%string = s.
  Proof.
     intros. revert H. revert n.
     induction s; intros.
     - simpl in H. assert (n = 0) by omega. subst. simpl. auto.
     - destruct (Nat.eq_dec n 0).
       * subst. simpl. rewrite entire_substring. auto.
       * assert (n > 0) by omega.
         assert (exists m, n = S m) as mEq by
            (exists (Nat.pred n); rewrite Nat.succ_pred; auto).
         destruct mEq as [m mEq].
         rewrite mEq.
         rewrite substring_cons_head.
         rewrite substring_cons_tail.
         simpl.
         rewrite cons_eq_cons.
         apply IHs.
         simpl in H.
         omega.
  Qed.

  Function concat (xs : list string): string :=
     match xs with
     | nil => ""%string
     | (s :: more)%list => (s ++ concat more)%string
     end.

  Lemma concat_substring:
     forall k xs,
     k < List.length xs ->
     String.substring
        (natlist_sum (take k (List.map String.length xs)))
        (String.length (List.nth k xs EmptyString))
        (concat xs) =
       List.nth k xs EmptyString.
  Proof.
     intros k xs. revert k.
     induction xs; intros.
     - simpl in H. omega.
     - rewrite List.map_cons.
       rewrite concat_equation.
       destruct k.
       * rewrite take_equation.
         rewrite natlist_sum_equation.
         simpl.
         rewrite substring_append_head_shorter; try omega.
         rewrite entire_substring.
         auto.
       * rewrite take_equation.
         rewrite natlist_sum_equation.
         simpl.
         rewrite substring_append_second; try omega.
         rewrite minus_plus.
         apply IHxs.
         simpl in H.
         omega.
  Qed.

  Lemma concat_length:
     forall xs,
     length (concat xs) = natlist_sum (List.map length xs).
  Proof.
     intros.
     induction xs.
     - simpl. auto.
     - rewrite List.map_cons.
       rewrite concat_equation.
       rewrite natlist_sum_equation.
       rewrite length_append.
       rewrite IHxs.
       auto.
  Qed.

  Lemma concat_in:
     forall x xs,
     List.In x xs ->
     exists m, String.substring m (String.length x) (concat xs) = x.
  Proof.
     intros. revert H. revert x.
     induction xs; intros.
     - simpl in H. contradiction.
     - apply List.in_inv in H.
       destruct H.
       * rewrite H.
         rewrite concat_equation.
         exists 0.
         rewrite substring_append_head_shorter; try omega.
         rewrite entire_substring.
         auto.
       * apply IHxs in H.
         destruct H as [m H].
         rewrite concat_equation.
         exists (length a + m).
         rewrite substring_append_second; try omega.
         rewrite minus_plus.
         auto.
  Qed.

  Function reverse s: string :=
     match s with
     | EmptyString => EmptyString
     | String c s' => ((reverse s') ++ String c EmptyString)%string
     end.

  Lemma length_reverse:
     forall s, String.length (reverse s) = String.length s.
  Proof.
     intro.
     induction s; simpl.
     - auto.
     - rewrite length_append.
       simpl.
       rewrite Nat.add_1_r.
       apply eq_S.
       auto.
  Qed.

  Lemma reverse_cons:
     forall c s,
     reverse (String c s) = (reverse s ++ String c EmptyString)%string.
  Proof.
     intros.
     rewrite reverse_equation.
     auto.
  Qed.

  Lemma cons_reverse:
     forall c s,
     String c (reverse s) = reverse (s ++ String c EmptyString)%string.
  Proof.
     intros.
     induction s.
     - rewrite append_nil_l. simpl. auto.
     - simpl. rewrite <- IHs. rewrite append_comm_cons. auto.
  Qed.

  Lemma reverse_reverse:
     forall s,
     reverse (reverse s) = s.
  Proof.
     intro.
     induction s; simpl.
     - auto.
     - rewrite <- cons_reverse. rewrite cons_eq_cons. auto.
  Qed.

  Function StringMap f s: string :=
     match s with
     | EmptyString => EmptyString
     | String c s' => String (f c) (StringMap f s')
     end.

  Lemma map_identity:
     forall s, StringMap (fun c => c) s = s.
  Proof.
     intro.
     induction s; simpl.
     - auto.
     - rewrite cons_eq_cons. auto.
  Qed.

  Lemma map_length:
     forall s f, String.length (StringMap f s) = String.length s.
  Proof.
     intros; induction s; simpl; try rewrite IHs; auto.
  Qed.

  Lemma map_cons:
     forall c s f, StringMap f (String c s) = String (f c) (StringMap f s).
  Proof.
     intros; destruct s; simpl; auto.
  Qed.

  Lemma map_append:
     forall s1 s2 f,
     StringMap f (s1 ++ s2)%string = (StringMap f s1 ++ StringMap f s2)%string.
  Proof.
     intros.
     induction s1; simpl.
     - auto.
     - rewrite cons_eq_cons. auto.
  Qed.

  Lemma map_reverse:
     forall s f, StringMap f (reverse s) = reverse (StringMap f s).
  Proof.
     intros.
     induction s; simpl.
     - auto.
     - rewrite map_append. rewrite map_cons. rewrite IHs. simpl. auto.
  Qed.

  Inductive StringIn: ascii -> string -> Prop :=
  | string_in_cons_eq: forall c s, StringIn c (String c s)
  | string_in_cons_neq: forall c1 c2 s, StringIn c1 s -> StringIn c1 (String c2 s)
  .

  Inductive StringNotIn: ascii -> string -> Prop :=
  | string_notin_nil: forall c, StringNotIn c EmptyString
  | string_notin_cons: forall c1 c2 s,
       c1 <> c2 -> StringNotIn c1 s -> StringNotIn c1 (String c2 s)
  .

  (* this is redundant XXX *)
  Lemma StringInCons:
     forall c1 c2 s,
     StringIn c1 s -> StringIn c1 (String c2 s).
  Proof.
     intros; inversion H; subst; apply string_in_cons_neq; auto.
  Qed.

  Lemma StringInInv:
     forall c1 c2 s,
     StringIn c1 (String c2 s) -> c1 = c2 \/ StringIn c1 s.
  Proof.
     intros.
     destruct (ascii_dec c1 c2).
     - left; auto.
     - right. inversion H; subst; try contradiction; auto.
  Qed.

  Function StringNth n s def: ascii :=
     match n, s with
     | _, EmptyString => def
     | 0, String c _ => c
     | S n', String _ s' => StringNth n' s' def
     end.

  Lemma StringNthCons:
     forall n s def c,
     StringNth n s def = StringNth (S n) (String c s) def.
  Proof.
     intros. revert n; induction s; intros; destruct n; simpl; auto.
  Qed.

  Lemma StringNthOverflow:
     forall s n def, String.length s <= n -> StringNth n s def = def.
  Proof.
     intro. (* s only *)
     induction s; intros.
     - rewrite StringNth_equation. destruct n; auto.
     - destruct n; try rewrite StringNth_equation; try apply IHs; simpl in H; omega.
  Qed.

  Lemma StringNthIndep:
     forall s n def def', n < String.length s -> StringNth n s def = StringNth n s def'.
  Proof.
     intro. (* s only *)
     induction s; intros.
     - simpl in H. omega.
     - destruct n; rewrite StringNth_equation.
       * rewrite StringNth_equation; auto.
       * simpl. apply IHs. simpl in H. omega.
  Qed.

  Lemma StringNthSCons:
     forall n s def c,
     StringIn (StringNth n s def) s ->
        StringIn (StringNth (S n) (String c s) def) (String c s).
  Proof.
     intros.
     rewrite <- StringNthCons.
     apply StringInCons.
     auto.
  Qed.

  Lemma StringNthIn:
     forall n s def, n < String.length s -> StringIn (StringNth n s def) s.
  Proof.
     intros n s. revert n.
     induction s; intros.
     - simpl in H. omega.
     - destruct n; simpl.
       * apply string_in_cons_eq.
       * apply StringInCons. apply IHs. simpl in H. omega.
  Qed.

  Lemma StringInNth:
     forall s c def,
     StringIn c s -> exists n, n < String.length s /\ StringNth n s def = c.
  Proof.
     intro. (* s only *)
     induction s; intros.
     - inversion H.
     - apply StringInInv in H.
       destruct H.
       * rewrite H. exists 0; split; simpl; try omega; auto.
       * apply IHs with (def := def) in H.
         destruct H as [n H].
         exists (S n).
         simpl.
         rewrite <- Nat.succ_lt_mono.
         auto.
  Qed.

  Lemma StringNthInOrDefault:
     forall n s def, {StringIn (StringNth n s def) s} + {StringNth n s def = def}.
  Proof.
     intros.
     destruct (le_gt_dec (String.length s) n).
     - right; apply StringNthOverflow; auto.
     - left. apply StringNthIn. omega.
  Qed.

  Lemma StringAppNth_l:
     forall s1 s2 def n,
     n < String.length s1 -> StringNth n (s1 ++ s2)%string def = StringNth n s1 def.
  Proof.
     intro. (* s1 only *)
     induction s1; intros; simpl in H.
     - omega.
     - rewrite append_comm_cons.
       destruct n; simpl.
       * auto.
       * apply IHs1. omega.
  Qed.

  Lemma StringAppNth_r:
     forall s1 s2 def n,
     n >= String.length s1 ->
        StringNth n (s1 ++ s2)%string def = StringNth (n - String.length s1) s2 def.
  Proof.
     intro. (* s1 only *)
     induction s1; intros; simpl in H.
     - simpl. rewrite Nat.sub_0_r. auto.
     - rewrite append_comm_cons.
       destruct n; simpl; try apply IHs1; omega.
  Qed.

  Lemma StringNthSplit:
     forall n s def,
     n < String.length s ->
        exists s1 s2,
        s = (s1 ++ String (StringNth n s def) s2)%string /\ String.length s1 = n.
  Proof.
     intros n s. revert n.
     induction s; intros.
     - simpl in H. omega.
     - destruct n.
       * exists EmptyString, s.
         rewrite append_nil_l.
         simpl.
         split; auto.
       * simpl.
         specialize IHs with (n := n) (def := def).
         simpl in H.
         apply lt_S_n in H.
         apply IHs in H.
         destruct H as [s1 [s2 [H1 H2]]].
         exists (String a s1), s2.
         rewrite append_comm_cons.
         rewrite cons_eq_cons.
         simpl.
         rewrite H2.
         split; auto.
  Qed.

  Lemma StringRevNth:
     forall s def n,
     n < String.length s ->
        StringNth n (reverse s) def = StringNth (String.length s - S n) s def.
  Proof.
     intro. (* s only *)
     induction s; intros; simpl in H.
     - omega.
     - simpl.
       destruct (Nat.eq_dec n (String.length s)).
       * subst.
         rewrite StringAppNth_r; rewrite length_reverse; try omega.
         rewrite Nat.sub_diag.
         simpl.
         auto.
       * simpl in H.
         assert (n < length s) by omega.
         rewrite StringAppNth_l; try rewrite length_reverse; auto.
         apply IHs with (def := def) in H0.
         rewrite H0.
         assert (S (length s - S n) = length s - n) by omega.
         rewrite <- H1.
         rewrite <- StringNthCons.
         auto.
  Qed.

  Lemma StringMapNth:
     forall f s def n,
     StringNth n (StringMap f s) (f def) = f (StringNth n s def).
  Proof.
     intros f s. revert f.
     induction s; intros; destruct n; simpl; auto.
  Qed.

  Lemma string_dec:
     forall s1 s2 : string, {s1 = s2} + {s1 <> s2}.
  Proof.
     intro.
     induction s1; intros; destruct s2.
     - left. auto.
     - right. congruence.
     - right. congruence.
     - destruct (ascii_dec a a0); destruct IHs1 with (s2 := s2); subst.
       * left; auto.
       * right; congruence.
       * right; congruence.
       * right; congruence.
  Qed.

  (*
   * string_eq is an executable equality test for strings
   *)
  Function string_eq (s1 s2 : string): bool :=
     match s1, s2 with
     | EmptyString, EmptyString => true
     | String c1 s1', String c2 s2' => ascii_eq c1 c2 && string_eq s1' s2'
     | _, _ => false
     end.

  (* string equality is reflexive *)
  Lemma string_eq_refl:
     forall s, string_eq s s = true.
  Proof.
     intros.
     induction s; simpl; auto.
     rewrite andb_true_iff.
     rewrite ascii_eq_iff.
     auto.
  Qed.

  (* show that string_eq is equivalent to structural equality *)
  Lemma string_eq_iff:
     forall s1 s2, string_eq s1 s2 = true <-> s1 = s2.
  Proof.
     split; revert s2; induction s1; intros; destruct s2; try discriminate; auto.
     - simpl in H.
       rewrite andb_true_iff in H.
       destruct H as [H1 H2].
       apply IHs1 in H2.
       rewrite ascii_eq_iff in H1.
       subst; auto.
     - simpl.
       rewrite andb_true_iff.
       split.
       * rewrite ascii_eq_iff; congruence.
       * rewrite IHs1; auto; congruence.
  Qed.

  (* also nonequality *)
  Lemma string_neq_iff:
     forall s1 s2, string_eq s1 s2 = false <-> s1 <> s2.
  Proof.
     split; revert s2; induction s1; intros; destruct s2;
        try discriminate; try contradiction; auto.
     - simpl in H.
       rewrite andb_false_iff in H.
       destruct H.
       * rewrite ascii_neq_iff in H. congruence.
       * apply IHs1 in H. congruence.
     - simpl.
       rewrite andb_false_iff.
       apply cons_neq_cons_3 in H.
       destruct H.
       * left. rewrite ascii_neq_iff. auto.
       * right. apply IHs1. auto.
  Qed.

End StringFacts.


Require Import general.

Lemma lem_in_app_1 : forall {A} (a x : A) l l', In a (l ++ x :: l') -> a = x \/ In a l \/ In a l'.
Proof.
  Reconstr.hsimple Reconstr.Empty
		   (@Coq.Lists.List.in_app_or, @Coq.Lists.List.in_inv)
		   Reconstr.Empty.
Qed.

Definition at_lem_in_app_1 {A} (a : A) := lem_in_app_1 a.

Lemma lem_in_app_2 : forall {A} (a x : A) l l', a = x \/ In a l \/ In a l' -> In a (l ++ x :: l').
Proof.
  Reconstr.htrivial Reconstr.Empty
	(@Coq.Lists.List.in_or_app, @Coq.Lists.List.in_cons)
	Reconstr.Empty.
  induction l; ycrush.
Qed.

Definition at_lem_in_app_2 {A} (a : A) := lem_in_app_2 a.

Lemma lem_skipn_length : forall {A} n (l : list A), n + length (skipn n l) >= length l.
Proof.
  induction n.
  ycrush.
  destruct l; simpl in *.
  omega.
  generalize (IHn l); omega.
Qed.

Lemma lem_firstn_len : forall {A : Type} (l : list A) l', firstn (length l) (l ++ l') = l.
Proof.
  induction l; ycrush.
Qed.

Lemma lem_skipn_len : forall {A : Type} (l : list A) l', skipn (length l) (l ++ l') = l'.
Proof.
  induction l; ycrush.
Qed.

Lemma lem_skipn_nonempty : forall {A} n (l : list A), n < length l -> is_nonempty (skipn n l).
Proof.
  intro A.
  assert (forall k n (l : list A), k + n = length l -> k > 0 -> is_nonempty (skipn n l)).
  induction k.
  ycrush.
  intros.
  pose (lem_skipn_length n l).
  assert (length (skipn n l) > 0) by omega.
  clear -H1.
  destruct (skipn n l); ycrush.
  intros; apply (H (length l - n)); omega.
Qed.

Lemma lem_firstn_preserves_elements : forall {A} n (l : list A) x, In x (firstn n l) -> In x l.
Proof.
  induction n; ycrush.
Qed.

Lemma lem_skipn_preserves_elements : forall {A} n (l : list A) x, In x (skipn n l) -> In x l.
Proof.
  induction n; ycrush.
Qed.

Lemma lem_map_preserves_length : forall {A} (f : A -> A) l, length (map f l) = length l.
Proof.
  Reconstr.htrivial Reconstr.Empty
		    (@Coq.Lists.List.map_length)
		    Reconstr.Empty.
Qed.

Lemma lem_map_preserves_elements :
  forall {A} {B} (f : A -> B) (P : B -> Prop) l, (forall x, In x l -> P (f x)) ->
                                                 forall x, In x (map f l) -> P x.
Proof.
  Reconstr.hcrush Reconstr.Empty
	          (@Coq.Lists.List.in_map_iff)
	          Reconstr.Empty.
Qed.

Lemma lem_len_app : forall (A : Type) (l : list A) l', length l' > 0 -> length l < length (l ++ l').
Proof.
  induction l.
  ycrush.
  simpl; yintros; omega.
Qed.

Lemma lem_all_append : forall (A : Type) (P : A -> Prop) l l', (forall x, In x l -> P x) ->
                                                               (forall x, In x l' -> P x) ->
                                                               forall x, In x (l ++ l') -> P x.
Proof.
  induction l; ycrush.
Qed.

Inductive list_closure {A : Type} (R : A -> A -> Prop) : list A -> list A -> Prop :=
| lc_base : list_closure R nil nil
| lc_step : forall x x' l l', R x x' -> list_closure R l l' -> list_closure R (x :: l) (x' :: l').

Lemma lem_list_closure_refl : forall {A : Type}
                                     (R : A -> A -> Prop), (forall x, R x x) ->
                                                           forall l, list_closure R l l.
Proof.
  induction l; pose @lc_base; pose @lc_step; ycrush.
Qed.

Lemma lem_list_closure_step :
  forall {A : Type} (R : A -> A -> Prop), (forall x, R x x) ->
                                       forall x x' l l', R x x' -> list_closure R (l ++ x :: l')
                                                                                (l ++ x' :: l').
Proof.
  induction l; pose @lc_base; pose @lc_step; pose @lem_list_closure_refl; ycrush.
Qed.

Lemma lem_list_closure_trans :
  forall {A : Type} (R : A -> A -> Prop), (forall x y z, R x y -> R y z -> R x z) ->
                                       forall l2 l1 l3, list_closure R l1 l2 ->
                                                        list_closure R l2 l3 ->
                                                        list_closure R l1 l3.
Proof.
  induction l2.
  pose @lc_base; pose @lc_step; ycrush.
  intros.
  yinversion H0.
  yinversion H1.
  pose @lc_base; pose @lc_step; ycrush.
Qed.

Ltac pose_lc := pose @lc_base; pose @lc_step;
                pose @lem_list_closure_refl; pose @lem_list_closure_trans;
                pose @lem_list_closure_step.


(**

Definition natural number objects (NNO's)

This is related to the initial algebra definition in FunctorAlgebras.v

Written by: Anders Mörtberg, 2018

*)
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.limits.terminal.

Local Open Scope cat.

Section nno.

Context {C : category} (TC : Terminal C).

Local Notation "1" := TC.

Definition isNNO (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧) : hProp.
Proof.
use tpair.
- exact (∏ (a : C) (q : C ⟦ 1, a ⟧) (f : C ⟦ a, a ⟧),
         ∃! u : C ⟦ n, a ⟧, (z · u = q) × (s · u = u · f)).
- abstract (repeat (apply impred_isaprop; intros); apply isapropiscontr).
Defined.

Definition NNO : UU :=
  ∑ (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧), isNNO n z s.

Definition NNObject (n : NNO) : C := pr1 n.
Coercion NNObject : NNO >-> ob.

Definition zeroNNO (n : NNO) : C ⟦1,n⟧ := pr1 (pr2 n).
Definition sucNNO (n : NNO) : C ⟦n,n⟧ := pr1 (pr2 (pr2 n)).

Lemma isNNO_NNO (n : NNO) : isNNO n (zeroNNO n) (sucNNO n).
Proof.
exact (pr2 (pr2 (pr2 n))).
Qed.

Definition make_NNO (n : C) (z : C ⟦ 1, n ⟧) (s : C ⟦ n, n ⟧)
 (h : isNNO n z s) : NNO := (n,,z,,s,,h).

Definition hasNNO : hProp := ∥ NNO ∥.

End nno.


Require Import Common.exceptionMonad.
Require Import Common.certiClasses.
Require Import Coq.Unicode.Utf8.
Require Import List.
Generalizable Variables Src Dst Inter Term Value SrcValue DstValue InterValue.

From MetaCoq.Template Require BasicAst.
Require Import Coq.btauto.Btauto.
Require Import Morphisms.

Global Instance  liftLeRefl {A:Type} (R: A -> A -> Prop)
  {rl: Reflexive R} : Reflexive (liftLe R).
Proof using.
  intros x. destruct x; constructor; auto.
Defined.

(** Some values, e.g. constructors, can have subterms.
   This operation allows asking for the nth subterm.
   When trying to observe the nth subterm of a value having only m (m<n)
   subterms, all bets are off about the returned value.
 *)
Class ObserveNthSubterm (Value:Type) :=
  observeNthSubterm: nat -> Value -> option Value.

Section YesNoQuestions.

(* Zoe's suggestion for Question *)
Inductive Question : Set  :=
| Cnstr : BasicAst.inductive -> nat -> Question
| Abs : Question.

(** Given a value of a language, we can observe it by asking it yes/no
questions.
 [Cnstr i n] represents the question "Are you the nth constructor
      of the inductive i?".
 [Abs] represents the question "Are you an abstraction
    (do you represent a lambda or fixpoint)?".
A value can respond "yes" to many such questions.
Thus, the compiler is allowed to to use the same representation for
different types.

Regarding Erasure:
If a value [v] has sort Prop, then in L1g,
  [questionHead _ v is] supposed to be false.
We can then do whatever we want with such values.
Another choice is that if a value [v] is a constructor
(and not, e.g., a lambda or fix) of sort Prop, then in L1g,
[questionHead _ v is] supposed to be false.

After erasure,
  [questionHead (Cnstr _ _) \box] is false
  [questionHead Abs \box] is true.
Note that \box eventually becomes a fixpoint.
*)
Class QuestionHead (Value:Type) := questionHead: Question -> Value -> bool.

(** A value in the destination should say "yes" to all the questions
   to which the corresponding source value said "yes"
**)
Definition yesPreserved
           `{QuestionHead SrcValue} `{QuestionHead DstValue}
           (s: SrcValue) (d: DstValue) :=
  forall (q:Question), implb (questionHead q s) (questionHead q d) = true.

Section ObsLe.

(* Typically, Src=SrcValue *)
Context `{QuestionHead SrcValue} `{ObserveNthSubterm SrcValue}
   `{QuestionHead DstValue} `{ObserveNthSubterm DstValue}.

(* obsLe extends yesPreserved to corresponding subterms *)
(* Coinductive, in case we add support for Coq's coinductive types later on.
Currently, [Inductive] should suffice
*)
CoInductive obsLe : SrcValue -> DstValue -> Prop :=
| sameObs : forall (s : SrcValue) (d : DstValue),
    yesPreserved s d
    -> (forall n:nat, obsLeOp (observeNthSubterm n s) (observeNthSubterm n d))
    -> obsLe s d
with obsLeOp : option SrcValue -> option DstValue -> Prop :=
(* defining this using pattern matching confuses the strict positivity checker.
  TODO: consider using liftLe *)
| obsSome: forall s d, obsLe s d -> obsLeOp (Some s) (Some d)
| obsNone: forall d, obsLeOp None d.

(** Sometimes, the greatest fixedpoint is obtained at \omega.
*)
Inductive obsLeInd : nat -> SrcValue -> DstValue -> Prop :=
| obsLeS: forall m (s : SrcValue) (d : DstValue),
    yesPreserved s d
    -> (forall n:nat, liftLe (obsLeInd m) (observeNthSubterm n s) (observeNthSubterm n d))
    -> obsLeInd (S m) s d
| obsLeO: forall s d, obsLeInd O s d. (** \top element in the space of relations *)

(** this part is generally easy and unconditional *)
Lemma fromCoInd s d:
  obsLe s d -> forall m, obsLeInd m s d.
Proof using.
  intros Hc m. revert Hc. revert s. revert d.
  induction m as [ | m Hind]; intros ? ? Hc;
    [ constructor; fail
    | destruct Hc as [? ? Hyes Hsub];
      constructor; [ assumption | ] ].
  intros n. specialize (Hsub n).
  inversion Hsub; subst; clear Hsub; constructor; eauto.
Qed.

(** This part is generally hard and conditional.
Here, it is unconditional. [obsLe] does not depend on computations.
However, in certiclasses3, where obsLe mentions computation, we may need the
big step eval in LambdaANF to be deterministic.
*)
Lemma toCoInd s d:
  (forall m, obsLeInd m s d) -> obsLe s d.
Proof using.
  revert s d.
  cofix toCoInd. intros ? ? Hi. pose proof Hi as Hib.
  specialize (Hi 1); inversion Hi as [ ? ? ? Hyes Hsub | ]; subst. clear Hi.
  constructor; [ assumption | ].
  intros ?.
  specialize (Hsub n).
  inversion Hsub; subst; clear Hsub; constructor.
  apply toCoInd. revert H3. revert H4. revert Hib.
  clear.
  intros.
  specialize (Hib (S m)).
  inversion Hib as  [ ? ? ? _ Hsubb | ]. subst. clear Hib.
  specialize (Hsubb n).
  rewrite <- H3, <- H4 in Hsubb.
  inversion Hsubb. assumption.
Qed.

Global Instance  yesPreservedRefl: Reflexive (@yesPreserved SrcValue _ SrcValue _).
Proof using.
  intros x q. unfold implb. btauto.
Qed.

End ObsLe.

Notation "s ⊑ t" := (obsLe s t) (at level 65).

Class CerticoqLanguage (Term Value:Type)
  `{BigStepOpSem Term Value} `{GoodTerm Term}
   `{QuestionHead Value} `{ObserveNthSubterm Value}
:=
{
  (* Sensible, but not needed yet.
  goodPreserved : forall (s v : Term),
    goodTerm s
    -> s ⇓ v
    -> goodTerm v
  *)
}.

Global Arguments CerticoqLanguage Term Value {H} {H0} {H1} {H2}.

(* The final correctness property is just the conjunction of goodPreserving and obsPreserving.
The lemma [composeCerticoqTranslationCorrect] below
shows that composes correctness proofs of adjacent translations. *)
Class CerticoqTranslationCorrect
  `{CerticoqLanguage Src SrcValue}
  `{CerticoqLanguage Dst DstValue}
  `{CerticoqTranslation Src Dst} :=
{
  certiGoodPres2 : goodPreserving Src Dst;
  obsePres : obsPreserving Src Dst obsLe;
}.

Global Arguments CerticoqTranslationCorrect
  {Src} {SrcValue} {H} {H0} {H1} {H2} H3 {Dst} {DstValue} {H4} {H5} {H6} {H7} H8 {H9}.

Lemma yesPreservedTransitive {SrcValue InterValue DstValue:Type}
         `{QuestionHead SrcValue}
   `{QuestionHead InterValue}
   `{QuestionHead DstValue}
      (s : SrcValue) (i : InterValue) (d : DstValue):
  yesPreserved s i
  -> yesPreserved i d
  -> yesPreserved s d.
Proof using.
  unfold yesPreserved. intros Hyesi Hyesd q.
  specialize (Hyesi q).
  specialize (Hyesd q).
  destruct (questionHead q s); simpl in *;[| reflexivity].
  rewrite Hyesi in Hyesd. assumption.
Qed.

Lemma obsLeTrns
   `{QuestionHead SrcValue} `{ObserveNthSubterm SrcValue}
   `{QuestionHead InterValue} `{ObserveNthSubterm InterValue}
   `{QuestionHead DstValue} `{ObserveNthSubterm DstValue} :
   forall   (s : SrcValue) (i : InterValue) (d : DstValue),
  s ⊑ i
  -> i ⊑ d
  -> s ⊑ d.
Proof.
  (************
  induction 1. intros.
  constructor.  Set Printing All.
  - unfold yesPreserved. intros.
    unfold yesPreserved in H5. specialize (H5 q).
    inversion H7. subst.
    unfold yesPreserved in H8. specialize (H8 q).
    inversion H7. subst.
    unfold yesPreserved in H10. specialize (H10 q).
    unfold implb in *.
**********)
  cofix obsLeTrns.
  intros ? ? ? Ha Hb.
  inversion Ha as [ss is Hah Has]. subst. clear Ha.
  inversion Hb as [is ds Hbh Hbs]. subst. clear Hb.
  constructor; auto;
    [eauto using (@yesPreservedTransitive SrcValue InterValue DstValue); fail
    |].
 clear Hah Hbh. intros n.
  specialize (Has n).
  specialize (Hbs n).
  destruct Has;[| constructor ].
  inversion Hbs. subst. clear Hbs.
  constructor. eauto.
Qed.

Global Instance composeCerticoqTranslationCorrect
  `{Ls: CerticoqLanguage Src SrcValue}
  `{Li: CerticoqLanguage Inter InterValue}
  `{Ld: CerticoqLanguage Dst DstValue}
  {t1 : CerticoqTranslation Src Inter}
  {t2 : CerticoqTranslation Inter Dst}
(* we don't need a translation for the value type, although typically Src=SrcValue*)
  {Ht1: CerticoqTranslationCorrect Ls Li}
  {Ht2: CerticoqTranslationCorrect Li Ld}
    : CerticoqTranslationCorrect Ls Ld.
Proof.
  destruct Ht1, Ht2.
  constructor;[eapply composePreservesGood; eauto; fail|].
  intros ? ? ? Hgood Hev.
  unfold goodPreserving, obsPreserving in *.
  eapply obsePres0 with (o:=o) in Hev; [| assumption].
  eapply certiGoodPres3 with (o:=o) in Hgood.
  unfold composeTranslation, translate in *.
  destruct (t1 o s); compute in Hev; try contradiction.
  destruct Hev as [iv Hev].
  destruct Hev as [Hev Hoeq].
  edestruct obsePres1 with (o:=o) as [dv [Hsd Hsubd]].
  now apply Hgood. eassumption.

  exists dv. compute.
  compute in Hsd. split;[tauto|].
  eapply obsLeTrns with (i0 := iv); assumption.
Qed.

End YesNoQuestions.

Notation "s ⊑ t" := (obsLe s t) (at level 65).

(** Here are some other correctness properties that we may be interested in: *)

(** A translation can be proved correct trivially if the questionHead function
in the destination says yes to everything. This property of
the questionHead function enforces that
if it says "yes" to some constructor of an inductive type, it must say
"no" to all other constructors of the SAME inductive type
**)

Definition nonTrivialQuestionHead (Value : Type)
  `{@QuestionHead Value} : Prop:=
forall (v:Value) (i: BasicAst.inductive) n,
  (questionHead (Cnstr i n) v = true)
  -> forall m, m<>n ->  questionHead (Cnstr i m) v = false.

(** We can also ask every language to declare their notion of application
as a function of type Term->Value->Term.
Then, in obsLe, we can also exploit
observations on values resulting from applications of functions to values.
**)

(* can be used to get the Term type from an instance *)
Definition cTerm `{CerticoqLanguage Term Value} : Type := Term.
(* can be used to get the Value type from an instance *)
Definition cValue `{CerticoqLanguage Term Value} : Type := Value.

Arguments cTerm {Term} {Value} {H} {H0} {H1} {H2} _.
Arguments cValue {Term} {Value} {H} {H0} {H1} {H2} _.

Arguments CerticoqLanguage Term {Value} {H} {H0} {H1} {H2}.

Definition evalPreservesGoodness `{Ls: BigStepOpSem Src SrcValue}
  `{GoodTerm Src} `{GoodTerm SrcValue} :=
  forall (s:Src) (sv: SrcValue),
    s ⇓ sv -> goodTerm s -> goodTerm sv.

(* This can be typically be easily proven by induction on sv *)
Definition valueTypeTranslateLe (SrcValue DstValue : Type)
           `{CerticoqTranslation SrcValue DstValue}
           `{QuestionHead SrcValue}
           `{QuestionHead DstValue}
           `{ObserveNthSubterm SrcValue}
           `{ObserveNthSubterm DstValue} : Prop :=
  forall (o: Opt) (sv: SrcValue) (dv: DstValue),
    translate _ DstValue o sv = Ret dv -> sv ⊑ dv.

Lemma certicoqTranslationCorrect_suff1
  `{Ls: CerticoqLanguage Src SrcValue}
  `{Ld: CerticoqLanguage Dst DstValue}
  {t1 : CerticoqTranslation Src Dst}
  {t1v : CerticoqTranslation SrcValue DstValue}
  (bgs : bigStepPreserving Src Dst)
  (gp: goodPreserving Src Dst)
  (vt : valueTypeTranslateLe SrcValue DstValue)
  :
  CerticoqTranslationCorrect Ls Ld.
Proof using.
  constructor;[assumption|].
  intros ? ? ? Hgs Hev.
  unfold bigStepPreserving in *.
  eapply bgs with (o:=o) in Hev;[| assumption].
  hnf in Hev.
  specialize (gp s o Hgs).
  specialize (vt o sv).
  destruct (translate Src Dst o s); simpl in *; try contradiction.
  destruct (translate SrcValue DstValue o sv) as [ | dv]; simpl in *; try contradiction.
  eauto.
Qed.

(* For the case when the type of terms and values is the same. In many lemmas
  IsValue only needs to be complete (not sound) *)
Definition valuePredTranslateLe (Src Dst : Type)
           `{CerticoqTranslation Src Dst}
           `{IsValue Src}
           `{QuestionHead Src}
           `{QuestionHead Dst}
           `{ObserveNthSubterm Src}
           `{ObserveNthSubterm Dst} : Prop :=
  forall (o: Opt) (sv: Src) (dv: Dst),
    isValue sv -> translate _ Dst o sv = Ret dv -> sv ⊑ dv.

Lemma certicoqTranslationCorrect_suff2
  `{Ls: CerticoqLanguage Src SrcValue}
  `{Ld: CerticoqLanguage Dst DstValue}
  {t1 : CerticoqTranslation Src Dst}
  {t1v : CerticoqTranslation SrcValue DstValue}
  (bgs : bigStepPreserving Src Dst)
  (gp: goodPreserving Src Dst)
  {isv : IsValue SrcValue}
  (vt : valuePredTranslateLe SrcValue DstValue)
  (isvc : IsValueComplete) (* soundness is not needed. *)
  :
  CerticoqTranslationCorrect Ls Ld.
Proof using.
  constructor;[assumption|].
  intros ? ? ? Hgs Hev.
  pose proof Hev as Hevb.
  unfold bigStepPreserving in bgs.
  eapply bgs with (o:=o) in Hev;[| assumption].
  apply isvc in Hevb.
  hnf in Hev.
  specialize (gp s o Hgs).
  specialize (vt o sv).
  destruct (translate Src Dst o s); simpl in *; try contradiction.
  destruct (translate SrcValue DstValue o sv) as [ | dv]; simpl in *; try contradiction.
  eauto.
Qed.

Definition valuePredTranslateYesPreserved (Src Dst : Type)
           `{CerticoqTranslation Src Dst}
           `{IsValue Src}
           `{QuestionHead Src}
           `{QuestionHead Dst}
           `{ObserveNthSubterm Src}
           `{ObserveNthSubterm Dst} : Prop :=
  forall (o:Opt) (sv: Src) (dv: Dst),
    isValue sv -> translate _ Dst o sv = Ret dv ->
    yesPreserved sv dv.

Definition valuePredTranslateObserveNthCommute (Src Dst : Type)
           `{CerticoqTranslation Src Dst}
           `{IsValue Src}
           `{QuestionHead Src}
           `{QuestionHead Dst}
           `{ObserveNthSubterm Src}
           `{ObserveNthSubterm Dst} : Prop :=
  forall (o:Opt) (sv: Src) (dv: Dst) n,
    isValue sv -> translate _ Dst o sv = Ret dv ->
    option_map (translate _ Dst o) (observeNthSubterm n sv) =
    option_map (@Ret _) (observeNthSubterm n dv)
    /\ (match (observeNthSubterm n sv)  with
       | Some s => isValue s
       | None => True
       end).

Require Import SquiggleEq.LibTactics.
Require Import SquiggleEq.tactics.
Lemma valuePredTranslateLe_suff  (Src Dst : Type)
           `{CerticoqTranslation Src Dst}
           `{IsValue Src}
           `{QuestionHead Src}
           `{QuestionHead Dst}
           `{ObserveNthSubterm Src}
           `{ObserveNthSubterm Dst} :
  valuePredTranslateObserveNthCommute Src Dst
  -> valuePredTranslateYesPreserved Src Dst
  -> valuePredTranslateLe Src Dst.
Proof using.
  intros Ho Hy.
  cofix valuePredTranslateLe_suff.
  intros ? ? ? Hv Ht.
  constructor;[eauto|].
  intros.
  specialize (Ho o _ _ n Hv Ht).
  destruct (observeNthSubterm n sv);[| constructor].
  simpl in Ho. repnd.
  destruct (observeNthSubterm n dv); inverts Ho0.
  constructor.
  eapply valuePredTranslateLe_suff; eauto.
Qed.

Lemma certicoqTranslationCorrect_suff3
  `{Ls: CerticoqLanguage Src SrcValue}
  `{Ld: CerticoqLanguage Dst DstValue}
  {t1 : CerticoqTranslation Src Dst}
  {t1v : CerticoqTranslation SrcValue DstValue}
  {isv : IsValue SrcValue}
  (bgs : bigStepPreserving Src Dst)
  (gp: goodPreserving Src Dst)
  (vty : valuePredTranslateYesPreserved SrcValue DstValue)
  (vto : valuePredTranslateObserveNthCommute SrcValue DstValue)
  (isvc : IsValueComplete) (* soundness is not needed. *)
  :
  CerticoqTranslationCorrect Ls Ld.
Proof using.
  eapply valuePredTranslateLe_suff in vto; eauto;[].
  clear vty.
  eapply certicoqTranslationCorrect_suff2; eauto.
Qed.


(** This is a port of Go's crypto/sha256. *)

From Coq Require Import NArith ZArith Lia Int63.
From Coq Require Import String HexString.

From EVM Require Import Nibble UInt64.
From EVM Require Tuplevector Vec8.

Definition output_size := 32.
Definition block_size := 64.

Definition vec8_add (a b: Vec8.t int)
:= let 'Vec8.Vec8 a0 a1 a2 a3 a4 a5 a6 a7 := a in
   let 'Vec8.Vec8 b0 b1 b2 b3 b4 b5 b6 b7 := b in
   (Vec8.Vec8 (a0 + b0) (a1 + b1) (a2 + b2) (a3 + b3)
              (a4 + b4) (a5 + b5) (a6 + b6) (a7 + b7))%int63.

Definition init_hex: Vec8.t string
:= (Vec8.Vec8 "0x6A09E667"
              "0xBB67AE85"
              "0x3C6EF372"
              "0xA54FF53A"
              "0x510E527F"
              "0x9B05688C"
              "0x1F83D9AB"
              "0x5BE0CD19")%string.

Definition init := Vec8.map Int63.of_Z (Vec8.map HexString.to_Z init_hex).

Definition K_hex: Vec8.t (Vec8.t string)
:= (Vec8.Vec8 (Vec8.Vec8 "0x428a2f98" "0x71374491" "0xb5c0fbcf" "0xe9b5dba5"
                         "0x3956c25b" "0x59f111f1" "0x923f82a4" "0xab1c5ed5")
              (Vec8.Vec8 "0xd807aa98" "0x12835b01" "0x243185be" "0x550c7dc3"
                         "0x72be5d74" "0x80deb1fe" "0x9bdc06a7" "0xc19bf174")
              (Vec8.Vec8 "0xe49b69c1" "0xefbe4786" "0x0fc19dc6" "0x240ca1cc"
                         "0x2de92c6f" "0x4a7484aa" "0x5cb0a9dc" "0x76f988da")
              (Vec8.Vec8 "0x983e5152" "0xa831c66d" "0xb00327c8" "0xbf597fc7"
                         "0xc6e00bf3" "0xd5a79147" "0x06ca6351" "0x14292967")
              (Vec8.Vec8 "0x27b70a85" "0x2e1b2138" "0x4d2c6dfc" "0x53380d13"
                         "0x650a7354" "0x766a0abb" "0x81c2c92e" "0x92722c85")
              (Vec8.Vec8 "0xa2bfe8a1" "0xa81a664b" "0xc24b8b70" "0xc76c51a3"
                         "0xd192e819" "0xd6990624" "0xf40e3585" "0x106aa070")
              (Vec8.Vec8 "0x19a4c116" "0x1e376c08" "0x2748774c" "0x34b0bcb5"
                         "0x391c0cb3" "0x4ed8aa4a" "0x5b9cca4f" "0x682e6ff3")
              (Vec8.Vec8 "0x748f82ee" "0x78a5636f" "0x84c87814" "0x8cc70208"
                         "0x90befffa" "0xa4506ceb" "0xbef9a3f7" "0xc67178f2"))%string.
Definition K := Vec8.map (Vec8.map (fun hex => Int63.of_Z (HexString.to_Z hex))) K_hex.

(** Calculate the padding length given the data length. *)
Definition padding_length (data_length: N)
: N
:= let m := (data_length mod 64)%N in
   if (m <? 56)%N
      then (56 - m)%N
      else (64 + 56 - m)%N.

Lemma padding_length_nonzero (len: N):
  padding_length len <> 0%N.
Proof.
unfold padding_length.
remember (_ <? _)%N as c. symmetry in Heqc.
destruct c.
{ rewrite N.ltb_lt in Heqc. lia. }
rewrite N.ltb_ge in Heqc.
assert (F: (64 <> 0)%N) by discriminate.
assert (B := N.mod_upper_bound len 64 F).
lia.
Qed.

Lemma padding_length_ok (len: N):
  ((len + padding_length len) mod 64 = 56)%N.
Proof.
unfold padding_length.
assert (F: (64 <> 0)%N) by discriminate.
assert (B := N.mod_upper_bound len 64 F).
rewrite N.add_mod by discriminate.
rewrite N.add_mod_idemp_r by discriminate.
remember (len mod 64)%N as n.
remember (_ <? _)%N as c. symmetry in Heqc.
destruct c.
{
  rewrite N.ltb_lt in Heqc.
  replace (n + (56 - n))%N with 56%N. { easy. }
  lia.
}
rewrite N.ltb_ge in Heqc.
replace (n + (64 + 56 - n))%N with (64 + 56)%N. { easy. }
lia.
Qed.

Definition padding (len: N)
:= match N.to_nat len with
   | O => nil
   | S k => (byte_of_int 128 :: List.repeat (byte_of_int 0) k)%list
   end.

Lemma padding_ok (len: N):
  N.of_nat (List.length (padding len)) = len.
Proof.
unfold padding.
destruct len. { easy. }
rewrite positive_N_nat.
assert (P := Pos2Nat.is_pos p).
rewrite<- positive_nat_N.
remember (Pos.to_nat p) as n.
destruct n. { now apply Nat.lt_irrefl in P. }
cbn. now rewrite List.repeat_length.
Qed.

Definition pad (data: list byte)
: list byte
:= let len := N.of_nat (List.length data) in
   let len_in_bits := N.shiftl len 3 in
   data
    ++
   padding (padding_length len)
    ++
   Tuplevector.app_to_list
    (uint64_to_be_bytes
      (uint64_of_Z_mod
        (Z.of_N len_in_bits)): Tuplevector.t _ 8)
    nil.

Lemma pad_ok_mod (data: list byte):
  ((N.of_nat (List.length (pad data))) mod 64 = 0)%N.
Proof.
unfold pad.
repeat rewrite List.app_length.
rewrite Tuplevector.app_to_list_length.
repeat rewrite Nat2N.inj_add.
rewrite N.add_assoc.
rewrite N.add_mod by discriminate.
cbn.
remember (N.of_nat (List.length data)) as n.
rewrite padding_ok.
rewrite padding_length_ok.
trivial.
Qed.

Lemma pad_ok (data: list byte):
  let d := (List.length (pad data) / 64)%nat in
    (List.length (pad data) = d * 64)%nat.
Proof.
apply Nat2N.inj.
assert (M := pad_ok_mod data).
remember (List.length  _) as len. clear Heqlen.
match goal with |- ?lhs = ?rhs => rewrite<- (N.add_0_r rhs) end.
rewrite<- M.
rewrite Nat.mul_comm.
rewrite Nat2N.inj_mul.
rewrite Arith2.Nat2N_inj_div.
apply N.div_mod.
subst. discriminate.
Qed.

Lemma can_gather_by_4 (n: nat):
  (n = n / 64 * 64  ->  n = (n / 64 * 16) * 4)%nat.
Proof.
now rewrite<- Nat.mul_assoc.
Qed.

Definition int_of_4_le_bytes (b: byte * byte * byte * byte)
: int
:= let '(b0, b1, b2, b3) := b in
   ((int_of_byte b3 << 24) lor
    (int_of_byte b2 << 16) lor
    (int_of_byte b1 <<  8) lor
    (int_of_byte b0))%int63.

Definition pad_and_gather_into_uint32s (data: list byte)
:= let padded := pad data in
   let PadOk  := pad_ok data in
   List.map int_of_4_le_bytes (* gather flips the tuples *)
            (Tuplevector.gather padded _ 4 (can_gather_by_4 _ PadOk)).

Lemma pad_and_gather_into_uint32s_length (data: list byte):
  let d := (List.length (pad data) / 64)%nat in
    (List.length (pad_and_gather_into_uint32s data) = d * 16)%nat.
Proof.
unfold pad_and_gather_into_uint32s.
rewrite List.map_length.
apply (Tuplevector.gather_length (pad data) (Datatypes.length (pad data) / 64 * 16) 4
     (can_gather_by_4 (Datatypes.length (pad data)) (pad_ok data))).
Qed.

Definition vec64 (T: Type) := Vec8.t (Vec8.t T).

Definition block_of_tuple (block: Tuplevector.t int 16)
: vec64 int
:= let z := (Vec8.Vec8 0 0 0 0 0 0 0 0)%int63 in
   let '(bF, bE, bD, bC, bB, bA, b9, b8, b7, b6, b5, b4, b3, b2, b1, b0) := block in
   Vec8.Vec8 (Vec8.Vec8 b0 b1 b2 b3 b4 b5 b6 b7) (Vec8.Vec8 b8 b9 bA bB bC bD bE bF) z z z z z z.

Definition blocks (data: list byte)
: list (vec64 int)
:= List.map block_of_tuple
            (Tuplevector.gather (pad_and_gather_into_uint32s data)
                                _ 16
                                (pad_and_gather_into_uint32s_length data)).

Definition vec64_get {T: Type} (v: vec64 T) (i: int)
:= Vec8.get (Vec8.get v (i >> 3)%int63) i.

Definition vec64_set {T: Type} (v: vec64 T) (i: int) (new: T)
:= let hi := (i >> 3)%int63 in
   Vec8.set v hi (Vec8.set (Vec8.get v hi) i new).

Definition uint32_mask := ((1 << 32) - 1)%int63.

Definition shr (i sh: int) := ((i land uint32_mask) >> sh)%int63.
Definition rot (i sh: int) := (shr i sh lor (i << (32 - sh)))%int63.

Fixpoint calc_w_rec (n: nat) (start: vec64 int)
:= match n with
   | O => start
   | S k => (let w := calc_w_rec k start in
             let i := Int63.of_Z (Z.of_nat n + 15)%Z in
             let v1 := vec64_get w (i -  2)%int63 in
             let t1 := (rot v1 17) lxor (rot v1 19) lxor (shr v1 10) in
             let v2 := vec64_get w (i - 15)%int63 in
             let t2 := (rot v2 7) lxor (rot v2 18) lxor (shr v2 3) in
             vec64_set w i (t1 + vec64_get w (i-7) + t2 + vec64_get w (i-16)))%int63
   end.
Definition calc_w (w: vec64 int) := calc_w_rec 48 w.

Fixpoint do_block_rec (n: nat) (initial_state: Vec8.t int) (w_after_calc: vec64 int)
: Vec8.t int
:= match n with
   | O => initial_state
   | S k => let state := do_block_rec k initial_state w_after_calc in
            let i := Int63.of_Z (Z.of_nat k) in
            let 'Vec8.Vec8 a b c d e f g h := state in
            (let t1 := h + ((rot e 6) lxor (rot e 11) lxor (rot e 25))
                         + ((e land f) lxor ((e lxor uint32_mask) land g))
                         + vec64_get K i
                         + vec64_get w_after_calc i in
             let t2 := ((rot a 2) lxor (rot a 13) lxor (rot a 22))
                         + ((a land b) lxor (a land c) lxor (b land c)) in
             Vec8.Vec8 (t1 + t2) a b c (d + t1) e f g)%int63
   end.
Definition do_block (state: Vec8.t int) (w: vec64 int)
:= do_block_rec 64 state w.

Definition absorb_block (state: Vec8.t int) (w: vec64 int)
:= vec8_add state (do_block state (calc_w w)).

Definition absorb (data: list byte)
:= List.fold_left absorb_block (blocks data) init.

Definition be_4_bytes_of_int (i: int)
:= (byte_of_int (i >> 24)
 :: byte_of_int (i >> 16)
 :: byte_of_int (i >> 8)
 :: byte_of_int i :: nil)%list%int63.

Definition squeeze (state: Vec8.t int)
:= List.concat (List.map be_4_bytes_of_int (Vec8.to_list state)).

Definition sha256 (data: list byte)
: list byte
:= squeeze (absorb data).

Definition sha256_of_string (s: String.string)
:= sha256 (bytes_of_string s).

Definition sha256_hex (data: list byte)
: String.string
:= hex_of_bytes (sha256 data) true.

Definition sha256_hex_of_string (s: String.string)
: String.string
:= hex_of_bytes (sha256_of_string s) true.

(* This test is from Go's sha256_test.go. *)
Example smoke_test:
  sha256_hex_of_string
    "For every action there is an equal and opposite government program."
   =
  "23b1018cd81db1d67983c5f7417c44da9deb582459e378d7a068552ea649dc9f"%string.
Proof. trivial. Qed.