Require Import List.
Import ListNotations.
Require Import Lia.

Require Import BinInt ZArith_dec Zorder ZArith.
Require Export Id.
Require Export State.
Require Export Expr.

From hahn Require Import HahnBase.

(* AST for statements *)
Inductive stmt : Type :=
| SKIP  : stmt
| Assn  : id -> expr -> stmt
| READ  : id -> stmt
| WRITE : expr -> stmt
| Seq   : stmt -> stmt -> stmt
| If    : expr -> stmt -> stmt -> stmt
| While : expr -> stmt -> stmt.

(* Supplementary notation *)
Notation "x  '::=' e"                         := (Assn  x e    ) (at level 37, no associativity).
Notation "s1 ';;'  s2"                        := (Seq   s1 s2  ) (at level 35, right associativity).
Notation "'COND' e 'THEN' s1 'ELSE' s2 'END'" := (If    e s1 s2) (at level 36, no associativity).
Notation "'WHILE' e 'DO' s 'END'"             := (While e s    ) (at level 36, no associativity).

(* Configuration *)
Definition conf := (state Z * list Z * list Z)%type.

(* Big-step evaluation relation *)
Reserved Notation "c1 '==' s '==>' c2" (at level 0).

Notation "st [ x '<-' y ]" := (update Z st x y) (at level 0).

Inductive bs_int : stmt -> conf -> conf -> Prop :=
| bs_Skip        : forall (c : conf),
    c == SKIP ==> c
| bs_Assign      : forall (s : state Z) (i o : list Z) (x : id) (e : expr) (z : Z)
                          (VAL : [| e |] s => z),
    (s, i, o) == x ::= e ==> (s [x <- z], i, o)
| bs_Read        : forall (s : state Z) (i o : list Z) (x : id) (z : Z),
    (s, z::i, o) == READ x ==> (s [x <- z], i, o)
| bs_Write       : forall (s : state Z) (i o : list Z) (e : expr) (z : Z)
                          (VAL : [| e |] s => z),
    (s, i, o) == WRITE e ==> (s, i, z::o)
| bs_Seq         : forall (c c' c'' : conf) (s1 s2 : stmt)
                          (STEP1 : c == s1 ==> c') (STEP2 : c' == s2 ==> c''),
    c ==  s1 ;; s2 ==> c''
| bs_If_True     : forall (s : state Z) (i o : list Z) (c' : conf) (e : expr) (s1 s2 : stmt)
                     (CVAL : [| e |] s => Z.one)
                     (STEP : (s, i, o) == s1 ==> c'),
    (s, i, o) == COND e THEN s1 ELSE s2 END ==> c'
| bs_If_False    : forall (s : state Z) (i o : list Z) (c' : conf) (e : expr) (s1 s2 : stmt)
                     (CVAL : [| e |] s => Z.zero)
                     (STEP : (s, i, o) == s2 ==> c'),
    (s, i, o) == COND e THEN s1 ELSE s2 END ==> c'
| bs_While_True  : forall (st : state Z) (i o : list Z) (c' c'' : conf) (e : expr) (s : stmt)
                          (CVAL  : [| e |] st => Z.one)
                          (STEP  : (st, i, o) == s ==> c')
                          (WSTEP : c' == WHILE e DO s END ==> c''),
    (st, i, o) == WHILE e DO s END ==> c''
| bs_While_False : forall (st : state Z) (i o : list Z) (e : expr) (s : stmt)
                          (CVAL : [| e |] st => Z.zero),
    (st, i, o) == WHILE e DO s END ==> (st, i, o)
where "c1 == s ==> c2" := (bs_int s c1 c2).

(* Big step equivalence *)
Definition bs_equivalent (s1 s2 : stmt) :=
  forall (c c' : conf),
    c == s1 ==> c' <-> c == s2 ==> c'.

Notation "s1 '~~~' s2" := (bs_equivalent s1 s2) (at level 0).

Ltac seq_inversion :=
  match goal with
    H: _ == _ ;; _ ==> _ |- _ => inversion_clear H
  end.

Ltac seq_apply :=
  match goal with
  | H: _   == ?s1 ==> ?c' |- _ == (?s1 ;; _) ==> _ =>
    apply bs_Seq with c'; solve [seq_apply | assumption]
  | H: ?c' == ?s2 ==>  _  |- _ == (_ ;; ?s2) ==> _ =>
    apply bs_Seq with c'; solve [seq_apply | assumption]
  end.

Module SmokeTest.

  (* Associativity of sequential composition *)
  Lemma seq_assoc (s1 s2 s3 : stmt) :
    ((s1 ;; s2) ;; s3) ~~~ (s1 ;; (s2 ;; s3)).
  Proof. admit. Admitted.

  (* One-step unfolding *)
  Lemma while_unfolds (e : expr) (s : stmt) :
    (WHILE e DO s END) ~~~ (COND e THEN s ;; WHILE e DO s END ELSE SKIP END).
  Proof. admit. Admitted.

  (* Terminating loop invariant *)
  Lemma while_false (e : expr) (s : stmt) (st : state Z)
        (i o : list Z) (c : conf)
        (EXE : c == WHILE e DO s END ==> (st, i, o)) :
    [| e |] st => Z.zero.
  Proof. admit. Admitted.

  (* Big-step semantics does not distinguish non-termination from stuckness *)
  Lemma loop_eq_undefined :
    (WHILE (Nat 1) DO SKIP END) ~~~
    (COND (Nat 3) THEN SKIP ELSE SKIP END).
  Proof. admit. Admitted.

  (* Loops with equivalent bodies are equivalent *)
  Lemma while_eq (e : expr) (s1 s2 : stmt)
        (EQ : s1 ~~~ s2) :
    WHILE e DO s1 END ~~~ WHILE e DO s2 END.
  Proof. admit. Admitted.

  (* Loops with the constant true condition don't terminate *)
  (* Exercise 4.8 from Winskel's *)
  Lemma while_true_undefined c s c' :
    ~ c == WHILE (Nat 1) DO s END ==> c'.
  Proof. admit. Admitted.

End SmokeTest.

(* Semantic equivalence is a congruence *)
Lemma eq_congruence_seq_r (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  (s  ;; s1) ~~~ (s  ;; s2).
Proof. admit. Admitted.

Lemma eq_congruence_seq_l (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  (s1 ;; s) ~~~ (s2 ;; s).
Proof. admit. Admitted.

Lemma eq_congruence_cond_else
      (e : expr) (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  COND e THEN s  ELSE s1 END ~~~ COND e THEN s  ELSE s2 END.
Proof. admit. Admitted.

Lemma eq_congruence_cond_then
      (e : expr) (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  COND e THEN s1 ELSE s END ~~~ COND e THEN s2 ELSE s END.
Proof. admit. Admitted.

Lemma eq_congruence_while
      (e : expr) (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  WHILE e DO s1 END ~~~ WHILE e DO s2 END.
Proof. admit. Admitted.

Lemma eq_congruence (e : expr) (s s1 s2 : stmt) (EQ : s1 ~~~ s2) :
  ((s  ;; s1) ~~~ (s  ;; s2)) /\
  ((s1 ;; s ) ~~~ (s2 ;; s )) /\
  (COND e THEN s  ELSE s1 END ~~~ COND e THEN s  ELSE s2 END) /\
  (COND e THEN s1 ELSE s  END ~~~ COND e THEN s2 ELSE s  END) /\
  (WHILE e DO s1 END ~~~ WHILE e DO s2 END).
Proof. admit. Admitted.

(* Big-step semantics is deterministic *)
Ltac by_eval_deterministic :=
  match goal with
    H1: [|?e|]?s => ?z1, H2: [|?e|]?s => ?z2 |- _ =>
     apply (eval_deterministic e s z1 z2) in H1; [subst z2; reflexivity | assumption]
  end.

Ltac eval_zero_not_one :=
  match goal with
    H : [|?e|] ?st => (Z.one), H' : [|?e|] ?st => (Z.zero) |- _ =>
    assert (Z.zero = Z.one) as JJ; [ | inversion JJ];
    eapply eval_deterministic; eauto
  end.

Lemma bs_int_deterministic (c c1 c2 : conf) (s : stmt)
      (EXEC1 : c == s ==> c1) (EXEC2 : c == s ==> c2) :
  c1 = c2.
Proof. admit. Admitted.

(* Contextual equivalence *)
Inductive Context : Type :=
| Hole
| SeqL   : Context -> stmt -> Context
| SeqR   : stmt -> Context -> Context
| IfThen : expr -> Context -> stmt -> Context
| IfElse : expr -> stmt -> Context -> Context
| WhileC : expr -> Context -> Context.

(* Plugging a statement into a context *)
Fixpoint plug (C : Context) (s : stmt) : stmt :=
  match C with
  | Hole => s
  | SeqL     C  s1 => Seq (plug C s) s1
  | SeqR     s1 C  => Seq s1 (plug C s)
  | IfThen e C  s1 => If e (plug C s) s1
  | IfElse e s1 C  => If e s1 (plug C s)
  | WhileC   e  C  => While e (plug C s)
  end.

Notation "C '<~' e" := (plug C e) (at level 43, no associativity).

(* Contextual equivalence *)
Definition contextual_equivalent (s1 s2 : stmt) :=
  forall (C : Context), (C <~ s1) ~~~ (C <~ s2).
Notation "s1 '~c~' s2" := (contextual_equivalent s1 s2)
                            (at level 42, no associativity).

(* Contextual equivalence is equivalent to the semantic one *)
(* TODO: no longer needed *)
Ltac by_eq_congruence e s s1 s2 H :=
  remember (eq_congruence e s s1 s2 H) as Congruence;
  match goal with H: Congruence = _ |- _ => clear H end;
  repeat (match goal with H: _ /\ _ |- _ => inversion_clear H end); assumption.

Lemma eq_eq_ceq s1 s2: s1 ~~~ s2 <-> s1 ~c~ s2.
Proof. admit. Admitted.

(* Small-step semantics *)
Module SmallStep.

  Reserved Notation "c1 '--' s '-->' c2" (at level 0).

  Inductive ss_int_step : stmt -> conf -> option stmt * conf -> Prop :=
  | ss_Skip        : forall (c : conf), c -- SKIP --> (None, c)
  | ss_Assign      : forall (s : state Z) (i o : list Z) (x : id) (e : expr) (z : Z)
                            (SVAL : [| e |] s => z),
      (s, i, o) -- x ::= e --> (None, (s [x <- z], i, o))
  | ss_Read        : forall (s : state Z) (i o : list Z) (x : id) (z : Z),
      (s, z::i, o) -- READ x --> (None, (s [x <- z], i, o))
  | ss_Write       : forall (s : state Z) (i o : list Z) (e : expr) (z : Z)
                            (SVAL : [| e |] s => z),
      (s, i, o) -- WRITE e --> (None, (s, i, z::o))
  | ss_Seq_Compl   : forall (c c' : conf) (s1 s2 : stmt)
                            (SSTEP : c -- s1 --> (None, c')),
      c -- s1 ;; s2 --> (Some s2, c')
  | ss_Seq_InCompl : forall (c c' : conf) (s1 s2 s1' : stmt)
                            (SSTEP : c -- s1 --> (Some s1', c')),
      c -- s1 ;; s2 --> (Some (s1' ;; s2), c')
  | ss_If_True     : forall (s : state Z) (i o : list Z) (s1 s2 : stmt) (e : expr)
                            (SCVAL : [| e |] s => Z.one),
      (s, i, o) -- COND e THEN s1 ELSE s2 END --> (Some s1, (s, i, o))
  | ss_If_False    : forall (s : state Z) (i o : list Z) (s1 s2 : stmt) (e : expr)
                            (SCVAL : [| e |] s => Z.zero),
      (s, i, o) -- COND e THEN s1 ELSE s2 END --> (Some s2, (s, i, o))
  | ss_While       : forall (c : conf) (s : stmt) (e : expr),
      c -- WHILE e DO s END --> (Some (COND e THEN s ;; WHILE e DO s END ELSE SKIP END), c)
  where "c1 -- s --> c2" := (ss_int_step s c1 c2).

  Reserved Notation "c1 '--' s '-->>' c2" (at level 0).

  Inductive ss_int : stmt -> conf -> conf -> Prop :=
    ss_int_Base : forall (s : stmt) (c c' : conf),
                    c -- s --> (None, c') -> c -- s -->> c'
  | ss_int_Step : forall (s s' : stmt) (c c' c'' : conf),
                    c -- s --> (Some s', c') -> c' -- s' -->> c'' -> c -- s -->> c''
  where "c1 -- s -->> c2" := (ss_int s c1 c2).

  Lemma ss_int_step_deterministic (s : stmt)
        (c : conf) (c' c'' : option stmt * conf)
        (EXEC1 : c -- s --> c')
        (EXEC2 : c -- s --> c'') :
    c' = c''.
  Proof. admit. Admitted.

  Lemma ss_int_deterministic (c c' c'' : conf) (s : stmt)
        (STEP1 : c -- s -->> c') (STEP2 : c -- s -->> c'') :
    c' = c''.
  Proof. admit. Admitted.

  Lemma ss_bs_base (s : stmt) (c c' : conf) (STEP : c -- s --> (None, c')) :
    c == s ==> c'.
  Proof. admit. Admitted.

  Lemma ss_ss_composition (c c' c'' : conf) (s1 s2 : stmt)
        (STEP1 : c -- s1 -->> c'') (STEP2 : c'' -- s2 -->> c') :
    c -- s1 ;; s2 -->> c'.
  Proof. admit. Admitted.

  Lemma ss_bs_step (c c' c'' : conf) (s s' : stmt)
        (STEP : c -- s --> (Some s', c'))
        (EXEC : c' == s' ==> c'') :
    c == s ==> c''.
  Proof. admit. Admitted.

  Theorem bs_ss_eq (s : stmt) (c c' : conf) :
    c == s ==> c' <-> c -- s -->> c'.
  Proof. admit. Admitted.

End SmallStep.

(* CPS semantics *)
Inductive cont : Type :=
| KEmpty : cont
| KStmt  : stmt -> cont.

Definition Kapp (l r : cont) : cont :=
  match (l, r) with
  | (KStmt ls, KStmt rs) => KStmt (ls ;; rs)
  | (KEmpty  , _       ) => r
  | (_       , _       ) => l
  end.

Notation "'!' s" := (KStmt s) (at level 0).
Notation "s1 @ s2" := (Kapp s1 s2) (at level 0).

Reserved Notation "k '|-' c1 '--' s '-->' c2" (at level 0).

Inductive cps_int : cont -> cont -> conf -> conf -> Prop :=
| cps_Empty       : forall (c : conf), KEmpty |- c -- KEmpty --> c
| cps_Skip        : forall (c c' : conf) (k : cont)
                           (CSTEP : KEmpty |- c -- k --> c'),
    k |- c -- !SKIP --> c'
| cps_Assign      : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (x : id) (e : expr) (n : Z)
                           (CVAL : [| e |] s => n)
                           (CSTEP : KEmpty |- (s [x <- n], i, o) -- k --> c'),
    k |- (s, i, o) -- !(x ::= e) --> c'
| cps_Read        : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (x : id) (z : Z)
                      (CSTEP : KEmpty |- (s [x <- z], i, o) -- k --> c'),
    k |- (s, z::i, o) -- !(READ x) --> c'
| cps_Write       : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (z : Z)
                      (CVAL : [| e |] s => z)
                      (CSTEP : KEmpty |- (s, i, z::o) -- k --> c'),
    k |- (s, i, o) -- !(WRITE e) --> c'
| cps_Seq         : forall (c c' : conf) (k : cont) (s1 s2 : stmt)
                           (CSTEP : !s2 @ k |- c -- !s1 --> c'),
    k |- c -- !(s1 ;; s2) --> c'
| cps_If_True     : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s1 s2 : stmt)
                      (CVAL : [| e |] s => Z.one)
                      (CSTEP : k |- (s, i, o) -- !s1 --> c'),
    k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_If_False    : forall (s : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s1 s2 : stmt)
                      (CVAL : [| e |] s => Z.zero)
                      (CSTEP : k |- (s, i, o) -- !s2 --> c'),
    k |- (s, i, o) -- !(COND e THEN s1 ELSE s2 END) --> c'
| cps_While_True  : forall (st : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s : stmt)
                      (CVAL : [| e |] st => Z.one)
                      (CSTEP : !(WHILE e DO s END) @ k |- (st, i, o) -- !s --> c'),
    k |- (st, i, o) -- !(WHILE e DO s END) --> c'
| cps_While_False : forall (st : state Z) (i o : list Z) (c' : conf)
                           (k : cont) (e : expr) (s : stmt)
                      (CVAL : [| e |] st => Z.zero)
                      (CSTEP : KEmpty |- (st, i, o) -- k --> c'),
    k |- (st, i, o) -- !(WHILE e DO s END) --> c'
where "k |- c1 -- s --> c2" := (cps_int k s c1 c2).

Ltac cps_bs_gen_helper k H HH :=
  destruct k eqn:K; subst; inversion H; subst;
  [inversion EXEC; subst | eapply bs_Seq; eauto];
  apply HH; auto.

Lemma cps_bs_gen (S : stmt) (c c' : conf) (S1 k : cont)
      (EXEC : k |- c -- S1 --> c') (DEF : !S = S1 @ k):
  c == S ==> c'.
Proof. admit. Admitted.

Lemma cps_bs (s1 s2 : stmt) (c c' : conf) (STEP : !s2 |- c -- !s1 --> c'):
   c == s1 ;; s2 ==> c'.
Proof. admit. Admitted.

Lemma cps_int_to_bs_int (c c' : conf) (s : stmt)
      (STEP : KEmpty |- c -- !(s) --> c') :
  c == s ==> c'.
Proof. admit. Admitted.

Lemma cps_cont_to_seq c1 c2 k1 k2 k3
      (STEP : (k2 @ k3 |- c1 -- k1 --> c2)) :
  (k3 |- c1 -- k1 @ k2 --> c2).
Proof. admit. Admitted.

Lemma bs_int_to_cps_int_cont c1 c2 c3 s k
      (EXEC : c1 == s ==> c2)
      (STEP : k |- c2 -- !(SKIP) --> c3) :
  k |- c1 -- !(s) --> c3.
Proof. admit. Admitted.

Lemma bs_int_to_cps_int st i o c' s (EXEC : (st, i, o) == s ==> c') :
  KEmpty |- (st, i, o) -- !s --> c'.
Proof. admit. Admitted.

(* Lemma cps_stmt_assoc s1 s2 s3 s (c c' : conf) : *)
(*   (! (s1 ;; s2 ;; s3)) |- c -- ! (s) --> (c') <-> *)
(*   (! ((s1 ;; s2) ;; s3)) |- c -- ! (s) --> (c'). *)


(*
 * Copyright (c) 2020 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
Require Import bedrock.lang.cpp.
Import cQp_compat.

Section with_Sigma.

  Context `{Sigma: cpp_logic} {CU:genv}.
  Import primitives.

  Variable x:ptr.
  Variable y:ptr.
  Variable r:Rep.
  Variable q:Qp.

  (** * Struct & Class

      consider the following C++ class.

      [[
      class Point {
        int x;
        int y;
      };
      ]]

      cpp2v will generate mangled names and some notations to help
      you write predicates more conveniently.
 *)

  Notation "`::Point::x`" :={| f_type := "Z4Point" ; f_name := "_Z4Pointx" |} (at level 0).

  Notation "`::Point::y`" :={| f_type := "Z4Point" ; f_name := "_Z4Pointy" |} (at level 0).

  (**
Just like [intR] defines the memory representation for the type [int],
we can define [PointR] to define the memory representation for the class [Point].
The following says, that the field x contains the integer 1 and field y contains
the integer value [5] *)

    Example PointR15 (q : Qp) : Rep :=
    _field `::Point::x`  |-> intR q 1 **
    _field `::Point::y`  |-> intR q 5.

(**
The above was too concrete; it stored the specific point (1,5).
Just like [intR] takes as agument a [z:Z] to denote the mathematical number being
represented, we define a Gallina record to denote the mathematical model of what is stored:
*)

  Record Model_Point : Type :=
    { p_x : Z
    ; p_y : Z
    }.

  (** Then we can define the general class representation as follows: *)
    Definition PointR (q : Qp) (m: Model_Point): Rep :=
    _field `::Point::x`  |-> intR q (p_x m) **
    _field `::Point::y`  |-> intR q (p_y m).

  (** * Tagged Unions

   Sometimes, the interpretation of a piece of data depends on another value.
   For example, consider the following class.

   [[
   struct tagged {
     bool tag;
     union { int x; bool y; };
   };
   ]]

   A datatype like this represents *either* an integer, or a boolean.
   Following the same pattern above, we construct a Coq type to capture this.
   In this case, rather than writing a [Record], we use a [Variant].
 *)
  Variant M : Set :=
  | AnInt (_ : Z) (* a value of type [Z] *)
  | ABool (_: bool) (* a value of type [bool] *).

  (** this has both integers and booleans *)
  Check AnInt 3 : M.
  Check ABool true : M.

  (** these are tagged in Coq, i.e. we can pattern match on a value of
      type [M] to determine which case it is.
   *)
  Definition is_an_int (m : M) : bool :=
    match m with
    | AnInt _ => true
    | _ => false
    end.

  (** to write a representation predicate for a tagged union, we
      can pattern match on the model to comput the value of the [tag]
      field for the representation predicate.
   *)
  Parameters tag_field x_field y_field : field.

  Definition taggedR (m : M) : Rep :=
    match m with
    | AnInt z => _field tag_field |-> boolR 1 true **
                 _field x_field |-> intR 1 z
    | ABool b => _field tag_field |-> boolR 1 false **
                 _field y_field |-> boolR 1 b
    end.
  (** note that in this definition, the [x_field] and [y_field] are *not*
      disjoint.

      an equivalent way to write this definition is the following.
   *)
  Definition taggedR' (m : M) : Rep :=
    _field tag_field |-> boolR 1 (is_an_int m) **
    match m with
    | AnInt z => _field x_field |-> intR 1 z
    | ABool b => _field y_field |-> boolR 1 b
    end.
  (** a benefit to this approach is that is is clear that, regardless of the
      value of the model, it is always safe to access the [tag] field.

      in practice, however, it isn't difficult to prove that they are equivalent.
   *)
  Goal forall (this : ptr) m, this |-> taggedR m -|- this |-> taggedR' m.
  Proof.
    rewrite /taggedR /taggedR'.
    split'; (* prove each direction of the entailment separately (our automation
               can only prove one direction at a time) *)
      destruct m; (* case analysis on the [m] to determine if it is an [AnInt]
                     or an [ABool] *)
      simpl; eauto with iFrame. (* standard entailment checking *)
  Qed.

  (** with the above representation predicate, we can represent an object
      carrying the value [5] and an object carrying the value [false] as
      below.
   *)
  Definition __ (this : ptr) : mpred := this |-> taggedR (AnInt 5).
  Definition __1 (this : ptr) : mpred := this |-> taggedR (ABool false).

  (** one issue with the above definitions is that they do not capture the
      possible "slack" bits in the implementation. to understand the intricacies
      connected to "slack" bits, see slack_bits.v
   *)

  (** * Untagged Unions

    Untagged unions are a little bit more complex. In practice, they should
    be avoided when possible, but this doesn't always lead to nice code,
    so we do support them.

    If you must use them, we write a representation predicate for each of the
    possibilites of the [union] and then prove equivalences between them.
    Concretely, here is an example:

    [[
    union OrBytes {
      int32 word;
      struct { int16 high; int16 low; };
    };
    ]]

    The representation for [word] is easy, the one for the struct is only
    slightly more complex.
   *)
  Parameters word_field high_field low_field : field.

  Definition OrBytes_wordR (q : Qp) (w : Z) : Rep :=
    _field word_field |-> intR q w.

  Definition OrBytes_high_lowR (q : Qp) (h l : Z) : Rep :=
    _field high_field |-> intR q h **
    _field low_field |-> intR q l.

  (** Now, when we write the representation predidate for [OrBytes], we pick
      one of the two representations as primary. Here, we will pick
      [OrBytes_wordR] as primary.
   *)
  Definition OrBytesR (q : Qp) (w : Z) : Rep :=
    OrBytes_wordR q w.

  (** It is undefined behavior in C++ to read the element of a union that was
      not most recently written.

      To convert from one representation to another by writing, you can first
      convert the representation back to [uninitR "OrBytes" 1], and then
      re-initialize the desired union member.
   *)

  (**
     Some compilers implement a language extension which defines this behaivor.
     If you wish to rely on this behavior, you can write lemmas similar to the
     following.

     This theorem allows you to view an [OrBytesR] as an [OrBytes_high_lowR]
   *)
  Lemma words_high_low : forall q w,
      OrBytesR q w -|- OrBytes_high_lowR q (Z.shiftr w 16) (Z.land w (2 ^ 16 - 1)).
  Proof. Admitted.

  (** this theorem allows you to go the other way *)
  Lemma high_low_words : forall q l h,
      OrBytes_high_lowR q l h -|- OrBytesR q (Z.lor (Z.shiftl h 16) l).
  Proof. Admitted.

  (** proving these lemmas tends to not be very difficult in most cases,
      assuming the appropriate axioms about memory layout and alignedness.
      Bare in mind that these sometimes have compiler or architecture specified
      behavior. For example, the struct above is relying on a particular
      endianness, switching to another architecture might get you the opposite
      values.
   *)

End with_Sigma.


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

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

Print Assumptions add.


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

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

Print Assumptions mul.


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

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

Print Assumptions add.


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

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

Print Assumptions add.


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

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

Print Assumptions mul.


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

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

Print Assumptions mul.


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

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

Print Assumptions sub.


From FA Require Import String DFA NFA NFA2DFA eNFA.
From mathcomp Require Import all_ssreflect.

Definition enfa_nfa (n: enfa): nfa.
Proof. unshelve econstructor.
       - exact (enfa_state n).
(*        - exact (enfa_start n). *)
       - exact (eps_closure_set n (@enfa_start n)).
       - intros p l.
         exact (enfa_multistep n [set p] (glue eps l)).
       - exact ([set q: n | [exists x, (x \in eps_closure n q) && (x \in enfa_finals n)]]).
Defined.

Lemma enfa_nfa_ms1A: forall (e: enfa) (r: (@enfa_state e))  (A: {set (@enfa_state e)}) (x: String),
  r \in nfa_multistep (enfa_nfa e) (eps_closure_set e A) x ->
  r \in enfa_multistep e A x.
Proof. intros e r A x.
       revert e r A.
       induction x; intros.
       - simpl in *.
         unfold eps_closure_set.
         apply/bigcupP.
         unfold eps_closure_set in H.
         move=>/bigcupP in H.
         destruct H as (p, Ha, Hb).
         exists p.
         easy.
         easy.
       - simpl in *.
         move=>/bigcupP in H.
         destruct H as (p, Ha, Hb).
         move=>/bigcupP in Hb.
         destruct Hb as (i, Hb, Hc).
         apply/bigcupP.
         exists p.
         apply IHx.
         easy.
         unfold eps_closure_set in Hc.
         move=>/bigcupP in Hc.
         destruct Hc as (j, Hc, Hd).
         rewrite inE in Hc.
         unfold eps_closure_set in Hb.
         move=>/bigcupP in Hb.
         destruct Hb as (k, Hb, He).
         rewrite inE in Hb.
         move=>/eqP in Hb.
         subst.
         unfold eps_closure_set.
         apply/bigcupP.
         exists j.
         rewrite inE.
         unfold eps_closure in He.
         rewrite inE in He.
         apply enfa_connect_r with (q := i).
         easy.
         easy.
         easy.
(*          split; easy.
         easy. *)
Qed.

Lemma enfa_nfa_ms2A: forall (e: enfa) (r: (@enfa_state e)) (A: {set (@enfa_state e)}) (x: String),
  r \in enfa_multistep e A x ->
  r \in nfa_multistep (enfa_nfa e) (eps_closure_set e A) x.
Proof. intros e r A x.
       revert e r A.
       induction x; intros.
       - easy.
       - simpl in *.
         move=>/bigcupP in H.
           destruct H as (p, Ha, Hb).
           specialize (IHx e p A Ha).
           simpl.
           apply/bigcupP.
           exists p.
           easy.
           apply/bigcupP.
           exists p.
           unfold eps_closure_set.
           apply/bigcupP.
           exists p.
           rewrite inE. easy.
           unfold eps_closure.
           rewrite inE.
           apply epsa.
(*            apply connect0. *)
           easy.
Qed.

Lemma enfa_nfa_ms_lAS: forall (e: enfa) (A: {set (@enfa_state e)}) (x: String),
  nfa_acceptance (enfa_nfa e) (eps_closure_set e A) x ->
  enfa_acceptance e A x.
Proof. intros.
       revert e A H.
       induction x; intros.
       - unfold enfa_acceptance, nfa_acceptance in *.
         simpl in *.
         move=>/existsP in H.
         destruct H as (q, H).
         move=>/andP in H.
         destruct H as (Ha, Hb).
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (r, Hb).
         apply/existsP.
         exists q.
         apply/andP.
         split.
         + easy.
         + rewrite inE.
           apply/existsP.
           exists r.
           easy.
       - unfold enfa_acceptance in H.
         move=>/existsP in H.
         destruct H as (i, Ha).
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         specialize (enfa_nfa_ms1A e i A (glue x s) Ha); intro HH.
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (m, Hb).
         unfold nfa_acceptance.
         apply/existsP.
         exists i.
         apply/andP.
         split.
         easy.
         simpl.
         rewrite inE.
         apply/existsP.
         exists m.
         easy.
Qed.

Lemma enfa_nfa_ms_rAS: forall (e: enfa) (A: {set (@enfa_state e)}) (x: String),
  enfa_acceptance e A x ->
  nfa_acceptance (enfa_nfa e) (eps_closure_set e A) x.
Proof. intros.
       revert e A H.
       induction x; intros.
       - unfold enfa_acceptance, nfa_acceptance in *.
         simpl in *.
         move=>/existsP in H.
         destruct H as (q, H).
         move=>/andP in H.
         destruct H as (Ha, Hb).
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (r, Hb).
         apply/existsP.
         exists q.
         apply/andP.
         split.
         + easy.
         + rewrite inE.
           apply/existsP.
           exists r.
           easy.
       - unfold enfa_acceptance in H.
         move=>/existsP in H.
         destruct H as (i, Ha).
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         specialize (enfa_nfa_ms2A e i A (glue x s) Ha); intro HH.
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (m, Hb).
         unfold nfa_acceptance.
         apply/existsP.
         exists i.
         apply/andP.
         split.
         easy.
         simpl.
         rewrite inE.
         apply/existsP.
         exists m.
         easy.
Qed.

Lemma enfa_nfa_lang_eqi: forall n, enfa_language n =i nfa_language (enfa_nfa n).
Proof. intros.
       unfold enfa_language, nfa_language.
       move => y. apply/idP/idP => /=.
       intro Ha.
       rewrite inE in Ha.
       apply enfa_nfa_ms_rAS in Ha.
       simpl in Ha.
       rewrite inE.
       easy.
       intro Ha.
       rewrite inE in Ha.
       apply enfa_nfa_ms_lAS in Ha.
       rewrite inE.
       easy.
Qed.

Lemma enfa_eps_cl: forall (e: enfa) (p q: e) (A: {set (@enfa_state e)}) (x: String),
    p \in nfa_multistep (enfa_nfa e) (eps_closure_set e A) x ->
    q \in eps_closure e p ->
    q \in nfa_multistep (enfa_nfa e) (eps_closure_set e A) x.
Proof. intros.
       revert e p q A H H0.
       induction x; intros.
       - simpl in *.
         unfold eps_closure_set in *.
         move=>/bigcupP in H.
         destruct H as (i, Ha, Hb).
         apply/bigcupP.
         exists i.
         easy.
         unfold eps_closure in *.
         rewrite inE in H0.
         rewrite inE in Hb.
         rewrite inE.
         apply (enfa_connect_l e i p q None Hb H0).
(*          apply(connect_trans Hb H0). *)
       - simpl in *.
         move=>/bigcupP in H.
         destruct H as (i, Ha, Hb).
         move=>/bigcupP in Hb.
         destruct Hb as (j, Hb, Hc).
         move=>/bigcupP in Hc.
         destruct Hc as (m, Hc, Hd).
         rewrite inE in Hc.

         apply/bigcupP.
         exists i.
         easy.
         apply/bigcupP.
         exists j.
         easy.
         apply/bigcupP.
         exists m.
         rewrite inE.
         easy.
         unfold eps_closure in H0, Hd.
         rewrite inE in H0.
         rewrite inE in Hd.
         unfold eps_closure.
         rewrite inE.
         apply (enfa_connect_l e m p q None Hd H0).
(*          apply (connect_trans Hd H0). *)
Qed.

Lemma enfa_nfa_ms_eq: forall (e: enfa) (A: {set (@enfa_state e)}) (x: String),
  enfa_multistep e A x =
  nfa_multistep (enfa_nfa e) (eps_closure_set e A) x.
Proof. intros e A x.
       revert e A.
       induction x; intros.
       - easy.
       - simpl in *.
         specialize (IHx e A).
         apply/setP.
         move => y. apply/idP/idP => /=.
         intro H.
         move=>/bigcupP in H.
         destruct H as (p, Ha, Hb).
         apply/bigcupP.
         exists p.
         rewrite <- IHx.
         easy.
         move=>/bigcupP in Hb.
         destruct Hb as (q, Hb, Hc).
         rewrite inE in Hb.
         apply/bigcupP.
         exists p.
         unfold eps_closure_set.
         apply/bigcupP.
         exists p.
         rewrite inE. easy.
         unfold eps_closure.
         rewrite inE.
         apply epsa.
(*          apply connect0. *)

         apply/bigcupP.
         exists q.
         rewrite inE.
         easy.
         easy.

         intro H.
         move=>/bigcupP in H.
         destruct H as (p, Ha, Hb).
         move=>/bigcupP in Hb.
         destruct Hb as (q, Hb, Hc).
         move=>/bigcupP in Hc.
         destruct Hc as (i, Hc, Hd).
         rewrite inE in Hc.

         apply/bigcupP.
         exists q.
         rewrite IHx.

         unfold eps_closure_set in Hb.
         move=>/bigcupP in Hb.
         destruct Hb as (j, Hb, He).
         apply enfa_eps_cl with (p := p).
         easy.
         rewrite inE in Hb.
         move=>/eqP in Hb.
         subst.
         easy.
         apply/bigcupP.
         exists i.
         rewrite inE.
         easy.
         easy.
Qed.

Lemma enfa_nfa_acc_eq: forall (e: enfa) (A: {set (@enfa_state e)}) (x: String),
  nfa_acceptance (enfa_nfa e) (eps_closure_set e A) x =
  enfa_acceptance e A x.
Proof. intros.
       unfold enfa_acceptance, nfa_acceptance.
       rewrite enfa_nfa_ms_eq.
       apply/existsP.
       case_eq (
       [exists y,
          (y \in nfa_multistep (enfa_nfa e) (eps_closure_set e A) x) &&
          (y \in [set q | [exists x0, (x0 \in eps_closure e q) && (x0 \in enfa_finals e)]])]
       ); intro HH.
       - rewrite HH.
         move=>/existsP in HH.
         destruct HH as (p, Ha).
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         rewrite inE in Hb.
         move=>/existsP in Hb.
         destruct Hb as (q, Hb).
         move=>/andP in Hb.
         destruct Hb as (Hb, Hc).
         exists q.
         apply/andP.
         split.
         - apply enfa_eps_cl with (p := p).
           easy.
           easy.
         - simpl.
           rewrite inE.
           apply/existsP.
           exists q.
           apply/andP.
           split.
           + unfold eps_closure.
             rewrite inE.
             apply epsa.
(*              apply connect0. *)
           + easy.
       - rewrite HH.
         unfold not.
         intro H.
         move=>/existsP in HH.
         unfold not in HH.
         apply HH.
         destruct H as (p, Ha).
         move=>/andP in Ha.
         destruct Ha as (Ha, Hb).
         exists p.
         apply/andP.
         split.
         - easy.
         - rewrite inE.
           apply/existsP.
           simpl in Hb.
           rewrite inE in Hb.
           move/existsP in Hb.
           destruct Hb as (i, Hb).
           exists i.
           easy.
Qed.

Lemma enfa_nfa_lang_eqiA: forall n, enfa_language n =i nfa_language (enfa_nfa n).
Proof. intros.
       unfold enfa_language, nfa_language.
       move => y. apply/idP/idP => /=.
       intro Ha.
       rewrite inE in Ha.
       rewrite inE.
       rewrite enfa_nfa_acc_eq.
       easy.
       intro Ha.
       rewrite inE in Ha.
       rewrite inE.
       rewrite <- enfa_nfa_acc_eq.
       easy.
Qed.


(** * 6.887 Formal Reasoning About Programs, Spring 2017 - Pset 9 *)

Require Import Frap.

(* Authors:
 * Joonwon Choi (joonwonc@csail.mit.edu)
 * Adam Chlipala (adamc@csail.mit.edu)
 *)

Set Implicit Arguments.

(** Data Abstraction via Contextual Equivalence *)

(* Here's a typical student reaction to the content on type systems from a
 * course like this one:
 *   "Yeah, it's good to prove that programs don't crash, but it's so much more
 *   exciting to prove that programs actually return correct answers, and we've
 *   seen plenty of techniques for that already (and will see more in the rest
 *   of the course).  Can we get this type-system stuff over with so we can move
 *   on to the _important_ stuff?"
 *
 * However, it turns out that type systems are very handy for formalizing a very
 * thorough kind of correctness condition for code libraries!  In particular,
 * let's return to _abstract data types_, which we first studied in Pset 2,
 * where we define a formal _interface_ for a data structure and prove that some
 * _implementation_ satisfies the interface.  Recall that Pset 2 asked you to
 * prove a selection of algebraic laws for some implementation.  But how do we
 * know that we picked the right set of laws?  What if we could show that the
 * laws were somehow _complete_ for the interface, prescribing _all possible
 * behaviors_ of the abstract data type?
 *
 * The concept of _contextual equivalence_ formalizes that idea in a general
 * way.  Say we have a simple _reference implementation_ of an abstract data
 * type, and we also have a more fancy, optimized implementation.  Consider all
 * possible _client code_ that imports a library for this data structure.  It
 * doesn't known which of the two it will be linked with; it must work for both.
 * The two libraries are _contextually equivalent_ if no client code can tell
 * them apart, so, say, the client code computes the same answer regardless.
 *
 * It is crucial to formalize the library interface with a type, so that we can
 * constraint which client programs are valid.  That's exactly what we do in
 * this pset, in addition to introducing a method for proving contextual
 * equivalence. *)

(** * Language syntax, semantics, and typing *)

(* Here's our base language, which only uses features familiar from the last
 * pset and class examples. *)

Inductive exp  :=
(* First, the basic STLC ingredients *)
| Var (x : var)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)
(* Constants and basic arithmetic *)
| Const (n : nat)
| Add (e1 e2 : exp)
| Sub (e1 e2 : exp)
(* And pairs; they're less general than tuples in the previous problem set. *)
| Pair (e1 e2 : exp)
| Fst (e : exp)
| Snd (e : exp).

Inductive value : exp -> Prop :=
| VAbs : forall x e1, value (Abs x e1)
| VConst : forall n, value (Const n)
| VPair : forall e1 e2, value e1 -> value e2 -> value (Pair e1 e2).

Hint Constructors value.
Hint Extern 1 (value _) => constructor.

(* Syntax of types *)
Inductive type :=
| Nat
| Fun (dom ran : type)
| Prod (t1 t2 : type)
(* We have a new type, called [AbsT], representing the abstract type. When
 * implementing a certain data structure, we don't want to expose how it is
 * implemented by giving actual types of the implementation.  Instead, we just
 * claim that the implementation satisfies an abstract type.  Clients use it
 * without knowing the actual implementation, while the implementer should check
 * the type without any abstraction. *)
| AbsT.

(* Fancy notations *)
Coercion Var : var >-> exp.
Notation "\ x , e" := (Abs x e) (at level 51).
Infix "@" := App (at level 49, left associativity).
Coercion Const : nat >-> exp.
Infix "^+^" := Add (at level 50).
Infix "^-^" := Sub (at level 50).
Notation "@( e1 , e2 )" := (Pair e1 e2) (at level 51).
Notation "'fst' e" := (Fst e) (at level 51).
Notation "'snd' e" := (Snd e) (at level 51).

Infix "-->" := Fun (at level 60, right associativity).
Notation "t1 ^*^ t2" := (Prod t1 t2) (at level 61).

(** A target ADT: simple counters *)
(* We want to prove that two simple counter implementations are
 * _contextually equivalent_, using a logical relation.  Below we can see two
 * implementations: [counter_impl1] is just using a single number to count.
 * Note that the counter exposes two distinct methods for incrementing its
 * value.  They should do the same work from the perspective of the external
 * world.  [counter_impl2] makes each increment method increment a different
 * private number, storing the two numbers within a pair. *)

Definition counter_type : type :=
  (AbsT ^*^ (* The internal counter value is abstracted; clients cannot use this
             * value.  In Java terms, think of this type part as a private
             * field. *)
  (AbsT --> Nat ^*^  (* Method to get the actual counter value *)
  (AbsT --> AbsT ^*^ (* Method to increase the counter value *)
   AbsT --> AbsT))). (* Second method to increase the counter value *)

(* Here's the simple reference implementation. *)
Definition counter_val1 := Const 0.
Definition counter_get1 := \"x", "x".
Definition counter_inc11 := \"x", "x" ^+^ 1.
Definition counter_inc21 := \"x", "x" ^+^ 1.
Definition counter_impl1 :=
  @(counter_val1, @(counter_get1, @(counter_inc11, counter_inc21))).

(* And here's the more convoluted two-counter version. *)
Definition counter_val2 := @(0, 0).
Definition counter_get2 := \"xy", (fst "xy") ^+^ (snd "xy").
Definition counter_inc12 := \"xy", @( (fst "xy") ^+^ 1, snd "xy" ).
Definition counter_inc22 := \"xy", @( fst "xy", (snd "xy") ^+^ 1 ).
Definition counter_impl2 :=
  @(counter_val2, @(counter_get2, @(counter_inc12, counter_inc22))).

(* Intuitively, client code can't distinguish these two versions, if it doesn't
 * know how the abstract type is implemented.  In this pset, we will work up to
 * proving that property for this example, in the process developing formal
 * machinery also applicable to many related examples.  (And all of this
 * generalizes to fancier languages with more expressive typing, though the
 * details are out of scope for the assignment.) *)

(* Some routine definitions again! They should should now be very familiar, so
 * it's safe for you to skim through quickly. But it is recommended to pay
 * attention to the typing rules, since now there is a new concept with
 * _abstract types_. *)

Fixpoint subst (e1 : exp) (x : var) (e2 : exp) : exp :=
  match e2 with
  | Var y => if y ==v x then e1 else Var y
  | Abs y e => Abs y (if y ==v x then e else subst e1 x e)
  | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
  | Const n => Const n
  | Add e1' e2' => Add (subst e1 x e1') (subst e1 x e2')
  | Sub e1' e2' => Sub (subst e1 x e1') (subst e1 x e2')
  | Pair e1' e2' => Pair (subst e1 x e1') (subst e1 x e2')
  | Fst e => Fst (subst e1 x e)
  | Snd e => Snd (subst e1 x e)
  end.

(* We use a big-step semantics for this problem set. *)
Inductive eval : exp -> exp -> Prop :=
| BigAbs : forall x e,
    eval (Abs x e) (Abs x e)
| BigApp : forall e1 x e1' e2 v2 v,
    eval e1 (Abs x e1') ->
    eval e2 v2 ->
    eval (subst v2 x e1') v ->
    eval (App e1 e2) v
| BigConst : forall n,
    eval (Const n) (Const n)
| BigAdd : forall e1 e2 n1 n2,
    eval e1 (Const n1) ->
    eval e2 (Const n2) ->
    eval (Add e1 e2) (Const (n1 + n2))
| BigSub : forall e1 e2 n1 n2,
    eval e1 (Const n1) ->
    eval e2 (Const n2) ->
    eval (Sub e1 e2) (Const (n1 - n2))
| BigPair : forall e1 e2 v1 v2,
    eval e1 v1 ->
    eval e2 v2 ->
    eval (Pair e1 e2) (Pair v1 v2)
| BigFst : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Fst e) v1
| BigSnd : forall e v1 v2,
    eval e (Pair v1 v2) ->
    eval (Snd e) v2.

Hint Constructors eval.

(* Here is an expression-typing relation with a single abstract type.  Clients
 * use [hasty] with the first argument as [None], where the actual type is not
 * exposed.  On the contrary, the implementation side uses [hasty] with the
 * first argument as [Some abst], where [abst] is the actual type used to
 * implement the data structure. *)
Inductive hasty : option type -> fmap var type -> exp -> type -> Prop :=
| HtVar : forall abs G x t,
    G $? x = Some t ->
    hasty abs G (Var x) t

(* Now there are two typing rules for [Abs]. The first one is as usual, but
 * requires argument type not equal to [AbsT]. It is for ensuring that [G]
 * always stores the actual type information, not the abstract one. *)
| HtAbs : forall abs G x e1 t1 t2,
    hasty abs (G $+ (x, t1)) e1 t2 ->
    t1 <> AbsT ->
    hasty abs G (Abs x e1) (Fun t1 t2)
(* The second typing rule for [Abs] is for the case when the argument has an
 * abstract type [AbsT]. In this case, we store the actual type by referring to
 * [Some abst]. *)
| HtAbsAbs : forall abst G x e1 t2,
    hasty (Some abst) (G $+ (x, abst)) e1 t2 ->
    hasty (Some abst) G (Abs x e1) (Fun AbsT t2)

(* Then the next few rules are standard, with [abs] threaded through. *)
| HtApp : forall abs G e1 e2 t1 t2,
    hasty abs G e1 (Fun t1 t2) ->
    hasty abs G e2 t1 ->
    hasty abs G (App e1 e2) t2
| HtConst : forall abs G n,
    hasty abs G (Const n) Nat
| HtAdd : forall abs G e1 e2,
    hasty abs G e1 Nat ->
    hasty abs G e2 Nat ->
    hasty abs G (Add e1 e2) Nat
| HtSub : forall abs G e1 e2,
    hasty abs G e1 Nat ->
    hasty abs G e2 Nat ->
    hasty abs G (Sub e1 e2) Nat
| HtPair : forall abs G e1 e2 t1 t2,
    hasty abs G e1 t1 ->
    hasty abs G e2 t2 ->
    hasty abs G (Pair e1 e2) (Prod t1 t2)
| HtFst : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Fst e) t1
| HtSnd : forall abs G e t1 t2,
    hasty abs G e (Prod t1 t2) ->
    hasty abs G (Snd e) t2

(* Finally, one more rule for the abstract type.  [AbsT] can be instantiated to
 * the actual type only if the actual type is provided, meaning this typing
 * rule is for the implementer. *)
| HtAbsT1 : forall abst G e,
    hasty (Some abst) G e abst ->
    hasty (Some abst) G e AbsT.

Hint Constructors hasty.

(** * Logical relation *)

(* How can we prove that two expressions are contextually equivalent?  That is,
 * how can we show that no well-typed client program could tell them apart?
 * Reasoning explicitly about every possible client program would be a lot of
 * work!  Instead, here's a fun idea from the literature, _logical relations_,
 * that gives a straightforward condition where we avoid reasoning about client
 * programs explicitly.  The key distinguishing property of logical relations is
 * that they are defined by recursion on type structure, helping explain why use
 * of a type system is so critical to the approach. *)

Section LogicalRel.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  (* The relation is parameterized over two different implementation types for
   * the abstract type, along with a primitive relation for saying when two
   * "private field" values for the two sides should be considered to represent
   * the same abstract value. *)

  (* This relation says when two expressions are equivalent at some type.  It is
   * parameterized on the relation to use to compare two *values* at a type. *)
  Definition exp_rel' (v_rel: type -> exp -> exp -> Prop)
             (t: type) (e1 e2: exp): Prop :=
    (* First, the two expressions really have the claimed type, in the
     * corresponding implementations of the abstract type. *)
    hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\

    (* Then, both evaluate to values that are themselves related. *)
    exists v1 v2, eval e1 v1 /\ eval e2 v2 /\
                  v_rel t v1 v2.

  (* Now we go methodically through the types, explaining what equivalence means
   * for each one. *)
  Fixpoint value_rel (t: type) (e1 e2: exp) : Prop :=
    match t with
    | Nat =>
      (* An easy case: numbers are equivalent when equal. *)
      match e1, e2 with
      | Const n1, Const n2 => n1 = n2
      | _, _ => False
      end

    | Prod t1 t2 =>
      (* Another pretty easy case: equivalent pairs have equivalent
       * components. *)
      match e1, e2 with
      | Pair v11 v12, Pair v21 v22 =>
        value_rel t1 v11 v21 /\ value_rel t2 v12 v22
      | _, _ => False
      end

    | AbsT =>
      (* The abstract type picks up whatever [value_rel_abs] relation we
       * chose, additionally requiring that the two expressions are
       * well-typed. *)
      hasty (Some abst1) $0 e1 AbsT /\
      hasty (Some abst2) $0 e2 AbsT /\
      value_rel_abs e1 e2

    | Fun t' t'' =>
      (* Now the signature case of logical relations: "the two functions map
       * equivalent inputs to equivalent outputs." *)
      match e1, e2 with
      | Abs x1 e1', Abs x2 e2' =>
        hasty (Some abst1) $0 e1 t /\ hasty (Some abst2) $0 e2 t /\
        forall v1 v2, (* <-- These are the two equivalent inputs! *)
          hasty (Some abst1) $0 v1 t' -> hasty (Some abst2) $0 v2 t' ->
          value_rel t' v1 v2 (* ...and this hypothesis says so. *) ->
          exp_rel' value_rel t'' (subst v1 x1 e1') (subst v2 x2 e2')
                   (* These substitution results are the equivalent outputs. *)
      | _, _ => False
      end
    end.

  Definition exp_rel := exp_rel' value_rel.

  (* We also need to argue for equivalence of terms with free variables.
   * This relation formalizes it in terms of typing contexts [G].
   * Basically it says: "two expressions with free variables are equivalent iff
   * we get equivalent expressions by substituting equivalent values for all the
   * free variables." *)
  Definition g_rel (G: fmap var type) (g1 g2: fmap var exp) : Prop :=
    forall x,
      (* Any variable in [G] is mapped to equivalent values. *)
      (forall t,
          G $? x = Some t ->
          exists v1 v2, g1 $? x = Some v1 /\ g2 $? x = Some v2 /\ value_rel t v1 v2) /\

      (* Any variable _not_ in [G] is mapped to nothing. *)
      (G $? x = None -> g1 $? x = None /\ g2 $? x = None).

  (* Here we define substitution for several variables at once. *)
  Fixpoint substs (g : fmap var exp) (e : exp) : exp :=
    match e with
    | Var y =>
      match g $? y with
      | Some v => v
      | _ => Var y
      end
    | Abs y e' => Abs y (substs (g $- y) e')
    | App e' e'' => App (substs g e') (substs g e'')
    | Const n => Const n
    | Add e' e'' => Add (substs g e') (substs g e'')
    | Sub e' e'' => Sub (substs g e') (substs g e'')
    | Pair e' e'' => Pair (substs g e') (substs g e'')
    | Fst e' => Fst (substs g e')
    | Snd e' => Snd (substs g e')
    end.

  (* Finally, the most general logical relation, for expressions that may not be
   * closed *)
  Definition logical_rel (G: fmap var type) (e1 e2: exp) (t: type) :=
    hasty (Some abst1) G e1 t /\ hasty (Some abst2) G e2 t /\
    forall g1 g2,
      g_rel G g1 g2 ->
      exp_rel t (substs g1 e1) (substs g2 e2).
End LogicalRel.

(** * Returning to the example of counters *)

(* Let's demonstrate this machinery by proving that our two counter
 * implementations inhabit the appropriate logical relation.  We'll use this
 * relation to capture when the "private fields" on the two sides are
 * equivalent. *)
Inductive value_rel_counters : exp -> exp -> Prop :=
| Vrc : forall c inc dec,
    c = inc + dec ->
    value_rel_counters c (@(inc, dec)).

Hint Constructors value_rel_counters.

Hint Extern 1 (_ $? _ = Some _) => simplify; reflexivity.

(* And here's how we prove the relation. *)
Theorem counter_impls_related:
   exp_rel Nat (Nat ^*^ Nat) value_rel_counters counter_type counter_impl1 counter_impl2.
Proof.
  (* We unfold some symbols and reveal a type-specialized notion of
   * equivalence! *)
  unfold exp_rel, exp_rel', counter_type,
  counter_impl1, counter_val1, counter_get1, counter_inc11, counter_inc21,
  counter_impl2, counter_val2, counter_get2, counter_inc12, counter_inc22; simplify.

  (* At the top level, we have some typing requirements, which are easy to
   * discharge with [eauto]. *)
  propositional; eauto 30.

  (* Now we need to show that the two tuples of fields and methods are related,
   * beginning with demonstrating values that they evaluate to.  But that's
   * easy, since they're already values. *)
  do 2 eexists; propositional; eauto.

  (* Now we're staring at the type-specific condition for relatedness.  It looks
   * unwieldy, but actually [simplify] can shrink it, now that the we know the
   * value forms of the methods. *)
  simplify.
  (* We see a conjunction of conditions for the different tuple parts (fields
   * and methods).  Let's attack the conjuncts separately, using [eauto] to fill
   * in typing details. *)
  propositional; eauto 10.

  (* Nifty: the only remaining goals are for the three methods, one for each. *)

  (* First is the "get" method.  We have that the two sides have equivalent
   * private-field values, and we must show that the two "get" methods will
   * therefore return equivalent results. *)
  invert H4.
  unfold exp_rel'; simplify.
  propositional; eauto 10.
  do 2 eexists; propositional; eauto 10.
  simplify.
  reflexivity.

  (* Next is the "inc1" method. *)
  invert H4.
  unfold exp_rel'; simplify.
  propositional; eauto 10.
  do 2 eexists; propositional; eauto 10.
  constructor.
  linear_arithmetic.

  (* Finally, the "inc2" method. *)
  invert H4.
  unfold exp_rel'; simplify.
  propositional; eauto 10.
  do 2 eexists; propositional; eauto 10.
  constructor.
  linear_arithmetic.
Qed.

(* Believe it or not, that condition implies contextual equivalence of the two
 * implementations... but we'll need to spend the rest of the pset proving it.
 * ;-)  We should at least prove a more general theorem that applies to many
 * other abstract data types, too. *)

Module Type S.
  (* We ask you to prove the "fundamental property" of the logical relation. It
   * seems very weak (every value is related to itself?  sounds obvious,
   * right?), but it's actually strong enough to prove the contextual equality.
   * According to the definition of [logical_rel], [G] can be regarded as a
   * "placeholder" to substitute two values in the logical relation, where the
   * values may differ! *)
  Axiom logical_rel_fundamental:
    forall abst1 abst2 (value_rel_abs: exp -> exp -> Prop)
           (Hvr: forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2)
           (Habst1: abst1 <> AbsT) (Habst2: abst2 <> AbsT)
           e G t,
      hasty None G e t ->
      logical_rel abst1 abst2 value_rel_abs G e e t.

  (* The following corollary should be quite easy to prove, using
   * [logical_rel_fundamental]. *)
  Axiom counter_impls_equiv:
    forall x e,
      hasty None ($0 $+ (x, counter_type)) e Nat ->
      exists n : nat,
        eval (subst counter_impl1 x e) n /\ eval (subst counter_impl2 x e) n.
End S.

(** We provide some lemmas which may help you prove the theorems. *)

Lemma value_eval : forall v, value v -> eval v v.
Proof.
  induct 1; eauto.
Qed.

Hint Resolve value_eval.

Lemma eval_value : forall e v, eval e v -> value v.
Proof.
  induct 1; eauto.
  - invert IHeval; eauto.
  - invert IHeval; eauto.
Qed.

Hint Resolve eval_value.

Hint Extern 1 (_ <> _) => equality.

(* [adds] is a binary operation for [fmap]s, doing a merge between two maps
 * where the second map takes a priority for the same key. It should be useful
 * for merging two type environments.
 *)
Section Adds.

  Definition adds {A B} (m1 m2: fmap A B) :=
    merge (fun v1 v2 => match v2 with
                        | Some _ => v2
                        | _ => v1
                        end) m1 m2.

  Lemma adds_empty1:
    forall {B} (m: fmap var B), adds $0 m = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty1; auto.
    intros; cases x; auto.
  Qed.

  Lemma adds_empty2:
    forall {B} (m: fmap var B), adds m $0 = m.
  Proof.
    intros; unfold adds.
    rewrite merge_empty2; auto.
  Qed.

  Lemma adds_add:
    forall {B} (m1 m2: fmap var B) x v,
      adds m1 m2 $+ (x, v) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify; auto.
  Qed.

  Lemma adds_add2:
    forall {B} (m: fmap var B) x v,
      adds ($0 $+ (x, v)) (m $- x) = m $+ (x, v).
  Proof.
    intros; apply fmap_ext; intros.
    cases (x ==v k); subst; simplify.
    - unfold adds; rewrite lookup_merge; simplify; auto.
    - unfold adds; rewrite lookup_merge; simplify.
      cases (m $? k); equality.
  Qed.

  Lemma adds_remove:
    forall {B} (m1 m2: fmap var B) x v,
      adds (m1 $+ (x, v)) (m2 $- x) = adds m1 (m2 $+ (x, v)).
  Proof.
    intros; apply fmap_ext; intros.
    unfold adds; rewrite 2! lookup_merge.
    cases (x ==v k); subst; simplify; auto.
  Qed.

End Adds.

(* Some facts of [hasty] *)
Section HasTyFacts.

  Lemma hasty_Nat_value:
    forall abst G e,
      hasty abst G e Nat ->
      value e ->
      exists n, e = Const n.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  (* Note that a different type [t1'] is used when the type information is
   * stored.  It's due to the type instantiation that [hasty] does.*)
  Lemma hasty_Fun_value:
    forall abst G e t1 t2,
      hasty abst G e (Fun t1 t2) ->
      value e ->
      exists x1 t1' e2,
        e = Abs x1 e2 /\ hasty abst (G $+ (x1, t1')) e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_Prod_value:
    forall abst G e t1 t2,
      hasty abst G e (Prod t1 t2) ->
      value e ->
      exists e1 e2,
        e = @(e1, e2) /\ hasty abst G e1 t1 /\ hasty abst G e2 t2.
  Proof.
    induct 1; simplify; eauto;
      try match goal with
          | [H: value _ |- _] => invert H
          end.
  Qed.

  Lemma hasty_weakening:
    forall abst G e t,
      hasty abst G e t ->
      forall G',
        (forall x t, G $? x = Some t -> G' $? x = Some t) ->
        hasty abst G' e t.
  Proof.
    induct 1; simplify; eauto.
    - constructor; auto.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
    - apply HtAbsAbs.
      apply IHhasty; intros.
      cases (x ==v x0); simplify; propositional; auto.
  Qed.

  Corollary hasty_weakening_empty:
    forall abst e t,
      hasty abst $0 e t ->
      forall G,
        hasty abst G e t.
  Proof.
    intros; apply hasty_weakening with (G:= $0); auto.
  Qed.

  Lemma hasty_weakening_abst:
    forall G e t, hasty None G e t ->
                  forall abst,
                    hasty (Some abst) G e t.
  Proof.
    induct 1; simplify; eauto.
  Qed.

  (* Closedness of expressions.
   * [e] is closed iff it does not have any free variables.
   * We define a more general version that uses argument [vs] to express which
   * free variables are allowed. *)
  Fixpoint closed (e: exp) (vs: set var) :=
    match e with
    | Var x => x \in vs
    | Abs x e' => closed e' (vs \cup {x})
    | App e' e'' => closed e' vs /\ closed e'' vs
    | Const _ => True
    | Add e' e'' => closed e' vs /\ closed e'' vs
    | Sub e' e'' => closed e' vs /\ closed e'' vs
    | Pair e' e'' => closed e' vs /\ closed e'' vs
    | Fst e' => closed e' vs
    | Snd e' => closed e' vs
    end.

  (* When [e] is type-checked, then it's closed. *)
  Lemma hasty_closed:
    forall abst G e t,
      hasty abst G e t ->
      closed e (dom G).
  Proof.
    induct 1; simplify; eauto.
    eapply lookup_Some_dom; eauto.
  Qed.

  (* When [e] is closed, then it's not affected by substitutions. *)
  Lemma closed_subst:
    forall e (G: fmap var type),
      closed e (dom G) ->
      forall v x,
        G $? x = None ->
        subst v x e = e.
  Proof.
    induct e; simplify; try (propositional; f_equal; eauto; fail).
    - cases (x ==v x0); subst; propositional.
      apply lookup_None_dom in H0; propositional.
    - cases (x ==v x0); subst; propositional.
      f_equal.
      apply IHe with (G:= G $+ (x, Nat)); simplify; auto.
  Qed.

  (* Here's a special case of the above, for truly closed expressions. *)
  Lemma value_hasty_closed:
    forall e abst t,
      hasty abst $0 e t ->
      forall x v,
        subst v x e = e.
  Proof.
    intros.
    apply closed_subst with (G := $0).
    - eapply hasty_closed. eauto.
    - simplify; equality.
  Qed.

End HasTyFacts.

Hint Immediate hasty_weakening hasty_weakening_abst.

(* Some facts of [substs] *)
Section Substs.

  Lemma substs_empty:
    forall e, substs $0 e = e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    replace (empty string exp $- x) with (empty string exp); auto.
    clear IHe; apply fmap_ext; simplify.
    cases (x ==v k); subst; simplify; equality.
  Qed.

  Lemma substs_single:
    forall x v e,
      substs ($0 $+ (x, v)) e = subst v x e.
  Proof.
    induct e; simplify; eauto; try (f_equal; auto).
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); equality.
      + cases (x0 ==v x); equality.
    - cases (x ==v x0); subst; simplify.
      + cases (x0 ==v x0); try equality.
        rewrite <-substs_empty.
        f_equal.
        apply fmap_ext; simplify.
        cases (x0 ==v k); subst; simplify; equality.
      + cases (x0 ==v x); subst; simplify; try equality.
        replace ($0 $+ (x, v) $- x0) with ($0 $+ (x, v)); auto.
        apply fmap_ext; simplify.
        cases (x ==v k); subst; simplify; try equality.
        cases (x0 ==v k); subst; simplify; try equality.
  Qed.

End Substs.

(* Some facts of logical relations *)
Section LogicalRelFacts.
  Variables (abst1 abst2 : type)
            (value_rel_abs: exp -> exp -> Prop).
  Hypotheses (Hvr: forall v1 v2, value_rel_abs v1 v2 -> value v1 /\ value v2).

  Lemma value_rel_value:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      value v1 /\ value v2.
  Proof.
    induct t.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - simplify.
      cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_hasty:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      hasty (Some abst1) $0 v1 t /\ hasty (Some abst2) $0 v2 t.
  Proof.
    induct t; simplify; auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      auto.
    - cases v1; try invert H.
      cases v2; try invert H.
      propositional; subst.
    - cases v1; try invert H.
      cases v2; try invert H.
      specialize (IHt1 _ _ H0).
      specialize (IHt2 _ _ H1).
      first_order; constructor; auto.
    - first_order.
  Qed.

  Lemma value_rel_implies_exp_rel:
    forall t v1 v2,
      value_rel abst1 abst2 value_rel_abs t v1 v2 ->
      exp_rel abst1 abst2 value_rel_abs t v1 v2.
  Proof.
    unfold exp_rel, exp_rel'; intros; repeat split.
    - apply value_rel_hasty in H; propositional.
    - apply value_rel_hasty in H; propositional.
    - exists v1, v2; repeat split; auto.
      + apply value_rel_value in H.
        apply value_eval; propositional.
      + apply value_rel_value in H.
        apply value_eval; propositional.
  Qed.

End LogicalRelFacts.


(* -*- mode: coq; mode: visual-line -*- *)
Require Import Basics Types.
Require Import HSet.
Require Import Spaces.Pos Spaces.Int.
Require Import Colimits.Coeq.
Require Import Truncations.Core Truncations.Connectedness.
Require Import Cubical.DPath.

(** * Theorems about the [Circle]. *)

Local Open Scope path_scope.

Generalizable Variables X A B f g n.

(* ** Definition of the [Circle]. *)

(** We define the circle as the coequalizer of two copies of the identity map of [Unit].  This is easily equivalent to the naive definition

<<<
Private Inductive Circle : Type0 :=
| base : Circle
| loop : base = base.
>>>

but it allows us to apply the flattening lemma directly rather than having to pass across that equivalence.  *)

(** The circle is defined to be the coequalizer of two copies of the identity map on [Unit]. *)
Definition Circle := @Coeq Unit Unit idmap idmap.

(** It has a basepoint. *)
Definition base : Circle := coeq tt.

(** And a non-trivial path. *)
Definition loop : base = base := cglue tt.

(** Here is a notation for the circle that can be imported. *)
Module CircleNotation.
  Notation S1 := Circle (only parsing).
End CircleNotation.

(** Circle induction *)
Definition Circle_ind (P : Circle -> Type)
  (b : P base) (l : loop # b = b)
  : forall (x : Circle), P x.
Proof.
  refine (Coeq_ind P (fun u => transport P (ap coeq (path_unit tt u)) b) _).
  intros []; exact l.
Defined.

(** Computation rule for circle induction. *)
Definition Circle_ind_beta_loop (P : Circle -> Type)
  (b : P base) (l : loop # b = b)
  : apD (Circle_ind P b l) loop = l
  := Coeq_ind_beta_cglue P _ _ tt.

(** We mark [Circle], [base] and [loop] to never be simplified by [simpl] or [cbn] in order to hide how we defined it from the user. *)
Arguments Circle : simpl never.
Arguments base : simpl never.
Arguments loop : simpl never.
Arguments Circle_ind_beta_loop : simpl never.

(** The recursion princple or non-dependent eliminator. *)
Definition Circle_rec (P : Type) (b : P) (l : b = b)
  : Circle -> P
  := Circle_ind (fun _ => P) b (transport_const _ _ @ l).

(** Computation rule for non-dependent eliminator. *)
Definition Circle_rec_beta_loop (P : Type) (b : P) (l : b = b)
  : ap (Circle_rec P b l) loop = l.
Proof.
  unfold Circle_rec.
  refine (cancelL (transport_const loop b) _ _ _).
  refine ((apD_const (Circle_ind (fun _ => P) b _) loop)^ @ _).
  refine (Circle_ind_beta_loop (fun _ => P) _ _).
Defined.

(** The [Circle] is pointed by [base]. *)
Global Instance ispointed_Circle : IsPointed Circle := base.

(** ** In this section we prove that the loop space of the [Circle] is the Integers [Int]. This is the encode-decode style proof a la Licata-Shulman. *)

Section EncodeDecode.
  (** We assume univalence throughout this section. *)
  Context `{Univalence}.

  (** First we define the type of codes, this is a type family over the circle. This can be thought of as the covering space by the homotopical real numbers. It is defined by mapping loop to the path given by univalence applied to the automorphism of the integers. We will show that the section of this family at [base] is equivalent to the loop space of the circle. Giving us an equivalence [base = base <~> Int]. *)
  Definition Circle_code : Circle -> Type
    := Circle_rec Type Int (path_universe int_succ).

  (** Transporting along [loop] gives us the successor automorphism on [Int]. *)
  Definition transport_Circle_code_loop (z : Int)
    : transport Circle_code loop z = int_succ z.
  Proof.
    refine (transport_compose idmap Circle_code loop z @ _).
    unfold Circle_code; rewrite Circle_rec_beta_loop.
    apply transport_path_universe.
  Defined.

  (** Transporting along [loop^] gives us the predecessor on [Int]. *)
  Definition transport_Circle_code_loopV (z : Int)
    : transport Circle_code loop^ z = int_pred z.
  Proof.
    refine (transport_compose idmap Circle_code loop^ z @ _).
    rewrite ap_V.
    unfold Circle_code; rewrite Circle_rec_beta_loop.
    rewrite <- (path_universe_V int_succ).
    apply transport_path_universe.
  Defined.

  (** To turn a path in [Circle] based at [base] into a code we transport along it. We call this encoding. *)
  Definition Circle_encode (x:Circle) : (base = x) -> Circle_code x
    := fun p => p # zero.

  (** TODO: explain this proof in more detail. *)
  (** Turning a code into a path based at [base]. We call this decoding. *)
  Definition Circle_decode (x : Circle) : Circle_code x -> (base = x).
  Proof.
    revert x; refine (Circle_ind (fun x => Circle_code x -> base = x) (loopexp loop) _).
    apply path_forall; intros z; simpl in z.
    refine (transport_arrow _ _ _ @ _).
    refine (transport_paths_r loop _ @ _).
    rewrite transport_Circle_code_loopV.
    destruct z as [n| |n].
    2: apply concat_Vp.
    { rewrite <- int_neg_pos_succ.
      unfold loopexp, loopexp_pos.
      rewrite pos_peano_ind_beta_pos_succ.
      apply concat_pV_p. }
    induction n as [|n nH] using pos_peano_ind.
    1: apply concat_1p.
    rewrite <- pos_add_1_r.
    change (pos (n + 1)%pos)
      with (int_succ (pos n)).
    rewrite int_pred_succ.
    cbn; rewrite pos_add_1_r.
    unfold loopexp_pos.
    rewrite pos_peano_ind_beta_pos_succ.
    reflexivity.
  Defined.

  (** The non-trivial part of the proof that decode and encode are equivalences is showing that decoding followed by encoding is the identity on the fibers over [base]. *)
  Definition Circle_encode_loopexp (z:Int)
    : Circle_encode base (loopexp loop z) = z.
  Proof.
    destruct z as [n | | n]; unfold Circle_encode.
    - induction n using pos_peano_ind; simpl in *.
      + refine (moveR_transport_V _ loop _ _ _).
        by symmetry; apply transport_Circle_code_loop.
      + unfold loopexp_pos.
        rewrite pos_peano_ind_beta_pos_succ.
        rewrite transport_pp.
        refine (moveR_transport_V _ loop _ _ _).
        refine (_ @ (transport_Circle_code_loop _)^).
        refine (IHn @ _^).
        rewrite int_neg_pos_succ.
        by rewrite int_succ_pred.
    - reflexivity.
    - induction n using pos_peano_ind; simpl in *.
      + by apply transport_Circle_code_loop.
      + unfold loopexp_pos.
        rewrite pos_peano_ind_beta_pos_succ.
        rewrite transport_pp.
        refine (moveR_transport_p _ loop _ _ _).
        refine (_ @ (transport_Circle_code_loopV _)^).
        refine (IHn @ _^).
        rewrite <- pos_add_1_r.
        change (int_pred (int_succ (pos n)) = pos n).
        apply int_pred_succ.
  Defined.

  (** Now we put it together. *)
  Definition Circle_encode_isequiv (x:Circle) : IsEquiv (Circle_encode x).
  Proof.
   refine (isequiv_adjointify (Circle_encode x) (Circle_decode x) _ _).
    (* Here we induct on [x:Circle].  We just did the case when [x] is [base]. *)
    - refine (Circle_ind (fun x => (Circle_encode x) o (Circle_decode x) == idmap)
        Circle_encode_loopexp _ _).
      (* What remains is easy since [Int] is known to be a set. *)
      by apply path_forall; intros z; apply hset_path2.
    (* The other side is trivial by path induction. *)
    - intros []; reflexivity.
  Defined.

  (** Finally giving us an equivalence between the loop space of the [Circle] and [Int]. *)
  Definition equiv_loopCircle_int : (base = base) <~> Int
    := Build_Equiv _ _ (Circle_encode base) (Circle_encode_isequiv base).

End EncodeDecode.

(** ** Connectedness and truncatedness of the [Circle] *)

(** The circle is 0-connected. *)
Global Instance isconnected_Circle `{Univalence} : IsConnected 0 Circle.
Proof.
  apply is0connected_merely_allpath.
  1: exact (tr base).
  srefine (Circle_ind _ _ _).
  - simple refine (Circle_ind _ _ _).
    + exact (tr 1).
    + apply path_ishprop.
  - apply path_ishprop.
Defined.

(** It follows that the circle is a 1-type. *)
Global Instance istrunc_Circle `{Univalence} : IsTrunc 1 Circle.
Proof.
  intros x y.
  assert (p := merely_path_is0connected Circle base x).
  assert (q := merely_path_is0connected Circle base y).
  strip_truncations.
  destruct p, q.
  refine (istrunc_equiv_istrunc (n := 0) Int equiv_loopCircle_int^-1).
Defined.

(** ** Iteration of equivalences *)

(** If [P : Circle -> Type] is defined by a type [X] and an autoequivalence [f], then the image of [n : Int] regarded as in [base = base] is [iter_int f n]. *)
Definition Circle_action_is_iter `{Univalence} X (f : X <~> X) (n : Int) (x : X)
: transport (Circle_rec Type X (path_universe f)) (equiv_loopCircle_int^-1 n) x
  = int_iter f n x.
Proof.
  refine (_ @ loopexp_path_universe _ _ _).
  refine (transport_compose idmap _ _ _ @ _).
  refine (ap (fun p => transport idmap p x) _).
  unfold equiv_loopCircle_int; cbn.
  unfold Circle_decode; simpl.
  rewrite ap_loopexp.
  refine (ap (fun p => loopexp p n) _).
  apply Circle_rec_beta_loop.
Defined.

(** An alternative induction principle for Circle that produces a DPath. *)
Definition Circle_ind_dp (P : Circle -> Type) (b : P base)
  (bl : DPath P loop b b) (x : Circle) : P x
  := Circle_ind P b (dp_path_transport^-1 bl) x.

Definition Circle_ind_dp_beta_loop (P : Circle -> Type) (b : P base)
  (bl : DPath P loop b b) : dp_apD (Circle_ind_dp P b bl) loop = bl.
Proof.
  apply dp_apD_path_transport.
  exact (Circle_ind_beta_loop _ _ _).
Defined.

(** The universal property of the circle (Lemma 6.2.9 in the Book).  We could deduce this from [isequiv_Coeq_rec], but it's nice to see a direct proof too. *)
Definition Circle_rec_uncurried (P : Type)
  : {b : P & b = b} -> (Circle -> P)
  := fun x => Circle_rec P (pr1 x) (pr2 x).

Global Instance isequiv_Circle_rec_uncurried `{Funext} (P : Type) : IsEquiv (Circle_rec_uncurried P).
Proof.
  srapply isequiv_adjointify.
  - exact (fun g => (g base ; ap g loop)).
  - intros g.
    apply path_arrow.
    srapply Circle_ind.
    + reflexivity.
    + unfold Circle_rec_uncurried; cbn.
      rewrite transport_paths_FlFr.
      rewrite Circle_rec_beta_loop.
      rewrite concat_p1; apply concat_Vp.
  - intros [b p]; apply ap.
    apply Circle_rec_beta_loop.
Defined.

Definition equiv_Circle_rec `{Funext} (P : Type)
  : {b : P & b = b} <~> (Circle -> P)
  := Build_Equiv _ _ _ (isequiv_Circle_rec_uncurried P).