Require Export SfLib.

(**  Motivative example:
     Z ::= X;
     Y ::= 1;
     WHILE not (Z = 0) DO
       Y ::= Y * Z;
       Z ::= Z - 1
     END
*)

Module AExp.

  Inductive aexp : Type :=
  | ANum : nat -> aexp
  | APlus : aexp -> aexp -> aexp
  | AMinus : aexp -> aexp -> aexp
  | AMult : aexp -> aexp -> aexp.

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

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

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

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

  Theorem optimize_0plus_sound : forall e,
    aeval (optimize_0plus e) = aeval e.
  Proof.
    intros e.
    induction e.

    (* ANum *)
    reflexivity.
    (* APlus *)
    destruct e1.
      destruct n.
        simpl. apply IHe2.
        simpl. rewrite IHe2. reflexivity.
      simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
      simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
      simpl. simpl in IHe1. rewrite IHe1. rewrite IHe2. reflexivity.
    (* AMinus *)
    simpl. rewrite IHe1. rewrite IHe2. reflexivity.
    simpl. rewrite IHe1. rewrite IHe2. reflexivity.
  Qed.

  Theorem optimize_0plus_sound' : forall e,
    aeval (optimize_0plus e) = aeval e.
  Proof.
    intros e.
    induction e;
      try (simpl; rewrite IHe1; rewrite IHe2; reflexivity);
      try reflexivity.

  (* APlus *)
    destruct e1;
      try (simpl; simpl in IHe1; rewrite IHe1; rewrite IHe2; reflexivity).
    destruct n;
      simpl; rewrite IHe2; reflexivity.
  Qed.

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

  Example silly_presburger_example :
    forall m n o p,
      m + n <= n + o /\ o + 3 = p + 3 ->
      m <= p.
  Proof.
    intros. omega.
  Qed.

  Reserved Notation "e '||' n" (at level 50, left associativity).

  Inductive aevalR : aexp -> nat -> Prop :=
  | E_ANum : forall (n:nat),
               (ANum n) || n
  | E_APlus : forall (e1 e2: aexp) (n1 n2 : nat),
                (e1 || n1) -> (e2 || n2) -> (APlus e1 e2) || (n1 + n2)
  | E_AMinus : forall (e1 e2: aexp) (n1 n2 : nat),
                 (e1 || n1) -> (e2 || n2) -> (AMinus e1 e2) || (n1 - n2)
  | E_AMult :  forall (e1 e2: aexp) (n1 n2 : nat),
                 (e1 || n1) -> (e2 || n2) -> (AMult e1 e2) || (n1 * n2)

                                                           where "e '||' n" := (aevalR e n) : type_scope.

  Tactic Notation "aevalR_cases" tactic(first) ident(c) :=
    first;
    [ Case_aux c "E_ANum" | Case_aux c "E_APlus"
      | Case_aux c "E_AMinus" | Case_aux c "E_AMult" ].

  Theorem aeval_iff_aevalR :
    forall a n,
      (a || n) <-> aeval a = n.
  Proof.
    split.
    Case "->".
      intros H; induction H; subst; reflexivity.
    Case "<-".
      generalize dependent n.
      induction a;
      intros; subst; simpl; constructor;

      try apply IHa1;
        try apply IHa2;
        reflexivity.
  Qed.

  Inductive bevalR : bexp -> bool -> Prop :=
    | E_BTrue : bevalR BTrue true
    | E_BFalse : bevalR BFalse false
    | E_BEq : forall (e1 e2 : aexp) (n1 n2 : nat),
                (e1 || n1) -> (e2 || n2) -> (bevalR (BEq e1 e2) (beq_nat n1 n2))
    | E_BLe : forall (e1 e2 : aexp) (n1 n2 : nat),
                (e1 || n1) -> (e2 || n2) -> (bevalR (BLe e1 e2) (ble_nat n1 n2))
    | E_BNot : forall (e : bexp) (b : bool),
                 (bevalR e b) -> (bevalR (BNot e) (negb b))
    | E_BAnd : forall (e1 e2 : bexp) (b1 b2 : bool),
                 (bevalR e1 b1) -> (bevalR e2 b2) -> (bevalR (BAnd e1 e2) (b1 && b2)).

  Theorem beval_iff_bevalR :
    forall e b,
      bevalR e b <-> beval e = b.
  Proof.
    split.
    Case "->".
    intros H.
    induction H.
    reflexivity.

    reflexivity.

    simpl.
    apply aeval_iff_aevalR in H.
    apply aeval_iff_aevalR in H0.
    rewrite H. rewrite H0.
    reflexivity.

    simpl.
    apply aeval_iff_aevalR in H.
    apply aeval_iff_aevalR in H0.
    rewrite H. rewrite H0.
    reflexivity.

    simpl.
    rewrite IHbevalR.
    reflexivity.

    simpl.
    rewrite IHbevalR1.
    rewrite IHbevalR2.
    reflexivity.

    Case "<-".
    generalize dependent b.
    induction e;
      intros;
      simpl in H;
      rewrite <- H;
      constructor.

    apply aeval_iff_aevalR.
    reflexivity.
    apply aeval_iff_aevalR.
    reflexivity.

    apply aeval_iff_aevalR.
    reflexivity.
    apply aeval_iff_aevalR.
    reflexivity.

    apply IHe.
    reflexivity.

    apply IHe1.
    reflexivity.
    apply IHe2.
    reflexivity.
  Qed.

End AExp.

Module Id.

  Inductive id : Type :=
    Id : nat -> id.

  Definition beq_id X1 X2 :=
    match (X1, X2) with
        (Id n1, Id n2) => beq_nat n1 n2
    end.

  Theorem beq_id_refl :
    forall X,
      true = beq_id X X.
  Proof.
    intros. destruct X.
    apply beq_nat_refl.  Qed.

  Theorem beq_id_eq :
    forall i1 i2,
      true = beq_id i1 i2 -> i1 = i2.
  Proof.
  Admitted.

  Theorem beq_id_false_not_eq :
    forall i1 i2,
      beq_id i1 i2 = false -> i1 <> i2.
  Proof.
  Admitted.

  Theorem not_eq_beq_id_false :
    forall i1 i2,
      i1 <> i2 -> beq_id i1 i2 = false.
  Proof.
  Admitted.

  Theorem beq_id_sym:
    forall i1 i2,
      beq_id i1 i2 = beq_id i2 i1.
  Proof.
  Admitted.

End Id.

Definition state := id -> nat.

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

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

Theorem update_eq : forall n X st,
  (update st X n) X = n.
Proof.
  Admitted.

Theorem update_neq : forall V2 V1 n st,
  beq_id V2 V1 = false ->
  (update st V2 n) V1 = (st V1).
Proof.
  Admitted.

Theorem update_example : forall (n:nat),
  (update empty_state (Id 2) n) (Id 3) = 0.
Proof.
  Admitted.

Theorem update_shadow : forall x1 x2 k1 k2 (f : state),
   (update  (update f k2 x1) k2 x2) k1 = (update f k2 x2) k1.
Proof.
  Admitted.

Theorem update_same : forall x1 k1 k2 (f : state),
  f k1 = x1 ->
  (update f k1 x1) k2 = f k2.
Proof.
  Admitted.

Theorem update_permute : forall x1 x2 k1 k2 k3 f,
  beq_id k2 k1 = false ->
  (update (update f k2 x1) k1 x2) k3 = (update (update f k1 x2) k2 x1) k3.
Proof.
  Admitted.

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

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

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

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

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

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

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

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

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

Notation "'SKIP'" :=
  CSkip.
Notation "X '::=' a" :=
  (CAss X a) (at level 60).
Notation "c1 ; c2" :=
  (CSeq c1 c2) (at level 80, right associativity).
Notation "'WHILE' b 'DO' c 'END'" :=
  (CWhile b c) (at level 80, right associativity).
Notation "'IFB' e1 'THEN' e2 'ELSE' e3 'FI'" :=
  (CIf e1 e2 e3) (at level 80, right associativity).

Definition fact_in_coq : com :=
  Z ::= AId X;
  Y ::= ANum 1;
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    Y ::= AMult (AId Y) (AId Z);
    Z ::= AMinus (AId Z) (ANum 1)
  END.

Definition fact_body : com :=
  Y ::= AMult (AId Y) (AId Z) ;
  Z ::= AMinus (AId Z) (ANum 1).

Definition fact_loop : com :=
  WHILE BNot (BEq (AId Z) (ANum 0)) DO
    fact_body
  END.

Definition fact_com : com :=
  Z ::= AId X ;
  Y ::= ANum 1 ;
  fact_loop.

(* from ImpCEvalFun *)
Notation "'LETOPT' x <== e1 'IN' e2"
   := (match e1 with
         | Some x => e2
         | None => None
       end)
   (right associativity, at level 60).

Fixpoint ceval_step (st : state) (c : com) (i : nat)
                    : option state :=
  match i with
  | O => None
  | S i' =>
    match c with
      | SKIP =>
          Some st
      | l ::= a1 =>
          Some (update st l (aeval st a1))
      | c1 ; c2 =>
          LETOPT st' <== ceval_step st c1 i' IN
          ceval_step st' c2 i'
      | IFB b THEN c1 ELSE c2 FI =>
          if (beval st b)
            then ceval_step st c1 i'
            else ceval_step st c2 i'
      (* This definition of while needs special tecnique *)
      | WHILE b1 DO c1 END =>
          if (beval st b1)
          then LETOPT st' <== ceval_step st c1 i' IN
               ceval_step st' c i'
          else Some st
    end
  end.

Definition test_ceval (st:state) (c:com) :=
  match ceval_step st c 500 with
  | None    => None
  | Some st => Some (st X, st Y, st Z)
  end.

Definition pup_to_n : com :=
  Y ::= ANum 0;
  WHILE BLe (ANum 1) (AId X) DO
    Y ::= APlus (AId Y) (AId X);
    X ::= AMinus (AId X) (ANum 1)
  END.

Example pup_to_n_1 :
  test_ceval (update empty_state X 5) pup_to_n
  = Some (0, 15, 0).
Proof. reflexivity. Qed.

(* Relational definition *)

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

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

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

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

Example ceval_example2:
    (X ::= ANum 0; Y ::= ANum 1; Z ::= ANum 2) / empty_state ||
    (update (update (update empty_state X 0) Y 1) Z 2).
Proof.
  repeat eapply E_Seq; eapply E_Ass; simpl; exists.
Qed.

Theorem ceval_deterministic: forall c st st1 st2,
     c / st || st1  ->
     c / st || st2 ->
     st1 = st2.
Proof.
  intros c st st1 st2 E1 E2.
  generalize dependent st2.

  ceval_cases (induction E1) case;
    intros; inversion E2; subst.
  reflexivity.

  reflexivity.

  apply IHE1_1 in H1.
  rewrite <- H1 in H4.
  apply IHE1_2.
  assumption.

  apply IHE1.
  assumption.

  rewrite H in H5.
  inversion H5.

  rewrite H in H5.
  inversion H5.

  apply IHE1.
  assumption.

  reflexivity.

  rewrite H in H2.
  inversion H2.

  rewrite H in H4.
  inversion H4.

  apply IHE1_2.
  assert (st' = st'0) as EQ1.
  apply IHE1_1.
  assumption.
  rewrite EQ1.
  assumption.
Qed.

Definition XtimesYinZ : com :=
  Z ::= (AMult (AId X) (AId Y)).

Theorem XtimesYinZ_spec :
  forall st n m st',
    st X = n -> st Y = m -> XtimesYinZ / st || st' -> st' Z = n * m.
Proof.
  intros.
  inversion H1.
  subst.
  apply update_eq.
Qed.

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

Theorem loop_never_stops : forall st st',
  ~(loop / st || st').
Proof.
  intros st st' contra. unfold loop in contra.
  remember (WHILE BTrue DO SKIP END) as loopdef.
  ceval_cases (induction contra) Case; inversion Heqloopdef.
  subst. inversion H.
  subst. apply IHcontra2. assumption.
Qed.
(* Reference: https://github.com/sfja/sfja/blob/master/ImpList_J.v *)

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

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

Definition fact_invariant (x:nat) (st:state) :=
  (st Y) * (real_fact (st Z)) = real_fact x.

Require Export Arith.Minus.

Theorem fact_body_preserves_invariant: forall st st' x,
     fact_invariant x st ->
     st Z <> 0 ->
     fact_body / st || st' ->
     fact_invariant x st'.
Proof.
  unfold fact_invariant, fact_body.
  intros st st' x Hm HZnz He.
  inversion He.
  subst.
  inversion H1.
  inversion H4.
  subst.

  unfold update. simpl.
  destruct (st Z) as [| z'].
  apply ex_falso_quodlibet.  apply HZnz. reflexivity.

  rewrite <- Hm.
  rewrite <- mult_assoc.
  replace (S z' - 1) with z' by omega.
  reflexivity.
Qed.

Theorem fact_loop_preserves_invariant : forall st st' x,
     fact_invariant x st ->
     fact_loop / st || st' ->
     fact_invariant x st'.
Proof.
  intros st st' x H Hce.
  remember fact_loop as c.
  ceval_cases (induction Hce) Case;
    inversion Heqc; subst; clear Heqc.
  Case "E_WhileEnd".
  assumption.
  Case "E_WhileLoop".
  apply IHHce2.
  apply fact_body_preserves_invariant with st.
  assumption.
  simpl in H0.
  apply beq_nat_false.
  apply negb_true_iff.
  assumption.
  assumption.
  reflexivity.
Qed.

Theorem guard_false_after_loop: forall b c st st',
     (WHILE b DO c END) / st || st' ->
     beval st' b = false.
Proof.
  intros b c st st' Hce.
  remember (WHILE b DO c END) as cloop.
  ceval_cases (induction Hce) Case;
     inversion Heqcloop; subst; clear Heqcloop.
  Case "E_WhileEnd".
    assumption.
  Case "E_WhileLoop".
    apply IHHce2. reflexivity.  Qed.

Theorem fact_com_correct : forall st st' x,
     st X = x ->
     fact_com / st || st' ->
     st' Y = real_fact x.
Proof.
  intros st st' x HX Hce.
  inversion Hce. subst. clear Hce.
  inversion H1.  subst. clear H1.
  inversion H4.  subst. clear H4.
  inversion H1.  subst. clear H1.
  rename st' into st''. simpl in H5.
  remember (update (update st Z (st X)) Y 1) as st'.
  assert (fact_invariant (st X) st').
    subst. unfold fact_invariant, update. simpl. omega.
  assert (fact_invariant (st X) st'').
    apply fact_loop_preserves_invariant with st'; assumption.
  apply guard_false_after_loop in H5. simpl in H5.
  assert (st'' Z = 0).
    apply beq_nat_true_iff. rewrite <- negb_false_iff. assumption.
  unfold fact_invariant in H0.
  rewrite H1 in H0.
  simpl in H0.
  omega.
Qed.

(* stack machine *)
Inductive sinstr : Type :=
| SPush : nat -> sinstr
| SLoad : id -> sinstr
| SPlus : sinstr
| SMinus : sinstr
| SMult : sinstr.

Definition s_eval (st : state) (stack : list nat) (inst : sinstr) : list nat :=
  match inst with
    | SPush x => x :: stack
    | SLoad v => st v :: stack
    | SPlus   => match stack with
                   | a :: b :: rest => b + a :: rest
                   | _ => []
                 end
    | SMinus  => match stack with
                   | a :: b :: rest => b - a :: rest
                   | _ => []
                 end
    | SMult   => match stack with
                   | a :: b :: rest => b * a :: rest
                   | _ => []
                 end
  end.

Fixpoint s_execute (st : state) (stack : list nat)
                   (prog : list sinstr)
                 : list nat :=
  match prog with
    | [] => stack
    | inst :: insts =>
      s_execute st (s_eval st stack inst) insts
  end.

Example s_execute1 :
     s_execute empty_state []
       [SPush 5, SPush 3, SPush 1, SMinus]
   = [2, 5].
Proof. reflexivity. Qed.

Example s_execute2 :
     s_execute (update empty_state X 3) [3,4]
       [SPush 4, SLoad X, SMult, SPlus]
   = [15, 4].
Proof. reflexivity. Qed.

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
    | ANum n       => [SPush n]
    | AId X        => [SLoad X]
    | APlus a1 a2  => s_compile a1 ++ s_compile a2 ++ [SPlus]
    | AMinus a1 a2 => s_compile a1 ++ s_compile a2 ++ [SMinus]
    | AMult a1 a2  => s_compile a1 ++ s_compile a2 ++ [SMult]
  end.

(* not used *)
Theorem s_execute_step :
  forall (st : state) (inst : sinstr) (prog : list sinstr) (l l' l'': list nat),
    s_eval st l inst = l' ->
    s_execute st l' prog = l'' ->
    s_execute st l (inst :: prog) = l''.
Proof.
  intros st inst.
  destruct inst;
    simpl;
    intros;
    try rewrite H; assumption;
    try destruct l;
      try rewrite H; assumption;
      try destruct l; rewrite H; assumption.
Qed.

(* not used *)
Theorem s_execute_step_last :
  forall (st : state) (inst : sinstr) (prog : list sinstr) (l l' l'': list nat),
    s_execute st l prog = l' ->
    s_eval st l' inst = l'' ->
    s_execute st l (prog ++ [inst]) = l''.
Proof.
  intros st inst.
  induction prog.
  destruct inst;
    simpl;
    intros;
    rewrite H;
    assumption.

  intros.
  rewrite <- app_comm_cons.
  eapply s_execute_step.
  exists.
  eapply IHprog.
  exists.
  simpl in H.
  rewrite H.
  assumption.
Qed.

Theorem s_execute_concat_program :
  forall (st : state) (prog1 prog2 : list sinstr) (l : list nat),
    s_execute st l (prog1 ++ prog2) = s_execute st (s_execute st l prog1) prog2.
Proof.
  intros st.
  induction prog1 as [| inst insts].
  Case "prog1 = []".
    simpl. reflexivity.
  Case "prog1 = inst :: insts".
    simpl.
    intros.
    destruct (s_eval st l inst);
      apply IHinsts.
Qed.

Theorem s_compile_correct : forall (st : state) (e : aexp) (l : list nat),
  s_execute st l (s_compile e) = aeval st e :: l.
Proof.
  intros st.

  aexp_cases (induction e) Case;
    intros;
    simpl;
    try trivial;
    try
      (repeat (rewrite s_execute_concat_program);
       rewrite IHe2;
       rewrite IHe1;
       reflexivity).
Qed.


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

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

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

Example test_next_weekday: (next_weekday (next_weekday saturday)) = tuesday.

Proof. simpl. reflexivity. Qed.

From Coq Require Export String.

Inductive bool: Type :=
  | true
  | false.

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

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

Definition orb (b₁: bool) (b₂ : bool) : bool :=
  match b₁ 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.

Notation "x && y" := (andb x y).
Notation "x || y" := (orb x y).

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

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

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

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

Definition nandb (b₁:bool) (b₂:bool) : bool :=
  if b₁ then (negb b₂)
  else true.

Example test_nand1: (nandb false true) = true.
Proof. simpl. reflexivity. Qed.

Example test_nand2: (nandb true false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nand3: (nandb false false) = true.
Proof. simpl. reflexivity. Qed.

Example test_nand4: (nandb true true) = false.
Proof. simpl. reflexivity. Qed.

Definition andb3 (b₁:bool) (b₂:bool) (b₃:bool) : bool :=
  if (andb (andb b₁ b₂) b₃) then true
  else false.

Example test_andb31: (andb3 true true true) = true.
Proof. simpl. reflexivity. Qed.
Example test_andb32: (andb3 false true true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb33: (andb3 true false true) = false.
Proof. simpl. reflexivity. Qed.
Example test_andb34: (andb3 true true false) = false.
Proof. simpl. reflexivity. Qed.

Check true.
Check (negb true).
Check negb.

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 p => 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 :=
    | B₀
    | B₁.

  Inductive nybble : Type :=
    | bits (b₀ b₁ b₂ b₃ : bit).

  Check (bits B₁ B₀ B₁ B₀) : nybble.

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

  Compute (all_zero (bits B₁ B₀ B₁ B₀)).
  Compute (all_zero (bits B₀ B₀ B₀ B₀)).
End TuplePlayground.

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

  Inductive nat' : Type :=
    | stop
    | tick (foo : 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
  | 0 => 0
  | S 0 => 0
  | S (S n') => n'
  end.

Compute (minustwo 4).

Check S : nat -> nat.
Check pred : nat -> nat.
Check minustwo : nat -> nat.

Fixpoint even (n : nat) : bool :=
  match n with
  | 0 => true
  | S 0 => 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
  | 0 => m
  | S n' => S (plus n' m)
  end.

Compute (plus 3 2).

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

Example test_mult1: (mult 3 3) = 9.
Proof. simpl. reflexivity. Qed.

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

Fixpoint exp (base power : nat) : nat :=
  match power with
  | 0 => S 0
  | S p => mult base (exp base p)
  end.

  Fixpoint factorial (n:nat) : nat :=
    match n with
    | 0 => 1
    | S n' => (NatPlayground2.mult (S 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.

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.

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

Fixpoint leb (n m : nat) : bool :=
  match n with
  | 0 => true
  | S n' => match m with
    | 0 => 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 :=
  andb (leb n m) (negb (eqb n m)).

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_0_n : forall n : nat, 0 + n = n.
Proof.
  intros n. simpl. reflexivity. Qed.

Theorem plus_0_n' : forall n : nat, 0 + n = n.
Proof.
  intros n. reflexivity. Qed.

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

Theorem plus_1_l : forall n : nat, 1 + n = S n.
Proof. intros n. reflexivity. Qed.

Theorem mult_0_l : 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.

Theorem plus_id_exercise : forall n m o : nat,
  n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1 H2.
  rewrite -> H1.
  rewrite -> H2.
  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 mult_n_1 : forall p : nat,
  p * 1 = p.
Proof.
  intros p.
  rewrite <- mult_n_Sm.
  rewrite <- mult_n_O.
  reflexivity. Qed.

Theorem plus_1_neq_0_firsttry : 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.
  - 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.
    + reflexivity.
    + reflexivity.
  - destruct c eqn:Ec.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange : forall b c d,
  andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d. destruct b eqn:Eb.
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
  - destruct c eqn:Ec.
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
    { destruct d eqn:Ed.
      - reflexivity.
      - reflexivity. }
Qed.

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

Theorem plus_1_neq_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 zero_nbeq_plus_1 : forall n : nat,
  0 =? (n + 1) = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.


Require Import List Cpdt.CpdtTactics.

Set Implicit Arguments.
Set Asymmetric Patterns.

Section stream.
  Variable A : Type.

  CoInductive stream : Type :=
  | Cons : A -> stream -> stream.
End stream.

CoFixpoint zeroes : stream nat := Cons 0 zeroes.

CoFixpoint trues_falses : stream bool := Cons true falses_trues
with falses_trues : stream bool := Cons false trues_falses.

Fixpoint approx A (s : stream A) (n : nat) : list A :=
  match n with
  | O => nil
  | S n' =>
    match s with
    | Cons h t => h :: approx t n'
    end
  end.

Eval simpl in approx zeroes 10.
Compute (approx zeroes 10).

Eval simpl in approx trues_falses 10.

Section map.
  Variables A B : Type.
  Variable f : A -> B.

  CoFixpoint map (s : stream A) : stream B :=
    match s with
    | Cons h t => Cons (f h) (map t)
    end.
End map.

Section interleave.
  Variable A : Type.

  CoFixpoint interleave (s1 s2 : stream A) : stream A :=
    match s1, s2 with
    | Cons h1 t1, Cons h2 t2 => Cons h1 (Cons h2 (interleave t1 t2))
    end.
End interleave.

Section map'.
  Variables A B : Type.
  Variable f : A -> B.

  (* CoFixpoint map' (s : stream A) : stream B :=
    match s with
    | Cons h t => interleave (Cons (f h) (map' t)) (Cons (f h) (map' t))
    end. *)
End map'.

Definition tl A (s : stream A) : stream A :=
  match s with
  | Cons _ s' => s'
  end.

CoFixpoint ones : stream nat := Cons 1 ones.
Definition ones' := map S zeroes.

Theorem ones_eq : ones = ones'.
Abort.

Section stream_eq.
  Variable A : Type.

  CoInductive stream_eq : stream A -> stream A -> Prop :=
  | Stream_eq : forall h t1 t2,
      stream_eq t1 t2 -> stream_eq (Cons h t1) (Cons h t2).

End stream_eq.

Theorem ones_eq : stream_eq ones ones'.
  cofix.
  assumption.
  Undo.
  simpl.
Abort.

Definition frob A (s : stream A) : stream A :=
  match s with
  | Cons h t => Cons h t
  end.

Theorem frob_eq : forall A (s : stream A), s = frob s.
  destruct s; reflexivity.
Qed.

Theorem ones_eq : stream_eq ones ones'.
  cofix.
  rewrite (frob_eq ones).
  rewrite (frob_eq ones').
  simpl.
  constructor.
  assumption.
Qed.

Definition hd A (s : stream A) : A :=
  match s with
  | Cons x _ => x
  end.

Section stream_eq_coind.
  Variable A : Type.
  Variable R : stream A -> stream A -> Prop.

  Hypothesis Cons_case_hd : forall s1 s2, R s1 s2 -> hd s1 = hd s2.
  Hypothesis Cons_case_tl : forall s1 s2, R s1 s2 -> R (tl s1) (tl s2).

  Theorem stream_eq_coind : forall s1 s2, R s1 s2 -> stream_eq s1 s2.
    cofix. destruct s1. destruct s2. intro.
    generalize (Cons_case_hd H). simpl. intro Heq. rewrite Heq.
    constructor.
    apply stream_eq_coind.
    apply (Cons_case_tl H).
  Qed.
End stream_eq_coind.

Print stream_eq_coind.

Theorem ones_eq'' : stream_eq ones ones'.
  apply (stream_eq_coind (fun s1 s2 => s1 = ones /\ s2 = ones')); crush.
Qed.

Section stream_eq_loop.
  Variable A : Type.
  Variables s1 s2 : stream A.

  Hypothesis Cons_case_hd : hd s1 = hd s2.
  Hypothesis loop1 : tl s1 = s1.
  Hypothesis loop2 : tl s2 = s2.

  Theorem stream_eq_loop : stream_eq s1 s2.
    apply (stream_eq_coind (fun s1' s2' => s1' = s1 /\ s2' = s2)); crush.
  Qed.
End stream_eq_loop.

Theorem ones_eq''' : stream_eq ones ones'.
  apply stream_eq_loop; crush.
Qed.

Require Import Arith.

Print fact.

CoFixpoint fact_slow' (n : nat) := Cons (fact n) (fact_slow' (S n)).
Definition fact_slow := fact_slow' 1.

CoFixpoint fact_iter' (cur acc : nat) := Cons acc (fact_iter' (S cur) (acc * cur)).
Definition fact_iter := fact_iter' 2 1.

Eval simpl in approx fact_iter 5.
Eval simpl in approx fact_slow 5.

Lemma fact_def : forall x n,
    fact_iter' x (fact n * S n) = fact_iter' x (fact (S n)).
  simpl. intros. f_equal. ring.
Qed.

Hint Resolve fact_def.

Lemma fact_eq' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  intro;
  apply (stream_eq_coind (fun s1 s2 => exists n, s1 = fact_iter' (S n) (fact n)
                                                 /\ s2 = fact_slow' n));
    crush;
    eauto.
Qed.

Theorem fact_eq : stream_eq fact_iter fact_slow.
  apply fact_eq'.
Qed.

Section stream_eq_onequant.
  Variables A B : Type.
  Variables f g : A -> stream B.

  Hypothesis Cons_case_hd : forall x, hd (f x) = hd (g x).
  Hypothesis Cons_case_tl : forall x, exists y,
        tl (f x) = f y /\ tl (g x) = g y.

  Theorem stream_eq_onequant : forall x, stream_eq (f x) (g x).
    intro.
    apply (stream_eq_coind (fun s1 s2 => exists x,
                                s1 = f x /\ s2 = g x));
      crush; eauto.
  Qed.
End stream_eq_onequant.

Lemma fact_eq'' : forall n, stream_eq (fact_iter' (S n) (fact n)) (fact_slow' n).
  apply stream_eq_onequant; crush; eauto.
Qed.

Definition var := nat.
Definition vars := var -> nat.
Definition set (vs : vars) (v : var) (n : nat) : vars :=
  fun v' => if beq_nat v v' then n else vs v'.

Inductive exp : Set :=
| Const : nat -> exp
| Var : var -> exp
| Plus : exp -> exp -> exp.

Fixpoint evalExp (vs : vars) (e : exp) : nat :=
  match e with
  | Const n => n
  | Var v => vs v
  | Plus e1 e2 => evalExp vs e1 + evalExp vs e2
  end.

Inductive cmd : Set :=
| Assign : var -> exp -> cmd
| Seq : cmd -> cmd -> cmd
| If : exp -> cmd -> cmd
| While : exp -> cmd -> cmd.

CoInductive evalCmd : vars -> cmd -> vars -> Prop :=
| EvalAssign : forall vs v e, evalCmd vs (Assign v e) (set vs v (evalExp vs e))
| EvalSeq : forall vs1 vs2 vs3 c1 c2,
    evalCmd vs1 c1 vs2 ->
    evalCmd vs2 c2 vs3 ->
    evalCmd vs1 (Seq c1 c2) vs3
| EvalIfFalse : forall vs e c,
    evalExp vs e = 0 ->
    evalCmd vs (If e c) vs
| EvalIfTrue : forall vs1 vs2 e c,
    evalExp vs1 e <> 0 ->
    evalCmd vs1 c vs2 ->
    evalCmd vs1 (If e c) vs2
| EvalWhileFalse : forall vs e c,
    evalExp vs e = 0 ->
    evalCmd vs (While e c) vs
| EvalWhileTrue : forall vs1 vs2 vs3 e c,
    evalExp vs1 e <> 0 ->
    evalCmd vs1 c vs2 ->
    evalCmd vs2 (While e c) vs3 ->
    evalCmd vs1 (While e c) vs3.

Section evalCmd_coind.
  Variable R : vars -> cmd -> vars -> Prop.

  Hypothesis AssignCase : forall vs1 vs2 v e, R vs1 (Assign v e) vs2
                                              -> vs2 = set vs1 v (evalExp vs1 e).
  Hypothesis SeqCase : forall vs1 vs3 c1 c2, R vs1 (Seq c1 c2) vs3
                                             -> exists vs2, R vs1 c1 vs2 /\ R vs2 c2 vs3.
  Hypothesis IfCase : forall vs1 vs2 e c, R vs1 (If e c) vs2
                      -> (evalExp vs1 e = 0 /\ vs1 = vs2)
                           \/ (evalExp vs1 e <> 0 /\ R vs1 c vs2).
  Hypothesis WhileCase : forall vs1 vs3 e c, R vs1 (While e c) vs3
                                             -> (evalExp vs1 e = 0 /\ vs3 = vs1)
                                                \/ exists vs2, evalExp vs1 e <> 0 /\ R vs1 c vs2 /\ R vs2 (While e c) vs3.

  Theorem evalCmd_coind : forall vs1 c vs2, R vs1 c vs2 -> evalCmd vs1 c vs2.
    cofix; intros; destruct c.
    rewrite (AssignCase H); constructor.
    destruct (SeqCase H) as [? [? ?]]. econstructor; eauto.
    destruct (IfCase H) as [[? ?] | [? ?]]; subst; constructor; auto.
    destruct (WhileCase H) as [[? ?] | [? [? [? ?]]]]; subst; econstructor; eauto.
  Qed.
End evalCmd_coind.

Fixpoint optExp (e : exp) : exp :=
  match e with
  | Plus (Const 0) e => optExp e
  | Plus e1 e2 => Plus (optExp e1) (optExp e2)
  | _ => e
  end.

Fixpoint optCmd (c : cmd) : cmd :=
  match c with
  | Assign v e => Assign v (optExp e)
  | Seq c1 c2 => Seq (optCmd c1) (optCmd c2)
  | If e c => If (optExp e) (optCmd c)
  | While e c => While (optExp e) (optCmd c)
  end.

Lemma optExp_correct : forall vs e, evalExp vs (optExp e) = evalExp vs e.
  induction e; crush;
  repeat (match goal with
          | [ |- context [match ?E with Const _ => _ | _ => _ end]] => destruct E
          | [ |- context [match ?E with O => _ | S _ => _ end]] => destruct E
          end; crush).
Qed.

Hint Rewrite optExp_correct.

Ltac finisher := match goal with
                 | [H : evalCmd _ _ _ |- _ ] => ((inversion H; [])
                                                 || (inversion H; [|])); subst
                 end; crush; eauto 10.

Lemma optCmd_correct1 : forall vs1 c vs2, evalCmd vs1 c vs2
                                          -> evalCmd vs1 (optCmd c) vs2.
  intros; apply (evalCmd_coind (fun vs1 c' vs2 => exists c, evalCmd vs1 c vs2
                                                            /\ c' = optCmd c));
  eauto; crush;
    match goal with
    | [H : _ = optCmd ?E |- _ ] => destruct E; simpl in *; discriminate
                                                           || injection H; intros; subst
    end; finisher.
Qed.

Lemma optCmd_correct2 : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
                                          -> evalCmd vs1 c vs2.
  intros; apply (evalCmd_coind (fun vs1 c vs2 => evalCmd vs1 (optCmd c) vs2));
    crush; finisher.
Qed.

Theorem optCmd_correct : forall vs1 c vs2, evalCmd vs1 (optCmd c) vs2
                                           <-> evalCmd vs1 c vs2.
  intuition;
    apply optCmd_correct1 || apply optCmd_correct2; assumption.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (z : natural) (lf2 : natural) (lf1 : natural)
  : natural := plus Zero (plus Zero lf1).


Require Import Le.

Require Import Logic.Axiom.Wec.
Require Import Logic.Axiom.Dec.
Require Import Logic.Axiom.Witness.

Require Import Logic.Class.Ord.

Require Import Logic.Nat.Ord.
Require Import Logic.Nat.Leq.
Require Import Logic.Nat.Wec.
Require Import Logic.Nat.Dec.

Declare Scope Nat_Subset_scope.

(* Subset of N defined as predicate over N                                      *)
Definition Subset : Type := nat -> Prop.

(* n is an element of subset A.                                                 *)
Definition Elem (n:nat) (A:Subset) : Prop := A n.

Notation "n :: A" := (Elem n A) : Nat_Subset_scope.

Open Scope Nat_Subset_scope.

(* n is the smallest element of A.                                              *)
Definition SmallestOf (A:Subset) (n:nat) : Prop :=
    (n :: A) /\ forall (m:nat), m :: A -> n <= m.

(* A is a finite subset of N.                                                   *)
Definition Finite (A:Subset) : Prop :=
    exists (n:nat), forall (m:nat), m :: A -> m <= n.

(* A /\ [0,n]                                                                   *)
Definition restrict (n:nat) (A:Subset) : Subset :=
    fun (m:nat)  => m :: A /\ m <= n.

Lemma restrictWec : forall (A:Subset) (n:nat), pWec A -> pWec (restrict n A).
Proof.
    intros A n H1 k. apply andWec.
    - apply H1.
    - apply DecWec, leqDec.
Defined.

(* All restricted subsets are finite.                                           *)
Lemma restrictFinite : forall (A:Subset) (n:nat), Finite (restrict n A).
Proof.
    intros A n. exists n. intros m [H1 H2]. assumption.
Defined.

(* If A /\ [0,n] is non-empty, being the smallest element of A is the same as   *)
(* being the smallest element of A /\ [0, n].                                   *)
Lemma restrictSmallest : forall (A:Subset) (n m:nat),
    (exists (k:nat), k :: restrict n A) ->
    SmallestOf A m <-> SmallestOf (restrict n A) m.
Proof.
    intros A n m [k [H1 H2]]. split.
    - intros [H3 H4]. split.
        + split; try assumption. apply le_trans with k; try assumption.
          apply H4. assumption.
        + intros p [H5 H6]. apply H4. assumption.
    - intros [[H3 H4] H5]. split; try assumption. intros p H6.
      destruct (leqTotal p n) as [H7|H7].
        + apply H5. split; assumption.
        + apply le_trans with n; assumption.
Defined.

Lemma nonEmptyFiniteHasSmallest : forall (A:Subset),
    pWec A                   ->     (* A is weakly decidable *)
    (exists (k:nat), k :: A) ->
    Finite A                 ->
    (exists (k:nat), SmallestOf A k).

Proof.
    intros A W H2 [n H1]. revert n A W H1 H2.
    induction n as [|n IH]; intros A W H1 [m H2].
    - assert (m = 0) as H3. { apply le_0, H1. assumption. }
      subst. exists 0. split; try assumption. intros m H3. apply le_0_n.
    - destruct (boundedWec A W n) as [H3|H3].
        + destruct H3 as [m' [H3 H4]].
          assert (exists (k:nat), SmallestOf (restrict n A) k) as H5.
            {apply IH.
                { apply  restrictWec. assumption. }
                { intros k [H5 H6]. assumption. }
                { exists m'. split; assumption. }}
          destruct H5 as [k H5]. exists k. rewrite (restrictSmallest A n k);
          try assumption. exists k. destruct H5 as [H5 H6]. assumption.
        + exists m. split; try assumption. intros k H4.
          assert (k = S n) as H5.
            { apply le_antisym.
                { apply H1. assumption. }
                { destruct (leqDec k n) as [H5|H5].
                    { exfalso. apply H3. exists k. split; assumption. }
                    { apply not_le_ge. assumption. }}}
          rewrite H5. apply H1. assumption.
Defined.

Theorem nonEmptyHasSmallest : forall (A:Subset),
    pWec A                   ->
    (exists (k:nat), k :: A) ->
    (exists (k:nat), SmallestOf A k).
Proof.
    intros A W [k H1].
    assert (exists (m:nat), SmallestOf (restrict k A) m) as H2.
    { apply nonEmptyFiniteHasSmallest.
        { apply restrictWec. assumption. }
        { exists k. split; try assumption. apply le_n. }
        { apply restrictFinite. }}
    destruct H2 as [m H2]. exists m.
    apply restrictSmallest in H2; try assumption. exists k.
    split; try assumption. apply le_n.
Defined.

(* If a subset is computationally decidable, then so is the predicate which     *)
(* expresses the fact that a natural number is its smallest element.            *)
Lemma DecSmallest : forall (A:Subset), pDec A -> pDec (SmallestOf A).
Proof.
    intros A H1 n. destruct n as [|n].
    - destruct (H1 0) as [H2|H2].
        + left. split; try assumption. intros m H3. apply le_0_n.
        + right. intros [H3 H4]. apply H2. assumption.
    - remember (boundedDec A H1 n) as H2 eqn:E. clear E. destruct H2 as [H2|H2].
        + right. intros [H3 H4]. destruct H2 as [m [H2 H5]].
          apply not_le_Sn_n with n. apply le_trans with m; try assumption.
          apply H4. assumption.
        + destruct (H1 (S n)) as [H3|H3].
            { left. split; try assumption. intros m H4.
              destruct (leqDec m n) as [H5|H5].
                { exfalso. apply H2. exists m. split; assumption. }
                { apply not_le_ge. assumption. }}
            { right. intros [H4 H5]. apply H3 in H4. contradiction. }
Defined.

(* Function which given a subset, a proof of it computational decidability,     *)
(* a proof of its non-emptiness, returns its smallest element.                  *)
Definition smallestOf (A:Subset) (p:pDec A) (q:exists (k:nat), k :: A) : nat :=
    proj1_sig
        (witness
            (SmallestOf A)
            (DecSmallest A p)
            (nonEmptyHasSmallest A (pDecWec nat A p) q)).

Lemma smallestOfSound :
    forall (A:Subset) (p:pDec A) (q:exists (k:nat), k :: A),
        SmallestOf A (smallestOf A p q).
Proof.
    intros A p q. exact (
        proj2_sig
            (witness
                (SmallestOf A)
                (DecSmallest A p)
                (nonEmptyHasSmallest A (pDecWec nat A p) q))).
Defined.

(*
Definition ex1 : Subset := fun n => n * n = 144.

Lemma ex1Dec : pDec ex1.
Proof.
    unfold ex1. intros n. exact (eqDec (n*n) 144).
Defined.

Lemma ex1NonEmpty : exists (k:nat), k :: ex1.
Proof.
    exists 12. reflexivity.
Defined.

Compute smallestOf ex1 ex1Dec ex1NonEmpty.
*)


From Tealeaves Require Export
  Classes.Decorated.Functor
  Classes.Decorated.Monad
  Classes.Listable.Functor
  Classes.Listable.Monad.

Import Monoid.Notations.
Import List.ListNotations.

#[local] Generalizable Variables W F A.

(** * Decorated listable functors *)
(******************************************************************************)

(** ** Derived operation [tolistd] *)
(******************************************************************************)
Definition tolistd F `{Decorate W F} `{Tolist F} {A} : F A -> list (W * A)
  := tolist F ∘ dec F.

(** ** General properties *)
(******************************************************************************)
Section ListableFunctor_decorated_theory.

  Context
    `{Monoid W}
    `{Fmap F} `{Decorate W F} `{Tolist F}
    `{! DecoratedFunctor W F}
    `{! ListableFunctor F}.

  (** ** Interaction between [tolistd] and [dec] *)
  (******************************************************************************)
  Theorem tolistd_dec {A} :
      tolistd F ∘ dec F (A:=A) = fmap list (cojoin (prod W)) ∘ tolistd F.
  Proof.
    intros. unfold tolistd.
    reassociate ->.
    rewrite (dfun_dec_dec W F).
    reassociate <-.
    rewrite <- natural.
    reflexivity.
  Qed.

  (** ** Corollaries: [tolist] and [dec] *)
  (******************************************************************************)
  Theorem tolist_dec {A} :
      tolist F ∘ dec F (A:=A) = tolistd F.
  Proof.
    reflexivity.
  Qed.

  (** ** Corollaries: [tolistd] and [fmap] *)
  (******************************************************************************)
  Theorem tolistd_fmap {A B} : forall (f : A -> B),
      tolistd F ∘ fmap F f = fmap list (fmap (prod W) f) ∘ tolistd F.
  Proof.
    intros. unfold tolistd.
    reassociate <-.
    rewrite natural.
    reassociate -> on right.
    change (fmap F (fmap (prod W) ?f)) with (fmap (F ∘ prod W) f).
    rewrite (natural (ϕ := @dec W F _)).
    reflexivity.
  Qed.

End ListableFunctor_decorated_theory.

(*

Below needs Kleisli-style presentation of decorated functors

(** ** General properties *)
(******************************************************************************)
Section ListableFunctor_decorated_theory.

  Context
    `{Monoid W}
    `{Fmap F} `{Decorate W F} `{Tolist F}
    `{! DecoratedFunctor W F}
    `{! ListableFunctor F}.

  #[local] Set Keyed Unification.

  (** ** Interaction between [tolistd] and [fmapd] *)
  (******************************************************************************)
  Theorem tolistd_fmapd {A B} : forall (f : W * A -> B),
      tolistd F ∘ fmapd F f = fmap list (cobind (prod W) f) ∘ tolistd F.
  Proof.
    intros. unfold fmapd, tolistd.
    reassociate <- on left; reassociate <- on right.
    change_left (tolist F ∘ (dec F ∘ fmap F f ∘ dec F)).
    rewrite <- (natural (G := F ∘ prod W)).
    reassociate <- on left. unfold_ops @Fmap_compose.
    reassociate <- on left. rewrite <- (natural (F := F)).
    reassociate -> on left. rewrite (dfun_dec_dec W F).
    change_left (fmap list (fmap (prod W) f) ∘ (tolist F ∘ fmap F (cojoin (prod W))) ∘ dec F).
    rewrite <- natural.
    reassociate <- on left. rewrite (fun_fmap_fmap list).
    reflexivity.
  Qed.

  (** ** Corollaries: [tolist] and [fmapd] *)
  (******************************************************************************)
  Theorem tolist_fmapd {A B} : forall (f : W * A -> B),
      tolist F ∘ fmapd F f = fmap list f ∘ tolistd F.
  Proof.
    intros. unfold fmapd, tolistd.
    reassociate <- on left; reassociate <- on right.
    now rewrite <- natural.
  Qed.

  (** ** Corollaries: [tolistd] and [fmap] *)
  (******************************************************************************)
  Theorem tolistd_fmap {A B} : forall (f : W * A -> B),
      tolistd F ∘ fmap F f = fmap list (fmap (prod W) f) ∘ tolistd F.
  Proof.
    intros. unfold fmapd, tolistd.
    reassociate -> on left. rewrite <- (natural (G := F ∘ prod W)).
    reassociate <- on left. unfold_ops @Fmap_compose.
    now rewrite <- (natural (F := F) (G := list)).
  Qed.

  #[local] Unset Keyed Unification.

End ListableFunctor_decorated_theory.
*)

(** * Decorated listable monads *)
(******************************************************************************)

(** ** Interaction between [tolistd], [join], and [ret] *)
(******************************************************************************)
Section ListableMonad_tolistd.

  Context
    (T : Type -> Type)
    `{Monoid W}
    `{Fmap T} `{Decorate W T} `{Tolist T}
    `{Return T} `{Join T}
    `{! DecoratedMonad W T}
    `{! ListableMonad T}
    {A B : Type}.

  Implicit Types (w : W) (a : A) (b : B) (t : T A).

  Theorem tolistd_ret : forall a,
      tolistd T (ret T a) = [ (Ƶ, a) ].
  Proof.
    introv. unfold tolistd, compose.
    compose near a on left. rewrite (dmon_ret W T).
    unfold compose. compose near (Ƶ, a) on left.
    now rewrite (lmon_ret T).
  Qed.

  Lemma tolistd_join1 :
    tolist T ∘ fmap T (tolist T ∘ shift T (A := A)) =
    fmap list (shift list) ∘ tolist T ∘ fmap T (fmap (prod W) (tolist T)).
  Proof.
    unfold shift. reassociate <-.
    rewrite <- (fun_fmap_fmap list).
    reassociate -> near (tolist T).
    rewrite (natural (ϕ := @tolist T _)).
    reassociate <-. reassociate -> near (fmap T (fmap (prod W) (tolist T))).
    rewrite (fun_fmap_fmap T).
    replace (strength list ∘ fmap (prod W) (tolist T))
      with (tolist T ∘ strength T (A := W) (B := W * A)).
    rewrite <- (fun_fmap_fmap T).
    rewrite <- (fun_fmap_fmap T _ _ _ (strength T)).
    do 2 reassociate <-. fequal.
    rewrite (natural (ϕ := @tolist T _)).
    reassociate -> on right; rewrite (fun_fmap_fmap T). fequal.
    fequal. now rewrite (natural (ϕ := @tolist T _)).
    ext [w t]; unfold compose; cbn. compose near t.
    now rewrite (natural (ϕ := @tolist T _)).
  Qed.

  Theorem tolistd_join : forall (t : T (T A)),
      tolistd T (join T t) = join list (fmap list (shift list) (tolistd T (fmap T (tolistd T) t))).
  Proof.
    introv. unfold tolistd, compose.
    compose near t on left. rewrite (dmon_join W T).
    unfold compose. compose near (fmap T (shift T) (dec T (fmap T (dec T) t))) on left.
    rewrite (lmon_join T). unfold compose.
    compose near (dec T (fmap T (tolist T ○ dec T) t)) on right.
    change (tolist T ○ dec T) with (tolist T ∘ dec T (A:=A)).
    rewrite <- (fun_fmap_fmap T). unfold compose.
    compose near (fmap T (dec T) t) on right.
    rewrite <- (natural (ϕ := @dec W T _)). unfold compose.
    unfold_ops @Fmap_compose. fequal. compose near (dec T (fmap T (dec T) t)).
    rewrite (fun_fmap_fmap T).
    compose near (dec T (fmap T (dec T) t)).
    now rewrite tolistd_join1.
  Qed.

End ListableMonad_tolistd.


(** Complements on lists

   Pierre Castéran, Univ. Bordeaux and LaBRI *)

From Coq  Require Export List Arith Relations Lia.
Require Import Sorting.Sorted  Compare_dec  Sorting.Sorted.

(** *  Sets of natural numbers as lists *)

(** ** Definitions *)

(** numbers from i to i+n-1  *)

Fixpoint iota_from i n :=
  match n with 0 => nil
            | S p =>  i :: iota_from (S i) p
  end.

Definition interval i j := iota_from i (S j - i).

Definition bounded_by (n:nat)(s: list nat) :=
  List.Forall (fun i => i<=n)%nat s.

(*  shift and unshift lists of nats *)

Definition shift (l: list nat) := List.map S l.

Fixpoint unshift (l : list nat) : list nat :=
  match l with
      nil => nil
    | 0 :: l' => unshift l'
    | S i :: l' => i :: unshift l'
  end.

 (** sorted list of elements greater or equal than n *)

Inductive sorted_ge (n: nat) : list nat -> Prop :=
| sorted_ge_nil : sorted_ge n nil
| sorted_ge_one : forall p, n<=p -> sorted_ge n (p::nil)
| sorted_ge_cons: forall p q s,
    n <= p -> p < q -> sorted_ge p (q::s) ->
    sorted_ge n (p::q::s).

(** simpler than StdLib's last *)

Fixpoint simple_last {A} (x:A) s :=
  match s with
      nil => x
    | i::s' => simple_last  i s'
  end.

(** the list (x::s) without its last item *)

Fixpoint but_last {A:Type}(x:A) (s : list A) :=
  match s with
  | nil => nil
  | y::s' => x :: but_last  y s'
  end.

Lemma but_last_iota_from : forall l i,
      but_last i (iota_from (S i) (S l)) = i::iota_from (S i) l.
induction l; simpl.
reflexivity.
intros.
repeat f_equal.
simpl.
specialize (IHl (S i)).
simpl in IHl.
injection IHl. intros. rewrite H. auto.
Qed.

Lemma interval_length i j : length (interval i j) = S j - i.
Proof.
  unfold interval.
 generalize (S j - i). intro.   revert i.
 induction n; simpl; auto.
Qed.

Lemma but_last_interval i j:
  i < j ->
  but_last i (interval (S i) (S j)) = i:: interval (S i) j.
Proof.
  intros.
  unfold interval.
  specialize (but_last_iota_from (S j - S i) i).
 intro.
  replace (S (S j) - S i) with (S (S j - S i)).
  replace (S j) with (i + S (S j - S i)) at 3.
 2: lia.

  2:lia.
 auto.
Qed.

Lemma but_last_shift'   s : forall x,
     but_last (S x) (shift  s) = shift (but_last x s).
Proof.
  induction s; cbn.
  - auto.
  - intros;f_equal.  rewrite IHs.  cbn;  reflexivity.
Qed.

Lemma unshift_but_last   s : forall x,
    ~ In 0 (x::s) ->
    unshift (but_last  x s) = but_last (Nat.pred x) (unshift s).
Proof.
  induction s; cbn.
  - auto.
  - intros;f_equal. destruct x.
    destruct H; auto.
    simpl.
    specialize (IHs  a).  simpl in IHs.
     destruct a.
      destruct H; auto.
     simpl.
     simpl in IHs.
      f_equal.
    apply IHs.
    tauto.
Qed.

Lemma unshift_app : forall s t,  unshift (s ++ t) = unshift s ++ unshift t.
Proof.
  induction s; cbn.
  - reflexivity.
  - intro; destruct a; auto.
    now rewrite (IHs t).
Qed.

Lemma unshift_not_nil : forall s, ~ In 0 s -> s <> nil -> unshift s <> nil.
Proof.
  destruct  s.
  - destruct 2; auto.
  - cbn. destruct n.
     + destruct 1; now left.
     +  discriminate.
 Qed.

Lemma but_last_app {A} : forall s (x:A),
  but_last x s ++  simple_last x s :: nil = x::s.
Proof.
  induction s; simpl; auto.
  intros; simpl; now rewrite IHs.
Qed.

(* useful ??? *)
Lemma but_last_iota_from' j : forall i, but_last i (iota_from (S i) (S j)) =
                                       iota_from i (S j).
 intros; rewrite but_last_iota_from.
 reflexivity.
Qed.

Definition ptwise_le: list nat -> list nat -> Prop := Forall2 le.

(** ** Lemmas *)

Lemma empty_interval i j : (j < i)%nat -> interval i j = nil.
Proof.
 unfold interval.
  intro H; replace (S j - i)%nat with 0.
  reflexivity.
  abstract lia.
Qed.

Lemma shift_iota_from : forall i l,  shift (iota_from i l) = iota_from (S i) l.
Proof.
  intros i l; revert i;induction l.
  - trivial.
  - cbn; intro; now rewrite IHl.
Qed.

Lemma shift_interval (i j: nat): shift (interval i j) = interval (S i) (S j).
Proof.
  unfold interval; rewrite shift_iota_from; f_equal.
Qed.

Lemma unshift_iota_from : forall i l,  unshift (iota_from (S i) l) =
                                       iota_from i l.
Proof.
  intros i l; revert i;induction l.
  - trivial.
  - cbn. intro; now rewrite IHl.
Qed.

Lemma unshift_interval (i j: nat): unshift (interval (S i) (S j)) =
                                   interval  i  j.
Proof.
 unfold interval;rewrite unshift_iota_from;f_equal.
Qed.

Lemma unshift_interval_pred (i j:nat) : 0 < j ->
  unshift (interval (S i) j) = interval i (Nat.pred j).
  Proof.
    destruct j.
   inversion 1.
   intro; simpl.
   now   rewrite unshift_interval.
  Qed.

Lemma shift_no_zero l : ~ In 0 (shift l).
Proof.
  induction l; destruct 1; [discriminate | auto].
Qed.

Lemma shift_unshift l : unshift (shift l) = l.
Proof.
  induction l; simpl in *; [trivial | now rewrite IHl].
Qed.

Lemma unshift_shift l (H: ~ In 0 l): shift (unshift l) = l.
Proof.
  induction l.
- reflexivity.
- simpl. destruct a.
 contradiction H; now left.
  simpl;  rewrite IHl; auto.
  intro; apply H; now right.
Qed.

Lemma unshift_pred : forall (s: list nat),  ~ In 0 s ->
                                            unshift s = List.map Nat.pred s.
Proof.
induction s.
 -  trivial.
 -  destruct a.
   +   destruct 1; now  left.
   +  simpl;  intro;  rewrite IHs; auto.
 Qed.

Lemma sorted_ge_Forall (n:nat) : forall l, sorted_ge n l ->
                                           Forall (fun x =>  n <= x) l.
Proof.
  induction 1.
  - left.
  - now right.
  - right.
   + assumption.
   +  eapply Forall_impl  with (P := (fun x: nat => p <= x)); [|trivial].
     intros; abstract lia.
Qed.

Lemma sorted_ge_trans n p l : n <= p -> sorted_ge p l -> sorted_ge n l.
induction 2.
- constructor 1.
- constructor 2; eauto with arith.
- constructor 3; [eauto with arith |assumption | assumption].
Qed.

Lemma sorted_ge_not_In (n:nat) : forall l, sorted_ge (S n) l ->
                                           ~ In n l.
Proof.
 intros l H; generalize (sorted_ge_Forall _ _ H); intros H0 H1.
 rewrite Forall_forall in H0. generalize (H0 n).
 intro H2; generalize (H2 H1).
 abstract lia.
Qed.

#[global] Hint Constructors sorted_ge : lists.

Lemma sorted_inv_gt : forall n p s, sorted_ge n (p::s) ->
                                    (p < n)%nat -> False.
Proof.
 inversion_clear 1 ; intro;abstract lia.
Qed.

Lemma iota_from_app n p :
  iota_from n (S p) = iota_from n p ++ (n+p::nil)%nat.
Proof.
  revert n; induction p; simpl.
  -  intros; f_equal; abstract lia.
  -  intros;  f_equal; replace (n + S p)%nat with (S n + p)%nat.
     +  rewrite  <- IHp; auto.
     +  abstract lia.
Qed.

Lemma iota_from_plus : forall k i j, iota_from i (k+j) =
                                     iota_from i k ++ iota_from (k+i) j.
Proof.
  induction k; simpl.
  - trivial.
  - intros; rewrite IHk; repeat  f_equal; abstract lia.
Qed.

Lemma interval_not_empty : forall i j, i <= j -> interval i j <> nil.
Proof.
  induction 1.
  - unfold interval.
    case_eq (S i -  i).
    + intro; abstract lia.
    + simpl. destruct i; discriminate.
  -  cbn.
     destruct i.
     cbn; discriminate.
     destruct i; cbn.
     discriminate.
     case_eq (m - i).
     intro; abstract lia.
     cbn; discriminate.
Qed.

Lemma interval_not_empty_iff (n p : nat) :
  interval n p <> nil <-> (n <= p)%nat.
Proof.
  split.
  - intro H; destruct (le_lt_dec n p); [trivial| ].

   apply empty_interval in l.
   contradiction.
    - apply interval_not_empty.
Qed.

Lemma interval_singleton (i:nat) : interval i i = i::nil.
Proof.
  unfold interval; replace (S i - i) with 1;  [reflexivity | lia].
Qed.

Lemma interval_app (i j k:nat):
  (i <= j)%nat -> (j <= k)%nat ->
  interval i k = interval i j ++ interval (S j) k.
Proof.
  unfold interval;intros.
  replace (S k - i)%nat with ((S j - i) + (S k - S j))%nat.
  - rewrite iota_from_plus;repeat f_equal; lia.
  - abstract lia.
Qed.

Lemma iota_from_unroll i l : iota_from i (S l) = i :: iota_from (S i) l.
Proof. reflexivity. Qed.

Lemma interval_unroll : forall i j:nat , (i < j)%nat ->
                                       interval i j = i :: interval (S i) j.
Proof.
  intros.
  change (interval i j = (i :: nil) ++ interval (S i) j).
  replace (i::nil) with (interval i i).
  rewrite  interval_app with i i j.
  reflexivity.
  auto with arith.
  auto with arith.
  unfold interval.
  replace (S i - i)%nat with 1.
  reflexivity.
  abstract lia.
Qed.

Lemma iota_from_sorted_ge : forall p n q : nat,
    (q <= n)%nat  ->
    sorted_ge q (iota_from n p).
Proof.
  induction p.
  - constructor.
  - simpl; destruct p.
     + constructor 2 ; auto.
     +  simpl; simpl in IHp;  constructor 3; auto.
Qed.

Lemma interval_sorted_ge: forall p n q : nat,  (q <= n)%nat ->
                                                sorted_ge q (interval n p).
 unfold interval; intros; now apply iota_from_sorted_ge.
Qed.

Lemma iota_from_lt_not_In i j l : i < j -> ~ In i (iota_from j l).
Proof.
   intros; generalize (iota_from_sorted_ge l j (S i) H ).
   intros; now apply sorted_ge_not_In.
Qed.

Lemma interval_lt_not_In :
  forall i j k,  i < j -> ~ In i (interval j k).
Proof.
  intros; unfold interval; now apply iota_from_lt_not_In.
Qed.

Section Forall2_right_induction.

Inductive Forall2R {A B: Type} (R: A -> B -> Prop) : list A -> list B -> Prop :=
  Forall2R_nil : Forall2R R nil nil
| Forall2R_last : forall l l' x y l1 l'1, Forall2R R l l' ->
                                          R x y ->
                                          l1 = l++(x::nil) ->
                                          l'1 = l' ++ (y::nil) ->
                                          Forall2R R l1 l'1.

Remark Forall2R_cons {A B: Type} (R: A -> B -> Prop):
  forall l l',  Forall2R R l l' -> forall x y, R x y -> Forall2R R (x::l) (y:: l').
  induction 1.
  - intros.
    eright with nil nil x y ; auto.
    left.
  -  intros; subst;  right with (x0::l) (y0::l') x y; auto.
Qed.

Remark Forall2_R  {A B: Type} (R: A -> B -> Prop) :
  forall l l', Forall2 R l l' -> Forall2R R l l'.
  induction 1.
  - constructor.
  - inversion IHForall2.
     + eright with nil nil x y;auto.
       now left.
     + subst; apply Forall2R_cons; auto.
Qed.

Remark Forall2_RR  {A B: Type} (R: A -> B -> Prop) :
  forall l l', Forall2R R l l' -> Forall2 R l l'.
Proof.
  induction 1.
  - constructor.
  - subst; apply Forall2_app; auto.
Qed.

Lemma Forall2R_iff {A B: Type} (R: A -> B -> Prop) :
  forall l l', Forall2R R l l' <-> Forall2 R l l'.
Proof.
  split.
  - intro;now  apply Forall2_RR .
  - intro;now  apply Forall2_R .
Qed.

Lemma Forall2_indR {A B : Type} (R : A -> B -> Prop) (P : list A -> list B -> Prop):
P nil nil ->
(forall (l : list A) (l' : list B) (x : A) (y : B)
   (l1 : list A) (l'1 : list B),
 Forall2 R l l' -> P l l' ->
 R x y -> l1 = l ++ x :: nil -> l'1 = l' ++ y :: nil -> P l1 l'1) ->
  forall (l : list A) (l0 : list B), Forall2 R l l0 -> P l l0.
Proof.
  intros; rewrite  <- Forall2R_iff in  H1.
  eapply Forall2R_ind; eauto.
  intros; subst.
  eapply H0 with l1 l' x y; auto.
  now  rewrite  <- Forall2R_iff .
Qed.

End  Forall2_right_induction.

Lemma sorted_le : forall i j X, i <= j ->
                                sorted_ge j X ->
                                sorted_ge i X.
Proof.
  induction 2; eauto with arith lists.
Qed.

Lemma sorted_tail : forall i j X, sorted_ge i (j::X) ->
                                  sorted_ge i X.
Proof.
  inversion 1.
  -   constructor.
  -   destruct s; auto.
      all:  inversion H4;eauto with arith lists.
Qed.

Lemma sorted_tail' : forall i j X, sorted_ge i (j::X) ->
                                   sorted_ge j X.
Proof.
  inversion_clear  1; auto with lists.
Qed.

Lemma sorted_head : forall n m s, sorted_ge n (m::s)
                                  -> n<=m.
Proof.
  induction s.
  - inversion 1; auto.
  - inversion_clear 1.
    apply IHs.
  inversion_clear H2.
  +   constructor; auto with arith.
  +  constructor; eauto with arith.
     eapply sorted_le;eauto.
Qed.

Lemma Sorted_mono {A:Type}(R S : relation A)
      (Hincl : forall x y, R x y -> S x y):
  forall l, Sorted R l -> Sorted S l.
Proof.
  induction 1; auto.
  constructor; auto.
  destruct H0;auto.
Qed.

Lemma sorted_ge_iff0 : forall l n, sorted_ge n l <->
                                    LocallySorted Peano.lt l /\
                                    List.Forall (fun i => n <= i) l.
Proof.
  induction l.
  - split; auto with lists.
    split; auto with lists; constructor.
  - destruct l.
    + split.
      * split; auto with lists.
        constructor.
        constructor.
        eapply  sorted_head; eauto.
        constructor.
      *   destruct 1;  constructor;  inversion H0;auto.
    +  repeat  split.
      *  inversion_clear H; auto.
         rewrite IHl in H2.
         constructor;tauto.
      *   inversion_clear H.
          rewrite IHl in H2.
          constructor; auto.
          destruct H2.
          eapply Forall_impl.
          2:eapply H2.
          intros;   transitivity a.
          auto.
          apply H3.
      *  destruct 1.
         constructor.
           inversion_clear H0; auto.
           inversion_clear H; auto.
           inversion_clear H.
           rewrite IHl.
           split; auto.
           constructor;  auto with arith.
           apply Sorted_extends.
           intros x y z Hxy Hyz.
           eauto with arith.
           apply Sorted_mono with Peano.lt.
           eauto with arith.
           rewrite <- Sorted_LocallySorted_iff in H1.
           inversion_clear H1.
           constructor;auto.
           induction H3.
           constructor.
           constructor.
           eauto with arith.
Qed.

Lemma sorted_ge_iff : forall l n, sorted_ge n l <->
                                    Sorted lt l /\
                                    List.Forall (fun i => n <= i) l.
Proof.
 intros.
 rewrite Sorted_LocallySorted_iff.
 apply sorted_ge_iff0.
Qed.

Lemma sorted_ge_prefix :
  forall  l1 n l2, sorted_ge n (l1 ++ l2) -> sorted_ge n l1.
  induction l1.
  - constructor.
  -
    destruct l1.
    constructor.
    cbn in H.
    eapply sorted_head; eauto.
    constructor.
    cbn in H.
    eapply sorted_head; eauto.
    inversion_clear H.
    auto.
    eapply IHl1.
    inversion_clear H.
    eauto.
Qed.

Lemma sorted_In : forall i X, Sorted lt (i::X) -> forall j, In j X -> i < j.
Proof.
  intros.
  apply Sorted_StronglySorted in H.
  apply StronglySorted_inv in H.
  destruct H.
  rewrite Forall_forall in H1.
  auto.
  red.
  intros; abstract lia.
Qed.

Lemma sorted_not_in_tail : forall  i j X, Sorted lt (i::X)   -> j<=i ->
                                           ~ (In j X).
Proof.
 intros.
 red; intro.
 specialize (sorted_In _ _ H j H1).
 intro; abstract lia.
Qed.

Remark simple_last_correct {A}: forall s (x:A), simple_last x s = last s x.
  induction s.
  - now cbn.
  -  cbn.
     destruct s.
     now cbn.
     auto.
Qed.

Lemma In_sorted_ge_inv : forall x y s,
                             In x (y::s) ->
                             sorted_ge y s ->
                             y < x /\ In x s \/ y = x.
Proof.
  intros x y s H H0;  destruct H.
  -    subst; auto.
  -  destruct (lt_eq_lt_dec x y) as [[H1 | H2] | H3].
   +  rewrite   sorted_ge_iff in H0;  destruct H0.
     rewrite Forall_forall in H2;  specialize (H2 x H).
    cut False; [contradiction | abstract lia ].
   +  subst; auto.
   +  auto.
Qed.

Lemma incl_inv : forall x y l1 l2,  Sorted lt (x::l1) ->
                                    Sorted lt (y::l2)  ->
                                    incl (x::l1)(y::l2) ->
                                    y <= x /\ incl l1 l2.
Proof.
  intros.
  red in H1.
  assert (y <= x).
  {
    specialize (H1 x (in_eq x  l1)).
    destruct H1.
    subst; auto with arith.

    specialize (sorted_In _ _ H0 _ H1).
    auto with arith.
  }
  split;auto.
  intros z Hz.
  assert (x < z). {

    specialize (sorted_In _ _ H _ Hz).
    auto.
  }
  assert (y < z).
  eauto with arith.

  specialize (H1 z).
  destruct H1.
  right;auto.
  subst.
  assert (F: False) by abstract lia; elim F.
  auto.
Qed.

Lemma incl_decomp : forall l1 l2,  Sorted lt l1 ->
                                   Sorted lt l2  ->
                                   incl l1 l2 ->
                                   exists l3 l4,  l2 = l3 ++ l4 /\
                                                  ptwise_le l3 l1.
  induction l1.
  intros; exists nil, l2.
  split.
  reflexivity.
  constructor.
  destruct l2.
  intros.
  red in H1.
  destruct (H1 a) ;auto.
  now left.
  intros.
  destruct (incl_inv a n l1 l2);auto.
  destruct (IHl1 l2).
  now inversion_clear H.
  now inversion_clear H0.
  auto.
  destruct H4 as [l4 [H5 H6]].
  subst.
  exists (n::x), l4.
  split;auto.
  constructor.
  auto.

  auto.
Qed.

  Lemma simple_last_app {A}: forall l l1 (x y:A), simple_last x (l++(y::l1))  =
                                     simple_last y l1 .
  induction l; cbn.
  - reflexivity.
  - intros; now rewrite IHl.
Qed.

Lemma simple_last_app1 {A}: forall l (x y:A), simple_last x (l++(y::nil))  = y.
Proof.
  intros; now rewrite simple_last_app.
Qed.

Lemma sorted_max_1 : forall s n, sorted_ge n s ->
                                 (n <= simple_last n s)%nat.
  induction s; cbn.
  - auto with arith.
  -  intros; destruct s.
    + now inversion_clear H.
    + inversion_clear H; transitivity a; auto.
Qed.

Lemma sorted_cut :forall l1 n x l2, sorted_ge n (l1++(x::l2)) ->
                                    simple_last n l1 <= x.
  induction l1.
  - cbn;  eapply sorted_head; eauto.
  - cbn; intros; eapply IHl1 with l2.
    cbn in H;    inversion_clear H; auto with lists.
Qed.

Lemma sorted_max_2 : forall s n, sorted_ge n s ->
                                 Forall (fun i =>
                                           (i <= simple_last n s)%nat)
                                        s.
Proof.
  induction s; cbn.
  - intros; simpl; constructor.
  -     constructor.
       +  apply sorted_max_1; inversion H;auto with lists.
       + apply IHs; eapply sorted_tail'; eauto with lists.
Qed.

Lemma sorted_ge_suffix :
  forall  l1 n l2, sorted_ge n (l1 ++ l2) -> sorted_ge (simple_last n l1) l2.
  induction l1.
  -  intros; cbn. assumption.
  -  destruct l1.
    + cbn; inversion_clear 1; auto with lists.
    + inversion_clear 1; cbn in *; eauto with lists.
Qed.


Require Import Znumtheory .
Require Import Zdiv .
Require Import ZArith .
Import Z .

Section SimpleChineseRemainder .

Open Scope Z_scope .

Definition modulo (a b n : Z) : Prop := (n | (a - b)) .
Notation "( a == b [ n ])" := (modulo a b n) .

Lemma modulo_tran : forall a b c n : Z,
    (a == b [ n ]) -> (b == c [ n ]) -> (a == c [ n ]) .
Proof.
  intros a b c n Hab Hbc .
  red in Hab, Hbc |- * .
  cut (a - c = a - b + (b - c)) .
  - intros H .
    rewrite H .
    apply Zdivide_plus_r .
    + trivial .
    + trivial .
  - auto with * .
Qed.

Lemma modulo_plus_subst : forall a b c n : Z,
    (a == b [ n ]) -> (a + c == b + c [ n ]) .
Proof.
  (* to be done *)
  intros a b c n Hab.
  red in Hab |- *.
  cut (a + c - (b + c) = a - b).
  - intros H.
    rewrite H.
    trivial.
  - auto with *.
Qed.

Lemma modulo_mult_subst : forall a b c n : Z,
    (a == b [ n ]) -> (a * c == b * c [ n ]) .
Proof.
  (* to be done *)
  intros a b c n Hab.
  red in Hab |- *.
  cut (a * c - b * c = (a - b) * c).
  - intros H.
    rewrite H.
    apply Zdivide_mult_l.
    trivial.
  - auto with *.
Qed.

Lemma modulo_plus_multiple_of_n : forall a b c m n : Z,
    (a * m + b * n == c[ n ]) <-> (a * m == c [ n ]).
Proof.
  intros a b c m n.
  unfold iff.
  split.
  (* (a * m + b * n == c[ n ]) -> (a * m == c [ n ]) *)
  - intros Hambnc.
    red in Hambnc |- *.
    apply divide_add_cancel_r with (m := b * n).
    + apply Zdivide_factor_l.
    + cut (b * n + (a * m - c) = a * m + b * n - c).
    * intros H.
      rewrite H.
      trivial.
    * auto with *.
  (* (a * m == c [ n ]) -> (a * m + b * n == c[ n ]) *)
  - intros Hamc.
    red in Hamc |- *.
    cut (a * m + b * n - c = a * m - c + b * n).
    + intros H.
      rewrite H.
      apply Zdivide_plus_r.
      * trivial.
      * apply Zdivide_factor_l.
    + auto with *.
Qed.

Hypothesis m n : Z .
Hypothesis co_prime : rel_prime m n .

Theorem modulo_inv : forall m n : Z, rel_prime m n ->
                       exists x : Z, (m * x == 1 [ n ]) .
Proof.
  (* to be done *)
  intros m0 n0 Hrel_prime.
  elim (Zis_gcd_bezout m0 n0 1).
  - intros u v Hbezout_identity.
    exists u.
    rewrite mul_comm.
    apply modulo_plus_multiple_of_n with (b := v).
    rewrite Hbezout_identity.
    red.
    rewrite sub_diag.
    apply Zdivide_0.
  - trivial.
Qed.

Theorem SimpleChineseRemainder : forall a b : Z,
  exists x : Z, (x == a [ m ]) /\ (x == b [ n ]) .
Proof.
  (* to be done *)
  intros a b.
  destruct (rel_prime_bezout _ _ co_prime) as [u v Hbezout_identity].
  exists (a * v * n + b * u * m).
  split.
  (* (a * v * n + b * u * m == a [ m ]) *)
  - apply add_move_l in Hbezout_identity.
    rewrite <- mul_assoc.
    rewrite Hbezout_identity.
    cut (a * (1 - u * m) + b * u * m = a * 1 + (b * u - a * u) * m).
    + intros H.
      rewrite H.
      apply modulo_plus_multiple_of_n.
      rewrite mul_1_r.
      red.
      rewrite sub_diag.
      apply Zdivide_0.
    + auto with *.
  (* (a * v * n + b * u * m == b [ n ]) *)
  - apply add_move_r in Hbezout_identity.
    rewrite add_comm.
    rewrite <- mul_assoc.
    rewrite Hbezout_identity.
    cut (b * (1 - v * n) + a * v * n = b * 1 + (a * v - b * v) * n).
    + intros H.
      rewrite H.
      apply modulo_plus_multiple_of_n.
      rewrite mul_1_r.
      red.
      rewrite sub_diag.
      apply Zdivide_0.
    + auto with *.
Qed.

End SimpleChineseRemainder .

Check SimpleChineseRemainder .


Require Import Arith.

Inductive TVar : Type :=
| tvar : nat -> TVar
.

Inductive FType : Type :=
| VarType : TVar -> FType
| FunType : FType -> FType -> FType
| UniType : TVar -> FType -> FType
.

Definition tvarEqual (X Y:TVar) : bool :=
    match X, Y with
    | (tvar x), (tvar y)    => if (beq_nat x y) then true else false
    end.

Fixpoint FTypeEqual (T T':FType) : bool :=
    match T with
    | VarType X     => match T' with
                       | VarType Y     => tvarEqual X Y
                       | _             => false
                       end
    | FunType T1 T2 => match T' with
                       | FunType S1 S2 => andb (FTypeEqual T1 S1)(FTypeEqual T2 S2)
                       | _             => false
                       end
    | UniType X T1  => match T' with (* equality stricter than alpha equivalence *)
                       | UniType Y S1  => andb (tvarEqual X Y)(FTypeEqual T1 S1)
                       | _             => false
                       end
    end.


(* Exercise 10 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_010 : (exists x : D, P x -> Q x) -> (forall x : D, P x) -> (exists x : D, Q x).
Proof.
imp_i a1.
imp_i a2.
exi_e (exists x:D, P x -> Q x) a a3.
hyp a1.
exi_i a.
imp_e (P a).
hyp a3.
all_e (forall x:D, P x) a.
hyp a2.
Qed.


Require Import PolTac.
Require Import NAux.

Open Scope N_scope.

Theorem pols_test1: forall x y: N,  x < y ->  (x + x < y + x).
intros.
pols.
auto.
Qed.

Theorem pols_test2: forall x y, y < 0 ->  (x + y < x).
intros.
pols.
auto.
Qed.

Theorem pols_test4:
 forall x y,
 x * x  < y * y ->  ((x + y) * (x + y) < 2 * (x * y + y * y)).
intros.
pols.
auto.
Qed.

Theorem pols_test5:
 forall x y z, x + y * (y + z) = 2 * z ->  2 * x + y * (y + z) = (x + z) + z.
intros.
pols.
auto.
Qed.

Theorem polf_test1: forall x y, (1 <= y -> x  <= x  * y).
intros.
polf.
Qed.

Theorem polf_test2: forall x y, 0 < x -> x  <= x  * y -> 1 <= y.
intros.
hyp_polf H0.
auto.
Qed.

Theorem polr_test1: forall x y z, (x + z) < y -> x + y + z < 2*y.
intros x y z H.
polr H.
pols.
auto.
pols.
auto.
Qed.