Require Export SfLib.

(** Assignment 09 *)
(** Due: 2016/05/15 23:59 *)

(* Important:
   - You are NOT allowed to use the [admit] tactic.

   - You are ALLOWED to use any tactics including:

     [tauto], [intuition], [firstorder], [omega].

   - Just leave [exact GIVEUP] for those problems that you fail to prove.
*)

Definition GIVEUP {T: Type} : T.  Admitted.

Axiom functional_extensionality : forall {X Y: Type} {f g : X -> Y},
    (forall (x: X), f x = g x) ->  f = g.

Definition state := id -> nat.

Definition empty_state : state :=
  fun _ => 0.

Definition update (st : state) (x : id) (n : nat) : state :=
  fun x' => if eq_id_dec x x' then n else st x'.

Inductive aexp : Type :=
  | ANum : nat -> aexp
  | AId : id -> aexp                (* <----- NEW *)
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

Tactic Notation "aexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ANum" | Case_aux c "AId" | Case_aux c "APlus"
  | Case_aux c "AMinus" | Case_aux c "AMult" ].

(** Defining a few variable names as notational shorthands will make
    examples easier to read: *)

Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

Opaque X.
Opaque Y.
Opaque Z.

Inductive bexp : Type :=
  | BTrue : bexp
  | BFalse : bexp
  | BEq : aexp -> aexp -> bexp
  | BLe : aexp -> aexp -> bexp
  | BNot : bexp -> bexp
  | BAnd : bexp -> bexp -> bexp.

Tactic Notation "bexp_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "BTrue" | Case_aux c "BFalse" | Case_aux c "BEq"
  | Case_aux c "BLe" | Case_aux c "BNot" | Case_aux c "BAnd" ].

Fixpoint aeval (st : state) (a : aexp) : nat :=
  match a with
  | ANum n => n
  | AId x => st x
  | APlus a1 a2 => (aeval st a1) + (aeval st a2)
  | AMinus a1 a2  => (aeval st a1) - (aeval st a2)
  | AMult a1 a2 => (aeval st a1) * (aeval st a2)
  end.

Fixpoint beval (st : state) (b : bexp) : bool :=
  match b with
  | BTrue       => true
  | BFalse      => false
  | BEq a1 a2   => beq_nat (aeval st a1) (aeval st a2)
  | BLe a1 a2   => ble_nat (aeval st a1) (aeval st a2)
  | BNot b1     => negb (beval st b1)
  | BAnd b1 b2  => andb (beval st b1) (beval st b2)
  end.

Inductive com : Type :=
  | CSkip : com
  | CAss : id -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com.

Tactic Notation "com_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "SKIP" | Case_aux c "::=" | Case_aux c ";;"
  | Case_aux c "IFB" | Case_aux c "WHILE" ].

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' c1 'THEN' c2 'ELSE' c3 'FI'" :=
  (CIf c1 c2 c3) (at level 80, right associativity).

Reserved Notation "c1 '/' st '||' st'" (at level 40, st at level 39).

Inductive ceval : com -> state -> state -> Prop :=
  | E_Skip : forall st,
      SKIP / st || st
  | E_Ass  : forall st a1 n x,
      aeval st a1 = n ->
      (x ::= a1) / st || (update st x n)
  | E_Seq : forall c1 c2 st st' st'',
      c1 / st  || st' ->
      c2 / st' || st'' ->
      (c1 ;; c2) / st || st''
  | E_IfTrue : forall st st' b c1 c2,
      beval st b = true ->
      c1 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_IfFalse : forall st st' b c1 c2,
      beval st b = false ->
      c2 / st || st' ->
      (IFB b THEN c1 ELSE c2 FI) / st || st'
  | E_WhileEnd : forall b st c,
      beval st b = false ->
      (WHILE b DO c END) / st || st
  | E_WhileLoop : forall st st' st'' b c,
      beval st b = true ->
      c / st || st' ->
      (WHILE b DO c END) / st' || st'' ->
      (WHILE b DO c END) / st || st''

  where "c1 '/' st '||' st'" := (ceval c1 st st').

Tactic Notation "ceval_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "E_Skip" | Case_aux c "E_Ass" | Case_aux c "E_Seq"
  | Case_aux c "E_IfTrue" | Case_aux c "E_IfFalse"
  | Case_aux c "E_WhileEnd" | Case_aux c "E_WhileLoop" ].

Definition aequiv (a1 a2 : aexp) : Prop :=
  forall (st:state),
    aeval st a1 = aeval st a2.

Definition bequiv (b1 b2 : bexp) : Prop :=
  forall (st:state),
    beval st b1 = beval st b2.

(** For commands, the situation is a little more subtle.  We can't
    simply say "two commands are behaviorally equivalent if they
    evaluate to the same ending state whenever they are started in the
    same initial state," because some commands (in some starting
    states) don't terminate in any final state at all!  What we need
    instead is this: two commands are behaviorally equivalent if, for
    any given starting state, they either both diverge or both
    terminate in the same final state.  A compact way to express this
    is "if the first one terminates in a particular state then so does
    the second, and vice versa." *)

Definition cequiv (c1 c2 : com) : Prop :=
  forall (st st' : state),
    (c1 / st || st') <-> (c2 / st || st').

Definition atrans_sound (atrans : aexp -> aexp) : Prop :=
  forall (a : aexp),
    aequiv a (atrans a).

Definition btrans_sound (btrans : bexp -> bexp) : Prop :=
  forall (b : bexp),
    bequiv b (btrans b).

Definition ctrans_sound (ctrans : com -> com) : Prop :=
  forall (c : com),
    cequiv c (ctrans c).

(* ####################################################### *)
(** ** Behavioral Equivalence is an Equivalence *)

Lemma refl_aequiv : forall (a : aexp), aequiv a a.
Proof.
  intros a st. reflexivity.  Qed.

Lemma sym_aequiv : forall (a1 a2 : aexp),
  aequiv a1 a2 -> aequiv a2 a1.
Proof.
  intros a1 a2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_aequiv : forall (a1 a2 a3 : aexp),
  aequiv a1 a2 -> aequiv a2 a3 -> aequiv a1 a3.
Proof.
  unfold aequiv. intros a1 a2 a3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_bequiv : forall (b : bexp), bequiv b b.
Proof.
  unfold bequiv. intros b st. reflexivity.  Qed.

Lemma sym_bequiv : forall (b1 b2 : bexp),
  bequiv b1 b2 -> bequiv b2 b1.
Proof.
  unfold bequiv. intros b1 b2 H. intros st. symmetry. apply H.  Qed.

Lemma trans_bequiv : forall (b1 b2 b3 : bexp),
  bequiv b1 b2 -> bequiv b2 b3 -> bequiv b1 b3.
Proof.
  unfold bequiv. intros b1 b2 b3 H12 H23 st.
  rewrite (H12 st). rewrite (H23 st). reflexivity.  Qed.

Lemma refl_cequiv : forall (c : com), cequiv c c.
Proof.
  unfold cequiv. intros c st st'. apply iff_refl.  Qed.

Lemma sym_cequiv : forall (c1 c2 : com),
  cequiv c1 c2 -> cequiv c2 c1.
Proof.
  unfold cequiv. intros c1 c2 H st st'.
  assert (c1 / st || st' <-> c2 / st || st') as H'.
    SCase "Proof of assertion". apply H.
  apply iff_sym. assumption.
Qed.

Lemma iff_trans : forall (P1 P2 P3 : Prop),
  (P1 <-> P2) -> (P2 <-> P3) -> (P1 <-> P3).
Proof.
  intros P1 P2 P3 H12 H23.
  inversion H12. inversion H23.
  split; intros A.
    apply H1. apply H. apply A.
    apply H0. apply H2. apply A.  Qed.

Lemma trans_cequiv : forall (c1 c2 c3 : com),
  cequiv c1 c2 -> cequiv c2 c3 -> cequiv c1 c3.
Proof.
  unfold cequiv. intros c1 c2 c3 H12 H23 st st'.
  apply iff_trans with (c2 / st || st'). apply H12. apply H23.  Qed.

(* ######################################################## *)
(** ** Behavioral Equivalence is a Congruence *)

Theorem CAss_congruence : forall i a1 a1',
  aequiv a1 a1' ->
  cequiv (CAss i a1) (CAss i a1').
Proof.
  intros i a1 a2 Heqv st st'.
  split; intros Hceval.
  Case "->".
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.
  Case "<-".
    inversion Hceval. subst. apply E_Ass.
    rewrite Heqv. reflexivity.  Qed.

(** The congruence property for loops is a little more interesting,
    since it requires induction.

    _Theorem_: Equivalence is a congruence for [WHILE] -- that is, if
    [b1] is equivalent to [b1'] and [c1] is equivalent to [c1'], then
    [WHILE b1 DO c1 END] is equivalent to [WHILE b1' DO c1' END].

    _Proof_: Suppose [b1] is equivalent to [b1'] and [c1] is
    equivalent to [c1'].  We must show, for every [st] and [st'], that
    [WHILE b1 DO c1 END / st || st'] iff [WHILE b1' DO c1' END / st
    || st'].  We consider the two directions separately.

      - ([->]) We show that [WHILE b1 DO c1 END / st || st'] implies
        [WHILE b1' DO c1' END / st || st'], by induction on a
        derivation of [WHILE b1 DO c1 END / st || st'].  The only
        nontrivial cases are when the final rule in the derivation is
        [E_WhileEnd] or [E_WhileLoop].

          - [E_WhileEnd]: In this case, the form of the rule gives us
            [beval st b1 = false] and [st = st'].  But then, since
            [b1] and [b1'] are equivalent, we have [beval st b1' =
            false], and [E-WhileEnd] applies, giving us [WHILE b1' DO
            c1' END / st || st'], as required.

          - [E_WhileLoop]: The form of the rule now gives us [beval st
            b1 = true], with [c1 / st || st'0] and [WHILE b1 DO c1
            END / st'0 || st'] for some state [st'0], with the
            induction hypothesis [WHILE b1' DO c1' END / st'0 ||
            st'].

            Since [c1] and [c1'] are equivalent, we know that [c1' /
            st || st'0].  And since [b1] and [b1'] are equivalent, we
            have [beval st b1' = true].  Now [E-WhileLoop] applies,
            giving us [WHILE b1' DO c1' END / st || st'], as
            required.

      - ([<-]) Similar. [] *)

Theorem CWhile_congruence : forall b1 b1' c1 c1',
  bequiv b1 b1' -> cequiv c1 c1' ->
  cequiv (WHILE b1 DO c1 END) (WHILE b1' DO c1' END).
Proof.
  (* WORKED IN CLASS *)
  unfold bequiv,cequiv.
  intros b1 b1' c1 c1' Hb1e Hc1e st st'.
  split; intros Hce.
  Case "->".
    remember (WHILE b1 DO c1 END) as cwhile eqn:Heqcwhile.
    induction Hce; inversion Heqcwhile; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite <- Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite <- Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st').  apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity.
  Case "<-".
    remember (WHILE b1' DO c1' END) as c'while eqn:Heqc'while.
    induction Hce; inversion Heqc'while; subst.
    SCase "E_WhileEnd".
      apply E_WhileEnd. rewrite -> Hb1e. apply H.
    SCase "E_WhileLoop".
      apply E_WhileLoop with (st' := st').
      SSCase "show loop runs". rewrite -> Hb1e. apply H.
      SSCase "body execution".
        apply (Hc1e st st').  apply Hce1.
      SSCase "subsequent loop execution".
        apply IHHce2. reflexivity.  Qed.

(* ######################################################## *)
(** ** Definitions used in the exercises *)

Definition loop : com :=
  WHILE BTrue DO
    SKIP
  END.

Fixpoint no_whiles (c : com) : bool :=
  match c with
  | SKIP       => true
  | _ ::= _    => true
  | c1 ;; c2  => andb (no_whiles c1) (no_whiles c2)
  | IFB _ THEN ct ELSE cf FI => andb (no_whiles ct) (no_whiles cf)
  | WHILE _ DO _ END  => false
  end.

Fixpoint fold_constants_aexp (a : aexp) : aexp :=
  match a with
  | ANum n       => ANum n
  | AId i        => AId i
  | APlus a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 + n2)
      | (a1', a2') => APlus a1' a2'
      end
  | AMinus a1 a2 =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 - n2)
      | (a1', a2') => AMinus a1' a2'
      end
  | AMult a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => ANum (n1 * n2)
      | (a1', a2') => AMult a1' a2'
      end
  end.

Fixpoint fold_constants_bexp (b : bexp) : bexp :=
  match b with
  | BTrue        => BTrue
  | BFalse       => BFalse
  | BEq a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => if beq_nat n1 n2 then BTrue else BFalse
      | (a1', a2') => BEq a1' a2'
      end
  | BLe a1 a2  =>
      match (fold_constants_aexp a1, fold_constants_aexp a2) with
      | (ANum n1, ANum n2) => if ble_nat n1 n2 then BTrue else BFalse
      | (a1', a2') => BLe a1' a2'
      end
  | BNot b1  =>
      match (fold_constants_bexp b1) with
      | BTrue => BFalse
      | BFalse => BTrue
      | b1' => BNot b1'
      end
  | BAnd b1 b2  =>
      match (fold_constants_bexp b1, fold_constants_bexp b2) with
      | (_, BFalse) | (BFalse, _) => BFalse
      | (b1', BTrue) | (BTrue, b1') => b1'
      | (b1', b2') => BAnd b1' b2'
      end
  end.

Fixpoint fold_constants_com (c : com) : com :=
  match c with
  | SKIP      =>
      SKIP
  | i ::= a  =>
      CAss i (fold_constants_aexp a)
  | SKIP ;; c' | c' ;; SKIP => c'
  | c1 ;; c2  =>
      (fold_constants_com c1) ;; (fold_constants_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      match fold_constants_bexp b with
      | BTrue => fold_constants_com c1
      | BFalse => fold_constants_com c2
      | b' => IFB b' THEN fold_constants_com c1
                     ELSE fold_constants_com c2 FI
      end
  | WHILE b DO c END =>
      match fold_constants_bexp b with
      | BTrue => WHILE BTrue DO SKIP END
      | BFalse => SKIP
      | b' => WHILE b' DO (fold_constants_com c) END
      end
  end.

Theorem fold_constants_aexp_sound :
  atrans_sound fold_constants_aexp.
Proof.
  unfold atrans_sound. intros a. unfold aequiv. intros st.
  aexp_cases (induction a) Case; simpl;
    (* ANum and AId follow immediately *)
    try reflexivity;
    (* APlus, AMinus, and AMult follow from the IH
       and the observation that
              aeval st (APlus a1 a2)
            = ANum ((aeval st a1) + (aeval st a2))
            = aeval st (ANum ((aeval st a1) + (aeval st a2)))
       (and similarly for AMinus/minus and AMult/mult) *)
    try (destruct (fold_constants_aexp a1);
         destruct (fold_constants_aexp a2);
         rewrite IHa1; rewrite IHa2; reflexivity). Qed.

Axiom skip_left: forall c,
  cequiv
     (SKIP;; c)
     c.

Axiom skip_right: forall c,
  cequiv
    (c;; SKIP)
    c.

Axiom IFB_true: forall b c1 c2,
     bequiv b BTrue  ->
     cequiv
       (IFB b THEN c1 ELSE c2 FI)
       c1.

Axiom IFB_false: forall b c1 c2,
  bequiv b BFalse  ->
  cequiv
    (IFB b THEN c1 ELSE c2 FI)
    c2.

Axiom swap_if_branches: forall b e1 e2,
  cequiv
    (IFB b THEN e1 ELSE e2 FI)
    (IFB BNot b THEN e2 ELSE e1 FI).

Axiom WHILE_true: forall b c,
     bequiv b BTrue  ->
     cequiv
       (WHILE b DO c END)
       (WHILE BTrue DO SKIP END).

Axiom seq_assoc : forall c1 c2 c3,
  cequiv ((c1;;c2);;c3) (c1;;(c2;;c3)).

Axiom assign_aequiv : forall X e,
  aequiv (AId X) e ->
  cequiv SKIP (X ::= e).

Axiom CSeq_congruence : forall c1 c1' c2 c2',
  cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (c1;;c2) (c1';;c2').

Axiom CIf_congruence : forall b b' c1 c1' c2 c2',
  bequiv b b' -> cequiv c1 c1' -> cequiv c2 c2' ->
  cequiv (IFB b THEN c1 ELSE c2 FI) (IFB b' THEN c1' ELSE c2' FI).

(* ######################################################## *)
(* optimize_0plus *)

Fixpoint optimize_0plus_aexp (e:aexp) : aexp :=
  match e with
  | ANum n =>
      ANum n
  | AId i => AId i
  | APlus (ANum 0) e' | APlus e' (ANum 0) =>
      optimize_0plus_aexp e'
  | APlus e1 e2 =>
      APlus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMinus e1 e2 =>
      AMinus (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  | AMult e1 e2 =>
      AMult (optimize_0plus_aexp e1) (optimize_0plus_aexp e2)
  end.

Fixpoint optimize_0plus_bexp (b : bexp) : bexp :=
  match b with
  | BTrue => BTrue
  | BFalse => BFalse
  | BEq a1 a2  =>
      BEq (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BLe a1 a2  =>
      BLe (optimize_0plus_aexp a1) (optimize_0plus_aexp a2)
  | BNot b1  =>
      BNot (optimize_0plus_bexp b1)
  | BAnd b1 b2  =>
      BAnd (optimize_0plus_bexp b1) (optimize_0plus_bexp b2)
  end.

Fixpoint optimize_0plus_com (c : com) : com :=
  match c with
  | SKIP     =>
      SKIP
  | i ::= a  =>
      CAss i (optimize_0plus_aexp a)
  | c1 ;; c2  =>
      (optimize_0plus_com c1) ;; (optimize_0plus_com c2)
  | IFB b THEN c1 ELSE c2 FI =>
      IFB (optimize_0plus_bexp b)
      THEN optimize_0plus_com c1
      ELSE optimize_0plus_com c2
      FI
  | WHILE b DO c END =>
      WHILE (optimize_0plus_bexp b) DO
        (optimize_0plus_com c)
      END
  end.

Definition constfold_0plus (c: com) : com :=
  optimize_0plus_com (fold_constants_com c).

Eval compute in
  constfold_0plus
    (X ::= APlus (ANum 4) (ANum 5);;
     Y ::= AMinus (AId X) (ANum 3);;
     IFB BEq (AMinus (AId X) (AId Y)) (APlus (AId X) (AMinus (ANum 4) (ANum 4))) THEN
       SKIP
     ELSE
       Y ::= ANum 0
     FI;;
     IFB BLe (ANum 0) (AMinus (ANum 4) (APlus (ANum 2) (ANum 1))) THEN
       Y ::= ANum 0
     ELSE
       SKIP
     FI;;
     WHILE BEq (AId Y) (ANum 0) DO
       X ::= APlus (AId X) (ANum 1)
     END).


Require Export WeakIVT.
Require Export CalculusTheorems.

Section IVT'.

(* Tex_Prose
\chapter{The Generalized IVT}

The IVT can be generalized to arbitrary partial functions; in the first
part, we will simply do that, repeating the previous construction.

The same notations and conventions apply as before.
*)

Variables a,b:IR.
Hypothesis Hab' : a[<]b.
Hypothesis Hab : a[<=]b.

Local I := (Compact Hab).
Local I' := (iprop (olor a b)).

Variable F:PartIR.
Hypothesis contF : (Continuous_I Hab F).
Local incF:=(contin_imp_inc ???? contF).

(* Begin_Tex_Verb *)
Hypothesis incrF : (x,y:IR)(I x)->(I y)->
  (x[<]y)->(Hx,Hy:?)(F x Hx)[<](F y Hy).
(* End_Tex_Verb *)

Local Ha:=(compact_inc_lft ?? Hab).
Local Hb:=(compact_inc_rht ?? Hab).

Local HFab' := (incrF ?? Ha Hb Hab' (incF ? Ha) (incF ? Hb)).

(* Begin_Tex_Verb *)
Variable z:IR.
Hypothesis Haz:(F a (incF ? Ha))[<]z.
Hypothesis Hzb:z[<](F b (incF ? Hb)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma IVT'_seq_lemma : (xy:IR*IR)[x:=(Fst xy)][y:=(Snd xy)]
  (Hxy:(I x)*(I y))[Hx:=(Fst Hxy)][Hy:=(Snd Hxy)](x[<]y)->
  ((F x (incF ? Hx))[<]z)*(z[<](F y (incF ? Hy)))->
  {xy0:IR*IR & [x0:=(Fst xy0)][y0:=(Snd xy0)]{Hxy0:(I x0)*(I y0) &
  [Hx0:=(Fst Hxy0)][Hy0:=(Snd Hxy0)]
    (x0[<]y0)*((F x0 (incF ? Hx0))[<]z)*(z[<](F y0 (incF ? Hy0))) |
     ((y0[-]x0)[=](Two[/]ThreeNZ)[*](y[-]x)) /\ (x[<=]x0) /\ (y0[<=]y)}}.
(* End_Tex_Verb *)
Intros.
LetTac x1:=(Two[*]x[+]y)[/]ThreeNZ.
LetTac y1:=(x[+]Two[*]y)[/]ThreeNZ.
Cut x1[<]y1; Intros.
2: Unfold x1 y1; Apply lft_rht; Auto.
Cut (I x1); Intros.
Cut (I y1); Intros.
Cut (F x1 (incF ? H2))[<](F y1 (incF ? H3)); Intros; Auto.
Elim (cotrans_less_unfolded ??? H4 z); Intros.
Exists (x1,y); Exists (H2,Hy); Simpl; Repeat Split; Auto.
Apply less_transitive_unfolded with y1; Unfold x1 y1; [Apply lft_rht | Apply rht_b]; Auto.
Auto.
Elim H0; Auto.
Unfold x1; Apply smaller_rht.
Unfold x1; Apply less_leEq; Apply a_lft; Auto.
Apply leEq_reflexive.
Exists (x,y1); Exists (Hx,H3); Simpl; Repeat Split; Auto.
Apply less_transitive_unfolded with x1; Unfold x1 y1; [Apply a_lft | Apply lft_rht]; Auto.
Elim H0; Auto.
Unfold y1; Apply smaller_lft; Auto.
Apply leEq_reflexive.
Apply less_leEq; Unfold y1; Apply rht_b; Auto.
Unfold y1; Inversion_clear Hx; Inversion_clear Hy; Split.
Apply leEq_transitive with x; Auto.
Apply less_leEq; Apply less_transitive_unfolded with x1; Unfold x1; [Apply a_lft | Apply lft_rht]; Auto.
Apply leEq_transitive with y; Auto.
Apply less_leEq; Apply rht_b; Auto.
Unfold x1; Inversion_clear Hx; Inversion_clear Hy; Split.
Apply leEq_transitive with x; Auto.
Apply less_leEq; Apply a_lft; Auto.
Apply leEq_transitive with y; Auto.
Apply less_leEq; Apply less_transitive_unfolded with y1; Unfold y1; [Apply lft_rht | Apply rht_b]; Auto.
Qed.

(* Begin_Tex_Verb *)
Record IVT'_aux_seq_type : Set :=
  {IVT'seq1 : IR;
   IVT'seq2 : IR;
   IVT'H1   : (I IVT'seq1);
   IVT'H2   : (I IVT'seq2);
   IVT'prf  : IVT'seq1[<]IVT'seq2;
   IVT'z1   : (F IVT'seq1 (incF ? IVT'H1))[<]z;
   IVT'z2   : z[<](F IVT'seq2 (incF ? IVT'H2))}.

Definition IVT'_iter : IVT'_aux_seq_type->IVT'_aux_seq_type.
(* End_Tex_Verb *)
Intro Haux; Elim Haux; Intros.
Elim (IVT'_seq_lemma (IVT'seq3,IVT'seq4) (IVT'H3,IVT'H4) IVT'prf0 (IVT'z3,IVT'z4)).
Intro x; Elim x; Simpl; Clear x; Intros.
Elim p.
Intro x; Elim x; Simpl; Clear x; Intros.
Inversion_clear p0.
Inversion_clear H.
Inversion_clear q.
Inversion_clear H3.
Apply Build_IVT'_aux_seq_type with a0 b0 a1 b1; Auto.
Defined.

(* Begin_Tex_Verb *)
Definition IVT'_seq : nat->IVT'_aux_seq_type.
(* End_Tex_Verb *)
Intro n; Induction n.
Apply Build_IVT'_aux_seq_type with a b Ha Hb; Auto.
Apply (IVT'_iter Hrecn).
Defined.

(* Begin_Tex_Verb *)
Definition a'_seq := [n:nat](IVT'seq1 (IVT'_seq n)).
Definition b'_seq := [n:nat](IVT'seq2 (IVT'_seq n)).

Definition a'_seq_I [n:nat] : (I (a'_seq n)) := (IVT'H1 (IVT'_seq n)).
Definition b'_seq_I [n:nat] : (I (b'_seq n)) := (IVT'H2 (IVT'_seq n)).
(* End_Tex_Verb *)

(* Begin_Tex_Verb *)
Lemma a'_seq_less_b'_seq : (n:nat)(a'_seq n)[<](b'_seq n).
(* End_Tex_Verb *)
Exact [n:nat](IVT'prf (IVT'_seq n)).
Qed.

(* Begin_Tex_Verb *)
Lemma a'_seq_less_z : (n:nat)(F ? (incF ? (a'_seq_I n)))[<]z.
(* End_Tex_Verb *)
Exact [n:nat](IVT'z1 (IVT'_seq n)).
Qed.

(* Begin_Tex_Verb *)
Lemma z_less_b'_seq : (n:nat)z[<](F ? (incF ? (b'_seq_I n))).
(* End_Tex_Verb *)
Exact [n:nat](IVT'z2 (IVT'_seq n)).
Qed.

(* Begin_Tex_Verb *)
Lemma a'_seq_mon : (i:nat)(a'_seq i)[<=](a'_seq (S i)).
(* End_Tex_Verb *)
Intro.
Unfold a'_seq.
Simpl.
Elim (IVT'_seq i); Simpl; Intros.
Elim IVT'_seq_lemma; Simpl; Intro.
Elim x; Simpl; Clear x; Intros.
Elim p; Clear p; Intro.
Elim x; Simpl; Clear x; Intros.
Case q; Clear q; Simpl; Intros.
Case a2; Clear a2; Simpl; Intros.
Elim p; Clear p; Simpl; Intros.
Elim a2; Clear a2; Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma b'_seq_mon : (i:nat)(b'_seq (S i))[<=](b'_seq i).
(* End_Tex_Verb *)
Intro.
Unfold b'_seq.
Simpl.
Elim (IVT'_seq i); Simpl; Intros.
Elim IVT'_seq_lemma; Simpl; Intro.
Elim x; Simpl; Clear x; Intros.
Elim p; Clear p; Intro.
Elim x; Simpl; Clear x; Intros.
Case q; Clear q; Simpl; Intros.
Case a2; Clear a2; Simpl; Intros.
Elim p; Clear p; Simpl; Intros.
Elim a2; Clear a2; Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma a'_seq_b'_seq_dist_n : (n:nat)((b'_seq (S n))[-](a'_seq (S n)))[=](Two[/]ThreeNZ)[*]((b'_seq n)[-](a'_seq n)).
(* End_Tex_Verb *)
Intro.
Unfold a'_seq b'_seq.
Simpl.
Elim (IVT'_seq n); Simpl; Intros.
Elim IVT'_seq_lemma; Simpl; Intro.
Elim x; Simpl; Clear x; Intros.
Elim p; Clear p; Intro.
Elim x; Simpl; Clear x; Intros.
Case q; Clear q; Simpl; Intros.
Case a2; Clear a2; Simpl; Intros.
Elim p; Clear p; Simpl; Intros.
Elim a2; Clear a2; Simpl; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma a'_seq_b'_seq_dist : (n:nat)((b'_seq n)[-](a'_seq n))[=](Two[/]ThreeNZ)[^]n[*](b[-]a).
(* End_Tex_Verb *)
Induction n.
Simpl; Algebra.
Clear n; Intros.
Stepr (Two[/]ThreeNZ)[*](Two[/]ThreeNZ)[^]n[*](b[-]a).
Stepr (Two[/]ThreeNZ)[*]((Two[/]ThreeNZ)[^]n[*](b[-]a)).
Stepr (Two[/]ThreeNZ)[*]((b'_seq n)[-](a'_seq n)).
Apply a'_seq_b'_seq_dist_n.
Qed.

(* Begin_Tex_Verb *)
Lemma a'_seq_Cauchy : (Cauchy_prop a'_seq).
(* End_Tex_Verb *)
Red; Intros.
Elim (intervals_small' a b e H); Intros i Hi.
Exists i; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_transitive.
2: Apply Hi.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step (a'_seq i).
2: Apply local_mon'_imp_mon'; Auto; Exact a'_seq_mon.
EApply leEq_wdr.
2: Apply a'_seq_b'_seq_dist.
Apply minus_resp_leEq.
Apply less_leEq; Apply a_b'.
Exact a'_seq_mon.
Exact b'_seq_mon.
Exact a'_seq_less_b'_seq.
Qed.

(* Begin_Tex_Verb *)
Lemma b'_seq_Cauchy : (Cauchy_prop b'_seq).
(* End_Tex_Verb *)
Red; Intros.
Elim (intervals_small' a b e H); Intros i Hi.
Exists i; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_transitive.
2: Apply Hi.
EApply leEq_wdl.
2: Apply AbsIR_minus.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step (b'_seq m).
2: Step [--][--](b'_seq m); Stepr [--][--](b'_seq i).
2: Apply inv_resp_leEq; Apply local_mon'_imp_mon' with f:=[n:nat][--](b'_seq n); Auto.
2: Intro; Apply inv_resp_leEq; Apply b'_seq_mon.
EApply leEq_wdr.
2: Apply a'_seq_b'_seq_dist.
Unfold cg_minus; Apply plus_resp_leEq_lft.
Apply inv_resp_leEq.
Apply less_leEq; Apply a_b'.
Exact a'_seq_mon.
Exact b'_seq_mon.
Exact a'_seq_less_b'_seq.
Qed.

Local xa:=(Lim (Build_CauchySeq ?? a'_seq_Cauchy)).
Local xb:=(Lim (Build_CauchySeq ?? b'_seq_Cauchy)).

(* Begin_Tex_Verb *)
Lemma a'_seq_b'_seq_lim : xa[=]xb.
(* End_Tex_Verb *)
Unfold xa xb; Clear xa xb.
Apply cg_inv_unique_2.
Apply eq_symmetric_unfolded.
EApply eq_transitive_unfolded.
2: Apply Lim_minus.
Simpl.
Apply Limits_unique.
Simpl.
Red; Intros.
Elim (intervals_small' a b eps H); Intros i Hi.
Exists i; Intros.
Apply AbsIR_imp_AbsSmall.
EApply leEq_transitive.
2: Apply Hi.
EApply leEq_wdl.
2: Apply AbsIR_minus.
EApply leEq_wdl.
2: Apply eq_symmetric_unfolded; Apply AbsIR_eq_x.
2: Apply shift_leEq_minus; Step (a'_seq m)[-](b'_seq m).
2: Apply shift_minus_leEq; Stepr (b'_seq m).
2: Apply less_leEq; Apply a'_seq_less_b'_seq.
EApply leEq_wdr.
2: Apply a'_seq_b'_seq_dist.
RStep (b'_seq m)[-](a'_seq m).
Unfold cg_minus; Apply plus_resp_leEq_both.
Step [--][--](b'_seq m); Stepr [--][--](b'_seq i).
Apply inv_resp_leEq; Apply local_mon'_imp_mon' with f:=[n:nat][--](b'_seq n); Auto.
Intro; Apply inv_resp_leEq; Apply b'_seq_mon.
Apply inv_resp_leEq; Apply local_mon'_imp_mon'; Auto; Exact a'_seq_mon.
Qed.

(* Begin_Tex_Verb *)
Lemma xa'_in_interval : (I xa).
(* End_Tex_Verb *)
Split.
Unfold xa.
Apply leEq_seq_so_leEq_Lim.
Simpl.
Intro; Elim (a'_seq_I i); Auto.
Unfold xa.
Apply seq_leEq_so_Lim_leEq.
Simpl.
Intro; Elim (a'_seq_I i); Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma IVT'_I : {x:IR & (I' x) | (Hx:?)(F x Hx)[=]z}.
(* End_Tex_Verb *)
Elim (IVT_I a b Hab' Hab F contF) with z; Try Apply less_leEq; Auto.
Intros x H H0.
Exists x; Auto.
Elim H; Intros; Split; Apply leEq_not_eq; Auto.
Apply pfstrx with F (incF ? Ha) (incF ? H).
Apply less_imp_ap; Stepr z; Auto.
Apply pfstrx with F (incF ? H) (incF ? Hb).
Apply less_imp_ap; Step z; Auto.
Qed.

End IVT'.

(* Tex_Prose
\section{Other formulations}

We now generalize the various statements of the intermediate value theorem to more widely applicable forms.
*)

(* Begin_Tex_Verb *)
Lemma Weak_IVT : (I,F:?)(Continuous I F)->
  (a,b,Ha,Hb:?)(HFab:(F a Ha)[<](F b Hb))
  (iprop I a)->(iprop I b)->
  (e:IR)(Zero[<]e)->(y:IR)(Compact (less_leEq ??? HFab) y)->
  {x:IR & (Compact (Min_leEq_Max a b) x) | (Hx:?)(AbsIR (F x Hx)[-]y)[<=]e}.
(* End_Tex_Verb *)
Intros.
LetTac H5:=(less_imp_ap ??? HFab).
LetTac H6:=(pfstrx ?????? H5).
Elim (ap_imp_less ??? H6); Clear H6 H5; Intro.
Cut (Continuous_I (Min_leEq_Max a b) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
LetTac incF:=(contin_imp_inc ???? H4).
Cut (Min a b)[=]a.
Cut (Max a b)[=]b; Intros.
2: Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
2: Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
LetTac Ha':=(incF ? (compact_inc_lft ?? (Min_leEq_Max a b))).
LetTac Hb':=(incF ? (compact_inc_rht ?? (Min_leEq_Max a b))).
Cut (F ? Ha')[<](F ? Hb'); Intros.
Apply Weak_IVT_ap_lft with HFab:=H7; Auto.
Apply compact_wd' with Hab:=(less_leEq ??? HFab); Algebra.
Step (F a Ha); Stepr (F b Hb); Auto.
Cut (Continuous_I (Min_leEq_Max b a) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
LetTac incF:=(contin_imp_inc ???? H4).
Cut (Min a b)[=]b.
Cut (Max a b)[=]a; Intros.
2: EApply eq_transitive_unfolded; [Apply Max_comm | Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto].
2: EApply eq_transitive_unfolded; [Apply Min_comm | Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto].
LetTac Ha':=(incF ? (compact_inc_lft ?? (Min_leEq_Max b a))).
LetTac Hb':=(incF ? (compact_inc_rht ?? (Min_leEq_Max b a))).
Cut (F ? Hb')[<](F ? Ha'); Intros.
Elim (Weak_IVT_ap_rht ???? H4 ?? H7 ? H2 y); Auto.
Intro x; Intros.
Exists x; Auto.
Apply compact_wd' with Hab:=(Min_leEq_Max b a); [Apply Min_comm | Apply Max_comm | Auto].
Apply compact_wd' with Hab:=(less_leEq ??? HFab); Algebra.
Apply pfwdef; Step (Max a b); Apply Max_comm.
Apply pfwdef; Step (Min a b); Apply Min_comm.
Apply less_wdl with (F a Ha).
Apply less_wdr with (F b Hb).
Auto.
Apply pfwdef; Step (Min a b); Apply Min_comm.
Apply pfwdef; Step (Max a b); Apply Max_comm.
Qed.

(* Begin_Tex_Verb *)
Lemma IVT_inc : (I,F:?)(Continuous I F)->
  (a,b,Ha,Hb:?)((F a Ha)[#](F b Hb))->
  (iprop I a)->(iprop I b)->
  ((x,y:IR)(iprop I x)->(iprop I y)->
    (x[<]y)->(Hx,Hy:?)(F x Hx)[<](F y Hy))->
  (y:IR)(Compact (Min_leEq_Max (F a Ha) (F b Hb)) y)->
  {x:IR & (Compact (Min_leEq_Max a b) x) | (Hx:?)(F x Hx)[=]y}.
(* End_Tex_Verb *)
Intros.
LetTac H5:=(pfstrx ?????? H0).
Elim (ap_imp_less ??? H5); Clear H5; Intro.
Cut (Continuous_I (Min_leEq_Max a b) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
Cut (Min a b)[=]a; [Intro | Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto].
Cut (Max a b)[=]b; [Intro | Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto].
Cut (H,H':?)(F (Min a b) H)[<](F (Max a b) H'); Intros.
2: Apply H3; Auto.
2: Apply iprop_wd with a; Algebra.
2: Apply iprop_wd with b; Algebra.
2: Step a; Stepr b; Auto.
Elim H4; Intros.
Apply IVT_I with H5.
Apply ap_imp_Min_less_Max; Apply less_imp_ap; Auto.
Intros.
Apply H3; Auto.
Apply (included_interval ??? H1 H2 (Min_leEq_Max a b)); Auto.
Apply (included_interval ??? H1 H2 (Min_leEq_Max a b)); Auto.
EApply leEq_wdl.
Apply a1.
Stepr (F a Ha); Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
EApply leEq_wdr.
Apply b0.
Stepr (F b Hb); Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Cut (Continuous_I (Min_leEq_Max b a) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
Cut (Min b a)[=]b; [Intro | Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto].
Cut (Max b a)[=]a; [Intro | Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto].
Cut (H,H':?)(F (Min b a) H)[<](F (Max b a) H'); Intros.
2: Apply H3; Auto.
2: Apply iprop_wd with b; Algebra.
2: Apply iprop_wd with a; Algebra.
2: Step b; Stepr a; Auto.
Elim H4; Intros.
Elim IVT_I with contF:=H5 z:=y; Intros; Auto.
Exists x; Auto.
Apply compact_wd' with Hab:=(Min_leEq_Max b a); Auto.
Apply Min_comm.
Apply Max_comm.
Step b; Stepr a; Auto.
Apply H3; Auto.
Apply (included_interval ??? H2 H1 (Min_leEq_Max b a)); Auto.
Apply (included_interval ??? H2 H1 (Min_leEq_Max b a)); Auto.
EApply leEq_wdl.
Apply a0.
Stepr (F b Hb); EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
EApply leEq_wdr.
Apply b1.
Stepr (F a Ha); EApply eq_transitive_unfolded.
Apply Max_comm.
Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Qed.

Transparent Min.

(* Begin_Tex_Verb *)
Lemma IVT_dec : (I,F:?)(Continuous I F)->
  (a,b,Ha,Hb:?)((F a Ha)[#](F b Hb))->
  (iprop I a)->(iprop I b)->
  ((x,y:IR)(iprop I x)->(iprop I y)->
    (x[<]y)->(Hx,Hy:?)(F y Hy)[<](F x Hx))->
  (y:IR)(Compact (Min_leEq_Max (F a Ha) (F b Hb)) y)->
  {x:IR & (Compact (Min_leEq_Max a b) x) | (Hx:?)(F x Hx)[=]y}.
(* End_Tex_Verb *)
Intros.
Elim IVT_inc with I:=I F:={--}F a:=a b:=b y:=[--]y Ha:=Ha Hb:=Hb; Auto.
Intros x H5 H6.
Exists x; Auto.
Intro.
Step [--][--](F x Hx); Stepr [--][--]y.
Apply un_op_wd_unfolded; Simpl in H6; Apply H6.
Contin.
Simpl; Apply un_op_strext_unfolded with (!cg_inv IR).
Step (F a Ha); Stepr (F b Hb); Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Inversion_clear H4; Split; Simpl.
Apply inv_resp_leEq.
EApply leEq_wdr.
Apply H6.
Apply max_wd_unfolded; Algebra.
Stepr [--][--](Max [--](F a Ha) [--](F b Hb)).
Apply inv_resp_leEq; Auto.
Qed.

(* Begin_Tex_Verb *)
Lemma IVT'_inc : (I,F:?)(Continuous I F)->
  (a,b,Ha,Hb:?)((F a Ha)[#](F b Hb))->
  (iprop I a)->(iprop I b)->
  ((x,y:IR)(iprop I x)->(iprop I y)->
    (x[<]y)->(Hx,Hy:?)(F x Hx)[<](F y Hy))->
  (y:IR)(iprop (olor (Min (F a Ha) (F b Hb)) (Max (F a Ha) (F b Hb))) y)->
  {x:IR & (iprop (olor (Min a b) (Max a b)) x) | (Hx:?)(F x Hx)[=]y}.
(* End_Tex_Verb *)
Intros.
LetTac H5:=(pfstrx ?????? H0).
Elim (ap_imp_less ??? H5); Clear H5; Intro.
Cut (Continuous_I (Min_leEq_Max a b) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
Cut (Min a b)[=]a; [Intro | Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto].
Cut (Max a b)[=]b; [Intro | Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto].
Cut (H,H':?)(F (Min a b) H)[<](F (Max a b) H'); Intros.
2: Apply H3; Auto.
2: Apply iprop_wd with a; Algebra.
2: Apply iprop_wd with b; Algebra.
2: Step a; Stepr b; Auto.
Elim H4; Intros.
Apply IVT'_I with (Min_leEq_Max a b) H5.
Apply ap_imp_Min_less_Max; Apply less_imp_ap; Auto.
Intros.
Apply H3; Auto.
Apply (included_interval ??? H1 H2 (Min_leEq_Max a b)); Auto.
Apply (included_interval ??? H1 H2 (Min_leEq_Max a b)); Auto.
EApply less_wdl.
Apply a1.
Stepr (F a Ha); Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
EApply less_wdr.
Apply b0.
Stepr (F b Hb); Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Cut (Continuous_I (Min_leEq_Max b a) F); Intros.
2: Apply included_imp_Continuous with I; Auto; Apply included_interval; Auto.
Cut (Min b a)[=]b; [Intro | Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto].
Cut (Max b a)[=]a; [Intro | Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto].
Cut (H,H':?)(F (Min b a) H)[<](F (Max b a) H'); Intros.
2: Apply H3; Auto.
2: Apply iprop_wd with b; Algebra.
2: Apply iprop_wd with a; Algebra.
2: Step b; Stepr a; Auto.
Elim H4; Intros.
Elim IVT'_I with contF:=H5 z:=y; Auto.
Intros x H9 H10; Exists x; Auto.
Inversion_clear H9; Split.
EApply less_wdl; [Apply H11 | Apply Min_comm].
EApply less_wdr; [Apply H12 | Apply Max_comm].
Apply ap_imp_Min_less_Max; Apply less_imp_ap; Auto.
Intros; Apply H3; Auto.
Apply (included_interval ??? H2 H1 (Min_leEq_Max b a)); Auto.
Apply (included_interval ??? H2 H1 (Min_leEq_Max b a)); Auto.
EApply less_wdl.
Apply a0.
Stepr (F b Hb); EApply eq_transitive_unfolded.
Apply Min_comm.
Apply leEq_imp_Min_is_lft; Apply less_leEq; Auto.
EApply less_wdr.
Apply b1.
Stepr (F a Ha); EApply eq_transitive_unfolded.
Apply Max_comm.
Apply leEq_imp_Max_is_rht; Apply less_leEq; Auto.
Qed.

Transparent Min.

(* Begin_Tex_Verb *)
Lemma IVT'_dec : (I,F:?)(Continuous I F)->
  (a,b,Ha,Hb:?)((F a Ha)[#](F b Hb))->
  (iprop I a)->(iprop I b)->
  ((x,y:IR)(iprop I x)->(iprop I y)->
    (x[<]y)->(Hx,Hy:?)(F y Hy)[<](F x Hx))->
  (y:IR)(iprop (olor (Min (F a Ha) (F b Hb)) (Max (F a Ha) (F b Hb))) y)->
  {x:IR & (iprop (olor (Min a b) (Max a b)) x) | (Hx:?)(F x Hx)[=]y}.
(* End_Tex_Verb *)
Intros.
Elim IVT'_inc with I:=I F:={--}F a:=a b:=b y:=[--]y Ha:=Ha Hb:=Hb; Auto.
Intros x H5 H6.
Exists x; Auto.
Intro.
Step [--][--](F x Hx); Stepr [--][--]y.
Apply un_op_wd_unfolded; Simpl in H6; Apply H6.
Contin.
Simpl; Apply un_op_strext_unfolded with (!cg_inv IR).
Step (F a Ha); Stepr (F b Hb); Auto.
Intros; Simpl; Apply inv_resp_less; Auto.
Inversion_clear H4; Split; Simpl.
Apply inv_resp_less.
EApply less_wdr.
Apply H6.
Apply max_wd_unfolded; Algebra.
Stepr [--][--](Max [--](F a Ha) [--](F b Hb)).
Apply inv_resp_less; Auto.
Qed.


Set Implicit Arguments.

Require Import Logic.

Set Asymmetric Patterns.
Set Nonrecursive Elimination Schemes.
Set Primitive Projections.

Record prod (A B : Type) : Type :=
  pair { fst : A; snd : B }.

Print prod_rect.
(** prod_rect =
fun (A B : Type) (P : prod A B -> Type)
  (f : forall (fst : A) (snd : B), P {| fst := fst; snd := snd |})
  (p : prod A B) =>
match p as p0 return (P p0) with
| {| fst := x; snd := x0 |} => f x x0
end
     : forall (A B : Type) (P : prod A B -> Type),
       (forall (fst : A) (snd : B), P {| fst := fst; snd := snd |}) ->
       forall p : prod A B, P p

Arguments A, B are implicit
Argument scopes are [type_scope type_scope _ _ _]
 *)

(* What I really want: *)
Definition prod_rect' A B (P : prod A B -> Type) (u : forall (fst : A) (snd : B), P (pair fst snd))
           (p : prod A B) : P p
  := u (fst p) (snd p).

Notation typeof x := (ltac:(let T := type of x in exact T)) (only parsing).

(* Check for eta *)
Check eq_refl : typeof (@prod_rect) = typeof (@prod_rect').

(* Check for the recursion principle I want *)
Check eq_refl : @prod_rect = @prod_rect'.


(** * ADT: Abstract Data Types *)

(** An _abstract data type_ (ADT) can be defined as a set of values
    together with some operations.  From the perspective of formal
    verification, the specifications of those operations should also
    be a part of an ADT.

    When we implemented BSTs in [SearchTree], we saw that
    maintaining a representation invariant was important to rule out
    trees that could never be constructed through operations of the
    data structure.  That invariant became a precondition for many
    operations, though there was no need for _clients_ of the data
    structure to know any details of the invariant.

    In this chapter we'll study a little of Coq's _module system_,
    which enables hiding some details of the implementation of an ADT,
    while also exposing the formal specification of the ADT.

    Some prior knowledge of an ML-style module system, especially
    OCaml's, will be helpful.  Here are some sources that cover it:

    - _Introduction to Objective Caml_, chapters 12 and 13.  Jason
      Hickey, 2008.  Available from
      https://ocaml.org/learn/books.html.

    - The OCaml System Manual, chapter 2.  Xavier Leroy et al.,
      2020. Available from
      http://caml.inria.fr/pub/docs/manual-ocaml/.  *)

From Coq Require Import String.  (* for manual grading *)
From VFA Require Import Perm.
From VFA Require Import Maps.
From VFA Require Import SearchTree.

(* ################################################################# *)
(** * The Table ADT *)

(** An _association table_ is an ADT that binds keys to values.  There
    are many other names for this concept, including _map_.  We've
    already used that name before, though, for a specific data
    structure using higher-order functions.  So for clarity in this
    chapter we use _table_.

    Below is a Coq [Module Type] that declares an _interface_ for the
    table ADT. A _parameter_ is like a definition, except it declares
    only the type of an identifier, not the value to which it is
    bound.  An _axiom_ is similarly like a theorem, except no proof is
    provided. *)

Module Type Table.

  (** A [table] is a binding from keys to values. It is _total_,
      meaning it binds all keys. *)
  Parameter table : Type.

  (** Keys are natural numbers. *)
  Definition key := nat.

  (** Values are an arbitrary type [V]. *)
  Parameter V : Type.

  (** The default value to which keys are bound. *)
  Parameter default : V.

  (** [empty] is the table that binds all keys to the default value. *)
  Parameter empty : table.

  (** [get k t] is the value [v] to which [k] is bound in [t]. *)
  Parameter get : key -> table -> V.

  (** [set k v t] is the table that binds [k] to [v] and otherwise has
      the same bindings as [t]. *)
  Parameter set : key -> V -> table -> table.

  (** The following three axioms are an equational specification for
      the table ADT. *)

  Axiom get_empty_default : forall (k : key),
      get k empty = default.

  Axiom get_set_same : forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.

  Axiom get_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.

End Table.

(* ################################################################# *)
(** * Implementing [Table] with Functions *)

(** We can _implement_ [Table] with a [Module] that is
    parameterized on the type of values -- or, rather, parameterized
    on a module that contains such a type.  A parameterized module is
    also called a _functor_.

    Module type [ValType] says that there must be a type named [V],
    with a default value provided: *)

Module Type ValType.
  Parameter V : Type.
  Parameter default : V.
End ValType.

(** Functor [FunTable] takes as input a module of type
    [ValType], which must therefore contain a type [V].  As output,
    [FunTable] produces a module of type [Table].  By writing [<:
    Table], below, we ask Coq to check that the output module contains
    all the components required by [Table]. *)

Module FunTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.

  (** A [table] is a function from keys to values. *)
  Definition table := key -> V.

  Definition empty : table :=
    fun _ => default.

  Definition get (k : key) (t : table) : V :=
    t k.

  Definition set (k : key) (v : V) (t : table) : table :=
    fun k' => if k =? k' then v else t k'.

  (** The implementation must prove the theorems that the interface
      specified as axioms. *)

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof. intros. unfold get, empty. reflexivity. Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof. intros. unfold get, set. bdall. Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof. intros. unfold get, set. bdall. Qed.
End FunTable.

(** As an example, let's instantiate [FunTable] with strings as
    values. *)

Module StringVal.
  Definition V := string.
  Definition default := ""%string.
End StringVal.

Module FunTableExamples.

  Module StringFunTable := FunTable StringVal.
  Import StringFunTable.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof. reflexivity. Qed.

  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof. reflexivity. Qed.

  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof. reflexivity. Qed.

End FunTableExamples.

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

(** Define a module that uses [FunTable] to implement a table mapping
    keys to values, where the values have type [nat], with a default of [0].
    Write unit tests to check the operation of [get] and [set]. *)

Module NatFunTableExamples.
  (* FILL IN HERE *)
End NatFunTableExamples.

(** [] *)

(* ################################################################# *)
(** * Implementing [Table] with Lists *)

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

(** Use association lists to implement [Table]. *)

Module ListsTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := list (key * V).

  Definition empty : table := [].

  Fixpoint get (k : key) (t : table) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition set (k : key) (v : V) (t : table) : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    (* FILL IN HERE *) Admitted.

End ListsTable.

(** Instantiate your table and prove the following facts. *)

Module StringListsTableExamples.

  Module StringListsTable := ListsTable StringVal.
  Import StringListsTable.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof.
    (* FILL IN HERE *) Admitted.

  Example ex2 : get 0 (set 0 "A" empty) = "A".
  Proof.
    (* FILL IN HERE *) Admitted.

  Example ex3 : get 1 (set 0 "A" empty) = "".
  Proof.
    (* FILL IN HERE *) Admitted.

End StringListsTableExamples.

(** [] *)

(* ################################################################# *)
(** * Implementing [Table] with BSTs *)

(** Tables implemented with functions and association lists are, of course,
    inefficient.  For a more efficient implementation, we can use BSTs. *)

Module TreeTable (VT : ValType) <: Table.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := tree V.

  Definition empty : table :=
    @empty_tree V.

  Definition get (k : key) (t: table) : V :=
    lookup default k t.

  Definition set (k : key) (v : V) (t : table) : table :=
    insert k v t.

  (** The three basic equations we proved about [tree] in
      [SearchTree] make short work of the theorems we need to
      prove for [Table]. *)

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty.
  Qed.

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set. apply lookup_insert_eq.
  Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set. apply lookup_insert_neq. assumption.
  Qed.

End TreeTable.

(* ################################################################# *)
(** * Tables with an [elements] Operation *)

(** Now let's consider a richer interface [ETable] for Tables that support
    [bound] and [elements] operation. *)

(* ================================================================= *)
(** ** A First Attempt at [ETable] *)

Module Type ETable_first_attempt.

  (** [Include], as the name suggests, includes all the declarations
      from [Table].  Not only does that save keystrokes, it also means
      if we ever update [Table] to have new operations or new types,
      they automatically get included here, too. *)
  Include Table.

  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETable_first_attempt.

(** We proved in [SearchTree] that the BST [elements] operation is
    correct and complete.  So we ought to be able to implement
    [ETable] with BSTs.  Let's try. *)

Module TreeETable_first_attempt (VT : ValType) <: ETable_first_attempt.

  (** Include all the definitions from [TreeTable], instantiated on
      [VT]. *)
  Include TreeTable VT.

  (** Thanks to the [Include], we now have all the tree operations
      defined "for free" in this module.  For example: *)
  Check get : key -> table -> V.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup. unfold get in Hlookup.
    (** [pose proof t as H] is equivalent to [assert (H : ...the type
        of t...). { apply t. }] but saves some keystrokes. *)
    pose proof (SearchTree.elements_complete) as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete with default.
    - (** Stuck! We don't know that [t] satisfies the BST invariant. *)
  Admitted.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t Hin.
    pose proof (SearchTree.elements_correct) as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect.
    - (** Again stuck because of the BST invariant. *)
  Admitted.

End TreeETable_first_attempt.

(* ================================================================= *)
(** ** A Revised [ETable] *)

(** To prove that [elements] is correct, we need to know that
    trees satisfy the BST invariant. So, we declare a function
    [rep_ok] in the interface, and use it as a precondition for values
    of type [table]. We also add axioms to state that the ADT
    operations produce values that satisfy the representation
    invariant, i.e., it is a postcondition. And, we add a
    specification of [bound]. *)

Module Type ETable.

  Include Table.

  Parameter rep_ok : table -> Prop.
  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  (** [empty] and [set] produce valid representations. *)

  Axiom empty_ok : rep_ok empty.

  Axiom set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).

  (** The specification of [bound]: *)

  Axiom bound_empty : forall (k : key),
      bound k empty = false.

  Axiom bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.

  Axiom bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.

  (** The specification of [elements]: *)

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETable.

Module TreeETable (VT : ValType) <: ETable.

  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETable.

(** Now we can use the table. *)

Module StringTreeETableExample.

  Module StringTreeETable := TreeETable StringVal.
  Import StringTreeETable.
  Open Scope string_scope.

  Example ex1 :
    In (0, "A") (elements (set 0 "A" (set 1 "B" empty))).
  Proof.
    apply elements_complete;
      auto using empty_ok, set_ok, bound_set_same, get_set_same.
  Qed.

End StringTreeETableExample.

(* ################################################################# *)
(** * Encapsulation with the Coq Module System (Advanced) *)

(** Functor [TreeETable], above, reveals internal implementation
    details that your data structures class probably taught you are
    better kept private.  For example, the constructors [E] and [T] of
    trees and the implementation of [get] are publicly exposed: *)

Example exposed_trees_ex :
  (StringTreeETableExample.StringTreeETable.get 0 (T E 0 "A" E) = "A")%string.
Proof.
  unfold StringTreeETableExample.StringTreeETable.get. (* we can see [lookup] *)
  reflexivity.
Qed.

(** Like many languages, Coq makes it possible to _encapsulate_
    these details, meaning that they become hidden outside the module.
    It's a simple matter of changing the [<:] syntax to [:] in the
    functor's type.  The only change in the implementation below is
    that one character. *)

(** The [:] syntax makes the module type _opaque_: only what is
    revealed in the type is available for code outside the module to
    use.  The [<:] syntax, however, makes the module type
    _transparent_: the module must conform to the type, but everything
    about the module is still revealed. *)

Module TreeETableFullyEncapsulated (VT : ValType) : ETable.
  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETableFullyEncapsulated.

(** Unfortunately, the module is now too encapsulated to be useful: *)

Module OverlyEncapsulatedExample.

  Module StringTreeETableFullyEncapsulated := TreeETableFullyEncapsulated StringVal.
  Import StringTreeETableFullyEncapsulated.
  Open Scope string_scope.

  Fail Example ex1 : get 0 empty = "".
  (* fails with an error about [""] not having type [V] *)

End OverlyEncapsulatedExample.

(** The problem is that the module now hides not only the internal
    implementation, but also the value type [V]. The functor was
    instantiated on [StringVal], which defines that type as [string].
    But the output of the functor has type [ETable], which doesn't
    reveal anything about [V] except that it is a [Type]. Note in the
    output of the following command how [V] is printed like an axiom
    would be, indicating that nothing is known (externally) about its
    implementation: *)

Print OverlyEncapsulatedExample.StringTreeETableFullyEncapsulated.V.

(** We need to selectively expose certain implementation details.
    We've just seen that [V] should be exposed.  Along with it, we'll
    also want [default] to be exposed.  We can accomplish that with an
    advanced feature of Coq's module system.  The Coq manual doesn't
    give this feature a name, but OCaml (in which Coq is implemented)
    calls it a _sharing constraint_, so we'll use that term here. A
    sharing constraint enables us to constrain definitions shared by
    modules to be the same. *)

Module Type SimpleTable.
  Parameter key : Type.
  Parameter V : Type.
  Parameter default : V.
  Parameter table : Type.
  (* We omit everything else for sake of a simple example. *)
End SimpleTable.

Module SimpleStringTable1 : SimpleTable.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable1.

(* [V] is abstract. *)
Print SimpleStringTable1.V.

Module Type SimpleTable2 := SimpleTable with Definition V := string.

Module SimpleStringTable2 : SimpleTable2.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable2.

(* [V] is exposed, but [default] is abstract. *)
Print SimpleStringTable2.V.
Print SimpleStringTable2.default.

Module Type SimpleTable3 := SimpleTable
  with Definition V := string
  with Definition default := ""%string.

Module SimpleStringTable3 : SimpleTable3.
  Definition key := nat.
  Definition V := string.
  Definition default : string := "".
  Definition table := tree V.
End SimpleStringTable3.

(* Both [V] and [default] are exposed. *)
Print SimpleStringTable3.V.
Print SimpleStringTable3.default.

(** Putting sharing constraints to use, let's expose [V] and [default]
    in our implementation of tree-based tables. *)

Module TreeETableEncapsulated (VT : ValType) : (ETable with Definition V := VT.V with Definition default := VT.default).

  Include TreeTable VT.

  Definition rep_ok (t : table) : Prop :=
    BST t.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k t.

  Definition elements (t : table) : list (key * V) :=
    SearchTree.elements t.

  Theorem empty_ok : rep_ok empty.
  Proof.
    apply empty_tree_BST.
  Qed.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    apply insert_BST.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set. induction t; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set. induction t; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete; assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      rep_ok t ->
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; assumption.
  Qed.

End TreeETableEncapsulated.

Module NicelyEncapsulatedExample.

  Module StringTreeETableEncapsulated := TreeETableEncapsulated StringVal.
  Import StringTreeETableEncapsulated.
  Open Scope string_scope.

  Example ex1 : get 0 empty = "".
  Proof.
    (* We can't directly simplify, because [get] is encapsulated. *)
    Fail reflexivity.
    (* But we can use the specifications exposed in the interface. *)
    apply get_empty_default.
  Qed.

  (* We can't fabricate trees with [T] and [E] anymore, because [tree]
     is encapsulated. *)
  Fail Example ex2 : get 0 (T E 0 "A" E) = "A".
End NicelyEncapsulatedExample.

(** Note what we've happily achieved: we can reason about the behavior
    of an ADT entirely from its specification, rather than depending
    on the implementation code.  This is what specification comments
    in interfaces attempt to achieve in real-world code. *)

(** **** Exercise: 4 stars, advanced, optional (elements_spec)  *)

(** Develop a nicely-encapsulated interface and implementation of
    tree-based tables that exposes the rest of the specification of
    [elements] from [SearchTree], including the inverses of
    correctness and completenesss, sortedness, and
    non-duplication. Send us your solution, so we can include it! *)

(** [] *)

(* ################################################################# *)
(** * Model-based Specification *)

(** The interfaces above have been based on equational specification
    of tables.  Let's consider model-based specifications.  Recall
    from [SearchTree] that in this style of specification, we

    - introduce an abstraction function (or relation) that associates
      a _concrete value_ of the ADT implementation with an _abstract
      value_ in an already well-understood type; and

    - show that the concrete and abstract operations are related in a
      sensible way. *)

(** We begin by defining a new map operation, [bound], and redefining
    existing operations to make them more clear in the table
    specification we are about to write. *)

Definition map_update {V : Type}
           (k : key) (v : V) (m : partial_map V) : partial_map V :=
  update m k v.

Definition map_find {V : Type} := @find V.

Definition empty_map {V : Type} := @Maps.empty V.

(** Now we can define an interface for tables that includes an
    abstraction function [Abs], and specifications written in terms of
    it. *)

Module Type ETableAbs.

  Parameter table : Type.
  Definition key := nat.
  Parameter V : Type.
  Parameter default : V.

  Parameter empty : table.
  Parameter get : key -> table -> V.
  Parameter set : key -> V -> table -> table.
  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Parameter Abs : table -> partial_map V.
  Parameter rep_ok : table -> Prop.

  Axiom empty_ok :
      rep_ok empty.

  Axiom set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).

  Axiom empty_relate :
      Abs empty = empty_map.

  Axiom bound_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_bound k (Abs t) = bound k t.

  Axiom lookup_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_find default k (Abs t) = get k t.

  Axiom insert_relate : forall (t : table) (k : key) (v : V),
      rep_ok t ->
      map_update k v (Abs t) = Abs (set k v t).

  Axiom elements_relate : forall (t : table),
      rep_ok t ->
      Abs t = map_of_list (elements t).

End ETableAbs.

(** **** Exercise: 4 stars, standard (list_etable_abs)  *)

(** Implement [ETableAbs] using association lists as the
    representation type. *)

Module ListETableAbs (VT : ValType) <: ETableAbs.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.
  Definition table := list (key * V).

  Definition empty : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Fixpoint get (k : key) (t : table) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition set (k : key) (v : V) (t : table) : table
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Fixpoint bound (k : key) (t : table) : bool
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition elements (t : table) : list (key * V)
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition Abs (t : table) : partial_map V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition rep_ok (t : table) : Prop
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem empty_ok : rep_ok empty.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem set_ok : forall (k : key) (v : V) (t : table),
      rep_ok t -> rep_ok (set k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem empty_relate :
    Abs empty = empty_map.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem bound_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_bound k (Abs t) = bound k t.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem lookup_relate : forall (t : table) (k : key),
      rep_ok t ->
      map_find default k (Abs t) = get k t.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem insert_relate : forall (t : table) (k : key) (v : V),
      rep_ok t ->
      map_update k v (Abs t) = Abs (set k v t).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem elements_relate : forall (t : table),
      rep_ok t ->
      Abs t = map_of_list (elements t).
  Proof.
    (* FILL IN HERE *) Admitted.

End ListETableAbs.

(* Instantiate functor for sake of autograding. *)
Module StringListETableAbs := ListETableAbs StringVal.

(** [] *)

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

    Give an implementation of [ETableAbs] using the abstraction
    function [Abs] from [SearchTree]. All the proofs of the
    [relate] axioms should be simple applications of the lemmas
    already proved as exercises in that chapter. *)

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

(** [] *)

(** **** Exercise: 2 stars, advanced, optional (TreeTableModel')  *)

(** Repeat the previous exercise, this time using the alternative
    [Abs'] function from [SearchTree]. Hint: Just tweak your
    solution to the previous exercise. *)

(** [] *)

(* ################################################################# *)
(** * Summary of ADT Verification *)

(** With equational specifications:

    - Define a _representation invariant_ to characterize which
      values of the _representation type_ are legal.  Prove that each
      operation on the representation type _preserves_ the representation
      invariant.

    - Using the representation invariant, verify the equational
      specification.

    With model-based specifications:

    - Define and verify preservation of the the representation invariant.

    - Define an _abstraction function_ that relates the
      representation type to another type that is easier to reason
      about.

    - Prove that operations of the abstract and concrete types commute
      with the abstraction function. *)

(* ################################################################# *)
(** * Another ADT: Queue *)

(** Here is an interface and algebraic specification for FIFO queues. To
    ensure totality, [peek] takes a default value and [deq] returns the
    empty queue when applied to the empty queue. *)

Module Type Queue.
  Parameter V : Type.
  Parameter queue : Type.
  Parameter empty: queue.
  Parameter is_empty : queue -> bool.
  Parameter enq : queue -> V -> queue.
  Parameter deq : queue -> queue.
  Parameter peek : V -> queue -> V.
  Axiom is_empty_empty : is_empty empty = true.
  Axiom is_empty_nonempty : forall q v, is_empty (enq q v) = false.
  Axiom peek_empty : forall d, peek d empty = d.
  Axiom peek_nonempty : forall d q v, peek d (enq q v) = peek v q.
  Axiom deq_empty : deq empty = empty.
  Axiom deq_nonempty : forall q v, deq (enq q v) = if is_empty q then q else enq (deq q) v.
End Queue.

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

(** Implement that interface and verify your implementation.  As the
    representation type, use [list V].  At least one operation will
    have to be linear time; we recommend that it be [enq]. All the
    proofs should be quite easy. *)

Module ListQueue <: Queue.
  Definition V := nat. (* for simplicity *)
  Definition queue := list V.

  Definition empty : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition is_empty (q : queue) : bool
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition enq (q : queue) (v : V) : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition deq (q : queue) : queue
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Definition peek (default : V) (q : queue) : V
    (* REPLACE THIS LINE WITH ":= _your_definition_ ." *). Admitted.

  Theorem is_empty_empty : is_empty empty = true.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem is_empty_nonempty : forall q v,
      is_empty (enq q v) = false.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_empty : forall d,
      peek d empty = d.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_nonempty : forall d q v,
      peek d (enq q v) = peek v q.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_empty :
    deq empty = empty.
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_nonempty : forall q v,
      deq (enq q v) = if is_empty q then q else enq (deq q) v.
  Proof.
    (* FILL IN HERE *) Admitted.

End ListQueue.

(** [] *)

(** Here is an interface and model-based specification for queues. We omit
    [rep_ok] from it, because our intended implementation isn't going
    to require a representation invariant. *)

Module Type QueueAbs.
  Parameter V : Type.
  Parameter queue : Type.
  Parameter empty : queue.
  Parameter is_empty : queue -> bool.
  Parameter enq : queue -> V -> queue.
  Parameter deq : queue -> queue.
  Parameter peek : V -> queue -> V.
  Parameter Abs : queue -> list V.
  Axiom empty_relate : Abs empty = [].
  Axiom enq_relate : forall q v,  Abs (enq q v) = (Abs q) ++ [v].
  Axiom peek_relate : forall d q, peek d q = hd d (Abs q).
  Axiom deq_relate : forall q, Abs (deq q) = tl (Abs q).
End QueueAbs.

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

(** Below is an implementation of [QueueAbs] using two lists.  It
    achieves amortized constant-time performance, improving on the
    single-list implementation. Verify this implementation. *)

Module TwoListQueueAbs <: QueueAbs.
  Definition V := nat. (* for simplicity *)

  Definition queue : Type := list V * list V.

  (* [(f, b)] represents a queue with a front list [f] and a back list
     [b], where the back list is stored in reverse order. *)
  Definition Abs '((f, b) : queue) : list V :=
    f ++ (rev b).

  Definition empty : queue :=
    ([], []).

  Definition is_empty (q: queue) :=
    match q with
    | ([], []) => true
    | _ => false
    end.

  Definition enq '((f, b) : queue) (v : V) :=
    (f, v :: b).

  Definition deq (q : queue) :=
    match q with
    | ([], []) => ([], [])
    | ([], b) =>
      match rev b with
      | [] => ([], [])
      | _ :: f => (f, [])
      end
    | (_ :: f, b) => (f, b)
    end.

  Definition peek (d : V) (q : queue) :=
    match q with
    | ([], []) => d
    | ([], b) =>
      match rev b with
      | [] => d
      | v :: _ => v
      end
    | (v :: _, _) => v
    end.

  Theorem empty_relate : Abs empty = [].
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem enq_relate : forall q v,
      Abs (enq q v) = (Abs q) ++ [v].
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem peek_relate : forall d q,
      peek d q = hd d (Abs q).
  Proof.
    (* FILL IN HERE *) Admitted.

  Theorem deq_relate : forall q,
      Abs (deq q) = tl (Abs q).
  Proof.
    (* FILL IN HERE *) Admitted.

End TwoListQueueAbs.

(** [] *)

(* ################################################################# *)
(** * Representation Invariants and Subset Types *)

(** In specifications thus far, whenever there was a representation
    invariant that needed to be enforced we had to add it as a
    precondition and postcondition for operations.  For example, the
    correctness of the table [get] operation depended on its [table]
    input satisfying [rep_ok].  We had to write propositions like [forall
    (t : table), rep_ok t -> ...], in which we had a type [table] with
    lots of values, and we got rid of some of those values by
    requiring [rep_ok] to hold of them. *)

(** Coq makes it possible to directly express the requirement that
    values of a type must satisfy a proposition.  The type

      {x : A | P}

    is the type of all values [x] of type [A] that satisfy property
    [P], which itself has type [A -> Prop].  The notation is deliberately
    suggestive of set-builder notation used in mathematics. Such types
    are known as _subset types_. *)

(* ================================================================= *)
(** ** Example: The Even Naturals *)

(** We can define the subset type of even natural numbers using
    the property [Nat.Even] from the standard library: *)

Definition even_nat := {x : nat | Nat.Even x}.

(** But when we try to say that [2] is an [even_nat], Coq rejects the
    definition: *)

Fail Definition two : even_nat := 2.

(** The problem is that [2] is a [nat], but we haven't proved [Nat.Even 2].
    The proof is easy: *)

Lemma Even2 : Nat.Even 2.
Proof. exists 1. reflexivity. Qed.

(** Now we can provide that proof to convince Coq [two] is an [even_nat].
    We can do that with function [exist], which is suggestive of
    "there exists an [x : A] such that [P x]." *)

Check exist : forall {A : Type} (P : A -> Prop) (x : A), P x -> {x : A | P x}.

Definition two : even_nat := exist Nat.Even 2 Even2.

(** Another way of constructing [two] is to enter Coq's proof scripting
    mode and use tactics.  We saw this briefly in [ProofObjects]. *)

Definition two' : even_nat.
Proof.
  apply exist with (x := 2).
  exists 1. reflexivity.
Defined.

(** That technique is often useful with subset types, because it
    helps us more easily build the proof objects, rather than have to
    write them ourselves. *)

(** A value of type [even_nat] is like a "package" containing the [nat]
    and the proof that the [nat] is even.  We have to use functions to
    extract those components from the package. *)

Fail Example plus_two : 1 + two = 3.

Check proj1_sig : forall {A : Type} {P : A -> Prop} (e : {x : A | P x}), A.

Example plus_two : 1 + proj1_sig two = 3.
Proof. reflexivity. Qed.

Check proj2_sig : forall {A : Type} {P : A -> Prop} (e : {x : A | P x}), P (proj1_sig e).

Example Even2' : Nat.Even 2 := proj2_sig two.

(* ================================================================= *)
(** ** Defining Subset Types *)

(** Like nearly everything else we've seen in Coq's logic, subset
    types are actually defined in the standard library rather than
    being built-in to the language. *)

Module SigSandbox.

  (** Subset types are just a syntactic notation for [sig]: *)

  Inductive sig {A : Type} (P : A -> Prop) : Type :=
  | exist (x : A) : P x -> sig P.

  Notation "{ x : A | P }" := (sig A (fun x => P)).

  (** The name [sig] is short for the Greek capital letter sigma,
      because subset types are similar to something known in type
      theory as _sigma types_, aka _dependent sums_. *)

  (** Subset types and existential quantification are quite similar.
      Recall how the latter is defined: *)

  Inductive ex {A : Type} (P : A -> Prop) : Prop :=
  | ex_intro (x : A) : P x -> ex P.

  (** The only difference is that [sig] creates a [Type] whereas [ex]
      creates a [Prop].  That is, the former is computational in content,
      whereas the latter is logical.  Therefore we can pattern match
      to recover the witness from a [sig], but we cannot do the same
      with an [ex]. *)

  Definition proj1_sig {A : Type} {P : A -> Prop} (e : sig P) : A :=
    match e with
    | exist _ x _ => x
    end.

  Definition proj2_sig {A : Type} {P : A -> Prop} (e : sig P) : P (proj1_sig e) :=
    match e with
    | exist _ _ p => p
    end.

  Fail Definition proj1_ex {A : Type} {P : A -> Prop} (e : ex P) : A :=
    match e with
    | ex_intro _ x _ => x
    end.

End SigSandbox.

(* ================================================================= *)
(** ** Example: Vectors *)

(** A _vector_ is a list of a known length. Type [vector X] contains
    values [(xs, n)] with a particular representation invariant: [n]
    must be the length of [xs].  *)

Definition vector (X : Type) :=
  { '(xs, n) : list X * nat | length xs = n }.

(** The type itself enforces the representation invariant, because a
    value of type [vector X] cannot be constructed without first
    proving that the invariant holds. *)

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

(** Construct any vector of your choice. *)

Example a_vector : vector nat.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

(** Define a cons operation on vectors. Remember to end with
    [Defined] rather than [Qed]. *)

Definition vector_cons {X : Type} (x : X) (v : vector X) : vector X.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the correctness of your cons operation. *)

Definition list_of_vector {X : Type} (v : vector X) : list X :=
  fst (proj1_sig v).

Theorem vector_cons_correct : forall (X : Type) (x : X) (v : vector X),
    list_of_vector (vector_cons x v) = x :: (list_of_vector v).
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

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

(** Define an append operation on vectors. *)

Definition vector_app {X : Type} (v1 v2 : vector X) : vector X.
Proof.
  (* FILL IN HERE *) Admitted.

(** Prove the correctness of your append operation. *)

Theorem vector_app_correct : forall (X : Type) (v1 v2 : vector X),
    list_of_vector (vector_app v1 v2) =
    list_of_vector v1 ++ list_of_vector v2.
Proof.
  (* FILL IN HERE *) Admitted.

(** [] *)

(* ================================================================= *)
(** ** Using Subset Types to Enforce the BST Invariant *)

(** Let's use subset types to reimplement tree-based tables with an
    [elements] operation.  Previously we had to add [rep_ok] to the
    interface and specifications.  With subset types we can eliminate
    that. *)

Module Type ETableSubset.

  Include Table.

  (** Note: no [rep_ok] anywhere. *)

  Parameter bound : key -> table -> bool.
  Parameter elements : table -> list (key * V).

  Axiom bound_empty : forall (k : key),
      bound k empty = false.

  Axiom bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.

  Axiom bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.

  Axiom elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).

  Axiom elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.

End ETableSubset.

Module TreeETableSubset (VT : ValType) <: ETableSubset.

  Definition V := VT.V.
  Definition default := VT.default.
  Definition key := nat.

  (** [table] now is required to enforce [BST]. *)
  Definition table := { t : tree V | BST t }.

  (** Now instead of proving separate theorems that operations return
      valid representations, the proofs are "baked in" to the
      operations. *)
  Definition empty : table.
  Proof.
    apply (exist _ empty_tree).
    apply empty_tree_BST.
  Defined.

  (** Now we insert a projection to get to the tree. *)
  Definition get (k : key) (t : table) : V :=
    lookup default k (proj1_sig t).

  Definition set (k : key) (v : V) (t : table) : table.
  Proof.
    destruct t as [t Ht].
    apply (exist _ (insert k v t)).
    apply insert_BST. assumption.
  Defined.

  Definition bound (k : key) (t : table) : bool :=
    SearchTree.bound k (proj1_sig t).

  Definition elements (t : table) : list (key * V) :=
    elements (proj1_sig t).

  Theorem get_empty_default: forall (k : key),
      get k empty = default.
  Proof.
    apply lookup_empty.
  Qed.

  (** Now the rest of the proofs require minor modifications to
      destruct the table to get the tree and the representation
      invariant, and use the latter where needed. *)

  Theorem get_set_same: forall (k : key) (v : V) (t : table),
      get k (set k v t) = v.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_eq.
  Qed.

  Theorem get_set_other: forall (k k' : key) (v : V) (t : table),
      k <> k' -> get k' (set k v t) = get k' t.
  Proof.
    intros. unfold get, set.
    destruct t as [t Hbst]. simpl.
    apply lookup_insert_neq. assumption.
  Qed.

  Theorem bound_empty : forall (k : key),
      bound k empty = false.
  Proof.
    reflexivity.
  Qed.

  Theorem bound_set_same : forall (k : key) (v : V) (t : table),
      bound k (set k v t) = true.
  Proof.
    intros k v t. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    induction t; inv Hbst; bdall.
  Qed.

  Theorem bound_set_other : forall (k k' : key) (v : V) (t : table),
      k <> k' -> bound k' (set k v t) = bound k' t.
  Proof.
    intros k k' v t Hneq. unfold bound, set.
    destruct t as [t Hbst]. simpl in *.
    induction t; inv Hbst; bdall.
  Qed.

  Theorem elements_complete : forall (k : key) (v : V) (t : table),
      bound k t = true ->
      get k t = v ->
      In (k, v) (elements t).
  Proof.
    intros k v t Hbound Hlookup.
    pose proof SearchTree.elements_complete as Hcomplete.
    unfold elements_complete_spec in Hcomplete.
    apply Hcomplete with default; try assumption.
    destruct t as [t Hbst]. assumption.
  Qed.

  Theorem elements_correct : forall (k : key) (v : V) (t : table),
      In (k, v) (elements t) ->
      bound k t = true /\ get k t = v.
  Proof.
    intros k v t. simpl. intros Hin.
    pose proof SearchTree.elements_correct as Hcorrect.
    unfold elements_correct_spec in Hcorrect.
    apply Hcorrect; try assumption.
    destruct t as [t Hbst]. assumption.
  Qed.

End TreeETableSubset.

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

(** Implement [ETableSubset] using association lists that are not
    permitted to contain duplicate keys.  Enforce that representation
    invariant with a subset type.  Note that you do not have to keep
    the lists in a sorted order. The implementation of [elements]
    should therefore just be quite easy: just return the association
    list.  The implementation of [set], though, will have to be a
    linear-time operation. *)

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

(* 2020-08-07 17:08 *)


Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import Coq.Init.Peano.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Compare_dec.
Require Import Coq.PArith.BinPosDef.
Require Import Coq.ZArith.BinInt Coq.ZArith.ZArith Coq.ZArith.Zdiv Coq.ZArith.Znumtheory Coq.NArith.NArith. (* import Zdiv before Znumtheory *)
Require Import Coq.NArith.Nnat.

Require Import Crypto.Algebra.Hierarchy Crypto.Algebra.Field.
Require Import Crypto.Spec.ModularArithmetic.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems Crypto.Arithmetic.PrimeFieldTheorems.

Require Import Crypto.Util.Decidable. (* Crypto.Util.Notations. *)
Require Import Coq.setoid_ring.Ring_theory Coq.setoid_ring.Field_theory Coq.setoid_ring.Field_tac.
Require Import Ring.

From Circom Require Import Circom Default Util DSL Tuple ListUtil LibTactics Simplify.
From Circom Require Import Repr ReprZ.
From Circom.CircomLib Require Import Bitify Comparators.
From Circom.BigInt.Definition Require Import ModProd.
(* Circuit:
* https://github.com/yi-sun/circom-pairing/blob/master/circuits/bigint.circom
*)

Module ModProd.

Module D := DSL.
Module Cmp := Comparators.
Module RZU := ReprZUnsigned.
Module RZ := RZU.RZ.
Module R := Repr.

Local Open Scope list_scope.
Local Open Scope Z_scope.
Local Open Scope F_scope.
Local Open Scope circom_scope.
Local Open Scope tuple_scope.

Local Coercion Z.of_nat: nat >-> Z.
Local Coercion N.of_nat: nat >-> N.

Module N := Bitify.Num2Bits.
Module B := Bitify.Bits2Num.

Section _ModProd.
Context {n: nat}.

Definition cons (a b prod carry: F) :=
  exists n2b: (@N.t (2*n)),
  n2b.(N._in) = a*b /\
  exists (b2n1: @B.t n) (b2n2: @B.t n),
  D.iter (fun (i: nat) (cons : Prop) => cons /\
    b2n1.(B._in)[i] = n2b.(N.out)[i] /\
    b2n2.(B._in)[i] = n2b.(N.out)[i + n])
  n True /\
  prod = b2n1.(B.out) /\
  carry = b2n2.(B.out).

Record t := { a: F; b: F; prod: F; carry: F; _cons: cons a b prod carry}.

Local Notation "[| xs |]" := (Bitify.R.as_le 1 xs).

#[local]Hint Extern 10 (Forall _ (firstn _ _)) => apply Forall_firstn : core.
#[local]Hint Extern 10 (Forall _ (skipn _ _)) => apply Forall_skipn : core.

Theorem soundness: forall (c: t),
  2 * n <= k ->
  let '(a,b,prod,carry) := (c.(a), c.(b), c.(prod), c.(carry)) in
  carry * 2^n + prod = a * b /\
  prod | (n).
Proof with (lia || rewrite_length || fqsatz || eauto).
  unwrap_C.
  intros c Hn. destruct c as [a b prod carry _cons].
  destruct _cons as [n2b [n2b_in [b2n1 [b2n2 [loop [Pprod Pcarry]]]]]].
  simpl.
  rem_iter.
  pose proof (N.soundness n2b) as SN.
  pose proof (B.soundness b2n1) as SB1.
  pose proof (B.soundness b2n2) as SB2.
  pose proof SN as Hrepr.
  destruct Hrepr as [_ [Sout Has]].
  pose_lengths.

  rewrite n2b_in in *. clear n2b_in.

  pose (Inv := fun (i: nat) (_cons: Prop) => _cons ->
    (* forall (j: nat), j < i ->
    'b2n1.(B._in)[:j] = 'n2b.(N.out)[:j] /\
    'b2n2.(B._in)[:j] = 'n2b.(N.out)[:j+n] *)
    'b2n1.(B._in)[:i] = 'n2b.(N.out)[:i] /\
    'b2n2.(B._in)[:i] = 'n2b.(N.out)[n:][:i]
  ).

  assert (Hinv: Inv n%nat (D.iter f n%nat True)). {
    apply DSL.iter_inv; unfold Inv.
    - easy.
    - intros i _cons IH Hi Hstep.
      subst f; lift_to_list; intuit.
      eapply firstn_congruence; fold_default; (lia || eauto).
      eapply firstn_congruence; auto.
      rewrite skipn_nth. fold_default. lrewrite. f_equal. lia.
  }
  pose_lengths.
  specialize (Hinv loop). clear Inv.
  firstn_all.
  (* why didn't firstn *)
  rewrite firstn_all2 with (l:=' B._in b2n2) in Hinv by lia.
  destruct Hinv as [H H'].
  rewrite H, H', SB1, SB2, Pprod, Pcarry in *; auto.
  unfold R.as_le2 in *.
  split.
  rewrite Has.
  rewrite firstn_all2 with (l:=(' N.out n2b [n:]))...
  remember ('N.out n2b [:n]) as fst. remember ('N.out n2b [n:]) as snd.
  erewrite <- firstn_skipn with (l:='N.out n2b) (n:=n).
  rewrite R.as_le_app... subst. fqsatz.
  applys_eq R.repr_le_ub'; auto...
  Unshelve. all:exact F.zero.
Qed.

End _ModProd.
End ModProd.