Require Export aula3 aula4 aula5 aula6.

Inductive natlist : Type :=
  | nil  : natlist
  | cons : nat -> natlist -> natlist.

(** For example, here is a three-element list: *)

Definition mylist := cons 1 (cons 2 (cons 3 nil)).

Notation "x :: l" := (cons x l)
                     (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Definition mylist1 := 1 :: (2 :: (3 :: nil)).
Definition mylist2 := 1 :: 2 :: 3 :: nil.
Definition mylist3 := [1;2;3].

Fixpoint repeat (n count : nat) : natlist :=
  match count with
  | O => nil
  | S count' => n :: (repeat n count')
  end.

Fixpoint length (l:natlist) : nat :=
  match l with
  | nil => O
  | h :: t => S (length t)
  end.

Fixpoint app (l1 l2 : natlist) : natlist :=
  match l1 with
  | nil    => l2
  | h :: t => h :: (app t l2)
  end.

(** Actually, [app] will be used a lot in some parts of what
    follows, so it is convenient to have an infix operator for it. *)

Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).

Example test_app1:             [1;2;3] ++ [4;5] = [1;2;3;4;5].
Proof. reflexivity.  Qed.
Example test_app2:             nil ++ [4;5] = [4;5].
Proof. reflexivity.  Qed.
Example test_app3:             [1;2;3] ++ nil = [1;2;3].
Proof. reflexivity.  Qed.

Definition hd (default:nat) (l:natlist) : nat :=
  match l with
  | nil => default
  | h :: t => h
  end.

Definition tl (l:natlist) : natlist :=
  match l with
  | nil => nil
  | h :: t => t
  end.

Example test_hd1:             hd 0 [1;2;3] = 1.
Proof. reflexivity.  Qed.
Example test_hd2:             hd 0 [] = 0.
Proof. reflexivity.  Qed.
Example test_tl:              tl [1;2;3] = [2;3].
Proof. reflexivity.  Qed.


(** 6. 述語論理 *)
Module Section6.

(** 述語論理 *)
(* 述語 iszero:nat -> Prop *)
Definition iszero(n:nat):Prop :=
match n with
| O => True
| _ => False
end.

(* 動作確認 *)
Eval compute in (iszero 0).
Eval compute in (iszero 3).

(** forall がある場合 *)
Theorem sample_forall : forall (X:Type)(P Q:X->Prop)(x:X),
  P x -> (forall y:X, Q y) -> (P x /\ Q x).
Proof.
  (* 最初は intro(s) する。名前は判りやすく付けると良い *)
  intros X P Q x px Hqy.
  (* ゴールが /\ の形ならば split. する *)
  split.
    (* goal = P x *)
    assumption.
    (* goal = Q x. Hqy の forall y の y に x を代入 *)
    apply (Hqy x).
Qed.

Theorem sample_exists : forall (P Q:nat->Prop),
  (forall n, P n) -> (exists n, Q n) ->
  (exists n, P n /\ Q n).
Proof.
  intros P Q Hpn Hqn.
  (* exists の式は /\ と同様に destruct する *)
  destruct Hqn as [n' qn'].
  (* ゴールの exists n に具体的な n' という値を示す *)
  exists n'.
  split.
    (* 仮定 Hpn から P n' を得る *)
    apply (Hpn n').
    (* goal = Q n' *)
    assumption.
Qed.

(** 課題５：述語論理の証明 *)
Theorem ex5_1 : forall (A:Set)(P:A->Prop),
  (~exists a, P a) -> (forall a, ~P a).
Proof.
(* Proof here *)
Qed.

Theorem ex5_2 : forall (A:Set)(P Q:A->Prop),
  (exists a, P a \/ Q a) ->
  (exists a, P a) \/ (exists a, Q a).
Proof.
(* Proof here *)
Qed.

Theorem ex5_3 : forall (A:Set)(P Q:A->Prop),
  (exists a, P a) \/ (exists a, Q a) ->
  (exists a, P a \/ Q a).
Proof.
(* Proof here *)
Qed.

Theorem ex5_4 : forall (A:Set)(R:A->A->Prop),
  (exists x, forall y, R x y) -> (forall y, exists x, R x y).
Proof.
(* Proof here *)
Qed.

Theorem ex5_5 : forall (A:Set)(R:A->A->Prop),
  (forall x y, R x y -> R y x) ->
  (forall x y z, R x y -> R y z -> R x z) ->
  (forall x, exists y, R x y) ->
  (forall x, R x x).
Proof.
(* Proof here *)
Qed.

(** 6.3 =を含む証明 *)
(* =　は eq という名前で定義されている *)
Print eq.

Theorem plus_0_l : forall n, 0 + n = n.
Proof.
  intro n.
  (* 0 + n をplusの定義に従い簡単にする *)
  simpl.
  (* = の左辺と右辺が同じ形ならば reflexivity. *)
  reflexivity.
Qed.

(* simpl では簡単にならない例 *)
Theorem plus_0_r : forall n, n + 0 = n.
Proof.
  intro n.
  simpl.
Abort. (* 中断して破棄 *)

(* natに関する帰納法 *)
Check nat_ind.

(* 証明課題を無名関数にして渡した例 *)
Check (nat_ind (fun n => n + 0 = n)).

(* boolに関する帰納法は、単なる場合分け *)
Check bool_ind.

Theorem plus_0_r : forall n, n + 0 = n.
Proof.
  (* n を O と S n' とに場合分けする *)
  induction n as [|n'].
    (* n=0 の場合 *)
    reflexivity.
    (* n=S n' の場合. 簡単にする *)
    simpl.
    (* ゴールに対して、IHn'の左辺->右辺と書き換え *)
    rewrite IHn'.
    reflexivity.
Qed.

(** 課題６：n+m=m+nの証明 *)
SearchAbout plus.

(*
plus_n_O: forall n : nat, n = n + 0
plus_O_n: forall n : nat, 0 + n = n
plus_n_Sm: forall n m : nat, S (n + m) = n + S m
plus_Sn_m: forall n m : nat, S n + m = S (n + m)
mult_n_Sm: forall n m : nat, n * m + n = n * S m
plus_0_r: forall n : nat, n + 0 = n
plus_0_l: forall n : nat, 0 + n = n
*)

Theorem plus_comm : forall m n, m + n = n + m.
Proof.
(* Proof here *)
Qed.

(* リストライブラリをインポート *)
Require Import List.
Theorem length_app : forall (A:Type)(l1 l2:list A),
  length (l1 ++ l2) = length l1 + length l2.
Proof.
(* (1) 最初に全て intros する場合 *)
  intros A l1 l2.
  induction l1 as [|a l1'].
    simpl. reflexivity.
    (* ここでの IHl1'は、
IHl1' : length (l1' ++ l2) = length l1' + length l2 *)
    simpl. rewrite IHl1'. reflexivity.
Qed.
(* (2) 最初に全て l1 のみ intros する場合
  intros A l1.
  induction l1 as [|a l1'].
    intro l2. simpl. reflexivity.
    (* ここでの IHl1'は、任意の l2 に対する仮定
IHl1' : forall l2 : list A,
  length (l1' ++ l2) = length l1' + length l2 *)
    intro l2. simpl. rewrite IHl1'. reflexivity.
Qed.
*)
(** 課題７：リストに関する証明 *)
Fixpoint append{A:Type}(l1 l2:list A) :=
match l1 with
| nil => l2
| a::l1' => a::(append l1' l2)
end.
(* 動作確認 *)
Eval compute in (append (1::2::3::nil) (4::5::nil)).

Fixpoint reverse{A:Type}(l:list A):=
match l with
| nil => nil
| a::l' => append (reverse l') (a::nil)
end.
(* 動作確認 *)
Eval compute in (reverse (1::2::3::4::nil)).

(* Lemma は補題の意味だが、Coq の処理としては Theorem と同じ *)
Lemma append_nil : forall (A:Type)(l:list A),
  append l nil = l.
Proof.
(* proof here *)
Qed.

Lemma append_assoc : forall (A:Type)(l1 l2 l3:list A),
  append (append l1 l2) l3 = append l1 (append l2 l3).
Proof.
(* proof here *)
Qed.

Lemma reverse_append : forall (A:Type)(l1 l2:list A),
  reverse (append l1 l2) = append (reverse l2) (reverse l1).
Proof.
(* proof here *)
Qed.

Theorem reverse_reverse : forall (A:Type)(l:list A),
  reverse (reverse l) = l.
Proof.
(* proof here *)
Qed.
End Section6.


Require Import A1_Plan A2_Orientation .
Require Import B5_BetweenProp .
Require Import C1_Distance C3_SumDistance C6_DistanceTimesN C7_Tactics .
Require Import E4_Tactics .
Require Import F3_Graduation.

Section ARCHIMEDIAN_DISTANCE.

Lemma GraduationSegmentSn : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Segment A (Graduation (S n) A B Hab) B.
Proof.
	intros; induction n.
	 rewrite Graduation1; immediate4.
	 apply (SegmentTransADB A B (Graduation (S n) A B Hab)).
	  trivial.
	  apply GraduationSegment.
Qed.

Lemma GraduationBetweenAnSn : forall n : nat, forall A B : Point, forall Hab : A <> B,
	n >= 1 ->
	Between A (Graduation n A B Hab) (Graduation (S n) A B Hab).
Proof.
	intros.
	induction H.
	 apply SegmentBetween.
	  rewrite Graduation1; apply GraduationSegmentSn.
	  rewrite Graduation1; immediate4.
	  apply GraduationDistinctnSn.
	 step4 IHle.
	  apply GraduationBetweennSnSSn.
Qed.

Lemma GraduationSegmentB : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Segment B (Graduation (S (S n)) A B Hab) (Graduation (S n) A B Hab).
Proof.
	intros.
	apply (SegmentTransBDC A).
	 apply GraduationSegmentSn.
	 apply GraduationSegment.
Qed.

Lemma GraduationEqDistance : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Distance A (Graduation n A B Hab) = Distance B (Graduation (S n) A B Hab).
Proof.
	intros; induction n.
	 rewrite Graduation0; rewrite Graduation1; immediate4.
	 usingChasles2 A (Graduation n A B Hab) (Graduation (S n) A B Hab).
	  usingChasles2 B (Graduation (S n) A B Hab) (Graduation (S (S n)) A B Hab).
	   repeat rewrite EqDistanceGraduation.
	     immediate4.
	   apply GraduationSegmentB.
	  apply GraduationSegment.
Qed.

Lemma DistanceGraduation : forall n : nat, forall A B : Point, forall Hab : A <> B,
	Distance A (Graduation n A B Hab) = DistanceTimes n A B.
Proof.
	intros; induction n.
	 rewrite Graduation0; simpl in |- *; immediate4.
	 usingChasles2 A (Graduation n A B Hab) (Graduation (S n) A B Hab).
	  rewrite EqDistanceGraduation; simpl in |- *.
	    rewrite IHn; apply DistancePlusCommut.
	  apply GraduationSegment.
Qed.

End ARCHIMEDIAN_DISTANCE.


Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
intros f.
intros H.
intros b.
destruct b.
- rewrite -> H. rewrite -> H. reflexivity.
- rewrite -> H. rewrite -> H. reflexivity.
Qed.


Require Export Properties.

Definition Un X :=
  forall x y z, M x -> M y -> M z ->
  <|x,y|> ∈ X -> <|x,z|> ∈ X -> y = z.

Definition Fnc X :=
  Rel X /\ Un X.

Definition Map f X Y :=
  Fnc f /\ Dom f = X /\ Ran f ⊂ Y.
Notation "f : X → Y" := (Map f X Y) (at level 10).

Definition Restriction f X  :=
  f ∩ (X × V).
Notation "f | ( X )" := (Restriction f X)(at level 10).

Theorem in_restrict f X g :
    g ∈ (f | (X)) <-> exists x y, M x /\ M y /\ g = <|x,y|> /\ g ∈ f /\ x ∈ X.
Proof.
  unfold Restriction.
  rewrite in_cap.
  rewrite in_prod.
  split => [ [gf [x [y [ x_ [y_  [g_xy [ xX _]]]]]]] | [x [y [x_ [y_ [g_xy [gf xX]]]]]]]; [|split] => //; exists x; exists y => //.
  by rewrite in_universe.
Qed.

Definition Image f X :=
  Ran (f | (X)).

Theorem in_image f X y (y_ : M y):
    y ∈ (Image f X) <-> exists x, M x /\ x ∈ X /\ <|x,y|> ∈ f.
Proof.
  unfold Image.
  rewrite in_ran => //.
  split => [[x [x_ H]]| [x [x_ [xX xy_f]]]].
  + move /in_restrict : H => [x0 [y0 [x0_ [y0_ [xyxy [xy_f xX]]]]]].
    move /(orderd_eq x y x0 y0 x_ y_ x0_ y0_) : xyxy => [xx0 yy0]; subst x0 y0.
    by exists x.
  + exists x; split => //; rewrite in_restrict.
    by exists x ; exists y.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf2 : natural) (x : natural) (y : natural) (lf1 : natural)
  : natural := plus x (Succ Zero).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (lf2 : natural) (y : natural) (x : natural)
  : natural := mult (Succ Zero) lf1.


Require Import ZArith Lia.

(**  contributed by GhasSee

  This version solves some computing issues
    (computation of [sqrt' n])
*)

(** Euclidean division specification *)

Definition div_type'' m n q r := m = q*n+r /\ r < n.

Definition div_type  (m:nat)  :=
  forall n, 0 < n -> {q & { r | m = q*n+r /\ r < n }}.

Definition div_type' m n q    := { r | m = q*n+r /\ r < n }.

(* implementation by well-founded recursion *)

Definition div_F :
  forall x, (forall y, y < x -> div_type y) -> div_type x.
Proof.
  unfold div_type at 2.
  refine (fun m div_rec n Hlt =>
      match le_gt_dec n m with
      | left H_n_le_m =>
          match div_rec (m-n) _ n _ with
          | existT _ q (exist _ r H_spec) =>
              existT (div_type' m n) (S q)
                (exist (div_type'' m n (S q)) r _ )
          end
      | right H_n_gt_m =>
            existT (div_type' m n) O (exist (div_type'' m n O) m _ ) end );
  unfold div_type'' ; lia.
Defined.

Definition div :
  forall m n, 0 < n ->
              {q & {r | m = q*n+r /\ r < n }} :=
  well_founded_induction lt_wf div_type div_F.

Compute  match div 100 15 _
         with
         | existT _ q (exist _ r _ )   => (q,r)
         end .

(*   square root spec *)

Definition sqrt_type (n:nat)  :=
  {s & { r | n = s*s+r /\ n < S s * S s }}.

Definition sqrt_type' n s := { r | n = s*s+r /\ n < (S s)*(S s) }.

Definition sqrt_type'' n s r  := n = s*s+r /\ n < (S s)*(S s).

Definition sqrt_F :
  forall x, (forall y, y < x -> sqrt_type y) -> sqrt_type x.
Proof.
  destruct x.
  - refine (fun sqrt_rec => existT _ 0 (exist _ 0 _ )); lia.
  - unfold sqrt_type at 2.
    refine (fun sqrt_rec =>
      let n := S x in
      match div n 4 _ with
      | existT _ q (exist _ r0 _ ) =>
          match sqrt_rec q _ with
          | existT _ s' (exist _ r' H_spec) =>
              match le_gt_dec (S(4*s')) (4*r'+r0) with
              | left HSs =>
                  let s := S(2*s') in
                  let r := 4*r'+r0 - S(4*s') in
                  existT(sqrt_type' n) s
                    (exist (sqrt_type'' n s) r _ )
              | right Hs =>
                  let s := 2*s' in
                  let r := 4*r'+r0 in
                  existT(sqrt_type' n) s
                    (exist (sqrt_type'' n s) r _ )  end end end);
    unfold sqrt_type''; auto with zarith.
Defined.

Definition sqrt : forall n, sqrt_type n :=
  well_founded_induction lt_wf sqrt_type sqrt_F.

Compute match sqrt 10 with | existT _ s _ => s end .

(* ex. 15.11 *)
Definition sqrt_F' :
  forall x, (forall y, y < x -> sqrt_type y) -> sqrt_type x.
Proof.
  destruct x.
  - intros. exists 0. exists 0. auto with arith.
  - intros sqrt_rec. set (S x) as n. fold n.
    refine (match div n 4 _ with
            | existT _ q (exist _ r0 _) => _ end );
      auto with zarith.
    + destruct (sqrt_rec q) as [s' [r' [H1' H2']]];
        auto with zarith.
      * { destruct (le_gt_dec (S(4*s')) (4*r'+r0)).
          - exists (S(2*s')); exists (4*r'+r0-S(4*s'));
              auto with zarith.
        - exists (2*s'), (4*r'+r0); auto with zarith. }
Defined.

Definition sqrt' : forall n:nat, sqrt_type n :=
  well_founded_induction lt_wf sqrt_type sqrt_F'.

(* hurrah !!! *)

Compute match sqrt' 42 with existT _ s _ => s end.


Add LoadPath "." as OPAT.
Require Import OPAT.aula3 OPAT.aula4 OPAT.aula5.

(** **** Exercise: 2 stars, each one, recommended (basic_induction)  *)
(** Prove the following using induction. You might need previously
    proven results. *)

Theorem mult_0_r : forall n:nat,
  n * 0 = 0.
Proof.
  intros n. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_n_Sm : forall n m : nat,
  S(n + m) = n + (S m).
Proof.
  intros n m. induction n as [| n' IHn'].
  - simpl. reflexivity.
  - simpl. rewrite -> IHn'. reflexivity.
Qed.

Theorem plus_comm : forall n m : nat,
  n + m = m + n.
Proof.
  intros n m. induction n as [| n' IHn'].
  - rewrite <- plus_n_O. simpl. reflexivity.
  - rewrite <- plus_n_Sm. simpl. rewrite <- IHn'. reflexivity.
Qed.

Theorem plus_assoc : forall n m p : nat,
  n + (m + p) = (n + m) + p.
Proof.
  intros n m p. induction n as [| n' IHn'].
  -simpl. reflexivity.
  -simpl. rewrite -> IHn'. reflexivity.
Qed.

Fixpoint double (n:nat) :=
  match n with
  | O => O
  | S n' => S (S (double n'))
  end.

(** Use induction to prove this simple fact about [double]: *)

Lemma double_plus : forall n, double n = n + n.
Proof.
  intros n. induction n as [| n' IHn'].
  -simpl. reflexivity.
  -simpl. rewrite -> IHn'. rewrite <- plus_n_Sm. reflexivity.
Qed.

(** **** Exercise: 2 stars, optional (evenb_S)  *)
(** One inconvenient aspect of our definition of [evenb n] is the
    recursive call on [n - 2]. This makes proofs about [evenb n]
    harder when done by induction on [n], since we may need an
    induction hypothesis about [n - 2]. The following lemma gives an
    alternative characterization of [evenb (S n)] that works better
    with induction: *)
Lemma negb_negb : forall a:bool,
  negb (negb a) = a.
Proof.
  intros a.
  destruct a.
  -simpl. reflexivity.
  -simpl. reflexivity.
Qed.

Theorem evenb_S : forall n : nat,
  evenb (S n) = negb (evenb n).
Proof.
  intros n. induction n as [|n' IHn'].
  -simpl. reflexivity.
  -rewrite -> IHn'. simpl. rewrite negb_negb. reflexivity.
Qed.


(** %\chapter{Encoding Mathematical Structures}% *)

From mathcomp.ssreflect
Require Import ssreflect ssrbool ssrnat ssrfun.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Module DepRecords.

(** * Encoding partial commutative monoids *)

Module PCMDef.

(**

We have already seen a use of a dependent pair type, exemplified by
the Coq's definition of the universal quantification.

*)

Print ex.

(**
[[
Inductive ex (A : Type) (P : A -> Prop) : Prop :=
    ex_intro : forall x : A, P x -> ex P
]]

*)

Record mixin_of (T : Type) := Mixin {
    valid_op : T -> bool;
    join_op : T -> T -> T;
    unit_op : T;
    _ : commutative join_op;
    _ : associative join_op;
    _ : left_id unit_op join_op;
    _ : forall x y, valid_op (join_op x y) -> valid_op x;
    _ : valid_op unit_op
}.

(**
[[
mixin_of is defined
mixin_of_rect is defined
mixin_of_ind is defined
mixin_of_rec is defined
valid_op is defined
join_op is defined
unit_op is defined
]]
*)

Check valid_op.

(**
[[
valid_op
     : forall T : Type, mixin_of T -> T -> bool
]]
*)

Lemma r_unit T (pcm: mixin_of T) (t: T) : (join_op pcm t (unit_op pcm)) = t.
Proof.
case: pcm=>_ join unit Hc _ Hlu _ _ /=.

(**
[[
  T : Type
  t : T
  join : T -> T -> T
  unit : T
  Hc : commutative join
  Hlu : left_id unit join
  ============================
   join t unit = t
]]
*)

by rewrite Hc Hlu.
Qed.

(** ** An alternative definition *)

Inductive mixin_of' (T: Type) :=
  Mixin' (valid_op: T -> bool) (join_op : T -> T -> T) (unit_op: T) of
    commutative join_op &
    associative join_op &
    left_id unit_op join_op &
    forall x y, valid_op (join_op x y) -> valid_op x &
    valid_op unit_op.

(**

Although this definition seems more principled and is closer to what
we have seen in previous chapters, the record notation is more
convenient in this case, as it defined getters automatically as well
as allows one to express inheritance between data structures by means
of the coercion operator %\texttt{:>}%
operator%~\cite{Garillot-al:TPHOL09}%.%\footnote{In the next section
will show a different way to encode implicit inheritance, though.}%

** Packaging the structure from mixins
%\label{sec:packaging}%

*)

Section Packing.

Structure pack_type : Type := Pack {type : Type; _ : mixin_of type}.

(**

The dependent data structure [pack_type] declares two fields: the
field [type] of type [Type], which described the carrier type of the
PCM instance, and the actual PCM structure (without an explicit name
given) of type [mixin_of type]. That is, in order to construct an
instance of [pack_type], one will have to provide _both_ arguments:
the carrier set and a PCM structure for it.

*)

Local Coercion type : pack_type >-> Sortclass.

(**

Next, in the same section, we provide a number of abbreviations to
simplify the work with the PCM packed structure and prepare it to be
exported by clients.

*)
Variable cT: pack_type.

Definition pcm_struct : mixin_of cT :=
    let: Pack _ c := cT return mixin_of cT in c.

Definition valid := valid_op pcm_struct.
Definition join := join_op pcm_struct.
Definition unit := unit_op pcm_struct.

End Packing.

Module Exports.

Notation pcm := pack_type.
Notation PCMMixin := Mixin.
Notation PCM T m := (@Pack T m).

Notation "x \+ y" := (join x y) (at level 43, left associativity).
Notation valid := valid.
Notation Unit := unit.

Coercion type : pack_type >-> Sortclass.

(** * Properties of partial commutative monoids *)

Section PCMLemmas.
Variable U : pcm.

(**

For instance, the following lemma re-establishes the commutativity of
the [\+] operation:

*)

Lemma joinC (x y : U) : x \+ y = y \+ x.
Proof.
by case: U x y=> tp [v j z Cj *]; apply Cj.
Qed.

(**

Notice that in order to make the proof to go through, we had to "push"
the PCM elements [x] and [y] to be the assumption of the goal before
case-analysing on [U]. This is due to the fact that the structure of
[U] affects the type of [x] and [y], therefore destructing it by means
of [case] would change the representation of [x] and [y] as well,
doing some rewriting and simplifications. Therefore, when [U] is being
decomposed, al values, whose type depends on it (i.e., [x] and [y])
should be in the scope of decomposition. The naming pattern [*] helped
us to give automatic names to all remaining assumptions, appearing
from decomposition of [U]'s second component before moving it to the
context before finishing the proof by applying the commutativity
"field" [Cj].

*)

Lemma joinA (x y z : U) : x \+ (y \+ z) = x \+ y \+ z.
Proof.
by case: U x y z=>tp [v j z Cj Aj *]; apply: Aj.
Qed.

(*******************************************************************)
(**                     * Exercices 1 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [PCM Laws]
---------------------------------------------------------------------

Proove the rest of the PCM laws.
*)

Lemma joinAC (x y z : U) : x \+ y \+ z = x \+ z \+ y.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma joinCA (x y z : U) : x \+ (y \+ z) = y \+ (x \+ z).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma validL (x y : U) : valid (x \+ y) -> valid x.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma validR (x y : U) : valid (x \+ y) -> valid y.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma unitL (x : U) : (@Unit U) \+ x = x.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma unitR (x : U) : x \+ (@Unit U) = x.
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

Lemma valid_unit : valid (@Unit U).
Proof.
(* fill in your proof here instead of [admit] *)
Admitted.

(*******************************************************************)
(**                 * End of Exercices 1 *                         *)
(*******************************************************************)

End PCMLemmas.

End Exports.

End PCMDef.

Export PCMDef.Exports.

(** * Implementing inheritance hierarchies

We will now go even further and show how to build hierarchies of
mathematical structures using the same way of encoding inheritance. We
will use a _cancellative PCM_ as a running example.

*)

Module CancelPCM.

Record mixin_of (U : pcm) := Mixin {
  _ : forall a b c: U, valid (a \+ b) -> a \+ b = a \+ c -> b = c
}.

Structure pack_type : Type := Pack {pcmT : pcm; _ : mixin_of pcmT}.

Module Exports.

Notation cancel_pcm := pack_type.
Notation CancelPCMMixin := Mixin.
Notation CancelPCM T m:= (@Pack T m).

Coercion pcmT : pack_type >-> pcm.

Lemma cancel (U: cancel_pcm) (x y z: U):
  valid (x \+ y) -> x \+ y = x \+ z -> y = z.
Proof.
by case: U x y z=>Up [Hc] x y z; apply: Hc.
Qed.

End Exports.
End CancelPCM.

Export CancelPCM.Exports.

Lemma cancelC (U: cancel_pcm) (x y z : U) :
  valid (y \+ x \+ z) -> y \+ x = x \+ z -> y = z.
Proof.
by move/validL; rewrite ![y \+ _]joinC; apply: cancel.
Qed.

(**

* Instantiation and canonical structures

Now, as we have defined a PCM structure along with its specialized
version, a cancellative PCM, it is time to see how to _instantiate_
these abstract definitions with concrete datatypes, i.e., _prove_ the
later ones to be instances of a PCM.

** Defining arbitrary PCM instances

Natural numbers form a PCM, in particular, with addition as a join
operation and zero as a unit element. The validity predicate is
constant true, because the addition of two natural numbers is again a
valid natural number. Therefore, we can instantiate the PCM structure
for [nat] as follows, first by constructing the appropriate mixin.

*)

Definition natPCMMixin :=
  PCMMixin addnC addnA add0n (fun x y => @id true) (erefl _).

Definition NatPCM := PCM nat natPCMMixin.

(**

This definition will indeed work, although, being somewhat
unsatisfactory. For example, assume we want to prove the following
lemma for natural numbers treated as elements of a PCM, which should
trivially follow from the PCM properties of [nat] with addition and
zero:

[[
Lemma add_perm (a b c : nat) : a \+ (b \+ c) = a \+ (c \+ b).
]]

[[
The term "a" has type "nat" while it is expected to have type "PCMDef.type ?135".
]]

*)

Canonical natPCM := PCM nat natPCMMixin.

Print Canonical Projections.

(**
[[
...
nat <- PCMDef.type ( natPCM )
pred_of_mem <- topred ( memPredType )
pred_of_simpl <- topred ( simplPredType )
sig <- sub_sort ( sig_subType )
number <- sub_sort ( number_subType )
...
]]
*)

Lemma cancelNat : forall a b c: nat, true -> a + b = a + c -> b = c.
Proof.
move=> a b c; elim: a=>// n /(_ is_true_true) Hn _ H.
by apply: Hn; rewrite !addSn in H; move/eq_add_S: H.
Qed.

Definition cancelNatPCMMixin := CancelPCMMixin cancelNat.

Canonical cancelNatPCM := CancelPCM natPCM cancelNatPCMMixin.

(**

Let us now see the canonical instances in action, so we can prove a
number of lemmas about natural numbers employing the general PCM
machinery.

*)

Section PCMExamples.

Variables a b c: nat.

Goal a \+ (b \+ c) =  c \+ (b \+ a).
by rewrite joinA [c \+ _]joinC [b \+ _]joinC.
Qed.

Goal c \+ a = a \+ b -> c = b.
by rewrite [c \+ _]joinC; apply: cancel.
Qed.

(**

It might look a bit cumbersome, though, to write the PCM join
operation [\+] instead of the boolean addition when specifying the
facts about natural numbers (even though they are treated as elements
of the appropriate PCM). Unfortunately, it is not trivial to encode
the mechanism, which will perform such conversion implicitly. Even
though Coq is capable of figuring out what PCM is necessary for a
particular type (if the necessary canonical instance is defined),
e.g., when seeing [(a b : nat)] being used, it infers the [natPCM],
alas, it's not powerful enough to infer that the by writing the
addition function [+] on natural numbers, we mean the PCM's
join. However, if necessary, in most of the cases the conversion like
this can be done by manual rewriting using the following trivial
"conversion" lemma.

*)

Lemma addn_join (x y: nat): x + y = x \+ y.
Proof. by []. Qed.

End PCMExamples.

(** ** Types with decidable equalities

The module [eqtype] of SSReflect's standard library provides a
definition of the equality mixin and packaged class of the familiar
shape, which, after some simplifications, boil to the following ones:

[[
Module Equality.

Definition axiom T (e : rel T) := forall x y, reflect (x = y) (e x y).

Structure mixin_of T := Mixin {op : rel T; _ : axiom op}.
Structure type := Pack {sort; _ : mixin_of sort}.

...

Notation EqMixin := Mixin.
Notation EqType T m := Pack T m.

End Equality.
]]

DEMO: check the corresponding files ssreflect-1.4/theories/eqtype.v
and ssreflect-1.4/theories/ssrnat.v

*)

(*******************************************************************)
(**                     * Exercices 2 *                            *)
(*******************************************************************)

(**
---------------------------------------------------------------------
Exercise [Partially-ordered sets]
---------------------------------------------------------------------

A partially ordered set order is a pair (T, <==), where T is a carrier
set and <== is a relation on T, such that

- forall x in T, x <== x (reflexivity);

- forall x, y in T, x <== y /\ y <== x \implies x = y (antisymmetry);

- forall x, y, z in T, x <== y /\ y <== z \implies x <== z (transitivity).

Implement a data structure for partially-ordered sets using mixins and
packed classes. Prove the following laws:

Lemma poset_refl (x : T) : x <== x.
Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
*)

(**
---------------------------------------------------------------------
Exercise [Canonical instances of partially ordered sets]
---------------------------------------------------------------------

Provide canonical instances of partially ordered sets for the
following types:

- [nat] and [<=];

- [prod], whose components are posets;

- functions [A -> B], whose codomain (range) [B] is a partially
  ordered set.

In order to provide a canonical instance for functions, you will need
to assume and make use of the following axiom of functional
extensionality:

*)

Axiom fext : forall A (B : A -> Type) (f1 f2 : forall x, B x),
               (forall x, f1 x = f2 x) -> f1 = f2.

(*******************************************************************)
(**                 * End of Exercices 2 *                         *)
(*******************************************************************)

End DepRecords.


Require Export stlc.Maps.

Inductive ty : Type :=
  | TVar  : string -> ty
  | TArrow : ty -> ty -> ty.

Inductive tm : Type :=
  | tvar : string -> tm
  | tapp : tm -> tm -> tm
  | tabs : string -> ty -> tm -> tm.

Definition context := partial_map ty.

Definition extend {A:Type} (Gamma : partial_map A) (x:string) (T : A) :=
  fun x' => if beq_string x x' then Some T else Gamma x'.

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T11 T12 Gamma t1 t2,
      has_type Gamma t1 (TArrow T11 T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (tapp t1 t2) T12.

Fixpoint beq_ty (T1 T2:ty) : bool :=
  match T1,T2 with
  | TVar a, TVar b => beq_string a b
  | TArrow T11 T12, TArrow T21 T22 =>
      andb (beq_ty T11 T21) (beq_ty T12 T22)
  | _,_ =>
      false
  end.

Lemma beq_ty_refl : forall T1,
  beq_ty T1 T1 = true.
Proof.
  intros T1. induction T1; simpl.
    apply beq_string_true_iff. reflexivity.
    rewrite IHT1_1. rewrite IHT1_2. reflexivity.  Qed.

Lemma beq_ty__eq : forall T1 T2,
  beq_ty T1 T2 = true -> T1 = T2.
Proof.
  intros T1. induction T1; intros T2 Hbeq; destruct T2; inversion Hbeq.
  - apply beq_string_true_iff in H0. rewrite H0. reflexivity.
  - apply andb_prop in H0. inversion H0 as [Hbeq1 Hbeq2].
    apply IHT1_1 in Hbeq1. apply IHT1_2 in Hbeq2. subst... reflexivity. Qed.

Fixpoint type_check (Gamma:context) (t:tm) : option ty :=
  match t with
  | tvar x => Gamma x
  | tabs x T11 t12 => match type_check (extend Gamma x T11) t12 with
                          | Some T12 => Some (TArrow T11 T12)
                          | _ => None
                        end
  | tapp t1 t2 => match type_check Gamma t1, type_check Gamma t2 with
                      | Some (TArrow T11 T12),Some T2 =>
                        if beq_ty T11 T2 then Some T12 else None
                      | _,_ => None
                    end
  end.

Ltac solve_by_inverts n :=
  match goal with | H : ?T |- _ =>
  match type of T with Prop =>
    solve [
      inversion H;
      match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
  end end.

Ltac solve_by_invert :=
  solve_by_inverts 1.

Fixpoint subst (x:string) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_string x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_string x x' then t1 else (subst x s t1))
  | tapp t1 t2 =>
      tapp (subst x s t1) (subst x s t2)
  end.

Theorem type_checking_sound : forall Gamma t T,
  type_check Gamma t = Some T -> has_type Gamma t T.
Proof.
  intros Gamma t. generalize dependent Gamma.
  induction t; intros Gamma T Htc; inversion Htc.
  - apply T_Var. apply H0.
  - remember (type_check Gamma t1) as TO1.
    remember (type_check Gamma t2) as TO2.
    destruct TO1 as [T1|]; try solve_by_invert;
    destruct T1 as [|T11 T12]; try solve_by_invert.
    destruct TO2 as [T2|]; try solve_by_invert.
    remember (beq_ty T11 T2) as b.
    destruct b; try solve_by_invert.
    symmetry in Heqb. apply beq_ty__eq in Heqb.
    inversion H0; subst...
    apply T_App with (T11 := T2) (T12 := T).
    symmetry in HeqTO1.
    apply IHt1 in HeqTO1. apply HeqTO1.
    symmetry in HeqTO2.
    apply IHt2 in HeqTO2. apply HeqTO2.
  - remember (extend Gamma s t) as G'.
    remember (type_check G' t0) as TO2.
    destruct TO2; try solve_by_invert.
    inversion H0. apply T_Abs. rewrite <- HeqG'.
    apply IHt. rewrite HeqTO2. reflexivity. Qed.

Lemma typecheck_complete : forall E t A,
  has_type E t A ->
  type_check E t = Some A.
Proof.
intros E t A H.
induction H.
- apply H.
- simpl.
  rewrite IHtyped1. rewrite IHtyped2.
  rewrite beq_ty_refl.
  reflexivity.
- simpl.
  rewrite IHtyped. reflexivity.
Qed.


Require Arith_base.

(* fin n is a convenient way to represent \1 .. n\
fin n can be seen as a n-uplet of unit. F1 is the first element of the n-uplet.
If f is the k-th element of the (n-1)-uplet, FS f is the (k+1)-th element of the n-uplet.
Author: Pierre Boutillier Institution: PPS, INRIA 12/2010-01/2012-07/2012 *)

(* Vom Prinzip her die gleiche Definition mit t = Finite_Set *)
Inductive t : nat -> Set :=
|F1 : forall {n}, t (S n)
|FS : forall {n}, t n -> t (S n).

Print False_rect.
Print ID.

Section SCHEMES.
(**)
Definition case0 P (p: t 0): P p :=
  match p with
  | F1    => fun devil => False_rect (@ID) devil
  | FS _ => fun devil => False_rect (@ID) devil end.
Print case0.

(**)
Definition caseS' {n : nat} (p : t (S n)) :
forall (P : t (S n) -> Type) (P1 : P F1) (PS : forall (p : t n), P (FS p)), P p :=
  match p with
  | @F1 k => fun P P1 PS => P1
  | FS pp  => fun P P1 PS => PS pp
  end.

(**)
Definition caseS (P: forall {n}, t (S n) -> Type)
  (P1: forall n, @P n F1) (PS : forall {n} (p: t n), P (FS p))
  {n} (p: t (S n)) : P p := caseS' p P (P1 n) PS.

(**)
Definition rectS (P: forall {n}, t (S n) -> Type)
  (P1: forall n, @P n F1) (PS : forall {n} (p: t (S n)), P p -> P (FS p)):
  forall {n} (p: t (S n)), P p :=
fix rectS_fix {n} (p: t (S n)): P p:=
  match p with
  | @F1 k => P1 k
  | @FS 0 pp => case0 (fun f => P (FS f)) pp
  | @FS (S k) pp => PS pp (rectS_fix pp)
  end.

(**)
Definition rect2 (P : forall {n} (a b : t n), Type)
  (H0 : forall n, @P (S n) F1 F1)
  (H1 : forall {n} (f : t n), P F1 (FS f))
  (H2 : forall {n} (f : t n), P (FS f) F1)
  (HS : forall {n} (f g : t n), P f g -> P (FS f) (FS g)) :
    forall {n} (a b : t n), P a b :=
  fix rect2_fix {n} (a : t n) {struct a} : forall (b : t n), P a b :=
    match a with
    | @F1 m => fun (b : t (S m)) => caseS' b (P F1) (H0 _) H1
    | @FS m a' => fun (b : t (S m)) =>
      caseS' b (fun b => P (@FS m a') b) (H2 a') (fun b' => HS _ _ (rect2_fix a' b'))
    end.

End SCHEMES.

(**)
Definition FS_inj {n} (x y: t n) (eq: FS x = FS y): x = y :=
match eq in _ = a return
  match a as a' in t m return
    match m with
      |0 => Prop
      |S n' => t n' -> Prop
    end
  with
     F1 => fun _ => True
    |FS y => fun x' => x' = y
  end
x with
  eq_refl => eq_refl
end.

(* to_nat f = p iff f is the p{^ th} element of fin m. *)
Fixpoint to_nat {m} (n : t m) : {i | i < m} :=
  match n with
    |@F1 j => exist _ 0 (Lt.lt_0_Sn j)
    |FS p =>
      match to_nat p with
       |exist _ i P => exist _ (S i) (Lt.lt_n_S _ _ P)
     end
  end.

(* of_nat p n answers the p{^ th} element of fin n if p < n or a proof of p >= n else *)
Fixpoint of_nat (p n : nat) : (t n) + { exists m, p = n + m } :=
  match n with
   |0 => inright _ (ex_intro _ p eq_refl)
   |S n' =>
      match p with
        |0 => inleft _ (F1)
        |S p' =>
          match of_nat p' n' with
            |inleft f => inleft _ (FS f)
            |inright arg => inright _ (match arg with |ex_intro _ m e =>
          ex_intro (fun x => S p' = S n' + x) m (f_equal S e) end)
          end
      end
  end.

(* of_nat_lt p n H answers the p{^ th} element of fin n it behaves much better than of_nat p n on open term *)
Fixpoint of_nat_lt {p n : nat} : p < n -> t n :=
  match n with
    |0 => fun H : p < 0 => False_rect _ (Lt.lt_n_O p H)
    |S n' => match p with
      |0 => fun _ => @F1 n'
      |S p' => fun H => FS (of_nat_lt (Lt.lt_S_n _ _ H))
    end
  end.

(**)
Lemma of_nat_ext {p}{n} (h h' : p < n) : of_nat_lt h = of_nat_lt h'.

(**)
Lemma of_nat_to_nat_inv {m} (p : t m) : of_nat_lt (proj2_sig (to_nat p)) = p.

(**)
Lemma to_nat_of_nat {p}{n} (h : p < n) : to_nat (of_nat_lt h) = exist _ p h.

(**)
Lemma to_nat_inj {n} (p q : t n) :
 proj1_sig (to_nat p) = proj1_sig (to_nat q) -> p = q.

(* weak p f answers a function witch is the identity for the p{^ th} first element of
fin (p + m) and FS (FS .. (FS (f k))) for FS (FS .. (FS k)) with p FSs *)
Fixpoint weak {m}{n} p (f : t m -> t n) :
  t (p + m) -> t (p + n) :=
match p as p' return t (p' + m) -> t (p' + n) with
  |0 => f
  |S p' => fun x => match x with
     |@F1 n' => fun eq : n' = p' + m => F1
     |@FS n' y => fun eq : n' = p' + m => FS (weak p' f (eq_rect _ t y _ eq))
  end (eq_refl _)
end.

(* The p{^ th} element of fin m viewed as the p{^ th} element of fin (m + n) *)
Fixpoint L {m} n (p : t m) : t (m + n) :=
  match p with |F1 => F1 |FS p' => FS (L n p') end.

(**)
Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p).

(* The p{^ th} element of fin m viewed as the p{^ th} element of fin (n + m) Really really ineficient !!! *)
Definition L_R {m} n (p : t m) : t (n + m).

(* The p{^ th} element of fin m viewed as the (n + p){^ th} element of fin (n + m) *)
Fixpoint R {m} n (p : t m) : t (n + m) :=
  match n with |0 => p |S n' => FS (R n' p) end.

(**)
Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p).

(**)
Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) :=
match o with
  |@F1 m' => L (m' * n) p
  |FS o' => R n (depair o' p)
end.

(**)
Lemma depair_sanity {m n} (o : t m) (p : t n) :
  proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)).

(**)
Fixpoint eqb {m n} (p : t m) (q : t n) :=
match p, q with
| @F1 m', @F1 n' => EqNat.beq_nat m' n'
| FS _, F1 => false
| F1, FS _ => false
| FS p', FS q' => eqb p' q'
end.

(**)
Lemma eqb_nat_eq : forall m n (p : t m) (q : t n), eqb p q = true -> m = n.

(**)
Lemma eqb_eq : forall n (p q : t n), eqb p q = true <-> p = q.

(**)
Lemma eq_dec {n} (x y : t n): {x = y} + {x <> y}.

(**)
Definition cast: forall {m} (v: t m) {n}, m = n -> t n.


Require Import Classical.

Class Hilbert := {
  Line : Type;
  Point : Type;
  Inc : Point -> Line -> Prop;
  Par l m := forall P:Point, ~(Inc P l /\ Inc P m);
  Algn A B C := exists l:Line, Inc A l /\ Inc B l /\ Inc C l;
  nAlgn A B C := forall l:Line, ~(Inc A l /\ Inc B l /\ Inc C l);

  I1: forall P Q:Point, P<>Q -> (exists ! l:Line, Inc P l /\ Inc Q l);
  I2: forall l:Line, (exists P Q:Point, Inc P l /\ Inc Q l /\ P<>Q);
  I3: exists A B C:Point, (A<>B/\B<>C/\C<>A) /\ nAlgn A B C;
}.

Context `{Hilbert}.

Proposition prop3_1: (forall l m:Line,
  l<>m -> ~(Par l m) -> exists ! P:Point, Inc P l /\ Inc P m).
Proof.
  intros l m l_ne_m nPar.
  apply not_all_ex_not in nPar.
  destruct nPar as [P].
  apply NNPP in H0.
  refine (ex_intro _ P _).
  split.
    assumption.

    intros Q H1.
    case (classic (P = Q)).
      trivial.

      intros P_ne_Q.
      pose (I1 P Q) as only.
      apply only in P_ne_Q.
      unfold unique in P_ne_Q.
      destruct P_ne_Q as [s].
      destruct H2 as [H2 only_s].

      specialize (only_s l) as only_sl.
      pose (conj (proj1 H0) (proj1 H1)) as bothl.
      apply only_sl in bothl.

      specialize (only_s m) as only_sm.
      pose (conj (proj2 H0) (proj2 H1)) as bothm.
      apply only_sm in bothm.
      rewrite bothl in bothm.
      apply l_ne_m in bothm.
      case bothm.
Qed.

Proposition prop3_2 : (exists l m n: Line, (l<>m/\m<>n/\n<>l) /\
  forall P:Point, ~(Inc P l /\ Inc P m /\ Inc P n)).
Proof.
  destruct I3 as [A [B [C [[AneB [BneC CneA]] nAlgnABC]]]].

  destruct ((I1 A B) AneB) as [AB [incAB unAB]].
  destruct ((I1 B C) BneC) as [BC [incBC unBC]].
  destruct ((I1 C A) CneA) as [CA [incCA unCA]].

  exists AB, BC, CA.
  assert(AB <> BC) as AB_neq_BC.
    case (classic (AB = BC)).
    intros AB_e_BC.
    rewrite AB_e_BC in incAB.
    pose (conj incBC (proj2 incAB)) as incABC.
    specialize (nAlgnABC BC).
    tauto.
    trivial.

  assert(BC <> CA) as BC_neq_CA.
    case (classic (BC = CA)).
    intros BC_e_CA.
    rewrite BC_e_CA in incBC.
    pose (conj incCA (proj2 incBC)) as incABC.
    specialize (nAlgnABC CA).
    tauto.
    trivial.

  assert(CA <> AB) as CA_neq_AB.
    case (classic (CA = AB)).
    intros CA_e_AB.
    rewrite CA_e_AB in incCA.
    pose (conj incAB (proj2 incCA)) as incABC.
    specialize (nAlgnABC AB).
    tauto.
    trivial.

  split.
  tauto.

  intros P.
  case (classic (Inc P AB /\ Inc P BC /\ Inc P CA)).
  intros absurd.
  case (classic (P = A)).
    intros P_eq_A.
    case (classic (P = B)).
      intros P_eq_B.
      rewrite P_eq_A in P_eq_B.
      tauto.

      intros P_neq_B.
      destruct ((I1 P B) P_neq_B) as [PB [ incPB unPB]].

      pose (conj (proj1 absurd) (proj2 incAB)) as BnP_inc_AB.
      pose ((unPB AB) BnP_inc_AB) as PB_eq_AB.

      pose (conj (proj1 (proj2 absurd)) (proj1 incBC)) as BnP_inc_BC.
      pose ((unPB BC) BnP_inc_BC) as PB_eq_BC.

      rewrite PB_eq_AB in PB_eq_BC.
      tauto.

    intros P_neq_A.
    destruct ((I1 P A) P_neq_A) as [PA [ incPA unPA]].

    pose (conj (proj1 absurd) (proj1 incAB)) as AnP_inc_AB.
    pose ((unPA AB) AnP_inc_AB) as PA_eq_AB.

    pose (conj (proj2 (proj2 absurd)) (proj2 incCA)) as AnP_inc_CA.
    pose ((unPA CA) AnP_inc_CA) as PA_eq_CA.

    rewrite PA_eq_CA in PA_eq_AB.
    tauto.

  trivial.
Qed.

Proposition prop3_3 : (forall r:Line, exists P:Point, ~(Inc P r)).
Proof.
  intros r.
  destruct I3.
  destruct H0.
  destruct H0.
  apply proj2 in H0.
  specialize (H0 r).
  apply not_and_or in H0.
  case H0.
    intros nInc_x_r.
    refine (ex_intro _ x _).
    assumption.

    intros H1.
    apply not_and_or in H1.
    case H1.
      intros nInc_x0_r.
      exists x0.
      assumption.

      intros nInc_x1_r.
      exists x1.
      assumption.
Qed.

Proposition prop3_4: (forall P:Point, exists r:Line, ~(Inc P r)).
Proof.
  intros P.
  destruct prop3_2 as [l [m [n [[l_ne_m [m_ne_n n_ne_l]] nAlgn_lmn]]]].
  case (classic(forall r : Line, Inc P r)).

  intros all_inc.
  specialize (nAlgn_lmn P).
  pose (all_inc l) as l_inc.
  pose (all_inc m) as m_inc.
  pose (all_inc n) as n_inc.
  tauto.

  intros not_all_inc.
  apply not_all_ex_not in not_all_inc.
  trivial.
Qed.


Class ordered (T : Type) :=
  { eq  : T -> T -> bool
  ; lt  : T -> T -> bool
  ; leq : T -> T -> bool

  ; eq_sym
      : forall (t1 t2 : T)
      , eq t1 t2 = eq t2 t1
  ; lt_asym
      : forall (t1 t2 : T) (b : bool)
      , lt t1 t2 = true -> lt t2 t1 = false
  ; eq_implies_leq
      : forall (t1 t2 : T)
      , eq t1 t2 = true -> leq t1 t2 = true
  ; lt_implies_leq
      : forall (t1 t2 : T)
      , lt t1 t2 = true -> leq t1 t2 = true
  ; lt_not_eq
      : forall (t1 t2 : T)
      , lt t1 t2 = true -> eq t1 t2 = false
  }.

Class heap (H : Type) (E : Type) `{o : ordered E} : Type :=
  { empty     : H
  ; isEmpty   : H -> bool
  ; insert    : E -> H -> H
  ; merge     : H -> H -> H
  ; findMin   : H -> option E
  ; deleteMin : H -> option H

  ; empty_is_empty
      : isEmpty empty = true
  ; non_empty_is_not_empty
      : forall (h : H) (e : E)
      , isEmpty (insert e h) = true
  ; merge_empty_left
      : forall (h : H)
      , merge empty h = h
  ; merge_empty_right
      : forall (h : H)
      , merge h empty = h
  ; empty_findMin
      : findMin empty = None
  ; empty_deleteMin
      : deleteMin empty = None
  ; insert_min
      : forall (h : H) (e1 e2 : E)
      , findMin h = Some e1 -> lt e2 e1 = true -> findMin (insert e2 h) = Some e2
  ; insert_non_min
      : forall (h : H) (e1 e2 : E)
      , findMin h = Some e1 -> lt e2 e1 = false -> findMin (insert e2 h) = Some e1
  ; merge_min_left
      : forall (h1 h2 : H) (e1 e2 : E)
      , findMin h1 = Some e1 -> findMin h2 = Some e2 -> lt e1 e2 = true -> findMin (merge h1 h2) = Some e1
  ; merge_min_right
      : forall (h1 h2 : H) (e1 e2 : E)
      , findMin h1 = Some e1 -> findMin h2 = Some e2 -> lt e2 e1 = true -> findMin (merge h1 h2) = Some e2
  ; delete_min
      : forall (h1 h2 : H) (e1 e2 : E)
      , findMin h1 = Some e1 -> lt e2 e1 = true -> deleteMin (insert e2 h1) = Some h2 -> findMin h2 = Some e1
  }.

Require Import Arith.

Inductive leftish_heap (E : Type) : Type :=
  | Empty : leftish_heap E
  | Node  : nat -> E -> leftish_heap E -> leftish_heap E -> leftish_heap E
  .

Definition lh_empty {E : Type} : leftish_heap E :=
  Empty E.

Definition lh_isEmpty {E : Type} (h : leftish_heap E) : bool :=
  match h with
    | Empty _         => true
    | Node  _ _ _ _ _ => false
  end.

Definition lh_findMin {E : Type} `{o : ordered E} (h : leftish_heap E) : option E :=
  match h with
    | Empty _ => None
    | Node _ _ x _ _ => Some x
  end.

Definition rank {E : Type} (e : leftish_heap E) : nat :=
  match e with
    | Empty _         => 0
    | Node  _ r _ _ _ => r
  end.

(* Cannot guess decreasing argument of fix. *)
Definition makeT {E : Type} (x : E) (a : leftish_heap E) (b : leftish_heap E) : leftish_heap E :=
  if (rank b) <? (rank a)
    then Node E (rank b + 1) x a b
    else Node E (rank a + 1) x b a.

(* FAIL *)
Fail Fixpoint lh_merge1 {E : Type} {o : ordered E} (e1 : leftish_heap E) (e2 : leftish_heap E) : leftish_heap E :=
  match e1, e2 with
    | h, Empty _ => h
    | Empty _, h => h
    | Node _ _ x a1 b1 as h1, Node _ _ y a2 b2 as h2 =>
        if leq x y
          then makeT x a1 (lh_merge1 b1 h2)
          else makeT y a2 (lh_merge1 h1 b2)
  end.

(* the name 'merge' seems to be in scope already *)
Fixpoint lh_merge (E:Type) (o:ordered E) (e1 e2:leftish_heap E) : leftish_heap E :=
match e1 with
| Empty _ => e2
| Node _ _ x a1 b1 as h1  =>
   (fix g (e2' : leftish_heap E) : leftish_heap E :=
        match e2' with
        | Empty _   => e1
        | Node _ _ y a2 b2 as h2 =>
           if leq x y
              then makeT x a1 (lh_merge _ _ b1 h2)
              else makeT y a2 (g b2)
        end) e2
end.

(* declares arguments as implicit going forward *)
Arguments lh_merge {E} {o}.
Arguments Empty  {E}.
Arguments Node {E}.

(* These 4 lemmas to check that lh_merge as the intended semantics *)
Lemma checkMerge1 : forall (E:Type) (o:ordered E) (e:leftish_heap E),
  lh_merge Empty e = e.
Proof.
  intros E o e.
  reflexivity.
Qed.

Lemma checkMerge2 : forall (E:Type) (o:ordered E) (e:leftish_heap E),
  lh_merge e Empty = e.
Proof.
  intros E o. destruct e as [|x a b]; reflexivity.
Qed.

Lemma checkMerge3
  : forall (E:Type) (o:ordered E) (e1 e2:leftish_heap E)
  , forall (n m:nat) (x y:E) (a1 b1 a2 b2:leftish_heap E) ,
  e1 = Node n x a1 b1 ->
  e2 = Node m y a2 b2 ->
  leq x y = true ->
  lh_merge e1 e2 = makeT x a1 (lh_merge b1 e2).
Proof.
  intros E o e1 e2 n m x y a1 b1 a2 b2 H1 H2 H.
  rewrite H1, H2. simpl. rewrite H. reflexivity.
Qed.

Lemma checkMerge4
  : forall (E:Type) (o:ordered E) (e1 e2:leftish_heap E),
    forall (n m:nat) (x y:E) (a1 b1 a2 b2:leftish_heap E),
  e1 = Node n x a1 b1 ->
  e2 = Node m y a2 b2 ->
  leq x y = false ->
  lh_merge e1 e2 = makeT y a2 (lh_merge e1 b2).
Proof.
  intros E o e1 e2 n m x y a1 b1 a2 b2 H1 H2 H.
  rewrite H1, H2. simpl. rewrite H. reflexivity.
Qed.

Definition lh_insert {E : Type} `{o : ordered E} (x : E) (h : leftish_heap E) : leftish_heap E :=
  lh_merge (Node 1 x Empty Empty) h.

Definition lh_deleteMin {E : Type} `{o : ordered E} (h : leftish_heap E) : option (leftish_heap E) :=
  match h with
    | Empty         => None
    | Node  _ x a b => Some (lh_merge a b)
  end.

Theorem lh_empty_is_empty
  : forall (E : Type)
  , @lh_isEmpty E lh_empty = true.
Proof.
    intros E. reflexivity.
Qed.

Lemma makeT_is_not_empty
  : forall (E : Type) (x : E) (a b : leftish_heap E)
  , lh_isEmpty (makeT x a b) = false.
Proof.
    intros E x a b. unfold makeT. destruct (rank b <? rank a); reflexivity.
Qed.

Theorem lh_non_empty_is_not_empty
  : forall (E : Type) (o : ordered E) (h : leftish_heap E) (e : E)
  , lh_isEmpty (lh_insert e h) = false.
Proof.
    intros E o h e. destruct h as [|n x h1 h2].
    - reflexivity.
    - unfold lh_insert, lh_merge. destruct (leq e x).
        + reflexivity.
        + apply makeT_is_not_empty.
Qed.

Theorem lh_merge_empty_left
  : forall (E : Type) (o : ordered E) (h : leftish_heap E)
  , lh_merge lh_empty h = h.
Proof.
    intros E o h. reflexivity.
Qed.

Theorem lh_merge_empty_right
  : forall (E : Type) (o : ordered E) (h : leftish_heap E)
  , lh_merge h lh_empty = h.
Proof.
    intros E o h. destruct h; reflexivity.
Qed.

Theorem lh_empty_findMin
  : forall (E : Type) (o : ordered E)
  , lh_findMin lh_empty = None.
Proof.
    intros E o. reflexivity.
Qed.

Theorem lh_empty_deleteMin
  : forall (E : Type) (o : ordered E)
  , lh_deleteMin lh_empty = None.
Proof.
    intros E o. reflexivity.
Qed.

Theorem lh_insert_min
  : forall (E : Type) (o : ordered E) (h : leftish_heap E) (e1 e2 : E)
  , lh_findMin h = Some e1 -> lt e2 e1 = true -> lh_findMin (lh_insert e2 h) = Some e2.
Proof.
    intros E o h e1 e2 H1 H2. unfold lh_insert, lh_findMin. destruct h.
    - reflexivity.
    - simpl. unfold lh_findMin in H1. inversion H1. subst.
      assert (leq e2 e1 = true) as H3. { apply lt_implies_leq. assumption. }
      rewrite H3. reflexivity.
Qed.

Theorem lh_insert_non_min
  : forall (E : Type) (o : ordered E) (h : leftish_heap E) (e1 e2 : E)
  , lh_findMin h = Some e1 -> lt e2 e1 = false -> lh_findMin (lh_insert e2 h) = Some e1.
Proof.
    intros E o h e1 e2 H1 H2. unfold lh_insert, lh_findMin. destruct h.
    - inversion H1.
    - simpl. unfold lh_findMin in H1. inversion H1. subst. destruct (leq e2 e1) eqn:H3.
        + simpl.
          assert (e2 = e1).

Show.
(*

Theorem lh_merge_min_left
  : forall (E : Type) (o : ordered E) (h1 h2 : leftish_heap E) (e1 e2 : E)
  , lh_findMin h1 = Some e1 -> lh_findMin h2 = Some e2 -> lt e1 e2 = true -> lh_findMin (lh_merge h1 h2) = Some e1.
Proof.
Admitted.

Theorem lh_merge_min_right
  : forall (E : Type) (o : ordered E) (h1 h2 : leftish_heap E) (e1 e2 : E)
  , lh_findMin h1 = Some e1 -> lh_findMin h2 = Some e2 -> lt e2 e1 = true -> lh_findMin (lh_merge h1 h2) = Some e2.
Proof.
Admitted.

Theorem lh_delete_min
  : forall (E : Type) (o : ordered E) (h1 h2 : leftish_heap E) (e1 e2 : E)
  , lh_findMin h1 = Some e1 -> lt e2 e1 = true -> lh_deleteMin (lh_insert e2 h1) = Some h2 -> lh_findMin h2 = Some e1.
Proof.
Admitted.

Instance leftish {E : Type} `{o : ordered E} : heap (leftish_heap E) E :=
  { empty     := lh_empty
  ; isEmpty   := lh_isEmpty
  ; insert    := lh_insert
  ; merge     := lh_merge
  ; findMin   := lh_findMin
  ; deleteMin := lh_deleteMin

  (* Type and ordered instance come from the type class, thus we use _ _ *)
  ; empty_is_empty          := lh_empty_is_empty _
  ; non_empty_is_not_empty  := lh_non_empty_is_not_empty _ _
  ; merge_empty_left        := lh_merge_empty_left _ _
  ; merge_empty_right       := lh_merge_empty_right _ _
  ; empty_findMin           := lh_empty_findMin _ _
  ; empty_deleteMin         := lh_empty_deleteMin _ _
  ; insert_min              := lh_insert_min _ _
  ; insert_non_min          := lh_insert_non_min _ _
  ; merge_min_left          := lh_merge_min_left _ _
  ; merge_min_right         := lh_merge_min_right _ _
  ; delete_min              := lh_delete_min _ _
  }.
*)


Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Lists.List.
Require Import Crypto.Arithmetic.Core.
Require Import Crypto.Arithmetic.ModOps.
Require Import Crypto.Arithmetic.Partition.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.SplitInContext.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.

Require Import Crypto.Util.Notations.
Local Open Scope Z_scope.
Import Weight.

Definition uweight (lgr : Z) : nat -> Z
  := weight lgr 1.
Definition uwprops lgr (Hr : 0 < lgr) : @weight_properties (uweight lgr).
Proof using Type. apply wprops; lia. Qed.
Lemma uweight_eq_alt' lgr n : uweight lgr n = 2^(lgr*Z.of_nat n).
Proof using Type. now cbv [uweight weight]; autorewrite with zsimplify_fast. Qed.
Lemma uweight_eq_alt lgr (Hr : 0 <= lgr) n : uweight lgr n = (2^lgr)^Z.of_nat n.
Proof using Type. now rewrite uweight_eq_alt', Z.pow_mul_r by lia. Qed.
Lemma uweight_eval_shift lgr (Hr : 0 <= lgr) xs :
  forall n,
    length xs = n ->
    Positional.eval (fun i => uweight lgr (S i)) n xs =
    (uweight lgr 1) * Positional.eval (uweight lgr) n xs.
Proof using Type.
  induction xs using rev_ind; destruct n; distr_length;
    intros; [cbn; ring | ].
  rewrite !Positional.eval_snoc with (n:=n) by distr_length.
  rewrite IHxs, !uweight_eq_alt by lia.
  autorewrite with push_Zof_nat push_Zpow.
  rewrite !Z.pow_succ_r by auto with zarith.
  ring.
Qed.
Lemma uweight_S lgr (Hr : 0 <= lgr) n : uweight lgr (S n) = 2 ^ lgr * uweight lgr n.
Proof using Type.
  rewrite !uweight_eq_alt by auto.
  autorewrite with push_Zof_nat.
  rewrite Z.pow_succ_r by auto with zarith.
  reflexivity.
Qed.
Lemma uweight_double_le lgr (Hr : 0 < lgr) n : uweight lgr n + uweight lgr n <= uweight lgr (S n).
Proof using Type.
  rewrite uweight_S, uweight_eq_alt by lia.
  rewrite Z.add_diag.
  apply Z.mul_le_mono_nonneg_r.
  { auto with zarith. }
  { transitivity (2 ^ 1); [ reflexivity | ].
    apply Z.pow_le_mono_r; lia. }
Qed.
Lemma uweight_sum_indices lgr (Hr : 0 <= lgr) i j : uweight lgr (i + j) = uweight lgr i * uweight lgr j.
Proof.
  rewrite !uweight_eq_alt by lia.
  rewrite Nat2Z.inj_add; auto using Z.pow_add_r with zarith.
Qed.
Lemma uweight_0 lgr : uweight lgr 0 = 1.
Proof.
  rewrite uweight_eq_alt', Z.mul_0_r; reflexivity.
Qed.
Lemma uweight_1 lgr : uweight lgr 1 = 2^lgr.
Proof using Type.
  cbv [uweight weight].
  f_equal; autorewrite with zsimplify_const; lia.
Qed.

(* Because the weight is uniform, we can start partitioning from
  any index and end up with the same result. *)
Lemma uweight_recursive_partition_change_start lgr (Hr : 0 <= lgr) n :
  forall i j x,
    recursive_partition (uweight lgr) n i x
    = recursive_partition (uweight lgr) n j x.
Proof using Type.
  induction n; intros; [reflexivity | ].
  cbn [recursive_partition].
  rewrite !uweight_eq_alt by lia.
  autorewrite with push_Zof_nat push_Zpow.
  rewrite <-!Z.pow_sub_r by auto using Z.pow_nonzero with lia.
  rewrite !Z.sub_succ_l.
  autorewrite with zsimplify_fast.
  erewrite IHn. reflexivity.
Qed.
Lemma uweight_recursive_partition_equiv lgr (Hr : 0 < lgr) n i x:
  Partition.partition (uweight lgr) n x =
  recursive_partition (uweight lgr) n i x.
Proof using Type.
  rewrite recursive_partition_equiv by auto using uwprops.
  auto using uweight_recursive_partition_change_start with lia.
Qed.

Lemma uweight_firstn_partition lgr (Hr : 0 < lgr) n x m (Hm : (m <= n)%nat) :
  firstn m (Partition.partition (uweight lgr) n x) = Partition.partition (uweight lgr) m x.
Proof.
  cbv [Partition.partition];
    repeat match goal with
           | _ => progress intros
           | _ => progress autorewrite with push_firstn natsimplify zsimplify_fast
           | _ => rewrite Nat.min_l by lia
           | _ => rewrite weight_0 by auto using uwprops
           | _ => reflexivity
           end.
Qed.

Lemma uweight_skipn_partition lgr (Hr : 0 < lgr) n x m :
  skipn m (Partition.partition (uweight lgr) n x) = Partition.partition (uweight lgr) (n - m) (x / uweight lgr m).
Proof.
  cbv [Partition.partition];
    repeat match goal with
           | _ => progress intros
           | _ => progress autorewrite with push_skipn natsimplify zsimplify_fast
           | _ => rewrite skipn_seq by auto
           | _ => rewrite weight_0 by auto using uwprops
           | _ => rewrite recursive_partition_equiv' by auto using uwprops
           | _ => auto using uweight_recursive_partition_change_start with zarith
           end.
Qed.

Lemma uweight_partition_unique lgr (Hr : 0 < lgr) n ls :
  length ls = n -> (forall x, List.In x ls -> 0 <= x <= 2^lgr - 1) ->
  ls = Partition.partition (uweight lgr) n (Positional.eval (uweight lgr) n ls).
Proof using Type.
  intro; subst n.
  rewrite uweight_recursive_partition_equiv with (i:=0%nat) by assumption.
  induction ls as [|x xs IHxs]; [ reflexivity | ].
  repeat first [ progress cbn [List.length recursive_partition List.In] in *
               | progress intros
               | assumption
               | rewrite Positional.eval_cons by reflexivity
               | rewrite weight_0 by now apply uwprops
               | rewrite uweight_1
               | progress specialize_by_assumption
               | progress split_contravariant_or
               | rewrite uweight_recursive_partition_change_start with (i:=1%nat) (j:=0%nat) by lia
               | rewrite uweight_eval_shift by lia
               | rewrite Z.div_1_r
               | progress Z.rewrite_mod_small
               | rewrite Z.div_add' by auto with arith lia
               | rewrite Z.div_small by lia
               | match goal with
                 | [ H : forall x, _ = x -> _ |- _ ] => specialize (H _ eq_refl)
                 | [ |- context[(_ + ?x * _) mod ?x] ]
                   => let k := fresh in
                      set (k := x); push_Zmod; pull_Zmod; subst k;
                      progress autorewrite with zsimplify_const
                 | [ |- ?x :: _ = ?x :: _ ] => apply f_equal
                 end ].
Qed.

Lemma uweight_eval_app' lgr (Hr : 0 <= lgr) n x y :
  n = length x ->
  Positional.eval (uweight lgr) (n + length y) (x ++ y) = Positional.eval (uweight lgr) n x + (uweight lgr n) * Positional.eval (uweight lgr) (length y) y.
Proof using Type.
  induction y using rev_ind;
    repeat match goal with
           | _ => progress intros
           | _ => progress distr_length
           | _ => progress autorewrite with push_eval zsimplify natsimplify
           | _ => rewrite Nat.add_succ_r
           | H : ?x = 0%nat |- _ => subst x
           | _ => progress rewrite ?app_nil_r, ?app_assoc
           | _ => reflexivity
           end.
  rewrite IHy by auto. rewrite uweight_sum_indices; lia.
Qed.

Lemma uweight_eval_app lgr (Hr : 0 <= lgr) n m x y :
  n = length x ->
  m = (n + length y)%nat ->
  Positional.eval (uweight lgr) m (x ++ y) = Positional.eval (uweight lgr) n x + (uweight lgr n) * Positional.eval (uweight lgr) (length y) y.
Proof using Type. intros. subst m. apply uweight_eval_app'; lia. Qed.

Lemma uweight_partition_app lgr (Hr : 0 < lgr) n m a b :
 Partition.partition (uweight lgr) n a ++ Partition.partition (uweight lgr) m b
  = Partition.partition (uweight lgr) (n+m) (a mod uweight lgr n + b * uweight lgr n).
Proof.
  assert (0 < uweight lgr n) by auto using uwprops.
  match goal with |- _ = ?rhs => rewrite <-(firstn_skipn n rhs) end.
  rewrite uweight_firstn_partition, uweight_skipn_partition by lia.
  rewrite Z.div_add by lia.
  rewrite (Z.div_small (_ mod _)) by auto with zarith.
  f_equal.
  { apply partition_eq_mod; [ auto using uwprops | ].
    push_Zmod. autorewrite with zsimplify. reflexivity. }
  { f_equal; lia. }
Qed.

Lemma mod_mod_uweight lgr (Hr : 0 < lgr) a i j :
  (i <= j)%nat -> (a mod (uweight lgr j)) mod (uweight lgr i) = a mod (uweight lgr i).
Proof.
  intros. rewrite <-Znumtheory.Zmod_div_mod; auto using uwprops; [ ].
  rewrite !uweight_eq_alt'. apply Divide.Z.divide_pow_le. nia.
Qed.

Lemma uweight_pull_mod lgr (Hr : 0 < lgr) x i j :
  (j <= i)%nat ->
  x mod (uweight lgr i) / uweight lgr j = (x / uweight lgr j) mod (uweight lgr (i - j)).
Proof.
  intros. rewrite Z.mod_pull_div by auto using Z.lt_le_incl, uwprops.
  rewrite <-uweight_sum_indices by lia.
  repeat (f_equal; try lia).
Qed.


(**
池渕さん 「プログラマのための圏論の基礎」
- Categories for the Working Programmer -
1. 圏論とプログラミング、プロダクト
http://www.iij-ii.co.jp/lab/techdoc/category/category1.html

勉強のために、この表層をSSReflectに移した。
オリジナルと異なり、Setoid は自分で定義している。
また、Mor の定義を Obj -> Obj -> Setoid とした。
*)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import Classes.RelationClasses.     (* Equivalence *)

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(*
Reserved Notation "A ~> B" (at level 89, right associativity, only parsing).
Reserved Notation "f 'o' g" (at level 41, right associativity, only parsing).
 *)

Section Categories.

  Class Setoid :=
    {
      carrier : Type;
      equiv : carrier -> carrier -> Prop
    }.
  Coercion carrier : Setoid >-> Sortclass.
  Notation "x === z" := (equiv x z) (at level 70).

  Class Category :=
    {
      (* 対象の定義 *)
      Obj : Type;                           (* Category -> Type *)

      (* 射の定義 *)
      Mor : Obj -> Obj -> Setoid;           (* Coersion が有効になる。 *)

      (* 恒等射の定義 *)
      idC : forall {A : Obj}, Mor A A;

      (* 射の合成の定義 *)
      composeC : forall {A B C : Obj}, Mor B C -> Mor A B -> Mor A C;

      (* 単位律の定義 *)
      left_identity : forall (A B : Obj) (f : Mor A B), composeC idC f === f;
      right_identity : forall (A B : Obj) (f : Mor A B), composeC f idC === f;

      (* 結合律の定義 *)
      associativity : forall (A B C D : Obj)
                             (f : Mor A B) (g : Mor B C) (h : Mor C D),
          composeC (composeC h g) f === composeC h (composeC g f)
    }.

  Check @Obj : Category -> Type.
  (* Obj が出現する文脈では、CP : Category を省略できない。
     ここで、CPは、ProductをもつCategoryの意味。 *)

  (* 可換の定義 *)
  Definition commute {CP : Category} {A B C : Obj}
             (f : Mor A B) (g : Mor B C) (h : Mor A C) :=
    @composeC CP _ _ _ g f === h.

  (* 直積 *)
  Class Product {CP : Category} (P : Obj -> Obj -> Obj) :=
    {
      proj1 : forall {A B : Obj}, Mor (P A B) A;
      proj2 : forall {A B : Obj}, Mor (P A B) B;

      (* 仲介射 *)
      mediating : forall {A B X : Obj}, Mor X A -> Mor X B -> Mor X (P A B);
      (* mediating = (&&&) *)

      (* CP は、commute を経由して、composeC に渡される。 *)
      med_commute1 : forall (A B X : Obj) (f : Mor X A) (g : Mor X B),
          commute (mediating f g) proj1 f;
      med_commute2 : forall (A B X : Obj) (f : Mor X A) (g : Mor X B),
          commute (mediating f g) proj2 g;
      med_unique : forall (A B X : Obj)
                          (f : Mor X A) (g : Mor X B) (h : Mor X (P A B)),
                     @commute CP X (P A B) A h proj1 f ->
                     @commute CP X (P A B) B h proj2 g ->
                     h === @mediating A B X f g
    }.

  Definition parallel {CP : Category} {A B C D : Obj} {P : Obj -> Obj -> Obj}
             {Prod : Product P}
             (f : Mor A B) (g : Mor C D) : Mor (P A C) (P B D) :=
    let (p1, p2) :=
        (@proj1 CP P Prod A C, @proj2 CP P Prod A C) in
    mediating (composeC f p1) (composeC g p2).
  (* parallel = (***) または <f,g> *)
End Categories.

(* *********************** *)
(* 関数の世界、関数 と 直積 *)
(* *********************** *)
Section Functions.
  (* Ordinary tuples are products *)

  Instance EquivExt : forall (A B : Set), Equivalence (@eqfun A B) := (* notu *)
    {
      Equivalence_Reflexive := @frefl A B;
      Equivalence_Symmetric := @fsym A B;
      Equivalence_Transitive := @ftrans A B
    }.

  Instance EqMor : forall (A B : Set), Setoid :=
    {
      carrier := A -> B;
      equiv := @eqfun B A
    }.

  Instance Func : Category :=               (* Category *)
    {
      Obj := Set;
      Mor := EqMor;
      idC A := id;
      composeC A B C := funcomp tt          (* compose *)
    }.
  Proof.
    - by rewrite //=.
    - by rewrite //=.
    - by rewrite //=.
  Defined.

  (* Instance Prod : @Product Func prod := *)
  Instance Prod : Product prod :=
    {
      proj1 A B := @fst A B;
      proj2 A B := @snd A B ;
      mediating A B X := fun f g x => (f x, g x)
    }.
  Proof.
    - by rewrite //=.
    - by rewrite //=.
    - rewrite /commute /= /eqfun.
      move=> A B X f g h H H0 x.
      rewrite -H -H0.
        by apply surjective_pairing.
  Qed.
End Functions.

(* ********************** *)
(* 半順序の世界、>= と max *)
(* >= はProp、つまり (m >= n)%coq_nat にするべき *)
(* ********************** *)
Section Orders.
  (* max of nat is a product *)

  Definition geq m n := m >= n.

  Check leqnn : forall n : nat, n <= n.

  Lemma geq_trans : forall m n p : nat, n >= p -> m >= n -> m >= p.
  Proof.
    move=> m n p H1 H2.
    move: H1 H2.
      by apply: leq_trans.
  Qed.

  Definition eq_geq m n (p q : m >= n) := true.

  Instance EquivGeq : forall m n, Equivalence (@eq_geq m n). (* notu *)
  Proof.
      by [].
  Qed.

  Instance EqGeq : forall m n, Setoid :=
    {
      carrier := m >= n;
      equiv := @eq_geq m n
    }.

  Instance Order : Category :=
    {
      Obj := nat;
      Mor := EqGeq;
      idC := leqnn;
      composeC := geq_trans
    }.
  Proof.
    - by [].
    - by [].
    - by [].
  Defined.

  Check leq_maxl : forall m n : nat, m <= maxn m n.
  Check leq_maxr : forall m n : nat, n <= maxn m n.

  Lemma max_med : forall m n x,
      m <= x -> n <= x -> maxn m n <= x.
  Proof.
    move=> m n x H1 H2.
    rewrite geq_max.
    apply/andP.
      by split.
  Qed.

  (* Instance Max : Product maxn := *)
  Instance Max : @Product Order maxn :=
    {
      proj1 := leq_maxl;
      proj2 := leq_maxr;
      mediating := max_med
    }.
  Proof.
    - by [].
    - by [].
    - by [].
  Defined.
  (* an application of parallel (***) *)

  Theorem parallel_max : forall m n p q,
      m >= n -> p >= q -> maxn m p >= maxn n q.
  Proof.
    move=> m n p q.
    Check @parallel.
    Check @parallel Order.
    Check @parallel Order m n p q maxn Max.
      by apply: (@parallel Order m n p q maxn Max).
  Qed.
End Orders.

(* ********************** *)
(* 半順序の世界、<= と min *)
(* >= はProp、つまり (m <= n)%coq_nat にするべき *)
(* ********************** *)
Section Orders'.

  Check leqnn : forall n : nat, n <= n.

  (* leq_trans とは前提の順番が違うので、作り直しておく。 *)
  Lemma leq_trans' : forall m n p : nat, n <= p -> m <= n -> m <= p.
  Proof.
    move=> m n p H1 H2.
    move: H2 H1.
      by apply: leq_trans.
  Qed.

  Definition eq_leq m n (p q : m <= n) := true.

  Instance EquivLeq : forall m n, Equivalence (@eq_leq m n). (* notu *)
  Proof.
      by [].
  Qed.

  Instance EqLeq : forall m n, Setoid :=
    {
      carrier := m <= n;
      equiv := @eq_leq m n
    }.

  Instance Order' : Category :=
    {
      Obj := nat;
      Mor := EqLeq;
      idC := leqnn;
      composeC := leq_trans'
    }.
  Proof.
    - by [].
    - by [].
    - by [].
  Defined.

  Check geq_minl : forall m n : nat, minn m n <= m.
  Check geq_minr : forall m n : nat, minn m n <= n.

  Lemma min_med : forall m n x,
      x <= m -> x <= n -> x <= minn m n.
  Proof.
    move=> m n x H1 H2.
    rewrite leq_min.
    apply/andP.
      by split.
  Qed.

  (* Instance Min : Product minn := *)
  Instance Min : @Product Order' minn :=
    {
      proj1 := geq_minl;
      proj2 := geq_minr;
      mediating := min_med
    }.
  Proof.
    - by [].
    - by [].
    - by [].
  Defined.
  (* an application of parallel (***) *)

  Theorem parallel_min : forall m n p q,
      m <= n -> p <= q -> minn m p <= minn n q.
  Proof.
    move=> m n p q.
    Check @parallel Order' m n p q minn Min.
      by apply: (@parallel Order' m n p q minn Min).
  Qed.
End Orders'.

(* END *)


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

Require Import Arith Omega.

Require Import utils decidable_t.
Require Import recalg ra_ca.

Set Implicit Arguments.

(* Computation always have a cost greater than 1 *)

Theorem ra_ca_cost k (f : recalg k) v q x : [f;v] -[q>> x -> 0 < q.
Proof.
  induction 1; omega.
Qed.

Section functionality.

  (* This one is not very complicated but it requires inversion lemmas
     which can be difficult to obtain if you do not know how to proceed
     with dependent types
  *)

  Theorem ra_ca_fun k (f : recalg k) v n m x y :
           [f;v] -[n>> x
        -> [f;v] -[m>> y
        -> n = m /\ x = y.
  Proof.
    intros H.
    revert H m y.
    induction 1 as [ n v | v | v
                   | k v p
                   | k i f gj v n w q x H1 IH1 H2 IH2
                   | k f g v n x H1 IH2
                   | k f g v n p x q y H1 IH1 H2 IH2
                   | k f v p n w q H1 IH1 H2 IH2 ]; intros n2 x2 H3.
    apply ra_ca_cst_inv  in H3; destruct H3; split; auto.
    apply ra_ca_zero_inv in H3; destruct H3; split; auto.
    apply ra_ca_succ_inv in H3; destruct H3; split; auto.
    apply ra_ca_proj_inv in H3; destruct H3; split; auto.

    apply ra_ca_comp_inv in H3.
    destruct H3 as (q' & w' & n' & H5 & H3 & H4).
    assert (forall p, vec_pos n p = vec_pos n' p /\ vec_pos w p = vec_pos w' p) as E.
      intros p; apply IH1, H3.
    assert (n = n' /\ w = w') as E'.
      split; apply vec_pos_ext; intro; apply E.
    destruct E'; subst n' w'.
    destruct (IH2 _ _ H4); subst; auto.

    apply ra_ca_rec_0_inv in H3.
    destruct H3 as (m & ? & H3).
    apply IH2 in H3; destruct H3; subst; auto.
    apply ra_ca_rec_S_inv in H3.
    destruct H3 as (y' & q' & p' & H3 & H5 & H4).
    apply IH1 in H5; destruct H5; subst.
    apply IH2 in H4; destruct H4; subst; auto.

    apply ra_ca_min_inv in H3.
    destruct H3 as (q' & w' & n' & H3 & H5 & H4).
    destruct (lt_eq_lt_dec p x2) as [ [ C | E ] | C ].

    specialize (H4 (nat2pos C)).
    rewrite pos2nat_nat2pos in H4.
    apply IH2, proj2 in H4; discriminate H4.

    subst x2.
    apply IH2, proj1 in H5; subst q'.
    assert (forall p, vec_pos q p = vec_pos n' p /\ S (vec_pos w p) = S(vec_pos w' p)) as E.
      intros i; apply IH1, H4.
    assert (q = n' /\ w = w') as E'.
      split; apply vec_pos_ext; intro i.
      apply E.
      generalize (proj2 (E i)); omega.
    destruct E'; subst; auto.

    rewrite <- (pos2nat_nat2pos C) in H5.
    apply IH1, proj2 in H5.
    discriminate H5.
  Qed.

End functionality.

Section decidability.

  (* These next two forms of *ra_ca_min* are better suited for the decidability proof,
     they generate lesser subcases *)

  Local Lemma in_ra_ca_min' k (f : recalg (S k)) v x (q w : vec nat (x+1)) :
       (forall p, [f;pos2nat p##v] -[vec_pos q p>> vec_pos w p)
    -> (forall p, 0 < vec_pos w (pos_lft _ p))
    -> 0 = vec_pos w (pos_rt _ pos0)
    -> [ra_min f;v] -[1+vec_sum q>> x.
  Proof.
    intros H1 H2 H3.
    rewrite (vec_app_lft_rt _ _ q), vec_sum_app.
    rewrite (plus_comm (vec_sum _)), plus_assoc.
    apply in_ra_ca_min with (vec_set_pos (fun p => vec_pos (vec_lft w) p - 1)).
    intros j.
    generalize (H1 (pos_lft _ j)).
    rewrite pos2nat_pos_lft; eqgoal; f_equal.
    unfold vec_lft; rewrite vec_pos_set; auto.
    rewrite vec_pos_set.
    generalize (H2 j); unfold vec_lft; rewrite vec_pos_set; omega.
    rewrite H3.
    generalize (H1 (pos_rt _ pos0)).
    eqgoal; f_equal.
    rewrite pos2nat_pos_rt; f_equal; auto.
    simpl; auto.
  Qed.

  Local Lemma ra_ca_min_inv' k (f : recalg (S k)) v n x :
       [ra_min f;v] -[n>> x
    -> exists q w : vec nat (x+1),
         n = 1+vec_sum q
      /\ 0 = vec_pos w (pos_rt _ pos0)
      /\ (forall p, 0 < vec_pos w (pos_lft _ p))
      /\ (forall p, [f;pos2nat p##v] -[vec_pos q p>> vec_pos w p).
  Proof.
    intros H.
    apply ra_ca_min_inv in H.
    destruct H as (p & w & q & H1 & H2 & H3).
    exists (vec_app q (p##vec_nil)),
           (vec_app (vec_set_pos (fun p => S (vec_pos w p))) (0##vec_nil)).
    split.
    rewrite vec_sum_app; simpl; omega.
    split.
    rewrite vec_pos_app_rt; auto.
    split.
    intros i; rewrite vec_pos_app_lft, vec_pos_set; omega.
    intros i.
    destruct (pos_split i) as [ (j & ?) | (j & ?) ]; subst i.
    repeat rewrite vec_pos_app_lft.
    rewrite vec_pos_set, pos2nat_pos_lft; auto.
    repeat rewrite vec_pos_app_rt.
    rewrite pos2nat_pos_rt.
    pos_inv j; simpl.
    revert H2; eqgoal; do 2 f_equal; auto.
    pos_inv j.
  Qed.

  (* Since ra_ca is functional, sequences of computations with the same total cost
     must have the same length *)

  Local Lemma ra_ca_id_prefix k (f : recalg (S k)) (v : vec nat k) x qx wx y qy wy :
       (forall p : pos x, [f;pos2nat p##v] -[vec_pos qx p>> vec_pos wx p)
    -> (forall p : pos y, [f;pos2nat p##v] -[vec_pos qy p>> vec_pos wy p)
    -> vec_sum qx = vec_sum qy
    -> x < y -> False.
  Proof.
    intros H3 H4 H5 H.

    assert ({ p | y = x + S p }) as E.
      exists (y-x-1); omega.
    destruct E as (p & ?); subst y.

    assert (qx = vec_lft qy) as E2.
      apply vec_pos_ext.
      intros i.
      unfold vec_lft; rewrite vec_pos_set.
      generalize (H4 (pos_lft _ i)).
      rewrite pos2nat_pos_lft; intros H6.
      apply (ra_ca_fun (H3 i) H6).
    rewrite (vec_app_lft_rt _ _ qy), vec_sum_app in H5.
    generalize (vec_pos_sum (vec_rt qy) pos0).
    specialize (H4 (pos_rt _ pos0)).
    apply ra_ca_cost in H4.
    rewrite <- E2 in H5.
    simpl in H5.
    omega.
  Qed.

  Local Lemma ra_ca_prefix_eq k (f : recalg (S k)) (v : vec nat k) x qx wx y qy wy :
       (forall p : pos x, [f;pos2nat p##v] -[vec_pos qx p>> vec_pos wx p)
    -> (forall p : pos y, [f;pos2nat p##v] -[vec_pos qy p>> vec_pos wy p)
    -> vec_sum qx = vec_sum qy
    -> x = y.
  Proof.
    intros H3 H4 H5.
    destruct (lt_eq_lt_dec x y) as [ [ H | ] | H ]; auto; exfalso.
    apply ra_ca_id_prefix with (1 := H3) (2 := H4); auto.
    apply ra_ca_id_prefix with (1 := H4) (2 := H3); auto.
  Qed.

  Theorem ra_ca_decidable_t k (f : recalg k) v n : decidable_t { x | [f;v] -[n>> x }.
  Proof.
    revert v n; induction f as [ i | | | | k i f g Hf Hg | k f g Hf Hg | k f ]; intros v n.

    (* case of ra_cst *)
    destruct (eq_nat_dec n 1) as [ H | H ]; subst.
    left; exists i; constructor.
    right; intros (x & Hx); apply ra_ca_cst_inv in Hx; omega.

    (* case of ra_zero *)
    destruct (eq_nat_dec n 1) as [ H | H ]; subst.
    left; exists 0; constructor.
    right; intros (x & Hx); apply ra_ca_zero_inv in Hx; omega.

    (* case of ra_succ *)
    destruct (eq_nat_dec n 1) as [ H | H ]; subst.
    left; exists (1+vec_head v); constructor.
    right; intros (x & Hx); apply ra_ca_succ_inv in Hx; omega.

    (* case of ra_proj *)
    destruct (eq_nat_dec n 1) as [ H | H ]; subst.
    left; exists (vec_pos v p); constructor.
    right; intros (x & Hx); apply ra_ca_proj_inv in Hx; omega.

    (* case of ra_comp *)

    destruct n as [ | n ].
    right; intros (x & Hx); apply ra_ca_cost in Hx; omega.

    (* first we try to compute [vec_pos g *;v] in less than n steps total *)

    generalize (@vec_sum_decide_t _ (vec_set_pos (fun p n => { x | [vec_pos g p;v] -[n>> x} : Type))).
    intros Hg'; inst Hg'.
    intros; rewrite vec_pos_set; auto.
    apply (@decidable_t_bounded' (S n)) in Hg'.
    destruct Hg' as [ (m & Hm & q & Hq & Hg') | Hg' ].

    assert (Hq' : forall p, { x | [vec_pos g p;v] -[vec_pos q p>> x }).
      intros p; specialize (Hg' p); rewrite vec_pos_set in Hg'; auto.
    clear Hg'.
    apply vec_reif_t in Hq'.
    destruct Hq' as (w & Hw).

    (* then we try to compute [f;_] in the remaining number of steps *)

    destruct (Hf w (n-m)) as [ (x & Hx) | C ].

    (* we can compute [ f o g ; v ] *)

    left; exists x.
    cutrewrite (n = (n-m)+vec_sum q); try omega.
    apply in_ra_ca_comp with (1 := Hw); auto.

    (* [f;_] cannot be computed *)

    right; intros (x & Hx).
    apply ra_ca_comp_inv in Hx.
    destruct Hx as (p & w' & q' & H1 & H2 & H3).
    assert ( q = q' /\ w = w' ) as E.
      split; apply vec_pos_ext; intros u;
      apply (ra_ca_fun (Hw u) (H2 u)).
    destruct E; subst q' w'.
    apply C; exists x; revert H3; eqgoal; f_equal; omega.

    (* [vec_pos g *;v] cannot be computed in less than n steps total *)

    right; intros (x & Hx).
    apply ra_ca_comp_inv in Hx.
    destruct Hx as (p & w & q & H1 & H2 & H3).
    apply Hg'.
    exists (vec_sum q).
    exists. omega.
    exists q; split; auto.
    intros j; rewrite vec_pos_set; exists (vec_pos w j); auto.

    (* case of ra_rec *)

    rewrite (vec_head_tail v); generalize (vec_head v) (vec_tail v).
    clear v; intros u v.
    revert n; induction u as [ | u IHu ]; intros n.

    (* case of rec 0 *)

    destruct n as [ | n ].
    right; intros (x & Hx); apply ra_ca_cost in Hx; omega.
    destruct (Hf v n) as [ (x & Hx) | C ].
    left; exists x; constructor; auto.
    right; intros (x & Hx); apply C; exists x.
    apply ra_ca_rec_0_inv in Hx.
    destruct Hx as (m & Hm & Hx).
    revert Hx; eqgoal; f_equal; omega.

    (* case of rec S *)

    destruct n as [ | n ].
    right; intros (x & Hx); apply ra_ca_cost in Hx; omega.
    apply (decidable_t_bounded' (S n)) in IHu.
    destruct IHu as [ (p & H1 & y & Hy) | C ].

    destruct (Hg (u##y##v) (n-p)) as [ (x & Hx) | C ].
    left; exists x.
    cutrewrite (n = p+(n-p)); try omega.
    apply in_ra_ca_rec_S with y; auto.

    right; intros (x & Hx).
    apply ra_ca_rec_S_inv in Hx.
    destruct Hx as (y' & q' & p' & H2 & H3 & H4).
    destruct (ra_ca_fun Hy H3); subst p' y'.
    apply C; exists x; revert H4; eqgoal; f_equal; omega.

    right; intros (x & Hx).
    apply ra_ca_rec_S_inv in Hx.
    destruct Hx as (y & q & p & H2 & H3 & H4).
    apply C.
    exists p.
    exists.
    omega.
    exists y; auto.

    (* case of ra_min *)

    specialize (fun i => IHf (i##v)).
    destruct n as [ | n ].
    right; intros (x & Hx); apply ra_ca_cost in Hx; omega.
    apply (vec_sum_unbounded_decide_t) with (m := n) in IHf.
    2: intros ? (? & H); apply ra_ca_cost in H; omega.
    destruct IHf as [ (x' & q & H1 & H2) | C ].

    (* no sequence of computation as a total cost of n *)
    Focus 2.
    right.
    intros (x & Hx).
    apply ra_ca_min_inv' in Hx.
    destruct Hx as (q & w & H2 & H3 & H4 & H5).
    apply C.
    exists (x+1), q; split.
    omega.
    intros p; exists (vec_pos w p); auto.

    (* the sequence q has a total cost of n *)
    apply vec_reif_t in H2.
    destruct H2 as (w & Hw).

    assert ( (x' = 0) + { x | (x' = x + 1)%nat } )%type as E.
      destruct x' as [ | x' ]; [ left | right ]; auto; exists x'; omega.
    destruct E as [ ? | (x & ?) ]; subst x'.

    (* q is of length 0 *)
    rewrite (vec_0_nil q) in H1; simpl in H1.
    right.
    intros (x & Hx).
    apply ra_ca_min_inv' in Hx.
    destruct Hx as (q' & w' & H2 & H3 & H4 & H5).
    specialize (H5 (pos_rt _ pos0)).
    apply ra_ca_cost in H5.
    generalize (vec_pos_sum q' (pos_rt _ pos0)).
    omega.

    (* q is of length x+1 *)
    destruct (eq_nat_dec (vec_pos w (pos_rt _ pos0)) 0) as [ H2 | H2 ].
    destruct (vec_strict_pos (vec_lft w)) as [ H3 | (p & Hp) ].

    (* the sequence is strictly positive and ends with 0 *)
    left; exists x.
    cutrewrite (S n = 1+vec_sum q); try omega.
    apply in_ra_ca_min' with w; auto.
    intros p; generalize (H3 p); unfold vec_lft; rewrite vec_pos_set; auto.

    (* the sequence contains a zero before it ends *)
    right; intros (x' & Hx').
    apply ra_ca_min_inv' in Hx'.
    destruct Hx' as (q' & w' & H3 & H4 & H5 & H6).
    generalize (@ra_ca_prefix_eq k f v _ q w _ q' w' Hw H6); intros H7.
    assert (x = x') as E. omega.
    subst x'; clear H7.
    specialize (Hw (pos_lft _ p)).
    rewrite pos2nat_pos_lft in Hw.
    specialize (H6 (pos_lft _ p)).
    rewrite pos2nat_pos_lft in H6.
    generalize (proj2 (ra_ca_fun Hw H6)).
    generalize (H5 p).
    unfold vec_lft in Hp; rewrite vec_pos_set in Hp; omega.

    (* the sequence does not end with a zero *)

    right; intros (x' & Hx').
    apply ra_ca_min_inv' in Hx'.
    destruct Hx' as (q' & w' & H3 & H4 & H5 & H6).
    generalize (@ra_ca_prefix_eq k f v _ q w _ q' w' Hw H6); intros H7.
    assert (x = x') as E. omega.
    subst x'; clear H7.
    specialize (Hw (pos_rt _ pos0)).
    rewrite pos2nat_pos_rt in Hw.
    specialize (H6 (pos_rt _ pos0)).
    rewrite pos2nat_pos_rt in H6.
    generalize (proj2 (ra_ca_fun Hw H6)).
    omega.
  Qed.

End decidability.

Definition ra_ca_eval k (f : recalg k) v n : option nat :=
  match ra_ca_decidable_t f v n with
    | inl T  => Some (proj1_sig T)
    | inr _ => None
  end.

Fact ra_ca_eval_prop k f v n x : [f;v] -[n>> x <-> @ra_ca_eval k f v n = Some x.
Proof.
  unfold ra_ca_eval.
  destruct (ra_ca_decidable_t f v n) as [ (y & Hy) | C ]; simpl.
  split.
  intros Hx; generalize (ra_ca_fun Hx Hy); intros (? & ?); subst; auto.
  injection 1; intros; subst; auto.
  split.
  intro; exfalso; apply C; exists x; auto.
  discriminate 1.
Qed.

(*
Extraction Language Haskell.
Extraction "ra_compute" ra_ca_eval.
*)


Set Implicit Arguments.

Require Import Coq.Arith.Arith.
Require Import Coq.omega.Omega.

Lemma plus_eq_right_0 : forall a b, a + b = b -> a = 0.
  induction a; simpl; intuition.
Qed.