Require Import FinTypes.

Definition Cardinality (F: finType) := | elem F |.

(** Dupfreeness *)
(* Proofs about dupfreeness *)

Lemma dupfree_countOne (X: eqType) (A: list X) : (forall x, count A x <= 1) -> dupfree A.
Proof.
  induction A.
  - constructor.
  - intro H. constructor.
    + cbn in H.  specialize (H a). deq a. assert (count A a = 0) by omega. now apply countZero.
    + apply IHA. intro x. specialize (H x). cbn in H. dec; omega.
Qed.

Lemma dupfree_elements (X: finType) : dupfree (elem X).
Proof.
  destruct X as [X [A AI]]. assert (forall x, count A x <= 1) as H'.
  {
    intro x. specialize (AI x). omega.
  }
  now apply dupfree_countOne.
Qed.

Lemma dupfree_length (X: finType) (A: list X) : dupfree A -> |A| <= Cardinality X.
Proof.
  unfold Cardinality.  intros D.
  rewrite <- (dupfree_card D). rewrite <- (dupfree_card (dupfree_elements X)).
  apply card_le. apply allSub.
Qed.

Lemma disjoint_concat X (A: list (list X)) (B: list X) : (forall C, C el A -> disjoint B C) -> disjoint B (concat A).
Proof.
  intros H. induction A.
  - cbn. auto.
  - cbn. apply disjoint_symm. apply disjoint_app. split; auto using disjoint_symm.
Qed.

Lemma dupfree_concat (X: Type) (A: list (list X)) : (forall B, B el A -> dupfree B) /\ (forall B C, B <> C -> B el A -> C el A -> disjoint B C) -> dupfree A -> dupfree (concat A).
Proof.
  induction A.
  - constructor.
  - intros [H H'] D. cbn. apply dupfree_app.
    + apply disjoint_concat. intros C E. apply H'; auto. inv D. intro G; apply H2. now subst a.
    + now apply H.
    + inv D; apply IHA; auto.
Qed.

(* (** Proofs about Cardinality *) *)

(* Lemma Card_positiv (X: finType) (x:X) : Cardinality X > 0. *)
(* Proof. *)
(*   pose proof (elem_spec x).  unfold Cardinality.  destruct (elem X). *)
(*   - contradiction H. *)
(*   - cbn. omega. *)
(* Qed.  *)

(* Lemma Cardinality_card_eq (X: finType): card (elem X) = Cardinality X. *)
(* Proof. *)
(*   apply dupfree_card. apply dupfree_elements. *)
(* Qed. *)

(* Lemma card_upper_bound (X: finType) (A: list X): card A <= Cardinality X. *)
(* Proof. *)
(*  rewrite <-  Cardinality_card_eq. apply card_le. apply allSub. *)
(* Qed.   *)

(* Lemma injective_dupfree (X: finType) (Y: Type) (A: list X) (f: X -> Y) : injective f -> dupfree (getImage f). *)
(* Proof. *)
(*   intro inj. unfold injective in inj. *)
(*   unfold getImage. apply dupfree_map. *)
(*   - firstorder. *)
(*   - apply dupfree_elements. *)
(* Qed. *)

(* Theorem pidgeonHole_inj (X Y: finType) (f: X -> Y) (inj: injective f): Cardinality X <= Cardinality Y. *)
(* Proof. *)
(*   rewrite <- (getImage_length f). apply dupfree_length. apply (injective_dupfree (elem X) inj). *)
(* Qed. *)

(* Lemma surj_sub (X Y: finType) (f: X -> Y) (surj: surjective f): elem Y <<= getImage f. *)
(* Proof. *)
(* intros y E. specialize (surj y). destruct surj as [x H]. subst y. apply getImage_in. *)
(* Qed. *)

(* Theorem pidgeonHole_surj (X Y: finType) (f: X -> Y) (surj: surjective f): Cardinality X >= Cardinality Y. *)
(* Proof. *)
(*   rewrite <- (getImage_length f). rewrite <- Cardinality_card_eq. *)
(*     pose proof (card_le (surj_sub surj)) as H. pose proof (card_length_leq (getImage f)) as H'. omega. *)
(* Qed. *)

(* Lemma eq_iff (x y: nat) : x >= y /\ x <= y -> x = y. *)
(* Proof. *)
(*   omega. *)
(* Qed. *)

(* Corollary pidgeonHole_bij (X Y: finType) (f: X -> Y) (bij: bijective f): *)
(*   Cardinality X = Cardinality Y. *)
(* Proof. *)
(*   destruct bij as [inj surj]. apply eq_iff. split. *)
(*   - now eapply pidgeonHole_surj. *)
(*   - eapply pidgeonHole_inj; eauto. *)
(* Qed.     *)

(* Lemma Prod_Card (X Y: finType) : Cardinality (X (x) Y) = Cardinality X * Cardinality Y. *)
(* Proof. *)
(*   cbn.  unfold prodLists. unfold Cardinality. induction (elem X).  *)
(*   - reflexivity. *)
(*   - cbn. rewrite app_length. rewrite IHl. f_equal. apply map_length. *)
(* Qed.     *)

(* Lemma Option_Card (X: finType) : Cardinality (? X) = S(Cardinality X). *)
(* Proof. *)
(*   cbn. now rewrite map_length. *)
(* Qed. *)

(* Lemma SumCard (X Y: finType) : Cardinality (finType_sum X Y) = Cardinality X + Cardinality Y. *)
(* Proof. *)
(*   unfold Cardinality. cbn. rewrite app_length. unfold toSumList1, toSumList2. now  repeat rewrite map_length. *)
(* Qed. *)

(* Lemma extPow_length X Y L P: |@extensionalPower X Y L P| = | L |. *)
(* Proof. *)
(*   induction L. *)
(*   -  reflexivity. *)
(*   - simpl. f_equal. apply IHL. *)
(* Qed. *)

(* Lemma concat_map_length (X: Type) (A: list X) (B: list (list X)) : *)
(* | concat (map (fun x => map (cons x) B) A) |= |A| * |B|. *)
(* Proof. *)
(*   induction A. *)
(*   - reflexivity. *)
(*   - cbn. rewrite app_length. rewrite map_length. congruence. *)
(* Qed.     *)

(* Lemma images_length Y (A: list Y) n : |images A n| = (|A| ^ n)%nat. *)
(* Proof. *)
(*   induction n. *)
(*   - reflexivity. *)
(*   - cbn. rewrite concat_map_length.  now rewrite IHn. *)
(* Qed. *)

(* Lemma Vector_Card (X Y: finType): Cardinality (Y ^ X) = (Cardinality Y ^ (Cardinality X ))%nat. *)
(* Proof. *)
(*   cbn. rewrite extPow_length. now rewrite images_length. *)
(* Qed. *)


Require Export D.

(** 2 stars (and_assoc)  *)
(** In the following proof, notice how the _nested pattern_ in the
    [destruct] breaks the hypothesis [H : P /\ (Q /\ R)] down into
    [HP: P], [HQ : Q], and [HR : R].  Finish the proof from there: *)

Theorem and_assoc : forall P Q R : Prop,
  P /\ (Q /\ R) -> (P /\ Q) /\ R.
Proof.
  intros P Q R H.
  destruct H as [HP [HQ HR]].
  apply conj. apply conj. apply HP. apply HQ. apply HR.
Qed.


(** The following axiom systems are used to formalize
    Euclid's proofs of Euclid's Elements.OriginalProofs.statements. *)

(** First, we define an axiom system for neutral geometry,
    i.e. geometry without continuity axioms nor parallel postulate.
 *)

Class euclidean_neutral :=
{
  Point : Type;
  Circle : Type;
  Cong : Point -> Point -> Point -> Point -> Prop;
  BetS : Point -> Point -> Point -> Prop;
  PA : Point;
  PB : Point;
  PC : Point;
  CI : Circle -> Point -> Point -> Point -> Prop;
  eq := @eq Point;
  neq A B := ~ eq A B;
  TE A B C := ~ (neq A B /\ neq B C /\ ~ BetS A B C);
  nCol A B C := neq A B /\ neq A C /\ neq B C /\ ~ BetS A B C /\ ~ BetS A C B /\ ~ BetS B A C;
  Col A B C := (eq A B \/ eq A C \/ eq B C \/ BetS B A C \/ BetS A B C \/ BetS A C B);
  Cong_3 A B C a b c := Cong A B a b /\ Cong B C b c /\ Cong A C a c;
  TS P A B Q := exists X, BetS P X Q /\ Col A B X /\ nCol A B P;
  Triangle A B C := nCol A B C;

  OnCirc B J := exists X Y U, CI J U X Y /\ Cong U B X Y;
  InCirc P J := exists X Y U V W, CI J U V W /\ (eq P U \/ (BetS U Y X /\ Cong U X V W /\ Cong U P U Y));
  OutCirc P J := exists X U V W, CI J U V W /\ BetS U X P /\ Cong U X V W;

  cn_congruencetransitive :
   forall B C D E P Q, Cong P Q B C -> Cong P Q D E -> Cong B C D E;
  cn_congruencereflexive :
   forall A B, Cong A B A B;
  cn_equalityreverse :
   forall A B, Cong A B B A;
  cn_sumofparts :
   forall A B C a b c, Cong A B a b -> Cong B C b c -> BetS A B C -> BetS a b c -> Cong A C a c;
  cn_stability :
   forall A B, ~ neq A B -> eq A B;
  axiom_circle_center_radius :
   forall A B C J P, CI J A B C -> OnCirc P J -> Cong A P B C;
  axiom_lower_dim : nCol PA PB PC;
  axiom_betweennessidentity :
   forall A B, ~ BetS A B A;
  axiom_betweennesssymmetry :
   forall A B C, BetS A B C -> BetS C B A;
  axiom_innertransitivity :
   forall A B C D,
    BetS A B D -> BetS B C D -> BetS A B C;
  axiom_connectivity :
   forall A B C D,
    BetS A B D -> BetS A C D -> ~ BetS A B C -> ~ BetS A C B ->
    eq B C;
  axiom_nocollapse :
   forall A B C D, neq A B -> Cong A B C D -> neq C D;
  axiom_5_line :
   forall A B C D a b c d,
    Cong B C b c -> Cong A D a d -> Cong B D b d ->
    BetS A B C -> BetS a b c -> Cong A B a b ->
    Cong D C d c;
  postulate_Pasch_inner :
   forall A B C P Q,
    BetS A P C -> BetS B Q C -> nCol A C B ->
    exists X, BetS A X Q /\ BetS B X P;
  postulate_Pasch_outer :
   forall A B C P Q,
    BetS A P C -> BetS B C Q -> nCol B Q A ->
    exists X, BetS A X Q /\ BetS B P X;
  postulate_Euclid2 : forall A B, neq A B -> exists X, BetS A B X;
  postulate_Euclid3 : forall A B, neq A B -> exists X, CI X A A B;
}.

(** Second, we enrich the axiom system with line-circle
     and circle-circle continuity axioms.
    Those two axioms state that we allow ruler and compass
    constructions.
*)

Class euclidean_neutral_ruler_compass `(Ax : euclidean_neutral) :=
{
  postulate_line_circle :
   forall A B C K P Q,
    CI K C P Q -> InCirc B K -> neq A B ->
    exists X Y, Col A B X /\ BetS A B Y /\ OnCirc X K /\ OnCirc Y K /\ BetS X B Y;
  postulate_circle_circle :
   forall C D F G J K P Q R S,
    CI J C R S -> InCirc P J ->
    OutCirc Q J -> CI K D F G ->
    OnCirc P K -> OnCirc Q K ->
    exists X, OnCirc X J /\ OnCirc X K
}.

(** Third, we introduce the famous fifth postulate of Euclid,
    which ensures that the geometry is
    Euclidean (i.e. not hyperbolic).
 *)

Class euclidean_euclidean `(Ax : euclidean_neutral_ruler_compass) :=
{
  postulate_Euclid5 :
   forall a p q r s t,
    BetS r t s -> BetS p t q -> BetS r a q ->
    Cong p t q t -> Cong t r t s -> nCol p q s ->
    exists X, BetS p a X /\ BetS s q X
}.

(** Last, we enrich the axiom system with axioms for equality of areas. *)

Class area `(Ax : euclidean_euclidean) :=
{
  EF : Point -> Point -> Point -> Point -> Point -> Point -> Point -> Point -> Prop;
  ET : Point -> Point -> Point -> Point -> Point -> Point -> Prop;
  axiom_congruentequal :
   forall A B C a b c, Cong_3 A B C a b c -> ET A B C a b c;
  axiom_ETpermutation :
   forall A B C a b c,
    ET A B C a b c ->
    ET A B C b c a /\
    ET A B C a c b /\
    ET A B C b a c /\
    ET A B C c b a /\
    ET A B C c a b;
  axiom_ETsymmetric :
   forall A B C a b c, ET A B C a b c -> ET a b c A B C;
  axiom_EFpermutation :
   forall A B C D a b c d,
   EF A B C D a b c d ->
     EF A B C D b c d a /\
     EF A B C D d c b a /\
     EF A B C D c d a b /\
     EF A B C D b a d c /\
     EF A B C D d a b c /\
     EF A B C D c b a d /\
     EF A B C D a d c b;
  axiom_halvesofequals :
   forall A B C D a b c d, ET A B C B C D ->
                           TS A B C D -> ET a b c b c d ->
                           TS a b c d -> EF A B D C a b d c -> ET A B C a b c;
  axiom_EFsymmetric :
   forall A B C D a b c d, EF A B C D a b c d ->
                           EF a b c d A B C D;
  axiom_EFtransitive :
   forall A B C D P Q R S a b c d,
     EF A B C D a b c d -> EF a b c d P Q R S ->
     EF A B C D P Q R S;
  axiom_ETtransitive :
   forall A B C P Q R a b c,
    ET A B C a b c -> ET a b c P Q R -> ET A B C P Q R;
  axiom_cutoff1 :
   forall A B C D E a b c d e,
    BetS A B C -> BetS a b c -> BetS E D C -> BetS e d c ->
    ET B C D b c d -> ET A C E a c e ->
    EF A B D E a b d e;
  axiom_cutoff2 :
   forall A B C D E a b c d e,
    BetS B C D -> BetS b c d -> ET C D E c d e -> EF A B D E a b d e ->
    EF A B C E a b c e;
  axiom_paste1 :
   forall A B C D E a b c d e,
    BetS A B C -> BetS a b c -> BetS E D C -> BetS e d c ->
    ET B C D b c d -> EF A B D E a b d e ->
    ET A C E a c e;
  axiom_deZolt1 :
   forall B C D E, BetS B E D -> ~ ET D B C E B C;
  axiom_deZolt2 :
   forall A B C E F,
    Triangle A B C -> BetS B E A -> BetS B F C ->
  ~ ET A B C E B F;
  axiom_paste2 :
   forall A B C D E M a b c d e m,
    BetS B C D -> BetS b c d -> ET C D E c d e ->
    EF A B C E a b c e ->
    BetS A M D -> BetS B M E ->
    BetS a m d -> BetS b m e ->
    EF A B D E a b d e;
  axiom_paste3 :
   forall A B C D M a b c d m,
    ET A B C a b c -> ET A B D a b d ->
    BetS C M D ->
    (BetS A M B \/ eq A M \/ eq M B) ->
    BetS c m d ->
    (BetS a m b \/ eq a m \/ eq m b) ->
    EF A C B D a c b d;
  axiom_paste4 :
   forall A B C D F G H J K L M P e m,
    EF A B m D F K H G -> EF D B e C G H M L ->
    BetS A P C -> BetS B P D -> BetS K H M -> BetS F G L ->
    BetS B m D -> BetS B e C -> BetS F J M -> BetS K J L ->
    EF A B C D F K M L;
}.


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

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

Unset Positivity Checking.
Unset Guard Checking.

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

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

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

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

Definition synth (lf3 : natural) (lf2 : natural) (lf1 : natural) : natural :=
  plus lf1 Zero.


Require Export TopologicalSpaces.
Require Export Ensembles.
Require Import EnsemblesImplicit.
Require Export InteriorsClosures.

Definition open_neighborhood {X:TopologicalSpace}
  (U:Ensemble (point_set X)) (x:point_set X) :=
  open U /\ In U x.

Definition neighborhood {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X) :=
  exists U:Ensemble (point_set X),
    open_neighborhood U x /\ Included U N.

Lemma open_neighborhood_is_neighborhood: forall {X:TopologicalSpace}
  (U:Ensemble (point_set X)) (x:point_set X),
  open_neighborhood U x -> neighborhood U x.
Proof.
intros.
exists U; auto with sets.
Qed.

Lemma neighborhood_interior: forall {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X),
  neighborhood N x -> In (interior N) x.
Proof.
intros.
destruct H.
destruct H.
destruct H.
assert (Included x0 (interior N)).
apply interior_maximal; trivial.
auto with sets.
Qed.

Lemma interior_neighborhood: forall {X:TopologicalSpace}
  (N:Ensemble (point_set X)) (x:point_set X),
  In (interior N) x -> neighborhood N x.
Proof.
intros.
exists (interior N).
repeat split.
apply interior_open.
assumption.
apply interior_deflationary.
Qed.


(* include libraries and notations *)
Require Import Arith Lia List String.
Import ListNotations.
Open Scope string.

Set Implicit Arguments.

Definition eq_dec (A : Type) :=
  forall (x : A),
    forall (y : A),
      {x = y} + {x <> y}.

Notation var := string.
Definition var_eq : eq_dec var := string_dec.

Definition valuation := list (var * nat).

Fixpoint lookup (x : var) (v : valuation) : option nat :=
  match v with
  | [] => None
  | (y, n) :: v' =>
    if var_eq x y
    then Some n
    else lookup x v'
  end.

Inductive arith : Set :=
| Const (n : nat)
| Var (x : var)
| Plus (e1 e2 : arith)
| Minus (e1 e2 : arith)
| Times (e1 e2 : arith).

Fixpoint eval_arith (e : arith) (v : valuation) : nat :=
  match e with
  | Const n => n
  | Var x =>
    match lookup x v with
    | None => 0
    | Some n => n
    end
  | Plus  e1 e2 => eval_arith e1 v + eval_arith e2 v
  | Minus e1 e2 => eval_arith e1 v - eval_arith e2 v
  | Times e1 e2 => eval_arith e1 v * eval_arith e2 v
  end.

Declare Scope arith_scope.
Coercion Const : nat >-> arith.
Coercion Var : var >-> arith.
Infix "+" := Plus : arith_scope.
Infix "-" := Minus : arith_scope.
Infix "*" := Times : arith_scope.
Delimit Scope arith_scope with arith.
Bind Scope arith_scope with arith.

(*
If you could use a refresher on any of these definitions, please check out
the code from Week04 where they're discussed in detail:
    https://gitlab.cs.washington.edu/cse505-23wi/cse505-23wi/-/blob/main/week04/Week04.v
*)

(* Copied from Week04.v *)
Inductive trc {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| trc_refl :
    forall x,
      trc R x x
| trc_front :
    forall x y z,
      R x y ->
      trc R y z ->
      trc R x z.

Record trsys state :=
  { Init : state -> Prop
  ; Step : state -> state -> Prop }.

Definition is_invariant {state} (sys : trsys state) (P : state -> Prop) :=
  forall s0,
    sys.(Init) s0 ->
    forall sN,
      trc sys.(Step) s0 sN ->
      P sN.

Definition initially_holds {state} (sys : trsys state) (P : state -> Prop) :=
  forall s,
    sys.(Init) s ->
    P s.

Definition closed_under_step {state} (sys : trsys state) (P : state -> Prop) :=
  forall s1,
    P s1 ->
    forall s2,
      sys.(Step) s1 s2 ->
      P s2.

Lemma closed_under_step_trc :
  forall {state} (sys : trsys state) (P : state -> Prop) s0 sN,
    trc sys.(Step) s0 sN ->
    closed_under_step sys P ->
    P s0 ->
    P sN.
Proof.
  unfold closed_under_step.
  intros state sys P s0 sN Htrc.
  induction Htrc; intros Hclosed HP0.
  - assumption.
  - apply IHHtrc; auto.
    eapply Hclosed; eauto.
Qed.

Theorem invariant_induction :
  forall {state} (sys : trsys state) (P : state -> Prop),
    initially_holds sys P ->
    closed_under_step sys P ->
    is_invariant sys P.
Proof.
  unfold is_invariant. intros.
  eapply closed_under_step_trc; eauto.
Qed.

Lemma invariant_implies :
  forall {state} (sys : trsys state) (P Q : state -> Prop),
    is_invariant sys P ->
    (forall s, P s -> Q s) ->
    is_invariant sys Q.
Proof.
  unfold is_invariant.
  eauto.
Qed.

Ltac unfold_predicate P :=
  match P with
  | ?head _ => unfold_predicate head
  | _ => try unfold P
  end.

Ltac invariant_induction_boilerplate :=
  intros;
  apply invariant_induction; [
    unfold initially_holds; simpl;
    match goal with
    | [ |- forall _, ?P _ -> ?Q _ ] =>
      unfold_predicate P;
      unfold_predicate Q;
      intros s Hinit;
      try subst
    end
  |
    unfold closed_under_step; simpl;
    match goal with
    | [ |- forall _, ?P _ -> forall _, ?Q _ _ -> _ ] =>
      unfold_predicate P;
      unfold_predicate Q;
      intros s1 IH s2 Hstep
    end
  ].
(* End of copied stuff *)

Module Imp.

(*
CREDITS: This formalization also follows the development from Chlipala's
excellent FRAP textbook: http://adam.chlipala.net/frap/
*)

(* Syntax of Imp. *)
Inductive cmd :=
| Skip
| Assign (x : var) (e : arith)
| Sequence (c1 c2 : cmd)
| If (e : arith) (then_ else_ : cmd) (* new this week (but nothing fundamental) *)
| While (e : arith) (body : cmd). (* new this week (and fundamentally different!) *)

Notation "x <- e" := (Assign x e%arith) (at level 75).
Infix ";;" := Sequence (at level 76). (* ;; instead of ; because it interferes
                                         with record syntax *)
Notation "'when' e 'then' then_ 'else' else_ 'done'" :=
  (If e%arith then_ else_) (at level 75, e at level 0).
Notation "'while' e 'loop' body 'done'" :=
  (While e%arith body) (at level 75).

(* Translate our long horizontal lines to an inductive definition. *)
Inductive step : valuation * cmd -> valuation * cmd -> Prop :=
| StepAssign :
    forall v x e v',
      v' = (x, eval_arith e v) :: v ->
      (* --------------------------- *)
      step (v, Assign x e) (v', Skip)
| StepSeqLStep :
    forall v c1 c2 v' c1',
      step (v, c1) (v', c1') ->
      step (v, Sequence c1 c2) (v', Sequence c1' c2)
| StepSeqLDone :
    forall v c2,
      step (v, Sequence Skip c2) (v, c2)
| StepIfTrue :
    forall v e then_ else_,
      eval_arith e v <> 0 ->
      step (v, If e then_ else_) (v, then_)
| StepIfFalse :
    forall v e then_ else_,
      eval_arith e v = 0 ->
      step (v, If e then_ else_) (v, else_)
| StepWhileTrue :
    forall v e body,
      eval_arith e v <> 0 ->
      (* -------------- *)
      step (v, While e body) (v, Sequence body (While e body))
| StepWhileFalse :
    forall v e body,
      eval_arith e v = 0 ->
      step (v, While e body) (v, Skip).

Definition counter :=
  "x" <- 5;;
  while 1 loop
    "x" <- "x" + 1
  done.

Example counter_steps_10_times :
  exists v,
    trc step ([], counter) (v, while 1 loop
                                  "x" <- "x" + 1
                               done) /\
    lookup "x" v = Some 15.
Proof.
Admitted.

(* Here's our old friend the factorial program. *)
Definition factorial : cmd :=
  "n" <- "input";;
  "acc" <- 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Print factorial.

Example factorial_4 :
  forall v1,
    lookup "input" v1 = Some 4 ->
    exists v2,
      trc step (v1, factorial) (v2, Skip) /\
      lookup "output" v2 = Some 24.
Proof.
  intros v1 Hv1.
  eexists.
  split.
  - unfold factorial.

    Print trc.
    eapply trc_front.
    eapply StepSeqLStep.
    eapply StepSeqLStep.
    eapply StepSeqLStep.
    apply StepAssign.
    reflexivity.

    eapply trc_front.
    eapply StepSeqLStep.
    eapply StepSeqLStep.
    apply StepSeqLDone.

Restart.

  intros v1 H.
  eexists.
  split.
  - eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    (* Now we are left with a Skip out front of our Seq. Get rid of it. *)
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLDone.
    (* Time for the next assignment statement... *)
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLDone.
    (* Now we're at the top of the loop. *)
    cbn. rewrite H.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepWhileTrue. (* Try to enter the loop. *)
    cbn. lia. (* Prove that we actually do enter the loop. *)
    (* Now execute the body of the loop. *)
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLDone.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLDone.
    (* We're back at the top of the loop. Time for the next iteration. *)
    cbn.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepWhileTrue.
    cbn. lia.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLDone.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLDone.
    (* next iteration *)
    cbn.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepWhileTrue.
    cbn. lia.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLDone.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLDone.
    (* next iteration *)
    cbn.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepWhileTrue.
    cbn. lia.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepSeqLDone.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLStep.
    apply StepAssign.
    reflexivity.
    eapply trc_front.
    apply StepSeqLStep.
    apply StepSeqLDone.
    cbn.
    (* Finally n is 0. Try to exit the loop. *)
    eapply trc_front.
    apply StepSeqLStep.
    apply StepWhileFalse.
    cbn. lia. (* Prove we actually do exit the loop. *)
    (* Just a few more steps left after the loop. *)
    eapply trc_front.
    apply StepSeqLDone.
    eapply trc_front.
    apply StepAssign.
    reflexivity.
    cbn.
    (* Finally, we end the proof of trc using trc_refl. If you look carefully at
       the goal here, you can "see" the actual v2 that gets plugged in for our
       placeholder. Yikes! *)
    apply trc_refl.
  - (* All that's left is to show *)
    cbn.
    reflexivity.
Qed. (* Nailed it, only 130 ish tactics. Lots of copy paste! *)

(* like econstructor, but avoid StepWhileTrue b/c infinite tactic loops *)
Ltac step_easy :=
  repeat (
    apply StepSeqLDone ||
    eapply StepSeqLStep ||
    (apply StepWhileFalse; cbn; reflexivity) ||
    (apply StepAssign; reflexivity)
  ); cbn.

Example factorial_4_again :
  forall v1,
    lookup "input" v1 = Some 4 ->
    exists v2,
      trc step (v1, factorial) (v2, Skip) /\
      lookup "output" v2 = Some 24.
Proof.
  intros v1 H.
  eexists.
  split.
  - econstructor.
    step_easy.
    cbn. rewrite H.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    apply StepWhileTrue.
    cbn. lia.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    apply StepWhileTrue.
    cbn. lia.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    apply StepWhileTrue.
    cbn. lia.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    apply StepWhileTrue.
    cbn. lia.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    cbn.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    econstructor.
    step_easy.
    cbn.
    econstructor.
  - reflexivity. (* ok that only took half as many tactics *)
  Restart.
  (* We can do even better with more tactics. *)
  Ltac trc_easy :=
    eapply trc_front; [solve [step_easy]|]; cbn.

  Ltac trc_enter_loop :=
    eapply trc_front; [step_easy; apply StepWhileTrue; cbn; try lia|]; cbn.

  intros v1 H.
  eexists.
  split.
  - trc_easy. rewrite H.
    repeat trc_easy. (* Executes as many assignments/skips as possible. *)
    trc_enter_loop.
    repeat trc_easy.
    trc_enter_loop.
    repeat trc_easy.
    trc_enter_loop.
    repeat trc_easy.
    trc_enter_loop.
    repeat trc_easy.
    (* exited the loop *)
    apply trc_refl.
  - reflexivity.
Qed.

Definition cmd_init (v : valuation) (c : cmd) (s : valuation * cmd) : Prop :=
  s = (v, c).

Definition cmd_to_trsys (v : valuation) (c : cmd) : trsys (valuation * cmd) :=
  {| Init := cmd_init v c
   ; Step := step
   |}.

Definition counter_sys : trsys (valuation * cmd) :=
  cmd_to_trsys [] counter.

Definition counter_ge_5_attempt (s : valuation * cmd) :=
  let (v, c) := s in
  exists x,
    lookup "x" v = Some x /\
    x >= 5.

Theorem counter_ge_5_attempt_invariant :
  is_invariant counter_sys counter_ge_5_attempt.
Proof.
  invariant_induction_boilerplate.
  (* Uh oh, this just isn't true initially! x is not mapped to anything yet. *)
Abort.

Definition counter_ge_5 (s : valuation * cmd) :=
  let (v, c) := s in
  c = counter \/
  exists x,
    lookup "x" v = Some x /\
    x >= 5.

Theorem counter_ge_5_invariant :
  is_invariant counter_sys counter_ge_5.
Proof.
  invariant_induction_boilerplate.
  - auto.
  - destruct s1 as [v1 c1], s2 as [v2 c2].
    destruct IH as [IH|IH].
    + subst. unfold counter in *.
      inversion Hstep; subst; clear Hstep.
      inversion H0; subst; clear H0.
      cbn. eauto.
    +
Abort.

(*

Definition counter :=
  "x" <- 5;;
  while 1 loop
    "x" <- "x" + 1
  done.

  Skip;;
  while 1 loop
    "x" <- "x" + 1
  done.

  while 1 loop
    "x" <- "x" + 1
  done.

  "x" <- "x" + 1;;
  while 1 loop
    "x" <- "x" + 1
  done.
 *)

Definition counter_programs (s : valuation * cmd) :=
  let (v, c) := s in
  c = counter \/
  c = (Skip;;
       while 1 loop
         "x" <- "x" + 1
       done) \/
  c = (while 1 loop
         "x" <- "x" + 1
       done) \/
  c = ("x" <- "x" + 1;;
       while 1 loop
         "x" <- "x" + 1
       done) \/
  c = Skip.

Theorem counter_programs_invariant :
  is_invariant counter_sys counter_programs.
Proof.
  invariant_induction_boilerplate.
  - auto.
  - destruct s1 as [v1 c1], s2 as [v2 c2].
    intuition; subst; inversion Hstep; subst; clear Hstep; auto.
    + inversion H0; subst; clear H0. auto.
    + inversion H0; subst; clear H0.
    + inversion H0; subst; clear H0. auto.
Qed.

Definition counter_valuation_x_ge_5 (v : valuation) :=
  exists x,
    lookup "x" v = Some x /\
    x >= 5.

Definition counter_programs_x_ge_5 (s : valuation * cmd) :=
  let (v, c) := s in
  c = counter \/
  (c = (Skip;;
        while 1 loop
          "x" <- "x" + 1
        done) /\ counter_valuation_x_ge_5 v) \/
  (c = (while 1 loop
          "x" <- "x" + 1
        done) /\ counter_valuation_x_ge_5 v) \/
  (c = ("x" <- "x" + 1;;
        while 1 loop
          "x" <- "x" + 1
        done) /\ counter_valuation_x_ge_5 v).

Lemma counter_programs_x_ge_5_invariant :
  is_invariant counter_sys counter_programs_x_ge_5.
Proof.
  invariant_induction_boilerplate.
  - auto.
  - destruct s1 as [v1 c1], s2 as [v2 c2].
    unfold counter_valuation_x_ge_5 in *.
    intuition; subst; inversion Hstep; subst; clear Hstep; auto.
    + inversion H0; subst; clear H0. cbn. eauto 10.
    + inversion H0; subst; clear H0.
    + simpl in *. discriminate.
    + inversion H0; subst; clear H0.
    destruct H1 as [x [Hlook Hx]]. cbn. rewrite Hlook. right. left.
    split; auto. eexists. split; auto. lia.

Qed.

Theorem counter_ge_5_invariant :
  is_invariant counter_sys counter_ge_5.
Proof.
  apply invariant_implies with (P := counter_programs_x_ge_5).
  - apply counter_programs_x_ge_5_invariant.
  - unfold counter_programs_x_ge_5, counter_ge_5.
    intros [v c] Hinv.
    intuition.
Qed.

Definition factorial_sys (input : nat) : trsys (valuation * cmd) :=
  cmd_to_trsys [("input", input)] factorial.

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

Definition factorial_safe (input : nat) (s : valuation * cmd) : Prop :=
  let (v, c) := s in
  c = Skip ->
  lookup "output" v = Some (fact input).

Theorem factorial_safe_invariant :
  forall input,
    is_invariant (factorial_sys input) (factorial_safe input).
Proof.
Abort.

Definition factorial_after_step_one :=
  Skip;;
  "acc" <- 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_after_step_two :=
  "acc" <- 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_after_step_three :=
  Skip;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_top_of_loop :=
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_body_start :=
  "acc" <- "acc" * "n";;
  "n" <- "n" - 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_body_after_step_one :=
  Skip;;
  "n" <- "n" - 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_body_after_step_two :=
  "n" <- "n" - 1;;
  while "n" loop
    "acc" <- "acc" * "n";;
    "n" <- "n" - 1
  done;;
  "output" <- "acc".

Definition factorial_after_loop :=
  Skip;;
  "output" <- "acc".

Definition factorial_last_step :=
  "output" <- "acc".

Definition factorial_loop_invariant input v :=
  exists n acc,
    lookup "n" v = Some n /\
    lookup "acc" v = Some acc /\
    fact n * acc = fact input.

Definition factorial_body_invariant input v :=
  exists n acc,
    lookup "n" v = Some (S n) /\
    lookup "acc" v = Some acc /\
    fact (S n) * acc = fact input.

Definition factorial_body_invariant_after_step input v :=
  exists n acc,
    lookup "n" v = Some (S n) /\
    lookup "acc" v = Some acc /\
    fact n * acc = fact input.

Definition factorial_inv (input : nat) (s : valuation * cmd) : Prop :=
  let (v, c) := s in
  (c = factorial /\ lookup "input" v = Some input) \/
  (c = factorial_after_step_one /\ lookup "n" v = Some input) \/
  (c = factorial_after_step_two /\ lookup "n" v = Some input) \/
  (c = factorial_after_step_three /\ factorial_loop_invariant input v) \/
  (c = factorial_top_of_loop /\ factorial_loop_invariant input v) \/
  (c = factorial_body_start /\ factorial_body_invariant input v) \/
  (c = factorial_body_after_step_one /\ factorial_body_invariant_after_step input v) \/
  (c = factorial_body_after_step_two /\ factorial_body_invariant_after_step input v) \/
  (c = factorial_after_loop /\ lookup "acc" v = Some (fact input)) \/
  (c = factorial_last_step /\ lookup "acc" v = Some (fact input)) \/
  (c = Skip /\ lookup "output" v = Some (fact input)).

Ltac invc H := inversion H; subst; clear H.

Lemma factorial_inv_invariant :
  forall input,
    is_invariant (factorial_sys input) (factorial_inv input).
Proof.
  invariant_induction_boilerplate.
  - auto.
  - unfold factorial_loop_invariant, factorial_body_invariant.
    unfold factorial_body_invariant_after_step.
    destruct s1 as [v1 c1], s2 as [v2 c2].
    intuition idtac; subst.
    + invc Hstep. invc H0. invc H2. invc H0.
      cbn [eval_arith].
      rewrite H1.
      auto.
    + invc Hstep. invc H0. invc H2. invc H0. auto.
    + invc Hstep. invc H0. invc H2.
      right. right. right. left. split; [reflexivity|].
      exists input, 1.
      cbn. split; auto. split; auto. lia.
    + destruct H1 as [n [acc [? []]]].
      invc Hstep. invc H3. invc H4.
      eauto 20.
    + destruct H1 as [n [acc [? []]]].
      invc Hstep. invc H3.
      -- right. right. right. right. right. left. split; [reflexivity|].
         cbn in *. rewrite H in *.
         destruct n; [congruence|]. (* note: destruct before exists *)
         eauto.
      -- right. right. right. right. right. right. right. right. left. split; [reflexivity|].
         cbn in *. rewrite H in *. subst n.
         cbn in *. rewrite H0, <- H1. f_equal. lia.
    + destruct H1 as [n [acc [? []]]].
      invc Hstep. invc H3. invc H4. invc H3.
      right. right. right. right. right. right. left. split; [reflexivity|].
      cbn. rewrite H, H0. eexists. eexists. split; eauto. split; eauto.
      rewrite <- H1. cbn. lia.
    + destruct H1 as [n [acc [? []]]].
      invc Hstep. invc H3. invc H4. invc H3.
      eauto 15.
    + destruct H1 as [n [acc [? []]]].
      invc Hstep. invc H3. invc H4.
      right. right. right. left. split; [reflexivity|].
      cbn. rewrite H. cbn. rewrite Nat.sub_0_r. eauto.
    + invc Hstep. invc H1. invc H0.
      auto 20.
    + invc Hstep.
      right. right. right. right. right. right. right. right. right. right.
      split; auto.
      cbn. rewrite H1. auto.
    + invc Hstep.
Qed.

Ltac invert_one_step :=
  match goal with
  | [ H : step _ _ |- _ ] => invc H
  end.

Ltac invert_steps :=
  repeat invert_one_step.

Ltac magic_select_case :=
  repeat match goal with
  | [ |- _ \/ _ ] => (left; split; [reflexivity|]) || right
  | _ => try split; [reflexivity|]
  end.

Ltac break_up_hyps :=
  repeat match goal with
  | [ H : exists _, _ |- _ ] => destruct H
  | [ H : _ /\ _ |- _ ] => destruct H
  end.

Ltac find_rewrites :=
  repeat match goal with
  | [ H : _ = _ |- _ ] => rewrite H in *
  end.

Lemma factorial_inv_invariant_again :
  forall input,
    is_invariant (factorial_sys input) (factorial_inv input).
Proof.
  invariant_induction_boilerplate.
  - auto.
  - destruct s1 as [v1 c1], s2 as [v2 c2].
    fold (factorial_inv input (v2, c2)).
    intuition; subst; invert_steps;
    unfold factorial_inv;
    unfold factorial_loop_invariant, factorial_body_invariant in *;
    unfold factorial_body_invariant_after_step in *;
    magic_select_case;
    break_up_hyps;
    cbn in *;
    find_rewrites;
    eauto 20.
    + eexists. eexists.
      split; eauto. split; eauto. lia.
    + destruct x; [congruence|]. (* note: destruct before exists *)
      eauto.
    + subst.
      cbn in *. rewrite <- H1. f_equal. lia.
    + eexists. eexists. split; eauto. split; eauto.
      rewrite <- H1. cbn. lia.
    + eexists. eexists. split; eauto. split; eauto.
      cbn. rewrite <- H1. f_equal. f_equal. lia.
Qed.

Theorem factorial_safe_invariant :
  forall input,
    is_invariant (factorial_sys input) (factorial_safe input).
Proof.
  intros input.
  apply invariant_implies with (P := factorial_inv input).
  - apply factorial_inv_invariant.
  - unfold factorial_inv, factorial_safe.
    intros [v c] Hinv Hfinal.
    subst.
    intuition; discriminate.
Qed.

Lemma decompose_sequence_execution :
  forall v v' c1 c2 c',
    trc step (v, c1;; c2) (v', c') ->
    exists v1' c1',
      trc step (v, c1) (v1', c1') /\
      (c' = (c1';; c2) \/
        (c1' = Skip /\ trc step (v1', c2) (v', c'))).
Proof.
  intros v v' c1 c2 c' Hstep.
  induction Hstep.
  - (* wait... what is x??? *)
  Restart.
  intros v v' c1 c2 c' Hstep.
  remember (v, c1;;c2) as s.
  remember (v', c') as s'.
  revert v c1 c2 v' c' Heqs Heqs'.
  induction Hstep; intros v c1 c2 v' c' ? ?; subst.
  - invc Heqs'. eexists. eexists. split. constructor. auto.
  - invc H.
    + specialize (IHHstep v'0 c1' c2 v' c' eq_refl eq_refl).
      destruct IHHstep as [v1' [c1'0 [Hstep' Hc']]].
      eexists. eexists.
      split. eapply trc_front; eauto.
      intuition.
    + eexists. eexists. split. apply trc_refl.
      auto.
Qed.

Lemma trc_seq_l_trc :
  forall v1 c1 v2 c2 c3,
    trc step (v1, c1) (v2, c2) ->
    trc step (v1, c1;;c3) (v2, c2;;c3).
Proof.
  intros v1 c1 v2 c2 c3 Hstep.
  remember (v1, c1) as s1.
  remember (v2, c2) as s2.
  revert v1 c1 v2 c2 c3 Heqs1 Heqs2.
  induction Hstep; intros v1 c1 v2 c2 c3 ? ?; subst.
  - invc Heqs2. econstructor.
  - destruct y as [v1' c1'].
    specialize (IHHstep v1' c1' v2 c2 c3 eq_refl eq_refl).
    eapply trc_front. apply StepSeqLStep. eauto. eauto.
Qed.

Inductive trc_backward {A} (R : A -> A -> Prop) : A -> A -> Prop :=
| trcb_refl :
    forall x,
      trc_backward R x x
| trcb_back :
    forall x y z,
      trc_backward R x y ->
      R y z ->
      trc_backward R x z.

Lemma trc_back :
  forall {A} (R : A -> A -> Prop) x y,
    trc R x y ->
    forall z,
      R y z ->
      trc R x z.
Proof.
  (* On HW3 *)
Admitted.

Lemma trcb_front :
  forall {A} (R : A -> A -> Prop) y z,
    trc_backward R y z ->
    forall x,
      R x y ->
      trc_backward R x z.
Proof.
  (* Very similar to previous lemma. *)
Admitted.

Lemma trc_implies_trc_backward :
  forall A (R : A -> A -> Prop) x y,
    trc R x y ->
    trc_backward R x y.
Proof.
  intros A R x y Htrc.
  induction Htrc.
  - constructor.
  - eapply trcb_front; eauto.
Qed.

Lemma trc_backward_implies_trc :
  forall A (R : A -> A -> Prop) x y,
    trc_backward R x y ->
    trc R x y.
Proof.
  intros A R x y Htrcb.
  induction Htrcb.
  - constructor.
  - eapply trc_back; eauto.
Qed.

Lemma trc_reverse_ind :
  forall A (R : A -> A -> Prop) (P : A -> A -> Prop),
    (forall x, P x x) ->
    (forall x y z, trc R x y -> R y z -> P x y -> P x z) ->
    forall x y,
      trc R x y ->
      P x y.
Proof.
  intros A R P Hbase Hind x y H.
  apply trc_implies_trc_backward in H.
  induction H.
  - apply Hbase.
  - eapply Hind; eauto.
    apply trc_backward_implies_trc.
    auto.
Qed.

Definition loop_runs_to (e : arith) (c : cmd) (v1 v2 : valuation) :=
  eval_arith e v1 <> 0 /\
  trc step (v1, c) (v2, Skip).

Ltac prepare_induct_step H :=
  match type of H with
  | step (?v, ?c) (?v', ?c') =>
    let s := fresh "s" in
    let Heqs := fresh "Heqs" in
    let s' := fresh "s'" in
    let Heqs' := fresh "Heqs'" in
    remember (v, c) as s eqn:Heqs;
    remember (v', c') as s' eqn:Heqs';
    revert Heqs Heqs';
    try revert c';
    try revert v';
    try revert c;
    try revert v
  end.

Ltac induct_step H :=
  prepare_induct_step H;
  induction H; intros; subst.

Ltac prepare_induct_trc_step H :=
  match type of H with
  | trc step (?v, ?c) (?v', ?c') =>
    let s := fresh "s" in
    let Heqs := fresh "Heqs" in
    let s' := fresh "s'" in
    let Heqs' := fresh "Heqs'" in
    remember (v, c) as s eqn:Heqs;
    remember (v', c') as s' eqn:Heqs';
    revert Heqs Heqs';
    try revert c';
    try revert v';
    try revert c;
    try revert v
  end.

Ltac induct_trc_step H :=
  prepare_induct_trc_step H;
  induction H; intros; subst.

Lemma decompose_while_execution :
  forall v v' e c c',
    trc step (v, while e loop c done) (v', c') ->
    exists v1,
      trc (loop_runs_to e c) v v1 /\
      ((c' = Skip /\ v' = v1 /\ eval_arith e v' = 0) \/
       (c' = (while e loop c done) /\ v' = v1) \/
       (eval_arith e v1 <> 0 /\ exists c1', trc step (v1, c) (v', c1') /\ c' = (c1' ;; while e loop c done))).
Proof.
  intros v v' e c c' Htrc.
  prepare_induct_trc_step Htrc.
  revert e c.
  induction Htrc using trc_reverse_ind; intros v e c v' c' ? ?; subst.
  - invc Heqs'. (* eexists. split.
    + apply trc_refl.
    + auto.  *)
    eauto 10 using trc_refl.
  - destruct y as [v2 c2].
    specialize (IHHtrc v e c v2 c2 eq_refl eq_refl).
    destruct IHHtrc as [v1 [Htrc1 IH]].
    destruct IH as [[? [? He]]|[[? ?]|[He [c1' [Hc ?]]]]]; subst.
    + invc H.
    + invc H.
      * eexists. split; eauto.
        right. right. split; auto.
        eexists. split; eauto. constructor.
      * eauto 10.
    + invc H.
      * eexists. split; eauto.
        right. right. split; auto.
        eexists. split; [|reflexivity].
        eapply trc_back; eauto.
      * exists v'. split.
        -- eapply trc_back; eauto. split; auto.
        -- auto.
Qed.

Fixpoint strength_reduction (e : arith) : arith :=
  match e with
  | Const _ => e
  | Var _ => e
  | Plus e1 e2 => Plus (strength_reduction e1) (strength_reduction e2)
  | Minus e1 e2 => Minus (strength_reduction e1) (strength_reduction e2)
  | Times (Const 2) e2 =>
    let e2' := strength_reduction e2 in
    Plus e2' e2'
  | Times e1 e2 => Times (strength_reduction e1) (strength_reduction e2)
  end.

Fixpoint cmd_xform_arith (f : arith -> arith) (c : cmd) : cmd :=
  match c with
  | Skip => Skip
  | Assign x e => Assign x (f e)
  | Sequence c1 c2 => Sequence (cmd_xform_arith f c1) (cmd_xform_arith f c2)
  | If e c1 c2 => If (f e) (cmd_xform_arith f c1) (cmd_xform_arith f c2)
  | While e c => While (f e) (cmd_xform_arith f c)
  end.

Lemma cmd_xform_arith_equiv_step :
  forall f,
    (forall e v, eval_arith (f e) v = eval_arith e v) ->
    forall v c v' c',
      step (v, c) (v', c') ->
      step (v, cmd_xform_arith f c) (v', cmd_xform_arith f c').
Proof.
  intros f Hf v c v' c' Hstep.
  induct_step Hstep; invc Heqs; invc Heqs'; simpl; constructor;
   try rewrite Hf; auto.
Qed.

Theorem cmd_xform_arith_equiv :
  forall f,
    (forall e v, eval_arith e v = eval_arith (f e) v) ->
    forall v c v' c',
      trc step (v, c) (v', c') ->
      trc step (v, cmd_xform_arith f c) (v', cmd_xform_arith f c').
Proof.
  intros f Hf v c v' c' Htrc.
  induct_trc_step Htrc.
  - invc Heqs'. constructor.
  - destruct y as [v1 c1].
    eapply cmd_xform_arith_equiv_step in H; eauto.
    econstructor; eauto.
Qed.

End Imp.


Require Import List.
Import ListNotations.

From CoqAlgs Require Export Sorting.Sort.

Set Implicit Arguments.

Class ISArgs : Type :=
{
    A : Type;
    S : Type;

    empty  : S;
    insert : A -> S -> S;

    toList : S -> list A;

    R : A -> A -> Prop;

    Sorted_toList :
      forall s : S, Sorted R (toList s);

    countS : (A -> bool) -> S -> nat;

    countS_empty :
      forall p : A -> bool,
        countS p empty = 0;

    countS_insert :
      forall (p : A -> bool) (x : A) (s : S),
        countS p (insert x s) =
          (if p x then 1 else 0) + countS p s;

    countS_toList :
      forall (p : A -> bool) (s : S),
        countS p s = count p (toList s);
}.

Fixpoint fromList (args : ISArgs) (l : list A) : S :=
match l with
    | [] => empty
    | h :: t => insert h (fromList args t)
end.

Definition insSort (args : ISArgs) (l : list A) : list A := toList (fromList args l).

Lemma countS_fromList :
  forall (args : ISArgs) (p : A -> bool) (l : list A),
    countS p (fromList args l) = count p l.
Proof.
  induction l as [| h t]; cbn.
    rewrite countS_empty. reflexivity.
    rewrite countS_insert, IHt. reflexivity.
Qed.

Lemma perm_insSort :
  forall (args : ISArgs) (l : list A),
    perm (insSort args l) l.
Proof.
  unfold perm, insSort. intros.
  rewrite <- countS_toList, <- countS_fromList.
  reflexivity.
Qed.


Set Warnings "-notation-overridden,-parsing".
Require Import Coq.Arith.Arith.
Require Import Coq.Arith.EqNat.
Require Import Coq.omega.Omega.
Require Import Coq.Lists.List.
Import ListNotations.
Require Import maps.
Require Import imp.
Require Import rel.

Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm.

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n => n
  | P a1 a2 => evalF a1 + evalF a2
  end.

Reserved Notation " t '\\' n " (at level 50, left associativity).

Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      C n \\ n
  | E_Plus : forall t1 t2 n1 n2,
      t1 \\ n1 ->
      t2 \\ n2 ->
      P t1 t2 \\ (n1 + n2)

  where " t '\\' n " := (eval t n).

Module SimpleArith1.

Reserved Notation " t '==>' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall n1 t2 t2',
      t2 ==> t2' ->
      P (C n1) t2 ==> P (C n1) t2'

  where " t '==>' t' " := (step t t').

Example test_step_1 :
      P(P (C 0)(C 3))(P (C 2) (C 4))
      ==>P(C (0 + 3))(P (C 2) (C 4)).
Proof.
apply ST_Plus1.
apply ST_PlusConstConst.
Qed.

Example test_step_2 :
P (C 0) (P (C 2) (P (C 0) (C 3)))
==> P (C 0) (P (C 2) (C (0 + 3))).
Proof.
apply ST_Plus2.
simpl.
apply ST_Plus2.
apply ST_PlusConstConst.
Qed.
End SimpleArith1.

Definition deterministic {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
Import SimpleArith1.
Theorem step_deterministic:
deterministic step.
Proof.
unfold deterministic.
intros x y1 y2 Hy1 Hy2.
generalize dependent y2.
induction Hy1. intros y2 Hy2.
Admitted.

End SimpleArith2.

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

Ltac solve_by_invert :=
  solve_by_inverts 1.

Module SimpleArith3.
Import SimpleArith1.
Theorem step_deterministic_alt: deterministic step.
Proof.
  intros x y1 y2 Hy1 Hy2.
  generalize dependent y2.
  induction Hy1; intros y2 Hy2;
    inversion Hy2; subst; try solve_by_invert.
  - (* ST_PlusConstConst *) reflexivity.
  - (* ST_Plus1 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
  - (* ST_Plus2 *)
    apply IHHy1 in H2. rewrite H2. reflexivity.
Qed.
End SimpleArith3.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n).

Reserved Notation " t '==>' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
          P (C n1) (C n2)
      ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
        t1 ==> t1' ->
        P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
        value v1 -> (* <----- n.b. *)
        t2 ==> t2' ->
        P v1 t2 ==> P v1 t2'

  where " t '==>' t' " := (step t t').

Theorem step_deterministic :
  deterministic step.
Proof.
  (* FILL IN HERE *) Admitted.

Theorem strong_progress : forall t,
  value t \/ (exists t', t ==> t').
Proof.
intros.
induction t.
- left. apply v_const.
- right. inversion IHt1.
  + inversion IHt2. inversion H0.
Admitted.

Definition normal_form {X:Type} (R:relation X) (t:X) : Prop :=
  ~ exists t', R t t'.

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
unfold normal_form.
intros.
unfold not.
inversion H.
intros c.
inversion c.
inversion H1.
Qed.

Lemma nf_is_value : forall t,
  normal_form step t -> value t.
Proof.
unfold normal_form.
intros t H.
assert ( G: value t \/ exists t', t==>t').
{ apply strong_progress. }
inversion G.
+ assumption.
+ exfalso. apply H. assumption.
Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
split.
apply nf_is_value.
apply value_is_nf.
Qed.

(** some good exercises are left **)

Inductive multi {X:Type} (R: relation X) : relation X :=
  | multi_refl : forall (x : X), multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation " t '==>*' t' " := (multi step t t') (at level 40).

Theorem multi_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> (multi R) x y.
Proof.
intros.
apply multi_step with y.
assumption.
apply multi_refl.
Qed.

Theorem multi_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      multi R x y ->
      multi R y z ->
      multi R x z.
Proof.
intros X R x y z H1 H2.
induction H1.
assumption.
apply multi_step with y.
assumption. apply IHmulti. apply H2.
Qed.

Lemma test_multistep_1:
P(P (C 0) (C 3))(P (C 2) (C 4))==>*C ((0 + 3) + (2 + 4)).
Proof.
apply multi_step with (P (C (0 + 3))
               (P (C 2) (C 4))).
apply ST_Plus1.
apply ST_PlusConstConst.
apply multi_step with (P (C (0 + 3))
                (C (2 + 4))).
apply ST_Plus2.
apply v_const.
apply ST_PlusConstConst.
apply multi_step with (C (0 + 3 + (2 + 4))).
apply ST_PlusConstConst.
apply multi_refl.
Qed.

Lemma test_multistep_1':
P(P (C 0) (C 3))(P (C 2) (C 4))
==>* C ((0 + 3) + (2 + 4)).
Proof.
eapply multi_step.
apply ST_Plus1. apply ST_PlusConstConst.
  eapply multi_step. apply ST_Plus2. apply v_const.
  apply ST_PlusConstConst.
  eapply multi_step. apply ST_PlusConstConst.
  apply multi_refl. Qed.

Lemma test_multistep_2:
  C 3 ==>* C 3.
Proof.
apply multi_refl.
Qed.

Lemma test_multistep_3:
      P (C 0) (C 3)
   ==>*
      P (C 0) (C 3).
Proof.
apply multi_refl.
Qed.

Lemma test_multistep_4:
P(C 0)(P(C 2) (P (C 0) (C 3)))
  ==>*P(C 0)(C (2 + (0 + 3))).
Proof.
apply multi_step with (P(C 0)(P(C 2)(C (0 + 3)))).
apply ST_Plus2.
apply v_const.
apply ST_Plus2.
apply v_const.
apply ST_PlusConstConst.
apply multi_step with (P(C 0)(C (2 + (0 + 3)))).
apply ST_Plus2.
apply v_const.
apply ST_PlusConstConst.
apply multi_refl.
Qed.

Definition step_normal_form := normal_form step.
Definition normal_form_of (t t' : tm) :=
  (t ==>* t' /\ step_normal_form t').

Theorem normal_forms_unique:
  deterministic normal_form_of.
Proof.
unfold deterministic.
unfold normal_form_of.
intros.
inversion H as [P1 P2]. clear H.
- inversion H0 as [P3 P4]. clear H0.
generalize dependent y2.
Admitted.

Definition normalizing {X:Type} (R:relation X) :=
  forall t, exists t',
    (multi R) t t' /\ normal_form R t'.

Lemma multistep_congr_1 : forall t1 t1' t2,
     t1 ==>* t1' ->
     P t1 t2 ==>* P t1' t2.
Proof.
intros. induction H .
apply multi_refl.
apply multi_step with (P y t2).
apply ST_Plus1. apply H.
assumption.
Qed.

Lemma multistep_congr_2 : forall t1 t2 t2',
     value t1 ->
     t2 ==>* t2' ->
     P t1 t2 ==>* P t1 t2'.
Proof.
intros.
induction H0.
- apply multi_refl.
- apply multi_step with (P t1 y).
apply ST_Plus2.
apply H. apply H0. apply IHmulti.
Qed.

Theorem step_normalizing :
  normalizing step.
Proof.
unfold normalizing.
induction t.
- exists (C n).
split. apply multi_refl.
apply nf_same_as_value. apply v_const.
- destruct IHt1 as [t1' [H11 H12]].
  destruct IHt2 as [t2' [H21 H22]].
rewrite nf_same_as_value in H12.
rewrite nf_same_as_value in H22.
inversion H12 as [n1 H].
inversion H22 as [n2 H'].
Admitted.

Theorem eval__multistep : forall t n,
  t \\ n -> t ==>* C n.
Proof.
intros.
  induction H. constructor.
  eapply multi_trans.
  assert(P t1 t2 ==>* P (C n1) t2).
    apply multistep_congr_1; assumption.
    apply H1.
  eapply multi_trans.
    apply multistep_congr_2. constructor.
    apply IHeval2.
  econstructor; constructor.
  Qed.

Definition manual_grade_for_eval__multistep_inf : option (prod nat string) := None.

Lemma step__eval : forall t t' n,
     t ==> t' ->
     t' \\ n ->
     t \\ n.
Proof.
intros t t' n Hs. generalize dependent n.
induction Hs.
- intros. inversion H; subst.
constructor. constructor. constructor.
- intros. inversion H; subst.
constructor. apply IHHs. assumption.
assumption.
- intros. inversion H0; subst.
constructor. assumption. apply IHHs.
assumption.
Qed.

Theorem multistep__eval : forall t t',
  normal_form_of t t' ->
  exists n, t' = C n /\ t \\ n.
Proof.
intros. unfold normal_form_of in H.
inversion H.
induction H0.
- assert (value x).
 + apply nf_is_value. apply H1.
 + inversion H0.  exists n. split.
reflexivity. constructor.
- assert(exists n : nat, z = C n /\ y \\ n).
apply IHmulti. split.
assumption. assumption. assumption.
inversion H3 as [n [H6 H7]].
exists n. split. assumption.
eapply step__eval. apply H0.
apply H7.
Qed.

Theorem evalF_eval : forall t n,
  evalF t = n <-> t \\ n.
Proof.
intros.
split. generalize dependent n.
-  induction t.
 + intros. subst.
constructor.
 + intros. simpl in H. rewrite <-H.
constructor.
 apply IHt1. reflexivity.
apply IHt2. reflexivity.
- intros. induction H.
constructor. simpl.
subst. reflexivity.
Qed.

Module Combined.
Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.
Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_true : value ttrue
  | v_false : value tfalse.
Reserved Notation " t '==>' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) ==> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 ==> t1' ->
      P t1 t2 ==> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 ==> t2' ->
      P v1 t2 ==> P v1 t2'
  | ST_IfTrue : forall t1 t2,
      tif ttrue t1 t2 ==> t1
  | ST_IfFalse : forall t1 t2,
      tif tfalse t1 t2 ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      tif t1 t2 t3 ==> tif t1' t2 t3

  where " t '==>' t' " := (step t t').

End Combined.
Definition manual_grade_for_combined_properties : option (prod nat string) := None.

Inductive aval : aexp -> Prop :=
  | av_num : forall n, aval (ANum n).

Reserved Notation " t '/' st '==>a' t' "
                  (at level 40, st at level 39).
Inductive astep : state -> aexp -> aexp -> Prop :=
  | AS_Id : forall st i,
      AId i / st ==>a ANum (st i)
  | AS_Plus : forall st n1 n2,
      APlus (ANum n1) (ANum n2) / st ==>a ANum (n1 + n2)
  | AS_Plus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (APlus a1 a2) / st ==>a (APlus a1' a2)
  | AS_Plus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (APlus v1 a2) / st ==>a (APlus v1 a2')
  | AS_Minus : forall st n1 n2,
      (AMinus (ANum n1) (ANum n2)) / st ==>a (ANum (minus n1 n2))
  | AS_Minus1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMinus a1 a2) / st ==>a (AMinus a1' a2)
  | AS_Minus2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMinus v1 a2) / st ==>a (AMinus v1 a2')
  | AS_Mult : forall st n1 n2,
      (AMult (ANum n1) (ANum n2)) / st ==>a (ANum (mult n1 n2))
  | AS_Mult1 : forall st a1 a1' a2,
      a1 / st ==>a a1' ->
      (AMult a1 a2) / st ==>a (AMult a1' a2)
  | AS_Mult2 : forall st v1 a2 a2',
      aval v1 ->
      a2 / st ==>a a2' ->
      (AMult v1 a2) / st ==>a (AMult v1 a2')

    where " t '/' st '==>a' t' " := (astep st t t').
Reserved Notation " t '/' st '==>b' t' "
                  (at level 40, st at level 39).
Inductive bstep : state -> bexp -> bexp -> Prop :=
| BS_Eq : forall st n1 n2,
    (BEq (ANum n1) (ANum n2)) / st ==>b
    (if (beq_nat n1 n2) then BTrue else BFalse)
| BS_Eq1 : forall st a1 a1' a2,
    a1 / st ==>a a1' ->
    (BEq a1 a2) / st ==>b (BEq a1' a2)
| BS_Eq2 : forall st v1 a2 a2',
    aval v1 ->
    a2 / st ==>a a2' ->
    (BEq v1 a2) / st ==>b (BEq v1 a2')
| BS_LtEq : forall st n1 n2,
    (BLe (ANum n1) (ANum n2)) / st ==>b
             (if (leb n1 n2) then BTrue else BFalse)
| BS_LtEq1 : forall st a1 a1' a2,
    a1 / st ==>a a1' ->
    (BLe a1 a2) / st ==>b (BLe a1' a2)
| BS_LtEq2 : forall st v1 a2 a2',
    aval v1 ->
    a2 / st ==>a a2' ->
    (BLe v1 a2) / st ==>b (BLe v1 a2')
| BS_NotTrue : forall st,
    (BNot BTrue) / st ==>b BFalse
| BS_NotFalse : forall st,
    (BNot BFalse) / st ==>b BTrue
| BS_NotStep : forall st b1 b1',
    b1 / st ==>b b1' ->
    (BNot b1) / st ==>b (BNot b1')
| BS_AndTrueTrue : forall st,
    (BAnd BTrue BTrue) / st ==>b BTrue
| BS_AndTrueFalse : forall st,
    (BAnd BTrue BFalse) / st ==>b BFalse
| BS_AndFalse : forall st b2,
    (BAnd BFalse b2) / st ==>b BFalse
| BS_AndTrueStep : forall st b2 b2',
    b2 / st ==>b b2' ->
    (BAnd BTrue b2) / st ==>b (BAnd BTrue b2')
| BS_AndStep : forall st b1 b1' b2,
    b1 / st ==>b b1' ->
    (BAnd b1 b2) / st ==>b (BAnd b1' b2)

where " t '/' st '==>b' t' " := (bstep st t t').

Reserved Notation " t '/' st '==>' t' '/' st' "
                  (at level 40, st at level 39, t' at level 39).
Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / (st & { i --> n })
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      IFB BTrue THEN c1 ELSE c2 FI / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      IFB BFalse THEN c1 ELSE c2 FI / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b / st ==>b b' ->
          IFB b THEN c1 ELSE c2 FI / st
      ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      ==> (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st

  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).

Module CImp.
Inductive com : Type :=
  | CSkip : com
  | CAss : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  (* New: *)
  | CPar : com -> com -> com.
Notation "'SKIP'" :=
  CSkip.
Notation "x '::=' a" :=
  (CAss x a) (at level 60).
Notation "c1 ;; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' b 'THEN' c1 'ELSE' c2 'FI'" :=
  (CIf b c1 c2) (at level 80, right associativity).
Notation "'PAR' c1 'WITH' c2 'END'" :=
  (CPar c1 c2) (at level 80, right associativity).
Inductive cstep : (com * state) -> (com * state) -> Prop :=
    (* Old part *)
  | CS_AssStep : forall st i a a',
      a / st ==>a a' ->
      (i ::= a) / st ==> (i ::= a') / st
  | CS_Ass : forall st i n,
      (i ::= (ANum n)) / st ==> SKIP / st & { i --> n }
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st ==> c1' / st' ->
      (c1 ;; c2) / st ==> (c1' ;; c2) / st'
  | CS_SeqFinish : forall st c2,
      (SKIP ;; c2) / st ==> c2 / st
  | CS_IfTrue : forall st c1 c2,
      (IFB BTrue THEN c1 ELSE c2 FI) / st ==> c1 / st
  | CS_IfFalse : forall st c1 c2,
      (IFB BFalse THEN c1 ELSE c2 FI) / st ==> c2 / st
  | CS_IfStep : forall st b b' c1 c2,
      b /st ==>b b' ->
          (IFB b THEN c1 ELSE c2 FI) / st
      ==> (IFB b' THEN c1 ELSE c2 FI) / st
  | CS_While : forall st b c1,
          (WHILE b DO c1 END) / st
      ==> (IFB b THEN (c1;; (WHILE b DO c1 END)) ELSE SKIP FI) / st
    (* New part: *)
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st ==> c1' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1' WITH c2 END) / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st ==> c2' / st' ->
      (PAR c1 WITH c2 END) / st ==> (PAR c1 WITH c2' END) / st'
  | CS_ParDone : forall st,
      (PAR SKIP WITH SKIP END) / st ==> SKIP / st
  where " t '/' st '==>' t' '/' st' " := (cstep (t,st) (t',st')).
Definition cmultistep := multi cstep.
Notation " t '/' st '==>*' t' '/' st' " :=
   (multi cstep (t,st) (t',st'))
   (at level 40, st at level 39, t' at level 39).

Definition par_loop : com :=
  PAR
    Y ::= 1
  WITH
    WHILE Y = 0 DO
      X ::= X + 1
    END
  END.

Example par_loop_example_0:
  exists st',
       par_loop / { --> 0 } ==>* SKIP / st'
    /\ st' X = 0.
Proof.
eapply ex_intro. split.
eapply multi_step. apply CS_Par1.
apply CS_Ass. eapply multi_step.
apply CS_Par2. apply CS_While.
eapply multi_step. eapply CS_Par2.
apply CS_IfStep. apply BS_Eq1.
apply AS_Id. eapply multi_step.
apply CS_Par2. apply CS_IfStep.
apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  eapply multi_refl.
  reflexivity. Qed.

Example par_loop_example_2:
  exists st',
       par_loop / { --> 0 } ==>* SKIP / st'
    /\ st' X = 2.
Proof.
Admitted.

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / { --> 0 } ==>* SKIP / st'
    /\ st' X = n.
Proof.
Admitted.


(* First, let us look at some example : *)

Lemma P3Q : forall P Q : Prop, (((P->Q)->Q)->Q) -> P -> Q.
Proof.
 intros P Q H p.
 apply H.
 intro H0.
 apply H0.
 assumption.
Qed.

Lemma triple_neg : forall P:Prop, ~~~P -> ~P.
Proof.
  intros P.
  unfold not.
  apply P3Q.
Qed.

Lemma all_perm :
 forall (A:Type) (P:A -> A -> Prop),
   (forall x y:A, P x y) -> forall x y:A, P y x.
Proof.
  intros.
  apply (H y x).
Qed.

Lemma resolution :
 forall (A:Type) (P Q R S:A -> Prop),
   (forall a:A, Q a -> R a -> S a) ->
   (forall b:A, P b -> Q b) ->
   forall c:A, P c -> R c -> S c.
Proof.
  intros.
  apply H.
  * apply H0.
    apply H1.
  * apply H2.
Qed.

Lemma not_ex_forall_not : forall (A: Type) (P: A -> Prop),
                      ~(exists x, P x) <-> forall x, ~ P x.
Proof.
  intros.
  split.
  * intro.
    intro.
    unfold not in H.
    unfold not.
    intro.
    apply H.
    exists x.
    assumption.
  * intro.
    unfold not.
    intro.
    unfold not in H.
    destruct H0.
    apply (H x).
    assumption.
Qed.

Lemma ex_not_forall_not : forall (A: Type) (P: A -> Prop),
                       (exists x, P x) -> ~ (forall x, ~ P x).
Proof.
  intros.
  unfold not.
  destruct H.
  intro.
  apply (H0 x).
  assumption.
Qed.

Lemma diff_sym : forall (A:Type) (a b : A), a <> b -> b <> a.
Proof.
  intros.
  unfold not.
  unfold not in H.
  intro.
  apply H.
  symmetry.
  assumption.
Qed.

Lemma fun_diff :  forall (A B:Type) (f : A -> B) (a b : A),
                       f a <> f b -> a <> b.
Proof.
  intros.
  unfold not.
  intro.
  unfold not in H.
  apply H.
  rewrite H0.
  trivial.
Qed.


Require Export GeoCoq.Tarski_dev.Ch04_col.
Require Import GeoCoq.Utils.all_equiv.

Section Equivalence_between_decidability_properties_of_basic_relations.

Context `{Tn:Tarski_neutral_dimensionless}.

Lemma cong_dec_eq_dec :
  (forall A B C D, Cong A B C D \/ ~ Cong A B C D) ->
  (forall A B:Tpoint, A=B \/ A<>B).
Proof.
    intros H A B.
    elim (H A B A A); intro HCong.
      left; apply cong_identity with A; assumption.
    right; intro; subst; apply HCong.
    apply cong_pseudo_reflexivity.
Qed.

Lemma eq_dec_implies_l2_11 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C A' B' C',
  Bet A B C -> Bet A' B' C' -> Cong A B A' B' -> Cong B C B' C' -> Cong A C A' C'.
Proof.
intro eq_dec; intros.
induction (eq_dec A B).
subst B.
assert (A' = B') by (apply (cong_identity A' B' A); Cong).
subst; Cong.
apply cong_commutativity; apply (five_segment A A' B B' C C' A A'); Cong.
Qed.

Lemma eq_dec_implies_construction_uniqueness :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall Q A B C X Y,
  Q <> A -> Bet Q A X -> Cong A X B C -> Bet Q A Y -> Cong A Y B C -> X=Y.
Proof.
intro eq_dec; intros.
assert (Cong A X A Y) by eCong.
assert (Cong Q X Q Y) by (apply (eq_dec_implies_l2_11 eq_dec Q A X Q A Y);Cong).
assert(OFSC Q A X Y Q A X X) by (unfold OFSC;repeat split;Cong).
apply five_segment_with_def in H6; try assumption.
apply cong_identity with X; Cong.
Qed.

Lemma eq_dec_implies_outer_transitivity_between2 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D, Bet A B C -> Bet B C D -> B<>C -> Bet A C D.
Proof.
intro eq_dec; intros.
prolong A C x C D.
assert (x = D) by (apply (eq_dec_implies_construction_uniqueness eq_dec B C C D); try apply (between_exchange3 A B C x); Cong).
subst x;assumption.
Qed.

Lemma eq_dec_implies_between_exchange4 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D, Bet A B C -> Bet A C D -> Bet A B D.
Proof.
intro eq_dec; intros.
induction (eq_dec B C); [subst; auto|].
apply between_symmetry;
apply eq_dec_implies_outer_transitivity_between2 with C; eBetween.
Qed.

Lemma eq_dec_implies_two_distinct_points :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  exists X, exists Y: Tpoint, X <> Y.
Proof.
intro eq_dec.
assert (ld:=lower_dim_ex).
ex_elim ld A.
ex_elim H B.
ex_elim H0 C.
induction (eq_dec A B).
subst A; exists B; exists C; Between.
exists A; exists B; assumption.
Qed.

Lemma eq_dec_implies_point_construction_different :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B, exists C, Bet A B C /\ B <> C.
Proof.
intro eq_dec; intros.
assert (tdp := eq_dec_implies_two_distinct_points eq_dec).
ex_elim tdp x.
ex_elim H y.
prolong A B F x y.
exists F.
show_distinct B F.
intuition.
intuition.
Qed.

Lemma eq_dec_implies_l4_2 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D A' B' C' D', IFSC A B C D A' B' C' D' -> Cong B D B' D'.
Proof.
unfold IFSC.
intro eq_dec; intros.
spliter.

induction (eq_dec A C).

treat_equalities;assumption.

assert (exists E, Bet A C E /\ C <> E)
 by (apply eq_dec_implies_point_construction_different; auto).
ex_and H6 E.
prolong A' C' E' C E.

assert  (Cong E D E' D')
 by (
  apply (five_segment_with_def A C E D A' C' E' D');[
  unfold OFSC;  repeat split;Cong|
  assumption]).

apply (five_segment_with_def E C B D E' C' B' D').
unfold OFSC.
repeat split; try solve [eBetween| Cong ].
auto.
Qed.

Lemma eq_dec_implies_l4_5 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C A' C',
  Bet A B C -> Cong A C A' C' ->
  exists B', Bet A' B' C' /\ Cong_3 A B C A' B' C'.
Proof.
intro eq_dec; intros.
unfold Cong_3.

assert (exists D', Bet C' A' D' /\ A' <> D')
 by (apply eq_dec_implies_point_construction_different; auto).
ex_and H1 x'.
prolong x' A' B' A B.
prolong x' B' C'' B C.

assert (Bet A' B' C'') by eBetween.

assert (C'' = C').
eapply (eq_dec_implies_construction_uniqueness eq_dec x' A' ).

auto.

apply eq_dec_implies_between_exchange4 with B'; auto.

apply (eq_dec_implies_l2_11 eq_dec A' B' C'' A B C);Between.

eBetween.
Cong.

subst C''.
exists B'.
repeat split;Cong.
Qed.

Lemma eq_dec_implies_l4_6 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C A' B' C', Bet A B C -> Cong_3 A B C A' B' C' -> Bet A' B' C'.
Proof.
unfold Cong_3.
intro eq_dec; intros.
assert (exists B'', Bet A' B'' C' /\ Cong_3 A B C A' B'' C')
  by (eapply eq_dec_implies_l4_5;intuition).
ex_and H1 x.
unfold Cong_3 in *;spliter.

assert (Cong_3 A' x C' A' B' C')
 by (unfold Cong_3;repeat split;eCong).
unfold Cong_3 in H7;spliter.

assert (IFSC A' x C' x  A' x C' B')
 by (unfold IFSC;repeat split;Cong).
assert (Cong x x x B')
 by (eapply eq_dec_implies_l4_2; try apply H10; auto).
Between.
Qed.

Lemma eq_dec_implies_l4_16 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D A' B' C' D',
  FSC A B C D A' B' C' D' -> A<>B -> Cong C D C' D'.
Proof.
unfold FSC.
unfold Col.
intro eq_dec; intros.
decompose [or and] H; clear H.
assert (Bet A' B' C') by (eapply eq_dec_implies_l4_6;eauto).
unfold Cong_3 in *; spliter.
assert(OFSC A B C D A' B' C' D') by (unfold OFSC;repeat split; assumption).
eapply five_segment_with_def; eauto.
assert(Bet B' C' A') by (apply (eq_dec_implies_l4_6 eq_dec B C A B' C' A'); Cong;auto with cong3).
apply (eq_dec_implies_l4_2 eq_dec B C A D B' C' A' D').
unfold IFSC; unfold Cong_3 in *; spliter; repeat split;Between;Cong.
assert (Bet C' A' B') by (eapply (eq_dec_implies_l4_6 eq_dec C A B C' A' B'); auto with cong3).
eapply (five_segment_with_def B A C D B' A'); unfold OFSC; unfold Cong_3 in *; spliter; repeat split; Between; Cong.
Qed.

Lemma eq_dec_implies_l4_17 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C P Q,
  A<>B -> Col A B C -> Cong A P A Q -> Cong B P B Q -> Cong C P C Q.
Proof.
intros.
assert (FSC A B C P A B C Q) by (unfold FSC; unfold Cong_3; repeat split;Cong).
eapply eq_dec_implies_l4_16; eauto.
Qed.

Lemma eq_dec_implies_l5_1 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D,
  A<>B -> Bet A B C -> Bet A B D -> Bet A C D \/ Bet A D C.
Proof.
intro eq_dec; intros.
prolong A D C' C D.
prolong A C D' C D.
prolong A C' B' C B.
prolong A D' B'' D B.
assert (Cong B C' B'' C).
apply (eq_dec_implies_l2_11 eq_dec B D C' B'' D' C).
apply between_exchange3 with A; Between.
apply between_inner_transitivity with A; Between.
Cong.
apply cong_transitivity with C D; Cong.
assert (Cong B B' B'' B).
  {
  apply (eq_dec_implies_l2_11 eq_dec B C' B' B'' C B); Cong.

    {
    assert (Bet A B C'); [|eBetween].
    induction (eq_dec B D); [treat_equalities; auto|].
    apply between_symmetry.
    apply eq_dec_implies_outer_transitivity_between2 with D; eBetween.
    }

    {
    induction (eq_dec C D'); [treat_equalities; eBetween|].
    apply eq_dec_implies_outer_transitivity_between2 with D'; eBetween.
    }
  }
assert(B'' =  B').
apply (eq_dec_implies_construction_uniqueness eq_dec A B B B''); try Cong.
apply eq_dec_implies_between_exchange4 with D'; Between;
apply eq_dec_implies_between_exchange4 with C; Between.
apply eq_dec_implies_between_exchange4 with C'; Between;
apply eq_dec_implies_between_exchange4 with D; Between.
subst B''.
assert (FSC B C D' C' B' C' D C).
unfold FSC.
repeat split; unfold Col; try Cong.
left; apply between_exchange3 with A; Between.
apply (eq_dec_implies_l2_11 eq_dec B C D' B' C' D); Cong.
apply between_exchange3 with A; assumption.
apply between_symmetry.
apply between_exchange3 with A; assumption.
apply cong_transitivity with C D; Cong.
apply cong_transitivity with C D; Cong.
induction (eq_dec B C).
subst C; auto.
assert (Cong D' C' D C) by (eapply eq_dec_implies_l4_16; try apply H12; assumption).
assert (exists E, Bet C E C' /\ Bet D E D') by (apply inner_pasch with A; Between).
ex_and H15 E.
assert (IFSC D E D' C D E D' C') by (unfold IFSC; repeat split; Cong; apply cong_transitivity with C D; Cong).
assert (IFSC C E C' D C E C' D') by (unfold IFSC; repeat split; Cong; apply cong_transitivity with C D; Cong).
assert (Cong E C E C') by (eapply eq_dec_implies_l4_2; try apply H17; auto).
assert (Cong E D E D') by (eapply eq_dec_implies_l4_2; try apply H18; auto).
induction (eq_dec C C').
subst C'; right; assumption.
show_distinct C D'; intuition.
prolong C' C P C D'.
prolong D' C R C E.
prolong P R Q R P.
assert (FSC D' C R P P C E D').
unfold FSC.
unfold Cong_3.
assert_cols.
repeat split; Cong.
apply eq_dec_implies_l2_11 with C C; Cong.
apply between_inner_transitivity with C'; Between.
assert (Cong R P E D') by (eauto using eq_dec_implies_l4_16).
assert (Cong R Q E D).
eapply cong_transitivity.
apply cong_transitivity with R P; Cong.
apply cong_transitivity with E D'; Cong.
assert (FSC D' E D C P R Q C).
unfold FSC.
repeat split; Cong.
unfold Col; Between.
eapply (eq_dec_implies_l2_11 eq_dec D' E D P R Q); Between; Cong.
assert (Cong D C Q C).
induction (eq_dec D' E).
unfold FSC, IFSC, Cong_3 in *; spliter; treat_equalities; Cong.
apply eq_dec_implies_l4_16 with D' E P R; assumption.
assert (Cong C P C Q).
unfold FSC in *;unfold Cong_3 in *.
spliter.
apply cong_transitivity with C D.
apply cong_transitivity with C D'; Cong.
Cong.
show_distinct R C.
intuition.
assert (Cong D' P D' Q) by (apply (eq_dec_implies_l4_17 eq_dec R C); unfold Col; Between; Cong).
assert (Cong B P B Q).
apply eq_dec_implies_l4_17 with C D'; try assumption.
unfold Col; right;right.
apply between_exchange3 with A; assumption.
assert (Cong B' P B' Q).
eapply (eq_dec_implies_l4_17 eq_dec C D'); Cong.
unfold Col; left.
apply between_exchange3 with A; assumption.
assert (Cong C' P C' Q).
induction(eq_dec B B').
subst B'.
unfold IFSC,FSC, Cong_3 in *.
spliter.
clean_duplicated_hyps.
clean_trivial_hyps.
apply eq_dec_implies_l4_17 with C D'; try assumption.
unfold Col; left.
apply between_exchange3 with A; try assumption.
apply eq_dec_implies_between_exchange4 with B; try assumption.
apply eq_dec_implies_between_exchange4 with D; assumption.
eapply eq_dec_implies_l4_17 with B B'; Cong.
unfold Col; right; left.
apply between_symmetry.
apply between_exchange3 with A; try assumption.
apply eq_dec_implies_between_exchange4 with D; assumption.
assert (Cong P P P Q).
apply eq_dec_implies_l4_17 with C C'; try assumption.
unfold Col; right; right.
apply between_symmetry; assumption.
unfold IFSC,FSC, Cong_3 in *; spliter.
treat_equalities.
Between.
Qed.

Lemma eq_dec_implies_l5_2 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C D,
  A<>B -> Bet A B C -> Bet A B D -> Bet B C D \/ Bet B D C.
Proof.
intros.
assert (Bet A C D \/ Bet A D C) by (eapply eq_dec_implies_l5_1; eauto).
induction H3.
left; eBetween.
right; eBetween.
Qed.

Lemma eq_dec_implies_segment_construction_2 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A Q B C, A<>Q -> exists X, (Bet Q A X \/ Bet Q X A) /\ Cong Q X B C.
Proof.
intro eq_dec; intros.
prolong A Q A' A Q.
prolong A' Q X B C.
exists X.
show_distinct A' Q.
solve [intuition].
split; try assumption.
eapply (eq_dec_implies_l5_2 eq_dec A' Q); Between.
Qed.

Lemma eq_dec_implies_between_cong :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B C, Bet A C B -> Cong A C A B -> C=B.
Proof.
intros.
assert (Bet A B C).
eapply eq_dec_implies_l4_6 with A C B; unfold Cong_3; repeat split; Cong.
eapply between_equality; eBetween.
Qed.

Lemma eq_dec_cong_dec :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  (forall A B C D, Cong A B C D \/ ~ Cong A B C D).
Proof.
intro eq_dec; intros.
elim (eq_dec A B); intro; subst; elim (eq_dec C D); intro; subst.
left; Cong.
right; intro; apply H; apply cong_identity with B; Cong.
right; intro; apply H; apply cong_identity with D; Cong.
elim (eq_dec_implies_segment_construction_2 eq_dec B A C D).
intros D' HD'.
spliter.
elim (eq_dec B D');intro.
subst; left; assumption.
right; intro.
assert (Cong A D' A B) by eCong.
elim H1; intro; clear H1.
assert (B = D') by (apply (eq_dec_implies_between_cong eq_dec A D' B); Cong).
subst;intuition.
assert (D'=B) by (apply (eq_dec_implies_between_cong eq_dec A B D');assumption).
subst;intuition.
intuition.
Qed.

Lemma bet_dec_eq_dec :
  (forall A B C, Bet A B C \/ ~ Bet A B C) ->
  (forall A B:Tpoint, A=B \/ A<>B).
Proof.
intros.
induction (H A B A).
left; apply between_identity; assumption.
right; intro; subst; apply H0;  apply between_trivial.
Qed.

Lemma eq_dec_implies_between_cong_3 :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  forall A B D E, A <> B -> Bet A B D -> Bet A B E -> Cong B D B E -> D = E.
Proof.
intro eq_dec; intros.
assert (T:=eq_dec_implies_l5_2 eq_dec A B D E H H0 H1).
elim T; intro; clear T.
apply eq_dec_implies_between_cong with B; Cong.
symmetry; apply eq_dec_implies_between_cong with B; Cong.
Qed.

Lemma eq_dec_bet_dec :
  (forall A B:Tpoint, A=B \/ A<>B) ->
  (forall A B C, Bet A B C \/ ~ Bet A B C).
Proof.
intro eq_dec; intros.
elim (segment_construction A B B C); intros C' HC'.
spliter.
elim (eq_dec C C'); intro.
subst; tauto.
elim (eq_dec A B);intro.
left; subst; Between.
right; intro; apply H1; apply eq_dec_implies_between_cong_3 with A B; Cong.
Qed.

Definition decidability_of_equality_of_points := forall A B:Tpoint, A=B \/ A<>B.

Definition decidability_of_congruence_of_points := forall A B C D:Tpoint,
  Cong A B C D \/ ~ Cong A B C D.

Definition decidability_of_betweenness_of_points := forall A B C:Tpoint,
  Bet A B C \/ ~ Bet A B C.

Theorem equivalence_between_decidability_properties_of_basic_relations :
  all_equiv  (decidability_of_equality_of_points::
              decidability_of_congruence_of_points::
              decidability_of_betweenness_of_points::nil).
Proof.
unfold all_equiv.
simpl.
intros.
assert (P:=cong_dec_eq_dec).
assert (Q:=eq_dec_cong_dec).
assert (R:=bet_dec_eq_dec).
assert (S:=eq_dec_bet_dec).
decompose [or] H;clear H;decompose [or] H0;clear H0;subst; tauto.
Qed.

End Equivalence_between_decidability_properties_of_basic_relations.


(***************************** LIFLF - TPNOTE *********************************)
(************* Evaluation pratique en temps limité : 30' **********************)

(************************ SUJET D'ENTRAINEMENT ********************************)
(* Ce sujet est représentatif de celui qui vous sera donné à réaliser en temps
limité. Les fonctions lemmes demandés ici sont tout à fait classiques.
*)
Require Import Utf8.

(******************************************************************************)
(* Logique propositionnelle *)
(******************************************************************************)
Section PL.

Context (P Q : Prop).

(* EXERCICE : prouver la propriété suivante SANS UTILISER UNE TACTIQUE AUTOMATIQUE *)
Lemma de_morgan : (~P \/ ~Q) -> ~(P /\ Q).
Proof.
unfold not.
intros.
destruct H.
apply H.
destruct H0.
assumption.
apply H.
destruct H0.
assumption.
Qed.

End PL.

(******************************************************************************)
(* Les listes *)
(******************************************************************************)

Print length. (* la longueur de listes *)

(* EXERCICE :  énoncer le lemme "mystere" en langue naturelle *)
Lemma mystere A:  forall l : list A, length l = 0 <-> l = nil.
Proof.
induction l; split.
- simpl. reflexivity.
- simpl. reflexivity.
- intros. discriminate H.
- simpl. intros. discriminate H.
Qed.

Goal 1 = 0 -> 42 = 3.
Proof.
intros.
discriminate H.
Qed.

(* EXERCICE :  prouver le lemme "mystere"  SANS UTILISER "Require Import List." *)


Require Import Arith.

Goal forall m n : nat, (n * 10) + m = (10 * n) + m.
Proof.
  intros.
  apply NPeano.Nat.add_cancel_r.
  apply mult_comm.
Qed.