(** * Stlc: The Simply Typed Lambda-Calculus *)

(* $Date: 2012-04-11 22:03:26 -0400 (Wed, 11 Apr 2012) $ *)

Require Export Types.

(* ###################################################################### *)
(** * The Simply Typed Lambda-Calculus *)

(** The simply typed lambda-calculus (STLC) is a tiny core calculus
    embodying the key concept of _functional abstraction_, which shows
    up in pretty much every real-world programming language in some
    form (functions, procedures, methods, etc.).

    We will follow exactly the same pattern as in the previous
    chapter when formalizing this calculus (syntax, small-step
    semantics, typing rules) and its main properties (progress and
    preservation).  The new technical challenges (which will take some
    work to deal with) all arise from the mechanisms of _variable
    binding_ and _substitution_. *)

(* ###################################################################### *)
(** ** Overview *)

(** The STLC is built on some collection of _base types_ -- booleans,
    numbers, strings, etc.  The exact choice of base types doesn't
    matter -- the construction of the language and its theoretical
    properties work out pretty much the same -- so for the sake of
    brevity let's take just [Bool] for the moment.  At the end of the
    chapter we'll see how to add more base types, and in later
    chapters we'll enrich the pure STLC with other useful constructs
    like pairs, records, subtyping, and mutable state.

    Starting from the booleans, we add three things:
        - variables
        - function abstractions
        - application

    This gives us the following collection of abstract syntax
    constructors (written out here in informal BNF notation -- we'll
    formalize it below).

*)

(** Informal concrete syntax:
<<
       t ::= x                       variable
           | \x:T.t1                 abstraction
           | t1 t2                   application
           | true                    constant true
           | false                   constant false
           | if t1 then t2 else t3   conditional
>>
    The [\] symbol in a function abstraction [\x:T.t1] is often
    written as a greek "lambda" (hence the name of the calculus).  The
    variable [x] is called the _parameter_ to the function; the term
    [t1] is its _body_.  The annotation [:T] specifies the type of
    arguments that the function can be applied to.

    Some examples:

      - [\x:Bool. x]

        The identity function for booleans.

      - [(\x:Bool. x) true]

        The identity function for booleans, applied to the boolean [true].

      - [\x:Bool. if x then false else true]

        The boolean "not" function.

      - [\x:Bool. true]

        The constant function that takes every (boolean) argument to
        [true].

      - [\x:Bool. \y:Bool. x]

        A two-argument function that takes two booleans and returns
        the first one.  (Note that, as in Coq, a two-argument function
        is really a one-argument function whose body is also a
        one-argument function.)

      - [(\x:Bool. \y:Bool. x) false true]

        A two-argument function that takes two booleans and returns
        the first one, applied to the booleans [false] and [true].
        Note that, as in Coq, application associates to the left --
        i.e., this expression is parsed as [((\x:Bool. \y:Bool. x)
        false) true].

      - [\f:Bool->Bool. f (f true)]

        A higher-order function that takes a _function_ [f] (from
        booleans to booleans) as an argument, applies [f] to [true],
        and applies [f] again to the result.

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)]

        The same higher-order function, applied to the constantly
        [false] function. *)

(** As the last several examples show, the STLC is a language of
    _higher-order_ functions: we can write down functions that take
    other functions as arguments and/or return other functions as
    results.

    Another point to note is that the STLC doesn't provide any
    primitive syntax for defining _named_ functions -- all functions
    are "anonymous."  We'll see in chapter [MoreStlc] that it is easy
    to add named functions to what we've got -- indeed, the
    fundamental naming and binding mechanisms are exactly the same.

    The _types_ of the STLC include [Bool], which classifies the
    boolean constants [true] and [false] as well as more complex
    computations that yield booleans, plus _arrow types_ that classify
    functions. *)
(**
<<
      T ::= Bool
          | T1 -> T2
>>
    For example:

      - [\x:Bool. false] has type [Bool->Bool]

      - [\x:Bool. x] has type [Bool->Bool]

      - [(\x:Bool. x) true] has type [Bool]

      - [\x:Bool. \y:Bool. x] has type [Bool->Bool->Bool] (i.e. [Bool -> (Bool->Bool)])

      - [(\x:Bool. \y:Bool. x) false] has type [Bool->Bool]

      - [(\x:Bool. \y:Bool. x) false true] has type [Bool]

      - [\f:Bool->Bool. f (f true)] has type [(Bool->Bool) -> Bool]

      - [(\f:Bool->Bool. f (f true)) (\x:Bool. false)] has type [Bool]
*)

(* ###################################################################### *)
(** ** Syntax *)

Module STLC.

(* ################################### *)
(** *** Types *)

Inductive ty : Type :=
  | TBool  : ty
  | TArrow : ty -> ty -> ty.

(* ################################### *)
(** *** Terms *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | ttrue : tm
  | tfalse : tm
  | tif : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "ttrue"
  | Case_aux c "tfalse" | Case_aux c "tif" ].

(** Note that an abstraction [\x:T.t] (formally, [tabs x T t]) is
    always annotated with the type [T] of its parameter, in contrast
    to Coq (and other functional languages like ML, Haskell, etc.),
    which use _type inference_ to fill in missing annotations.  We're
    not considering type inference here, to keep things simple. *)

(** Some examples... *)

Definition x := (Id 0).
Definition y := (Id 1).
Definition z := (Id 2).
Hint Unfold x.
Hint Unfold y.
Hint Unfold z.

(** [idB = \x:Bool. x] *)

Notation idB :=
  (tabs x TBool (tvar x)).

(** [idBB = \x:Bool->Bool. x] *)

Notation idBB :=
  (tabs x (TArrow TBool TBool) (tvar x)).

(** [idBBBB = \x:(Bool->Bool)->(Bool->Bool). x] *)

Notation idBBBB :=
  (tabs x (TArrow (TArrow TBool TBool)
                      (TArrow TBool TBool))
    (tvar x)).

(** [k = \x:Bool. \y:Bool. x] *)

Notation k := (tabs x TBool (tabs y TBool (tvar x))).

(** (We write these as [Notation]s rather than [Definition]s to make
    things easier for [auto].) *)

(* ###################################################################### *)
(** ** Operational Semantics *)

(** To define the small-step semantics of STLC terms, we begin -- as
    always -- by defining the set of values.  Next, we define the
    critical notions of _free variables_ and _substitution_, which are
    used in the reduction rule for application expressions.  And
    finally we give the small-step relation itself. *)

(* ################################### *)
(** *** Values *)

(** To define the values of the STLC, we have a few cases to consider.

    First, for the boolean part of the language, the situation is
    clear: [true] and [false] are the only values.  (An [if]
    expression is never a value.)

    Second, an application is clearly not a value: It represents a
    function being invoked on some argument, which clearly still has
    work left to do.

    Third, for abstractions, we have a choice:

      - We can say that [\x:T.t1] is a value only when [t1] is a
        value -- i.e., only if the function's body has been
        reduced (as much as it can be without knowing what argument it
        is going to be applied to).

      - Or we can say that [\x:T.t1] is always a value, no matter
        whether [t1] is one or not -- in other words, we can say that
        reduction stops at abstractions.

    Coq (in its built-in functional programming langauge) makes the
    first choice -- for example,
         Eval simpl in (fun x:bool => 3 + 4)
    yields [fun x:bool => 7].  But most real-world functional
    programming languages make the second choice -- reduction of a
    function's body only begins when the function is actually applied
    to an argument.  We also make the second choice here.

    Finally, having made the choice not to reduce under abstractions,
    we don't need to worry about whether variables are values, since
    we'll always be reducing programs "from the outside in," and that
    means the [step] relation will always be working with closed
    terms (ones with no free variables).  *)

Inductive value : tm -> Prop :=
  | v_abs : forall x T t,
      value (tabs x T t)
  | t_true :
      value ttrue
  | t_false :
      value tfalse.

Hint Constructors value.

(* ###################################################################### *)
(** *** Free Variables and Substitution *)

(** Now we come to the heart of the matter: the operation of
    substituting one term for a variable in another term.

    This operation will be used below to define the operational
    semantics of function application, where we will need to
    substitute the argument term for the function parameter in the
    function's body.  For example, we reduce
       (\x:Bool. if x then true else x) false
    to [false] by substituting [false] for the parameter [x] in the
    body of the function.  In general, we need to be able to
    substitute some given term [s] for occurrences of some variable
    [x] in another term [t].  In informal discussions, this is usually
    written [ [x:=s]t ] and pronounced "substitute [x] with [s] in [t]."

    Here are some examples:

      - [[x:=true] (if x then x else false)] yields [if true then true else false]

      - [[x:=true] x] yields [true]

      - [[x:=true] (if x then x else y)] yields [if true then true else y]

      - [[x:=true] y] yields [y]

      - [[x:=true] false] yields [false] (vacuous substitution)

      - [[x:=true] (\y:Bool. if y then x else false)] yields [\y:Bool. if y then true else false]
      - [[x:=true] (\y:Bool. x)] yields [\y:Bool. true]

      - [[x:=true] (\y:Bool. y)] yields [\y:Bool. y]

      - [[x:=true] (\x:Bool. x)] yields [\x:Bool. x]

    The last example is very important: substituting [x] with [true] in
    [\x:Bool. x] does _not_ yield [\x:Bool. true]!  The reason for
    this is that the [x] in the body of [\x:Bool. x] is _bound_ by the
    abstraction: it is a new, local name that just happens to be
    spelled the same as some global name [x].

    Here is the definition, informally...
      [x:=s]x = s
      [x:=s]y = y                                     if x <> y
      [x:=s](\x:T11.t12)   = \x:T11. t12
      [x:=s](\y:T11.t12)   = \y:T11. [x:=s]t12         if x <> y
      [x:=s](t1 t2)        = ([x:=s]t1) ([x:=s]t2)
      [x:=s]true           = true
      [x:=s]false          = false
      [x:=s](if t1 then t2 else t3) =
                          if [x:=s]t1 then [x:=s]t2 else [x:=s]t3
]]
    ... and formally: *)

Fixpoint subst (x:id) (s:tm) (t:tm) : tm :=
  match t with
  | tvar x' =>
      if beq_id x x' then s else t
  | tabs x' T t1 =>
      tabs x' T (if beq_id x x' then t1 else (subst x s t1))
  | tapp t1 t2 =>
      tapp (subst x s t1) (subst x s t2)
  | ttrue =>
      ttrue
  | tfalse =>
      tfalse
  | tif t1 t2 t3 =>
      tif (subst x s t1) (subst x s t2) (subst x s t3)
  end.

Notation "'[' x ':=' s ']' t" := (subst x s t) (at level 20).

(** _Technical note_: Substitution becomes trickier to define if we
    consider the case where [s], the term being substituted for a
    variable in some other term, may itself contain free variables.
    Since we are only interested here in defining the [step] relation
    on closed terms (i.e., terms like [\x:Bool. x y] that mention
    variables are not bound by some enclosing lambda), we can avoid
    this extra complexity. *)

(* ################################### *)
(** *** Reduction *)

(** The small-step reduction relation for STLC now follows the same
    pattern as the ones we have seen before.  Intuitively, to reduce a
    function application, we first reduce its left-hand side until it
    becomes a literal function; then we reduce its right-hand
    side (the argument) until it is also a value; and finally we
    substitute the argument for the bound variable in the body of the
    function.  This last rule, written informally as
      (\x:T.t12) v2 ==> [x:=v2]t12
    is traditionally called "beta-reduction". *)

(**
                               value v2
                     ----------------------------                   (ST_AppAbs)
                     (\x:T.t12) v2 ==> [x:=v2]t12

                              t1 ==> t1'
                           ----------------                           (ST_App1)
                           t1 t2 ==> t1' t2

                              value v1
                              t2 ==> t2'
                           ----------------                           (ST_App2)
                           v1 t2 ==> v1 t2'
   (plus the usual rules for booleans).
*)

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

Inductive step : tm -> tm -> Prop :=
  | ST_AppAbs : forall x T t12 v2,
         value v2 ->
         (tapp (tabs x T t12) v2) ==> [x:=v2]t12
  | ST_App1 : forall t1 t1' t2,
         t1 ==> t1' ->
         tapp t1 t2 ==> tapp t1' t2
  | ST_App2 : forall v1 t2 t2',
         value v1 ->
         t2 ==> t2' ->
         tapp v1 t2 ==> tapp v1  t2'
  | ST_IfTrue : forall t1 t2,
      (tif ttrue t1 t2) ==> t1
  | ST_IfFalse : forall t1 t2,
      (tif tfalse t1 t2) ==> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 ==> t1' ->
      (tif t1 t2 t3) ==> (tif t1' t2 t3)

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

Tactic Notation "step_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "ST_AppAbs" | Case_aux c "ST_App1"
  | Case_aux c "ST_App2" | Case_aux c "ST_IfTrue"
  | Case_aux c "ST_IfFalse" | Case_aux c "ST_If" ].

Hint Constructors step.

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

(* ##################################### *)
(** *** Examples *)

(** Example:
    ((\x:Bool->Bool. x) (\x:Bool. x)) ==>* (\x:Bool. x)
i.e.
    (idBB idB) ==>* idB
*)

Lemma step_example1 :
  (tapp idBB idB) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.  Qed.

(** A more automatic proof *)

Lemma step_example1' :
  (tapp idBB idB) ==>* idB.
Proof. normalize.  Qed.

Lemma step_example2 :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  eapply multi_step.
    apply ST_App2. auto.
    apply ST_AppAbs. auto.
  eapply multi_step.
    apply ST_AppAbs. simpl. auto.
  simpl. apply multi_refl.  Qed.

(** Again, we can use the [normalize] tactic from above to simplify
    the proof. *)

Lemma step_example2' :
  (tapp idBB (tapp idBB idB)) ==>* idB.
Proof.
  normalize.
Qed.

(** **** Exercise: 2 stars (step_example3) *)
(** Try to do this one both with and without [normalize]. *)

Lemma step_example3 :
       (tapp (tapp idBBBB idBB) idB)
  ==>* idB.
Proof.
  (*Use normalize. can finish all.*)
  eapply multi_step.
    apply ST_App1. auto.
    simpl.
    (* Or use apply step_example1. to end *)
  eapply multi_step.
    apply ST_AppAbs.
    apply v_abs.
  simpl.
  apply multi_refl.
Qed.
(** [] *)

(* ###################################################################### *)
(** ** Typing *)

(* ################################### *)
(** *** Contexts *)

(** _Question_: What is the type of the term "[x y]"?

    _Answer_: It depends on the types of [x] and [y]!

    I.e., in order to assign a type to a term, we need to know
    what assumptions we should make about the types of its free
    variables.

    This leads us to a three-place "typing judgment", informally
    written [Gamma |- t : T], where [Gamma] is a
    "typing context" -- a mapping from variables to their types. *)

(** We hide the definition of partial maps in a module since it is
    actually defined in [SfLib]. *)

Module PartialMap.

Definition partial_map (A:Type) := id -> option A.

Definition empty {A:Type} : partial_map A := (fun _ => None).

(** Informally, we'll write [Gamma, x:T] for "extend the partial
    function [Gamma] to also map [x] to [T]."  Formally, we use the
    function [extend] to add a binding to a partial map. *)

Definition extend {A:Type} (Gamma : partial_map A) (x:id) (T : A) :=
  fun x' => if beq_id x x' then Some T else Gamma x'.

Lemma extend_eq : forall A (ctxt: partial_map A) x T,
  (extend ctxt x T) x = Some T.
Proof.
  intros. unfold extend. rewrite <- beq_id_refl. auto.
Qed.

Lemma extend_neq : forall A (ctxt: partial_map A) x1 T x2,
  beq_id x2 x1 = false ->
  (extend ctxt x2 T) x1 = ctxt x1.
Proof.
  intros. unfold extend. rewrite H. auto.
Qed.

End PartialMap.

Definition context := partial_map ty.

(* ################################### *)
(** *** Typing Relation *)

(**
                             Gamma x = T
                            --------------                              (T_Var)
                            Gamma |- x : T

                      Gamma , x:T11 |- t12 : T12
                     ----------------------------                       (T_Abs)
                     Gamma |- \x:T11.t12 : T11->T12

                        Gamma |- t1 : T11->T12
                          Gamma |- t2 : T11
                        ----------------------                          (T_App)
                         Gamma |- t1 t2 : T12

                         --------------------                          (T_True)
                         Gamma |- true : Bool

                        ---------------------                         (T_False)
                        Gamma |- false : Bool

       Gamma |- t1 : Bool    Gamma |- t2 : T    Gamma |- t3 : T
       --------------------------------------------------------          (T_If)
                  Gamma |- if t1 then t2 else t3 : T
*)

Inductive has_type : context -> tm -> ty -> Prop :=
  | T_Var : forall Gamma x T,
      Gamma x = Some T ->
      has_type Gamma (tvar x) T
  | T_Abs : forall Gamma x T11 T12 t12,
      has_type (extend Gamma x T11) t12 T12 ->
      has_type Gamma (tabs x T11 t12) (TArrow T11 T12)
  | T_App : forall T11 T12 Gamma t1 t2,
      has_type Gamma t1 (TArrow T11 T12) ->
      has_type Gamma t2 T11 ->
      has_type Gamma (tapp t1 t2) T12
  | T_True : forall Gamma,
       has_type Gamma ttrue TBool
  | T_False : forall Gamma,
       has_type Gamma tfalse TBool
  | T_If : forall t1 t2 t3 T Gamma,
       has_type Gamma t1 TBool ->
       has_type Gamma t2 T ->
       has_type Gamma t3 T ->
       has_type Gamma (tif t1 t2 t3) T.

Tactic Notation "has_type_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "T_Var" | Case_aux c "T_Abs"
  | Case_aux c "T_App" | Case_aux c "T_True"
  | Case_aux c "T_False" | Case_aux c "T_If" ].

Hint Constructors has_type.

(* ################################### *)
(** *** Examples *)

Example typing_example_1 :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof.
  apply T_Abs. apply T_Var. reflexivity.  Qed.

(** Note that since we added the [has_type] constructors to the hints
    database, auto can actually solve this one immediately. *)

Example typing_example_1' :
  has_type empty (tabs x TBool (tvar x)) (TArrow TBool TBool).
Proof. auto.  Qed.

Hint Unfold beq_id beq_nat extend.

(** Another example:
     empty |- \x:A. \y:A->A. y (y x))
           : A -> (A->A) -> A.
*)

Example typing_example_2 :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof with auto using extend_eq.
  apply T_Abs.
  apply T_Abs.
  eapply T_App. apply T_Var...
  eapply T_App. apply T_Var...
  apply T_Var...
Qed.

(** **** Exercise: 2 stars, optional (typing_example_2_full) *)
(** Prove the same result without using [auto], [eauto], or
    [eapply]. *)

Example typing_example_2_full :
  has_type empty
    (tabs x TBool
       (tabs y (TArrow TBool TBool)
          (tapp (tvar y) (tapp (tvar y) (tvar x)))))
    (TArrow TBool (TArrow (TArrow TBool TBool) TBool)).
Proof.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (T11:=TBool).
    apply T_Var. reflexivity.
  apply T_App with (T11:=TBool).
    apply T_Var. reflexivity.
  apply T_Var. reflexivity.
Qed.
(** [] *)

(** **** Exercise: 2 stars (typing_example_3) *)
(** Formally prove the following typing derivation holds: *)
(**
   empty |- (\x:Bool->Bool. \y:Bool->Bool. \z:Bool.
               y (x z))
         : T.
*)

Example typing_example_3 :
  exists T,
    has_type empty
      (tabs x (TArrow TBool TBool)
         (tabs y (TArrow TBool TBool)
            (tabs z TBool
               (tapp (tvar y) (tapp (tvar x) (tvar z))))))
      T.

Proof with auto.
  exists (TArrow (TArrow TBool TBool) (TArrow (TArrow TBool TBool) (TArrow TBool TBool))).
  apply T_Abs.
  apply T_Abs.
  apply T_Abs.
  apply T_App with (TBool). apply T_Var...
  apply T_App with (TBool). apply T_Var...
  apply T_Var...
Qed.
(** [] *)

(** We can also show that terms are _not_ typable.  For example, let's
    formally check that there is no typing derivation assigning a type
    to the term [\x:Bool. \y:Bool, x y] -- i.e.,
    ~ exists T,
        empty |- (\x:Bool. \y:Bool, x y) : T.
*)

Example typing_nonexample_1 :
  ~ exists T,
      has_type empty
        (tabs x TBool
            (tabs y TBool
               (tapp (tvar x) (tvar y))))
        T.
Proof.
  intros Hc. inversion Hc.
  (* The [clear] tactic is useful here for tidying away bits of
     the context that we're not going to need again. *)
  inversion H. subst. clear H.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  inversion H5. subst. clear H5.
  (* rewrite extend_neq in H1. rewrite extend_eq in H1. *)
  inversion H1.  Qed.

(** **** Exercise: 3 stars (typing_nonexample_3) *)
(** Another nonexample:
    ~ (exists S, exists T,
          empty |- (\x:S. x x) : T).
*)

Example typing_nonexample_3 :
  ~ (exists S, exists T,
        has_type empty
          (tabs x S
             (tapp (tvar x) (tvar x)))
          T).
Proof.
  intros Hc. inversion Hc.
  inversion H. subst. clear H.
  inversion H0. subst. clear H0.
  inversion H5. subst. clear H5.
  inversion H4. subst. clear H4.
  inversion H2. subst. clear H2.
  Case "Proof X != X -> Y".
  rewrite H1 in H3. inversion H3.
  induction T11. inversion H0.
  inversion H0. apply IHT11_1. rewrite H2. assumption.
  rewrite <- H4. rewrite H2 at 1. reflexivity.
  rewrite <- H4. assumption.
Qed.
(** [] *)

(** **** Exercise: 1 star, optional (typing_statements) *)

(** Which of the following propositions are provable?
       - [y:Bool |- \x:Bool.x : Bool->Bool]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. y x) : T]

       - [exists T,  empty |- (\y:Bool->Bool. \x:Bool. x y) : T]

       - [exists S, x:S |- (\y:Bool->Bool. y) x : S]

       - [exists S, exists T,  x:S |- (x x x) : T]

[]
*)

(** **** Exercise: 1 star (more_typing_statements) *)

(** Which of the following propositions are provable?  For the
    ones that are, give witnesses for the existentially bound
    variables.
       - [exists T,  empty |- (\y:B->B->B. \x:B, y x) : T]
         T = (B->B->B)->(B->(B->B))

       - [exists T,  empty |- (\x:A->B, \y:B-->C, \z:A, y (x z)):T]
         T = (A->B)->((B->C)->(A->C))

       - [exists S, exists U, exists T,  x:S, y:U |- \z:A. x (y z) : T]
         S = B->C
         U = A->B
         T = A->C

       - [exists S, exists T,  x:S |- \y:A. x (x y) : T]
         S = A->A
         T = A->A

       - [exists S, exists U, exists T,  x:S |- x (\z:U. z x) : T]
         S = A
         U = A->B
         T = B

[]
*)

Theorem mts1: exists T,
  has_type empty
     (tabs y (TArrow TBool (TArrow TBool TBool))
       (tabs x TBool
         (tapp (tvar y) (tvar x)))) T.
Proof.
  exists (TArrow (TArrow TBool (TArrow TBool TBool)) ((TArrow TBool (TArrow TBool TBool)))).
  apply T_Abs.
  apply T_Abs.
  apply T_App with (TBool). apply T_Var. reflexivity.
  apply T_Var. reflexivity.
Qed.
(* ###################################################################### *)
(** ** Properties *)

(* ###################################################################### *)
(** *** Free Occurrences *)

(** A variable [x] _appears free in_ a term _t_ if [t] contains some
    occurrence of [x] that is not under an abstraction labeled [x].  For example:
      - [y] appears free, but [x] does not, in [\x:T->U. x y]
      - both [x] and [y] appear free in [(\x:T->U. x y) x]
      - no variables appear free in [\x:T->U. \y:T. x y]  *)

Inductive appears_free_in : id -> tm -> Prop :=
  | afi_var : forall x,
      appears_free_in x (tvar x)
  | afi_app1 : forall x t1 t2,
      appears_free_in x t1 -> appears_free_in x (tapp t1 t2)
  | afi_app2 : forall x t1 t2,
      appears_free_in x t2 -> appears_free_in x (tapp t1 t2)
  | afi_abs : forall x y T11 t12,
      y <> x  ->
      appears_free_in x t12 ->
      appears_free_in x (tabs y T11 t12)
  | afi_if1 : forall x t1 t2 t3,
      appears_free_in x t1 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if2 : forall x t1 t2 t3,
      appears_free_in x t2 ->
      appears_free_in x (tif t1 t2 t3)
  | afi_if3 : forall x t1 t2 t3,
      appears_free_in x t3 ->
      appears_free_in x (tif t1 t2 t3).

Tactic Notation "afi_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "afi_var"
  | Case_aux c "afi_app1" | Case_aux c "afi_app2"
  | Case_aux c "afi_abs"
  | Case_aux c "afi_if1" | Case_aux c "afi_if2"
  | Case_aux c "afi_if3" ].

Hint Constructors appears_free_in.

(** A term in which no variables appear free is said to be _closed_. *)

Definition closed (t:tm) :=
  forall x, ~ appears_free_in x t.

(* ###################################################################### *)
(** *** Substitution *)

(** We first need a technical lemma connecting free variables and
    typing contexts.  If a variable [x] appears free in a term [t],
    and if we know [t] is well typed in context [Gamma], then it must
    be the case that [Gamma] assigns a type to [x]. *)

Lemma free_in_context : forall x t T Gamma,
   appears_free_in x t ->
   has_type Gamma t T ->
   exists T', Gamma x = Some T'.

(** _Proof_: We show, by induction on the proof that [x] appears free
      in [t], that, for all contexts [Gamma], if [t] is well typed
      under [Gamma], then [Gamma] assigns some type to [x].

      - If the last rule used was [afi_var], then [t = x], and from
        the assumption that [t] is well typed under [Gamma] we have
        immediately that [Gamma] assigns a type to [x].

      - If the last rule used was [afi_app1], then [t = t1 t2] and [x]
        appears free in [t1].  Since [t] is well typed under [Gamma],
        we can see from the typing rules that [t1] must also be, and
        the IH then tells us that [Gamma] assigns [x] a type.

      - Almost all the other cases are similar: [x] appears free in a
        subterm of [t], and since [t] is well typed under [Gamma], we
        know the subterm of [t] in which [x] appears is well typed
        under [Gamma] as well, and the IH gives us exactly the
        conclusion we want.

      - The only remaining case is [afi_abs].  In this case [t =
        \y:T11.t12], and [x] appears free in [t12]; we also know that
        [x] is different from [y].  The difference from the previous
        cases is that whereas [t] is well typed under [Gamma], its
        body [t12] is well typed under [(Gamma, y:T11)], so the IH
        allows us to conclude that [x] is assigned some type by the
        extended context [(Gamma, y:T11)].  To conclude that [Gamma]
        assigns a type to [x], we appeal to lemma [extend_neq], noting
        that [x] and [y] are different variables. *)

Proof.
  intros x t T Gamma H H0. generalize dependent Gamma. generalize dependent T.
  afi_cases (induction H) Case;
         intros; try solve [inversion H0; eauto].
  Case "afi_abs".
    inversion H1; subst.
    apply IHappears_free_in in H7.
    apply not_eq_beq_id_false in H.
    rewrite extend_neq in H7; assumption.
Qed.

(** Next, we'll need the fact that any term [t] which is well typed in
    the empty context is closed -- that is, it has no free variables. *)

(** **** Exercise: 2 stars (typable_empty__closed) *)
Corollary typable_empty__closed : forall t T,
    has_type empty t T  ->
    closed t.
Proof.
  (* FILL IN HERE *) Admitted.
(** [] *)

(** Sometimes, when we have a proof [Gamma |- t : T], we will need to
    replace [Gamma] by a different context [Gamma'].  When is it safe
    to do this?  Intuitively, it must at least be the case that
    [Gamma'] assigns the same types as [Gamma] to all the variables
    that appear free in [t]. In fact, this is the only condition that
    is needed. *)

Lemma context_invariance : forall Gamma Gamma' t S,
     has_type Gamma t S  ->
     (forall x, appears_free_in x t -> Gamma x = Gamma' x) ->
     has_type Gamma' t S.

(** _Proof_: By induction on the derivation of [Gamma |- t : T].

      - If the last rule in the derivation was [T_Var], then [t = x]
        and [Gamma x = T].  By assumption, [Gamma' x = T] as well, and
        hence [Gamma' |- t : T] by [T_Var].

      - If the last rule was [T_Abs], then [t = \y:T11. t12], with [T
        = T11 -> T12] and [Gamma, y:T11 |- t12 : T12].  The induction
        hypothesis is that for any context [Gamma''], if [Gamma,
        y:T11] and [Gamma''] assign the same types to all the free
        variables in [t12], then [t12] has type [T12] under [Gamma''].
        Let [Gamma'] be a context which agrees with [Gamma] on the
        free variables in [t]; we must show [Gamma' |- \y:T11. t12 :
        T11 -> T12].

        By [T_Abs], it suffices to show that [Gamma', y:T11 |- t12 :
        T12].  By the IH (setting [Gamma'' = Gamma', y:T11]), it
        suffices to show that [Gamma, y:T11] and [Gamma', y:T11] agree
        on all the variables that appear free in [t12].

        Any variable occurring free in [t12] must either be [y], or
        some other variable.  [Gamma, y:T11] and [Gamma', y:T11]
        clearly agree on [y].  Otherwise, we note that any variable
        other than [y] which occurs free in [t12] also occurs free in
        [t = \y:T11. t12], and by assumption [Gamma] and [Gamma']
        agree on all such variables, and hence so do [Gamma, y:T11]
        and [Gamma', y:T11].

      - If the last rule was [T_App], then [t = t1 t2], with [Gamma |-
        t1 : T2 -> T] and [Gamma |- t2 : T2].  One induction
        hypothesis states that for all contexts [Gamma'], if [Gamma']
        agrees with [Gamma] on the free variables in [t1], then [t1]
        has type [T2 -> T] under [Gamma']; there is a similar IH for
        [t2].  We must show that [t1 t2] also has type [T] under
        [Gamma'], given the assumption that [Gamma'] agrees with
        [Gamma] on all the free variables in [t1 t2].  By [T_App], it
        suffices to show that [t1] and [t2] each have the same type
        under [Gamma'] as under [Gamma].  However, we note that all
        free variables in [t1] are also free in [t1 t2], and similarly
        for free variables in [t2]; hence the desired result follows
        by the two IHs.
*)

Proof with eauto.
  intros.
  generalize dependent Gamma'.
  has_type_cases (induction H) Case; intros; auto.
  Case "T_Var".
    apply T_Var. rewrite <- H0...
  Case "T_Abs".
    apply T_Abs.
    apply IHhas_type. intros x1 Hafi.
    (* the only tricky step... the [Gamma'] we use to
       instantiate is [extend Gamma x T11] *)
    unfold extend. remember (beq_id x0 x1) as e. destruct e...
  Case "T_App".
    apply T_App with T11...
Qed.

(** Now we come to the conceptual heart of the proof that reduction
    preserves types -- namely, the observation that _substitution_
    preserves types.

    Formally, the so-called _Substitution Lemma_ says this: suppose we
    have a term [t] with a free variable [x], and suppose we've been
    able to assign a type [T] to [t] under the assumption that [x] has
    some type [U].  Also, suppose that we have some other term [v] and
    that we've shown that [v] has type [U].  Then, since [v] satisfies
    the assumption we made about [x] when typing [t], we should be
    able to substitute [v] for each of the occurrences of [x] in [t]
    and obtain a new term that still has type [T]. *)

(** _Lemma_: If [Gamma,x:U |- t : T] and [|- v : U], then [Gamma |-
    [x:=v]t : T]. *)

Lemma substitution_preserves_typing : forall Gamma x U v t T,
     has_type (extend Gamma x U) t T ->
     has_type empty v U   ->
     has_type Gamma ([x:=v]t) T.

(** One technical subtlety in the statement of the lemma is that we
    assign [v] the type [U] in the _empty_ context -- in other words,
    we assume [v] is closed.  This assumption considerably simplifies
    the [T_Abs] case of the proof (compared to assuming [Gamma |- v :
    U], which would be the other reasonable assumption at this point)
    because the context invariance lemma then tells us that [v] has
    type [U] in any context at all -- we don't have to worry about
    free variables in [v] clashing with the variable being introduced
    into the context by [T_Abs].

    _Proof_: We prove, by induction on [t], that, for all [T] and
    [Gamma], if [Gamma,x:U |- t : T] and [|- v : U], then [Gamma |-
    [x:=v]t : T].

      - If [t] is a variable, there are two cases to consider, depending
        on whether [t] is [x] or some other variable.

          - If [t = x], then from the fact that [Gamma, x:U |- x : T] we
            conclude that [U = T].  We must show that [[x:=v]x = v] has
            type [T] under [Gamma], given the assumption that [v] has
            type [U = T] under the empty context.  This follows from
            context invariance: if a closed term has type [T] in the
            empty context, it has that type in any context.

          - If [t] is some variable [y] that is not equal to [x], then
            we need only note that [y] has the same type under [Gamma,
            x:U] as under [Gamma].

      - If [t] is an abstraction [\y:T11. t12], then the IH tells us,
        for all [Gamma'] and [T'], that if [Gamma',x:U |- t12 : T']
        and [|- v : U], then [Gamma' |- [x:=v]t12 : T'].  In
        particular, if [Gamma,y:T11,x:U |- t12 : T12] and [|- v : U],
        then [Gamma,y:T11 |- [x:=v]t12 : T12].  There are again two
        cases to consider, depending on whether [x] and [y] are the
        same variable name.

        First, suppose [x = y].  Then, by the definition of
        substitution, [[x:=v]t = t], so we just need to show [Gamma |-
        t : T].  But we know [Gamma,x:U |- t : T], and since the
        variable [y] does not appear free in [\y:T11. t12], the
        context invariance lemma yields [Gamma |- t : T].

        Second, suppose [x <> y].  We know [Gamma,x:U,y:T11 |- t12 :
        T12] by inversion of the typing relation, and [Gamma,y:T11,x:U
        |- t12 : T12] follows from this by the context invariance
        lemma, so the IH applies, giving us [Gamma,y:T11 |- [x:=v]t12 :
        T12].  By [T_Abs], [Gamma |- \y:T11. [x:=v]t12 : T11->T12], and
        by the definition of substitution (noting that [x <> y]),
        [Gamma |- \y:T11. [x:=v]t12 : T11->T12], as required.

      - If [t] is an application [t1 t2], the result follows
        straightforwardly from the definition of substitution and the
        induction hypotheses.

      - The remaining cases are similar to the application case.

    Another technical note: This proof is a rare case where an
    induction on terms, rather than typing derivations, yields a
    simpler argument.  The reason for this is that the assumption
    [has_type (extend Gamma x U) t T] is not completely generic, in
    the sense that one of the "slots" in the typing relation -- namely
    the context -- is not just a variable, and this means that Coq's
    native induction tactic does not give us the induction hypothesis
    that we want.  It is possible to work around this, but the needed
    generalization is a little tricky.  The term [t], on the other
    hand, _is_ completely generic. *)

Proof with eauto.
  intros Gamma x U v t T Ht Hv.
  generalize dependent Gamma. generalize dependent T.
  t_cases (induction t) Case; intros T Gamma H;
    (* in each case, we'll want to get at the derivation of H *)
    inversion H; subst; simpl...
  Case "tvar".
    rename i into y. remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      apply beq_id_eq in Heqe. subst.
      rewrite extend_eq in H2.
      inversion H2; subst. clear H2.
                  eapply context_invariance... intros x Hcontra.
      destruct (free_in_context _ _ T empty Hcontra) as [T' HT']...
      inversion HT'.
    SCase "x<>y".
      apply T_Var. rewrite extend_neq in H2...
  Case "tabs".
    rename i into y. apply T_Abs.
    remember (beq_id x y) as e. destruct e.
    SCase "x=y".
      eapply context_invariance...
      apply beq_id_eq in Heqe. subst.
      intros x Hafi. unfold extend.
      destruct (beq_id y x)...
    SCase "x<>y".
      apply IHt. eapply context_invariance...
      intros z Hafi. unfold extend.
      remember (beq_id y z) as e0. destruct e0...
      apply beq_id_eq in Heqe0. subst.
      rewrite <- Heqe...
Qed.

(** The substitution lemma can be viewed as a kind of "commutation"
    property.  Intuitively, it says that substitution and typing can
    be done in either order: we can either assign types to the terms
    [t] and [v] separately (under suitable contexts) and then combine
    them using substitution, or we can substitute first and then
    assign a type to [ [x:=v] t ] -- the result is the same either
    way. *)

(* ###################################################################### *)
(** *** Preservation *)

(** We now have the tools we need to prove _preservation_: if a closed
    term [t] has type [T], and takes an evaluation step to [t'], then [t']
    is also a closed term with type [T].  In other words, the small-step
    evaluation relation preserves types.
*)

Theorem preservation : forall t t' T,
     has_type empty t T  ->
     t ==> t'  ->
     has_type empty t' T.

(** _Proof_: by induction on the derivation of [|- t : T].

    - We can immediately rule out [T_Var], [T_Abs], [T_True], and
      [T_False] as the final rules in the derivation, since in each of
      these cases [t] cannot take a step.

    - If the last rule in the derivation was [T_App], then [t = t1
      t2].  There are three cases to consider, one for each rule that
      could have been used to show that [t1 t2] takes a step to [t'].

        - If [t1 t2] takes a step by [ST_App1], with [t1] stepping to
          [t1'], then by the IH [t1'] has the same type as [t1], and
          hence [t1' t2] has the same type as [t1 t2].

        - The [ST_App2] case is similar.

        - If [t1 t2] takes a step by [ST_AppAbs], then [t1 =
          \x:T11.t12] and [t1 t2] steps to [[x:=t2]t12]; the
          desired result now follows from the fact that substitution
          preserves types.

    - If the last rule in the derivation was [T_If], then [t = if t1
      then t2 else t3], and there are again three cases depending on
      how [t] steps.

        - If [t] steps to [t2] or [t3], the result is immediate, since
          [t2] and [t3] have the same type as [t].

        - Otherwise, [t] steps by [ST_If], and the desired conclusion
          follows directly from the induction hypothesis.
*)

Proof with eauto.
  remember (@empty ty) as Gamma.
  intros t t' T HT. generalize dependent t'.
  has_type_cases (induction HT) Case;
     intros t' HE; subst Gamma; subst;
     try solve [inversion HE; subst; auto].
  Case "T_App".
    inversion HE; subst...
    (* Most of the cases are immediate by induction,
       and [auto] takes care of them *)
    SCase "ST_AppAbs".
      apply substitution_preserves_typing with T11...
      inversion HT1...
Qed.

(** **** Exercise: 2 stars, recommended (subject_expansion_stlc) *)
(** An exercise in Types.v asked about the subject
    expansion property for the simple language of arithmetic and
    boolean expressions.  Does this property hold for STLC?  That
    is, is it always the case that, if [t ==> t'] and [has_type
    t' T], then [has_type t T]?  If so, prove it.  If not, give a
    counter-example.

(* FILL IN HERE *)
[]
*)

(* ###################################################################### *)
(** *** Progress *)

(** Finally, the _progress_ theorem tells us that closed, well-typed
    terms are not stuck: either a well-typed term is a value, or
    else it can take an evaluation step.
*)

Theorem progress : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.

(** _Proof_: by induction on the derivation of [|- t : T].

    - The last rule of the derivation cannot be [T_Var], since a
      variable is never well typed in an empty context.

    - The [T_True], [T_False], and [T_Abs] cases are trivial, since in
      each of these cases we know immediately that [t] is a value.

    - If the last rule of the derivation was [T_App], then [t = t1
      t2], and we know that [t1] and [t2] are also well typed in the
      empty context; in particular, there exists a type [T2] such that
      [|- t1 : T2 -> T] and [|- t2 : T2].  By the induction
      hypothesis, either [t1] is a value or it can take an evaluation
      step.

        - If [t1] is a value, we now consider [t2], which by the other
          induction hypothesis must also either be a value or take an
          evaluation step.

            - Suppose [t2] is a value.  Since [t1] is a value with an
              arrow type, it must be a lambda abstraction; hence [t1
              t2] can take a step by [ST_AppAbs].

            - Otherwise, [t2] can take a step, and hence so can [t1
              t2] by [ST_App2].

        - If [t1] can take a step, then so can [t1 t2] by [ST_App1].

    - If the last rule of the derivation was [T_If], then [t = if t1
      then t2 else t3], where [t1] has type [Bool].  By the IH, [t1]
      is either a value or takes a step.

        - If [t1] is a value, then since it has type [Bool] it must be
          either [true] or [false].  If it is [true], then [t] steps
          to [t2]; otherwise it steps to [t3].

        - Otherwise, [t1] takes a step, and therefore so does [t] (by
          [ST_If]).

*)

Proof with eauto.
  intros t T Ht.
  remember (@empty ty) as Gamma.
  has_type_cases (induction Ht) Case; subst Gamma...
  Case "T_Var".
    (* contradictory: variables cannot be typed in an
       empty context *)
    inversion H.

  Case "T_App".
    (* [t] = [t1 t2].  Proceed by cases on whether [t1] is a
       value or steps... *)
    right. destruct IHHt1...
    SCase "t1 is a value".
      destruct IHHt2...
      SSCase "t2 is also a value".
        (* Since [t1] is a value and has an arrow type, it
           must be an abs. Sometimes this is proved separately
           and called a "canonical forms" lemma. *)
        inversion H; subst. exists ([x0:=t2]t)...
        solve by inversion. solve by inversion.
      SSCase "t2 steps".
        inversion H0 as [t2' Hstp]. exists (tapp t1 t2')...

    SCase "t1 steps".
      inversion H as [t1' Hstp]. exists (tapp t1' t2)...

  Case "T_If".
    right. destruct IHHt1...

    SCase "t1 is a value".
      (* Since [t1] is a value of boolean type, it must
         be true or false *)
      inversion H; subst. solve by inversion.
      SSCase "t1 = true". eauto.
      SSCase "t1 = false". eauto.

    SCase "t1 also steps".
      inversion H as [t1' Hstp]. exists (tif t1' t2 t3)...
Qed.

(** **** Exercise: 3 stars, optional (progress_from_term_ind) *)
(** Show that progress can also be proved by induction on terms
    instead of types. *)

Theorem progress' : forall t T,
     has_type empty t T ->
     value t \/ exists t', t ==> t'.
Proof.
  intros t.
  t_cases (induction t) Case; intros T Ht; auto.
  (* FILL IN HERE *) Admitted.
(** [] *)

(* ###################################################################### *)
(** *** Uniqueness of Types *)

(** **** Exercise: 3 stars (types_unique) *)
(** Another pleasant property of the STLC is that types are
    unique: a given term (in a given context) has at most one
    type. *)
(** Formalize this statement and prove it. *)

(* FILL IN HERE *)
(** [] *)

(* ###################################################################### *)
(** ** Additional Exercises *)

(** **** Exercise: 1 star (progress_preservation_statement) *)
(** Without peeking, write down the progress and preservation
    theorems for the simply typed lambda-calculus. *)
(** [] *)

(** **** Exercise: 2 stars, optional (stlc_variation1) *)
(** Suppose we add the following new rule to the evaluation
    relation of the STLC:
      | T_Strange : forall x t,
           has_type empty (tabs x Bool t) Bool
    Which of the following properties of the STLC remain true in
    the presence of this rule?  For each one, write either
    "remains true" or else "becomes false." If a property becomes
    false, give a counterexample.

      - Determinism of [step]

      - Progress

      - Preservation

[]
*)

(** **** Exercise: 2 stars (stlc_variation2) *)
(** Suppose we remove the rule [ST_App1] from the [step]
    relation. Which of the three properties in the previous
    exercise become false in the absence of this rule? For each
    that becomes false, give a counterexample.

[]
*)

End STLC.

(* ###################################################################### *)
(* ###################################################################### *)
(** * Exercise: STLC with Arithmetic *)

(** To see how the STLC might function as the core of a real
    programming language, let's extend it with a concrete base
    type of numbers and some constants and primitive
    operators. *)

Module STLCArith.

(* ###################################################################### *)
(** ** Syntax and Operational Semantics *)

(** To types, we add a base type of natural numbers (and remove
    booleans, for brevity) *)

Inductive ty : Type :=
  | TArrow : ty -> ty -> ty
  | TNat   : ty.

(** To terms, we add natural number constants, along with
    successor, predecessor, multiplication, and zero-testing... *)

Inductive tm : Type :=
  | tvar : id -> tm
  | tapp : tm -> tm -> tm
  | tabs : id -> ty -> tm -> tm
  | tnat  : nat -> tm
  | tsucc : tm -> tm
  | tpred : tm -> tm
  | tmult : tm -> tm -> tm
  | tif0  : tm -> tm -> tm -> tm.

Tactic Notation "t_cases" tactic(first) ident(c) :=
  first;
  [ Case_aux c "tvar" | Case_aux c "tapp"
  | Case_aux c "tabs" | Case_aux c "tnat"
  | Case_aux c "tsucc" | Case_aux c "tpred"
  | Case_aux c "tmult" | Case_aux c "tif0" ].

(** **** Exercise: 4 stars, recommended (stlc_arith) *)
(** Finish formalizing the definition and properties of the STLC extended
    with arithmetic.  Specifically:

    - Copy the whole development of STLC that we went through above (from
      the definition of values through the Progress theorem), and
      paste it into the file at this point.

    - Extend the definitions of the [subst] operation and the [step]
      relation to include appropriate clauses for the arithmetic operators.

    - Extend the proofs of all the properties of the original STLC to deal
      with the new syntactic forms.  Make sure Coq accepts the whole file. *)

(* FILL IN HERE *)
(** [] *)

End STLCArith.


(** Test of the compilation pipeline. *)
Require Import ZArith.
Require Import List.
Require Import Compiler.Source.
Require Import Compiler.SourceToMacroAsm.
Require Import Compiler.MacroAsm.
Require Import Compiler.MacroAsmToCFG.
Require Import Compiler.CFG.

Set Implicit Arguments.
Import ListNotations.
Local Open Scope Z_scope.

Definition P (z : Z) := z >= 20.

Definition e0 : Source.t P :=
  Source.Test.e_15.

Definition e1 : Program.t P [] :=
  SourceToMacroAsm.compile e0.

Definition e2 : CFG.t (MacroAsmToCFG.L.t []) (MacroAsmToCFG.L.t [P]) :=
  MacroAsmToCFG.compile e1.

Check eq_refl : 27 = projT1 (Source.eval e0).
Check eq_refl : 27 = projT1 (Program.eval e1).
Check eq_refl : [27] = projT1 (CFG.eval e2 [] MacroAsmToCFG.L.nil).


Require Import Coq.Strings.String.

Require Export SystemFR.EquivalentContext.
Require Export SystemFR.StepTactics.

Open Scope list_scope.

Definition nat_eq_fix: tree :=
  notype_tfix (
    notype_lambda (notype_lambda (
      tmatch (lvar 1 term_var)
        (tmatch (lvar 0 term_var)
          ttrue
          tfalse)
        (tmatch (lvar 1 term_var)
          tfalse
          (app (app (lvar 4 term_var) (lvar 1 term_var)) (lvar 0 term_var))
        )
    ))
  ).

Definition nat_eq (a: tree) (b: tree) :=
  app (app nat_eq_fix a) b.

Lemma nat_eq_zero_b:
  forall b,
    cbv_value b ->
    nat_eq zero b ~>* ttrue ->
    b = zero.
Proof.
  unfold nat_eq, nat_eq_fix.
  destruct 1;
    repeat step || t_invert_star || star_smallstep_app_onestep;
    eauto with lia;
    eauto with values.
Qed.

Lemma nat_eq_succ:
  forall a b,
    cbv_value a ->
    cbv_value b ->
    wf a 0 ->
    wf b 0 ->
    nat_eq (succ a) b ~>* ttrue ->
    exists b',
      b = succ b' /\
      nat_eq a b' ~>* ttrue.
Proof.
  unfold nat_eq, nat_eq_fix; steps.

  reverse_once.
  reverse_once; eauto with values.
  reverse_once; repeat open_none; eauto with values.
  reverse_once; repeat open_none; eauto with values.
  reverse_once; repeat open_none; eauto with values.
Qed.

Lemma nat_eq_nat:
  forall a b,
    cbv_value a ->
    cbv_value b ->
    wf a 0 ->
    wf b 0 ->
    nat_eq a b ~>* ttrue ->
      (a = zero \/ exists a', a = succ a').
Proof.
  unfold nat_eq, nat_eq_fix; steps.
  reverse_once.
  reverse_once.
  reverse_once; repeat open_none.
  reverse_once; eauto.
Qed.

Lemma nat_eq_sound:
  forall a, cbv_value a ->
    wf a 0 ->
    forall b,
      cbv_value b ->
      wf b 0 ->
      nat_eq a b ~>* ttrue ->
      a = b.
Proof.
  induction 1; steps;
    try solve [ apply_anywhere nat_eq_nat; steps; eauto with values ];
    try solve [ apply_anywhere nat_eq_zero_b; steps ].

  apply_anywhere nat_eq_succ; repeat step || f_equal || apply_any || step_inversion cbv_value.
Qed.

Ltac nat_eq_sound :=
  match goal with
  | H: nat_eq ?a ?b ~>* ttrue |- _ =>
    cbv_value a; cbv_value b;
    poseNew (Mark (a,b) "nat_eq_sound");
    unshelve epose proof (nat_eq_sound a _ _ b _ _ H)
  | H: [ nat_eq ?a ?b ≡ ttrue ] |- _ =>
    cbv_value a; cbv_value b;
    poseNew (Mark (a,b) "tlt_sound");
    unshelve epose proof (nat_eq_sound a _ _ b _ _ _)
  end.

Lemma open_nat_eq:
  forall a b k rep, open k (nat_eq a b) rep = nat_eq (open k a rep) (open k b rep).
Proof.
  steps.
Qed.

Lemma pfv_nat_eq:
  forall a b tag, pfv (nat_eq a b) tag = pfv a tag ++ pfv b tag.
Proof.
  steps.
Qed.

Lemma psubstitute_nat_eq:
  forall a b l tag,
    psubstitute (nat_eq a b) l tag = nat_eq (psubstitute a l tag) (psubstitute b l tag).
Proof.
  steps.
Qed.

Ltac one_step_aux :=
 eapply Relation_Operators.rt1n_trans; [ eauto using is_nat_value_build_nat with values smallstep cbvlemmas | idtac ];
   repeat step || (rewrite open_none in * by (repeat step; eauto using is_nat_value_build_nat with wf)).

Ltac one_step := unshelve one_step_aux; steps.

Lemma nat_eq_complete:
  forall n,
    nat_eq (build_nat n) (build_nat n) ~>* ttrue.
Proof.
  unfold nat_eq, nat_eq_fix.
  induction n; repeat step || one_step.
Qed.

Lemma nat_eq_complete2:
  forall v,
    is_nat_value v ->
    nat_eq v v ~>* ttrue.
Proof.
  repeat step || is_nat_value_buildable || apply nat_eq_complete.
Qed.

Lemma nat_eq_bool:
  forall v1, is_nat_value v1 ->
    forall v2, is_nat_value v2 ->
      nat_eq v1 v2 ~>* ttrue \/
      nat_eq v1 v2 ~>* tfalse.
Proof.
  induction 1; inversion 1;
    repeat step;
    eauto using nat_eq_complete2.

  - right. unfold nat_eq, nat_eq_fix.
    repeat one_step.

  - right. unfold nat_eq, nat_eq_fix.
    repeat one_step.

  - instantiate_any; steps.
    + left. unfold nat_eq, nat_eq_fix.
      repeat one_step.
    + right. unfold nat_eq, nat_eq_fix.
      repeat one_step.
Qed.

Lemma equivalent_nat_eq_terms:
  forall t1 t2 v1 v2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    wf t1 0 ->
    wf t2 0 ->
    pfv t1 term_var = nil ->
    pfv t2 term_var = nil ->
    t1 ~>* v1 ->
    t2 ~>* v2 ->
    [ nat_eq t1 t2 ≡ nat_eq v1 v2 ].
Proof.
  unfold nat_eq, nat_eq_fix; repeat step || apply equivalent_app;
    try solve [ equivalent_star ];
    eauto 3 using equivalent_refl with step_tactic lia.
Qed.

Lemma equivalent_nat_eq_terms_trans:
  forall t1 t2 v1 v2 t,
    [ nat_eq t1 t2 ≡ t ] ->
    t1 ~>* v1 ->
    t2 ~>* v2 ->
    [ nat_eq v1 v2 ≡ t ].
Proof.
  intros.
  eapply equivalent_trans; try eassumption.
  apply equivalent_sym.
  apply equivalent_nat_eq_terms; steps;
    try solve [ unfold equivalent_terms in *; repeat step || list_utils ].
Qed.

Lemma is_erased_term_nat_eq:
  forall t1 t2,
    is_erased_term t1 ->
    is_erased_term t2 ->
    is_erased_term (nat_eq t1 t2).
Proof.
  unfold nat_eq; steps.
Qed.

Lemma wf_nat_eq:
  forall t1 t2 k,
    wf t1 k ->
    wf t2 k ->
    wf (nat_eq t1 t2) k.
Proof.
  unfold nat_eq; steps; eauto with lia.
Qed.


From Coq Require Import String.

From MatchingLogic Require Import
    Logic
    DerivedOperators_Syntax
    ProofSystem
    ProofMode.MLPM
.

Import
  MatchingLogic.Logic.Notations
  MatchingLogic.DerivedOperators_Syntax.Notations
.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

(** Low-level proof, using only the proof system *)
Lemma ex3_low : forall {Σ : Signature} (Γ : Theory) (A B : Pattern) x,
  well_formed A = true ->
  well_formed B = true ->
  x ∉ free_evars A ->
  x ∉ free_evars B ->
  Γ ⊢ (ex, A^{{evar:x ↦ 0}} and B^{{evar:x↦0}}) ---> ex, A^{{evar:x↦0}}.
Proof.
  intros Σ Γ A B x WFA WFB Hx1 Hx2.
  (* inline proof of ex_quan_monotone *)
  assert (forall A B, well_formed A -> well_formed B -> x ∉ free_evars A -> x ∉ free_evars B ->
    Γ ⊢ A ---> B -> Γ ⊢ (ex, A^{{evar:x↦0}}) ---> ex, B^{{evar:x↦0}}) as H. {
    intros. apply Ex_gen. 1-2: shelve.
    eapply syllogism_meta. 1-3: shelve. exact H3.
    rewrite <- (evar_open_evar_quantify x 0 B0) at 1. 2: shelve.
    unfold evar_open. fold (instantiate (ex, B0^{{evar:x↦0}}) (patt_free_evar x)).
    epose proof (Ex_quan Γ (B0^{{evar:x↦0}}) x _) as H4.
    eapply useGenericReasoning in H4. exact H4. shelve.
  }
  apply (H (A and B)). 1-4: shelve.
  epose proof (pf_conj_elim_l Γ A B _ _).
  eapply useGenericReasoning in H0. exact H0. shelve.
  Unshelve.
  (* 9 well_formed goals *)
  3-7,9-10,13-14: try wf_auto2.
  (* 3 variable membership goals *)
  4,5: cbn; solve_free_evars 1. 2: { apply evar_quantify_no_occurrence. }
  (* 3 ProofInfoLe goals *)
  1-3: try_solve_pile.
Defined.

From Coq Require Import ssreflect ssrfun ssrbool.

Open Scope string_scope.
Open Scope list_scope.
Open Scope ml_scope.

(** Proof using only FOL proof mode *)
Lemma ex3_fol_pm : forall {Σ : Signature} (Γ : Theory) (A B : Pattern) x,
  well_formed A = true ->
  well_formed B = true ->
  x ∉ free_evars A ->
  x ∉ free_evars B ->
  Γ ⊢ (ex, A^{{evar:x ↦ 0}} and B^{{evar:x↦0}}) ---> ex, A^{{evar:x↦0}}.
Proof.
  intros Σ Γ A B x WFA WFB Hx1 Hx2.
  mlIntro "H". mlDestructEx "H" as x.
  mlSimpl. mlExists x. fromMLGoal.
  epose proof (pf_conj_elim_l Γ A _ _ _) as H0.
  eapply useGenericReasoning in H0. exact H0. shelve.
  Unshelve.
  (* 2 well_formedness *)
  1-2: wf_auto2.
  (* 1 ProofInfoLe *)
  try_solve_pile.
Defined.

(** Proof using proof mode *)
Lemma ex3_pm : forall {Σ : Signature} (Γ : Theory) (A B : Pattern) x,
  well_formed A = true ->
  well_formed B = true ->
  x ∉ free_evars A ->
  x ∉ free_evars B ->
  Γ ⊢ (ex, A^{{evar:x ↦ 0}} and B^{{evar:x↦0}}) ---> ex, A^{{evar:x↦0}}.
Proof.
  intros Σ Γ A B x WFA WFB Hx1 Hx2.
  mlIntro "H". mlDestructEx "H" as x.
  mlSimpl. mlDestructAnd "H" as "H0" "H1".
  mlExists x. mlAssumption.
Defined.

Section compute.
  From MatchingLogic.Theories Require Import Definedness_Syntax
                                             Definedness_Semantics
                                             Sorts_Syntax
                                             Sorts_Semantics
                                             Definedness_ProofSystem.
  From stdpp Require Import base fin_sets sets propset finite.

  Inductive Symbols :=
    | sym_import_definedness (d : Definedness_Syntax.Symbols)
    | Zero | Succ (* constructors for Nats *)
    | TT | FF
    | even
  .

  Instance Symbols_eqdec : EqDecision Symbols.
  Proof. solve_decision. Defined.

  #[local]
  Program Instance Symbols_fin : Finite Symbols :=
  {|
    enum := [Zero; Succ; TT ; FF; even;
      sym_import_definedness Definedness_Syntax.definedness] ;
  |}.
  Next Obligation.
    repeat constructor; set_solver.
  Qed.
  Next Obligation.
    destruct x; try set_solver.
    destruct d; set_solver.
  Qed.

  Instance signature : Signature :=
    {| variables := StringMLVariables ;
       ml_symbols := {|
          symbols := Symbols ;
        |}
    |}.

  Instance definedness_syntax : Definedness_Syntax.Syntax :=
    {|
       Definedness_Syntax.inj := sym_import_definedness;
    |}.

  Open Scope string_scope.
  Let X0 := patt_free_evar "X0".
  Let X := patt_free_evar "X".
  Let sym_even := patt_sym even.
  Let sym_succ := patt_sym Succ.
  Let sym_zero := patt_sym Zero.
  Let sym_tt := patt_sym TT.
  Let sym_ff := patt_sym FF.
  (* axioms *)
  Definition defined : Pattern := Definedness_Syntax.axiom AxDefinedness.

  Definition A : Pattern :=
    sym_zero.
  Definition B : Pattern :=
    patt_app sym_succ sym_zero.

  Definition proof3_low := ex3_low ∅ A B "X" ltac:(wf_auto2) ltac:(wf_auto2) ltac:(set_solver) ltac:(set_solver).
  Definition proof3_fol_pm := ex3_fol_pm ∅ A B "X" ltac:(wf_auto2) ltac:(wf_auto2) ltac:(set_solver) ltac:(set_solver).
  Definition proof3_pm := ex3_pm ∅ A B "X" ltac:(wf_auto2) ltac:(wf_auto2) ltac:(set_solver) ltac:(set_solver).

End compute.


Module Option.
  Definition bind {A B} (x : option A) (f : A -> option B) : option B :=
    match x with
    | Some x => f x
    | None => None
    end.

  Definition map {A B} (x : option A) (f : A -> B) : option B :=
    match x with
    | Some x => Some (f x)
    | None => None
    end.

  Definition default {A} (x : option A) (d : A) : A :=
    match x with
    | Some x => x
    | None => d
    end.
End Option.

Module Sum.
  Definition bind {E A B} (x : A + E) (f : A -> B + E) : B + E :=
    match x with
    | inl x => f x
    | inr e => inr e
    end.

  Definition map {E A B} (x : A + E) (f : A -> B) : B + E :=
    match x with
    | inl x => inl (f x)
    | inr e => inr e
    end.

  Definition default {E A} (x : A + E) (d : A) : A :=
    match x with
    | inl x => x
    | inr _ => d
    end.
End Sum.


(*

  Copyright 2014 Cornell University
  Copyright 2015 Cornell University
  Copyright 2016 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Websites: http://nuprl.org/html/verification/
            http://nuprl.org/html/Nuprl2Coq
            https://github.com/vrahli/NuprlInCoq

  Authors: Vincent Rahli

*)

Require Export sequents2.
Require Export sequents_tacs.
Require Export sequents_equality.
Require Export per_props_uni.
Require Export per_props_halts.

(*
   H |- A = B in Type(i)

     By equalityUniverse

     H |- (a1 = a2 in A) = (b1 = b2 in B) in Type(i)
 *)
Definition rule_equality_universe {o}
           (H : @bhyps o)
           (A B a1 a2 b1 b2 : NTerm)
           (i : nat) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality A B (mk_uni i))))
    [
      mk_baresequent H (mk_conclax (mk_equality
                                      (mk_equality a1 a2 A)
                                      (mk_equality b1 b2 B)
                                      (mk_uni i)))
    ]
    [].

Lemma rule_equality_universe_true3 {o} :
  forall lib (H : @bhyps o) A B a1 a2 b1 b2 i,
    rule_true3 lib (rule_equality_universe H A B a1 a2 b1 b2 i).
Proof.
  intros.
  unfold rule_equality_universe, rule_true3, wf_bseq, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros; repnd.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  destruct Hyp  as [ ws1 hyp1 ].
  destseq; allsimpl; proof_irr; GC.

  match goal with
  | [ |- sequent_true2 _ ?s ] => assert (wf_csequent s) as wfc
  end.
  { clear hyp1.
    unfold wf_csequent, closed_type, closed_extract, wf_sequent, wf_concl; simpl.
    dwfseq.
    rw @vswf_hypotheses_nil_eq.
    dands; tcsp.
    introv j; allrw in_app_iff; tcsp. }

  exists wfc.
  unfold wf_csequent, wf_sequent, wf_concl in wfc; allsimpl; repnd; proof_irr; GC.

  (* We prove some simple facts on our sequents *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lsubst_tac.
  rw <- @member_equality_iff.
  pose proof (teq_and_eq_if_equality lib (mk_uni i) A B s1 s2 H wT w1 w2 c1 c0 c2 c3 cT cT0) as q.
  lsubst_tac.
  repeat (autodimp q hyp);[apply tequality_mkc_uni|].

  clear dependent s1.
  clear dependent s2.
  introv hf sim.

  vr_seq_true in hyp1.
  pose proof (hyp1 s1 s2 hf sim) as h; clear hyp1; exrepnd.
  lsubst_tac.
  rw <- @member_equality_iff in h1.
  apply equality_commutes in h0; auto;[].
  apply equality_mkc_equality2_sp_in_uni in h0; sp.
Qed.


(* To be imported qualified. *)
Require
  MathClasses.categories.varieties MathClasses.categories.product MathClasses.theory.forget_algebra MathClasses.theory.forget_variety.
Require Import
  MathClasses.interfaces.abstract_algebra MathClasses.interfaces.universal_algebra MathClasses.theory.ua_homomorphisms MathClasses.misc.workaround_tactics.

Inductive op := mult.

Definition sig: Signature := single_sorted_signature
  (λ o, match o with mult => 2%nat end).

Section laws.
  Global Instance: SgOp (Term0 sig nat tt) :=
    λ x, App sig _ _ _ (App sig _ _ _ (Op sig nat mult) x).

  Local Notation x := (Var sig nat 0%nat tt).
  Local Notation y := (Var sig nat 1%nat tt).
  Local Notation z := (Var sig nat 2%nat tt).

  Import notations.

  Inductive Laws: EqEntailment sig → Prop :=
    | e_mult_assoc: Laws (x & (y & z) === (x & y) & z).
End laws.

Definition theory: EquationalTheory := Build_EquationalTheory sig Laws.
Definition Object := varieties.Object theory.

Definition forget: Object → setoids.Object :=
  @product.project unit
    (λ _, setoids.Object)
    (λ _, _: Arrows setoids.Object) _
    (λ _, _: CatId setoids.Object)
    (λ _, _: CatComp setoids.Object)
    (λ _, _: Category setoids.Object) tt
     ∘ forget_algebra.object theory ∘ forget_variety.forget theory.
  (* todo: too ugly *)

(* Now follow a series of encoding/decoding functions to convert between the
 specialized Monoid/Monoid_Morphism type classes and the universal
 Algebra/InVariety/HomoMorphism type classes instantiated with the above
 signature and theory. *)

Instance encode_operations A `{!SgOp A}: AlgebraOps sig (λ _, A) :=
  λ o, match o with mult => (&) end.

Section decode_operations.
  Context `{AlgebraOps theory A}.
  Global Instance: SgOp (A tt) := algebra_op mult.
End decode_operations.

Section encode_variety_and_ops.
  Context A `{SemiGroup A}.

  Global Instance encode_algebra_and_ops: Algebra sig _.
  Proof. constructor; intros []; simpl; apply _. Qed.

  Global Instance encode_variety_and_ops: InVariety theory (λ _, A).
  Proof.
   constructor. apply _.
   intros ? [] ?; simpl; unfold algebra_op; simpl.
   apply associativity.
  Qed.

  Definition object: Object := varieties.object theory (λ _, A).
End encode_variety_and_ops.

Lemma encode_algebra_only `{!AlgebraOps theory A} `{∀ u, Equiv (A u)} `{!SemiGroup (A tt)}: Algebra theory A .
Proof. constructor; intros []; simpl in *; try apply _. Qed.

Global Instance decode_variety_and_ops `{InVariety theory A}: SemiGroup (A tt).
Proof with simpl; auto.
 pose proof (λ law lawgood x y z, variety_laws law lawgood (λ s n,
  match s with tt => match n with 0 => x | 1 => y | _ => z end end)) as laws.
 constructor; try apply _.
  intro. apply_simplified (laws _ e_mult_assoc).
 apply_simplified (algebra_propers mult)...
Qed.

Lemma encode_morphism_only
  `{AlgebraOps theory A} `{∀ u, Equiv (A u)}
  `{AlgebraOps theory B} `{∀ u, Equiv (B u)}
  (f: ∀ u, A u → B u) `{!SemiGroup_Morphism (f tt)}: HomoMorphism sig A B f.
Proof.
 pose proof (sgmor_a (f:=f tt)).
 pose proof (sgmor_b (f:=f tt)).
 constructor.
    intros []. apply _.
   intros []; simpl.
   apply preserves_sg_op.
  apply (encode_algebra_only).
 apply encode_algebra_only.
Qed.

Lemma encode_morphism_and_ops `{SemiGroup_Morphism A B f}:
  @HomoMorphism sig (λ _, A) (λ _, B) _ _ ( _) ( _) (λ _, f).
Proof. intros. apply encode_morphism_only; assumption. Qed.

Lemma decode_morphism_and_ops
  `{InVariety theory x} `{InVariety theory y} `{!HomoMorphism theory x y f}:
    SemiGroup_Morphism (f tt).
Proof.
 constructor; try apply _.
 apply (preserves theory x y f mult).
Qed.

Instance id_sg_morphism `{SemiGroup A}: SemiGroup_Morphism (@id A).
Proof. repeat (split; try apply _); easy. Qed.

(* Finally, we use these encoding/decoding functions to specialize some universal results: *)
Section specialized.
  Context `{Equiv A} `{SgOp A} `{Equiv B} `{SgOp B} `{Equiv C} `{SgOp C}
    (f : A → B) (g : B → C).

  Instance compose_sg_morphism:
    SemiGroup_Morphism f → SemiGroup_Morphism g → SemiGroup_Morphism (g ∘ f).
  Proof.
    intros. pose proof (encode_morphism_and_ops (f:=f)) as P.
    pose proof (encode_morphism_and_ops (f:=g)) as Q.
    pose proof (@compose_homomorphisms theory _ _ _ _ _ _ _ _ _ _ _ P Q) as PP.
    pose proof (sgmor_a (f:=f)). pose proof (sgmor_b (f:=f)). pose proof (sgmor_b (f:=g)).
    apply (@decode_morphism_and_ops _ _ _ _ _ _ _ _ _ PP).
  Qed.

  Instance invert_sg_morphism:
    ∀ `{!Inverse f}, Bijective f → SemiGroup_Morphism f → SemiGroup_Morphism (f⁻¹).
  Proof.
    intros. pose proof (encode_morphism_and_ops (f:=f)) as P.
    pose proof (@invert_homomorphism theory _ _ _ _ _ _ _ _ _ _ P) as Q.
    pose proof (sgmor_a (f:=f)). pose proof (sgmor_b (f:=f)).
    apply (@decode_morphism_and_ops _ _ _ _ _ _ _ _ _ Q).
  Qed.
End specialized.

Hint Extern 4 (SemiGroup_Morphism (_ ∘ _)) => class_apply @compose_sg_morphism : typeclass_instances.
Hint Extern 4 (SemiGroup_Morphism (_⁻¹)) => class_apply @invert_sg_morphism : typeclass_instances.


Section InductionPrinciple.
  Variable P : nat -> Type.

  Require Import Omega.

  Definition nat_xrect_aux:
    (forall n, (forall m, m<n -> P m) -> P n) ->
    forall n, (forall m, m<n -> P m).
  Proof.
    induction n as [|n IHn].
    - intros m H.
      omega.
    - intros m H.
      apply X.
      intros m0 H0.
      apply IHn.
      omega.
  Qed.

  Definition weaken:
    (forall n, (forall m, m<n -> P m)) -> (forall n, P n).
  Proof.
    intros X n.
    apply (X (S n) n).
    omega.
  Qed.

  Theorem nat_xrect:
    (forall n, (forall m, m<n -> P m) -> P n) -> forall n, P n.
  Proof.
    intros X n.
    apply weaken.
    apply nat_xrect_aux.
    assumption.
  Qed.

End InductionPrinciple.

Section EInductionPrinciple.
  Require Import erasable.
  Import ErasableNotation.
  Notation EN := (##nat).
  Definition Elt := liftP2 lt.

  Theorem Elt_wf : well_founded Elt.
  Proof.
    intros y.
    unerase.
    induction y as [y H] using nat_xrect.
    constructor.
    intros ? (x & ? & ? & ? & ?).
    simplify_hyps.
    apply H.
    assumption.
  Qed.

  Variable P : EN -> Type.

  Definition enat_xrect := well_founded_induction_type Elt_wf.

End EInductionPrinciple.

Extraction Inline weaken.
Extraction Inline nat_xrect_aux.
Extraction Inline nat_xrect.
Extraction Inline enat_xrect.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06

This file provides a specification of finite multiset data-type along
with specification of operations on multisets.
*)

Set Implicit Arguments.

From CoLoR Require RelExtras.
From Coq Require Import Min Relations.
From Coq Require Import Psatz.

Module Type MultisetCore.

  Declare Module Export Sid : RelExtras.Eqset_dec.

  Parameter Multiset : Type.

  Parameter mult : A -> Multiset -> nat.

  Parameter meq : relation Multiset.

  Parameter empty : Multiset.

  Parameter singleton : A -> Multiset.

  Parameter union : Multiset -> Multiset -> Multiset.

  Parameter intersection : Multiset -> Multiset -> Multiset.

  Parameter diff : Multiset -> Multiset -> Multiset.

Declare Scope msets_scope.
  Notation "X =mul= Y" := (meq X Y) (at level 70) : msets_scope.
  Notation "X <>mul Y" := (~meq X Y) (at level 50) : msets_scope.
  Notation "{{ x }}" := (singleton x) (at level 5) : msets_scope.
  Notation "X + Y" := (union X Y) : msets_scope.
  Notation "X - Y" := (diff X Y) : msets_scope.
  Notation "X # Y" := (intersection X Y) (at level 50, left associativity)
                      : msets_scope.
  Notation "x / M" := (mult x M) : msets_scope.

  Delimit Scope msets_scope with msets.
  Open Scope msets_scope.
  Bind Scope msets_scope with Multiset.

  Section Specification.

    Variables (M N P : Multiset) (x y z : A) (n : nat).

    Parameter mult_eqA_compat: x =A= y -> x/M = y/M.

    Parameter meq_multeq: M =mul= N -> (forall x, x/M = x/N).

    Parameter multeq_meq: (forall x, x/M = x/N) -> M =mul= N.

    Parameter empty_mult: x/empty = 0.

    Parameter union_mult: x/(M+N) = (x/M + x/N)%nat.

    Parameter diff_mult: x/(M-N) = (x/M - x/N)%nat.

    Parameter intersection_mult: x/(M#N) = Nat.min (x/M) (x/N).

    Parameter singleton_mult_in: x =A= y -> x/{{y}} = 1.

    Parameter singleton_mult_notin: ~x =A= y -> x/{{y}} = 0.

    Parameter mset_ind_type: forall P : Multiset -> Type,
        P empty -> (forall M a, P M -> P (M + {{a}})) -> forall M, P M.

  End Specification.

 #[export]  Hint Resolve mult_eqA_compat
               meq_multeq
               multeq_meq
               empty_mult
               union_mult
               diff_mult
               intersection_mult
               singleton_mult_in
               singleton_mult_notin : multisets.

  #[export] Hint Rewrite empty_mult
               union_mult
	       diff_mult
	       intersection_mult using trivial : multisets.

End MultisetCore.

Section Multiset_IntersectionAsDifference.

  Variables
    (A : Type) (Multiset : Type) (meq : relation Multiset)
    (mult : A -> Multiset -> nat)
    (diff : Multiset -> Multiset -> Multiset)
    (diff_mult : forall M N x, mult x (diff M N) = mult x M - mult x N).

  Definition inter_as_diff x y := diff x (diff x y).

  Lemma inter_as_diff_ok : forall M N x,
    mult x (inter_as_diff M N) = Nat.min (mult x M) (mult x N).

  Proof.
    intros M N x. unfold inter_as_diff. rewrite !diff_mult.
     lia.
  Qed.

End Multiset_IntersectionAsDifference.


(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Axiom Max_is_ge : forall (x:Z) (y:Z), (x <= (Zmax x y))%Z /\
  (y <= (Zmax x y))%Z.

Axiom Max_is_some : forall (x:Z) (y:Z), ((Zmax x y) = x) \/ ((Zmax x y) = y).

Axiom Min_is_le : forall (x:Z) (y:Z), ((Zmin x y) <= x)%Z /\
  ((Zmin x y) <= y)%Z.

Axiom Min_is_some : forall (x:Z) (y:Z), ((Zmin x y) = x) \/ ((Zmin x y) = y).

Axiom Max_x : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmax x y) = x).

Axiom Max_y : forall (x:Z) (y:Z), (x <= y)%Z -> ((Zmax x y) = y).

Axiom Min_x : forall (x:Z) (y:Z), (x <= y)%Z -> ((Zmin x y) = x).

Axiom Min_y : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmin x y) = y).

Axiom Max_sym : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmax x y) = (Zmax y x)).

Axiom Min_sym : forall (x:Z) (y:Z), (y <= x)%Z -> ((Zmin x y) = (Zmin y x)).

Inductive list (a:Type) :=
  | Nil : list a
  | Cons : a -> (list a) -> list a.
Set Contextual Implicit.
Implicit Arguments Nil.
Unset Contextual Implicit.
Implicit Arguments Cons.

Set Implicit Arguments.
Fixpoint length (a:Type)(l:(list a)) {struct l}: Z :=
  match l with
  | Nil  => 0%Z
  | Cons _ r => (1%Z + (length r))%Z
  end.
Unset Implicit Arguments.

Axiom Length_nonnegative : forall (a:Type), forall (l:(list a)),
  (0%Z <= (length l))%Z.

Axiom Length_nil : forall (a:Type), forall (l:(list a)),
  ((length l) = 0%Z) <-> (l = (Nil:(list a))).

Parameter char : Type.

Definition word  := (list char).

Inductive dist : (list char) -> (list char) -> Z -> Prop :=
  | dist_eps : (dist (Nil:(list char)) (Nil:(list char)) 0%Z)
  | dist_add_left : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (Cons a w1) w2 (n + 1%Z)%Z)
  | dist_add_right : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist w1 (Cons a w2) (n + 1%Z)%Z)
  | dist_context : forall (w1:(list char)) (w2:(list char)) (n:Z), (dist w1
      w2 n) -> forall (a:char), (dist (Cons a w1) (Cons a w2) n).

Definition min_dist(w1:(list char)) (w2:(list char)) (n:Z): Prop := (dist w1
  w2 n) /\ forall (m:Z), (dist w1 w2 m) -> (n <= m)%Z.

Set Implicit Arguments.
Fixpoint infix_plpl (a:Type)(l1:(list a)) (l2:(list a)) {struct l1}: (list
  a) :=
  match l1 with
  | Nil  => l2
  | Cons x1 r1 => (Cons x1 (infix_plpl r1 l2))
  end.
Unset Implicit Arguments.

Axiom Append_assoc : forall (a:Type), forall (l1:(list a)) (l2:(list a))
  (l3:(list a)), ((infix_plpl l1 (infix_plpl l2
  l3)) = (infix_plpl (infix_plpl l1 l2) l3)).

Axiom Append_l_nil : forall (a:Type), forall (l:(list a)), ((infix_plpl l
  (Nil:(list a))) = l).

Axiom Append_length : forall (a:Type), forall (l1:(list a)) (l2:(list a)),
  ((length (infix_plpl l1 l2)) = ((length l1) + (length l2))%Z).

Set Implicit Arguments.
Fixpoint mem (a:Type)(x:a) (l:(list a)) {struct l}: Prop :=
  match l with
  | Nil  => False
  | Cons y r => (x = y) \/ (mem x r)
  end.
Unset Implicit Arguments.

Axiom mem_append : forall (a:Type), forall (x:a) (l1:(list a)) (l2:(list a)),
  (mem x (infix_plpl l1 l2)) <-> ((mem x l1) \/ (mem x l2)).

Axiom mem_decomp : forall (a:Type), forall (x:a) (l:(list a)), (mem x l) ->
  exists l1:(list a), exists l2:(list a), (l = (infix_plpl l1 (Cons x l2))).

Set Implicit Arguments.
Fixpoint last_char(a:char) (u:(list char)) {struct u}: char :=
  match u with
  | Nil  => a
  | Cons c uqt => (last_char c uqt)
  end.
Unset Implicit Arguments.

Set Implicit Arguments.
Fixpoint but_last(a:char) (u:(list char)) {struct u}: (list char) :=
  match u with
  | Nil  => (Nil:(list char))
  | Cons c uqt => (Cons a (but_last c uqt))
  end.
Unset Implicit Arguments.

(* YOU MAY EDIT THE CONTEXT BELOW *)

(* DO NOT EDIT BELOW *)

Theorem first_last_explicit : forall (u:(list char)) (a:char),
  ((infix_plpl (but_last a u) (Cons (last_char a u) (Nil:(list
  char)))) = (Cons a u)).
(* YOU MAY EDIT THE PROOF BELOW *)
simple induction u; simpl.
reflexivity.
intros.
rewrite (H a).
reflexivity.
Qed.
(* DO NOT EDIT BELOW *)


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.MinimumLogic.Syntax.
Require Logic.MinimumLogic.Semantics.Kripke.
Require Logic.MinimumLogic.Semantics.Trivial.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import KripkeModelFamilyNotation.
Import KripkeModelNotation_Intuitionistic.

Section SemanticEquiv.

Context {L: Language}
        {minL: MinimumLanguage L}
        {MD: Model}
        {SM: Semantics L MD}.

Lemma eqR_KripkeIntuitionistic: @Kripke.KripkeIntuitionisticSemantics L MD (unit_kMD _) tt eq SM.
Proof.
  constructor.
  intros; hnf; intros.
  hnf in H; subst.
  auto.
Qed.

Lemma Trivial2Kripke {tpSM: Trivial.TrivialMinimumSemantics L MD SM}:
  @Kripke.KripkeMinimumSemantics L minL MD (unit_kMD _) tt eq SM.
Proof.
  constructor.
  + intros.
    change (@Kdenotation L MD (unit_kMD _) tt SM) with denotation.
    rewrite Trivial.denote_impp.
    split; unfold Included, Ensembles.In; intros.
    - hnf; intros.
      hnf in H0; subst.
      apply H, H1.
    - hnf; intros; apply (H x0); auto.
      reflexivity.
Qed.

End SemanticEquiv.


(**************************************************************************)
(*   Mechanised Framework for Local Interactions & Distributed Algorithms *)
(*   T. Balabonski, P. Courtieu, L. Rieg, X. Urbain                       *)
(*   PACTOLE project                                                      *)
(*                                                                        *)
(*   This file is distributed under the terms of the CeCILL-C licence.    *)
(*                                                                        *)
(**************************************************************************)

(**************************************************************************)
(** Mechanised Framework for Local Interactions & Distributed Algorithms
    T. Balabonski, P. Courtieu, L. Rieg, X. Urbain

    PACTOLE project

    This file is distributed under the terms of the CeCILL-C licence      *)
(**************************************************************************)

Require Import Utf8_core.
Require Import SetoidList.
Require Import SetoidDec.
Require Import Rbase.
Require Import Pactole.Util.FSets.FSetInterface.
Require Import Pactole.Util.FSets.FSetFacts.
Require Import Pactole.Util.Coqlib.
Require Import Pactole.Core.Identifiers.
Require Import Pactole.Core.State.
Require Import Pactole.Core.Configuration.
Require Import Pactole.Observations.Definition.
Require Import Pactole.Spaces.RealMetricSpace.
Require Import Pactole.Spaces.Similarity.
Require Pactole.Observations.SetObservation.
Coercion Bijection.section : Bijection.bijection >-> Funclass.

Section LimitedSetObservation.

Context `{State}.
Context (RVS : @RealVectorSpace _ _ (location_EqDec)).
Context {RMS : @RealMetricSpace _ _ _ RVS}.
Context `{Names}.

Implicit Type config : configuration.

Instance limited_set_observation (radius : R) : Observation.
simple refine {|
  observation := set location;
  obs_from_config config state :=
    SetObservation.make_set (List.filter
                               (fun x => Rle_bool (dist x (get_location state)) radius)
                               (List.map get_location (config_list config)));
  obs_is_ok s config state :=
    forall l, In l s <-> InA equiv l (List.map get_location (config_list config))
                         /\ (dist l (get_location state) <= radius)%R |}; autoclass; [|].
Proof.
* intros config1 config2 Hconfig pt1 pt2 Hpt.
  apply SetObservation.make_set_compat, eqlistA_PermutationA_subrelation.
  f_equiv.
  + intros ? ? Heq. now rewrite Heq, Hpt.
  + apply (@map_eqlistA_compat _ _ equiv equiv _ get_location); autoclass; [].
    now apply config_list_compat.
* intros config pt x. rewrite SetObservation.make_set_spec, filter_InA, Rle_bool_true_iff.
  + reflexivity.
  + intros ? ? Heq. f_equal. now rewrite Heq.
Defined.

Local Notation "'from_config' radius" := (@obs_from_config _ _ _ _ (limited_set_observation radius)) (at level 1).

Lemma obs_from_config_map : forall radius (sim : similarity location),
  forall Psim config pt,
  map (sim_f sim) (from_config radius config pt)
  == from_config (Similarity.zoom sim * radius)
                 (map_config (lift (existT precondition sim Psim)) config)
                 ((lift (existT precondition sim Psim)) pt).
Proof using .
repeat intro. unfold obs_from_config, limited_set_observation.
rewrite config_list_map; try (now apply lift_compat; simpl; apply Bijection.section_compat); [].
rewrite map_map, 2 filter_map, <- SetObservation.make_set_map, map_map; autoclass; [].
apply SetObservation.make_set_compat, eqlistA_PermutationA_subrelation.
assert (Hequiv : (@equiv _ state_Setoid ==> @equiv _ location_Setoid)%signature
          (fun x => sim (get_location x)) (fun x => get_location (lift (existT precondition sim Psim) x))).
{ intros pt1 pt2 Heq. now rewrite get_location_lift, Heq. }
apply (map_extensionalityA_compat _ Hequiv). f_equiv.
intros ? ? Heq. rewrite 2 get_location_lift. simpl.
rewrite sim.(Similarity.dist_prop), Heq, Rle_bool_mult_l; trivial; [].
apply Similarity.zoom_pos.
Qed.

Property pos_in_config : forall radius config state id,
  ((dist (get_location (config id)) (get_location state)) <= radius)%R ->
  In (get_location (config id)) (from_config radius config state).
Proof using .
intros radius config state id. unfold obs_from_config. simpl.
rewrite SetObservation.make_set_spec, filter_InA, InA_map_iff; autoclass; [|].
+ intro Hle. repeat esplit; auto; [|].
  - apply config_list_InA. now exists id.
  - now rewrite Rle_bool_true_iff.
+ intros ? ? Heq. now rewrite Heq.
Qed.

Property obs_from_config_In : forall radius config state l,
  In l (from_config radius config state)
  <-> exists id, get_location (config id) == l /\ (dist l (get_location state) <= radius)%R.
Proof using .
intros radius config state l. split; intro Hin.
+ unfold obs_is_ok, obs_from_config, limited_set_observation in *. simpl in *.
  rewrite SetObservation.make_set_spec, filter_InA in Hin.
  - rewrite config_list_spec, map_map, InA_map_iff, Rle_bool_true_iff in Hin;
    autoclass || firstorder.
  - intros ? ? Heq. now rewrite Heq.
+ destruct Hin as [id [Hid Hle]]. rewrite <- Hid. apply pos_in_config. now rewrite Hid.
Qed.

End LimitedSetObservation.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall A B C Q X : Universe, ((wd_ B C /\ (wd_ A B /\ (wd_ C Q /\ (wd_ B Q /\ (wd_ Q A /\ (wd_ A C /\ (col_ Q X A /\ (col_ B C Q /\ col_ A B C)))))))) -> col_ A Q B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj15synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (mult (mult (Succ lv0) lv1) lv2) (plus (mult lv0 (mult lv1 lv2)) (mult lv1 lv2))).
Admitted.
QuickChick conj15synthconj5.


Require Import BinPos.
Require Import ZArith.
Require Import FMapPositive.
Require Import String.

Require Import Setoid.

Set Implicit Arguments.

Inductive Map (Key Elt : Type) : Type :=
| mapEmpty
| mapItem (k : Key) (v : Elt)
| mapJoin (m1 m2 : Map Key Elt)
.
Arguments mapEmpty [Key Elt].

Infix "|->" := mapItem (at level 50, no associativity).
Infix ":*" := mapJoin (at level 60, right associativity).

Inductive MapEquiv {K E : Type} : Map K E -> Map K E -> Prop :=
| equivUnit : forall m, MapEquiv (m :* mapEmpty) m
| equivComm : forall m1 m2, MapEquiv (m1 :* m2) (m2 :* m1)
| equivAssoc : forall m1 m2 m3, MapEquiv ((m1 :* m2) :* m3) (m1 :* (m2 :* m3))

| equivJoin : forall l1 r1 l2 r2, MapEquiv l1 l2 -> MapEquiv r1 r2 -> MapEquiv (l1 :* r1) (l2 :* r2)
| equivTrans : forall m1 m2 m3, MapEquiv m1 m2 -> MapEquiv m2 m3 -> MapEquiv m1 m3
| equivSym : forall m1 m2, MapEquiv m1 m2 -> MapEquiv m2 m1
| equivRefl : forall m, MapEquiv m m
.
Infix "~=" := MapEquiv (at level 70, no associativity).

Definition equivJoinL {K V} (r : Map K V) l1 l2 pfl : l1 :* r ~= l2 :* r :=
  equivJoin pfl (equivRefl r).
Definition equivJoinR {K V} (l : Map K V) r1 r2 pfr :  l :* r1 ~= l :* r2 :=
  equivJoin (equivRefl l) pfr.

Add Parametric Relation (K E : Type) : (Map K E) MapEquiv
  reflexivity proved by equivRefl
  symmetry proved by equivSym
  transitivity proved by equivTrans
  as map_equiv_rel.

Add Parametric Morphism K E : (@mapJoin K E) with
  signature MapEquiv ==> MapEquiv ==> MapEquiv as map_join_mor.
Proof. auto using equivJoin. Qed.

Lemma equivUnitL : forall {K V} (m : Map K V), MapEquiv (mapEmpty :* m) m.
intros. rewrite equivComm. apply equivUnit.
Qed.

Lemma equivComAssoc : forall {K V} (m1 m2 m3 : Map K V), m1 :* m2 :* m3 ~= m2 :* m1 :* m3.
intros. rewrite <- equivAssoc, (equivComm m1 m2), equivAssoc. reflexivity. Qed.

Inductive label : Set :=
  | EPlus
  | EMinus
  | EDiv
  | BLe
  | BNot
  | BAnd
  | Skip
  | Seq
  | SAssign
  | HAssign
  | SIf
  | SWhile
  | Jump
  .

Inductive hook_fun : Set :=
  | Z_Z_Z : (Z -> Z -> Z) -> hook_fun
  | Z_Z_bool : (Z -> Z -> bool) -> hook_fun
  | bool_bool : (bool -> bool) -> hook_fun
  .

Definition hook l :=
  match l with
    | EPlus => Some (Z_Z_Z Zplus)
    | EMinus => Some (Z_Z_Z Zminus)
    | BLe => Some (Z_Z_bool Z.leb)
    | BNot => Some (bool_bool negb)
    | _ => None
  end.

Definition is_strict1 l :=
  match l with
  | EPlus | EMinus
  | EDiv  | BLe
  | BNot  | BAnd
  | SIf => true
  | _ => false
  end.

Definition is_strict2 l :=
  match l with
  | EPlus | EMinus
  | EDiv  | BLe
  | SAssign | HAssign => true
  | _ => false
  end.

Definition is_sequential l :=
  match l with
    | BLe => true
    | _ => false
  end.

Inductive Ast : Set :=
  | AId (x : string)
  | ABool (b : bool)
  | AInt (i : Z)
  | AApp (l : label) (args : list Ast)
  .

Definition isVal a :=
  match a with
    | AInt _ => true
    | ABool _ => true
    | _ => false
  end.

Inductive kitem : Set :=
  | KAst (a : Ast)
  | KFreezer (f : Ast -> kitem)
  .

Definition kra : kitem -> list kitem -> list kitem := @cons kitem.
Definition kdot : list kitem := nil.

Structure kcfg := KCfg {
  kcell : list kitem;
  store : Map string Z;
  heap : Map Z Z;
  labels : Map string Ast
  }.


(*
- commutativity
- X x 1 ~ X
- iso pointwise -> iso
 *)

Require Import UniMath.Foundations.PartD.
Require Import UniMath.Foundations.Propositions.
Require Import UniMath.Foundations.Sets.
(* Require Import UniMath.SubstitutionSystems.FromBindingSigsToMonads_Summary. *)
Require Import UniMath.SubstitutionSystems.BindingSigToMonad.
Require Import UniMath.SubstitutionSystems.Signatures.
Require Import UniMath.SubstitutionSystems.SignatureCategory.
Require Import UniMath.SubstitutionSystems.BinProductOfSignatures.

Require Import UniMath.CategoryTheory.Core.Prelude.
Require Import UniMath.CategoryTheory.categories.HSET.All.

Require Import UniMath.CategoryTheory.Epis.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.bincoproducts.
Require Import UniMath.CategoryTheory.limits.coproducts.
Require Import UniMath.CategoryTheory.limits.binproducts.
Require Import UniMath.CategoryTheory.limits.terminal.
Require Import UniMath.CategoryTheory.EpiFacts.

Open Scope cat.

Section BinProdComplements.
  Context {C : category}.

  Definition BinProductOfArrows_eq (CC : BinProducts C) a b c d (f f' : a --> c) (g g' : b --> d)
    : f = f' → g = g' →
      BinProductOfArrows _ _ _ f g = BinProductOfArrows _ (CC _ _) (CC _ _) f' g'.
  Proof.
    induction 1.
    induction 1.
    apply idpath.
  Qed.

  Definition BinProduct_commutative {a b : C} (bpab : BinProduct _ a b) (bpba : BinProduct _ b a)
    : C ⟦BinProductObject _ bpab, BinProductObject _ bpba ⟧
   := BinProductArrow C bpba (BinProductPr2 C bpab) (BinProductPr1 C bpab).

  Lemma BinProduct_commutative_id_commute {a b : C} (bpab : BinProduct _ a b) (bpba : BinProduct _ b a):
    BinProduct_commutative bpab bpba · BinProduct_commutative bpba bpab =
  identity (BinProductObject C bpab).
  Proof.
    etrans; [apply precompWithBinProductArrow|].
    apply pathsinv0.
    apply BinProduct_endo_is_identity.
    - etrans;[apply BinProductPr1Commutes|].
      apply BinProductPr2Commutes.
    - etrans;[apply BinProductPr2Commutes|].
      apply BinProductPr1Commutes.
  Qed.
  Definition BinProduct_commutative_iso {a b : C} (bpab : BinProduct _ a b)
             (bpba : BinProduct _ b a)
    : iso (BinProductObject _ bpab) (BinProductObject _ bpba ).
    eapply make_iso.
    use is_iso_from_is_z_iso.
    eapply make_is_z_isomorphism.
    split; apply BinProduct_commutative_id_commute.
  Defined.
  Local Notation BPO := (BinProductObject _).

  Definition BinProduct_pw_iso_mor {a b a' b' : C} (bp_ab : BinProduct _ a b)
             (bp_ab' : BinProduct _ a' b') (isoa : iso a a') (isob : iso b b') :
    C ⟦ BPO bp_ab, BPO bp_ab'⟧ :=
    BinProductOfArrows C bp_ab' bp_ab isoa isob.

  Lemma BinProduct_pw_eq_id  {a b a' b' : C} (bp_ab : BinProduct _ a b)
             (bp_ab' : BinProduct _ a' b') (isoa : iso a a') (isob : iso b b') :
    BinProduct_pw_iso_mor bp_ab bp_ab' isoa isob · BinProduct_pw_iso_mor bp_ab' bp_ab
                          (iso_inv_from_iso isoa)
                          (iso_inv_from_iso isob) =
    identity (BPO bp_ab).
  Proof.
   etrans;[apply postcompWithBinProductArrow|].
   apply pathsinv0.
   cbn.
   do 2 rewrite <- assoc.
   do 2 rewrite iso_inv_after_iso.
   do 2 rewrite id_right.
   apply  BinProduct_endo_is_identity; [apply BinProductPr1Commutes| apply BinProductPr2Commutes].
  Qed.
  Definition BinProduct_pw_iso_is_inverse {a b a' b' : C} (bp_ab : BinProduct _ a b)
             (bp_ab' : BinProduct _ a' b') (isoa : iso a a') (isob : iso b b') :
      is_inverse_in_precat (BinProduct_pw_iso_mor bp_ab bp_ab' isoa isob)
    (BinProduct_pw_iso_mor bp_ab' bp_ab (iso_inv_from_iso isoa) (iso_inv_from_iso isob)).
  Proof.
    - use make_is_inverse_in_precat.
      + apply BinProduct_pw_eq_id.
      +
        etrans.
        {
        apply cancel_precomposition.
        apply map_on_two_paths; eapply pathsinv0; apply iso_inv_iso_inv.
        }
        apply BinProduct_pw_eq_id.
  Defined.
  Definition BinProduct_pw_iso {a b a' b' : C} (bp_ab : BinProduct _ a b)
             (bp_ab' : BinProduct _ a' b') (isoa : iso a a') (isob : iso b b') :
    iso (BPO bp_ab) (BPO bp_ab').
  Proof.
    eapply make_iso.
    eapply is_iso_from_is_z_iso.
    eapply make_is_z_isomorphism.
    unshelve apply BinProduct_pw_iso_is_inverse; assumption.
  Defined.

  Lemma BinProductWith1_is_inverse (T : Terminal C) {a} (bp : BinProduct _ a (TerminalObject T)) :
    is_inverse_in_precat (BinProductPr1 _ bp) (BinProductArrow _ bp (identity _) (TerminalArrow _ _)).
  Proof.
    use make_is_inverse_in_precat.
    + apply pathsinv0.
      apply BinProduct_endo_is_identity.
      * rewrite <- assoc.
        rewrite BinProductPr1Commutes.
        apply id_right.
      * etrans; [apply TerminalArrowUnique|].
        apply pathsinv0.
        apply  TerminalArrowUnique.
    + apply BinProductPr1Commutes.
  Qed.

  Definition BinProductWith1_iso (T : Terminal C) {a} (bp : BinProduct _ a (TerminalObject T))  :
    iso (BPO bp) a.
  Proof.
    eapply make_iso.
    eapply is_iso_from_is_z_iso.
    eapply make_is_z_isomorphism.
    apply BinProductWith1_is_inverse.
  Defined.

End BinProdComplements.