(* A context language provides operations on programs taken from type
   [cl_program] and contexts taken from type [cl_context]. *)
Class context_language (cl_program: Type) (cl_context: Type): Type :=
  {
    cl_insert: cl_context -> cl_program -> cl_program;
    cl_compatible: cl_context -> cl_program -> Prop;
    cl_complete: cl_program -> Prop;
    cl_stat_eq: cl_program -> cl_program -> Prop;
    cl_beh_eq: cl_program -> cl_program -> Prop;
    (* Put relevant hypotheses here *)
    cl_stat_eq_compatible_complete:
      forall P Q,
        cl_stat_eq P Q ->
        (forall A,
           cl_compatible A P /\ cl_complete (cl_insert A P) ->
           cl_compatible A Q /\ cl_complete (cl_insert A Q))
  }.

Definition full_abstraction
           {source_program source_context: Type}
           {target_program target_context: Type}

           (source_cl: context_language source_program source_context)
           (target_cl: context_language target_program target_context)
           (cl_compile: source_program -> target_program): Prop :=
  forall P Q,
    cl_stat_eq P Q ->
    ((forall A, cl_compatible A P /\ cl_complete (cl_insert A P) ->
                cl_beh_eq (cl_insert A P) (cl_insert A Q))
     <->
     (forall a, cl_compatible a (cl_compile P) /\ cl_complete (cl_insert a (cl_compile P)) ->
                cl_beh_eq (cl_insert a (cl_compile P)) (cl_insert a (cl_compile Q)))).

(* A context language can be structured. It is the case when programs
   and contexts can have a shape. The shape characterizes the
   structure of the program or context. *)
Class structured_context_language
      {scl_program scl_context: Type}

      (scl_cl: context_language scl_program scl_context)
      (scl_shape: Type)
: Type :=
  {
    scl_program_has_shape: scl_shape -> scl_program -> Prop;
    scl_program_fully_defined: scl_program -> scl_shape -> Prop;
    scl_context_has_shape: scl_shape -> scl_context -> Prop;
    scl_context_fully_defined: scl_context -> scl_shape -> Prop
  }.

Definition structured_full_abstraction
           {source_scl_program source_scl_context: Type}
           {target_scl_program target_scl_context: Type}
           {source_scl_cl: context_language source_scl_program source_scl_context}
           {target_scl_cl: context_language target_scl_program target_scl_context}
           {scl_shape: Type}

           (source_scl: structured_context_language source_scl_cl scl_shape)
           (target_scl: structured_context_language target_scl_cl scl_shape)
           (scl_compile: source_scl_program -> target_scl_program): Prop :=
  forall (s: scl_shape) (PP QQ: source_scl_program),
    cl_stat_eq PP QQ ->
    scl_program_has_shape s PP -> scl_program_fully_defined PP s ->
    scl_program_has_shape s QQ -> scl_program_fully_defined QQ s ->
    ((forall AA,
        scl_context_has_shape s AA -> scl_context_fully_defined AA s ->
        cl_compatible AA PP ->
        cl_complete (cl_insert AA PP) ->
        cl_beh_eq (cl_insert AA PP) (cl_insert AA QQ))
     <->
     (forall aa,
        scl_context_has_shape s aa ->
        cl_compatible aa (scl_compile PP) ->
        cl_complete (cl_insert aa (scl_compile PP)) ->
        cl_beh_eq (cl_insert aa (scl_compile PP)) (cl_insert aa (scl_compile QQ)))).

(* A structured context language can be a structured variant of
   another (unstructured) context language. In this case one can
   "destruct" programs and contexts, i.e. forget their structure. *)
Class structured_variant
      {cl_program cl_context: Type}
      {scl_program scl_context: Type}
      {scl_cl: context_language scl_program scl_context}
      {scl_shape: Type}

      (cl: context_language cl_program cl_context)
      (scl: structured_context_language scl_cl scl_shape)
: Type :=
  {
    sv_destruct_program: scl_program -> cl_program;
    sv_destruct_context: scl_context -> cl_context
    (* Put relevant hypotheses here *)
  }.

(* There can be a link between (1) a compiler between structured
   languages and (2) a compiler between their unstructured
   variants. *)
Class structural_link
      {source_cl_program source_cl_context: Type}
      {source_scl_program source_scl_context: Type}
      {source_scl_cl: context_language source_scl_program source_scl_context}
      {target_cl_program target_cl_context: Type}
      {target_scl_program target_scl_context: Type}
      {target_scl_cl: context_language target_scl_program target_scl_context}
      {scl_shape: Type}
      {source_cl: context_language source_cl_program source_cl_context}
      {source_scl: structured_context_language source_scl_cl scl_shape}
      {target_cl: context_language target_cl_program target_cl_context}
      {target_scl: structured_context_language target_scl_cl scl_shape}

      (source_sv: structured_variant source_cl source_scl)
      (target_sv: structured_variant target_cl target_scl)
      (cl_compile: source_cl_program -> target_cl_program)
      (scl_compile: source_scl_program -> target_scl_program)
: Type :=
  {
    (* Put relevant hypotheses here *)
    (*forall PP, sv_destruct_program (scl_compile PP)
               =
               cl_compile (sv_destruct_program PP) *)
  }.

(* When there is a structural link between compilers, full abstraction
   for the unstructured one follows from structured full abstraction
   for the structured compiler. *)
Conjecture structured_full_abstraction_implies_full_abstraction : forall
        {source_cl_program source_cl_context: Type}
        {source_scl_program source_scl_context: Type}
        {source_scl_cl: context_language source_scl_program source_scl_context}
        {target_cl_program target_cl_context: Type}
        {target_scl_program target_scl_context: Type}
        {target_scl_cl: context_language target_scl_program target_scl_context}
        {scl_shape: Type}
        {source_cl: context_language source_cl_program source_cl_context}
        {source_scl: structured_context_language source_scl_cl scl_shape}
        {target_cl: context_language target_cl_program target_cl_context}
        {target_scl: structured_context_language target_scl_cl scl_shape}

        (source_sv: structured_variant source_cl source_scl)
        (target_sv: structured_variant target_cl target_scl),
  forall cl_compile scl_compile,
      structural_link source_sv target_sv cl_compile scl_compile ->
      structured_full_abstraction source_scl target_scl scl_compile ->
      full_abstraction source_cl target_cl cl_compile.


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 conj20synthconj6 : forall  (lv0 : natural) (lv1 : natural), (@eq natural (Succ (plus (mult lv0 (Succ lv1)) lv1)) (plus (mult lv1 (Succ lv0)) (Succ lv0))).
Admitted.
QuickChick conj20synthconj6.


Require Import Bool.
Require Import Metalib.Metatheory.
Require Import List.
(** syntax *)
Definition i : Set := nat.
Definition b : Set := bool.

Inductive typ : Set :=  (*r types *)
 | t_int : typ (*r int *)
 | t_arrow (A:typ) (B:typ) (*r function types *)
 | t_dyn : typ (*r dynamic type *)
 | t_pro (A:typ) (B:typ).

Inductive st : Set :=  (*r input type or projection label *)
 | st_ty (A:typ).

 Inductive exp : Set :=  (*r expressions *)
 | e_var_b (_:nat) (*r variables *)
 | e_var_f (x:var) (*r variables *)
 | e_lit (i5:i) (*r lit *)
 | e_abs (e:exp) (*r abstractions *)
 | e_app (e1:exp) (e2:exp) (*r applications *)
 | e_add (e1:exp) (e2:exp) (*r additions *)
 | e_anno (e:exp) (A:typ) (*r annotation *)
 | e_pro (e1:exp) (e2:exp)
 | e_l (e:exp)
 | e_r (e:exp).

 Inductive dirflag : Set :=  (*r checking direction *)
 | Inf : dirflag
 | Chk : dirflag.

 Definition ctx : Set := list ( atom * typ ).

 Definition ls : Set := list st.

 (* EXPERIMENTAL *)
 (** auxiliary functions on the new list types *)
 (** library functions *)
 (** subrules *)
 (** arities *)
 (** opening up abstractions *)
 Fixpoint open_exp_wrt_exp_rec (k:nat) (e_5:exp) (e__6:exp) {struct e__6}: exp :=
    match e__6 with
    | (e_var_b nat) =>
        match lt_eq_lt_dec nat k with
          | inleft (left _) => e_var_b nat
          | inleft (right _) => e_5
          | inright _ => e_var_b (nat - 1)
        end
    | (e_var_f x) => e_var_f x
    | (e_lit i5) => e_lit i5
    | (e_abs e) => e_abs (open_exp_wrt_exp_rec (S k) e_5 e)
    | (e_app e1 e2) => e_app (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
    | (e_anno e A) => e_anno (open_exp_wrt_exp_rec k e_5 e) A
    | (e_add e1 e2) => e_add (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
    | (e_pro e1 e2) => e_pro (open_exp_wrt_exp_rec k e_5 e1) (open_exp_wrt_exp_rec k e_5 e2)
    | (e_l e) => e_l (open_exp_wrt_exp_rec k e_5 e)
    | (e_r e) => e_r (open_exp_wrt_exp_rec k e_5 e)
  end.

Definition open_exp_wrt_exp e_5 e__6 := open_exp_wrt_exp_rec 0 e__6 e_5.

(** terms are locally-closed pre-terms *)
(** definitions *)

(* defns LC_exp *)
Inductive lc_exp : exp -> Prop :=    (* defn lc_exp *)
 | lc_e_var_f : forall (x:var),
     (lc_exp (e_var_f x))
 | lc_e_lit : forall (i5:i),
     (lc_exp (e_lit i5))
 | lc_e_abs : forall (e:exp),
      ( forall x , lc_exp  (open_exp_wrt_exp e (e_var_f x))  )  ->
     (lc_exp (e_abs e))
 | lc_e_app : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_app e1 e2))
 | lc_e_anno : forall (e:exp) (A:typ),
     (lc_exp e) ->
     (lc_exp (e_anno e A))
 | lc_e_add : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_add e1 e2))
 | lc_e_pro : forall (e1 e2:exp),
     (lc_exp e1) ->
     (lc_exp e2) ->
     (lc_exp (e_pro e1 e2))
 | lc_e_l : forall (e:exp),
     (lc_exp e) ->
     (lc_exp (e_l e))
 | lc_e_r : forall (e:exp),
     (lc_exp e) ->
     (lc_exp (e_r e)).

Inductive nlam : exp -> Prop :=
 | nl_var_f : forall (x:var),
     nlam (e_var_f x)
 | nl_lit : forall (i5:i),
     nlam (e_lit i5)
 | nl_app : forall (e1 e2:exp),
     nlam (e_app e1 e2)
 | nl_anno : forall (e:exp) (A:typ),
     nlam (e_anno e A)
 | nl_add : forall (e1 e2:exp),
     nlam (e_add e1 e2)
 | nl_pro : forall (e1 e2:exp),
     nlam (e_pro e1 e2)
 | nl_l : forall (e:exp),
     nlam (e_l e)
 | nl_r : forall (e:exp),
     nlam (e_r e).

(** free variables *)
Fixpoint fv_exp (e_5:exp) : vars :=
  match e_5 with
  | (e_var_b nat) => {}
  | (e_var_f x) => {{x}}
  | (e_lit i5) => {}
  | (e_abs e) => (fv_exp e)
  | (e_app e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_anno e A) => (fv_exp e)
  | (e_add e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_pro e1 e2) => (fv_exp e1) \u (fv_exp e2)
  | (e_l e) => (fv_exp e)
  | (e_r e) => (fv_exp e)
end.

(** substitutions *)
Fixpoint subst_exp (e_5:exp) (x5:var) (e__6:exp) {struct e__6} : exp :=
  match e__6 with
  | (e_var_b nat) => e_var_b nat
  | (e_var_f x) => (if eq_var x x5 then e_5 else (e_var_f x))
  | (e_lit i5) => e_lit i5
  | (e_abs e) => e_abs (subst_exp e_5 x5 e)
  | (e_app e1 e2) => e_app (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_anno e A) => e_anno (subst_exp e_5 x5 e) A
  | (e_add e1 e2) => e_add (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_pro e1 e2) => e_pro (subst_exp e_5 x5 e1) (subst_exp e_5 x5 e2)
  | (e_l e) => e_l (subst_exp e_5 x5 e)
  | (e_r e) => e_r (subst_exp e_5 x5 e)
end.

(* principal types for values*)
Fixpoint principal_type (v:exp) : typ :=
  match v with
  | (e_lit i5) => t_int
  | (e_anno e A) => A
  | (e_abs e) => (t_arrow t_dyn t_dyn)
  | (e_pro v1 v2) => t_pro (principal_type v1) (principal_type v2)
  | _ => t_dyn
  end.

(* Fixpoint trans (e:exp) : exp :=
    match e with
    | (e_var_b nat) => e_var_b nat
    | (e_var_f x) => (e_var_f x)
    | (e_lit i5) => e_lit i5
    | (e_abs e) => e_abs (trans (e))
    | (e_anno e1 A) => (e_anno (trans e1) A)
    | (e_app e1 e2) => e_app (trans e1) (trans e2)
    | (e_add e1 e2) => e_add (trans e1) (trans e2)
    end. *)

Inductive sval : exp -> Prop :=    (* defn fval *)
 | sval_abs : forall (e:exp) A B,
     lc_exp (e_abs e) ->
     sval  (e_anno (e_abs e) (t_arrow A B)).

Inductive ssval : exp -> Prop :=    (* defn fval *)
 | ssval_abs : forall (e:exp) A B,
     lc_exp (e_abs e) ->
     ssval  (e_anno (e_abs e) (t_arrow A B))
 | ssval_lit : forall (i5:i),
     ssval (e_lit i5)
 | ssval_pro : forall s1 s2,
     ssval s1 ->
     ssval s2 ->
     ssval  (e_pro s1 s2).

Inductive ssvalue : exp -> Prop :=
  | ssvalue_abs : forall (e:exp) A B,
     lc_exp (e_abs e) ->
     ssvalue  (e_anno (e_abs e) (t_arrow A B))
 | ssvalue_lit : forall (i5:i),
     ssvalue (e_lit i5)
 | ssvalue_absd : forall (e:exp),
     lc_exp (e_abs e) ->
     ssvalue  (e_anno (e_abs e) t_dyn)
 | ssvalue_pro : forall s1 s2,
     ssvalue s1 ->
     ssvalue s2 ->
     ssvalue  (e_pro s1 s2)
.

(* defns Values *)
Inductive value : exp -> Prop :=    (* defn value *)
 | value_pro : forall s A,
    ssval s ->
    value (e_anno s A).

Inductive walue : exp -> Prop :=
 | walue_val : forall v,
     value v ->
     walue v
 | walue_abs : forall e ,
     lc_exp (e_abs e) ->
     walue (e_abs e).

(* defns Consistency *)
Inductive sim : typ -> typ -> Prop :=    (* defn sim *)
 | S_i :
     sim t_int t_int
 | S_arr : forall (A B C D:typ),
     sim C A ->
     sim B D ->
     sim (t_arrow A B) (t_arrow C D)
 | S_dynl : forall (A:typ),
     sim t_dyn A
 | S_dynr : forall (A:typ),
     sim A t_dyn
 | S_pro : forall (A B C D:typ),
     sim A C ->
     sim B D ->
     sim (t_pro A B) (t_pro C D).

Inductive pattern : typ -> typ -> Prop :=
 | pa_fun : forall A1 A2,
    pattern (t_arrow A1 A2) (t_arrow A1 A2)
 | pa_dyn :
    pattern t_dyn (t_arrow t_dyn t_dyn).

Inductive pattern_pro : typ -> typ -> Prop :=
 | ppa_fun : forall A1 A2,
    pattern_pro (t_pro A1 A2) (t_pro A1 A2)
 | ppa_dyn :
    pattern_pro t_dyn (t_pro t_dyn t_dyn).

(* defns Typing *)
Inductive Typing : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | Typ_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
     Typing G (e_lit i5) Inf t_int
 | Typ_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
     Typing G (e_var_f x) Inf A
 | Typ_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (A1 A2:typ),
      ( forall x , x \notin  L  -> Typing  (cons ( x , A1 )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk A2 )  ->
      pattern A (t_arrow A1 A2) ->
     Typing G (e_abs e) Chk A
 | Typ_sugar : forall (L:vars) (G:ctx) (e:exp),
     ( forall x , x \notin  L  -> Typing  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn )  ->
    Typing G (e_abs e) Inf (t_arrow t_dyn t_dyn)
 | Typ_app : forall (G:ctx) (e1 e2:exp) (A A1 A2:typ),
     Typing G e1 Inf A ->
     pattern A (t_arrow A1 A2) ->
     Typing G e2 Chk A1 ->
     Typing G (e_app e1 e2) Inf A2
 | Typ_anno : forall (G:ctx) (e:exp) (A:typ),
     Typing G e Chk A ->
     Typing G  ( (e_anno e A) )  Inf A
 | Typ_add : forall (G:ctx) (e1 e2:exp),
     Typing G e1 Chk t_int ->
     Typing G e2 Chk t_int ->
     Typing G (e_add e1 e2) Inf t_int
 | Typ_sim : forall (G:ctx) (e:exp) (B A:typ),
     Typing G e Inf A ->
     sim A B ->
     nlam e ->
     Typing G e Chk B
 | Typ_pro : forall (G:ctx) (e1 e2:exp) (A1 A2:typ),
     Typing G e1 Inf A1 ->
     Typing G e2 Inf A2 ->
     Typing G (e_pro e1 e2) Inf (t_pro A1 A2)
 | Typ_l : forall (G:ctx) (e:exp) (A A1 A2:typ),
     Typing G e Inf A ->
     pattern_pro A (t_pro A1 A2) ->
     Typing G  ( (e_l e) )  Inf A1
 | Typ_r : forall (G:ctx) (e:exp) (A A1 A2:typ),
     Typing G e Inf A ->
     pattern_pro A (t_pro A1 A2) ->
     Typing G  ( (e_r e) )  Inf A2.

Inductive gtyping : ctx -> exp -> dirflag -> typ -> Prop :=    (* defn Typing *)
 | gtyp_lit : forall (G:ctx) (i5:i),
      uniq  G  ->
      gtyping G (e_lit i5) Inf t_int
 | gtyp_var : forall (G:ctx) (x:var) (A:typ),
      uniq  G  ->
      binds  x A G  ->
      gtyping G (e_var_f x) Inf A
 | gtyp_abs : forall (L:vars) (G:ctx) (A:typ) (e:exp) (B:typ),
      ( forall x , x \notin  L  -> gtyping  (cons ( x , A )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk B )  ->
      gtyping G (e_abs e) Chk (t_arrow A B)
 | gtyp_sugar : forall (L:vars) (G:ctx) (e:exp),
      ( forall x , x \notin  L  -> gtyping  (cons ( x , t_dyn )  G )   ( open_exp_wrt_exp e (e_var_f x) )  Chk t_dyn )  ->
     gtyping G (e_abs e) Inf (t_arrow t_dyn t_dyn)
 | gtyp_app : forall (G:ctx) (e1 e2:exp) (B A:typ),
     gtyping G e1 Inf (t_arrow A B) ->
     gtyping G e2 Chk A ->
     gtyping G (e_app e1 e2) Inf B
 | gtyp_anno : forall (G:ctx) (e:exp) (A:typ),
     gtyping G e Chk A ->
     gtyping G  ( (e_anno e A) )  Inf A
 | gtyp_sim : forall (G:ctx) (e:exp) (B A:typ),
     gtyping G e Inf A ->
     sim A B ->
     nlam e ->
     gtyping G e Chk B.

Inductive simpl_item : Type :=
     | sappCtxL : exp -> simpl_item
     | sappCtxR : exp -> simpl_item
     | saddCtxL : exp -> simpl_item
     | saddCtxR : exp -> simpl_item
     | sproCtxL : exp -> simpl_item
     | sproCtxR : exp -> simpl_item
     | slCtx : simpl_item
     | srCtx : simpl_item.

Inductive ctx_item : Type :=
     | appCtxL : exp -> ctx_item
     | appCtxR : exp -> ctx_item
     | annoCtx : typ -> ctx_item.

Inductive simpl_wf : simpl_item -> Prop :=
     | swf_appl : forall (e : exp),
                     lc_exp e ->
                    simpl_wf (sappCtxL e)
     | swf_appr : forall (v : exp),
                    walue v ->
                    simpl_wf (sappCtxR v)
     | swf_addl : forall (e : exp),
                     lc_exp e ->
                    simpl_wf (saddCtxL e)
     | swf_addr : forall (v : exp),
                    value v ->
                    simpl_wf (saddCtxR v)
     | swf_prol : forall (e : exp),
                     lc_exp e ->
                    simpl_wf (sproCtxL e)
     | swf_pror : forall (v : exp),
                    walue v ->
                    simpl_wf (sproCtxR v)
     | swf_l :
                    simpl_wf (slCtx)
     | swf_r :
                    simpl_wf (srCtx).

Definition FLike A := not (A = t_dyn) /\ not (A = (t_arrow t_dyn t_dyn)) /\ (sim A (t_arrow t_dyn t_dyn)).

Inductive Ground : typ -> Prop :=    (* defn Ground *)
 | Ground_lit :
     Ground t_int
 | Ground_dyn :
     Ground  (t_arrow t_dyn t_dyn) .

(* defns Values *)
Inductive gvalue : exp -> Prop :=    (* defn value *)
 | gvalue_lit : forall (i5:i),
     gvalue (e_lit i5)
 | gvalue_abs : forall  (e:exp),
     lc_exp (e_abs e) ->
     gvalue (e_abs e)
 | gvalue_fanno : forall (v:exp) (A B C D:typ),
     gvalue v ->
      (t_arrow C D)  =   (principal_type   ( v )  )   ->
     gvalue (e_anno v (t_arrow A B))
 | gvalue_dyn : forall (v:exp),
     Ground   (principal_type  v )   ->
     gvalue v ->
     gvalue  ( (e_anno v t_dyn) ).

Inductive gwalue : exp -> Prop :=
| gwalue_val : forall v,
    gvalue v ->
    gwalue v
| gwalue_abs : forall e ,
    lc_exp (e_abs e) ->
    gwalue (e_abs e).

Inductive wellformed : ctx_item -> Prop :=
     | wf_appCtxL : forall (e : exp),
                    lc_exp e ->
                    wellformed (appCtxL e)
     | wf_appCtxR : forall (v : exp),
                    gvalue v ->
                    wellformed (appCtxR v)
     | wf_annoCtx : forall (A : typ),
                    wellformed (annoCtx A).

Definition simpl_fill (EE : simpl_item) (e : exp) : exp :=
     match EE with
     | sappCtxL e2 => e_app e e2
     | sappCtxR v1 => e_app v1 e
     | saddCtxL e2 => e_add e e2
     | saddCtxR v1 => e_add v1 e
     | sproCtxL e2 => e_pro e e2
     | sproCtxR v1 => e_pro v1 e
     | slCtx => e_l e
     | srCtx => e_r e
     end.

Definition fill (E : ctx_item) (e : exp) : exp :=
     match E with
     | appCtxL e2 => e_app e e2
     | appCtxR v1 => e_app v1 e
     | annoCtx A => e_anno e A
     end.

Inductive res : Type :=
     | Expr  : exp -> res
     | Blame :  res.

(* defns Semantics *)

Inductive TypedReduce : exp -> typ -> res -> Prop :=    (* defn TypedReduce *)
 | TReduce_sim : forall (e:exp) (A:typ) (B:typ),
     lc_exp e ->
     ssval e ->
     sim (principal_type e) B ->
     TypedReduce  ( (e_anno e A) ) B  (Expr (e_anno e B) )
 | TReduce_simp : forall (e:exp) (A:typ) (B:typ),
     lc_exp e ->
     ssval e ->
     not(sim (principal_type e) B) ->
     TypedReduce  ( (e_anno e A) ) B  Blame.

Inductive TypeLists : exp -> list typ -> res -> Prop :=    (* defn TypeLists *)
 | TLists_base : forall (v v':exp) (A:typ),
     lc_exp v ->
     TypedReduce v A (Expr v') ->
     TypeLists  v (cons A nil)  (Expr v')
 | TLists_baseb : forall (A:typ) (v:exp),
     lc_exp v ->
     TypedReduce v A Blame ->
     TypeLists  v (cons A nil) Blame
 | TLists_cons : forall (A:typ) (B: list typ) v1 v2 r,
     lc_exp v1 ->
     TypedReduce v1 A (Expr v2) ->
     TypeLists  v2 B r ->
     TypeLists  v1 (cons A B) r
 | TLists_consb : forall (A:typ) (B: list typ) v1,
     lc_exp v1 ->
     TypedReduce v1 A Blame ->
     TypeLists  v1 (cons A B) Blame.

Inductive gTypedReduce : exp -> typ -> res -> Prop :=    (* defn TypedReduce *)
 | gTReduce_abs: forall v A B C D,
   sim (t_arrow C D) (t_arrow A B) ->
   principal_type v = (t_arrow C D) ->
   gTypedReduce v (t_arrow A B) (Expr (e_anno v (t_arrow A B)))
  | gTReduce_v : forall (v:exp),
   Ground(principal_type v) ->
   gTypedReduce v t_dyn (Expr (e_anno v t_dyn))
 | gTReduce_lit : forall (i5:i),
     gTypedReduce (e_lit i5) t_int (Expr (e_lit i5))
 | gTReduce_dd : forall (v:exp),
     lc_exp v ->
     gTypedReduce  ( (e_anno v t_dyn) )  t_dyn  (Expr  (e_anno v t_dyn) )
 | gTReduce_anyd : forall (v:exp),
      FLike (principal_type  v )  ->
     gTypedReduce v t_dyn  (Expr (e_anno  ( (e_anno v (t_arrow t_dyn t_dyn)) )  t_dyn) )
 | gTReduce_dyna : forall (v:exp) (A:typ),
      FLike A ->
     sim (principal_type v) A ->
    gTypedReduce  ( (e_anno v t_dyn) )  A  (Expr (e_anno v A) )
 | gTReduce_vany : forall (v:exp),
   gTypedReduce (e_anno v t_dyn) (principal_type  v) (Expr v)
 | gTReduce_blame : forall (v:exp) (A:typ),
      not (sim A (principal_type  v ))  ->
     gTypedReduce (e_anno v t_dyn) A Blame.

Inductive gTypeLists : exp -> list typ -> res -> Prop :=    (* defn TypeLists *)
 | gTLists_base : forall (v v':exp) (A:typ),
     lc_exp v ->
     gTypedReduce v A (Expr v') ->
     gTypeLists  v (cons A nil)  (Expr v')
 | gTLists_baseb : forall (A:typ) (v:exp),
     lc_exp v ->
     gTypedReduce v A Blame ->
     gTypeLists  v (cons A nil) Blame
 | gTLists_cons : forall (A:typ) (B: list typ) v1 v2 r,
     lc_exp v1 ->
     gTypedReduce v1 A (Expr v2) ->
     gTypeLists  v2 B r ->
     gTypeLists  v1 (cons A B) r
 | gTLists_consb : forall (A:typ) (B: list typ) v1,
     lc_exp v1 ->
     gTypedReduce v1 A Blame ->
     gTypeLists  v1 (cons A B) Blame.

Fixpoint erase (v:exp) : exp :=
  match v with
  | (e_abs e) => (e_anno (e_abs e) (t_arrow t_dyn t_dyn))
  | (e_anno s A) => s
  | _ => v
  end.

Inductive step : exp -> res -> Prop :=
   | Step_abs : forall e A B,
      lc_exp (e_abs e) ->
      step (e_anno (e_abs e) (t_arrow A B)) (Expr (e_anno (e_anno (e_abs e) (t_arrow A B)) (t_arrow A B)))
   | Step_lit : forall i,
      step (e_lit i) (Expr (e_anno (e_lit i) t_int))
   | Step_absd : forall e,
      lc_exp (e_abs e) ->
      step (e_anno (e_abs e) t_dyn) (Expr (e_anno (e_anno (e_abs e) (t_arrow t_dyn t_dyn)) t_dyn))
   (* | Step_pro : forall s1 s2 A B,
      ssval s1 ->
      ssval s2 ->
      step (e_pro (e_anno s1 A) (e_anno s2 B)) (Expr (e_anno (e_pro s1 s2) (t_pro A B))) *)
   | Step_pro : forall v1 v2,
      walue v1 ->
      walue v2 ->
      step (e_pro v1 v2) (Expr (e_anno (e_pro (erase v1) (erase v2)) (t_pro (principal_type v1) (principal_type v2))))
   | do_step E e1 e2 :
    simpl_wf E ->
    step e1 ( Expr e2 ) ->
    step (simpl_fill E e1) (Expr (simpl_fill E e2))
  | blame_step E e1 :
    simpl_wf E ->
    step e1 Blame ->
    step (simpl_fill E e1) Blame
   | Step_anno : forall (e e':exp ) (A: typ),
     step e (Expr e') ->
     not (value (e_anno e A)) ->
     step (e_anno e A) (Expr (e_anno e' A))
   | Step_annob : forall (e:exp ) (A: typ),
     step e Blame ->
     step (e_anno e A) Blame
   | Step_absr : forall (e:exp) v A1 A B,
     lc_exp (e_abs e) ->
     principal_type v = A1 ->
     pattern A1 (t_arrow A B) ->
     walue v ->
     step (e_app v (e_abs e))  (Expr (e_app v (e_anno (e_abs e) A)))
   | Step_beta : forall A (A1 A2:typ) (e:exp) (B1 B2:typ) (v v': exp),
     lc_exp (e_abs e) ->
     walue v ->
     TypeLists v (cons A2 (cons A1 nil)) (Expr v') ->
     pattern A (t_arrow A2 B2) ->
     step (e_app (e_anno (e_anno (e_abs e) (t_arrow A1 B1)) A)  v)  (Expr (e_anno (e_anno (open_exp_wrt_exp  e v' ) B1) B2) )
  | Step_dyn : forall v1 (v: exp),
     value v ->
     walue v1 ->
     TypedReduce v1 (t_arrow t_dyn t_dyn) Blame ->
     step (e_app v1 v)  Blame
   | Step_betap : forall A (A1 A2:typ) (e:exp) (B1 B2:typ) (v: exp),
     lc_exp (e_abs e) ->
     walue v ->
     TypeLists v (cons A2 (cons A1 nil)) Blame ->
     pattern A (t_arrow A2 B2) ->
     step (e_app (e_anno (e_anno (e_abs e) (t_arrow A1 B1)) A) v)  Blame
  | Step_annov : forall (v:exp) (A:typ) r,
     walue v ->
     TypedReduce v A r ->
     step (e_anno v A) r
  | Step_addl : forall v1 v2,
     walue v1 ->
     walue v2 ->
     TypedReduce v1 t_int Blame ->
     step (e_add v1 v2) Blame
   | Step_addr : forall i5 v2 A,
     walue v2 ->
     TypedReduce v2 t_int Blame ->
     step (e_add (e_anno (e_lit i5) A) v2) Blame
  | Step_addb : forall i1 i2 A B,
     step (e_add (e_anno (e_lit i1) A) (e_anno (e_lit i2) B)) (Expr (e_anno (e_lit (i1 + i2)) t_int))
  | Step_lp : forall v,
      walue v ->
      TypedReduce v (t_pro t_dyn t_dyn) Blame ->
      step (e_l v) Blame
  | Step_l : forall s1 s2 A A1 A2,
      value (e_anno (e_pro s1 s2) A) ->
      pattern_pro A (t_pro A1 A2) ->
      step (e_l (e_anno (e_pro s1 s2) A)) (Expr (e_anno s1 A1))
  | Step_rp : forall v,
      walue v ->
      TypedReduce v (t_pro t_dyn t_dyn) Blame ->
      step (e_r v) Blame
  | Step_r : forall s1 s2 A A1 A2,
      value (e_anno (e_pro s1 s2) A) ->
      pattern_pro A (t_pro A1 A2) ->
      step (e_r (e_anno (e_pro s1 s2) A)) (Expr (e_anno s2 A2))
  (* | Step_al : forall e e2,
      lc_exp (e_abs e) ->
      step (e_pro (e_abs e) e2) (Expr (e_pro (e_anno (e_anno (e_abs e) (t_arrow t_dyn t_dyn)) (t_arrow t_dyn t_dyn)) e2))
  | Step_ar : forall e v1,
      lc_exp (e_abs e) ->
      value v1 ->
      step (e_pro v1 (e_abs e)) (Expr (e_pro v1 (e_anno (e_abs e) (t_arrow t_dyn t_dyn)))) *)
  | Step_nbeta : forall  (e:exp) (v v': exp),
      lc_exp (e_abs e) ->
      walue v ->
      TypedReduce v t_dyn (Expr v') ->
      step (e_app (e_abs e)  v)  (Expr (e_anno (open_exp_wrt_exp  e v' ) t_dyn) ).

Inductive gstep : exp -> res -> Prop :=    (* defn step *)
  | gdo_step E e1 e2 :
       wellformed E ->
       gstep e1 (Expr e2 ) ->
      gstep (fill E e1) (Expr (fill E e2))
  | gblame_step E e1:
      wellformed E ->
      gstep e1 Blame ->
      gstep (fill E e1) Blame
  | gStep_nbeta : forall (e:exp) (v v' : exp),
    lc_exp (e_abs e) ->
    gvalue v ->
    gTypedReduce v t_dyn (Expr v') ->
    gstep (e_app (e_abs e) v)  (Expr (e_anno (open_exp_wrt_exp  e v' ) t_dyn) )
 | gStep_beta : forall (A:typ) (e:exp) (B:typ) (v v' : exp),
      lc_exp (e_abs e) ->
      gvalue v ->
      gTypedReduce v A (Expr v') ->
      gstep (e_app (e_anno (e_abs e) (t_arrow A B)) v)  (Expr (e_anno (open_exp_wrt_exp  e v' ) B) )
 | gStep_betap : forall (v1:exp) (A B:typ) (v2 v2':exp),
      gvalue  ( (e_anno v1 (t_arrow A B)) )  ->
      gTypedReduce v2 A Blame ->
      gvalue v2 ->
      gstep (e_app (e_anno v1 (t_arrow A B)) v2) Blame
 | gStep_annov : forall (v:exp) (A:typ) (v':res),
     gvalue v ->
     gTypedReduce v A v' ->
     not (gvalue (e_anno v A)) ->
     gstep (e_anno v A) v'
 | gStep_abeta : forall (v1:exp) (A B C D:typ) (v2 v2':exp),
     gvalue (e_anno v1 (t_arrow A B))  ->
     gTypedReduce v2 C (Expr v2') ->
     gvalue v2 ->
     gstep (e_app (e_anno (e_anno v1 (t_arrow A B)) (t_arrow C D))  v2) (Expr (e_anno (e_app (e_anno v1 (t_arrow A B)) v2') D)).

(* defns type precision *)
Inductive tpre : typ -> typ -> Prop :=    (* defn sim *)
 | tp_i :
     tpre t_int t_int
 | tp_dyn : forall (A:typ),
     tpre A t_dyn
 | tp_abs : forall (A B C D:typ),
     tpre A C ->
     tpre B D ->
     tpre (t_arrow A B) (t_arrow C D)
 | tp_pro : forall (A B C D:typ),
     tpre A C ->
     tpre B D ->
     tpre (t_pro A B) (t_pro C D).

(* defns expression precision *)
Inductive epre : exp -> exp -> Prop :=    (* defn sim *)
 | ep_var : forall (x:var),
    epre (e_var_f x) (e_var_f x)
 | ep_i i:
    epre (e_lit i) (e_lit i)
 | ep_abs : forall (e1 e2:exp) (L:vars),
     ( forall x , x \notin  L  ->
      epre  ( open_exp_wrt_exp e1 (e_var_f x) )   ( open_exp_wrt_exp e2 (e_var_f x) )  )  ->
     epre (e_abs e1) (e_abs e2)
 | ep_app : forall (e1 e2 e1' e2':exp),
     epre e1 e1' ->
     epre e2 e2' ->
     epre (e_app e1 e2) (e_app e1' e2')
 | ep_add : forall (e1 e2 e1' e2':exp),
     epre e1 e1' ->
     epre e2 e2' ->
     epre (e_add e1 e2) (e_add e1' e2')
 | ep_anno : forall (A B:typ) (e1 e2:exp),
     tpre A B ->
     epre e1 e2 ->
     epre (e_anno e1 A) (e_anno e2 B)
 | ep_pro : forall (e1 e2 e1' e2':exp),
     epre e1 e1' ->
     epre e2 e2' ->
     epre (e_pro e1 e2) (e_pro e1' e2')
 | ep_l : forall  (e1 e2:exp),
     epre e1 e2 ->
     epre (e_l e1) (e_l e2)
 | ep_r : forall  (e1 e2:exp),
     epre e1 e2 ->
     epre (e_r e1) (e_r e2).

Inductive steps : exp -> res -> Prop :=
  | step_refl e e':
    step e (Expr e') ->
    steps e (Expr e')
  | step_n e t' e':
    step e (Expr e') ->
    steps e' (Expr t') ->
    steps e  (Expr t')
  | step_nb e e':
    step e (Expr e') ->
    steps e' Blame ->
    steps e  Blame

  | step_b e:
    step e (Blame) ->
    steps e (Blame).

(* Inductive steps : exp -> res -> Prop :=
  | step_refl e:
    steps e (Expr e)

  | step_n e t' e':
    step e (Expr e') ->
    steps e' (Expr t') ->
    steps e  (Expr t')
  | step_nb e e':
    step e (Expr e') ->
    steps e' Blame ->
    steps e  Blame

  | step_b e:
    step e (Blame) ->
    steps e (Blame). *)

Inductive gsteps : exp -> res -> Prop :=
  | gstep_refl e:
    gsteps e (Expr e)

  | gstep_n e t' e':
    gstep e (Expr e') ->
    gsteps e' (Expr t') ->
    gsteps e  (Expr t')

  | gstep_nb e e':
    gstep e (Expr e') ->
    gsteps e' Blame ->
    gsteps e  Blame

  | gstep_b e:
    gstep e (Blame) ->
    gsteps e (Blame).

(** infrastructure *)
Hint Constructors ssvalue pattern pattern_pro ssval value nlam walue gvalue Ground gvalue gwalue sval sim TypedReduce gTypedReduce
TypeLists gTypeLists wellformed simpl_wf step gstep steps gsteps tpre epre Typing gtyping lc_exp : core.


Require Import RelationClasses.

Axiom R : Prop -> Prop -> Prop.
Declare Instance : Reflexive R.

Class bar := { x : False }.
Record foo := { a : Prop ; b : bar }.

Definition default_foo (a0 : Prop) `{b : bar} : foo := {| a := a0 ; b := b |}.

Goal exists k, R k True.
Proof.
eexists.
evar (b : bar).
let e := match goal with |- R ?e _ => constr:(e) end in
unify e (a (default_foo True)).
subst b.
reflexivity.


Require Coq.extraction.Extraction.
Extraction Language Haskell.
From Coq Require Export String.

Inductive day : Type :=
  | monday
  | tuesday
  | wednesday
  | thursday
  | friday
  | saturday
  | sunday.

Definition next_weekday (d: day) : day :=
  match d with
  | monday => thursday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Compute (next_weekday friday).
Compute (next_weekday (next_weekday saturday)).

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = thursday.
Proof. simpl. reflexivity. Qed.

Extraction next_weekday.

Inductive bool : Type :=
  | true
  | false.

Definition negb (b:bool) : bool :=
match b with
| true => false
| false => true
end.

Definition andb (a: bool) (b: bool) : bool :=
match a with
| true => b
| false => false
end .

Definition orb (a: bool) (b: bool) : bool :=
match a with
| true => true
| false => b
end.

Example test_orb1: (orb true false) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb2: (orb false false) = false.
Proof. simpl. reflexivity. Qed.
Example test_orb3: (orb false true) = true.
Proof. simpl. reflexivity. Qed.
Example test_orb4: (orb true true) = true.
Proof. simpl. reflexivity. Qed.

Compute negb(true).

Notation "a && b":= (andb a b).
Notation "a || b":= (orb a b).

Example test_orb5: false || false || true = true.
Proof. simpl. reflexivity. Qed.

Definition negb' (b : bool) : bool :=
if b then false
else true.

Definition andb' (a: bool) (b: bool) : bool :=
if a then b
else false.

Definition orb' (a: bool) (b: bool) : bool :=
if a then true
else b.

Definition nandb (b1:bool) (b2:bool) : bool :=
  negb (andb b1 b2).
Example test_nandb1: (nandb true false) = true.
Proof. reflexivity. Qed.
Example test_nandb2: (nandb false false) = true.
Proof. reflexivity. Qed.
Example test_nandb3: (nandb false true) = true.
Proof. reflexivity. Qed.
Example test_nandb4: (nandb true true) = false.
Proof. reflexivity. Qed.

Definition andb3 (b1:bool) (b2:bool) (b3:bool) : bool :=
  (andb b1 (andb b2 b3)).
Example test_andb31: (andb3 true true true) = true.
Proof. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. reflexivity. Qed.

Check true.
Check true : bool.
Check (negb true) : bool.
Check negb : bool -> bool.
Check andb.

Inductive rgb : Type :=
  | red
  | green
  | blue.

Inductive color : Type :=
  | black
  | white
  | primary (p : rgb).

Definition monochrome (c: color) : bool :=
  match c with
  | black => true
  | white => true
  | primary _ => false
end.

Definition isred (c: color) : bool :=
  match c with
  | black => false
  | white => false
  | primary red => true
  | primary _ => false
end.

Module Playground.
  Definition b : rgb := blue.
End Playground.

Definition b : bool := true.

Check Playground.b : rgb.
Check b : bool.

Module TuplePlayground.
Inductive bit : Type :=
  | B0
  | B1.

Inductive nybble : Type :=
  | bits (b0 b1 b2 b3: bit).

Check (bits B1 B0 B1 B0).

Definition all_zero (nb: nybble) : bool :=
  match nb with
  | (bits B0 B0 B0 B0) => true
  | (bits _ _ _ _) => false
  end.

Check (all_zero (bits B1 B0 B1 B0)).

End TuplePlayground.

Module NatPlayground.

Inductive nat : Type :=
  | O
  | S (n : nat).

Inductive nat' : Type :=
  | stop
  | tick (n : nat').

Definition pred (n : nat) : nat :=
  match n with
  | O => O
  | S n' => n'
  end.

End NatPlayground.

Check (S (S (S (S O)))).

Definition minustwo (n : nat) : nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Compute (minustwo 4).

Fixpoint even (n : nat) : bool :=
  match n with
  | O => true
  | S O => false
  | S (S n') => even n'
  end.

Definition odd (n : nat) : bool :=
  negb (even n).

Example test_odd1: odd 1 = true.
Proof. simpl. reflexivity. Qed.
Example test_odd2: odd 4 = false.
Proof. simpl. reflexivity. Qed.

Module NatPlayground2.

Fixpoint plus (n : nat) (m : nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus n' m)
  end.

Compute (plus 3 2).

Fixpoint mult (n m: nat) : nat :=
  match n with
  | O => O
  | S n' => plus m (mult n' m)
  end.

Example test_mul5by5: mult 5 5 = 25.
Proof. simpl. reflexivity. Qed.

Fixpoint minus (n m: nat): nat :=
  match n, m with
  | O, _ => O
  | S _, O => n
  | S n', S m' => minus n' m'
  end.

End NatPlayground2.

Notation "x + y" := (plus x y) (at level 50, left associativity) : nat_scope.
Notation "x - y" := (minus x y) (at level 50, left associativity) : nat_scope.
Notation "x * y" := (mult x y) (at level 40, left associativity) : nat_scope.

Check ((0 + 1) + 1) : nat.

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

Example test_factorial1: (factorial 3) = 6.
Proof. simpl. reflexivity. Qed.
Example test_factorial2: (factorial 5) = (mult 10 12).
Proof. simpl. reflexivity. Qed.

Fixpoint eqb (n m: nat) : bool :=
  match n with
  | O => match m with
        | O => true
        | S _ => false
        end
  | S n' => match m with
        | O => false
        | S m' => eqb n' m'
        end
  end.

Fixpoint leb (n m: nat) : bool :=
  match n with
  | O => true
  | S n' => match m with
        | O => false
        | S m' => leb n' m'
        end
  end.

  Example test_leb1: leb 2 2 = true.
  Proof. simpl. reflexivity. Qed.
  Example test_leb2: leb 2 4 = true.
  Proof. simpl. reflexivity. Qed.
  Example test_leb3: leb 4 2 = false.
  Proof. simpl. reflexivity. Qed.

  Notation "x =? y" := (eqb x y) (at level 70) : nat_scope.
  Notation "x <=? y" := (leb x y) (at level 70) : nat_scope.
  Example test_leb3': (4 <=? 2) = false.
  Proof. simpl. reflexivity. Qed.

Definition ltb (n m : nat) : bool :=
  negb (m <=? n).
Notation "x <? y" := (ltb x y) (at level 70) : nat_scope.
Example test_ltb1: (ltb 2 2) = false.
Proof. simpl. reflexivity. Qed.
Example test_ltb2: (ltb 2 4) = true.
Proof. simpl. reflexivity. Qed.
Example test_ltb3: (ltb 4 2) = false.
Proof. simpl. reflexivity. Qed.

Theorem  plus_O_n :
  forall (n : nat), 0 + n = n.
Proof.
  intros n.
  simpl.
  reflexivity.
Qed.

Theorem  plus_O_n' :
  forall (n : nat), 0 + n = n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem  plus_O_n'' :
  forall (n : nat), 0 + n = n.
Proof.
  intros m.
  reflexivity.
Qed.

Theorem  plus_1_n :
  forall (n : nat), 1 + n = S n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem  mult_0_n :
  forall (n : nat), 0 * n = 0.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem plus_id_example : forall n m : nat,
  n = m -> n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Check mult_n_O.

Check mult_n_Sm.

Theorem mult_n_0_m_0 : forall p q : nat,
  (p * 0) + (q * 0) = 0.
Proof.
  intros p q.
  rewrite <- mult_n_O.
  rewrite <- mult_n_O.
  reflexivity.
Qed.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros m n o.
  intros H.
  rewrite -> H.
  intros I.
  rewrite -> I.
  reflexivity.
Qed.

Theorem mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  simpl.
  reflexivity.
Qed.

Theorem plus_1_neg_0_firsttry : forall n : nat,
  ((n + 1) =? 0) = false.
Proof.
  intros n.
  simpl.
Abort.

Theorem plus_1_neg_0 : forall n : nat,
  ((n + 1) =? 0) = false.
Proof.
  intros n. destruct n as [| n'] eqn:E.
  - reflexivity.
  - reflexivity.
Qed.

Theorem negb_involutive : forall b : bool,
  negb (negb b) = b.
Proof.
  intros b. destruct b eqn:E.
  - simpl. reflexivity.
  - simpl. reflexivity.
Qed.

Theorem andb_commutative : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    + simpl. reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + simpl. reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative' : forall b c, andb b c = andb c b.
Proof.
  intros b c. destruct b eqn:Eb.
  { destruct c eqn:Ec.
    { simpl. reflexivity. }
    { reflexivity. } }
  { destruct c eqn:Ec.
    { simpl. reflexivity. }
    { reflexivity. } }
Qed.

Theorem plus_1_neg_0' : forall n : nat,
  ((n + 1) =? 0) = false.
Proof.
  intros [| n].
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative'' : forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2 : forall b c : bool,
  andb b c = true -> c = true.
Proof.
  intros [] [].
  - reflexivity.
  - intros H. rewrite <- H. reflexivity.
  - reflexivity.
  - intros H. rewrite <- H. reflexivity.
Qed.

Theorem zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.

(* Exercise: 1 star, standard (identity_fn_applied_twice) *)
Theorem identity_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  reflexivity.
Qed.

(* Exercise: 1 star, standard (negation_fn_applied_twice) *)
Theorem negation_fn_applied_twice :
  forall (f : bool -> bool),
  (forall (x : bool), f x = negb x) ->
  forall (b : bool), f (f b) = b.
Proof.
  intros.
  rewrite -> H.
  rewrite -> H.
  rewrite -> negb_involutive.
  reflexivity.
Qed.

(* Exercise: 3 stars, standard, optional (andb_eq_orb) *)
Theorem andb_eq_orb :
  forall (b c : bool),
  (andb b c = orb b c) ->
  b = c.
Proof.
  intros [] [].
  - reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - simpl. intros H. rewrite -> H. reflexivity.
  - reflexivity.
Qed.

Inductive bin : Type :=
  | Z
  | B_0 (n : bin)
  | B_1 (n : bin).

Fixpoint incr_with_carry (m: bin) (carry: bool) : bin :=
  match m, carry with
  | Z, _ => B_1 Z
  | B_1 m', true => B_0 (incr_with_carry m' true)
  | B_1 m', false => B_0 (incr_with_carry m' false)
  | B_0 m', _ => B_1 m'
  end.

Definition incr' (m: bin) : bin :=
  incr_with_carry m false.

Fixpoint incr (m:bin) : bin :=
match m with
  | Z    => B_1 Z
  | B_0 n => B_1 n
  | B_1 n => B_0 (incr n)
  end.

Compute (incr Z).
Compute (incr(incr Z)).
Compute (incr(incr(incr Z))).
Compute (incr(incr(incr(incr Z)))).
Compute (incr(incr(incr(incr(incr Z))))).
Compute (incr(incr(incr(incr(incr(incr Z)))))).

Example test_bin_incr1 : (incr (B_1 Z)) = B_0 (B_1 Z).
Proof. reflexivity. Qed.

Example test_bin_incr2 : (incr (B_0 (B_1 Z))) = B_1 (B_1 Z).
Proof. reflexivity. Qed.

Example test_bin_incr3 : (incr (B_1 (B_1 Z))) = B_0 (B_0 (B_1 Z)).
Proof. reflexivity. Qed.

Fixpoint bin_to_nat_rec (m:bin) (pos multiplier:nat) : nat :=
  match m, pos, multiplier with
  | Z, _, _ => 0
  | B_1 Z, _, _ => multiplier
  | B_1 m', 0, 1 => 1 + (bin_to_nat_rec m' 1 2)
  | B_1 m', _, _ => multiplier + (bin_to_nat_rec m' (pos + 1) (multiplier * 2))
  | B_0 m', 0, 1 => (bin_to_nat_rec m' 1 2)
  | B_0 m', _, _ => (bin_to_nat_rec m' (pos + 1) (multiplier * 2))
  end.

Definition bin_to_nat' (m:bin) := (bin_to_nat_rec m 0 1).

Fixpoint bin_to_nat (m:bin) : nat :=
  match m with
    | Z    => O
    | B_0 n => (bin_to_nat n) + (bin_to_nat n)
    | B_1 n => S ((bin_to_nat n) + (bin_to_nat n))
  end.

Definition one_bin := (B_1 Z).
Definition two_bin := (B_0 (B_1 Z)).
Definition three_bin := (B_1 (B_1 Z)).
Definition four_bin := (B_0 (B_0 (B_1 Z))).
Definition five_bin := (B_1 (B_0 (B_1 Z))).
Definition six_bin := (B_0 (B_1 (B_1 Z))).
Definition seven_bin := (B_1 (B_1 (B_1 Z))).
Definition eight_bin := (B_0 (B_0 (B_0 (B_1 Z)))).

Compute (bin_to_nat one_bin).
Compute (bin_to_nat two_bin).
Compute (bin_to_nat three_bin).
Compute (bin_to_nat four_bin).
Compute (bin_to_nat five_bin).
Compute (bin_to_nat six_bin).
Compute (bin_to_nat seven_bin).
Compute (bin_to_nat eight_bin).

Example test_bin_incr5 :
  bin_to_nat (incr (B_1 Z)) = 1 + bin_to_nat (B_1 Z).
Proof. cbn. reflexivity. Qed.

Example test_bin_incr6 :
  bin_to_nat (incr (incr (B_1 Z))) = 2 + bin_to_nat (B_1 Z).
Proof. cbv. reflexivity. Qed.

Example incr_seven: incr seven_bin = eight_bin.
Proof. reflexivity. Qed.

Example incr_seven_nat: bin_to_nat(incr seven_bin) = 8.
Proof. reflexivity. Qed.

Example incr_seven_twice_nat: bin_to_nat(incr (incr seven_bin)) = 9.
Proof. reflexivity. Qed.


Require Import Basics.
Require Import Paths.
Require Import HIT.
Require Import Polygraphs.

(* Morphism of Polygraphs *)

Definition ForgetA {T F: Type} (f : F -> T )  (n : nat)  : Aug F n.
Proof.
  simple refine (mkAug _ _).
  - simple refine (PullB _ _).
    + exact (Ball n -> T).
    + exact (Sphere n -> F).
    + exact (Sphere n -> T).
    + exact (nFaces n T).
    + exact (compose f).
  - intros [x e]. exact (pi2 x e).
Defined.

Definition CounitA {T F : Type} (n : nat)  ( f : F -> T ) : FreeA (ForgetA f n) -> T.
Proof.
  simple refine (Pushout_rect _ _ _).
  - exact f.
  - intro. exact (pi1 X.1 X.2).
  - intros [x e]. simpl. exact (f_equal (fun W => W e) (coh x)^).
Defined.

Fixpoint ForgetAndCounit (n : nat) : {p : forall T : Type, Pol n | forall T : Type, Free (p T) -> T}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _ ); intro T.
    + exact (Disc T).
    + exact (fun x => x).
  - simple refine (mkDPair _ _); intro T.
    + simple refine (Ext _ _).
      * exact (fstd (ForgetAndCounit n) T).
      * exact (ForgetA (sndd (ForgetAndCounit n) T) (S n)).
    +  simpl. exact (CounitA (S n) (sndd (ForgetAndCounit n) T)).
Defined.

Notation Forget T n := (fstd (ForgetAndCounit n) T).
Notation Counit T n := (sndd (ForgetAndCounit n) T).

Opaque ForgetAndCounit.

Lemma eq_MA {F F' : Type} {n : nat} {f : F -> F'} {aug : Aug F n} {aug' : Aug F' n} (G H : aug - f -- aug')
      (p : ME G = ME H )
      (q : forall e x, ((f_equal (fun W => d aug' (W e, x)) p) @ (Md H e x)) =  Md G e x) :
    G = H :> MAug f aug aug'.
Proof.
  destruct H as [HME HMd].
  simpl in  p. destruct p.
  assert (Md G = HMd).
  {
    repeat (apply FunExtDep; intro). simpl in *.
    exact ((q x x0)^ @ concat_1p _).
  }
  now destruct H.
Defined.

Lemma FreeMA_inr {F F' : Type} {n : nat} {f : F -> F'} {aug : Aug F n} {aug' : Aug F' n}
      (G H : aug - f -- aug')
      (p : ME G = ME H )
      (q : forall e x,  (f_equal (fun W => d aug' (W e, x)) p) @ (Md H e x) = (Md G e x))
      (x : E aug × Ball n) :
  FreeMA G (inr x) = inr (ME G x.1, x.2).
Proof.
  reflexivity.
Defined.

Lemma eq_MA_inr {F F' : Type} {n : nat} {f : F -> F'} {aug : Aug F n} {aug' : Aug F' n}
      (G H : aug - f -- aug')
      (p : ME G = ME H )
      (q : forall e x,  (f_equal (fun W => d aug' (W e, x)) p) @ (Md H e x) = (Md G e x))
      (x : E aug × Ball n) :
  f_equal (fun T => FreeMA T (inr x)) (eq_MA G H p q) = f_equal (fun T => inr (T x.1, x.2)) p.
Proof.
  simpl. unfold eq_MA. destruct H as [HE Hd]. simpl in *.
  destruct p. simpl in *.
  match goal with
  | |- f_equal _ (match ?a return _ with |_ => _ end q) = 1 => destruct a
  end.
  reflexivity.
Defined.

Lemma FreeMA_eq  {F F' : Type} {n : nat} {f : F -> F'} {aug : Aug F n} {aug' : Aug F' n}
      (G H : aug - f -- aug')
      (p : ME G = ME H )
      (q : forall e x,  (f_equal (fun W => d aug' (W e, x)) p) @ (Md H e x) = (Md G e x)) :
  FreeMA G = FreeMA H :> ([aug]* -> [aug']* ).
Proof.
  destruct H as [HME HMd].
  simpl in  p. destruct p.
  assert (Md G = HMd).
  {
    repeat (apply FunExtDep; intro). simpl in *.
    exact ((q x x0)^ @ concat_1p _).
  }
  now destruct H.
Defined.

Lemma ap_FreeMA  {F F' : Type} {n : nat} {f : F -> F'} {aug : Aug F n} {aug' : Aug F' n}
      (G H : aug - f -- aug')
      (p : ME G = ME H )
      (q : forall e x,  (f_equal (fun W => d aug'  (W e, x)) p) @ (Md H e x) = (Md G e x)):
  f_equal FreeMA (eq_MA G H p q) = FreeMA_eq G H p q :> (FreeMA G = FreeMA H :> (FreeA aug -> FreeA aug')).
Proof.
  destruct H as [HE Hd]. simpl in *.
  destruct p. simpl in q.
  set (q' := fun e x => (concat_1p _ )^ @ q e x).
  assert ((fun e x => (concat_1p _) @ (q' e x)) = q).
  { apply FunExtDep. intro. apply FunExtDep. intro. subst q'. simpl.
    rewrite assoc. rewrite concat_pV. exact (concat_1p _).
  }
  clearbody q'. destruct H.
  refine (destruct_fun_eq (fun G1 G2 q =>
                             f_equal FreeMA (eq_MA (mkMAug (ME G) G2) (mkMAug (ME G) G1) 1 (fun e x => concat_1p _ @ q e x )) =
                             FreeMA_eq (mkMAug (ME G) G2)  (mkMAug (ME G) G1) 1 (fun e x => concat_1p _ @ q e x ))
                          _ q').
  intro. clear Hd q'. simpl.
  match goal with
  | |- f_equal FreeMA
         (match ?f in (_ = y) return _ with | _ => _ end _) = _ => destruct f
  end. reflexivity.
Defined.

Definition ForgetMA (n : nat) {T T' : Type} {F F' : Type} (g : F -> T) (g' : F' -> T')  (Ff: F -> F') (Tf : T -> T')
           (H : (compose g' Ff) = (compose Tf g)) : MAug Ff (ForgetA g n) (ForgetA g' n).
Proof.
  unshelve econstructor.
  - intro. simple refine (mkPullB _ _ _).
    + exact (compose Tf (pi1 X)).
    + exact (compose Ff (pi2 X)).
    + unfold nFaces.
      unfold compose.
      simple refine (_ @ (f_equal (fun W => compose W (pi2 X)) H^)).
      exact (f_equal (fun W => compose Tf W) (coh X)).
  - reflexivity.
Defined.

Definition pre_ap_counit_coh {T F : Type} (n : nat)  ( f : F -> T ) (a : E (ForgetA f n) × Sphere n) :
  CounitA n f (inl (d (ForgetA f n) a)) = CounitA n f (inr {| fst := a.1; snd := Faces n a.2 |}) :=
  f_equal (fun T => T a.2) (coh a.1)^.

Lemma ap_counit_coh {T F : Type} (n : nat)  ( f : F -> T ) (a : E (ForgetA f n) × Sphere n) :
  (f_equal (fun x : [ForgetA f n ]* => CounitA n f x) (incoh a)) =  f_equal (fun T => T a.2) (coh a.1)^.
Proof.
  exact Pushout_rect_compute_coh.
Defined.

Definition NaturalMA (n : nat) {T T' : Type} {F F' : Type} (g : F -> T) (g' : F' -> T')  (Ff: F -> F') (Tf : T -> T')
           (H : (compose g' Ff) = (compose Tf g)) :
  compose (CounitA n g') (FreeMA (ForgetMA n g g' Ff Tf H))  = compose Tf (CounitA n g).
Proof.
  apply funext. simple refine (eqMorphPushout _ _ _).
  - unfold compose. simpl. intro b. exact (f_equal (fun W => W b) H).
  - reflexivity.
  - intro a. unfold compose. simpl.
    match goal with
    | |- _ = f_equal (fun x => CounitA n g' (?f x)) ?p =>
      simple refine (_ @ (ap_compose f (CounitA n g') p)^)
    end.
    unfold FreeMA.
    simple refine (_ @ (f_equal (fun W => f_equal (CounitA n g') W) Pushout_rect_compute_coh^)).
    simple refine (_ @ (ap_concat _ _ _)^).
    simple refine (_ @ (concat_1p _)^).
    simple refine (_ @ Pushout_rect_compute_coh^).
    simpl.
    simple refine (_ @ (concat_ap_V _ _)^).
    match goal with
    | |- _ = (f_equal ?f (?p @ ?q))^ => simple refine (_ @ (f_equal (fun W => W^) (ap_concat f p q)^))
    end.
    simple refine (_ @ (concat_V _ _)^).
    match goal with
    | |- _ = (f_equal ?f (f_equal ?g (?p ^))) ^ @ ?q =>
      simple refine (_ @ (f_equal (fun W => W ^ @ q) (ap_compose g f (p ^))));
        simple refine (_ @ (f_equal (fun W => W ^ @ q) (concat_ap_V (compose f g) p)^));
        simple refine (_ @ f_equal (fun W => W @ q) (concat_VV _)^)
    end.
    match goal with
      | |- _ = ?p @ (f_equal ?f (f_equal ?g ?q)) ^ =>
      simple refine (_ @ (f_equal (fun W => p @ W ^) (ap_compose g f q)))
    end.
    match goal with
    | |- ?p @ f_equal (fun x => Tf (@?f x)) ?q = _ =>
      simple refine (f_equal (fun W => p @ W) (ap_compose f Tf q) @ _)
    end.
    unfold compose.
    match goal with
    | |- ?p @ f_equal Tf _ = _ => simple refine (f_equal (fun W => p @ f_equal Tf W) (ap_counit_coh _ _ _) @ _)
    end. simpl.
    match goal with
    | |- ?p @ f_equal ?f (f_equal ?g ?q ^) = _ =>
      simple refine (f_equal (fun W => p @ f_equal f W) (concat_ap_V _ _) @ _);
        simple refine (f_equal (fun W => p @ W) (concat_ap_V _ _) @ _);
        exact (f_equal (fun W => p @ W ^) (ap_compose g f q)^ )
    end.
Defined.

Fixpoint ForgetFunctorialAndNatural (n : nat) {struct n}:
  {ForgetM : forall (T T' : Type) (f : T -> T'), MPol (Forget T n) (Forget T' n) |
   forall (T T' : Type) (f : T -> T'), compose (Counit T' n) (FreeM (ForgetM T T' f)) = compose f (Counit T n)}.
Proof.
  destruct n.
  - simple refine (mkDPair _ _); intros T T' f.
    + econstructor. exact f.
    + exact 1.
  - simple refine (mkDPair _ _); intros T T' f.
    + unshelve econstructor.
      * exact (fstd (ForgetFunctorialAndNatural n) _ _ f).
      * cbn. simple refine (ForgetMA (S n) _ _ _ f _). simpl.
        match goal with
        | |- compose (sndd (?f n)  T')  _  = _  => change (sndd (f n) T') with (Counit T' n)
        end.
        exact (sndd (ForgetFunctorialAndNatural n) _ _ f).
    + simple refine ((NaturalMA (S n) _ _ _ _ _) @ _). reflexivity.
Defined.

Notation ForgetM n f := (fstd (ForgetFunctorialAndNatural n) _ _ f).
Notation CounitM n f := (sndd (ForgetFunctorialAndNatural n) _ _ f).