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

Require Import Bool.

Require Import tacs rel square cl cl_eq cl_confluent.

Set Implicit Arguments.

(* The notation of reduction in combinatory logic *)

Reserved Notation "x '-b->' y" (at level 70).

Inductive cl_beta : clterm -> clterm -> Prop :=

  | in_cl_beta_I   : forall x,     I o x          -b-> x

  | in_cl_beta_K   : forall x y,   K o x o y      -b-> x

  | in_cl_beta_S   : forall x y z, S o x o y o z  -b-> x o z o (y o z)

  | in_cl_beta_lft : forall f g a,          f     -b-> g
                                         -> f o a -b-> g o a

  | in_cl_beta_rt  : forall f a b,              a -b->     b
                                         -> f o a -b-> f o b

where "x -b-> y" := (cl_beta x y).

Notation "x '-b>>' y" := (crt cl_beta x y) (at level 70).
Notation "x '~b' y" := (crst cl_beta x y) (at level 70).

Fact cl_beta_rt_beta_eq f g : f -b>> g -> f ~b g.
Proof. apply crt_inc_crst. Qed.

Fact cl_beta_cl_eq f g : f -b-> g -> f ~cl g.
Proof.
  induction 1.
  apply in_cl_eq_I.
  apply in_cl_eq_K.
  apply in_cl_eq_S.
  apply in_cl_eq_3; auto.
  apply in_cl_eq_4; auto.
Qed.

Fact cl_beta_rt_cl_eq f g : f -b>> g -> f ~cl g.
Proof.
  induction 1 as [ | | f g h ].
  apply cl_beta_cl_eq; auto.
  apply in_cl_eq_0.
  apply cl_eq_trans with g; auto.
Qed.

Fact cl_beta_rt_app f g a b : f -b>> g -> a -b>> b -> f o a -b>> g o b.
Proof.
  intros H1 H2.
  constructor 3 with (f o b).
  induction H2 as [ | | a y b ].
  constructor 1; constructor 5; auto.
  constructor 2.
  constructor 3 with (f o y); auto.
  induction H1 as [ | | f h g ].
  constructor 1; constructor 4; auto.
  constructor 2.
  constructor 3 with (h o b); auto.
Qed.

Fact cl_beta_eq_cl_eq f g : f ~b g -> f ~cl g.
Proof.
  induction 1 as [ | | | f g h ].
  apply cl_beta_cl_eq; auto.
  apply in_cl_eq_0.
  apply in_cl_eq_1; auto.
  apply cl_eq_trans with g; auto.
Qed.

Fact cl_beta_eq_app f g a b : f ~b g -> a ~b b -> f o a ~b g o b.
Proof.
  intros H0 H1.
  constructor 4 with (f o b).
  induction H1.
  constructor 1; constructor 5; auto.
  constructor 2.
  constructor 4 with (f o y).
  constructor 2.
  constructor 3; auto.
  constructor 4 with (f o y); auto.

  induction H0 as [ | | | f h g ].
  constructor 1; constructor 4; auto.
  constructor 2.
  constructor 3; auto.
  constructor 4 with (h o b); auto.
Qed.

Fact cl_beta_equiv_cl_eq f g : f ~b g <-> f ~cl g.
Proof.
  split.
  apply cl_beta_eq_cl_eq.
  induction 1 as [ | | | | x y | | | ].

  constructor 1; constructor 1.
  constructor 1; constructor 2.
  constructor 1; constructor 3.
  constructor 2.
  constructor 3; auto.
  constructor 4 with y; auto.
  apply cl_beta_eq_app; auto.
  constructor 2.
  apply cl_beta_eq_app.
  constructor 2.
  auto.
Qed.

(* See the definition of cl_rho in file cl_confluent *)

Local Notation "x '-r->' y" := (cl_rho x y) (at level 70).
Local Notation "x '-r>>' y" := (crt cl_rho x y) (at level 70).

Fact cl_beta_rho f g : f -b-> g -> f -r-> g.
Proof.
  intros H.

  induction H.
  constructor 1.
  constructor 2.
  constructor 3.
  constructor 5; auto.
  constructor 4.
  constructor 5; auto.
  constructor 4.
Qed.

Fact cl_rho_beta_rt f g : f -r-> g -> f -b>> g.
Proof.
  induction 1.
  constructor 1; constructor 1.
  constructor 1; constructor 2.
  constructor 1; constructor 3.
  constructor 2.
  apply cl_beta_rt_app; auto.
Qed.

Lemma cl_rho_rt_beta_rt_eq f g : f -r>> g <-> f -b>> g.
Proof.
  split.

  induction 1 as [ | | x y ].
  apply cl_rho_beta_rt. auto.
  constructor 2.
  constructor 3 with y; auto.

  induction 1 as [ | | x y ].
  constructor 1; apply cl_beta_rho; auto.
  constructor 2.
  constructor 3 with y; auto.
Qed.

Corollary cl_rho_cl_eq f g : f -r-> g -> f ~cl g.
Proof.
  intro; apply cl_beta_rt_cl_eq, cl_rho_beta_rt; auto.
Qed.

(* Since (crt cl_rho) and (crt cl_beta) are equivalent
   and since cl_rho is confluent then so is cl_beta *)

Theorem cl_beta_confluent : confluent cl_beta.
Proof.
  intros f a b.
  do 2 rewrite <- cl_rho_rt_beta_rt_eq.
  intros H2 H3.
  destruct (cl_rho_confluent H2 H3) as (g & H4 & H5).
  exists g; do 2 rewrite <- cl_rho_rt_beta_rt_eq; auto.
Qed.

Fact cl_beta_cr f g : f ~b g <-> exists h, f -b>> h /\ g -b>> h.
Proof.
  apply confluent_church_rosser, cl_beta_confluent.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal29.

Set Printing Depth 1000.
Definition lfind_eval  l2 n0:=
Cons n0 l2.

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ Zero)) (Cons (Succ Zero) Nil)) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Cons (Succ (Succ (Succ (Succ Zero)))) (Cons Zero (Cons (Succ (Succ (Succ Zero))) Nil))) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons (Succ (Succ (Succ Zero))) (Cons (Succ Zero) (Cons (Succ Zero) Nil))) (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero (Cons (Succ (Succ (Succ (Succ Zero)))) Nil)))) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ Zero) Nil)) (Zero).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil)) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero Nil)) (Succ (Succ (Succ (Succ Zero)))).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Cons Zero (Cons (Succ Zero) (Cons (Succ (Succ Zero)) Nil))) (Zero).

Compute lfind_eval  (Cons Zero Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Succ (Succ Zero)).

Compute lfind_eval  (Nil) (Succ Zero).

Compute lfind_eval  (Cons Zero (Cons Zero (Cons Zero Nil))) (Succ Zero).

Compute lfind_eval  (Cons (Succ Zero) Nil) (Succ Zero).

Compute lfind_eval  (Nil) (Zero).

Compute lfind_eval  (Nil) (Zero).


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

Require Import List Arith Lia.

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

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

From Undecidability.FOL.TRAKHTENBROT
  Require Import notations utils fol_ops fo_sig fo_terms.

Require Import Undecidability.Shared.ListAutomation.
Import ListAutomationHints.

Set Implicit Arguments.

(* * The syntax and semantics of FO logic *)

Local Notation ø := vec_nil.

Local Infix "∊" := In (at level 70, no associativity).
Local Infix "⊑" := incl (at level 70, no associativity).

Opaque fo_term_subst fo_term_map fo_term_sem.

(* Terms are just variables in Σrel *)

Definition Σrel_var k : fol_term (Σrel k) -> nat.
Proof. intros [ n | [] ]; exact n. Defined.

(* Unscoped (nat) DeBruijn syntax for FOL formulas *)

Inductive fol_form (Σ : fo_signature) : Type :=
  | fol_false : fol_form Σ
  | fol_atom  : forall p, vec (fol_term Σ) (ar_rels Σ p) -> fol_form Σ
  | fol_bin   : fol_bop -> fol_form Σ -> fol_form Σ -> fol_form Σ
  | fol_quant : fol_qop -> fol_form Σ -> fol_form Σ.

Module fol_notations.

  Infix "⤑" := (fol_bin fol_imp) (at level 62, right associativity).
  Infix "⟑" := (fol_bin fol_conj) (at level 60, right associativity).
  Infix "⟇" := (fol_bin fol_disj) (at level 61, right associativity).
  Notation "∀ f" := (fol_quant fol_fa f) (at level 64, right associativity).
  Notation "∃ f" := (fol_quant fol_ex f) (at level 64, right associativity).
  Notation "x ↔ y" := ((x⤑y)⟑(y⤑x)) (at level 63, no associativity).

  Notation "£" := (in_var : nat -> fol_term _).
  Notation "⊥" := (fol_false _).

End fol_notations.

Import fol_notations.

Section fol_subst.

  Variable (Σ : fo_signature).

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Implicit Type A : 𝔽.

  Fixpoint fol_height A :=
    match A with
      | ⊥             => 1
      | fol_atom p v  => 1
      | fol_bin c A B => 1 + max (fol_height A) (fol_height B)
      | fol_quant q A => 1 + fol_height A
    end.

  Fixpoint fol_vars A :=
    match A with
      | ⊥             => nil
      | fol_atom p v  => flat_map fo_term_vars (vec_list v)
      | fol_bin c A B => fol_vars A ++ fol_vars B
      | fol_quant q A => flat_map (fun n => match n with 0 => nil | S n => n::nil end)
                           (fol_vars A)
    end.

  Fact fol_vars_bin b A B : fol_vars (fol_bin b A B) = fol_vars A ++ fol_vars B.
  Proof. trivial. Qed.

  Fact fol_vars_quant q A : fol_vars (fol_quant q A)
                         = flat_map (fun n => match n with 0 => nil | S n => n::nil end) (fol_vars A).
  Proof. trivial. Qed.

  Definition fol_vars_max A := lmax (fol_vars A).

  Fact fol_vars_max_spec A n : n ∊ fol_vars A -> n <= fol_vars_max A.
  Proof. apply lmax_prop. Qed.

  Fixpoint fol_syms (A : 𝔽) :=
    match A with
      | ⊥              => nil
      | fol_atom p v   => flat_map fo_term_syms (vec_list v)
      | fol_bin c A B  => fol_syms A ++ fol_syms B
      | fol_quant q A  => fol_syms A
    end.

  Fact fol_syms_bin b A B : fol_syms (fol_bin b A B) = fol_syms A ++ fol_syms B.
  Proof. trivial. Qed.

  Fact fol_syms_quant q A : fol_syms (fol_quant q A) = fol_syms A.
  Proof. trivial. Qed.

  Fixpoint fol_rels (A : 𝔽) :=
    match A with
      | ⊥              => nil
      | fol_atom p v   => p::nil
      | fol_bin c A B  => fol_rels A ++ fol_rels B
      | fol_quant q A  => fol_rels A
    end.

  Fact fol_rels_bin b A B : fol_rels (fol_bin b A B) = fol_rels A ++ fol_rels B.
  Proof. trivial. Qed.

  Fact fol_rels_quant q A : fol_rels (fol_quant q A) = fol_rels A.
  Proof. trivial. Qed.

  Fixpoint fol_subst σ (A : 𝔽) :=
    match A with
      | ⊥              => ⊥
      | fol_atom _ v   => fol_atom _ (vec_map (fo_term_subst σ) v)
      | fol_bin c A B => fol_bin c (A⦃σ⦄) (B⦃σ⦄)
      | fol_quant q A => fol_quant q (A⦃⇡σ⦄)
    end
  where "A ⦃ σ ⦄" := (fol_subst σ A).

  Fact fol_subst_ext σ ρ A :
         (forall n, n ∊ fol_vars A -> σ n = ρ n)
       -> A⦃σ⦄ = A⦃ρ⦄.
  Proof.
    intros Hfg; revert A σ ρ Hfg.
    induction A as [ | p v | c A IHA B IHB | q A IHA ]; intros f g Hfg; simpl; f_equal; auto.
    + apply vec_map_ext; intros t Ht.
      apply fo_term_subst_ext; intros n Hn.
      apply Hfg, in_flat_map; exists t; split; auto.
      apply in_vec_list; auto.
    + apply IHA; intros n Hn; apply Hfg, in_or_app; auto.
    + apply IHB; intros n Hn; apply Hfg, in_or_app; auto.
    + apply IHA; intros [ | n ] Hn; simpl; auto; rew fot.
      f_equal; apply Hfg; simpl.
      apply in_flat_map; exists (S n); simpl; auto.
  Qed.

  Fact fol_vars_subst σ (A : 𝔽) : fol_vars (A⦃σ⦄) = flat_map (fun x => fo_term_vars (σ x)) (fol_vars A).
  Proof.
    revert σ; induction A as [ | s r | b A HA B HB | q A HA ]; intros phi; auto.
    + simpl fol_vars.
      rewrite vec_list_vec_map.
      rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map.
      rewrite map_map; f_equal.
      apply map_ext; intros x.
      rewrite fo_term_vars_subst; auto.
    + simpl; rewrite flat_map_app; f_equal; auto.
    + simpl; rewrite HA.
      do 2 rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map; f_equal.
      apply map_ext_in; intros [ | x ] Hx; simpl; auto.
      rewrite fo_term_vars_map; rew fot.
      rewrite flat_map_concat_map, map_map.
      rewrite <- flat_map_concat_map.
      rewrite <- app_nil_end.
      rewrite flat_map_single, map_id; auto.
  Qed.

  Fact fol_vars_map σ (A : 𝔽) : fol_vars (A⦃fun n => £(σ n)⦄) = map σ (fol_vars A).
  Proof. rewrite fol_vars_subst, <- flat_map_single; auto. Qed.

  Fact fol_syms_subst P σ (A : 𝔽) :
        (forall n, n ∊ fol_vars A -> Forall P (fo_term_syms (σ n)))
     -> Forall P (fol_syms A) -> Forall P (fol_syms (A⦃σ⦄)).
  Proof.
    revert σ.
    induction A as [ | s r | b A HA B HB | q A HA ]; intros f Hf H; simpl; auto.
    + rewrite Forall_forall in H |- *.
      intros s'; rewrite in_flat_map.
      intros (t & Ht); revert Ht.
      rewrite vec_list_vec_map, in_map_iff.
      intros ((t' & <- & H1) & H2).
      revert s' H2; apply Forall_forall.
      apply fo_term_syms_subst.
      simpl in H, Hf.
      * intros n Hn; apply Hf, in_flat_map.
        exists t'; auto.
      * apply Forall_forall; intros s' Hs'.
        apply H, in_flat_map; exists t'; auto.
    + simpl in H; rewrite Forall_app in H.
      rewrite Forall_app; split.
      * apply HA; try tauto.
        intros; apply Hf, in_or_app; auto.
      * apply HB; try tauto.
        intros; apply Hf, in_or_app; auto.
    + simpl in H; apply HA; auto.
      intros [ | n ]; simpl; rew fot; auto.
      rewrite fo_term_syms_map; intros Hn.
      apply Hf, in_flat_map.
      exists (S n); simpl; auto.
  Qed.

  Fact fol_rels_subst σ (A : 𝔽) : fol_rels (A⦃σ⦄) = fol_rels A.
  Proof.
    revert σ.
    induction A as [ | s r | b A HA B HB | q A HA ]; intros f; simpl; auto.
    rewrite HA, HB; auto.
  Qed.

  Definition fol_bigop c A := fold_right (@fol_bin Σ c) A.

  Fact fol_vars_bigop c l A : fol_vars (fol_bigop c A l) = flat_map fol_vars l++fol_vars A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_syms_bigop c l A : fol_syms (fol_bigop c A l) = flat_map fol_syms l++fol_syms A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_rels_bigop c l A : fol_rels (fol_bigop c A l) = flat_map fol_rels l++fol_rels A.
  Proof.
    induction l; simpl; auto.
    rewrite app_ass; f_equal; auto.
  Qed.

  Fact fol_subst_bigop c l A σ : (fol_bigop c A l)⦃σ⦄ = fol_bigop c (A⦃σ⦄) (map (fol_subst σ) l).
  Proof. induction l; simpl; f_equal; auto. Qed.

  (* ∀ ... ∀ A  and  ∃ ... ∃ A *)

  Fixpoint fol_mquant q n (A : 𝔽) :=
    match n with
      | 0   => A
      | S n => (fol_quant q) (fol_mquant q n A)
    end.

  Fact fol_mquant_plus q a b A : fol_mquant q (a+b) A = fol_mquant q a (fol_mquant q b A).
  Proof. induction a; simpl; f_equal; auto. Qed.

  Fact fol_mquant_S q n A : fol_mquant q (S n) A = fol_mquant q n (fol_quant q A).
  Proof.
    replace (S n) with (n+1) by lia.
    apply fol_mquant_plus.
  Qed.

  (* (Free) variables in ∀ ... ∀ A  and  ∃ ... ∃ A *)

  Fact fol_vars_mquant q n (A : 𝔽) :
        fol_vars (fol_mquant q n A)
      = flat_map (fun i => if le_lt_dec n i then (i-n::nil) else nil) (fol_vars A).
  Proof.
    revert A; induction n as [ | n IHn ]; intros A.
    + simpl; rewrite <- map_id at 1; rewrite <- flat_map_single.
      do 2 rewrite flat_map_concat_map; f_equal; apply map_ext.
      intro a; destruct (le_lt_dec 0 a); f_equal; lia.
    + rewrite fol_mquant_S.
      rewrite IHn; simpl fol_vars; rewrite flat_map_flat_map.
      do 2 rewrite flat_map_concat_map; f_equal; apply map_ext.
      intros [ | a ]; auto; simpl flat_map.
      rewrite <- app_nil_end.
      destruct (le_lt_dec n a); destruct (le_lt_dec (S n) (S a)); auto; lia.
  Qed.

  Fact fol_syms_mquant q n A : fol_syms (fol_mquant q n A) = fol_syms A.
  Proof. induction n; simpl; auto. Qed.

  Fact fol_rels_mquant q n A : fol_rels (fol_mquant q n A) = fol_rels A.
  Proof. induction n; simpl; auto. Qed.

  (* This theorem is the important one that shows substitutions do compose
      hence De Bruijn notation are handled correctly by substitutions *)

  Fact fol_subst_subst σ ρ A : A⦃σ⦄⦃ρ⦄ = A⦃fun n => (σ n)⟬ρ⟭⦄.
  Proof.
    revert σ ρ; induction A
        as [ | p v | b A IHA B IHB | q A IHA ];
        simpl; intros f g; auto.
    + f_equal.
      rewrite vec_map_map.
      apply vec_map_ext.
      intros A w; rew fot; auto.
    + f_equal; auto.
    + f_equal.
      rewrite IHA; auto.
      apply fol_subst_ext.
      intros [ | n ] _; rew fot; simpl; rew fot; simpl; auto.
      do 2 rewrite <- fo_term_subst_map, fo_term_subst_comp.
      apply fo_term_subst_ext.
      intros; rew fot; rewrite fo_term_subst_map; simpl; rew fot; auto.
  Qed.

End fol_subst.

Notation "A ⦃ σ ⦄" := (fol_subst σ A).

Notation fol_lconj := (@fol_bigop _ fol_conj (⊥⤑⊥)).
Notation fol_ldisj := (@fol_bigop _ fol_disj ⊥).

Section fol_semantics.

  Variable (Σ : fo_signature)
           (X : Type) (M : fo_model Σ X).

  Implicit Type φ : nat -> X.

  Notation 𝕋 := (fol_term Σ).
  Notation 𝔽 := (fol_form Σ).

  Notation "⟦ t ⟧" := (fun φ => fo_term_sem M φ t).

  Fixpoint fol_sem φ A : Prop :=
    match A with
      | ⊥              => False
      | fol_atom _ v   => fom_rels M _ (vec_map (fun t => ⟦t⟧ φ) v)
      | fol_bin b A B  => fol_bin_sem b (⟪A⟫ φ) (⟪B⟫ φ)
      | fol_quant q A  => fol_quant_sem q (fun x => ⟪A⟫ x·φ)
    end
  where "⟪ A ⟫" := (fun φ => fol_sem φ A).

  Fact fol_sem_bin_fix φ b A B : fol_sem φ (fol_bin b A B) = fol_bin_sem b (⟪A⟫ φ) (⟪B⟫ φ).
  Proof. reflexivity. Qed.

  Fact fol_sem_quant_fix φ q A : fol_sem φ (fol_quant q A) = fol_quant_sem q (fun x => ⟪A⟫ x·φ).
  Proof. reflexivity. Qed.

  (* Semantics depends only on occuring variables *)

  Fact fol_sem_ext φ ψ A : (forall n, n ∊ fol_vars A -> φ n = ψ n) -> ⟪A⟫ φ <-> ⟪A⟫ ψ.
  Proof.
    intros H; revert A φ ψ H.
    induction A as [ | p v | b A IHA B IHB | q A IHA ]; simpl; intros phi psy H; try tauto.
    + fol equiv rel.
      apply vec_map_ext; intros w Hw.
      apply fo_term_sem_ext; auto.
      intros n Hn; apply H, in_flat_map; exists w; split; auto.
      apply in_vec_list; auto.
    + apply fol_bin_sem_ext.
      * apply IHA; intros; apply H, in_or_app; auto.
      * apply IHB; intros; apply H, in_or_app; auto.
    + apply fol_quant_sem_ext.
      intros x; apply IHA.
      intros [ | n] Hn; simpl; auto; apply H, in_flat_map.
      exists (S n); simpl; auto.
  Qed.

  Section decidable.

    (* REMARK: not requiring the fom_rels M s relation to be decidable
        would allow hiding uncomputability inside the model which
        would be kind of cheating. The semantic relation should be
        decidable, only the (finite) satisfiability relation should
        be undec *)

    (* For the semantics relation to be decidable over a finite domain,
        it is necessary and SUFFICIENT that the sem_pred relation is decidable
        or equivalently, each predicate is interpreted as a map: vec X _ -> bool *)

    Variable (M_fin : finite_t X).
    Variable (rels_dec : fo_model_dec M).

    Theorem fol_sem_dec A φ : { ⟪A⟫ φ } + { ~ ⟪A⟫ φ }.
    Proof using rels_dec M_fin.
      revert φ.
      induction A as [ | p v | b A IHA B IHB | q A IHA ]; intros phi.
      + simpl; tauto.
      + simpl; apply rels_dec.
      + simpl fol_sem; apply fol_bin_sem_dec; auto.
      + simpl fol_sem; apply fol_quant_sem_dec; auto.
    Qed.

  End decidable.

  (* Semantics commutes with substitutions ... good *)

  Theorem fol_sem_subst φ σ A : ⟪ A⦃σ⦄ ⟫ φ <-> ⟪A⟫ (fun n => ⟦σ n⟧ φ).
  Proof.
    revert φ σ; induction A as [ | p v | b A IHA B IHB | q A IHA ]; simpl; intros phi f; try tauto.
    + fol equiv rel.
      rewrite vec_map_map; apply vec_map_ext.
      intros; rewrite fo_term_sem_subst; auto.
    + apply fol_bin_sem_ext; auto.
    + apply fol_quant_sem_ext.
      intros x; rewrite IHA.
      apply fol_sem_ext.
      intros [ | n ] _; simpl; rew fot; simpl; auto.
      rewrite <- fo_term_subst_map; rew fot.
      apply fo_term_sem_ext; intros; rew fot; auto.
  Qed.

  Definition fol_lift t n : 𝕋 := match n with 0 => t | S n => £n end.

  Corollary fol_sem_lift φ t A : ⟪A⦃fol_lift t⦄⟫ φ <-> ⟪A⟫ (⟦t⟧ φ)·φ.
  Proof.
    rewrite fol_sem_subst.
    apply fol_sem_ext; intros [ | n ] _; simpl; rew fot; auto.
  Qed.

  (* Bigops, ie finitary conjunction and disjunction *)

  Fact fol_sem_lconj lf φ : ⟪fol_lconj lf⟫ φ <-> forall f, f ∊ lf -> ⟪f⟫ φ.
  Proof.
    induction lf as [ | f lf IHlf ]; simpl.
    + split; tauto.
    + rewrite IHlf.
      split.
      * intros [] ? [ -> | ]; auto.
      * intros H; split; intros; apply H; auto.
  Qed.

  Fact fol_sem_lconj_app l m φ :
         ⟪fol_lconj (l++m)⟫ φ <-> ⟪fol_lconj l⟫ φ /\ ⟪fol_lconj m⟫ φ.
  Proof.
    rewrite !fol_sem_lconj; split.
    + intros H; split; intros; apply H, in_app_iff; firstorder.
    + intros (H1 & H2) f; rewrite in_app_iff; firstorder.
  Qed.

  Fact fol_sem_ldisj lf φ : ⟪fol_ldisj lf⟫ φ <-> exists f, f ∊ lf /\ ⟪f⟫ φ.
  Proof.
    induction lf as [ | f lf IHlf ]; simpl.
    + split; try tauto; intros ( ? & [] & _).
    + rewrite IHlf.
      split.
      * intros [ H | (g & H1 & H2) ].
        - exists f; auto.
        - exists g; auto.
      * intros (g & [ <- | Hg ] & ?); auto.
        right; exists g; auto.
  Qed.

  Fact fol_sem_ldisj_app l m φ :
         ⟪fol_ldisj (l++m)⟫ φ <-> ⟪fol_ldisj l⟫ φ \/ ⟪fol_ldisj m⟫ φ.
  Proof.
    rewrite !fol_sem_ldisj; split.
    + intros (f & H1 & H2); revert H1; rewrite in_app_iff; firstorder.
    + intros [ (? & ? & ?) | (? & ? & ?) ]; firstorder auto with *.
  Qed.

  Definition fol_vec_fa n (A : vec 𝔽 n) := fol_lconj (vec_list A).

  Fact fol_vars_vec_fa n A : fol_vars (@fol_vec_fa n A) = flat_map (@fol_vars _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_vars_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_syms_vec_fa n A : fol_syms (@fol_vec_fa n A) = flat_map (@fol_syms _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_syms_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_rels_vec_fa n A : fol_rels (@fol_vec_fa n A) = flat_map (@fol_rels _) (vec_list A).
  Proof.
    unfold fol_vec_fa; rewrite fol_rels_bigop; simpl.
    rewrite app_nil_end; auto.
  Qed.

  Fact fol_sem_vec_fa n A φ : ⟪@fol_vec_fa n A⟫ φ <-> forall p, ⟪vec_pos A p⟫ φ.
  Proof.
    unfold fol_vec_fa; rewrite fol_sem_lconj; split.
    + intros H p; apply H, in_vec_list, in_vec_pos.
    + intros H f Hf.
      apply vec_list_inv in Hf.
      destruct Hf as (p & ->); auto.
  Qed.

  (* [x1;...;xn] · φ := x1 · x2 ... · xn · φ *)

  Fixpoint env_vlift φ n (v : vec X n) :=
    match v with
      | ø    => φ
      | x##v => x·(env_vlift φ v)
    end.

  Fact env_vlift_fix0 φ n (v : vec X n) p : env_vlift φ v (pos2nat p) = vec_pos v p.
  Proof.
    revert φ p; induction v as [ | n x v IHv ]; intros phi p; auto.
    + invert pos p.
    + invert pos p.
      * rewrite pos2nat_fst; auto.
      * rewrite pos2nat_nxt; simpl; auto.
  Qed.

  Fact env_vlift_fix1 φ n (v : vec X n) k : env_vlift φ v (k+n) = φ k.
  Proof.
    revert φ k; induction v as [ | x n v IHv ]; intros phi k; simpl; auto.
    replace (k+S n) with (S (k+n)) by lia; simpl; auto.
  Qed.

  (* The semantics of ∀ ... ∀ A *)

  Fact fol_sem_mforall n A φ : ⟪fol_mquant fol_fa n A⟫ φ
                           <-> forall v : vec X n, ⟪A⟫ (env_vlift φ v).
  Proof.
    revert A φ; induction n as [ | n IHn ]; intros A phi.
    + split.
      * intros H v; vec nil v; simpl; auto.
      * intros H; apply (H ø).
    + rewrite fol_mquant_S, IHn; split.
      * intros H v; vec split v with x; apply (H v).
      * intros H v; intros x; apply (H (x##v)).
  Qed.

  (* The semantics of ∃ ... ∃ A *)

  Fact fol_sem_mexists n A φ : ⟪fol_mquant fol_ex n A⟫ φ
                           <-> exists v : vec X n, ⟪A⟫ (env_vlift φ v).
  Proof.
    revert A φ; induction n as [ | n IHn ]; intros A phi.
    + split.
      * intros H; exists ø; auto.
      * intros (v & Hv); revert Hv; vec nil v; auto.
    + rewrite fol_mquant_S, IHn; split.
      * intros (v & x & Hv).
        exists (x##v); auto.
      * intros (v & Hv); revert Hv; vec split v with x.
        exists v, x; auto.
  Qed.

End fol_semantics.

(*
Notation fol_sem_big_conj := fol_sem_lconj.
Notation fol_sem_big_disj := fol_sem_ldisj.
*)

Definition fot_vec_env Σ n p :
        { w : vec (fo_term (ar_syms Σ)) n | (forall X (M : fo_model Σ X) v φ q x,
             fo_term_sem M x·(env_vlift φ v) (vec_pos w q)
           = vec_pos (vec_change v p x) q)
         /\ forall q, fo_term_syms (vec_pos w q) = nil }.
Proof.
  exists (vec_change (vec_set_pos (fun q => £(S (pos2nat q)))) p (£0)); split.
  * intros X M v phi q x;rew fot; rew vec; rew fot.
    destruct (pos_eq_dec p q) as [ H | H ].
    + rewrite !vec_change_eq; auto.
    + rewrite !vec_change_neq; auto; rew vec; rew fot; simpl.
      rewrite env_vlift_fix0; auto.
  * intros q; destruct (pos_eq_dec p q) as [ H | H ].
    + rewrite !vec_change_eq; auto.
    + rewrite !vec_change_neq; auto; rew vec.
Qed.

Section fo_model_simulation.

  (* We state a general simulation result for models on a given
      formula build on a bounded list of symbols. The statement
      is so general that the proof is just obvious ;-) *)

  Variables  (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
             (X : Type) (M : fo_model Σ X)
             (Y : Type) (N : fo_model Σ Y).

  (* We assume that ⋈ is a simulation, ie a congruence for all operators in ls
      and all relations in lr *)

  Record fo_simulation := Mk_fo_simulation {
    fos_simul :> X -> Y -> Prop;
    fos_syms  : forall s v w, s ∊ ls
                          -> (forall p, fos_simul (vec_pos v p) (vec_pos w p))
                          -> fos_simul (fom_syms M s v) (fom_syms N s w);
    fos_rels  : forall r v w, r ∊ lr
                          -> (forall p, fos_simul (vec_pos v p) (vec_pos w p))
                          -> fom_rels M r v <-> fom_rels N r w;
    fos_total : forall x, exists y, fos_simul x y;
    fos_surj  : forall y, exists x, fos_simul x y;
  }.

  Record fo_projection := Mk_fo_projection {
    fop_surj :> X -> Y;
    fop_inj  : Y -> X;
    fop_eq   : forall x, fop_surj (fop_inj x) = x;
    fop_syms : forall s v, s ∊ ls -> fop_surj (fom_syms M s v) = fom_syms N s (vec_map fop_surj v);
    fop_rels : forall r v, r ∊ lr -> fom_rels M r v <-> fom_rels N r (vec_map fop_surj v);
  }.

  Fact fo_proj_simul : fo_projection -> fo_simulation.
  Proof.
    intros [ i j E Hs Hr ].
    exists (fun x y => i x = y); auto.
    + intros s v w H1 H2; rewrite Hs; auto.
      f_equal; apply vec_pos_ext; intro; rew vec.
    + intros s v w H1 H2; rewrite Hr; auto.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intro; rew vec.
    + intros x; exists (i x); auto.
    + intros y; exists (j y); auto.
  Defined.

  Variable R : fo_simulation.

  Infix "⋈" := R (at level 70, no associativity).

  Notation "⟦ t ⟧" := (fun φ => fo_term_sem M φ t).
  Notation "⟦ t ⟧'" := (fun φ => fo_term_sem N φ t) (at level 1, format "⟦ t ⟧'").

  Notation "⟪ A ⟫" := (fun φ => fol_sem M φ A).
  Notation "⟪ A ⟫'" := (fun φ => fol_sem N φ A) (at level 1, format "⟪ A ⟫'").

  (* The simulation lifts from variables to terms *)

  Let fo_term_simulation t φ ψ :
           (forall n, n ∊ fo_term_vars t -> φ n ⋈ ψ n)
        -> fo_term_syms t ⊑ ls
        -> ⟦t⟧ φ ⋈ ⟦t⟧' ψ.
  Proof.
    revert φ ψ.
    induction t as [ k | s v IH ];
      intros phi psi Hv Hls; rew fot; auto.
    + apply Hv; simpl; auto.
    + apply fos_syms.
      * apply Hls; simpl; auto.
      * intros p; do 2 rewrite vec_pos_map.
        apply IH; auto.
        - intros n Hn; apply Hv; rew fot.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
        - apply incl_tran with (2 := Hls).
          intros s' Hs'; rew fot.
          right; apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
  Qed.

  (* We assume the simulation to be total and surjective *)

  Theorem fo_model_simulation A φ ψ :
           fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> (forall n, n ∊ fol_vars A -> φ n ⋈ ψ n)
        -> ⟪A⟫ φ <-> ⟪A⟫' ψ.
  Proof.
    revert φ ψ.
    induction A as [ | r v | b A HA B HB | q A HA ]; intros phi psi Hs1 Hr1 Hp; simpl; try tauto.
    + apply (fos_rels R).
      * apply Hr1; simpl; auto.
      * intros p; do 2 rewrite vec_pos_map.
        apply fo_term_simulation.
        - intros n Hn; apply Hp; simpl.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
        - apply incl_tran with (2 := Hs1).
          intros s' Hs'; simpl.
          apply in_flat_map.
          exists (vec_pos v p); split; auto.
          apply in_vec_list, in_vec_pos.
    + apply fol_bin_sem_ext; [ apply HA | apply HB ].
      3,6: intros; apply Hp; simpl; apply in_or_app; auto.
      1,3: apply incl_tran with (2 := Hs1); intros ? ?; apply in_or_app; auto.
      1,2: apply incl_tran with (2 := Hr1); intros ? ?; apply in_or_app; auto.
    + destruct q; simpl; split.
      1: intros (x & Hx); destruct (fos_total R x) as (y & Hy); exists y; revert Hx; apply HA; eauto.
      2: intros (y & Hy); destruct (fos_surj R y) as (x & Hx); exists x; revert Hy; apply HA; eauto.
      3: intros H y; destruct (fos_surj R y) as (x & Hx); generalize (H x); apply HA; eauto.
      4: intros H x; destruct (fos_total R x) as (y & Hy); generalize (H y); apply HA; eauto.
      all: intros []; simpl; auto; intros; apply Hp, in_flat_map; exists (S n); simpl; auto.
  Qed.

End fo_model_simulation.

Theorem fo_model_projection Σ ls lr X M Y N (p : @fo_projection Σ ls lr X M Y N) A φ ψ :
           (forall n, n ∊ fol_vars A -> p (φ n) = ψ n)
        -> fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> fol_sem M φ A <-> fol_sem N ψ A.
Proof.
  intros H1 H2 H3.
  apply fo_model_simulation with (R := fo_proj_simul p); auto.
  destruct p; simpl; auto.
Qed.

Section fo_model_projection.

  (* We specialize the previous simulation result on simulation
      obtained as surjective projections *)

  Variable (Σ : fo_signature) (ls : list (syms Σ)) (lr : list (rels Σ))
           (X : Type) (M : fo_model Σ X) (φ : nat -> X)
           (Y : Type) (N : fo_model Σ Y) (ψ : nat -> Y)
           (i : X -> Y) (j : Y -> X) (E : forall x, i (j x) = x)
           (Hs : forall s v, s ∊ ls -> i (fom_syms M s v) = fom_syms N s (vec_map i v))
           (Hr : forall r v, r ∊ lr -> fom_rels M r v <-> fom_rels N r (vec_map i v)).

  Let p : fo_projection ls lr M N.
  Proof. exists i j; auto. Defined.

  Theorem fo_model_projection' A :
           (forall n, n ∊ fol_vars A -> i (φ n) = ψ n)
        -> fol_syms A ⊑ ls
        -> fol_rels A ⊑ lr
        -> fol_sem M φ A <-> fol_sem N ψ A.
  Proof using Hs Hr E. apply fo_model_projection with (p := p). Qed.

End fo_model_projection.

Section fo_model_nosyms.

  Variable (Σ : fo_signature)
           (X : Type) (M M' : fo_model Σ X) (φ : nat -> X)
           (A : fol_form Σ)
           (HA : fol_syms A = nil)
           (H : forall r v, r ∊ fol_rels A -> fom_rels M r v <-> fom_rels M' r v).

  Theorem fo_model_nosyms : fol_sem M φ A <-> fol_sem M' φ A.
  Proof using HA H.
    apply fo_model_projection' with (ls := nil) (lr := fol_rels A) (i := fun x => x) (j := fun x => x); auto.
    + intros; rewrite H; auto.
      apply fol_equiv_ext; f_equal.
      apply vec_pos_ext; intro; rew vec.
    + rewrite HA; apply incl_refl.
  Qed.

End fo_model_nosyms.


Require Import Coq.Arith.Plus.

Fixpoint pow a b :=
  match b with
  | O => 1
  | S c => a * (pow a c)
  end.

Notation "a ^ b" := (pow a b).

Theorem testing : forall a b x y z,
  x ^ (y + z) = x ^ (z + y) /\ (a && b)%bool = (b && a)%bool.
Proof.
  intros. split.
  + rewrite plus_comm. reflexivity.
  + rewrite Bool.andb_comm. reflexivity.
Qed.

Theorem test_nesting : forall x, x ^ x ^ x = x ^ x ^ x.


(** * Binary Patricia tries *)

(* Author: Xavier Leroy, Collège de France and Inria.
   Copyright: Inria.
   License: BSD-3-Clause. *)

(** Inspired by section 12.3 of "Functional algorithms, verified!"
    by T. Nipkow et al. *)

From Coq Require Import PArith.
From Tries Require Original.

Module O := Original.PTree.

Set Implicit Arguments.

(** ** Operations on positive numbers viewed as lists of bits *)

(** Concatenation. *)

Fixpoint app (p q: positive) : positive :=
  match p with
  | xH => q
  | xO p => xO (app p q)
  | xI p => xI (app p q)
  end.

Lemma app_xH: forall p, app p xH = p.
Proof.
  induction p; simpl; congruence.
Qed.

Lemma app_assoc: forall p q r, app (app p q) r = app p (app q r).
Proof.
  induction p; intros; simpl; auto; rewrite IHp; auto.
Qed.

Lemma app_inj: forall p q1 q2, app p q1 = app p q2 -> q1 = q2.
Proof.
  induction p; simpl; intros; auto; apply IHp; congruence.
Qed.

(** Viewing positive numbers as lists of bits, check that p is a prefix of q,
    and if so return the remainder of q. *)

Fixpoint prefix (p q: positive) {struct p} : option positive :=
  match p, q with
  | xH, _ => Some q
  | xO p, xO q => prefix p q
  | xI p, xI q => prefix p q
  | _, _ => None
  end.

Lemma prefix_charact: forall p q r,
  prefix p q = Some r <-> q = app p r.
Proof.
  induction p; intros; simpl.
- split; intros.
  + destruct q; try discriminate. apply IHp in H. congruence.
  + subst q. apply IHp. auto.
- split; intros.
  + destruct q; try discriminate. apply IHp in H. congruence.
  + subst q. apply IHp. auto.
- intuition congruence.
Qed.

Lemma prefix_app: forall p1 p2 i,
  prefix (app p1 p2) i =
    match prefix p1 i with
    | None => None
    | Some i1 => prefix p2 i1
    end.
Proof.
  intros. destruct (prefix p1 i) as [i1 | ] eqn:P1.
- apply prefix_charact in P1.
  destruct (prefix (app p1 p2) i) as [i2 | ] eqn:P2.
  + apply prefix_charact in P2.
    symmetry. apply prefix_charact. apply app_inj with p1.
    rewrite <- app_assoc. congruence.
  + destruct (prefix p2 i1) as [i2 | ] eqn:P3; auto.
    apply prefix_charact in P3. subst i1. rewrite <- app_assoc in P1. apply prefix_charact in P1. congruence.
- destruct (prefix (app p1 p2) i) as [i1 | ] eqn: P; auto.
  apply prefix_charact in P. rewrite app_assoc in P. apply prefix_charact in P. congruence.
Qed.

(** Viewing positive numbers as lists of bits, find the longest common prefix
    between p and q.  Also return the suffixes. *)

Fixpoint common (p q: positive) {struct p} : positive * positive * positive :=
  match p, q with
  | xO p, xO q => let '(c, p', q') := common p q in (xO c, p', q')
  | xI p, xI q => let '(c, p', q') := common p q in (xI c, p', q')
  | _, _ => (xH, p, q)
  end.

Definition disagree (p q: positive) : Prop :=
  match p, q with
  | xO _, xO _ => False
  | xI _, xI _ => False
  | _, _ => True
  end.

Lemma common_charact: forall p q,
  let '(c, p', q') := common p q in
  p = app c p' /\ q = app c q' /\ disagree p' q'.
Proof.
  induction p; destruct q; simpl; auto.
- specialize (IHp q). destruct (common p q) as [[c p'] q']. simpl. intuition congruence.
- specialize (IHp q). destruct (common p q) as [[c p'] q']. simpl. intuition congruence.
Qed.

Module PTree.

(** ** Representation of Patricia tries *)

Inductive tree (A: Type) : Type :=
  | Leaf: tree A
  | Node: positive -> tree A -> option A -> tree A -> tree A.

(** In [Node p l x r], the [p] argument represents the list of bits that
    lead to this node.  The node is, then, a branch point, with
    an optional value [x] and a left subtree [l] and a right subtree [r],
    as in the other binary tries. *)

Arguments Leaf {A}.
Arguments Node [A].

Definition t := tree.

(** Smart constructor: avoids creating empty nodes and nodes where the
    prefix is not maximal. *)

Definition Node' (A: Type) (p: positive) (l: tree A) (x: option A) (r: tree A) : tree A :=
  match l, x, r with
  | Leaf, None, Leaf => Leaf
  | Node p1 l1 x1 r1, None, Leaf => Node (app p (xO p1)) l1 x1 r1
  | Leaf, None, Node p2 l2 x2 r2 => Node (app p (xI p2)) l2 x2 r2
  | _, _, _ => Node p l x r
  end.

(** ** Basic operations: [empty], [get], [set], [remove] *)

Definition empty (A: Type) : tree A := Leaf.

Fixpoint get (A: Type) (i: positive) (m: tree A) {struct m} : option A :=
  match m with
  | Leaf => None
  | Node p l x r =>
      match prefix p i with
      | None => None
      | Some xH => x
      | Some (xO ii) => get ii l
      | Some (xI ii) => get ii r
      end
  end.

Definition singleton (A: Type) (i: positive) (v: A) : tree A :=
  Node i Leaf (Some v) Leaf.

Fixpoint set (A: Type) (i: positive) (v: A) (m: tree A) {struct m} : tree A :=
  match m with
  | Leaf => singleton i v
  | Node p l x r =>
      match common p i with
      | (_, xH, xH) => Node p l (Some v) r
      | (_, xH, xO ii) => Node p (set ii v l) x r
      | (_, xH, xI ii) => Node p l x (set ii v r)
      | (c, xO pp, xH) => Node c (Node pp l x r) (Some v) Leaf
      | (c, xI pp, xH) => Node c Leaf (Some v) (Node pp l x r)
      | (c, xO pp, xI ii) => Node c (Node pp l x r) None (singleton ii v)
      | (c, xI pp, xO ii) => Node c (singleton ii v) None (Node pp l x r)
      | _ => Leaf   (*r never happens *)
      end
  end.

Fixpoint remove (A: Type) (i: positive) (m: tree A) {struct m} : tree A :=
  match m with
  | Leaf => Leaf
  | Node p l x r =>
      match prefix p i with
      | None => m
      | Some xH => Node' p l None r
      | Some (xO ii) => Node' p (remove ii l) x r
      | Some (xI ii) => Node' p l x (remove ii r)
      end
  end.

(** ** Relating Patricia trees with binary tries *)

(** As in "Functional algorithms, verified!", we transport some of the
    results for plain binary tries to Patricia binary tries via the
    following translation functions. *)

(** [transl m] produces the plain trie equivalent to the given Patricia
    trie.  No attempt is made to eliminate redundant nodes. *)

Fixpoint addpref {A: Type} (p: positive) (m: O.tree A) : O.tree A :=
  match p with
  | xH => m
  | xO pp => O.Node (addpref pp m) None O.Leaf
  | xI pp => O.Node O.Leaf None (addpref pp m)
  end.

Fixpoint transl {A: Type} (m: tree A) : O.tree A :=
  match m with
  | Leaf => O.Leaf
  | Node p l x r => addpref p (O.Node (transl l) x (transl r))
  end.

(** [transl' m] is similar but replaces empty nodes by leaves. *)

Fixpoint addpref' {A: Type} (p: positive) (m: O.tree A) : O.tree A :=
  match p with
  | xH => m
  | xO pp => O.Node' (addpref' pp m) None O.Leaf
  | xI pp => O.Node' O.Leaf None (addpref' pp m)
  end.

Fixpoint transl' {A: Type} (m: tree A) : O.tree A :=
  match m with
  | Leaf => O.Leaf
  | Node p l x r => addpref' p (O.Node' (transl' l) x (transl' r))
  end.

(** We now show commutation diagrams between the operations over Patricia tries
    and the same operations over the corresponding binary tries. *)

Lemma transl_get:
  forall {A: Type} (m: tree A) i,
  get i m = O.get i (transl m).
Proof.
  induction m; simpl.
- intros. auto.
- induction p as [ pp | pp | ]; simpl; intros; destruct i; auto.
Qed.

Lemma transl_singleton: forall {A: Type} (v: A) i,
  transl (singleton i v) = O.set i v O.Leaf.
Proof.
  unfold singleton; induction i; simpl; auto; f_equal; auto.
Qed.

Remark o_set_app: forall {A} (v: A) c i p t,
  O.set (app c i) v (addpref (app c p) t) = addpref c (O.set i v (addpref p t)).
Proof.
  induction c; simpl; intros; auto; f_equal; auto.
Qed.

Lemma transl_set:
  forall {A: Type} (v: A) (m: tree A) i,
  transl (set i v m) = O.set i v (transl m).
Proof.
  induction m; simpl.
- intros. apply transl_singleton.
- intros i.
  generalize (common_charact p i). destruct (common p i) as [[c pp] ii] eqn:C.
  intros (E1 & E2 & DIS). rewrite E1, E2.
  rewrite o_set_app.
  destruct pp as [ pp | pp | ]; destruct ii as [ ii | ii | ]; simpl; try (elim DIS); auto.
  + f_equal. f_equal. apply transl_singleton.
  + f_equal. f_equal. apply transl_singleton.
  + rewrite app_xH. f_equal. f_equal. apply IHm2.
  + rewrite app_xH. f_equal. f_equal. apply IHm1.
  + rewrite app_xH. auto.
Qed.

Lemma gNode': forall {A} i p l (x: option A) r,
  get i (Node' p l x r) =
    match prefix p i with
    | None => None
    | Some xH => x
    | Some (xO ii) => get ii l
    | Some (xI ii) => get ii r
    end.
Proof.
  intros. destruct l, x, r; auto.
- destruct (prefix p i) as [[] | ]; auto.
- simpl. rewrite prefix_app. destruct (prefix p i) as [ii | ]; auto.
  simpl. destruct ii; auto.
- simpl. rewrite prefix_app. destruct (prefix p i) as [ii | ]; auto.
  simpl. destruct ii; auto.
Qed.

Lemma transl'_get:
  forall {A: Type} (m: tree A) i,
  get i m = O.get i (transl' m).
Proof.
  Local Opaque O.Node'.
  induction m; simpl.
- intros. auto.
- induction p as [ pp | pp | ]; simpl; intros; rewrite O.gNode'; destruct i; auto.
Qed.

Lemma o_remove_node': forall {A: Type} i (l: O.tree A) x r,
  O.remove i (O.Node' l x r) =
    match i with
    | xH => O.Node' l None r
    | xO i => O.Node' (O.remove i l) x r
    | xI i => O.Node' l x (O.remove i r)
    end.
Proof.
  intros.
  assert (E: l = O.Leaf /\ x = None /\ r = O.Leaf \/ O.Node' l x r = O.Node l x r).
  { destruct l, x, r; auto. }
  destruct E as [(E1 & E2 & E3) | E].
  - subst l x r. simpl. destruct i; auto.
  - rewrite E; destruct i; simpl; auto.
Qed.

Lemma o_remove_notpref: forall {A} (m: O.tree A) p i,
  prefix p i = None -> O.remove i (addpref' p m) = addpref' p m.
Proof.
  Local Opaque O.Node'.
  induction p; intros.
- destruct i; simpl in *; rewrite o_remove_node'; f_equal; auto.
- destruct i; simpl in *; rewrite o_remove_node'; f_equal; auto.
- discriminate.
Qed.

Lemma o_remove_app: forall {A} p i (m: O.tree A),
  O.remove (app p i) (addpref' p m) = addpref' p (O.remove i m).
Proof.
  induction p; simpl; intros.
- rewrite o_remove_node'. f_equal; auto.
- rewrite o_remove_node'. f_equal; auto.
- auto.
Qed.

Lemma addpref'_app: forall {A} p q (m: O.tree A),
  addpref' (app p q) m = addpref' p (addpref' q m).
Proof.
  induction p; simpl; intros.
- f_equal; auto.
- f_equal; auto.
- auto.
Qed.

Lemma transl'_node': forall {A} p (l: tree A) x r,
  transl' (Node' p l x r) = addpref' p (O.Node' (transl' l) x (transl' r)).
Proof.
  intros. destruct l, x, r; auto.
- simpl. induction p; simpl; rewrite <- ? IHp; auto.
- simpl. rewrite addpref'_app. auto.
- simpl. rewrite addpref'_app. auto.
Qed.

Lemma transl_remove:
  forall {A: Type} (m: tree A) i,
  transl' (remove i m) = O.remove i (transl' m).
Proof.
  induction m; simpl; intros.
- auto.
- destruct (prefix p i) as [ii | ] eqn:P.
  + apply prefix_charact in P. subst i. rewrite o_remove_app.
    destruct ii; rewrite transl'_node', o_remove_node'; f_equal; auto; f_equal; auto.
  + rewrite o_remove_notpref by auto. auto.
Qed.

(** ** Good variable properties for the basic operations *)

(** Obtained by transporting the good variable properties for
    plain binary tries. *)

Theorem gempty:
  forall {A} (i: positive), get i (empty A) = None.
Proof.
  auto.
Qed.

Theorem gss:
  forall {A} (i: positive) (x: A) (m: tree A), get i (set i x m) = Some x.
Proof.
  intros. rewrite transl_get, transl_set. apply O.gss.
Qed.

Theorem gso:
  forall {A} (i j: positive) (x: A) (m: tree A), i <> j -> get i (set j x m) = get i m.
Proof.
  intros. rewrite ! transl_get, transl_set. apply O.gso; auto.
Qed.

Theorem grs:
  forall {A} (i: positive) (m: tree A), get i (remove i m) = None.
Proof.
  intros. rewrite transl'_get, transl_remove. apply O.grs.
Qed.

Theorem gro:
  forall {A} (i j: positive) (m: tree A),
  i <> j -> get i (remove j m) = get i m.
Proof.
  intros. rewrite ! transl'_get, transl_remove. apply O.gro; auto.
Qed.

(** ** Collective operations over tries *)

(** The [map_filter] operation combines a "map" (apply a function to
    every value of a trie) and a "filter" (keep only the values
    that satisy a given predicate).  The function [f] being mapped
    has type [A -> option B].  A value [a] in the input trie
    becomes a value [b] in the output trie if [f a = Some b]
    and is absent in the output trie if [f a = None]. *)

Section MAP_FILTER.

Variables A B: Type.

Definition option_map (f: A -> option B) (o: option A): option B :=
  match o with None => None | Some a => f a end.

Fixpoint map_filter (f: A -> option B) (m: tree A) : tree B :=
  match m with
  | Leaf => Leaf
  | Node p l o r => Node' p (map_filter f l) (option_map f o) (map_filter f r)
  end.

Lemma gmap_filter:
  forall (f: A -> option B) (m: tree A) (i: positive),
  get i (map_filter f m) = option_map f (get i m).
Proof.
  induction m; intros; simpl.
  - auto.
  - rewrite gNode'. destruct (prefix p i) as [i'|]; auto. destruct i'; auto.
Qed.

End MAP_FILTER.

(** The [combine] operation traverses two tries in parallel,
    applying a function [f: option A -> option B -> option C]
    at each node to build the resulting trie. *)

Section COMBINE.

Variables A B C: Type.
Variable f: option A -> option B -> option C.
Hypothesis f_None_None: f None None = None.

Let combine_r := map_filter (fun b => f None (Some b)).
Let combine_l := map_filter (fun a => f (Some a) None).

Fixpoint combine (m1: tree A) (m2: tree B): tree C :=
  match m1 with
  | Leaf => combine_r m2
  | Node p1 l1 o1 r1 =>
      let fix combi (p1: positive) (m2: tree B) : tree C :=
        match m2, p1 with
        | Leaf, _ => combine_l (Node p1 l1 o1 r1)
        | Node xH l2 o2 r2, xH => Node' xH (combine l1 l2) (f o1 o2) (combine r1 r2)
        | Node xH l2 o2 r2, xO p1 => Node' xH (combi p1 l2) (f None o2) (combine_r r2)
        | Node xH l2 o2 r2, xI p1 => Node' xH (combine_r l2) (f None o2) (combi p1 r2)
        | Node (xO p2) l2 o2 r2, xH => Node' xH (combine l1 (Node p2 l2 o2 r2)) (f o1 None) (combine_l r1)
        | Node (xO p2) l2 o2 r2, xO p1 => Node' xH (combi p1 (Node p2 l2 o2 r2)) None Leaf
        | Node (xO p2) l2 o2 r2, xI p1 => Node' xH (combine_r (Node p2 l2 o2 r2)) None (combine_l (Node p1 l1 o1 r1))
        | Node (xI p2) l2 o2 r2, xH => Node' xH (combine_l l1) (f o1 None) (combine r1 (Node p2 l2 o2 r2))
        | Node (xI p2) l2 o2 r2, xO p1 => Node' xH (combine_l (Node p1 l1 o1 r1)) None (combine_r (Node p2 l2 o2 r2))
        | Node (xI p2) l2 o2 r2, xI p1 => Node' xH Leaf None (combi p1 (Node p2 l2 o2 r2))
        end
      in combi p1 m2
  end.

Lemma gcombine_l: forall i m1, get i (combine_l m1) = f (get i m1) None.
Proof.
  unfold combine_l; intros. rewrite gmap_filter. destruct (get i m1); auto.
Qed.

Lemma gcombine_r: forall i m2, get i (combine_r m2) = f None (get i m2).
Proof.
  unfold combine_r; intros. rewrite gmap_filter. destruct (get i m2); auto.
Qed.

Lemma gNode'1: forall {A} i l (x: option A) r,
  get i (Node' xH l x r) =
    match i with xH => x | xO ii => get ii l | xI ii => get ii r end.
Proof.
  intros. rewrite gNode'. auto.
Qed.

Lemma gcombine:
  forall (m1: tree A) (m2: tree B) (i: positive),
  get i (combine m1 m2) = f (get i m1) (get i m2).
Proof.
  Local Opaque map_filter.
  Local Opaque Node'.
  induction m1; simpl; intros.
- apply gcombine_r.
- rename m1_1 into l1, o into o1, m1_2 into r1. revert m2 i.
  induction p; destruct m2 as [ | p2 l2 o2 r2]; intros; try (apply gcombine_l); destruct p2 as [ p2 | p2 | ]; rewrite ? gNode'1.
  + destruct i; auto. rewrite IHp; auto.
  + destruct i; rewrite ? gcombine_l, ? gcombine_r; auto.
  + destruct i; rewrite ? gcombine_r; auto. rewrite IHp; auto.
  + destruct i; rewrite ? gcombine_l, ? gcombine_r; auto.
  + destruct i; auto. rewrite IHp; auto.
  + destruct i; rewrite ? gcombine_r; auto. rewrite IHp; auto.
  + destruct i; rewrite ? gcombine_l; auto. rewrite IHm1_2; auto.
  + destruct i; rewrite ? gcombine_l; auto. rewrite IHm1_1; auto.
  + destruct i; auto. rewrite IHm1_2; auto. rewrite IHm1_1; auto.
Qed.

End COMBINE.

End PTree.


Require Import Coq.Setoids.Setoid.
Require Import List.
Require Import JamesTactics.
Require Import Misc.
Require Import ListEx.
Require Import EqDec.
Require Import Enumerable.
Import ListNotations.

Class SpaceSearch := {
  Space : Type -> Type;
  empty : forall {A}, Space A;
  single : forall {A}, A -> Space A;
  union : forall {A}, Space A -> Space A -> Space A;
  bind : forall {A B}, Space A -> (A -> Space B) -> Space B;
  search : forall {A}, Space A -> option A;

  contains : forall {A}, A -> Space A -> Prop;
  emptyOk : forall {A} {a:A}, ~contains a empty;
  singleOk : forall {A} {a a':A}, a = a' <-> contains a' (single a);
  unionOk : forall {A S T} {a:A}, (contains a S \/ contains a T) <-> contains a (union S T);
  bindOk : forall {A B S f} {b:B}, (exists a:A, contains a S /\ contains b (f a)) <-> contains b (bind S f);
  searchOk : forall {A S} {a:A}, search S = Some a -> contains a S;
  searchOk' : forall {A S} {a:A}, search S = None -> ~contains a S
}.

Section SpaceSearch.
  Context `{SpaceSearch}.

  Class Free A := {
    free : Space A;
    freeOk : forall (a:A), contains a free
  }.

  Arguments free _ [_].

  Global Instance freeBool : Free bool.
    refine {|
      free := union (single true) (single false)
    |}.
  Proof.
    intro b.
    rewrite <- unionOk.
    destruct b.
    - left. apply singleOk. reflexivity.
    - right. apply singleOk. reflexivity.
  Defined.

  Global Instance freeSigT {A B} `{Free A}
                          `{forall a:A, Free (B a)} :
                            Free (sigT B).
    refine {|
      free := bind (free A) (fun a =>
              bind (free (B a)) (fun b =>
              single [a & b]))
    |}.
  Proof.
    intros [a b].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    apply singleOk.
    reflexivity.
  Defined.

  Global Instance freeProd {A B} `{Free A} `{Free B} : Free (A * B).
    refine {|
      free := bind (free A) (fun a =>
              bind (free B) (fun b =>
              single (a, b)))
    |}.
  Proof.
    intros [a b].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    rewrite <- bindOk; eexists.
    constructor; [apply freeOk|].
    apply singleOk.
    reflexivity.
  Defined.

  Global Instance freeEmpty : Free Empty_set.
    refine {| free := empty |}.
  Proof.
    intros [].
  Defined.

  Global Instance freeUnit : Free unit.
    refine {| free := single tt |}.
  Proof.
    intros [].
    apply singleOk.
    reflexivity.
  Defined.

  Global Instance freeListIn {A} l : Free {a:A | In a l}.
    refine {| free := _ |}.
    refine (list_rect (fun l => Space {a:A | In a l}) empty (fun a l' S => _) l).
    refine (union (single (exist _ a _))
             (bind S (fun p =>
             (single (exist (fun a' => In a' (a::l')) (proj1_sig p) _))))).
  Proof.
  - cbn.
    left.
    reflexivity.
  - cbn.
    right.
    exact (proj2_sig p).
  - induction l as [|a l IHl].
    * intros [? []].
    * intros [a' l'].
      cbn in *.
      rewrite <- unionOk.
      destruct l'.
      + subst.
        left.
        apply singleOk.
        reflexivity.
      + right.
        specialize (IHl (exist _ a' i)).
        rewrite <- bindOk.
        eexists.
        split; [apply IHl|].
        apply singleOk.
        reflexivity.
  Defined.
End SpaceSearch.

Arguments free [_] _ [_].

Instance listSpaceSearch : SpaceSearch.
  refine {|
    Space := list;
    empty A := [];
    single A a := [a];
    union A l l' := l ++ l';
    bind A B S f := concat (f <$> S);
    search A l := match l with [] => None | a::_ => Some a end;
    contains := In
  |}.
Proof.
  - compute.
    trivial.
  - compute.
    intros.
    constructor.
    * left.
      trivial.
    * intro h.
      destruct h; intuition.
  - symmetry.
    apply in_app_iff.
  - intros A B l f b.
    constructor.
    * intro h.
      destruct h as [a [al bfa]].
      induction l as [|a'].
      + compute in *.
        intuition.
      + cbn in *.
        rewrite in_app_iff.
        destruct al. {
          left.
          subst_max.
          intuition.
        } {
          right.
          intuition.
        }
    * intro h.
      induction l.
      + compute in h.
        intuition.
      + cbn in h.
        rewrite in_app_iff in *.
        destruct h. {
          exists a.
          cbn.
          intuition.
        } {
          specialize (IHl H).
          destruct IHl as [a' []].
          exists a'.
          intuition.
        }
  - intros.
    break_match.
    * intuition.
      inversion H.
    * intuition.
      inversion H.
      subst_max.
      cbn.
      left.
      reflexivity.
  - intros.
    break_match.
    * cbn.
      intuition.
    * inversion H.
Defined.

Global Instance enumerableFree {A} `{@Free listSpaceSearch A} : enumerable A.
  refine {| enumerate := free A |}.
Proof.
  exact freeOk.
Defined.


Require Import Metalib.Metatheory.
Require Import Coq.Program.Equality.
Require Import Coq.Sorting.Permutation.

Set Implicit Arguments.

Inductive subsequence {A : Type} : list A -> list A -> Prop :=
  | subseq_base : forall ys,
      subsequence nil ys
  | subseq_cons : forall y xs ys,
      subsequence xs ys ->
      subsequence xs (y :: ys)
  | subseq_both : forall x xs ys,
      subsequence xs ys ->
      subsequence (x :: xs) (x :: ys).

Hint Constructors subsequence.

Lemma subseq_refl : forall A (xs : list A),
    subsequence xs xs.
Proof.
  induction xs; auto.
Qed.

Lemma subseq_weaken_left : forall A (us xs zs : list A),
    subsequence xs zs ->
    subsequence xs (us ++ zs).
Proof.
  induction us; simpl; auto.
Qed.

Lemma subseq_weaken_right : forall A (us xs ys : list A),
    subsequence xs ys ->
    subsequence xs (ys ++ us).
Proof.
  induction 1; simpl; auto.
Qed.

Lemma subseq_reduce_left_cons : forall A (x : A) (xs ys : list A),
    subsequence (x :: xs) ys ->
    subsequence xs ys.
Proof.
  intros A x xs ys H1. dependent induction H1; eauto.
Qed.

Lemma subseq_reduce_left : forall A (us xs ys : list A),
    subsequence (us ++ xs) ys ->
    subsequence xs ys.
Proof.
  induction us; eauto using subseq_reduce_left_cons.
Qed.

Lemma subseq_reduce_both : forall A (x y : A) (xs ys : list A),
    subsequence (x :: xs) (y :: ys) ->
    subsequence xs ys.
Proof.
  inversion 1; eauto using subseq_reduce_left_cons.
Qed.

Lemma subseq_dom : forall A (x1 : atom) (E1 E2 : list (atom * A)),
    x1 `notin` dom E2 ->
    subsequence E1 E2 ->
    x1 `notin` dom E1.
Proof.
  intros A x1 E1 E2 H1 H2; induction H2;
    try destruct x as [x2 T2];
    try destruct y as [x3 T3];
    try solve [solve_uniq].
Qed.

Lemma subseq_uniq : forall A (E1 E2 : list (atom * A)),
    uniq E2 ->
    subsequence E1 E2 ->
    uniq E1.
Proof.
  intros A E1 E2 H1 H2; induction H2;
    try destruct x as [x2 T2];
    try destruct y as [x3 T3];
    try solve [solve_uniq].
  - inversion H1; eauto using subseq_dom.
Qed.

Lemma subseq_binds : forall A (E1 E2 : list (atom * A)),
    (* uniq E2 -> *)
    subsequence E1 E2 ->
    (forall x1 T1, binds x1 T1 E1 -> binds x1 T1 E2).
Proof.
  intros A E1 E2 H1 x1 T1 H2.
  induction H1 as [| [x2 T2] | [x2 T2]]; auto.
  - analyze_binds H2.
  - analyze_binds H2.
Qed.

Lemma subseq_reduce_notin : forall A (x1 : atom) (T1 : A) (E1 E2 : list (atom * A)),
    x1 `notin` dom E1 ->
    subsequence E1 ((x1 ~ T1) ++ E2) ->
    subsequence E1 E2.
Proof.
  induction E1; intros E2 H1 H2; eauto;
    try destruct a as [x2 T2].
  - assert (D1 : x1 <> x2) by solve_uniq.
    inversion H2; subst; intuition.
Qed.

Lemma subseq_remove_left_notin : forall A (x1 : atom) (T1 : A) (E1 F2 : list (atom * A)),
    x1 `notin` dom E1 ->
    subsequence E1 ((x1 ~ T1) ++ F2) ->
    subsequence E1 F2.
Proof.
  intros A x1 T1 E1 F2 H1 H2.
  dependent induction H2; simpl; eauto.
  - simpl in H1. solve_uniq.
Qed.

Lemma subseq_remove_mid_notin : forall A (x1 : atom) (T1 : A) (E1 F1 F2 : list (atom * A)),
    x1 `notin` dom E1 ->
    subsequence E1 (F1 ++ (x1 ~ T1) ++ F2) ->
    subsequence E1 (F1 ++ F2).
Proof.
  intros A x1 T1 E1 F1.
  generalize dependent E1.
  dependent induction F1;
    intros E1 E2 H1 H2;
    try destruct a as [x2 T2].
  - eapply subseq_remove_left_notin; eauto.
  - inversion H2; subst; simpl; eauto.
Qed.

Lemma subseq_notin_reverse : forall A (x1 : atom) (E1 E2 : list (atom * A)),
    x1 `notin` dom E2 ->
    subsequence E1 E2 ->
    x1 `notin` dom E1.
Proof.
  intros A x1 E1 E2 H1 H2; induction H2;
  try destruct x as [x2 T2];
  try destruct y as [x3 T3]; eauto.
Qed.

Lemma subseq_invert_cons : forall A (x1 x2 : atom) (T1 T2 : A) (E1 E2 : list (atom * A)),
    x1 `notin` dom E2 ->
    subsequence ((x1 ~ T1) ++ E1) ((x2 ~ T2) ++ E2) ->
    x1 = x2 /\ T1 = T2.
Proof.
  intros A x1 x2 T1 T2 E1 E2 H1 H2.
  dependent induction H2; eauto.
  - pose proof (subseq_notin_reverse H1 H2).
    simpl in H. solve_uniq.
Qed.

Lemma subseq_cons_mid : forall A (u : A) (xs ys vs us : list A),
    subsequence (xs ++ ys) (vs ++ us) ->
    subsequence (xs ++ ys) (vs ++ u :: us).
Proof.
  intros A u xs ys vs us H1. dependent induction H1.
  - apply nil_eq_app in x as [? ?]. subst. constructor.
  - apply cons_eq_app in x as [[zs [? ?]] | [? ?]]; subst; simpl; eauto.
  - apply cons_eq_app in x1 as [[ws [? ?]] | [? ?]]; subst; simpl;
    apply cons_eq_app in x as [[zs [? ?]] | [? ?]]; subst; simpl; eauto.
    + apply subseq_both. rewrite_env (nil ++ xs0). eauto.
Qed.

Lemma subseq_trans : forall A (xs ys zs : list A),
    subsequence xs ys ->
    subsequence ys zs ->
    subsequence xs zs.
Proof.
  intros A xs ys zs H1 H2.
  generalize dependent ys.
  generalize dependent xs.
  induction zs; intros xs ys H1 H2; eauto.
  - inversion H2; subst; eauto.
  - inversion H1; subst; eauto.
    + apply subseq_reduce_both in H2. eauto.
    + inversion H2; subst; eauto.
Qed.

Lemma uniq_subseq_app : forall A (E1 E2 E3 : list (atom * A)),
    subsequence E1 E2 ->
    uniq E1 ->
    uniq (E3 ++ E2) ->
    uniq (E3 ++ E1).
Proof.
  intros A E1 E2 E3 H1 H2 H3.
  induction H1 as [| [x1 T1] | [x1 T1]]; simpl_env.
  - solve_uniq.
  - eapply IHsubsequence; solve_uniq.
  - apply uniq_insert_mid.
    + assert (H4 : uniq ys) by solve_uniq.
      pose proof (subseq_uniq H4 H1) as H5.
      apply IHsubsequence; solve_uniq.
    + solve_uniq.
    + solve_uniq.
Qed.

Lemma subseq_length : forall {A : Type} (xs ys : list A),
    subsequence xs ys ->
    length xs <= length ys.
Proof.
  intros A xs ys H1.
  induction H1; simpl; auto with arith.
Qed.

Lemma permute_subseq_equal : forall A (E1 E2 : list (atom * A)),
    Permutation E1 E2 ->
    subsequence E1 E2 ->
    E1 = E2.
Proof.
  intros A E1 E2 H1 H2; induction H2;
    try destruct x as [x1 T1];
    try destruct y as [x2 T2].
  - rewrite (Permutation_nil H1). reflexivity.
  - apply Permutation_length in H1. simpl in H1.
    apply subseq_length in H2. rewrite H1 in H2.
    exfalso. eapply Nat.nle_succ_diag_l. eauto.
  - apply Permutation_cons_inv in H1.
    f_equal. apply IHsubsequence; assumption.
Qed.

Lemma subseq_app_head : forall A (xs ys us vs : list A),
    subsequence xs ys ->
    subsequence us vs ->
    subsequence (xs ++ us) (ys ++ vs).
Proof.
  intros A xs ys us vs H1 H2.
  dependent induction H1 generalizing us vs; simpl; auto.
  - apply subseq_weaken_left; auto.
Qed.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.
Require Import UniMath.Combinatorics.FiniteSets.
Require Import UniMath.CategoryTheory.Core.Categories.

Require Import prelude.
Require Import syntax.containers.
Require Import syntax.hit_signature.
Require Import syntax.W_types.
Require Import algebra.set_algebra.

Local Open Scope container_scope.

(**
Natural numbers modulo 2

Inductive ring : Type :=
| 0 : ring
| +
| S : ℕ₂ → ℕ₂
| mod : ∏ (n : ℕ₂), S(S n) = n
 *)
Definition mod2_sig_point_constr
  : container.
Proof.
  use make_container.
  - exact boolset.
  - intro b.
    destruct b.
    + exact emptyset.
    + exact unitset.
Defined.

Definition mod2_sig_path_arg
  : container.
Proof.
  use make_container.
  - exact unitset.
  - exact (λ _, unitset).
Defined.

Definition mod2_sig_lhs
  : W mod2_sig_point_constr unitset.
Proof.
  simple refine (sup _ (λ _, sup _ (λ _, var _))) ; cbn.
  - exact false.
  - exact false.
  - exact tt.
Defined.

Definition mod2_sig_rhs
  : W mod2_sig_point_constr unitset.
Proof.
  apply var.
  exact tt.
Defined.

Definition mod2_sig : hit_signature.
Proof.
  use make_hit_signature.
  - exact mod2_sig_point_constr.
  - exact mod2_sig_path_arg.
  - exact (λ _, mod2_sig_lhs).
  - exact (λ _, mod2_sig_rhs).
Defined.

Definition is_finitary_mod2_sig
  : is_finitary_hit mod2_sig.
Proof.
  split.
  - intro x.
    destruct x ; cbn -[isfinite].
    + apply isfiniteempty.
    + apply isfiniteunit.
  - intro.
    apply isfiniteunit.
Qed.

Section Mod2Algebra.
  Variable (X : hit_algebra mod2_sig).

  Definition mod2_carrier
    : hSet
    := pr11 X.

  Definition mod2_Z
    : mod2_carrier
    := pr21 X (true ,, fromempty).

  Definition mod2_S
    : mod2_carrier → mod2_carrier
    := λ x, pr21 X (false ,, (λ _, x)).

  Definition mod2_path
    : ∏ (n : mod2_carrier), mod2_S (mod2_S n) = n
    := λ n, pr2 X tt (λ _ , n).
End Mod2Algebra.

Definition make_mod2_algebra
           (X : hSet)
           (Z : X)
           (S : X → X)
           (p : ∏ (n : X), S(S n) = n)
  : hit_algebra mod2_sig.
Proof.
  simple refine ((X ,, _) ,, _) ; cbn.
  - intro x.
    induction x as [x arg].
    induction x ; cbn in *.
    + exact Z.
    + exact (S (arg tt)).
  - exact (λ _ n, p (n tt)).
Defined.

Definition bool_mod2_sig
  : hit_algebra mod2_sig.
Proof.
  use make_mod2_algebra.
  - exact boolset.
  - exact false.
  - exact negb.
  - intro b ; induction b ; cbn.
    + apply idpath.
    + apply idpath.
Defined.


Variables P Q : nat -> Prop.
Variable f : nat -> nat.

Goal forall (x:nat), (forall y, P y -> forall z, Q z -> y=f z -> False) -> False.
Proof.
intros.
ecase H with (3:=eq_refl).
Abort.

Goal forall (x:nat), (forall y, y=x -> False) -> False.
Proof.
intros.
unshelve ecase H with (1:=eq_refl).
Qed.


Require Import A1_Plan A2_Orientation A4_Droite A7_Tactics .
Require Import B1_ClockwiseProp B2_CollinearProp B3_EquiOrientedProp B4_RaysProp B5_BetweenProp B7_Tactics .
Require Import C1_Distance C7_Tactics .
Require Import D2_ExistsClockwise.

Unset Standard Proposition Elimination Names.

Section SECOND_DIMENSION.

Ltac setClockwise A B H C :=
	pose (C := ExistsClockwise A B H);
	let Hyp := fresh in (
	assert (Hyp := ClockwiseExistsClockwise A B H);
	fold C in Hyp).

Lemma OpenRayDistinct : forall A B C : Point,
	A <> B -> OpenRay A B C -> A <> C.
Proof.
	intros.
	setClockwise A B H ipattern:(D).
	from2 H0 (Clockwise A D C).
Qed.

Lemma BetweenDistinctBC : forall A B C : Point,
	Between A B C -> B <> C.
Proof.
	intros A B C (H, H0).
	setClockwise A B H ipattern:(D).
	from2 H0 (Clockwise B D C).
Qed.

Lemma BetweenSym : forall A B C : Point,
	Between A B C -> Between C B A.
Proof.
	intros A B C (H, H0); split.
	 apply sym_not_eq; apply (BetweenDistinctBC A B C); canonize1.
	 immediate2.
Qed.

Lemma  BetweenDistinctAC : forall A B C : Point,
	Between A B C -> A <> C.
Proof.
	intros A B C (H, H0).
	apply (OpenRayDistinct A B C H).
	apply BetweenOpenRayAB; canonize1.
Qed.

Lemma BetweenOpenRayCA : forall A B C : Point,
	Between A B C -> OpenRay C A B.
Proof.
	intros; apply OpenRaySym.
	 apply sym_not_eq; apply (BetweenDistinctBC _ _ _ H).
	 apply BetweenOpenRayCB; trivial.
Qed.

Lemma BetweenTransACD : forall A B C D : Point,
	Between A B C ->
	Between B C D ->
	Between A C D.
Proof.
	intros.
	apply BetweenSym; apply (OpenRayBetween D C B A).
	 immediate2.
	 apply BetweenSym; immediate2.
Qed.

Lemma BetweenTransBCD : forall A B C D : Point,
	Between A B C ->
	Between A C D ->
	Between B C D.
Proof.
	intros.
	apply BetweenSym; apply (OpenRayBetween D C A B).
	 apply BetweenOpenRayCA; immediate2.
	 apply BetweenSym; immediate2.
Qed.

Lemma BetweenTransABD : forall A B C D : Point,
	Between A B C ->
	Between A C D ->
	Between A B D.
Proof.
	intros; split.
	 immediate2.
	 assert (H1 := BetweenTransBCD A B C D H H0).
	   assert (H2 := BetweenOpenRayAC B C D H1).
	   step2 H2.
	   apply (BetweenDistinctAC B C D H1).
Qed.

Lemma Apart : forall A B C : Point,
	A <> B -> A <> C \/ B <> C.
Proof.
	intros.
	by4Cases1 A B C.
	 right; immediate2.
	 right; immediate2.
	 left; apply (OpenRayDistinct A B C H H0).
	 right; apply (OpenRayDistinct B A C); auto.
Qed.

Lemma EquiOrientedDistinct : forall A B C D : Point,
	A <> B -> EquiOriented A B C D ->
	C <> D.
Proof.
	intros.
	setClockwise B A (sym_not_eq H) ipattern:(E).
	from2 H0 (Clockwise C D E).
Qed.

Lemma BetweenClockwiseOrClockwiseBC : forall A B C M : Point,
	Between A B C -> Clockwise A B M \/ Clockwise A C M ->
	Clockwise B C M.
Proof.
	intros.
	assert (H1 := BetweenOpenRayAB A B C H).
	canonize1.
	apply H3; step2 H1; trivial.
Qed.

Lemma BetweenClockwiseOrClockwiseAC : forall A B C M : Point,
	Between A B C -> Clockwise A B M \/ Clockwise B C M ->
	Clockwise A C M.
Proof.
	intros.
	assert (H1 := BetweenOpenRayAB A B C H).
	canonize1.
	apply H1; step2 H3.
Qed.

Lemma BetweenClockwiseOrClockwiseAB : forall A B C M : Point,
	Between A B C -> Clockwise A C M \/ Clockwise B C M ->
	Clockwise A B M.
Proof.
	intros.
	assert (H1 := BetweenOpenRayAB A B C H).
	canonize1.
	 step2 H1; trivial.
	 step2 H3; trivial.
Qed.

Lemma OpenRaysBetween : forall A B C D E : Point,
	Between B A C ->
	OpenRay A B D  ->
	OpenRay A C E ->
	Between D A E.
Proof.
	canonize1.
	 subst.
	   setClockwise B A H2 ipattern:(F).
	   elim (NotClockwiseAAB A F); step2 H.
	 step2 H1.
	   step2 H3.
	   step2 H0.
Qed.

Lemma DistinctOrDistinct : forall A B C D : Point,
	A <> B ->
	(Distance A B = Distance C D) \/
	(EquiOriented A B C D) ->
	C <> D.
Proof.
	intros A B C D H [H0| H1].
	 apply (DistinctEqDistanceDistinct A B C D H H0).
	 apply (EquiOrientedDistinct A B C D H H1).
Qed.

Lemma DistinctOrDistinctABC : forall A B C : Point,
	A <> B ->
	(OpenRay A B C) \/
	(Distance A B = Distance A C) \/
	(EquiOriented A B A C) ->
	A <> C.
Proof.
	intros A B C H [H0| [H1| H2]].
	 apply (OpenRayDistinct A B C H H0).
	 apply (DistinctEqDistanceDistinct A B A C H H1).
	 apply (EquiOrientedDistinct A B A C H H2).
Qed.

Lemma EquiOrientedCollinearBCDCollinearABC : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear B C D ->
	Collinear A B C.
Proof.
	intros; split.
	 immediate2.
	 intro; assert (EquiOriented B A D C).
	  apply ChangeSide.
	   apply ChangeAll.
	    trivial.
	    immediate2.
	    intuition.
	   apply (EquiOrientedDistinct A B); immediate2.
	  contradict1 H1 H2.
Qed.

Lemma EquiOrientedCollinearABDCollinearABC : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A B D ->
	Collinear A B C.
Proof.
	intros; split.
	 immediate2.
	 intro H1; decompose [or] (FourthPoint B A C D H1).
	  contradict1 H0 H2.
	  contradict1 H H3.
	  setLine0 A B ipattern:(ab).
	   immediate2.
	   setCircle0 D A B ipattern:(gamma).
	     setInterDiameter ab gamma ipattern:(A').
	     elim (NotClockwiseABA A' D).
	     apply (ChangeSide _ _ _ _ Heo).
	    apply (DistinctEqDistanceDistinct A B D A'); immediate2.
	    step2 H.
	      step2 Heo.
	      apply (DistinctEqDistanceDistinct A B D A'); immediate2.
Qed.

Lemma EquiOrientedCollinearACDCollinearABC : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A C D ->
	Collinear A B C.
Proof.
	intros; split.
	 immediate2.
	 intro; elim (ClockwiseBACNotCollinear _ _ _ H1).
	   apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H).
	   apply CollinearCBA; apply (EquiOrientedCollinearABDCollinearABC D C B A).
	  step2 H.
	  immediate2.
Qed.

Lemma EquiOrientedCollinearBCDCollinearABD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear B C D ->
	Collinear A B D.
Proof.
	intros; from2 H (EquiOriented B A D C).
	   apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H H0).
	 apply CollinearBAC; apply (EquiOrientedCollinearACDCollinearABC _ _ _ _ H1).
	   immediate2.
Qed.

Lemma EquiOrientedCollinearABCCollinearABD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A B C ->
	Collinear A B D.
Proof.
	intros;from2 H (EquiOriented B A D C).
	 apply CollinearBAC; apply (EquiOrientedCollinearABDCollinearABC _ _ _ _ H1).
	   immediate2.
Qed.

Lemma EquiOrientedCollinearACDCollinearABD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A C D ->
	Collinear A B D.
Proof.
	intros;from2 H (EquiOriented B A D C).
	   apply (EquiOrientedCollinearACDCollinearABC _ _ _ _ H H0).
	 apply CollinearBAC; apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H1).
	   immediate2.
Qed.

Lemma EquiOrientedCollinearBCDCollinearACD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear B C D ->
	Collinear A C D.
Proof.
	intros; split.
	 intro H1; decompose [or] (FourthPoint A C D B H1).
	  elim (ClockwiseBACNotCollinear _ _ _ H2).
	    apply CollinearCAB;
	     apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H H0).
	  elim (ClockwiseABCNotCollinear _ _ _ H3).
	    apply (EquiOrientedCollinearBCDCollinearABD _ _ _ _ H H0).
	  contradict1 H0 H3.
	 intro H1; decompose [or] (FourthPoint C A D B H1).
	  elim (ClockwiseABCNotCollinear _ _ _ H2).
	    apply CollinearCAB;
	     apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H H0).
	  contradict1 H0 H3.
	  elim (ClockwiseBACNotCollinear _ _ _ H3).
	    apply (EquiOrientedCollinearBCDCollinearABD _ _ _ _ H H0).
Qed.

Lemma EquiOrientedCollinearABCCollinearACD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C ->
	Collinear A C D.
Proof.
	intros.
	apply CollinearCBA; apply (EquiOrientedCollinearBCDCollinearABD D C B A).
	 step2 H.
	 immediate2.
Qed.

Lemma EquiOrientedCollinearABDCollinearACD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B D ->
	Collinear A C D.
Proof.
	intros.
	apply CollinearCBA; apply (EquiOrientedCollinearACDCollinearABD D C B A).
	 step2 H.
	 immediate2.
Qed.

Lemma EquiOrientedCollinearACDCollinearBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A C D ->
	Collinear B C D.
Proof.
	intros;from2 H (EquiOriented B A D C).
	   apply (EquiOrientedCollinearACDCollinearABC _ _ _ _ H H0).
	 apply CollinearACB; apply (EquiOrientedCollinearBCDCollinearACD _ _ _ _ H1).
	   immediate2.
Qed.

Lemma EquiOrientedCollinearABCCollinearBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B C ->
	Collinear B C D.
Proof.
	intros.
	apply CollinearCBA; apply (EquiOrientedCollinearBCDCollinearABC D C B A).
	 step2 H.
	 immediate2.
Qed.

Lemma EquiOrientedCollinearABDCollinearBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	A <> B ->
	Collinear A B D ->
	Collinear B C D.
Proof.
	intros.
	apply CollinearCBA; apply (EquiOrientedCollinearACDCollinearABC D C B A).
	 step2 H.
	 immediate2.
Qed.

Lemma EquiOrientedCollinearCollinearABC : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear B C D \/ Collinear A B D\/ Collinear A C D ->
	Collinear A B C.
Proof.
	intuition.
	 apply (EquiOrientedCollinearBCDCollinearABC _ _ _ _ H H1).
	 apply (EquiOrientedCollinearABDCollinearABC _ _ _ _ H H0).
	 apply (EquiOrientedCollinearACDCollinearABC _ _ _ _ H H0).
Qed.

Lemma EquiOrientedCollinearCollinearABD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A B C  \/ Collinear A C D \/ Collinear B C D ->
	Collinear A B D.
Proof.
	intuition.
	 apply (EquiOrientedCollinearABCCollinearABD _ _ _ _ H H1).
	 apply (EquiOrientedCollinearACDCollinearABD _ _ _ _ H H0).
	 apply (EquiOrientedCollinearBCDCollinearABD _ _ _ _ H H0).
Qed.

Lemma EquiOrientedCollinearCollinearACD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear B C D  \/ (A<>B /\ Collinear A B C) \/ (A<>B /\ Collinear A B D) ->
	Collinear A C D.
Proof.
	intuition.
	 apply (EquiOrientedCollinearBCDCollinearACD _ _ _ _ H H1).
	 apply (EquiOrientedCollinearABCCollinearACD _ _ _ _ H H1 H2).
	 apply (EquiOrientedCollinearABDCollinearACD _ _ _ _ H H1 H2).
Qed.

Lemma EquiOrientedCollinearCollinearBCD : forall A B C D : Point,
	EquiOriented A B C D ->
	Collinear A C D  \/ (A<>B /\ Collinear A B C) \/ (A<>B /\ Collinear A B D) ->
	Collinear B C D.
Proof.
	intuition.
	 apply (EquiOrientedCollinearACDCollinearBCD _ _ _ _ H H1).
	 apply (EquiOrientedCollinearABCCollinearBCD _ _ _ _ H H1 H2).
	 apply (EquiOrientedCollinearABDCollinearBCD _ _ _ _ H H1 H2).
Qed.

Lemma TwoPointsOnLineOrientation : forall A B : Point, forall l : Line,
	OnLine l A ->
	OnLine l B ->
	EquiOriented A B (LineA l) (LineB l) \/ EquiOriented A B (LineB l) (LineA l).
Proof.
	intros; destruct l; simplLine1.
	by2Cases1 H.
	 assert (Collinear A0 A B).
	  canonize1.
	   elim H.
	     step2 H1.
	   elim H4.
	     step2 H1.
	  by2Cases1 H2.
	   since2 (Collinear A B A0).
	    by2Cases1 H4.
	     right; canonize1.
	       step2 H1.
	       step2 H5.
	     left; canonize1.
	       step2 H1.
	       step2 H3.
	      apply (OpenRayDistinct A0 B0 A); immediate2.
	      step2 H5.
	   right; canonize1.
	     step2 H1.
	     step2 H3.
	     apply sym_not_eq; apply (OpenRayDistinct A0 B0 A); immediate2.
	 assert (Collinear B0 A B).
	  canonize1.
	   elim H4; step2 H1.
	   elim H; step2 H1.
	  by2Cases1 H2.
	   since2 (Collinear A B B0).
	    by2Cases1 H4.
	     left; canonize1.
	       step2 H1.
	       step2 H5.
	     right; canonize1.
	       step2 H1.
	       step2 H3.
	      apply (OpenRayDistinct B0 A0 A); immediate2.
	      step2 H5.
	   left; canonize1.
	     step2 H1.
	     step2 H3.
	     apply sym_not_eq; apply (OpenRayDistinct B0 A0 A); immediate2.
Qed.

Lemma OnLine3 : forall d : Line, forall A B C : Point,
	OnLine d A ->
	OnLine d B ->
	OnLine d C ->
	Collinear A B C.
Proof.
	destruct d; simplLine1; intros.
	destruct (Apart A B A0 n).
	 from2 H (Collinear A0 A B0).
	   from2 H (Collinear A0 A C).
	   step1 H3.
	 from2 H (Collinear A0 B B0).
	   from2 H (Collinear A0 B C).
	   step1 H3.
Qed.

End SECOND_DIMENSION.


(** * Structural Rules

This file proves some structural properties as exchange (for the
classical and linear context) as well as weakening and contraction in
the classical context. *)

Require Export FLL.Misc.Utils.
Require Export FLL.SL.Sequent.

Export ListNotations.
Export LLNotations .
Set Implicit Arguments.

Section FLLBasicTheory.
  Context `{OLS: OLSig}.

  Section StructuralProperties.
    Variable theory : oo -> Prop. (* Theory Definition *)

    Notation " n '|-F-' B ';' L ';' X " := (seqN theory n B L X)  (at level 80).
    Hint Constructors seqN : core .
    Notation " '|-f-' B ';' L ';' X " := (seq theory B L X)  (at level 80).
    Hint Constructors seq : core.

    (**  Exchange Rule: Classical Context *)
    Theorem exchangeCCN : forall n  CC CC' LC  (X: Arrow) ,
        Permutation CC CC' ->
        n |-F- CC ; LC ; X -> n |-F- CC' ; LC ; X.
      induction n using strongind;intros.
      + inversion H0;subst;eauto.
        apply tri_init2;eauto using Permutation_in.
      + inversion H1;subst;eauto.
        apply tri_init2;eauto using Permutation_in.
        apply tri_quest.
        eapply H with (CC' := CC' ++ [F]) (CC := CC ++ [F]);auto  using Permutation_app_tail.
        apply @tri_dec2 with (F:=F);eauto using Permutation_in.
    Qed.

    (** Exchange Rule: Linear Context *)
    Theorem exchangeLCN : forall n CC LC LC'  (X: Arrow),
        Permutation LC LC' ->
        (n |-F- CC ; LC ; X) -> n |-F- CC ; LC' ; X.
    Proof with subst;auto.
      induction n using strongind;intros.
      + inversion H0 ...
        apply Permutation_unq in H ...
        apply Permutation_nil in H ...
        apply Permutation_nil in H ...
      + inversion H1;subst;eauto.
        apply Permutation_unq in H0 ...
        apply Permutation_nil in H0 ...
        apply Permutation_nil in H0 ...
        apply @tri_tensor with (M:=M) (N:=N) (MN :=LC');
          eauto using Permutation_sym ,Permutation_trans.
        apply Permutation_nil in H0 ...
        apply tri_store ...
        eapply H;eauto using Permutation_app_tail.

        generalize (Remove_Permutation_Ex2 H4 H0);intros.
        destruct H2 as [M' [H2 H2']].
        eapply @tri_dec1 with (F:=F) (L':=M') ...
        apply H with (LC' := M') (LC:= L');auto.
        rewrite <- H2'...
    Qed.

    (**  Weakening on the classical context *)
    Theorem weakeningN : forall n CC LC  F X ,
        (n |-F- CC ; LC ; X) -> n |-F- F :: CC ; LC ; X.
      induction n using strongind;intros.
      + inversion H;subst;eauto.
        apply tri_init2. right;auto.
      + inversion H0;subst;eauto.
        apply tri_init2. right;auto.
        apply @tri_dec2 with (F:=F0);eauto. right;auto.
    Qed.

    Theorem weakeningGenN (CC LC : multiset oo) CC' X n:
      n |-F- CC ; LC ; X -> n |-F- CC'++ CC ; LC ; X.
      intro H.
      induction CC';simpl;auto.
      apply weakeningN;auto.
    Qed.

    Theorem weakeningGenN_rev (CC LC : multiset oo) CC' X n:
      n |-F- CC ; LC ; X -> n |-F- CC++ CC' ; LC ; X.
      intros.
      eapply exchangeCCN with (CC := CC' ++ CC);auto.
      apply Permutation_app_comm; auto.
      apply weakeningGenN;auto.
    Qed.

    (**  Weakening on the classical context *)
    Theorem weakening (CC LC : multiset oo) F X:
    |-f- CC ; LC ; X -> |-f- F :: CC ; LC ; X.
      intro H.
      induction H;eauto.
      apply tri_init2'. right;auto.
      apply @tri_dec2' with (F:=F0);eauto. right;auto.
    Qed.

    Theorem weakeningGen (CC LC : multiset oo) CC' X:
    |-f- CC ; LC ; X -> |-f- CC' ++ CC ; LC ; X.
      intro H.
      induction CC';simpl;auto.
      apply weakening;auto.
    Qed.

    (**  Exchange Rule: Classical Context *)
    Theorem exchangeCC (CC CC' LC : multiset oo) (X: Arrow):
      Permutation CC CC' ->
    |-f- CC ; LC ; X -> |-f- CC' ; LC ; X.
      intros Hp Hseq.
      generalize dependent CC'.
      induction Hseq;intros;eauto using Permutation_in.
      + apply tri_quest'.
        apply IHHseq;auto using Permutation_app_tail.
    Qed.

    (** Exchange Rule: Linear Context *)
    Theorem exchangeLC (CC LC LC' : multiset oo) (X: Arrow):
      Permutation LC LC' ->
    |-f- CC ; LC ; X -> |-f- CC ; LC' ; X.
    Proof with subst;auto.
      intros Hp Hseq.
      generalize dependent LC'.
      induction Hseq;intros;eauto.
      + apply Permutation_unq in Hp ...
      + apply Permutation_nil in Hp ...
      + apply Permutation_nil in Hp ...
      + apply @tri_tensor' with (M:=M) (N:=N) (MN :=LC');
          eauto using Permutation_sym ,Permutation_trans.
      + apply Permutation_nil in Hp ...
      + apply tri_store' ...
        apply IHHseq.
        apply Permutation_app_tail...
      + generalize (Remove_Permutation_Ex2 H0 Hp) ;intros.
        destruct H1 as [M' [H1 H1']].
        eapply @tri_dec1' with (F:=F) (L':=M') ...
        apply IHHseq.
        rewrite H1' ...
    Qed.

    (** Contraction on the classical context *)
    Theorem contractionN  : forall n CC LC  F X ,
        (n |-F- (F :: CC) ; LC ; X) -> In F CC -> n |-F- CC ; LC ; X.
      induction n using strongind;intros.
      + inversion H;subst;eauto.
        inversion H1;subst;auto.
      + inversion H0;subst;eauto.
        inversion H2;subst;auto.
        simpl in H3. apply H in H3;auto using in_or_app.
        inversion H4;subst.
        apply H in H5;auto.
        apply @tri_dec2 with (F:=F0);eauto.
        apply H in H5;auto.
        apply @tri_dec2 with (F:=F0);eauto.
    Qed.

    Global Instance seq_morphismN  (n:nat) :
      Proper ((@Permutation oo) ==> (@Permutation oo) ==> eq ==> iff)
             (seqN theory n).
    Proof.
      unfold Proper; unfold respectful.
      intros.
      split; intro;subst.
      +  refine (exchangeCCN H _);auto.
         refine (exchangeLCN H0 _);auto.
      + apply Permutation_sym in H.
        apply Permutation_sym in H0.
        refine (exchangeCCN H _);auto.
        refine (exchangeLCN H0 _);auto.
    Qed.

    Global Instance seq_morphism  :
      Proper ((@Permutation oo) ==> (@Permutation oo) ==> eq ==> iff)
             (seq theory).
    Proof.
      unfold Proper; unfold respectful.
      intros.
      split; intro;subst.
      +  refine (exchangeCC H _);auto.
         refine (exchangeLC H0 _);auto.
      + apply Permutation_sym in H.
        apply Permutation_sym in H0.
        refine (exchangeCC H _);auto.
        refine (exchangeLC H0 _);auto.
    Qed.

    Add Parametric Relation (L : multiset oo) (L' : multiset oo)  :
      (multiset oo ) (@Permutation oo)
        reflexivity proved by (@Permutation_refl oo)
        symmetry proved by (@Permutation_sym oo)
        transitivity proved by (@Permutation_trans oo) as eq_perm_seq.

  End StructuralProperties.

  (**  Weakening on the theory [theory] *)
  Section WeakeningTheory.
    Hint Constructors seqN seq : core .
    Variable theory theory' : oo ->Prop .
    Theorem WeakTheoryN : forall n CC LC X ,
        (forall F, theory F -> theory' F) ->
        seqN theory n CC LC X -> seqN theory' n CC LC X.
      induction n using strongind;intros.
      + inversion H0;eauto.
      + inversion H1;subst;eauto.
    Qed.

    Theorem WeakTheory : forall CC LC X,
        (forall F, theory F -> theory' F) ->
        seq theory CC LC X -> seq theory'  CC LC X.
      intros.
      induction H0;eauto.
    Qed.

  End WeakeningTheory.

  Definition EmptyTheory (F :oo) := False.
  Lemma EmptySubSetN : forall (theory : oo-> Prop) CC LC X n,
      seqN EmptyTheory n CC LC X -> seqN theory n CC LC X.
    intros.
    apply WeakTheoryN with (theory:= EmptyTheory);auto.
    intros.
    inversion H0.
  Qed.
  Lemma EmptySubSet : forall (theory : oo-> Prop) CC LC X,
      seq EmptyTheory CC LC X -> seq theory CC LC X.
    intros.
    apply WeakTheory with (theory:= EmptyTheory);auto.
    intros.
    inversion H0.
  Qed.

  (** Admissible rules including alternative definitions for the initial rule *)
  Section AdmissibleRules.
    Variable theory : oo -> Prop.

    Theorem InitPosNegDwN : forall Gamma A,
        seqN theory 4 Gamma   [perp A ] (DW (atom A)).
      intros.
      apply tri_rel.
      constructor.
      apply tri_store.
      intro. inversion H.
      eapply tri_dec1 with (F:= ( perp A)).
      intro;inversion H.
      constructor.
      apply tri_init1.
    Qed.

    Theorem InitPosNegN : forall Gamma A,
        seqN theory 2 Gamma [atom A ; perp A ] (UP []).
      intros.
      eapply tri_dec1 with (F:= (perp A )).
      intro;inversion H.
      repeat constructor.
      apply tri_init1.
    Qed.

    Theorem InitPosNegN' : forall Gamma A,
        seqN theory 2 Gamma [perp A ; atom A ] (UP []).
      intros.
      eapply tri_dec1 with (F:= (perp A )).
      intro;inversion H.
      repeat constructor.
      apply tri_init1.
    Qed.

    Theorem InitPosNegDw : forall Gamma A,
        seq theory Gamma [perp A ] (DW (atom A)).
      intros.
      apply tri_rel'.
      constructor.
      apply tri_store'.
      intro. inversion H.
      eapply tri_dec1' with (F:= (perp A)).
      intro;inversion H.
      constructor.
      apply tri_init1'.
    Qed.

    Theorem InitPosNeg : forall Gamma A,
        seq theory Gamma [atom A ; perp A ] (UP []).
      intros.
      eapply tri_dec1' with (F:= (perp A)).
      intro;inversion H.
      repeat constructor.
      apply tri_init1'.
    Qed.

    Theorem InitPosNeg' : forall Gamma A,
        seq theory Gamma [perp A ; atom A ] (UP []).
      intros.
      eapply tri_dec1' with (F:= (perp A)).
      intro;inversion H.
      repeat constructor.
      apply tri_init1'.
    Qed.

  End AdmissibleRules.

  (** Some simple invertibility lemmas *)
  Section Invertibility.
    Variable theory : oo -> Prop. (* Theory Definition *)

    Theorem FocusAtomN: forall n Gamma Delta A,
        (seqN theory n Gamma Delta (>> ((perp A ) ))) ->
        Delta = [ (atom A)] \/ (Delta = [] /\ In (atom A ) Gamma) .
    Proof with subst;auto.
      intros.
      inversion H ...
      inversion H1.
    Qed.

    Theorem FocusAtom: forall Gamma Delta A,
        (seq theory Gamma Delta (>> ((perp A ) ))) ->
        Delta = [(atom A)]  \/ (Delta = [] /\ In (atom A) Gamma) .
    Proof with subst;auto.
      intros.
      inversion H ...
      inversion H1.
    Qed.

    Theorem FocusAtomTensorN: forall n Gamma Delta A F,
        (seqN theory n Gamma Delta (>> ((perp A) ** F))) ->
        In (atom A) Delta \/ In (atom A) Gamma .
    Proof with subst;auto.
      intros.
      inversion H ...
      inversion H6 ...
      left.
      rewrite H2...
      constructor ...
      inversion H8...
      inversion H1...

      inversion H1...
    Qed.

    Theorem FocusAtomTensor: forall Gamma Delta A F,
        (seq theory Gamma Delta (>> ((perp A) ** F))) ->
        In (atom A) Delta \/ In (atom A) Gamma .
    Proof with subst;eauto.
      intros.
      inversion H ...
      inversion H5 ...
      left.
      rewrite H2.
      constructor...
      inversion H7...
      inversion H1...
      inversion H1...
    Qed.

    Theorem FocusAtomTensorInvN: forall n  A F,
        (seqN theory n []  [atom A] (>> ((perp A) ** F))) ->
        (seqN theory (sub n  1 ) [] [] (>> (F))).
    Proof with subst;auto.
      intros.
      inversion H ...
      apply FocusAtomN  in H6.
      destruct H6;subst.
      apply Permutation_unq in H2;subst.
      inversion H2...
      simpl.
      rewrite Nat.sub_0_r;auto.
      inversion H0.
      inversion H3.
      inversion H1...
    Qed.

  End Invertibility.

  Section GeneralResults.
    Variable Theory : oo -> Prop. (* Theory Definition *)
    Hint Constructors seqN : core .
    Hint Constructors seq : core .

    (** Measure of derivations *)
    Theorem HeightGeq : forall n Gamma Delta X,
        (seqN Theory n Gamma Delta X) ->
        forall m, m>=n -> seqN Theory m Gamma Delta X.
    Proof with eauto.
      induction n;intros ...
      + inversion H ...
      + inversion H;subst; try mgt0;intuition.
        (* tensor *)
        eapply tri_tensor;eauto;eapply IHn;try lia ...

        (* dec *)
        eapply @tri_dec1 with (F:=F);eauto;eapply IHn;try lia...
        eapply @tri_dec2 with (F:=F);eauto;eapply IHn;try lia...
        eapply @tri_dec3 with (F:=F);eauto;eapply IHn;try lia...
        (* exists*)
        eapply tri_ex;eauto;eapply IHn;try lia...
    Qed.

    (** HeightGeq with Exchange Linear Context *)
    Theorem HeightGeqEx : forall n CC LC LC' X,
        Permutation LC LC' ->
        (seqN Theory n  CC LC' X) ->
        forall m, m>=n -> (seqN Theory m  CC LC X).
    Proof with eauto.
      intros.
      eapply HeightGeq with (n:=n);auto.
      symmetry in H.
      eapply exchangeLCN;eauto.
    Qed.
  End GeneralResults.

  (** Adequacy relating the system with and without inductive meassures *)
  Section Adequacy.
    (* Relating the system with and without measures *)
    Variable theory : oo -> Prop. (* Theory Definition *)
    Hint Constructors seqN : core .
    Hint Constructors seq : core.

    Theorem seqNtoSeq : forall n Gamma Delta X ,  (seqN theory n Gamma Delta X) -> seq theory  Gamma Delta X.
      induction n using strongind;intros;eauto.
      + inversion H;subst;eauto.
      + inversion H0;subst;eauto.
    Qed.

    Axiom seqtoSeqN : forall Gamma Delta X ,
        (seq theory  Gamma Delta X) ->  exists n, (seqN theory n Gamma Delta X).

    Theorem contraction  : forall CC LC  F X ,
        ( seq theory   (F :: CC) LC X) -> In F CC -> (seq theory CC LC  X).
      intros.
      apply seqtoSeqN in H.
      destruct H.
      apply contractionN in H;auto.
      eapply seqNtoSeq;eauto.
    Qed.

    Theorem contractionSet  : forall CC LC X L, (forall F, In F L -> In F CC) ->
        ( seq theory (L ++ CC) LC X) -> (seq theory CC LC  X).
      intros.
      induction L.
      simpl in H0;auto.
      apply IHL;intros.
      apply H. firstorder.
      eapply exchangeCC with (CC':=a :: (L ++ CC)) in H0;[|auto].
      apply seqtoSeqN in H0 .
      destruct H0.
      apply contractionN in H0;auto.
      eapply seqNtoSeq;eauto.
      apply in_or_app.
      firstorder.
    Qed.

  End Adequacy.

  (** Weakening in the linear context when the formula belongs to the theory *)
  Section MoreWeakening.
    Variable theory : oo -> Prop .
    Hint Constructors seq : core .
    Hint Constructors seqN : core .
    Hint Constructors IsPositiveAtom : core .

    Theorem WeakLinearTheoryN : forall n CC LC F X ,
        ~ IsPositiveAtom F ->
        (seqN theory n CC (F::LC) X) -> theory F ->
        seqN theory n CC LC X.

    Proof with auto.
      induction n;intros;subst.
      + inversion H0;subst...
        contradict H ...
      + inversion H0;subst;eauto.
        contradict H ...
        assert(In F (M++N)).
        apply Permutation_in with (l:= F::LC)...
        constructor ...

        (* Tensor: 2 cases, F is in N or in M *)
        apply in_app_or in H2.
        destruct H2.
        ++
          apply in_split in H2;
            destruct H2 as [l1 H2];
            destruct H2 as [l2 H2];subst.
          rewrite Permutation_midle in H4.
          apply IHn in H4 ...

          rewrite Permutation_midle in H3.
          simpl in H3.
          apply Permutation_cons_inv in H3.
          rewrite H3.
          eapply tri_tensor;eauto.
        ++
          apply in_split in H2;
            destruct H2 as [l1 H2];
            destruct H2 as [l2 H2];subst.
          rewrite Permutation_midle in H5.
          apply IHn in H5 ...
          rewrite app_assoc in H3.
          rewrite Permutation_midle in H3.
          apply Permutation_cons_inv in H3.
          rewrite H3.
          rewrite <- app_assoc.
          eapply tri_tensor;eauto.
        ++ inversion H4;subst. (* F = F0 or F in LC *)
           eapply @tri_dec3 with (F:=F) ...

           apply IHn in H5  ...
           eapply @tri_dec1 with (F:=F0);eauto.
    Qed.

    Theorem WeakLinearTheory : forall CC LC F X,
        ~ IsPositiveAtom F ->
        (seq theory CC (F::LC) X) -> theory F -> seq theory CC LC X.
      intros.
      apply seqtoSeqN in H0.
      destruct H0.
      apply WeakLinearTheoryN in H0;auto.
      apply seqNtoSeq in H0;auto.
    Qed.
  End MoreWeakening.
End FLLBasicTheory.


From HB Require Import structures.
From Coq Require Import ZArith ssreflect ssrbool.
From mathcomp Require Import ssrfun eqtype choice order ssrnat bigop.
Require Import mathcomp.dioid.HB_wrappers mathcomp.dioid.dioid.

(** nat extended with -oo and +oo *)
Variant enat := ENFin of nat | ENPInf | ENMInf.

Definition eq_enat (x y : enat) :=
  match x, y with
  | ENFin x, ENFin y => x == y
  | ENPInf, ENPInf => true
  | ENMInf, ENMInf => true
  | _, _ => false
  end.

Lemma enat_eqP : Equality.axiom eq_enat.
Proof. by case=> [?||][?||]; apply: (iffP idP) => //= [/eqP|[]] ->. Qed.

Definition enat_eqMixin := Equality.Mixin enat_eqP.

Definition code (x : enat) :=
  match x with
  | ENFin x => GenTree.Node 0 (GenTree.Leaf x :: nil)
  | ENPInf => GenTree.Node 1 nil
  | ENMInf => GenTree.Node 2 nil
  end.

Definition decode (x : GenTree.tree nat) : option enat :=
  match x with
  | GenTree.Node 0 (GenTree.Leaf x :: nil) => Some (ENFin x)
  | GenTree.Node 1 nil => Some ENPInf
  | GenTree.Node 2 nil => Some ENMInf
  | _ => None
  end.

Lemma codeK : pcancel code decode. Proof. by case. Qed.

Definition enat_choiceMixin := PcanChoiceMixin codeK.

Definition ezero := ENMInf.
Definition eone := ENFin 0.
Definition adden (x y : enat) :=
  match x, y with
  | ENFin x, ENFin y => ENFin (maxn x y)
  | ENPInf, _ | _, ENPInf => ENPInf
  | ENMInf, x | x, ENMInf => x
  end.
Definition mulen (x y : enat) :=
  match x, y with
  | ENFin x, ENFin y => ENFin (x + y)
  | ENMInf, _ | _, ENMInf => ENMInf
  | ENPInf, _ | _, ENPInf => ENPInf
  end.

Lemma addenA : associative adden.
Proof. by move=> [?||] [?||] [?||] //=; rewrite maxnA. Qed.

Lemma addenC : commutative adden.
Proof. by move=> [?||] [?||] //=; rewrite maxnC. Qed.

Lemma add0en : left_id ezero adden.
Proof. by case. Qed.

Lemma addenen : idempotent adden.
Proof. by move=> [?||] //=; rewrite maxnn. Qed.

Lemma mulenA : associative mulen.
Proof. by move=> [?||] [?||] [?||] //=; rewrite addnA. Qed.

Lemma mulenC : commutative mulen.
Proof. by move=> [?||] [?||] //=; rewrite addnC. Qed.

Lemma mul1en : left_id eone mulen.
Proof. by case. Qed.

Lemma mulenDl : left_distributive mulen adden.
Proof. by move=> [?||] [?||] [?||] //=; rewrite addn_maxl. Qed.

Lemma mul0en : left_zero ezero mulen.
Proof. by case. Qed.

HB.instance Definition enat_WrapChoice_axioms :=
  WrapChoice_of_TYPE.Build enat enat_eqMixin enat_choiceMixin.
Canonical enat_eqType := [eqType of enat for enat_is_a_WrapChoice].
Canonical enat_choiceType := [choiceType of enat for enat_is_a_WrapChoice].

HB.instance Definition enat_ComDioid_axioms :=
  ComDioid_of_WrapChoice.Build
    enat addenA addenC add0en addenen mulenA mulenC mul1en mulenDl mul0en.
Canonical enat_porderType := [porderType of enat for enat_is_a_WrapPOrder].

Check (eone == ezero).

Check (ezero <= ezero)%D.

Goal (\big[+%D/0%D]_(0 <= i < 2) (ENFin 42)
      = (\big[+%D/0%D]_(0 <= i < 1) (ENFin 42)) + (ENFin 42))%D.
Proof. by rewrite big_nat_recr. Qed.

Goal (ENFin 42 <= ENFin 12 + ENFin 42)%D.
Proof.
rewrite adddC.
exact: led_addr.
Qed.

Section Test1.

Variable R : SemiRing.type.
Variables x y : R.

Check (x + 1 * y)%D.

Check (1 + y)%D.

End Test1.

Definition evenenat_def (x : enat) : bool :=
  match x with
  | ENPInf | ENMInf => true
  | ENFin x => ~~ odd x
  end.

Definition evenenat := [qualify a x | evenenat_def x].

Record eenat := {
  eenat_val :> enat;
  eenat_prop : eenat_val \is a evenenat
}.

Canonical eenat_subType := [subType for eenat_val].
Definition eenat_eqMixin := Eval hnf in [eqMixin of eenat by <:].
Canonical eenat_eqType := Eval hnf in EqType eenat eenat_eqMixin.
Definition eenat_choiceMixin := Eval hnf in [choiceMixin of eenat by <:].
Canonical eenat_choiceType := Eval hnf in ChoiceType eenat eenat_choiceMixin.

HB.instance Definition eenat_WrapChoice_axioms :=
  WrapChoice_of_TYPE.Build eenat eenat_eqMixin eenat_choiceMixin.

Lemma eenat_semiring : semiring_closed evenenat.
Proof.
split; split=> [// | x y Hx Hy].
- case: x Hx => [x||] Hx; case: y Hy => [y||] Hy //.
  by rewrite /add /=; case: ltnP => _.
- case: x Hx => [x||] Hx; case: y Hy => [y||] Hy //.
  move: Hx Hy; rewrite /mem /in_mem /= oddD.
  by move=> /negbTE -> /negbTE ->.
Qed.

Fact eenat_key : pred_key evenenat. Proof. by []. Qed.
Canonical eenat_keyed := KeyedQualifier eenat_key.
Canonical eenat_addPred := AddPred eenat_semiring.
Canonical eenat_semiringPred := SemiRingPred eenat_semiring.

Definition eenat_semiRing := Eval hnf in [SemiRing of eenat by <:].
HB.instance eenat eenat_semiRing.

Section Test2.

Variables x y : eenat.

Check (x + 1 * y)%D.

Check (1 + y)%D.

Variable z : enat.

Check ((x : enat) + z)%D.

Check (z + x)%D.

Goal (x * y = y * x)%D.
Proof.
Fail rewrite muldC.
apply/val_inj.
by rewrite /= muldC.
Qed.

End Test2.

Definition eenat_comSemiRing := Eval hnf in [ComSemiRing of eenat by <:].
HB.instance eenat eenat_comSemiRing.

Section Test3.

Variables x y : eenat.

Goal (x * y = y * x)%D.
Proof.
by rewrite muldC.
Qed.

End Test3.

Definition eenat_porderMixin := Eval hnf in [porderMixin of eenat by <:].
Canonical eenat_porderType :=
  Order.POrder.pack dioid_display id eenat_porderMixin.

HB.instance Definition eenat_WrapPOrder_axioms :=
  WrapPOrder_of_WrapChoice.Build eenat eenat_porderMixin.

Definition eenat_dioid := Eval hnf in [Dioid of eenat by <:].
HB.instance eenat eenat_dioid.

Require Import mathcomp.analysis.classical_sets.
Require Import mathcomp.dioid.complete_lattice.
Require Import mathcomp.dioid.complete_dioid.

Parameter set_joinen : set enat -> enat.

Axiom set_joinen_is_lub : set_f_is_lub wrap_porderMixin set_joinen.

HB.instance Definition enat_CompleteLattice_axioms :=
  CompleteLattice_of_WrapPOrder.Build enat set_joinen_is_lub.
Canonical enat_latticeType := [latticeType of enat for enat_is_a_WrapLattice].

Axiom set_mulenDl : forall (a : enat) (B : set enat),
  (a * set_join B = set_join [set a * x | x in B])%D.

Axiom set_mulenDr : forall (a : enat) (B : set enat),
  (set_join B * a = set_join [set x * a | x in B])%D.

HB.instance Definition enat_CompleteDioid_axioms :=
  CompleteDioid_of_Dioid_and_CompleteLattice.Build enat set_mulenDl set_mulenDr.

Parameter eenat_latticeMixin : latticeMixin eenat_porderType.
HB.instance Definition eenat_WrapLattice_axioms :=
  WrapLattice_of_WrapPOrder.Build eenat eenat_latticeMixin.
Canonical eenat_latticeType := [latticeType of eenat for eenat_is_a_WrapLattice].

Axiom eenat_set_join : set_join_closed evenenat.

Canonical eenat_setJoinPred := SetJoinPred eenat_set_join.

Definition eenat_completeLattice :=
  Eval hnf in [CompleteLattice of eenat by <:].
HB.instance eenat eenat_completeLattice.

Definition eenat_completeDioid :=
  Eval hnf in [CompleteDioid of eenat by <:].
HB.instance eenat eenat_completeDioid.


(* Adapted from http://poleiro.info/posts/2013-04-03-parse-errors-as-type-errors.html,
   https://github.com/arthuraa/poleiro/blob/master/theories/ForceOption.v
   to produce N instead of nat *)

Require Export Coq.Strings.String.
Require Import Coq.Strings.Ascii.
Require Import Coq.NArith.NArith.

Local Open Scope char_scope.

Local Open Scope N_scope.

Definition hexDigitToN (c : ascii) : option N :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | "2" => Some 2
    | "3" => Some 3
    | "4" => Some 4
    | "5" => Some 5
    | "6" => Some 6
    | "7" => Some 7
    | "8" => Some 8
    | "9" => Some 9
    | "a" | "A" => Some 10
    | "b" | "B" => Some 11
    | "c" | "C" => Some 12
    | "d" | "D" => Some 13
    | "e" | "E" => Some 14
    | "f" | "F" => Some 15
    | _   => None
  end.

Local Open Scope string_scope.

Fixpoint readHexNAux (s : string) (acc : N) : option N :=
  match s with
    | "" => Some acc
    | String c s' =>
      match hexDigitToN c with
        | Some n => readHexNAux s' (16 * acc + n)
        | None => None
      end
  end.

Definition readHexN (s : string) : option N := readHexNAux s 0.

Goal readHexN "ff" = Some 255.
Proof. reflexivity. Qed.

Definition forceOption A Err (o : option A) (err : Err) : match o with
                                                            | Some _ => A
                                                            | None => Err
                                                          end :=
  match o with
    | Some a => a
    | None => err
  end.

Inductive parseError := ParseError.

Definition hex (s : string) := forceOption N parseError (readHexN s) ParseError.

Goal hex"ff" = 255.
Proof. reflexivity. Qed.

Goal hex"a0f" = 2575.
Proof. reflexivity. Qed.

Goal hex"1O" = ParseError.
Proof. reflexivity. Qed.

Goal hex"ff34c8e3" = 4281649379.
Proof. reflexivity. Qed.
Local Close Scope string_scope.
Local Close Scope N_scope.

Definition binDigitToNat (c : ascii) : option nat :=
  match c with
    | "0" => Some 0
    | "1" => Some 1
    | _   => None
  end.

Open Scope string_scope.

Fixpoint readBinAux (s : string) (acc : nat) : option nat :=
  match s with
    | "" => Some acc
    | String c s' =>
      match binDigitToNat c with
        | Some n => readBinAux s' (2 * acc + n)
        | None => None
      end
  end.

Definition readBinNat (s : string) : option nat := readBinAux s 0.

Goal readBinNat "01" = Some 1.
Proof. reflexivity. Qed.

Definition bin (s : string) := @forceOption nat parseError (readBinNat s) ParseError.