Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat.
From Coq Require Import Init.Nat.
From Coq Require Import Lia.
From Coq Require Import Lists.List. Import ListNotations.
From PLF Require Import Maps.
From PLF Require Import Imp.

 Inductive tm : Type :=
  | C : nat -> tm        (* Constant *)
  | P : tm  -> tm -> tm. (* Plus *)

Fixpoint evalF (t : tm) : nat :=
  match t with
  | C n   => n
  | P a b => evalF a + evalF b
  end.

Reserved Notation " t '==>' n " (at level 50, left associativity).
Inductive eval : tm -> nat -> Prop :=
  | E_Const : forall n,
      C n ==> n
  | E_Plus : forall t1 t2 n1 n2,
      t1 ==> n1 ->
      t2 ==> n2 ->
      P t1 t2 ==> (n1 + n2)
where " t '==>' n " := (eval t n).

Module SimpleArith1.
  Reserved Notation " t '-->' t' " (at level 40).
  Inductive step : tm -> tm -> Prop :=
    | ST_PlusConstConst : forall n m,
        P (C n) (C m) --> C (n + m)
    | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
    | ST_Plus2 : forall n t2 t2',
        t2 --> t2' ->
        P (C n) t2 --> P (C n) t2'
    where " t '-->' t' " := (step t t').

   Example test_step_2 :
        P
          (C 0)
          (P
            (C 2)
            (P (C 1) (C 3)))
        -->
        P
          (C 0)
          (P
            (C 2)
            (C 4)).
  Proof.
    apply ST_Plus2.
    apply ST_Plus2.
    apply ST_PlusConstConst.
  Qed.
End SimpleArith1.

(* See Rel.v in vol1 *)
Definition relation (X : Type) := X -> X -> Prop.

Definition deterministic {X : Type} (R : relation X) :=  forall x y1 y2 : X,
  R x y1 -> R x y2 -> y1 = y2.

Module SimpleArith2.
  Import SimpleArith1.
  Theorem step_deterministic:  deterministic step.
  Proof.
    unfold deterministic. intros x y1 y2 Hy1 Hy2.
    generalize dependent y2.
    induction Hy1; intros y2 Hy2.
    - (* ST_PlusConstConst *) inversion Hy2; subst.
      + (* ST_PlusConstConst *) reflexivity.
      + (* ST_Plus1 *) inversion H2.
      + (* ST_Plus2 *) inversion H2.
    - (* ST_Plus1 *) inversion Hy2; subst.
      + (* ST_PlusConstConst *)
        inversion Hy1.
      + (* ST_Plus1 *)
        apply IHHy1 in H2. rewrite H2. reflexivity.
      + (* ST_Plus2 *)
        inversion Hy1.
    - (* ST_Plus2 *) inversion Hy2; subst.
      + (* ST_PlusConstConst *)
        inversion Hy1.
      + (* ST_Plus1 *) inversion H2.
      + (* ST_Plus2 *)
        apply IHHy1 in H2. rewrite H2. reflexivity.
  Qed.
End SimpleArith2.

Ltac solve_by_inverts n :=
  match goal with
  | H : ?T |- _ =>
    match type of T with
    | Prop =>
      solve [
        inversion H;
        match n with S (S (?n')) => subst; solve_by_inverts (S n') end ]
    end
  end.

Ltac solve_by_invert :=  solve_by_inverts 1.

Module SimpleArith3.
  Import SimpleArith1.
  Theorem step_deterministic_alt: deterministic step.
  Proof.
    intros x y1 y2 Hy1 Hy2.
    generalize dependent y2.
    induction Hy1; intros y2 Hy2;
      inversion Hy2; subst; try solve_by_invert.
    - (* ST_PlusConstConst *) reflexivity.
    - (* ST_Plus1 *)
      apply IHHy1 in H2. rewrite H2. reflexivity.
    - (* ST_Plus2 *)
      apply IHHy1 in H2. rewrite H2. reflexivity.
  Qed.
End SimpleArith3.

Inductive value : tm -> Prop :=
  | v_const: forall n, value (C n).

Reserved Notation " t '-->' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n m,
          P (C n) (C m) --> C (n + m)
  | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' -> P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v t2 t2',
        value v ->
        t2 --> t2' ->
        P v t2 --> P v t2'
  where " t '-->' t' " := (step t t').

Theorem step_deterministic :  deterministic step.
Proof.
  unfold deterministic. intros x y1 y2 H1 H2.
  generalize dependent y2.
  induction H1; intros y2 H2.
  - inversion H2; subst.
    + reflexivity.
    + inversion H3.
    + inversion H4.
  - inversion H2; subst.
    + inversion H1.
    + assert (G: t1' = t1'0). {
        apply IHstep.
        apply H4.
      }
      rewrite G.
      reflexivity.
    + inversion H3; subst.
      inversion H1.
  - inversion H2; subst.
    + inversion H1.
    + inversion H; subst.
      inversion H5.
    + assert (G: t2' = t2'0). {
        apply IHstep.
        apply H6.
      }
      rewrite G. reflexivity.
Qed.

Theorem strong_progress : forall t,
  value t \/ (exists t', t --> t').
Proof.
  intro t.
  induction t.
  - left. apply v_const.
  - right.
    destruct IHt1 as [Ht1Val | Ht1Red].
    + inversion Ht1Val; subst.
      destruct IHt2 as [Ht2Val | Ht2Red].
      * inversion Ht2Val; subst.
        eexists.
        apply ST_PlusConstConst.
      * destruct Ht2Red as [t' Ht'].
        eexists.
        apply ST_Plus2.
        apply Ht1Val.
        apply Ht'.
    + destruct Ht1Red as [t' Ht'].
      eexists.
      apply ST_Plus1.
      apply Ht'.
Qed.

Definition normal_form {X : Type} (R : relation X) (t : X) : Prop :=
  ~(exists t', R t t').

Lemma value_is_nf : forall v,
  value v -> normal_form step v.
Proof.
  intros v H H1.
  inversion H.
  subst.
  destruct H1 as [t' H1'].
  inversion H1'.
Qed.

Lemma nf_is_value : forall t,
  normal_form step t -> value t.
Proof.
  unfold normal_form. intros t H.
  assert (G : value t \/ exists t', t --> t').
  { apply strong_progress. }
  destruct G as [G | G].
  - (* l *) apply G.
  - (* r *) exfalso. apply H. assumption.
Qed.

Corollary nf_same_as_value : forall t,
  normal_form step t <-> value t.
Proof.
  split. apply nf_is_value. apply value_is_nf.
Qed.

Module Temp1.
  Inductive value : tm -> Prop :=
    | v_const : forall n, value (C n)
    | v_funny : forall t1 n2, (* <--- NEW *)
                  value (P t1 (C n2)).
  Reserved Notation " t '-->' t' " (at level 40).
  Inductive step : tm -> tm -> Prop :=
    | ST_PlusConstConst : forall n1 n2,
        P (C n1) (C n2) --> C (n1 + n2)
    | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
    | ST_Plus2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        P v1 t2 --> P v1 t2'
    where " t '-->' t' " := (step t t').

  Lemma value_not_same_as_normal_form :
    exists v, value v /\ ~ normal_form step v.
  Proof.
    exists (P (C 0) (C 0)).
    split.
    - apply v_funny.
    - intro Hcontra. unfold normal_form in Hcontra.
      apply Hcontra.
      exists (C 0).
      apply ST_PlusConstConst.
  Qed.
End Temp1.

Module Temp2.
  Inductive value : tm -> Prop :=
    | v_const : forall n, value (C n). (* Original definition *)

  Reserved Notation " t '-->' t' " (at level 40).
  Inductive step : tm -> tm -> Prop :=
    | ST_Funny : forall n,
        C n --> P (C n) (C 0) (* <--- NEW *)
    | ST_PlusConstConst : forall n1 n2,
        P (C n1) (C n2) --> C (n1 + n2)
    | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
    | ST_Plus2 : forall v1 t2 t2',
        value v1 ->
        t2 --> t2' ->
        P v1 t2 --> P v1 t2'
    where " t '-->' t' " := (step t t').

  Lemma value_not_same_as_normal_form :
    exists v, value v /\ ~normal_form step v.
  Proof.
    exists (C 0).
    split.
    - apply v_const.
    - intro HContra. apply HContra.
      exists (P (C 0) (C 0)).
      apply ST_Funny.
  Qed.
End Temp2.

Module Temp3.
  Inductive value : tm -> Prop :=
    | v_const : forall n, value (C n).

  Reserved Notation " t '-->' t' " (at level 40).
  Inductive step : tm -> tm -> Prop :=
    | ST_PlusConstConst : forall n1 n2,
        P (C n1) (C n2) --> C (n1 + n2)
    | ST_Plus1 : forall t1 t1' t2,
        t1 --> t1' ->
        P t1 t2 --> P t1' t2
    where " t '-->' t' " := (step t t').

  Lemma value_not_same_as_normal_form :
    exists t, ~ value t /\ normal_form step t.
  Proof.
    exists (P (C 0) (P (C 0) (C 0))).
    split.
    - intros HContra. inversion HContra.
    - intros HContra. destruct HContra as [t' HContra].
      inversion HContra; subst. inversion H2.
  Qed.
End Temp3.

Module Temp4.
  Inductive tm : Type :=
    | tru : tm
    | fls : tm
    | test : tm -> tm -> tm -> tm.
  Inductive value : tm -> Prop :=
    | v_tru : value tru
    | v_fls : value fls.

  Reserved Notation " t '-->' t' " (at level 40).
  Inductive step : tm -> tm -> Prop :=
    | ST_IfTrue : forall t1 t2,
        test tru t1 t2 --> t1
    | ST_IfFalse : forall t1 t2,
        test fls t1 t2 --> t2
    | ST_If : forall t1 t1' t2 t3,
        t1 --> t1' ->
        test t1 t2 t3 --> test t1' t2 t3
    where " t '-->' t' " := (step t t').

  (* Definition bool_step_prop1 :=  fls --> fls. *)
  (*
  Definition bool_step_prop2 :=
       test
         tru
         (test tru tru tru)
         (test fls fls fls)
    -->
       tru.
  *)
  (*
  Definition bool_step_prop3 :=
       test
         (test tru tru tru)
         (test tru tru tru)
         fls
     -->
       test
         tru
         (test tru tru tru)
         fls.
  *)

  Theorem strong_progress_bool : forall t,
    value t \/ (exists t', t --> t').
  Proof.
    intro t. induction t.
    - left. constructor.
    - left. constructor.
    - right.
      destruct t1.
      + eexists. apply ST_IfTrue.
      + eexists. apply ST_IfFalse.
      + destruct IHt1 as [Hl | Hr].
        * inversion Hl.
        * destruct Hr as [t' Hr].
          exists (test t' t2 t3).
          apply ST_If. assumption.
  Qed.

  Lemma test_true: forall t f x, test tru t f --> x -> x = t.
  Proof.
    intros t f x H.
    inversion H; subst.
    - reflexivity.
    - inversion H4.
  Qed.

  Lemma test_false: forall t f x, test fls t f --> x -> x = f.
  Proof.
    intros t f x H.
    inversion H; subst.
    - reflexivity.
    - inversion H4.
  Qed.

  Theorem step_deterministic :
    deterministic step.
  Proof.
    unfold deterministic. intro x. induction x; intros y1 y2 H1 H2.
    - inversion H1; subst.
    - inversion H1; subst.
    - destruct x1; subst.
      + (* x1 = true *)
        rewrite (test_true _ _ _ H1).
        rewrite (test_true _ _ _ H2).
        reflexivity.
      + (* x1 = false *)
        rewrite (test_false _ _ _ H1).
        rewrite (test_false _ _ _ H2).
        reflexivity.
      + inversion H1; subst. inversion H2; subst.
        assert (G: t1' = t1'0). {
          apply IHx1. apply H5. apply H6.
        }
        rewrite G. reflexivity.
  Qed.

  Module Temp5.
    Reserved Notation " t '-->' t' " (at level 40).
    Inductive step : tm -> tm -> Prop :=
      | ST_IfTrue : forall t1 t2,
          test tru t1 t2 --> t1
      | ST_IfFalse : forall t1 t2,
          test fls t1 t2 --> t2
      | ST_If : forall t1 t1' t2 t3,
          t1 --> t1' ->
          test t1 t2 t3 --> test t1' t2 t3
      | ST_ShortCircuit : forall t1 t2,
          test t1 t2 t2 --> t2
      where " t '-->' t' " := (step t t').

    Definition bool_step_prop4 :=
             test
                (test tru tru tru)
                fls
                fls
         -->
             fls.
    Example bool_step_prop4_holds :
      bool_step_prop4.
    Proof.
      unfold bool_step_prop4.
      apply ST_ShortCircuit.
    Qed.

    Theorem step_with_short_circ_not_deterministic :
      ~(deterministic step).
    Proof.
      unfold deterministic.
      intro H.
      assert (G: fls = test tru fls fls). {
        apply H with (x := test (test tru tru tru) fls fls).
        - apply ST_ShortCircuit.
        - apply ST_If. apply ST_IfTrue.
      }
      inversion G.
    Qed.

    Theorem strong_progress_bool : forall t,
      value t \/ (exists t', t --> t').
    Proof.
      intro t. induction t.
      - left. constructor.
      - left. constructor.
      - right.
        destruct t1.
        + eexists. apply ST_IfTrue.
        + eexists. apply ST_IfFalse.
        + destruct IHt1 as [Hl | Hr].
          * inversion Hl.
          * destruct Hr as [t' Hr].
            exists (test t' t2 t3).
            apply ST_If. assumption.
    Qed.
  End Temp5.
End Temp4.

Inductive multi {X : Type} (R : relation X) : relation X :=
  | multi_refl : forall (x : X),
                    multi R x x
  | multi_step : forall (x y z : X),
                    R x y ->
                    multi R y z ->
                    multi R x z.

Notation " t '-->*' t' " := (multi step t t') (at level 40).

Theorem multi_R : forall (X : Type) (R : relation X) (x y : X),
    R x y -> (multi R) x y.
Proof. intros X R x y H.
  apply (multi_step R x y y H).
  apply multi_refl.
Qed.

Theorem multi_trans :  forall (X : Type) (R : relation X) (x y z : X),
      multi R x y ->
      multi R y z ->
      multi R x z.
Proof.
  intros X R x y z H1 H2.
  induction H1.
  - (* refl *)apply H2.
  - (* step *)apply multi_step with y.
    apply H.
    apply IHmulti.
    apply H2.
Qed.

Print multi_trans.
Print multi_ind.

Lemma test_multistep_1:
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
   -->*
      C ((0 + 3) + (2 + 4)).
Proof.
  apply multi_step with (P (C (0 + 3)) (P (C 2) (C 4))).
  { apply ST_Plus1. apply ST_PlusConstConst. }
  apply multi_step with (P (C (0 + 3)) (C (2 + 4))).
  { apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  apply multi_R.
  apply ST_PlusConstConst.
Qed.

Lemma test_multistep_1':
      P
        (P (C 0) (C 3))
        (P (C 2) (C 4))
  -->*
      C ((0 + 3) + (2 + 4)).
Proof.
  eapply multi_step. { apply ST_Plus1. apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_PlusConstConst. }
  apply multi_refl.
Qed.

Lemma test_multistep_2:
  C 3 -->* C 3.
Proof.
  apply multi_refl.
Qed.

Lemma test_multistep_3:
      P (C 0) (C 3)
   -->*
      P (C 0) (C 3).
Proof.
  apply multi_refl.
Qed.

Lemma test_multistep_4:
      P
        (C 0)
        (P
          (C 2)
          (P (C 0) (C 3)))
  -->*
      P
        (C 0)
        (C (2 + (0 + 3))).
Proof.
  apply multi_step with (P
        (C 0)
        (P
          (C 2)
          (C (0 + 3)))). { apply ST_Plus2. apply v_const. apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  eapply multi_step. { apply ST_Plus2. apply v_const. apply ST_PlusConstConst. }
  apply multi_refl.
Qed.

Definition step_normal_form := normal_form step.
Definition normal_form_of (t t' : tm) :=  (t -->* t' /\ step_normal_form t').

Theorem normal_forms_unique:  deterministic normal_form_of.
Proof.
  unfold deterministic. unfold normal_form_of.
  intros x y1 y2 P1 P2.
  destruct P1 as [P11 P12].
  destruct P2 as [P21 P22].
  induction P11.
  - inversion P21; subst.
    + reflexivity.
    + exfalso. apply P12. exists y. assumption.
  - inversion P21; subst.
    + exfalso. apply P22. exists y. assumption.
    + assert (G: y = y0). { apply (step_deterministic _ _ _ H H0). }
      apply IHP11.
      apply P12.
      rewrite G.
      assumption.
Qed.

Definition normalizing {X : Type} (R : relation X) :=
  forall t, exists t',
    (multi R) t t' /\ normal_form R t'.

Lemma multistep_congr_1 : forall t1 t1' t2,
     t1 -->* t1' ->
     P t1 t2 -->* P t1' t2.
Proof.
  intros t1 t1' t2 H.
  induction H.
  - (* refl *) apply multi_refl.
  - apply multi_step with (P y t2). apply ST_Plus1. apply H.
    assumption.
Qed.

Lemma multistep_congr_2 : forall t1 t2 t2',
     value t1 ->
     t2 -->* t2' ->
     P t1 t2 -->* P t1 t2'.
Proof.
  intros t1 t2 t2' Hv H.
  induction H.
  - (* refl *) apply multi_refl.
  - apply multi_step with (P t1 y). apply ST_Plus2. apply Hv. apply H.
    assumption.
Qed.

Theorem step_normalizing :
  normalizing step.
Proof.
  unfold normalizing.
  induction t.
  - (* C *)
    exists (C n).
    split.
    + (* l *) apply multi_refl.
    + (* r *)
      (* We can use rewrite with "iff" statements, not
           just equalities: *)
      apply nf_same_as_value. apply v_const.
  - (* P *)
    destruct IHt1 as [t1' [Hsteps1 Hnormal1] ].
    destruct IHt2 as [t2' [Hsteps2 Hnormal2] ].
    apply nf_same_as_value in Hnormal1.
    apply nf_same_as_value in Hnormal2.
    destruct Hnormal1 as [n1].
    destruct Hnormal2 as [n2].
    exists (C (n1 + n2)).
    split.
    + (* l *)
      apply multi_trans with (P (C n1) t2).
      * apply multistep_congr_1. apply Hsteps1.
      * apply multi_trans with (P (C n1) (C n2)).
        { apply multistep_congr_2. apply v_const. apply Hsteps2. }
        apply multi_R. apply ST_PlusConstConst.
    + (* r *)
      apply nf_same_as_value. apply v_const.
Qed.

Theorem eval__multistep : forall t n,
  t ==> n -> t -->* C n.
Proof.
  intros t n H.
  induction H.
  - apply multi_refl.
  - induction t1.
    + (* const *) induction t2.
      * (* const *)
        inversion IHeval1; subst.
        inversion IHeval2; subst.
        eapply multi_step. apply ST_PlusConstConst. apply multi_refl.
        inversion H0; subst. eapply multi_step. apply ST_PlusConstConst. apply multi_refl.
        inversion H0; subst. inversion H; subst. eapply multi_step. apply ST_PlusConstConst. apply multi_refl.
      * (* _ + _ *)
        inversion H; subst.
        assert (G: P (C n1) (P t2_1 t2_2) -->* P (C n1) (C n2)). {
          apply multistep_congr_2.
          apply v_const.
          apply IHeval2.
        }
        apply multi_trans with (P (C n1) (C n2)).
        apply G.
        eapply multi_step. apply ST_PlusConstConst. apply multi_refl.
    + (* _ + _ *)
      assert (G: P (P t1_1 t1_2) t2 -->* P (C n1) t2). {
        apply multistep_congr_1.
        apply IHeval1.
      }
      apply multi_trans with (P (C n1) t2).
      apply G.
      assert (G': P (C n1) t2 -->* P (C n1) (C n2)). {
        apply multistep_congr_2.
        apply v_const.
        apply IHeval2.
      }
      apply multi_trans with (P (C n1) (C n2)).
      apply G'.
      eapply multi_step. apply ST_PlusConstConst. apply multi_refl.
Qed.

Lemma step__eval : forall t t' n,
     t --> t' ->
     t' ==> n ->
     t ==> n.
Proof.
  intros t t' n Hs. generalize dependent n.
  induction Hs.
  - intros k H.
    inversion H; subst.
    apply E_Plus.
    + constructor.
    + constructor.
  - intros n H.
    inversion H; subst.
    apply E_Plus.
    + apply IHHs. assumption.
    + assumption.
  - intros n H'.
    inversion H'; subst.
    apply E_Plus.
    + assumption.
    + apply IHHs. assumption.
Qed.

Theorem multistep__eval : forall t t',
  normal_form_of t t' -> exists n, t' = C n /\ t ==> n.
Proof.
  intro t.
  induction t; intros t' Hn; unfold normal_form_of in Hn; destruct Hn as [Hnl Hnr].
  - exists n.
    split.
    + inversion Hnl; subst; try reflexivity.
      inversion H.
    + constructor.
  -
    assert (G1: exists n1, t1 ==> n1). {
      destruct (step_normalizing t1) as [a [b c]].
      destruct (IHt1 a).
      split. apply b. apply c.
      destruct H. exists x. assumption.
    }
    assert (G2: exists n2, t2 ==> n2). {
      destruct (step_normalizing t2) as [a [b c]].
      destruct (IHt2 a).
      split. apply b. apply c.
      destruct H. exists x. assumption.
    }
    clear IHt1 IHt2.
    destruct G1 as [n1 H1].
    destruct G2 as [n2 H2].
    exists (n1 + n2). split; try reflexivity.
    + apply eval__multistep in H1.
      apply eval__multistep in H2.
      assert (G: P t1 t2 -->* P (C n1) t2). {
        apply multistep_congr_1.
        apply H1.
      }
      assert (G1: P (C n1) t2 -->* P (C n1) (C n2)). {
        apply multistep_congr_2.
        constructor.
        apply H2.
      }
      assert (G2: P t1 t2 -->*P (C n1) (C n2)). {
        eapply multi_trans.
        apply G.
        apply G1.
      }
      assert (G3: P t1 t2 -->* C (n1 + n2)). {
        eapply multi_trans.
        apply G2.
        eapply multi_step. constructor. eapply multi_refl.
      }
      assert (G5: t' = C (n1 + n2)). {
        apply (normal_forms_unique (P t1 t2)).
        - split. apply Hnl. apply Hnr.
        - split. apply G3.
          unfold step_normal_form, normal_form.
          intros [a b]. inversion b.
      }
      apply G5.
    + constructor. assumption. assumption.
Qed.

Theorem evalF_eval : forall t n,
  evalF t = n <-> t ==> n.
Proof.
  intros t n. split; intro H.
  generalize dependent n.
  - induction t.
    + intros n' H. simpl in H; subst. constructor.
    + intros n H. simpl in H.
      rewrite <- H.
      apply (E_Plus t1 t2).
      * apply IHt1. reflexivity.
      * apply IHt2. reflexivity.
  - induction H.
    + reflexivity.
    + simpl. auto.
Qed.

Module Combined.
Inductive tm : Type :=
  | C : nat -> tm
  | P : tm -> tm -> tm
  | tru : tm
  | fls : tm
  | test : tm -> tm -> tm -> tm.

Inductive value : tm -> Prop :=
  | v_const : forall n, value (C n)
  | v_tru : value tru
  | v_fls : value fls.

Reserved Notation " t '-->' t' " (at level 40).
Inductive step : tm -> tm -> Prop :=
  | ST_PlusConstConst : forall n1 n2,
      P (C n1) (C n2) --> C (n1 + n2)
  | ST_Plus1 : forall t1 t1' t2,
      t1 --> t1' ->
      P t1 t2 --> P t1' t2
  | ST_Plus2 : forall v1 t2 t2',
      value v1 ->
      t2 --> t2' ->
      P v1 t2 --> P v1 t2'
  | ST_IfTrue : forall t1 t2,
      test tru t1 t2 --> t1
  | ST_IfFalse : forall t1 t2,
      test fls t1 t2 --> t2
  | ST_If : forall t1 t1' t2 t3,
      t1 --> t1' ->
      test t1 t2 t3 --> test t1' t2 t3
  where " t '-->' t' " := (step t t').

Theorem combined_deterministic: deterministic step.
Proof.
  unfold deterministic.
  intros x y1 y2 H1 H2.
  generalize dependent y2.
  induction H1; intros y2 H2.
  - (*ST_PlusConstConst*) inversion H2; subst.
    + reflexivity.
    + inversion H3.
    + inversion H4.
  - (* ST_Plus1 *) inversion H2; subst.
    + inversion H1.
    + apply IHstep in H4. subst. reflexivity.
    + inversion H3; subst. inversion H1. inversion H1. inversion H1.
  - (* ST_Plus2 *) inversion H; subst.
    + inversion H2; subst.
      * inversion H1.
      * inversion H5.
      * inversion H2; subst. inversion H3.
        apply IHstep in H8; subst. reflexivity.
    + inversion H2. inversion H5; subst.
      apply IHstep in H6. subst. reflexivity.
    + inversion H2. inversion H5; subst.
      apply IHstep in H6. subst. reflexivity.
  - (* ST_IfTrue *) inversion H2; subst. reflexivity. inversion H4.
  - (* ST_IfFalse *) inversion H2; subst. reflexivity. inversion H4.
  - (* ST_If *) inversion H2; subst.
    + inversion H1.
    + inversion H1.
    + apply IHstep in H5. subst. reflexivity.
Qed.
End Combined.

Inductive aval : aexp -> Prop :=
  | av_num : forall n, aval (ANum n).

Reserved Notation " a '/' st '-->a' a' " (at level 40, st at level 39).
Inductive astep (st : state) : aexp -> aexp -> Prop :=
  | AS_Id : forall (i : string),
      i / st -->a (st i)
  | AS_Plus1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 + a2 }> / st -->a <{ a1' + a2 }>
  | AS_Plus2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 + a2 }> / st -->a <{ v1 + a2' }>
  | AS_Plus : forall (n1 n2 : nat),
      <{ n1 + n2 }> / st -->a (n1 + n2)
  | AS_Minus1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 - a2 }> / st -->a <{ a1' - a2 }>
  | AS_Minus2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 - a2 }> / st -->a <{ v1 - a2' }>
  | AS_Minus : forall (n1 n2 : nat),
      <{ n1 - n2 }> / st -->a (n1 - n2)
  | AS_Mult1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 * a2 }> / st -->a <{ a1' * a2 }>
  | AS_Mult2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 * a2 }> / st -->a <{ v1 * a2' }>
  | AS_Mult : forall (n1 n2 : nat),
      <{ n1 * n2 }> / st -->a (n1 * n2)
  where " a '/' st '-->a' a' " := (astep st a a').

Reserved Notation " b '/' st '-->b' b' " (at level 40, st at level 39).
Inductive bstep (st : state) : bexp -> bexp -> Prop :=
  | BS_Eq1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 = a2 }> / st -->b <{ a1' = a2 }>
  | BS_Eq2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 = a2 }> / st -->b <{ v1 = a2' }>
  | BS_Eq : forall (n1 n2 : nat),
      <{ n1 = n2 }> / st -->b
      (if (n1 =? n2) then <{ true }> else <{ false }>)
  | BS_LtEq1 : forall a1 a1' a2,
      a1 / st -->a a1' ->
      <{ a1 <= a2 }> / st -->b <{ a1' <= a2 }>
  | BS_LtEq2 : forall v1 a2 a2',
      aval v1 ->
      a2 / st -->a a2' ->
      <{ v1 <= a2 }> / st -->b <{ v1 <= a2' }>
  | BS_LtEq : forall (n1 n2 : nat),
      <{ n1 <= n2 }> / st -->b
      (if (n1 <=? n2) then <{ true }> else <{ false }>)
  | BS_NotStep : forall b1 b1',
      b1 / st -->b b1' ->
      <{ ~b1 }> / st -->b <{ ~b1' }>
  | BS_NotTrue : <{ ~true }> / st -->b <{ false }>
  | BS_NotFalse : <{ ~false }> / st -->b <{ true }>
  | BS_AndStep : forall b1 b1' b2,
      b1 / st -->b b1' ->
      <{ b1 && b2 }> / st -->b <{ b1' && b2 }>
  | BS_AndTrueStep : forall b2 b2',
      b2 / st -->b b2' ->
      <{ true && b2 }> / st -->b <{ true && b2' }>
  | BS_AndFalse : forall b2,
      <{ false && b2 }> / st -->b <{ false }>
  | BS_AndTrueTrue : <{ true && true }> / st -->b <{ true }>
  | BS_AndTrueFalse : <{ true && false }> / st -->b <{ false }>
where " b '/' st '-->b' b' " := (bstep st b b').

Reserved Notation " t '/' st '-->' t' '/' st' "    (at level 40, st at level 39, t' at level 39).
Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AsgnStep : forall st i a1 a1',
      a1 / st -->a a1' ->
      <{ i := a1 }> / st --> <{ i := a1' }> / st
  | CS_Asgn : forall st i (n : nat),
      <{ i := n }> / st --> <{ skip }> / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      <{ c1 ; c2 }> / st --> <{ c1' ; c2 }> / st'
  | CS_SeqFinish : forall st c2,
      <{ skip ; c2 }> / st --> c2 / st
  | CS_IfStep : forall st b1 b1' c1 c2,
      b1 / st -->b b1' ->
      <{ if b1 then c1 else c2 end }> / st  -->  <{ if b1' then c1 else c2 end }> / st
  | CS_IfTrue : forall st c1 c2,
      <{ if true then c1 else c2 end }> / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      <{ if false then c1 else c2 end }> / st --> c2 / st
  | CS_While : forall st b1 c1,
      <{ while b1 do c1 end }> / st  -->  <{ if b1 then c1; while b1 do c1 end else skip end }> / st
where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

Module CImp.

Inductive com : Type :=
  | CSkip : com
  | CAsgn : string -> aexp -> com
  | CSeq : com -> com -> com
  | CIf : bexp -> com -> com -> com
  | CWhile : bexp -> com -> com
  | CPar : com -> com -> com. (* <--- NEW *)

Notation "x || y" :=
         (CPar x y) (in custom com at level 90, right associativity).
Notation "'skip'" :=
         CSkip (in custom com at level 0).
Notation "x := y" :=
         (CAsgn x y) (in custom com at level 0, x constr at level 0, y at level 85, no associativity).
Notation "x ; y" :=
         (CSeq x y) (in custom com at level 90, right associativity).
Notation "'if' x 'then' y 'else' z 'end'" :=
         (CIf x y z) (in custom com at level 89, x at level 99, y at level 99, z at level 99).
Notation "'while' x 'do' y 'end'" :=
         (CWhile x y) (in custom com at level 89, x at level 99, y at level 99).

Inductive cstep : (com * state) -> (com * state) -> Prop :=
  | CS_AsgnStep : forall st i a1 a1',
      a1 / st -->a a1' ->
      <{ i := a1 }> / st --> <{ i := a1' }> / st
  | CS_Asgn : forall st i (n : nat),
      <{ i := n }> / st --> <{ skip }> / (i !-> n ; st)
  | CS_SeqStep : forall st c1 c1' st' c2,
      c1 / st --> c1' / st' ->
      <{ c1 ; c2 }> / st --> <{ c1' ; c2 }> / st'
  | CS_SeqFinish : forall st c2,
      <{ skip ; c2 }> / st --> c2 / st
  | CS_IfStep : forall st b1 b1' c1 c2,
      b1 / st -->b b1' ->
      <{ if b1 then c1 else c2 end }> / st
      -->
      <{ if b1' then c1 else c2 end }> / st
  | CS_IfTrue : forall st c1 c2,
      <{ if true then c1 else c2 end }> / st --> c1 / st
  | CS_IfFalse : forall st c1 c2,
      <{ if false then c1 else c2 end }> / st --> c2 / st
  | CS_While : forall st b1 c1,
      <{ while b1 do c1 end }> / st
      -->
      <{ if b1 then c1; while b1 do c1 end else skip end }> / st
  (**** New part: ****)
  | CS_Par1 : forall st c1 c1' c2 st',
      c1 / st --> c1' / st' ->
      <{ c1 || c2 }> / st --> <{ c1' || c2 }> / st'
  | CS_Par2 : forall st c1 c2 c2' st',
      c2 / st --> c2' / st' ->
      <{ c1 || c2 }> / st --> <{ c1 || c2' }> / st'
  | CS_ParDone : forall st,
      <{ skip || skip }> / st --> <{ skip }> / st
where " t '/' st '-->' t' '/' st' " := (cstep (t,st) (t',st')).

Definition cmultistep := multi cstep.
Notation " t '/' st '-->*' t' '/' st' " :=
   (cmultistep (t,st) (t',st')) (at level 40, st at level 39, t' at level 39).

Definition par_loop : com :=
  <{ Y := 1 || while (Y = 0) do X := X + 1 end }>.

Lemma par_body_n__Sn : forall n st,
  st X = n /\ st Y = 0 ->
  par_loop / st -->* par_loop / (X !-> S n ; st).
Proof.
  intros n st [Hx Hy].
  eapply multi_step. apply CS_Par2. apply CS_While.

  eapply multi_step. apply CS_Par2. apply CS_IfStep.
  eapply BS_Eq1. apply AS_Id.

  eapply multi_step. apply CS_Par2. apply CS_IfStep. rewrite -> Hy.
  eapply BS_Eq.

  eapply multi_step. apply CS_Par2. apply CS_IfTrue.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AsgnStep. apply AS_Plus1. apply AS_Id. rewrite -> Hx.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_AsgnStep. apply AS_Plus.

  eapply multi_step. apply CS_Par2. apply CS_SeqStep.
  apply CS_Asgn.

  eapply multi_step. apply CS_Par2. apply CS_SeqFinish.
  fold par_loop.
  assert (G: n + 1 = S n). { lia. }
  rewrite -> G.

  apply multi_refl.
Qed.

Lemma par_body_n : forall n st,
  st X = 0 /\ st Y = 0 ->
  exists st', par_loop / st -->* par_loop / st' /\ st' X = n /\ st' Y = 0.
Proof.
(* it looks like mistake, we need n > 0 *)
Admitted.

Theorem par_loop_any_X:
  forall n, exists st',
    par_loop / empty_st -->* <{skip}> / st'
    /\ st' X = n.
Proof.
  intros n.
  destruct (par_body_n n empty_st).
    split; reflexivity.
  rename x into st.
  inversion H as [H' [HX HY] ]; clear H.
  exists (Y !-> 1 ; st). split.
  eapply multi_trans with (par_loop,st). apply H'.
  eapply multi_step. apply CS_Par1. apply CS_Asgn.
  eapply multi_step. apply CS_Par2. apply CS_While.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq1. apply AS_Id. rewrite t_update_eq.
  eapply multi_step. apply CS_Par2. apply CS_IfStep.
    apply BS_Eq. simpl.
  eapply multi_step. apply CS_Par2. apply CS_IfFalse.
  eapply multi_step. apply CS_ParDone.
  apply multi_refl.
  rewrite t_update_neq. assumption. intro X; inversion X.
Qed.

End CImp.

Definition stack := list nat.
Definition prog := list sinstr.
Inductive stack_step (st : state) : prog * stack -> prog * stack -> Prop :=
  | SS_Push : forall stk n p,
    stack_step st (SPush n :: p, stk) (p, n :: stk)
  | SS_Load : forall stk i p,
    stack_step st (SLoad i :: p, stk) (p, st i :: stk)
  | SS_Plus : forall stk n m p,
    stack_step st (SPlus :: p, n::m::stk) (p, (m+n)::stk)
  | SS_Minus : forall stk n m p,
    stack_step st (SMinus :: p, n::m::stk) (p, (m-n)::stk)
  | SS_Mult : forall stk n m p,
    stack_step st (SMult :: p, n::m::stk) (p, (m*n)::stk).

Theorem stack_step_deterministic : forall st,
  deterministic (stack_step st).
Proof.
  unfold deterministic. intros st x y1 y2 H1 H2.
  induction H1; inversion H2; reflexivity.
Qed.

Definition stack_multistep st := multi (stack_step st).

Fixpoint s_compile (e : aexp) : list sinstr :=
  match e with
  | ANum n => SPush n :: nil
  | AId  x => SLoad x :: nil
  | AMult  a1 a2 => (s_compile a1 ++ s_compile a2) ++ [SMult]
  | APlus  a1 a2 => (s_compile a1 ++ s_compile a2) ++ [SPlus]
  | AMinus a1 a2 => (s_compile a1 ++ s_compile a2) ++ [SMinus]
  end.
(* TODO : *)
Definition compiler_is_correct_statement : Prop. Admitted.

Tactic Notation "print_goal" :=
  match goal with |- ?x => idtac x end.
Tactic Notation "normalize" :=
  repeat (print_goal; eapply multi_step ; [ (eauto 10; fail) | (instantiate; simpl) ]);
  apply multi_refl.
Hint Constructors step value : core.

Example step_example1'' :
  (P (C 3) (P (C 3) (C 4))) -->* (C 10).
Proof.
  normalize.
Qed.

Example step_example1''' : exists e',
  (P (C 3) (P (C 3) (C 4))) -->* e'.
Proof.
  eexists. normalize.
Qed.

Theorem normalize_ex : exists e',
  (P (C 3) (P (C 2) (C 1))) -->* e' /\ value e'.
Proof.
  eexists. split.
  - normalize.
  - constructor.
Qed.


(** %\chapter{%#<H0>#Finite automata%}%#</H0># *)

(* Proofs *)
 Section Automata.
(*Load FinSets.*)
Load Finitesets.
Require Import List.

Set Implicit Arguments.

(*Definition Alphabet := nat.*)
(*Variable Sigma : Alphabet. *)

(** * Introduction

  In finite automata theory, the basic element that we need to use in order  to reason about the behaviour of an automaton is the _word_ .

  By definition, we call  a word to be a list of _symbols_.

  - A symbol is an element of an alphabet( usually denoted as $\Sigma $ ).

  - A set of words is defined to be called a _language_ .

  In our implementation , a language is represented as a function that takes a word

  and decides whether it is a member of the set (type [Prop]).

      *)
Definition Word(x:Alphabet) := list (Fin x).

Definition Language (a:Alphabet):= Word a -> Prop.

(** An empty word is defined as the [nil] list constructor *)

Definition eps (a:Alphabet):Word a:=nil.

(**  * Deterministic finite automata

  As in "Automata and theory of computation"(J.Hopcroft), a deterministic finite automaton

 (DFA) is defined a 5-uple (Q,$\Sigma $ , $\sigma $, ${q}_{0}$, F)

  - A finite set of states Q (here denoted by [states])

  - A set of symbols ([Fin a])

  - A transition function $\sigma $ : Q * $\Sigma $ -> Q , denoted by [delta]

  - An initial state ${q}_{0}$

  - A set of final states F .

*)

Record dfa (n:nat) (a:Alphabet) :Type:= DFA {
  states :=  Fin n; (*finite sets*)
  symbol := Fin a;
  delta : Fin n ->Fin a  -> Fin n;
  q0 : Fin n ; (*only 1 initial state*)
  final :Fin n -> bool (*multiple states*)
}.
Check dfa.

(** * Language of a finite deterministic automaton *)

(*Definition is_accepting (n:nat)(a:Alphabet)(d:dfa n a)(q: states d)  := In q (final d).*)

(** Below, we have the extended transition function for a DFA , [deltah] : *)

Fixpoint deltah (n:nat)(a:Alphabet)(d: dfa n a)(q: Fin n) (w: Word a) : (Fin n):=
  match w with
     | nil => q
     | h :: t => (deltah d (delta  d q h ) t)
  end.
Lemma deltah_prop:
  forall (a:Alphabet)(n:nat)(q:Fin n) (d:dfa n a) (xs ys :Word a),
   deltah d (q) (xs++ ys) = deltah d (deltah d (q) xs) ys.

induction xs.
simpl in *.
reflexivity.
simpl in *.

intros.
simpl in *.
(*induction ys.
simpl in *.
assert (xs++nil = xs).
intuition.
rewrite H.
reflexivity.
simpl in *.
intuition. *)
admit.
Qed.
Lemma deltah_property :
    forall (a:Alphabet)(n:nat) (d:dfa n a)(q:Fin n)(xs ys zs :Word a) ,
   deltah d (q) (xs ++ ys ++ zs) =
    deltah d(deltah d (deltah d (q) xs) ys ) zs.
induction xs.
simpl.
induction ys.
simpl in *.
reflexivity.
simpl in *.
apply deltah_prop.

simpl in *.
intros.
assert (xs ++ ys ++ zs = (xs ++ ys)++ zs).
auto with *.
admit.

(*simpl in *.
induction xs.

induction zs.
simpl in *.
intuition.
assert (ys ++ nil = ys).
intuition.
 (*very well known property*)
rewrite H.
reflexivity.
simpl in *. *)

Qed.

Notation " x ^ y " := (exps x y).

Definition dfa_lang1 (n:nat)(a:Alphabet)(d: dfa n a) :Language a :=
  fun w:Word a => final  d (deltah  d(q0 d ) w)=true.

(** The actual definition of the language of a DFA *)

Definition dfa_lang (n:nat)(a:Alphabet)(d: dfa n a) :Language a :=
  fun w:Word a => match  final  d (deltah  d(q0 d ) w)  with
              | true => True
              | false => False
             end.

Check dfa_lang.
Check tt.

(** Empty automaton : a (initial )state with no final states*)

Definition dfa_void(q:Fin 1)(a:Alphabet) : dfa 1 a :=
          DFA (fun x:Fin 1 => fun b:Fin a => q ) q (fun x:Fin 1 => false).

Print dfa_void.

(** The empty automaton will not accept any word *)

Definition empty_lang (a:Alphabet):Language a:= fun w:Word a=>False.

Definition isNil (a:Alphabet) (w:Word a): Prop :=
    match w with  |nil => True
                  | _  => False
                              end.

Definition eps_lang (a:Alphabet) :Language a :=

             fun w:Word a=> w=nil.

              (*fun w:Word a => match w with  |nil => True
                                            | _  => False
                              end. *)

Definition eps_lang1 (a:Alphabet) :Language a :=
        fun w:Word a => w =nil.

Lemma dfa_void_correct: forall (a:Alphabet)(q:Fin 1) (w:Word a),
     dfa_lang (dfa_void q a) w -> empty_lang w.
intros.
unfold dfa_lang in H.
unfold empty_lang.
simpl in H.

auto with *.
Qed.

(*The automaton that will take the epsilon language *)

Print option.
Check (S (S 0)).
Definition dfa_epsilon (q:Fin 1)(a:Alphabet) : dfa (1) a :=
   DFA( fun _:Fin 1 => fun _:Fin a=> q) q   (fun x:Fin 1 => eqf q x).

Print dfa_epsilon.

Definition dfa_compl (a:Alphabet)(n:nat)(d:dfa n a) : dfa n a :=

   DFA( delta d) (q0 d) (fun q : Fin n=>

    negb (final d q)).
Inductive empty :Set := .
Inductive singleton :Set := emptyx : singleton.
Print emptyx.

(** Remove states that are unreachable !!! *)

Definition reachable_immediate (a:Alphabet) (n:nat) (d: dfa n a)(x y :Fin n)  :=

  exists c:Fin a,   (delta d x c) = y.

Definition reachable (a:Alphabet)(n:nat) (d:dfa n a) (y:Fin n) :=

   exists w:Word a , deltah d ( q0 d)w = y.

Definition isconnected (a:Alphabet)(n:nat) (d:dfa n a) :=

    forall (x:Fin n), exists w:Word a, deltah d (q0 d) w = x.

(** * Nondeterministic finite automaton

   A _nondeterministic finite automaton_ (NFA) A is defined as a 5-uple Q,$\Sigma $ , $\sigma $, S, F),
   where :

   - [Q] represent a finite set of initial states ( [nstates])

   - A set of symbols $\Sigma $ ([Fin a])

   - A transition function $\sigma $ : Q * $\Sigma $ -> $P (Q)$ ([ndelta])

   - A set of initial states [S] , denoted by [ninitial]

   - A set of final states [F], denoted by [nfinal].

*)

Record nfa (n:nat)(a:Alphabet) := NFA {

   nstates :=Fin n;
   nsymbol := Fin a;
   ndelta : Fin n-> Fin a  ->Fin (2^n);
   ninitial : Fin n -> bool (* multiple states*);
   nfinal : Fin n -> bool
 }.
Check nfa.

(** We want to generate the union of 2 sets, taking into account the isomorphism [(Fin n -> bool) <-> Fin (2^n)], proven in the library of

    finite sets. *)

Definition unionf (n:nat) (sets : (Fin n -> bool) -> bool) (x:Fin n) : bool :=
  existsf1 (fun q : Fin (2^n) => sets( allexp2 q) && allexp2 q x).

Definition prepare (n:nat)(a:Alphabet) (nr:nfa n a)(states : Fin (2^n)) (x:Fin a)  : (Fin n -> bool)  :=
   fun s : Fin n  => existsf1 (fun st : Fin n => allexp2 (states) (st) &&  allexp2(ndelta  nr st x) s).

(** The extended transition function for an NFA  [ndeltah]: *)

Fixpoint ndeltah (n : nat) (a:Alphabet) (nr: nfa n a) (qs : (Fin (2^ n))) (w:Word a) :(Fin (2^n)) :=
       match w with
     | nil    =>  qs
     | h :: t =>  (ndeltah nr (allexp1 (prepare nr qs h)) t)
       end.
(*Definition nfa_lang (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q)))=true.
*)
Definition nfa_lang (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => match (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q))) with
                   | true => True
                  | false => False
                   end .
Definition nfa_lang1 (n:nat)(a:Alphabet) (nr: nfa n a) :Language a :=
  fun w :Word a => (existsf1(fun q :Fin n=>( allexp2(ndeltah nr (allexp1 (ninitial nr) ) w)) q && (nfinal  nr q)))=true.

(** * The subset construction *)

(*Convert a dfa to an nfa: *)

Definition dfa2nfa (n:nat) (a:Alphabet) (d:dfa n a): nfa n a :=
    NFA(fun k : Fin n => fun a : Fin a =>

     (allexp1 ( fun x:Fin n => eqf x (delta d k a) ))) (fun x:Fin n => eqf x (q0 d)) (final d).

(* union of ndelta *)

Definition nfa2dfa (n:nat) (a:Alphabet) (nr: nfa n a) : dfa (2^n) a :=

 DFA (fun k:Fin (2^n)=> fun a : Fin a => allexp1 (prepare nr k a)) (allexp1 (ninitial nr ))
    (fun k:Fin (2^n)=>existsf1(fun q:Fin n=> (allexp2 k q ) && nfinal nr  q)).

Definition nfa_void (a:Alphabet) : nfa 1 a :=
  NFA(fun x:Fin 1 => fun a:Fin a=> allexp1 (fun y:Fin 1 => false))
      (fun x:Fin 1 =>existsf1 (fun y:Fin 1 => eqf x y))
       (fun x:Fin 1 =>existsf1 (fun y:Fin 1 => false)).

Lemma nfa_void_lang :  forall (a:Alphabet)(w:Word a),
     nfa_lang (nfa_void a) w -> empty_lang w.
intros.
unfold empty_lang.
unfold nfa_lang in H.
simpl in H.
auto with *.

Qed.
Print eps.
(*
Definition chec (a:Alphabet) (p :Fin a) :=

 if (p::nil)=eps a then true else false.*)

Definition nfa_eps(a:Alphabet):nfa 1 a :=

  NFA(fun x:Fin 1 => fun a0:Fin a => allexp1 (fun y:Fin 1 => eqf x  y))
   (fun x:Fin 1 => true ) (fun x:Fin 1 => true).

Print nfa_eps.

Print option.

Lemma nfa_eps_lang1 : forall (a:Alphabet)(w:Word a) ,
     eps_lang w -> nfa_lang (nfa_eps a) w.
intros.
unfold eps_lang in H.
unfold nfa_lang.
simpl.
split.
Qed.
Lemma nfa_eps_lang :forall (a:Alphabet) (w:Word a) ,
   nfa_lang (nfa_eps a) w -> eps_lang w.
intros.
unfold eps_lang.

unfold nfa_lang in H.
simpl in *.

admit.
Qed.

Definition nfa_var (a:Alphabet) :=

   NFA (fun xs : Fin 2 => fun c:Fin a =>

     allexp1 (fun ys : Fin 2 => eqf xs ys =false) )

     (fun xs :Fin 2 =>

Definition nfa_var(a:Alphabet)(cc:Fin a)  :=
    NFA( fun it :Fin 2 => fun aa :Fin a =>  allexp1 (fun final:Fin 2=>if negb (eqf it final)&& eqf cc aa then true  else  false ))
      (fun x : Fin 2 => existsf1 (fun y: Fin 2 => eqf x y) )
    (fun x:Fin 2 => existsf1 ( fun y :Fin 2 => eqf x y)).

Print nfa_var.
(*
Definition nfa_var1(a:Alphabet)(x:Fin a) : nfa 2 a:=

   NFA (fun xs :Fin 2 => fun c :Fin a => allexp1(existsf1(fun y:Fin 2 =>
           end))) tt tt. *)

Definition single_lang (a:Alphabet):Language a:=
  fun w =>

match w with
        | a::nil => True
        | _ => False
     end.
Print single_lang.

Definition single_lang1 (a:Alphabet)(x:Fin a) :Language a :=
  fun w : Word a => match w with

     | p :: nil => if eqf p x then True else False
     | _ => False
    end.
Lemma nfa_var_lang : forall (a:Alphabet)(w:Word a)(cc:Fin a) ,
    nfa_lang (nfa_var  cc) w -> single_lang1 cc w.
intros.
unfold nfa_lang in H.
(*intuition.
(*We want to prove that in an nfa with the epsilon language does not accept a word
different from <nil>  useful in the theorem of correctness nfa_eps_lang *)
rewrite H0 in H.
assert(False). *)
unfold nfa_var in *.
simpl in *.
unfold single_lang1.
simpl.
admit.
Qed.
Print nfa_var.

Print sum.
Print prod.

Definition condition1 (a:Alphabet)(p q :nat) (c:Fin a) (n1:nfa p a)(n2:nfa q a) (xd : Fin (p+q)) : bool :=

         match (addfin1 p q xd) with
        | inl x => existsf1 (fun tx:Fin(2^p) => eqf tx (ndelta n1 x c))

        | inr y => existsf1 (fun ty :Fin (2^q) => eqf ty (ndelta n2 y c))

       end.

Definition nfa_disj (a:Alphabet)(p q :nat) (n1:nfa p a)(n2:nfa q a) : nfa(p+q) a :=

    NFA( fun xs : Fin (p+q) => fun c:Fin a =>

    allexp1 (fun xss :Fin (p+q) => eqf xs xss &&  condition1 c n1 n2 xss))

    (fun xs :Fin (p+q) =>

       match (addfin1 p q xs) with

          | inl x => ninitial n1 x

          | inr y => ninitial n2 y

     end)

    (fun xs :Fin (p+q)  =>

       match (addfin1 p q xs) with

          | inl x => nfinal n1 x

          | inr y => nfinal n2 y

     end) .

Definition lang_conc(a:Alphabet)(l1:Language a)(l2:Language a):Language a:=
    fun w:Word a=> exists w1:Word a, exists w2:Word a,  w1 ++ w2=w /\ l1 w1 /\ l2 w2.

Definition lang_union(a:Alphabet) (l1:Language a )(l2:Language a):Language a:=
    fun w:Word a=>  l1 w \/ l2 w.
Print nfa_lang1.
Lemma nfa_disj_lang : forall (a:Alphabet) (p q:nat) (n1: nfa p a) (n2: nfa q a) (w:Word a),

        nfa_lang1 ( nfa_disj n1 n2 ) w -> lang_union (nfa_lang1 n1  ) (nfa_lang1 n2 ) w.
intros.
unfold lang_union.
unfold nfa_lang1 in *.
simpl.
simpl in *.
set( PP:= fun qx :Fin (p+q) => match addfin1 p q qx with
  | inl x => nfinal n1 x

  | inr y => nfinal n2 y end).

left.
admit.
Qed.

Lemma nfa_disj_lang1 : forall (a:Alphabet) (p q:nat) (n1: nfa p a) (n2: nfa q a) (w:Word a),

       lang_union (nfa_lang1 n1  ) (nfa_lang1 n2 ) w -> nfa_lang1 ( nfa_disj n1 n2 ) w.
intros.
unfold lang_union in *.
unfold nfa_lang1 in *.
destruct H.
simpl in *.
set( PP:= fun qx :Fin (p+q) => match addfin1 p q qx with
  | inl x => nfinal n1 x

  | inr y => nfinal n2 y end).

set (pp:= fun q :Fin p => nfinal n1 q).
admit.

simpl in *.
admit.

(*
intros.
unfold lang_union.
unfold nfa_lang.
simpl in *.
unfold nfa_lang in H.
simpl in *.
left.
case_eq( existsf1(fun q1:Fin p => nfinal n1 q1)).
intro.
split.
intro.

left.*)

Qed.

Eval compute in existsf1( fun y: Fin 3=>(existsf1 (fun x:Fin 2 => true&& false))).

Print sum.

(*Inductive empty :Set := .*)
(**For a set with a single element, we consider an element x defined itself on  the singleton.

*)
(*Inductive singleton :Set := emptyx : singleton.  *)

Check (inr  emptyx).
Check existsf1(fun (t:Fin 2)=> existsf1 (fun o : Fin 2 => eqf t o )).

Print nfa_disj.

Check ( fun (c:Fin 2) => fun (d:Fin 3)=> inr (Fin 3) c).

Definition nfa_conc(a:Alphabet)(p q:nat) (n1:nfa p a) (n2:nfa q a) : nfa( p+q) a:=

    NFA( fun xs:(Fin (p+q)) => fun c:Fin a=>
  ( allexp1( fun xss:Fin (p+q) => eqf xss xs && (  existsf1 (fun x:Fin p=> existsf1(fun y:Fin q =>

          (*
      match addfin1 x , addfin1 y with

      | inl x , inl y =>  existsf1 (fun t:Fin (2^p) => (eqf(ndelta n1 x c) t))

      | inl x, inr y =>  (nfinal n1 x) && ndelta (n2) *)

         match (addfin1 p q xs) with
       | inl  x => existsf1 (fun t:Fin (2^p) => (eqf(ndelta n1 x c) t)) ||

                          existsf1 (fun q'': Fin q => existsf1 (fun q' :Fin p =>

                     existsf1 (fun tx:Fin (2^p)=>

                        (nfinal n1 q') && (ninitial n2 q'') && (allexp2 (ndelta n1 x c) q'))))

       | inr  y => existsf1( fun tr: Fin (2^q) => (eqf(ndelta n2 y c) tr))

        end ))))))
      (fun xs :Fin (p+q) =>
          existsf1(fun x:Fin p => existsf1(fun y:Fin q =>

           match  (addfin1 p q xs) with
         | inl x =>  ninitial n1 x

         | inr y => nfinal n2 y && existsf1( fun t: Fin p => ninitial n1 t && nfinal n1 t)

         end)))

     (fun xs :Fin (p+q) =>
        existsf1 (fun x:Fin p=> existsf1(fun y:Fin q =>
           match  (addfin1 p q xs) with

         | inl x =>  false

         | inr y => nfinal n2 y
        end ))).

Print nfa_conc.

Lemma nfa_conc1 : forall (a:Alphabet) (p q:nat)
        (n1 :nfa p a) (n2 : nfa q a)  (w:Word a) ,

   nfa_lang1 (nfa_conc n1 n2) w -> lang_conc (nfa_lang1 n1) (nfa_lang1 n2) w.

intros.
unfold lang_conc in *.
unfold nfa_lang1 in *.
simpl in *.
admit . (*??*)
Qed.
Definition nfa_star (a:Alphabet) (p:nat) (n1:nfa p a) : nfa (p+1) a :=

    NFA( fun xs:Fin (p+1) => fun c:Fin a=>

    allexp1 (fun xss:Fin(p+1) => eqf xs xss && existsf1( fun _:Fin p =>

        match (addfin1 p 1 xs) with

     | inl x => existsf1 (fun tx:Fin (2^p) => eqf tx (ndelta n1 x c)) ||

                existsf1 (fun q' :Fin p => existsf1 (fun tx:Fin (p) =>

                           (ninitial n1 q') &&  (allexp2  (ndelta n1 x c) tx )&& (nfinal n1 tx)))

     | inr y => false

   end )))

    (fun xs:Fin (p+1) =>

        match (addfin1 p 1 xs) with

    | inl x => ninitial n1 x

    | inr y => true

       end)

     (fun xs:Fin (p+1) =>

        match (addfin1 p 1 xs) with

    | inl x => nfinal n1 x

    | inr y => true

       end) .

Lemma nfa_eps_lang :  forall (a:Alphabet)(w:Word a),
     nfa_lang1 (nfa_eps a) w -> eps_lang1 w.

intros.
unfold nfa_lang1 in H.

unfold eps_lang1.

simpl in *.
destruct w.
split.
inversion H.
induction w.
simpl.
split.
simpl.
rewrite IHw.

simpl in H.
simpl in IHw.
inversion H.
simpl in IHw.
unfold isNil in IHw.
(*induction w.
split.
simpl in H.
simpl in IHw.
apply IHw in H.
simpl in H. *)

admit.
Qed. *)
Check negb.
Print negb.
Check inl.

Lemma dfa2nfa_correct2 : forall (n:nat)(a:Alphabet)(w:Word a)(d:dfa n a),
              dfa_lang d w-> nfa_lang (dfa2nfa d)w.
intros.
unfold dfa_lang in H.
unfold nfa_lang.
simpl.

case_eq (existsf1 (fun q:Fin n => final d q)).
intros.
split.
intro.
assert( final d (deltah d (q0 d) w)=false).
admit.

(*must prove that if there is no state that is final, then
also the initial state cannot be final, taken as a particular case of the problem *)

rewrite H1 in H.
destruct H.
(*reflexivity.*)
Qed.

Lemma dfa2nfa_correct1 : forall (n:nat)(a:Alphabet)(w:Word a)(d:dfa n a),
               nfa_lang (dfa2nfa d)w-> dfa_lang d w .
(*intros.
unfold nfa_lang1 in *.
unfold dfa_lang1 in *.
simpl in *.*)

intros.
unfold nfa_lang in H.
simpl in H.
unfold dfa_lang.
simpl.
simpl in H.
case_eq (existsf1 (fun q:Fin n => final d q)).
intro.
simpl.
simpl in *.
rewrite H0 in H.

case_eq (final d (deltah d (q0 d) w)).
split.
intro.
admit.
intro.

rewrite H0 in H.
destruct H.
Qed.

Theorem nfa2dfa_correct1 :forall (n:nat)(a:Alphabet)(w:Word a) (nr:nfa n a),
       dfa_lang (nfa2dfa nr) w -> nfa_lang nr w.
Proof.
intros.
unfold dfa_lang in H.
unfold nfa_lang.
simpl in H.
simpl.
exact H.
Qed.

Theorem nfa2dfa_correct2: forall (n:nat)(a:Alphabet)(w:Word a) (nr:nfa n a),
       nfa_lang nr w -> dfa_lang (nfa2dfa nr) w.
Proof.
intros.
unfold dfa_lang.
unfold nfa_lang in H.
simpl.
simpl in H.
assumption.
Qed.

(*Lemma for the equivalence of extended transition functions of a DFA and an NFA*)
Lemma eqref: forall (n:nat) (p :Fin n)  , equalsf p p =true.
intros.
induction n.
simpl.

assert (False).
apply fin0empty.
exact p.
destruct H.

unfold equalsf.
unfold equalsf in IHn.
simpl.
admit. (*prove inductive step *)
Qed.
Lemma ext_delta_coincide: forall (n:nat)(a:Alphabet) (nr:nfa n a)(w:Word a) ,
    eqf (ndeltah nr  (allexp1(ninitial nr)) w)(deltah (nfa2dfa nr) (q0 (nfa2dfa nr)) w)=true.

intros.
unfold eqf.
simpl.
induction w.
simpl.
rewrite eqref.

reflexivity.

set(P:=deltah (nfa2dfa nr) (allexp1 (ninitial nr )) w).

assert(deltah (nfa2dfa nr) (allexp1 (ninitial nr)) (a0:: w) =

      (deltah (nfa2dfa nr) (delta  (nfa2dfa nr) (allexp1 (ninitial nr)) a0 ) w)).
simpl.
reflexivity.
simpl.
trivial.

Qed.

End Automata.


Require Export DMFP.Day08_sets.

(* ================================================================= *)
(** ** Case study: DNA edit distance *)

(** A key biological question of interest is _similarity_. How similar
    are two individuals of the same species? How similar are two
    species? When we see similarities or differences in expressed
    behavior (_phenotype_), can we trace these to corresponding
    similarities or differences in genetics (_genotype_)?
 *)

(** To ask these questions in a formal way, we need measures of
    similarity. One popular quantitative measure for any list-based
    data is called _edit distance_. Given two strands of DNA, how many
    edits do we need to make to get from one to the other?

    For example, consider the following DNA sequences.
 *)

Definition dna_src  : strand := [G; C; A; T].
Definition dna_tgt1 : strand := [T; C; A; T].
Definition dna_tgt2 : strand := [C; A; T].
Definition dna_tgt3 : strand := [C; A; T; G].

(** What edits might we need to make to get from [dna_src] to each of
    the [dna_tgt]s?

    To change [dna_src] into [dna_tgt1], we should replace the first
    [G], substituting it with a [T].

    To change [dna_src] into [dna_tgt2], we should delete the first
    [G].

    To change [dna_src] into [dna_tgt3], we should delete the first
    [G] and add a [G] at the end.

*)

(** We can formalize this idea explicitly: we'll define a type [edit]
    and say what it means to 'apply' an edit.

    Here's what an edit is: you can either [copy] a nucleotide,
    [delete] a nucleotide, [add] a nucleotide, or [substitute] a
    nucleotide for what was already there.  *)

Inductive edit : Type :=
| copy
| delete
| add (e : base)
| substitute (e : base).

(** These aren't the only edits we could have defined. For example, we
    don't _need_ [substitute], since we can always [delete] and then
    [add] (or vice versa). We could add a [move] edit that somehow
    said where to move the current base (i.e., in changing [dna_src]
    to [dna_tgt3], we could say that that [G] _moves_ to the end).

    We've chosen these edits because they correspond to the edits
    invented by Vladimir Levenshtein in 1966, and are used to compute
    the widely used Levenshtein distance (see
    https://en.wikipedia.org/wiki/Levenshtein_distance). It's worth
    noting that this distance is _very_ useful in computational
    applications in a variety of domains, but (according to folklore),
    Levenshtein didn't get to use computers at his Soviet institute!

    In order to justify [substitute]'s presence when [add] and
    [delete] would do, we define a notion of [cost]. It's free to
    [copy], but every other edit has a cost of 1.
 *)

Definition cost (edit : edit) : nat :=
  match edit with
  | copy => 0
  | delete => 1
  | add _ => 1
  | substitute _ => 1
  end.

(** Given a list of edits, the cost is just the sum of the costs of
    every constituent edit. *)
Fixpoint total_cost (edits : list edit) : nat :=
  match edits with
  | [] => 0
  | e::edits' => cost e + total_cost edits'
  end.

(** We've only given an intuition for edits. How do they actually
    work? We must define what it means to apply an edit. We'll do it
    in two parts: first, given an edit and a strand of DNA we're
    editing, [apply_edit] returns two things: first, an optional
    nucleotide which will appear at the front of the new, edited
    strand; and second, a (possibly modified) DNA strand that we're
    working on. *)

Definition apply_edit (edit : edit) (orig : strand) : option base * strand :=
  match edit with
  | copy =>
    match orig with
    | [] => (None, [])
    | b::orig' => (Some b, orig')
    end
  | delete => (None, match orig with
                     | [] => []
                     | _::orig' => orig'
                     end)
  | add b => (Some b, orig)
  | substitute b => (Some b, match orig with
                             | [] => [] (* just act like add *)
                             | _::orig' => orig'
                             end)
  end.

(** It's worth paying close attention to this function, as there
    are several corner cases.

    - [copy] has two possibilities. Either the strand we're editing is
      done, in which there's nothing to add and nothing to continue
      with... or the strand has some base [b] at the front, which (a)
      we'll make sure to copy to the front of the new strand ([Some
      b]), and (b) we'll return the rest of the strand ([orig']).

    - [delete] is slightly simpler. We'll never add anything to the
      front ([None]), and we'll knock off the base at the front of the
      strand we're working with, returning whatever may be left
      ([orig']).

    - [add b] is the simplest case: add [b] to the front and leave the
      strand we're editing alone.

    - [susbtitute b] is trickier. We'll put [b] at the front no matter
      what ([Some b]), but what should we do if we're supposed to
      substitute [b] but the strand we're editing is empty? We choose
      to shrug and say, "That's fine, we'll pretend you meant [add b]
      and not worry about having nothing to substitute for." If, on
      the other hand, [orig = b'::orig'], then we'll ignore [b']
      (which is what we substituted for) and give [orig'] to keep
      editing.
 *)

(** Once we know how to apply an individual edit, it's easy enough to
    apply a list of edits. We walk down the list and, for each edit,
    we see what should be added to the front ([new]) and what remains
    of the strand of DNA we're editing ([orig']). *)

Fixpoint apply_edits (orig : strand) (edits : list edit) : strand :=
  match edits with
  | [] => orig
  | edit::edits' =>
    let (new, orig') := apply_edit edit orig in
    match new with
    | None => apply_edits orig' edits'
    | Some b => b::apply_edits orig' edits'
    end
  end.

(** With a notion of edits in hand, let's verify that our formal model
    matches our intuition. Can we come up with the 'valid' edits that
    match our informal descriptions above? *)

Definition valid_edit (src : strand) (tgt : strand) (edits : list edit) :=
  eq_strand (apply_edits src edits) tgt.

Definition edit_tgt1 : list edit := [substitute T; copy; copy; copy].
Definition edit_tgt1_worse : list edit := [delete; add T; copy; copy; copy].
Definition edit_tgt1_same : list edit := [substitute T].

Compute (valid_edit dna_src dna_tgt1 edit_tgt1).
Compute (valid_edit dna_src dna_tgt1 edit_tgt1_worse).
Compute (leb (total_cost edit_tgt1) (total_cost edit_tgt1_worse)).
Compute (eqb (total_cost edit_tgt1) (total_cost edit_tgt1_same)).

(** **** Exercise: 3 stars, standard (edit_tgt23)

    Write edits that take [dna_src] to [dna_tgt2] and [dna_tgt3]. Your
    edits should be _minimal_, i.e., the lowest cost possible, while
    still being valid. *)

Definition edit_tgt2 : list edit := [delete; copy; copy ; copy].

Compute (valid_edit dna_src dna_tgt2 edit_tgt2).

Definition edit_tgt3 : list edit := [delete; copy; copy; copy; add G].

Compute (valid_edit dna_src dna_tgt3 edit_tgt3).
(* Do not modify the following line: *)
Definition manual_grade_for_edit_tgt23 : option (nat*string) := None.
(** [] *)

(** **** Exercise: 3 stars, standard (delete_add_edit)

    With our notion of edits in hand, we can contemplate defining
    algorithms that compute edits from one strand to another. Let's
    begin with the simplest one: the [delete_add_edit].

    To go from [src] to [tgt], first delete everything in [src] and
    then add everything in [tgt].

    Now, [delete_add_edit] won't be minimal, but it's a place to
    start!

    We'll define it in three parts: [delete_edit] takes a [src] strand
    and produces the correct number of [delete] edits; [add_edit]
    takes a [tgt] strand and produces the correct number of [add]
    edits with the right bases; and [delete_add_edit] combines the
    two.
*)

(** NOTE: your solutions should:

    (a) be only line each

    (b) for [delete_edit] and [add_edit], use the [map] function

    (c) for [delete_add_edit], use [delete_edit] and [add_edit].
 *)

Definition delete_edit (src : strand) : list edit := map (fun n  => delete ) src.

Definition add_edit (tgt : strand) : list edit := map add tgt.

Definition delete_add_edit (src : strand) (tgt : strand) : list edit := delete_edit src ++ add_edit tgt.
(** [] *)

(** With those definitions under our belt, we can write a more
    interesting edit function: substitute when possible, only adding
    or deleting when one list runs out. *)

Fixpoint naive_sub_edit (src : strand) (tgt : strand) : list edit :=
  match (src, tgt) with
  | ([], tgt) => add_edit tgt
  | (src, []) => delete_edit src
  | (_::src', b2::tgt') =>
    substitute b2 :: naive_sub_edit src' tgt'
  end.

(** **** Exercise: 2 stars, standard (sub_edit)

    [naive_sub_edit] is a little bit, well, naive. Give an example of
    a pair of DNA strands [naive_src] and [naive_tgt] for which
    [naive_sub_edit] gives a high cost when it could give a very low
    cost. *)
Definition naive_src : strand := [T; G; T; C].
Definition naive_tgt : strand := [A; G; T; C].

(** Explain why [naive_sub_edit naive_src naive_tgt] is so high
    cost. What should happen differently?  *)

(* It is because naive_sub_edit is just substituting the bases in naive_src with the bases in naive_tgt, regardless of whether the base in src matches the base in tgt.
 What should be done is that it copys the base in tgt if the base in src matches the base in tgt  *)

(** Define a function [sub_edit] that generates an edit similarly to
    [naive_sub_edit], but without the naivete. *)
Fixpoint sub_edit (src : strand) (tgt : strand) : list edit :=
  match (src, tgt) with
  | ([], tgt) => add_edit tgt
  | (src, []) => delete_edit src
  | (bl::src', b2::tgt') => match eq_base bl b2 with
                            | true=> copy :: sub_edit src' tgt'
                            | false => substitute b2 :: sub_edit src' tgt'
                            end
  end.
(** [] *)

(* ################################################################# *)
(** * Levenshtein's edit distance *)

(** **** Exercise: 3 stars, standard (levenshtein)

    We've looked at a bunch of different edit functions: it's time to
    look at Vladimir Levenshtein's!

    The key idea is to consider four possible edits at each juncture
    and choose the cheapest one. Suppose we're trying to edit [b1 ::
    src] into [b2 :: tgt]. (When one is empty, things are simpler.)

    - If [b1] and [b2] are the same, we can [copy], continuing with
      [src] and [tgt].

    - If [b1] and [b2] are different, we can [substitute b2],
      continuing with [src] and [tgt].

    - We can delete [b1], continuing with [src] and [b2 :: tgt].

    - We can add [b2], continuing with [b1 :: src] and [tgt].

    You'll want to use [argmin3] to select the best possible
    choice. You'll also need to use the [let fix] trick we used to
    define [merge] (and you used to define [subset]).  *)
Fixpoint levenshtein (src tgt : strand) : list edit :=
  let fix inner tgt :=
      match src, tgt with
      | src, [] => delete_edit src
      | [], tgt  => add_edit tgt
      | b1 :: src, b2 :: tgt =>
        let copy_sub_edit :=
            (if eq_base b1 b2 then copy else substitute b2) :: levenshtein src tgt in
        let add_edit := (add b2) :: inner tgt in
        let delete_edit := delete :: levenshtein src (b2 :: tgt) in
        argmin3 total_cost copy_sub_edit add_edit delete_edit
      end
  in
  inner tgt.

(** [] *)

(** If you're stuck, here's a concrete example:

    levenshtein [C; A; T] [C; G; T]

    should generate [ [copy; substitute G; copy] ].

    How will it do that? Well, looking at the bullet points in the
    comments, it'll start by comparing [C] and [C], with [ [A; T] ]
    remaining as [src'] and [ [G;T] ] remaining as [tgt'].

    Since they're the same, a copy edit is possible and it's senseless
    to use a substitute. But you could still end up with add or delete
    edits being better (well, delete, at least). So consider each of
    those.

    So you have three possiblities:

    - [ copy   :: levenshtein   [A;T]   [G;T] ]
    - [ delete :: levenshtein   [A;T] [C;G;T] ]
    - [ add C  :: levenshtein [C;A;T]   [G;T] ]

    The Levenshtein algorithm looks at all three of these and picks
    the best (this is where we use [argmin3]).
*)
Compute(apply_edits dna_src (levenshtein dna_src dna_tgt3)).
(** **** Exercise: 1 star, standard (levenshtein__sub_edit)

    Later on we'll prove that [levenshtein] produces _optimal_ edits,
    i.e., you can't do better. That might not be obvious, though!

    Give an example of a pair of DNA strands where [levenshtein] does
    _much_ better than [sub_edit]. Our testing script asks for twice
    as good. *)
Definition levenshtein__sub_edit_src : strand := [A; T].
Definition levenshtein__sub_edit_tgt : strand := [C; G; A; T].

(** You've got it right when the first is less than or equal to the second. *)
Compute (2 * (total_cost (levenshtein levenshtein__sub_edit_src levenshtein__sub_edit_tgt))).
Compute      (total_cost (sub_edit    levenshtein__sub_edit_src levenshtein__sub_edit_tgt)).

(** Why is [levenshtein] better than [sub_edit]? Try to make your
    answer general. What can [levenshtein] do that [sub_edit] can't?
    The best answer characterizes the difference, giving a _recipe_
    for writing pairs of strands that will do better under
    [levenshtein] than [sub_edit]. *)

(* Levenshtein can utilize add and delete if and when they are needed at the beginning of editing src into tgt. However, sub_edit cannot use add and delete at the beginning of editing an src. Instead, sub_edit must use substitute first untill either src or tgt ends. Then it uses add and delete, even if some of the bases in tgt are in the same order  as those in src.That is why the cost of sub_edit is higher than the cost of levenshtein.    *)
(* Do not modify the following line: *)
Definition manual_grade_for_levenshtein__sub_edit_tgt : option (nat*string) := None.
(** [] *)

(* 2021-09-13 09:44 *)


(** * Properties of Binary Positive Numbers *)

From Coq Require Import
  Classes.DecidableClass Classes.Morphisms Lia PArith.PArith.
From DEZ.Has Require Export
  ArithmeticOperations.
From DEZ.Is Require Export
  Commutative Group Semigroup Monoid.

#[export] Instance positive_has_one : HasOne positive := xH.

Module Pos.

(** We extend the [Pos] module here. *)

Export BinPos.Pos.

Local Open Scope N_scope.
Local Open Scope positive_scope.

(** This incomplete set of corollaries
    would be generated by the equations plugin. *)

Corollary pred_N_equation_1 (p : positive) : pred_N (xI p) = Npos (xO p).
Proof. reflexivity. Qed.

Corollary pred_N_equation_2 (p : positive) :
  pred_N (xO p) = Npos (pred_double p).
Proof. reflexivity. Qed.

Corollary pred_N_equation_3 : pred_N xH = N0.
Proof. reflexivity. Qed.

#[export] Hint Rewrite @pred_N_equation_1 @pred_N_equation_2 @pred_N_equation_3 : pred_N.

Corollary pos_shiftl_equation_1 (p : positive) : shiftl p N0 = p.
Proof. reflexivity. Qed.

Corollary pos_shiftl_equation_2 (p n0 : positive) :
  shiftl p (Npos n0) = iter xO p n0.
Proof. reflexivity. Qed.

#[export] Hint Rewrite @pos_shiftl_equation_1 @pos_shiftl_equation_2 : shiftl.

Corollary iter_equation_1 (A : Type) (f : A -> A) (x : A) (n' : positive) :
  iter f x (xI n') = f (iter f (iter f x n') n').
Proof. reflexivity. Qed.

Corollary iter_equation_2 (A : Type) (f : A -> A) (x : A) (n' : positive) :
  iter f x (xO n') = iter f (iter f x n') n'.
Proof. reflexivity. Qed.

Corollary iter_equation_3 (A : Type) (f : A -> A) (x : A) :
  iter f x xH = f x.
Proof. reflexivity. Qed.

#[export] Hint Rewrite @iter_equation_1 @iter_equation_2 @iter_equation_3 : iter.

(** Whether the given number is a power of two or not. *)

Equations bin (n : positive) : bool :=
  bin (xO p) := bin p;
  bin (xI p) := false;
  bin xH := true.

(** These lemmas are missing from the standard library. *)

Lemma shiftl_0_r (a : positive) : shiftl a N0 = a.
Proof. reflexivity. Qed.

(** These instances are missing from the standard library. *)

Global Program Instance Decidable_equiv_positive (x y : positive) :
  Decidable (x = y) := {
  Decidable_witness := eqb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply eqb_eq. Qed.

Global Program Instance Decidable_le_positive (x y : positive) :
  Decidable (x <= y) := {
  Decidable_witness := leb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply leb_le. Qed.

Global Program Instance Decidable_lt_positive (x y : positive) : Decidable (x < y) := {
  Decidable_witness := ltb x y;
  Decidable_spec := _;
}.
Next Obligation. intros x y. apply ltb_lt. Qed.

Global Instance le_add_wd : Proper (le ==> le ==> le) add.
Proof. intros n p l n' p' l'. apply add_le_mono; [lia |]. lia. Qed.

Global Instance le_mul_wd : Proper (le ==> le ==> le) mul.
Proof. intros n p l n' p' l'. apply mul_le_mono; [lia |]. lia. Qed.

Global Instance le_div2_wd : Proper (le ==> le) div2.
Proof. intros n p l. destruct n, p; unfold div2; lia. Qed.

Global Instance le_sqrt_wd : Proper (le ==> le) sqrt.
Proof.
  intros n p l. unfold sqrt. destruct
  (sqrtrem_spec n) as [s x | s x r],
  (sqrtrem_spec p) as [s' x' | s' x' r']; cbn; nia.
Qed.

(** Whether the given number is even or not. *)

Equations even (n : positive) : bool :=
  even (xI p) := false;
  even (xO p) := true;
  even xH := false.

(** Whether the given number is odd or not. *)

Equations odd (n : positive) : bool :=
  odd n := negb (even n).

End Pos.

Module Additive.

Global Instance positive_has_bin_op : HasBinOp positive := Pos.add.

Global Instance positive_bin_op_is_assoc : IsAssoc _=_ Pos.add.
Proof. intros x y z. apply Pos.add_assoc. Defined.

Global Instance positive_bin_op_is_semigrp : IsSemigrp _=_ Pos.add.
Proof. esplit; typeclasses eauto. Defined.

Global Instance positive_bin_op_is_comm_bin_op : IsCommBinOp _=_ Pos.add.
Proof. intros x y. apply Pos.add_comm. Defined.

End Additive.

Module Multiplicative.

Global Instance positive_bin_op_has_bin_op : HasBinOp positive := Pos.mul.
Global Instance positive_has_null_op : HasNullOp positive := xH.

Global Instance positive_bin_op_is_assoc : IsAssoc _=_ Pos.mul.
Proof. intros x y z. apply Pos.mul_assoc. Defined.

Global Instance positive_bin_op_is_semigrp : IsSemigrp _=_ Pos.mul.
Proof. esplit; typeclasses eauto. Defined.

Global Instance positive_bin_op_is_bin_op : IsCommBinOp _=_ Pos.mul.
Proof. intros x y. apply Pos.mul_comm. Defined.

Global Instance positive_bin_op_null_op_is_unl_l : IsUnlElemL _=_ xH Pos.mul.
Proof. intros x. apply Pos.mul_1_l. Defined.

Global Instance positive_bin_op_null_op_is_unl_r : IsUnlElemR _=_ xH Pos.mul.
Proof. intros x. apply Pos.mul_1_r. Defined.

Global Instance positive_bin_op_null_op_is_unl : IsUnlElem _=_ xH Pos.mul.
Proof. esplit; typeclasses eauto. Defined.

Global Instance positive_bin_op_null_op_is_mon : IsMon _=_ xH Pos.mul.
Proof. esplit; typeclasses eauto. Defined.

End Multiplicative.


(************************************************************************)
(* Copyright 2022 Frédéric Dabrowski                                    *)
(*
    This program is free software:: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

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

    You should have received a copy of the GNU General Public License
    along with Foobar.  If not, see <https://www.gnu.org/licenses/>.    *)
(************************************************************************)

(** * Lattices *)

Require Import Coq.Relations.Relation_Definitions.
Require Import Coq.Classes.RelationClasses.

Class JoinLattice {A : Type} (eqA : relation A) `{equ : Equivalence A eqA}
(R : relation A) `{partialOrder : PartialOrder A eqA R} (join : A -> A -> A)  :=
{
    join_bound1 (x y : A) : R x (join x y);
    join_bound2 (x y : A) : R y (join x y);
    join_least_upper_bound (x y z : A) : R x z -> R y z -> R (join x y) z
}.

Class MeetLattice {A : Type} (eqA : relation A) `{equ : Equivalence A eqA}
(R : relation A) `{partialOrder : PartialOrder A eqA R} (meet : A -> A -> A)  :=
{
    meet_bound1 (x y : A) : R (meet x y) x;
    meet_bound2 (x y : A) : R (meet x y) y;
    meet_greatest_lower_bound (x y z : A) : R z x -> R z y -> R z (meet x y)
}.

Class Lattice {A : Type} (eqA : relation A) `{equ : Equivalence A eqA}
(R : relation A) `{partialOrder : PartialOrder A eqA R}
(join : A -> A -> A) (meet : A -> A -> A): Type :=
{
    Lattice_JoinLattice :> JoinLattice eqA R join;
    Lattice_MeetLattice :> MeetLattice  eqA R meet
}.


(**
スタックコンパイラの証明
========
@suharahiromichi

2014_04_30
 *)
Require Import ssreflect ssrbool ssrnat seq eqtype ssrfun.
(**
算術式をスタック指向のプログラミング言語にコンパイルするコンパイラ
（スタックコンパイラ）が正しく動作することの証明をする。
証明は SSReflect を使っておこなう。

ソースコードは以下にあります。

https://github.com/suharahiromichi/coq/blob/master/ssr/ssr_stack_compiler.v
*)
(**
# ソース言語（算術式）の定義
 *)
(**
状態`state`はプログラムの実行のある時点のすべての変数の現在値を表す。
 *)
Inductive id : Type :=
  Id of nat.

Definition state := id -> nat.

(**
ソース言語である算術式 `aexp` を定義する。
 *)
Inductive aexp : Type :=
| ANum of nat
| AId of id
| APlus of aexp & aexp
| AMinus of aexp & aexp
| AMult of aexp & aexp.

(**
変数の略記法を以下に定義する。
 *)
Definition X : id := Id 0.
Definition Y : id := Id 1.
Definition Z : id := Id 2.

(**
`aexp` を評価する関数を定義する。
 *)
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.

(**
# スタック指向のプログラミング言語（スタック言語）
 *)
(**
スタック言語の命令セット`sinstr`は、以下の命令から構成される:

- `SPush n`: 数 `n` をスタックにプッシュする。
- `SLoad X`: ストアから識別子 `X` に対応する値を読み込み、スタックにプッシュする。
- `SPlus`:   スタックの先頭の 2 つの数をポップし、それらを足して、結果をスタックにプッシュする。
- `SMinus`:  上と同様。ただし引く。
- `SMult`:   上と同様。ただし掛ける。
*)

Inductive sinstr : Type :=
| SPush of nat
| SLoad of id
| SPlus
| SMinus
| SMult.

(**
スタック言語のプログラムを評価するための関数を書く。
 *)
Fixpoint s_exec (st : state) (ins : sinstr) (stack : seq nat) : seq nat :=
  match ins with
    | SPush n =>  n :: stack
    | SLoad idx => (st idx) :: stack
    | SPlus => match stack with
                 | b :: a :: stack' => (a + b) :: stack'
                 | _ => stack
               end
    | SMinus => match stack with
                 | b :: a :: stack' => (a - b) :: stack'
                 | _ => stack
               end
    | SMult => match stack with
                 | b :: a :: stack' => (a * b) :: stack'
                 | _ => stack
               end
  end.
(**
補足：stack underflow の判定をまとめて前に出すと、証明がたいへんになるだろう。
また、そのときの例外処理を行わないが、それによって、s_compile_correct_app
の証明が簡単になっていると思う。
 *)

Fixpoint s_execute (st : state) (stack : seq nat) (prog : seq sinstr) : seq nat :=
  match prog with
    | [::] =>
      stack
    | ins :: prog' =>
      s_execute st (s_exec st ins stack) prog'
  end.

(**
`aexp` をスタック言語の命令列にコンパイルする関数 `s_compile` を書く。
 *)
Fixpoint s_compile (e : aexp) : seq sinstr :=
  match e with
    | ANum n => [:: SPush n]
    | AId id => [:: SLoad id]
    | APlus a b =>  (s_compile a) ++ (s_compile b) ++ [:: SPlus]
    | AMinus a b => (s_compile a) ++ (s_compile b) ++ [:: SMinus]
    | AMult a b =>  (s_compile a) ++ (s_compile b) ++ [:: SMult]
  end.

(**
# コンパイルが正しいことの証明
 *)
(**
以下で、`s_compile` 関数が正しく振る舞うことを述べる定理を証明する。
 *)
(**
最初に補題として、スタック言語の命令列が append できることを証明する。
 *)
Lemma s_compile_correct_app : forall (st : state)
  (stack1 stack2 stack3: seq nat)
  (prog1 prog2 : seq sinstr),
  s_execute st stack1 prog1 = stack2 ->
  s_execute st stack2 prog2 = stack3 ->
  s_execute st stack1 (prog1 ++ prog2) = stack3.
Proof.
  move=> st stack1 stack2 stack3 prog1.
  elim: prog1 stack1 stack2 stack3.
    by move=> stack1 stack2 stack3 prog2; rewrite cat0s; move=> <- <-.
  move=> a prog1' IHprog1' stack1 stack2 stack3.
  elim: a;
    by move=> ?; apply IHprog1' with (stack2 := stack2).
Qed.

(**
より一般的な、stackが任意の状態の場合について、
`aexp`をコンパイルしたスタック言語の命令列を実行した結果（左辺）と、
`aexp`を直接実行した結果（右辺）が一致することを証明する。
 *)
Lemma s_compile_correct_stack : forall (st : state) (stack : seq nat) (e : aexp),
  s_execute st stack (s_compile e) = [:: aeval st e] ++ stack.
Proof.
  move=> st stack e.
  elim: e stack;                            (* 「stack」をpushするのが肝。 *)
    (* ANum, AId の場合 *)
    try by [];
  (* APlus, AMinus, AMult の場合 *)
  try move=> e1 IHe1 e2 IHe2 st0;
    apply s_compile_correct_app with (stack2 := aeval st e1 :: st0);
    by [rewrite IHe1 |
       apply s_compile_correct_app with (stack2 := aeval st e2 :: aeval st e1 :: st0);
            [rewrite (IHe2 (aeval st e1 :: st0)) |]].
Qed.

(**
最後に、stackが初期状態（空[]）の場合について、
`aexp`をコンパイルしたスタック言語の命令列を実行した結果（左辺）と、
`aexp`を直接実行した結果（右辺）が一致することを証明する。
 *)
Theorem s_compile_correct : forall (st : state) (e : aexp),
  s_execute st [::] (s_compile e) = [:: aeval st e].
Proof.
  move=> st e.
  apply s_compile_correct_stack.
Qed.

(* END *)


Require Export Order.

Theorem wellorder_subst {R A X} :
  well_order R A -> X ⊂ A -> well_order R X.
Proof.
  intros H XA.
  induction H as [W T].
  unfold well_found in W.
  induction T as [trans_ T].
  induction T as [notrefl tri].
  split.
  + intros Y YX notY.
    apply W.
    - intros y yY.
      apply (XA y (YX y yY)).
    - done.
  + split.
    intros x y z xX yX zX xyR yzR.
    apply (trans_ x y z (XA x xX) (XA y yX) (XA z zX) xyR yzR).
    split.
    * intros x xX H.
      apply ((notrefl x (XA x xX)) H) .
    * intros x y xX yX.
      induction (tri x y (XA x xX) (XA y yX)).
      apply (or_introl H).
      induction H.
      apply (or_intror (or_introl H)).
      apply (or_intror (or_intror H)).
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) (x : natural) : natural := mult x y.


Require Export Arith.
Require Export ArithRing.
Require Export Lia.
Require Export Wf_nat.

Fixpoint div2 (n : nat) : nat :=
 match n with S (S p) => S (div2 p) | _ => 0 end.

Theorem div2_ind:
 forall (P : nat ->  Prop),
 P 0 -> P 1 -> (forall n, P n ->  P (S (S n))) -> forall n,  P n.
Proof.
intros P H0 H1 Hstep n.
assert (H : P n /\ P (S n)) by (elim n; intuition).
 now destruct H.
Qed.

Theorem div2_lt: forall n,  (div2 (S n) < S n).
Proof.
intros; elim n  using div2_ind; simpl; intros; lia.
Qed.

Definition log2_it_F (log2 : nat ->  nat) (n : nat) : nat :=
   match n with
     0 => 0
    | 1 => 0
    | S (S p) => S (log2 (div2 (S (S p))))
   end.

Fixpoint iter {A : Type} (f : A ->  A) (k : nat) (a : A) {struct k} : A :=
 match k with   0%nat => a
               | S p => f (iter  f p a) end.

Definition log2_terminates:
 forall (n : nat),
  ({v : nat | exists p : nat , forall k g, p < k ->  iter log2_it_F k g n = v }).
Proof.
 intros n; elim n  using (well_founded_induction lt_wf); clear n.
 intros n; case n.
 - intros; exists 0, 0;  intros k; case k.
   + intros; lia.
   + intros k' g _; simpl; auto.
 - intros n'; case n'.
   + intros; exists 0; exists 0; intros k; case k.
     * intros; lia.
     * intros k' g_; simpl; auto.
   + intros p f; assert (Hlt: div2 (S (S p)) < S (S p))
                 by apply div2_lt.
     destruct (f (div2 (S (S p))) Hlt) as [v Hex];exists (S v).
     destruct Hex as [p' Heq];exists (S p').
     intros k g; case k.
     * intros; lia.
     * intros k' Hltk;rewrite <- (Heq k' g); auto.
       lia.
Qed.

Definition log2 (n : nat) : nat :=
   match log2_terminates n with exist _ v _ => v end.

Theorem log2_fix_eqn:
 forall n,  log2 n = match n with
                       0 => 0
                      | 1 => 0
                      | S (S p) => S (log2 (div2 (S (S p))))
                     end.
Proof.
 intros n; unfold log2; case (log2_terminates n); case n.
 - intros v [p Heq]; rewrite <- (Heq (S p) log2); auto.
 - intros n'; case n'.
   + intros v [p Heq];rewrite <- (Heq (S p) log2); auto.
   + intros n'' v [p Heq];case (log2_terminates (div2 (S (S n'')))).
     intros v' [p' Heq'];
     rewrite <- (Heq (S (S (p + p'))) log2),
             <- (Heq' (S (p + p')) log2); auto.
     lia.
     lia.
Qed.

Theorem div2_eq: forall n,  2 * div2 n = n \/ 2 * div2 n + 1 = n.
Proof.
intros n; elim n  using div2_ind; simpl; lia.
Qed.

Fixpoint exp2 (n : nat) : nat :=
 match n with 0 => 1 | S p => 2 * exp2 p end.

Theorem log2_power:
 forall n, 0 < n ->  ( exp2 (log2 n) <= n < 2 * exp2 (log2 n) ).
Proof.
intros n; elim n  using (well_founded_ind lt_wf).
intros x; case x.
- simpl; intros; lia.
- intros x'; case x'.
  + rewrite (log2_fix_eqn 1); simpl; auto with arith.
  + intros p Hrec; elim (Hrec (div2 (S (S p)))).
    * intros Hle Hlt _; rewrite (log2_fix_eqn (S (S p))).
      cbv zeta iota beta delta [exp2]; fold exp2.
      split.
      apply le_trans with (2 * div2 (S (S p))).
      auto with arith.
      elim (div2_eq (S (S p))).
      lia.
      lia.
      apply le_lt_trans with (2 * div2 (S (S p)) + 1).
      elim (div2_eq (S (S p))).
      lia.
      lia.
      lia.
    * apply div2_lt; simpl; auto with arith.
    *  simpl; auto with arith.
Qed.