Require Import Notations.
Require Import Coq.Lists.List.
Require Import Coq.Numbers.Natural.Peano.NPeano.
Require Import Coq.omega.Omega.
Require Import Coq.Arith.Le.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.Numbers.NatInt.NZMul.
Require Import Coq.Structures.OrdersFacts.
Require Import Coq.ZArith.Znat.
Require Import Coq.QArith.QArith_base.
Require Import  Coq.QArith.QOrderedType.
Require Import QArith_base Equalities Orders OrdersTac.
Require Import Coq.Sorting.Permutation.
Require Import Wf.
Require Import Lexicographic_Product.
Require Import Inverse_Image.
Import ListNotations.

(* notation for type level existential quantifier *)
Notation "'existsT' x .. y , p" := (sigT (fun x => .. (sigT (fun y => p)) ..))
  (at level 200, x binder, right associativity,
   format "'[' 'existsT' '/ ' x .. y , '/ ' p ']'")
  : type_scope.

Section genericTermination.
Close Scope Q_scope.

(* generic notion of a judgement *)
Variable Judgement : Type.
Variable final: Judgement -> Prop.
Hypothesis final_dec: forall j : Judgement, (final j) + (not (final j)).

(* generic well-founded relation on a type *)
Variable WFO : Type.
Variable wfo: WFO -> WFO -> Prop.
Hypothesis wfo_wf: well_founded wfo.

(* the `measure' function *)
Variable m: { j: Judgement | not (final j) } -> WFO.

(* 'make non-final judgement' - pairs a judgement with evidence that it is non-final *)
Definition mk_nfj: forall j: Judgement, forall e: not (final j), { j : Judgement | not (final j) }.
  intros j e. exists j. assumption.
Defined.

(* generic rule - a relation on two judgements *)
Definition Rule := Judgement -> Judgement -> Prop.

(* property 1: the measure always decreases  *)
Definition dec (Rules : list Rule) : Type :=
  forall r, In r Rules ->
  forall p c : Judgement, r p c ->
  forall ep : not (final p),
  forall ec : not (final c),
  wfo (m (mk_nfj c ec )) (m (mk_nfj p ep)).

(* property 2: for every non-final judgement, there is a rule which may be applied *)
Definition app (Rules : list Rule) : Type :=
  forall p : Judgement, not (final  p) ->
  existsT r, existsT c, (In r Rules * r p c).

(* the type of proofs *)
Inductive Pf (a : Judgement) (Rules : list Rule) : Judgement -> Type :=
  ax : forall j : Judgement, j = a -> Pf a Rules j
  | mkp: forall c : Judgement,
  forall r : Rule, In r Rules ->
  forall b : Judgement, r b c ->
  Pf a Rules b ->
  Pf a Rules c.

(* lemma specifying when and how a proof may be 'extended' *)
Lemma extend:
  forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall a b : Judgement,
  forall eb: not (final b),
  Pf a Rules b ->
  existsT c : Judgement,
    (Pf a Rules c) *
    (forall ec: not (final c), wfo (m (mk_nfj c ec)) (m (mk_nfj b eb))).
Proof.
  intros Rules Hdec Happ a b eb Pab.
  unfold dec in Hdec.
  unfold app in Happ.
  specialize Happ with b.
  destruct Happ as [r Happ]. assumption.
  destruct Happ as [c [Happ1 Happ2]].
  specialize (Hdec r Happ1 b c Happ2).
  exists c.
  split.
  apply (mkp a Rules c r Happ1 b Happ2 Pab).
  intro ec.
  specialize (Hdec eb ec).
  assumption.
Defined.

(* auxiliary termination theorem *)
Theorem termination_aux : forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall n: WFO,
  forall a b : Judgement,
  forall eb:  not (final b),
  m (mk_nfj b eb) = n ->
  Pf a Rules b ->
  (existsT c : Judgement, final c * Pf a Rules c).
Proof.
  intros Rules Hdec Happ n.
  induction n as [w IH] using (well_founded_induction_type wfo_wf).
  intros a b eb Hmb Hab.
  assert (Hex : existsT c : Judgement,
    (Pf a Rules c) *
    (forall ec: not (final c), wfo (m (mk_nfj c ec)) (m (mk_nfj b eb)))).
  apply (extend Rules Hdec Happ a b eb Hab).
  destruct Hex as [c [Hex1 Hex2]].
  destruct (final_dec c) as [f | nf].
  (* c is final *)
  exists c. split. assumption. assumption.
  (* c is non-final *)
  specialize (Hex2 nf).
  rewrite <- Hmb in IH.
  destruct (IH (m (mk_nfj c nf)) Hex2 a c nf) as [j Hj].
  reflexivity.
  assumption.
  exists j.
  assumption.
Defined.

(* the main theorem *)
Corollary termination:  forall Rules : list Rule,
  dec Rules ->
  app Rules ->
  forall a : Judgement,
  (existsT c : Judgement, final c * Pf a Rules c).
Proof.
  intros Rules Hdec Happ a.
  destruct (final_dec a) as [f | ea].
  exists a.
  split.
  assumption.
  apply (ax a).
  reflexivity.
  apply (termination_aux Rules Hdec Happ (m (mk_nfj a ea)) a a ea).
  reflexivity.
  apply (ax a).
  reflexivity.
Defined.

End genericTermination.

Section unionCount.
Close Scope Q_scope.

(* lists with pairwise distinct candidates *)
Inductive PD  {A: Type} : list A -> Prop :=
   PDe :  PD  ( nil)
 | PDc :  forall a:A,forall l: list A, PD l /\ ~(In a l) -> (PD  (cons a l)).

Variable cand: Type.
Variable cand_all: list cand.
Hypothesis cand_pd: PD cand_all.
Hypothesis cand_finite: forall c, In c cand_all.
Hypothesis cand_eq_dec: forall c d:cand, {c=d} + {c<>d}.
Hypothesis cand_in_dec: forall c : cand, forall l : list cand, {In c l} + {~In c l}.

(* a ballot is a permutation of the list of candidates and a transfer balue *)
Definition ballot :=  ({v : list cand | Permutation cand_all v} * Q).

Variable bs : list ballot.
Variable st : nat.
Definition qu : Q := ((inject_Z (Z.of_nat (length bs))) / (1 + inject_Z (Z.of_nat st)) + 1)%Q.

(* intermediate and final states in vote counting *)
Inductive FT_Judgement :=
   state:                                   (** intermediate states **)
       list ballot                          (* uncounted votes *)
     * (cand -> Q)                   (* tally *)
     * (cand -> list ballot)          (* pile of ballots for each candidate*)
     * list cand                          (* backlog of candidates requiring transfer *)
     * {elected: list cand | length  elected <= st}   (* elected candidates no longer in the running *)
     * list cand                          (* hopeful candidates still in the running *)
     -> FT_Judgement
  | winners:                  (** final state **)
    list cand -> FT_Judgement.        (* election winners *)

Definition FT_final (a : FT_Judgement) : Prop :=
   exists w, a = winners w.

Lemma final_dec: forall j : FT_Judgement, (FT_final j) + (not (FT_final j)).
Proof.
  intro j. destruct j.
  right.
  unfold FT_final.
  unfold not. intro H.
  destruct H.
  discriminate.
  left.
  unfold FT_final.
  exists l.
  reflexivity.
Defined.

(* Rules *)
Definition FT_Rule := FT_Judgement -> FT_Judgement -> Prop.

(* relation for `first continuing candidate' on a ballot in the list of ballots requiring attention *)
Definition fcc (ba : list ballot) (h : list cand) (c : cand) (b : ballot): Prop :=
  In b ba /\
  In c h /\
  (exists l1 l2 : list cand,
      proj1_sig (fst b) = l1 ++ [c] ++ l2 /\
      forall d, (In d l1 -> ~(In d h))).

(* l and nl are equal except that nl additionally contains x *)
Definition eqe {A: Type} (x:A) (l: list A) (nl: list A) : Prop :=
  exists l1 l2: list A, l = l1 ++ l2 /\ nl = l1 ++ [x] ++ l2.

(* l and nl are equal except that nl additionally contains all the elements of a list k *)
Definition leqe {A: Type} (k: list A) (l: list A) (nl: list A) : Prop :=
  forall x, In x k -> eqe x l nl.

(* summation of weights in a list of ballots *)
Fixpoint sum (l : list ballot) : Q :=
 match l with
   | [] => 0%Q
   | l :: ls => (snd l + sum ls)%Q
 end.

Definition count (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists ba t nt p np bl h e,                (** count the ballots requiring attention **)
  prem = state (ba, t, p, bl, e, h) /\     (* if we are in an intermediate state of the count *)
  [] <> ba /\                                        (* and there are ballots requiring attention *)
  (forall c, exists l,                              (* and for each candidate c there is a list of ballots *)
     np(c) = p(c) ++ l /\                       (* such that the pile for c is updated by adding these ballots to the top *)
     (forall b, In b l <-> fcc ba h c b) /\ (* and a ballot is added to c's pile iff c is the first continuing candidate on the ballot *)
     nt(c) = sum (np(c))) /\                  (* and the new tally for c is the sum of the weights of the ballots in c's pile *)
  conc = state ([], nt, np, bl, e, h).     (* then we proceed with no ballots requiring attention and updated piles and tallies *)

Definition transfer (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists nba t p np bl nbl h e,         (** transfer votes **)
  prem = state ([], t, p, bl, e, h) /\   (* if we are in an intermediate state of the count*)
  (forall c, In c h -> (t(c) < qu)%Q) /\        (* and we can't elect any candidate *)
  exists l c,                                     (* and there exists a list l and a candidate c *)
     (bl = c :: l /\                               (* such that c is the head of the backlog *)
     nbl = l /\                                    (* and the backlog is updated by removing the head c *)
     nba = p(c) /\                             (* and the pile of ballots for c is the new list of ballots requiring attention *)
     np(c) = [] /\                                (* and the new pile for c is empty *)
     (forall d, d <> c -> np(d) = p(d))) /\ (* and the piles for every other candidate remain the same *)
  conc = state (nba, t, np, nbl, e, h).  (* then continue with the new pile of ballots requiring attention and updated piles and backlog *)

Definition cut_list {A : Type} (l : list A) (n : nat) : list A :=
  if (le_lt_dec (length l) n) then  l else l.

Inductive ordered {A : Type} (f : A -> Q) : list A -> Prop :=
  ord_emp : ordered f []
 | ord_sing : forall x : A, ordered f [x]
 | ord_cons : forall l x y, ordered f (y :: l) -> (f(x) >= f(y))%Q -> ordered f (x :: y :: l).

Definition elect (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists (ba: list ballot) (t: cand -> Q) (p np: cand -> list ballot) (bl nbl h nh: list cand) (e ne: {l : list cand | length l <= st }),
    let (els, elp) := e in                (*  e and ne are sigma-types: {l : list cand | length l <= s } *)
    let (nels, nelp) := ne in
  prem = state ([], t, p, bl, e, h) /\ (* if there are no ballots requiring attentions *)
  exists l,                                      (* and there is a list l *)
    (l <> [] /\                                   (* that is non empty *)
     length l <= st - length (proj1_sig e) /\   (* and is no greater than the number of available seats *)
     (forall c, In c l -> In c h /\ (t(c) >= qu)%Q) /\       (* and contains the candidates who have reached the quota*)
     ordered t l /\ (* and l is ordered by tally, with the greatest at the head of the list *)
     leqe l nh h /\           (* and all of the candidates over quota have been removed from the hopefuls *)
     leqe l els nels /\      (* and added to the list of elected candidates *)
     (forall c, In c l -> (np c = map (fun (b : ballot) =>
        (fst b, (snd b * ((t(c)-qu)/t(c)))%Q)) (p c))) /\   (* and the piles for the candidates over quota are updated by transfer balue *)
     (forall c, ~ In c l -> np (c) = p (c)) /\  (* and the piles for all other candidates remain the same *)
     nbl = bl ++ l) /\                                  (* and the backlog is updated by adding l to the end *)
  conc = state ([], t, np, nbl, ne, nh).      (* then continue counting with updated piles, backlog, electeds and hopefuls *)

Definition elim (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists nba t p np e h nh,                    (** eliminate a hopeful **)
  prem = state ([], t, p, [], e, h) /\          (* if there are no ballots requiring attention and no backlog*)
  length (proj1_sig e) + length h > st /\ (* and the sum of the elected candidates and hopfuls is greater than the number of seats *)
  (forall c, In c h -> (t(c) < qu)%Q) /\    (* and all of the hopefuls are under the quota *)
  exists c,                                             (* and there is a candidate c *)
     ((forall d, In d h -> (t(c) <= t(d)))%Q /\            (* with minimum tally *)
     eqe c nh h /\                                   (* and the hopefuls are updated by removing c *)
     nba = p(c) /\                                    (* and the new list of ballots to requiring attention is c's pile *)
     np(c)=[] /\                                        (* and the new pile for c is empty *)
     (forall d, d <> c -> np (d) = p (d))) /\  (* and every other pile remains the same *)
   conc = state (nba, t, np, [], e, nh).  (* then continute counting with updated ballots requiring attentions, piles and hopefuls *)

Definition hwin (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists w ba t p bl e h,                            (** hopefuls win **)
  prem = state (ba, t, p, bl, e, h) /\           (* if at any time *)
  length (proj1_sig e) + length h <= st /\ (* we have fewer hopefuls and electeds  than seats *)
  w = (proj1_sig e) ++ h /\                        (* and the winning candidates are their union *)
  conc = winners (w).                              (* the elected cands and the remaining hopefuls are declared winners *)

Definition ewin (prem: FT_Judgement) (conc: FT_Judgement) : Prop :=
  exists w ba t p bl e h,                    (** elected win **)
  prem = state (ba, t, p, bl, e, h) /\   (* if at any time *)
  length (proj1_sig e) = st /\             (* we have as many elected candidates as setas *)
  w = (proj1_sig e) /\                        (* and the winners are precisely the electeds *)
  conc = winners (w).                      (* they are declared the winners *)

Definition FTR : list FT_Rule := [count; transfer; elect; elim; hwin; ewin].

(* well founded order *)

Definition FT_WFO := nat * (nat * nat).

Definition dep2 := sigT (A:= nat) (fun a => nat).
Definition dep3 := sigT (A:= nat) (fun a => dep2).

Definition mk2  : nat * nat -> dep2.
 intros (p,q).
 exists p.
 exact q.
 Defined.

Definition mk3 : nat * (nat * nat) -> dep3.
 intros (n, p_q).
 exists n.
 exact (mk2 p_q).
Defined.

Definition lt_pq :dep2->dep2->Prop :=
     (lexprod nat (fun a => nat) Peano.lt (fun a:nat =>Peano.lt)).
Definition lt_npq : dep3 -> dep3 -> Prop :=
     (lexprod nat (fun a => dep2) Peano.lt (fun a:nat =>lt_pq)).

Lemma wf_lexprod : well_founded lt_npq.
 unfold lt_npq;apply wf_lexprod.
 apply lt_wf.
 intro n.
 unfold lt_pq;apply wf_lexprod.
 apply lt_wf.
 intro m; apply lt_wf.
Qed.

Definition FT_wfo : FT_WFO -> FT_WFO -> Prop := (fun x y : nat * (nat * nat) =>
 lt_npq (mk3 x) (mk3 y)).

Lemma FT_wfo_wf : well_founded FT_wfo.
  unfold FT_wfo.
 apply wf_inverse_image.
 apply wf_lexprod.
Qed.

(* measure function maps to (length h, length bl, length ba) *)
Definition FT_m: { j: FT_Judgement | not (FT_final j) } -> FT_WFO.
  intro H.
  destruct H as [j ej].
  destruct j.
  destruct p as [[[[[ba t] p] bl] e] h].
  split.
  exact (length h).
  split.
  exact (length bl).
  exact (length ba).
  contradiction ej.
  unfold FT_final.
  exists l.
  reflexivity.
Defined.

(* lexicographic order behaves as expected *)
Lemma wfo_aux:  forall a b c a' b' c' : nat,
  (lt_npq (mk3 (a, (b, c))) (mk3 (a', (b', c'))) <->
    (a < a' \/
    (a = a' /\ b < b' \/
    (a = a' /\ b = b' /\ c < c')))).
Proof.
  intros. split. unfold lt_npq. unfold mk3. simpl. intro H. inversion H. subst.
  (* case 1st component are below one another *)
  auto.
  (* case 1st components are equal *)
  unfold lt_pq in H1. inversion H1. subst. auto.
  (* case 1st and 2nd components are equal and 3rd are below one another *)
  subst. auto.
  (* right-to-left direction *)
  intro H. destruct H.
  (* case 1st components are below one another *)
  unfold lt_npq. apply left_lex. assumption.
  destruct H.
  (* case 1st components are equal and 2nd components are below one another *)
  destruct H as [H1 H2]. subst. apply right_lex. apply left_lex. assumption.
  (* case 1st and 2nd components are identical, and 3rd components are below one another *)
  destruct H as [H1 H2]. subst. apply right_lex.  destruct H2 as [H1 H2]. subst. apply right_lex. assumption.
Qed.

(* we can find a candidate with least no of first prefs *)
Lemma list_min : forall A:Type, forall l: list A, forall f: A -> Q,
   (l = []) + (existsT m:A, (In m l /\ (forall b:A, In b l ->(f m <= f b)%Q))).
Proof.
  intros.
  induction l as [ | l ls ].
  left. trivial.
  destruct IHls.
  right.
  exists l. split.
  apply (in_eq l ls). intros b ass.
  assert (l = b \/ In b ls).
  apply (in_inv ass). destruct H. replace l with b. intuition. replace ls with ([] : list A) in H.
  contradict H.
  right. destruct s. destruct a.
  assert ( {(f x < (f l))%Q}  + {((f l) <= (f x))%Q}).
  apply (Qlt_le_dec (f x) (f l))%Q.
  assert ( {(f x <= (f l))%Q}  + {((f l) <= (f x))%Q}).
  intuition.
  destruct H2.
  (* x is the minimum *)
  exists x. split.
  apply (in_cons l x ls). assumption. intros b ass.
  assert (l = b \/ In b ls).
  apply (in_inv ass).
  destruct H2. replace b with l. assumption.
  apply (H0 b H2).
  (* l is the minimum *)
  exists l. split.
  apply (in_eq l ls).
  intros b ass.
  assert (l = b \/ In b ls). apply (in_inv ass). destruct H2.
  replace l with b. intuition.
  specialize (H0 b H2).
  apply (Qle_trans (f l) (f x) (f b)). assumption. assumption.
Defined.

(* remove one occurrence of a candidate from a list *)
Fixpoint remc (c: cand) (l: list cand) :=
  match l with
    nil => nil
  | cons l0 ls => if (cand_eq_dec c l0) then ls else cons l0 (remc c ls)
  end.

(* remove a list of candidates from another list *)
Fixpoint reml (l : list cand) ( r : list cand) : list cand :=
  match r with
  [] => l
  | r0 :: rs => reml (remove cand_eq_dec r0 l) rs
end.

Lemma remc_ok : forall c:cand, forall l:list cand, In c l -> eqe c (remc c l) l.
Proof.
  intros c l. induction l as [| l0 ls IHls].
  intro i. contradict i.
  intro i.
  assert (H: {l0=c} + {l0<>c}) by apply (cand_eq_dec l0 c).
  destruct H as [l0eqc | l0neqc ].
  replace (remc c (l0::ls)) with ls.
  unfold eqe.
  exists ([]: list cand). exists ls. split.
  auto. replace c with l0. auto.
  replace c with l0. unfold remc. destruct (cand_eq_dec l0 l0). trivial.
  contradict n. trivial.
  (* we must have that In c ls *)
  assert (Hin: l0 = c \/ In c ls) by apply (in_inv i).
  destruct Hin as [l0eqc | Hin ].
  contradict l0neqc. assumption.
  (* apply IH *)
  assert (eqe c (remc c ls) ls) by apply (IHls Hin).
  unfold eqe in H.
  replace (remc c (l0::ls)) with (l0::(remc c ls)).
  destruct H as [l1 H]. destruct H as [l2 H]. destruct H as [lft rgt].
  unfold eqe.
  exists (l0::l1). exists l2.
  split.
  transitivity (l0::(l1++l2)). congruence. auto.
  transitivity (l0::(l1 ++ [c] ++ l2)). congruence. auto.
  unfold remc.
  destruct (cand_eq_dec c l0). contradict l0neqc. symmetry. assumption. trivial.
Qed.

(* update piles of candidates in a list *)
Fixpoint upiles (p: cand -> list ballot) (t: cand -> Q) (m : list cand) : cand -> list ballot :=
  match m with
  [] => p
 | m0 :: ms => upiles (fun (c : cand) =>
        (if cand_eq_dec c m0 then (map (fun (b : ballot) =>
        (fst b, (snd b * ((t(m0)-qu)/t(m0)))%Q)) (p m0)) else p c)) t ms
  end.

(* empty the pile for one candidate and leave the rest unchanged *)
Definition emp (c: cand) (p: cand -> list ballot) : cand -> list ballot :=
  fun d => if (cand_eq_dec c d) then [] else p d.

(* proof of dec property *)
(* proof done rule by rule *)
Lemma dec_FT_count : forall p c : FT_Judgement,
count p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p.
  destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c.
  destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
   (* non final judgements *)
  unfold FT_m.
  simpl.
  unfold FT_wfo.
  rewrite -> wfo_aux.
  right. right.
  unfold count in Hr.
  destruct Hr as [ba [t [nt [p [np [bl [h [e H]]]]]]]].
  destruct H as [Heq1 [Hba [Hc Heq2]]].
  inversion Heq1.
  inversion Heq2. subst.
  split. reflexivity.
  split. reflexivity.
  simpl.
  destruct ba.
  contradict Hba. reflexivity.
  simpl. intuition.
  (* final jugements *)
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT_transfer : forall p c : FT_Judgement,
transfer p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p.
  destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c.
  destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
   (* non final judgements *)
  unfold FT_m.
  simpl.
  unfold FT_wfo.
  rewrite -> wfo_aux.
  right. left.
  unfold transfer in Hr.
  destruct Hr as [nba [t [p [np [bl [nbl [h [e H]]]]]]]].
  destruct H as [Heq1 [ Hinh [l [c [Hex Heq2]]]]].
  inversion Heq1.
  inversion Heq2. subst.
  split. reflexivity.
  destruct Hex as [Hex1 [Hex2 Hex]].
  rewrite -> Hex1, Hex2.
  intuition.
  (* final jugements *)
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT_elect : forall p c : FT_Judgement,
elect p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p.
  destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c.
  destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
   (* non final judgements *)
  unfold FT_m.
  simpl.
  unfold FT_wfo.
  rewrite -> wfo_aux.
  left.
  unfold elect in Hr.
  destruct Hr as [ba [t [p [np [bl [nbl [h [nh [e [ne H]]]]]]]]]].
  destruct e.
  destruct ne.
  destruct H as [Heq1 [k [Hc Heq2]]].
  inversion Heq1.
  inversion Heq2. subst.
  destruct Hc as [H1 [H2 [H3 [H4 [H5 H6]]]]].
  unfold leqe in H5.
  unfold eqe in H5.
  destruct k.
  contradict H1. reflexivity.
  specialize (H5 c).
  assert (In c (c :: k)).
  intuition.
  specialize (H5 H).
  destruct H5 as [l1 [l2 [h1 h2]]].
  subst.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT_elim : forall p c : FT_Judgement,
elim p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p.
  destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c.
  destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
   (* non final judgements *)
  unfold FT_m.
  simpl.
  unfold FT_wfo.
  rewrite -> wfo_aux.
  left.
  unfold elim in Hr.
  destruct Hr as [nba [t [p [np [e [h [nh H]]]]]]].
  destruct H as [Heq1 [Hl [Hc [c [Ht Heq2]]]]].
  inversion Heq1.
  inversion Heq2.
  subst.
  destruct Ht as [H1 [H2 H3]].
  unfold eqe in H2.
  destruct H2 as [l1 [l2 [h1 h2]]].
  subst.
  rewrite -> app_length. rewrite -> app_length. rewrite -> app_length.
  intuition.
  (* final jugements *)
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT_hwin : forall p c : FT_Judgement,
hwin p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c. destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
  unfold hwin in Hr.
  destruct Hr as [w [ba [t [p [bl [e [h H]]]]]]].
  destruct H as [Heq1 [Hl [Hw Heq2]]].
  inversion Heq2.
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  (* final jugements *)
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT_ewin : forall p c : FT_Judgement,
ewin p c -> forall (ep : ~ FT_final p) (ec : ~ FT_final c),
FT_wfo (FT_m (mk_nfj FT_Judgement FT_final c ec))
  (FT_m (mk_nfj FT_Judgement FT_final p ep)).
Proof.
  intros p c Hr ep ec.
  destruct p. destruct p as [[[[[ba1 t1] p1] bl1] e1] h1].
  destruct c. destruct p as [[[[[ba2 t2] p2] bl2] e2] h2].
  unfold hwin in Hr.
  destruct Hr as [w [ba [t [p [bl [e [h H]]]]]]].
  destruct H as [Heq1 [Hl [Hw Heq2]]].
  inversion Heq2.
  unfold FT_final in ec.
  contradict ec.
  exists l. reflexivity.
  (* final jugements *)
  unfold FT_final in ep.
  contradict ep.
  exists l. reflexivity.
Qed.

Lemma dec_FT : dec FT_Judgement FT_final FT_WFO FT_wfo FT_m FTR.
Proof.
  unfold dec.
  intros r Hin p c Hr ep ec.
  destruct Hin.
  rewrite <- H in Hr.
  apply dec_FT_count.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_FT_transfer.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_FT_elect.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_FT_elim.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_FT_hwin.
  assumption.
  destruct H.
  rewrite <- H in Hr.
  apply dec_FT_ewin.
  assumption.
  destruct H.
Qed.

Fixpoint insert_sorted (A : Type) (a : A) (f : A -> Q) (l : list A) : list A :=
 match l with
   | [] => [a]
   | b :: ls =>
      match (Qcompare (f a) (f b)) with
      | Eq => a::l
      | Lt => a::l
      | Gt => b::(insert_sorted A a f ls)
      end
 end.

(* proof of app property --- still under construction ---
Lemma app_FT : app FT_Judgement FT_final FTR.
Proof.
  unfold app.
  intros p Hnf.
  destruct p.
  destruct p as [[[[[ba t] p] bl] e] h].
  destruct ba.
  (* case ba = [] *)
  destruct (le_lt_dec (length (proj1_sig e) + length h) st) as [ les1 | les2 ].
       (* case length (proj1_sig e) + length h <= st *)
  exists hwin.
  exists (winners ((proj1_sig e) ++ h)).
  split.
  unfold FTR. intuition.
  unfold hwin.
  exists (proj1_sig e ++ h); exists []; exists t; exists p; exists bl; exists e; exists h.
  split. reflexivity.
  split. assumption.
  split. reflexivity.
  reflexivity.
       (* case length (proj1_sig e) + length h > st *)
   assert (existsT m : list cand,
    (forall d : cand, In d m <-> In d h /\ (t(d) >= qu)%Q)
    /\ (ordered t m)).
  apply (over_quota cand h t qu cand_eq_dec).
  destruct X as [l [Hl1 Hl2]].
  destruct l.
               (* case l = [] (-> forall In c h, t(c) < qu) *)
  assert (forall d, In d h -> (t(d)<qu)%Q).
  intros d H.
  specialize (Hl1 d).
  destruct Hl1 as [Hla Hlb].
  assert (~ (In d h /\ (qu <= t d)%Q)).
  contradict Hlb.
  intuition.
  intuition.
  destruct bl.
                  (* case bl = [] *)
  exists elim.
  assert (min:  (h = []) + (existsT d, (In d h /\ (forall e, In e h -> (t d <= t e)%Q)))).
  apply list_min .
  destruct min as [emp | non_emp].
  destruct h.
          (* case h = [] *)
  contradict les2. destruct e. simpl. intuition.
          (* case h = c :: h *)
  symmetry in emp.
  assert ([] <> c :: h).
  apply nil_cons.
  contradiction.
  destruct non_emp as [d [Hin Hmin]].
  exists (state ((p d), t, (emp d p), [], e, (remc d h))).
  split.
  unfold FTR.
  intuition.
  unfold elim.
  exists (p d); exists t; exists p; exists (emp d p); exists e; exists h; exists (remc d h).
  split. reflexivity.
  split. assumption.
  split. assumption.
  exists d.
  split. split. assumption.
  split. apply (remc_ok d h Hin).
  split. reflexivity.
  split. unfold emp. destruct (cand_eq_dec d d). reflexivity. contradict n. reflexivity.
  intros d0 Hneq.
  unfold emp. destruct (cand_eq_dec d d0). subst. contradict Hneq. reflexivity. reflexivity.
  reflexivity.
                  (* case bl = c :: bl *)
  exists transfer.
  exists (state ((p c), t, (emp c p), bl, e, h)).
  split. unfold FTR. intuition.
  unfold transfer.
  exists (p c). exists t. exists p. exists (emp c p). exists (c :: bl). exists bl. exists h. exists e.
  split. reflexivity.
  split. assumption.
  exists bl. exists c.
  split. split. reflexivity.
  split. reflexivity.
  split. reflexivity.
  split. unfold emp. destruct (cand_eq_dec c c). reflexivity. contradict n. reflexivity.
  intros d Hneq.
  unfold emp. destruct (cand_eq_dec c d). subst. contradict Hneq. reflexivity. reflexivity.
  reflexivity.
               (* case l = c :: k  (-> ~(forall In c h, t(c) < qu)) *)
  exists elect. (* construct new pile *)
      (* l *)
  destruct (le_lt_dec (length (c::l) + (length (proj1_sig e))) (st)).
  rewrite <- app_length in l0.
  exists (state ([], t, (upiles p t (c :: l)), (bl ++ (c :: l)),
  (@exist (list cand) (fun l => length l <= st) ((c :: l) ++ (proj1_sig e)) (l0)),
  (reml (c :: l) h))).
  split.
  unfold FTR. intuition.
  unfold elect.
  exists []. exists t. exists p. exists (upiles p t (c :: l)). exists bl.
  exists ( bl ++ c :: l). exists h. exists (reml h (c :: l)). exists e.  exists (@exist (list cand) (fun l => length l <= st) ((c :: l) ++ (proj1_sig e)) (l0)).
  destruct e. split.
  reflexivity.
  exists (c :: l).
  split.
  split. intuition. symmetry in H.  contradict H. apply nil_cons.
  split. simpl. simpl in l0.
  rewrite -> app_length in l0. intuition.
  split. intro c0. specialize (Hl1 c0). destruct Hl1.  assumption.
  split. assumption.
  split. admit.
  split. admit.
  split. intros c0 H. unfold upiles. destruct (cand_eq_dec c0 c). subst. *)

End unionCount.


(****************************************************************************

          IEEE754  :  Closest2Prop

          Laurent Thery

  ******************************************************************************)
Require Export ClosestProp.
Section F2.
Variable b : Fbound.
Variable precision : nat.

Let radix := 2%Z.

Let FtoRradix := FtoR radix.
Local Coercion FtoRradix : float >-> R.

Theorem TwoMoreThanOne : (1 < radix)%Z.
unfold radix in |- *; red in |- *; simpl in |- *; auto.
Qed.
Hint Resolve TwoMoreThanOne.
Hypothesis precisionNotZero : 1 < precision.
Hypothesis pGivesBound : Zpos (vNum b) = Zpower_nat radix precision.

Theorem FevenNormMin : Even (nNormMin 2%nat precision).
unfold nNormMin in |- *.
generalize precisionNotZero; case precision.
intros H'2; Contradict H'2; auto with zarith.
intros n; case n.
intros H'2; Contradict H'2; auto with zarith.
intros n0 H'2; replace (pred (S (S n0))) with (S n0).
apply EvenExp; auto.
exists 1%Z; ring.
simpl in |- *; auto.
Qed.

Theorem EvenFNSuccFNSuccMid :
 forall p : float,
 Fbounded b p ->
 FNeven b radix precision p ->
 Fminus radix (FNSucc b radix precision (FNSucc b radix precision p))
   (FNSucc b radix precision p) = Fminus radix (FNSucc b radix precision p) p
 :>R.
intros p H' H'0.
unfold FtoRradix in |- *; apply FNSuccFNSuccMid; auto.
red in |- *; intros H'1;
 absurd (FNodd b radix precision (FNSucc b radix precision p));
 auto.
unfold FNodd in |- *.
rewrite FcanonicFnormalizeEq; auto with float arith.
unfold Fodd in |- *.
rewrite H'1.
apply EvenNOdd; auto with float arith.
apply FevenNormMin; auto with float arith.
apply FNevenSuc; auto.
red in |- *; intros H'1;
 absurd (FNodd b radix precision (FNSucc b radix precision p));
 auto with float arith.
unfold FNodd in |- *.
rewrite FcanonicFnormalizeEq; auto with float arith.
unfold Fodd in |- *.
rewrite H'1.
apply EvenNOdd.
apply EvenOpp; apply FevenNormMin.
Qed.

Theorem AScal2 :
 forall p : float, Float (Fnum p) (Fexp p + 1%nat) = (radix * p)%R :>R.
intros p.
unfold FtoRradix in |- *; rewrite FvalScale; auto.
replace (powerRZ radix 1%nat) with (INR 2); [ idtac | simpl in |- *; unfold radix; ring ];
 auto.
Qed.
End F2.
Hint Resolve FevenNormMin: float.


From mathcomp Require Import ssreflect eqtype.
From deriving Require Import deriving.

Require Import type.

Time Definition sum_indDef L R := [indDef for sum_rect L R].
Canonical sum_indType L R := IndType (sum L R) (sum_indDef L R).

Time Definition sum_eqMixin (L R : eqType) := [derive eqMixin for sum L R].
Canonical sum_eqType (L R : eqType) := EqType (sum L R) (sum_eqMixin L R).


(* This code is copyrighted by its authors; it is distributed under  *)
(* the terms of the LGPL license (see LICENSE and description files) *)

Require Import Reals.

Definition Rlog (r b : R) : R := ln r / ln b.


Require Export CatSem.CAT.monad_haskell.
Require Export CatSem.CAT.orders.
Require Import Coq.Relations.Relations.

Set Implicit Arguments.
Unset Strict Implicit.

Inductive F (V : Ord) : Type :=
   | Var : V -> F V
   | Ar : F V -> F V -> F V.

Inductive FPO V : relation (F V) :=
   | arp1 : forall s s' t, FPO s s' -> FPO (Ar s' t) (Ar s t)
   | arp2 : forall s t t', FPO t t' -> FPO (Ar s t) (Ar s t')
(*   | arp : forall s t s' t', FPO s s' -> FPO t t' -> FPO (Ar s' t) (Ar s t') *)
   | varp: forall v v', v << v' -> FPO (Var v) (Var v').

Definition FP (V : Ord) := Clos_RT_1n_prf ((@FPO V)).

Instance FPP (V : Ord)  : PO_obj_struct (F V) := {
  POprf := FP V
}.

Definition FF (V : Ord) : Ord := Build_PO_obj (FPP V).

Lemma Ar2 V (s t t' : FF V) : t << t' -> (Ar s t) << (Ar s t').
Proof.
  intro.
  generalize dependent s.
  induction H.
  reflexivity.
  intros.
  constructor 2 with (Ar s y).
  Focus 2. apply IHclos_refl_trans_1n.
  constructor.
  auto.
Qed.

Lemma nnn V (x z : F V):
clos_refl_trans_1n  (F V) (@FPO V) z  x ->
     clos_refl_trans_n1 (F V) (@FPO V) z x.
Proof.
intro H.
apply clos_rt_rtn1.
apply clos_rt1n_rt.
auto.
Qed.

Lemma kkk V (x z : F V):
clos_refl_trans_n1  (F V) (@FPO V) z  x ->
     clos_refl_trans_1n (F V) (@FPO V) z x.
Proof.
intro H.
apply clos_rt_rt1n.
apply clos_rtn1_rt.
auto.
Qed.

Lemma Ar1 V (s s' t : FF V) : s' << s -> (Ar s t) << (Ar s' t).
Proof.
  intro.
  generalize dependent t.
  induction H.
  reflexivity.
  intros.
  simpl.
  apply kkk.
  constructor 2 with (Ar y t).
  constructor.
  auto.
  apply nnn.
  apply IHclos_refl_trans_1n.
Qed.

Lemma bla : forall V (s t s' t' : FF V) , s << s' -> t << t' ->
      Ar s' t << Ar s t'.
Proof.
  intros.
  transitivity (Ar s' t').
  apply Ar2.
  auto.
  apply Ar1.
  auto.
Qed.

Fixpoint subst (V W : Ord) (f : V ---> FF W) (x : FF V) : FF W :=
  match x with
  | Var v => f v
  | Ar s t => Ar (subst f s) (subst f t)
 end .

Program Instance _subst V W (f : V ---> FF W) : PO_mor_struct (subst f).
Next Obligation.
Proof.
  unfold Proper; red.
  intros.
  induction H.
  reflexivity.
  transitivity (subst f y);
  auto.
  clear dependent z.
  induction H; simpl.
  apply Ar1.
  auto.
  apply Ar2.
  auto.
  apply f.
  auto.
Qed.

Definition subst_po V W (f : V ---> FF W) := Build_PO_mor (_subst V W f).

Program Instance var V : PO_mor_struct (b:=FF V) (@Var V).
Next Obligation.
Proof.
  unfold Proper; red.
  intros.
  apply clos_refl_trans_1n_contains.
  constructor.
  auto.
Qed.

Definition VAR V := Build_PO_mor (var V).

Program Instance FFMonad : Monad_struct FF := {
  weta := VAR;
  kleisli := subst_po
}.
Next Obligation.
Proof.
  unfold Proper; red.
  simpl.
  intros f g H x.
  induction x; simpl.
  auto.
  rewrite IHx1.
  rewrite IHx2.
  auto.
Qed.
Next Obligation.
Proof.
  induction x;
  simpl.
  auto.
  rewrite IHx2.
  rewrite IHx1.
  auto.
Qed.
Next Obligation.
Proof.
  induction x;
  simpl.
  auto.
  rewrite IHx1.
  rewrite IHx2.
  auto.
Qed.

(*
Definition subst V W f : FF V ---> FF W

  Focus 2.
  apply f.
  auto.

  simpl.

  transitivit

  apply clos_refl_trans_1n_contains.
  simpl.
  apply
  apply clos_refl_trans_1n_contains.
  induction H.
  simpl in *.
  constructor;
  auto.
  simpl.
  apply PO_mor_monotone.
  apply f.
  apply
  constructor.
  apply clos_refl_trans_1n_contains.
  constructor.
  app
  simpl.
  apply reflexivity.
  apply PO_refl.
  simpl.

*)


Require Import Crypto.Arithmetic.PrimeFieldTheorems.
Require Import Crypto.Specific.montgomery64_2e322m2e161m1_6limbs.Synthesis.

(* TODO : change this to field once field isomorphism happens *)
Definition opp :
  { opp : feBW_small -> feBW_small
  | forall a, phiM_small (opp a) = F.opp (phiM_small a) }.
Proof.
  Set Ltac Profiling.
  Time synthesize_opp ().
  Show Ltac Profile.
Time Defined.

Print Assumptions opp.


Goal forall X Y : Prop, (forall Z : Prop, (X -> Y -> Z) -> Z) -> X.

Proof.
  intros X Y A.
  apply A.
  intros B C.
  exact B.
Qed.


Require Export kat_alph atoms ProofIrrelevance.

Ltac inv c := inversion c;try (discriminate||congruence).
Ltac gl_goal := split;red;intros.

Module GS(X:KAT_Alph).

  Export X.

  Notation atom := (ord (pow2 ntests)).
  Notation prim_test := (ord (ntests)).
  Definition AtSy := (atom*Z)%type.

  (** * Type of tests *)

  Inductive test : Type :=
  | ba0 : test
  | ba1 : test
  | baV : prim_test -> test
  | baN : test -> test
  | baAnd : test -> test -> test
  | baOr : test -> test -> test.

  Notation "`` x" := (baV x)(at level 35).
  Notation "! x" := (baN x)(at level 35).
  Infix "`+" := baOr(at level 45).
  Infix "`·" := baAnd(at level 45).

  (** Burocratic definitions and properties that make [test] and odered typ *)

  Inductive test_eq : test -> test -> Prop :=
  | test_eq_ba0 : test_eq ba0 ba0
  | test_eq_ba1 : test_eq ba1 ba1
  | test_eq_baV : forall x y, x === y -> test_eq (baV x) (baV y)
  | test_eq_baN : forall x y:test, test_eq x y -> test_eq (baN x) (baN y)
  | test_eq_baAnd : forall x₁ x₂ y₁ y₂, test_eq x₁ x₂ -> test_eq y₁ y₂ ->
                                        test_eq (baAnd x₁ y₁) (baAnd x₂ y₂)
  | test_eq_baOr : forall x₁ x₂ y₁ y₂, test_eq x₁ x₂ -> test_eq y₁ y₂ ->
                                        test_eq (baOr x₁ y₁) (baOr x₂ y₂).

  Proposition leibniz_test:
    forall x y:test,
      test_eq x  y -> x = y.
  Proof.
    induction 1;intros;subst;auto.
    apply ord_Eq_unique in H.
    rewrite H.
    reflexivity.
  Qed.

  Inductive test_lt : test -> test -> Prop :=
    test_lt_ba0_ba1 : test_lt ba0 ba1
  | test_lt_ba0_baV : forall y1 , test_lt ba0 (baV y1)
  | test_lt_ba0_baN : forall y1 : test, test_lt ba0 (baN y1)
  | test_lt_ba0_baAnd : forall y1 y2 : test, test_lt ba0 (baAnd y1 y2)
  | test_lt_ba0_baOr : forall y1 y2 : test, test_lt ba0 (baOr y1 y2)
  | test_lt_ba1_baV : forall y1 , test_lt ba1 (baV y1)
  | test_lt_ba1_baN : forall y1 : test, test_lt ba1 (baN y1)
  | test_lt_ba1_baAnd : forall y1 y2 : test, test_lt ba1 (baAnd y1 y2)
  | test_lt_ba1_baOr : forall y1 y2 : test, test_lt ba1 (baOr y1 y2)
  | test_lt_baV_1 : forall x1 y1 , x1 <<< y1 -> test_lt (baV x1) (baV y1)
  | test_lt_baV_baN : forall x1 (y1 : test), test_lt (baV x1) (baN y1)
  | test_lt_baV_baAnd : forall x1 (y1 y2 : test),
                        test_lt (baV x1) (baAnd y1 y2)
  | test_lt_baV_baOr : forall x1 (y1 y2 : test),
                       test_lt (baV x1) (baOr y1 y2)
  | test_lt_baN_1 : forall x1 y1 : test,
                    test_lt x1 y1 -> test_lt (baN x1) (baN y1)
  | test_lt_baN_baAnd : forall x1 y1 y2 : test,
                        test_lt (baN x1) (baAnd y1 y2)
  | test_lt_baN_baOr : forall x1 y1 y2 : test, test_lt (baN x1) (baOr y1 y2)
  | test_lt_baAnd_1 : forall x1 y1 x2 y2 : test,
                      test_lt x1 y1 -> test_lt (baAnd x1 x2) (baAnd y1 y2)
  | test_lt_baAnd_2 : forall x1 y1 x2 y2 : test,
                      test_eq x1 y1 ->
                      test_lt x2 y2 -> test_lt (baAnd x1 x2) (baAnd y1 y2)
  | test_lt_baAnd_baOr : forall x1 x2 y1 y2 : test,
                         test_lt (baAnd x1 x2) (baOr y1 y2)
  | test_lt_baOr_1 : forall x1 y1 x2 y2 : test,
                     test_lt x1 y1 -> test_lt (baOr x1 x2) (baOr y1 y2)
  | test_lt_baOr_2 : forall x1 y1 x2 y2 : test,
                     test_eq x1 y1 ->
                     test_lt x2 y2 -> test_lt (baOr x1 x2) (baOr y1 y2).

  Fixpoint test_cmp (x y : test) : comparison :=
  match x with
  | ba0 =>
      match y with
      | ba0 => Eq
      | ba1 => Lt
      | baV _ => Lt
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | ba1 =>
      match y with
      | ba0 => Gt
      | ba1 => Eq
      | baV _ => Lt
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baV x1 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV y1 => ord_Cmp (ntests) x1 y1
      | baN _ => Lt
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baN x1 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN y1 => test_cmp x1 y1
      | baAnd _ _ => Lt
      | baOr _ _ => Lt
      end
  | baAnd x1 x2 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN _ => Gt
      | baAnd y1 y2 =>
          match test_cmp x1 y1 with
          | Eq => test_cmp x2 y2
          | Lt => Lt
          | Gt => Gt
          end
      | baOr _ _ => Lt
      end
  | baOr x1 x2 =>
      match y with
      | ba0 => Gt
      | ba1 => Gt
      | baV _ => Gt
      | baN _ => Gt
      | baAnd _ _ => Gt
      | baOr y1 y2 =>
          match test_cmp x1 y1 with
          | Eq => test_cmp x2 y2
          | Lt => Lt
          | Gt => Gt
          end
      end
  end.

  Functional Scheme test_cmp_ind := Induction for test_cmp Sort Prop.
  Functional Scheme test_cmp_rec := Induction for test_cmp Sort Set.

  Global Instance test_eq_refl : Reflexive test_eq.
  Proof.
    repeat red;intros;induction x;try constructor;auto.
  Qed.

  Global Instance test_eq_symm : Symmetric test_eq.
  Proof.
    repeat red.
    induction 1;try reflexivity.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
    - constructor;auto.
  Qed.

  Global Instance test_eq_trans : Transitive test_eq.
  Proof.
    repeat red.
    induction x;intros.
    - inv H.
    - inv H.
    - inv H;subst;inv H0;subst;constructor.
      rewrite H2;auto.
    - inv H;subst. inv H0;subst. constructor;eauto.
    - inv H;subst;inv H0;subst. constructor;eauto.
    - inv H;subst;inv H0;subst. constructor;eauto.
  Qed.

  Global Instance test_eq_Equiv : Equivalence test_eq.
  Proof.
    constructor;autotc.
  Qed.

  (** Auxiliary lemmas for test_cmp *)
  Lemma test_cmp_eq_leibniz :
    forall x y, test_cmp x y = Eq -> x = y.
  Proof.
    intros.
    functional induction (test_cmp x y);
      first [reflexivity|discriminate|auto].
    apply compare_2 in H.
    apply ord_Eq_unique in H.
    rewrite H;auto.
    apply IHc in H;subst;auto.
    apply IHc in e1;apply IHc0 in H;subst;auto.
    apply IHc in e1;apply IHc0 in H;subst;auto.
  Qed.

  Lemma test_cmp_lt :
    forall x y, test_cmp x y = Lt -> test_lt x y.
  Proof.
    intros.
    functional induction (test_cmp x y);
      try (now constructor||discriminate).
    apply compare_1 in H;auto.
    constructor;auto.
    constructor.
    apply IHc;auto.
    apply IHc0 in H.
    apply test_lt_baAnd_2;auto.
    apply test_cmp_eq_leibniz in e1;subst;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
    apply test_cmp_eq_leibniz in e1;subst.
    apply test_lt_baOr_2;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
  Qed.

  Lemma test_cmp_gt :
    forall x y, test_cmp x y = Gt -> test_lt y x.
  Proof.
    intros.
    functional induction (test_cmp x y);
      try (now constructor||discriminate).
    apply compare_3 in H;auto.
    constructor;auto.
    constructor.
    apply IHc;auto.
    apply IHc0 in H.
    apply test_lt_baAnd_2;auto.
    apply test_cmp_eq_leibniz in e1;subst;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
    apply test_cmp_eq_leibniz in e1;subst.
    apply test_lt_baOr_2;auto.
    reflexivity.
    constructor.
    apply IHc;auto.
  Qed.

  Proposition test_lt_not_refl :
    forall y, ~test_lt y y.
  Proof.
    intros;intro.
    dependent induction H.
    order.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
    elim IHtest_lt.
  Qed.

  Global Program Instance testUOrd : UsualOrderedType test :=
    { SOT_lt := test_lt ; SOT_cmp := test_cmp}.
  Next Obligation.
    constructor.
    - repeat red;induction x;intros;destruct y;try now(inv H);try now(inv H0;constructor).
      + inv H0;subst;econstructor;inv H;subst;transitivity o0;auto.
      + inv H0;subst;inv H;try (now constructor);subst. constructor. eapply IHx;eauto.
      + inv H0;subst;inv H;subst.
        * constructor;eapply IHx1;eauto.
        * constructor;apply leibniz_test in H5;subst;assumption.
        * { apply leibniz_test in H3;subst;inv H;subst.
            - constructor;eauto.
            - constructor;eauto.
          }
        * apply leibniz_test in H6;subst. apply test_lt_baAnd_2;auto;eapply IHx2;eauto.
        * { inv H0;subst;inv H;subst.
            - constructor;eauto.
            - apply leibniz_test in H5;subst. constructor;eauto.
          }
        * { inv H;subst.
            - apply leibniz_test in H4;subst. constructor.
            - constructor.
          }
      + inv H;subst.
        * { inv H0;subst.
            - constructor;eapply IHx1;eauto.
            - apply leibniz_test in H4. subst. apply test_lt_baOr_1;auto.
          }
        * { apply leibniz_test in H4;subst. inv H0;subst.
            - constructor;auto.
            - apply test_lt_baOr_2;eauto.
          }
    - intros;intro. rewrite H0 in H. pose proof test_lt_not_refl y. contradiction.
  Defined.
  Next Obligation.
    - case_eq(test_cmp x y);constructor.
     + apply test_cmp_eq_leibniz;auto.
     + apply test_cmp_lt;auto.
     + apply test_cmp_gt;auto.
  Defined.

  (** * Boolean evaluation of tests wrt. atoms. *)

  (* begin show *)
  Function evalT(a:atom)(x:test){struct x} : bool :=
    match x with
      | ba0 => false
      | ba1 => true
      | baV b => nth_bit _ a b
      | baN a1 => negb (evalT a a1)
      | baAnd a1 a2 => andb (evalT a a1) (evalT a a2)
      | baOr a1 a2 => orb (evalT a a1) (evalT a a2)
    end.
  (* end show*)

  (** * Type [gstring] of Guarded Strings *)

  Inductive gstring : Type :=
  | gs_end  : atom -> gstring
  | gs_conc : atom -> Z -> gstring -> gstring.

  (** Bureocratic definitions and properties that characterize [gstring] as an ordered type *)

  Inductive gstring_eq : gstring -> gstring -> Prop :=
    gstring_eq_gs_end : forall x1 y1 : atom,
                        x1 === y1 -> gstring_eq (gs_end x1) (gs_end y1)
  | gstring_eq_gs_conc : forall (x1 y1 : atom) (x2 y2 : Z) (x3 y3 : gstring),
                         x1 === y1 ->
                         x2 === y2 ->
                         gstring_eq x3 y3 ->
                         gstring_eq (gs_conc x1 x2 x3) (gs_conc y1 y2 y3).

  Hint Constructors gstring_eq.

  Structure can_gstring :=
    { Gs :> Type;
      Gs_end : atom -> Gs;
      Gs_c : atom -> Z -> Gs -> Gs;
      Gs_Eq : Gs -> Gs -> Prop;
      Gs_Eq_equiv : Equivalence Gs_Eq;
      Gs_Eq_def : forall x y:Gs, Gs_Eq x y -> x = y
    }.

  Proposition leibniz_gstring :
    forall x y:gstring, gstring_eq x y -> x = y.
  Proof.
    induction 1.
    - ord_eq_un H;auto.
    - ord_eq_un H;inv H0.
  Qed.

  Instance gstring_eq_equiv : Equivalence gstring_eq.
  Proof.
    constructor;repeat red.
    - intros;induction x;auto.
    - induction 1;inv H;auto.
    - induction x.
      + intros;inv H;subst;ord_eq_un H2;auto.
      + intros;inv H;subst;ord_eq_un H4;inv H6;subst;inv H0;subst;
        constructor;auto;eapply IHx;eauto.
  Qed.

  Inductive gstring_lt : gstring -> gstring -> Prop :=
    gstring_lt_gs_end_1 : forall x1 y1 : atom,
                            x1 <<< y1 -> gstring_lt (gs_end x1) (gs_end y1)
  | gstring_lt_gs_end_gs_conc : forall (x1 y1 : atom)
                                       (y2 : Z) (y3 : gstring),
                                  gstring_lt (gs_end x1) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_1 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 <<< y1 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_2 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 === y1 ->
                             x2 <<< y2 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3)
  | gstring_lt_gs_conc_3 : forall (x1 y1 : atom) (x2 y2 : Z)
                                  (x3 y3 : gstring),
                             x1 === y1 ->
                             x2 === y2 ->
                             gstring_lt x3 y3 ->
                             gstring_lt (gs_conc x1 x2 x3) (gs_conc y1 y2 y3).

  Instance gstring_lt_trans : Transitive gstring_lt.
  Proof.
    repeat red.
    induction x;intros.
    - inv H;inv H0;subst.
      + injection H5;intros;subst;constructor;order.
      + constructor.
      + constructor.
      + constructor.
      + constructor.
    - inv H;subst;inv H0;subst.
      + constructor;order.
      + ord_eq_un H6. constructor;order.
      + ord_eq_un H4. inv H7;subst;constructor;order.
      + ord_eq_un H5. constructor;auto.
      + ord_eq_un H5;inv H7;subst;constructor 4;order.
      + ord_eq_un H5;inv H4;inv H8;subst;constructor 4;order.
      + ord_eq_un H4;inv H6;subst;constructor;auto.
      + ord_eq_un H4;inv H6;inv H8;subst;constructor 4;auto.
      + ord_eq_un H4;inv H6;inv H5;inv H9;subst;constructor 5;auto;
        eapply IHx;eauto.
  Qed.

  Fixpoint gstring_cmp (x y : gstring) : comparison :=
    match x with
      | gs_end x1 =>
        match y with
          | gs_end y1 => ord_Cmp _ x1 y1
          | gs_conc _ _ _ => Lt
        end
      | gs_conc x1 x2 x3 =>
        match y with
          | gs_end _ => Gt
          | gs_conc y1 y2 y3 =>
            match ord_Cmp _ x1 y1 with
              | Eq =>
                match compare x2 y2 with
                  | Eq => gstring_cmp x3 y3
                  | Lt => Lt
                  | Gt => Gt
                end
              | Lt => Lt
              | Gt => Gt
            end
        end
    end.

  Functional Scheme gstring_cmp_ind := Induction for gstring_cmp Sort Prop.
  Functional Scheme gstring_cmp_rec := Induction for gstring_cmp Sort Set.

  Proposition gstring_cmp_eq_leibniz :
    forall x y, gstring_cmp x y = Eq -> x = y.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try discriminate.
    + apply compare_2 in H. ord_eq_un H;auto.
    + apply compare_2 in e1; apply compare_2 in e2.
      ord_eq_un e1. inv e2. subst. apply IHc in H;subst;reflexivity.
  Qed.

  Proposition gstring_cmp_lt :
    forall x y, gstring_cmp x y = Lt -> gstring_lt x y.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try (now (discriminate||constructor)).
    + apply compare_1 in H. constructor. order.
    + apply compare_2 in e1; apply compare_2 in e2;subst;inv e1;inv e2;subst.
      constructor 5;auto.
    + apply compare_2 in e1;apply compare_1 in e2;inv e1;subst;constructor 4;auto.
    + apply compare_1 in e1;constructor;auto.
  Qed.

  Proposition gstring_cmp_gt :
    forall x y, gstring_cmp x y = Gt -> gstring_lt y x.
  Proof.
    intros.
    functional induction (gstring_cmp x y);try (now (discriminate||constructor)).
    + apply compare_3 in H;constructor;auto.
    + apply compare_2 in e1; apply compare_2 in e2;subst;inv e1;inv e2;subst.
      constructor 5;auto.
    + apply compare_2 in e1;apply compare_3 in e2;inv e1;subst;constructor 4;auto.
    + apply compare_3 in e1;constructor;auto.
  Qed.

  Instance gstring_UOT : UsualOrderedType gstring :=
    { SOT_lt := gstring_lt ; SOT_cmp := gstring_cmp}.
  Proof.
    constructor;autotc.
    - induction 1;intros.
      + intro H0;inv H0;subst;order.
      + intro H0;inv H0.
      + intro H0;inv H0;subst;order.
      + intro H1;inv H1;subst;order.
      + intro H2;inv H2;subst;order.
    - intros. case_eq(gstring_cmp x y);intro;constructor.
      + apply gstring_cmp_eq_leibniz;auto.
      + apply gstring_cmp_lt;auto.
      + apply gstring_cmp_gt;auto.
  Defined.

  Lemma list_leibniz :
    forall l1 l2:list (atom*Z),
      l1 === l2 -> l1 = l2.
  Proof.
    induction 1;try congruence.
    normalize_notations.
    subst.
    destruct a;destruct a'.
    f_equal.
    destruct H.
    normalize_notations. clear H0. inv H1.
  Qed.

  (** * First and last atom of a guarded string *)

  Fixpoint last gs :=
    match gs with
      | gs_end k => k
      | gs_conc _ _ k => last k
    end.
  Notation "↓ g" := (last g)(at level 44).

  Fixpoint first gs :=
    match gs with
      | gs_end k => k
      | gs_conc k _ _ => k
    end.
  Notation "↑ g" := (first g)(at level 44).

  Notation "⌜  a  , b ⌝:: v" := (gs_conc a b v)(at level 45).
  Notation "⌜  a ⌝" := (gs_end a)(at level 45).

  (** Two guarded strings are [compatible] if the last atom of the
      first guarded string is the same as the first atom of the
      second. *)

  Definition compatible gs1 gs2 := last gs1 = first gs2.
  Infix "≀" := (compatible)(at level 10).

  (** Properties of compatibility *)

  Lemma compatible_gs_conc :
    forall g1 g2 x xs,
      compatible g1 g2 -> compatible (gs_conc x xs g1) g2.
  Proof.
    auto.
  Qed.

  Lemma compatible_last :
    forall g1 g2,
      compatible g1 g2 -> compatible (gs_end (last g1)) g2.
  Proof.
    auto.
  Qed.

  Definition compatible_rewrite (gs1 gs2:gstring)(H:compatible gs1 gs2)
              (x:atom)(k:Z)(t:gstring)(L:gs1 = gs_conc x k t) :
    compatible t gs2.
  Proof.
    subst.
    auto.
  Defined.

  (** * Fusion product for guarded strings. *)

  Fixpoint fusion_prod gs1 gs2 (H:compatible gs1 gs2) : gstring :=
    match gs1 as x return gs1=x -> gstring with
      | gs_end _ =>
          fun H:(gs1 = gs_end _) => gs2
      | gs_conc k s t =>
          fun H0:(gs1 = gs_conc k s t) =>
            gs_conc k s (fusion_prod t gs2 (compatible_rewrite gs1 gs2 H k s t H0))
    end (refl_equal gs1).

  Notation "a ⋄ b ( c )" := (fusion_prod a b c)(at level 45).

  (** Properties of fusion product. *)

  Lemma fusion_prod_compatible :
    forall a a0 s x y0 T0,
      compatible (gs_end a) (fusion_prod (gs_conc a0 s x) y0 T0) ->
      compatible (gs_end a) (gs_conc a0 s x).
  Proof.
    intros.
    simpl in H.
    unfold compatible in H.
    simpl in H.
    subst.
    unfold compatible.
    simpl.
    reflexivity.
  Qed.

  (** Decidability of the [compatible] predicate. *)

  Lemma compatible_dec :
    forall x y,
      {compatible x y}+{~compatible x y}.
  Proof.
    unfold compatible.
    induction x;simpl;auto with typeclass_instances.
    intros.
    destruct y;simpl;intros;
    (case_eq(compare o o0);intros;
    [apply compare_2 in H | apply compare_1 in H | apply compare_3 in H]);try auto;
    try (right;intro;subst;order).
  Qed.

  (** Some more properties about [fusion_prod] *)

  Lemma fusion_prod_head :
    forall a a0 s x H,
    fusion_prod (gs_end a) (gs_conc a0 s x) H = gs_conc a0 s x.
  Proof. auto. Qed.

  Lemma fusion_prod_ext :
    forall a y H,
      fusion_prod (gs_end a) y H = y.
  Proof. auto. Qed.

  Lemma fusion_prod_end :
    forall x0 a T,
      fusion_prod x0 (gs_end a) T = x0.
  Proof.
    induction x0;simpl;intros.
    -  unfold compatible in T;simpl in T;subst;auto.
    - f_equal;rewrite IHx0;auto.
  Qed.

  Lemma fusion_prod_fst :
    forall x y0 T0,
      first (fusion_prod x y0 T0) = first x.
  Proof. induction x;simpl;intros;auto. Qed.

  Lemma fusion_prod_gs_conc :
    forall a s x0 x y0 T0 T,
      exists t',
        fusion_prod (gs_conc a s x0) (fusion_prod x y0 T0) T =
        gs_conc a s (fusion_prod x0 (fusion_prod x y0 T0) t').
  Proof.
    intros.

    assert(compatible x0 (fusion_prod x y0 T0)).
    unfold compatible in T |- *.
    simpl in *.
    assumption.

    red in T;simpl in T.
    exists T;simpl;f_equal.
  Qed.

  Lemma fusion_prod_gs_conc_rev :
    forall a s x0 x y0 T0 T,
      exists t',
        gs_conc a s (fusion_prod x0 (fusion_prod x y0 T0) T) =
        fusion_prod (gs_conc a s x0) (fusion_prod x y0 T0) t'.
  Proof.
    induction x0.
    simpl.
    intros.
    eexists.
    red.
    simpl.
    red in T.
    simpl in T.
    assumption.
    f_equal.
    intros.
    unfold compatible in *.
    simpl in *.
    exists T.
    f_equal.
  Qed.

  Lemma fusion_prod_gs_generic :
    forall a s x0 z T,
      exists t',
        fusion_prod (gs_conc a s x0) z T =
        gs_conc a s (fusion_prod x0 z t').
  Proof.
    intros.
    simpl.
    eexists.
    f_equal.
  Qed.

  Lemma fusion_prod_proof_inj :
    forall x z T T',
      fusion_prod x z T = fusion_prod x z T'.
  Proof.
    induction x;simpl;intros.
    reflexivity.
    f_equal.
    unfold compatible in *;simpl in *.
    generalize(
      (compatible_rewrite (gs_conc o z x) z0 T o z x (eq_refl (gs_conc o z x)))).
    generalize(
      (compatible_rewrite (gs_conc o z x) z0 T' o z x (eq_refl (gs_conc o z x)))).
    intros.
    unfold compatible in c,c0.
    pose proof IHx z0 c0 c.
    assumption.
  Qed.

  Lemma fusion_prod_gs_generic_inv :
    forall a s x0 z t',
      exists T,
        gs_conc a s (fusion_prod x0 z t') =
        fusion_prod (gs_conc a s x0) z T.
  Proof.
    intros.
    assert(compatible (gs_conc a s x0) z).
    unfold compatible in *.
    simpl in *.
    assumption.
    simpl.
    exists H.
    f_equal.
    apply fusion_prod_proof_inj.
  Qed.

  Lemma last_fusion_prod :
    forall x0 x c,
    last (fusion_prod x0 x c) = last x.
  Proof.
    induction x0;intros.
    simpl.
    reflexivity.
    erewrite <- (IHx0 x _).
    simpl.
    f_equal.
  Qed.

  Lemma fusion_prod_end_gen :
    forall a s x0 x H,
      last (fusion_prod (gs_conc a s x0) x H) = last x.
  Proof.
    intros.
    simpl.
    generalize((compatible_rewrite (gs_conc a s x0) x H a s x0
           (eq_refl (gs_conc a s x0)))).
    intro.
    rewrite last_fusion_prod.
    reflexivity.
  Qed.

  Lemma fusion_prod_same_last :
    forall x t ,
       x = fusion_prod x (gs_end (last x)) t.
  Proof.
    induction x;intros.
    simpl.
    reflexivity.
    simpl.
    rewrite IHx at 1.
    reflexivity.
  Qed.

  Lemma fusion_product_assoc_left :
    forall x x0 y0 T0 T,
    exists T',
      exists T'',
        (fusion_prod x0 (fusion_prod x y0 T0) T) =
        (fusion_prod (fusion_prod x0 x T') y0 T'').
  Proof.
    induction x0;intros.
    destruct x.
    simpl in T.

    assert(compatible (gs_end o) (gs_end o0)).
    unfold compatible in *.
    rewrite T.
    symmetry.
    assumption.

    exists H.
    simpl.
    exists T0.
    reflexivity.

    pose proof fusion_prod_compatible o o0 z x y0 T0 T.
    exists H.

    assert(compatible (fusion_prod (gs_end o) (gs_conc o0 z x) H) y0).
    unfold compatible in *;simpl in *.
    assumption.

    rewrite fusion_prod_head.
    exists T0.
    unfold compatible in T,T0;simpl in T,T0.
    generalize T.
    rewrite T.
    intro.
    rewrite fusion_prod_ext.
    reflexivity.

    assert(compatible (gs_conc o z x0) x).
    apply compatible_last in T.
    simpl in T.
    unfold compatible in T.
    simpl in T.
    red.
    simpl.
    rewrite fusion_prod_fst in T.
    assumption.

    exists H.
    assert(compatible x0 (fusion_prod x y0 T0)).
    unfold compatible in H.
    unfold compatible.
    simpl in H.
    rewrite fusion_prod_fst.
    assumption.
    specialize IHx0 with y0 T0 H0.
    destruct IHx0.
    destruct H1.

    assert(compatible (fusion_prod (gs_conc o z x0) x H) y0).
    unfold compatible in *;simpl in *.
    generalize((compatible_rewrite (gs_conc o z x0) x H o z x0
           (eq_refl (gs_conc o z x0))));intro.
    rewrite last_fusion_prod.
    assumption.
    exists H2.
    simpl.
    assert(fusion_prod x0 (fusion_prod x y0 T0) H0 =
      (fusion_prod x0 (fusion_prod x y0 T0)
        (compatible_rewrite (gs_conc o z x0) (fusion_prod x y0 T0) T o z x0
           (eq_refl (gs_conc o z x0))))).
    apply fusion_prod_proof_inj.
    rewrite <- H3.
    rewrite H1.
    f_equal.
    generalize((compatible_rewrite
        (gs_conc o z
           (fusion_prod x0 x
              (compatible_rewrite (gs_conc o z x0) x H o z x0
                 (eq_refl (gs_conc o z x0))))) y0 H2 o z
        (fusion_prod x0 x
           (compatible_rewrite (gs_conc o z x0) x H o z x0
              (eq_refl (gs_conc o z x0))))
        (eq_refl
           (gs_conc o z
              (fusion_prod x0 x
                 (compatible_rewrite (gs_conc o z x0) x H o z x0
                    (eq_refl (gs_conc o z x0)))))))).
    intro.
    assert(fusion_prod x0 x x1 =
      fusion_prod x0 x
        (compatible_rewrite (gs_conc o z x0) x H o z x0
           (eq_refl (gs_conc o z x0)))).
    apply fusion_prod_proof_inj.
    revert c.
    rewrite <- H4.
    intros.
    apply fusion_prod_proof_inj.
  Qed.

  Lemma fusion_product_assoc_right :
    forall x x0 y0 T' T'',
    exists T0,
      exists T,
        (fusion_prod (fusion_prod x0 x T') y0 T'') =
        (fusion_prod x0 (fusion_prod x y0 T0) T).
  Proof.
    induction x0;intros.
    destruct x.
    simpl in T''.

    exists T''.
    assert(compatible (gs_end o) (fusion_prod (gs_end o0) y0 T'')).
    simpl.
    unfold compatible in *.
    simpl in *.
    subst.
    reflexivity.
    exists H.
    rewrite fusion_prod_ext.
    simpl.
    reflexivity.
    simpl in T''.
    exists T''.

    assert(compatible (gs_end o) (fusion_prod (gs_conc o0 z x) y0 T'')).
    unfold compatible.
    simpl.
    unfold compatible in T'.
    simpl in T'.
    assumption.
    exists H.

    rewrite fusion_prod_ext.
    simpl.
    reflexivity.

    assert(compatible x y0).
    unfold compatible in T'' |- *.
    rewrite fusion_prod_end_gen in T''.
    assumption.

    exists H.
    assert(compatible (gs_conc o z x0) (fusion_prod x y0 H)).
    unfold compatible.
    simpl.
    unfold compatible in T';simpl in T'.
    rewrite fusion_prod_fst.
    assumption.

    exists H0.
    assert(compatible x0 x).
    unfold compatible in T'.
    simpl in T'.
    apply T'.

    generalize T''.

    pose proof fusion_prod_gs_generic o z x0 _ H0.
    destruct H2.
    rewrite H2.
    pose proof fusion_prod_gs_generic o z x0 x T'.
    destruct H3.
    rewrite H3.
    intro.
    pose proof fusion_prod_gs_generic o z (fusion_prod x0 x x2) y0 T''0.
    destruct H4.
    rewrite H4.
    f_equal.
    pose proof IHx0 y0 x2 x3.
    destruct H5.
    destruct H5.
    rewrite H5.
    assert(fusion_prod x y0 x4 = fusion_prod x y0 H) by
      (apply fusion_prod_proof_inj).
    revert x5 H5.
    rewrite H6.
    intros.
    apply fusion_prod_proof_inj.
  Qed.

  Corollary fusion_prod_split_gs_end :
  forall x y a T,
    fusion_prod x y T = gs_end a ->
    x = gs_end a /\ y = gs_end a.
  Proof.
    induction x;intros.
    simpl in H;rewrite H in T.
    red in T;simpl in T.
    subst.
    split;auto.
    split.
    assert(compatible x y).
    apply T.
    pose proof IHx y a T.
    simpl in H.
    discriminate.
    assert(compatible x y).
    apply T.
    assert(fusion_prod x y T = gs_end a).
    revert H.
    induction x.
    simpl.
    intros.
    discriminate.
    simpl.
    intros.
    discriminate.
    apply IHx in H1.
    destruct H1;auto.
  Qed.

  Lemma blop :
      forall x0 y T a s x,
        fusion_prod x0 y T = gs_conc a s x ->
        (exists x',exists t',
                 x0 = gs_conc a s x' /\ fusion_prod x' y t' = x) \/
        (x0 = gs_end a /\ y = gs_conc a s x).
    Proof.
      induction x0;intros.
      simpl in *.
      right.
      split;auto.
      rewrite H in T.
      unfold compatible in T.
      simpl in T.
      subst;auto.
      simpl in H.
      injection H.
      intros.
      clear H.
      subst.
      left.
      exists x0.
      assert(compatible x0 y).
      unfold compatible in T |- *.
      simpl in T.
      assumption.
      exists H.
      split;auto.
      apply fusion_prod_proof_inj.
    Qed.

  (** Besides guarded strings, we also consider guarded sequences,
      which are lists of type [(atom*Z)]. Sequences can be mapped and
      extracted form a guarded string since sequences are guarded strings
      without their last atom.*)

  Notation seq := (list (atom*Z)).

  Fixpoint to_gstring (l:seq) (g:gstring) : gstring :=
    match l with
      | nil => g
      | x::xs => gs_conc (fst x) (snd x) (to_gstring xs g)
    end.

  Fixpoint from_gstring (g:gstring) : (list (atom*Z)) :=
    match g with
      | gs_end a => nil
      | gs_conc a p x => (a,p)::from_gstring x
    end.

  Lemma to_gstring_app :
    forall w1 w2 x,
      to_gstring (w1 ++ w2) x = to_gstring w1 (to_gstring w2 x).
  Proof.
    induction w1;simpl;intros.
    reflexivity.
    f_equal.
    rewrite IHw1.
    reflexivity.
  Qed.

  Lemma from_to_gstring :
    forall w,
      w = (to_gstring (from_gstring w) (gs_end (last w))).
  Proof.
    induction w;simpl;intros.
    reflexivity.
    rewrite <- IHw.
    reflexivity.
  Qed.

  Lemma from_string_correct :
    forall g,
      g = to_gstring (from_gstring g) (gs_end (last g)).
  Proof.
    induction g;intros.
    simpl.
    reflexivity.
    simpl.
    rewrite <- IHg.
    reflexivity.
  Qed.

End GS.


Require Import Functor.

(** * Interface of monads *)

(** As in Haskell, we define monads in terms of [ret] and [bind].
  However we want to be able to use the corresponding [Functor]
  instances both independently and in the context of monads.
  To permit this, instead of defining a generic [Functor] instance
  for all monads, we require a priori that monads be functors,
  then define the relationship between [fmap], [ret] and [bind]
  as the [monad_fmap] equation in the [Monad] class. This way,
  code need not depend on this module when they use, say, [option]
  as a simple [Functor] rather than a full-blown [Monad].
  In addition, [id] for instance is both a [Monad] and [Comonad],
  but we do not want to derive two separate instances of the
  corresponding [Functor]. *)

Class MonadOps (M: Type -> Type) `{Mfmap: FunctorOps M} := {
  ret {A}: A -> M A;
  bind {A B}: (A -> M B) -> M A -> M B
}.

Notation "'do' x <- M ; N" := (bind (fun x => N) M)
  (at level 200, x ident, M at level 100, N at level 200).

Class Monad (M: Type -> Type) `{Mops: MonadOps M}: Prop := {
  monad_functor :> Functor M;
  monad_fmap {A B} (f: A -> B):
    fmap f = bind (fun x => ret (f x));
  monad_ret_bind {A B} (f: A -> M B) (x: A):
    bind f (ret x) = f x;
  monad_bind_ret {A} (m: M A):
    bind ret m = m;
  monad_bind_bind {A B C} (f: B -> M C) (g: A -> M B) (m: M A):
    bind f (bind g m) = bind (fun x => bind f (g x)) m
}.

(** Using the theorem in [Monad], we can try to normalize monadic
  expressions to the form [x1 <- M1; x2 <- M2; ...; xn <- Mn]. *)
Hint Rewrite
    @monad_ret_bind
    @monad_bind_ret
    @monad_bind_bind
  using typeclasses eauto : monad.

(** Unfortunately, the [MonadOps] instance in [monad_fmap] cannot
  be obtained by unification when matching the left-hand side of
  the rewrite with the current goal. Since the [autorewrite] tactic
  does not do type class resolution, we cannot use [monad_fmap]
  as a rewrite rule. *)
Ltac monadNorm :=
  rewrite !monad_fmap; autorewrite with monad.

(** * Some instances *)

Section INSTANCES.
  (** ** [option] is a monad *)

  Global Instance option_monad_ops: MonadOps option := {
    bind A B f mx :=
      match mx with
        | Some a => f a
        | None => None
      end;
    ret := Some
  }.

  Global Instance option_monad: Monad option.
  Proof.
    split; intros; try destruct m; try reflexivity.
    typeclasses eauto.
  Qed.
End INSTANCES.


Set Implicit Arguments.
Unset Strict Implicit.

Require Export lci.

Require Import List.
Require Import Permutation.

Module AAC_tools.

Inductive list_sub : (list E) -> E -> Prop :=
  | sub_nil : forall x, list_sub nil x
  | sub_cons : forall x a t, inc a x -> list_sub t x -> list_sub (a::t) x
.

Fixpoint list_iter (op:E2) (def:E) (l: list E) := match l with
  | nil => def
  | x::nil => x
  | x::t => op x (list_iter op def t)
  end.

Lemma lci_list_inc : forall op x, is_lci op x -> forall def, inc def x ->
forall l, list_sub l x -> inc (list_iter op def l) x.
Proof.
ir. nin H1.
simpl. am.
simpl. destruct t.
am.
ap H. am. ap IHlist_sub.
am. am.
Qed.

Lemma lci_list_nonempty_inc : forall op x, is_lci op x -> forall def l, list_sub l x -> l<>nil -> inc (list_iter op def l) x.
Proof.
ir. nin H0.
ap False_rect;au.

nin H2.
simpl. am.
change (inc (op a (list_iter op def (a0::t))) x).
ap H. am.
ap IHlist_sub. am. uhg;ir. inversion H4.
Qed.

Lemma list_sub_concat : forall x l l', list_sub l x -> list_sub l' x -> list_sub (l++l') x.
Proof.
ir. nin H. simpl;am.
simpl. constructor. am.
au.
Qed.

Lemma concat_list_sub : forall x l l', list_sub (l ++ l') x -> A (list_sub l x) (list_sub l' x).
Proof.
intros x.
assert (forall l0, list_sub l0 x -> forall l l', l0 = l ++ l' ->
A (list_sub l x) (list_sub l' x)).

intros l0 H. nin H;ir.
destruct l;destruct l';simpl in H;try inversion H;simpl.
ee;constructor.

destruct l. simpl;ee. constructor.
simpl in H1. wr H1. constructor;am.

simpl in H1. inversion H1;subst.
cp (IHlist_sub l l' (eq_refl (l ++ l'))).
ee;au. constructor;am.

ir. eapply H. ap H0. tv.
Qed.

Definition force_nil : forall T:Type, list T.
ir. exact nil.
Defined.

Lemma Permutation_sub : forall x l, list_sub l x -> forall l', Permutation l l' -> list_sub l' x.
Proof.
ir. nin H0.
constructor.

inversion H;subst;constructor;au.

inversion H;subst. inversion H4;subst.
constructor;try am;constructor;am.

au.
Qed.

Ltac mk_iter_aux op a b l l' := match a with
  | op ?x ?a' => mk_iter_aux op a' b (x::l) l'
  | _ => match b with
    | op ?y ?b' => mk_iter_aux op a b' l (y::l')
    | _ => change (eq (list_iter op emptyset (rev (a::l))) (list_iter op emptyset (rev (b::l'))))
    end
  end.

Ltac mk_iter op := match goal with
  | |- eq ?a ?b => mk_iter_aux op a b (force_nil E) (force_nil E)
  | _ => assert True
  end.

(*step in solving Permutation (a::t) (l1++l1') by attempting to find an instance of a in l1'
and changing goal to (a::t) (l1 ++ a::l1')*)
Ltac Permchange a t l1 l1' := match l1' with
  | cons a ?t' => change (Permutation (a::t) (l1 ++ a::t'))
  | cons ?b ?t' => Permchange a t (l1 ++ (b::nil)) t'
  end.

(*assumes lists are syntactic permutations, pre-simplified ! may fail if List.app terms present*)
Ltac solve_list_perm := match goal with
  | |- Permutation ?l ?l' => try ap Permutation_refl;try (constructor;solve_list_perm);
match l with
  | cons ?a ?t => Permchange a t (force_nil E) l';ap Permutation_cons_app;simpl;solve_list_perm
  end
  end.

End AAC_tools.

Module AAC_all.
Export AAC_tools.

Lemma aac_perm_eq : forall op, (forall x y z, op x (op y z) = op (op x y) z) ->
(forall x y, op x y = op y x) ->
forall l l', Permutation l l' ->
forall e, list_iter op e l = list_iter op e l'.
Proof.
ir. nin H1.
tv.
destruct l.
assert (l' = nil).
ap Permutation_nil. am. subst. tv.
destruct l'.
assert (e0::l = nil). ap Permutation_nil.
ap Permutation_sym. am.
inversion H2.
transitivity (op x (list_iter op e (e0::l))).
tv. rw IHPermutation. tv.
destruct l. simpl.
au.
transitivity (op y (op x (list_iter op e (e0::l)))).
tv. rw H. rw (H0 y). wr H. tv.
etransitivity;au.
Qed.

Ltac aa_normb_all Ha := repeat wr Ha.

Ltac aac_to_perm_all Ha Hc := try reflexivity;
match type of Hc with
| (forall x y, ?op x y = ?op y x) => aa_normb_all Ha; mk_iter op; ap (aac_perm_eq Ha Hc);simpl
end.

Ltac aac_solve_all Ha Hc := aac_to_perm_all Ha Hc; solve_list_perm.

End AAC_all.

Module AAC_lci.
Export AAC_tools.

Lemma aac_perm_eq : forall op x, is_lci op x -> associative op x -> commutative op x ->
forall l l', list_sub l x -> Permutation l l' -> forall e,
list_iter op e l = list_iter op e l'.
Proof.
ir. cp (Permutation_sub H2 H3). nin H3.
tv.

destruct l as [nil | x1 t].
apply Permutation_nil in H3. subst.
tv.
destruct l' as [nil | x1' t'].
symmetry in H3. apply Permutation_nil in H3. inversion H3.

change (op x0 (list_iter op e (x1::t)) = op x0 (list_iter op e (x1'::t'))).
rw IHPermutation.
tv. inversion H2;subst;au.
inversion H4;subst;au.

destruct l.
simpl. inversion H2;subst.  inversion H8;subst. ap H1;au.

transitivity (op y (op x0 (list_iter op e (e0::l)))).
simpl;tv.
transitivity (op x0 (op y (list_iter op e (e0::l)))).
assert (inc x0 x). inversion H4;subst;au.
assert (inc y x). inversion H4;subst;au.
inversion H2;au.
assert (inc (list_iter op e (e0::l)) x).
ap lci_list_nonempty_inc. am. inversion H2;subst;inversion H10;subst;au.
uhg;ir. inversion H6.

transitivity (op (op y x0) (list_iter op e (e0::l))).
rw H0;au.
rw (H1 y H5 x0 H3). rw H0;au.

simpl. tv.

cp (Permutation_sub H2 H3_).
rw IHPermutation1. ap IHPermutation2.
am. am. am. am.
Qed.

Ltac solve_lci_inc Hlci := first [ ap Hlci; solve_lci_inc Hlci | am | tv].

Ltac aa_normb_lci Hlci Ha := try (wr Ha;[aa_normb_lci Hlci Ha | solve_lci_inc Hlci | solve_lci_inc Hlci | solve_lci_inc Hlci]).

Ltac uf_list_sub := simpl;match goal with
   | |- list_sub nil _ => constructor
   | |- list_sub _ _ => constructor;[idtac | uf_list_sub]
  end.

Ltac aac_to_perm_lci op Hlci Ha Hc := try reflexivity;
aa_normb_lci Hlci Ha; mk_iter op; ap (aac_perm_eq Hlci Ha Hc);simpl;[uf_list_sub | idtac]
.

Ltac aac_solve_lci op Hlci Ha Hc := aac_to_perm_lci op Hlci Ha Hc; simpl;try solve_list_perm
.

Ltac aac_solve_monoid Hmon Hc := match type of Hmon with
  | is_monoid ?op _ _ => aac_solve_lci op (and_P Hmon) (and_Q (and_Q Hmon)) Hc
  | is_group ?op _ _ =>  aac_solve_lci op (and_P Hmon) (and_P (and_Q (and_Q Hmon))) Hc
  end.

End AAC_lci.


(* 7. Hierarchies *)
(* 7.5 Linking a custom data type to the library *)

From mathcomp Require Import all_ssreflect.

(* Inductive windrose : Type := N | S | E | W. *)
Inductive windrose : predArgType := N | S | E | W.

Definition w2o (w : windrose) : 'I_4 :=
  match w with
  | N => inord 0
  | S => inord 1
  | E => inord 2
  | W => inord 3
  end.

Definition o2w (o : 'I_4) : option windrose :=
  match val o with
  | 0 => Some N
  | 1 => Some S
  | 2 => Some E
  | 3 => Some W
  | _ => None
  end.

Lemma pcan_wo4 : pcancel w2o o2w.
Proof.
    by case; rewrite /o2w /= inordK.
Qed.

Definition windrose_eqMixin := PcanEqMixin pcan_wo4.
Canonical windrose_eqType := EqType windrose windrose_eqMixin.
Definition windrose_choiceMixin := PcanChoiceMixin pcan_wo4.
Canonical windrose_choiceType := ChoiceType windrose windrose_choiceMixin.
Definition windrose_countMixin := PcanCountMixin pcan_wo4.
Canonical windrose_countType := CountType windrose windrose_countMixin.
Definition windrose_finMixin := PcanFinMixin pcan_wo4.
Canonical windrose_finType := FinType windrose windrose_finMixin.

(* predArgType にしないとエラーになる。 *)
Check (N != S) && (N \in windrose) && (#| windrose | == 4).

(* END *)


(** * Types: Type Systems *)

(** Our next major topic is _type systems_ -- static program
    analyses that classify expressions according to the "shapes" of
    their results.  We'll begin with a typed version of the simplest
    imaginable language, to introduce the basic ideas of types and
    typing rules and the fundamental theorems about type systems:
    _type preservation_ and _progress_.  In chapter [Stlc] we'll move
    on to the _simply typed lambda-calculus_, which lives at the core
    of every modern functional programming language (including
    Coq!). *)

Set Warnings "-notation-overridden,-parsing,-implicit-core-hint-db".
From Coq Require Import Arith.Arith.
From LF Require Import Maps.
From LF Require Import Imp.

From PLF Require Import Smallstep.

Hint Constructors multi.

(* ################################################################# *)
(** * Typed Arithmetic Expressions *)

(** To motivate the discussion of type systems, let's begin as
    usual with a tiny toy language.  We want it to have the potential
    for programs to go wrong because of runtime type errors, so we
    need something a tiny bit more complex than the language of
    constants and addition that we used in chapter [Smallstep]: a
    single kind of data (e.g., numbers) is too simple, but just two
    kinds (numbers and booleans) gives us enough material to tell an
    interesting story.

    The language definition is completely routine. *)

(* ================================================================= *)
(** ** Syntax *)

(** Here is the syntax, informally:

    t ::= tru
        | fls
        | test t then t else t
        | zro
        | scc t
        | prd t
        | iszro t

    And here it is formally: *)

Inductive tm : Type :=
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm
  | zro : tm
  | scc : tm -> tm
  | prd : tm -> tm
  | iszro : tm -> tm.

(** _Values_ are [tru], [fls], and numeric values... *)

Inductive bvalue : tm -> Prop :=
  | bv_tru : bvalue tru
  | bv_fls : bvalue fls.

Inductive nvalue : tm -> Prop :=
  | nv_zro : nvalue zro
  | nv_scc : forall t, nvalue t -> nvalue (scc t).

Definition value (t : tm) := bvalue t \/ nvalue t.

Hint Constructors bvalue nvalue.
Hint Unfold value.
Hint Unfold update.

(* ================================================================= *)
(** ** Operational Semantics *)

(** Here is the single-step relation, first informally...

                   -------------------------------                  (ST_TestTru)
                   test tru then t1 else t2 --> t1

                   -------------------------------                  (ST_TestFls)
                   test fls then t1 else t2 --> t2

                               t1 --> t1'
            ----------------------------------------------------       (ST_Test)
            test t1 then t2 else t3 --> test t1' then t2 else t3

                             t1 --> t1'
                         ------------------                             (ST_Scc)
                         scc t1 --> scc t1'

                           ---------------                           (ST_PrdZro)
                           prd zro --> zro

                         numeric value v1
                        -------------------                          (ST_PrdScc)
                        prd (scc v1) --> v1

                              t1 --> t1'
                         ------------------                             (ST_Prd)
                         prd t1 --> prd t1'

                          -----------------                        (ST_IszroZro)
                          iszro zro --> tru

                         numeric value v1
                      ----------------------                       (ST_IszroScc)
                      iszro (scc v1) --> fls

                            t1 --> t1'
                       ----------------------                         (ST_Iszro)
                       iszro t1 --> iszro t1'
*)

(** ... and then formally: *)

Reserved Notation "t1 '-->' t2" (at level 40).

Inductive step : tm -> tm -> Prop :=
  | ST_TestTru : forall t1 t2,
      (test tru t1 t2) --> t1
  | ST_TestFls : forall t1 t2,
      (test fls t1 t2) --> t2
  | ST_Test : forall t1 t1' t2 t3,
      t1 --> t1' ->
      (test t1 t2 t3) --> (test t1' t2 t3)
  | ST_Scc : forall t1 t1',
      t1 --> t1' ->
      (scc t1) --> (scc t1')
  | ST_PrdZro :
      (prd zro) --> zro
  | ST_PrdScc : forall t1,
      nvalue t1 ->
      (prd (scc t1)) --> t1
  | ST_Prd : forall t1 t1',
      t1 --> t1' ->
      (prd t1) --> (prd t1')
  | ST_IszroZro :
      (iszro zro) --> tru
  | ST_IszroScc : forall t1,
       nvalue t1 ->
      (iszro (scc t1)) --> fls
  | ST_Iszro : forall t1 t1',
      t1 --> t1' ->
      (iszro t1) --> (iszro t1')

where "t1 '-->' t2" := (step t1 t2).

Hint Constructors step.

(** Notice that the [step] relation doesn't care about whether the
    expression being stepped makes global sense -- it just checks that
    the operation in the _next_ reduction step is being applied to the
    right kinds of operands.  For example, the term [scc tru] cannot
    take a step, but the almost as obviously nonsensical term

       scc (test tru then tru else tru)

    can take a step (once, before becoming stuck). *)

(* ================================================================= *)
(** ** Normal Forms and Values *)

(** The first interesting thing to notice about this [step] relation
    is that the strong progress theorem from the [Smallstep] chapter
    fails here.  That is, there are terms that are normal forms (they
    can't take a step) but not values (because we have not included
    them in our definition of possible "results of reduction").  Such
    terms are _stuck_. *)

Notation step_normal_form := (normal_form step).

Definition stuck (t : tm) : Prop :=
  step_normal_form t /\ ~ value t.

Hint Unfold stuck.

(** **** Exercise: 2 stars, standard (some_term_is_stuck)  *)
Example some_term_is_stuck :
  exists t, stuck t.
Proof.
  exists (scc tru). unfold stuck. split.
  intros [t contra]. inversion contra; subst. inversion H0.
  intros contra. inversion contra. inversion H. inversion H; subst. inversion H1.
Qed.
(** [] *)

(** However, although values and normal forms are _not_ the same in
    this language, the set of values is a subset of the set of normal
    forms.  This is important because it shows we did not accidentally
    define things so that some value could still take a step. *)

(** **** Exercise: 3 stars, standard (value_is_nf)  *)
Lemma value_is_nf : forall t,
  value t -> step_normal_form t.
Proof.
  unfold step_normal_form.
  induction t; intros Hv [t' Ht]; try solve_by_inverts 2.
  + induction Ht; try solve_by_inverts 2.
    inversion Hv; subst. inversion H. inversion H; subst.
    assert (value t1) by auto. apply IHHt in H0. auto.
Qed.

(** (Hint: You will reach a point in this proof where you need to
    use an induction to reason about a term that is known to be a
    numeric value.  This induction can be performed either over the
    term itself or over the evidence that it is a numeric value.  The
    proof goes through in either case, but you will find that one way
    is quite a bit shorter than the other.  For the sake of the
    exercise, try to complete the proof both ways.)

    [] *)

(** **** Exercise: 3 stars, standard, optional (step_deterministic)

    Use [value_is_nf] to show that the [step] relation is also
    deterministic. *)

Theorem step_deterministic:
  deterministic step.
Proof with eauto.
  unfold deterministic. intros. generalize dependent y2.
  induction H; intros;
    try (inversion H0; subst; reflexivity || solve_by_invert).
  - inversion H0; subst; try solve_by_invert.
    assert (t1' = t1'0). apply IHstep. apply H5. subst. reflexivity.
  - inversion H0; subst. apply IHstep in H2; subst; reflexivity.
  - assert (value t1) by auto. apply value_is_nf in H1.
    unfold step_normal_form in H1. inversion H0; subst. reflexivity.
    inversion H3; subst. exfalso. apply H1. exists t1'0. apply H4.
  - inversion H0; subst. inversion H. assert (value y2) by auto.
    apply value_is_nf in H1. exfalso. apply H1. inversion H; subst.
    exists t1'0. assumption. apply IHstep in H2; subst. reflexivity.
  - inversion H0; subst. reflexivity. inversion H2; subst.
    assert (value t1) by auto. apply value_is_nf in H1. exfalso.
    apply H1. exists t1'0. assumption.
  - inversion H0; subst; try solve_by_invert. exfalso.
    inversion H; subst. assert (value t0) by auto.
    apply value_is_nf in H1. apply H1. exists t1'0. auto.
    apply IHstep in H2. subst. reflexivity.
Qed.
(** [] *)

(* ================================================================= *)
(** ** Typing *)

(** The next critical observation is that, although this
    language has stuck terms, they are always nonsensical, mixing
    booleans and numbers in a way that we don't even _want_ to have a
    meaning.  We can easily exclude such ill-typed terms by defining a
    _typing relation_ that relates terms to the types (either numeric
    or boolean) of their final results.  *)

Inductive ty : Type :=
  | Bool : ty
  | Nat : ty.

(** In informal notation, the typing relation is often written
    [|- t \in T] and pronounced "[t] has type [T]."  The [|-] symbol
    is called a "turnstile."  Below, we're going to see richer typing
    relations where one or more additional "context" arguments are
    written to the left of the turnstile.  For the moment, the context
    is always empty.

                           ---------------                     (T_Tru)
                           |- tru \in Bool

                          ---------------                      (T_Fls)
                          |- fls \in Bool

             |- t1 \in Bool    |- t2 \in T    |- t3 \in T
             --------------------------------------------     (T_Test)
                    |- test t1 then t2 else t3 \in T

                             --------------                    (T_Zro)
                             |- zro \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Scc)
                          |- scc t1 \in Nat

                            |- t1 \in Nat
                          -----------------                    (T_Prd)
                          |- prd t1 \in Nat

                            |- t1 \in Nat
                        --------------------                 (T_IsZro)
                        |- iszro t1 \in Bool
*)

Reserved Notation "'|-' t '\in' T" (at level 40).

Inductive has_type : tm -> ty -> Prop :=
  | T_Tru :
       |- tru \in Bool
  | T_Fls :
       |- fls \in Bool
  | T_Test : forall t1 t2 t3 T,
       |- t1 \in Bool ->
       |- t2 \in T ->
       |- t3 \in T ->
       |- test t1 t2 t3 \in T
  | T_Zro :
       |- zro \in Nat
  | T_Scc : forall t1,
       |- t1 \in Nat ->
       |- scc t1 \in Nat
  | T_Prd : forall t1,
       |- t1 \in Nat ->
       |- prd t1 \in Nat
  | T_Iszro : forall t1,
       |- t1 \in Nat ->
       |- iszro t1 \in Bool

where "'|-' t '\in' T" := (has_type t T).

Hint Constructors has_type.

Example has_type_1 :
  |- test fls zro (scc zro) \in Nat.
Proof.
  apply T_Test.
    - apply T_Fls.
    - apply T_Zro.
    - apply T_Scc.
       + apply T_Zro.
Qed.

(** (Since we've included all the constructors of the typing relation
    in the hint database, the [auto] tactic can actually find this
    proof automatically.) *)

(** It's important to realize that the typing relation is a
    _conservative_ (or _static_) approximation: it does not consider
    what happens when the term is reduced -- in particular, it does
    not calculate the type of its normal form. *)

Example has_type_not :
  ~ ( |- test fls zro tru \in Bool ).
Proof.
  intros Contra. solve_by_inverts 2.  Qed.

(** **** Exercise: 1 star, standard, optional (scc_hastype_nat__hastype_nat)  *)
Example scc_hastype_nat__hastype_nat : forall t,
  |- scc t \in Nat ->
  |- t \in Nat.
Proof.
  intros. inversion H; subst. assumption.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Canonical forms *)

(** The following two lemmas capture the fundamental property that the
    definitions of boolean and numeric values agree with the typing
    relation. *)

Lemma bool_canonical : forall t,
  |- t \in Bool -> value t -> bvalue t.
Proof.
  intros t HT [Hb | Hn].
  - assumption.
  - induction Hn; inversion HT; auto.
Qed.

Lemma nat_canonical : forall t,
  |- t \in Nat -> value t -> nvalue t.
Proof.
  intros t HT [Hb | Hn].
  - inversion Hb; subst; inversion HT.
  - assumption.
Qed.

(* ================================================================= *)
(** ** Progress *)

(** The typing relation enjoys two critical properties.  The first is
    that well-typed normal forms are not stuck -- or conversely, if a
    term is well typed, then either it is a value or it can take at
    least one step.  We call this _progress_. *)

(** **** Exercise: 3 stars, standard (finish_progress)  *)
Theorem progress : forall t T,
  |- t \in T ->
  value t \/ exists t', t --> t'.

(** Complete the formal proof of the [progress] property.  (Make sure
    you understand the parts we've given of the informal proof in the
    following exercise before starting -- this will save you a lot of
    time.) *)
Proof with auto.
  intros t T HT.
  induction HT...
  (* The cases that were obviously values, like T_Tru and
     T_Fls, were eliminated immediately by auto *)
  - (* T_Test *)
    right. inversion IHHT1; clear IHHT1.
    + (* t1 is a value *)
    apply (bool_canonical t1 HT1) in H.
    inversion H; subst; clear H.
      exists t2...
      exists t3...
    + (* t1 can take a step *)
      inversion H as [t1' H1].
      exists (test t1' t2 t3)...
  - destruct IHHT.
    + left. right. apply nv_scc. apply (nat_canonical t1 HT). auto.
    + right. destruct H as [t' H]. exists (scc t')...
  - destruct IHHT.
    + apply (nat_canonical t1 HT) in H. inversion H; subst.
      * right. exists zro...
      * right. exists t...
    + destruct H as [t' H]. right. exists (prd t')...
  - destruct IHHT.
    + right. apply (nat_canonical t1 HT) in H. inversion H; subst.
      * exists tru...
      * exists fls...
    + destruct H. right. exists (iszro x)...
Qed.

(** [] *)

(** **** Exercise: 3 stars, advanced (finish_progress_informal)

    Complete the corresponding informal proof: *)

(** _Theorem_: If [|- t \in T], then either [t] is a value or else
    [t --> t'] for some [t']. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].  By the IH, either [t1] is a value or else [t1] can step
      to some [t1'].

      - If [t1] is a value, then by the canonical forms lemmas
        and the fact that [|- t1 \in Bool] we have that [t1]
        is a [bvalue] -- i.e., it is either [tru] or [fls].
        If [t1 = tru], then [t] steps to [t2] by [ST_TestTru],
        while if [t1 = fls], then [t] steps to [t3] by
        [ST_TestFls].  Either way, [t] can step, which is what
        we wanted to show.

      - If [t1] itself can take a step, then, by [ST_Test], so can
        [t].

    - If the rule is T_Scc, then t = scc t1 with t1 in Nat and t in Nat.
      By the induction hypothesis,
      - t1 is either a value, and it's a Nat, in which case
        scc t1 is a value by the nv_scc constructor
      - or t1 can take a step to some t. By ST_Scc, (scc t1) can take
        a step to (scc t).

        ...

 *)
(* Do not modify the following line: *)
Definition manual_grade_for_finish_progress_informal : option (nat*string) := None.
(** [] *)

(** This theorem is more interesting than the strong progress theorem
    that we saw in the [Smallstep] chapter, where _all_ normal forms
    were values.  Here a term can be stuck, but only if it is ill
    typed. *)

(* ================================================================= *)
(** ** Type Preservation *)

(** The second critical property of typing is that, when a well-typed
    term takes a step, the result is also a well-typed term. *)

(** **** Exercise: 2 stars, standard (finish_preservation)  *)
Theorem preservation : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.

(** Complete the formal proof of the [preservation] property.  (Again,
    make sure you understand the informal proof fragment in the
    following exercise first.) *)

Proof with auto.
  intros t t' T HT HE.
  generalize dependent t'.
  induction HT;
         (* every case needs to introduce a couple of things *)
         intros t' HE;
         (* and we can deal with several impossible
            cases all at once *)
         try solve_by_invert.
    - (* T_Test *) inversion HE; subst; clear HE.
      + (* ST_TESTTru *) assumption.
      + (* ST_TestFls *) assumption.
      + (* ST_Test *) apply T_Test; try assumption.
        apply IHHT1; assumption.
    - inversion HE; subst...
    - inversion HE; subst... inversion HT; auto.
    - inversion HE; subst...
Qed.
(** [] *)

(** **** Exercise: 3 stars, advanced (finish_preservation_informal)

    Complete the following informal proof: *)

(** _Theorem_: If [|- t \in T] and [t --> t'], then [|- t' \in T]. *)

(** _Proof_: By induction on a derivation of [|- t \in T].

    - If the last rule in the derivation is [T_Test], then [t = test t1
      then t2 else t3], with [|- t1 \in Bool], [|- t2 \in T] and [|- t3
      \in T].

      Inspecting the rules for the small-step reduction relation and
      remembering that [t] has the form [test ...], we see that the
      only ones that could have been used to prove [t --> t'] are
      [ST_TestTru], [ST_TestFls], or [ST_Test].

      - If the last rule was [ST_TestTru], then [t' = t2].  But we
        know that [|- t2 \in T], so we are done.

      - If the last rule was [ST_TestFls], then [t' = t3].  But we
        know that [|- t3 \in T], so we are done.

      - If the last rule was [ST_Test], then [t' = test t1' then t2
        else t3], where [t1 --> t1'].  We know [|- t1 \in Bool] so,
        by the IH, [|- t1' \in Bool].  The [T_Test] rule then gives us
        [|- test t1' then t2 else t3 \in T], as required.

    - (* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_finish_preservation_informal : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, standard (preservation_alternate_proof)

    Now prove the same property again by induction on the
    _evaluation_ derivation instead of on the typing derivation.
    Begin by carefully reading and thinking about the first few
    lines of the above proofs to make sure you understand what
    each one is doing.  The set-up for this proof is similar, but
    not exactly the same. *)

Theorem preservation' : forall t t' T,
  |- t \in T ->
  t --> t' ->
  |- t' \in T.
Proof with eauto.
  intros. generalize dependent T.
  induction H0; intros; inversion H; subst...
  - inversion H0; subst...
  - inversion H0; subst. inversion H3...
  - inversion H0...
  - inversion H0...
Qed.

(** [] *)

(** The preservation theorem is often called _subject reduction_,
    because it tells us what happens when the "subject" of the typing
    relation is reduced.  This terminology comes from thinking of
    typing statements as sentences, where the term is the subject and
    the type is the predicate. *)

(* ================================================================= *)
(** ** Type Soundness *)

(** Putting progress and preservation together, we see that a
    well-typed term can never reach a stuck state.  *)

Definition multistep := (multi step).
Notation "t1 '-->*' t2" := (multistep t1 t2) (at level 40).

Corollary soundness : forall t t' T,
  |- t \in T ->
  t -->* t' ->
  ~(stuck t').
Proof.
  intros t t' T HT P. induction P; intros [R S].
  destruct (progress x T HT); auto.
  apply IHP.  apply (preservation x y T HT H).
  unfold stuck. split; auto.   Qed.

(* ================================================================= *)
(** ** Additional Exercises *)

(** **** Exercise: 2 stars, standard, recommended (subject_expansion)

    Having seen the subject reduction property, one might
    wonder whether the opposity property -- subject _expansion_ --
    also holds.  That is, is it always the case that, if [t --> t']
    and [|- t' \in T], then [|- t \in T]?  If so, prove it.  If
    not, give a counter-example.  (You do not need to prove your
    counter-example in Coq, but feel free to do so.)
*)

Theorem subject_expansion: ~(forall T t t',
  t --> t' ->
  |- t' \in T ->
  |- t \in T).
Proof with eauto.
 intros contra.
 assert (test tru tru zro --> tru)...
 apply (contra Bool) in H. solve_by_inverts 2. auto.
Qed.

(* Do not modify the following line: *)
Definition manual_grade_for_subject_expansion : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (variation1)

    Suppose that we add this new rule to the typing relation:

      | T_SccBool : forall t,
           |- t \in Bool ->
           |- scc t \in Bool

   Which of the following properties remain true in the presence of
   this rule?  For each one, write either "remains true" or
   else "becomes false." If a property becomes false, give a
   counterexample.
      - Determinism of [step]
            remain true
      - Progress
            remain true
      - Preservation
            remain true?
*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation1 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard (variation2)

    Suppose, instead, that we add this new rule to the [step] relation:

      | ST_Funny1 : forall t2 t3,
           (test tru t2 t3) --> t3

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
      determinism become false (test tru tru fls) can yield both tru
      and fls)
      progress remains true
      preservation remains true
*)
(* Do not modify the following line: *)
Definition manual_grade_for_variation2 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 2 stars, standard, optional (variation3)

    Suppose instead that we add this rule:

      | ST_Funny2 : forall t1 t2 t2' t3,
           t2 --> t2' ->
           (test t1 t2 t3) --> (test t1 t2' t3)

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
      determinisme remains true
      progress remains true?
      preservation remains true
      eager evaluation of t2

    [] *)

(** **** Exercise: 2 stars, standard, optional (variation4)

    Suppose instead that we add this rule:

      | ST_Funny3 :
          (prd fls) --> (prd (prd fls))

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
(* FILL IN HERE *)

    [] *)

(** **** Exercise: 2 stars, standard, optional (variation5)

    Suppose instead that we add this rule:

      | T_Funny4 :
            |- zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
      determinism remains true
      progress remains true
      preservation becomes false,
      |- prd zro in Nat -> (prd zro --> zro) -> |- prd zro in Bool

    [] *)

(** **** Exercise: 2 stars, standard, optional (variation6)

    Suppose instead that we add this rule:

      | T_Funny5 :
            |- prd zro \in Bool

   Which of the above properties become false in the presence of
   this rule?  For each one that does, give a counter-example.
(* FILL IN HERE *)

    [] *)

(** **** Exercise: 3 stars, standard, optional (more_variations)

    Make up some exercises of your own along the same lines as
    the ones above.  Try to find ways of selectively breaking
    properties -- i.e., ways of changing the definitions that
    break just one of the properties and leave the others alone.
*)
(* FILL IN HERE

    [] *)

(** **** Exercise: 1 star, standard (remove_prdzro)

    The reduction rule [ST_PrdZro] is a bit counter-intuitive: we
    might feel that it makes more sense for the predecessor of [zro] to
    be undefined, rather than being defined to be [zro].  Can we
    achieve this simply by removing the rule from the definition of
    [step]?  Would doing so create any problems elsewhere?

(* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_remove_predzro : option (nat*string) := None.
(** [] *)

(** **** Exercise: 4 stars, advanced (prog_pres_bigstep)

    Suppose our evaluation relation is defined in the big-step style.
    State appropriate analogs of the progress and preservation
    properties. (You do not need to prove them.)

    Can you see any limitations of either of your properties?  Do they
    allow for nonterminating commands?  Why might we prefer the
    small-step semantics for stating preservation and progress?

(* FILL IN HERE *)
*)
(* Do not modify the following line: *)
Definition manual_grade_for_prog_pres_bigstep : option (nat*string) := None.
(** [] *)

(* Thu Feb 7 20:09:24 EST 2019 *)