From mathcomp Require Import all_ssreflect.
From chip Require Import connect.

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

Section Cycles.

Variable V : finType.
Variable g : rel V.

Lemma self_loop_cycle : forall x, g x x -> cycle g [:: x].
Proof.
move => x H_in.
rewrite /cycle /=.
by apply/andP.
Qed.

Lemma diconnect_path_cycle :
  forall x y, x != y -> diconnect g x y -> exists p, cycle g (x :: p).
Proof.
move => x y H_neq /andP /= [H_x H_y].
move/connectP: H_x; case => px H_px H_pl.
move/connectP: H_y; case => py H_py H_pl'.
case: py H_py H_pl' => /=; first by move => H_py H_eq; rewrite H_eq in H_neq; move/negP: H_neq.
move => y' py' /andP [H_in H_py'] H_x.
exists (px ++ belast y' py').
rewrite rcons_cat /= {2}H_x -lastI cat_path -H_pl /=.
apply/andP; split => //.
by apply/andP.
Qed.

Lemma cycle_path_diconnect :
  forall x p, cycle g (x :: p) ->
  x \in g x \/ (exists y, diconnect g x y /\ x != y).
Proof.
move => x p.
move: x.
rewrite /=.
case: p => //=.
- move => x /andP [H_p ?].
  by left.
- move => y p x.
  case H_eq: (x == y).
  * move/eqP: H_eq => H_eq.
    rewrite H_eq.
    move/andP => [H_in H_p].
    by left.
  * move/negP: H_eq => H_eq.
    move/andP => [H_in H_p].
    right.
    exists y; split; last by apply/negP.
    apply/andP.
    split; first by apply/connectP; exists [:: y]; first by rewrite /=; apply/andP.
    apply/connectP.
    exists (rcons p x); first by [].
    by rewrite last_rcons.
Qed.

End Cycles.

Section Acyclic.

Variable V : finType.
Variable g : rel V.

Definition acyclic := forall x p, path g x p -> ~~ cycle g (x :: p).

Hypothesis g_acyclic: acyclic.

Lemma acyclic_no_self_loop : forall x, ~~ g x x.
Proof.
move => x; apply/negP => Hg.
move/g_acyclic: (self_loop_cycle Hg).
by move/negP; case => /=; apply/and3P.
Qed.

Lemma acyclic_diconnect : forall x y, diconnect g x y -> x = y.
Proof.
move => x y Hd.
case Hx: (x == y); first by apply/eqP.
move/negP/negP: Hx => Hx.
have [p Hc] := diconnect_path_cycle Hx Hd.
have Hp: path g x p by move: Hc; rewrite /= rcons_path; move/andP => [Hp Ha].
by move/negP: (g_acyclic Hp); case.
Qed.

End Acyclic.

Section AcyclicSub.

Variable V : finType.
Variable g : rel V.

Hypothesis g_acyclic : acyclic g.

Variable P : pred V.

Local Notation I := (sig_finType P).

Local Notation gsub := [rel x y : I | g (val x) (val y)].

Lemma gsub_acyclic : acyclic gsub.
Proof.
move => x p.
move/gsub_path.
move/g_acyclic => Hc.
rewrite /= rcons_path.
apply/negP => Hc'.
move/andP: Hc' => [Hp Hg].
move/negP: Hc.
case.
rewrite /= rcons_path.
apply/andP.
split; first by apply/gsub_path.
rewrite /= in Hg.
by rewrite last_map.
Qed.

End AcyclicSub.

Section AcyclicRev.

Variable V : finType.

Variable g : rel V.

Hypothesis g_acyclic : acyclic g.

Local Notation grev := [rel x y | g y x].

Lemma acyclic_rev : acyclic grev.
Proof.
move => x p Hp.
apply/negP => H_c; move: H_c.
move/cycle_path_diconnect.
case.
- move => H_in.
  have Hg: g x x by [].
  move/self_loop_cycle: Hg => Hg.
  contradict Hg.
  apply/negP.
  exact: g_acyclic.
- move => [y [Hd Hn]].
  have H_rev: g =2 [rel x y | grev y x] by [].
  have Hd': diconnect g x y.
  have Heq := eq_diconnect H_rev.
    rewrite Heq.
    move/andP: Hd => [Hc1 Hc2].
    apply/andP.
    by split; apply connect_rev.
  have Hc := diconnect_path_cycle _ Hd'.
  have [p' Hc'] := Hc Hn.
  have Hp': path g x p'.
    rewrite /= in Hc'.
    rewrite rcons_path in Hc'.
    by move/andP:Hc' => [Hp' Hgl].
  contradict Hc'.
  apply/negP.
  exact: g_acyclic.
Qed.

End AcyclicRev.

Section Acyclicity.

Variable V : finType.
Variable sccs : rel V -> seq (seq V).
Variable g : rel V.

Hypothesis uniq_flatten : uniq (flatten (sccs g)).

Hypothesis all_in_flatten : forall v : V, v \in (flatten (sccs g)).

Hypothesis class_diconnected :
  forall c, c \in sccs g ->
  exists x, forall y, (y \in c) = diconnect g x y.

Lemma in_flatten (A : seq (seq V)) s :
  s \in A ->
  subseq s (flatten A).
Proof.
elim: A => //=.
move => vs c IH H_in.
have H_or: s = vs \/ s \in c.
  move/orP: H_in.
  case; first by move/eqP; left.
  by right.
case: H_or => H_in'.
  by rewrite H_in' prefix_subseq.
have IH' := IH H_in'.
have ->: s = [::] ++ s by [].
by apply cat_subseq; first exact: sub0seq.
Qed.

Lemma non_singleton_neq : forall v v' vs,
  [:: v, v' & vs] \in sccs g ->
  v != v'.
Proof.
move => v v' vs H_ks.
apply/negP.
move/eqP => H_eq.
rewrite -H_eq {H_eq} in H_ks.
have H_fl := uniq_flatten.
apply in_flatten in H_ks.
apply subseq_uniq in H_ks => //.
rewrite /= in H_ks.
move/andP: H_ks.
rewrite inE.
move => [H_n H_u].
move/negP: H_n => H_n.
case: H_n.
by apply/orP; left.
Qed.

Lemma non_singleton_cycle : forall v v' vs,
  [:: v, v' & vs] \in sccs g ->
  exists x p, cycle g (x :: p).
Proof.
move => v v' vs H_ks.
have H_c := class_diconnected H_ks.
rewrite /class_diconnected /= in H_c.
move: H_c => /= [x H_y].
have H_v := H_y v.
have H_v' := H_y v'.
have H_neq := non_singleton_neq H_ks.
have H_in_v: v \in [:: v, v' & vs] by rewrite inE; apply/orP; left.
have H_in_v': v' \in [:: v, v' & vs] by rewrite inE; apply/orP; right; apply/orP; left.
rewrite H_v {H_v} in H_in_v.
rewrite H_v' {H_v'} in H_in_v'.
rewrite /diconnect in H_in_v H_in_v'.
move/andP: H_in_v => [H_cn_v H_cn'_v].
move/connectP: H_cn_v => [pv H_pv] H_vl.
move/connectP: H_cn'_v => [p'v H_p'v] H_vl'.
move/andP: H_in_v' => [H_cn_v' H_cn'_v'].
move/connectP: H_cn_v' => [pv' H_pv'] H_v'l.
move/connectP: H_cn'_v' => [p'v' H_p'v'] H_v'l'.
have H_pvv': connect g v v'.
  apply/connectP.
  exists (p'v ++ pv'); last by rewrite last_cat -H_vl'.
  rewrite cat_path.
  rewrite -H_vl'.
  by apply/andP.
have H_p'vv': connect g v' v.
  apply/connectP.
  exists (p'v' ++ pv); last by rewrite last_cat -H_v'l'.
  rewrite cat_path.
  rewrite -H_v'l'.
  by apply/andP.
have H_di: diconnect g v v'.
  rewrite /diconnect.
  by apply/andP.
have [p H_p] := diconnect_path_cycle H_neq H_di.
by exists v, p.
Qed.

Lemma all_in_sccs v : exists vs, vs \in sccs g /\ v \in vs.
Proof.
move/flattenP: (all_in_flatten v).
by case => vs H_vs H_in; exists vs.
Qed.

Lemma diconnect_neq_sccs :
  forall x y, diconnect g x y -> x != y ->
  exists v v' vs, [:: v, v' & vs] \in sccs g.
Proof.
move => x y H_y H_neq.
have [vs [H_vs H_in]] := all_in_sccs x.
have [x' H_c] := class_diconnected H_vs.
have H_eq: x \in vs by [].
have H_c' := H_c x.
rewrite H_c' in H_eq.
have H_di: diconnect g x' y.
  move/andP: H_eq => [H_x'x H_xx'].
  move/andP: H_y => [H_xy H_yx].
  apply/andP; split.
  - move: H_x'x H_xy.
    exact: connect_trans.
  - move: H_yx H_xx'.
    exact: connect_trans.
rewrite -H_c in H_di.
move {H_y H_c H_c' H_eq}.
case: vs H_in H_di H_vs => //.
move => v.
case.
- rewrite 2!inE.
  move/eqP => H_xv.
  rewrite -H_xv.
  move/eqP => H_yx.
  move/negP: H_neq => H_neq.
  case: H_neq.
  by apply/eqP.
- move => v' vs H_x H_y.
  by exists v, v', vs.
Qed.

Definition class_acyclic (c : seq V) :=
match c with
| [::] => true
| [:: v] => ~~ g v v
| [:: _, _ & _] => false
end.

Definition sccs_acyclic :=
  all [pred c | class_acyclic c] (sccs g).

Lemma sccs_acyclicP :
  reflect (acyclic g) sccs_acyclic.
Proof.
  apply: (iffP idP).
- move/allP => /=.
  move => H_in_ac v p H_p.
  apply/negP => H_ce.
  apply cycle_path_diconnect in H_ce.
  case: H_ce => H_ce.
  * have [vs [H_vs H_v]] := all_in_sccs v.
    move: H_vs H_v.
    move/H_in_ac.
    case: vs => //=.
    move => v'.
    case => //=.
    move/negP.
    rewrite inE => H_in.
    move/eqP => H_eq.
    by rewrite H_eq in H_ce.
  * move: H_ce => [y [H_d H_neq]].
    have [v0 [v1 [vs H_ks]]] := diconnect_neq_sccs H_d H_neq.
    by move/H_in_ac: H_ks.
- move => H_gc.
  apply/allP.
  case => //= v.
  case => //=.
  * move => H_in.
    apply/negP.
    move => H_in'.
    have H_ce: cycle g [:: v] by apply/andP.
    contradict H_ce.
    apply/negP.
    exact: H_gc.
  * move => v' vs.
    move/non_singleton_cycle.
    move => [x [p H_ce]].
    have H_ce' := H_ce.
    rewrite /= in H_ce'.
    rewrite rcons_path in H_ce'.
    move/andP: H_ce' => [H_p H_l].
    contradict H_ce.
    apply/negP.
    exact: H_gc.
Qed.

End Acyclicity.


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

Require Export BinNums.
Require Import BinPos.

Local Open Scope N_scope.

Local Notation "0" := N0.
Local Notation "1" := (Npos 1).
Local Notation "2" := (Npos 2).

(**********************************************************************)
(** * Binary natural numbers, definitions of operations *)
(**********************************************************************)

Module N.

Definition t := N.

(** ** Nicer name [N.pos] for contructor [Npos] *)

Notation pos := Npos.

(** ** Constants *)

Definition zero := 0.
Definition one := 1.
Definition two := 2.

(** ** Operation [x -> 2*x+1] *)

Definition succ_double x :=
  match x with
  | 0 => 1
  | pos p => pos p~1
  end.

(** ** Operation [x -> 2*x] *)

Definition double n :=
  match n with
  | 0 => 0
  | pos p => pos p~0
  end.

(** ** Successor *)

Definition succ n :=
  match n with
  | 0 => 1
  | pos p => pos (Pos.succ p)
  end.

(** ** Predecessor *)

Definition pred n :=
  match n with
  | 0 => 0
  | pos p => Pos.pred_N p
  end.

(** ** The successor of a [N] can be seen as a [positive] *)

Definition succ_pos (n : N) : positive :=
 match n with
   | 0 => 1%positive
   | pos p => Pos.succ p
 end.

(** ** Addition *)

Definition add n m :=
  match n, m with
  | 0, _ => m
  | _, 0 => n
  | pos p, pos q => pos (p + q)
  end.

Infix "+" := add : N_scope.

(** Subtraction *)

Definition sub n m :=
match n, m with
| 0, _ => 0
| n, 0 => n
| pos n', pos m' =>
  match Pos.sub_mask n' m' with
  | IsPos p => pos p
  | _ => 0
  end
end.

Infix "-" := sub : N_scope.

(** Multiplication *)

Definition mul n m :=
  match n, m with
  | 0, _ => 0
  | _, 0 => 0
  | pos p, pos q => pos (p * q)
  end.

Infix "*" := mul : N_scope.

(** Order *)

Definition compare n m :=
  match n, m with
  | 0, 0 => Eq
  | 0, pos m' => Lt
  | pos n', 0 => Gt
  | pos n', pos m' => (n' ?= m')%positive
  end.

Infix "?=" := compare (at level 70, no associativity) : N_scope.

(** Boolean equality and comparison *)

Fixpoint eqb n m :=
  match n, m with
    | 0, 0 => true
    | pos p, pos q => Pos.eqb p q
    | _, _ => false
  end.

Definition leb x y :=
 match x ?= y with Gt => false | _ => true end.

Definition ltb x y :=
 match x ?= y with Lt => true | _ => false end.

Infix "=?" := eqb (at level 70, no associativity) : N_scope.
Infix "<=?" := leb (at level 70, no associativity) : N_scope.
Infix "<?" := ltb (at level 70, no associativity) : N_scope.

(** Min and max *)

Definition min n n' := match n ?= n' with
 | Lt | Eq => n
 | Gt => n'
 end.

Definition max n n' := match n ?= n' with
 | Lt | Eq => n'
 | Gt => n
 end.

(** Dividing by 2 *)

Definition div2 n :=
  match n with
  | 0 => 0
  | 1 => 0
  | pos (p~0) => pos p
  | pos (p~1) => pos p
  end.

(** Parity *)

Definition even n :=
  match n with
    | 0 => true
    | pos (xO _) => true
    | _ => false
  end.

Definition odd n := negb (even n).

(** Power *)

Definition pow n p :=
  match p, n with
    | 0, _ => 1
    | _, 0 => 0
    | pos p, pos q => pos (q^p)
  end.

Infix "^" := pow : N_scope.

(** Square *)

Definition square n :=
  match n with
    | 0 => 0
    | pos p => pos (Pos.square p)
  end.

(** Base-2 logarithm *)

Definition log2 n :=
 match n with
   | 0 => 0
   | 1 => 0
   | pos (p~0) => pos (Pos.size p)
   | pos (p~1) => pos (Pos.size p)
 end.

(** How many digits in a number ?
    Number 0 is said to have no digits at all.
*)

Definition size n :=
 match n with
  | 0 => 0
  | pos p => pos (Pos.size p)
 end.

Definition size_nat n :=
 match n with
  | 0 => O
  | pos p => Pos.size_nat p
 end.

(** Euclidean division *)

Fixpoint pos_div_eucl (a:positive)(b:N) : N * N :=
  match a with
    | xH =>
       match b with 1 => (1,0) | _ => (0,1) end
    | xO a' =>
       let (q, r) := pos_div_eucl a' b in
       let r' := double r in
       if b <=? r' then (succ_double q, r' - b)
        else (double q, r')
    | xI a' =>
       let (q, r) := pos_div_eucl a' b in
       let r' := succ_double r in
       if b <=? r' then (succ_double q, r' - b)
        else  (double q, r')
  end.

Definition div_eucl (a b:N) : N * N :=
  match a, b with
   | 0,  _ => (0, 0)
   | _, 0  => (0, a)
   | pos na, _ => pos_div_eucl na b
  end.

Definition div a b := fst (div_eucl a b).
Definition modulo a b := snd (div_eucl a b).

Infix "/" := div : N_scope.
Infix "mod" := modulo (at level 40, no associativity) : N_scope.

(** Greatest common divisor *)

Definition gcd a b :=
 match a, b with
  | 0, _ => b
  | _, 0 => a
  | pos p, pos q => pos (Pos.gcd p q)
 end.

(** Generalized Gcd, also computing rests of [a] and [b] after
    division by gcd. *)

Definition ggcd a b :=
 match a, b with
  | 0, _ => (b,(0,1))
  | _, 0 => (a,(1,0))
  | pos p, pos q =>
     let '(g,(aa,bb)) := Pos.ggcd p q in
     (pos g, (pos aa, pos bb))
 end.

(** Square root *)

Definition sqrtrem n :=
 match n with
  | 0 => (0, 0)
  | pos p =>
    match Pos.sqrtrem p with
     | (s, IsPos r) => (pos s, pos r)
     | (s, _) => (pos s, 0)
    end
 end.

Definition sqrt n :=
 match n with
  | 0 => 0
  | pos p => pos (Pos.sqrt p)
 end.

(** Operation over bits of a [N] number. *)

(** Logical [or] *)

Definition lor n m :=
 match n, m with
   | 0, _ => m
   | _, 0 => n
   | pos p, pos q => pos (Pos.lor p q)
 end.

(** Logical [and] *)

Definition land n m :=
 match n, m with
  | 0, _ => 0
  | _, 0 => 0
  | pos p, pos q => Pos.land p q
 end.

(** Logical [diff] *)

Fixpoint ldiff n m :=
 match n, m with
  | 0, _ => 0
  | _, 0 => n
  | pos p, pos q => Pos.ldiff p q
 end.

(** [xor] *)

Definition lxor n m :=
  match n, m with
    | 0, _ => m
    | _, 0 => n
    | pos p, pos q => Pos.lxor p q
  end.

(** Shifts *)

Definition shiftl_nat (a:N) := nat_rect _ a (fun _ => double).
Definition shiftr_nat (a:N) := nat_rect _ a (fun _ => div2).

Definition shiftl a n :=
  match a with
    | 0 => 0
    | pos a => pos (Pos.shiftl a n)
  end.

Definition shiftr a n :=
  match n with
    | 0 => a
    | pos p => Pos.iter div2 a p
  end.

(** Checking whether a particular bit is set or not *)

Definition testbit_nat (a:N) :=
  match a with
    | 0 => fun _ => false
    | pos p => Pos.testbit_nat p
  end.

(** Same, but with index in N *)

Definition testbit a n :=
  match a with
    | 0 => false
    | pos p => Pos.testbit p n
  end.

(** Translation from [N] to [nat] and back. *)

Definition to_nat (a:N) :=
  match a with
    | 0 => O
    | pos p => Pos.to_nat p
  end.

Definition of_nat (n:nat) :=
  match n with
    | O => 0
    | S n' => pos (Pos.of_succ_nat n')
  end.

(** Iteration of a function *)

Definition iter (n:N) {A} (f:A->A) (x:A) : A :=
  match n with
    | 0 => x
    | pos p => Pos.iter f x p
  end.

(** Conversion with a decimal representation for printing/parsing *)

Definition of_uint (d:Decimal.uint) := Pos.of_uint d.

Definition of_int (d:Decimal.int) :=
  match Decimal.norm d with
  | Decimal.Pos d => Some (Pos.of_uint d)
  | Decimal.Neg _ => None
  end.

Definition to_uint n :=
  match n with
  | 0 => Decimal.zero
  | pos p => Pos.to_uint p
  end.

Definition to_int n := Decimal.Pos (to_uint n).

Numeral Notation N of_uint to_uint : N_scope.

End N.

(** Re-export the notation for those who just [Import NatIntDef] *)
Numeral Notation N N.of_uint N.to_uint : N_scope.


Require Import Util.
Require Import List.
Require Import Sumbool.

Parameters maze node : Set.
Parameter node_dec : forall (x y: node), {x = y} + {x <> y}.
Parameters start goal : node.
Parameters next : node -> list node.
Definition is_next y x := In y (next x).

Inductive path : Set :=
| PUnit (_: node)
| PCons (_:node) (_: path)
.

Fixpoint plength (p : path) :=
  match p with
  | PUnit _ => O
  | PCons _ p => S (plength p)
  end.
Definition endof (p : path) : node :=
  match p with
  | PUnit x => x
  | PCons y _ => y
  end.

Inductive Path (x : node) : path -> Prop :=
| P1 : Path x (PUnit x)
| P2 : forall y p, is_next y (endof p) -> Path x p ->
   Path x (PCons y p)
.

(* Get next of the end of inputed path *)
Definition expand (p: path) : list path :=
  map (fun y => PCons y p) (next (endof p)).

(* Can expand Path *)
Lemma expand1 : forall p p',
  In p' (expand p) -> exists y, is_next y (endof p) /\ p' = PCons y p.
Proof.
unfold expand; intros p p' H.
elim (in_map_iff (fun y => PCons y p) (next (endof p)) p').
intros H0 _; elim (H0 H); intros y _H; inversion _H.
exists y; split; [apply H2 | rewrite H1; reflexivity].
Qed.

(* path(p->y) -> y::p < expand(p) *)
Lemma expand2 : forall y p,
  is_next y (endof p) -> In (PCons y p) (expand p).
Proof.
unfold is_next; intros y p H.
apply (in_map (fun y => PCons y p) _ _ H).
Qed.

Lemma expand_length : forall p p',
  In p' (expand p) -> plength p' = S (plength p).
Proof.
intros p p' H; elim (expand1 p p' H); intros y H0; inversion H0.
rewrite H2; reflexivity.
Qed.

Definition path_equiv (p1 p2: path) :=
  endof p1 = endof p2.
Definition path_equiv_dec (p1 p2: path) :
  {path_equiv p1 p2} + {~ path_equiv p1 p2} :=
  node_dec (endof p1) (endof p2).
Lemma path_equiv_refl : forall (p : path), path_equiv p p.
Proof.
reflexivity.
Qed.

Fixpoint accessibles (start:node) (len:nat) : list path :=
  match len with
  | O => (PUnit start) :: nil
  | S n' => div_equiv path_equiv_dec @@ (flat_map expand @@ accessibles start n')
  end.

Theorem soundness : forall x n p,
  In p (accessibles x n) -> Path x p /\ plength p = n.
Proof.
intros x n; induction n; simpl in |- *; intros p H.
 elim H; intro HH; [ rewrite <- HH in |- * | elim HH ].
 split; [ apply P1 | reflexivity ].

 unfold atat in H.
 elim (in_flat_map expand (accessibles x n) p).
 intros H1 _.
 elim (H1 (div_In_incl _ _ _ _ _ H)).
 intros p0 _H; inversion _H.
 elim (IHn _ H0); intros.
 elim (expand1 _ _ H2); intros y _H0; inversion _H0.
 rewrite H6 in |- *; simpl; split; [apply (P2 x _ _ H5 H3)| rewrite H4; reflexivity].
Qed.

Theorem completeness : forall x p,
  Path x p -> exists p0,
    endof p = endof p0 /\ plength p = plength p0 /\ In p0 (accessibles x (plength p)).
Proof.
intros x p; induction p; simpl in |- *; intro.
 inversion H.
 exists (PUnit n); simpl in |- *.
 split; [ reflexivity | split; [ reflexivity | left; reflexivity ] ].

 cut
  (exists p1 : _,
     endof p1 = n /\
     plength p1 = plength (PCons n p) /\
     In p1 (flat_map expand (accessibles x (plength p)))).
  unfold atat in |- *.
  intro _H; elim _H; intros p1 _H00; elim _H00; intros H01 _H01; elim _H01;
   intros H02 H0.
  elim (div_In _ _ path_equiv_refl path_equiv_dec p1 _ H0).
  intros p0 _H0; elim _H0; intros.
  unfold path_equiv in H1.
  elim (in_flat_map expand (accessibles x (plength p)) p0).
  intros HH _; elim (HH (div_In_incl _ _ _ _ _ H2)).
  intros p2 _H1; elim _H1; intros.
  elim (soundness _ _ _ H3); intros.
  exists p0.
  split; [ rewrite H1 in |- *; rewrite H01 in |- *; reflexivity | idtac ].
  split; [ rewrite <- H6; rewrite (expand_length _ _ H4); reflexivity | apply H2 ].

  inversion H.
  elim (IHp H3); intros p00 _H0; elim _H0.
  intros H4 _H1; elim _H1; intros.
  exists (PCons n p00).
  simpl in |- *.
  split; [ reflexivity | split; [ rewrite H5 in |- *; reflexivity | idtac ] ].
  apply <-
  (in_flat_map expand (accessibles x (plength p)) (PCons n p00)).
  exists p00; split; [ apply H6 | idtac ].
  rewrite H4 in H2.
  apply (expand2 _ _ H2).
Qed.

Definition goals_len n :=
  filter_dec (fun p => node_dec (endof p) goal) (accessibles start n).

Lemma gloals_len_end : forall p n, In p (goals_len n) -> endof p = goal.
Proof.
intros.
elim (filter_dec_In _ _ _ H); intros; assumption.
Qed.

Require Streams.
CoFixpoint from n := Streams.Cons n (from (S n)).
Definition goals := Streams.map goals_len (from 0).

(*
CoFixpoint accessibles_aux (p : list path) : Streams.Stream (list path) :=
    let p' := div_equiv path_equiv_dec @@ (flat_map expand p) in
    Streams.Cons p' (accessibles_aux p').

Definition accessibles_st (x : node) : Streams.Stream (list path) := accessibles_aux (PUnit x :: nil).

Definition goals :=
  Streams.map (filter_dec (fun p => node_dec goal (endof p))) @@ accessibles_st start.
*)


Require Import String.
Require Import Nat.
Require Import Coq.Vectors.Vector.
Require Import List.
Import ListNotations.
From ST Require Import Logic.V Logic.Term ST.SoftType.
From ST Require Import EVarsScratchwork.
Import VectorNotations.
(** * Natural Deduction

We need to formalize the proof calculus to then prove the correctness of soft
type system.

References relevant:

- https://people.compute.dtu.dk/ahfrom/Formalized%20First-Order%20Logic.pdf
- https://hal.archives-ouvertes.fr/hal-03096253
*)

Class Ground A : Type := {
  is_ground : A -> Prop
}.

Fixpoint is_ground_term (t : Term) :=
match t with
| Var x => match x with
           | FVar _ => True
           | _ => False
           end
| EConst _ => False
| Fun f args => let fix are_args_ground {k} (ars : Vector.t Term k) :=
                    match ars with
                    | [] => True
                    | a::tl => is_ground_term a /\ are_args_ground tl
                    end
                in are_args_ground args
end.

Global Instance GroundTerm : Ground Term := {
  is_ground := is_ground_term
}.

(** ** Predicates

We encode the syntax of a predicate, analogous to [Term], as its arity
[n : nat], its [name], and its arguments as a [Vector.t Term].
*)
Inductive Predicate : Type :=
| P : forall (n : nat), name -> Vector.t Term n -> Predicate.

Global Instance ContainsBVarPredicate : ContainsBVar Predicate := {
  contains_bvar (index : nat) (p : Predicate) :=
  match p with
  | P n nm args => Vector.Exists (fun (arg : Term) => contains_bvar index arg)
                   args
  end
}.

Global Instance GroundPredicate : Ground Predicate := {
  is_ground (p : Predicate) := match p with
  | P n s args => Vector.Forall is_ground args
  end
}.

Global Instance substPred : Subst Predicate :=
{
  subst (x : V) (t : Term) (p : Predicate) :=
  match p with
  | P n s args => P n s (Vector.map (fun (arg : Term) => subst x t arg) args)
  end
}.

Open Scope string_scope.

Example pred_subst_1 : subst (BVar 0) (Fun "c" []) (P 3 "P" [Var (BVar 1); Var (BVar 0); Fun "f" [Var (BVar 0); Var (FVar "y")]])
= (P 3 "P" [Var (BVar 1); (Fun "c" []); Fun "f" [(Fun "c" []); Var (FVar "y")]]).
Proof.
  trivial.
Qed.

Lemma subst_id : forall (n : nat) (p : Predicate),
  subst (BVar n) (Var (BVar n)) p = p.
Proof.
  intros. destruct p; unfold subst; unfold substPred.
  rewrite Term.subst_id_vec. reflexivity.
Qed.

Global Instance EqPred : Eq Predicate :=
{
  eqb (P1 P2 : Predicate) :=
  match P1,P2 with
  | P n1 s1 args1, P n2 s2 args2 =>
      if andb (eqb n1 n2) (eqb s1 s2)
      then vectors_eqb args1 args2 term_eqb
      else false
  end
}.

(* TODO I am too lazy to prove this... *)
Lemma eq_dec : forall (x y : Predicate),
  {x = y} + {x <> y}.
Admitted.

Global Instance LiftPred : Lift Predicate :=
{
  lift (c d : nat) (p : Predicate) :=
  match p with
  | P n s args => P n s (Vector.map (fun (a : Term) => lift c d a) args)
  end;
  unlift (c d : nat) (p : Predicate) :=
  match p with
  | P n s args => P n s (Vector.map (fun (a : Term) => unlift c d a) args)
  end
}.

Require Import Coq.Logic.Eqdep_dec.

Theorem lift_id : forall (p : Predicate),
  lift 0 0 p = p.
Proof. intros. destruct p. rename t into args.
  unfold lift; unfold LiftPred.
  assert (Vector.map (fun a : Term => lift 0 0 a) args = args). {
    induction args.
    - simpl; auto.
    - assert (Vector.map (fun a : Term => lift 0 0 a) (h::args)
               = ((fun a : Term => lift 0 0 a) h)::(Vector.map (fun a : Term => lift 0 0 a) args)). {
        simpl; auto.
      }
      rewrite H. rewrite IHargs.
      rewrite Term.term_zero_lift_is_id. unfold id. reflexivity.
  }
  rewrite H; reflexivity.
Qed.

Require Import Coq.Logic.Eqdep_dec.

Lemma bigger_lift_is_id : forall (i k1 k2 : nat) (p : Predicate),
  k1 < k2 -> lift k1 i p = p -> lift k2 i p = p.
Proof.
  intros. destruct p.
  unfold lift; unfold LiftPred. rename t into args.
  assert (Vector.map (fun (a : Term) => lift k1 i a) args = args). {
    unfold lift in H0; unfold LiftPred in H0.
    inversion H0. apply inj_pair2_eq_dec in H2. rewrite H2.
    2: decide equality.
    unfold lift; unfold liftTerm. simpl; auto.
  }
  assert (Vector.map (fun (a : Term) => lift k2 i a) args = args). {
    apply bigger_lift_is_id_vector with (k2 := k2) in H1 as IH.
    simpl; auto. assumption.
  }
  rewrite H2; reflexivity.
Qed.

Theorem lift_comp : forall (c d1 d2 : nat) (p : Predicate),
  lift c d1 (lift c d2 p) = lift c (d1 + d2) p.
Proof.
  intros. destruct p as [n nm args].
  unfold lift; unfold LiftPred.
  rewrite vect_lift_comp. reflexivity.
Qed.

Theorem lift_seq : forall (c d2 d1 : nat) (p : Predicate),
  d1 > 0 -> lift (S c) d2 (lift c d1 p) = lift c (d2 + d1) p.
Proof.
  intros. destruct p as [n nm args].
  unfold lift; unfold LiftPred.
  rewrite vect_lift_seq. reflexivity. assumption.
Qed.

(*
Theorem variadic_lift_seq : forall (m : nat) (p : Predicate),
  (lift (S m) 1 (lift 1 m p)) = lift 1 (S m) p.
Proof.
  intros. destruct p as [n nm args].
  unfold lift; unfold LiftPred.
  rewrite vect_variadic_quantifier_lift_seq. reflexivity.
Qed.
*)
Corollary variadic_quantifier_lift_seq :
  forall (m k : nat) (p : Predicate),
  k > 0 -> (lift (k + m) 1 (lift k m p)) = lift k (S m) p.
Proof.
  intros. destruct p as [n nm args].
  unfold lift; unfold LiftPred.
  rewrite vect_variadic_quantifier_lift_seq. reflexivity. assumption.
Qed.

Global Instance FreshPredicate : Fresh Predicate := {
  fresh (c : Term) (p : Predicate) :=
  match p with
  | P n s args => Term.fresh_vect c args
  end
}.

Global Instance EnumerateEVarsPredicate : EnumerateEVars Predicate := {
list_evars p := match p with
| P n s args => Vector.fold_left (fun l' => fun (arg : Term) => insert_merge (list_evars arg) l') []%list args
end
}.

Theorem list_evars_predicate_sorted : forall (p : Predicate),
  sorted (list_evars p).
Proof. intros.
  destruct p.
  rename t into args.
  unfold list_evars; unfold EnumerateEVarsPredicate.
  apply insert_merge_vector_fold_sorted2.
  apply sorted_nil.
Qed.

Global Instance LiftEvarsPredicate : LiftEvars Predicate := {
lift_evars k p := match p with
| P n s args => P n s (Vector.map (lift_evars k) args)
end
}.

(* Contains a subterm *)

Global Instance ContainsPredicate : Contains Predicate := {
  contains (sub : Term) (p : Predicate) := match p with
  | P _ _ args => Vector.Exists (contains sub) args
  end
}.


Section Closure.

  (* SF Rel.v *)

  Definition relation (X : Type) := X -> X -> Prop.

  Inductive refl_step_closure {X : Type} (R : relation X)  : X -> X -> Prop :=
  | rsc_refl  : forall (x : X), refl_step_closure R x x
  | rsc_step : forall (x y z : X),
      R x y ->
      refl_step_closure R y z ->
      refl_step_closure R x z.

  Lemma rsc_R : forall {X : Type} (R : relation X) (x y : X),
      R x y -> refl_step_closure R x y.
  Proof.
    intros X R x y r.
    apply rsc_step with y.
    apply r.
    now apply rsc_refl.
  Qed.

  Lemma rsc_trans : forall {X : Type} (R : relation X) (x y z : X),
      refl_step_closure R x y ->
      refl_step_closure R y z ->
      refl_step_closure R x z.
  Proof.
    intros X R x y z.
    intros HRxy HRyz.
    induction HRxy as [|z' x y Rxy].
    - now apply HRyz.
    - apply (rsc_step R z' x z).
      apply Rxy.
      apply IHHRxy.
      now apply HRyz.
  Qed.

End Closure.

(* END *)


Require Export ProjectiveGeometry.Dev.matroid_to_matroid_p.

(*****************************************************************************)
(** Matroid properties **)

Section s_matroidProperties.

Context `{M : Matroid}.
Context `{EP : EqDecidability Point}.

Global Add Morphism couple : couple_mor.
Proof.
intros.
unfold couple.
rewrite H0.
rewrite H1.
fsetdecide.
Qed.

Lemma add_inj : forall x E E',
 Equal E E' -> (Equal (add x E) (add x E')).
Proof.
intros.
rewrite H0.
fsetdecide.
Qed.

Global Add Morphism triple : triple_mor.
Proof.
intros.
unfold triple.
rewrite H0;clear H0.
apply add_inj.
rewrite H1; clear H1.
apply add_inj.
rewrite H2; clear H2.
fsetdecide.
Qed.

Global Add Morphism quadruple : quadruple_mor.
Proof.
intros.
unfold quadruple.
rewrite H0;clear H0.
apply add_inj.
rewrite H1; clear H1.
apply add_inj.
rewrite H2; clear H2.
apply add_inj.
rewrite H3.
fsetdecide.
Qed.

Lemma rk_singleton_le : forall p : Point, rk (singleton p) <= 1.
Proof.
generalize (matroid2' empty).
intro.
rewrite matroid1' in H0.
intro.
assert (HH:= H0 p).
setoid_replace (add p empty) with (singleton p) in HH.
omega.
fsetdecide.
Qed.

Lemma matroid1_b_useful :  forall X m,  cardinal X <= m -> rk X <= m.
Proof.
intros.
assert (rk X <= cardinal X).
apply matroid1_b;auto.
omega.
Qed.

Lemma cardinal_couple : forall p q, ~ p[==]q -> cardinal (couple p q) = 2.
Proof.
intros.
unfold couple.
repeat (rewrite (add_cardinal_2)).
rewrite empty_cardinal;auto.
fsetdecide.
fsetdecide.
Qed.

Lemma cardinal_triple : forall p q r, ~ p[==]q -> ~ p[==]r -> ~ q[==]r -> cardinal (triple p q r) <= 3.
Proof.
intros.
unfold triple.
repeat (rewrite (add_cardinal_2)).
rewrite empty_cardinal;auto.
fsetdecide.
fsetdecide.
fsetdecide.
Qed.

Lemma cardinal_quadruple : forall p q r s,
~ p[==]q -> ~ p[==]r -> ~ p[==]s ->
~ q[==]r -> ~ q[==]s -> ~ r[==]s -> cardinal (quadruple p q r s) <= 4.
Proof.
intros.
unfold quadruple.
repeat (rewrite (add_cardinal_2)).
rewrite empty_cardinal;auto.
fsetdecide.
fsetdecide.
fsetdecide.
fsetdecide.
Qed.

Lemma rk_couple_2 : forall p q : Point, rk(couple p q) <= 2.
Proof.
intros.
case_eq (eq_dec p q).
intros.
rewrite e.
setoid_replace (couple q q) with (singleton q) by fsetdecide.
apply matroid1_b_useful.
assert(cardinal {q} = 1);solve[intuition].
intros.
apply matroid1_b_useful.
rewrite cardinal_couple.
intuition.
intuition.
Qed.

Lemma rk_triple_le : forall A B C : Point, rk (triple A B C) <= 3.
Proof.
intros.
assert (T:=matroid2' (couple A B) C).
decompose [and] T;clear T.
setoid_replace (add C (couple A B)) with (triple A B C) in H1 by fsetdecide.
assert (rk (couple A B) <= 2) by apply rk_couple_2.
omega.
Qed.

Lemma rk_quadruple_le : forall A B C D : Point, rk (quadruple A B C D) <= 4.
Proof.
intros.
assert (T:=matroid2' (triple A B C) D).
decompose [and] T;clear T.
setoid_replace (add D (triple A B C)) with (quadruple A B C D) in H1 by fsetdecide.
assert (rk (triple A B C) <= 3) by apply rk_triple_le.
omega.
Qed.

Lemma matroid3'_gen : forall E A B,
rk (union E A) = rk E ->
rk (union E B) = rk E ->
rk (union E (union A B)) = rk E.
Proof.
intros.
apply le_antisym.
setoid_replace (union E (union A B)) with (union (union E A) (union E B)) by fsetdecide.
assert (rk (union (union E A) (union E B)) + rk E <=
  rk (union E A) + rk (union E B)).
apply (matroid3_useful (union E A) (union E B) E).
fsetdecide.
rewrite H1 in H2.
rewrite H0 in H2.
omega.
apply matroid2.
fsetdecide.
Qed.

End s_matroidProperties.


From Hammer Require Import Hammer.

Require Import Bool BinPos BinNat PeanoNat Nnat.
Declare ML Module "ascii_syntax_plugin".

Inductive ascii : Set := Ascii (_ _ _ _ _ _ _ _ : bool).

Delimit Scope char_scope with char.
Bind Scope char_scope with ascii.

Definition zero := Ascii false false false false false false false false.

Definition one := Ascii true false false false false false false false.

Definition shift (c : bool) (a : ascii) :=
match a with
| Ascii a1 a2 a3 a4 a5 a6 a7 a8 => Ascii c a1 a2 a3 a4 a5 a6 a7
end.

Definition ascii_dec : forall a b : ascii, {a = b} + {a <> b}.
Proof. hammer_hook "Ascii" "Ascii.ascii_dec".
decide equality; apply bool_dec.
Defined.

Definition ascii_of_pos : positive -> ascii :=
let loop := fix loop n p :=
match n with
| O => zero
| S n' =>
match p with
| xH => one
| xI p' => shift true (loop n' p')
| xO p' => shift false (loop n' p')
end
end
in loop 8.

Definition ascii_of_N (n : N) :=
match n with
| N0 => zero
| Npos p => ascii_of_pos p
end.

Definition ascii_of_nat (a : nat) := ascii_of_N (N.of_nat a).

Local Open Scope list_scope.

Fixpoint N_of_digits (l:list bool) : N :=
match l with
| nil => 0
| b :: l' => (if b then 1 else 0) + 2*(N_of_digits l')
end%N.

Definition N_of_ascii (a : ascii) : N :=
let (a0,a1,a2,a3,a4,a5,a6,a7) := a in
N_of_digits (a0::a1::a2::a3::a4::a5::a6::a7::nil).

Definition nat_of_ascii (a : ascii) : nat := N.to_nat (N_of_ascii a).

Theorem ascii_N_embedding :
forall a : ascii, ascii_of_N (N_of_ascii a) = a.
Proof. hammer_hook "Ascii" "Ascii.ascii_N_embedding".
destruct a as [[|][|][|][|][|][|][|][|]]; vm_compute; reflexivity.
Qed.

Theorem N_ascii_embedding :
forall n:N, (n < 256)%N -> N_of_ascii (ascii_of_N n) = n.
Proof. hammer_hook "Ascii" "Ascii.N_ascii_embedding".
destruct n.
reflexivity.
do 8 (destruct p; [ | | intros; vm_compute; reflexivity ]);
intro H; vm_compute in H; destruct p; discriminate.
Qed.

Theorem ascii_nat_embedding :
forall a : ascii, ascii_of_nat (nat_of_ascii a) = a.
Proof. hammer_hook "Ascii" "Ascii.ascii_nat_embedding".
destruct a as [[|][|][|][|][|][|][|][|]]; compute; reflexivity.
Qed.

Theorem nat_ascii_embedding :
forall n : nat, n < 256 -> nat_of_ascii (ascii_of_nat n) = n.
Proof. hammer_hook "Ascii" "Ascii.nat_ascii_embedding".
intros. unfold nat_of_ascii, ascii_of_nat.
rewrite N_ascii_embedding.
apply Nat2N.id.
unfold N.lt.
change 256%N with (N.of_nat 256).
rewrite <- Nat2N.inj_compare.
now apply Nat.compare_lt_iff.
Qed.


Require Import Coq.Lists.List.
Require Export TypeClasses.Monoid.

(** * The Foldable Class *)

Class Foldable (T : Type -> Type) :=
  { foldr : forall {A B : Type}, (B -> A -> A) -> A -> T B -> A;
    foldl : forall {A B : Type}, (A -> B -> A) -> A -> T B -> A }.
(**[]*)

Definition foldMap {T : Type -> Type} `{Foldable T}
           {A M : Type} `{Monoid M}
           (f : A -> M) (t : T A) : M :=
  foldr (mappend ∘ f) mempty t.
(**[]*)

Definition fold {T : Type -> Type} `{Foldable T}
           {M : Type} `{Monoid M} (t : T M) : M := foldMap id t.
(**[]*)

Instance IdentityFoldable : Foldable (fun X => X) :=
  { foldr _ _ f a b := f b a; foldl _ _ f a b := f a b }.

Definition fold_option {A B : Type}
           (f : B -> A -> A) (a : A) (t : option B) : A :=
  match t with
  | None   => a
  | Some b => f b a
  end.
(**[]*)

Instance OptionFoldable : Foldable option :=
  { foldr _ _ f := fold_option f;
    foldl _ _ f := fold_option (fun a b => f b a) }.
(**[]*)

Instance ListFoldable : Foldable list :=
  { foldr := fold_right; foldl _ _ f a l := fold_left f l a }.
(**[]*)

(** Binary Trees. *)

Fixpoint foldr_tree {A K V : Type}
         (f : K -> V -> A -> A) (a : A) (t : tree K V) : A :=
  match t with
  | Leaf         => a
  | Node k v l r => foldr_tree f (f k v (foldr_tree f a r)) l
  end.
(**[]*)

Fixpoint foldl_tree {A K V : Type}
         (f : A -> K -> V -> A) (a : A) (t : tree K V) : A :=
  match t with
  | Leaf         => a
  | Node k v l r => foldl_tree f (f (foldl_tree f a l) k v) r
  end.
(**[]*)

(** Note that this instance ignores keys. *)
Instance TreeFoldable (K : Type) : Foldable (tree K) :=
  { foldr A V f := @foldr_tree A K V (fun _ => f);
    foldl A V f := @foldl_tree A K V (fun a _ => f a) }.
(**[]*)

(** Ternary Trees. *)

Fixpoint foldr_ternary {A B : Type}
         (f : B -> A -> A) (a : A) (t : ternary B) : A :=
  match t with
  | LF           => a
  | N2 b l r     => foldr_ternary f (f b (foldr_ternary f a r)) r
  | N3 x y l m r => foldr_ternary f (f x (foldr_ternary f (f y (foldr_ternary f a r)) m)) l
  end.
(**[]*)

Fixpoint foldl_ternary {A B : Type}
         (f : A -> B -> A) (a : A) (t : ternary B) : A :=
  match t with
  | LF           => a
  | N2 b l r     => foldl_ternary f (f (foldl_ternary f a l) b) r
  | N3 x y l m r => foldl_ternary f (f (foldl_ternary f (f (foldl_ternary f a l) x) m) y) r
  end.
(**[]*)

Instance TernaryFoldable : Foldable ternary :=
  { foldr := @foldr_ternary; foldl := @foldl_ternary }.
(**[]*)


From Coq Require Import List Lia.

Import ListNotations.

(* TODO: Move. Also, do I really have to define this? *)
Fixpoint zipWith {A B C} (f : A -> B -> C) (xs : list A) (ys : list B) : list C
  := match xs, ys with
     | [], _        => []
     | _, []        => []
     | a::xs', b::ys' => f a b :: zipWith f xs' ys'
     end.

Definition zip {X Y} (xs : list X) (ys : list Y) := zipWith (fun a b => (a, b)) xs ys.

Lemma map_In {A B : Type} (l : list A) (f : forall (x : A), In x l -> B) : list B.
Proof.
  induction l.
  - exact [].
  - refine (f a _ :: IHl _).
    + simpl. auto.
    + intros x H. apply (f x). simpl. auto.
Defined.

Lemma list_sum_map :
  forall {X} (f : X -> nat) x xs,
    In x xs ->
    list_sum (map f xs) >= f x.
Proof.
  induction xs; intros In; [contradiction|].
  destruct In; subst.
  - cbn. lia.
  - cbn. specialize (IHxs H).
    unfold list_sum in IHxs.
    lia.
Qed.


(**
Coq/SSReflect/MathComp による定理証明

第3章 演習問題と追加の問題、回答なし。

======

2018_09_16 @suharahiromichi
 *)

From mathcomp Require Import all_ssreflect.

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

(** 問 3.1 *)

Inductive 紅白玉 :=
| 赤玉
| 白玉
.

(** 問 3.2 *)

Print list.
(*
Inductive list (A : Type) : Type :=
  nil  : seq A
| cons : A -> seq A -> seq A
*)

Definition 玉の列 := list 紅白玉.

(** 問 3.3 *)

Check nil : 玉の列.
Fail Check 赤玉      : 玉の列.
Check cons 赤玉 nil  : 玉の列.
Fail Check nil cons 赤玉 nil : 玉の列.
Check cons 白玉 (cons 赤玉 nil).

(** 問 3.4 *)
(* 次の定義を修正して、完成してください。 *)

Definition eq_ball (a b : 紅白玉) : bool :=
  match a with
  | 赤玉 =>
      match b with
      | 赤玉 => true
      | 白玉 => false
      end
  | 白玉 =>
      match b with
      | 赤玉 => false
      | 白玉 => true
      end
  end.

Fixpoint 赤数え (s : 玉の列) : nat :=
  match s with
    nil => 0
  | cons h t =>
      if eq_ball h 赤玉 then
        1 + 赤数え t
      else
        赤数え t
  end.

Compute 赤数え nil.
  (* = 0 : nat *)
Compute 赤数え (cons 赤玉 nil).
  (* = 1 : nat *)
Compute 赤数え (cons 白玉 nil).
  (* = 0 : nat *)
Compute 赤数え (cons 赤玉 (cons 赤玉 nil)).
  (* = 2 : nat *)
Compute 赤数え (cons 赤玉 (cons 白玉 (cons 赤玉 nil))).
  (* = 2 : nat *)

Definition count_rouge_with_map s :=
  sumn (map (fun m => if m is 赤玉 then 1 else 0) s).
(*
m is 赤玉　はProp型ではない点に注意
m = 赤玉 ではない
by 須原さん
*)

Compute count_rouge_with_map nil.
  (* = 0 : nat *)
Compute count_rouge_with_map (cons 赤玉 nil).
  (* = 1 : nat *)
Compute count_rouge_with_map (cons 白玉 nil).
  (* = 0 : nat *)
Compute count_rouge_with_map (cons 赤玉 (cons 赤玉 nil)).
  (* = 2 : nat *)
Compute count_rouge_with_map (cons 赤玉 (cons 白玉 (cons 赤玉 nil))).
  (* = 2 : nat *)

Definition count_rouge_with_filter s :=
  size (filter (fun m => if m is 赤玉 then true else false) s).

Compute count_rouge_with_filter nil.
  (* = 0 : nat *)
Compute count_rouge_with_filter (cons 赤玉 nil).
  (* = 1 : nat *)
Compute count_rouge_with_filter (cons 白玉 nil).
  (* = 0 : nat *)
Compute count_rouge_with_filter (cons 赤玉 (cons 赤玉 nil)).
  (* = 2 : nat *)
Compute count_rouge_with_filter (cons 赤玉 (cons 白玉 (cons 赤玉 nil))).
  (* = 2 : nat *)

Definition count_rouge_with_filter' s :=
  size (filter (eq_ball 赤玉) s).

Compute count_rouge_with_filter' nil.
  (* = 0 : nat *)
Compute count_rouge_with_filter' (cons 赤玉 nil).
  (* = 1 : nat *)
Compute count_rouge_with_filter' (cons 白玉 nil).
  (* = 0 : nat *)
Compute count_rouge_with_filter' (cons 赤玉 (cons 赤玉 nil)).
  (* = 2 : nat *)
Compute count_rouge_with_filter' (cons 赤玉 (cons 白玉 (cons 赤玉 nil))).
  (* = 2 : nat *)

Theorem thm1 :
  forall s : 玉の列,
    赤数え s = count_rouge_with_map s.
Proof.
  intro.
  induction s.
  - (* s = nil の場合 *)
    reflexivity.
  - (* s = nil でない場合 *)
    case a.
    + (* a = 赤玉の場合 *)
      simpl.
      rewrite IHs.
      reflexivity.
    + (* a = 白玉の場合 *)
      simpl.
      rewrite IHs.
      reflexivity.
Qed.

Theorem thm2 :
  forall s : 玉の列,
    赤数え s = count_rouge_with_filter s.
Proof.
  intro.
  induction s.
  - (* s = nil の場合 *)
    reflexivity.
  - (* s = nil でない場合 *)
    case a.
    + (* a = 赤玉の場合 *)
      simpl.
      rewrite IHs.
      reflexivity.
    + (* a = 白玉の場合 *)
      simpl.
      rewrite IHs.
      reflexivity.
Qed.

(** 問 3.5 追加の問題 *)
(** 与えられた玉の列に対する赤玉の数を示す述語 num_of_red を Inductive により定義せよ。 *)
(* 次の定義を修正して、完成してください。 *)

Inductive num_of_red : 玉の列 -> nat -> Prop :=
| b_nil   : num_of_red nil 0
| b_red   : forall s n, num_of_red s n -> num_of_red (赤玉 :: s) (1 + n)
(* 1 + n は変数で置き換えて、前提条件にする方がいい by 須原さん *)
| b_white : forall s n, num_of_red s n -> num_of_red (白玉 :: s) n
.

(** 問 3.6 追加の問題 *)
(** 命題 [num_of_red (cons 白玉 (cons 赤玉 nil)) 1] が真であることを示せ。 *)
(* Admitted を修正してください。 *)

Goal num_of_red (cons 白玉 (cons 赤玉 nil)) 1.
Proof.
  apply b_white.
  apply b_red with (s := nil) (n := 0).
  apply b_nil.
Qed.

(** 問 3.7 追加の問題 *)
(** 命題 [num_of_red (cons 白玉 (cons 赤玉 nil)) 0] が偽（否定が真）であることを示せ。 *)
(* Admitted を修正してください。 *)

Goal ~ num_of_red (cons 白玉 (cons 赤玉 nil)) 0.
Proof.
  unfold not.
  intro.
  inversion H; subst; clear H.
  inversion H1.
(*
  inversion H1; subst; clear H1.
  inversion H2.
  rewrite <- H1 in H0.
  inversion H0.
*)
Qed.

(** 問 3.8 追加の問題 *)
(** 問 3.4 で定義した 関数 赤数え の結果と、問 3.5 で定義した 述語
    num_of_red の命題が必要十分条件であることを定理として示せ。
    このとき、num_of_red の定義を見直してもよい。 *)
(* admit と Admitted を修正してください。 *)

Lemma eq_red :
  forall a : 紅白玉,
    eq_ball a 赤玉 = true -> a = 赤玉.
Proof.
  intro.
  induction a.
  - (* aが赤玉の場合 *)
    intro.
    reflexivity.
  - (* aが白玉の場合 *)
    intro.
    inversion H.
Qed.

Lemma eq_white :
  forall a : 紅白玉,
    eq_ball a 赤玉 = false -> a = 白玉.
Proof.
  intro.
  induction a.
  - (* aが赤玉の場合 *)
    intro.
    inversion H.
  - (* aが白玉の場合 *)
    intro.
    reflexivity.
Qed.

Theorem 赤数え_赤の数 s n : 赤数え s = n <-> num_of_red s n.
Proof.
  split.
  - (* Fixpoint -> Inductive *)
    intros.
    rewrite <- H; clear H.
    induction s.
    + (* nilの場合 *)
      simpl.
      apply b_nil.
    + (* consの場合 *)
      simpl.
      case_eq (eq_ball a 赤玉).
      * (* trueの場合 *)
        intros.
        apply b_red in IHs.
        apply eq_red in H.
        rewrite H.
        apply IHs.
      * (* falseの場合 *)
        intros.
        apply b_white in IHs.
        apply eq_white in H.
        rewrite H.
        apply IHs.
  - (* Inductive -> Fixpoint *)
    intros.
    induction H.
    + (* b_nilの場合 *)
      simpl.
      reflexivity.
    + (* b_redの場合 *)
      simpl.
      rewrite IHnum_of_red addnC.
      reflexivity.
    + (* b_whiteの場合 *)
      simpl.
      rewrite IHnum_of_red.
      reflexivity.
Qed.

(* END *)


Require Import LibTactics.
Require Import Metalib.Metatheory.

Require Import
        syntax_ott
        rules_inf
        Infrastructure
        Subtyping_inversion
        Key_Properties
        Deterministic
        rules_inf2
        dunfield.

Require Import Omega.

Lemma open_dexp_eqn_aux :
                forall ee1 ee2 x n,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp_rec n (de_var_f x) ee1 = open_dexp_wrt_dexp_rec n (de_var_f x) ee2
       -> ee1 = ee2.
Proof.
  apply_mutual_ind dexp_mutind;
  apply_mutual_ind dexp_mutind;
  default_simp;
  try solve [eapply_first_hyp; eauto].
  omega.
Qed.

Lemma open_dexp_eqn : forall x ee1 ee2,
       x `notin` fv_dexp ee1 ->
       x `notin` fv_dexp ee2 ->
       open_dexp_wrt_dexp ee1 (de_var_f x) = open_dexp_wrt_dexp ee2 (de_var_f x)
       -> ee1 = ee2.
Proof.
  intros x ee1 ee2 H H0 H1.
  unfold open_dexp_wrt_dexp in H1.
  pose proof open_dexp_eqn_aux.
  eauto.
Qed.

Lemma subtyping_completeness : forall A B,
    isub A B -> sub A B.
Proof.
  intros A B H.
  induction* H.
Qed.

Lemma disjoint_completeness : forall A B,
    icfpDisjoint A B -> disjointSpec A B.
Proof.
  intros A B H. apply disjoint_eqv.
  induction~ H.
  (* H: icfpDisjointAx A B *)
  induction~ H.
  (* symm case *)
  apply disjoint_eqv.
  applys~ disjoint_symmetric.
  apply~ disjoint_eqv.
Qed.

(* completeness of typing with respect to the type system in ICFP 2016 *)
Theorem typing_completeness : forall G ee A e,
    ITyping G ee A e -> Etyping G e A /\ |e| = ee.
Proof with auto.
  intros G ee A e Typ.
  induction Typ...
  -
    split.
    eapply Etyp_abs.
    intros.
    forwards* [? ?]: H1 H2.
    auto_sub.
    auto_sub.
    simpl.
    pick fresh x for (union L (union (fv_dexp (|e|)) (fv_dexp ee))).
    forwards* [? ?]: H1.
    rewrite erasure_open in H3.
    simpl in H3.
    forwards*: open_dexp_eqn H3.
    congruence.
  -
    lets [HT1 Era1]: IHTyp1.
    lets [HT2 Era2]: IHTyp2.
    split*.
    simpl.
    congruence.
  - (* disjoint *)
    apply disjoint_completeness in H.
    lets [HT1 Era1]: IHTyp1.
    lets [HT2 Era2]: IHTyp2.
    simpl. split... congruence.
  -
    destruct IHTyp.
    apply subtyping_completeness in H.
    split*.
Qed.


(***************************************************************************)
(*   This is part of FA_Landau, it is distributed under the terms of the   *)
(*             GNU Lesser General Public License version 3                 *)
(*                (see file LICENSE for more details)                      *)
(*                                                                         *)
(*           Copyright 2020-2022: Yaoshun Fu and Wensheng Yu.              *)
(***************************************************************************)

Require Export finite reals.

Corollary uneqOP : ∀ {c}, c > O -> neq_zero c.
Proof.
  intros. destruct c; auto. inversion H.
Qed.

Corollary Pos : ∀ x y, x > O -> y > O -> (x · y) > O.
Proof.
  intros; destruct x, y; simpl; auto.
Qed.

Corollary Pos' : ∀ x y l, x > O -> y > O -> (x/y) l > O.
Proof.
  intros; destruct x, y; simpl; auto; elim H; elim H0.
Qed.

Corollary Pl_R : ∀ x y, y > O <-> x + y > x.
Proof.
  split; intros.
  - apply Theorem188_1 with (Θ:=-x); Simpl_R.
  - apply Theorem188_1' with (Θ:=-x) in H; Simpl_Rin H.
Qed.

Corollary Pl_R' : ∀ x y, y > O <-> x - y < x + y.
Proof.
  split; intros.
  - apply Theorem188_1 with (Θ:=y); Simpl_R.
    rewrite Theorem186; simpl; apply Pl_R. destruct y; auto.
  - apply Theorem188_1' with (Θ:=y) in H; Simpl_Rin H.
    rewrite Theorem186 in H; apply Pl_R in H. destruct y; auto.
Qed.

Corollary Mi_R : ∀ a b c d, (a - c) + (b - d) = (a + b) - (c + d).
Proof.
  intros. unfold Minus_R.
  rewrite Theorem180. repeat rewrite <- Theorem186.
  apply Theorem188_2 with (Θ:=d); Simpl_R. unfold Minus_R.
  do 2 rewrite Theorem186. rewrite (Theorem175 b); auto.
Qed.

Corollary Mi_R' : ∀ a b c d, (a - c) - (b - d) = (a - b) - (c - d).
Proof.
  intros. unfold Minus_R at 2 3. rewrite <- Mi_R. Simpl_R.
  unfold Minus_R at 2. f_equal.
  rewrite Theorem181, Theorem175. Simpl_R.
Qed.

Corollary Real_PZp : ∀ n m :Nat, n + m = Real_PZ (Plus_N n m).
Proof.
  intros; simpl; unfold Cut_I; rewrite <- (eq2 Theorem155_1).
  rewrite (eq1 (Theorem112_1 _ _)); Simpl_N.
Qed.

Corollary Real_TZp : ∀ n m :Nat, n · m = Real_PZ (Times_N n m).
Proof.
  intros; simpl; unfold Cut_I; rewrite <- (eq2 Theorem155_3).
  rewrite (eq1 (Theorem112_2 _ _)); Simpl_N.
Qed.

Corollary RN1 : ∀ a, a` - 1 = a.
Proof.
  intros; apply Theorem188_2 with (Θ:=1); Simpl_R.
  rewrite Real_PZp; Simpl_N.
Qed.

Corollary RN2 : ∀ a :Nat, a` - a = 1.
Proof.
  intros; apply Theorem188_2 with (Θ:=a); Simpl_R.
  rewrite Real_PZp; Simpl_N.
Qed.

Corollary RN3 : ∀ a :Nat, a + 1 = a`.
Proof.
  intros; rewrite Real_PZp; Simpl_N.
Qed.

Corollary RN4 : ∀ a :Nat, 1 + a = a`.
Proof.
  intros; rewrite Real_PZp; Simpl_N.
Qed.

Hint Rewrite RN1 RN2 RN3 RN4 : Real.

Corollary R_T2 : ∀ a, 2 · a = a + a.
Proof.
  intros. rewrite <- NPl1_, <-Real_PZp, Theorem201'; Simpl_R.
Qed.

Corollary OrderNRlt : ∀ n m :Nat, ILT_N n m -> n < m.
Proof.
  intros; simpl. apply Theorem154_1; apply Theorem111_1'; auto.
Qed.

Corollary OrderNRle : ∀ n m :Nat, ILE_N n m -> n ≦ m.
Proof.
  intros; destruct H; [left; apply OrderNRlt|subst n; red]; auto.
Qed.

Corollary NoO_N : ∀ {N :Nat}, neq_zero N.
Proof.
  intros; simpl; auto.
Qed.

Definition RdiN r (N :Nat) := (r/N) NoO_N.

Corollary RdN1 : ∀ a n, a > O -> RdiN a n > O.
Proof.
  intros. unfold RdiN. apply Pos; simpl; auto.
Qed.

Corollary RdN2 : ∀ a b n, a·(RdiN b n) = RdiN (a·b) n.
Proof.
  intros. unfold RdiN. rewrite Di_Rt; auto.
Qed.

Corollary RdN3 : ∀ a b n, (RdiN a n) + (RdiN b n) = RdiN (a+b) n.
Proof.
  intros. unfold RdiN. rewrite Di_Rp; auto.
Qed.

Corollary RdN4 : ∀ a b n, (RdiN a n) - (RdiN b n) = RdiN (a-b) n.
Proof.
  intros. unfold RdiN. rewrite Di_Rm; auto.
Qed.

Corollary Pr_2a : ∀ {z}, z > O -> (z/2) NoO_N > O.
Proof.
  intros; apply Pos; simpl; auto.
Qed.

Corollary Pr_2b : ∀ {z}, z > O -> (z/2) NoO_N < z.
Proof.
  intros; apply Theorem203_1' with (Θ:=2); Simpl_R; [|reflexivity].
  replace 2 with (Plus_N 1 1); auto.
  rewrite <- Real_PZp,  Theorem201; Simpl_R; apply Pl_R; auto.
Qed.

Corollary Pr_2c : ∀ z l, ((z/2) l) + ((z/2) l) = z.
Proof.
  intros; rewrite Di_Rp, <- (Theorem195 z),
    <- Theorem201, Real_PZp; Simpl_R.
Qed.

Hint Rewrite Pr_2c : Real.

Corollary Ab1 : ∀ x y, -x < y /\ y < x <-> |y| < x.
Proof.
  split; intros; destruct x, y; simpl in *; tauto.
Qed.

Corollary Ab1' : ∀ x y, -x ≦ y /\ y ≦ x <-> |y| ≦ x.
Proof.
  split; intros.
  - destruct H, H, H0; red.
    + left; apply -> Ab1; auto.
    + subst y; destruct x; simpl in *; destruct H; auto.
    + subst y; destruct x; simpl in *; destruct H0; auto.
    + subst y; destruct x; simpl in *; destruct H0; auto.
  - destruct H; split; red.
    + apply Ab1 in H; tauto. + apply Ab1 in H; tauto.
    + destruct x, y; simpl; auto; inversion H; auto.
    + destruct x, y; simpl; auto; inversion H; auto.
Qed.

Corollary Ab1'' : ∀ x y z, x - y < z /\ z < x + y <-> |z - x| < y.
Proof.
  split; intros.
  - destruct H; apply (Ab1 y (z - x)); split.
    + apply Theorem188_1 with (Θ:=x); Simpl_R.
      rewrite Theorem175; auto.
    + apply Theorem188_1 with (Θ:=x); Simpl_R.
      rewrite Theorem175; auto.
  - apply (Ab1 y (z - x)) in H; destruct H; split.
    + apply Theorem188_1' with (Θ:=x) in H; Simpl_Rin H.
      rewrite Theorem175 in H; auto.
    + apply Theorem188_1' with (Θ:=x) in H0; Simpl_R.
      unfold Minus_R in H0; rewrite Theorem186 in H0; Simpl_Rin H0.
      rewrite Theorem175; auto.
Qed.

Corollary Ab2 : ∀ x y, |x + y| ≦ |x| + |y|.
Proof.
  intros; destruct x, y; simpl; red; auto.
  - destruct (Ccase c c0) as [[H | H] | H]; simpl; left; auto.
    + rewrite (eq2 Theorem130).
      apply Theorem136_3 with (ζ:=c); Simpl_C.
      rewrite (eq2 Theorem131); apply Theorem133.
    + apply Theorem136_3 with (ζ:=c0); Simpl_C.
      rewrite (eq2 Theorem131); apply Theorem133.
  - destruct (Ccase c c0) as [[H | H] | H]; simpl; left; auto.
    + rewrite (eq2 Theorem130).
      apply Theorem136_3 with (ζ:=c); Simpl_C.
      rewrite (eq2 Theorem131); apply Theorem133.
    + apply Theorem136_3 with (ζ:=c0); Simpl_C.
      rewrite (eq2 Theorem131); apply Theorem133.
Qed.

Corollary Ab2' : ∀ x y, |x| - |y| ≦ |x - y|.
Proof.
  intros; destruct (Ab2 (x-y) y); Simpl_Rin H.
  - left; apply Theorem188_1 with (Θ:=|y|); Simpl_R.
  - right; apply Theorem188_2 with (Θ:=|y|); Simpl_R.
Qed.

Corollary Ab3 : ∀ x, x > O -> |x| = x.
Proof.
  intros; destruct x; simpl in *; auto; elim H.
Qed.

Corollary Ab3' : ∀ x, O ≦ x -> |x| = x.
Proof.
  intros. destruct H, x; inversion H; reflexivity.
Qed.

Corollary Ab3'' : ∀ x, x < O -> |x| = -x.
Proof.
  intros. destruct x; inversion H; reflexivity.
Qed.

Corollary Ab3''' : ∀ x, x ≦ O -> |x| = -x.
Proof.
  intros. destruct H, x; inversion H; reflexivity.
Qed.

Corollary Ab4 : ∀ x y, x > y -> |x - y| = x - y.
Proof.
  intros; destruct x, y; simpl in *; try tauto;
  destruct (Ccase c c0) as [[H0 | H0] | H0]; simpl; auto; LGC H H0.
Qed.

Corollary Ab5 : ∀ x y, y ≦ x -> |x - y| = x - y.
Proof.
  intros; destruct H.
  - apply Ab4; auto. - rewrite H; simpl; Simpl_R.
Qed.

Corollary Ab6 : ∀ x y, y ≦ x -> |y - x| = x - y.
Proof.
  intros; rewrite <- Theorem178, Theorem181; apply Ab5; auto.
Qed.

Corollary Ab7 : ∀ x, x ≦ |x|.
Proof.
  intros; destruct x; red; simpl; auto.
Qed.

Corollary Ab8 : ∀ x, x <> O -> |x| > O.
Proof.
  intros. destruct x; simpl; tauto.
Qed.

Corollary Ab8' : ∀ x y, x <> y -> |x - y| > O.
Proof.
  intros. apply Ab8; intro; apply H, Theorem182_2; auto.
Qed.

Corollary Ab1''' : ∀ x y z, x-y ≦ z /\ z ≦ x+y <-> |z-x| ≦ y.
Proof.
  split; intros.
  - destruct H, H, H0; try subst z; Simpl_R.
    + left; apply Ab1''; auto.
    + apply Pl_R' in H. destruct y; inversion H; red; auto.
    + unfold Minus_R; rewrite (Theorem175 x _); Simpl_R.
      apply Pl_R' in H0. destruct y; inversion H0; red; auto.
    + unfold Minus_R; rewrite (Theorem175 x _); Simpl_R.
      apply Theorem183_2 in H0.
      rewrite Theorem181,Theorem175,Theorem180 in H0; Simpl_Rin H0.
      apply Theorem188_2' with (Θ:=x) in H0; Simpl_Rin H0.
      rewrite Theorem178; red; destruct y; auto.
  - destruct H; split; red.
    + apply Ab1'' in H; tauto. + apply Ab1'' in H; tauto.
    + destruct (Theorem167 x z) as [H0 | [H0 | H0]].
      * subst z; Simpl_Rin H; simpl in H. rewrite <- H; Simpl_R.
      * rewrite Ab4 in H; auto; left.
        assert (y > O). { rewrite <- H; apply Theorem182_1'; auto. }
        apply Theorem188_1 with (Θ:=y); Simpl_R.
        rewrite <- (Theorem175' x). apply Theorem189; auto.
      * rewrite <- Theorem178, Theorem181, Ab4 in H; auto; right.
        apply Theorem188_2 with (Θ:=y); Simpl_R.
        rewrite Theorem175, <- H; Simpl_R.
    + destruct (Theorem167 x z) as [H0 | [H0 | H0]].
      * subst z; Simpl_Rin H; simpl in H. rewrite <- H; Simpl_R.
      * right; rewrite Theorem175. apply Theorem188_2 with (Θ:=-x);
        Simpl_R. apply Theorem182_1' in H0. rewrite <- H.
        destruct (z-x); inversion H0; auto.
      * left; rewrite Theorem175. apply Theorem188_3 with (Θ:=-x);
        Simpl_R. apply Theorem182_3' in H0. eapply Theorem171;
        eauto; rewrite <- H. destruct (z-x); inversion H0; auto.
Qed.

Corollary Ab9 : ∀ x y, (∀ z, z > O -> |x - y| ≦ z) -> x = y.
Proof.
  intros; destruct (Theorem167 x y) as [H0 | [H0 | H0]]; auto.
  - rewrite <- Theorem178, Theorem181 in H.
    rewrite Ab4 in H; auto. apply Theorem182_1' in H0.
    pose proof (Pr_2a H0). apply H in H1; destruct H1.
    + LGR H1 (Pr_2b H0). + EGR H1 (Pr_2b H0).
  - rewrite Ab4 in H; auto. apply Theorem182_1' in H0.
    pose proof (Pr_2a H0). apply H in H1; destruct H1.
   + LGR H1 (Pr_2b H0). + EGR H1 (Pr_2b H0).
Qed.

Fixpoint Pow x n :=
  match n with
   | 1 => x
   | m` => (Pow x m) · x
  end.

Notation "x ^ n" := (Pow x n).

Corollary Pow1 : ∀ x, x^1 = x.
Proof.
  intros; simpl; auto.
Qed.

Corollary PowS : ∀ x n, x^n` = x^n · x.
Proof.
  intros; simpl; auto.
Qed.

Corollary powO : ∀ n, O^n = O.
Proof.
  intros. destruct n; simpl; Simpl_R.
Qed.

Corollary pow1 : ∀ n, 1^n = 1.
Proof.
  intros. induction n; auto. simpl. rewrite IHn; Simpl_R.
Qed.

Corollary square_p1 : ∀ a, O ≦ a^2.
Proof.
  intros; red; destruct a; simpl; auto.
Qed.

Corollary square_p2 : ∀ a, |a|^2 = a^2.
Proof.
  intros. destruct a; simpl; auto.
Qed.

Corollary square_p3 : ∀ a, (-a)^2 = a^2.
Proof.
  intros. destruct a; simpl; auto.
Qed.

Corollary powT : ∀ a b n, a^n · b^n = (a·b)^n.
Proof.
  induction n; simpl; auto.
  rewrite (Theorem194 _ b), Theorem199, <- (Theorem199 a).
  rewrite (Theorem194 (a·b)), <- Theorem199, IHn; auto.
Qed.

Corollary powm : ∀ a n, (-a)^n = (-(1))^n · a^n.
Proof.
  induction n; intros; Simpl_R. repeat rewrite PowS.
  rewrite IHn, Theorem199, Theorem199, Theorem197''; Simpl_R.
Qed.

Corollary Archimedes : ∀ x, ∃ N:Nat, x < N.
Proof.
  intros; destruct x.
  - exists 1; reflexivity.
  - ENC X c H. destruct (Theorem115 1 X) as [n H0]; Simpl_Prin H0.
    pose proof (Theorem119 _ _ _ H H0).
    apply Theorem158_2 in H1; apply Theorem124 in H1.
    assert (IGT_C (Plus_N n 1) c).
    { eapply Theorem127; left; split; eauto.
      apply Theorem154_3; apply Theorem111_3'; red; eauto. }
    exists (Plus_N n 1); simpl; auto.
  - exists 1; reflexivity.
Qed.

Corollary LEminus : ∀ x y, x ≦ y <-> -y ≦ -x.
Proof.
  split; intros; destruct H.
  - left; apply Theorem183_1; auto.
  - right; apply Theorem183_2; auto.
  - left; apply Theorem183_1'; auto.
  - right; apply Theorem183_2'; auto.
Qed.

Corollary Co_T167 : ∀ x y, x ≦ y \/ y < x.
Proof.
  intros; destruct (Theorem167 x y) as [H | [H | H]];
  unfold ILE_R; auto.
Qed.

Corollary Rcase : ∀ x y, {x ≦ y} + {y < x}.
Proof.
  intros. destruct (classicT (x ≦ y)); auto. right.
  destruct (Co_T167 x y); tauto.
Qed.

Corollary Rcase2 : ∀ x y, x ≦ y \/ y ≦ x.
Proof.
  intros; destruct (Theorem167 x y) as [H | [H | H]];
  unfold ILE_R; auto.
Qed.

Definition R2max x y := ((x + y + |x - y|)/2) NoO_N.
Definition R2min x y := ((x + y - |x - y|)/2) NoO_N.

Corollary Pr_min : ∀ x y, x ≦ y -> (R2min x y = x).
Proof.
  intros; unfold R2min; rewrite Ab6; auto.
  unfold Minus_R; rewrite Theorem180.
  rewrite Theorem186, <- (Theorem186 _ (-y) _); Simpl_R.
  pattern x at 1 2; rewrite <- Theorem195.
  rewrite <- Theorem201, Real_PZp; Simpl_R.
Qed.

Corollary Pr_min1 : ∀ x y, (R2min x y) = (R2min y x).
Proof.
  intros; unfold R2min.
  rewrite (Theorem175 x y), <- Theorem178, Theorem181; auto.
Qed.

Corollary Pr_min1' : ∀ x y z,
  R2min (R2min x y) z = R2min x (R2min y z).
Proof.
  intros; destruct (Rcase2 x y), (Rcase2 y z).
  - rewrite (Pr_min y z), (Pr_min x y); auto.
    rewrite Pr_min; auto. eapply Theorem173; eauto.
  - rewrite (Pr_min1 y z), (Pr_min z y), (Pr_min x y); auto.
  - rewrite (Pr_min1 x y), (Pr_min1 x (R2min y z)); auto.
    repeat rewrite (Pr_min y _); auto.
  - rewrite (Pr_min1 x y), (Pr_min1 y z).
    rewrite (Pr_min y x), (Pr_min z y); auto.
    rewrite Pr_min1, (Pr_min1 x z). repeat rewrite Pr_min; auto.
    eapply Theorem173; eauto.
Qed.

Corollary Pr_min2 : ∀ x y, (R2min x y) ≦ x.
Proof.
  intros; destruct (Rcase2 x y); red.
  - rewrite Pr_min; auto. - rewrite Pr_min1, Pr_min; auto.
Qed.

Corollary Pr_min3 : ∀ x y, (R2min x y) ≦ y.
Proof.
  intros; rewrite Pr_min1; apply Pr_min2.
Qed.

Corollary Pr_min4 : ∀ x y, (R2min x y) = x \/ R2min x y = y.
Proof.
  intros; destruct (Rcase2 x y).
  - left; apply Pr_min; auto.
  - right; rewrite Pr_min1; apply Pr_min; auto.
Qed.

Corollary Pr_max : ∀ x y, x ≦ y -> (R2max x y = y).
Proof.
  intros; unfold R2max; rewrite Ab6; auto.
  rewrite Theorem175, <- Theorem186; Simpl_R.
  pattern y at 1 2; rewrite <- Theorem195.
  rewrite <- Theorem201, Real_PZp; Simpl_R.
Qed.

Corollary Pr_max1 : ∀ x y, (R2max x y) = (R2max y x).
Proof.
  intros; unfold R2max.
  rewrite (Theorem175 x y), <- Theorem178, Theorem181; auto.
Qed.

Corollary Pr_max1' : ∀ x y z,
  R2max (R2max x y) z = R2max x (R2max y z).
Proof.
  intros; destruct (Rcase2 x y), (Rcase2 y z).
  - rewrite (Pr_max y z), (Pr_max x y); auto.
    repeat rewrite Pr_max; auto. eapply Theorem173; eauto.
  - rewrite (Pr_max1 y z), (Pr_max z y),
      (Pr_max x y), Pr_max1, Pr_max; auto.
  - rewrite (Pr_max1 x y), (Pr_max1 x (R2max y z)); auto.
    repeat rewrite (Pr_max y _); auto. apply Pr_max1.
  - rewrite (Pr_max1 x y), (Pr_max1 y z).
    rewrite (Pr_max y x), (Pr_max z y); auto.
    rewrite Pr_max1, (Pr_max1 x y). repeat rewrite Pr_max; auto.
    eapply Theorem173; eauto.
Qed.

Corollary Pr_max2 : ∀ x y, x ≦ (R2max x y).
Proof.
  intros; destruct (Rcase2 x y).
  - rewrite Pr_max; auto.
  - rewrite Pr_max1, Pr_max; red; auto.
Qed.

Corollary Pr_max3 : ∀ x y, y ≦ (R2max x y).
Proof.
  intros; rewrite Pr_max1; apply Pr_max2.
Qed.

Corollary Pr_max4 : ∀ x y, (R2max x y) = x \/ R2max x y = y.
Proof.
  intros; destruct (Rcase2 x y).
  - right; apply Pr_max; auto.
  - left; rewrite Pr_max1; apply Pr_max; auto.
Qed.

Definition Boundup_Ens y A := ∀ x, x ∈ A -> x ≦ y.
Definition Bounddown_Ens y A := ∀ x, x ∈ A -> y ≦ x.

Definition EnsMax x X := x ∈ X /\ (Boundup_Ens x X).
Definition EnsMin x X := x ∈ X /\ (Bounddown_Ens x X).

Corollary FinMin : ∀ R, fin R -> No_Empty R -> ∃ r, EnsMin r R.
Proof.
  intros; destruct H as [n [f H]]; generalize dependent R;
  generalize dependent f; induction n; intros.
  - destruct H0 as [r H0].
    apply H in H0; destruct H0, H as [_ [_ [_ [H _]]]].
    apply H in H0; destruct H0; N1F H0.
  - rename H0 into H1; rename H into H0; rename IHn into H.
    rename n into m; assert (m ∈ (Fin_En m`)).
    { constructor; red; exists 1; Simpl_N. }
    apply H0 in H2; destruct H2 as [x H2].
    destruct (classic (∃ y, y <> x /\ y ∈ R)) as [H3 | H3].
    + destruct H3 as [y H3], H3.
      set (R1 := /{ r | r ∈ R /\ r <> x /}).
      set (N1 := /{ n | ∃ r1, r1 ∈ R1 /\ f n r1 /}).
      assert (Surjection (Fin_En m) R1 (RelAB N1 (Fin_En m) y f)).
      { destruct H0, H5, H6, H7; repeat split; try red; intros.
        - destruct H9, H10; try tauto.
          + eapply H0; eauto.  + subst y0 z; auto.
        - destruct (classic (x0 ∈ N1)).
          + destruct H9, H5 with x0.
            * constructor. eapply Theorem15; eauto.
              red; exists 1; Simpl_N.
            * exists x1; constructor; auto.
          + exists y; constructor 2; eauto.
        - destruct H9, H9, H6 with y0; auto.
          exists x0; constructor; auto.
          constructor; exists y0; split; auto. constructor; auto.
        - destruct H9.
          + destruct H9, H9, H9, H9, H9.
            apply (H0 _ _ _ H10) in H11; subst x1.
            pose proof H10; apply H7 in H10; destruct H10.
            apply Theorem26 in H10. destruct H10; auto.
            subst x0; elim H12; eapply H0; eauto.
          + destruct H10; auto.
        - destruct H9.
          + eapply H8; eauto. + subst y0; auto.
        - subst y0; destruct H9.
          + destruct H9,H9,H9,H9,H9. apply H12; eapply H0; eauto.
          + subst x; auto. }
    assert (No_Empty R1). { red; exists y; constructor; auto. }
    destruct (H _ _ H5 H6) as [r1 H7], H7.
    assert (R1 ⊂ R). { red; intros; destruct H9; tauto. }
    assert (R = Union R1 (/{ r | r = x /})).
    { apply ens_ext; split; intros.
      - destruct (classic (x0 = x)).
        + constructor; right; constructor; auto.
        + constructor; left; constructor; auto.
      - destruct H10, H10; auto. destruct H10. subst x0.
        eapply H0; eauto. }
    destruct (Rcase2 r1 x).
    * exists r1; split; auto; red; intros.
      rewrite H10 in H12. destruct H12, H12.
      { apply H8 in H12; auto. }
      { destruct H12; subst x0; auto. }
    * apply H0 in H2. exists x; split; auto; red; intros.
      rewrite H10 in H12. destruct H12, H12.
      { apply H8 in H12; eapply Theorem173; eauto. }
      { destruct H12; subst x0; red ;auto. }
  + apply H0 in H2. exists x; split; auto; red; intros; red.
    destruct (Theorem167 x0 x) as [H5 | [H5 | H5]]; auto.
    elim H3; exists x0; split; auto.
    intro; eapply OrdR2; eauto.
Qed.

Inductive RelMax (f :Relation Nat Real) n y : Prop :=
  | M_in : f n (-y) -> RelMax f n y.

Corollary FinMax : ∀ R, fin R -> No_Empty R -> ∃ r, EnsMax r R.
Proof.
  intros; set (R' := /{ r | (-r) ∈ R /} ).
  destruct H as [n [f H]], H, H1, H2, H3.
  assert (fin R').
  { red; exists n, (RelMax f); repeat split; try red; intros.
    - destruct H5, H6. apply Theorem183_2'. eapply H; eauto.
    - destruct H1 with x; auto.
      exists (- x0); constructor; Simpl_R.
    - destruct H5, H2 with (-y); auto. exists x; constructor; auto.
    - destruct H5. apply H3 in H5. destruct H5; auto.
    - destruct H5. apply H4 in H5; auto. }
  assert (No_Empty R').
  { destruct H0; exists (- x); constructor; Simpl_R. }
  destruct (FinMin _ H5 H6) as [M H7], H7, H7.
  exists (- M); red; split; auto; red; intros.
  apply LEminus; Simpl_R. apply H8; constructor; Simpl_R.
Qed.

Definition mid x y := RdiN (x + y) 2.

Corollary Mid_P : ∀ x y, y > x -> y > mid x y.
Proof.
  intros; apply Theorem203_1' with (Θ:=2); simpl; auto.
  unfold mid, RdiN; Simpl_R.
  rewrite <- NPl1_, <-Real_PZp, Theorem201; Simpl_R.
  apply Theorem188_1'; auto.
Qed.

Corollary Mid_P' : ∀ x y, y > x -> x < mid x y.
Proof.
  intros; apply Theorem203_1' with (Θ:=2); simpl; auto.
  unfold mid, RdiN; Simpl_R; rewrite Theorem175.
  rewrite <- NPl1_, <-Real_PZp, Theorem201; Simpl_R.
  apply Theorem188_1'; auto.
Qed.

Corollary Midp1 : ∀ x y l, mid x y - ((y-x)/2) l = x.
Proof.
  intros. unfold mid, RdiN. rewrite (proof_irr l NoO_N), Di_Rm.
  unfold Minus_R. rewrite Theorem180, <- Theorem186. Simpl_R.
  rewrite <- Di_Rp. Simpl_R.
Qed.

Corollary Midp2 : ∀ x y l, y - ((y-x)/2) l = mid x y.
Proof.
  intros. pose proof (Midp1 x y l).
  apply Theorem188_2' with (Θ:=((y-x)/2) l) in H; Simpl_Rin H.
  rewrite H; apply Theorem188_2 with (Θ:=((y-x)/2) l); Simpl_R.
  rewrite Theorem186; Simpl_R.
Qed.

Corollary MiR : ∀ x y z l l1,
  (z - (x/(y·2)) l) - (x/(y·2)) l = z - (x/y) l1.
Proof.
  intros; unfold Minus_R; rewrite Theorem186,<- Theorem180; Simpl_R.
  f_equal. rewrite Di_Rp, <- (RTi1_ x), <- Theorem201'.
  rewrite Real_PZp; Simpl_N. apply ROv_uni.
  rewrite <- Di_Rt, <- Theorem199, Theorem194; Simpl_R.
Qed.

Definition oo x y := /{ z | x < z /\ z < y /}.
Definition cc x y := /{ z | x ≦ z /\ z ≦ y /}.
Definition neighO x y := /{ z | (x - y) < z /\ z < (x + y) /}.
Definition neighC x y := /{ z | (x - y) ≦ z /\ z ≦ (x + y) /}.

Notation " ( x | y ) " := (oo x y).
Notation " [ x | y ] " := (cc x y).
Notation " ( x  |- y ) " := (neighO x y).
Notation " [ x  |- y ] " := (neighC x y).


Require Import HoTT.

(** A few lemmas regarding sigma types that we did not find in the HoTT library  *)

Definition distributivity `{Funext} (A : Type) (B : A -> Type) (C : forall a : A, B a -> Type) :
  (forall a : A, {b : B a & C a b}) <~> {b : forall a : A, B a & forall a : A, C a (b a)}.
Proof.
  srapply @equiv_adjointify.
  - intro x.
    exists (fun a : A => (x a).1). exact (fun a : A => (x a).2).
  - intro x.
    intro a.
    exists (x.1 a). exact (x.2 a).
  - intros [b c]. simpl. reflexivity.
  - intro. simpl. apply path_forall. intro a.
    srapply @path_sigma; reflexivity.
Defined.

Lemma path_sigma_hprop_compose {A : Type} {P : A -> Type} {isprop : forall a : A, IsHProp (P a)}
      (x y z: { a : A & P a}) (p : x.1 = y.1) (q : y.1 = z.1) :
  path_sigma_hprop _ _ (p @ q) = (path_sigma_hprop _ _ p) @ (path_sigma_hprop _ _ q).
Proof.
  destruct x as [x1 x2]. destruct y as [y1 y2]. destruct z as [z1 z2]. simpl in p,q.
  destruct q. destruct p. cbn.
  destruct (center _ (isprop x1 x2 z2)).
  destruct (center _ (isprop x1 x2 y2)).
  refine (path_sigma_hprop_1 _ @ _).
  apply inverse.
  apply (concat2 (path_sigma_hprop_1 (x1; x2)) (path_sigma_hprop_1 (x1; x2))).
Defined.

(** A more general version of trunc_sigma that only requires A to be "locally truncated" wherever there is a [b : B(a)] *)
Definition trunc_sigma' {A : Type} {B : A -> Type} {n : trunc_index} :
           (forall a : A, IsTrunc (n.+1) (B a)) ->
           (forall p q : {a : A & B a}, IsTrunc n (p.1 = q.1)) ->
           IsTrunc (n.+1) {a : A & B a}.
Proof.
  intros H_B H_pq.
  intros ab ab'.
  cut (IsTrunc n ({p : ab.1 = ab'.1 & p# ab.2 = ab'.2})).
  { apply trunc_equiv'.
    exact (BuildEquiv _ _ (path_sigma_uncurried B ab ab') _). }
  apply trunc_sigma.
Defined.

Lemma equiv_sigma_sum' (A : Type) (B C : A -> Type) :
   {a : A & B a} + {a : A & C a} <~> {a : A & B a + C a}.
Proof.
  srapply @equiv_adjointify.
  - intros [[a b] | [a c]].
    + exact (a; inl b).
    + exact (a; inr c).
  - intros [a [b | c]].
    + exact (inl (a; b)).
    + exact (inr (a; c)).
  - intros [a [b | c]]; reflexivity.
  - intros [[a b] | [a c]]; reflexivity.
Defined.

(*The section corresponding to a dependent function:*)
Definition section_of {A : Type} {B : A -> Type} (f : forall a : A, B a) :
  A -> {a : A & B a} := fun a => (a ; f a).

Definition ap_section {A : Type} {B : A -> Type} (f : forall a : A, B a) {a a' : A} (p : a = a'):
  ap (section_of f) p = path_sigma B (a; f a) (a'; f a') p (apD f p).
Proof.
  destruct p. reflexivity.
Defined.

Definition refl_sigma {A : Type} {B : A -> Type} (a : A) (b : B a) : (a ; b) = (a ; b) :=
  path_sigma B _ _ idpath idpath.

Definition section_to_depfun {A : Type} {B : A -> Type} :
  {f : A -> {a : A & B a} | (pr1 o f == idmap)} -> (forall a : A, B a).
Proof.
  intros [f sect].
  exact (fun a => transport B (sect a) (f a).2).
Defined.

Definition equiv_path_sigma {A : Type} (P : A -> Type) (u v : {a : A & P a}) :
  u = v <~> {p : u.1 = v.1 & transport P p u.2 = v.2}.
Proof.
  srapply @equiv_adjointify.
  - intro p. destruct p. exact (idpath; idpath).
  - intros [p q].
    exact (path_sigma P u v p q).
  - intros [p q].
    destruct u as [u1 u2].
    destruct v as [v1 v2]. simpl in p.
    destruct p. simpl in q. destruct q. reflexivity.
  - intro p. destruct p. reflexivity.
Defined.

Definition path2_sigma {A : Type} (P : A -> Type) (u v : {a : A & P a})
           (p p' : u.1 = v.1)
           (q : transport P p u.2 = v.2)
           (q' : transport P p' u.2 = v.2)
           (h1 : p = p')
           (h2 : transport (fun p0 : u.1=v.1 => (transport P p0 u.2 = v.2)) h1 q = q')
  : path_sigma P u v p q = path_sigma P u v p' q'.
Proof.
  destruct u as [u1 u2].
  destruct v as [v1 v2].
  simpl in p. simpl in p'. destruct h1.
  simpl in q. simpl in q'.
  simpl in h2. destruct h2.
  destruct p. destruct q.
  reflexivity.
Defined.

Definition path_sigma_V {A : Type} (P : A -> Type) (u v : {a : A & P a})
           (p : u.1 = v.1) (q : transport P p u.2 = v.2)
           :
             (path_sigma P u v p q)^ =
             path_sigma P v u p^ (ap (transport P p^) q^ @ transport_Vp P p u.2).
Proof.
  destruct u as [u1 u2].
  destruct v as [v1 v2].
  simpl in p. destruct p.
  simpl in q. destruct q.
  reflexivity.
Defined.


Require Import aes.aesutils.
Require Import aes.AES256.

Require Import Coqlib.
Require Import msl.Coqlib2.
Require Import floyd.coqlib3.
Require Import Integers.
Require Import List. Import ListNotations.
Require Import floyd.sublist.
Require Import sha.SHA256.
Require Import sha.general_lemmas.
Require Import Sorting.Mergesort.

Local Open Scope logic.
(* we want to prove forward table lemmas:
 * for byte i, FT0[i] = (2 * sbox[i], sbox[i], sbox[i], 3 * sbox[i]), where * is GF(256) mult;
 * FT1[i] is the same but a rotation, etc.
 *
 * This means that FT0 corresponds to the first column of the transformation matrix in figure 5.6
 * in the official spec; FT1 is the second column, etc.
 *)

Lemma ft0_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n sbox Int.zero in
  nth n FT0 Int.zero = word_to_int (ff_mult b (Int.repr 2),  b, b, ff_mult b (Int.repr 3)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma ft1_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n sbox Int.zero in
  nth n FT1 Int.zero = word_to_int (ff_mult b (Int.repr 3), ff_mult b (Int.repr 2), b, b).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma ft2_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n sbox Int.zero in
  nth n FT2 Int.zero = word_to_int (b, ff_mult b (Int.repr 3), ff_mult b (Int.repr 2), b).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma ft3_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n sbox Int.zero in
  nth n FT3 Int.zero = word_to_int (b, b, ff_mult b (Int.repr 3), ff_mult b (Int.repr 2)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

(* Analogous reverse table lemmas with figure 5.10 *)

Lemma rt0_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n inv_sbox Int.zero in
  (* (0x0e, 0x09, 0x0d, 0x0b) *)
  nth n RT0 Int.zero = word_to_int (ff_mult b (Int.repr 14), ff_mult b (Int.repr 9),
                                    ff_mult b (Int.repr 13), ff_mult b (Int.repr 11)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma rt1_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n inv_sbox Int.zero in
  (* (0x0b, 0x0e, 0x09, 0x0d) *)
  nth n RT1 Int.zero = word_to_int (ff_mult b (Int.repr 11), ff_mult b (Int.repr 14),
                                    ff_mult b (Int.repr 9), ff_mult b (Int.repr 13)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma rt2_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n inv_sbox Int.zero in
  (* (0x0d, 0x0b, 0x0e, 0x09) *)
  nth n RT2 Int.zero = word_to_int (ff_mult b (Int.repr 13), ff_mult b (Int.repr 11),
                                    ff_mult b (Int.repr 14), ff_mult b (Int.repr 9)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.

Lemma rt3_equiv : forall n : nat,
  (n < 256)%nat ->
  let b := nth n inv_sbox Int.zero in
  (* (0x09, 0x0d, 0x0b, 0x0e) *)
  nth n RT3 Int.zero = word_to_int (ff_mult b (Int.repr 9), ff_mult b (Int.repr 13),
                                    ff_mult b (Int.repr 11), ff_mult b (Int.repr 14)).
Proof.
  intros.
  do 256 (destruct n as [ | n]; [reflexivity | ]).
  omega.
Qed.