From Tealeaves Require Import
     Util.Prelude Util.EqDec_eq
     LN.Atom LN.AtomSet LN.Leaf
     Classes.DecoratedTraversableModule
     Functors.Maybe.

Import DecoratedTraversableMonad.Notations.
Import LN.AtomSet.Notations.
Open Scope tealeaves_scope.
Open Scope set_scope.

(** * Locally nameless leaves *)
(******************************************************************************)
Inductive leaf :=
| Fr : Atom.atom -> leaf
| Bd : nat -> nat -> leaf.
(* Bd group index, individual index *)

Theorem eq_dec_leaf : forall l1 l2 : leaf, {l1 = l2} + {l1 <> l2}.
Proof.
  decide equality.
  - compare values a and a0; auto.
  - compare values n and n0; auto.
    compare values n0 and n2; auto.
    compare values n0 and n2; auto.
  - compare values n and n1; auto.
Qed.

Instance EqDec_leaf : EquivDec.EqDec leaf eq := eq_dec_leaf.

Fixpoint nth {A} (n : nat) (l : list A) : Maybe A :=
  match n, l with
  | O, x :: l' => Just x
  | O, other => None
  | S m, nil => None
  | S m, x :: t => nth m t
  end.

Lemma nth1 : forall (A : Type) (n : nat), nth n (@nil A) = None.
Proof.
  intros. now induction n.
Qed.

Lemma nth2 : forall (A : Type) (n : nat) (w : list A),
    Nat.compare n (length w) = Gt -> nth n w = None.
Proof.
  intros. generalize dependent n. induction w.
  - intros. now rewrite nth1.
  - intros. destruct n.
    + cbv in H. inversion H.
    + cbn in *. auto.
Qed.

Lemma nth3 : forall (A : Type) (w : list A),
    nth (length w) w = None.
Proof.
  intros. induction w.
  - cbn. reflexivity.
  - cbn. auto.
Qed.

(** * Operations for locally nameless *)
(******************************************************************************)

(** ** Local operations *)
(******************************************************************************)
Section local_operations.

  Context
    `{Return T}.

  Implicit Types (x : atom).

  Definition free_loc : leaf -> list atom :=
    fun l => match l with
          | Fr x => cons x List.nil
          | _ => List.nil
          end.

  Definition subst_loc x (u : T leaf) : leaf -> T leaf :=
    fun l => match l with
          | Fr y => if x == y then u else ret T (Fr y)
          | Bd grp ix => ret T (Bd grp ix)
          end.

  Definition open_loc (binders : list (T leaf)) : list nat * leaf -> Maybe (T leaf) :=
    fun p => match p with
          | (w, l) =>
            match l with
            | Fr x => Just (ret T (Fr x))
            | Bd grp ix =>
              match Nat.compare grp (length w) with
              | Lt => Just (ret T (Bd grp ix))
              | Eq => nth ix binders
              | Gt => Just (ret T (Bd (grp - 1) ix))
              end
            end
          end.

  Definition is_bound_or_free : list nat * leaf -> Prop :=
    fun p => match p with
          | (w, l) =>
            match l with
            | Fr x => True
            | Bd grp ix =>
              match nth grp w with
              | Just size => ix < size
              | None => False
              end
            end
          end.

End local_operations.

(** ** Lifted operations *)
(******************************************************************************)
Section LocallyNamelessOperations.

  About DecoratedTraversableModule.
  Context
    (T : Type -> Type)
    `{DecoratedTraversableMonad (list nat)
                                 (op := @List.app nat) (unit := nil) T}.

  Definition open (binders : list (T leaf)) : T leaf -> Maybe (T leaf)  :=
    binddt T (open_loc binders).

  Definition locally_closed : T leaf -> Prop :=
    fun t => forall w l, (w, l) ∈d t -> is_bound_or_free (w, l).

  Corollary open_respectful_id (us : list (T leaf)) : forall (t : T leaf),
      (forall w a, (w, a) ∈d t -> open_loc us (w, a) = Just (ret T a)) -> binddt T (open_loc us) t = pure Maybe t.
  Proof.
    intros. now apply (binddt_respectful_id T).
  Qed.

  Theorem correct : forall (t : T leaf) (us : list (T leaf)),
      locally_closed t -> open us t = Just t.
  Proof.
    introv LC. unfold locally_closed in LC.
    apply open_respectful_id.
    intros w l Hin. specialize (LC w l Hin).
    destruct l; cbn in LC.
    - reflexivity.
    - cbn. compare naturals n and (length w).
      + rewrite nth3 in LC. inversion LC.
      + assert (lemma : nth n w = None) by auto using nth2.
        rewrite lemma in LC. inversion LC.
  Qed.

End LocallyNamelessOperations.


(** ** lB-systems to precategories.

by Vladimir Voevodsky, started on Jan. 22, 2015 *)

Unset Automatic Introduction.

Require Export lBsystems.T_fun.
Require Export lBsystems.S_fun.

Require Export lBsystems.lB0 .

(** *** The first construction of the types Mor_from_B *)

(** We first define for Z in an lB-system and m <= ll Z the type
( iterated_sections m Z ) that corresponds to the sections of the projection Z -> ft^m Z
in the associated lC-system. We do it for non-unital prelBsystems but the only structure that
is actually required is an lBsystem_carrier and an operation of type S_ops_type satisfying
axiom ax0. *)

Lemma Tilden_dd_inn { BB : prelBsystem_non_unital }
      { n' : nat } { X : BB } ( s : Tilde_dd ( ftn ( S n' ) X ) ) : S_dom s X .
Proof.
  intros.
  unfold S_dom .
  destruct s as [ s' eq ].
  assert ( gt0 : ll ( ftn ( S n' ) X ) > 0 ).
  rewrite <- eq.
  apply ll_dd.

  simpl.
  rewrite eq.
  split.
  rewrite ll_ftn.
  rewrite ll_ftn in gt0.
  apply natminuslthn.
  assert ( gt := minusgth0inv _ _ gt0 ).
  apply ( istransnatgth _ _ _ gt ( natgthsn0 _ ) ).

  apply natgthsn0.

  apply ( isover_X_ftnX _ _ ).

Defined.

Opaque Tilden_dd_inn.

Fixpoint Tilden_dd { BB : prelBsystem_non_unital } ( n : nat )  ( X : BB )  : UU :=
  match n with
    | 0 => unit
    | S n' => match n' with
                | 0 => Tilde_dd X
                | S n'' => total2 ( fun s1 : Tilde_dd ( ftn ( S n'' ) X ) =>
                                      Tilden_dd n' ( S_op s1 X ( Tilden_dd_inn s1 ) ) )
              end
  end .

(*

Lemma iter_sec_inn { BB : prelBsystem_non_unital }
      { m : nat } { Z : BB } ( gt0 : m > 0 ) ( lesm : S m <= ll Z )
      ( s : Tilde_dd ( ftn m Z ) ) : S_dom s Z .
Proof.
  intros.
  unfold S_dom .
  set ( eq := pr2 s : dd s = ftn m Z ) . simpl in eq .
  rewrite eq .

  apply ( isabove_X_ftnX gt0 ) .
  apply ( natgehgthtrans _ _ _ lesm ( natgthsn0 _ ) ) .

Defined.

Lemma iter_sec_le { BB : prelBsystem_non_unital }
      { m : nat } { Z : BB } ( gt0 : m > 0 ) ( lesm : S m <= ll Z )
      ( s : Tilde_dd ( ftn m Z ) ) : m <= ll ( S_op s Z ( iter_sec_inn gt0 lesm s ) ) .
Proof.
  intros.
  rewrite S_ax0 .
  assert ( leint := natgehandminusr _ _ 1 lesm ) .
  simpl in leint .
  rewrite natminuseqn in leint .
  exact leint .

Defined.

Definition iter_sec { BB : prelBsystem_non_unital }
           ( m : nat ) ( Z : BB ) ( le : m <= ll Z ) : UU .
Proof.
  intros until m . set ( S := @S_op BB ) . set ( sax0 := @S_ax0 BB ) .
  induction m as [ | m IHm ] .
  intros. exact unit .

  intros Z le .
  destruct ( natgehchoice _ _ ( natgehn0 m ) ) as [ gt0 | eq0 ] .
  set ( inn := iter_sec_inn gt0 le ) .
  set ( le' := iter_sec_le gt0 le ) .
  exact ( total2 ( fun s : Tilde_dd ( ftn m Z ) => IHm ( S s Z ( inn s ) ) (le' s) ) ) .

  exact ( Tilde_dd Z ) .

Defined.

(* Definition iter_sec_m_eq_sn { BB : prelBsystem_non_unital }
           { m n : nat } ( eq : m = S n )
           ( Z : BB ) ( lem : m <= ll Z ) ( lesn : S n <= ll Z ) :
  iter_sec m Z lem =
  total2 ( fun s : Tilde_dd ( ftn m Z ) => iter_sec n ( S s Z ( inn s ) ))*)

*)

(** We now define morphisms X --> Y as iterated sections of the projection Tprod X Y --> X *)

Definition Mor_from_B { BB : lB0system_non_unital } ( X Y : BB ) : UU :=
  Tilden_dd ( ll Y ) ( Tprod X Y )  .

(** Here is another definition of morphisms that defines them together with the corresponding
operation f_star *)

Definition Mor_and_fstar { BB : lB0system_non_unital }
           ( X1 : BB ) ( n : nat ) ( A : BB ) ( eq : ll A = n ) :
  total2 ( fun Mor_X1_A : UU =>
             forall f : Mor_X1_A ,
               ltower_fun ( ltower_over A ) ( ltower_over X1 ) ) .
Proof .
  intros until n . induction n as [ | n IHn ] .
  intros .
  split with unit .

  intro .
  exact ( Tj_fun ( @isoverll0 BB _ eq X1 ) ) .

  intros .
  assert ( eqft : ll ( ft A ) = n ) . rewrite ll_ft . rewrite eq . simpl . rewrite natminuseqn .
  apply idpath .

  set ( Mor_X1_ftA := pr1 ( IHn ( ft A ) eqft ) ) .
  set ( Mor_X1_A :=
          total2 ( fun ftf : Mor_X1_ftA =>
                     Tilde_dd ( pocto ( ( pr2 ( IHn ( ft A ) eqft ) ftf ) ( X_over_ftX A ) ) ) ) ) .
  split with Mor_X1_A .

  intro f .
  set ( ftf := pr1 f : Mor_X1_ftA ) .
  set ( s_f := pr1 ( pr2 f ) : Tilde BB ) .
  set ( ftf_star := pr2 ( IHn ( ft A ) eqft ) ftf :
                      ltower_fun ( ltower_over ( ft A ) ) ( ltower_over X1 ) ) .
  set ( ftf_star_A := pocto ( ftf_star ( X_over_ftX A ) : ltower_over X1 ) ) .
  set ( eq_s_f := pr2 ( pr2 f ) : dd ( s_f ) = ftf_star_A ) .
  assert ( fun1 : ltower_fun ( ltower_over A ) ( ltower_over ftf_star_A ) ) .
  apply ( ltower_fun_second ftf_star ( X_over_ftX A ) ) .

  assert ( fun2 : ltower_fun ( ltower_over ftf_star_A ) ( ltower_over ( ft ftf_star_A ) ) ) .
  rewrite <- eq_s_f .
  apply ( S_fun s_f ) .

  assert ( gt0 : ll (ftf_star (X_over_ftX A)) > 0 ) .
  rewrite (@ll_ltower_fun (pltower_over ( ft A ) )).
  change ( ll (X_over_ftX A) > 0 ) .
  rewrite ll_X_over_ftX .
  apply idpath .

  rewrite eq . apply natgthsn0 .

  assert ( eq' : ft ftf_star_A = X1 ) .
  unfold ftf_star_A .
  rewrite ft_pocto .
  assert ( eq1 : ft (ftf_star (X_over_ftX A)) = X_over_X X1 ) .
  assert ( eq2 : ll ( ft (ftf_star (X_over_ftX A)) ) = 0 ) .
  rewrite ll_ft .
  rewrite (@ll_ltower_fun (pltower_over (ft A))).
  change ( ll (X_over_ftX A) - 1 = 0 ) .
  rewrite ll_X_over_ftX .
  apply idpath .

  rewrite eq . apply natgthsn0 .

  apply ( @noparts_ispointed  ( pltower_over _ ) _ _ eq2 ( ll_X_over_X X1 ) ) .

  rewrite eq1 .
  apply idpath .

  apply gt0 .

  set ( fun12 := ltower_funcomp fun1 fun2 ) .
  rewrite eq' in fun12 .
  exact fun12 .

Defined.

(* End of the file lB_to_precat.v *)


From Coq Require Import Strings.String.
From Coq Require Import Strings.Ascii.
From Coq Require Import Arith.Arith.
From Coq Require Import Init.Nat.
From Coq Require Import Arith.EqNat.
From Coq Require Import Lists.List. Import ListNotations.
From LF Require Import Imp.

Definition isWhite (c : ascii) : bool :=
  let n := nat_of_ascii c in
  match n with
  | 32 => true  (* space *)
  | 9 => true   (* tab *)
  | 10 => true  (* linefeed *)
  | 13 => true  (* Carriage return *)
  | _ => false
  end.

Notation "x '<=?' y" := (x <=? y).

Definition isLowerAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (97 <=? n) (n <=? 122).

Definition isAlpha (c : ascii) : bool :=
  let n := nat_of_ascii c in
    orb (andb (65 <=? n) (n <=? 90))
        (andb (97 <=? n) (n <=? 122)).

Definition isDigit (c : ascii) : bool :=
  let n := nat_of_ascii c in
    andb (48 <=? n) (n <=? 57).

Inductive charType : Type :=
| white
| alpha
| digit
| other.

Definition classifyChar (c : ascii) : charType :=
  if isWhite c then white
  else if isAlpha c then alpha
  else if isDigit c then digit
  else other.

Fixpoint listOfString (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String c s => c :: (listOfString s)
  end.

Definition stringOfList (xs : list ascii) : string :=
  fold_right String EmptyString xs.

Definition token := string.

Fixpoint tokenize_helper (cls : charType) (acc xs : list ascii)
                         : list (list ascii) :=
  let tk := match acc with
  | [] => []
  | _ :: _ => [rev acc]
  end in
  match xs with
  | [] => tk
  | (x :: xs') =>
    match cls, classifyChar x, x with
    | _, _, "(" => tk ++ ["("] :: (tokenize_helper other [] xs')
    | _, _, ")" => tk ++ [")"] :: (tokenize_helper other [] xs')
    | _, white, _ => tk ++ (tokenize_helper white [] xs')
    | alpha, alpha, x => tokenize_helper alpha (x::acc) xs'
    | digit, digit, x => tokenize_helper digit (x::acc) xs'
    | other, other, x => tokenize_helper other (x::acc) xs'
    | _, tp, x => tk ++ (tokenize_helper tp [x] xs')
    end
  end % char.

Definition tokenize (s : string) : list string :=
  map stringOfList (tokenize_helper white [] (listOfString s)).

Example tokenize_ex1 :
  tokenize "abc12=3 223*(3+(a+c))" % string
  = ["abc"; "12"; "="; "3"; "223";
     "*"; "("; "3"; "+"; "(";
     "a"; "+"; "c"; ")"; ")"] % string.
Proof.
  compute.
  reflexivity.
Qed.

Inductive optionE (X : Type) : Type :=
| SomeE (x : X)
| NoneE (s : string).

Arguments SomeE {X}.
Arguments NoneE {X}.

Notation "' p <- e1 ;; e2" :=
  (
    match e1 with
    | SomeE p => e2
    | NoneE err => NoneE err
    end
  )
  (right associativity, p pattern, at level 60,
    e1 at next level).

Notation "'TRY' ' p <- e1 ;; e2 'OR' e3" :=
  (
    match e1 with
    | SomeE p => e2
    | NoneE _ => e3
    end
  )
  (right associativity, p pattern, at level 60,
    e1 at next level, e2 at next level).

Open Scope string_scope.

Definition parser (T : Type) :=
  list token -> optionE (T * list token).

Fixpoint many_helper {T} (p : parser T) acc steps xs :=
  match steps, p xs with
  | 0, _ => NoneE "Too many recursive calls"
  | _, NoneE _ => SomeE ((rev acc), xs)
  | S steps', SomeE (t, xs') => many_helper p (t::acc) steps' xs'
  end.

Definition many {T} (p : parser T) (steps : nat) : parser (list T) :=
  many_helper p [] steps.

Definition firstExpect {T} (t : token) (p : parser T) : parser T :=
  fun xs =>
    match xs with
    | x :: xs' =>
      if string_dec x t then p xs'
      else NoneE ("expected '" ++ t  ++ "'.")
    | [] => NoneE ("expected '" ++ t  ++ "'.")
    end.

Definition expect (t : token) : parser unit :=
  firstExpect t (fun xs => SomeE (tt, xs)).

Definition parseIdentifier (xs : list token)
                          : optionE (string * list token) :=
  match xs with
  | [] => NoneE "Expected identifier"
  | x :: xs' =>
    if forallb isLowerAlpha (listOfString x) then SomeE (x, xs')
    else NoneE ("Illegal identifier: '" ++ x ++ "'")
  end.

Definition parseNumber (xs : list token)
                      : optionE (nat * list token) :=
  match xs with
  | [] => NoneE "Expected number"
  | x :: xs' =>
    if forallb isDigit (listOfString x) then
      SomeE (fold_left
        (fun n d =>
          10 * n + (nat_of_ascii d - nat_of_ascii "0"%char)
        )
        (listOfString x)
        0,
      xs')
    else
      NoneE "Expected number"
  end.

Fixpoint parsePrimaryExp (steps : nat) (xs : list token)
                        : optionE (aexp * list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    TRY ' (i, rest) <- parseIdentifier xs ;;
        SomeE (AId i, rest)
    OR
    TRY ' (n, rest) <- parseNumber xs ;;
        SomeE (ANum n, rest)
    OR
        ' (e, rest) <- firstExpect "(" (parseSumExp steps') xs ;;
        ' (u, rest') <- expect ")" rest ;;
        SomeE (e, rest')
  end

with parseProductExp (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls."
  | S steps' =>
    ' (e, rest) <- parsePrimaryExp steps' xs ;;
    ' (es, rest') <- many (firstExpect "*" (parsePrimaryExp steps'))
                          steps' rest ;;
      SomeE (fold_left AMult es e, rest')
  end

with parseSumExp (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    ' (e, rest) <- parseProductExp steps' xs ;;
    ' (es, rest') <- many (fun xs =>
        TRY ' (e, rest') <- firstExpect "+" (parseProductExp steps') xs ;;
            SomeE ((true, e), rest')
        OR
            ' (e, rest') <- firstExpect "-" (parseProductExp steps') xs ;;
            SomeE ((false, e), rest')
      ) steps' rest ;;
    SomeE (fold_left (fun e0 term =>
                      match term with
                      | (true, e) => APlus e0 e
                      | (false, e) => AMinus e0 e
                      end)
            es e,
      rest')
  end.

Definition parseAExp := parseSumExp.

Fixpoint parseAtomExp (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    TRY ' (u, rest) <- expect "true" xs ;;
        SomeE (BTrue, rest)
    OR
    TRY ' (u, rest) <- expect "false" xs ;;
        SomeE (BFalse, rest)
    OR
    TRY ' (e, rest) <- firstExpect "~" (parseAtomExp steps') xs ;;
        SomeE (BNot e, rest)
    OR
    TRY ' (e, rest) <- firstExpect "(" (parseConjunctionExp steps') xs ;;
        ' (u, rest') <- expect ")" rest ;;
        SomeE (e, rest')
    OR
        ' (e, rest) <- parseProductExp steps' xs ;;
          TRY ' (e', rest') <- firstExpect "=" (parseAExp steps') rest ;;
              SomeE (BEq e e', rest')
          OR
          TRY ' (e', rest') <- firstExpect "<=" (parseAExp steps') rest ;;
              SomeE (BLe e e', rest')
          OR
              NoneE "Expected '=' or '<=' after arithmetic expression"
  end

with parseConjunctionExp (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    ' (e, rest) <- parseAtomExp steps' xs ;;
    ' (es, rest') <- many (firstExpect "&&" (parseAtomExp steps')) steps' rest ;;
    SomeE (fold_left BAnd es e, rest')
  end.

Definition parseBExp := parseConjunctionExp.

Check parseConjunctionExp.

Definition testParsing {X : Type}
                       (p : nat -> list token -> optionE (X * list token))
                       (s : string) :=
  let t := tokenize s in p 100 t.

Eval compute in
  testParsing parseProductExp "x.y.(x.x).x".
Eval compute in
  testParsing parseConjunctionExp
  "~(x = x && x * x <= (x * x) * x) && x = x".

Fixpoint parseSimpleCommand (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    TRY ' (u, rest) <- expect "skip" xs ;;
      SomeE (<{skip}>, rest)
    OR
    TRY ' (e, rest) <- firstExpect "if" (parseBExp steps') xs ;;
        ' (c, rest') <- firstExpect "then" (parseSequencedCommand steps') rest ;;
        ' (c', rest'') <- firstExpect "else" (parseSequencedCommand steps') rest' ;;
        ' (tt, rest''') <- expect "end" rest'';;
        SomeE (<{if e then c else c' end}>, rest''')
    OR
    TRY ' (e, rest) <- firstExpect "while" (parseBExp steps') xs ;;
        ' (c, rest') <- firstExpect "do" (parseSequencedCommand steps') rest ;;
        ' (u, rest'') <- expect "end" rest' ;;
        SomeE (<{while e do c end}>, rest'')
    OR
    TRY ' (i, rest) <- parseIdentifier xs ;;
        ' (e, rest') <- firstExpect ":=" (parseAExp steps') rest ;;
        SomeE (<{i := e}>, rest')
    OR
        NoneE "Expecting a command"
  end

with parseSequencedCommand (steps : nat) (xs : list token) :=
  match steps with
  | 0 => NoneE "Too many recursive calls"
  | S steps' =>
    ' (c, rest) <- parseSimpleCommand steps' xs ;;
    TRY ' (c', rest') <- firstExpect ";" (parseSequencedCommand steps') rest ;;
      SomeE (<{c ; c'}>, rest')
    OR
      SomeE (c, rest)
  end.

Definition bignumber := 1000.

Definition parse (str : string) : optionE com :=
  let tokens := tokenize str in
  match parseSequencedCommand bignumber tokens with
  | SomeE (c, []) => SomeE c
  | SomeE (_, t::_) => NoneE ("Trailing tokens remaining: " ++ t)
  | NoneE err => NoneE err
  end.


Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Functor.Bifunctor.
Require Import Category.Construction.Product.
Require Import Category.Structure.Monoidal.

Generalizable All Variables.

#[local] Obligation Tactic := simpl; intros; simplify; simpl in *.

#[export]
Program Instance Product_Monoidal `{@Monoidal C} `{@Monoidal D} :
  @Monoidal (C ∏ D) := {
  tensor :=
    {| fobj := fun p => (fst (fst p) ⨂ fst (snd p),
                         snd (fst p) ⨂ snd (snd p))%object
     ; fmap := fun _ _ f => (fst (fst f) ⨂ fst (snd f),
                             snd (fst f) ⨂ snd (snd f)) |};
  I := (@I C _, @I D _)
}.
Next Obligation. exact H. Defined.
Next Obligation. exact H0. Defined.
Next Obligation.
  proper; simplify; simpl in *;
  rewrites; reflexivity.
Qed.
Next Obligation. all:normal; reflexivity. Qed.
Next Obligation. all:apply bimap_comp. Qed.
Next Obligation.
  isomorphism; simpl; simplify; simpl.
  - apply unit_left.
  - apply unit_left.
  - apply (unit_left⁻¹).
  - apply (unit_left⁻¹).
  - apply iso_to_from.
  - apply iso_to_from.
  - apply iso_from_to.
  - apply iso_from_to.
Defined.
Next Obligation.
  isomorphism; simpl; simplify; simpl.
  - apply unit_right.
  - apply unit_right.
  - apply (unit_right⁻¹).
  - apply (unit_right⁻¹).
  - apply iso_to_from.
  - apply iso_to_from.
  - apply iso_from_to.
  - apply iso_from_to.
Defined.
Next Obligation.
  isomorphism; simpl; simplify; simpl.
  - apply tensor_assoc.
  - apply tensor_assoc.
  - apply (tensor_assoc⁻¹).
  - apply (tensor_assoc⁻¹).
  - apply iso_to_from.
  - apply iso_to_from.
  - apply iso_from_to.
  - apply iso_from_to.
Defined.
Next Obligation. all:apply to_unit_left_natural. Qed.
Next Obligation. all:apply from_unit_left_natural. Qed.
Next Obligation. all:apply to_unit_right_natural. Qed.
Next Obligation. all:apply from_unit_right_natural. Qed.
Next Obligation. all:apply to_tensor_assoc_natural. Qed.
Next Obligation. all:apply from_tensor_assoc_natural. Qed.
Next Obligation. all:apply triangle_identity. Qed.
Next Obligation. all:apply pentagon_identity. Qed.


(**********************************************************************)
(* This Program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program 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 Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(**********************************************************************)

(**********************************************************************)
(*                      Adding.v                                      *)
(*                                                                    *)
(*                     Barry Jay                                      *)
(*                                                                    *)
(**********************************************************************)

Require Import Arith Omega Max Bool List.
Require Import IntensionalLib.Fieska_calculus.Test.
Require Import IntensionalLib.Fieska_calculus.General.
Require Import IntensionalLib.Fieska_calculus.Fieska_Terms.
Require Import IntensionalLib.Fieska_calculus.Fieska_Tactics.
Require Import IntensionalLib.Fieska_calculus.Fieska_reduction.
Require Import IntensionalLib.Fieska_calculus.Fieska_Normal.
Require Import IntensionalLib.Fieska_calculus.Fieska_Closed.
Require Import IntensionalLib.Fieska_calculus.Substitution.
Require Import IntensionalLib.Fieska_calculus.Fieska_Eval.
Require Import IntensionalLib.Fieska_calculus.Star.
Require Import IntensionalLib.Fieska_calculus.Fixpoints.
Require Import IntensionalLib.Fieska_calculus.Extensions.
Require Import IntensionalLib.Closure_to_Fieska.Tagging.

Ltac unfold_op := unfold pair, a_op, i_op, id, k_op, f_op, s_op.

Lemma pair_normal: forall M N, normal M -> normal N -> normal (pair M N).
Proof. intros; unfold_op; nf_out. Qed.

Lemma k_op_normal: forall M, normal M -> normal (App (App (Op Fop) (Op Fop)) M).
Proof. intros;  unfold_op; nf_out. Qed.

Ltac nf_out2 :=
match goal with
| |- normal (pair _ _) => apply pair_normal; nf_out2
| |- normal (App (App (Op Fop) (Op Fop)) _) => apply k_op_normal; nf_out2
| _ => nf_out
end.

(* pairing *)

Definition left_projection M := App (App (App (Op Fop) M) M) k_op.
Definition right_projection M := App (App (App (Op Fop) M) M) (App k_op i_op).
Definition fst_projection M := right_projection(left_projection M).
Definition snd_projection M := right_projection M.

Lemma fst_red : forall M N, sf_red (fst_projection (pair M N)) M.
Proof.
intros; unfold fst_projection, left_projection, right_projection.  unfold_op.
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto. eapply succ_red.
eapply2 f_compound_red. eval_tac. eapply succ_red.
eapply2 f_compound_red. eval_tac. auto. eapply succ_red.
eapply2 f_compound_red. eval_tac.
Qed.

Lemma snd_red : forall M N, sf_red (snd_projection (pair M N)) N.
Proof.
intros; unfold snd_projection, left_projection, right_projection.  unfold_op.
eapply succ_red. eapply2 f_compound_red. eval_tac.
Qed.

Lemma fst_preserves_sf_red:
forall M N, sf_red M N -> sf_red (fst_projection M) (fst_projection N).
Proof.
intros; unfold fst_projection, left_projection, right_projection.
repeat eapply2 preserves_app_sf_red. Qed.

Lemma snd_preserves_sf_red:
forall M N, sf_red M N -> sf_red (snd_projection M) (snd_projection N).
Proof.
intros; unfold snd_projection, left_projection, right_projection.
repeat eapply2 preserves_app_sf_red. Qed.

Lemma subst_rec_preserves_left_projection :
forall M N k, subst_rec (left_projection M) N k = left_projection (subst_rec M N k).
Proof. intros; unfold left_projection. simpl. auto. Qed.

Lemma subst_rec_preserves_right_projection :
forall M N k, subst_rec (right_projection M) N k = right_projection (subst_rec M N k).
Proof. intros; unfold right_projection. simpl. auto. Qed.

Lemma subst_rec_preserves_fst_projection :
forall M N k, subst_rec (fst_projection M) N k = fst_projection (subst_rec M N k).
Proof.
intros; unfold fst_projection. rewrite subst_rec_preserves_right_projection.
rewrite subst_rec_preserves_left_projection. auto.
Qed.

Lemma subst_rec_preserves_snd_projection :
forall M N k, subst_rec (snd_projection M) N k = snd_projection (subst_rec M N k).
Proof.
intros; unfold snd_projection. apply subst_rec_preserves_right_projection.
Qed.

Lemma pattern_size_app_comb:
forall M N, pattern_size(app_comb M N) = pattern_size M + pattern_size N.
Proof. intros; unfold app_comb. unfold_op; unfold  pattern_size; fold pattern_size; omega.  Qed.

Definition star_opt_app_comb M N :=
App (App (Op Sop) (App (Op Kop) (App (Op Aop) M))) N.

Lemma star_opt_app_comb_red:
forall M N P, sf_red (App (star_opt_app_comb M N) P) (app_comb M (App N P)).
Proof.
intros; unfold star_opt_app_comb, app_comb. eval_tac.  eval_tac.
Qed.

Definition add_fn := star_opt (star_opt
(* recursion argument, ((sigma,x),u)  *)
(extension (app_comb (Ref 1) (Ref 0))
(* tag *)
        (App (extension (app_comb (Ref 1) (Ref 0))
                        (App (App (App (Ref 5) (Ref 4)) (Ref 1))
                             (App (App (Ref 5) (Ref 4)) (Ref 0)))
(* add *)
             (extension (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0))
                        (app_comb (Ref 4)
                                  (App (App (Op Fop) (App (App (Op Fop)
                                                               (App (App (Ref 6) (Ref 5)) (Ref 2)))
                                                     (Ref 1)))
                                       (App (App (Ref 6) (Ref 5)) (Ref 0))))
(* var *)
             (App k_op (App (App (App (App (Op Eop) (Ref 0))
                                     (snd_projection (fst_projection (Ref 2)))) (* y = x *)
                               (snd_projection (Ref 2)))  (* u *)
                          (App (fst_projection (fst_projection (Ref 2)))
                               (app_comb (Ref 1) (Ref 0)))))
                                          (* sigma (var y) *)

 )) (Ref 0))

(* abs *)
(extension (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (Ref 2) (Ref 1))))) (App k_op (Ref 0)))
           (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (App (App (Ref 5) (Ref 4)) (Ref 2)) (Ref 1))))) (App k_op (Ref 0)))
(* Iop  *)
(fst_projection (fst_projection (Ref 0))))
)).

Definition add M :=  app_comb (app_comb (app_comb omega3 omega3) add_fn) M.

Definition abs sigma x t :=
App (App (Op Sop)  (star_opt_app_comb (app_comb (app_comb omega3 omega3) add_fn)
                         (App (Op Fop) (pair sigma x))))
    (App k_op t) .

Lemma Y3_to_add: forall sigma, sf_red (App (Y3 add_fn) sigma) (add sigma).
Proof.
intros. unfold Y3, app_comb.
eapply transitive_red.  eapply2 star_opt_beta.
unfold subst; rewrite ! subst_rec_app.
rewrite ! (subst_rec_closed omega3). 2: unfold omega3; cbv; auto.
unfold lift; rewrite subst_rec_lift_rec; try omega.
unfold subst_rec; fold subst_rec. insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
unfold add; eapply2 zero_red.
Qed.

Lemma maxvar_add: forall M, maxvar (add M) = maxvar M.
Proof.
unfold add, app_comb. intros. unfold maxvar; fold maxvar.
replace (maxvar omega3) with 0 by (unfold omega3; cbv; auto).
replace (maxvar add_fn) with 0. simpl; omega.
unfold add_fn. rewrite ! maxvar_star_opt.
repeat (rewrite maxvar_extension; rewrite ? maxvar_app; rewrite ? maxvar_app_comb).
cbv.  auto.
Qed.

Lemma abs_red :
forall sigma x t u, sf_red (App (abs sigma x t) u)
                           (App (add (pair (pair sigma x) u)) t).
Proof.
intros; unfold abs, app_comb. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 star_opt_app_comb_red. eval_tac.
eapply2 preserves_app_sf_red.
Qed.

Lemma lift_rec_preserves_Y3: forall M n k, lift_rec (Y3 M) n k = Y3 (lift_rec M n k).
Proof.
intros. unfold Y3, app_comb.  rewrite lift_rec_preserves_star_opt.
unfold lift, lift_rec; fold lift_rec; rewrite lift_lift_rec; try omega.
rewrite ! (lift_rec_closed omega3).  unfold  lift_rec; fold lift_rec. relocate_lt.  auto.
unfold omega3; cbv; auto.
Qed.

Lemma add_red_tag:
forall sigma M N, sf_red (App (add sigma) (tag M N))
                         (App (App (add sigma) M)
                              (App (add sigma) N)).
Proof.
intros. unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red.  eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red. eapply  preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
unfold tag, var, app_comb.
eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
rewrite ! subst_rec_app.
unfold pattern_size; fold pattern_size. unfold plus.
do 6 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite 4? subst_rec_lift_rec; try omega.
rewrite lift_rec_preserves_Y3.
(* tidying up *)
rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
unfold lift; rewrite ! lift_rec_null.
(* 1 *)
do 3 (rewrite subst_rec_ref; insert_Ref_out).
do 7 (rewrite subst_rec_ref at 1; insert_Ref_out).
(rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
unfold lift; rewrite ! lift_rec_null.
unfold subst_rec; fold subst_rec.
(* 1 *)
replace (star_opt (star_opt
(* recursion argument, ((sigma,x),u)  *)
(extension (App (App (Op Aop) (Ref 1)) (Ref 0))
(* tag *)
        (App (extension (App (App (Op Aop) (Ref 1)) (Ref 0))
                        (App (App (App (Ref 5) (Ref 4)) (Ref 1))
                             (App (App (Ref 5) (Ref 4)) (Ref 0)))
(* add *)
             (extension (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0))
                        (App (App (Op Aop) (Ref 4))
                                  (App (App (Op Fop) (App (App (Op Fop)
                                                               (App (App (Ref 6) (Ref 5)) (Ref 2)))
                                                     (Ref 1)))
                                       (App (App (Ref 6) (Ref 5)) (Ref 0))))
(* var *)
             (App k_op (App (App (App (App (Op Eop) (Ref 0))
                                     (snd_projection (fst_projection (Ref 2)))) (* y = x *)
                               (snd_projection (Ref 2)))  (* u *)
                          (App (fst_projection (fst_projection (Ref 2)))
                               (App (App (Op Aop) (Ref 1)) (Ref 0)))))
                                          (* sigma (var y) *)

 )) (Ref 0))

(* abs *)
(extension (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (Ref 2) (Ref 1))))) (App k_op (Ref 0)))
           (App (App (Op Sop) (star_opt_app_comb (Ref 3)
                         (App (Op Fop) (pair (App (App (Ref 5) (Ref 4)) (Ref 2)) (Ref 1))))) (App k_op (Ref 0)))
(* Iop  *)
(fst_projection (fst_projection (Ref 0))))
)))
with add_fn by auto.
apply preserves_app_sf_red;
apply preserves_app_sf_red;
try (eapply2 zero_red; fail);
apply Y3_to_add.
Qed.

Lemma add_red_var_unequal:
forall i u sigma j, program i -> program j -> i <> j ->
matchfail (app_comb (Ref 1) (Ref 0)) j ->
matchfail  (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0)) j ->
sf_red (App (add (pair (pair sigma i) u)) (var j)) (App sigma (var j)).
Proof.
intros. unfold_op;  unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matching.
unfold var, var_fn, app_comb; unfold_op.
 eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* not an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* not a pair *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* 1 *)
rewrite ! (subst_rec_closed k_op); unfold_op; auto.
rewrite ! (subst_rec_closed (Op Eop)); auto.
unfold pattern_size; fold pattern_size. unfold plus.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite lift_rec_null;
rewrite 4? subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! subst_rec_preserves_snd_projection.
rewrite ! subst_rec_preserves_fst_projection.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. eval_tac.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. auto.
eapply snd_preserves_sf_red. eapply2 fst_red. eapply2 snd_red.
eapply preserves_app_sf_red.
eapply transitive_red.
eapply fst_preserves_sf_red. eapply2 fst_red. eapply2 fst_red. auto.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red. eapply2 snd_red. auto. eapply2 zero_red.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 unequal_programs. auto. eapply2 zero_red.  eval_tac.
apply preserves_app_sf_red. auto.
insert_Ref_out.
unfold lift; rewrite ! lift_rec_null.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. eapply2 zero_red.
Qed.

Lemma add_red_var_equal:
forall i u sigma, program i ->
matchfail (app_comb (Ref 1) (Ref 0)) i ->
matchfail  (App (App (Op Fop) (App (App (Op Fop) (Ref 2)) (Ref 1))) (Ref 0)) i ->
sf_red (App (add (pair (pair sigma i) u)) (var i)) u.
Proof.
intros. unfold_op;  unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matching.
unfold var, var_fn, app_comb; unfold_op.
 eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
(* not an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* not a pair *)
eapply transitive_red.
 eapply2 extensions_by_matchfail.
repeat (rewrite ? subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null. auto.
(* 1 *)
rewrite ! (subst_rec_closed k_op); unfold_op; auto.
unfold pattern_size; fold pattern_size. unfold plus.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out; unfold pred).
unfold lift; rewrite lift_rec_null;
rewrite 4? subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
rewrite ! subst_rec_preserves_snd_projection.
rewrite ! subst_rec_preserves_fst_projection.
do 3 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold subst_rec; fold subst_rec. eval_tac.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red.
eapply snd_preserves_sf_red. eapply2 fst_red. eapply2 snd_red.
eapply preserves_app_sf_red.
eapply transitive_red.
eapply fst_preserves_sf_red. eapply2 fst_red. eapply2 fst_red. auto.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply preserves_app_sf_red. eapply2 zero_red. eapply2 snd_red. auto. eapply2 zero_red.
(* 1 *)
eapply transitive_red. eapply preserves_app_sf_red. eapply preserves_app_sf_red.
eapply2 equal_programs. auto. eapply2 zero_red.  eval_tac.
Qed.

Lemma add_red_abs :
forall sigma x t sigma2,
  sf_red (App (add sigma2) (abs sigma x t))
         (abs (App (add sigma2) sigma) x t).
Proof.
intros. unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matchfail.
(* abs not an app_comb *)
unfold abs, star_opt_app_comb, app_comb; unfold_op.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_l.
eapply2 matchfail_op. unfold factorable; eauto. discriminate.
(* an abs *)
eapply transitive_red. eapply2 extensions_by_matching.
unfold abs, star_opt_app_comb, pair; unfold_op.
eapply2 match_app.  eapply2 match_app.
eapply2 match_app. eapply2 match_app.
eapply2 match_app.
unfold map, app, length, fold_left, subst.
(* 1 *)
unfold star_opt_app_comb.
unfold_op; unfold pattern_size; fold pattern_size. unfold plus; fold plus.
rewrite !  subst_rec_app. rewrite !  subst_rec_op.
unfold lift; rewrite ! lift_rec_null.
do 12 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega.
unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega.
unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold abs, app_comb.
auto.
Qed.

Ltac nf_out :=
  unfold_op;
  match goal with
    | |- normal ?M =>
      match M with
         | App (App (Op _) _) _ => apply nf_compound; [| |auto]; nf_out
          | App (Op _) _ => apply nf_compound; [| |auto]; nf_out
          | _ => try apply nf_op
      end
    | _ => auto
        end.

Lemma add_fn_normal: normal add_fn.
Proof.
unfold add_fn. unfold_op.
repeat apply star_opt_normal.
unfold fst_projection, snd_projection, left_projection, right_projection.
cbv; nf_out; repeat (eapply2 nf_active; nf_out); auto.
Qed.

Lemma add_normal: forall f, normal f -> normal (add f).
Proof.
unfold add, app_comb. intros.
apply nf_compound. 2: auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. 2: eapply2 add_fn_normal. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound.
apply nf_compound. auto. 2: auto.
eapply2 omega3_program. eapply2 omega3_program. auto.
Qed.

Lemma abs_normal:
forall sigma x t, normal sigma -> normal x -> normal t -> normal (abs sigma x t).
Proof.
intros. unfold abs, star_opt_app_comb, app_comb. unfold_op.
apply nf_compound. 2: nf_out; auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. 2: nf_out; auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound. 2: eapply2 add_fn_normal. 2: auto.
apply nf_compound. auto. 2: auto.
apply nf_compound.
apply nf_compound. auto. 2: auto.
eapply2 omega3_program. eapply2 omega3_program. auto.
Qed.

Lemma add_red_add:
forall sigma sigma2 y v,
sf_red (App (add sigma) (add (pair (pair sigma2 y) v)))
        (add (pair (pair (App (add sigma) sigma2) y)
                   (App (add sigma) v))).
Proof.
intros. unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red.  eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red. eapply  preserves_app_sf_red.
eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
(* an app_comb *)
eapply transitive_red.
 eapply2 extensions_by_matching.
unfold add.
unfold app_comb; unfold_op. eapply2 match_app.
(* 1 *)
unfold map, app, length, fold_left, subst.
unfold subst_rec; fold subst_rec.
rewrite ! subst_rec_preserves_extension.
rewrite ! subst_rec_app.
insert_Ref_out.
(* not a tag *)
eapply transitive_red. apply extensions_by_matchfail.
repeat (rewrite subst_rec_ref; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
unfold app_comb. unfold_op.
eapply2 matchfail_compound_l.
eapply2 matchfail_compound_l.
eapply2 matchfail_op. left; eauto. discriminate.
(* 1  not a var *)
unfold pattern_size; fold pattern_size. unfold plus; fold plus.
do 12 (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_null.
eapply transitive_red. eapply extensions_by_matching.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite lift_rec_null. rewrite subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
repeat eapply2 match_app.
unfold map, app, length, fold_left, subst.
(* 1 *)
unfold subst_rec; fold subst_rec.
rewrite ! lift_rec_lift_rec; try omega.  unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.
unfold add. apply preserves_app_sf_red.
eapply2 zero_red.
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
 apply preserves_app_sf_red.  apply preserves_app_sf_red.  auto.
(* 2 *)
 apply preserves_app_sf_red.  apply preserves_app_sf_red.  auto.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
rewrite ! lift_rec_null.  insert_Ref_out.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite lift_rec_null.
eapply2 zero_red.
 insert_Ref_out.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite lift_rec_null.
rewrite subst_rec_lift_rec; try omega. rewrite lift_rec_null; auto.
(* 1 *)
 insert_Ref_out.
 apply preserves_app_sf_red.  apply preserves_app_sf_red.
unfold lift; rewrite lift_rec_null.
(rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null.
eapply2 zero_red.
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite ! lift_rec_null.  auto.
repeat (rewrite subst_rec_ref at 1; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega.  unfold plus.
rewrite ! subst_rec_lift_rec; try omega.
rewrite lift_rec_null. auto.
Qed.

Lemma add_red_empty:
forall sigma,
sf_red (App (add sigma) i_op) (App (fst_projection (fst_projection sigma)) i_op) .
Proof.
intros. unfold add at 1, app_comb. eval_tac. eval_tac. eval_tac.
eapply transitive_red. eapply preserves_app_sf_red. eapply2 omega3_omega3. auto.
(* 1 *)
unfold add_fn, app_comb.
eapply transitive_red.
eapply preserves_app_sf_red.  eapply2 star_opt_beta2. auto.
unfold subst; rewrite ! subst_rec_preserves_extension.
eapply transitive_red. eapply2 extensions_by_matchfail.
eapply transitive_red. eapply2 extensions_by_matchfail.
(* 1 *)
rewrite ! subst_rec_preserves_fst_projection.
 repeat (unfold subst_rec; fold subst_rec; insert_Ref_out).
unfold lift; rewrite ! lift_rec_lift_rec; try omega. unfold plus.
rewrite ! subst_rec_lift_rec; try omega. rewrite ! lift_rec_null.  auto.
Qed.


From discprob.basic Require Import base order.
From discprob.prob Require Import prob countable finite stochastic_order.
From discprob.monad Require Import monad monad_cost.
From mathcomp Require Import ssreflect ssrbool ssrfun eqtype ssrnat seq div choice fintype.
From mathcomp Require Import tuple finfun bigop prime binomial finset.
Require Import Reals Fourier Psatz Omega.

(* The following form of writing down a spec for the output of the monad comes
   from how Adam Chlipala does monadic reasoning in his PoplMark challenge solution;
   the idea is simple but it helps guide tactics to write things in this form *)

Definition output {A} (p: ldist_cost A) := [seq i.2.2 | i <- outcomes p].
Definition coutput {A} (p: ldist_cost A) := [seq i.2 | i <- outcomes p].

Definition mspec {A: eqType} (m: ldist_cost A) (P: A → Prop) :=
  ∀ y, y \in output m → P y.

Lemma mspec_mret {A: eqType} (x: A) (P: A → Prop):
  P x → mspec (mret x) P.
Proof.
  intros HP y. rewrite /mret/ldist_cost_ret/mret/dist_ret/output//= mem_seq1.
  move /eqP => -> //.
Qed.

Lemma output_mbind_in {A B: eqType} b (m: ldist_cost A) (f: A → ldist_cost B):
  (b \in output (x ← m; f x)) →
  ∃ r c a, ((r, (c, a)) \in outcomes m) ∧ (b \in output (f a)).
Proof.
  rewrite /mbind/ldist_cost_bind/output.
  move /mapP => [[r [c b'] Hin]] => //= ->.
  eapply (in_ldist_bind _ r (c, b') m) in Hin as (r'&r''&(c', a)&Hin1&Hin2&Heq).
  exists r'', c', a; split; first done.
  eapply (in_ldist_bind _ r' (c, b') (f a)) in Hin1 as (?&?&(?&?)&Hin3&Hin4&?).
  subst. rewrite //= mem_seq1 in Hin3. move /eqP in Hin3. inversion Hin3; subst.
  apply /mapP; eauto.
Qed.

Lemma mspec_mbind {A B: eqType} (f: A → ldist_cost B) m (P: A → Prop) (Q: B → Prop):
  mspec m P →
  (∀ a, P a → mspec (f a) Q) →
  mspec (mbind f m) Q.
Proof.
  intros Hinput Hbody b Hin.
  edestruct (output_mbind_in b m f) as (r&c&a&Hin'&Hout); eauto.
  eapply Hbody; eauto. apply Hinput; eauto.
  apply /mapP; eauto.
Qed.

Tactic Notation "tbind" open_constr(P) :=
  match goal with
  | [ |- mspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@mspec_mbind _ _ f m P); auto
  | [ |- mspec (base.mbind ?f ?m) ?Q ] =>
    intros; eapply (@mspec_mbind _ _ f m P); auto
  end.

Definition cspec {A: eqType} (m: ldist_cost A) (P: nat * A → Prop) :=
  ∀ y, y \in coutput m → P y.

Lemma cspec_mret {A: eqType} (x: A) (P: nat * A → Prop):
  P (O, x) → cspec (mret x) P.
Proof.
  intros HP y. rewrite /mret/ldist_cost_ret/mret/dist_ret/output//= mem_seq1.
  move /eqP => -> //.
Qed.

Lemma cspec_dist_ret {A: eqType} x (P: nat * A → Prop):
  P x → cspec (dist_ret _ x) P.
Proof.
  intros HP y. rewrite /mret/ldist_cost_ret/mret/dist_ret/output//= mem_seq1.
  move /eqP => -> //.
Qed.

Lemma fun_to_cspec {A: eqType} (m: ldist_cost A) (P: nat * A → Prop):
  cspec m P → (∀ x, P ((rvar_of_ldist m) x)).
Proof.
  rewrite /cspec/coutput => Hspec /= x.
  apply /Hspec/mem_nth. rewrite size_map. inversion x. done.
Qed.

Lemma coutput_mbind_in {A B: eqType} b (m: ldist_cost A) (f: A → ldist_cost B):
  (b \in coutput (x ← m; f x)) →
  ∃ r c a, ((r, (c, a)) \in outcomes m) ∧ ((fst b - c)%nat, snd b) \in coutput (f a)
                                         ∧ (fst b - c + c = fst b)%nat.
Proof.
  rewrite /mbind/ldist_cost_bind/output.
  move /mapP => [[r [c b'] Hin]] => //= ->.
  eapply (in_ldist_bind _ r (c, b') m) in Hin as (r'&r''&(c', a)&Hin1&Hin2&Heq).
  eapply (in_ldist_bind _ r' (c, b') (f a)) in Hin1 as (?&?&(?&?)&Hin3&Hin4&?).
  subst. rewrite //= mem_seq1 in Hin3. move /eqP in Hin3. inversion Hin3; subst.
  exists r'', c', a; repeat split; first done.
  - apply /mapP; eauto.
    eexists; eauto => //=; f_equal; auto with *.
  - rewrite //=. rewrite -?plusE -?minusE. omega.
Qed.

Lemma cspec_mbind {A B: eqType} (f: A → ldist_cost B) m (P: nat * A → Prop) (Q: nat * B → Prop):
  cspec m P →
  (∀ a, P a → cspec (f (snd a)) (λ nb, Q ((fst a + fst nb)%nat, snd nb)))→
  cspec (mbind f m) Q.
Proof.
  intros Hinput Hbody nb Hin.
  edestruct (coutput_mbind_in nb m f) as (r&c&a&Hin'&Hout&Heq); eauto.
  destruct nb as (nb1&nb2). rewrite //= in Heq. rewrite -Heq. rewrite addnC.
  replace c with (fst (c, a)); last done. specialize (Hbody (c, a)).
  rewrite /cspec//= in Hbody. rewrite //= in Hout. rewrite //=.
  assert (HP: P (c, a)).
  { apply Hinput. rewrite/ coutput. apply /mapP => //=. eauto. }
  eapply (Hbody HP ((nb1 - c)%nat, nb2)); auto.
Qed.

Lemma cspec_mspec {A: eqType} (m: ldist_cost A) (P: A → Prop):
  mspec m P → cspec m (λ x, P (snd x)).
Proof.
  rewrite /mspec/cspec/coutput/output => Hin y.
  move /mapP => [[c x] Hin' Heq].
  subst. apply Hin. apply /mapP. eauto.
Qed.

Tactic Notation "cbind" open_constr(P) :=
  match goal with
  | [ |- cspec (mbind ?f ?m) ?Q ] =>
    intros; eapply (@cspec_mbind _ _ f m P); auto
  end.

Lemma Ex_bound {A : eqType} (X: ldist_cost A) f r:
  cspec X (λ x, f x <= r) →
  Ex (rvar_comp (rvar_of_ldist X) f) <= r.
Proof.
  intros Hcspec. rewrite Ex_fin_comp.
  eapply Rle_trans.
  {
    eapply Rle_bigr => i _.
    apply Rmult_le_compat_l; last apply Hcspec.
    - apply Rge_le, ge_pr_0.
    - destruct i as (?&?) => //=. rewrite /coutput -mem_undup -img_rvar_of_ldist' //.
  }
  rewrite -big_distrl //= (pr_sum_all (rvar_of_ldist X)) Rmult_1_l. fourier.
Qed.